From a9d5b2efbe799bdd80d74e0906ab5c0c870c160f Mon Sep 17 00:00:00 2001 From: Brandon Reichl Date: Tue, 14 Apr 2020 07:41:01 -0400 Subject: [PATCH 001/336] Adding new MLD diagnostic - New MLD is computed as the depth a given energy would homogenize the water column - Three values are coded for output, 25 J/m2, 2500 J/m2, and 250000 J/m2. --- .../vertical/MOM_diabatic_aux.F90 | 191 +++++++++++++++++- .../vertical/MOM_diabatic_driver.F90 | 12 ++ 2 files changed, 201 insertions(+), 2 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index b17f6e4323..a7dbe6298e 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -1,4 +1,3 @@ - !> Provides functions for some diabatic processes such as fraxil, brine rejection, !! tendency due to surface flux divergence. module MOM_diabatic_aux @@ -32,7 +31,7 @@ module MOM_diabatic_aux public diabatic_aux_init, diabatic_aux_end public make_frazil, adjust_salt, insert_brine, differential_diffuse_T_S, triDiagTS -public find_uv_at_h, diagnoseMLDbyDensityDifference, applyBoundaryFluxesInOut, set_pen_shortwave +public find_uv_at_h, diagnoseMLDbyDensityDifference, diagnoseMLDbyEnergy, applyBoundaryFluxesInOut, set_pen_shortwave ! 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 @@ -847,6 +846,194 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, 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_driver due to its position within the time stepping. +subroutine diagnoseMLDbyEnergy(id_MLD, h, tv, G, GV, US, diagPtr) + 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, dimension(3), intent(in) :: id_MLD !< Handle (ID) of MLD diagnostics + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< 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_(G)) :: Z_L, Z_C, Z_U, dZ, Rho_c, pRef_MLD + + real :: PE_Before + real :: Rho_MixedLayer, H_MixedLayer + + real, parameter :: Surface = 0.0 + real, parameter, dimension(3) :: Mixing_Energy = (/25.,2500.,250000./) + + real :: PE_Column_before, PE_Column_Target, PE_column_0, PE_column_N + real :: Rho_MixedLayer_0, H_MixedLayer_0, Zc_MixedLayer_0, PE_MixedLayer_0 + real :: Rho_MixedLayer_N, H_MixedLayer_N, Zc_MixedLayer_N, PE_MixedLayer_N + real :: dz_mixed_0, dz_mixed_N + real :: PE_interior + real :: dz_below, zc_below, zl_below, zu_below, rho_c_below, PE_below + + real :: rho_c_mixed_n, zc_mixed_n + + real :: Guess_Fraction, PE_Threshold + real :: A, B, C, dz_increment + logical :: Not_Converged + integer :: IT, ITT + real :: dz_max_incr + + integer :: i, j, is, ie, js, je, k, nz, id_N2, id_SQ, iM + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + + pRef_MLD(:) = 0.0 + mld(:,:,:) = 0.0 + do j=js,je + do i=is,ie + call calculate_density(tv%T(i,j,:), tv%S(i,j,:), pRef_MLD, rho_c, 1, nz, & + tv%eqn_of_state, scale=US%kg_m3_to_R) + Z_U(1) = 0.0 + do k=2,nz ; Z_U(k) = Z_U(k-1) - h(i,j,k-1)*GV%H_to_z ; enddo + do k=1,nz + Z_C(k) = Z_U(k) - 0.5 * h(i,j,k) * GV%H_to_Z + Z_L(k) = Z_U(k) - h(i,j,k) * GV%H_to_Z + dZ(k) = h(i,j,k) * GV%H_to_Z + enddo + + do iM=1,3 + if (id_MLD(iM)>0) then + ! Compute PE of column + call PE_Kernel(PE_Column_before,NZ,Z_L,Z_U,Rho_c) + PE_Column_Target = PE_Column_before + Mixing_Energy(iM)/GV%g_earth + + rho_mixedlayer = 0. + h_mixedlayer = 0. + PE_threshold = Mixing_Energy(iM)/GV%g_earth*1.e-4 + + do k=1,NZ + + !Compute the PE if the whole layer is mixed + Rho_MixedLayer_0 = Rho_MixedLayer + Rho_c(k)*dZ(k) + H_MixedLayer_0 = H_MixedLayer + dZ(k) + Zc_MixedLayer_0 = 0.5 * (Surface - H_MixedLayer_0) + PE_MixedLayer_0 = Rho_MixedLayer_0 * Zc_MixedLayer_0 + + !Compute the PE of the interior layers + call PE_Kernel(PE_Interior,NZ-(K),Z_L(K+1:NZ),Z_U(K+1:NZ),Rho_c(K+1:NZ)) + + PE_Column_0 = PE_MixedLayer_0+PE_Interior + + !Check if we did not have enough energy to mix the whole layer + if (PE_Column_0>PE_Column_Target) then + + ! + dz_mixed_0 = dz(k) + dz_max_incr = dz(k)*0.1 + + ! Guess the thickness of the amount that can be mixed: + Guess_fraction = 0.5 + dz_mixed_N = dZ(k)*Guess_fraction + + !Compute the PE if we mixed to the guessed thickness + Rho_MixedLayer_N = Rho_MixedLayer + Rho_c(k)*dz_mixed_N + H_MixedLayer_N = H_MixedLayer + dz_mixed_N + Zc_MixedLayer_N = 0.5 * (Surface - H_MixedLayer_N) + PE_MixedLayer_N = Rho_MixedLayer_N * Zc_MixedLayer_N + + ! The remaining thickness is not mixed + dz_below = dz(k)*(1.-Guess_fraction) + Zl_below = Z_L(k) + Zu_below = Z_L(k) + dz_below + + !Compute the PE of the fraction of the layer that wasn't mixed + call PE_Kernel(PE_below, 1, (/Zl_below/),(/zu_below/), & + (/Rho_c(k)/) ) + + PE_column_N = PE_MixedLayer_N + PE_below + PE_interior + ITT = 0 + do IT = 1,20 !Do the iteration up to 20 times + Not_Converged = (abs(PE_column_N-PE_column_target)>PE_Threshold) + if (Not_Converged) then + + ITT = ITT+1 + + A = PE_column_target - PE_column_N + B = PE_column_N - PE_column_0 + C = dz_mixed_N - dz_mixed_0 + + if (abs(b)>PE_threshold) then + dz_increment = A*C/B + else + dz_increment = sign(dz(k)*1.e-4,A) + endif + + if ( (dz_mixed_N+dz_increment > dz(k)) .or. & + (dz_mixed_N+dz_increment < 0.0) ) then + dz_increment = min(dz_max_incr,min(dz(k)-dz_mixed_n,dz_increment)) + dz_increment = max(-dz_max_incr,max(0.-dz_mixed_n,dz_increment)) + endif + + !Reset the _0's: + PE_column_0 = PE_column_N + dz_mixed_0 = dz_mixed_N + + !Compute the _N's: + ! Guess the thickness of the amount that can be mixed: + dz_mixed_N = dz_mixed_N + dz_increment + + !Compute the PE if we mixed to the guessed thickness + Rho_MixedLayer_N = Rho_MixedLayer + Rho_c(k)*dz_mixed_N + H_MixedLayer_N = H_MixedLayer + dz_mixed_N + Zc_MixedLayer_N = 0.5 * (Surface - H_MixedLayer_N) + PE_MixedLayer_N = Rho_MixedLayer_N * Zc_MixedLayer_N + + ! The remaining thickness is not mixed + dz_below = dz(k) - dz_mixed_N + Zl_below = Z_L(k) + Zu_below = Z_L(k) + dz_below + !Compute the PE of the fraction of the layer that wasn't mixed + call PE_Kernel(PE_below, 1, (/Zl_below/), (/zu_below/), & + (/Rho_c(k)/)) + + PE_column_N = PE_MixedLayer_N + PE_below + PE_interior + endif + enddo + + H_MixedLayer = H_MixedLayer + dz_mixed_N + else + Rho_MixedLayer = Rho_MixedLayer_0 + H_MixedLayer = H_MixedLayer_0 + endif + mld(i,j,iM) = H_MixedLayer + enddo + endif + enddo + 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) + + return +end subroutine diagnoseMLDbyEnergy + +subroutine PE_Kernel(PE, NK, Z_L, Z_U, Rho_c ) + integer :: NK + real, intent(in), dimension(NK) :: Z_L, Z_U, Rho_c + real, intent(out) :: PE + integer :: k + + PE = 0.0 + do k=1,NK + PE = PE + (Rho_c(k))*0.5*(Z_U(k)**2-Z_L(k)**2) + enddo + + return +end subroutine PE_Kernel + !> 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. diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 256ec63ffd..9d37e9874c 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -14,6 +14,7 @@ module MOM_diabatic_driver use MOM_diabatic_aux, only : diabatic_aux_init, diabatic_aux_end, diabatic_aux_CS use MOM_diabatic_aux, only : make_frazil, adjust_salt, insert_brine, differential_diffuse_T_S, triDiagTS use MOM_diabatic_aux, only : find_uv_at_h, diagnoseMLDbyDensityDifference, applyBoundaryFluxesInOut +use MOM_diabatic_aux, only : diagnoseMLDbyEnergy use MOM_diabatic_aux, only : set_pen_shortwave use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr use MOM_diag_mediator, only : diag_ctrl, time_type, diag_update_remap_grids @@ -176,6 +177,7 @@ module MOM_diabatic_driver integer :: id_Kd_heat = -1, id_Kd_salt = -1, id_Kd_interface = -1, id_Kd_ePBL = -1 integer :: id_Tdif = -1, id_Tadv = -1, id_Sdif = -1, id_Sadv = -1 integer :: id_MLD_003 = -1, id_MLD_0125 = -1, id_MLD_user = -1, id_mlotstsq = -1 + integer :: id_MLD_EN25 = -1, id_MLD_EN2500 = -1, id_MLD_EN250000 = -1 integer :: id_subMLN2 = -1, id_brine_lay = -1 ! diagnostic for fields prior to applying diapycnal physics @@ -428,6 +430,10 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & 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_EN25 > 0) .or. (CS%id_MLD_EN2500 > 0) .or. (CS%id_MLD_EN250000 > 0)) then + call diagnoseMLDbyEnergy((/CS%id_MLD_EN25, CS%id_MLD_EN2500, CS%id_MLD_EN250000/),& + h, tv, G, GV, US, CS%diag) + endif if (CS%use_int_tides) then if (CS%id_cg1 > 0) call post_data(CS%id_cg1, cn_IGW(:,:,1),CS%diag) do m=1,CS%nMode ; if (CS%id_cn(m) > 0) call post_data(CS%id_cn(m), cn_IGW(:,:,m), CS%diag) ; enddo @@ -3426,6 +3432,12 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di 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) + CS%id_MLD_EN25 = register_diag_field('ocean_model', 'MLD_EN_25', diag%axesT1, Time, & + 'Mixed layer depth (Energy = 25 J/m2)', 'm', conversion=US%Z_to_m) + CS%id_MLD_EN2500 = register_diag_field('ocean_model', 'MLD_EN_2500', diag%axesT1, Time, & + 'Mixed layer depth (Energy = 2500 J/m2)', 'm', conversion=US%Z_to_m) + CS%id_MLD_EN250000 = register_diag_field('ocean_model', 'MLD_EN_250000', diag%axesT1, Time, & + 'Mixed layer depth (Energy = 250000 J/m2)', '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', 's-2', conversion=US%s_to_T**2) CS%id_MLD_user = register_diag_field('ocean_model', 'MLD_user', diag%axesT1, Time, & From 34d221cf303bf740b74f3a9fca321da1ff37a7cd Mon Sep 17 00:00:00 2001 From: Andrew Ross Date: Wed, 29 Jul 2020 13:57:05 -0400 Subject: [PATCH 002/336] Merge working tides version with latest dev/gfdl --- src/core/MOM_open_boundary.F90 | 393 +++++++++++++++--- src/framework/MOM_file_parser.F90 | 6 +- .../lateral/MOM_tidal_forcing.F90 | 270 ++++++++++-- 3 files changed, 559 insertions(+), 110 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 31f037c66e..fd5dd99f09 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -22,7 +22,8 @@ module MOM_open_boundary use MOM_restart, only : query_initialized, MOM_restart_CS use MOM_obsolete_params, only : obsolete_logical, obsolete_int, obsolete_real, obsolete_char use MOM_string_functions, only : extract_word, remove_spaces -use MOM_time_manager, only : time_type, time_type_to_real, operator(-) +use MOM_tidal_forcing, only : 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 time_interp_external_mod, only : init_external_field, time_interp_external use time_interp_external_mod, only : time_interp_external_init @@ -131,11 +132,17 @@ module MOM_open_boundary logical :: open !< Boundary is open for continuity solver. 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 :: v_values_needed!< Whether or not external v 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. @@ -148,6 +155,12 @@ module MOM_open_boundary 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 segment is located in the computational domain @@ -252,6 +265,16 @@ module MOM_open_boundary tracer_y_reservoirs_used => NULL() !< 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. + real, allocatable, dimension(:) :: tide_frequencies !< Angular frequencies of tidal constituents. + real, allocatable, dimension(:) :: tide_eq_phases, tide_fn, tide_un !< Equilibrium phases and nodal modulation for tidal constituents. + 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. + real :: time_ref !< Reference date (t = 0) for tidal forcing. + real, dimension(4) :: astro_shpn ! Lunar and solar longitudes used to calculate tidal forcing. ! Properties of the segments used. type(OBC_segment_type), pointer, dimension(:) :: & segment => NULL() !< List of segment objects. @@ -338,9 +361,11 @@ subroutine open_boundary_config(G, US, param_file, OBC) integer :: l ! For looping over segments logical :: debug_OBC, debug, mask_outside, reentrant_x, reentrant_y character(len=15) :: segment_param_str ! The run-time parameter name for each segment - character(len=100) :: segment_str ! The contents (rhs) for parameter "segment_param_str" + 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, dimension(3) :: tide_ref_date, nodal_ref_date !< Reference date (t = 0) for tidal forcing and fixed date for nodal modulation. + character(len=50) :: tide_constituent_str !< List of tidal constituents to add to boundary. allocate(OBC) call get_param(param_file, mdl, "OBC_NUMBER_OF_SEGMENTS", OBC%number_of_segments, & @@ -422,6 +447,41 @@ subroutine open_boundary_config(G, US, param_file, OBC) 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_n_tide_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. + 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_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 + + else + OBC%add_tide_constituents = .false. + endif call get_param(param_file, mdl, "DEBUG", debug, default=.false.) call get_param(param_file, mdl, "DEBUG_OBC", debug_OBC, default=.false.) @@ -465,10 +525,16 @@ subroutine open_boundary_config(G, US, param_file, OBC) 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. @@ -497,6 +563,13 @@ subroutine open_boundary_config(G, US, param_file, OBC) 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) @@ -548,14 +621,15 @@ subroutine open_boundary_config(G, US, param_file, OBC) .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, tide_ref_date, nodal_ref_date, tide_constituent_str) + 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) - else - ! Need this for ocean_only mode boundary interpolation. - call time_interp_external_init() endif end subroutine open_boundary_config @@ -570,7 +644,8 @@ subroutine initialize_segment_data(G, OBC, PF) type(param_file_type), intent(in) :: PF !< Parameter file handle integer :: n,m,num_fields - character(len=256) :: segstr, filename + character(len=1024) :: segstr + character(len=256) :: filename character(len=20) :: segnam, suffix character(len=32) :: varnam, fieldname real :: value @@ -733,18 +808,38 @@ subroutine initialize_segment_data(G, OBC, PF) if (segment%field(m)%name == 'V') then allocate(segment%field(m)%buffer_src(IsdB:IedB,JsdB:JedB,siz2(3))) segment%v_values_needed = .false. - else if (segment%field(m)%name == 'DVDX') then + 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. - else if (segment%field(m)%name == 'SSH') then + 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. - else if (segment%field(m)%name == 'TEMP') then + 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. - else if (segment%field(m)%name == 'SALT') then + elseif (segment%field(m)%name == 'SALT') then segment%s_values_needed = .false. endif endif @@ -752,18 +847,38 @@ subroutine initialize_segment_data(G, OBC, PF) if (segment%field(m)%name == 'U') then allocate(segment%field(m)%buffer_src(IsdB:IedB,JsdB:JedB,siz2(3))) segment%u_values_needed = .false. - else if (segment%field(m)%name == 'DUDY') then + 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. - else if (segment%field(m)%name == 'SSH') then + 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. - else if (segment%field(m)%name == 'TEMP') then + 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. - else if (segment%field(m)%name == 'SALT') then + elseif (segment%field(m)%name == 'SALT') then segment%s_values_needed = .false. endif endif @@ -772,25 +887,37 @@ subroutine initialize_segment_data(G, OBC, PF) segment%field(m)%fid = init_external_field(trim(filename),& trim(fieldname),ignore_axis_atts=.true.,threading=SINGLE_FILE) if (siz(3) > 1) then - 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))) + 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) .ne. 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 - 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))) + ! 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 - allocate(segment%field(m)%dz_src(isd:ied,JsdB:JedB,siz(3))) + 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)%fid_dz = init_external_field(trim(filename),trim(fieldname),& + ignore_axis_atts=.true.,threading=SINGLE_FILE) endif - segment%field(m)%dz_src(:,:,:)=0.0 - segment%field(m)%nk_src=siz(3) - segment%field(m)%fid_dz = init_external_field(trim(filename),trim(fieldname),& - ignore_axis_atts=.true.,threading=SINGLE_FILE) else segment%field(m)%nk_src=1 endif @@ -801,10 +928,22 @@ subroutine initialize_segment_data(G, OBC, PF) segment%field(m)%name = trim(fields(m)) if (segment%field(m)%name == 'U') then segment%u_values_needed = .false. + elseif (segment%field(m)%name == 'Uamp') then + segment%uamp_values_needed = .false. + elseif (segment%field(m)%name == 'Uphase') then + segment%uphase_values_needed = .false. elseif (segment%field(m)%name == 'V') then segment%v_values_needed = .false. + elseif (segment%field(m)%name == 'Vamp') then + segment%vamp_values_needed = .false. + elseif (segment%field(m)%name == 'Vphase') then + segment%vphase_values_needed = .false. elseif (segment%field(m)%name == 'SSH') then segment%z_values_needed = .false. + elseif (segment%field(m)%name == 'SSHamp') then + segment%zamp_values_needed = .false. + elseif (segment%field(m)%name == 'SSHphase') then + segment%zphase_values_needed = .false. elseif (segment%field(m)%name == 'TEMP') then segment%t_values_needed = .false. elseif (segment%field(m)%name == 'SALT') then @@ -814,9 +953,10 @@ subroutine initialize_segment_data(G, OBC, PF) endif endif enddo - if (segment%u_values_needed .or. segment%v_values_needed .or. & - segment%t_values_needed .or. segment%s_values_needed .or. & - segment%z_values_needed .or. segment%g_values_needed) then + 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 @@ -826,6 +966,60 @@ subroutine initialize_segment_data(G, OBC, PF) end subroutine initialize_segment_data +subroutine initialize_obc_tides(OBC, tide_ref_date, nodal_ref_date, tide_constituent_str) + type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure + integer, dimension(3), intent(in) :: tide_ref_date !< Reference date (t = 0) for tidal forcing. + integer, dimension(3), intent(in) :: nodal_ref_date !< Date to calculate nodal modulation for. + character(len=50), intent(in) :: tide_constituent_str !< List of tidal constituents to include on boundary. + real, dimension(4) :: nodal_shpn !< Solar and lunar longitudes for tidal forcing + real :: nodal_time !< Model time to calculate nodal modulation for. + integer :: c !< Index to tidal constituent. + + 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 = time_type_to_real(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%astro_shpn) + + ! 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) .ne. 0) then + nodal_time = time_type_to_real(set_date(nodal_ref_date(1), nodal_ref_date(2), nodal_ref_date(3))) + call astro_longitudes_init(nodal_time, nodal_shpn) + else + nodal_shpn = OBC%astro_shpn + 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 + OBC%tide_frequencies(c) = tidal_frequency(trim(OBC%tide_names(c))) + + ! Find equilibrum phase if needed + if (OBC%add_eq_phase) then + OBC%tide_eq_phases(c) = eq_phase(trim(OBC%tide_names(c)), OBC%astro_shpn) + 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_shpn(4), 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) @@ -1439,7 +1633,8 @@ subroutine parse_for_tracer_reservoirs(OBC, PF, use_temperature) ! Local variables integer :: n,m,num_fields - character(len=256) :: segstr, filename + character(len=1024) :: segstr + character(len=256) :: filename character(len=20) :: segnam, suffix character(len=32) :: varnam, fieldname real :: value @@ -3520,9 +3715,9 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(inout) :: h !< Thickness [H ~> m or kg m-2] type(time_type), intent(in) :: Time !< Model time ! Local variables - integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed + integer :: c, i, j, k, is, ie, js, je, isd, ied, jsd, jed integer :: IsdB, IedB, JsdB, JedB, n, m, nz - character(len=40) :: mdl = "set_OBC_segment_data" ! This subroutine's name. + character(len=40) :: mdl = "update_OBC_segment_data" ! This subroutine's name. character(len=200) :: filename, OBC_file, inputdir ! Strings for file/path type(OBC_segment_type), pointer :: segment => NULL() integer, dimension(4) :: siz @@ -3538,6 +3733,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) real, dimension(:), allocatable :: h_stack integer :: is_obc2, js_obc2 real :: net_H_src, net_H_int, scl_fac + real :: tidal_vel, tidal_elev real, pointer, dimension(:,:) :: normal_trans_bt=>NULL() ! barotropic transport integer :: turns ! Number of index quarter turns @@ -3615,6 +3811,11 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) 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,G%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,G%ke)) endif @@ -3625,6 +3826,11 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) 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,G%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,G%ke)) endif @@ -3635,20 +3841,22 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) endif else 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,1)) + 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,siz(3))) else - allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc+1:je_obc,1)) + allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc+1:je_obc,siz(3))) endif if (segment%field(m)%name == 'U') then allocate(segment%field(m)%bt_vel(is_obc:ie_obc,js_obc+1:je_obc)) segment%field(m)%bt_vel(:,:)=0.0 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,1)) + 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,siz(3))) else - allocate(segment%field(m)%buffer_dst(is_obc+1:ie_obc,js_obc:je_obc,1)) + allocate(segment%field(m)%buffer_dst(is_obc+1:ie_obc,js_obc:je_obc,siz(3))) endif if (segment%field(m)%name == 'V') then allocate(segment%field(m)%bt_vel(is_obc+1:ie_obc,js_obc:je_obc)) @@ -3714,7 +3922,8 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) 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 + 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+G%jdg_offset)+1:2*(je_obc+G%jdg_offset)+1:2,:) else @@ -3722,7 +3931,8 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) tmp_buffer(1,2*(js_obc+G%jdg_offset)+1:2*(je_obc+G%jdg_offset):2,:) endif else - if (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'DUDY') then + 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+G%idg_offset)+1:2*(ie_obc+G%idg_offset)+1:2,1,:) else @@ -3732,20 +3942,24 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) endif else if (segment%is_E_or_W) then - if (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'DVDX') 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+G%jdg_offset+1:je_obc+G%jdg_offset+1,:) else segment%field(m)%buffer_src(is_obc,:,:)=tmp_buffer(1,js_obc+G%jdg_offset+1:je_obc+G%jdg_offset,:) endif else - if (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'DUDY') then + 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+G%idg_offset+1:ie_obc+G%idg_offset+1,1,:) else segment%field(m)%buffer_src(:,js_obc,:)=tmp_buffer(is_obc+G%idg_offset+1:ie_obc+G%idg_offset,1,:) endif endif endif - if (segment%field(m)%nk_src > 1) then + ! no dz for tidal variables + if (segment%field(m)%nk_src > 1 .and.& + (index(segment%field(m)%name, 'phase') .le. 0 .and. index(segment%field(m)%name, 'amp') .le. 0)) then call time_interp_external(segment%field(m)%fid_dz,Time, tmp_buffer_in) if (turns /= 0) then ! TODO: This is hardcoded for 90 degrees, and needs to be generalized. @@ -3890,6 +4104,10 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) 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 @@ -3902,13 +4120,17 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) if (segment%field(m)%name == 'V') then allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,G%ke)) allocate(segment%field(m)%bt_vel(is_obc:ie_obc,js_obc:je_obc)) + 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,siz(3))) ! <- ? elseif (segment%field(m)%name == 'U') then allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc+1:je_obc,G%ke)) allocate(segment%field(m)%bt_vel(is_obc:ie_obc,js_obc+1:je_obc)) + 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,siz(3))) ! <- ? elseif (segment%field(m)%name == 'DVDX') then allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,G%ke)) - elseif (segment%field(m)%name == 'SSH') then - allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,1)) + 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,siz(3))) ! <- ? else allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc+1:je_obc,G%ke)) endif @@ -3916,13 +4138,17 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) if (segment%field(m)%name == 'U') then allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,G%ke)) allocate(segment%field(m)%bt_vel(is_obc:ie_obc,js_obc:je_obc)) + 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))) ! untested elseif (segment%field(m)%name == 'V') then allocate(segment%field(m)%buffer_dst(is_obc+1:ie_obc,js_obc:je_obc,G%ke)) allocate(segment%field(m)%bt_vel(is_obc+1:ie_obc,js_obc:je_obc)) + 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,siz(3))) ! untested elseif (segment%field(m)%name == 'DUDY') then allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,G%ke)) - elseif (segment%field(m)%name == 'SSH') then - allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,1)) + 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,siz(3))) ! untested else allocate(segment%field(m)%buffer_dst(is_obc+1:ie_obc,js_obc:je_obc,G%ke)) endif @@ -3930,10 +4156,14 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) segment%field(m)%buffer_dst(:,:,:) = segment%field(m)%value if (trim(segment%field(m)%name) == 'U' .or. trim(segment%field(m)%name) == 'V') then segment%field(m)%bt_vel(:,:) = segment%field(m)%value + ! TODO: tides? endif 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 if (segment%field(m)%fid>0) then ! calculate external BT velocity and transport if needed if (trim(segment%field(m)%name) == 'U' .or. trim(segment%field(m)%name) == 'V') then @@ -3941,10 +4171,16 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) 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_type_to_real(Time) - OBC%time_ref)*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,G%ke - segment%normal_vel(I,j,k) = US%m_s_to_L_T*segment%field(m)%buffer_dst(I,j,k) - segment%normal_trans(I,j,k) = US%m_s_to_L_T*segment%field(m)%buffer_dst(I,j,k)*segment%h(I,j,k) * & - G%dyCu(I,j) + segment%normal_vel(I,j,k) = US%m_s_to_L_T*(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) * G%dyCu(I,j)) @@ -3954,9 +4190,16 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) 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_type_to_real(Time) - OBC%time_ref)*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,G%ke - segment%normal_vel(i,J,k) = US%m_s_to_L_T*segment%field(m)%buffer_dst(i,J,k) - segment%normal_trans(i,J,k) = US%m_s_to_L_T*segment%field(m)%buffer_dst(i,J,k)*segment%h(i,J,k) * & + segment%normal_vel(i,J,k) = US%m_s_to_L_T*(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 @@ -3967,8 +4210,15 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) associated(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_type_to_real(Time) - OBC%time_ref)*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,G%ke - segment%tangential_vel(I,J,k) = US%m_s_to_L_T*segment%field(m)%buffer_dst(I,J,k) + segment%tangential_vel(I,J,k) = US%m_s_to_L_T*(segment%field(m)%buffer_dst(I,J,k) + tidal_vel) enddo if (associated(segment%nudged_tangential_vel)) & segment%nudged_tangential_vel(I,J,:) = segment%tangential_vel(I,J,:) @@ -3976,9 +4226,16 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) elseif (trim(segment%field(m)%name) == 'U' .and. segment%is_N_or_S .and. & associated(segment%tangential_vel)) then J=js_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_type_to_real(Time) - OBC%time_ref)*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 I=is_obc,ie_obc do k=1,G%ke - segment%tangential_vel(I,J,k) = US%m_s_to_L_T*segment%field(m)%buffer_dst(I,J,k) + segment%tangential_vel(I,J,k) = US%m_s_to_L_T*(segment%field(m)%buffer_dst(I,J,k) + tidal_vel) enddo if (associated(segment%nudged_tangential_vel)) & segment%nudged_tangential_vel(I,J,:) = segment%tangential_vel(I,J,:) @@ -4028,13 +4285,27 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) if (OBC%ramp) then do j=js_obc2,je_obc do i=is_obc2,ie_obc - segment%eta(i,j) = OBC%ramp_value * segment%field(m)%buffer_dst(i,j,1) + 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_type_to_real(Time) - OBC%time_ref)*OBC%tide_frequencies(c) - segment%field(segment%zphase_index)%buffer_dst(i,j,c) + OBC%tide_eq_phases(c) + OBC%tide_un(c)) + enddo + endif + segment%eta(i,j) = OBC%ramp_value * (segment%field(m)%buffer_dst(i,j,1) + tidal_elev) enddo enddo else do j=js_obc2,je_obc do i=is_obc2,ie_obc - segment%eta(i,j) = segment%field(m)%buffer_dst(i,j,1) + 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_type_to_real(Time) - OBC%time_ref)*OBC%tide_frequencies(c) - segment%field(segment%zphase_index)%buffer_dst(i,j,c) + OBC%tide_eq_phases(c) + OBC%tide_un(c)) + enddo + endif + segment%eta(i,j) = segment%field(m)%buffer_dst(i,j,1) + tidal_elev enddo enddo endif diff --git a/src/framework/MOM_file_parser.F90 b/src/framework/MOM_file_parser.F90 index 2e7a14dbe4..fa29ad9a53 100644 --- a/src/framework/MOM_file_parser.F90 +++ b/src/framework/MOM_file_parser.F90 @@ -1483,7 +1483,7 @@ subroutine log_param_char(CS, modulename, varname, value, desc, units, & 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 + character(len=1024) :: mesg, myunits write(mesg, '(" ",a," ",a,": ",a)') & trim(modulename), trim(varname), trim(value) @@ -1492,7 +1492,7 @@ subroutine log_param_char(CS, modulename, varname, value, desc, units, & if (CS%log_to_stdout) write(CS%stdout,'(a)') trim(mesg) endif - myunits=" "; if (present(units)) write(myunits(1:240),'(A)') trim(units) + myunits=" "; if (present(units)) write(myunits(1:1024),'(A)') trim(units) if (present(desc)) & call doc_param(CS%doc, varname, desc, myunits, value, default, & layoutParam=layoutParam, debuggingParam=debuggingParam, like_default=like_default) @@ -1893,7 +1893,7 @@ subroutine get_param_char_array(CS, modulename, varname, value, desc, units, & ! Local variables logical :: do_read, do_log integer :: i, len_tot, len_val - character(len=240) :: cat_val + character(len=1024) :: 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 diff --git a/src/parameterizations/lateral/MOM_tidal_forcing.F90 b/src/parameterizations/lateral/MOM_tidal_forcing.F90 index 57a1d78c03..79bb044cc9 100644 --- a/src/parameterizations/lateral/MOM_tidal_forcing.F90 +++ b/src/parameterizations/lateral/MOM_tidal_forcing.F90 @@ -6,16 +6,18 @@ module MOM_tidal_forcing 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_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 : time_type, time_type_to_real +use MOM_time_manager, only : set_date, time_type, time_type_to_real, operator(-) implicit none ; private public calc_tidal_forcing, tidal_forcing_init, tidal_forcing_end public tidal_forcing_sensitivity +! MOM_open_boundary uses the following to set tides on the boundary. +public astro_longitudes_init, eq_phase, nodal_fu, tidal_frequency #include @@ -31,6 +33,10 @@ module MOM_tidal_forcing !! by TIDAL_INPUT_FILE. logical :: use_prev_tides !< 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. @@ -43,6 +49,9 @@ module MOM_tidal_forcing integer :: struct(MAX_CONSTITUENTS) !< An encoded spatial structure for each constituent character (len=16) :: const_name(MAX_CONSTITUENTS) !< The name of each constituent + real :: time_ref !< Reference time (t = 0) used to calculate tidal forcing. + real, dimension(4) :: astro_shpn !< Astronomical longitudes used to calculate + !! tidal phases at t = 0. real, pointer, dimension(:,:,:) :: & sin_struct => NULL(), & !< The sine and cosine based structures that can cos_struct => NULL(), & !< be associated with the astronomical forcing. @@ -58,6 +67,158 @@ module MOM_tidal_forcing 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 is from 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_shpn) + real, dimension(4), intent(out) :: longitudes_shpn + real, intent(in) :: time_ref + real :: D, T + real, parameter :: PI = 4.0*atan(1.0) ! 3.14159... + ! if time_ref is not at midnight, this could be used to round down to nearest day. + ! time_ref = time_ref - mod(time_ref, 24.0*3600.0) + ! Find date at time_ref in days since 1900-01-01 + D = (time_ref - time_type_to_real(set_date(1900, 1, 1))) / (24.0 * 3600.0) + ! Time since 1900-01-01 in Julian centuries + T = D / 36525.0 + ! s: Mean longitude of moon + longitudes_shpn(1) = 277.0248 + 481267.8906 * T + 0.0011 * (T**2) + ! h: Mean longitude of sun + longitudes_shpn(2) = 280.1895 + 36000.7689 * T + 3.0310e-4 * (T**2) + ! p: Mean longitude of lunar perigee + longitudes_shpn(3) = 334.3853 + 4069.0340 * T - 0.0103 * (T**2) + ! n: Longitude of ascending node + longitudes_shpn(4) = 259.1568 - 1934.142 * T + 0.0021 * (T**2) + ! Convert to radians on [0, 2pi) + longitudes_shpn = mod(longitudes_shpn, 360.0) * PI / 180.0 +end subroutine astro_longitudes_init + +!> Calculates the equilibrium phase argument for the given tidal +!! constituent constit and the array of longitudes shpn. +!! 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, shpn) + character (len=2), intent(in) :: constit !> Name of constituent (e.g., M2). + real, dimension(3), intent(in) :: shpn !> Mean longitudes calculated using astro_longitudes_init + real :: s, h, p !> Longitudes of moon, sun, and lunar perigee. + real, parameter :: PI = 4.0*atan(1.0) !> 3.14159... + real :: eq_phase !> The equilibrium phase argument for the constituent. + + s = shpn(1) + h = shpn(2) + p = shpn(3) + + select case (constit) + case ("M2") + eq_phase = 2 * (h - s) + case ("S2") + eq_phase = 0.0 + case ("N2") + eq_phase = - 3 * s + 2 * h + p + case ("K2") + eq_phase = 2 * h + case ("K1") + eq_phase = h + PI / 2.0 + case("O1") + eq_phase = - 2 * s + h - PI / 2.0 + case ("P1") + eq_phase = - h - PI / 2.0 + case ("Q1") + eq_phase = - 3 * s + h + p - PI / 2.0 + case ("MF") + eq_phase = 2 * s + case ("MM") + eq_phase = s - 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, N, fn, un) + character (len=2), intent(in) :: constit !> Tidal constituent to find modulation for. + real, intent(in) :: N !> Longitude of ascending node in radians. + !! Calculate using astro_longitudes_init. + real, parameter :: RADIANS = 4.0 * atan(1.0) / 180.0 !> Converts degrees to radians. + real, intent(out) :: fn, un !> Amplitude (fn, unitless) and phase (un, radians) modulation. + + select case (constit) + case ("M2") + fn = 1.0 - 0.037 * cos(N) + un = -2.1 * RADIANS * sin(N) + case ("S2") + fn = 1.0 ! Solar S2 has no amplitude modulation. + un = 0.0 ! S2 has no phase mdulation. + case ("N2") + fn = 1.0 - 0.037 * cos(N) + un = -2.1 * RADIANS * sin(N) + case ("K2") + fn = 1.024 + 0.286 * cos(N) + un = -17.7 * RADIANS * sin(N) + case ("K1") + fn = 1.006 + 0.115 * cos(N) + un = -8.9 * RADIANS * sin(N) + case ("O1") + fn = 1.009 + 0.187 * cos(N) + un = 10.8 * RADIANS * sin(N) + case ("P1") + fn = 1.0 ! P1 has no amplitude modulation. + un = 0.0 ! P1 has no phase mdulation. + case ("Q1") + fn = 1.009 + 0.187 * cos(N) + un = 10.8 * RADIANS * sin(N) + case ("MF") + fn = 1.043 + 0.414 * cos(N) + un = -23.7 * RADIANS * sin(N) + case ("MM") + fn = 1.0 - 0.130 * cos(N) + 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. @@ -75,6 +236,7 @@ subroutine tidal_forcing_init(Time, G, param_file, CS) lat_rad, lon_rad ! Latitudes and longitudes of h-points in radians. real :: deg_to_rad real, dimension(MAX_CONSTITUENTS) :: freq_def, phase0_def, amp_def, love_def + integer, dimension(3) :: tide_ref_date !< Reference date (t = 0) for tidal forcing. logical :: use_const ! True if a constituent is being used. logical :: use_M2, use_S2, use_N2, use_K2, use_K1, use_O1, use_P1, use_Q1 logical :: use_MF, use_MM @@ -213,79 +375,97 @@ subroutine tidal_forcing_init(Time, G, param_file, CS) 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=.true., fail_if_missing=.false.) + + if (sum(tide_ref_date) == 0) then ! tide_ref_date defaults to 0. + CS%time_ref = 0 + 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 = time_type_to_real(set_date(tide_ref_date(1), tide_ref_date(2), tide_ref_date(3))) + endif ! Set the parameters for all components that are in use. + ! 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%astro_shpn) c=0 if (use_M2) then - c=c+1 ; CS%const_name(c) = "M2" ; CS%freq(c) = 1.4051890e-4 ; CS%struct(c) = 2 - CS%love_no(c) = 0.693 ; CS%amp(c) = 0.242334 ; CS%phase0(c) = 0.0 - freq_def(c) = CS%freq(c) ; love_def(c) = CS%love_no(c) - amp_def(c) = CS%amp(c) ; phase0_def(c) = CS%phase0(c) + c=c+1 ; CS%const_name(c) = "M2" ; CS%struct(c) = 2 + CS%love_no(c) = 0.693 ; CS%amp(c) = 0.242334 endif if (use_S2) then - c=c+1 ; CS%const_name(c) = "S2" ; CS%freq(c) = 1.4544410e-4 ; CS%struct(c) = 2 - CS%love_no(c) = 0.693 ; CS%amp(c) = 0.112743 ; CS%phase0(c) = 0.0 - freq_def(c) = CS%freq(c) ; love_def(c) = CS%love_no(c) - amp_def(c) = CS%amp(c) ; phase0_def(c) = CS%phase0(c) + c=c+1 ; CS%const_name(c) = "S2" ; CS%struct(c) = 2 + CS%love_no(c) = 0.693 ; CS%amp(c) = 0.112743 endif if (use_N2) then - c=c+1 ; CS%const_name(c) = "N2" ; CS%freq(c) = 1.3787970e-4 ; CS%struct(c) = 2 - CS%love_no(c) = 0.693 ; CS%amp(c) = 0.046397 ; CS%phase0(c) = 0.0 - freq_def(c) = CS%freq(c) ; love_def(c) = CS%love_no(c) - amp_def(c) = CS%amp(c) ; phase0_def(c) = CS%phase0(c) + c=c+1 ; CS%const_name(c) = "N2" ; CS%struct(c) = 2 + CS%love_no(c) = 0.693 ; CS%amp(c) = 0.046397 endif if (use_K2) then - c=c+1 ; CS%const_name(c) = "K2" ; CS%freq(c) = 1.4584234e-4 ; CS%struct(c) = 2 - CS%love_no(c) = 0.693 ; CS%amp(c) = 0.030684 ; CS%phase0(c) = 0.0 - freq_def(c) = CS%freq(c) ; love_def(c) = CS%love_no(c) - amp_def(c) = CS%amp(c) ; phase0_def(c) = CS%phase0(c) + c=c+1 ; CS%const_name(c) = "K2" ; CS%struct(c) = 2 + CS%love_no(c) = 0.693 ; CS%amp(c) = 0.030684 endif if (use_K1) then - c=c+1 ; CS%const_name(c) = "K1" ; CS%freq(c) = 0.7292117e-4 ; CS%struct(c) = 1 - CS%love_no(c) = 0.736 ; CS%amp(c) = 0.141565 ; CS%phase0(c) = 0.0 - freq_def(c) = CS%freq(c) ; love_def(c) = CS%love_no(c) - amp_def(c) = CS%amp(c) ; phase0_def(c) = CS%phase0(c) + c=c+1 ; CS%const_name(c) = "K1" ; CS%struct(c) = 1 + CS%love_no(c) = 0.736 ; CS%amp(c) = 0.141565 endif if (use_O1) then - c=c+1 ; CS%const_name(c) = "O1" ; CS%freq(c) = 0.6759774e-4 ; CS%struct(c) = 1 - CS%love_no(c) = 0.695 ; CS%amp(c) = 0.100661 ; CS%phase0(c) = 0.0 - freq_def(c) = CS%freq(c) ; love_def(c) = CS%love_no(c) - amp_def(c) = CS%amp(c) ; phase0_def(c) = CS%phase0(c) + c=c+1 ; CS%const_name(c) = "O1" ; CS%struct(c) = 1 + CS%love_no(c) = 0.695 ; CS%amp(c) = 0.100661 endif if (use_P1) then - c=c+1 ; CS%const_name(c) = "P1" ; CS%freq(c) = 0.7252295e-4 ; CS%struct(c) = 1 - CS%love_no(c) = 0.706 ; CS%amp(c) = 0.046848 ; CS%phase0(c) = 0.0 - freq_def(c) = CS%freq(c) ; love_def(c) = CS%love_no(c) - amp_def(c) = CS%amp(c) ; phase0_def(c) = CS%phase0(c) + c=c+1 ; CS%const_name(c) = "P1" ; CS%struct(c) = 1 + CS%love_no(c) = 0.706 ; CS%amp(c) = 0.046848 endif if (use_Q1) then - c=c+1 ; CS%const_name(c) = "Q1" ; CS%freq(c) = 0.6495854e-4 ; CS%struct(c) = 1 - CS%love_no(c) = 0.695 ; CS%amp(c) = 0.019273 ; CS%phase0(c) = 0.0 - freq_def(c) = CS%freq(c) ; love_def(c) = CS%love_no(c) - amp_def(c) = CS%amp(c) ; phase0_def(c) = CS%phase0(c) + c=c+1 ; CS%const_name(c) = "Q1" ; CS%struct(c) = 1 + CS%love_no(c) = 0.695 ; CS%amp(c) = 0.019273 endif if (use_MF) then - c=c+1 ; CS%const_name(c) = "MF" ; CS%freq(c) = 0.053234e-4 ; CS%struct(c) = 3 - CS%love_no(c) = 0.693 ; CS%amp(c) = 0.042041 ; CS%phase0(c) = 0.0 - freq_def(c) = CS%freq(c) ; love_def(c) = CS%love_no(c) - amp_def(c) = CS%amp(c) ; phase0_def(c) = CS%phase0(c) + c=c+1 ; CS%const_name(c) = "MF" ; CS%struct(c) = 3 + CS%love_no(c) = 0.693 ; CS%amp(c) = 0.042041 endif if (use_MM) then - c=c+1 ; CS%const_name(c) = "MM" ; CS%freq(c) = 0.026392e-4 ; CS%struct(c) = 3 - CS%love_no(c) = 0.693 ; CS%amp(c) = 0.022191 ; CS%phase0(c) = 0.0 - freq_def(c) = CS%freq(c) ; love_def(c) = CS%love_no(c) - amp_def(c) = CS%amp(c) ; phase0_def(c) = CS%phase0(c) + c=c+1 ; CS%const_name(c) = "MM" ; CS%struct(c) = 3 + CS%love_no(c) = 0.693 ; CS%amp(c) = 0.022191 endif - ! Parse the input file to potentially override the default values for the + ! Set defaults for all included constituents + ! and things that can be set by functions + do c=1,nc + CS%freq(c) = tidal_frequency(CS%const_name(c)) + freq_def(c) = CS%freq(c) + love_def(c) = CS%love_no(c) + amp_def(c) = CS%amp(c) + CS%phase0(c) = 0.0 + if (CS%use_eq_phase) then + phase0_def(c) = eq_phase(CS%const_name(c), CS%astro_shpn) + 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 @@ -411,8 +591,6 @@ subroutine calc_tidal_forcing(Time, eta, eta_tidal, G, CS, deta_tidal_deta, m_to real, optional, intent(in) :: m_to_Z !< A scaling factor from m to the units of eta. ! Local variables - real :: eta_astro(SZI_(G),SZJ_(G)) - real :: eta_SAL(SZI_(G),SZJ_(G)) real :: now ! The relative time in seconds. real :: amp_cosomegat, amp_sinomegat real :: cosomegat, sinomegat @@ -431,7 +609,7 @@ subroutine calc_tidal_forcing(Time, eta, eta_tidal, G, CS, deta_tidal_deta, m_to return endif - now = time_type_to_real(Time) + now = time_type_to_real(Time) - cs%time_ref if (CS%USE_SAL_SCALAR .and. CS%USE_PREV_TIDES) then eta_prop = 2.0*CS%SAL_SCALAR From a26a3864eb8cb790a4f3bdc9cdff329597e63317 Mon Sep 17 00:00:00 2001 From: Andrew Ross Date: Wed, 29 Jul 2020 15:06:59 -0400 Subject: [PATCH 003/336] Should be uppercase --- src/core/MOM_open_boundary.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index fd5dd99f09..fb40df2321 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -447,7 +447,7 @@ subroutine open_boundary_config(G, US, param_file, OBC) 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_n_tide_constituents", OBC%n_tide_constituents, & + call get_param(param_file, mdl, "OBC_N_TIDE_CONSTITUENTS", OBC%n_tide_constituents, & "Number of tidal constituents being added to the open boundary.", & default=0) From 1539071c51b053f33bc0e7e0444e4cc578c6f317 Mon Sep 17 00:00:00 2001 From: Andrew Ross Date: Wed, 29 Jul 2020 19:34:46 -0400 Subject: [PATCH 004/336] Add tide prefix to nodal ref date --- src/core/MOM_open_boundary.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index fb40df2321..ec5e274fd1 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -469,7 +469,7 @@ subroutine open_boundary_config(G, US, param_file, OBC) "Reference date to use for tidal calculations and equilibrium phase.", & fail_if_missing=.true.) - call get_param(param_file, mdl, "OBC_NODAL_REF_DATE", nodal_ref_date, & + 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) From b62ad1b52d968d95ba782853106f3f21ec1e1d42 Mon Sep 17 00:00:00 2001 From: Neeraja Bhamidipati Date: Mon, 10 Aug 2020 07:36:16 -0600 Subject: [PATCH 005/336] Added diagnostics for normal stress and shear stress --- src/parameterizations/lateral/MOM_hor_visc.F90 | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index cf993b8aa8..07e68a85bf 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -185,6 +185,7 @@ module MOM_hor_visc integer :: id_vort_xy_q = -1, id_div_xx_h = -1 integer :: id_FrictWork = -1, id_FrictWorkIntz = -1 integer :: id_FrictWork_GME = -1 + integer :: id_normstress = -1, id_shearstress = -1 !>@} @@ -501,6 +502,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, 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) + if (CS%id_normstress > 0) NoSt(i,j,k) = sh_xx enddo ; enddo ! Components for the shearing strain @@ -648,10 +650,12 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, 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 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 enddo ; enddo endif @@ -1277,6 +1281,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, 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) @@ -2021,6 +2027,11 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) endif ! Register fields for output from this module. + CS%id_normstress = register_diag_field('ocean_model', 'NoSt', diag%axesBL, 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) From 1978854205a5c06c0d17bb77b99cf66af6981b63 Mon Sep 17 00:00:00 2001 From: Neeraja Bhamidipati Date: Mon, 10 Aug 2020 08:47:07 -0600 Subject: [PATCH 006/336] Declare local variables NoSt and ShSt (normal stress and shear stress) --- src/parameterizations/lateral/MOM_hor_visc.F90 | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 07e68a85bf..3523defd0d 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -218,6 +218,12 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & intent(out) :: diffu !< Zonal acceleration due to convergence of !! along-coordinate stress tensor [L T-2 ~> m s-2] + real, dimension(SZIB_(G),SZJB_(G),SZK_(G)) :: & + intent(out) :: NoSt !< Normal stress [T-1 ~> s-1]. + + real, dimension(SZIB_(G),SZJB_(G),SZK_(G)) :: & + intent(out) :: ShSt !< Shear stress [T-1 ~> s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & intent(out) :: diffv !< Meridional acceleration due to convergence !! of along-coordinate stress tensor [L T-2 ~> m s-2]. From 41539427dac0458eb1d028472c4220c581c1a870 Mon Sep 17 00:00:00 2001 From: Neeraja Bhamidipati Date: Mon, 10 Aug 2020 10:13:16 -0600 Subject: [PATCH 007/336] De-bugged the code to fix diagnostics for normal and shear stresses --- .../lateral/MOM_hor_visc.F90 | 21 +++++++------------ 1 file changed, 8 insertions(+), 13 deletions(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 3523defd0d..318a4f4c90 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -218,12 +218,6 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & intent(out) :: diffu !< Zonal acceleration due to convergence of !! along-coordinate stress tensor [L T-2 ~> m s-2] - real, dimension(SZIB_(G),SZJB_(G),SZK_(G)) :: & - intent(out) :: NoSt !< Normal stress [T-1 ~> s-1]. - - real, dimension(SZIB_(G),SZJB_(G),SZK_(G)) :: & - intent(out) :: ShSt !< Shear stress [T-1 ~> s-1]. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & intent(out) :: diffv !< Meridional acceleration due to convergence !! of along-coordinate stress tensor [L T-2 ~> m s-2]. @@ -298,8 +292,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, 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] GME_coeff_q, & !< GME coeff. at q-points [L2 T-1 ~> m2 s-1] - max_diss_rate_q ! maximum possible energy dissipated by lateral friction [L2 T-3 ~> m2 s-3] - + max_diss_rate_q, & ! maximum possible energy dissipated by lateral friction [L2 T-3 ~> m2 s-3] + ShSt !< A diagnostic array of shear stress [T-1 ~> s-1]. real, dimension(SZIB_(G),SZJ_(G),SZK_(G)+1) :: & KH_u_GME !< interface height diffusivities in u-columns [L2 T-1 ~> m2 s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(G)+1) :: & @@ -310,7 +304,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, max_diss_rate_h, & ! maximum possible energy dissipated by lateral friction [L2 T-3 ~> m2 s-3] 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] + div_xx_h, & ! horizontal divergence [T-1 ~> s-1] + NoSt !< A diagnostic array of normal stress [T-1 ~> s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & GME_coeff_h !< GME coeff. at h-points [L2 T-1 ~> m2 s-1] real :: Ah ! biharmonic viscosity [L4 T-1 ~> m4 s-1] @@ -508,7 +503,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, 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) - if (CS%id_normstress > 0) NoSt(i,j,k) = sh_xx + if (CS%id_normstress > 0) NoSt(i,j,k) = sh_xx(i,j) enddo ; enddo ! Components for the shearing strain @@ -656,12 +651,12 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, 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 + 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 + if (CS%id_shearstress > 0) ShSt(I,J,k) = sh_xy(I,J) enddo ; enddo endif @@ -2033,7 +2028,7 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) endif ! Register fields for output from this module. - CS%id_normstress = register_diag_field('ocean_model', 'NoSt', diag%axesBL, Time, & + 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, & From e7c461da6f52ee83ff70b8e691906a7f7acff75c Mon Sep 17 00:00:00 2001 From: Neeraja Bhamidipati Date: Wed, 12 Aug 2020 05:35:47 -0600 Subject: [PATCH 008/336] Edited comments --- src/user/basin_builder.F90 | 26 ++++++++++++++++++++++++++ 1 file changed, 26 insertions(+) diff --git a/src/user/basin_builder.F90 b/src/user/basin_builder.F90 index 61b65e0e9c..c588a92c24 100644 --- a/src/user/basin_builder.F90 +++ b/src/user/basin_builder.F90 @@ -94,6 +94,17 @@ subroutine basin_builder_topography(D, G, param_file, max_depth) 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, latitude, "//& + "footprint radius, shelf depth.", & + units="degrees_E,degrees_N,degrees,m", & + fail_if_missing=.true.) + 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, "//& @@ -211,6 +222,21 @@ real function dist_line_fixed_y(x, y, x0, x1, y0) 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 [degrees_E] + real, intent(in) :: lat_mer !< Latitude [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*lat + lon_eq*lon - 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] From 726f70b3dcbe5d25d08aa4bcdd25f1f2b0c349bb Mon Sep 17 00:00:00 2001 From: Andrew Ross Date: Thu, 13 Aug 2020 16:25:44 -0400 Subject: [PATCH 009/336] Revert to always allocating 1. Fixes failing tests --- src/core/MOM_open_boundary.F90 | 19 +++++++++---------- 1 file changed, 9 insertions(+), 10 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 00f9c25b98..4469390e11 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -3844,9 +3844,9 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) 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,siz(3))) + 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,siz(3))) + allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc+1:je_obc,1)) endif if (segment%field(m)%name == 'U') then allocate(segment%field(m)%bt_vel(is_obc:ie_obc,js_obc+1:je_obc)) @@ -3855,9 +3855,9 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) 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,siz(3))) + 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,siz(3))) + allocate(segment%field(m)%buffer_dst(is_obc+1:ie_obc,js_obc:je_obc,1)) endif if (segment%field(m)%name == 'V') then allocate(segment%field(m)%bt_vel(is_obc+1:ie_obc,js_obc:je_obc)) @@ -4122,7 +4122,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,G%ke)) allocate(segment%field(m)%bt_vel(is_obc:ie_obc,js_obc:je_obc)) 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,siz(3))) ! <- ? + allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,siz(3))) ! <- not sure how to handle tides here ? elseif (segment%field(m)%name == 'U') then allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc+1:je_obc,G%ke)) allocate(segment%field(m)%bt_vel(is_obc:ie_obc,js_obc+1:je_obc)) @@ -4131,7 +4131,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) elseif (segment%field(m)%name == 'DVDX') then allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,G%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,siz(3))) ! <- ? + 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,G%ke)) endif @@ -4140,16 +4140,16 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,G%ke)) allocate(segment%field(m)%bt_vel(is_obc:ie_obc,js_obc:je_obc)) 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))) ! untested + allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,1)) ! not sure how to handle tides here ? elseif (segment%field(m)%name == 'V') then allocate(segment%field(m)%buffer_dst(is_obc+1:ie_obc,js_obc:je_obc,G%ke)) allocate(segment%field(m)%bt_vel(is_obc+1:ie_obc,js_obc:je_obc)) 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,siz(3))) ! untested + 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,G%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,siz(3))) ! untested + 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,G%ke)) endif @@ -4309,7 +4309,6 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) cos((time_type_to_real(Time) - OBC%time_ref)*OBC%tide_frequencies(c) - segment%field(segment%zphase_index)%buffer_dst(i,j,c) + OBC%tide_eq_phases(c) + OBC%tide_un(c)) enddo endif - segment%eta(i,j) = GV%m_to_H * (segment%field(m)%buffer_dst(i,j,1) + tidal_elev) enddo enddo endif From a6274576193805cc266281beeb1e34e9c65cf17a Mon Sep 17 00:00:00 2001 From: Neeraja Bhamidipati Date: Fri, 14 Aug 2020 07:33:39 -0600 Subject: [PATCH 010/336] Modified comments --- src/user/basin_builder.F90 | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/user/basin_builder.F90 b/src/user/basin_builder.F90 index c588a92c24..ab1889d88b 100644 --- a/src/user/basin_builder.F90 +++ b/src/user/basin_builder.F90 @@ -96,8 +96,8 @@ subroutine basin_builder_topography(D, G, param_file, max_depth) enddo ; enddo elseif (trim(lowercase(funcs)) == 'angled_coast') then call get_param(param_file, mdl, pname2, pars(1:4), & - "ANGLED_COAST parameters: longitude, latitude, "//& - "footprint radius, shelf depth.", & + "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.) do j=G%jsc,G%jec ; do i=G%isc,G%iec @@ -226,14 +226,14 @@ end function dist_line_fixed_y 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 [degrees_E] - real, intent(in) :: lat_mer !< 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*lat + lon_eq*lon - lon_eq*lat_mer) + 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 From 26d4cf4f3b6ea152f80271bc03b368f6fc66bbde Mon Sep 17 00:00:00 2001 From: Neeraja Bhamidipati Date: Fri, 14 Aug 2020 09:35:20 -0600 Subject: [PATCH 011/336] Changed conversion between s and T in the register step --- src/parameterizations/lateral/MOM_hor_visc.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index d615db5cf9..c4b89814ee 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -2066,10 +2066,10 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE, ADp) ! 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) + 'Normal Stress', 's-1', conversion=US%T_to_s) CS%id_shearstress = register_diag_field('ocean_model', 'ShSt', diag%axesBL, Time, & - 'Shear Stress', 's-1', conversion=US%s_to_T) + 'Shear Stress', 's-1', conversion=US%T_to_s) 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) From 7c347e5cac38cd02660431de3c087afd046caaf2 Mon Sep 17 00:00:00 2001 From: Neeraja Bhamidipati Date: Fri, 14 Aug 2020 11:50:35 -0600 Subject: [PATCH 012/336] Debugged the code to correct dimensions of pars(4) in angled_coast --- src/user/basin_builder.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/src/user/basin_builder.F90 b/src/user/basin_builder.F90 index ab1889d88b..c9cdbfa392 100644 --- a/src/user/basin_builder.F90 +++ b/src/user/basin_builder.F90 @@ -100,6 +100,7 @@ subroutine basin_builder_topography(D, G, param_file, max_depth) "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) From 418d5cc4374edcb76592548814021efb5d3ac704 Mon Sep 17 00:00:00 2001 From: Andrew Ross Date: Tue, 18 Aug 2020 10:48:26 -0400 Subject: [PATCH 013/336] Add missing update of SSH when there is no ramp --- src/core/MOM_open_boundary.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 4469390e11..4e2b61bbdd 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -4309,6 +4309,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) cos((time_type_to_real(Time) - OBC%time_ref)*OBC%tide_frequencies(c) - segment%field(segment%zphase_index)%buffer_dst(i,j,c) + OBC%tide_eq_phases(c) + OBC%tide_un(c)) enddo endif + segment%eta(i,j) = GV%m_to_H * (segment%field(m)%buffer_dst(i,j,1) + tidal_elev) enddo enddo endif From 7b2dcd989d90d39d61c5f3499e054586fd849209 Mon Sep 17 00:00:00 2001 From: Andrew Ross Date: Tue, 18 Aug 2020 12:36:26 -0400 Subject: [PATCH 014/336] Support setting tides by value= --- src/core/MOM_boundary_update.F90 | 2 +- src/core/MOM_open_boundary.F90 | 199 ++++++++++++++++--------------- 2 files changed, 105 insertions(+), 96 deletions(-) diff --git a/src/core/MOM_boundary_update.F90 b/src/core/MOM_boundary_update.F90 index 4dc89efeb0..d7ab6a1922 100644 --- a/src/core/MOM_boundary_update.F90 +++ b/src/core/MOM_boundary_update.F90 @@ -145,7 +145,7 @@ subroutine update_OBC_data(OBC, G, GV, US, tv, h, CS, Time) call shelfwave_set_OBC_data(OBC, CS%shelfwave_OBC_CSp, G, h, Time) if (CS%use_dyed_channel) & call dyed_channel_update_flow(OBC, CS%dyed_channel_OBC_CSp, G, Time) - if (OBC%needs_IO_for_data) & + if (OBC%needs_IO_for_data .or. OBC%add_tide_constituents) & call update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) end subroutine update_OBC_data diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 4e2b61bbdd..5191d1edf1 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -661,6 +661,8 @@ subroutine open_boundary_config(G, US, param_file, OBC) ! 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, tide_ref_date, nodal_ref_date, tide_constituent_str) + ! 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. & @@ -927,24 +929,38 @@ subroutine initialize_segment_data(G, OBC, PF) segment%field(m)%fid = -1 segment%field(m)%value = value segment%field(m)%name = trim(fields(m)) + ! Check if this is a tidal field. If so, the number + ! of expected constiuents 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 .gt. 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 @@ -4120,153 +4136,146 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) 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,G%ke)) - allocate(segment%field(m)%bt_vel(is_obc:ie_obc,js_obc:je_obc)) 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,siz(3))) ! <- not sure how to handle tides here ? + 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,G%ke)) - allocate(segment%field(m)%bt_vel(is_obc:ie_obc,js_obc+1:je_obc)) 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,siz(3))) ! <- ? + 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,G%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)) ! <- ? + 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,G%ke)) endif else if (segment%field(m)%name == 'U') then allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,G%ke)) - allocate(segment%field(m)%bt_vel(is_obc:ie_obc,js_obc:je_obc)) 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)) ! not sure how to handle tides here ? + 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,G%ke)) - allocate(segment%field(m)%bt_vel(is_obc+1:ie_obc,js_obc:je_obc)) 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)) ! ? + 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,G%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)) ! ? + 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,G%ke)) endif endif segment%field(m)%buffer_dst(:,:,:) = segment%field(m)%value - if (trim(segment%field(m)%name) == 'U' .or. trim(segment%field(m)%name) == 'V') then - segment%field(m)%bt_vel(:,:) = segment%field(m)%value - ! TODO: tides? - endif 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 - if (segment%field(m)%fid>0) 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_type_to_real(Time) - OBC%time_ref)*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,G%ke - segment%normal_vel(I,j,k) = US%m_s_to_L_T*(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 (associated(segment%nudged_normal_vel)) segment%nudged_normal_vel(I,j,:) = segment%normal_vel(I,j,:) - enddo - elseif (trim(segment%field(m)%name) == 'V' .and. segment%is_N_or_S) then - 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_type_to_real(Time) - OBC%time_ref)*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,G%ke - segment%normal_vel(i,J,k) = US%m_s_to_L_T*(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 (associated(segment%nudged_normal_vel)) segment%nudged_normal_vel(i,J,:) = segment%normal_vel(i,J,:) - enddo - elseif (trim(segment%field(m)%name) == 'V' .and. segment%is_E_or_W .and. & - associated(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_type_to_real(Time) - OBC%time_ref)*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,G%ke - segment%tangential_vel(I,J,k) = US%m_s_to_L_T*(segment%field(m)%buffer_dst(I,J,k) + tidal_vel) - enddo - if (associated(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. & - associated(segment%tangential_vel)) then - J=js_obc + ! if (segment%field(m)%fid>0) 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_type_to_real(Time) - OBC%time_ref)*OBC%tide_frequencies(c) - segment%field(segment%uphase_index)%buffer_dst(I,j,c) + OBC%tide_eq_phases(c) + OBC%tide_un(c)) + cos((time_type_to_real(Time) - OBC%time_ref)*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 I=is_obc,ie_obc - do k=1,G%ke - segment%tangential_vel(I,J,k) = US%m_s_to_L_T*(segment%field(m)%buffer_dst(I,J,k) + tidal_vel) + do k=1,G%ke + segment%normal_vel(I,j,k) = US%m_s_to_L_T*(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 (associated(segment%nudged_normal_vel)) segment%nudged_normal_vel(I,j,:) = segment%normal_vel(I,j,:) + enddo + elseif (trim(segment%field(m)%name) == 'V' .and. segment%is_N_or_S) then + 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_type_to_real(Time) - OBC%time_ref)*OBC%tide_frequencies(c) - segment%field(segment%vphase_index)%buffer_dst(I,j,c) + OBC%tide_eq_phases(c) + OBC%tide_un(c)) enddo - if (associated(segment%nudged_tangential_vel)) & - segment%nudged_tangential_vel(I,J,:) = segment%tangential_vel(I,J,:) + endif + do k=1,G%ke + segment%normal_vel(i,J,k) = US%m_s_to_L_T*(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 - endif - elseif (trim(segment%field(m)%name) == 'DVDX' .and. segment%is_E_or_W .and. & - associated(segment%tangential_grad)) then + segment%normal_vel_bt(i,J) = normal_trans_bt(i,J) & + / (max(segment%Htot(i,J), 1.e-12 * GV%m_to_H) * G%dxCv(i,J)) + if (associated(segment%nudged_normal_vel)) segment%nudged_normal_vel(i,J,:) = segment%normal_vel(i,J,:) + enddo + elseif (trim(segment%field(m)%name) == 'V' .and. segment%is_E_or_W .and. & + associated(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_type_to_real(Time) - OBC%time_ref)*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,G%ke - segment%tangential_grad(I,J,k) = US%T_to_s*segment%field(m)%buffer_dst(I,J,k) - if (associated(segment%nudged_tangential_grad)) & - segment%nudged_tangential_grad(I,J,:) = segment%tangential_grad(I,J,:) + segment%tangential_vel(I,J,k) = US%m_s_to_L_T*(segment%field(m)%buffer_dst(I,J,k) + tidal_vel) enddo + if (associated(segment%nudged_tangential_vel)) & + segment%nudged_tangential_vel(I,J,:) = segment%tangential_vel(I,J,:) enddo - elseif (trim(segment%field(m)%name) == 'DUDY' .and. segment%is_N_or_S .and. & - associated(segment%tangential_grad)) then + elseif (trim(segment%field(m)%name) == 'U' .and. segment%is_N_or_S .and. & + associated(segment%tangential_vel)) then J=js_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_type_to_real(Time) - OBC%time_ref)*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 I=is_obc,ie_obc do k=1,G%ke - segment%tangential_grad(I,J,k) = US%T_to_s*segment%field(m)%buffer_dst(I,J,k) - if (associated(segment%nudged_tangential_grad)) & - segment%nudged_tangential_grad(I,J,:) = segment%tangential_grad(I,J,:) + segment%tangential_vel(I,J,k) = US%m_s_to_L_T*(segment%field(m)%buffer_dst(I,J,k) + tidal_vel) enddo + if (associated(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. & + associated(segment%tangential_grad)) then + I=is_obc + do J=js_obc,je_obc + do k=1,G%ke + segment%tangential_grad(I,J,k) = US%T_to_s*segment%field(m)%buffer_dst(I,J,k) + if (associated(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. & + associated(segment%tangential_grad)) then + J=js_obc + do I=is_obc,ie_obc + do k=1,G%ke + segment%tangential_grad(I,J,k) = US%T_to_s*segment%field(m)%buffer_dst(I,J,k) + if (associated(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 From 656c5355a733f09d99b88f00c77d68802e99e6b4 Mon Sep 17 00:00:00 2001 From: Andrew Ross Date: Tue, 18 Aug 2020 12:36:57 -0400 Subject: [PATCH 015/336] Remove unused bt_vel --- src/core/MOM_open_boundary.F90 | 19 ------------------- 1 file changed, 19 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 5191d1edf1..e5d28dd62f 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -87,7 +87,6 @@ module MOM_open_boundary real, dimension(:,:,:), allocatable :: dz_src !< vertical grid cell spacing of the incoming segment !! data, set in [Z ~> m] then scaled to [H ~> m or kg m-2] real, dimension(:,:,:), pointer :: buffer_dst=>NULL() !< buffer src data remapped to the target vertical grid - real, dimension(:,:), pointer :: bt_vel=>NULL() !< barotropic velocity [L T-1 ~> m s-1] real :: value !< constant value if fid is equal to -1 end type OBC_segment_data_type @@ -3836,10 +3835,6 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) else allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc+1:je_obc,G%ke)) endif - if (segment%field(m)%name == 'U') then - allocate(segment%field(m)%bt_vel(is_obc:ie_obc,js_obc+1:je_obc)) - segment%field(m)%bt_vel(:,:)=0.0 - 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,G%ke)) @@ -3851,10 +3846,6 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) else allocate(segment%field(m)%buffer_dst(is_obc+1:ie_obc,js_obc:je_obc,G%ke)) endif - if (segment%field(m)%name == 'V') then - allocate(segment%field(m)%bt_vel(is_obc+1:ie_obc,js_obc:je_obc)) - segment%field(m)%bt_vel(:,:)=0.0 - endif endif else if (segment%is_E_or_W) then @@ -3864,10 +3855,6 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) else allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc+1:je_obc,1)) endif - if (segment%field(m)%name == 'U') then - allocate(segment%field(m)%bt_vel(is_obc:ie_obc,js_obc+1:je_obc)) - segment%field(m)%bt_vel(:,:)=0.0 - 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 @@ -3875,10 +3862,6 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) else allocate(segment%field(m)%buffer_dst(is_obc+1:ie_obc,js_obc:je_obc,1)) endif - if (segment%field(m)%name == 'V') then - allocate(segment%field(m)%bt_vel(is_obc+1:ie_obc,js_obc:je_obc)) - segment%field(m)%bt_vel(:,:)=0.0 - endif endif endif segment%field(m)%buffer_dst(:,:,:)=0.0 @@ -5535,8 +5518,6 @@ subroutine rotate_OBC_segment_data(segment_in, segment, turns) endif segment%field(n)%buffer_dst => NULL() - segment%field(n)%bt_vel => NULL() - segment%field(n)%value = segment_in%field(n)%value enddo From e3db1b8d65084021b80425a2aac5f8c0d6ec7d1d Mon Sep 17 00:00:00 2001 From: Andrew Ross Date: Wed, 19 Aug 2020 11:04:35 -0400 Subject: [PATCH 016/336] Include tides in rotation. Currently fails custom rotation tests. --- src/core/MOM_open_boundary.F90 | 17 ++++++++++++++--- 1 file changed, 14 insertions(+), 3 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index e5d28dd62f..0ccde09ecd 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -3901,11 +3901,13 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) 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 + .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 == 'DUDY')) then + .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 @@ -3915,7 +3917,8 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) ! 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') then + .or. segment%field(m)%name == 'DUDY' & + .or. segment%field(m)%name == 'Uamp') then tmp_buffer(:,:,:) = -tmp_buffer(:,:,:) endif endif @@ -5486,8 +5489,16 @@ subroutine rotate_OBC_segment_data(segment_in, segment, turns) 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') From aa648c74ad5d1c72a484eac0a2587924533c4276 Mon Sep 17 00:00:00 2001 From: Andrew Ross Date: Wed, 19 Aug 2020 15:39:01 -0400 Subject: [PATCH 017/336] Rename OBC_N_TIDE_CONSTITUENTS to have tide prefix first --- src/core/MOM_open_boundary.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 0ccde09ecd..4a38aa481c 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -451,7 +451,7 @@ subroutine open_boundary_config(G, US, param_file, OBC) 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_N_TIDE_CONSTITUENTS", OBC%n_tide_constituents, & + 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) From 217df96b401d14f22573f3b044b8f0f10423010c Mon Sep 17 00:00:00 2001 From: Andrew Ross Date: Mon, 24 Aug 2020 10:20:51 -0400 Subject: [PATCH 018/336] Fix bug: nest tidal calculation within loop --- src/core/MOM_open_boundary.F90 | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 4a38aa481c..5e51a060d9 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -4223,14 +4223,14 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) elseif (trim(segment%field(m)%name) == 'U' .and. segment%is_N_or_S .and. & associated(segment%tangential_vel)) then J=js_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_type_to_real(Time) - OBC%time_ref)*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 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_type_to_real(Time) - OBC%time_ref)*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,G%ke segment%tangential_vel(I,J,k) = US%m_s_to_L_T*(segment%field(m)%buffer_dst(I,J,k) + tidal_vel) enddo From 7bfc146d07dd00352dde267b0e70f8230ebdbba4 Mon Sep 17 00:00:00 2001 From: Andrew Ross Date: Tue, 25 Aug 2020 13:31:10 -0400 Subject: [PATCH 019/336] Should default to prev behavior of not using phase correction --- src/parameterizations/lateral/MOM_tidal_forcing.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/parameterizations/lateral/MOM_tidal_forcing.F90 b/src/parameterizations/lateral/MOM_tidal_forcing.F90 index 79bb044cc9..bd0751d127 100644 --- a/src/parameterizations/lateral/MOM_tidal_forcing.F90 +++ b/src/parameterizations/lateral/MOM_tidal_forcing.F90 @@ -382,7 +382,7 @@ subroutine tidal_forcing_init(Time, G, param_file, CS) 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=.true., fail_if_missing=.false.) + default=.false., fail_if_missing=.false.) if (sum(tide_ref_date) == 0) then ! tide_ref_date defaults to 0. CS%time_ref = 0 From 6e6f7b4e999a65a3154671235412fb523ec4251d Mon Sep 17 00:00:00 2001 From: Andrew Ross Date: Tue, 25 Aug 2020 15:18:38 -0400 Subject: [PATCH 020/336] Improve compatibility with code style guide --- src/core/MOM_open_boundary.F90 | 53 ++++++++++++------- .../lateral/MOM_tidal_forcing.F90 | 36 ++++++------- 2 files changed, 52 insertions(+), 37 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 5e51a060d9..dbae82b1b2 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -266,13 +266,16 @@ module MOM_open_boundary !! 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. - real, allocatable, dimension(:) :: tide_frequencies !< Angular frequencies of tidal constituents. - real, allocatable, dimension(:) :: tide_eq_phases, tide_fn, tide_un !< Equilibrium phases and nodal modulation for tidal constituents. - 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. + 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. + real, allocatable, dimension(:) :: tide_frequencies !< Angular frequencies of tidal constituents. + real, allocatable, dimension(:) :: tide_eq_phases, tide_fn, tide_un !< Equilibrium phases and nodal modulation + !! for tidal constituents. + 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. real :: time_ref !< Reference date (t = 0) for tidal forcing. real, dimension(4) :: astro_shpn ! Lunar and solar longitudes used to calculate tidal forcing. ! Properties of the segments used. @@ -364,7 +367,8 @@ subroutine open_boundary_config(G, US, param_file, OBC) character(len=1024) :: segment_str ! The contents (rhs) for parameter "segment_param_str" character(len=200) :: config1 ! String for OBC_USER_CONFIG real :: Lscale_in, Lscale_out ! parameters controlling tracer values at the boundaries [L ~> m] - integer, dimension(3) :: tide_ref_date, nodal_ref_date !< Reference date (t = 0) for tidal forcing and fixed date for nodal modulation. + integer, dimension(3) :: tide_ref_date, nodal_ref_date !< Reference date (t = 0) for tidal forcing + !! and fixed date for nodal modulation. character(len=50) :: tide_constituent_str !< List of tidal constituents to add to boundary. character(len=128) :: inputdir logical :: answers_2018, default_2018_answers @@ -928,7 +932,7 @@ subroutine initialize_segment_data(G, OBC, PF) segment%field(m)%fid = -1 segment%field(m)%value = value segment%field(m)%name = trim(fields(m)) - ! Check if this is a tidal field. If so, the number + ! Check if this is a tidal field. If so, the number ! of expected constiuents 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 .gt. 1 .and. OBC%add_tide_constituents) then @@ -986,7 +990,7 @@ subroutine initialize_obc_tides(OBC, tide_ref_date, nodal_ref_date, tide_constit type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure integer, dimension(3), intent(in) :: tide_ref_date !< Reference date (t = 0) for tidal forcing. integer, dimension(3), intent(in) :: nodal_ref_date !< Date to calculate nodal modulation for. - character(len=50), intent(in) :: tide_constituent_str !< List of tidal constituents to include on boundary. + character(len=50), intent(in) :: tide_constituent_str !< List of tidal constituents to include on boundary. real, dimension(4) :: nodal_shpn !< Solar and lunar longitudes for tidal forcing real :: nodal_time !< Model time to calculate nodal modulation for. integer :: c !< Index to tidal constituent. @@ -3752,6 +3756,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) real :: tidal_vel, tidal_elev real, pointer, dimension(:,:) :: normal_trans_bt=>NULL() ! barotropic transport integer :: turns ! Number of index quarter turns + real :: time_delta ! Time since tidal reference date is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -3762,6 +3767,8 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) if (.not. associated(OBC)) return + if (OBC%add_tide_constituents) time_delta = time_type_to_real(Time) - OBC%time_ref + do n = 1, OBC%number_of_segments segment => OBC%segment(n) @@ -4130,7 +4137,8 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) 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,G%ke)) - elseif (segment%field(m)%name == 'SSH' .or. segment%field(m)%name == 'SSHamp' .or. segment%field(m)%name == 'SSHphase') then + 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,G%ke)) @@ -4146,7 +4154,8 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) 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,G%ke)) - elseif (segment%field(m)%name == 'SSH' .or. segment%field(m)%name == 'SSHamp' .or. segment%field(m)%name == 'SSHphase') then + 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,G%ke)) @@ -4170,7 +4179,8 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) 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_type_to_real(Time) - OBC%time_ref)*OBC%tide_frequencies(c) - segment%field(segment%uphase_index)%buffer_dst(I,j,c) + OBC%tide_eq_phases(c) + OBC%tide_un(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,G%ke @@ -4187,10 +4197,11 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) do i=is_obc+1,ie_obc normal_trans_bt(i,J) = 0.0 tidal_vel = 0.0 - if(OBC%add_tide_constituents) then + 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_type_to_real(Time) - OBC%time_ref)*OBC%tide_frequencies(c) - segment%field(segment%vphase_index)%buffer_dst(I,j,c) + OBC%tide_eq_phases(c) + OBC%tide_un(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,G%ke @@ -4211,7 +4222,8 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) 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_type_to_real(Time) - OBC%time_ref)*OBC%tide_frequencies(c) - segment%field(segment%vphase_index)%buffer_dst(I,j,c) + OBC%tide_eq_phases(c) + OBC%tide_un(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,G%ke @@ -4228,7 +4240,8 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) 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_type_to_real(Time) - OBC%time_ref)*OBC%tide_frequencies(c) - segment%field(segment%uphase_index)%buffer_dst(I,j,c) + OBC%tide_eq_phases(c) + OBC%tide_un(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,G%ke @@ -4287,7 +4300,8 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) 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_type_to_real(Time) - OBC%time_ref)*OBC%tide_frequencies(c) - segment%field(segment%zphase_index)%buffer_dst(i,j,c) + OBC%tide_eq_phases(c) + OBC%tide_un(c)) + cos(time_delta*OBC%tide_frequencies(c) - segment%field(segment%zphase_index)%buffer_dst(i,j,c) & + + OBC%tide_eq_phases(c) + OBC%tide_un(c)) enddo endif segment%eta(i,j) = GV%m_to_H * OBC%ramp_value & @@ -4301,7 +4315,8 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) 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_type_to_real(Time) - OBC%time_ref)*OBC%tide_frequencies(c) - segment%field(segment%zphase_index)%buffer_dst(i,j,c) + OBC%tide_eq_phases(c) + OBC%tide_un(c)) + cos(time_delta*OBC%tide_frequencies(c) - segment%field(segment%zphase_index)%buffer_dst(i,j,c) & + + OBC%tide_eq_phases(c) + OBC%tide_un(c)) enddo endif segment%eta(i,j) = GV%m_to_H * (segment%field(m)%buffer_dst(i,j,1) + tidal_elev) diff --git a/src/parameterizations/lateral/MOM_tidal_forcing.F90 b/src/parameterizations/lateral/MOM_tidal_forcing.F90 index bd0751d127..cce420c944 100644 --- a/src/parameterizations/lateral/MOM_tidal_forcing.F90 +++ b/src/parameterizations/lateral/MOM_tidal_forcing.F90 @@ -77,10 +77,10 @@ module MOM_tidal_forcing !! be at midnight. These formulas also only make sense if !! the calendar is gregorian. subroutine astro_longitudes_init(time_ref, longitudes_shpn) - real, dimension(4), intent(out) :: longitudes_shpn - real, intent(in) :: time_ref - real :: D, T - real, parameter :: PI = 4.0*atan(1.0) ! 3.14159... + real, dimension(4), intent(out) :: longitudes_shpn !> Longitudes s, h, p, N + real, intent(in) :: time_ref !> Time to calculate longitudes for. + real :: D, T !> Date offsets + real, parameter :: PI = 4.0*atan(1.0) !> 3.14159... ! if time_ref is not at midnight, this could be used to round down to nearest day. ! time_ref = time_ref - mod(time_ref, 24.0*3600.0) ! Find date at time_ref in days since 1900-01-01 @@ -88,13 +88,13 @@ subroutine astro_longitudes_init(time_ref, longitudes_shpn) ! Time since 1900-01-01 in Julian centuries T = D / 36525.0 ! s: Mean longitude of moon - longitudes_shpn(1) = 277.0248 + 481267.8906 * T + 0.0011 * (T**2) + longitudes_shpn(1) = (277.0248 + 481267.8906 * T) + 0.0011 * (T**2) ! h: Mean longitude of sun - longitudes_shpn(2) = 280.1895 + 36000.7689 * T + 3.0310e-4 * (T**2) + longitudes_shpn(2) = (280.1895 + 36000.7689 * T) + 3.0310e-4 * (T**2) ! p: Mean longitude of lunar perigee - longitudes_shpn(3) = 334.3853 + 4069.0340 * T - 0.0103 * (T**2) + longitudes_shpn(3) = (334.3853 + 4069.0340 * T) - 0.0103 * (T**2) ! n: Longitude of ascending node - longitudes_shpn(4) = 259.1568 - 1934.142 * T + 0.0021 * (T**2) + longitudes_shpn(4) = (259.1568 - 1934.142 * T) + 0.0021 * (T**2) ! Convert to radians on [0, 2pi) longitudes_shpn = mod(longitudes_shpn, 360.0) * PI / 180.0 end subroutine astro_longitudes_init @@ -104,11 +104,11 @@ end subroutine astro_longitudes_init !! 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, shpn) - character (len=2), intent(in) :: constit !> Name of constituent (e.g., M2). - real, dimension(3), intent(in) :: shpn !> Mean longitudes calculated using astro_longitudes_init - real :: s, h, p !> Longitudes of moon, sun, and lunar perigee. - real, parameter :: PI = 4.0*atan(1.0) !> 3.14159... - real :: eq_phase !> The equilibrium phase argument for the constituent. + character (len=2), intent(in) :: constit !> Name of constituent (e.g., M2). + real, dimension(3), intent(in) :: shpn !> Mean longitudes calculated using astro_longitudes_init + real :: s, h, p !> Longitudes of moon, sun, and lunar perigee. + real, parameter :: PI = 4.0*atan(1.0) !> 3.14159... + real :: eq_phase !> The equilibrium phase argument for the constituent. s = shpn(1) h = shpn(2) @@ -120,17 +120,17 @@ function eq_phase(constit, shpn) case ("S2") eq_phase = 0.0 case ("N2") - eq_phase = - 3 * s + 2 * h + p + eq_phase = (- 3 * s + 2 * h) + p case ("K2") eq_phase = 2 * h case ("K1") eq_phase = h + PI / 2.0 case("O1") - eq_phase = - 2 * s + h - PI / 2.0 + eq_phase = (- 2 * s + h) - PI / 2.0 case ("P1") eq_phase = - h - PI / 2.0 case ("Q1") - eq_phase = - 3 * s + h + p - PI / 2.0 + eq_phase = ((- 3 * s + h) + p) - PI / 2.0 case ("MF") eq_phase = 2 * s case ("MM") @@ -180,8 +180,8 @@ subroutine nodal_fu(constit, N, fn, un) real, intent(in) :: N !> Longitude of ascending node in radians. !! Calculate using astro_longitudes_init. real, parameter :: RADIANS = 4.0 * atan(1.0) / 180.0 !> Converts degrees to radians. - real, intent(out) :: fn, un !> Amplitude (fn, unitless) and phase (un, radians) modulation. - + real, intent(out) :: fn, un !> Amplitude (fn, unitless) and phase + !! (un, radians) modulation. select case (constit) case ("M2") fn = 1.0 - 0.037 * cos(N) From c7f42c8b407656ae794ee839f7805b1e144f65c2 Mon Sep 17 00:00:00 2001 From: Andrew Ross Date: Tue, 25 Aug 2020 16:03:20 -0400 Subject: [PATCH 021/336] Improve code style --- src/core/MOM_open_boundary.F90 | 36 +++++++++++++++++----------------- 1 file changed, 18 insertions(+), 18 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index dbae82b1b2..6d532fb3ec 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -4178,9 +4178,9 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) 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) ) + 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,G%ke @@ -4199,9 +4199,9 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) 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)) + 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,G%ke @@ -4221,9 +4221,9 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) 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)) + 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,G%ke @@ -4239,9 +4239,9 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) 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)) + 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,G%ke @@ -4299,9 +4299,9 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) tidal_elev = 0.0 if(OBC%add_tide_constituents) then do c=1,OBC%n_tide_constituents - tidal_elev = tidal_elev + OBC%tide_fn(c)*segment%field(segment%zamp_index)%buffer_dst(i,j,c) * & - 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)) + 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%eta(i,j) = GV%m_to_H * OBC%ramp_value & @@ -4314,9 +4314,9 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) tidal_elev = 0.0 if(OBC%add_tide_constituents) then do c=1,OBC%n_tide_constituents - tidal_elev = tidal_elev + OBC%tide_fn(c)*segment%field(segment%zamp_index)%buffer_dst(i,j,c) * & - 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)) + 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%eta(i,j) = GV%m_to_H * (segment%field(m)%buffer_dst(i,j,1) + tidal_elev) From 3780b5c5227e43e18d9b495395e141d9d6475cec Mon Sep 17 00:00:00 2001 From: Andrew Ross Date: Thu, 27 Aug 2020 13:44:36 -0400 Subject: [PATCH 022/336] Note minor differences in formula --- src/parameterizations/lateral/MOM_tidal_forcing.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/parameterizations/lateral/MOM_tidal_forcing.F90 b/src/parameterizations/lateral/MOM_tidal_forcing.F90 index cce420c944..65ef4bce0a 100644 --- a/src/parameterizations/lateral/MOM_tidal_forcing.F90 +++ b/src/parameterizations/lateral/MOM_tidal_forcing.F90 @@ -72,7 +72,7 @@ module MOM_tidal_forcing !! 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 is from Schureman, 1958. +!! (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. @@ -86,6 +86,7 @@ subroutine astro_longitudes_init(time_ref, longitudes_shpn) ! Find date at time_ref in days since 1900-01-01 D = (time_ref - time_type_to_real(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 ! s: Mean longitude of moon longitudes_shpn(1) = (277.0248 + 481267.8906 * T) + 0.0011 * (T**2) From 31f40a59037013694e4cf900059829b357a41462 Mon Sep 17 00:00:00 2001 From: Andrew Ross Date: Thu, 27 Aug 2020 13:50:22 -0400 Subject: [PATCH 023/336] Fix typos --- src/parameterizations/lateral/MOM_tidal_forcing.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/parameterizations/lateral/MOM_tidal_forcing.F90 b/src/parameterizations/lateral/MOM_tidal_forcing.F90 index 65ef4bce0a..71062f14c4 100644 --- a/src/parameterizations/lateral/MOM_tidal_forcing.F90 +++ b/src/parameterizations/lateral/MOM_tidal_forcing.F90 @@ -189,7 +189,7 @@ subroutine nodal_fu(constit, N, fn, un) un = -2.1 * RADIANS * sin(N) case ("S2") fn = 1.0 ! Solar S2 has no amplitude modulation. - un = 0.0 ! S2 has no phase mdulation. + un = 0.0 ! S2 has no phase modulation. case ("N2") fn = 1.0 - 0.037 * cos(N) un = -2.1 * RADIANS * sin(N) @@ -204,7 +204,7 @@ subroutine nodal_fu(constit, N, fn, un) un = 10.8 * RADIANS * sin(N) case ("P1") fn = 1.0 ! P1 has no amplitude modulation. - un = 0.0 ! P1 has no phase mdulation. + un = 0.0 ! P1 has no phase modulation. case ("Q1") fn = 1.009 + 0.187 * cos(N) un = 10.8 * RADIANS * sin(N) From bbb6736cf3782629d1414ce259f0f8f7c55f6b77 Mon Sep 17 00:00:00 2001 From: Andrew Ross Date: Fri, 28 Aug 2020 09:53:46 -0400 Subject: [PATCH 024/336] Correct documentation --- src/core/MOM_open_boundary.F90 | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 6d532fb3ec..f157d686a3 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -268,16 +268,17 @@ module MOM_open_boundary 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. - real, allocatable, dimension(:) :: tide_frequencies !< Angular frequencies of tidal constituents. - real, allocatable, dimension(:) :: tide_eq_phases, tide_fn, tide_un !< Equilibrium phases and nodal modulation - !! for tidal constituents. + 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. + real, allocatable, dimension(:) :: tide_eq_phases !< Equilibrium phases of chosen tidal constituents. + real, allocatable, dimension(:) :: tide_fn !< Amplitude modulation of boundary tides by nodal cycle. + real, allocatable, dimension(:) :: tide_un !< Phase modulation of boundary tides by nodal cycle. 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. real :: time_ref !< Reference date (t = 0) for tidal forcing. - real, dimension(4) :: astro_shpn ! Lunar and solar longitudes used to calculate tidal forcing. + real, dimension(4) :: astro_shpn !< Lunar and solar longitudes used to calculate tidal forcing. ! Properties of the segments used. type(OBC_segment_type), pointer, dimension(:) :: & segment => NULL() !< List of segment objects. From 90c5625d0c589eb8956db1a2b0fc2ecc40c8720f Mon Sep 17 00:00:00 2001 From: Andrew Ross Date: Mon, 31 Aug 2020 08:35:00 -0400 Subject: [PATCH 025/336] Fix bug when equilibrium phase correction was not used and nodal reference date was not provided --- src/core/MOM_open_boundary.F90 | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index f157d686a3..13e4e50123 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -1009,10 +1009,16 @@ subroutine initialize_obc_tides(OBC, tide_ref_date, nodal_ref_date, tide_constit ! Otherwise, it can use N from the time reference. if (OBC%add_nodal_terms) then if (sum(nodal_ref_date) .ne. 0) then + ! A reference date was provided for the nodal correction nodal_time = time_type_to_real(set_date(nodal_ref_date(1), nodal_ref_date(2), nodal_ref_date(3))) call astro_longitudes_init(nodal_time, nodal_shpn) - else + elseif (OBC%add_eq_phase) then + ! Astronomical longitudes were already calculated for use in equilibrium phases, + ! so use nodal longitude from that. nodal_shpn = OBC%astro_shpn + else + ! Tidal reference time is a required parameter, so calculate the longitudes from that. + call astro_longitudes_init(OBC%time_ref, nodal_shpn) endif endif From aff69f2d5b56cd34375c9307c13b524bc46eb1f4 Mon Sep 17 00:00:00 2001 From: Andrew Ross Date: Mon, 31 Aug 2020 08:40:55 -0400 Subject: [PATCH 026/336] Fix assorted typos and spaces --- src/core/MOM_open_boundary.F90 | 18 +++++++++--------- .../lateral/MOM_tidal_forcing.F90 | 6 +++--- 2 files changed, 12 insertions(+), 12 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 13e4e50123..dd5b507a7d 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -460,7 +460,7 @@ subroutine open_boundary_config(G, US, param_file, OBC) "Number of tidal constituents being added to the open boundary.", & default=0) - if(OBC%n_tide_constituents > 0) then + if (OBC%n_tide_constituents > 0) then OBC%add_tide_constituents = .true. call get_param(param_file, mdl, "OBC_TIDE_CONSTITUENTS", tide_constituent_str, & "Names of tidal constituents being added to the open boundaries.", & @@ -482,7 +482,7 @@ subroutine open_boundary_config(G, US, param_file, OBC) "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 (.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.') @@ -573,8 +573,8 @@ subroutine open_boundary_config(G, US, param_file, OBC) ! 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 + 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 @@ -4183,7 +4183,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) do j=js_obc+1,je_obc normal_trans_bt(I,j) = 0.0 tidal_vel = 0.0 - if(OBC%add_tide_constituents) then + 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)) & @@ -4226,7 +4226,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) I=is_obc do J=js_obc,je_obc tidal_vel = 0.0 - if(OBC%add_tide_constituents) then + 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)) & @@ -4244,7 +4244,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) J=js_obc do I=is_obc,ie_obc tidal_vel = 0.0 - if(OBC%add_tide_constituents) then + 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)) & @@ -4304,7 +4304,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) do j=js_obc2,je_obc do i=is_obc2,ie_obc tidal_elev = 0.0 - if(OBC%add_tide_constituents) then + 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)) & @@ -4319,7 +4319,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) do j=js_obc2,je_obc do i=is_obc2,ie_obc tidal_elev = 0.0 - if(OBC%add_tide_constituents) then + 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)) & diff --git a/src/parameterizations/lateral/MOM_tidal_forcing.F90 b/src/parameterizations/lateral/MOM_tidal_forcing.F90 index 71062f14c4..934002dfd9 100644 --- a/src/parameterizations/lateral/MOM_tidal_forcing.F90 +++ b/src/parameterizations/lateral/MOM_tidal_forcing.F90 @@ -80,7 +80,7 @@ subroutine astro_longitudes_init(time_ref, longitudes_shpn) real, dimension(4), intent(out) :: longitudes_shpn !> Longitudes s, h, p, N real, intent(in) :: time_ref !> Time to calculate longitudes for. real :: D, T !> Date offsets - real, parameter :: PI = 4.0*atan(1.0) !> 3.14159... + real, parameter :: PI = 4.0 * atan(1.0) !> 3.14159... ! if time_ref is not at midnight, this could be used to round down to nearest day. ! time_ref = time_ref - mod(time_ref, 24.0*3600.0) ! Find date at time_ref in days since 1900-01-01 @@ -108,7 +108,7 @@ function eq_phase(constit, shpn) character (len=2), intent(in) :: constit !> Name of constituent (e.g., M2). real, dimension(3), intent(in) :: shpn !> Mean longitudes calculated using astro_longitudes_init real :: s, h, p !> Longitudes of moon, sun, and lunar perigee. - real, parameter :: PI = 4.0*atan(1.0) !> 3.14159... + real, parameter :: PI = 4.0 * atan(1.0) !> 3.14159... real :: eq_phase !> The equilibrium phase argument for the constituent. s = shpn(1) @@ -126,7 +126,7 @@ function eq_phase(constit, shpn) eq_phase = 2 * h case ("K1") eq_phase = h + PI / 2.0 - case("O1") + case ("O1") eq_phase = (- 2 * s + h) - PI / 2.0 case ("P1") eq_phase = - h - PI / 2.0 From 607ddfc2bfb9db1ba5793492457e3d84548cba0a Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Wed, 9 Sep 2020 13:09:41 -0800 Subject: [PATCH 027/336] Bob's bug fix. --- src/parameterizations/vertical/MOM_set_diffusivity.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 42babae7d8..50e1339d0d 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -2219,6 +2219,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ "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 = .false. if (CS%useKappaShear) CS%Vertex_Shear = kappa_shear_at_vertex(param_file) if (CS%useKappaShear) & From 2ffaa306c83fe9495f9c681a51666d0a486f3495 Mon Sep 17 00:00:00 2001 From: Andrew Ross Date: Thu, 10 Sep 2020 11:26:34 -0400 Subject: [PATCH 028/336] Use time_type for reference times --- src/core/MOM_open_boundary.F90 | 10 +++++----- .../lateral/MOM_tidal_forcing.F90 | 14 ++++++-------- 2 files changed, 11 insertions(+), 13 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index dd5b507a7d..6e851bf278 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -277,7 +277,7 @@ module MOM_open_boundary !! 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. - real :: time_ref !< Reference date (t = 0) for tidal forcing. + type(time_type) :: time_ref !< Reference date (t = 0) for tidal forcing. real, dimension(4) :: astro_shpn !< Lunar and solar longitudes used to calculate tidal forcing. ! Properties of the segments used. type(OBC_segment_type), pointer, dimension(:) :: & @@ -993,14 +993,14 @@ subroutine initialize_obc_tides(OBC, tide_ref_date, nodal_ref_date, tide_constit integer, dimension(3), intent(in) :: nodal_ref_date !< Date to calculate nodal modulation for. character(len=50), intent(in) :: tide_constituent_str !< List of tidal constituents to include on boundary. real, dimension(4) :: nodal_shpn !< Solar and lunar longitudes for tidal forcing - real :: nodal_time !< Model time to calculate nodal modulation for. + type(time_type) :: nodal_time !< Model time to calculate nodal modulation for. integer :: c !< Index to tidal constituent. 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 = time_type_to_real(set_date(tide_ref_date(1), tide_ref_date(2), tide_ref_date(3))) + 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%astro_shpn) @@ -1010,7 +1010,7 @@ subroutine initialize_obc_tides(OBC, tide_ref_date, nodal_ref_date, tide_constit if (OBC%add_nodal_terms) then if (sum(nodal_ref_date) .ne. 0) then ! A reference date was provided for the nodal correction - nodal_time = time_type_to_real(set_date(nodal_ref_date(1), nodal_ref_date(2), nodal_ref_date(3))) + nodal_time = set_date(nodal_ref_date(1), nodal_ref_date(2), nodal_ref_date(3)) call astro_longitudes_init(nodal_time, nodal_shpn) elseif (OBC%add_eq_phase) then ! Astronomical longitudes were already calculated for use in equilibrium phases, @@ -3774,7 +3774,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) if (.not. associated(OBC)) return - if (OBC%add_tide_constituents) time_delta = time_type_to_real(Time) - OBC%time_ref + if (OBC%add_tide_constituents) time_delta = time_type_to_real(Time - OBC%time_ref) do n = 1, OBC%number_of_segments segment => OBC%segment(n) diff --git a/src/parameterizations/lateral/MOM_tidal_forcing.F90 b/src/parameterizations/lateral/MOM_tidal_forcing.F90 index 934002dfd9..1770414e36 100644 --- a/src/parameterizations/lateral/MOM_tidal_forcing.F90 +++ b/src/parameterizations/lateral/MOM_tidal_forcing.F90 @@ -49,7 +49,7 @@ module MOM_tidal_forcing integer :: struct(MAX_CONSTITUENTS) !< An encoded spatial structure for each constituent character (len=16) :: const_name(MAX_CONSTITUENTS) !< The name of each constituent - real :: time_ref !< Reference time (t = 0) used to calculate tidal forcing. + type(time_type) :: time_ref !< Reference time (t = 0) used to calculate tidal forcing. real, dimension(4) :: astro_shpn !< Astronomical longitudes used to calculate !! tidal phases at t = 0. real, pointer, dimension(:,:,:) :: & @@ -78,13 +78,11 @@ module MOM_tidal_forcing !! the calendar is gregorian. subroutine astro_longitudes_init(time_ref, longitudes_shpn) real, dimension(4), intent(out) :: longitudes_shpn !> Longitudes s, h, p, N - real, intent(in) :: time_ref !> Time to calculate longitudes for. + type(time_type), intent(in) :: time_ref !> Time to calculate longitudes for. real :: D, T !> Date offsets real, parameter :: PI = 4.0 * atan(1.0) !> 3.14159... - ! if time_ref is not at midnight, this could be used to round down to nearest day. - ! time_ref = time_ref - mod(time_ref, 24.0*3600.0) ! Find date at time_ref in days since 1900-01-01 - D = (time_ref - time_type_to_real(set_date(1900, 1, 1))) / (24.0 * 3600.0) + 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 @@ -386,7 +384,7 @@ subroutine tidal_forcing_init(Time, G, param_file, CS) default=.false., fail_if_missing=.false.) if (sum(tide_ref_date) == 0) then ! tide_ref_date defaults to 0. - CS%time_ref = 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. @@ -394,7 +392,7 @@ subroutine tidal_forcing_init(Time, G, param_file, CS) ! correctly simulating tidal phases is not desired. call MOM_mesg('Tidal phases will *not* be corrected with equilibrium arguments.') endif - CS%time_ref = time_type_to_real(set_date(tide_ref_date(1), tide_ref_date(2), tide_ref_date(3))) + CS%time_ref = set_date(tide_ref_date(1), tide_ref_date(2), tide_ref_date(3)) endif ! Set the parameters for all components that are in use. ! Initialize reference time for tides and @@ -610,7 +608,7 @@ subroutine calc_tidal_forcing(Time, eta, eta_tidal, G, CS, deta_tidal_deta, m_to return endif - now = time_type_to_real(Time) - cs%time_ref + now = time_type_to_real(Time - cs%time_ref) if (CS%USE_SAL_SCALAR .and. CS%USE_PREV_TIDES) then eta_prop = 2.0*CS%SAL_SCALAR From 3ea831be7d063e9ec248b1b1b6bb723589a92684 Mon Sep 17 00:00:00 2001 From: Andrew Ross Date: Thu, 10 Sep 2020 15:08:21 -0400 Subject: [PATCH 029/336] Move longitudes to own type --- src/core/MOM_open_boundary.F90 | 18 +++--- .../lateral/MOM_tidal_forcing.F90 | 58 ++++++++++--------- 2 files changed, 39 insertions(+), 37 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 6e851bf278..f1f25fc592 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -22,7 +22,7 @@ module MOM_open_boundary use MOM_restart, only : query_initialized, MOM_restart_CS use MOM_obsolete_params, only : obsolete_logical, obsolete_int, obsolete_real, obsolete_char use MOM_string_functions, only : extract_word, remove_spaces -use MOM_tidal_forcing, only : astro_longitudes_init, eq_phase, nodal_fu, tidal_frequency +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 time_interp_external_mod, only : init_external_field, time_interp_external @@ -278,7 +278,7 @@ module MOM_open_boundary 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. - real, dimension(4) :: astro_shpn !< Lunar and solar longitudes used to calculate 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), pointer, dimension(:) :: & segment => NULL() !< List of segment objects. @@ -992,7 +992,7 @@ subroutine initialize_obc_tides(OBC, tide_ref_date, nodal_ref_date, tide_constit integer, dimension(3), intent(in) :: tide_ref_date !< Reference date (t = 0) for tidal forcing. integer, dimension(3), intent(in) :: nodal_ref_date !< Date to calculate nodal modulation for. character(len=50), intent(in) :: tide_constituent_str !< List of tidal constituents to include on boundary. - real, dimension(4) :: nodal_shpn !< Solar and lunar longitudes for tidal forcing + 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. @@ -1003,7 +1003,7 @@ subroutine initialize_obc_tides(OBC, tide_ref_date, nodal_ref_date, tide_constit 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%astro_shpn) + 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. @@ -1011,14 +1011,14 @@ subroutine initialize_obc_tides(OBC, tide_ref_date, nodal_ref_date, tide_constit if (sum(nodal_ref_date) .ne. 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_shpn) + 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_shpn = OBC%astro_shpn + 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_shpn) + call astro_longitudes_init(OBC%time_ref, nodal_longitudes) endif endif @@ -1032,14 +1032,14 @@ subroutine initialize_obc_tides(OBC, tide_ref_date, nodal_ref_date, tide_constit ! Find equilibrum phase if needed if (OBC%add_eq_phase) then - OBC%tide_eq_phases(c) = eq_phase(trim(OBC%tide_names(c)), OBC%astro_shpn) + 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_shpn(4), OBC%tide_fn(c), OBC%tide_un(c)) + 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 diff --git a/src/parameterizations/lateral/MOM_tidal_forcing.F90 b/src/parameterizations/lateral/MOM_tidal_forcing.F90 index 1770414e36..16df374d02 100644 --- a/src/parameterizations/lateral/MOM_tidal_forcing.F90 +++ b/src/parameterizations/lateral/MOM_tidal_forcing.F90 @@ -23,6 +23,14 @@ module MOM_tidal_forcing 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 + h, & !< Mean longitude of sun + p, & !< Mean longitude of lunar perigee + N !< Longitude of ascending node +end type astro_longitudes !> The control structure for the MOM_tidal_forcing module type, public :: tidal_forcing_CS ; private @@ -50,7 +58,7 @@ module MOM_tidal_forcing 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. - real, dimension(4) :: astro_shpn !< Astronomical longitudes used to calculate + type(astro_longitudes) :: tidal_longitudes !< Astronomical longitudes used to calculate !! tidal phases at t = 0. real, pointer, dimension(:,:,:) :: & sin_struct => NULL(), & !< The sine and cosine based structures that can @@ -76,9 +84,9 @@ module MOM_tidal_forcing !! 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_shpn) - real, dimension(4), intent(out) :: longitudes_shpn !> Longitudes s, h, p, N +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. real :: D, T !> Date offsets real, parameter :: PI = 4.0 * atan(1.0) !> 3.14159... ! Find date at time_ref in days since 1900-01-01 @@ -86,54 +94,48 @@ subroutine astro_longitudes_init(time_ref, longitudes_shpn) ! 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_shpn(1) = (277.0248 + 481267.8906 * T) + 0.0011 * (T**2) + longitudes%s = mod((277.0248 + 481267.8906 * T) + 0.0011 * (T**2), 360.0) * PI / 180.0 ! h: Mean longitude of sun - longitudes_shpn(2) = (280.1895 + 36000.7689 * T) + 3.0310e-4 * (T**2) + 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_shpn(3) = (334.3853 + 4069.0340 * T) - 0.0103 * (T**2) + longitudes%p = mod((334.3853 + 4069.0340 * T) - 0.0103 * (T**2), 360.0) * PI / 180.0 ! n: Longitude of ascending node - longitudes_shpn(4) = (259.1568 - 1934.142 * T) + 0.0021 * (T**2) - ! Convert to radians on [0, 2pi) - longitudes_shpn = mod(longitudes_shpn, 360.0) * PI / 180.0 + 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 array of longitudes shpn. +!! 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, shpn) +function eq_phase(constit, longitudes) character (len=2), intent(in) :: constit !> Name of constituent (e.g., M2). - real, dimension(3), intent(in) :: shpn !> Mean longitudes calculated using astro_longitudes_init - real :: s, h, p !> Longitudes of moon, sun, and lunar perigee. + type(astro_longitudes), intent(in) :: longitudes !> Mean longitudes calculated using astro_longitudes_init real, parameter :: PI = 4.0 * atan(1.0) !> 3.14159... real :: eq_phase !> The equilibrium phase argument for the constituent. - s = shpn(1) - h = shpn(2) - p = shpn(3) - select case (constit) case ("M2") - eq_phase = 2 * (h - s) + eq_phase = 2 * (longitudes%h - longitudes%s) case ("S2") eq_phase = 0.0 case ("N2") - eq_phase = (- 3 * s + 2 * h) + p + eq_phase = (- 3 * longitudes%s + 2 * longitudes%h) + longitudes%p case ("K2") - eq_phase = 2 * h + eq_phase = 2 * longitudes%h case ("K1") - eq_phase = h + PI / 2.0 + eq_phase = longitudes%h + PI / 2.0 case ("O1") - eq_phase = (- 2 * s + h) - PI / 2.0 + eq_phase = (- 2 * longitudes%s + longitudes%h) - PI / 2.0 case ("P1") - eq_phase = - h - PI / 2.0 + eq_phase = - longitudes%h - PI / 2.0 case ("Q1") - eq_phase = ((- 3 * s + h) + p) - PI / 2.0 + eq_phase = ((- 3 * longitudes%s + longitudes%h) + longitudes%p) - PI / 2.0 case ("MF") - eq_phase = 2 * s + eq_phase = 2 * longitudes%s case ("MM") - eq_phase = s - p + eq_phase = longitudes%s - longitudes%p case default call MOM_error(FATAL, "eq_phase: unrecognized constituent") end select @@ -397,7 +399,7 @@ subroutine tidal_forcing_init(Time, G, param_file, CS) ! Set the parameters for all components that are in use. ! 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%astro_shpn) + if (CS%use_eq_phase) call astro_longitudes_init(CS%time_ref, CS%tidal_longitudes) c=0 if (use_M2) then c=c+1 ; CS%const_name(c) = "M2" ; CS%struct(c) = 2 @@ -458,7 +460,7 @@ subroutine tidal_forcing_init(Time, G, param_file, CS) amp_def(c) = CS%amp(c) CS%phase0(c) = 0.0 if (CS%use_eq_phase) then - phase0_def(c) = eq_phase(CS%const_name(c), CS%astro_shpn) + phase0_def(c) = eq_phase(CS%const_name(c), CS%tidal_longitudes) else phase0_def(c) = 0.0 endif From b3ac7972c166791b7275450a45c89e7411de9c6a Mon Sep 17 00:00:00 2001 From: Andrew Ross Date: Thu, 10 Sep 2020 17:01:49 -0400 Subject: [PATCH 030/336] Document some units --- src/core/MOM_open_boundary.F90 | 14 +++++++------- .../lateral/MOM_tidal_forcing.F90 | 19 ++++++++++--------- 2 files changed, 17 insertions(+), 16 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index f1f25fc592..de4f980048 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -269,16 +269,16 @@ module MOM_open_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. - real, allocatable, dimension(:) :: tide_eq_phases !< Equilibrium phases of chosen tidal constituents. - real, allocatable, dimension(:) :: tide_fn !< Amplitude modulation of boundary tides by nodal cycle. - real, allocatable, dimension(:) :: tide_un !< Phase modulation of boundary tides by nodal cycle. + real, allocatable, dimension(:) :: tide_frequencies !< Angular frequencies of chosen tidal constituents [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. + type(astro_longitudes) :: tidal_longitudes !< Lunar and solar longitudes used to calculate tidal forcing. ! Properties of the segments used. type(OBC_segment_type), pointer, dimension(:) :: & segment => NULL() !< List of segment objects. @@ -992,8 +992,8 @@ subroutine initialize_obc_tides(OBC, tide_ref_date, nodal_ref_date, tide_constit integer, dimension(3), intent(in) :: tide_ref_date !< Reference date (t = 0) for tidal forcing. integer, dimension(3), intent(in) :: nodal_ref_date !< Date to calculate nodal modulation for. character(len=50), intent(in) :: 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. + 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. allocate(OBC%tide_names(OBC%n_tide_constituents)) diff --git a/src/parameterizations/lateral/MOM_tidal_forcing.F90 b/src/parameterizations/lateral/MOM_tidal_forcing.F90 index 16df374d02..2907d8dd30 100644 --- a/src/parameterizations/lateral/MOM_tidal_forcing.F90 +++ b/src/parameterizations/lateral/MOM_tidal_forcing.F90 @@ -26,10 +26,10 @@ module MOM_tidal_forcing !> Simple type to store astronomical longitudes used to calculate tidal phases. type, public :: astro_longitudes real :: & - s, & !< Mean longitude of moon - h, & !< Mean longitude of sun - p, & !< Mean longitude of lunar perigee - N !< Longitude of ascending node + s, & !< Mean longitude of moon [rad] + h, & !< Mean longitude of sun [rad] + p, & !< Mean longitude of lunar perigee [rad] + N !< Longitude of ascending node [rad] end type astro_longitudes !> The control structure for the MOM_tidal_forcing module @@ -113,7 +113,7 @@ 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... - real :: eq_phase !> The equilibrium phase argument for the constituent. + real :: eq_phase !> The equilibrium phase argument for the constituent [rad]. select case (constit) case ("M2") @@ -145,7 +145,7 @@ end function eq_phase !! 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}) + real :: tidal_frequency !> Angular frequency [s-1] select case (constit) case ("M2") @@ -178,11 +178,12 @@ end function tidal_frequency !! "Modern Theory and Practice of Tide Analysis and Tidal Power", 2019. subroutine nodal_fu(constit, N, fn, un) character (len=2), intent(in) :: constit !> Tidal constituent to find modulation for. - real, intent(in) :: N !> Longitude of ascending node in radians. + real, intent(in) :: N !> Longitude of ascending node [rad]. !! Calculate using astro_longitudes_init. real, parameter :: RADIANS = 4.0 * atan(1.0) / 180.0 !> Converts degrees to radians. - real, intent(out) :: fn, un !> Amplitude (fn, unitless) and phase - !! (un, radians) modulation. + real, intent(out) :: & + fn, & !> Amplitude modulation [nondim] + un !> Phase modulation [rad] select case (constit) case ("M2") fn = 1.0 - 0.037 * cos(N) From 1db8ec50fedd4cbd757c9aba254a49737de1c423 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Tue, 22 Sep 2020 10:26:14 -0400 Subject: [PATCH 031/336] Autoconf: 2.63 support Additional changes were made to support older Autoconf versions (at least as far back as 2.63). * AC_FC_LINE_LENGTH, added in 2.67, was backported * AC_OPENMP, bugged for Fortran until 2.69, tests against the C flag Version restrictions are now explicit (2.63) and This may work with 2.62, when the m4_version_change macro was introduced, but I have not yet tested it. The Cray pointer macro's cache variable was also renamed. --- ac/configure.ac | 19 +++++- ac/deps/configure.fms.ac | 38 +++++++++--- ac/deps/m4/ax_fc_cray_pointer.m4 | 18 +++--- ac/deps/m4/ax_fc_line_length.m4 | 101 +++++++++++++++++++++++++++++++ 4 files changed, 155 insertions(+), 21 deletions(-) create mode 100644 ac/deps/m4/ax_fc_line_length.m4 diff --git a/ac/configure.ac b/ac/configure.ac index ee6b76dacb..9ed6584e92 100644 --- a/ac/configure.ac +++ b/ac/configure.ac @@ -8,6 +8,8 @@ # - We would probably run this inside of a script to avoid the explicit # dependency on git. +AC_PREREQ([2.63]) + AC_INIT( [MOM6], [ ], @@ -102,11 +104,22 @@ AS_IF( # OpenMP configuration + +# NOTE: AC_OPENMP fails on `Fortran` for Autoconf <2.69 due to a m4 bug. +# For older versions, we test against CC and use the result for FC. +m4_version_prereq([2.69], [], [AC_LANG_PUSH([C])]) AC_OPENMP +m4_version_prereq([2.69], [], [ + AC_LANG_POP([C]) + OPENMP_FCFLAGS="$OPENMP_CFLAGS" +]) + +# NOTE: Only apply OpenMP flags if explicitly enabled. AS_IF( - [test "$enable_openmp" = yes], - [FCFLAGS="$FCFLAGS $OPENMP_FCFLAGS" - LDFLAGS="$LDFLAGS $OPENMP_FCFLAGS"]) + [test "$enable_openmp" = yes], [ + FCFLAGS="$FCFLAGS $OPENMP_FCFLAGS" + LDFLAGS="$LDFLAGS $OPENMP_FCFLAGS" +]) # FMS support diff --git a/ac/deps/configure.fms.ac b/ac/deps/configure.fms.ac index 1d66194c81..1f94caca44 100644 --- a/ac/deps/configure.fms.ac +++ b/ac/deps/configure.fms.ac @@ -1,4 +1,6 @@ # Autoconf configuration +AC_PREREQ([2.63]) + AC_INIT( [FMS], [ ], @@ -15,11 +17,11 @@ CC=$MPICC # FMS configuration -# Linux and OSX have a gettid system call, but it is not implemented in older +# Linux and macOS have a gettid system call, but it is not implemented in older # glibc implementations. When unavailable, a native syscall is used. # # On Linux, this is defined in unistd.h as __NR_gettid, and FMS is hard-coded -# to use this value. In OS X, this is defined in sys/syscall.h as SYS_gettid, +# to use this value. In macOS, this is defined in sys/syscall.h as SYS_gettid, # so we override this macro if __NR_gettid is unavailable. AC_CHECK_FUNCS([gettid], [], [ AC_MSG_CHECKING([if __NR_gettid must be redefined]) @@ -98,15 +100,31 @@ AS_IF( # OpenMP configuration + +# NOTE: AC_OPENMP fails in Autoconf <2.69 when LANG is Fortran or Fortran 77. +# For older versions, we test against CC and use the result for FC. +m4_version_prereq([2.69], [], [AC_LANG_PUSH([C])]) AC_OPENMP +m4_version_prereq([2.69], [], [ + AC_LANG_POP([C]) + OPENMP_FCFLAGS="$OPENMP_CFLAGS" +]) + +# NOTE: Only apply OpenMP flags if explicitly enabled. AS_IF( - [test "$enable_openmp" = yes], - [FCFLAGS="$FCFLAGS $OPENMP_FCFLAGS" - LDFLAGS="$LDFLAGS $OPENMP_FCFLAGS"]) + [test "$enable_openmp" = yes], [ + FCFLAGS="$FCFLAGS $OPENMP_FCFLAGS" + LDFLAGS="$LDFLAGS $OPENMP_FCFLAGS" +]) -# Unlimited line length -AC_FC_LINE_LENGTH([unlimited]) +# Unlimited line length (2.67) +# AC_FC_LINE_LENGTH was added in 2.67. +m4_version_prereq([2.67], + [AC_FC_LINE_LENGTH([unlimited])], + [AX_FC_LINE_LENGTH([unlimited])] +) + # Allow invaliz BOZ assignment AX_FC_ALLOW_INVALID_BOZ @@ -141,12 +159,14 @@ AS_IF([test -z "$MKMF"], [ # MKMF commands AC_CONFIG_COMMANDS([path_names], [${LIST_PATHS} -l ${srcdir}], - [LIST_PATHS=${LIST_PATHS}]) + [LIST_PATHS=${LIST_PATHS}] +) AC_CONFIG_COMMANDS([mkmf], [${MKMF} -p libFMS.a -m Makefile.mkmf path_names], - [MKMF=${MKMF}]) + [MKMF=${MKMF}] +) # Prepare output diff --git a/ac/deps/m4/ax_fc_cray_pointer.m4 b/ac/deps/m4/ax_fc_cray_pointer.m4 index a9f5d9bbe3..57ed186afa 100644 --- a/ac/deps/m4/ax_fc_cray_pointer.m4 +++ b/ac/deps/m4/ax_fc_cray_pointer.m4 @@ -19,8 +19,8 @@ dnl AC_DEFUN([AX_FC_CRAY_POINTER], [ AC_LANG_ASSERT([Fortran]) AC_MSG_CHECKING([for $FC option to support Cray pointers]) - AC_CACHE_VAL([ac_cv_prog_fc_cray_ptr], [ - ac_cv_prog_fc_cray_ptr='unknown' + AC_CACHE_VAL([ac_cv_fc_cray_ptr], [ + ac_cv_fc_cray_ptr='unknown' ac_save_FCFLAGS=$FCFLAGS for ac_option in none -fcray-pointer -Mcray=pointer; do test "$ac_option" != none && FCFLAGS="$ac_save_FCFLAGS $ac_option" @@ -29,21 +29,21 @@ AC_DEFUN([AX_FC_CRAY_POINTER], [ integer aptr(2) pointer (iptr, aptr) ])], - [ac_cv_prog_fc_cray_ptr=$ac_option], + [ac_cv_fc_cray_ptr=$ac_option], ) FCFLAGS=$ac_save_FCFLAGS - AS_IF([test "$ac_cv_prog_fc_cray_ptr" != unknown], [break]) + AS_IF([test "$ac_cv_fc_cray_ptr" != unknown], [break]) done ]) - AS_CASE([ac_cv_prog_fc_cray_ptr], + AS_CASE([ac_cv_fc_cray_ptr], [none], [AC_MSG_RESULT([none_needed])], [unknown], [AC_MSG_RESULT([unsupported])], - [AC_MSG_RESULT([$ac_cv_prog_fc_cray_ptr])] + [AC_MSG_RESULT([$ac_cv_fc_cray_ptr])] ) - AS_IF([test "$ac_cv_prog_fc_cray_ptr" != unknown], [ + AS_IF([test "$ac_cv_fc_cray_ptr" != unknown], [ m4_default([$1], [ - AS_IF([test "$ac_cv_prog_fc_cray_ptr" != none], - [FCFLAGS="$FCFLAGS $ac_cv_prog_fc_cray_ptr"] + AS_IF([test "$ac_cv_fc_cray_ptr" != none], + [FCFLAGS="$FCFLAGS $ac_cv_fc_cray_ptr"] ) ])], [m4_default([$2], [AC_MSG_ERROR(["$FC does not support Cray pointers"])])] diff --git a/ac/deps/m4/ax_fc_line_length.m4 b/ac/deps/m4/ax_fc_line_length.m4 new file mode 100644 index 0000000000..97271da1f6 --- /dev/null +++ b/ac/deps/m4/ax_fc_line_length.m4 @@ -0,0 +1,101 @@ +# AX_FC_LINE_LENGTH([LENGTH], [ACTION-IF-SUCCESS], +# [ACTION-IF-FAILURE = FAILURE]) +# ------------------------------------------------ +# This is a backport of the AC_FC_LINE_LENGTH macro in Autoconf 2.67 and newer. +# Comments below are from the Autoconf 2.69 implementation. +# +# Look for a compiler flag to make the Fortran (FC) compiler accept long lines +# in the current (free- or fixed-format) source code, and adds it to FCFLAGS. +# The optional LENGTH may be 80, 132 (default), or `unlimited' for longer +# lines. Note that line lengths above 250 columns are not portable, and some +# compilers (hello ifort) do not accept more than 132 columns at least for +# fixed format. Call ACTION-IF-SUCCESS (defaults to nothing) if successful +# (i.e. can compile code using new extension) and ACTION-IF-FAILURE (defaults +# to failing with an error message) if not. (Defined via DEFUN_ONCE to +# prevent flag from being added to FCFLAGS multiple times.) +# You should call AC_FC_FREEFORM or AC_FC_FIXEDFORM to set the desired format +# prior to using this macro. +# +# The known flags are: +# -f{free,fixed}-line-length-N with N 72, 80, 132, or 0 or none for none. +# -ffree-line-length-none: GNU gfortran +# -ffree-line-length-huge: g95 (also -ffixed-line-length-N as above) +# -qfixed=132 80 72: IBM compiler (xlf) +# -Mextend: Cray +# -132 -80 -72: Intel compiler (ifort) +# Needs to come before -extend_source because ifort +# accepts that as well with an optional parameter and +# doesn't fail but only warns about unknown arguments. +# -extend_source: SGI compiler +# -W, -WNN (132, 80, 72): Absoft Fortran +# +es, +extend_source: HP Fortran (254 in either form, default is 72 fixed, +# 132 free) +# -w, (-)-wide: Lahey/Fujitsu Fortran (255 cols in fixed form) +# -e: Sun Fortran compiler (132 characters) +# -132: NAGWare +# -72, -f, -Wf,-f: f2c (a weak form of "free-form" and long lines). +# /XLine: Open Watcom + +AC_DEFUN_ONCE([AX_FC_LINE_LENGTH], [ + AC_LANG_ASSERT([Fortran]) + m4_case(m4_default([$1], [132]), + [unlimited], [ + ac_fc_line_len_string=unlimited + ac_fc_line_len=0 + ac_fc_line_length_test=' + subroutine longer_than_132(arg1,arg2,arg3,arg4,arg5,arg6,arg7,arg8,'\ +'arg9,arg10,arg11,arg12,arg13,arg14,arg15,arg16,arg17,arg18,arg19)' + ], + [132], [ + ac_fc_line_len=132 + ac_fc_line_length_test=' + subroutine longer_than_80(arg1,arg2,arg3,arg4,arg5,arg6,arg7,arg8,arg9,'\ +'arg10)' + ], + [80], [ + ac_fc_line_len=80 + ac_fc_line_length_test=' + subroutine longer_than_72(arg1,arg2,arg3,arg4,arg5,arg6,arg7,arg8,arg9)' + ], + [m4_warning([Invalid length argument `$1'])] + ) + : ${ac_fc_line_len_string=$ac_fc_line_len} + AC_MSG_CHECKING([for Fortran flag needed to accept $ac_fc_line_len_string column source lines]) + AC_CACHE_VAL([ac_cv_fc_line_length], [ + ac_cv_fc_line_length=unknown + ac_save_FCFLAGS=$FCFLAGS + for ac_flag in none \ + -ffree-line-length-none \ + -ffixed-line-length-none \ + -ffree-line-length-huge \ + -ffree-line-length-$ac_fc_line_len \ + -ffixed-line-length-$ac_fc_line_len \ + -qfixed=$ac_fc_line_len \ + -Mextend \ + -$ac_fc_line_len \ + -extend_source \ + -W$ac_fc_line_len \ + -W +extend_source +es -wide --wide -w -e -f -Wf,-f -xline + do + test "$ac_flag" != none && FCFLAGS="$ac_save_FCFLAGS $ac_flag" + AC_COMPILE_IFELSE([$ac_fc_line_length_test + end subroutine + ], [ac_cv_fc_line_length=$ac_flag] + ) + FCFLAGS=$ac_save_FCFLAGS + dnl TODO: Remove conftest.{err,$ac_objext,$ac_ext} ?? + AS_IF([test "$ac_cv_fc_line_length" != unknown], [break]) + done + ]) + AC_MSG_RESULT([$ac_cv_fc_line_length]) + AS_IF([test "$ac_cv_fc_line_length" != unknown], [ + m4_default([$2], [ + AS_IF([test "$ac_cv_fc_line_length" != none], [ + FCFLAGS="$FCFLAGS $ac_cv_fc_line_length" + ]) + ])], [ + m4_default([$3], [ + AC_MSG_ERROR([Fortran does not accept long source lines], 77) + ]) + ]) +]) From e782c42bf889a630742a300041b00a5a52a7b224 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Tue, 22 Sep 2020 11:01:48 -0400 Subject: [PATCH 032/336] Autoconf cleanup Reduced two m4 version conditionals into a single block. --- ac/configure.ac | 6 +++--- ac/deps/configure.fms.ac | 6 +++--- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/ac/configure.ac b/ac/configure.ac index 9ed6584e92..8b59fad071 100644 --- a/ac/configure.ac +++ b/ac/configure.ac @@ -107,9 +107,9 @@ AS_IF( # NOTE: AC_OPENMP fails on `Fortran` for Autoconf <2.69 due to a m4 bug. # For older versions, we test against CC and use the result for FC. -m4_version_prereq([2.69], [], [AC_LANG_PUSH([C])]) -AC_OPENMP -m4_version_prereq([2.69], [], [ +m4_version_prereq([2.69], [AC_OPENMP], [ + AC_LANG_PUSH([C]) + AC_OPENMP AC_LANG_POP([C]) OPENMP_FCFLAGS="$OPENMP_CFLAGS" ]) diff --git a/ac/deps/configure.fms.ac b/ac/deps/configure.fms.ac index 1f94caca44..579b191bc7 100644 --- a/ac/deps/configure.fms.ac +++ b/ac/deps/configure.fms.ac @@ -103,9 +103,9 @@ AS_IF( # NOTE: AC_OPENMP fails in Autoconf <2.69 when LANG is Fortran or Fortran 77. # For older versions, we test against CC and use the result for FC. -m4_version_prereq([2.69], [], [AC_LANG_PUSH([C])]) -AC_OPENMP -m4_version_prereq([2.69], [], [ +m4_version_prereq([2.69], [AC_OPENMP], [ + AC_LANG_PUSH([C]) + AC_OPENMP AC_LANG_POP([C]) OPENMP_FCFLAGS="$OPENMP_CFLAGS" ]) From 45991b7025a1fe581df58d68b451acb4e9a3f558 Mon Sep 17 00:00:00 2001 From: "brandon.reichl" Date: Thu, 24 Sep 2020 10:24:36 -0400 Subject: [PATCH 033/336] Merge w/ dev/gfdl, 2 minor conflicts. --- .codecov.yml | 5 + .gitignore | 18 +- .gitlab-ci.yml | 8 +- .gitmodules | 6 - .testing/.gitignore | 9 +- .testing/Makefile | 506 +++- .testing/README.md | 223 +- .testing/linux-ubuntu-xenial-gnu.mk | 279 -- .testing/tc0/MOM_input | 10 + .testing/tc1.a/MOM_tc_variant | 1 + .testing/tc1.b/MOM_tc_variant | 1 + .testing/tc1/MOM_input | 13 + .testing/tc2/MOM_input | 20 + .testing/tc3/MOM_input | 9 + .testing/tc4/.gitignore | 4 + .testing/tc4/MOM_input | 20 +- .testing/tc4/Makefile | 7 +- .travis.yml | 67 +- README.md | 16 +- ac/Makefile.in | 78 + ac/README.md | 187 ++ ac/configure.ac | 174 ++ ac/deps/.gitignore | 5 + ac/deps/Makefile | 106 + ac/deps/Makefile.fms.in | 48 + ac/deps/configure.fms.ac | 155 + ac/deps/m4/ax_fc_allow_arg_mismatch.m4 | 58 + ac/deps/m4/ax_fc_allow_invalid_boz.m4 | 54 + ac/deps/m4/ax_fc_check_lib.m4 | 52 + ac/deps/m4/ax_fc_check_module.m4 | 28 + ac/deps/m4/ax_fc_cray_pointer.m4 | 51 + ac/deps/m4/ax_fc_real8.m4 | 86 + ac/deps/m4/ax_mpi.m4 | 176 ++ ac/m4/ax_fc_check_lib.m4 | 52 + ac/m4/ax_fc_check_module.m4 | 28 + ac/m4/ax_fc_real8.m4 | 86 + ac/m4/ax_mpi.m4 | 176 ++ .../MOM_surface_forcing_gfdl.F90 | 134 +- config_src/coupled_driver/ocean_model_MOM.F90 | 119 +- .../GFDL_ocean_BGC/FMS_coupler_util.F90 | 35 + config_src/external/GFDL_ocean_BGC/README.md | 6 + .../GFDL_ocean_BGC/generic_tracer.F90 | 130 + .../GFDL_ocean_BGC/generic_tracer_utils.F90 | 284 ++ config_src/external/ODA_hooks/README.md | 9 + config_src/external/ODA_hooks/kdtree.f90 | 12 + .../external/ODA_hooks/ocean_da_core.F90 | 47 + .../external/ODA_hooks/ocean_da_types.F90 | 85 + .../external/ODA_hooks/write_ocean_obs.F90 | 50 + config_src/external/README.md | 10 + .../ice_solo_driver/MOM_surface_forcing.F90 | 1204 -------- .../ice_solo_driver/ice_shelf_driver.F90 | 397 +-- .../ice_solo_driver/user_surface_forcing.F90 | 340 --- config_src/mct_driver/mom_ocean_model_mct.F90 | 129 +- .../mct_driver/mom_surface_forcing_mct.F90 | 94 +- config_src/mct_driver/ocn_comp_mct.F90 | 44 +- config_src/nuopc_driver/mom_cap.F90 | 515 ++-- .../nuopc_driver/mom_ocean_model_nuopc.F90 | 34 +- .../mom_surface_forcing_nuopc.F90 | 85 +- .../solo_driver/MESO_surface_forcing.F90 | 20 +- config_src/solo_driver/MOM_driver.F90 | 28 +- .../solo_driver/MOM_surface_forcing.F90 | 193 +- .../solo_driver/Neverland_surface_forcing.F90 | 272 -- .../solo_driver/user_surface_forcing.F90 | 13 +- docs/Doxyfile_nortd | 4 +- docs/Doxyfile_rtd | 4 +- pkg/MOM6_DA_hooks | 1 - pkg/geoKdTree | 1 - src/ALE/MOM_ALE.F90 | 111 +- src/ALE/MOM_regridding.F90 | 103 +- src/ALE/MOM_remapping.F90 | 31 +- src/ALE/P1M_functions.F90 | 40 +- src/ALE/P3M_functions.F90 | 54 +- src/ALE/PCM_functions.F90 | 6 +- src/ALE/PLM_functions.F90 | 358 ++- src/ALE/PPM_functions.F90 | 48 +- src/ALE/PQM_functions.F90 | 88 +- src/ALE/coord_adapt.F90 | 67 +- src/ALE/coord_hycom.F90 | 11 +- src/ALE/coord_rho.F90 | 24 +- src/ALE/coord_slight.F90 | 65 +- src/ALE/regrid_interp.F90 | 14 +- src/core/MOM.F90 | 665 +++-- src/core/MOM_CoriolisAdv.F90 | 156 +- src/core/MOM_PressureForce.F90 | 54 +- ...alytic_FV.F90 => MOM_PressureForce_FV.F90} | 378 +-- src/core/MOM_PressureForce_Montgomery.F90 | 157 +- src/core/MOM_PressureForce_blocked_AFV.F90 | 879 ------ src/core/MOM_barotropic.F90 | 1186 +++++--- src/core/MOM_checksum_packages.F90 | 75 +- src/core/MOM_continuity.F90 | 5 +- src/core/MOM_continuity_PPM.F90 | 109 +- src/core/MOM_density_integrals.F90 | 1655 +++++++++++ src/core/MOM_dynamics_split_RK2.F90 | 256 +- src/core/MOM_dynamics_unsplit.F90 | 63 +- src/core/MOM_dynamics_unsplit_RK2.F90 | 46 +- src/core/MOM_forcing_type.F90 | 543 +++- src/core/MOM_grid.F90 | 5 +- src/core/MOM_interface_heights.F90 | 41 +- src/core/MOM_isopycnal_slopes.F90 | 105 +- src/core/MOM_open_boundary.F90 | 930 ++++-- src/core/MOM_transcribe_grid.F90 | 92 +- src/core/MOM_variables.F90 | 124 +- src/core/MOM_verticalGrid.F90 | 14 +- src/diagnostics/MOM_PointAccel.F90 | 8 +- src/diagnostics/MOM_debugging.F90 | 26 +- src/diagnostics/MOM_diagnostics.F90 | 229 +- src/diagnostics/MOM_obsolete_params.F90 | 169 +- src/diagnostics/MOM_sum_output.F90 | 180 +- src/diagnostics/MOM_wave_speed.F90 | 745 +++-- src/diagnostics/MOM_wave_structure.F90 | 31 +- src/equation_of_state/MOM_EOS.F90 | 2620 ++++++----------- src/equation_of_state/MOM_EOS_Wright.F90 | 188 +- src/equation_of_state/MOM_EOS_linear.F90 | 137 +- .../gsw_chem_potential_water_t_exact.f90 | 83 +- .../TEOS10/gsw_ct_freezing_exact.f90 | 44 +- .../TEOS10/gsw_ct_freezing_poly.f90 | 54 +- .../TEOS10/gsw_ct_from_pt.f90 | 53 +- .../TEOS10/gsw_ct_from_t.f90 | 33 +- .../TEOS10/gsw_entropy_part.f90 | 63 +- .../TEOS10/gsw_entropy_part_zerop.f90 | 45 +- src/equation_of_state/TEOS10/gsw_gibbs.f90 | 318 +- .../TEOS10/gsw_gibbs_ice.f90 | 131 +- .../TEOS10/gsw_gibbs_pt0_pt0.f90 | 48 +- .../gsw_mod_freezing_poly_coefficients.f90 | 64 +- .../TEOS10/gsw_mod_gibbs_ice_coefficients.f90 | 31 +- .../TEOS10/gsw_mod_kinds.f90 | 17 +- .../TEOS10/gsw_mod_specvol_coefficients.f90 | 314 +- .../TEOS10/gsw_mod_teos10_constants.f90 | 72 +- .../TEOS10/gsw_mod_toolbox.f90 | 1494 +--------- .../TEOS10/gsw_pt0_from_t.f90 | 60 +- .../TEOS10/gsw_pt_from_ct.f90 | 73 +- .../TEOS10/gsw_pt_from_t.f90 | 62 +- src/equation_of_state/TEOS10/gsw_rho.f90 | 37 +- .../TEOS10/gsw_rho_first_derivatives.f90 | 111 +- .../TEOS10/gsw_rho_second_derivatives.f90 | 79 +- .../TEOS10/gsw_sp_from_sr.f90 | 31 +- src/equation_of_state/TEOS10/gsw_specvol.f90 | 53 +- .../TEOS10/gsw_specvol_first_derivatives.f90 | 105 +- .../TEOS10/gsw_specvol_second_derivatives.f90 | 132 +- .../TEOS10/gsw_sr_from_sp.f90 | 31 +- ...w_t_deriv_chem_potential_water_t_exact.f90 | 89 +- .../TEOS10/gsw_t_freezing_exact.f90 | 72 +- .../TEOS10/gsw_t_freezing_poly.f90 | 79 +- .../TEOS10/gsw_t_from_ct.f90 | 34 +- src/framework/MOM_array_transform.F90 | 358 +++ src/framework/MOM_checksums.F90 | 492 +++- src/framework/MOM_coms.F90 | 331 ++- src/framework/MOM_cpu_clock.F90 | 26 +- src/framework/MOM_diag_mediator.F90 | 161 +- src/framework/MOM_diag_remap.F90 | 146 +- src/framework/MOM_diag_vkernels.F90 | 28 +- src/framework/MOM_document.F90 | 96 +- src/framework/MOM_domains.F90 | 214 +- src/framework/MOM_dyn_horgrid.F90 | 2 +- src/framework/MOM_file_parser.F90 | 77 +- src/framework/MOM_get_input.F90 | 6 +- src/framework/MOM_hor_index.F90 | 55 +- src/framework/MOM_horizontal_regridding.F90 | 193 +- src/framework/MOM_random.F90 | 19 +- src/framework/MOM_restart.F90 | 143 +- src/framework/MOM_spatial_means.F90 | 42 +- src/framework/MOM_string_functions.F90 | 27 +- src/framework/MOM_transform_FMS.F90 | 405 +++ src/framework/MOM_unit_scaling.F90 | 78 +- src/framework/MOM_write_cputime.F90 | 64 +- src/framework/_Diagnostics.dox | 5 +- src/ice_shelf/MOM_ice_shelf.F90 | 232 +- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 1 + src/ice_shelf/MOM_ice_shelf_state.F90 | 1 - src/ice_shelf/MOM_marine_ice.F90 | 34 +- .../MOM_coord_initialization.F90 | 190 +- .../MOM_fixed_initialization.F90 | 11 +- src/initialization/MOM_grid_initialize.F90 | 8 +- .../MOM_shared_initialization.F90 | 5 +- .../MOM_state_initialization.F90 | 391 ++- .../MOM_tracer_initialization_from_Z.F90 | 4 +- src/ocean_data_assim/MOM_oda_driver.F90 | 29 +- src/ocean_data_assim/core | 1 - src/ocean_data_assim/geoKdTree | 1 - src/parameterizations/lateral/MOM_MEKE.F90 | 18 +- .../lateral/MOM_hor_visc.F90 | 402 +-- .../lateral/MOM_internal_tides.F90 | 299 +- .../lateral/MOM_lateral_mixing_coeffs.F90 | 197 +- .../lateral/MOM_mixed_layer_restrat.F90 | 59 +- .../lateral/MOM_thickness_diffuse.F90 | 161 +- .../vertical/MOM_ALE_sponge.F90 | 225 +- .../vertical/MOM_CVMix_KPP.F90 | 241 +- .../vertical/MOM_CVMix_conv.F90 | 41 +- .../vertical/MOM_CVMix_ddiff.F90 | 41 +- .../vertical/MOM_CVMix_shear.F90 | 69 +- .../vertical/MOM_bkgnd_mixing.F90 | 6 +- .../vertical/MOM_bulk_mixed_layer.F90 | 39 +- .../vertical/MOM_diabatic_aux.F90 | 233 +- .../vertical/MOM_diabatic_driver.F90 | 109 +- .../vertical/MOM_diapyc_energy_req.F90 | 121 +- .../vertical/MOM_energetic_PBL.F90 | 147 +- .../vertical/MOM_entrain_diffusive.F90 | 102 +- .../vertical/MOM_full_convection.F90 | 23 +- .../vertical/MOM_geothermal.F90 | 12 +- .../vertical/MOM_internal_tide_input.F90 | 18 +- .../vertical/MOM_kappa_shear.F90 | 438 +-- .../vertical/MOM_opacity.F90 | 2 +- .../vertical/MOM_regularize_layers.F90 | 202 +- .../vertical/MOM_set_diffusivity.F90 | 149 +- .../vertical/MOM_set_viscosity.F90 | 87 +- .../vertical/MOM_tidal_mixing.F90 | 50 +- .../vertical/MOM_vert_friction.F90 | 143 +- src/tracer/DOME_tracer.F90 | 6 +- src/tracer/ISOMIP_tracer.F90 | 8 +- src/tracer/MOM_OCMIP2_CFC.F90 | 16 +- src/tracer/MOM_generic_tracer.F90 | 115 +- src/tracer/MOM_lateral_boundary_diffusion.F90 | 609 ++-- src/tracer/MOM_neutral_diffusion.F90 | 694 +++-- src/tracer/MOM_offline_aux.F90 | 3 +- src/tracer/MOM_offline_main.F90 | 35 +- src/tracer/MOM_tracer_Z_init.F90 | 303 +- src/tracer/MOM_tracer_advect.F90 | 118 +- src/tracer/MOM_tracer_flow_control.F90 | 99 +- src/tracer/MOM_tracer_hor_diff.F90 | 88 +- src/tracer/MOM_tracer_registry.F90 | 27 +- src/tracer/RGC_tracer.F90 | 5 +- src/tracer/advection_test_tracer.F90 | 6 +- src/tracer/boundary_impulse_tracer.F90 | 6 +- src/tracer/dye_example.F90 | 14 +- src/tracer/ideal_age_example.F90 | 6 +- src/tracer/oil_tracer.F90 | 6 +- src/tracer/pseudo_salt_tracer.F90 | 4 +- src/tracer/tracer_example.F90 | 6 +- src/user/BFB_initialization.F90 | 21 +- src/user/BFB_surface_forcing.F90 | 23 +- src/user/DOME2d_initialization.F90 | 14 +- src/user/DOME_initialization.F90 | 10 +- src/user/ISOMIP_initialization.F90 | 28 +- src/user/Idealized_Hurricane.F90 | 43 +- src/user/Kelvin_initialization.F90 | 38 +- src/user/MOM_wave_interface.F90 | 14 +- ...tion.F90 => Neverworld_initialization.F90} | 166 +- src/user/RGC_initialization.F90 | 10 +- src/user/Rossby_front_2d_initialization.F90 | 4 +- src/user/SCM_CVMix_tests.F90 | 30 +- src/user/adjustment_initialization.F90 | 18 +- src/user/basin_builder.F90 | 309 ++ src/user/benchmark_initialization.F90 | 37 +- src/user/dense_water_initialization.F90 | 12 +- src/user/dumbbell_surface_forcing.F90 | 39 +- src/user/sloshing_initialization.F90 | 15 +- src/user/user_change_diffusivity.F90 | 12 +- src/user/user_initialization.F90 | 23 +- src/user/user_revise_forcing.F90 | 4 +- 249 files changed, 18132 insertions(+), 16346 deletions(-) delete mode 100644 .testing/linux-ubuntu-xenial-gnu.mk create mode 100644 .testing/tc4/.gitignore create mode 100644 ac/Makefile.in create mode 100644 ac/README.md create mode 100644 ac/configure.ac create mode 100644 ac/deps/.gitignore create mode 100644 ac/deps/Makefile create mode 100644 ac/deps/Makefile.fms.in create mode 100644 ac/deps/configure.fms.ac create mode 100644 ac/deps/m4/ax_fc_allow_arg_mismatch.m4 create mode 100644 ac/deps/m4/ax_fc_allow_invalid_boz.m4 create mode 100644 ac/deps/m4/ax_fc_check_lib.m4 create mode 100644 ac/deps/m4/ax_fc_check_module.m4 create mode 100644 ac/deps/m4/ax_fc_cray_pointer.m4 create mode 100644 ac/deps/m4/ax_fc_real8.m4 create mode 100644 ac/deps/m4/ax_mpi.m4 create mode 100644 ac/m4/ax_fc_check_lib.m4 create mode 100644 ac/m4/ax_fc_check_module.m4 create mode 100644 ac/m4/ax_fc_real8.m4 create mode 100644 ac/m4/ax_mpi.m4 create mode 100644 config_src/external/GFDL_ocean_BGC/FMS_coupler_util.F90 create mode 100644 config_src/external/GFDL_ocean_BGC/README.md create mode 100644 config_src/external/GFDL_ocean_BGC/generic_tracer.F90 create mode 100644 config_src/external/GFDL_ocean_BGC/generic_tracer_utils.F90 create mode 100644 config_src/external/ODA_hooks/README.md create mode 100644 config_src/external/ODA_hooks/kdtree.f90 create mode 100644 config_src/external/ODA_hooks/ocean_da_core.F90 create mode 100644 config_src/external/ODA_hooks/ocean_da_types.F90 create mode 100644 config_src/external/ODA_hooks/write_ocean_obs.F90 create mode 100644 config_src/external/README.md delete mode 100644 config_src/ice_solo_driver/MOM_surface_forcing.F90 delete mode 100644 config_src/ice_solo_driver/user_surface_forcing.F90 delete mode 100644 config_src/solo_driver/Neverland_surface_forcing.F90 delete mode 160000 pkg/MOM6_DA_hooks delete mode 160000 pkg/geoKdTree rename src/core/{MOM_PressureForce_analytic_FV.F90 => MOM_PressureForce_FV.F90} (72%) delete mode 100644 src/core/MOM_PressureForce_blocked_AFV.F90 create mode 100644 src/core/MOM_density_integrals.F90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_chem_potential_water_t_exact.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_ct_freezing_exact.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_ct_freezing_poly.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_ct_from_pt.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_ct_from_t.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_entropy_part.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_entropy_part_zerop.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_gibbs.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_gibbs_ice.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_gibbs_pt0_pt0.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_mod_freezing_poly_coefficients.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_mod_gibbs_ice_coefficients.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_mod_kinds.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_mod_specvol_coefficients.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_mod_teos10_constants.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_mod_toolbox.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_pt0_from_t.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_pt_from_ct.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_pt_from_t.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_rho.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_rho_first_derivatives.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_rho_second_derivatives.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_sp_from_sr.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_specvol.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_specvol_first_derivatives.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_specvol_second_derivatives.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_sr_from_sp.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_t_deriv_chem_potential_water_t_exact.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_t_freezing_exact.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_t_freezing_poly.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_t_from_ct.f90 create mode 100644 src/framework/MOM_array_transform.F90 create mode 100644 src/framework/MOM_transform_FMS.F90 delete mode 120000 src/ocean_data_assim/core delete mode 120000 src/ocean_data_assim/geoKdTree rename src/user/{Neverland_initialization.F90 => Neverworld_initialization.F90} (53%) create mode 100644 src/user/basin_builder.F90 diff --git a/.codecov.yml b/.codecov.yml index 576633bf6a..84e438145e 100644 --- a/.codecov.yml +++ b/.codecov.yml @@ -3,6 +3,11 @@ coverage: project: default: threshold: 100% + base: parent patch: default: threshold: 100% + base: parent +comment: + # This must be set to the number of test cases (TCs) + after_n_builds: 8 diff --git a/.gitignore b/.gitignore index e534738ed7..ccaecbbead 100644 --- a/.gitignore +++ b/.gitignore @@ -2,7 +2,19 @@ *.swp *~ html -*.log + + +# Build output +*.o +*.mod MOM6 -build/ -deps/ + + +# Autoconf +aclocal.m4 +autom4te.cache/ +config.log +config.status +configure +/Makefile +Makefile.mkmf diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 39b63c8f85..1622ae9886 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -32,13 +32,11 @@ setup: - git clone --recursive http://gitlab.gfdl.noaa.gov/ogrp/Gaea-stats-MOM6-examples.git tests && cd tests # Install / update testing scripts - git clone https://github.com/adcroft/MRS.git MRS - - (cd MRS ; git checkout xanadu-fms) # Update MOM6-examples and submodules - (cd MOM6-examples && git checkout . && git checkout dev/gfdl && git pull && git submodule init && git submodule update) - (cd MOM6-examples/src/MOM6 && git submodule update) - test -d MOM6-examples/src/LM3 || make -f MRS/Makefile.clone clone_gfdl -s - make -f MRS/Makefile.clone MOM6-examples/.datasets -s - #- (cd MOM6-examples/src/mkmf && git pull https://github.com/adcroft/mkmf.git add_coverage_mode) - env > gitlab_session.log # Cache everything under tests to unpack for each subsequent stage - cd ../ ; time tar zcf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz tests @@ -62,7 +60,7 @@ gnu:ocean-only-nolibs: - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests - make -f MRS/Makefile.build build/gnu/env && cd build/gnu # mkdir -p build/gnu/repro/symmetric_dynamic/ocean_only && cd build/gnu/repro/symmetric_dynamic/ocean_only - - ../../MOM6-examples/src/mkmf/bin/list_paths -l ../../../config_src/{solo_driver,dynamic_symmetric} ../../../src ../../MOM6-examples/src/FMS + - ../../MOM6-examples/src/mkmf/bin/list_paths -l ../../../config_src/{solo_driver,dynamic_symmetric,ext*} ../../../src ../../MOM6-examples/src/FMS - sed -i '/FMS\/.*\/test_/d' path_names - ../../MOM6-examples/src/mkmf/bin/mkmf -t ../../MOM6-examples/src/mkmf/templates/ncrc-gnu.mk -p MOM6 -c"-Duse_libMPI -Duse_netCDF" path_names - time (source ./env ; make NETCDF=3 REPRO=1 MOM6 -s -j) @@ -75,7 +73,7 @@ gnu:ice-ocean-nolibs: - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests - make -f MRS/Makefile.build build/gnu/env && cd build/gnu # mkdir -p build/gnu/repro/symmetric_dynamic/ocean_only && cd build/gnu/repro/symmetric_dynamic/ocean_only - - ../../MOM6-examples/src/mkmf/bin/list_paths -l ../../../config_src/{coupled_driver,dynamic} ../../../src ../../MOM6-examples/src/{FMS,coupler,SIS2,icebergs,ice_param,land_null,atmos_null} + - ../../MOM6-examples/src/mkmf/bin/list_paths -l ../../../config_src/{coupled_driver,dynamic,ext*} ../../../src ../../MOM6-examples/src/{FMS,coupler,SIS2,icebergs,ice_param,land_null,atmos_null} - sed -i '/FMS\/.*\/test_/d' path_names - ../../MOM6-examples/src/mkmf/bin/mkmf -t ../../MOM6-examples/src/mkmf/templates/ncrc-gnu.mk -p MOM6 -c"-Duse_libMPI -Duse_netCDF -D_USE_LEGACY_LAND_ -Duse_AM3_physics" path_names - time (source ./env ; make NETCDF=3 REPRO=1 MOM6 -s -j) @@ -118,7 +116,7 @@ run: - time tar zxf $CACHE_DIR/build-intel-repro-$CI_PIPELINE_ID.tgz - time tar zxf $CACHE_DIR/build-pgi-repro-$CI_PIPELINE_ID.tgz # time tar zxf $CACHE_DIR/build-gnu-debug-$CI_PIPELINE_ID.tgz - - (echo '#!/bin/tcsh';echo 'make -f MRS/Makefile.tests all -B') > job.sh + - (echo '#!/bin/tcsh';echo 'make -f MRS/Makefile.tests all') > job.sh - sbatch --clusters=c3,c4 --nodes=29 --time=0:34:00 --account=gfdl_o --qos=debug --job-name=mom6_regressions --output=log.$CI_PIPELINE_ID --wait job.sh - cat log.$CI_PIPELINE_ID - test -f restart_results_gnu.tar.gz diff --git a/.gitmodules b/.gitmodules index b499e43096..637f1188ed 100644 --- a/.gitmodules +++ b/.gitmodules @@ -4,9 +4,3 @@ [submodule "pkg/GSW-Fortran"] path = pkg/GSW-Fortran url = https://github.com/TEOS-10/GSW-Fortran.git -[submodule "pkg/MOM6_DA_hooks"] - path = pkg/MOM6_DA_hooks - url = https://github.com/MJHarrison-GFDL/MOM6_DA_hooks.git -[submodule "pkg/geoKdTree"] - path = pkg/geoKdTree - url = https://github.com/travissluka/geoKdTree.git diff --git a/.testing/.gitignore b/.testing/.gitignore index 441e73b8e8..488edabfe8 100644 --- a/.testing/.gitignore +++ b/.testing/.gitignore @@ -1,3 +1,6 @@ -config.mk -work/ -results/ +# Test output +/config.mk +/build/ +/work/ +/results/ +/deps/ diff --git a/.testing/Makefile b/.testing/Makefile index 8067e4218d..4b3dfdefb8 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -1,38 +1,43 @@ SHELL = bash +.SUFFIXES: # User-defined configuration -include config.mk -# Default configurations +# Set the MPI launcher here MPIRUN ?= mpirun -DO_REPRO_TESTS ?= true + +# Default target compiler flags +# NOTE: FMS will be built using FCFLAGS_DEBUG +FCFLAGS_DEBUG ?= -g -O0 +FCFLAGS_REPRO ?= -g -O2 +FCFLAGS_INIT ?= +FCFLAGS_COVERAGE ?= +# Additional notes: +# +# - The default values are simple, minimalist flags, supported by nearly all +# compilers which are comparable to GFDL's canonical DEBUG and REPRO builds. +# +# - These flags should be configured outside of the Makefile, either with +# config.mk or as environment variables. +# +# - FMS cannot be built with the same aggressive initialization flags as MOM6, +# so FCFLAGS_INIT is used to provide additional MOM6 configuration. + +# Set to `true` to require identical results from DEBUG and REPRO builds +DO_REPRO_TESTS ?= + +# Many compilers (Intel, GCC on ARM64) do not yet produce identical results +# across DEBUG and REPRO builds (as defined below), so we disable on default. #--- # Dependencies DEPS = deps # mkmf, list_paths (GFDL build toolchain) -MKMF_URL ?= https://github.com/NOAA-GFDL/mkmf.git -MKMF_COMMIT ?= master -LIST_PATHS := $(abspath $(DEPS)/mkmf/bin/list_paths) -MKMF := $(abspath $(DEPS)/mkmf/bin/mkmf) - -# FMS framework -FMS_URL ?= https://github.com/NOAA-GFDL/FMS.git -FMS_COMMIT ?= 2019.01.01 -FMS := $(DEPS)/fms - -#--- -# Build configuration +LIST_PATHS := $(DEPS)/bin/list_paths +MKMF := $(DEPS)/bin/mkmf -# Build settings -MKMF_CPP = "-Duse_libMPI -Duse_netCDF -DSPMD" - -# Environment -# TODO: This info ought to be determined by CMake, automake, etc. -#MKMF_TEMPLATE ?= .testing/linux-ubuntu-xenial-gnu.mk -MKMF_TEMPLATE ?= build/mkmf/templates/ncrc-gnu.mk -#MKMF_TEMPLATE ?= build/mkmf/templates/ncrc-intel.mk #--- # Test configuration @@ -40,7 +45,8 @@ MKMF_TEMPLATE ?= build/mkmf/templates/ncrc-gnu.mk # Executables BUILDS = symmetric asymmetric repro openmp CONFIGS := $(wildcard tc*) -TESTS = grids layouts restarts nans dims openmps +TESTS = grids layouts restarts nans dims openmps rotations +DIMS = t l h z q r # REPRO tests enable reproducibility with optimization, and often do not match # the DEBUG results in older GCCs and vendor compilers, so we can optionally @@ -76,6 +82,7 @@ else TARGET_CODEBASE = endif + # List of source files to link this Makefile's dependencies to model Makefiles # Assumes a depth of two, and the following extensions: F90 inc c h # (1): Root directory @@ -83,11 +90,38 @@ endif SOURCE = \ $(foreach ext,F90 inc c h,$(wildcard $(1)/*/*.$(ext) $(1)/*/*/*.$(ext))) -MOM_SOURCE = $(call SOURCE,../src) $(wildcard ../config_src/solo_driver/*.F90) +MOM_SOURCE = $(call SOURCE,../src) \ + $(wildcard ../config_src/solo_driver/*.F90) \ + $(wildcard ../config_src/ext*/*/*.F90) TARGET_SOURCE = $(call SOURCE,build/target_codebase/src) \ - $(wildcard build/target_codebase/config_src/solo_driver/*.F90) + $(wildcard build/target_codebase/config_src/solo_driver/*.F90) \ + $(wildcard build/target_codebase/config_src/ext*/*.F90) FMS_SOURCE = $(call SOURCE,$(DEPS)/fms/src) + +#--- +# Python preprocessing environment configuration + +HAS_NUMPY = $(shell python -c "import numpy" 2> /dev/null && echo "yes") +HAS_NETCDF4 = $(shell python -c "import netCDF4" 2> /dev/null && echo "yes") + +USE_VENV = +ifneq ($(HAS_NUMPY), yes) + USE_VENV = yes +endif +ifneq ($(HAS_NETCDF4), yes) + USE_VENV = yes +endif + +# When disabled, activation is a null operation (`true`) +VENV_PATH = +VENV_ACTIVATE = true +ifeq ($(USE_VENV), yes) + VENV_PATH = work/local-env + VENV_ACTIVATE = . $(VENV_PATH)/bin/activate +endif + + #--- # Rules @@ -99,86 +133,147 @@ build.regressions: $(foreach b,symmetric target,build/$(b)/MOM6) BUILD_TARGETS = MOM6 Makefile path_names .PRECIOUS: $(foreach b,$(BUILDS),$(foreach f,$(BUILD_TARGETS),build/$(b)/$(f))) +# Compiler flags + # Conditionally build symmetric with coverage support -COVFLAG=$(if $(REPORT_COVERAGE),COVERAGE=1,) +COVERAGE=$(if $(REPORT_COVERAGE),$(FCFLAGS_COVERAGE),) + +# .testing dependencies +# TODO: We should probably build TARGET with the FMS that it was configured +# to use. But for now we use the same FMS over all builds. +FCFLAGS_FMS = -I../../$(DEPS)/include +LDFLAGS_FMS = -L../../$(DEPS)/lib +PATH_FMS = PATH="${PATH}:../../$(DEPS)/bin" + + +# Define the build targets in terms of the traditional DEBUG/REPRO/etc labels +SYMMETRIC_FCFLAGS := FCFLAGS="$(FCFLAGS_DEBUG) $(FCFLAGS_INIT) $(COVERAGE) $(FCFLAGS_FMS)" +ASYMMETRIC_FCFLAGS := FCFLAGS="$(FCFLAGS_DEBUG) $(FCFLAGS_INIT) $(FCFLAGS_FMS)" +REPRO_FCFLAGS := FCFLAGS="$(FCFLAGS_REPRO) $(FCFLAGS_FMS)" +OPENMP_FCFLAGS := FCFLAGS="$(FCFLAGS_DEBUG) $(FCFLAGS_INIT) $(FCFLAGS_FMS)" +TARGET_FCFLAGS := FCFLAGS="$(FCFLAGS_DEBUG) $(FCFLAGS_INIT) $(FCFLAGS_FMS)" + +MOM_LDFLAGS := LDFLAGS="$(LDFLAGS_FMS)" +SYMMETRIC_LDFLAGS := LDFLAGS="$(COVERAGE) $(LDFLAGS_FMS)" + + +# Environment variable configuration +build/symmetric/Makefile: MOM_ENV=$(PATH_FMS) $(SYMMETRIC_FCFLAGS) $(SYMMETRIC_LDFLAGS) +build/asymmetric/Makefile: MOM_ENV=$(PATH_FMS) $(ASYMMETRIC_FCFLAGS) $(MOM_LDFLAGS) +build/repro/Makefile: MOM_ENV=$(PATH_FMS) $(REPRO_FCFLAGS) $(MOM_LDFLAGS) +build/openmp/Makefile: MOM_ENV=$(PATH_FMS) $(OPENMP_FCFLAGS) $(MOM_LDFLAGS) +build/target/Makefile: MOM_ENV=$(PATH_FMS) $(TARGET_FCFLAGS) $(MOM_LDFLAGS) + -build/target/MOM6: MOMFLAGS=NETCDF=3 DEBUG=1 INIT=1 -build/symmetric/MOM6: MOMFLAGS=NETCDF=3 DEBUG=1 INIT=1 $(COVFLAG) -build/asymmetric/MOM6: MOMFLAGS=NETCDF=3 DEBUG=1 INIT=1 -build/repro/MOM6: MOMFLAGS=NETCDF=3 REPRO=1 -build/openmp/MOM6: MOMFLAGS=NETCDF=3 DEBUG=1 OPENMP=1 INIT=1 +# Configure script flags +build/symmetric/Makefile: MOM_ACFLAGS= +build/asymmetric/Makefile: MOM_ACFLAGS=--enable-asymmetric +build/repro/Makefile: MOM_ACFLAGS= +build/openmp/Makefile: MOM_ACFLAGS=--enable-openmp +build/target/Makefile: MOM_ACFLAGS= -build/asymmetric/path_names: GRID_SRC=config_src/dynamic -build/%/path_names: GRID_SRC=config_src/dynamic_symmetric -build/%/MOM6: build/%/Makefile $(FMS)/lib/libfms.a - make -C $(@D) $(MOMFLAGS) $(@F) +# Fetch regression target source code +build/target/Makefile: | $(TARGET_CODEBASE) -build/%/Makefile: build/%/path_names - cp $(MKMF_TEMPLATE) $(@D) - cd $(@D) && $(MKMF) \ - -t $(notdir $(MKMF_TEMPLATE)) \ - -o '-I ../../$(DEPS)/fms/build' \ - -p MOM6 \ - -l '../../$(DEPS)/fms/lib/libfms.a' \ - -c $(MKMF_CPP) \ - path_names -# NOTE: These path_names rules could be merged +# Define source code dependencies +# NOTE: ./configure is too much, but Makefile is not enough! +# Ideally we would want to re-run both Makefile and mkmf, but our mkmf call +# is inside ./configure, so we must re-run ./configure as well. +$(foreach b,$(filter-out target,$(BUILDS)),build/$(b)/Makefile): $(MOM_SOURCE) +build/target/configure: $(TARGET_SOURCE) -build/target/path_names: $(LIST_PATHS) $(TARGET_CODEBASE) $(TARGET_SOURCE) + +# Build MOM6 +.PRECIOUS: $(foreach b,$(BUILDS),build/$(b)/MOM6) +build/%/MOM6: build/%/Makefile + cd $(@D) && time $(MAKE) -j + + +# Use autoconf to construct the Makefile for each target +.PRECIOUS: $(foreach b,$(BUILDS),build/$(b)/Makefile) +build/%/Makefile: ../ac/configure ../ac/Makefile.in $(DEPS)/lib/libFMS.a $(MKMF) $(LIST_PATHS) mkdir -p $(@D) - cd $(@D) && $(LIST_PATHS) -l \ - ../../$(TARGET_CODEBASE)/src \ - ../../$(TARGET_CODEBASE)/config_src/solo_driver \ - ../../$(TARGET_CODEBASE)/$(GRID_SRC) + cd $(@D) \ + && $(MOM_ENV) ../../../ac/configure $(MOM_ACFLAGS) \ + || (cat config.log && false) + -build/%/path_names: $(LIST_PATHS) $(MOM_SOURCE) +../ac/configure: ../ac/configure.ac ../ac/m4 + autoreconf -i $< + + +# Fetch the regression target codebase +build/target/Makefile: $(TARGET_CODEBASE)/ac/configure $(DEPS)/lib/libFMS.a $(MKMF) $(LIST_PATHS) mkdir -p $(@D) - cd $(@D) && $(LIST_PATHS) -l \ - ../../../src \ - ../../../config_src/solo_driver \ - ../../../$(GRID_SRC) + cd $(@D) \ + && $(MOM_ENV) ../../$(TARGET_CODEBASE)/ac/configure $(MOM_ACFLAGS) \ + || (cat config.log && false) + + +$(TARGET_CODEBASE)/ac/configure: $(TARGET_CODEBASE) + autoreconf -i $ $<.reg || true) +# stats rule is unchanged, but we cannot use CMP_RULE to generate it. +%.regression: $(foreach b,symmetric target,work/%/$(b)/ocean.stats) + @cmp $^ || !( \ + mkdir -p results/$*; \ + (diff $^ | tee results/$*/ocean.stats.regression.diff | head) ; \ + echo -e "$(FAIL): Solutions $*.regression have changed." \ + ) + @echo -e "$(PASS): Solutions $*.regression agree." + +# Regression testing only checks for changes in existing diagnostics +%.regression.diag: $(foreach b,symmetric target,work/%/$(b)/chksum_diag) + @! diff $^ | grep "^[<>]" | grep "^>" \ + || ! (\ + mkdir -p results/$*; \ + (diff $^ | tee results/$*/chksum_diag.regression.diff | head) ; \ + echo -e "$(FAIL): Diagnostics $*.regression.diag have changed." \ + ) + @diff $^ || echo -e "$(WARN): New diagnostics in $<" + @echo -e "$(PASS): Diagnostics $*.regression.diag agree." -%.regression.diag: $(foreach b,symmetric target,results/%/chksum_diag.$(b)) - cmp $^ || (diff $^ > $<.reg || true) #--- # Test run output files -# Generalized MPI environment variable support -# $(1): Environment variables -ifeq ($(shell $(MPIRUN) -x tmp=1 true 2> /dev/null ; echo $$?), 0) - MPIRUN_CMD=$(MPIRUN) $(if $(1),-x $(1),) -else ifeq ($(shell $(MPIRUN) -env tmp=1 true 2> /dev/null ; echo $$?), 0) - MPIRUN_CMD=$(MPIRUN) $(if $(1),-env $(1),) -else - MPIRUN_CMD=$(1) $(MPIRUN) -endif - -# Rule to build results//{ocean.stats,chksum_diag}. +# Rule to build work//{ocean.stats,chksum_diag}. # $(1): Test configuration name # $(2): Executable type # $(3): Enable coverage flag @@ -254,25 +393,40 @@ endif # $(5): Environment variables # $(6): Number of MPI ranks define STAT_RULE -results/%/ocean.stats.$(1): build/$(2)/MOM6 +work/%/$(1)/ocean.stats work/%/$(1)/chksum_diag: build/$(2)/MOM6 $(VENV_PATH) + @echo "Running test $$*.$(1)..." if [ $(3) ]; then find build/$(2) -name *.gcda -exec rm -f '{}' \; ; fi - mkdir -p work/$$*/$(1) - cp -rL $$*/* work/$$*/$(1) - cd work/$$*/$(1) && if [ -f Makefile ]; then make; fi - mkdir -p work/$$*/$(1)/RESTART - echo $(4) > work/$$*/$(1)/MOM_override - cd work/$$*/$(1) && $$(call MPIRUN_CMD,$(5)) -n $(6) ../../../$$< 2> debug.out > std.out \ - || ! sed 's/^/$$*.$(1): /' std.out debug.out \ - && sed 's/^/$$*.$(1): /' std.out mkdir -p $$(@D) - cp work/$$*/$(1)/ocean.stats $$@ - if [ $(3) ]; then cd .. && bash <(curl -s https://codecov.io/bash) -n $$@; fi - -results/%/chksum_diag.$(1): results/%/ocean.stats.$(1) - mkdir -p $$(@D) - cp work/$$*/$(1)/chksum_diag $$@ + cp -RL $$*/* $$(@D) + if [ -f $$(@D)/Makefile ]; then \ + $$(VENV_ACTIVATE) \ + && cd $$(@D) \ + && $(MAKE); \ + else \ + cd $$(@D); \ + fi + mkdir -p $$(@D)/RESTART + echo -e "$(4)" > $$(@D)/MOM_override + cd $$(@D) \ + && time $(5) $(MPIRUN) -n $(6) ../../../$$< 2> std.err > std.out \ + || !( \ + mkdir -p ../../../results/$$*/ ; \ + cat std.out | tee ../../../results/$$*/std.$(1).out | tail -20 ; \ + cat std.err | tee ../../../results/$$*/std.$(1).err | tail -20 ; \ + rm ocean.stats chksum_diag ; \ + echo -e "$(FAIL): $$*.$(1) failed at runtime." \ + ) + @echo -e "$(DONE): $$*.$(1); no runtime errors." + if [ $(3) ]; then \ + mkdir -p results/$$* ; \ + bash <(curl -s https://codecov.io/bash) -n $$@ \ + > work/$$*/codecov.$(1).out \ + 2> work/$$*/codecov.$(1).err \ + && echo -e "${MAGENTA}Report uploaded to codecov.${RESET}"; \ + fi endef + # Define $(,) as comma escape character , := , @@ -280,58 +434,98 @@ $(eval $(call STAT_RULE,symmetric,symmetric,$(REPORT_COVERAGE),,,1)) $(eval $(call STAT_RULE,asymmetric,asymmetric,,,,1)) $(eval $(call STAT_RULE,target,target,,,,1)) $(eval $(call STAT_RULE,repro,repro,,,,1)) -$(eval $(call STAT_RULE,openmp,openmp,,,,1)) +$(eval $(call STAT_RULE,openmp,openmp,,,GOMP_CPU_AFFINITY=0,1)) $(eval $(call STAT_RULE,layout,symmetric,,LAYOUT=2$(,)1,,2)) +$(eval $(call STAT_RULE,rotate,symmetric,,ROTATE_INDEX=True\nINDEX_TURNS=1,,1)) $(eval $(call STAT_RULE,nan,symmetric,,,MALLOC_PERTURB_=256,1)) $(eval $(call STAT_RULE,dim.t,symmetric,,T_RESCALE_POWER=11,,1)) $(eval $(call STAT_RULE,dim.l,symmetric,,L_RESCALE_POWER=11,,1)) $(eval $(call STAT_RULE,dim.h,symmetric,,H_RESCALE_POWER=11,,1)) $(eval $(call STAT_RULE,dim.z,symmetric,,Z_RESCALE_POWER=11,,1)) +$(eval $(call STAT_RULE,dim.q,symmetric,,Q_RESCALE_POWER=11,,1)) +$(eval $(call STAT_RULE,dim.r,symmetric,,R_RESCALE_POWER=11,,1)) + # Restart tests require significant preprocessing, and are handled separately. -results/%/ocean.stats.restart: build/symmetric/MOM6 - rm -rf work/$*/restart - mkdir -p work/$*/restart - cp -rL $*/* work/$*/restart - cd work/$*/restart && if [ -f Makefile ]; then make; fi - mkdir -p work/$*/restart/RESTART +work/%/restart/ocean.stats: build/symmetric/MOM6 $(VENV_PATH) + rm -rf $(@D) + mkdir -p $(@D) + cp -RL $*/* $(@D) + if [ -f $(@D)/Makefile ]; then \ + $(VENV_ACTIVATE) \ + && cd work/$*/restart \ + && $(MAKE); \ + else \ + cd work/$*/restart; \ + fi + mkdir -p $(@D)/RESTART # Generate the half-period input namelist - # TODO: Assumes runtime set by DAYMAX, will fail if set by input.nml - cd work/$*/restart \ - && daymax=$$(grep DAYMAX MOM_input | cut -d '!' -f 1 | cut -d '=' -f 2 | xargs) \ - && timeunit=$$(grep TIMEUNIT MOM_input | cut -d '!' -f 1 | cut -d '=' -f 2 | xargs) \ - && if [ -z "$${timeunit}" ]; then timeunit="8.64e4"; fi \ - && printf -v timeunit_int "%.f" "$${timeunit}" \ - && halfperiod=$$(printf "%.f" $$(bc <<< "scale=10; 0.5 * $${daymax} * $${timeunit_int}")) \ - && printf "\n&ocean_solo_nml\n seconds = $${halfperiod}\n/\n" >> input.nml + # TODO: Assumes that runtime set by DAYMAX, will fail if set by input.nml + cd $(@D) \ + && daymax=$$(grep DAYMAX MOM_input | cut -d '!' -f 1 | cut -d '=' -f 2 | xargs) \ + && timeunit=$$(grep TIMEUNIT MOM_input | cut -d '!' -f 1 | cut -d '=' -f 2 | xargs) \ + && if [ -z "$${timeunit}" ]; then timeunit="8.64e4"; fi \ + && printf -v timeunit_int "%.f" "$${timeunit}" \ + && halfperiod=$$(printf "%.f" $$(bc <<< "scale=10; 0.5 * $${daymax} * $${timeunit_int}")) \ + && printf "\n&ocean_solo_nml\n seconds = $${halfperiod}\n/\n" >> input.nml # Run the first half-period - cd work/$*/restart && $(MPIRUN) -n 1 ../../../$< 2> debug1.out > std1.out \ - || ! sed 's/^/$*.restart1: /' std1.out debug1.out \ - && sed 's/^/$*.restart1: /' std1.out + cd $(@D) && time $(MPIRUN) -n 1 ../../../$< 2> std1.err > std1.out \ + || !( \ + cat std1.out | tee ../../../results/$*/std.restart1.out | tail ; \ + cat std1.err | tee ../../../results/$*/std.restart1.err | tail ; \ + echo -e "$(FAIL): $*.restart failed at runtime." \ + ) # Setup the next inputs - cd work/$*/restart && rm -rf INPUT && mv RESTART INPUT - mkdir work/$*/restart/RESTART - cd work/$*/restart && sed -i -e "s/input_filename *= *'n'/input_filename = 'r'/g" input.nml + cd $(@D) && rm -rf INPUT && mv RESTART INPUT + mkdir $(@D)/RESTART + cd $(@D) && sed -i -e "s/input_filename *= *'n'/input_filename = 'r'/g" input.nml # Run the second half-period - cd work/$*/restart && $(MPIRUN) -n 1 ../../../$< 2> debug2.out > std2.out \ - || ! sed 's/^/$*.restart2: /' std2.out debug2.out \ - && sed 's/^/$*.restart2: /' std2.out - # Archive the results and cleanup - mkdir -p $(@D) - cp work/$*/restart/ocean.stats $@ + cd $(@D) && time $(MPIRUN) -n 1 ../../../$< 2> std2.err > std2.out \ + || !( \ + cat std2.out | tee ../../../results/$*/std.restart2.out | tail ; \ + cat std2.err | tee ../../../results/$*/std.restart2.err | tail ; \ + echo -e "$(FAIL): $*.restart failed at runtime." \ + ) # TODO: Restart checksum diagnostics +#--- +# Not a true rule; only call this after `make test` to summarize test results. +.PHONY: test.summary +test.summary: + @if ls results/*/* &> /dev/null; then \ + if ls results/*/std.*.err &> /dev/null; then \ + echo "The following tests failed to complete:" ; \ + ls results/*/std.*.out \ + | awk '{split($$0,a,"/"); split(a[3],t,"."); v=t[2]; if(length(t)>3) v=v"."t[3]; print a[2],":",v}'; \ + fi; \ + if ls results/*/ocean.stats.*.diff &> /dev/null; then \ + echo "The following tests report solution regressions:" ; \ + ls results/*/ocean.stats.*.diff \ + | awk '{split($$0,a,"/"); split(a[3],t,"."); v=t[3]; if(length(t)>4) v=v"."t[4]; print a[2],":",v}'; \ + fi; \ + if ls results/*/chksum_diag.*.diff &> /dev/null; then \ + echo "The following tests report diagnostic regressions:" ; \ + ls results/*/chksum_diag.*.diff \ + | awk '{split($$0,a,"/"); split(a[3],t,"."); v=t[2]; if(length(t)>3) v=v"."t[3]; print a[2],":",v}'; \ + fi; \ + false ; \ + else \ + echo -e "$(PASS): All tests passed!"; \ + fi + + #---- +# NOTE: These tests assert that we are in the .testing directory. + .PHONY: clean clean: clean.stats - @# Assert that we are in .testing for recursive delete @[ $$(basename $$(pwd)) = .testing ] rm -rf build + .PHONY: clean.stats clean.stats: - @# Assert that we are in .testing for recursive delete @[ $$(basename $$(pwd)) = .testing ] rm -rf work results diff --git a/.testing/README.md b/.testing/README.md index 5cd190ef25..adc56e56cd 100644 --- a/.testing/README.md +++ b/.testing/README.md @@ -2,30 +2,41 @@ This directory contains the Makefile and test configurations used to evaluate submissions to the MOM6 codebase. The tests are designed to run either locally -or in a Travis-CI. +or in a CI environment such as Travis. ## Overview This section gives a very brief overview of the test suite and how to use it. -To build and run the model tests +To build and run the model tests: ``` -make -make test +make -j +make -j test ``` +For new users, the default configuration should be suitable for most platforms. +If not, then the following options may need to be configured. + +`MPIRUN` (*default:* `mpirun`) + + Name of the MPI launcher. Often this is `mpirun` or `mpiexec` but may all + need to run through a scheduler, e.g. `srun` if using Slurm. + +`DO_REGRESSION_TESTS` (*default: none*) + + Set to `true` to compare output with `dev/gfdl`. + +`DO_REPRO_TESTS` (*default: none*) -Regression testing is disabled on default. To include regression tests: + Set to `true` to compare DEBUG and REPRO builds, which typically correspond + to unoptimized and optimized builds. See TODO for more information. + +These settings can either be specified at the command line, as shown below ``` make DO_REGRESSION_TESTS=true make test DO_REGRESSION_TESTS=true ``` - -On platforms other than Gaea, a MKMF build template may be required. To -specify the path to the template: -``` -make MKMF_TEMPLATE=/path/to/template.mk -``` +or saved in a configuration file, `config.mk`. To run individual classes of tests, use the subclass name: ``` @@ -33,11 +44,11 @@ make test.grids make test.layouts make DO_REGRESSION_TESTS=true test.regressions ``` - To test an individual test configuration (TC): ``` make tc0.grid ``` +See "Tests" and "Test Configurations" for the complete list of tests. The rest of the document describes the test suite in more detail, including names and descriptions of the test classes and configurations. @@ -45,20 +56,85 @@ names and descriptions of the test classes and configurations. ## Testing overview -The test suite consists of many comparisons of model output for different model -configurations when subjected to relevant numerical and mathematical -transformations, such as grid layout or dimensional rescaling, for which the -model output should be invariant. If the model state is unchanged after each -transformation, then the test is reported as passing. Any discrepancy in the -model state causes the test to fail. +The test suite checks for numerical consistency of the model output across +different model configurations when subjected to relevant numerical and +mathematical transformations, such as grid layout or dimensional rescaling. If +the model state is unchanged after each transformation, then the test is +reported as passing. Any discrepancy in the model state causes the test to +fail. Model state is currently defined by the `ocean.stats` output file, which reports the total energy (per unit mass) at machine precision alongside similar -global metrics, such as mass or mean sea level, at lower precision. +global metrics at lower precision, such as mass or mean sea level. + +Diagnostics are based on the MOM checksum function, which includes the mean, +minimum, and maximum values, alongside a bitcount checksum, in the physical +domain, which are saved in the `chksum_diag` output file. + + +## Build configuration + +The test suite defines a DEBUG and a REPRO build, which resemble targets used +at GFDL. The DEBUG build is intended for detecting potential errors and +troubleshooting, while the REPRO build has typically been optimized for +production runs. + +Ideally, the DEBUG and REPRO runs will produce identical results, although this +is often not the case for many compilers and platforms. The `DO_REPRO_TEST` +flag is used to test DEBUG/REPRO equivalency. + +The following options are provided to configure your compiler flags. + +`FCFLAGS_DEBUG` (*default:* `-g -O0`) + + Specify the flags used in the DEBUG build. These are the flags used for all + tests excepting the REPRO builds. They are also used to build the FMS + library. + + These should be used to enable settings favorable to debugging, such as no + optimizations, backtraces, range checking, and warnings. + + For more aggressive debugging flags which cannot be used with FMS, see + `FCFLAGS_INIT`. + +`FCFLAGS_REPRO:` (*default:* `-g -O2`) + + Specify the optimized reproducible run, typically used in production runs. + + Ideally, this should consist of optimization flags which improve peformance + but do not change model output. In practice, this is difficult to achieve, + and should only used in certain environments. + +`FCFLAGS_INIT` (*default: none*) + + This flag was historically used to specify variable initialization, such as + nonzero integers or floating point values, and is still generally used for + this purpose. + + As implemented, it is used for all MOM6 builds. It is not used for FMS + builds, so can also act as a debugging flag independent of FMS. -Checksums for every available diagnostic are also compared and the Makefile -will report any differences, but such differences are not yet considered a fail -condition. +`FCFLAGS_COVERAGE` (*default: none*) + + This flag is used to define a build which supports some sort of code + coverage, often one which is handled by the CI. + + For many compilers, this is set to `--coverage`, and is applied to both the + compiler (`FCFLAGS`) and linker (`LDFLAGS`). + +Example values used by GFDL and Travis for the GFortran compiler are shown +below. +``` +FCFLAGS_DEBUG="-g -O0 -Wextra -Wno-compare-reals -fbacktrace -ffpe-trap=invalid,zero,overflow -fcheck=bounds" +FCFLAGS_REPRO="-g -O2 -fbacktrace" +FCFLAGS_INIT="-finit-real=snan -finit-integer=2147483647 -finit-derived" +FCFLAGS_COVERAGE="--coverage" +``` + +Note that the default values for these flags are very minimal, in order to +ensure compatibility over the largest possible range of compilers. + +Like all configuration variables, these can be specified in a `config.mk` file. ## Building the executables @@ -71,66 +147,57 @@ This will fetch the MKMF build toolchain, fetch and compile the FMS framework library, and compile the executables used in the test suite. The default configuration uses the symmetric grid in the debug-compile mode, with optimizations disabled and stronger quality controls. The following -executables will be created: +executables will be created. -- `build/symmetric/MOM6`: Symmetric grid configuration (extended grids along - western and/or southern boundaries). This is the default configuration. +- `build/symmetric/MOM6`: Symmetric grid configuration (i.e. extended grids + along western and/or southern boundaries for selected fields). This is the + default configuration. - `build/asymmetric/MOM6`: Non-symmetric grid (equal-sized grids) - `build/repro/MOM6`: Optimized reproducible mode -- (optional) `build/target/MOM6`: A reference build for regression testing +- `build/target/MOM6`: A reference build for regression testing -The `target` build is only created when the `DO_REGRESSION_TESTS` flag is set -to `true`: -``` -make DO_REGRESSION_TESTS=true -``` -When set, the build will check out a second copy of the repository from a -specified URL and branch given by `MOM_TARGET_URL` and `MOM_TARGET_BRANCH`, -respectively. The code is checked out into the `TARGET_CODEBASE` directory. +- `build/openmp/MOM6`: OpenMP-enabled build + +The `target` and `repro` builds are only created when their respective tests +are set to `true`. + + +### Regression testing + +When regression tests are enabled, the Makefile will check out a second copy of +the repository from a specified URL and branch given by `MOM_TARGET_URL` and +`MOM_TARGET_BRANCH`, respectively. The code is checked out into the +`TARGET_CODEBASE` directory. -The current default settings are +The default settings, with resolved values as comments, are shown below. ``` MOM_TARGET_SLUG = NOAA-GFDL/MOM6 MOM_TARGET_URL = https://github.com/$(MOM_TARGET_SLUG) -# = https://github.com/NOAA-GFDL/MOM6 + #= https://github.com/NOAA-GFDL/MOM6 MOM_TARGET_LOCAL_BRANCH = dev/gfdl MOM_TARGET_BRANCH = origin/$(MOM_TARGET_LOCAL_BRANCH) -# = origin/dev/gfdl + #= origin/dev/gfdl TARGET_CODEBASE = $(BUILD)/target_codebase ``` These default values can be configured to target a particular development branch. +Currently the target can only be specifed by branch name, rather than hash. -#### MKMF template - -The MKMF build toolchain requires a template file when building the model. The -default template, `ncrc-gnu.mk`, is part of the MKMF repository, but has been -specifically configured for use on NOAA's Gaea computer, and other institutes -will require their own template files. - -The template can be specified as a Make flag. -``` -make MKMF_TEMPLATE=/path/to/template.mk -``` -The `linux-ubuntu-xenial-gnu.mk` template is provided in the `.testing` -directory, and is intended for Travis-CI builds, but may also be a good -reference point for other Linux distributions. - -In the future, this step may be replaced with a more generalized build system, -such as CMake or automake. +New diagnostics do not report as a fail, and are not tracked by any CIs, but +the test will report a warning to the user. ## Tests -Using `test` will run through the test suite. +Using `test` will run through the full test suite. ``` make test ``` -This will run through the following tests: +The tests are gathered into the following groups. - `test.regressions`: Regression tests relative to a code state (when enabled) - `test.grids`: Symmetric vs nonsymmetric grids @@ -140,13 +207,8 @@ This will run through the following tests: - `test.nans`: NaN initialization of allocated arrays - `test.dims`: Dimensional scaling (length, time, thickness, depth) -To enable the regression tests, use `DO_REGRESSION_TEST=true`. -``` -make test DO_REGRESSION_TESTS=true -``` - -Each test can also be run individually. For example, the following command -will only run the grid tests. +Each group of tests can also be run individually, such as in the following +example. ``` make test.grids ``` @@ -157,26 +219,27 @@ fail if the answers differ from this build. ## Test configurations -The following test configurations (TCs) are supported: +The following model test configurations (TCs) are supported, and are based on +configurations in the MOM6-examples repository. -- tc0: Unit testing of various model components, based on `unit_tests` -- tc1: A low-resolution version of the `benchmark` configuration - - tc1.a: Use the un-split mode with Runge-Kutta 3 time integration - - tc1.b: Use the un-split mode with Runge-Kutta 2 time integration -- tc2: An ALE configuration based on tc1 with tides - - tc2.a: Use sigma, PPM_H4 and no tides -- tc3: An open-boundary condition (OBC) test based on `circle_obcs` +- `tc0`: Unit testing of various model components, based on `unit_tests` +- `tc1`: A low-resolution version of the `benchmark` configuration + - `tc1.a`: Use the un-split mode with Runge-Kutta 3 time integration + - `tc1.b`: Use the un-split mode with Runge-Kutta 2 time integration +- `tc2`: An ALE configuration based on tc1 with tides + - `tc2.a`: Use sigma, PPM_H4 and no tides +- `tc3`: An open-boundary condition (OBC) test based on `circle_obcs` ## Code coverage -Code coverage reports the lines of code which have been tested, and can -explicitly demonstrate when a particular operation is untested. +Code coverage reports the lines of code which have been tested, and can be used +to determine if a particular section is untested. Coverage is measured using `gcov` and is reported for TCs using the `symmetric` executable. -Coverage reporting is optionally sent to the `codecov.io` site. +Coverage reporting is optionally uploaded to the `codecov.io` site. ``` https://codecov.io/gh/NOAA-GFDL/MOM6 ``` @@ -184,7 +247,7 @@ This is disabled on default, but can be enabled by the `REPORT_COVERAGE` flag. ``` make test REPORT_COVERAGE=true ``` -Note that any uploads will require a valid token generated by CodeCov. +Note that any uploads will require a valid CodeCov token. ## Running on Travis @@ -194,6 +257,8 @@ suite is triggered and the code changes are tested. When the tests are run on Travis, the following variables are re-defined: +- `DO_REPRO_TESTS` is set to `true` for all tests. + - `DO_REGRESSION_TESTS` is set to `true` for a PR submission, and is unset for code pushes. @@ -209,11 +274,3 @@ When the tests are run on Travis, the following variables are re-defined: a PR, this is the name of the branch which is receiving the PR. - `REPORT_COVERAGE` is set to `true`. - -## Running under slurm - -By default the executables are invoked using `mpirun`. Under slurm you might need to -use `srun` (such as on GFDL's gaea HPC): -``` -make MPIRUN=srun test -``` diff --git a/.testing/linux-ubuntu-xenial-gnu.mk b/.testing/linux-ubuntu-xenial-gnu.mk deleted file mode 100644 index 04ba952408..0000000000 --- a/.testing/linux-ubuntu-xenial-gnu.mk +++ /dev/null @@ -1,279 +0,0 @@ -# Template for the GNU Compiler Collection on Xenial version of Ubuntu Linux systems (used by Travis-CI) -# -# Typical use with mkmf -# mkmf -t linux-ubuntu-xenial-gnu.mk -c"-Duse_libMPI -Duse_netCDF" path_names /usr/local/include - -############ -# Commands Macors -FC = mpif90 -CC = mpicc -LD = mpif90 $(MAIN_PROGRAM) - -####################### -# Build target macros -# -# Macros that modify compiler flags used in the build. Target -# macrose are usually set on the call to make: -# -# make REPRO=on NETCDF=3 -# -# Most target macros are activated when their value is non-blank. -# Some have a single value that is checked. Others will use the -# value of the macro in the compile command. - -DEBUG = # If non-blank, perform a debug build (Cannot be - # mixed with REPRO or TEST) - -REPRO = # If non-blank, perform a build that guarentees - # reprodicuibilty from run to run. Cannot be used - # with DEBUG or TEST - -TEST = # If non-blank, use the compiler options defined in - # the FFLAGS_TEST and CFLAGS_TEST macros. Cannot be - # use with REPRO or DEBUG - -VERBOSE = # If non-blank, add additional verbosity compiler - # options - -OPENMP = # If non-blank, compile with openmp enabled - -NO_OVERRIDE_LIMITS = # If non-blank, do not use the -qoverride-limits - # compiler option. Default behavior is to compile - # with -qoverride-limits. - -NETCDF = # If value is '3' and CPPDEFS contains - # '-Duse_netCDF', then the additional cpp macro - # '-Duse_LARGEFILE' is added to the CPPDEFS macro. - -INCLUDES = # A list of -I Include directories to be added to the - # the compile command. - -SSE = # The SSE options to be used to compile. If blank, - # than use the default SSE settings for the host. - # Current default is to use SSE2. - -COVERAGE = # Add the code coverage compile options. - -INIT = # Enable aggressive initialization - -# Need to use at least GNU Make version 3.81 -need := 3.81 -ok := $(filter $(need),$(firstword $(sort $(MAKE_VERSION) $(need)))) -ifneq ($(need),$(ok)) -$(error Need at least make version $(need). Load module gmake/3.81) -endif - -# REPRO, DEBUG and TEST need to be mutually exclusive of each other. -# Make sure the user hasn't supplied two at the same time -ifdef REPRO -ifneq ($(DEBUG),) -$(error Options REPRO and DEBUG cannot be used together) -else ifneq ($(TEST),) -$(error Options REPRO and TEST cannot be used together) -endif -else ifdef DEBUG -ifneq ($(TEST),) -$(error Options DEBUG and TEST cannot be used together) -endif -endif - -MAKEFLAGS += --jobs=$(shell grep '^processor' /proc/cpuinfo | wc -l) - -# Macro for Fortran preprocessor -FPPFLAGS := $(INCLUDES) -# Fortran Compiler flags for the NetCDF library -FPPFLAGS += $(shell nf-config --fflags) - -# Base set of Fortran compiler flags -FFLAGS := -fcray-pointer -fdefault-double-8 -fdefault-real-8 -Waliasing -ffree-line-length-none -fno-range-check - -# Flags based on perforance target (production (OPT), reproduction (REPRO), or debug (DEBUG) -FFLAGS_OPT = -O3 -FFLAGS_REPRO = -O2 -fbounds-check -FFLAGS_DEBUG = -O0 -g -W -Wno-compare-reals -fbounds-check -fbacktrace -ffpe-trap=invalid,zero,overflow -# Enable aggressive initialization -ifdef INIT -FFLAGS_DEBUG += -finit-real=snan -finit-integer=2147483647 -finit-derived -endif - -# Flags to add additional build options -FFLAGS_OPENMP = -fopenmp -FFLAGS_VERBOSE = -FFLAGS_COVERAGE = --coverage - -# Macro for C preprocessor -CPPFLAGS = $(INCLUDES) -# C Compiler flags for the NetCDF library -CPPFLAGS += $(shell nf-config --cflags) - -# Base set of C compiler flags -CFLAGS := -D__IFC - -# Flags based on perforance target (production (OPT), reproduction (REPRO), or debug (DEBUG) -CFLAGS_OPT = -O2 -CFLAGS_REPRO = -O2 -CFLAGS_DEBUG = -O0 -g - -# Flags to add additional build options -CFLAGS_OPENMP = -fopenmp -CFLAGS_VERBOSE = -CFLAGS_COVERAGE = --coverage - -# Optional Testing compile flags. Mutually exclusive from DEBUG, REPRO, and OPT -# *_TEST will match the production if no new option(s) is(are) to be tested. -FFLAGS_TEST = $(FFLAGS_OPT) -CFLAGS_TEST = $(CFLAGS_OPT) - -# Linking flags -LDFLAGS := -LDFLAGS_OPENMP := -fopenmp -LDFLAGS_VERBOSE := -LDFLAGS_COVERAGE := --coverage - -# Start with a blank LIBS -LIBS = -# NetCDF library flags -LIBS += $(shell nf-config --flibs) - -# Get compile flags based on target macros. -ifdef REPRO -CFLAGS += $(CFLAGS_REPRO) -FFLAGS += $(FFLAGS_REPRO) -else ifdef DEBUG -CFLAGS += $(CFLAGS_DEBUG) -FFLAGS += $(FFLAGS_DEBUG) -else ifdef TEST -CFLAGS += $(CFLAGS_TEST) -FFLAGS += $(FFLAGS_TEST) -else -CFLAGS += $(CFLAGS_OPT) -FFLAGS += $(FFLAGS_OPT) -endif - -ifdef OPENMP -CFLAGS += $(CFLAGS_OPENMP) -FFLAGS += $(FFLAGS_OPENMP) -LDFLAGS += $(LDFLAGS_OPENMP) -endif - -ifdef SSE -CFLAGS += $(SSE) -FFLAGS += $(SSE) -endif - -ifdef NO_OVERRIDE_LIMITS -FFLAGS += $(FFLAGS_OVERRIDE_LIMITS) -endif - -ifdef VERBOSE -CFLAGS += $(CFLAGS_VERBOSE) -FFLAGS += $(FFLAGS_VERBOSE) -LDFLAGS += $(LDFLAGS_VERBOSE) -endif - -ifeq ($(NETCDF),3) - # add the use_LARGEFILE cppdef - ifneq ($(findstring -Duse_netCDF,$(CPPDEFS)),) - CPPDEFS += -Duse_LARGEFILE - endif -endif - -ifdef COVERAGE -ifdef BUILDROOT -PROF_DIR=-prof-dir=$(BUILDROOT) -endif -CFLAGS += $(CFLAGS_COVERAGE) $(PROF_DIR) -FFLAGS += $(FFLAGS_COVERAGE) $(PROF_DIR) -LDFLAGS += $(LDFLAGS_COVERAGE) $(PROF_DIR) -endif - -LDFLAGS += $(LIBS) - -#--------------------------------------------------------------------------- -# you should never need to change any lines below. - -# see the MIPSPro F90 manual for more details on some of the file extensions -# discussed here. -# this makefile template recognizes fortran sourcefiles with extensions -# .f, .f90, .F, .F90. Given a sourcefile ., where is one of -# the above, this provides a number of default actions: - -# make .opt create an optimization report -# make .o create an object file -# make .s create an assembly listing -# make .x create an executable file, assuming standalone -# source -# make .i create a preprocessed file (for .F) -# make .i90 create a preprocessed file (for .F90) - -# The macro TMPFILES is provided to slate files like the above for removal. - -RM = rm -f -TMPFILES = .*.m *.B *.L *.i *.i90 *.l *.s *.mod *.opt - -.SUFFIXES: .F .F90 .H .L .T .f .f90 .h .i .i90 .l .o .s .opt .x - -.f.L: - $(FC) $(FFLAGS) -c -listing $*.f -.f.opt: - $(FC) $(FFLAGS) -c -opt_report_level max -opt_report_phase all -opt_report_file $*.opt $*.f -.f.l: - $(FC) $(FFLAGS) -c $(LIST) $*.f -.f.T: - $(FC) $(FFLAGS) -c -cif $*.f -.f.o: - $(FC) $(FFLAGS) -c $*.f -.f.s: - $(FC) $(FFLAGS) -S $*.f -.f.x: - $(FC) $(FFLAGS) -o $*.x $*.f *.o $(LDFLAGS) -.f90.L: - $(FC) $(FFLAGS) -c -listing $*.f90 -.f90.opt: - $(FC) $(FFLAGS) -c -opt_report_level max -opt_report_phase all -opt_report_file $*.opt $*.f90 -.f90.l: - $(FC) $(FFLAGS) -c $(LIST) $*.f90 -.f90.T: - $(FC) $(FFLAGS) -c -cif $*.f90 -.f90.o: - $(FC) $(FFLAGS) -c $*.f90 -.f90.s: - $(FC) $(FFLAGS) -c -S $*.f90 -.f90.x: - $(FC) $(FFLAGS) -o $*.x $*.f90 *.o $(LDFLAGS) -.F.L: - $(FC) $(CPPDEFS) $(FPPFLAGS) $(FFLAGS) -c -listing $*.F -.F.opt: - $(FC) $(CPPDEFS) $(FPPFLAGS) $(FFLAGS) -c -opt_report_level max -opt_report_phase all -opt_report_file $*.opt $*.F -.F.l: - $(FC) $(CPPDEFS) $(FPPFLAGS) $(FFLAGS) -c $(LIST) $*.F -.F.T: - $(FC) $(CPPDEFS) $(FPPFLAGS) $(FFLAGS) -c -cif $*.F -.F.f: - $(FC) $(CPPDEFS) $(FPPFLAGS) -EP $*.F > $*.f -.F.i: - $(FC) $(CPPDEFS) $(FPPFLAGS) -P $*.F -.F.o: - $(FC) $(CPPDEFS) $(FPPFLAGS) $(FFLAGS) -c $*.F -.F.s: - $(FC) $(CPPDEFS) $(FPPFLAGS) $(FFLAGS) -c -S $*.F -.F.x: - $(FC) $(CPPDEFS) $(FPPFLAGS) $(FFLAGS) -o $*.x $*.F *.o $(LDFLAGS) -.F90.L: - $(FC) $(CPPDEFS) $(FPPFLAGS) $(FFLAGS) -c -listing $*.F90 -.F90.opt: - $(FC) $(CPPDEFS) $(FPPFLAGS) $(FFLAGS) -c -opt_report_level max -opt_report_phase all -opt_report_file $*.opt $*.F90 -.F90.l: - $(FC) $(CPPDEFS) $(FPPFLAGS) $(FFLAGS) -c $(LIST) $*.F90 -.F90.T: - $(FC) $(CPPDEFS) $(FPPFLAGS) $(FFLAGS) -c -cif $*.F90 -.F90.f90: - $(FC) $(CPPDEFS) $(FPPFLAGS) -EP $*.F90 > $*.f90 -.F90.i90: - $(FC) $(CPPDEFS) $(FPPFLAGS) -P $*.F90 -.F90.o: - $(FC) $(CPPDEFS) $(FPPFLAGS) $(FFLAGS) -c $*.F90 -.F90.s: - $(FC) $(CPPDEFS) $(FPPFLAGS) $(FFLAGS) -c -S $*.F90 -.F90.x: - $(FC) $(CPPDEFS) $(FPPFLAGS) $(FFLAGS) -o $*.x $*.F90 *.o $(LDFLAGS) diff --git a/.testing/tc0/MOM_input b/.testing/tc0/MOM_input index 217b2d2c3d..ff64c55803 100644 --- a/.testing/tc0/MOM_input +++ b/.testing/tc0/MOM_input @@ -138,6 +138,9 @@ THICKNESS_CONFIG = "uniform" ! ! === module MOM_diag_mediator === +USE_GRID_SPACE_DIAG_COORDINATE_AXES = True ! [Boolean] default = False + ! If true, use a grid index coordinate convention for diagnostic axes. + ! === module MOM_MEKE === ! === module MOM_lateral_mixing_coeffs === @@ -227,3 +230,10 @@ ENERGYSAVEDAYS = 1.0 DIAG_AS_CHKSUM = True DEBUG = True +DEFAULT_2018_ANSWERS = True ! [Boolean] default = True +GRID_ROTATION_ANGLE_BUGS = True ! [Boolean] default = True +USE_GM_WORK_BUG = True ! [Boolean] default = True +FIX_UNSPLIT_DT_VISC_BUG = False ! [Boolean] default = False +USE_LAND_MASK_FOR_HVISC = False ! [Boolean] default = False +GUST_CONST = 0.02 ! [Pa] default = 0.02 +FIX_USTAR_GUSTLESS_BUG = False ! [Boolean] default = False diff --git a/.testing/tc1.a/MOM_tc_variant b/.testing/tc1.a/MOM_tc_variant index 8032901a82..26407baf50 100644 --- a/.testing/tc1.a/MOM_tc_variant +++ b/.testing/tc1.a/MOM_tc_variant @@ -1 +1,2 @@ #override SPLIT=False +#override FIX_UNSPLIT_DT_VISC_BUG = False ! [Boolean] default = False diff --git a/.testing/tc1.b/MOM_tc_variant b/.testing/tc1.b/MOM_tc_variant index 8d821691f3..173196f164 100644 --- a/.testing/tc1.b/MOM_tc_variant +++ b/.testing/tc1.b/MOM_tc_variant @@ -1,2 +1,3 @@ #override SPLIT=False #override USE_RK2=True +#override FIX_UNSPLIT_DT_VISC_BUG = False ! [Boolean] default = False diff --git a/.testing/tc1/MOM_input b/.testing/tc1/MOM_input index 80fdd90860..68674f7a86 100644 --- a/.testing/tc1/MOM_input +++ b/.testing/tc1/MOM_input @@ -574,3 +574,16 @@ ENERGYSAVEDAYS = 0.125 ! [days] default = 3600.0 ! energies of the run and other globally summed diagnostics. DIAG_AS_CHKSUM = True DEBUG = True +USE_PSURF_IN_EOS = False ! [Boolean] default = False +DEFAULT_2018_ANSWERS = True ! [Boolean] default = True +GRID_ROTATION_ANGLE_BUGS = True ! [Boolean] default = True +INTERPOLATE_RES_FN = True ! [Boolean] default = True +GILL_EQUATORIAL_LD = False ! [Boolean] default = False +USE_GM_WORK_BUG = True ! [Boolean] default = True +USE_LAND_MASK_FOR_HVISC = False ! [Boolean] default = False +KAPPA_SHEAR_ITER_BUG = True ! [Boolean] default = True +KAPPA_SHEAR_ALL_LAYER_TKE_BUG = True ! [Boolean] default = True +BULKML_CONV_MOMENTUM_BUG = True ! [Boolean] default = True +PEN_SW_ABSORB_MINTHICK = 0.001 ! [m] default = 0.001 +GUST_CONST = 0.02 ! [Pa] default = 0.02 +FIX_USTAR_GUSTLESS_BUG = False ! [Boolean] default = False diff --git a/.testing/tc2/MOM_input b/.testing/tc2/MOM_input index c037648d95..1818390192 100644 --- a/.testing/tc2/MOM_input +++ b/.testing/tc2/MOM_input @@ -297,6 +297,10 @@ BOUND_CORIOLIS = True ! [Boolean] default = False ! v-points, and similarly at v-points. This option would ! have no effect on the SADOURNY Coriolis scheme if it ! were possible to use centered difference thickness fluxes. +PGF_STANLEY_T2_DET_COEFF = 0.5 ! [nondim] default = -1.0 + ! The coefficient correlating SGS temperature variance with the mean temperature + ! gradient in the deterministic part of the Stanley form of the Brankart + ! correction. Negative values disable the scheme. ! === module MOM_hor_visc === LAPLACIAN = True @@ -426,6 +430,10 @@ KHTH = 1.0 ! [m2 s-1] default = 0.0 ! The background horizontal thickness diffusivity. KHTH_MAX = 900.0 ! [m2 s-1] default = 0.0 ! The maximum horizontal thickness diffusivity. +STANLEY_PRM_DET_COEFF = 0.5 ! [nondim] default = -1.0 + ! The coefficient correlating SGS temperature variance with the mean temperature + ! gradient in the deterministic part of the Stanley parameterization. Negative + ! values disable the scheme. ! === module MOM_mixed_layer_restrat === FOX_KEMPER_ML_RESTRAT_COEF = 5.0 ! [nondim] default = 0.0 @@ -600,3 +608,15 @@ ENERGYSAVEDAYS = 0.5 ! [days] default = 3600.0 ! energies of the run and other globally summed diagnostics. DIAG_AS_CHKSUM = True DEBUG = True +USE_GM_WORK_BUG = False +USE_PSURF_IN_EOS = False ! [Boolean] default = False +DEFAULT_2018_ANSWERS = True ! [Boolean] default = True +GRID_ROTATION_ANGLE_BUGS = True ! [Boolean] default = True +REMAP_UV_USING_OLD_ALG = True ! [Boolean] default = True +USE_LAND_MASK_FOR_HVISC = False ! [Boolean] default = False +KAPPA_SHEAR_ITER_BUG = True ! [Boolean] default = True +KAPPA_SHEAR_ALL_LAYER_TKE_BUG = True ! [Boolean] default = True +USE_MLD_ITERATION = False ! [Boolean] default = False +PEN_SW_ABSORB_MINTHICK = 0.001 ! [m] default = 0.001 +GUST_CONST = 0.02 ! [Pa] default = 0.02 +FIX_USTAR_GUSTLESS_BUG = False ! [Boolean] default = False diff --git a/.testing/tc3/MOM_input b/.testing/tc3/MOM_input index 4026665f11..9112898b4c 100644 --- a/.testing/tc3/MOM_input +++ b/.testing/tc3/MOM_input @@ -469,3 +469,12 @@ ENERGYSAVEDAYS = 3.0 ! [hours] default = 1.44E+04 ! energies of the run and other globally summed diagnostics. DIAG_AS_CHKSUM = True DEBUG = True +DEFAULT_2018_ANSWERS = True ! [Boolean] default = True +OBC_RADIATION_MAX = 10.0 ! [nondim] default = 10.0 +GRID_ROTATION_ANGLE_BUGS = True ! [Boolean] default = True +USE_GM_WORK_BUG = True ! [Boolean] default = True +USE_LAND_MASK_FOR_HVISC = False ! [Boolean] default = False +KAPPA_SHEAR_ITER_BUG = True ! [Boolean] default = True +KAPPA_SHEAR_ALL_LAYER_TKE_BUG = True ! [Boolean] default = True +GUST_CONST = 0.02 ! [Pa] default = 0.02 +FIX_USTAR_GUSTLESS_BUG = False ! [Boolean] default = False diff --git a/.testing/tc4/.gitignore b/.testing/tc4/.gitignore new file mode 100644 index 0000000000..29f62fb208 --- /dev/null +++ b/.testing/tc4/.gitignore @@ -0,0 +1,4 @@ +ocean_hgrid.nc +sponge.nc +temp_salt_ic.nc +topog.nc diff --git a/.testing/tc4/MOM_input b/.testing/tc4/MOM_input index 2b08e9bccb..04598a9dc9 100644 --- a/.testing/tc4/MOM_input +++ b/.testing/tc4/MOM_input @@ -320,9 +320,6 @@ DTBT = 10.0 ! [s or nondim] default = -0.98 ! Parameterization of enhanced mixing due to convection via CVMix ! === module MOM_entrain_diffusive === -CORRECT_DENSITY = False ! [Boolean] default = True - ! If true, and USE_EOS is true, the layer densities are restored toward their - ! target values by the diapycnal mixing, as described in Hallberg (MWR, 2000). ! === module MOM_set_diffusivity === BBL_EFFIC = 0.0 ! [nondim] default = 0.2 @@ -410,3 +407,20 @@ MAXCPU = 2.88E+04 ! [wall-clock seconds] default = -1.0 DIAG_AS_CHKSUM = True DEBUG = True + +USE_PSURF_IN_EOS = False ! [Boolean] default = False +DEFAULT_2018_ANSWERS = True ! [Boolean] default = True +GRID_ROTATION_ANGLE_BUGS = True ! [Boolean] default = True +INTERPOLATE_RES_FN = True ! [Boolean] default = True +GILL_EQUATORIAL_LD = False ! [Boolean] default = False +USE_GM_WORK_BUG = True ! [Boolean] default = True +FIX_UNSPLIT_DT_VISC_BUG = False ! [Boolean] default = False +REMAP_UV_USING_OLD_ALG = True ! [Boolean] default = True +USE_LAND_MASK_FOR_HVISC = False ! [Boolean] default = False +KAPPA_SHEAR_ITER_BUG = True ! [Boolean] default = True +KAPPA_SHEAR_ALL_LAYER_TKE_BUG = True ! [Boolean] default = True +USE_MLD_ITERATION = False ! [Boolean] default = False +PEN_SW_ABSORB_MINTHICK = 0.001 ! [m] default = 0.001 +GUST_CONST = 0.02 ! [Pa] default = 0.02 +FIX_USTAR_GUSTLESS_BUG = False ! [Boolean] default = False + diff --git a/.testing/tc4/Makefile b/.testing/tc4/Makefile index cea78bf3bd..a9aa395b9c 100644 --- a/.testing/tc4/Makefile +++ b/.testing/tc4/Makefile @@ -1,3 +1,8 @@ -all: +OUT=ocean_hgrid.nc sponge.nc temp_salt_ic.nc topog.nc + +$(OUT): python build_grid.py python build_data.py + +clean: + rm -rf $(OUT) diff --git a/.travis.yml b/.travis.yml index ac7cab1b14..22c497f916 100644 --- a/.travis.yml +++ b/.travis.yml @@ -5,19 +5,27 @@ language: c dist: bionic -# --depth flag is breaking our merge, try disabling it -# NOTE: We may be able to go back to depth=50 in production -git: - depth: false - addons: apt: sources: - ubuntu-toolchain-r-test packages: - - tcsh pkg-config netcdf-bin libnetcdf-dev libnetcdff-dev openmpi-bin libopenmpi-dev gfortran + - tcsh pkg-config netcdf-bin libnetcdf-dev libnetcdff-dev gfortran + - mpich libmpich-dev - doxygen graphviz flex bison cmake - python-numpy python-netcdf4 + - python3 python3-dev python3-venv python3-pip + - bc + +# Environment variables +env: + global: + - TIMEFORMAT: "\"Time: %lR (user: %lU, sys: %lS)\"" + - FCFLAGS_DEBUG: "\"-g -O0 -Wextra -Wno-compare-reals -fbacktrace -ffpe-trap=invalid,zero,overflow -fcheck=bounds\"" + - FCFLAGS_REPRO: "\"-g -O2 -fbacktrace\"" + - FCFLAGS_INIT: "\"-finit-real=snan -finit-integer=2147483647 -finit-derived\"" + - FCFLAGS_COVERAGE: "\"--coverage\"" + - DO_REPRO_TESTS: true jobs: include: @@ -31,32 +39,55 @@ jobs: - test ! -s doxy_errors - env: - - JOB="Configuration testing" + - JOB="x86 verification testing" - DO_REGRESSION_TESTS=false - - MKMF_TEMPLATE=linux-ubuntu-xenial-gnu.mk script: - cd .testing - echo 'Build executables...' && echo -en 'travis_fold:start:script.1\\r' - - make all + - time make all - echo -en 'travis_fold:end:script.1\\r' - - echo 'Running tests...' && echo -en 'travis_fold:start:script.2\\r' - - make test - - echo -en 'travis_fold:end:script.2\\r' + - time make -k -s test + - make test.summary # NOTE: Code coverage upload is here to reduce load imbalance + # We do coverage with the regressions if part of a pull request + # otherwise as a separate job. - if: type = pull_request env: - - JOB="Regression testing" + - JOB="x86 Regression testing" - DO_REGRESSION_TESTS=true - REPORT_COVERAGE=true - - MKMF_TEMPLATE=linux-ubuntu-xenial-gnu.mk - MOM_TARGET_SLUG=${TRAVIS_REPO_SLUG} - MOM_TARGET_LOCAL_BRANCH=${TRAVIS_BRANCH} script: - cd .testing - echo 'Build executables...' && echo -en 'travis_fold:start:script.1\\r' - - make build.regressions + - time make build.regressions + - echo -en 'travis_fold:end:script.1\\r' + - time make -k -s test.regressions + - make test.summary + + - if: NOT type = pull_request + env: + - JOB="Coverage upload" + - REPORT_COVERAGE=true + - DO_REGRESSION_TESTS=false + script: + - cd .testing + - echo 'Build executables...' && echo -en 'travis_fold:start:script.1\\r' + - make build/symmetric/MOM6 + - echo -en 'travis_fold:end:script.1\\r' + - make -k -s run.symmetric + + - arch: arm64 + env: + - JOB="ARM64 verification testing" + - DO_REGRESSION_TESTS=false + - DO_REPRO_TESTS=false + script: + - cd .testing + - echo 'Build executables...' && echo -en 'travis_fold:start:script.1\\r' + - time make all - echo -en 'travis_fold:end:script.1\\r' - - echo 'Running tests...' && echo -en 'travis_fold:start:script.2\\r' - - make test.regressions - - echo -en 'travis_fold:end:script.2\\r' + - time make -k -s test + - make test.summary diff --git a/README.md b/README.md index 3e4ff016e3..dfbfafc7d0 100644 --- a/README.md +++ b/README.md @@ -6,12 +6,14 @@ This is the MOM6 source code. + # Where to find information Start at the [MOM6-examples wiki](https://github.com/NOAA-GFDL/MOM6-examples/wiki) which has installation instructions. [Source code documentation](http://mom6.readthedocs.io/) is hosted on read the docs. + # What files are what The top level directory structure groups source code and input files as follow: @@ -23,7 +25,19 @@ The top level directory structure groups source code and input files as follow: | ```src/``` | Contains the source code for MOM6 that is always compiled. | | ```config_src/``` | Contains optional source code depending on mode and configuration such as dynamic-memory versus static, ocean-only versus coupled. | | ```pkg/``` | Contains third party (non-MOM6 or FMS) code that is compiled into MOM6. | -| ```docs/``` | Workspace for generated documentation. | +| ```docs/``` | Workspace for generated documentation. See [docs/README.md](docs/README.md) | +| ```.testing/``` | Contains the verification test suite. See [.testing/README.md](.testing/README.md) | +| ```ac/``` | Contains the autoconf build configuration files. See [ac/README.md](ac/README.md) | + + +# Quick start guide + +To quickly get started and build an ocean-only MOM6 executable, see the +[autoconf README](ac/README.md). + +For setting up an experiment, or building an executable for coupled modeling, +consult the [MOM6-examples wiki](https://github.com/NOAA-GFDL/MOM6-examples/wiki). + # Disclaimer diff --git a/ac/Makefile.in b/ac/Makefile.in new file mode 100644 index 0000000000..ce8173e6f1 --- /dev/null +++ b/ac/Makefile.in @@ -0,0 +1,78 @@ +# Makefile template for MOM6 +# +# Compiler flags are configured by autoconf's configure script. +# +# Source code dependencies are configured by mkmf and list_paths, specified in +# the `Makefile.mkmf` file. +# +# mkmf conventions are close, but not identical, to autoconf. We attempt to +# map the autoconf variables to the mkmf variables. +# +# The following variables are used by Makefiles generated by mkmf. +# +# CC: C compiler +# CXX: C++ compiler +# FC: Fortran compiler (f77 and f90) +# LD: Linker +# +# CPPDEFS: Preprocessor macros +# CPPFLAGS: C preprocessing flags +# CXXFLAGS: C++ preprocessing flags +# FPPFLAGS: Fortran preprocessing flags +# +# CFLAGS: C compiler flags +# FFLAGS: Fortran compiler flags +# LDFLAGS: Linker flags + libraries +# +# NOTES: +# - FPPFLAGS and FFLAGS always appear as a pair, and autoconf does not use +# FPPFLAGS, so FPPFLAGS does not serve much purpose. +# +# - mkmf's FFLAGS does not distinguish between autoconf's fixed-format +# FFLAGS and free-format FCFLAGS. +# +# - LDFLAGS does not distinguish between autoconf's LDFLAGS and LIBS. +# It also places both after the executable rather than just LIBS. +# +# OTHERFLAGS: Additional flags for all languages (C, C++, Fortran) +# OTHER_CFLAGS: Optional C flags +# OTHER_CXXFLAGS: Optional C++ flags +# OTHER_FFLAGS: Optional Fortran flags +# +# TMPFILES: Placeholder for `make clean` deletion (as `make neat`). + +FC = @FC@ +LD = @FC@ + +CPPDEFS = @DEFS@ +CPPFLAGS = @CPPFLAGS@ +FFLAGS = @FCFLAGS@ +LDFLAGS = @LDFLAGS@ @LIBS@ + +# Gather modulefiles +TMPFILES = $(wildcard *.mod) + +include Makefile.mkmf + + +# Delete any files associated with configuration (including the Makefile). +.PHONY: distclean +distclean: clean + # configure output + rm -f config.log + rm -f config.status + rm -f Makefile + # mkmf output + rm -f path_names + rm -f Makefile.mkmf + + +# This deletes all files generated by autoconf, including configure. +# It is more aggressive than automake's maintainer-clean. +# NOTE: Not a standard GNU target, this is for internal use only. +# Don't be surprised if the name changes or if it disappears someday. +.PHONY: ac-clean +ac-clean: distclean + rm -f @srcdir@/ac/aclocal.m4 + rm -rf @srcdir@/ac/autom4te.cache + rm -f @srcdir@/ac/configure diff --git a/ac/README.md b/ac/README.md new file mode 100644 index 0000000000..d5a5310ab8 --- /dev/null +++ b/ac/README.md @@ -0,0 +1,187 @@ +# Autoconf Build Configuration + +This directory contains the configuration files required to build MOM6 using +Autoconf. + +Note that a top-level `./configure` is not contained in the repository, and the +instruction below will generate this script in the `ac` directory. + + +# Requirements + +The following tools and libraries must be installed on your system. + +* Autoconf +* Fortran compiler (e.g. GFortran) +* MPI (e.g. Open MPI, MPICH) +* netCDF, with Fortran support + +On some platforms, such as macOS, the Autoconf package may also require an +installation of Automake. + +Some packages such as netCDF may require an additional packages for Fortran +support. + + +# Quick start guide + +The following instructions will allow a new user to quickly create a MOM6 +executable for ocean-only simulations. + +Each set of instructions is meant to be run from the root directory of the +repository. + +A separate Makefile in `ac/deps/` is provided to gather and build any GFDL +dependencies. +``` +$ cd ac/deps +$ make -j +``` +This will fetch the `mkmf` tool and build the FMS library. + +To build MOM6, first generate the Autoconf `configure` script. +``` +$ cd ac +$ autoreconf +``` +Then select your build directory, e.g. `./build`, run the configure script, and +build the model. +``` +$ mkdir -p build +$ cd build +$ ../ac/configure +$ make -j +``` +This will create the MOM6 executable in the build directory. + +This executable is only useable for ocean-only simulations, and cannot be used +for coupled modeling. It also requires the necessary experiment configuration +files, such as `input.nml` and `MOM_input`. For more information, consult the +[MOM6-examples wiki](https://github.com/NOAA-GFDL/MOM6-examples/wiki). + + +# Build rules + +The Makefile produced by Autoconf provides the following rules. + +``make`` + + Build the MOM6 executable. + +``make clean`` + + Delete the executable and any object and module files, but preserve the + Autoconf output. + +``make distclean`` + + Delete all of the files above, as well as any files generated by + `./configure`. Note that this will delete the Makefile containing this rule. + +``make ac-clean`` + + Delete all of the files above, including `./configure` and any other files + created by `autoreconf`. As with `make distclean`, this will also delete the + Makefile containing this rule. + + +# Build configuration settings + +Autoconf will resolve most model dependencies, and includes the standard set of +configuration options, such as `FC` or `FCFLAGS`. The `configure` settings +specific to MOM6 are described below. + +`--enable-asymmetric` + + The MOM6 executable is configured to use symmetric grids by default. + + Use the flag above to compile using uniform (asymmetric) grids. + + Symmetric grids are defined such that the fields for every C-grid cell are + fully specified by their local values. In particular, quantities such as + velocities or vorticity are defined along the boundaries of the domain. + + Use of symmetric grids simplifies many calculations, but also results in + nonuniform domain sizes for different fields, and slightly greater storage + since the additional values can be considered redundant. + +`--enable-openmp` + + Use this flag to enable OpenMP in the build. + +`--disable-real-8` + + While MOM6 does not explicitly use double precision reals, most of the + algorithms are designed and tested under this assumption, and the default + configuration is to enforce 8-byte reals. + + This flag may be used to relax this requirement, causing the compiler to use + the default size (usually single precision reals), although there is no + guarantee that the model will be usable. + +For the complete list of settings, run `./configure --help`. + + +# GFDL Dependencies + +This section briefly describes the management of GFDL dependencies `mkmf` and +FMS. + +The `configure` script will first check if the compiler and its configured +flags (`FCFLAGS`, `LDFLAGS`, etc.) can find `mkmf` and the FMS library. If +unavailable, then it will search in the local `ac/deps` library. If still +unavailable, then the build will abort. + +Running `make -C ac/deps` will ensure that the libraries are available. But if +the user wishes to target an external FMS library, then they should add the +appropriate `FCFLAGS` and `LDFLAGS` to find the library. + +Similar options are provided for `mkmf` with respect to `PATH`, although it +is usually not necessary to use an external `mkmf` script. + +Some configuration options are provided by the `ac/deps` Makefile: + +`PATH_ENV` + + This variable will override the value of `PATH` when building the dependencies. + +`FCFLAGS_ENV` + + Used to override the default Autoconf flags, `-g -O2`. This is useful if, + for example, one wants to build with `-O0` to speed up the build time. + +`MKMF_URL` (*default:* https://github.com/NOAA-GFDL/mkmf.git) + +`MKMF_COMMIT`(*default:* `master`) + +`FMS_URL` (*default:* https://github.com/NOAA-GFDL/FMS.git) + +`FMS_COMMIT` (*default:* `2019.01.03`) + + These are used to specify where to check out the source code for each + respective project. + +Additional hooks for FMS builds do not yet exist, but can be added if +necessary. + + +# Known issues / Future development + +## MPI configuration + +There are minor issues with the MPI configuration macro, where it may use an +MPI build wrapper (e.g. `mpifort`) whose underlying compiler does not match +the `FC` compiler, which will often be auto-configured to `gfortran`. + +This is usually not an issue, but can cause confusion if `FCFLAGS` is +configured for the MPI wrapper but is incompatible with the `FC` compiler. + +To resolve this, ensure that `FC` and `FCFLAGS` are specified for the same +compiler. + + +## Coupled builds + +The Autoconf build is currently only capable of building ocean-only +executables, and cannot yet be used as part of a coupled model, nor as a +standalone library. This is planned to be addressed in a future release. diff --git a/ac/configure.ac b/ac/configure.ac new file mode 100644 index 0000000000..ee6b76dacb --- /dev/null +++ b/ac/configure.ac @@ -0,0 +1,174 @@ +# Autoconf configuration + +# NOTE: +# - We currently do not use a MOM6 version tag, but this would be one option in +# the future: +# [m4_esyscmd_s([git describe])] +# - Another option is `git rev-parse HEAD` for the full hash. +# - We would probably run this inside of a script to avoid the explicit +# dependency on git. + +AC_INIT( + [MOM6], + [ ], + [https://github.com/NOAA-GFDL/MOM6/issues], + [], + [https://github.com/NOAA-GFDL/MOM6]) + +#--- +# NOTE: For the autoconf-adverse, the configuration files and autoreconf output +# are kept in the `ac` directory. +# +# This breaks the convention where configure.ac resides in the top directory. +# +# As a result, $srcdir initially points to the `ac` directory, rather than the +# top directory of the codebase. +# +# In order to balance this, we up-path (../) srcdir and point AC_CONFIG_SRCDIR +# to srcdir and point AC_CONFIG_SRCDIR to the parent directory. +# +# Someday we may revert this and work from the top-level directory. But for +# now we will isolate autoconf to a subdirectory. +#--- + +# Validate srdcir and configure input +AC_CONFIG_SRCDIR([../src/core/MOM.F90]) +AC_CONFIG_MACRO_DIR([m4]) +srcdir=$srcdir/.. + + +# Default to symmetric grid +# NOTE: --enable is more properly used to add a feature, rather than to select +# a compile-time mode, so this is not exactly being used as intended. +MEM_LAYOUT=${srcdir}/config_src/dynamic_symmetric +AC_ARG_ENABLE([asymmetric], + AS_HELP_STRING([--enable-asymmetric], [Use the asymmetric grid])) +AS_IF([test "$enable_asymmetric" = yes], + [MEM_LAYOUT=${srcdir}/config_src/dynamic]) + + +# TODO: Rather than point to a pre-configured header file, autoconf could be +# used to configure a header based on a template. +#AC_CONFIG_HEADERS(["$MEM_LAYOUT/MOM_memory.h"]) + + +# Explicitly assume free-form Fortran +AC_LANG(Fortran) +AC_FC_SRCEXT(f90) + + +# Determine MPI compiler wrappers +# NOTE: +# - AX_MPI invokes AC_PROG_FC, often with gfortran, even if the MPI launcher +# does not use gfortran. +# - This can cause standard AC_PROG_FC tests to fail if FCFLAGS is configured +# with flags from another compiler. +# - I do not yet know how to resolve this possible issue. +AX_MPI([], + [AC_MSG_ERROR([Could not find MPI launcher.])]) + + +# Explicitly replace FC and LD with MPI wrappers +# NOTE: This is yet another attempt to manage the potential mismatches between +# FC and MPIFC. Without this step, the tests below would not use MPIFC. +AC_SUBST(FC, $MPIFC) +AC_SUBST(LD, $MPIFC) + +# Confirm that FC can see the Fortran 90 MPI module. +AX_FC_CHECK_MODULE([mpi], + [], [AC_MSG_ERROR([Could not find MPI Fortran module.])]) + + +# netCDF configuration +AC_PATH_PROG([NC_CONFIG], [nc-config]) +AS_IF([test -n "$NC_CONFIG"], + [CPPFLAGS="$CPPFLAGS -I$($NC_CONFIG --includedir)" + FCFLAGS="$FCFLAGS -I$($NC_CONFIG --includedir)" + LDFLAGS="$LDFLAGS -L$($NC_CONFIG --libdir)"], + [AC_MSG_ERROR([Could not find nc-config.])]) + +AX_FC_CHECK_MODULE([netcdf], + [], [AC_MSG_ERROR([Could not find FMS library.])]) +AX_FC_CHECK_LIB([netcdff], [nf_create], [netcdf], + [], [AC_MSG_ERROR([Could not link netcdff library.])] +) + + +# Force 8-byte reals +AX_FC_REAL8 +AS_IF( + [test "$enable_real8" != no], + [FCFLAGS="$FCFLAGS $REAL8_FCFLAGS"]) + + +# OpenMP configuration +AC_OPENMP +AS_IF( + [test "$enable_openmp" = yes], + [FCFLAGS="$FCFLAGS $OPENMP_FCFLAGS" + LDFLAGS="$LDFLAGS $OPENMP_FCFLAGS"]) + + +# FMS support + +# Test for fms_mod to verify FMS module access +AX_FC_CHECK_MODULE([fms_mod], [], [ + AS_UNSET([ax_fc_cv_mod_fms_mod]) + AX_FC_CHECK_MODULE([fms_mod], + [AC_SUBST([FCFLAGS], ["-I${srcdir}/ac/deps/include $FCFLAGS"])], + [AC_MSG_ERROR([Could not find fms_mod Fortran module.])], + [-I${srcdir}/ac/deps/include]) +]) + +# Test for fms_init to verify FMS library linking +AX_FC_CHECK_LIB([FMS], [fms_init], [fms_mod], + [], [ + AS_UNSET([ax_fc_cv_lib_FMS_fms_init]) + AX_FC_CHECK_LIB([FMS], [fms_init], [fms_mod], [ + AC_SUBST([LDFLAGS], ["-L${srcdir}/ac/deps/lib $LDFLAGS"]) + AC_SUBST([LIBS], ["-lFMS $LIBS"]) + ], + [AC_MSG_ERROR([Could not find FMS library.])], + [-L${srcdir}/ac/deps/lib]) + ] +) + + +# Search for mkmf build tools +AC_PATH_PROG([LIST_PATHS], [list_paths]) +AS_IF([test -z "$LIST_PATHS"], [ + AC_PATH_PROG([LIST_PATHS], [list_paths], [], ["$PATH:${srcdir}/ac/deps/bin"]) + AS_IF([test -z "$LIST_PATHS"], + [AC_MSG_ERROR([Could not find list_paths.])], + [AC_SUBST(PATH, ["$PATH:${srcdir}/ac/deps/bin"])]) + ] +) + +AC_PATH_PROG([MKMF], [mkmf]) +AS_IF([test -z "$MKMF"], [ + AC_PATH_PROG([MKMF], [mkmf], [], ["$PATH:${srcdir}/ac/deps/bin"]) + AS_IF([test -z "$MKMF"], + [AC_MSG_ERROR([Could not find mkmf.])], + [AC_SUBST(PATH, ["$PATH:${srcdir}/ac/deps/bin"])]) + ] +) + + +# NOTE: MEM_LAYOUT unneeded if we shift to MOM_memory.h.in template +AC_CONFIG_COMMANDS([path_names], + [list_paths -l \ + ${srcdir}/src \ + ${srcdir}/config_src/solo_driver \ + ${srcdir}/config_src/ext* \ + ${MEM_LAYOUT} +], [MEM_LAYOUT=$MEM_LAYOUT]) + + +AC_CONFIG_COMMANDS([Makefile.mkmf], + [mkmf -p MOM6 -m Makefile.mkmf path_names]) + + +# Prepare output +AC_SUBST(CPPFLAGS) +AC_CONFIG_FILES([Makefile:${srcdir}/ac/Makefile.in]) +AC_OUTPUT diff --git a/ac/deps/.gitignore b/ac/deps/.gitignore new file mode 100644 index 0000000000..8cfaa6ebcb --- /dev/null +++ b/ac/deps/.gitignore @@ -0,0 +1,5 @@ +/bin/ +/fms/ +/include/ +/lib/ +/mkmf/ diff --git a/ac/deps/Makefile b/ac/deps/Makefile new file mode 100644 index 0000000000..91fe343047 --- /dev/null +++ b/ac/deps/Makefile @@ -0,0 +1,106 @@ +SHELL = bash +.SUFFIXES: + +# FMS build configuration +PATH_ENV ?= +FCFLAGS_ENV ?= + +# Only set FCFLAGS if an argument is provided. +FMS_FCFLAGS = +ifneq ($(FCFLAGS_ENV),) + FMS_FCFLAGS := FCFLAGS="$(FCFLAGS_ENV)" +endif + + +# Ditto for path +FMS_PATH = +ifneq ($(PATH_ENV),) + FMS_PATH := PATH="$(PATH_ENV)" +endif + + +# mkmf, list_paths (GFDL build toolchain) +MKMF_URL ?= https://github.com/NOAA-GFDL/mkmf.git +MKMF_COMMIT ?= master + +# FMS framework +FMS_URL ?= https://github.com/NOAA-GFDL/FMS.git +FMS_COMMIT ?= 2019.01.03 + + +# List of source files to link this Makefile's dependencies to model Makefiles +# Assumes a depth of two, and the following extensions: F90 inc c h +# (1): Root directory +# NOTE: extensions could be a second variable +SOURCE = \ + $(foreach ext,F90 inc c h,$(wildcard $(1)/*/*.$(ext) $(1)/*/*/*.$(ext))) + +FMS_SOURCE = $(call SOURCE,fms/src) + + +#--- +# Rules + +.PHONY: all +all: bin/mkmf bin/list_paths lib/libFMS.a + + +#--- +# mkmf checkout + +bin/mkmf bin/list_paths: mkmf + mkdir -p $(@D) + cp $^/$@ $@ + +mkmf: + git clone $(MKMF_URL) $@ + git -C $@ checkout $(MKMF_COMMIT) + + +#--- +# FMS build + +# NOTE: We emulate the automake `make install` stage by storing libFMS.a to +# ${srcdir}/deps/lib and copying module files to ${srcdir}/deps/include. +# This is a flawed approach, since module files are untracked and could be +# handled more safely, but this is adequate for now. + +# TODO: track *.mod copy? +lib/libFMS.a: fms/build/libFMS.a fms/build/Makefile + mkdir -p {lib,include} + cp fms/build/libFMS.a lib/libFMS.a + cp fms/build/*.mod include + + +fms/build/libFMS.a: fms/build/Makefile + make -C fms/build libFMS.a + + +# TODO: Include FC, CC, CFLAGS? +fms/build/Makefile: FMS_ENV=$(FMS_PATH) $(FMS_FCFLAGS) + +fms/build/Makefile: Makefile.fms.in fms/src/configure bin/mkmf bin/list_paths + mkdir -p fms/build + cp Makefile.fms.in fms/src/Makefile.in + cd $(@D) && $(FMS_ENV) ../src/configure --srcdir=../src + + +# TODO: Track m4 macros? +fms/src/configure: configure.fms.ac $(FMS_SOURCE) | fms/src + cp configure.fms.ac fms/src/configure.ac + cp -r m4 $(@D) + cd $(@D) && autoreconf -i + +fms/src: + git clone $(FMS_URL) $@ + git -C $@ checkout $(FMS_COMMIT) + + +.PHONY: clean +clean: + rm -rf fms/build lib include bin + + +.PHONY: distclean +distclean: clean + rm -rf fms mkmf diff --git a/ac/deps/Makefile.fms.in b/ac/deps/Makefile.fms.in new file mode 100644 index 0000000000..694ad8e0b0 --- /dev/null +++ b/ac/deps/Makefile.fms.in @@ -0,0 +1,48 @@ +# Makefile template for MOM6 +# +# Previously this would have been generated by mkmf using a template file. +# +# The proposed autoconf build inverts this approach by constructing the +# information previously stored in the mkmf template, such as compiler names +# and flags, and importing the un-templated mkmf output for its rules and +# dependencies. +# +# While this approach does not eliminate our dependency on mkmf, it does +# promises to eliminate our reliance on platform-specific templates, and +# instead allows us to provide a configure script for determining our compilers +# and flags. As a last resort, we provide hooks to override such settings. + +# NOTE: mkmf conventions are close, but not identical, to autoconf. +# +# CC: C compiler +# CXX: C++ compiler +# FC: Fortran compiler (f77 and f90) +# LD: Linker +# +# CPPDEFS: Preprocessor macros +# CPPFLAGS: C preprocessing flags +# CXXFLAGS: C++ preprocessing flags +# FPPFLAGS: Fortran preprocessing flags +# +# CFLAGS: C compiler flags +# FFLAGS: Fortran compiler flags (f77 and f90) +# LDFLAGS: Linker flags +# +# OTHERFLAGS: Additional flags for all languages (C, C++, Fortran) +# OTHER_CFLAGS: Optional C flags +# OTHER_CXXFLAGS: Optional C++ flags +# OTHER_FFLAGS: Optional Fortran flags + +CC = @CC@ +FC = @FC@ +LD = @FC@ + +CPPDEFS = @DEFS@ +CPPFLAGS = @CPPFLAGS@ +FFLAGS = @FCFLAGS@ +LDFLAGS = @LDFLAGS@ + +# Gather modulefiles +TMPFILES = $(wildcard *.mod) + +include Makefile.mkmf diff --git a/ac/deps/configure.fms.ac b/ac/deps/configure.fms.ac new file mode 100644 index 0000000000..1d66194c81 --- /dev/null +++ b/ac/deps/configure.fms.ac @@ -0,0 +1,155 @@ +# Autoconf configuration +AC_INIT( + [FMS], + [ ], + [https://github.com/NOAA-GFDL/FMS/issues]) + +# Validate srdcir and configure input +AC_CONFIG_SRCDIR([fms/fms.F90]) +AC_CONFIG_MACRO_DIR([m4]) + +# C configuration +AC_PROG_CC +AX_MPI +CC=$MPICC + +# FMS configuration + +# Linux and OSX have a gettid system call, but it is not implemented in older +# glibc implementations. When unavailable, a native syscall is used. +# +# On Linux, this is defined in unistd.h as __NR_gettid, and FMS is hard-coded +# to use this value. In OS X, this is defined in sys/syscall.h as SYS_gettid, +# so we override this macro if __NR_gettid is unavailable. +AC_CHECK_FUNCS([gettid], [], [ + AC_MSG_CHECKING([if __NR_gettid must be redefined]) + AC_CACHE_VAL([ac_cv_cc_nr_gettid], [ + ac_cv_cc_nr_gettid='unknown' + for nr_gettid in __NR_gettid SYS_gettid; do + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([ +#include +#include + ], [syscall($nr_gettid)] + )], [ac_cv_cc_nr_gettid=$nr_gettid] + ) + AS_IF([test "$ac_cv_cc_nr_gettid" != unknown], [break]) + done + ]) + AS_CASE([ac_cv_cc_nr_gettid], + [__NR_gettid], [AC_MSG_RESULT([none needed])], + [AC_MSG_RESULT([$ac_cv_cc_nr_gettid])] + ) + AS_IF([test "$ac_cv_cc_nr_gettid" != unknown], [ + AS_IF([test "$ac_cv_cc_nr_gettid" != __NR_gettid], + [AC_DEFINE_UNQUOTED([__NR_gettid], [$ac_cv_cc_nr_gettid])] + )], [ + AC_MSG_ERROR(["Could not find the gettid syscall ID"]) + ]) +]) + + +# FMS 2019.01.03 uses __APPLE__ to disable Linux CPU affinity calls. +AC_CHECK_FUNCS([sched_getaffinity], [], [AC_DEFINE([__APPLE__])]) + + +# Standard Fortran configuration +AC_LANG(Fortran) +AC_FC_SRCEXT(f90) +AC_PROG_FC + + +# Determine MPI compiler wrappers and override compilers +AX_MPI +AC_SUBST(FC, $MPIFC) +AC_SUBST(LD, $MPIFC) + + +# Module tests +AX_FC_CHECK_MODULE([mpi]) +AC_DEFINE([use_libMPI]) + + +# netCDF configuration +AC_PATH_PROG([NC_CONFIG], [nc-config]) +AS_IF([test -n "$NC_CONFIG"], + [CPPFLAGS="$CPPFLAGS -I$($NC_CONFIG --includedir)" + FCFLAGS="$FCFLAGS -I$($NC_CONFIG --includedir)" + LDFLAGS="$LDFLAGS -L$($NC_CONFIG --libdir)"], + [AC_MSG_ERROR([Could not find nc-config.])]) + +AX_FC_CHECK_MODULE([netcdf], + [], [AC_MSG_ERROR([Could not find FMS library.])]) +AX_FC_CHECK_LIB([netcdff], [nf_create], [netcdf], + [], [AC_MSG_ERROR([Could not link netcdff library.])] +) +AC_DEFINE([use_netCDF]) + + +# Enable Cray pointers +AX_FC_CRAY_POINTER + + +# Force 8-byte reals +AX_FC_REAL8 +AS_IF( + [test "$enable_real8" != no], + [FCFLAGS="$FCFLAGS $REAL8_FCFLAGS"]) + + +# OpenMP configuration +AC_OPENMP +AS_IF( + [test "$enable_openmp" = yes], + [FCFLAGS="$FCFLAGS $OPENMP_FCFLAGS" + LDFLAGS="$LDFLAGS $OPENMP_FCFLAGS"]) + + +# Unlimited line length +AC_FC_LINE_LENGTH([unlimited]) + +# Allow invaliz BOZ assignment +AX_FC_ALLOW_INVALID_BOZ +FCFLAGS="$FCFLAGS $ALLOW_INVALID_BOZ_FCFLAGS" + + +# Allow argument mismatch (for functions lacking interfaces) +AX_FC_ALLOW_ARG_MISMATCH +FCFLAGS="$FCFLAGS $ALLOW_ARG_MISMATCH_FCFLAGS" + + +# Search for mkmf build tools +AC_PATH_PROG([LIST_PATHS], [list_paths]) +AS_IF([test -z "$LIST_PATHS"], [ + AC_PATH_PROG([LIST_PATHS], [list_paths], [], ["$PATH:${srcdir}/../../bin"]) + AS_IF([test -z "$LIST_PATHS"], + [AC_MSG_ERROR([Could not find list_paths.])], + [AC_SUBST(PATH, ["$PATH:${srcdir}/../../bin"])]) + ] +) + +AC_PATH_PROG([MKMF], [mkmf]) +AS_IF([test -z "$MKMF"], [ + AC_PATH_PROG([MKMF], [mkmf], [], ["$PATH:${srcdir}/../../bin"]) + AS_IF([test -z "$MKMF"], + [AC_MSG_ERROR([Could not find mkmf.])], + [AC_SUBST(PATH, ["$PATH:${srcdir}/../../bin"])]) + ] +) + + +# MKMF commands +AC_CONFIG_COMMANDS([path_names], + [${LIST_PATHS} -l ${srcdir}], + [LIST_PATHS=${LIST_PATHS}]) + + +AC_CONFIG_COMMANDS([mkmf], + [${MKMF} -p libFMS.a -m Makefile.mkmf path_names], + [MKMF=${MKMF}]) + + +# Prepare output +AC_SUBST(CPPFLAGS) +AC_CONFIG_FILES(Makefile) +AC_OUTPUT diff --git a/ac/deps/m4/ax_fc_allow_arg_mismatch.m4 b/ac/deps/m4/ax_fc_allow_arg_mismatch.m4 new file mode 100644 index 0000000000..cffa302c66 --- /dev/null +++ b/ac/deps/m4/ax_fc_allow_arg_mismatch.m4 @@ -0,0 +1,58 @@ +dnl Test if mismatched function arguments are permitted. +dnl +dnl This macro tests if a flag is required to enable mismatched functions in +dnl a single translation unit (aka file). +dnl +dnl If a compiler encounters two undefined programs with different input +dnl argument types, then it may regard this as a mismatch which requires action +dnl from the user. A common example is a procedure which may be called with +dnl a variable of either an integer or a real type. +dnl +dnl This can happen, for example, if one is relying on an interface to resolve +dnl such differences, but one is also relying on a legacy header interface via +dnl `#include` rather than an explicit module which includes the complete +dnl interface specification. +dnl +dnl No modern project is expected to see these issues, but this is helpful for +dnl older projects which used legacy headers. +dnl +dnl Flags: +dnl GNU: -fallow-argument-mismatch +dnl +AC_DEFUN([AX_FC_ALLOW_ARG_MISMATCH], + [ALLOW_ARG_MISMATCH_FCFLAGS= + AC_CACHE_CHECK( + [for $FC option to support mismatched procedure arguments], + [ac_cv_prog_fc_arg_mismatch], + [AC_COMPILE_IFELSE( + [AC_LANG_PROGRAM([], [ + call f(1) + call f(1.0) + ])], + [ac_cv_prog_fc_arg_mismatch='none needed'], + [ac_cv_prog_fc_arg_mismatch='unsupported' + for ac_option in -fallow-argument-mismatch; do + ac_save_FCFLAGS=$FCFLAGS + FCFLAGS="$FCFLAGS $ac_option" + AC_COMPILE_IFELSE( + [AC_LANG_PROGRAM([], [ + call f(1) + call f(1.0) + ])], + [ac_cv_prog_fc_arg_mismatch=$ac_option] + ) + FCFLAGS=$ac_save_FCFLAGS + if test "$ac_cv_prog_fc_arg_mismatch" != unsupported; then + break + fi + done]) + ] + ) + case $ac_cv_prog_fc_arg_mismatch in #( + "none needed" | unsupported) + ;; #( + *) + ALLOW_ARG_MISMATCH_FCFLAGS=$ac_cv_prog_fc_arg_mismatch ;; + esac + AC_SUBST(ALLOW_ARG_MISMATCH_FCFLAGS) +]) diff --git a/ac/deps/m4/ax_fc_allow_invalid_boz.m4 b/ac/deps/m4/ax_fc_allow_invalid_boz.m4 new file mode 100644 index 0000000000..5d4521b5fb --- /dev/null +++ b/ac/deps/m4/ax_fc_allow_invalid_boz.m4 @@ -0,0 +1,54 @@ +dnl Test if BOZ literal assignment is supported. +dnl +dnl This macro tests if a flag is required to enable BOZ literal assignments +dnl for variables. +dnl +dnl BOZ literals (e.g. Z'FFFF') are typeless, and formally cannot be assigned +dnl to typed variables. Nonetheless, few compilers forbid such operations, +dnl despite the potential pitfalls around interpreting such values. +dnl +dnl As of version 10.1, gfortran now forbids such assignments and requires a +dnl flag to convert the raised errors into warnings. +dnl +dnl While the best solution is to replace such assignments with proper +dnl conversion functions, this test is useful to accommodate older projects. +dnl +dnl Flags: +dnl GNU: -fallow-invalid-boz +AC_DEFUN([AX_FC_ALLOW_INVALID_BOZ], + [ALLOW_INVALID_BOZ_FCFLAGS= + AC_CACHE_CHECK( + [for $FC option to support invalid BOZ assignment], + [ac_cv_prog_fc_invalid_boz], + [AC_COMPILE_IFELSE( + [AC_LANG_PROGRAM([], [ + integer n + n = z'ff' + ])], + [ac_cv_prog_fc_invalid_boz='none needed'], + [ac_cv_prog_fc_invalid_boz='unsupported' + for ac_option in -fallow-invalid-boz; do + ac_save_FCFLAGS=$FCFLAGS + FCFLAGS="$FCFLAGS $ac_option" + AC_LINK_IFELSE( + [AC_LANG_PROGRAM([], [ + integer n + n = z'ff' + ])], + [ac_cv_prog_fc_invalid_boz=$ac_option] + ) + FCFLAGS=$ac_save_FCFLAGS + if test "$ac_cv_prog_fc_invalid_boz" != unsupported; then + break + fi + done]) + ] + ) + case $ac_cv_prog_fc_invalid_boz in #( + "none needed" | unsupported) + ;; #( + *) + ALLOW_INVALID_BOZ_FCFLAGS=$ac_cv_prog_fc_invalid_boz ;; + esac + AC_SUBST(ALLOW_INVALID_BOZ_FCFLAGS)] +) diff --git a/ac/deps/m4/ax_fc_check_lib.m4 b/ac/deps/m4/ax_fc_check_lib.m4 new file mode 100644 index 0000000000..c0accab6cd --- /dev/null +++ b/ac/deps/m4/ax_fc_check_lib.m4 @@ -0,0 +1,52 @@ +dnl AX_FC_CHECK_LIB(LIBRARY, FUNCTION, +dnl [MODULE], [ACTION-IF-FOUND], [ACTION-IF-NOT-FOUND], +dnl [OTHER-LDFLAGS], [OTHER-LIBS]) +dnl +dnl This macro checks if a Fortran library containing a designated function +dnl is available to the compiler. For the most part, this macro should behave +dnl like the Autoconf AC_CHECK_LIB macro. +dnl +dnl This macro differs somewhat from AC_CHECK_LIB, since it includes two +dnl additional features: +dnl +dnl 1. The third argument (optional) allows us to specify a Fortran module, +dnl which may be required to access the library's functions. +dnl +dnl 2. The sixth argument (optional) allows specification of supplemental +dnl LDFLAGS arguments. This can be used, for example, to test for the +dnl library with different -L flags, or perhaps other ld configurations. +dnl +dnl Results are cached in the ax_fc_cv_lib_LIBRARY_FUNCTION variable. +dnl +AC_DEFUN([AX_FC_CHECK_LIB],[dnl + AS_VAR_PUSHDEF([ax_fc_Lib], [ax_fc_cv_lib_$1_$2]) + m4_ifval([$6], + [ax_fc_lib_msg_LDFLAGS=" with $6"], + [ax_fc_lib_msg_LDFLAGS=""] + ) + AC_CACHE_CHECK([for $2 in -l$1$ax_fc_lib_msg_LDFLAGS], [ax_fc_cv_lib_$1_$2],[ + ax_fc_check_lib_save_LDFLAGS=$LDFLAGS + LDFLAGS="$6 $LDFLAGS" + ax_fc_check_lib_save_LIBS=$LIBS + LIBS="-l$1 $7 $LIBS" + AS_IF([test -n $3], + [ax_fc_use_mod="use $3"], + [ax_fc_use_mod=""]) + AC_LINK_IFELSE([ + AC_LANG_PROGRAM([], [dnl + $ax_fc_use_mod + call $2]dnl + ) + ], + [AS_VAR_SET([ax_fc_Lib], [yes])], + [AS_VAR_SET([ax_fc_Lib], [no])] + ) + LIBS=$ax_fc_check_lib_save_LIBS + LDFLAGS=$ax_fc_check_lib_save_LDFLAGS + ]) + AS_VAR_IF([ax_fc_Lib], [yes], + [m4_default([$4], [LIBS="-l$1 $LIBS"])], + [$5] + ) + AS_VAR_POPDEF([ax_fc_Lib]) +]) diff --git a/ac/deps/m4/ax_fc_check_module.m4 b/ac/deps/m4/ax_fc_check_module.m4 new file mode 100644 index 0000000000..1cfd0c5a5d --- /dev/null +++ b/ac/deps/m4/ax_fc_check_module.m4 @@ -0,0 +1,28 @@ +dnl AX_FC_CHECK_MODULE(MODULE, +dnl [ACTION-IF-FOUND], [ACTION-IF-NOT-FOUND], +dnl [OTHER-FCFLAGS]) +dnl +dnl This macro checks if a Fortran module is available to the compiler. +dnl +dnl The fourth argument (optional) allows for specification of supplemental +dnl FCFLAGS arguments. This would primarily be used to test additional +dnl paths (typically using -I) for the module file. +dnl +dnl Results are cached in the ax_fc_cv_mod_MODULE variable. +dnl +AC_DEFUN([AX_FC_CHECK_MODULE], +[ + AS_VAR_PUSHDEF([ax_fc_Module], [ax_fc_cv_mod_$1]) + AC_CACHE_CHECK([if $FC can use module $1$ax_fc_mod_msg_FCFLAGS], [ax_fc_cv_mod_$1],[ + ax_fc_chk_mod_save_FCFLAGS=$FCFLAGS + FCFLAGS="$4 $FCFLAGS" + AC_COMPILE_IFELSE( + [AC_LANG_PROGRAM([],[use $1])], + [AS_VAR_SET([ax_fc_Module], [yes])], + [AS_VAR_SET([ax_fc_Module], [no])] + ) + FCFLAGS=$ax_fc_chk_mod_save_FCFLAGS + ]) + AS_VAR_IF([ax_fc_Module], [yes], [$2], [$3]) + AS_VAR_POPDEF([ax_fc_Module]) +]) diff --git a/ac/deps/m4/ax_fc_cray_pointer.m4 b/ac/deps/m4/ax_fc_cray_pointer.m4 new file mode 100644 index 0000000000..a9f5d9bbe3 --- /dev/null +++ b/ac/deps/m4/ax_fc_cray_pointer.m4 @@ -0,0 +1,51 @@ +dnl AX_FC_CRAY_POINTER([ACTION-IF-SUCCESS], [ACTION-IF-FAILURE]) +dnl +dnl This macro tests if any flags are required to enable Cray pointers. +dnl +dnl Cray pointers provided a means for more direct access to memory. Since +dnl such references can potentially violate certain requirements of the +dnl language standard, they are typically considered a vendor extension. +dnl +dnl Most compilers provide these in some form. A partial list of supported +dnl flags are shown below, but additional feedback is required for other +dnl compilers. +dnl +dnl The known flags are: +dnl GCC -fcray-pointer +dnl Intel Fortran none +dnl PGI Fortran -Mcray=pointer +dnl Cray Fortran none +dnl +AC_DEFUN([AX_FC_CRAY_POINTER], [ + AC_LANG_ASSERT([Fortran]) + AC_MSG_CHECKING([for $FC option to support Cray pointers]) + AC_CACHE_VAL([ac_cv_prog_fc_cray_ptr], [ + ac_cv_prog_fc_cray_ptr='unknown' + ac_save_FCFLAGS=$FCFLAGS + for ac_option in none -fcray-pointer -Mcray=pointer; do + test "$ac_option" != none && FCFLAGS="$ac_save_FCFLAGS $ac_option" + AC_COMPILE_IFELSE( + [AC_LANG_PROGRAM([], [ + integer aptr(2) + pointer (iptr, aptr) + ])], + [ac_cv_prog_fc_cray_ptr=$ac_option], + ) + FCFLAGS=$ac_save_FCFLAGS + AS_IF([test "$ac_cv_prog_fc_cray_ptr" != unknown], [break]) + done + ]) + AS_CASE([ac_cv_prog_fc_cray_ptr], + [none], [AC_MSG_RESULT([none_needed])], + [unknown], [AC_MSG_RESULT([unsupported])], + [AC_MSG_RESULT([$ac_cv_prog_fc_cray_ptr])] + ) + AS_IF([test "$ac_cv_prog_fc_cray_ptr" != unknown], [ + m4_default([$1], [ + AS_IF([test "$ac_cv_prog_fc_cray_ptr" != none], + [FCFLAGS="$FCFLAGS $ac_cv_prog_fc_cray_ptr"] + ) + ])], + [m4_default([$2], [AC_MSG_ERROR(["$FC does not support Cray pointers"])])] + ) +]) diff --git a/ac/deps/m4/ax_fc_real8.m4 b/ac/deps/m4/ax_fc_real8.m4 new file mode 100644 index 0000000000..e914b9f39a --- /dev/null +++ b/ac/deps/m4/ax_fc_real8.m4 @@ -0,0 +1,86 @@ +dnl Determine the flag required to force 64-bit reals. +dnl +dnl Many applications do not specify the kind of its real variables, even +dnl though the code may intrinsically require double-precision. Most compilers +dnl will also default to using single-precision (32-bit) reals. +dnl +dnl This test determines the flag required to set reals without explcit kind to +dnl 64-bit double precision floats. Ideally, we also desire to leave any +dnl `DOUBLE PRECISION` variable as 64-bit. But this does not appear to always +dnl be possible, such as in NAG Fortran (see below). +dnl +dnl This does not test if the behavior of integers is changed; for example, +dnl Cray's Fortran wrapper's -default will double both. This is addressed by +dnl avoiding any flags with affect integers, but this should still be used with +dnl some care. +dnl +dnl GCC -fdefault-real-8, -fdefault-double-8 +dnl [Common alias] -r8 +dnl Intel Fortran -real-kind 64 +dnl PGI Fortran -Mr8 +dnl Cray Fortran -s real64 +dnl NAG -double +dnl +dnl NOTE: +dnl - Many compilers accept -r8 for real and double precision sizes, but +dnl several compiler-specific options are also provided. +dnl +dnl - -r8 in NAG will attempt to also set double precision to 16 bytes if +dnl available, which is generally undesired. +dnl +dnl Additionally, the -double flag, which doubles *all* types, appears to +dnl be the preferred flag here. +dnl +dnl Neither flag describes what we actually want, but we include it here +dnl as a last resort. +dnl +AC_DEFUN([AX_FC_REAL8], +[ + REAL8_FCFLAGS= + AC_ARG_ENABLE([real8], + [AS_HELP_STRING([--disable-real-8], [do not force 8-byte reals])]) + if test "$enable_real8" != no; then + AC_CACHE_CHECK([for $FC option to force 8-byte reals], + [ac_cv_prog_fc_real8], + [AC_COMPILE_IFELSE( + [AC_LANG_PROGRAM([], [ + real :: x(4) + double precision :: y(4) + integer, parameter :: & + m = merge(1, 0, kind(x(1)) == selected_real_kind(15, 307)), & + n = merge(1, 0, kind(y(1)) == selected_real_kind(15, 307)) + print *, x(::m) + print *, y(::n) + ])], + [ac_cv_prog_fc_real8='none needed'], + [ac_cv_prog_fc_real8='unsupported' + for ac_option in "-fdefault-real-8 -fdefault-double-8" -r8 "-real-kind 64" -Mr8 "-s real64" -double; do + ac_save_FCFLAGS=$FCFLAGS + FCFLAGS="$FCFLAGS $ac_option" + AC_LINK_IFELSE( + [AC_LANG_PROGRAM([], [ + real :: x(4) + double precision :: y(4) + integer, parameter :: & + m = merge(1, 0, kind(x(1)) == selected_real_kind(15, 307)), & + n = merge(1, 0, kind(y(1)) == selected_real_kind(15, 307)) + print *, x(::m) + print *, y(::n) + ])], + [ac_cv_prog_fc_real8=$ac_option] + ) + FCFLAGS=$ac_save_FCFLAGS + if test "$ac_cv_prog_fc_real8" != unsupported; then + break + fi + done]) + ]) + case $ac_cv_prog_fc_real8 in #( + "none needed" | unsupported) + ;; #( + *) + REAL8_FCFLAGS=$ac_cv_prog_fc_real8 ;; + esac + fi + AC_SUBST(REAL8_FCFLAGS) +]) diff --git a/ac/deps/m4/ax_mpi.m4 b/ac/deps/m4/ax_mpi.m4 new file mode 100644 index 0000000000..ecce2e141a --- /dev/null +++ b/ac/deps/m4/ax_mpi.m4 @@ -0,0 +1,176 @@ +# =========================================================================== +# https://www.gnu.org/software/autoconf-archive/ax_mpi.html +# =========================================================================== +# +# SYNOPSIS +# +# AX_MPI([ACTION-IF-FOUND[, ACTION-IF-NOT-FOUND]]) +# +# DESCRIPTION +# +# This macro tries to find out how to compile programs that use MPI +# (Message Passing Interface), a standard API for parallel process +# communication (see http://www-unix.mcs.anl.gov/mpi/) +# +# On success, it sets the MPICC, MPICXX, MPIF77, or MPIFC output variable +# to the name of the MPI compiler, depending upon the current language. +# (This may just be $CC/$CXX/$F77/$FC, but is more often something like +# mpicc/mpiCC/mpif77/mpif90.) It also sets MPILIBS to any libraries that +# are needed for linking MPI (e.g. -lmpi or -lfmpi, if a special +# MPICC/MPICXX/MPIF77/MPIFC was not found). +# +# Note that this macro should be used only if you just have a few source +# files that need to be compiled using MPI. In particular, you should +# neither overwrite CC/CXX/F77/FC with the values of +# MPICC/MPICXX/MPIF77/MPIFC, nor assume that you can use the same flags +# etc. as the standard compilers. If you want to compile a whole program +# using the MPI compiler commands, use one of the macros +# AX_PROG_{CC,CXX,FC}_MPI. +# +# ACTION-IF-FOUND is a list of shell commands to run if an MPI library is +# found, and ACTION-IF-NOT-FOUND is a list of commands to run if it is not +# found. If ACTION-IF-FOUND is not specified, the default action will +# define HAVE_MPI. +# +# LICENSE +# +# Copyright (c) 2008 Steven G. Johnson +# Copyright (c) 2008 Julian C. Cummings +# +# This program is free software: you can redistribute it and/or modify it +# under the terms of the GNU General Public License as published by the +# Free Software Foundation, either version 3 of the License, or (at your +# option) any later version. +# +# This program is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General +# Public License for more details. +# +# You should have received a copy of the GNU General Public License along +# with this program. If not, see . +# +# As a special exception, the respective Autoconf Macro's copyright owner +# gives unlimited permission to copy, distribute and modify the configure +# scripts that are the output of Autoconf when processing the Macro. You +# need not follow the terms of the GNU General Public License when using +# or distributing such scripts, even though portions of the text of the +# Macro appear in them. The GNU General Public License (GPL) does govern +# all other use of the material that constitutes the Autoconf Macro. +# +# This special exception to the GPL applies to versions of the Autoconf +# Macro released by the Autoconf Archive. When you make and distribute a +# modified version of the Autoconf Macro, you may extend this special +# exception to the GPL to apply to your modified version as well. + +#serial 9 + +AU_ALIAS([ACX_MPI], [AX_MPI]) +AC_DEFUN([AX_MPI], [ +AC_PREREQ(2.50) dnl for AC_LANG_CASE + +AC_LANG_CASE([C], [ + AC_REQUIRE([AC_PROG_CC]) + AC_ARG_VAR(MPICC,[MPI C compiler command]) + AC_CHECK_PROGS(MPICC, mpicc cc hcc mpxlc_r mpxlc mpcc cmpicc, $CC) + ax_mpi_save_CC="$CC" + CC="$MPICC" + AC_SUBST(MPICC) +], +[C++], [ + AC_REQUIRE([AC_PROG_CXX]) + AC_ARG_VAR(MPICXX,[MPI C++ compiler command]) + AC_CHECK_PROGS(MPICXX, mpic++ mpicxx mpiCC hcp mpxlC_r mpxlC mpCC cmpic++, $CXX) + ax_mpi_save_CXX="$CXX" + CXX="$MPICXX" + AC_SUBST(MPICXX) +], +[Fortran 77], [ + AC_REQUIRE([AC_PROG_F77]) + AC_ARG_VAR(MPIF77,[MPI Fortran 77 compiler command]) + AC_CHECK_PROGS(MPIF77, mpif77 hf77 mpxlf_r mpxlf mpf77 cmpifc, $F77) + ax_mpi_save_F77="$F77" + F77="$MPIF77" + AC_SUBST(MPIF77) +], +[Fortran], [ + AC_REQUIRE([AC_PROG_FC]) + AC_ARG_VAR(MPIFC,[MPI Fortran compiler command]) + AC_CHECK_PROGS(MPIFC, mpifort mpif90 ftn mpxlf95_r mpxlf90_r mpxlf95 mpxlf90 mpf90 cmpif90c, $FC) + ax_mpi_save_FC="$FC" + FC="$MPIFC" + AC_SUBST(MPIFC) +]) + +if test x = x"$MPILIBS"; then + AC_LANG_CASE([C], [AC_CHECK_FUNC(MPI_Init, [MPILIBS=" "])], + [C++], [AC_CHECK_FUNC(MPI_Init, [MPILIBS=" "])], + [Fortran 77], [AC_MSG_CHECKING([for MPI_Init]) + AC_LINK_IFELSE([AC_LANG_PROGRAM([],[ call MPI_Init])],[MPILIBS=" " + AC_MSG_RESULT(yes)], [AC_MSG_RESULT(no)])], + [Fortran], [AC_MSG_CHECKING([for MPI_Init]) + AC_LINK_IFELSE([AC_LANG_PROGRAM([],[ call MPI_Init])],[MPILIBS=" " + AC_MSG_RESULT(yes)], [AC_MSG_RESULT(no)])]) +fi +AC_LANG_CASE([Fortran 77], [ + if test x = x"$MPILIBS"; then + AC_CHECK_LIB(fmpi, MPI_Init, [MPILIBS="-lfmpi"]) + fi + if test x = x"$MPILIBS"; then + AC_CHECK_LIB(fmpich, MPI_Init, [MPILIBS="-lfmpich"]) + fi +], +[Fortran], [ + if test x = x"$MPILIBS"; then + AC_CHECK_LIB(fmpi, MPI_Init, [MPILIBS="-lfmpi"]) + fi + if test x = x"$MPILIBS"; then + AC_CHECK_LIB(mpichf90, MPI_Init, [MPILIBS="-lmpichf90"]) + fi +]) +if test x = x"$MPILIBS"; then + AC_CHECK_LIB(mpi, MPI_Init, [MPILIBS="-lmpi"]) +fi +if test x = x"$MPILIBS"; then + AC_CHECK_LIB(mpich, MPI_Init, [MPILIBS="-lmpich"]) +fi + +dnl We have to use AC_TRY_COMPILE and not AC_CHECK_HEADER because the +dnl latter uses $CPP, not $CC (which may be mpicc). +AC_LANG_CASE([C], [if test x != x"$MPILIBS"; then + AC_MSG_CHECKING([for mpi.h]) + AC_TRY_COMPILE([#include ],[],[AC_MSG_RESULT(yes)], [MPILIBS="" + AC_MSG_RESULT(no)]) +fi], +[C++], [if test x != x"$MPILIBS"; then + AC_MSG_CHECKING([for mpi.h]) + AC_TRY_COMPILE([#include ],[],[AC_MSG_RESULT(yes)], [MPILIBS="" + AC_MSG_RESULT(no)]) +fi], +[Fortran 77], [if test x != x"$MPILIBS"; then + AC_MSG_CHECKING([for mpif.h]) + AC_COMPILE_IFELSE([AC_LANG_PROGRAM([],[ include 'mpif.h'])],[AC_MSG_RESULT(yes)], [MPILIBS="" + AC_MSG_RESULT(no)]) +fi], +[Fortran], [if test x != x"$MPILIBS"; then + AC_MSG_CHECKING([for mpif.h]) + AC_COMPILE_IFELSE([AC_LANG_PROGRAM([],[ include 'mpif.h'])],[AC_MSG_RESULT(yes)], [MPILIBS="" + AC_MSG_RESULT(no)]) +fi]) + +AC_LANG_CASE([C], [CC="$ax_mpi_save_CC"], + [C++], [CXX="$ax_mpi_save_CXX"], + [Fortran 77], [F77="$ax_mpi_save_F77"], + [Fortran], [FC="$ax_mpi_save_FC"]) + +AC_SUBST(MPILIBS) + +# Finally, execute ACTION-IF-FOUND/ACTION-IF-NOT-FOUND: +if test x = x"$MPILIBS"; then + $2 + : +else + ifelse([$1],,[AC_DEFINE(HAVE_MPI,1,[Define if you have the MPI library.])],[$1]) + : +fi +])dnl AX_MPI diff --git a/ac/m4/ax_fc_check_lib.m4 b/ac/m4/ax_fc_check_lib.m4 new file mode 100644 index 0000000000..c0accab6cd --- /dev/null +++ b/ac/m4/ax_fc_check_lib.m4 @@ -0,0 +1,52 @@ +dnl AX_FC_CHECK_LIB(LIBRARY, FUNCTION, +dnl [MODULE], [ACTION-IF-FOUND], [ACTION-IF-NOT-FOUND], +dnl [OTHER-LDFLAGS], [OTHER-LIBS]) +dnl +dnl This macro checks if a Fortran library containing a designated function +dnl is available to the compiler. For the most part, this macro should behave +dnl like the Autoconf AC_CHECK_LIB macro. +dnl +dnl This macro differs somewhat from AC_CHECK_LIB, since it includes two +dnl additional features: +dnl +dnl 1. The third argument (optional) allows us to specify a Fortran module, +dnl which may be required to access the library's functions. +dnl +dnl 2. The sixth argument (optional) allows specification of supplemental +dnl LDFLAGS arguments. This can be used, for example, to test for the +dnl library with different -L flags, or perhaps other ld configurations. +dnl +dnl Results are cached in the ax_fc_cv_lib_LIBRARY_FUNCTION variable. +dnl +AC_DEFUN([AX_FC_CHECK_LIB],[dnl + AS_VAR_PUSHDEF([ax_fc_Lib], [ax_fc_cv_lib_$1_$2]) + m4_ifval([$6], + [ax_fc_lib_msg_LDFLAGS=" with $6"], + [ax_fc_lib_msg_LDFLAGS=""] + ) + AC_CACHE_CHECK([for $2 in -l$1$ax_fc_lib_msg_LDFLAGS], [ax_fc_cv_lib_$1_$2],[ + ax_fc_check_lib_save_LDFLAGS=$LDFLAGS + LDFLAGS="$6 $LDFLAGS" + ax_fc_check_lib_save_LIBS=$LIBS + LIBS="-l$1 $7 $LIBS" + AS_IF([test -n $3], + [ax_fc_use_mod="use $3"], + [ax_fc_use_mod=""]) + AC_LINK_IFELSE([ + AC_LANG_PROGRAM([], [dnl + $ax_fc_use_mod + call $2]dnl + ) + ], + [AS_VAR_SET([ax_fc_Lib], [yes])], + [AS_VAR_SET([ax_fc_Lib], [no])] + ) + LIBS=$ax_fc_check_lib_save_LIBS + LDFLAGS=$ax_fc_check_lib_save_LDFLAGS + ]) + AS_VAR_IF([ax_fc_Lib], [yes], + [m4_default([$4], [LIBS="-l$1 $LIBS"])], + [$5] + ) + AS_VAR_POPDEF([ax_fc_Lib]) +]) diff --git a/ac/m4/ax_fc_check_module.m4 b/ac/m4/ax_fc_check_module.m4 new file mode 100644 index 0000000000..1cfd0c5a5d --- /dev/null +++ b/ac/m4/ax_fc_check_module.m4 @@ -0,0 +1,28 @@ +dnl AX_FC_CHECK_MODULE(MODULE, +dnl [ACTION-IF-FOUND], [ACTION-IF-NOT-FOUND], +dnl [OTHER-FCFLAGS]) +dnl +dnl This macro checks if a Fortran module is available to the compiler. +dnl +dnl The fourth argument (optional) allows for specification of supplemental +dnl FCFLAGS arguments. This would primarily be used to test additional +dnl paths (typically using -I) for the module file. +dnl +dnl Results are cached in the ax_fc_cv_mod_MODULE variable. +dnl +AC_DEFUN([AX_FC_CHECK_MODULE], +[ + AS_VAR_PUSHDEF([ax_fc_Module], [ax_fc_cv_mod_$1]) + AC_CACHE_CHECK([if $FC can use module $1$ax_fc_mod_msg_FCFLAGS], [ax_fc_cv_mod_$1],[ + ax_fc_chk_mod_save_FCFLAGS=$FCFLAGS + FCFLAGS="$4 $FCFLAGS" + AC_COMPILE_IFELSE( + [AC_LANG_PROGRAM([],[use $1])], + [AS_VAR_SET([ax_fc_Module], [yes])], + [AS_VAR_SET([ax_fc_Module], [no])] + ) + FCFLAGS=$ax_fc_chk_mod_save_FCFLAGS + ]) + AS_VAR_IF([ax_fc_Module], [yes], [$2], [$3]) + AS_VAR_POPDEF([ax_fc_Module]) +]) diff --git a/ac/m4/ax_fc_real8.m4 b/ac/m4/ax_fc_real8.m4 new file mode 100644 index 0000000000..e914b9f39a --- /dev/null +++ b/ac/m4/ax_fc_real8.m4 @@ -0,0 +1,86 @@ +dnl Determine the flag required to force 64-bit reals. +dnl +dnl Many applications do not specify the kind of its real variables, even +dnl though the code may intrinsically require double-precision. Most compilers +dnl will also default to using single-precision (32-bit) reals. +dnl +dnl This test determines the flag required to set reals without explcit kind to +dnl 64-bit double precision floats. Ideally, we also desire to leave any +dnl `DOUBLE PRECISION` variable as 64-bit. But this does not appear to always +dnl be possible, such as in NAG Fortran (see below). +dnl +dnl This does not test if the behavior of integers is changed; for example, +dnl Cray's Fortran wrapper's -default will double both. This is addressed by +dnl avoiding any flags with affect integers, but this should still be used with +dnl some care. +dnl +dnl GCC -fdefault-real-8, -fdefault-double-8 +dnl [Common alias] -r8 +dnl Intel Fortran -real-kind 64 +dnl PGI Fortran -Mr8 +dnl Cray Fortran -s real64 +dnl NAG -double +dnl +dnl NOTE: +dnl - Many compilers accept -r8 for real and double precision sizes, but +dnl several compiler-specific options are also provided. +dnl +dnl - -r8 in NAG will attempt to also set double precision to 16 bytes if +dnl available, which is generally undesired. +dnl +dnl Additionally, the -double flag, which doubles *all* types, appears to +dnl be the preferred flag here. +dnl +dnl Neither flag describes what we actually want, but we include it here +dnl as a last resort. +dnl +AC_DEFUN([AX_FC_REAL8], +[ + REAL8_FCFLAGS= + AC_ARG_ENABLE([real8], + [AS_HELP_STRING([--disable-real-8], [do not force 8-byte reals])]) + if test "$enable_real8" != no; then + AC_CACHE_CHECK([for $FC option to force 8-byte reals], + [ac_cv_prog_fc_real8], + [AC_COMPILE_IFELSE( + [AC_LANG_PROGRAM([], [ + real :: x(4) + double precision :: y(4) + integer, parameter :: & + m = merge(1, 0, kind(x(1)) == selected_real_kind(15, 307)), & + n = merge(1, 0, kind(y(1)) == selected_real_kind(15, 307)) + print *, x(::m) + print *, y(::n) + ])], + [ac_cv_prog_fc_real8='none needed'], + [ac_cv_prog_fc_real8='unsupported' + for ac_option in "-fdefault-real-8 -fdefault-double-8" -r8 "-real-kind 64" -Mr8 "-s real64" -double; do + ac_save_FCFLAGS=$FCFLAGS + FCFLAGS="$FCFLAGS $ac_option" + AC_LINK_IFELSE( + [AC_LANG_PROGRAM([], [ + real :: x(4) + double precision :: y(4) + integer, parameter :: & + m = merge(1, 0, kind(x(1)) == selected_real_kind(15, 307)), & + n = merge(1, 0, kind(y(1)) == selected_real_kind(15, 307)) + print *, x(::m) + print *, y(::n) + ])], + [ac_cv_prog_fc_real8=$ac_option] + ) + FCFLAGS=$ac_save_FCFLAGS + if test "$ac_cv_prog_fc_real8" != unsupported; then + break + fi + done]) + ]) + case $ac_cv_prog_fc_real8 in #( + "none needed" | unsupported) + ;; #( + *) + REAL8_FCFLAGS=$ac_cv_prog_fc_real8 ;; + esac + fi + AC_SUBST(REAL8_FCFLAGS) +]) diff --git a/ac/m4/ax_mpi.m4 b/ac/m4/ax_mpi.m4 new file mode 100644 index 0000000000..ecce2e141a --- /dev/null +++ b/ac/m4/ax_mpi.m4 @@ -0,0 +1,176 @@ +# =========================================================================== +# https://www.gnu.org/software/autoconf-archive/ax_mpi.html +# =========================================================================== +# +# SYNOPSIS +# +# AX_MPI([ACTION-IF-FOUND[, ACTION-IF-NOT-FOUND]]) +# +# DESCRIPTION +# +# This macro tries to find out how to compile programs that use MPI +# (Message Passing Interface), a standard API for parallel process +# communication (see http://www-unix.mcs.anl.gov/mpi/) +# +# On success, it sets the MPICC, MPICXX, MPIF77, or MPIFC output variable +# to the name of the MPI compiler, depending upon the current language. +# (This may just be $CC/$CXX/$F77/$FC, but is more often something like +# mpicc/mpiCC/mpif77/mpif90.) It also sets MPILIBS to any libraries that +# are needed for linking MPI (e.g. -lmpi or -lfmpi, if a special +# MPICC/MPICXX/MPIF77/MPIFC was not found). +# +# Note that this macro should be used only if you just have a few source +# files that need to be compiled using MPI. In particular, you should +# neither overwrite CC/CXX/F77/FC with the values of +# MPICC/MPICXX/MPIF77/MPIFC, nor assume that you can use the same flags +# etc. as the standard compilers. If you want to compile a whole program +# using the MPI compiler commands, use one of the macros +# AX_PROG_{CC,CXX,FC}_MPI. +# +# ACTION-IF-FOUND is a list of shell commands to run if an MPI library is +# found, and ACTION-IF-NOT-FOUND is a list of commands to run if it is not +# found. If ACTION-IF-FOUND is not specified, the default action will +# define HAVE_MPI. +# +# LICENSE +# +# Copyright (c) 2008 Steven G. Johnson +# Copyright (c) 2008 Julian C. Cummings +# +# This program is free software: you can redistribute it and/or modify it +# under the terms of the GNU General Public License as published by the +# Free Software Foundation, either version 3 of the License, or (at your +# option) any later version. +# +# This program is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General +# Public License for more details. +# +# You should have received a copy of the GNU General Public License along +# with this program. If not, see . +# +# As a special exception, the respective Autoconf Macro's copyright owner +# gives unlimited permission to copy, distribute and modify the configure +# scripts that are the output of Autoconf when processing the Macro. You +# need not follow the terms of the GNU General Public License when using +# or distributing such scripts, even though portions of the text of the +# Macro appear in them. The GNU General Public License (GPL) does govern +# all other use of the material that constitutes the Autoconf Macro. +# +# This special exception to the GPL applies to versions of the Autoconf +# Macro released by the Autoconf Archive. When you make and distribute a +# modified version of the Autoconf Macro, you may extend this special +# exception to the GPL to apply to your modified version as well. + +#serial 9 + +AU_ALIAS([ACX_MPI], [AX_MPI]) +AC_DEFUN([AX_MPI], [ +AC_PREREQ(2.50) dnl for AC_LANG_CASE + +AC_LANG_CASE([C], [ + AC_REQUIRE([AC_PROG_CC]) + AC_ARG_VAR(MPICC,[MPI C compiler command]) + AC_CHECK_PROGS(MPICC, mpicc cc hcc mpxlc_r mpxlc mpcc cmpicc, $CC) + ax_mpi_save_CC="$CC" + CC="$MPICC" + AC_SUBST(MPICC) +], +[C++], [ + AC_REQUIRE([AC_PROG_CXX]) + AC_ARG_VAR(MPICXX,[MPI C++ compiler command]) + AC_CHECK_PROGS(MPICXX, mpic++ mpicxx mpiCC hcp mpxlC_r mpxlC mpCC cmpic++, $CXX) + ax_mpi_save_CXX="$CXX" + CXX="$MPICXX" + AC_SUBST(MPICXX) +], +[Fortran 77], [ + AC_REQUIRE([AC_PROG_F77]) + AC_ARG_VAR(MPIF77,[MPI Fortran 77 compiler command]) + AC_CHECK_PROGS(MPIF77, mpif77 hf77 mpxlf_r mpxlf mpf77 cmpifc, $F77) + ax_mpi_save_F77="$F77" + F77="$MPIF77" + AC_SUBST(MPIF77) +], +[Fortran], [ + AC_REQUIRE([AC_PROG_FC]) + AC_ARG_VAR(MPIFC,[MPI Fortran compiler command]) + AC_CHECK_PROGS(MPIFC, mpifort mpif90 ftn mpxlf95_r mpxlf90_r mpxlf95 mpxlf90 mpf90 cmpif90c, $FC) + ax_mpi_save_FC="$FC" + FC="$MPIFC" + AC_SUBST(MPIFC) +]) + +if test x = x"$MPILIBS"; then + AC_LANG_CASE([C], [AC_CHECK_FUNC(MPI_Init, [MPILIBS=" "])], + [C++], [AC_CHECK_FUNC(MPI_Init, [MPILIBS=" "])], + [Fortran 77], [AC_MSG_CHECKING([for MPI_Init]) + AC_LINK_IFELSE([AC_LANG_PROGRAM([],[ call MPI_Init])],[MPILIBS=" " + AC_MSG_RESULT(yes)], [AC_MSG_RESULT(no)])], + [Fortran], [AC_MSG_CHECKING([for MPI_Init]) + AC_LINK_IFELSE([AC_LANG_PROGRAM([],[ call MPI_Init])],[MPILIBS=" " + AC_MSG_RESULT(yes)], [AC_MSG_RESULT(no)])]) +fi +AC_LANG_CASE([Fortran 77], [ + if test x = x"$MPILIBS"; then + AC_CHECK_LIB(fmpi, MPI_Init, [MPILIBS="-lfmpi"]) + fi + if test x = x"$MPILIBS"; then + AC_CHECK_LIB(fmpich, MPI_Init, [MPILIBS="-lfmpich"]) + fi +], +[Fortran], [ + if test x = x"$MPILIBS"; then + AC_CHECK_LIB(fmpi, MPI_Init, [MPILIBS="-lfmpi"]) + fi + if test x = x"$MPILIBS"; then + AC_CHECK_LIB(mpichf90, MPI_Init, [MPILIBS="-lmpichf90"]) + fi +]) +if test x = x"$MPILIBS"; then + AC_CHECK_LIB(mpi, MPI_Init, [MPILIBS="-lmpi"]) +fi +if test x = x"$MPILIBS"; then + AC_CHECK_LIB(mpich, MPI_Init, [MPILIBS="-lmpich"]) +fi + +dnl We have to use AC_TRY_COMPILE and not AC_CHECK_HEADER because the +dnl latter uses $CPP, not $CC (which may be mpicc). +AC_LANG_CASE([C], [if test x != x"$MPILIBS"; then + AC_MSG_CHECKING([for mpi.h]) + AC_TRY_COMPILE([#include ],[],[AC_MSG_RESULT(yes)], [MPILIBS="" + AC_MSG_RESULT(no)]) +fi], +[C++], [if test x != x"$MPILIBS"; then + AC_MSG_CHECKING([for mpi.h]) + AC_TRY_COMPILE([#include ],[],[AC_MSG_RESULT(yes)], [MPILIBS="" + AC_MSG_RESULT(no)]) +fi], +[Fortran 77], [if test x != x"$MPILIBS"; then + AC_MSG_CHECKING([for mpif.h]) + AC_COMPILE_IFELSE([AC_LANG_PROGRAM([],[ include 'mpif.h'])],[AC_MSG_RESULT(yes)], [MPILIBS="" + AC_MSG_RESULT(no)]) +fi], +[Fortran], [if test x != x"$MPILIBS"; then + AC_MSG_CHECKING([for mpif.h]) + AC_COMPILE_IFELSE([AC_LANG_PROGRAM([],[ include 'mpif.h'])],[AC_MSG_RESULT(yes)], [MPILIBS="" + AC_MSG_RESULT(no)]) +fi]) + +AC_LANG_CASE([C], [CC="$ax_mpi_save_CC"], + [C++], [CXX="$ax_mpi_save_CXX"], + [Fortran 77], [F77="$ax_mpi_save_F77"], + [Fortran], [FC="$ax_mpi_save_FC"]) + +AC_SUBST(MPILIBS) + +# Finally, execute ACTION-IF-FOUND/ACTION-IF-NOT-FOUND: +if test x = x"$MPILIBS"; then + $2 + : +else + ifelse([$1],,[AC_DEFINE(HAVE_MPI,1,[Define if you have the MPI library.])],[$1]) + : +fi +])dnl AX_MPI diff --git a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 index 860ba90487..7075fb7c10 100644 --- a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 @@ -9,14 +9,12 @@ module MOM_surface_forcing_gfdl use MOM_constants, only : hlv, hlf use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_SUBCOMPONENT -use MOM_diag_mediator, only : diag_ctrl -use MOM_diag_mediator, only : safe_alloc_ptr, time_type +use MOM_diag_mediator, only : diag_ctrl, safe_alloc_ptr, time_type use MOM_domains, only : pass_vector, pass_var, fill_symmetric_edges -use MOM_domains, only : global_field_sum, BITWISE_EXACT_SUM use MOM_domains, only : AGRID, BGRID_NE, CGRID_NE, To_All use MOM_domains, only : To_North, To_East, Omit_Corners use MOM_error_handler, only : MOM_error, WARNING, FATAL, is_root_pe, MOM_mesg -use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_forcing_type, only : forcing, mech_forcing use MOM_forcing_type, only : forcing_diags, mech_forcing_diags, register_forcing_type_diags use MOM_forcing_type, only : allocate_forcing_type, deallocate_forcing_type @@ -71,8 +69,8 @@ module MOM_surface_forcing_gfdl real :: latent_heat_fusion !< Latent heat of fusion [J kg-1] real :: latent_heat_vapor !< Latent heat of vaporization [J kg-1] - real :: max_p_surf !< The maximum surface pressure that can be - !! exerted by the atmosphere and floating sea-ice [Pa]. + real :: max_p_surf !< The maximum surface pressure that can be exerted by + !! the atmosphere and floating sea-ice [R L2 T-2 ~> Pa]. !! This is needed because the FMS coupling structure !! does not limit the water that can be frozen out !! of the ocean and the ice-ocean heat fluxes are @@ -101,12 +99,12 @@ module MOM_surface_forcing_gfdl logical :: rigid_sea_ice !< If true, sea-ice exerts a rigidity that acts to damp surface !! deflections (especially surface gravity waves). The default is false. - real :: G_Earth !< Gravitational acceleration [m s-2] - real :: Kv_sea_ice !< Viscosity in sea-ice that resists sheared vertical motions [m2 s-1] - real :: density_sea_ice !< Typical density of sea-ice [kg m-3]. The value is only used to convert + real :: g_Earth !< Gravitational acceleration [L2 Z-1 T-2 ~> m s-2] + real :: Kv_sea_ice !< Viscosity in sea-ice that resists sheared vertical motions [L4 Z-2 T-1 ~> m2 s-1] + real :: density_sea_ice !< Typical density of sea-ice [R ~> kg m-3]. The value is only used to convert !! the ice pressure into appropriate units for use with Kv_sea_ice. real :: rigid_sea_ice_mass !< A mass per unit area of sea-ice beyond which sea-ice viscosity - !! becomes effective [kg m-2], typically of order 1000 kg m-2. + !! becomes effective [R Z ~> kg m-2], typically of order 1000 kg m-2. logical :: allow_flux_adjustments !< If true, use data_override to obtain flux adjustments logical :: restore_salt !< If true, the coupled MOM driver adds a term to restore surface @@ -466,7 +464,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, endif if (associated(IOB%mass_berg)) then - fluxes%mass_berg(i,j) = IOB%mass_berg(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%mass_berg(i,j) = US%m_to_Z*US%kg_m3_to_R * IOB%mass_berg(i-i0,j-j0) * G%mask2dT(i,j) if (CS%check_no_land_fluxes) & call check_mask_val_consistency(IOB%mass_berg(i-i0,j-j0), G%mask2dT(i,j), i, j, 'mass_berg', G) endif @@ -548,14 +546,14 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, if (associated(IOB%p)) then if (CS%max_p_surf >= 0.0) then do j=js,je ; do i=is,ie - fluxes%p_surf_full(i,j) = G%mask2dT(i,j) * IOB%p(i-i0,j-j0) + fluxes%p_surf_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) fluxes%p_surf(i,j) = MIN(fluxes%p_surf_full(i,j),CS%max_p_surf) if (CS%check_no_land_fluxes) & call check_mask_val_consistency(IOB%p(i-i0,j-j0), G%mask2dT(i,j), i, j, 'p', G) enddo ; enddo else do j=js,je ; do i=is,ie - fluxes%p_surf_full(i,j) = G%mask2dT(i,j) * IOB%p(i-i0,j-j0) + fluxes%p_surf_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) fluxes%p_surf(i,j) = fluxes%p_surf_full(i,j) if (CS%check_no_land_fluxes) & call check_mask_val_consistency(IOB%p(i-i0,j-j0), G%mask2dT(i,j), i, j, 'p', G) @@ -669,14 +667,14 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS, dt_ ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & - rigidity_at_h, & ! Ice rigidity at tracer points [m3 s-1] + rigidity_at_h, & ! Ice rigidity at tracer points [L4 Z-1 T-1 ~> m3 s-1] net_mass_src, & ! A temporary of net mass sources [kg m-2 s-1]. ustar_tmp ! A temporary array of ustar values [Z T-1 ~> m s-1]. - real :: I_GEarth ! 1.0 / G_Earth [s2 m-1] - real :: Kv_rho_ice ! (CS%kv_sea_ice / CS%density_sea_ice) [m5 s-1 kg-1] - real :: mass_ice ! mass of sea ice at a face [kg m-2] - real :: mass_eff ! effective mass of sea ice for rigidity [kg m-2] + real :: I_GEarth ! The inverse of the gravitational acceleration [T2 Z L-2 ~> s2 m-1] + real :: Kv_rho_ice ! (CS%Kv_sea_ice / CS%density_sea_ice) [L4 Z-2 T-1 R-1 ~> m5 s-1 kg-1] + real :: mass_ice ! mass of sea ice at a face [R Z ~> kg m-2] + real :: mass_eff ! effective mass of sea ice for rigidity [R Z ~> kg m-2] real :: wt1, wt2 ! Relative weights of previous and current values of ustar, ND. integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq, i0, j0 @@ -751,12 +749,12 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS, dt_ if (associated(IOB%p)) then if (CS%max_p_surf >= 0.0) then do j=js,je ; do i=is,ie - forces%p_surf_full(i,j) = G%mask2dT(i,j) * IOB%p(i-i0,j-j0) + forces%p_surf_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) forces%p_surf(i,j) = MIN(forces%p_surf_full(i,j),CS%max_p_surf) enddo ; enddo else do j=js,je ; do i=is,ie - forces%p_surf_full(i,j) = G%mask2dT(i,j) * IOB%p(i-i0,j-j0) + forces%p_surf_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) forces%p_surf(i,j) = forces%p_surf_full(i,j) enddo ; enddo endif @@ -816,13 +814,13 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS, dt_ enddo ; enddo ; endif if (associated(IOB%mass_berg)) then ; do j=js,je ; do i=is,ie - forces%mass_berg(i,j) = IOB%mass_berg(i-i0,j-j0) * G%mask2dT(i,j) + forces%mass_berg(i,j) = US%m_to_Z*US%kg_m3_to_R * IOB%mass_berg(i-i0,j-j0) * G%mask2dT(i,j) enddo ; enddo ; endif ! Obtain sea ice related dynamic fields if (associated(IOB%ice_rigidity)) then do j=js,je ; do i=is,ie - rigidity_at_h(i,j) = IOB%ice_rigidity(i-i0,j-j0) * G%mask2dT(i,j) + rigidity_at_h(i,j) = US%m_to_L**3*US%Z_to_L*US%T_to_s * IOB%ice_rigidity(i-i0,j-j0) * G%mask2dT(i,j) enddo ; enddo call pass_var(rigidity_at_h, G%Domain, halo=1) do I=is-1,ie ; do j=js,je @@ -837,14 +835,13 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS, dt_ if (CS%rigid_sea_ice) then call pass_var(forces%p_surf_full, G%Domain, halo=1) - I_GEarth = 1.0 / CS%G_Earth - Kv_rho_ice = (CS%kv_sea_ice / CS%density_sea_ice) + I_GEarth = 1.0 / CS%g_Earth + Kv_rho_ice = (CS%Kv_sea_ice / CS%density_sea_ice) do I=is-1,ie ; do j=js,je mass_ice = min(forces%p_surf_full(i,j), forces%p_surf_full(i+1,j)) * I_GEarth mass_eff = 0.0 if (mass_ice > CS%rigid_sea_ice_mass) then - mass_eff = (mass_ice - CS%rigid_sea_ice_mass) **2 / & - (mass_ice + CS%rigid_sea_ice_mass) + mass_eff = (mass_ice - CS%rigid_sea_ice_mass)**2 / (mass_ice + CS%rigid_sea_ice_mass) endif forces%rigidity_ice_u(I,j) = forces%rigidity_ice_u(I,j) + Kv_rho_ice * mass_eff enddo ; enddo @@ -852,8 +849,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS, dt_ mass_ice = min(forces%p_surf_full(i,j), forces%p_surf_full(i,j+1)) * I_GEarth mass_eff = 0.0 if (mass_ice > CS%rigid_sea_ice_mass) then - mass_eff = (mass_ice - CS%rigid_sea_ice_mass) **2 / & - (mass_ice + CS%rigid_sea_ice_mass) + mass_eff = (mass_ice - CS%rigid_sea_ice_mass)**2 / (mass_ice + CS%rigid_sea_ice_mass) endif forces%rigidity_ice_v(i,J) = forces%rigidity_ice_v(i,J) + Kv_rho_ice * mass_eff enddo ; enddo @@ -1233,7 +1229,7 @@ subroutine forcing_save_restart(CS, G, Time, directory, time_stamped, & end subroutine forcing_save_restart !> Initialize the surface forcing, including setting parameters and allocating permanent memory. -subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) +subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) 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 @@ -1242,6 +1238,8 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) !! diagnostic output type(surface_forcing_CS), pointer :: CS !< A pointer that is set to point to the control !! structure for this module + integer, optional, intent(in) :: wind_stagger !< If present, the staggering of the winds that are + !! being provided in calls to update_ocean_model ! Local variables real :: utide ! The RMS tidal velocity [Z T-1 ~> m s-1]. @@ -1274,7 +1272,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) call write_version_number(version) ! Read all relevant parameters and write them to the model log. - call log_version(param_file, mdl, version, "") + call log_version(param_file, mdl, version, "", log_to_all=.true., debugging=.true.) call get_param(param_file, mdl, "INPUTDIR", CS%inputdir, & "The directory in which all input files are found.", & @@ -1299,8 +1297,8 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) "needed because the FMS coupling structure does not "//& "limit the water that can be frozen out of the ocean and "//& "the ice-ocean heat fluxes are treated explicitly. No "//& - "limit is applied if a negative value is used.", units="Pa", & - default=-1.0) + "limit is applied if a negative value is used.", & + units="Pa", default=-1.0, scale=US%kg_m3_to_R*US%m_s_to_L_T**2) call get_param(param_file, mdl, "RESTORE_SALINITY", CS%restore_salt, & "If true, the coupled driver will add a globally-balanced "//& "fresh-water flux that drives sea-surface salinity "//& @@ -1327,7 +1325,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) call get_param(param_file, mdl, "USE_NET_FW_ADJUSTMENT_SIGN_BUG", & CS%use_net_FW_adjustment_sign_bug, & "If true, use the wrong sign for the adjustment to "//& - "the net fresh-water.", default=.true.) + "the net fresh-water.", default=.false.) call get_param(param_file, mdl, "ADJUST_NET_FRESH_WATER_BY_SCALING", & CS%adjust_net_fresh_water_by_scaling, & "If true, adjustments to net fresh water to achieve zero net are "//& @@ -1349,15 +1347,28 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) "the ocean dynamics. The actual net mass source may differ "//& "due to internal corrections.", default=.false.) - call get_param(param_file, mdl, "WIND_STAGGER", stagger, & - "A case-insensitive character string to indicate the "//& - "staggering of the input wind stress field. Valid "//& - "values are 'A', 'B', or 'C'.", default="C") - if (uppercase(stagger(1:1)) == 'A') then ; CS%wind_stagger = AGRID - elseif (uppercase(stagger(1:1)) == 'B') then ; CS%wind_stagger = BGRID_NE - elseif (uppercase(stagger(1:1)) == 'C') then ; CS%wind_stagger = CGRID_NE - else ; call MOM_error(FATAL,"surface_forcing_init: WIND_STAGGER = "// & - trim(stagger)//" is invalid.") ; endif + if (present(wind_stagger)) then + if (wind_stagger == AGRID) then ; stagger = 'AGRID' + elseif (wind_stagger == BGRID_NE) then ; stagger = 'BGRID_NE' + elseif (wind_stagger == CGRID_NE) then ; stagger = 'CGRID_NE' + else ; stagger = 'UNKNOWN' ; call MOM_error(FATAL,"surface_forcing_init: WIND_STAGGER = "// & + trim(stagger)// "is invalid."); endif + call log_param(param_file, mdl, "WIND_STAGGER", stagger, & + "The staggering of the input wind stress field "//& + "from the coupler that is actually used.") + CS%wind_stagger = wind_stagger + else + call get_param(param_file, mdl, "WIND_STAGGER", stagger, & + "A case-insensitive character string to indicate the "//& + "staggering of the input wind stress field. Valid "//& + "values are 'A', 'B', or 'C'.", default="C") + if (uppercase(stagger(1:1)) == 'A') then ; CS%wind_stagger = AGRID + elseif (uppercase(stagger(1:1)) == 'B') then ; CS%wind_stagger = BGRID_NE + elseif (uppercase(stagger(1:1)) == 'C') then ; CS%wind_stagger = CGRID_NE + else ; call MOM_error(FATAL,"surface_forcing_init: WIND_STAGGER = "// & + trim(stagger)//" is invalid.") ; endif + endif + call get_param(param_file, mdl, "WIND_STRESS_MULTIPLIER", CS%wind_stress_multiplier, & "A factor multiplying the wind-stress given to the ocean by the "//& "coupler. This is used for testing and should be =1.0 for any "//& @@ -1365,10 +1376,11 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) if (CS%restore_salt) then call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & - "The constant that relates the restoring surface fluxes "//& - "to the relative surface anomalies (akin to a piston "//& - "velocity). Note the non-MKS units.", & - units="m day-1", scale=US%m_to_Z*US%T_to_s, fail_if_missing=.true.) + "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, "SALT_RESTORE_FILE", CS%salt_restore_file, & "A file in which to find the surface salinity to use for restoring.", & default="salt_restore.nc") @@ -1376,8 +1388,6 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) "The name of the surface salinity variable to read from "//& "SALT_RESTORE_FILE for restoring salinity.", & default="salt") -! Convert CS%Flux_const from m day-1 to m s-1. - CS%Flux_const = CS%Flux_const / 86400.0 call get_param(param_file, mdl, "SRESTORE_AS_SFLUX", CS%salt_restore_as_sflux, & "If true, the restoring of salinity is applied as a salt "//& @@ -1413,10 +1423,11 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) if (CS%restore_temp) then call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & - "The constant that relates the restoring surface fluxes "//& - "to the relative surface anomalies (akin to a piston "//& - "velocity). Note the non-MKS units.", & - units="m day-1", scale=US%m_to_Z*US%T_to_s, fail_if_missing=.true.) + "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, "SST_RESTORE_FILE", CS%temp_restore_file, & "A file in which to find the surface temperature to use for restoring.", & default="temp_restore.nc") @@ -1424,8 +1435,6 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) "The name of the surface temperature variable to read from "//& "SST_RESTORE_FILE for restoring sst.", & default="temp") - ! Convert CS%Flux_const from m day-1 to m s-1. - CS%Flux_const = CS%Flux_const / 86400.0 call get_param(param_file, mdl, "MAX_DELTA_TRESTORE", CS%max_delta_trestore, & "The maximum sst difference used in restoring terms.", & @@ -1485,7 +1494,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) "an input file", default=.false.) call get_param(param_file, mdl, "GUST_CONST", CS%gust_const, & "The background gustiness in the winds.", & - units="Pa", default=0.02, scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) + units="Pa", default=0.0, scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) if (CS%read_gust_2d) then call get_param(param_file, mdl, "GUST_2D_FILE", gust_file, & "The file in which the wind gustiness is found in "//& @@ -1498,14 +1507,14 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) endif call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=.true.) + default=.false.) call get_param(param_file, mdl, "SURFACE_FORCING_2018_ANSWERS", CS%answers_2018, & "If true, use the order of arithmetic and expressions that recover the answers "//& "from the end of 2018. Otherwise, use a simpler expression to calculate gustiness.", & default=default_2018_answers) call get_param(param_file, mdl, "FIX_USTAR_GUSTLESS_BUG", CS%fix_ustar_gustless_bug, & "If true correct a bug in the time-averaging of the gustless wind friction velocity", & - default=.false.) + default=.true.) ! See whether sufficiently thick sea ice should be treated as rigid. call get_param(param_file, mdl, "USE_RIGID_SEA_ICE", CS%rigid_sea_ice, & @@ -1515,18 +1524,19 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) if (CS%rigid_sea_ice) then call get_param(param_file, mdl, "G_EARTH", CS%g_Earth, & "The gravitational acceleration of the Earth.", & - units="m s-2", default = 9.80) + 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, "SEA_ICE_MEAN_DENSITY", CS%density_sea_ice, & "A typical density of sea ice, used with the kinematic "//& - "viscosity, when USE_RIGID_SEA_ICE is true.", units="kg m-3", & - default=900.0) + "viscosity, when USE_RIGID_SEA_ICE is true.", & + units="kg m-3", default=900.0, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "SEA_ICE_VISCOSITY", CS%Kv_sea_ice, & "The kinematic viscosity of sufficiently thick sea ice "//& "for use in calculating the rigidity of sea ice.", & - units="m2 s-1", default=1.0e9) + units="m2 s-1", default=1.0e9, scale=US%Z_to_L**2*US%m_to_L**2*US%T_to_s) call get_param(param_file, mdl, "SEA_ICE_RIGID_MASS", CS%rigid_sea_ice_mass, & "The mass of sea-ice per unit area at which the sea-ice "//& - "starts to exhibit rigidity", units="kg m-2", default=1000.0) + "starts to exhibit rigidity", & + units="kg m-2", default=1000.0, scale=US%kg_m3_to_R*US%m_to_Z) endif call get_param(param_file, mdl, "ALLOW_ICEBERG_FLUX_DIAGNOSTICS", iceberg_flux_diags, & diff --git a/config_src/coupled_driver/ocean_model_MOM.F90 b/config_src/coupled_driver/ocean_model_MOM.F90 index 407a11a0c3..082099158c 100644 --- a/config_src/coupled_driver/ocean_model_MOM.F90 +++ b/config_src/coupled_driver/ocean_model_MOM.F90 @@ -77,6 +77,8 @@ module ocean_model_mod public ice_ocn_bnd_type_chksum public ocean_public_type_chksum public ocean_model_data_get +public get_ocean_grid +public ocean_model_get_UV_surf !> This interface extracts a named scalar field or array from the ocean surface or public type interface ocean_model_data_get @@ -222,7 +224,7 @@ module ocean_model_mod !! This subroutine initializes both the ocean state and the ocean surface type. !! Because of the way that indicies and domains are handled, Ocean_sfc must have !! been used in a previous call to initialize_ocean_type. -subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn) +subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, wind_stagger, gas_fields_ocn) type(ocean_public_type), target, & intent(inout) :: Ocean_sfc !< A structure containing various publicly !! visible ocean surface properties after initialization, @@ -232,6 +234,8 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn) !! contain all information about the ocean's interior state. type(time_type), intent(in) :: Time_init !< The start time for the coupled model's calendar type(time_type), intent(in) :: Time_in !< The time at which to initialize the ocean model. + integer, optional, intent(in) :: wind_stagger !< If present, the staggering of the winds that are + !! being provided in calls to update_ocean_model type(coupler_1d_bc_type), & optional, intent(in) :: gas_fields_ocn !< If present, this type describes the !! ocean and surface-ice fields that will participate @@ -354,8 +358,13 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn) call allocate_surface_state(OS%sfc_state, OS%grid, use_temperature, do_integrals=.true., & gas_fields_ocn=gas_fields_ocn, use_meltpot=use_melt_pot) - call surface_forcing_init(Time_in, OS%grid, OS%US, param_file, OS%diag, & - OS%forcing_CSp) + if (present(wind_stagger)) then + call surface_forcing_init(Time_in, OS%grid, OS%US, param_file, OS%diag, & + OS%forcing_CSp, wind_stagger) + else + call surface_forcing_init(Time_in, OS%grid, OS%US, param_file, OS%diag, & + OS%forcing_CSp) + endif if (OS%use_ice_shelf) then call initialize_ice_shelf(param_file, OS%grid, OS%Time, OS%ice_shelf_CSp, & @@ -862,40 +871,40 @@ subroutine convert_state_to_ocean_type(sfc_state, Ocean_sfc, G, US, patm, press_ if (present(patm)) then do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%sea_lev(i,j) = sfc_state%sea_lev(i+i0,j+j0) + patm(i,j) * press_to_z - Ocean_sfc%area(i,j) = US%L_to_m**2*G%areaT(i+i0,j+j0) + Ocean_sfc%sea_lev(i,j) = US%Z_to_m * sfc_state%sea_lev(i+i0,j+j0) + patm(i,j) * press_to_z + Ocean_sfc%area(i,j) = US%L_to_m**2 * G%areaT(i+i0,j+j0) enddo ; enddo else do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%sea_lev(i,j) = sfc_state%sea_lev(i+i0,j+j0) - Ocean_sfc%area(i,j) = US%L_to_m**2*G%areaT(i+i0,j+j0) + Ocean_sfc%sea_lev(i,j) = US%Z_to_m * sfc_state%sea_lev(i+i0,j+j0) + Ocean_sfc%area(i,j) = US%L_to_m**2 * G%areaT(i+i0,j+j0) enddo ; enddo endif if (allocated(sfc_state%frazil)) then do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%frazil(i,j) = sfc_state%frazil(i+i0,j+j0) + Ocean_sfc%frazil(i,j) = US%Q_to_J_kg*US%RZ_to_kg_m2 * sfc_state%frazil(i+i0,j+j0) enddo ; enddo endif if (Ocean_sfc%stagger == AGRID) then do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%u_surf(i,j) = G%mask2dT(i+i0,j+j0) * & + Ocean_sfc%u_surf(i,j) = G%mask2dT(i+i0,j+j0) * US%L_T_to_m_s * & 0.5*(sfc_state%u(I+i0,j+j0)+sfc_state%u(I-1+i0,j+j0)) - Ocean_sfc%v_surf(i,j) = G%mask2dT(i+i0,j+j0) * & + Ocean_sfc%v_surf(i,j) = G%mask2dT(i+i0,j+j0) * US%L_T_to_m_s * & 0.5*(sfc_state%v(i+i0,J+j0)+sfc_state%v(i+i0,J-1+j0)) enddo ; enddo elseif (Ocean_sfc%stagger == BGRID_NE) then do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%u_surf(i,j) = G%mask2dBu(I+i0,J+j0) * & + Ocean_sfc%u_surf(i,j) = G%mask2dBu(I+i0,J+j0) * US%L_T_to_m_s * & 0.5*(sfc_state%u(I+i0,j+j0)+sfc_state%u(I+i0,j+j0+1)) - Ocean_sfc%v_surf(i,j) = G%mask2dBu(I+i0,J+j0) * & + Ocean_sfc%v_surf(i,j) = G%mask2dBu(I+i0,J+j0) * US%L_T_to_m_s * & 0.5*(sfc_state%v(i+i0,J+j0)+sfc_state%v(i+i0+1,J+j0)) enddo ; enddo elseif (Ocean_sfc%stagger == CGRID_NE) then do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%u_surf(i,j) = G%mask2dCu(I+i0,j+j0)*sfc_state%u(I+i0,j+j0) - Ocean_sfc%v_surf(i,j) = G%mask2dCv(i+i0,J+j0)*sfc_state%v(i+i0,J+j0) + Ocean_sfc%u_surf(i,j) = G%mask2dCu(I+i0,j+j0)*US%L_T_to_m_s * sfc_state%u(I+i0,j+j0) + Ocean_sfc%v_surf(i,j) = G%mask2dCv(i+i0,J+j0)*US%L_T_to_m_s * sfc_state%v(i+i0,J+j0) enddo ; enddo else write(val_str, '(I8)') Ocean_sfc%stagger @@ -1045,6 +1054,16 @@ subroutine ocean_model_data2D_get(OS, Ocean, name, array2D, isc, jsc) array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET case('btfHeat') array2D(isc:,jsc:) = 0 + case('cos_rot') + array2D(isc:,jsc:) = OS%grid%cos_rot(g_isc:g_iec,g_jsc:g_jec) ! =1 + case('sin_rot') + array2D(isc:,jsc:) = OS%grid%sin_rot(g_isc:g_iec,g_jsc:g_jec) ! =0 + case('s_surf') + array2D(isc:,jsc:) = Ocean%s_surf(isc:,jsc:) + case('sea_lev') + array2D(isc:,jsc:) = Ocean%sea_lev(isc:,jsc:) + case('frazil') + array2D(isc:,jsc:) = Ocean%frazil(isc:,jsc:) case default call MOM_error(FATAL,'get_ocean_grid_data2D: unknown argument name='//name) end select @@ -1096,4 +1115,76 @@ subroutine ocean_public_type_chksum(id, timestep, ocn) end subroutine ocean_public_type_chksum +!> This subroutine gives a handle to the grid from ocean state +subroutine get_ocean_grid(OS, Gridp) + ! Obtain the ocean grid. + type(ocean_state_type) :: OS !< A structure containing the + !! internal ocean state + type(ocean_grid_type) , pointer :: Gridp !< The ocean's grid structure + + Gridp => OS%grid + return +end subroutine get_ocean_grid + +!> This subroutine extracts a named (u- or v-) 2-D surface current from ocean internal state +subroutine ocean_model_get_UV_surf(OS, Ocean, name, array2D, isc, jsc) + + type(ocean_state_type), pointer :: OS !< A pointer to the structure containing the + !! internal ocean state (intent in). + type(ocean_public_type), intent(in) :: Ocean !< A structure containing various publicly + !! visible ocean surface fields. + character(len=*) , intent(in) :: name !< The name of the current (ua or va) to extract + real, dimension(isc:,jsc:), intent(out):: array2D !< The values of the named field, it must + !! cover only the computational domain + integer , intent(in) :: isc !< The starting i-index of array2D + integer , intent(in) :: jsc !< The starting j-index of array2D + + type(ocean_grid_type) , pointer :: G !< The ocean's grid structure + type(surface), pointer :: sfc_state !< A structure containing fields that + !! describe the surface state of the ocean. + + integer :: isc_bnd, iec_bnd, jsc_bnd, jec_bnd + integer :: i, j, i0, j0 + integer :: is, ie, js, je + + if (.not.associated(OS)) return + if (.not.OS%is_ocean_pe) return + + G => OS%grid + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + call mpp_get_compute_domain(Ocean%Domain, isc_bnd, iec_bnd, & + jsc_bnd, jec_bnd) + + i0 = is - isc_bnd ; j0 = js - jsc_bnd + + sfc_state => OS%sfc_state + + select case(name) + case('ua') + do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd + array2D(i,j) = G%mask2dT(i+i0,j+j0) * & + 0.5*(sfc_state%u(I+i0,j+j0)+sfc_state%u(I-1+i0,j+j0)) + enddo ; enddo + case('va') + do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd + array2D(i,j) = G%mask2dT(i+i0,j+j0) * & + 0.5*(sfc_state%v(i+i0,J+j0)+sfc_state%v(i+i0,J-1+j0)) + enddo ; enddo + case('ub') + do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd + array2D(i,j) = G%mask2dBu(I+i0,J+j0) * & + 0.5*(sfc_state%u(I+i0,j+j0)+sfc_state%u(I+i0,j+j0+1)) + enddo ; enddo + case('vb') + do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd + array2D(i,j) = G%mask2dBu(I+i0,J+j0) * & + 0.5*(sfc_state%v(i+i0,J+j0)+sfc_state%v(i+i0+1,J+j0)) + enddo ; enddo + case default + call MOM_error(FATAL,'ocean_model_get_UV_surf: unknown argument name='//name) + end select + +end subroutine ocean_model_get_UV_surf + end module ocean_model_mod diff --git a/config_src/external/GFDL_ocean_BGC/FMS_coupler_util.F90 b/config_src/external/GFDL_ocean_BGC/FMS_coupler_util.F90 new file mode 100644 index 0000000000..f3d63dd061 --- /dev/null +++ b/config_src/external/GFDL_ocean_BGC/FMS_coupler_util.F90 @@ -0,0 +1,35 @@ +module FMS_coupler_util + +use coupler_types_mod, only : coupler_2d_bc_type + +implicit none ; private + +public :: extract_coupler_values, set_coupler_values + +contains + +!> Get element and index of a boundary condition +subroutine extract_coupler_values(BC_struc, BC_index, BC_element, array_out, ilb, jlb, & + is, ie, js, je, conversion) + real, dimension(ilb:,jlb:),intent(out) :: array_out !< The array being filled with the input values + integer, intent(in) :: ilb, jlb !< Lower bounds + type(coupler_2d_bc_type), intent(in) :: BC_struc !< The type from which the data is being extracted + integer, intent(in) :: BC_index !< The boundary condition number being extracted + integer, intent(in) :: BC_element !< The element of the boundary condition being extracted + integer, optional, intent(in) :: is, ie, js, je !< The i- and j- limits of array_out to be filled + real, optional, intent(in) :: conversion !< A number that every element is multiplied by +end subroutine extract_coupler_values + +!> Set element and index of a boundary condition +subroutine set_coupler_values(array_in, BC_struc, BC_index, BC_element, ilb, jlb,& + is, ie, js, je, conversion) + real, dimension(ilb:,jlb:), intent(in) :: array_in !< The array containing the values to load into the BC + integer, intent(in) :: ilb, jlb !< Lower bounds + type(coupler_2d_bc_type), intent(inout) :: BC_struc !< The type into which the data is being loaded + integer, intent(in) :: BC_index !< The boundary condition number being set + integer, intent(in) :: BC_element !< The element of the boundary condition being set + integer, optional, intent(in) :: is, ie, js, je !< The i- and j- limits of array_out to be filled + real, optional, intent(in) :: conversion !< A number that every element is multiplied by +end subroutine set_coupler_values + +end module FMS_coupler_util diff --git a/config_src/external/GFDL_ocean_BGC/README.md b/config_src/external/GFDL_ocean_BGC/README.md new file mode 100644 index 0000000000..198575c8a7 --- /dev/null +++ b/config_src/external/GFDL_ocean_BGC/README.md @@ -0,0 +1,6 @@ +GFDL_ocean_BGC +============== + +These APIs reflect those for the GFDL ocean_BGC available at https://github.com/NOAA-GFDL/ocean_BGC. + +The modules in this directory do not do any computations. They simply reflect the APIs of the above package. diff --git a/config_src/external/GFDL_ocean_BGC/generic_tracer.F90 b/config_src/external/GFDL_ocean_BGC/generic_tracer.F90 new file mode 100644 index 0000000000..bfbc846af9 --- /dev/null +++ b/config_src/external/GFDL_ocean_BGC/generic_tracer.F90 @@ -0,0 +1,130 @@ +!> A non-functioning template of the GFDL ocean BGC +module generic_tracer + + use time_manager_mod, only : time_type + use coupler_types_mod, only : coupler_2d_bc_type + + use g_tracer_utils, only : g_tracer_type, g_diag_type + + implicit none ; private + + public generic_tracer_register + public generic_tracer_init + public generic_tracer_register_diag + public generic_tracer_source + public generic_tracer_update_from_bottom + public generic_tracer_coupler_get + public generic_tracer_coupler_set + public generic_tracer_end + public generic_tracer_get_list + public do_generic_tracer + public generic_tracer_vertdiff_G + public generic_tracer_get_diag_list + public generic_tracer_coupler_accumulate + + !> Turn on generic tracers (note dangerous use of module data) + logical :: do_generic_tracer = .true. + +contains + + !> Unknown + subroutine generic_tracer_register + end subroutine generic_tracer_register + + !> Initialize generic tracers + subroutine generic_tracer_init(isc,iec,jsc,jec,isd,ied,jsd,jed,nk,ntau,axes,grid_tmask,grid_kmt,init_time) + integer, intent(in) :: isc,iec,jsc,jec,isd,ied,jsd,jed,nk,ntau,axes(3) !< Domain boundaries and axes + type(time_type), intent(in) :: init_time !< Time + real, dimension(:,:,:),target, intent(in) :: grid_tmask !< Mask + integer, dimension(:,:) , intent(in) :: grid_kmt !< Number of wet cells in column + end subroutine generic_tracer_init + + !> Unknown + subroutine generic_tracer_register_diag + end subroutine generic_tracer_register_diag + + !> Get coupler values + subroutine generic_tracer_coupler_get(IOB_struc) + type(coupler_2d_bc_type), intent(in) :: IOB_struc !< Ice Ocean Boundary flux structure + end subroutine generic_tracer_coupler_get + + !> Unknown + subroutine generic_tracer_coupler_accumulate(IOB_struc, weight, model_time) + type(coupler_2d_bc_type), intent(in) :: IOB_struc !< Ice Ocean Boundary flux structure + real, intent(in) :: weight !< Unknown + type(time_type), optional,intent(in) :: model_time !< Time + end subroutine generic_tracer_coupler_accumulate + + !> Calls the corresponding generic_X_update_from_source routine for each package X + subroutine generic_tracer_source(Temp,Salt,rho_dzt,dzt,hblt_depth,ilb,jlb,tau,dtts,& + grid_dat,model_time,nbands,max_wavelength_band,sw_pen_band,opacity_band,internal_heat,& + frunoff,grid_ht, current_wave_stress, sosga) + real, dimension(ilb:,jlb:,:), intent(in) :: Temp !< Potential temperature [deg C] + real, dimension(ilb:,jlb:,:), intent(in) :: Salt !< Salinity [psu] + real, dimension(ilb:,jlb:,:), intent(in) :: rho_dzt + real, dimension(ilb:,jlb:,:), intent(in) :: dzt !< Ocean layer thickness [m] + real, dimension(ilb:,jlb:), intent(in) :: hblt_depth !< Boundary layer depth + integer, intent(in) :: ilb !< Lower bounds of x extent of input arrays on data domain + integer, intent(in) :: jlb !< Lower bounds of y extent of input arrays on data domain + integer, intent(in) :: tau !< Time step index of %field + real, intent(in) :: dtts !< Unknown + real, dimension(ilb:,jlb:), intent(in) :: grid_dat !< Unknown + type(time_type), intent(in) :: model_time !< Time + integer, intent(in) :: nbands !< Unknown + real, dimension(:), intent(in) :: max_wavelength_band + real, dimension(:,ilb:,jlb:), intent(in) :: sw_pen_band !< Shortwave penetration + real, dimension(:,ilb:,jlb:,:), intent(in) :: opacity_band !< Unknown + real, dimension(ilb:,jlb:),optional, intent(in) :: internal_heat !< Unknown + real, dimension(ilb:,jlb:),optional, intent(in) :: frunoff !< Unknown + real, dimension(ilb:,jlb:),optional, intent(in) :: grid_ht !< Unknown + real, dimension(ilb:,jlb:),optional , intent(in) :: current_wave_stress !< Unknown + real, optional , intent(in) :: sosga ! global avg. sea surface salinity + end subroutine generic_tracer_source + + !> Update the tracers from bottom fluxes + subroutine generic_tracer_update_from_bottom(dt, tau, model_time) + real, intent(in) :: dt !< Time step increment + integer, intent(in) :: tau !< Time step index used for the concentration field + type(time_type), intent(in) :: model_time !< Time + end subroutine generic_tracer_update_from_bottom + + !> Vertically diffuse all generic tracers for GOLD ocean + subroutine generic_tracer_vertdiff_G(h_old, ea, eb, dt, kg_m2_to_H, m_to_H, tau) + real, dimension(:,:,:), intent(in) :: h_old !< Unknown + real, dimension(:,:,:), intent(in) :: ea !< Unknown + real, dimension(:,:,:), intent(in) :: eb !< Unknown + real, intent(in) :: dt !< Unknown + real, intent(in) :: kg_m2_to_H !< Unknown + real, intent(in) :: m_to_H !< Unknown + integer, intent(in) :: tau !< Unknown + end subroutine generic_tracer_vertdiff_G + + !> Set the coupler values for each generic tracer + subroutine generic_tracer_coupler_set(IOB_struc, ST,SS,rho,ilb,jlb,tau, dzt, sosga,model_time) + type(coupler_2d_bc_type), intent(inout) :: IOB_struc !< Ice Ocean Boundary flux structure + integer, intent(in) :: ilb !< Lower bounds of x extent of input arrays on data domain + integer, intent(in) :: jlb !< Lower bounds of y extent of input arrays on data domain + integer, intent(in) :: tau !< Time step index of %field + real, dimension(ilb:,jlb:), intent(in) :: ST !< Sea surface temperature [deg C] + real, dimension(ilb:,jlb:), intent(in) :: SS !< Sea surface salinity [psu] + real, dimension(ilb:,jlb:,:,:), intent(in) :: rho !< Ocean density [kg m-3] + real, dimension(ilb:,jlb:,:), optional, intent(in) :: dzt !< Layer thickness [m] + real, optional, intent(in) :: sosga !< Unknown + type(time_type),optional, intent(in) :: model_time !< Time + end subroutine generic_tracer_coupler_set + + !> End this module by calling the corresponding generic_X_end for each package X + subroutine generic_tracer_end + end subroutine generic_tracer_end + + !> Get a pointer to the head of the generic tracers list + subroutine generic_tracer_get_list(list) + type(g_tracer_type), pointer :: list !< Pointer to head of the linked list + end subroutine generic_tracer_get_list + + !> Unknown + subroutine generic_tracer_get_diag_list(list) + type(g_diag_type), pointer :: list !< Pointer to head of the linked list + end subroutine generic_tracer_get_diag_list + +end module generic_tracer diff --git a/config_src/external/GFDL_ocean_BGC/generic_tracer_utils.F90 b/config_src/external/GFDL_ocean_BGC/generic_tracer_utils.F90 new file mode 100644 index 0000000000..6937ef4710 --- /dev/null +++ b/config_src/external/GFDL_ocean_BGC/generic_tracer_utils.F90 @@ -0,0 +1,284 @@ +!> g_tracer_utils module consists of core utility subroutines to be used by +!! all generic tracer modules. These include the lowest level functions +!! for adding, allocating memory, and record keeping of individual generic +!! tracers irrespective of their physical/chemical nature. +module g_tracer_utils + + use coupler_types_mod, only: coupler_2d_bc_type + use time_manager_mod, only : time_type + use field_manager_mod, only: fm_string_len + use MOM_diag_mediator, only : g_diag_ctrl=>diag_ctrl + +implicit none ; private + + !> Each generic tracer node is an instant of a FORTRAN type with the following member variables. + !! These member fields are supposed to uniquely define an individual tracer. + !! One such type shall be instantiated for EACH individual tracer. + type g_tracer_type + !> Tracer concentration field in space (and time) + !! MOM keeps the prognostic tracer fields at 3 time levels, hence 4D. + real, pointer, dimension(:,:,:,:) :: field => NULL() + !> Tracer concentration in river runoff + real, allocatable, dimension(:,:) :: trunoff + logical :: requires_restart = .true. !< Unknown + !> Tracer source: filename, type, var name, units, record, gridfile + character(len=fm_string_len) :: src_file, src_var_name, src_var_unit, src_var_gridspec + integer :: src_var_record !< Unknown + logical :: requires_src_info = .false. !< Unknown + real :: src_var_unit_conversion = 1.0 !< This factor depends on the tracer. Ask Jasmin + real :: src_var_valid_min = 0.0 !< Unknown + end type g_tracer_type + + !> Unknown + type g_diag_type + integer :: dummy !< A dummy member, not part of the API + end type g_diag_type + + !> The following type fields are common to ALL generic tracers and hence has to be instantiated only once + type g_tracer_common +! type(g_diag_ctrl) :: diag_CS !< Unknown + !> Domain extents + integer :: isd,jsd + end type g_tracer_common + + !> Unknown dangerous module data! + type(g_tracer_common), target, save :: g_tracer_com + + public :: g_tracer_type + public :: g_tracer_flux_init + public :: g_tracer_set_values + public :: g_tracer_get_values + public :: g_tracer_get_pointer + public :: g_tracer_get_common + public :: g_tracer_set_common + public :: g_tracer_set_csdiag + public :: g_tracer_send_diag + public :: g_tracer_get_name + public :: g_tracer_get_alias + public :: g_tracer_get_next + public :: g_tracer_is_prog + public :: g_diag_type + + !> Set the values of various (array) members of the tracer node g_tracer_type + !! + !! This function is overloaded to set the values of the following member variables + interface g_tracer_set_values + module procedure g_tracer_set_real + module procedure g_tracer_set_2D + module procedure g_tracer_set_3D + module procedure g_tracer_set_4D + end interface + + !> Reverse of interface g_tracer_set_values for getting the tracer member arrays in the argument value + !! + !! This means "get the values of array %field_name for tracer tracer_name and put them in argument array_out" + interface g_tracer_get_values + module procedure g_tracer_get_4D_val + module procedure g_tracer_get_3D_val + module procedure g_tracer_get_2D_val + module procedure g_tracer_get_real + module procedure g_tracer_get_string + end interface + + !> Return the pointer to the requested field of a particular tracer + !! + !! This means "get the pointer of array %field_name for tracer tracer_name in argument array_ptr" + interface g_tracer_get_pointer + module procedure g_tracer_get_4D + module procedure g_tracer_get_3D + module procedure g_tracer_get_2D + end interface + +contains + + !> Unknown + subroutine g_tracer_flux_init(g_tracer) + type(g_tracer_type), pointer :: g_tracer !< Pointer to this tracer node + end subroutine g_tracer_flux_init + + !> Unknown + subroutine g_tracer_set_csdiag(diag_CS) + type(g_diag_ctrl), target,intent(in) :: diag_CS !< Unknown + end subroutine g_tracer_set_csdiag + + subroutine g_tracer_set_common(isc,iec,jsc,jec,isd,ied,jsd,jed,nk,ntau,axes,grid_tmask,grid_kmt,init_time) + integer, intent(in) :: isc,iec,jsc,jec,isd,ied,jsd,jed,nk,ntau,axes(3) !< Unknown + real, dimension(isd:,jsd:,:),intent(in) :: grid_tmask !< Unknown + integer,dimension(isd:,jsd:),intent(in) :: grid_kmt !< Unknown + type(time_type), intent(in) :: init_time !< Unknown + end subroutine g_tracer_set_common + + subroutine g_tracer_get_common(isc,iec,jsc,jec,isd,ied,jsd,jed,nk,ntau,& + axes,grid_tmask,grid_mask_coast,grid_kmt,init_time,diag_CS) + integer, intent(out) :: isc,iec,jsc,jec,isd,ied,jsd,jed,nk,ntau !< Unknown + integer,optional, intent(out) :: axes(3) !< Unknown + type(time_type), optional, intent(out) :: init_time !< Unknown + real, optional, dimension(:,:,:),pointer :: grid_tmask !< Unknown + integer, optional, dimension(:,:), pointer :: grid_mask_coast !< Unknown + integer, optional, dimension(:,:), pointer :: grid_kmt !< Unknown + type(g_diag_ctrl), optional, pointer :: diag_CS !< Unknown + end subroutine g_tracer_get_common + + !> Unknown + subroutine g_tracer_get_4D(g_tracer_list,name,member,array_ptr) + character(len=*), intent(in) :: name !< Unknown + character(len=*), intent(in) :: member !< Unknown + type(g_tracer_type), pointer :: g_tracer_list, g_tracer !< Unknown + real, dimension(:,:,:,:), pointer :: array_ptr + end subroutine g_tracer_get_4D + + !> Unknown + subroutine g_tracer_get_3D(g_tracer_list,name,member,array_ptr) + character(len=*), intent(in) :: name !< Unknown + character(len=*), intent(in) :: member !< Unknown + type(g_tracer_type), pointer :: g_tracer_list, g_tracer !< Unknown + real, dimension(:,:,:), pointer :: array_ptr !< Unknown + end subroutine g_tracer_get_3D + + !> Unknown + subroutine g_tracer_get_2D(g_tracer_list,name,member,array_ptr) + character(len=*), intent(in) :: name !< Unknown + character(len=*), intent(in) :: member !< Unknown + type(g_tracer_type), pointer :: g_tracer_list, g_tracer !< Unknown + real, dimension(:,:), pointer :: array_ptr !< Unknown + end subroutine g_tracer_get_2D + + !> Unknown + subroutine g_tracer_get_4D_val(g_tracer_list,name,member,array,isd,jsd) + character(len=*), intent(in) :: name !< Unknown + character(len=*), intent(in) :: member !< Unknown + type(g_tracer_type), pointer :: g_tracer_list, g_tracer !< Unknown + integer, intent(in) :: isd,jsd !< Unknown + real, dimension(isd:,jsd:,:,:), intent(out):: array !< Unknown + end subroutine g_tracer_get_4D_val + + !> Unknown + subroutine g_tracer_get_3D_val(g_tracer_list,name,member,array,isd,jsd,ntau,positive) + character(len=*), intent(in) :: name !< Unknown + character(len=*), intent(in) :: member !< Unknown + type(g_tracer_type), pointer :: g_tracer_list, g_tracer !< Unknown + integer, intent(in) :: isd,jsd !< Unknown + integer, optional, intent(in) :: ntau !< Unknown + logical, optional, intent(in) :: positive !< Unknown + real, dimension(isd:,jsd:,:), intent(out):: array !< Unknown + integer :: tau + character(len=fm_string_len), parameter :: sub_name = 'g_tracer_get_3D_val' + end subroutine g_tracer_get_3D_val + + !> Unknown + subroutine g_tracer_get_2D_val(g_tracer_list,name,member,array,isd,jsd) + character(len=*), intent(in) :: name !< Unknown + character(len=*), intent(in) :: member !< Unknown + type(g_tracer_type), pointer :: g_tracer_list, g_tracer !< Unknown + integer, intent(in) :: isd,jsd !< Unknown + real, dimension(isd:,jsd:), intent(out):: array !< Unknown + end subroutine g_tracer_get_2D_val + + !> Unknown + subroutine g_tracer_get_real(g_tracer_list,name,member,value) + character(len=*), intent(in) :: name !< Unknown + character(len=*), intent(in) :: member !< Unknown + type(g_tracer_type), pointer :: g_tracer_list, g_tracer !< Unknown + real, intent(out):: value + end subroutine g_tracer_get_real + + !> Unknown + subroutine g_tracer_get_string(g_tracer_list,name,member,string) + character(len=*), intent(in) :: name !< Unknown + character(len=*), intent(in) :: member !< Unknown + type(g_tracer_type), pointer :: g_tracer_list, g_tracer !< Unknown + character(len=fm_string_len), intent(out) :: string !< Unknown + end subroutine g_tracer_get_string + + !> Unknown + subroutine g_tracer_set_2D(g_tracer_list,name,member,array,isd,jsd,weight) + character(len=*), intent(in) :: name !< Unknown + character(len=*), intent(in) :: member !< Unknown + type(g_tracer_type), pointer :: g_tracer_list, g_tracer !< Unknown + integer, intent(in) :: isd,jsd !< Unknown + real, dimension(isd:,jsd:),intent(in) :: array !< Unknown + real, optional ,intent(in) :: weight !< Unknown + end subroutine g_tracer_set_2D + + !> Unknown + subroutine g_tracer_set_3D(g_tracer_list,name,member,array,isd,jsd,ntau) + character(len=*), intent(in) :: name !< Unknown + character(len=*), intent(in) :: member !< Unknown + type(g_tracer_type), pointer :: g_tracer_list, g_tracer !< Unknown + integer, intent(in) :: isd,jsd !< Unknown + integer, optional, intent(in) :: ntau !< Unknown + real, dimension(isd:,jsd:,:), intent(in) :: array !< Unknown + end subroutine g_tracer_set_3D + + !> Unknown + subroutine g_tracer_set_4D(g_tracer_list,name,member,array,isd,jsd) + character(len=*), intent(in) :: name !< Unknown + character(len=*), intent(in) :: member !< Unknown + type(g_tracer_type), pointer :: g_tracer_list, g_tracer !< Unknown + integer, intent(in) :: isd,jsd !< Unknown + real, dimension(isd:,jsd:,:,:), intent(in) :: array !< Unknown + end subroutine g_tracer_set_4D + + !> Unknown + subroutine g_tracer_set_real(g_tracer_list,name,member,value) + character(len=*), intent(in) :: name !< Unknown + character(len=*), intent(in) :: member !< Unknown + type(g_tracer_type), pointer :: g_tracer_list, g_tracer !< Unknown + real, intent(in) :: value !< Unknown + end subroutine g_tracer_set_real + + subroutine g_tracer_send_diag(g_tracer_list,model_time,tau) + type(g_tracer_type), pointer :: g_tracer_list !< pointer to the head of the generic tracer list + type(g_tracer_type), pointer :: g_tracer !< Pointer to tracer node + type(time_type), intent(in) :: model_time !< Time + integer, intent(in) :: tau !< The time step for the %field 4D field to be reported + end subroutine g_tracer_send_diag + + !> Unknown + subroutine g_tracer_get_name(g_tracer,string) + type(g_tracer_type), pointer :: g_tracer !< Unknown + character(len=*), intent(out) :: string !< Unknown + end subroutine g_tracer_get_name + + !> Unknown + subroutine g_tracer_get_alias(g_tracer,string) + type(g_tracer_type), pointer :: g_tracer !< Unknown + character(len=*), intent(out) :: string !< Unknown + end subroutine g_tracer_get_alias + + !> Is the tracer prognostic? + function g_tracer_is_prog(g_tracer) + logical :: g_tracer_is_prog + type(g_tracer_type), pointer :: g_tracer !< Pointer to tracer node + end function g_tracer_is_prog + + !> get the next tracer in the list + subroutine g_tracer_get_next(g_tracer,g_tracer_next) + type(g_tracer_type), pointer :: g_tracer !< Pointer to tracer node + type(g_tracer_type), pointer :: g_tracer_next !< Pointer to the next tracer node in the list + end subroutine g_tracer_get_next + + !>Vertical Diffusion of a tracer node + !! + !! This subroutine solves a tridiagonal equation to find and set values of vertically diffused field + !! for a tracer node.This is ported from GOLD (vertdiff) and simplified + !! Since the surface flux from the atmosphere (%stf) has the units of mol/m^2/sec the resulting + !! tracer concentration has units of mol/Kg + subroutine g_tracer_vertdiff_G(g_tracer, h_old, ea, eb, dt, kg_m2_to_H, m_to_H, tau, mom) + type(g_tracer_type), pointer :: g_tracer + !> Layer thickness before entrainment, in m or kg m-2. + real, dimension(g_tracer_com%isd:,g_tracer_com%jsd:,:), intent(in) :: h_old + !> The amount of fluid entrained from the layer above, in H. + real, dimension(g_tracer_com%isd:,g_tracer_com%jsd:,:), intent(in) :: ea + !> The amount of fluid entrained from the layer below, in H. + real, dimension(g_tracer_com%isd:,g_tracer_com%jsd:,:), intent(in) :: eb + real, intent(in) :: dt !< The amount of time covered by this call, in s. + real, intent(in) :: kg_m2_to_H !< A conversion factor that translates kg m-2 into + !! the units of h_old (H) + real, intent(in) :: m_to_H !< A conversion factor that translates m into the units + !! of h_old (H). + integer, intent(in) :: tau !< Unknown + logical, intent(in), optional :: mom + end subroutine g_tracer_vertdiff_G + +end module g_tracer_utils diff --git a/config_src/external/ODA_hooks/README.md b/config_src/external/ODA_hooks/README.md new file mode 100644 index 0000000000..b26731a463 --- /dev/null +++ b/config_src/external/ODA_hooks/README.md @@ -0,0 +1,9 @@ +ODA_hooks +========= + +These APIs reflect those for the ocean data assimilation hooks similar to https://github.com/MJHarrison-GFDL/MOM6_DA_hooks + +The modules in this directory do not do any computations. They simply reflect the APIs of the above package. + +- kdtree.f90 - would come from https://github.com/travissluka/geoKdTree +- ocean_da_core.F90, ocean_da_types.F90, write_ocean_obs.F90 were copied from https://github.com/MJHarrison-GFDL/MOM6_DA_hooks diff --git a/config_src/external/ODA_hooks/kdtree.f90 b/config_src/external/ODA_hooks/kdtree.f90 new file mode 100644 index 0000000000..a27716dde1 --- /dev/null +++ b/config_src/external/ODA_hooks/kdtree.f90 @@ -0,0 +1,12 @@ +!> A null version of K-d tree from geoKdTree +module kdtree + implicit none + private + + public :: kd_root + + !> A K-d tree tpe + type kd_root + integer :: dummy !< To stop a compiler from doing nothing + end type kd_root +end module kdtree diff --git a/config_src/external/ODA_hooks/ocean_da_core.F90 b/config_src/external/ODA_hooks/ocean_da_core.F90 new file mode 100644 index 0000000000..769e44b2aa --- /dev/null +++ b/config_src/external/ODA_hooks/ocean_da_core.F90 @@ -0,0 +1,47 @@ +!> A set of dummy interfaces for compiling the MOM6 DA driver code. +module ocean_da_core_mod + ! MOM modules + use MOM_domains, only : MOM_domain_type, domain2D + use MOM_time_manager, only : time_type, set_time, get_date + ! ODA_tools modules + use ocean_da_types_mod, only : ocean_profile_type, grid_type + use kdtree, only : kd_root + + implicit none + private + public :: ocean_da_core_init + public :: get_profiles + +contains + + !> Initializes the MOM6 DA driver code. + subroutine ocean_da_core_init(Domain, global_grid, Profiles, model_time) + type(domain2D), pointer, intent(in) :: Domain !< A MOM domain type + type(grid_type), pointer, intent(in) :: global_grid !< The global ODA horizontal grid type + type(ocean_profile_type), pointer :: Profiles !< This is an unstructured recursive list of profiles + !! which are either within the localized domain corresponding + !! to the Domain argument, or the global profile list (type). + type(time_type), intent(in) :: model_time !< The current model time type. + + + + Profiles=>NULL() + return + end subroutine ocean_da_core_init + + + !> Get profiles obs within the current analysis interval + subroutine get_profiles(model_time, Profiles, Current_profiles) + type(time_type), intent(in) :: model_time !< The current analysis time. + type(ocean_profile_type), pointer :: Profiles !< The full recursive list of profiles. + type(ocean_profile_type), pointer :: Current_profiles !< A returned list of profiles for the + !! current analysis step. + + Profiles=>NULL() + Current_Profiles=>NULL() + + return + end subroutine get_profiles + + +end module ocean_da_core_mod diff --git a/config_src/external/ODA_hooks/ocean_da_types.F90 b/config_src/external/ODA_hooks/ocean_da_types.F90 new file mode 100644 index 0000000000..bc5af1d782 --- /dev/null +++ b/config_src/external/ODA_hooks/ocean_da_types.F90 @@ -0,0 +1,85 @@ +!> Dummy aata structures and methods for ocean data assimilation. +module ocean_da_types_mod + + use MOM_time_manager, only : time_type + + implicit none + + private + + + !> Example type for ocean ensemble DA state + type, public :: OCEAN_CONTROL_STRUCT + integer :: ensemble_size + real, pointer, dimension(:,:,:) :: SSH=>NULL() !NULL() !NULL() !NULL() !NULL() !NULL() ! Example of a profile type + type, public :: ocean_profile_type + integer :: inst_type !< A numeric code indicating the type of instrument (e.g. ARGO drifter, CTD, ...) + logical :: initialized !< a True value indicates that this profile has been allocated for use + logical :: colocated !< a True value indicated that the measurements of (num_variables) data are + !! co-located in space-time + integer :: ensemble_size !< size of the ensemble of model states used in association with this profile + integer :: num_variables !< number of measurement types associated with this profile. + integer, pointer, dimension(:) :: var_id !< variable ids are defined by the ocean_types module + integer :: platform !< platform types are defined by platform class (e.g. MOORING, DROP, etc.) + !! and instrument type (XBT, CDT, etc.) + integer :: levels !< number of levels in the current profile + integer :: basin_mask !< 1:Southern Ocean, 2:Atlantic Ocean, 3:Pacific Ocean, + !! 4:Arctic Ocean, 5:Indian Ocean, 6:Mediterranean Sea, 7:Black Sea, + !! 8:Hudson Bay, 9:Baltic Sea, 10:Red Sea, 11:Persian Gulf + integer :: profile_flag !< an overall flag for the profile + real :: lat, lon !< latitude and longitude (degrees E and N) + logical :: accepted !< logical flag to disable a profile + type(time_type) :: time_window !< The time window associated with this profile [s] + real, pointer, dimension(:) :: obs_error !< The observation error by variable + real :: loc_dist !< The impact radius of this observation (m) + type(ocean_profile_type), pointer :: next=>NULL() !< all profiles are stored as linked list. + type(ocean_profile_type), pointer :: prev=>NULL() + type(ocean_profile_type), pointer :: cnext=>NULL() ! current profiles are stored as linked list. + type(ocean_profile_type), pointer :: cprev=>NULL() + integer :: nbr_xi, nbr_yi ! nearest neighbor model gridpoint for the profile + real :: nbr_dist ! distance to nearest neighbor model gridpoint + logical :: compute !< profile is within current compute domain + real, dimension(:,:), pointer :: depth => NULL() !< depth of measurement [m] + real, dimension(:,:), pointer :: data => NULL() !< data by variable type + integer, dimension(:,:), pointer :: flag => NULL() !< flag by depth and variable type + real, dimension(:,:,:), pointer :: forecast => NULL() !< ensemble member first guess + real, dimension(:,:,:), pointer :: analysis => NULL() !< ensemble member analysis + type(forward_operator_type), pointer :: obs_def => NULL() !< observation forward operator + type(time_type) :: time !< profile time type + real :: i_index, j_index !< model longitude and latitude indices respectively + real, dimension(:,:), pointer :: k_index !< model depth indices + type(time_type) :: tdiff !< difference between model time and observation time + character(len=128) :: filename + end type ocean_profile_type + + !> Example forward operator type. + type, public :: forward_operator_type + integer :: num + integer, dimension(2) :: state_size !< for + integer, dimension(:), pointer :: state_var_index !< for flattened data + integer, dimension(:), pointer :: i_index !< i-dimension index + integer, dimension(:), pointer :: j_index !< j-dimension index + real, dimension(:), pointer :: coef + end type forward_operator_type + + !> Grid type for DA + type, public :: grid_type + real, pointer, dimension(:,:) :: x=>NULL(), y=>NULL() + real, pointer, dimension(:,:,:) :: z=>NULL() + real, pointer, dimension(:,:,:) :: h=>NULL() + real, pointer, dimension(:,:) :: basin_mask => NULL() + real, pointer, dimension(:,:,:) :: mask => NULL() + real, pointer, dimension(:,:) :: bathyT => NULL() + logical :: tripolar_N + integer :: ni, nj, nk + end type grid_type + +end module ocean_da_types_mod diff --git a/config_src/external/ODA_hooks/write_ocean_obs.F90 b/config_src/external/ODA_hooks/write_ocean_obs.F90 new file mode 100644 index 0000000000..a2c41b58d6 --- /dev/null +++ b/config_src/external/ODA_hooks/write_ocean_obs.F90 @@ -0,0 +1,50 @@ +!> Dummy interfaces for writing ODA data +module write_ocean_obs_mod + + + use ocean_da_types_mod, only : ocean_profile_type + use MOM_time_manager, only : time_type, get_time, set_date + + implicit none + + private + + public :: open_profile_file, write_profile, close_profile_file, & + write_ocean_obs_init + +contains + +!> Open a profile file +integer function open_profile_file(name, nvar, grid_lon, grid_lat,thread,fset) + character(len=*), intent(in) :: name !< File name + integer, intent(in), optional :: nvar !< Number of variables + real, dimension(:), optional, intent(in) :: grid_lon !< Longitude [degreeE] + real, dimension(:), optional, intent(in) :: grid_lat !< Latitude [degreeN] + integer, intent(in), optional :: thread !< Thread + integer, intent(in), optional :: fset !< File set + + open_profile_file=-1 +end function open_profile_file + +!> Write a profile +subroutine write_profile(unit,profile) + integer, intent(in) :: unit !< File unit + type(ocean_profile_type), intent(in) :: profile !< Profile + + return +end subroutine write_profile + +!> Close a profile file +subroutine close_profile_file(unit) + integer, intent(in) :: unit !< File unit + + return +end subroutine close_profile_file + +!> Initialize write_ocean_obs module +subroutine write_ocean_obs_init() + + return +end subroutine write_ocean_obs_init + +end module write_ocean_obs_mod diff --git a/config_src/external/README.md b/config_src/external/README.md new file mode 100644 index 0000000000..ff70f35915 --- /dev/null +++ b/config_src/external/README.md @@ -0,0 +1,10 @@ +config_src/external +=================== + +Subdirectories in here provide null versions of external packages that +can be called by, or used with, MOM6 but that are not needed in all +configurations/executables. + +The APIs in these modules should be consistent with the actual external +package. To build with the actual external package include it in the +search path for your build system and remove the associated null version. diff --git a/config_src/ice_solo_driver/MOM_surface_forcing.F90 b/config_src/ice_solo_driver/MOM_surface_forcing.F90 deleted file mode 100644 index 1e59fee863..0000000000 --- a/config_src/ice_solo_driver/MOM_surface_forcing.F90 +++ /dev/null @@ -1,1204 +0,0 @@ -module MOM_surface_forcing - -! This file is part of MOM6. See LICENSE.md for the license. - -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* By Robert Hallberg, November 1998 - May 2002 * -!* Edited by Stephen Griffies June 2014 * -!* * -!* This program contains the subroutines that calculate the * -!* surface wind stresses and fluxes of buoyancy or temperature and * -!* fresh water. These subroutines will be called every time step, * -!* even if the wind stresses or buoyancy fluxes are constant in time * -!* - in that case these routines return quickly without doing * -!* anything. In addition, any I/O of forcing fields is controlled * -!* by surface_forcing_init, located in this file. * -!* * -!* set_forcing is a small entry subroutine for the subroutines in * -!* this file. It provides the external access to these subroutines. * -!* * -!* wind_forcing determines the wind stresses and places them into * -!* taux[][] and tauy[][]. Often wind_forcing must be tailored for * -!* a particular application - either by specifying file and variable * -!* names or by providing appropriate internal expressions for the * -!* stresses. * -!* * -!* buoyancy_forcing determines the surface fluxes of buoyancy, * -!* temperature, and fresh water, as is appropriate. A restoring * -!* boundary condition is implemented, but the code for any other * -!* boundary condition will usually be modified - either to specify * -!* file and variable names and which time level to read, or to set * -!* an internal expression for the variables. * -!* * -!* Macros written all in capital letters are defined in MOM_memory.h. * -!* * -!* A small fragment of the grid is shown below: * -!* * -!* j+1 x ^ x ^ x At x: q * -!* j+1 > o > o > At ^: v, tauy * -!* j x ^ x ^ x At >: u, taux * -!* j > o > o > At o: h, fluxes. * -!* j-1 x ^ x ^ x * -!* i-1 i i+1 At x & ^: * -!* i i+1 At > & o: * -!* * -!* The boundaries always run through q grid points (x). * -!* * -!********+*********+*********+*********+*********+*********+*********+** - -use MOM_constants, only : hlv, hlf -use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end -use MOM_cpu_clock, only : CLOCK_MODULE -use MOM_diag_mediator, only : post_data, query_averaging_enabled -use MOM_diag_mediator, only : register_diag_field, diag_ctrl, safe_alloc_ptr -use MOM_domains, only : pass_var, pass_vector, AGRID, To_South, To_West, To_All -use MOM_error_handler, only : callTree_enter, callTree_leave -use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg, is_root_pe -use MOM_file_parser, only : get_param, log_version, param_file_type -use MOM_string_functions, only : uppercase -use MOM_forcing_type, only : forcing, mech_forcing -use MOM_forcing_type, only : forcing_diags, mech_forcing_diags, register_forcing_type_diags -use MOM_forcing_type, only : set_net_mass_forcing, copy_common_forcing_fields -use MOM_forcing_type, only : set_derived_forcing_fields -use MOM_forcing_type, only : allocate_forcing_type, deallocate_forcing_type -use MOM_forcing_type, only : allocate_mech_forcing, deallocate_mech_forcing -use MOM_get_input, only : Get_MOM_Input, directories -use MOM_grid, only : ocean_grid_type -use MOM_io, only : file_exists, MOM_read_data, MOM_read_vector, slasher -use MOM_restart, only : register_restart_field, restart_init, MOM_restart_CS -use MOM_restart, only : restart_init_end, save_restart, restore_state -use MOM_time_manager, only : time_type, operator(+), operator(/), get_time, set_time -use MOM_tracer_flow_control, only : call_tracer_set_forcing -use MOM_tracer_flow_control, only : tracer_flow_control_CS -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : surface -use user_surface_forcing, only : USER_wind_forcing, USER_buoyancy_forcing -use user_surface_forcing, only : USER_surface_forcing_init, user_surface_forcing_CS -use user_revise_forcing, only : user_alter_forcing, user_revise_forcing_init -use user_revise_forcing, only : user_revise_forcing_CS - -implicit none ; private - -#include - -public set_forcing -public surface_forcing_init -public forcing_diagnostics -public forcing_save_restart - -! surface_forcing_CS is a structure containing pointers to the forcing fields -! which may be used to drive MOM. All fluxes are positive into the ocean. -type, public :: surface_forcing_CS ; private - - logical :: use_temperature !< if true, temp & salinity used as state variables - logical :: restorebuoy !< if true, use restoring surface buoyancy forcing - logical :: adiabatic !< if true, no diapycnal mass fluxes or surface buoyancy forcing - logical :: variable_winds !< if true, wind stresses vary with time - logical :: variable_buoyforce !< if true, buoyancy forcing varies with time. - real :: south_lat !< southern latitude of the domain - real :: len_lat !< domain length in latitude - - real :: Rho0 !< Boussinesq reference density [R ~> kg m-3] - real :: G_Earth !< gravitational acceleration [L2 Z-1 T-2 ~> m s-2] - real :: Flux_const !< piston velocity for surface restoring [Z T-1 ~> m s-1] - real :: latent_heat_fusion !< latent heat of fusion times [Q ~> J kg-1] - real :: latent_heat_vapor !< latent heat of vaporization [Q ~> J kg-1] - - real :: gust_const !< constant unresolved background gustiness for ustar [R L Z T-1 ~> Pa] - logical :: read_gust_2d !< if true, use 2-dimensional gustiness supplied from a file - real, pointer :: gust(:,:) => NULL() !< spatially varying unresolved background gustiness [R L Z T-1 ~> Pa] - !< gust is used when read_gust_2d is true. - - real, pointer :: T_Restore(:,:) => NULL() !< temperature to damp (restore) the SST to [degC] - real, pointer :: S_Restore(:,:) => NULL() !< salinity to damp (restore) the SSS [ppt] - real, pointer :: Dens_Restore(:,:) => NULL() !< density to damp (restore) surface density [kg m-3] - - integer :: wind_last_lev_read = -1 !< The last time level read from the wind input files - integer :: buoy_last_lev_read = -1 !< The last time level read from buoyancy input files - - ! if WIND_CONFIG=='gyres' then use the following as = A, B, C and n respectively for - ! taux = A + B*sin(n*pi*y/L) + C*cos(n*pi*y/L) - real :: gyres_taux_const !< A constant wind stress [Pa]. - real :: gyres_taux_sin_amp !< The amplitude of cosine wind stress gyres [Pa], if WIND_CONFIG=='gyres'. - real :: gyres_taux_cos_amp !< The amplitude of cosine wind stress gyres [Pa], if WIND_CONFIG=='gyres'. - real :: gyres_taux_n_pis !< The number of sine lobes in the basin if if WIND_CONFIG=='gyres' - - real :: T_north !< target temperatures at north used in buoyancy_forcing_linear - real :: T_south !< target temperatures at south used in buoyancy_forcing_linear - real :: S_north !< target salinity at north used in buoyancy_forcing_linear - real :: S_south !< target salinity at south used in buoyancy_forcing_linear - - logical :: first_call_set_forcing = .true. !< True until after the first call to set_forcing - - real :: wind_scale !< value by which wind-stresses are scaled, ND. - character(len=8) :: wind_stagger !< A character indicating how the wind stress components - !! are staggered in WIND_FILE. Valid values are A or C for now. - - type(tracer_flow_control_CS), pointer :: tracer_flow_CSp => NULL() !< A pointer to the structure - !! that is used to orchestrate the calling of tracer packages - type(MOM_restart_CS), pointer :: restart_CSp => NULL() !< A pointer to the restart control structure - - type(diag_ctrl), pointer :: diag !< structure used to regulate timing of diagnostic output - - character(len=200) :: inputdir !< directory where NetCDF input files are. - character(len=200) :: wind_config !< indicator for wind forcing type (2gyre, USER, FILE..) - character(len=200) :: wind_file !< if wind_config is "file", file to use - character(len=200) :: buoy_config !< indicator for buoyancy forcing type - - character(len=200) :: longwavedown_file = '' !< The file from which the downward longwave heat flux is read - character(len=200) :: shortwavedown_file = '' !< The file from which the downward shortwave heat flux is read - character(len=200) :: evaporation_file = '' !< The file from which the evaporation is read - character(len=200) :: sensibleheat_file = '' !< The file from which the sensible heat flux is read - character(len=200) :: latentheat_file = '' !< The file from which the latent heat flux is read - - character(len=200) :: precip_file = '' !< The file from which the rainfall is read - character(len=200) :: snow_file = '' !< The file from which the snowfall is read - character(len=200) :: freshdischarge_file = '' !< The file from which the runoff and calving are read - - character(len=200) :: longwaveup_file = '' !< The file from which the upward longwave heat flux is read - character(len=200) :: shortwaveup_file = '' !< The file from which the upward shorwave heat flux is read - - character(len=200) :: SSTrestore_file = '' !< The file from which to read the sea surface - !! temperature to restore toward - character(len=200) :: salinityrestore_file = '' !< The file from which to read the sea surface - !! salinity to restore toward - - character(len=80) :: stress_x_var = '' !< X-windstress variable name in the input file - character(len=80) :: stress_y_var = '' !< Y-windstress variable name in the input file - - type(forcing_diags), public :: handles !< A structure with diagnostics handles - - !>@{ Control structures for named forcing packages - type(user_revise_forcing_CS), pointer :: urf_CS => NULL() - type(user_surface_forcing_CS), pointer :: user_forcing_CSp => NULL() - ! type(MESO_surface_forcing_CS), pointer :: MESO_forcing_CSp => NULL() - !!@} -end type surface_forcing_CS - -integer :: id_clock_forcing - -contains - -!> This subroutine calls other subroutines in this file to get surface forcing fields. -!! It also allocates and initializes the fields in the flux type. -subroutine set_forcing(sfc_state, forcing, fluxes, day_start, day_interval, G, US, CS) - type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. - type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields - type(time_type), intent(in) :: day_start !< The start time of the fluxes - type(time_type), intent(in) :: day_interval !< Length of time over which these fluxes applied - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned by a - !! previous surface_forcing_init call - - ! Local variables - real :: dt ! length of time over which fluxes applied [s] - type(time_type) :: day_center ! central time of the fluxes. - integer :: intdt - integer :: isd, ied, jsd, jed - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - - call cpu_clock_begin(id_clock_forcing) - - day_center = day_start + day_interval/2 - call get_time(day_interval, intdt) - dt = real(intdt) - - if (CS%first_call_set_forcing) then - ! Allocate memory for the mechanical and thermodyanmic forcing fields. - call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., press=.true.) - - call allocate_forcing_type(G, fluxes, ustar=.true.) - if (trim(CS%buoy_config) /= "NONE") then - if ( CS%use_temperature ) then - call allocate_forcing_type(G, fluxes, water=.true., heat=.true., press=.true.) - if (CS%restorebuoy) then - call safe_alloc_ptr(CS%T_Restore,isd, ied, jsd, jed) - call safe_alloc_ptr(fluxes%heat_added, isd, ied, jsd, jed) - call safe_alloc_ptr(CS%S_Restore, isd, ied, jsd, jed) - endif - else ! CS%use_temperature false. - call safe_alloc_ptr(fluxes%buoy, isd, ied, jsd, jed) - - if (CS%restorebuoy) call safe_alloc_ptr(CS%Dens_Restore, isd, ied, jsd, jed) - endif ! endif for CS%use_temperature - endif - endif - - ! calls to various wind options - if (CS%variable_winds .or. CS%first_call_set_forcing) then - if (trim(CS%wind_config) == "file") then - call wind_forcing_from_file(sfc_state, forces, day_center, G, CS) - elseif (trim(CS%wind_config) == "2gyre") then - call wind_forcing_2gyre(sfc_state, forces, day_center, G, CS) - elseif (trim(CS%wind_config) == "1gyre") then - call wind_forcing_1gyre(sfc_state, forces, day_center, G, CS) - elseif (trim(CS%wind_config) == "gyres") then - call wind_forcing_gyres(sfc_state, forces, day_center, G, CS) - elseif (trim(CS%wind_config) == "zero") then - call wind_forcing_zero(sfc_state, forces, day_center, G, CS) - elseif (trim(CS%wind_config) == "MESO") then - call MOM_error(FATAL, "MESO forcing is not available with the ice-shelf"//& - "version of MOM_surface_forcing.") -! call MESO_wind_forcing(sfc_state, forces, day_center, G, CS%MESO_forcing_CSp) - elseif (trim(CS%wind_config) == "USER") then - call USER_wind_forcing(sfc_state, forces, day_center, G, CS%user_forcing_CSp) - elseif (CS%variable_winds .and. .not.CS%first_call_set_forcing) then - call MOM_error(FATAL, & - "MOM_surface_forcing: Variable winds defined with no wind config") - else - call MOM_error(FATAL, & - "MOM_surface_forcing:Unrecognized wind config "//trim(CS%wind_config)) - endif - endif - if ((CS%variable_buoyforce .or. CS%first_call_set_forcing) .and. & - (.not.CS%adiabatic)) then - if (trim(CS%buoy_config) == "file") then - call buoyancy_forcing_from_files(sfc_state, fluxes, day_center, dt, G, US, CS) - elseif (trim(CS%buoy_config) == "zero") then - call buoyancy_forcing_zero(sfc_state, fluxes, day_center, dt, G, CS) - elseif (trim(CS%buoy_config) == "linear") then - call buoyancy_forcing_linear(sfc_state, fluxes, day_center, dt, G, US, CS) - elseif (trim(CS%buoy_config) == "MESO") then - call MOM_error(FATAL, "MESO forcing is not available with the ice-shelf"//& - "version of MOM_surface_forcing.") -! call MESO_buoyancy_forcing(sfc_state, fluxes, day_center, dt, G, CS%MESO_forcing_CSp) - elseif (trim(CS%buoy_config) == "USER") then - call USER_buoyancy_forcing(sfc_state, fluxes, day_center, dt, G, CS%user_forcing_CSp) - elseif (trim(CS%buoy_config) == "NONE") then - call MOM_mesg("MOM_surface_forcing: buoyancy forcing has been set to omitted.") - elseif (CS%variable_buoyforce .and. .not.CS%first_call_set_forcing) then - call MOM_error(FATAL, & - "MOM_surface_forcing: Variable buoy defined with no buoy config.") - else - call MOM_error(FATAL, & - "MOM_surface_forcing: Unrecognized buoy config "//trim(CS%buoy_config)) - endif - endif - - if (associated(CS%tracer_flow_CSp)) then - call call_tracer_set_forcing(sfc_state, fluxes, day_start, day_interval, G, CS%tracer_flow_CSp) - endif - - ! Allow for user-written code to alter the fluxes after all the above - call user_alter_forcing(sfc_state, fluxes, day_center, G, CS%urf_CS) - - ! Fields that exist in both the forcing and mech_forcing types must be copied. - if (CS%variable_winds .or. CS%first_call_set_forcing) then - call copy_common_forcing_fields(forces, fluxes, G) - call set_derived_forcing_fields(forces, fluxes, G, US, CS%Rho0) - endif - - if ((CS%variable_buoyforce .or. CS%first_call_set_forcing) .and. & - (.not.CS%adiabatic)) then - call set_net_mass_forcing(fluxes, forces, G, US) - endif - - CS%first_call_set_forcing = .false. - - call cpu_clock_end(id_clock_forcing) -end subroutine set_forcing - -!> This subroutine allocates arrays for buoyancy forcing. -subroutine buoyancy_forcing_allocate(fluxes, G, CS) - type(forcing), intent(inout) :: fluxes !< A structure with pointers to thermodynamic - !! forcing fields that will be allocated here - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned by a - !! previous surface_forcing_init call - - integer :: isd, ied, jsd, jed - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - - if ( CS%use_temperature ) then - call allocate_forcing_type(G, fluxes, water=.true., heat=.true., & - ustar=.true., press=.true.) - - ! surface restoring fields - if (CS%restorebuoy) then - call safe_alloc_ptr(CS%T_Restore,isd,ied,jsd,jed) - call safe_alloc_ptr(fluxes%heat_added,isd,ied,jsd,jed) - call safe_alloc_ptr(CS%S_Restore,isd,ied,jsd,jed) - endif - - else ! CS%use_temperature false. - call safe_alloc_ptr(fluxes%buoy,isd,ied,jsd,jed) - - call allocate_forcing_type(G, fluxes, water=.true., heat=.true., & - ustar=.true., press=.true.) - - if (CS%restorebuoy) call safe_alloc_ptr(CS%Dens_Restore,isd,ied,jsd,jed) - - endif ! endif for CS%use_temperature - -end subroutine buoyancy_forcing_allocate - - -! This subroutine sets the surface wind stresses to zero -subroutine wind_forcing_zero(sfc_state, forces, day, G, US, CS) - type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. - type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(time_type), intent(in) :: day !< Time used for determining the fluxes. - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned by a - !! previous surface_forcing_init call - - real :: PI - integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB - - call callTree_enter("wind_forcing_zero, MOM_surface_forcing.F90") - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - - !set steady surface wind stresses, in units of Pa. - PI = 4.0*atan(1.0) - - do j=js,je ; do I=Isq,Ieq - forces%taux(I,j) = 0.0 - enddo ; enddo - - do J=Jsq,Jeq ; do i=is,ie - forces%tauy(i,J) = 0.0 - enddo ; enddo - - if (CS%read_gust_2d) then - if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie - forces%ustar(i,j) = sqrt(US%L_to_Z*CS%gust(i,j)/CS%Rho0) - enddo ; enddo ; endif - else - if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie - forces%ustar(i,j) = sqrt(US%L_to_Z*CS%gust_const/CS%Rho0) - enddo ; enddo ; endif - endif - - call callTree_leave("wind_forcing_zero") -end subroutine wind_forcing_zero - - -!> This subroutine sets the surface wind stresses according to double gyre. -subroutine wind_forcing_2gyre(sfc_state, forces, day, G, CS) - type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. - type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(time_type), intent(in) :: day !< Time used for determining the fluxes. - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned by a - !! previous surface_forcing_init call - - ! Local variables - real :: PI - integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB - - call callTree_enter("wind_forcing_2gyre, MOM_surface_forcing.F90") - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - - !set the steady surface wind stresses, in units of Pa. - PI = 4.0*atan(1.0) - - do j=js,je ; do I=Isq,Ieq - forces%taux(I,j) = 0.1*US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * & - (1.0 - cos(2.0*PI*(G%geoLatCu(I,j)-CS%South_lat) / CS%len_lat)) - enddo ; enddo - - do J=Jsq,Jeq ; do i=is,ie - forces%tauy(i,J) = 0.0 - enddo ; enddo - - call callTree_leave("wind_forcing_2gyre") -end subroutine wind_forcing_2gyre - - -!> This subroutine sets the surface wind stresses according to single gyre. -subroutine wind_forcing_1gyre(sfc_state, forces, day, G, CS) - type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. - type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(time_type), intent(in) :: day !< Time used for determining the fluxes. - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned by a - !! previous surface_forcing_init call - - ! Local variables - real :: PI - integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB - - call callTree_enter("wind_forcing_1gyre, MOM_surface_forcing.F90") - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - - ! set the steady surface wind stresses, in units of Pa. - PI = 4.0*atan(1.0) - - do j=js,je ; do I=Isq,Ieq - forces%taux(I,j) = -0.2*US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * & - cos(PI*(G%geoLatCu(I,j)-CS%South_lat)/CS%len_lat) - enddo ; enddo - - do J=Jsq,Jeq ; do i=is,ie - forces%tauy(i,J) = 0.0 - enddo ; enddo - - call callTree_leave("wind_forcing_1gyre") -end subroutine wind_forcing_1gyre - - -!> This subroutine sets the surface wind stresses according to gyres. -subroutine wind_forcing_gyres(sfc_state, forces, day, G, US, CS) - type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. - type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(time_type), intent(in) :: day !< Time used for determining the fluxes. - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned by a - !! previous surface_forcing_init call - - ! Local variables - real :: PI, y - integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB - - call callTree_enter("wind_forcing_gyres, MOM_surface_forcing.F90") - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - - ! steady surface wind stresses [Pa] - PI = 4.0*atan(1.0) - - do j=jsd,jed ; do I=IsdB,IedB - y = (G%geoLatCu(I,j)-CS%South_lat)/CS%len_lat - forces%taux(I,j) = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * (CS%gyres_taux_const + & - ( CS%gyres_taux_sin_amp*sin(CS%gyres_taux_n_pis*PI*y) & - + CS%gyres_taux_cos_amp*cos(CS%gyres_taux_n_pis*PI*y) )) - enddo ; enddo - - do J=JsdB,JedB ; do i=isd,ied - forces%tauy(i,J) = 0.0 - enddo ; enddo - - ! set the friction velocity - do j=js,je ; do i=is,ie - forces%ustar(i,j) = sqrt(US%L_to_S * (CS%gust_const/CS%Rho0 + & - sqrt(0.5*(forces%tauy(i,j-1)*forces%tauy(i,j-1) + forces%tauy(i,j)*forces%tauy(i,j) + & - forces%taux(i-1,j)*forces%taux(i-1,j) + forces%taux(i,j)*forces%taux(i,j)))/CS%Rho0) ) - enddo ; enddo - - call callTree_leave("wind_forcing_gyres") -end subroutine wind_forcing_gyres - -!> This subroutine sets the surface wind stresses by reading a file. -subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) - type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. - type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(time_type), intent(in) :: day !< Time used for determining the fluxes. - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned by a - !! previous surface_forcing_init call - - ! Local variables - integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB - integer :: time_lev ! With fields from a file, this must - ! be reset, depending on the time. - character(len=200) :: filename ! The name of the input file. - real :: temp_x(SZI_(G),SZJ_(G)) ! Pseudo-zonal and psuedo-meridional - real :: temp_y(SZI_(G),SZJ_(G)) ! wind stresses at h-points [Pa]. - real :: Pa_conversion ! A unit conversion factor from Pa to the internal wind stress - ! units [R Z L T-2 Pa-1 ~> 1] - integer :: days, seconds - - call callTree_enter("wind_forcing_from_file, MOM_surface_forcing.F90") - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - Pa_conversion = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z - - call get_time(day,seconds,days) - time_lev = days - 365*floor(real(days) / 365.0) +1 - - if (time_lev /= CS%wind_last_lev_read) then - filename = trim(CS%inputdir) // trim(CS%wind_file) -! if (is_root_pe()) & -! write(*,'("Wind_forcing Reading time level ",I," last was ",I,".")')& -! time_lev-1,CS%wind_last_lev_read-1 - select case ( uppercase(CS%wind_stagger(1:1)) ) - case ("A") - temp_x(:,:) = 0.0 ; temp_y(:,:) = 0.0 - call MOM_read_vector(filename, CS%stress_x_var, CS%stress_y_var, & - temp_x(:,:), temp_y(:,:), G%Domain, stagger=AGRID, & - timelevel=time_lev, scale=Pa_conversion) - - call pass_vector(temp_x, temp_y, G%Domain, To_All, AGRID) - do j=js,je ; do I=Isq,Ieq - forces%taux(I,j) = 0.5 * CS%wind_scale * (temp_x(i,j) + temp_x(i+1,j)) - enddo ; enddo - do J=Jsq,Jeq ; do i=is,ie - forces%tauy(i,J) = 0.5 * CS%wind_scale * (temp_y(i,j) + temp_y(i,j+1)) - enddo ; enddo - - if (CS%read_gust_2d) then - do j=js,je ; do i=is,ie - forces%ustar(i,j) = sqrt(US%L_to_Z * (CS%gust(i,j) + & - sqrt(temp_x(i,j)*temp_x(i,j) + temp_y(i,j)*temp_y(i,j)) ) / CS%Rho0) - enddo ; enddo - else - do j=js,je ; do i=is,ie - forces%ustar(i,j) = sqrt(US%L_to_Z * (CS%gust_const/CS%Rho0 + & - sqrt(temp_x(i,j)*temp_x(i,j) + temp_y(i,j)*temp_y(i,j)) / CS%Rho0) ) - enddo ; enddo - endif - case ("C") - call MOM_read_vector(filename,CS%stress_x_var, CS%stress_y_var, & - forces%taux(:,:), forces%tauy(:,:), & - G%Domain, timelevel=time_lev, & - scale=Pa_conversion) - if (CS%wind_scale /= 1.0) then - do j=js,je ; do I=Isq,Ieq - forces%taux(I,j) = CS%wind_scale * forces%taux(I,j) - enddo ; enddo - do J=Jsq,Jeq ; do i=is,ie - forces%tauy(i,J) = CS%wind_scale * forces%tauy(i,J) - enddo ; enddo - endif - - call pass_vector(forces%taux, forces%tauy, G%Domain, To_All) - if (CS%read_gust_2d) then - do j=js, je ; do i=is, ie - forces%ustar(i,j) = sqrt( (CS%gust(i,j) + & - sqrt(0.5*((forces%tauy(i,j-1)**2 + forces%tauy(i,j)**2) + & - (forces%taux(i-1,j)**2 + forces%taux(i,j)**2)))) * US%L_to_Z / CS%Rho0 ) - enddo ; enddo - else - do j=js, je ; do i=is, ie - forces%ustar(i,j) = sqrt(US%L_to_Z * (CS%gust_const/CS%Rho0 + & - sqrt(0.5*((forces%tauy(i,j-1)**2 + forces%tauy(i,j)**2) + & - (forces%taux(i-1,j)**2 + forces%taux(i,j)**2))) / CS%Rho0) ) - enddo ; enddo - endif - case default - call MOM_error(FATAL, "wind_forcing_from_file: Unrecognized stagger "//& - trim(CS%wind_stagger)//" is not 'A' or 'C'.") - end select - CS%wind_last_lev_read = time_lev - endif ! time_lev /= CS%wind_last_lev_read - - call callTree_leave("wind_forcing_from_file") -end subroutine wind_forcing_from_file - - -!> This subroutine specifies the current surface fluxes of buoyancy, temperature and fresh water -!! by reading a file. It may also be modified to add surface fluxes of user provided tracers. -subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) - type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. - type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields - type(time_type), intent(in) :: day !< Time used for determining the fluxes. - real, intent(in) :: dt !< The amount of time over which - !! the fluxes apply [s] - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned by a - !! previous surface_forcing_init call - - real :: rhoXcp ! mean density times the heat capacity [Q R degC-1 ~> J m-3 degC-1]. - real :: Irho0 ! inverse Boussinesq reference density [m3 kg-1]. - integer :: i, j, is, ie, js, je, isd, ied, jsd, jed - - integer :: time_lev ! With fields from a file, this must - ! be reset, depending on the time. - integer :: time_lev_monthly ! With fields from a file, this must - ! be reset, depending on the time. - integer :: days, seconds - real, dimension(SZI_(G),SZJ_(G)) :: & - temp, & ! A 2-d temporary work array with various units. - SST_anom, & ! Instantaneous sea surface temperature anomalies from a - ! target (observed) value [degC]. - SSS_anom, & ! Instantaneous sea surface salinity anomalies from a target - ! (observed) value [ppt]. - SSS_mean ! A (mean?) salinity about which to normalize local salinity - ! anomalies when calculating restorative precipitation - ! anomalies [ppt]. - - call callTree_enter("buoyancy_forcing_from_files, MOM_surface_forcing.F90") - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - - ! allocate and initialize arrays - call buoyancy_forcing_allocate(fluxes, G, CS) - - if (CS%use_temperature) rhoXcp = CS%Rho0 * fluxes%C_p - Irho0 = 1.0/(US%R_to_kg_m3*CS%Rho0) - - ! Read the file containing the buoyancy forcing. - call get_time(day,seconds,days) - - time_lev = days - 365*floor(real(days) / 365.0) - - if (time_lev < 31) then ; time_lev_monthly = 0 - else if (time_lev < 59) then ; time_lev_monthly = 1 - else if (time_lev < 90) then ; time_lev_monthly = 2 - else if (time_lev < 120) then ; time_lev_monthly = 3 - else if (time_lev < 151) then ; time_lev_monthly = 4 - else if (time_lev < 181) then ; time_lev_monthly = 5 - else if (time_lev < 212) then ; time_lev_monthly = 6 - else if (time_lev < 243) then ; time_lev_monthly = 7 - else if (time_lev < 273) then ; time_lev_monthly = 8 - else if (time_lev < 304) then ; time_lev_monthly = 9 - else if (time_lev < 334) then ; time_lev_monthly = 10 - else ; time_lev_monthly = 11 - endif - - time_lev = time_lev+1 - time_lev_monthly = time_lev_monthly+1 - - if (time_lev /= CS%buoy_last_lev_read) then - -! if (is_root_pe()) & -! write(*,'("buoyancy_forcing : Reading time level ",I3,", last was ",I3,".")')& -! time_lev,CS%buoy_last_lev_read - - - call MOM_read_data(trim(CS%inputdir)//trim(CS%longwavedown_file), "lwdn_sfc", & - fluxes%LW(:,:), G%Domain, timelevel=time_lev, scale=US%W_m2_to_QRZ_T) - call MOM_read_data(trim(CS%inputdir)//trim(CS%longwaveup_file), "lwup_sfc", & - temp(:,:), G%Domain, timelevel=time_lev, scale=US%W_m2_to_QRZ_T) - do j=js,je ; do i=is,ie ; fluxes%LW(i,j) = fluxes%LW(i,j) - temp(i,j) ; enddo ; enddo - - call MOM_read_data(trim(CS%inputdir)//trim(CS%evaporation_file), "evap", & - fluxes%evap(:,:), G%Domain, timelevel=time_lev, scale=-US%kg_m2s_to_RZ_T) - do j=js,je ; do i=is,ie - fluxes%latent(i,j) = CS%latent_heat_vapor*fluxes%evap(i,j) - fluxes%latent_evap_diag(i,j) = fluxes%latent(i,j) - enddo ; enddo - - call MOM_read_data(trim(CS%inputdir)//trim(CS%sensibleheat_file), "shflx", & - fluxes%sens(:,:), G%Domain, timelevel=time_lev, scale=-US%W_m2_to_QRZ_T) - - call MOM_read_data(trim(CS%inputdir)//trim(CS%shortwavedown_file), "swdn_sfc", & - fluxes%sw(:,:), G%Domain, timelevel=time_lev, scale=US%W_m2_to_QRZ_T) - call MOM_read_data(trim(CS%inputdir)//trim(CS%shortwaveup_file), "swup_sfc", & - temp(:,:), G%Domain, timelevel=time_lev, scale=US%W_m2_to_QRZ_T) - do j=js,je ; do i=is,ie - fluxes%sw(i,j) = fluxes%sw(i,j) - temp(i,j) - enddo ; enddo - - call MOM_read_data(trim(CS%inputdir)//trim(CS%snow_file), "snow", & - fluxes%fprec(:,:), G%Domain, timelevel=time_lev, scale=US%kg_m2s_to_RZ_T) - call MOM_read_data(trim(CS%inputdir)//trim(CS%precip_file), "precip", & - fluxes%lprec(:,:), G%Domain, timelevel=time_lev, scale=US%kg_m2s_to_RZ_T) - do j=js,je ; do i=is,ie - fluxes%lprec(i,j) = fluxes%lprec(i,j) - fluxes%fprec(i,j) - enddo ; enddo - - call MOM_read_data(trim(CS%inputdir)//trim(CS%freshdischarge_file), "disch_w", & - temp(:,:), G%Domain, timelevel=time_lev_monthly, scale=US%kg_m2s_to_RZ_T) - do j=js,je ; do i=is,ie - fluxes%lrunoff(i,j) = temp(i,j)*US%m_to_L**2*G%IareaT(i,j) - enddo ; enddo - call MOM_read_data(trim(CS%inputdir)//trim(CS%freshdischarge_file), "disch_s", & - temp(:,:), G%Domain, timelevel=time_lev_monthly, scale=US%kg_m2s_to_RZ_T) - do j=js,je ; do i=is,ie - fluxes%frunoff(i,j) = temp(i,j)*US%m_to_L**2*G%IareaT(i,j) - enddo ; enddo - -! Read the SST and SSS fields for damping. - if (CS%restorebuoy) then - call MOM_read_data(trim(CS%inputdir)//trim(CS%SSTrestore_file), "TEMP", & - CS%T_Restore(:,:), G%Domain, timelevel=time_lev_monthly) - call MOM_read_data(trim(CS%inputdir)//trim(CS%salinityrestore_file), "SALT", & - CS%S_Restore(:,:), G%Domain, timelevel=time_lev_monthly) - endif - CS%buoy_last_lev_read = time_lev - - ! mask out land points and compute heat content of water fluxes - ! assume liquid precip enters ocean at SST - ! assume frozen precip enters ocean at 0degC - ! assume liquid runoff enters ocean at SST - ! assume solid runoff (calving) enters ocean at 0degC - do j=js,je ; do i=is,ie - fluxes%evap(i,j) = fluxes%evap(i,j) * G%mask2dT(i,j) - fluxes%lprec(i,j) = fluxes%lprec(i,j) * G%mask2dT(i,j) - fluxes%fprec(i,j) = fluxes%fprec(i,j) * G%mask2dT(i,j) - fluxes%lrunoff(i,j) = fluxes%lrunoff(i,j) * G%mask2dT(i,j) - fluxes%frunoff(i,j) = fluxes%frunoff(i,j) * G%mask2dT(i,j) - fluxes%LW(i,j) = fluxes%LW(i,j) * G%mask2dT(i,j) - fluxes%sens(i,j) = fluxes%sens(i,j) * G%mask2dT(i,j) - fluxes%sw(i,j) = fluxes%sw(i,j) * G%mask2dT(i,j) - fluxes%latent(i,j) = fluxes%latent(i,j) * G%mask2dT(i,j) - - fluxes%heat_content_lrunoff(i,j) = fluxes%C_p * fluxes%lrunoff(i,j)*sfc_state%SST(i,j) - fluxes%latent_evap_diag(i,j) = fluxes%latent_evap_diag(i,j) * G%mask2dT(i,j) - fluxes%latent_fprec_diag(i,j) = -fluxes%fprec(i,j)*CS%latent_heat_fusion - fluxes%latent_frunoff_diag(i,j) = -fluxes%frunoff(i,j)*CS%latent_heat_fusion - enddo ; enddo - - endif ! time_lev /= CS%buoy_last_lev_read - - if (CS%restorebuoy) then - if (CS%use_temperature) then - do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) > 0) then - fluxes%heat_added(i,j) = G%mask2dT(i,j) * & - ((CS%T_Restore(i,j) - sfc_state%SST(i,j)) * rhoXcp * CS%Flux_const) - fluxes%vprec(i,j) = - (CS%Rho0*CS%Flux_const) * & - (CS%S_Restore(i,j) - sfc_state%SSS(i,j)) / & - (0.5*(sfc_state%SSS(i,j) + CS%S_Restore(i,j))) - else - fluxes%heat_added(i,j) = 0.0 - fluxes%vprec(i,j) = 0.0 - endif - enddo ; enddo - else - do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) > 0) then - fluxes%buoy(i,j) = (CS%Dens_Restore(i,j) - sfc_state%sfc_density(i,j)) * & - (CS%G_Earth * CS%Flux_const/(US%R_to_kg_m3*CS%Rho0)) - else - fluxes%buoy(i,j) = 0.0 - endif - enddo ; enddo - endif - else ! not RESTOREBUOY - if (.not.CS%use_temperature) then - call MOM_error(FATAL, "buoyancy_forcing in MOM_surface_forcing: "// & - "The fluxes need to be defined without RESTOREBUOY.") - endif - endif ! end RESTOREBUOY - - call callTree_leave("buoyancy_forcing_from_files") -end subroutine buoyancy_forcing_from_files - - -!> This subroutine specifies the current surface fluxes of buoyancy, temperature and fresh water. -!! It may also be modified to add surface fluxes of user provided tracers. -!! This case has zero surface buoyancy forcing. -subroutine buoyancy_forcing_zero(sfc_state, fluxes, day, dt, G, CS) - type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. - type(forcing), intent(inout) :: fluxes !< A structure with pointers to thermodynamic forcing fields - type(time_type), intent(in) :: day !< Time used for determining the fluxes. - real, intent(in) :: dt !< The amount of time over which - !! the fluxes apply [s] - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned by a - !! previous surface_forcing_init call - - integer :: i, j, is, ie, js, je - - call callTree_enter("buoyancy_forcing_zero, MOM_surface_forcing.F90") - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - - ! allocate and initialize arrays - call buoyancy_forcing_allocate(fluxes, G, CS) - - if (CS%use_temperature) then - do j=js,je ; do i=is,ie - fluxes%evap(i,j) = 0.0 - fluxes%lprec(i,j) = 0.0 - fluxes%fprec(i,j) = 0.0 - fluxes%lrunoff(i,j) = 0.0 - fluxes%frunoff(i,j) = 0.0 - fluxes%lw(i,j) = 0.0 - fluxes%latent(i,j) = 0.0 - fluxes%sens(i,j) = 0.0 - fluxes%sw(i,j) = 0.0 - fluxes%heat_content_lrunoff(i,j) = 0.0 - fluxes%latent_evap_diag(i,j) = 0.0 - fluxes%latent_fprec_diag(i,j) = 0.0 - fluxes%latent_frunoff_diag(i,j) = 0.0 - enddo ; enddo - else - do j=js,je ; do i=is,ie - fluxes%buoy(i,j) = 0.0 - enddo ; enddo - endif - - call callTree_leave("buoyancy_forcing_zero") -end subroutine buoyancy_forcing_zero - -!> This subroutine specifies the current surface fluxes of buoyancy, temperature and fresh water. -!! It may also be modified to add surface fluxes of user provided tracers. -subroutine buoyancy_forcing_linear(sfc_state, fluxes, day, dt, G, US, CS) - type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. - type(forcing), intent(inout) :: fluxes !< A structure with pointers to thermodynamic forcing fields - type(time_type), intent(in) :: day !< Time used for determining the fluxes. - real, intent(in) :: dt !< The amount of time over which - !! the fluxes apply, in s - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned by a - !! previous surface_forcing_init call - - ! Local variables - real :: y, T_restore, S_restore - integer :: i, j, is, ie, js, je - - call callTree_enter("buoyancy_forcing_linear, MOM_surface_forcing.F90") - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - - ! allocate and initialize arrays - call buoyancy_forcing_allocate(fluxes, G, CS) - - ! This case has no surface buoyancy forcing. - if (CS%use_temperature) then - do j=js,je ; do i=is,ie - fluxes%evap(i,j) = 0.0 - fluxes%lprec(i,j) = 0.0 - fluxes%fprec(i,j) = 0.0 - fluxes%lrunoff(i,j) = 0.0 - fluxes%frunoff(i,j) = 0.0 - fluxes%lw(i,j) = 0.0 - fluxes%latent(i,j) = 0.0 - fluxes%sens(i,j) = 0.0 - fluxes%sw(i,j) = 0.0 - fluxes%heat_content_lrunoff(i,j) = 0.0 - fluxes%latent_evap_diag(i,j) = 0.0 - fluxes%latent_fprec_diag(i,j) = 0.0 - fluxes%latent_frunoff_diag(i,j) = 0.0 - enddo ; enddo - else - do j=js,je ; do i=is,ie - fluxes%buoy(i,j) = 0.0 - enddo ; enddo - endif - - if (CS%restorebuoy) then - if (CS%use_temperature) then - do j=js,je ; do i=is,ie - y = (G%geoLatCu(I,j)-CS%South_lat)/CS%len_lat - T_restore = CS%T_south + (CS%T_north-CS%T_south)*y - S_restore = CS%S_south + (CS%S_north-CS%S_south)*y - if (G%mask2dT(i,j) > 0) then - fluxes%heat_added(i,j) = G%mask2dT(i,j) * & - ((T_Restore - sfc_state%SST(i,j)) * ((CS%Rho0 * fluxes%C_p) * CS%Flux_const)) - fluxes%vprec(i,j) = - (CS%Rho0*CS%Flux_const) * & - (S_Restore - sfc_state%SSS(i,j)) / & - (0.5*(sfc_state%SSS(i,j) + S_Restore)) - else - fluxes%heat_added(i,j) = 0.0 - fluxes%vprec(i,j) = 0.0 - endif - enddo ; enddo - else - call MOM_error(FATAL, "buoyancy_forcing_linear in MOM_surface_forcing: "// & - "RESTOREBUOY to linear not written yet.") - !do j=js,je ; do i=is,ie - ! if (G%mask2dT(i,j) > 0) then - ! fluxes%buoy(i,j) = US%kg_m3_to_R*(CS%Dens_Restore(i,j) - sfc_state%sfc_density(i,j)) * & - ! (CS%G_Earth * CS%Flux_const / CS%Rho0) - ! else - ! fluxes%buoy(i,j) = 0.0 - ! endif - !enddo ; enddo - endif - else ! not RESTOREBUOY - if (.not.CS%use_temperature) then - call MOM_error(FATAL, "buoyancy_forcing_linear in MOM_surface_forcing: "// & - "The fluxes need to be defined without RESTOREBUOY.") - endif - endif ! end RESTOREBUOY - - call callTree_leave("buoyancy_forcing_linear") -end subroutine buoyancy_forcing_linear - -!> Save any restart files associated with the surface forcing. -subroutine forcing_save_restart(CS, G, Time, directory, time_stamped, & - filename_suffix) - type(surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned - !! by a previous call to surface_forcing_init - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(time_type), intent(in) :: Time !< The current model time - character(len=*), intent(in) :: directory !< The directory into which to write the - !! restart files - logical, optional, intent(in) :: time_stamped !< If true, the restart file names include - !! a unique time stamp. The default is false. - character(len=*), optional, intent(in) :: filename_suffix !< An optional suffix (e.g., a time- - !! stamp) to append to the restart file names. - - if (.not.associated(CS)) return - if (.not.associated(CS%restart_CSp)) return - - call save_restart(directory, Time, 1, G, CS%restart_CSp, time_stamped) - -end subroutine forcing_save_restart - -!> Initialize the surface forcing, including setting parameters and allocating permanent memory. -subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_CSp) - type(time_type), intent(in) :: Time !< The current model time - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate diagnostic output. - type(surface_forcing_CS), pointer :: CS !< A pointer that is set to point to the control structure - !! for this module - type(tracer_flow_control_CS), pointer :: tracer_flow_CSp !< A pointer to the control structure of - !! the tracer flow control module. - - ! Local variables - type(directories) :: dirs - logical :: new_sim - type(time_type) :: Time_frc -! This include declares and sets the variable "version". -#include "version_variable.h" - character(len=40) :: mdl = "MOM_surface_forcing" ! This module's name. - character(len=60) :: axis_units - character(len=200) :: filename, gust_file ! The name of the gustiness input file. - - if (associated(CS)) then - call MOM_error(WARNING, "surface_forcing_init called with an associated "// & - "control structure.") - return - endif - allocate(CS) - - id_clock_forcing=cpu_clock_id('(Ocean surface forcing)', grain=CLOCK_MODULE) - call cpu_clock_begin(id_clock_forcing) - - CS%diag => diag - if (associated(tracer_flow_CSp)) CS%tracer_flow_CSp => tracer_flow_CSp - - ! Read all relevant parameters and write them to the model log. - call log_version(param_file, mdl, version, "") - call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", CS%use_temperature, & - "If true, Temperature and salinity are used as state "//& - "variables.", default=.true.) - call get_param(param_file, mdl, "INPUTDIR", CS%inputdir, & - "The directory in which all input files are found.", & - default=".") - CS%inputdir = slasher(CS%inputdir) - - call get_param(param_file, mdl, "ADIABATIC", CS%adiabatic, & - "There are no diapycnal mass fluxes if ADIABATIC is "//& - "true. This assumes that KD = KDML = 0.0 and that "//& - "there is no buoyancy forcing, but makes the model "//& - "faster by eliminating subroutine calls.", default=.false.) - call get_param(param_file, mdl, "VARIABLE_WINDS", CS%variable_winds, & - "If true, the winds vary in time after the initialization.", & - default=.true.) - call get_param(param_file, mdl, "VARIABLE_BUOYFORCE", CS%variable_buoyforce, & - "If true, the buoyancy forcing varies in time after the "//& - "initialization of the model.", default=.true.) - - call get_param(param_file, mdl, "BUOY_CONFIG", CS%buoy_config, & - "The character string that indicates how buoyancy forcing "//& - "is specified. Valid options include (file), (zero), "//& - "(linear), (USER), and (NONE).", fail_if_missing=.true.) - if (trim(CS%buoy_config) == "file") then - call get_param(param_file, mdl, "LONGWAVEDOWN_FILE", CS%longwavedown_file, & - "The file with the downward longwave heat flux, in "//& - "variable lwdn_sfc.", fail_if_missing=.true.) - call get_param(param_file, mdl, "LONGWAVEUP_FILE", CS%longwaveup_file, & - "The file with the upward longwave heat flux, in "//& - "variable lwup_sfc.", fail_if_missing=.true.) - call get_param(param_file, mdl, "EVAPORATION_FILE", CS%evaporation_file, & - "The file with the evaporative moisture flux, in "//& - "variable evap.", fail_if_missing=.true.) - call get_param(param_file, mdl, "SENSIBLEHEAT_FILE", CS%sensibleheat_file, & - "The file with the sensible heat flux, in "//& - "variable shflx.", fail_if_missing=.true.) - call get_param(param_file, mdl, "SHORTWAVEUP_FILE", CS%shortwaveup_file, & - "The file with the upward shortwave heat flux.", & - fail_if_missing=.true.) - call get_param(param_file, mdl, "SHORTWAVEDOWN_FILE", CS%shortwavedown_file, & - "The file with the downward shortwave heat flux.", & - fail_if_missing=.true.) - call get_param(param_file, mdl, "SNOW_FILE", CS%snow_file, & - "The file with the downward frozen precip flux, in "//& - "variable snow.", fail_if_missing=.true.) - call get_param(param_file, mdl, "PRECIP_FILE", CS%precip_file, & - "The file with the downward total precip flux, in "//& - "variable precip.", fail_if_missing=.true.) - call get_param(param_file, mdl, "FRESHDISCHARGE_FILE", CS%freshdischarge_file, & - "The file with the fresh and frozen runoff/calving fluxes, "//& - "invariables disch_w and disch_s.", fail_if_missing=.true.) - call get_param(param_file, mdl, "SSTRESTORE_FILE", CS%SSTrestore_file, & - "The file with the SST toward which to restore in "//& - "variable TEMP.", fail_if_missing=.true.) - call get_param(param_file, mdl, "SALINITYRESTORE_FILE", CS%salinityrestore_file, & - "The file with the surface salinity toward which to "//& - "restore in variable SALT.", fail_if_missing=.true.) - endif - call get_param(param_file, mdl, "WIND_CONFIG", CS%wind_config, & - "The character string that indicates how wind forcing "//& - "is specified. Valid options include (file), (2gyre), "//& - "(1gyre), (gyres), (zero), and (USER).", fail_if_missing=.true.) - if (trim(CS%wind_config) == "file") then - call get_param(param_file, mdl, "WIND_FILE", CS%wind_file, & - "The file in which the wind stresses are found in "//& - "variables STRESS_X and STRESS_Y.", fail_if_missing=.true.) - call get_param(param_file, mdl, "WINDSTRESS_X_VAR",CS%stress_x_var, & - "The name of the x-wind stress variable in WIND_FILE.", & - default="STRESS_X") - call get_param(param_file, mdl, "WINDSTRESS_Y_VAR", CS%stress_y_var, & - "The name of the y-wind stress variable in WIND_FILE.", & - default="STRESS_Y") - call get_param(param_file, mdl, "WINDSTRESS_STAGGER",CS%wind_stagger, & - "A character indicating how the wind stress components "//& - "are staggered in WIND_FILE. This may be A or C for now.", & - default="A") - call get_param(param_file, mdl, "WINDSTRESS_SCALE", CS%wind_scale, & - "A value by which the wind stresses in WIND_FILE are rescaled.", & - default=1.0, units="nondim") - endif - if (trim(CS%wind_config) == "gyres") then - call get_param(param_file, mdl, "TAUX_CONST", CS%gyres_taux_const, & - "With the gyres wind_config, the constant offset in the "//& - "zonal wind stress profile: "//& - " A in taux = A + B*sin(n*pi*y/L) + C*cos(n*pi*y/L).", & - units="Pa", default=0.0) - call get_param(param_file, mdl, "TAUX_SIN_AMP",CS%gyres_taux_sin_amp, & - "With the gyres wind_config, the sine amplitude in the "//& - "zonal wind stress profile: "//& - " B in taux = A + B*sin(n*pi*y/L) + C*cos(n*pi*y/L).", & - units="Pa", default=0.0) - call get_param(param_file, mdl, "TAUX_COS_AMP",CS%gyres_taux_cos_amp, & - "With the gyres wind_config, the cosine amplitude in "//& - "the zonal wind stress profile: "//& - " C in taux = A + B*sin(n*pi*y/L) + C*cos(n*pi*y/L).", & - units="Pa", default=0.0) - call get_param(param_file, mdl, "TAUX_N_PIS",CS%gyres_taux_n_pis, & - "With the gyres wind_config, the number of gyres in "//& - "the zonal wind stress profile: "//& - " n in taux = A + B*sin(n*pi*y/L) + C*cos(n*pi*y/L).", & - units="nondim", default=0.0) - endif - call get_param(param_file, mdl, "SOUTHLAT", CS%south_lat, & - "The southern latitude of the domain or the equivalent "//& - "starting value for the y-axis.", units=axis_units, default=0.) - call get_param(param_file, mdl, "LENLAT", CS%len_lat, & - "The latitudinal or y-direction length of the domain.", & - units=axis_units, fail_if_missing=.true.) - call get_param(param_file, mdl, "RHO_0", CS%Rho0, & - "The mean ocean density used with BOUSSINESQ true to "//& - "calculate accelerations and the mass for conservation "//& - "properties, or with BOUSSINSEQ false to convert some "//& - "parameters from vertical units of m to kg m-2.", & - units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) - call get_param(param_file, mdl, "RESTOREBUOY", CS%restorebuoy, & - "If true, the buoyancy fluxes drive the model back "//& - "toward some specified surface state with a rate "//& - "given by FLUXCONST.", default= .false.) - call get_param(param_file, mdl, "LATENT_HEAT_FUSION", CS%latent_heat_fusion, & - "The latent heat of fusion.", default=hlf, & - units="J/kg", scale=US%J_kg_to_Q) - call get_param(param_file, mdl, "LATENT_HEAT_VAPORIZATION", CS%latent_heat_vapor, & - "The latent heat of fusion.", default=hlv, units="J/kg", scale=US%J_kg_to_Q) - if (CS%restorebuoy) then - call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & - "The constant that relates the restoring surface fluxes "//& - "to the relative surface anomalies (akin to a piston "//& - "velocity). Note the non-MKS units.", & - units="m day-1", scale=US%m_to_Z*US%T_to_s/86400.0, fail_if_missing=.true.) - if (trim(CS%buoy_config) == "linear") then - call get_param(param_file, mdl, "SST_NORTH", CS%T_north, & - "With buoy_config linear, the sea surface temperature "//& - "at the northern end of the domain toward which to "//& - "to restore.", units="deg C", default=0.0) - call get_param(param_file, mdl, "SST_SOUTH", CS%T_south, & - "With buoy_config linear, the sea surface temperature "//& - "at the southern end of the domain toward which to "//& - "to restore.", units="deg C", default=0.0) - call get_param(param_file, mdl, "SSS_NORTH", CS%S_north, & - "With buoy_config linear, the sea surface salinity "//& - "at the northern end of the domain toward which to "//& - "to restore.", units="PSU", default=35.0) - call get_param(param_file, mdl, "SSS_SOUTH", CS%S_south, & - "With buoy_config linear, the sea surface salinity "//& - "at the southern end of the domain toward which to "//& - "to restore.", units="PSU", default=35.0) - endif - endif - call get_param(param_file, mdl, "G_EARTH", CS%G_Earth, & - "The gravitational acceleration of the Earth.", & - units="m s-2", default = 9.80, scale=US%m_to_L**2*US%Z_to_m*US%T_to_s**2) - - call get_param(param_file, mdl, "GUST_CONST", CS%gust_const, & - "The background gustiness in the winds.", & - units="Pa", default=0.02, scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) - call get_param(param_file, mdl, "READ_GUST_2D", CS%read_gust_2d, & - "If true, use a 2-dimensional gustiness supplied from "//& - "an input file", default=.false.) - if (CS%read_gust_2d) then - call get_param(param_file, mdl, "GUST_2D_FILE", gust_file, & - "The file in which the wind gustiness is found in "//& - "variable gustiness.", fail_if_missing=.true.) - call safe_alloc_ptr(CS%gust,G%isd,G%ied,G%jsd,G%jed) ; CS%gust(:,:) = 0.0 - filename = trim(CS%inputdir) // trim(gust_file) - call MOM_read_data(filename,'gustiness',CS%gust,G%domain, timelevel=1, & - scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) ! units in file should be Pa - endif - call get_param(param_file, mdl, "AXIS_UNITS", axis_units, default="degrees") - -! All parameter settings are now known. - - if (trim(CS%wind_config) == "USER" .or. trim(CS%buoy_config) == "USER" ) then - call USER_surface_forcing_init(Time, G, param_file, diag, CS%user_forcing_CSp) - elseif (trim(CS%wind_config) == "MESO" .or. trim(CS%buoy_config) == "MESO" ) then - call MOM_error(FATAL, "MESO forcing is not available with the ice-shelf"//& - "version of MOM_surface_forcing.") - endif - - call register_forcing_type_diags(Time, diag, US, CS%use_temperature, CS%handles) - - ! Set up any restart fields associated with the forcing. - call restart_init(G, param_file, CS%restart_CSp, "MOM_forcing.res") - call restart_init_end(CS%restart_CSp) - - if (associated(CS%restart_CSp)) then - call Get_MOM_Input(dirs=dirs) - - new_sim = .false. - if ((dirs%input_filename(1:1) == 'n') .and. & - (LEN_TRIM(dirs%input_filename) == 1)) new_sim = .true. - if (.not.new_sim) then - call restore_state(dirs%input_filename, dirs%restart_input_dir, Time_frc, & - G, CS%restart_CSp) - endif - endif - - call user_revise_forcing_init(param_file, CS%urf_CS) - - call cpu_clock_end(id_clock_forcing) -end subroutine surface_forcing_init - -!> Clean up and deallocate any memory associated with this module and its children. -subroutine surface_forcing_end(CS, fluxes) - type(surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned - !! by a previous surface_forcing_init call - !! that will be deallocated here. - type(forcing), optional, intent(inout) :: fluxes !< A structure containing pointers to any possible - !! forcing fields that will be deallocated here. - - if (present(fluxes)) call deallocate_forcing_type(fluxes) - - if (associated(CS)) deallocate(CS) - CS => NULL() - -end subroutine surface_forcing_end - -end module MOM_surface_forcing diff --git a/config_src/ice_solo_driver/ice_shelf_driver.F90 b/config_src/ice_solo_driver/ice_shelf_driver.F90 index f2c5099544..b1323a5485 100644 --- a/config_src/ice_solo_driver/ice_shelf_driver.F90 +++ b/config_src/ice_solo_driver/ice_shelf_driver.F90 @@ -1,4 +1,4 @@ -program SHELF_main +program Shelf_main ! This file is part of MOM6. See LICENSE.md for the license. @@ -21,92 +21,104 @@ program SHELF_main !* * !********+*********+*********+*********+*********+*********+*********+** - use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end - use MOM_cpu_clock, only : CLOCK_COMPONENT - use MOM_diag_mediator, only : enable_averaging, disable_averaging, diag_mediator_end - use MOM_diag_mediator, only : diag_mediator_close_registration, diag_mediator_end - use MOM_domains, only : MOM_infra_init, MOM_infra_end - use MOM_error_handler, only : MOM_error, MOM_mesg, WARNING, FATAL, is_root_pe - use MOM_file_parser, only : get_param, log_param, log_version, param_file_type - use MOM_file_parser, only : close_param_file -! use MOM_grid, only : ocean_grid_type - use MOM_get_input, only : Get_MOM_Input, directories - use MOM_io, only : file_exists, open_file, close_file - use MOM_io, only : check_nml_error, io_infra_init, io_infra_end - use MOM_io, only : APPEND_FILE, ASCII_FILE, READONLY_FILE, SINGLE_FILE - use MOM_restart, only : save_restart -! use MOM_sum_output, only : write_energy, accumulate_net_input -! use MOM_sum_output, only : MOM_sum_output_init, sum_output_CS - use MOM_string_functions, only : uppercase -! use MOM_surface_forcing, only : set_forcing, average_forcing -! use MOM_surface_forcing, only : surface_forcing_init, surface_forcing_CS - use MOM_time_manager, only : time_type, set_date, set_time, get_date, time_type_to_real - use MOM_time_manager, only : operator(+), operator(-), operator(*), operator(/) - use MOM_time_manager, only : operator(>), operator(<), operator(>=) - use MOM_time_manager, only : increment_date, set_calendar_type, month_name - use MOM_time_manager, only : JULIAN, GREGORIAN, NOLEAP, THIRTY_DAY_MONTHS - use MOM_time_manager, only : NO_CALENDAR - use MOM_write_cputime, only : write_cputime, MOM_write_cputime_init - use MOM_write_cputime, only : write_cputime_start_clock, write_cputime_CS + use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end + use MOM_cpu_clock, only : CLOCK_COMPONENT + use MOM_debugging, only : MOM_debugging_init + use MOM_diag_mediator, only : diag_mediator_init, diag_mediator_infrastructure_init + use MOM_diag_mediator, only : enable_averaging, disable_averaging, diag_mediator_end + use MOM_diag_mediator, only : diag_ctrl, diag_mediator_close_registration + use MOM_domains, only : MOM_infra_init, MOM_infra_end + use MOM_domains, only : MOM_domains_init, clone_MOM_domain, pass_var + use MOM_dyn_horgrid, only : dyn_horgrid_type, create_dyn_horgrid, destroy_dyn_horgrid + use MOM_error_handler, only : MOM_error, MOM_mesg, WARNING, FATAL, is_root_pe + use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint + use MOM_file_parser, only : read_param, get_param, log_param, log_version, param_file_type + use MOM_file_parser, only : close_param_file + use MOM_fixed_initialization, only : MOM_initialize_fixed + use MOM_get_input, only : Get_MOM_Input, directories + use MOM_grid, only : ocean_grid_type, MOM_grid_init, MOM_grid_end + use MOM_hor_index, only : hor_index_type, hor_index_init + use MOM_io, only : MOM_io_init, file_exists, open_file, close_file + use MOM_io, only : check_nml_error, io_infra_init, io_infra_end + use MOM_io, only : APPEND_FILE, ASCII_FILE, READONLY_FILE, SINGLE_FILE + use MOM_open_boundary, only : ocean_OBC_type + use MOM_restart, only : save_restart + use MOM_string_functions,only : uppercase + use MOM_time_manager, only : time_type, set_date, get_date + use MOM_time_manager, only : real_to_time, time_type_to_real + use MOM_time_manager, only : operator(+), operator(-), operator(*), operator(/) + use MOM_time_manager, only : operator(>), operator(<), operator(>=) + use MOM_time_manager, only : increment_date, set_calendar_type, month_name + use MOM_time_manager, only : JULIAN, GREGORIAN, NOLEAP, THIRTY_DAY_MONTHS, NO_CALENDAR + use MOM_transcribe_grid, only : copy_dyngrid_to_MOM_grid, copy_MOM_grid_to_dyngrid + use MOM_unit_scaling, only : unit_scale_type, unit_scaling_init + use MOM_verticalGrid, only : verticalGrid_type, verticalGridInit, verticalGridEnd + use MOM_write_cputime, only : write_cputime, MOM_write_cputime_init + use MOM_write_cputime, only : write_cputime_start_clock, write_cputime_CS use MOM_ice_shelf, only : initialize_ice_shelf, ice_shelf_end, ice_shelf_CS use MOM_ice_shelf, only : ice_shelf_save_restart, solo_step_ice_shelf -! , add_shelf_flux_forcing, add_shelf_flux_IOB + implicit none #include - -! type(forcing) :: fluxes ! A structure that will be uninitialized till i figure out - ! whether i can make the argument optional - -! type(ocean_grid_type), pointer :: grid ! A pointer to a structure containing - ! metrics and related information. logical :: use_ice_shelf = .false. ! If .true., use the ice shelf model for ! part of the domain. - logical :: permit_restart = .true. ! This is .true. if incremental restart - ! files may be saved. - integer :: m, n - - integer :: nmax=2000000000; ! nmax is the number of iterations - ! after which to stop so that the - ! simulation does not exceed its CPU - ! time limit. nmax is determined by - ! evaluating the CPU time used between - ! successive calls to write_energy. - ! Initially it is set to be very large. - type(directories) :: dirs ! A structure containing several relevant directory paths. - - type(time_type), target :: Time ! A copy of the model's time. - ! Other modules can set pointers to this and - ! change it to manage diagnostics. - - type(time_type) :: Master_Time ! The ocean model's master clock. No other - ! modules are ever given access to this. - - type(time_type) :: Time1 ! The value of the ocean model's time at the - ! start of a call to step_MOM. - - type(time_type) :: Start_time ! The start time of the simulation. + ! This is .true. if incremental restart files may be saved. + logical :: permit_incr_restart = .true. + + integer :: ns ! Running number of external timesteps. + integer :: ns_ice ! Running number of internal timesteps in solo_step_ice_shelf. + + ! nmax is the number of iterations after which to stop so that the simulation does not exceed its + ! CPU time limit. nmax is determined by evaluating the CPU time used between successive calls to + ! write_cputime. Initially it is set to be very large. + integer :: nmax=2000000000 + + ! A structure containing several relevant directory paths. + type(directories) :: dirs + + ! A suite of time types for use by the solo ice model. + type(time_type), target :: Time ! A copy of the model's time. + ! Other modules can set pointers to this and + ! change it to manage diagnostics. + type(time_type) :: Master_Time ! The ocean model's master clock. No other + ! modules are ever given access to this. + type(time_type) :: Time1 ! The value of the ocean model's time at the + ! start of a call to step_MOM. + type(time_type) :: Start_time ! The start time of the simulation. type(time_type) :: segment_start_time ! The start time of this run segment. + type(time_type) :: Time_end ! End time for the segment or experiment. + type(time_type) :: restart_time ! The next time to write restart files. + type(time_type) :: Time_step_shelf ! A time_type version of time_step. + type(time_type) :: time_chg ! An amount of time to adjust the segment_start_time + ! and elapsed time to avoid roundoff problems. - type(time_type) :: Time_end ! End time for the segment or experiment. + real :: elapsed_time = 0.0 ! Elapsed time in this run [s]. - type(time_type) :: restart_time ! The next time to write restart files. - - type(time_type) :: Time_step_shelf ! A time_type version of time_step. + logical :: elapsed_time_master ! If true, elapsed time is used to set the + ! model's master clock (Time). This is needed + ! if Time_step_shelf is not an exact + ! representation of time_step. + real :: time_step ! The time step [s] - real :: elapsed_time = 0.0 ! Elapsed time in this run in seconds. (years?) + ! A pointer to a structure containing metrics and related information. + type(ocean_grid_type), pointer :: ocn_grid - logical :: elapsed_time_master ! If true, elapsed time is used to set the - ! model's master clock (Time). This is needed - ! if Time_step_shelf is not an exact - ! representation of time_step. + type(dyn_horgrid_type), pointer :: dG => NULL() ! A dynamic version of the horizontal grid + type(hor_index_type), pointer :: HI => NULL() ! A hor_index_type for array extents + type(verticalGrid_type), pointer :: GV => NULL() ! Pointer to the ocean vertical grid structure - real :: time_step ! The time step (in years??? seconds???) + !> Pointer to the MOM open boundary condition type + type(ocean_OBC_type), pointer :: OBC => NULL() + ! A pointer to a structure containing dimensional unit scaling factors. + type(unit_scale_type), pointer :: US + type(diag_ctrl), pointer :: & + diag => NULL() ! A pointer to the diagnostic regulatory structure integer :: Restart_control ! An integer that is bit-tested to determine whether ! incremental restart files are saved and whether they @@ -114,41 +126,40 @@ program SHELF_main ! files and +2 (bit 1) for time-stamped files. A ! restart file is saved at the end of a run segment ! unless Restart_control is negative. - real :: Time_unit ! The time unit in seconds for the following input fields. + + real :: Time_unit ! The time unit for the following input fields [s]. type(time_type) :: restint ! The time between saves of the restart file. type(time_type) :: daymax ! The final day of the simulation. - integer :: date_init(6)=0 ! The start date of the whole simulation. - integer :: date(6)=-1 ! Possibly the start date of this run segment. + integer :: CPU_steps ! The number of steps between writing CPU time. + integer :: date_init(6)=0 ! The start date of the whole simulation. + integer :: date(6)=-1 ! Possibly the start date of this run segment. integer :: years=0, months=0, days=0 ! These may determine the segment run integer :: hours=0, minutes=0, seconds=0 ! length, if read from a namelist. - integer :: yr, mon, day, hr, min, sec ! Temp variables for writing the date. - type(param_file_type) :: param_file ! The structure indicating the file(s) - ! containing all run-time parameters. - character(len=9) :: month + integer :: yr, mon, day, hr, mins, sec ! Temp variables for writing the date. + type(param_file_type) :: param_file ! The structure indicating the file(s) + ! containing all run-time parameters. + character(len=9) :: month character(len=16) :: calendar = 'julian' integer :: calendar_type=-1 integer :: unit, io_status, ierr - logical :: unit_in_use + logical :: symmetric + logical :: unit_in_use integer :: initClock, mainClock, termClock -! type(ice_shelf_CS), pointer :: MOM_CSp => NULL() -! type(surface_forcing_CS), pointer :: surface_forcing_CSp => NULL() -! type(sum_output_CS), pointer :: sum_output_CSp => NULL() type(write_cputime_CS), pointer :: write_CPU_CSp => NULL() type(ice_shelf_CS), pointer :: ice_shelf_CSp => NULL() !----------------------------------------------------------------------- - character(len=4), parameter :: vers_num = 'v2.0' -! This include declares and sets the variable "version". -#include "version_variable.h" - character(len=40) :: mdl = "SHELF_main (ice_shelf_driver)" ! This module's name. + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mod_name = "SHELF_main (ice_shelf_driver)" ! This module's name. namelist /ice_solo_nml/ date_init, calendar, months, days, hours, minutes, seconds - !======================================================================= + !===================================================================== call write_cputime_start_clock(write_CPU_CSp) @@ -160,15 +171,16 @@ program SHELF_main termClock = cpu_clock_id( 'Termination' ) call cpu_clock_begin(initClock) - call MOM_mesg('======== Model being driven by ice_shelf_driver ========') + call MOM_mesg('======== Model being driven by ice_shelf_driver ========', 2) + call callTree_waypoint("Program Shelf_main, ice_shelf_driver.F90") if (file_exists('input.nml')) then ! Provide for namelist specification of the run length and calendar data. call open_file(unit, 'input.nml', form=ASCII_FILE, action=READONLY_FILE) read(unit, ice_solo_nml, iostat=io_status) call close_file(unit) + ierr = check_nml_error(io_status,'ice_solo_nml') if (years+months+days+hours+minutes+seconds > 0) then - ierr = check_nml_error(io_status,'ice_solo_nml') if (is_root_pe()) write(*,ice_solo_nml) endif endif @@ -184,38 +196,40 @@ program SHELF_main else calendar = uppercase(calendar) if (calendar(1:6) == 'JULIAN') then ; calendar_type = JULIAN - else if (calendar(1:9) == 'GREGORIAN') then ; calendar_type = GREGORIAN - else if (calendar(1:6) == 'NOLEAP') then ; calendar_type = NOLEAP - else if (calendar(1:10)=='THIRTY_DAY') then ; calendar_type = THIRTY_DAY_MONTHS - else if (calendar(1:11)=='NO_CALENDAR') then; calendar_type = NO_CALENDAR - else if (calendar(1:1) /= ' ') then - call MOM_error(FATAL,'MOM_driver: Invalid namelist value '//trim(calendar)//' for calendar') + elseif (calendar(1:9) == 'GREGORIAN') then ; calendar_type = GREGORIAN + elseif (calendar(1:6) == 'NOLEAP') then ; calendar_type = NOLEAP + elseif (calendar(1:10)=='THIRTY_DAY') then ; calendar_type = THIRTY_DAY_MONTHS + elseif (calendar(1:11)=='NO_CALENDAR') then; calendar_type = NO_CALENDAR + elseif (calendar(1:1) /= ' ') then + call MOM_error(FATAL,'Shelf_driver: Invalid namelist value '//trim(calendar)//' for calendar') else - call MOM_error(FATAL,'MOM_driver: No namelist value for calendar') + call MOM_error(FATAL,'Shelf_driver: No namelist value for calendar') endif endif call set_calendar_type(calendar_type) + if (sum(date_init) > 0) then Start_time = set_date(date_init(1),date_init(2), date_init(3), & date_init(4),date_init(5),date_init(6)) else - Start_time = set_time(0,0) + Start_time = real_to_time(0.0) endif call Get_MOM_Input(param_file, dirs) + ! Determining the internal unit scaling factors for this run. + call unit_scaling_init(param_file, US) ! Read all relevant parameters and write them to the model log. - call log_version(param_file, mdl, version, "") + call log_version(param_file, mod_name, version, "") - call get_param(param_file, mdl, "ICE_SHELF", use_ice_shelf, & + call get_param(param_file, mod_name, "ICE_SHELF", use_ice_shelf, & "If true, call the code to apply an ice shelf model over "//& "some of the domain.", default=.false.) - if (.not.use_ice_shelf) call MOM_error(FATAL, & - "shelf_driver: ICE_SHELF must be defined.") + if (.not.use_ice_shelf) call MOM_error(FATAL, "Shelf_driver: Run stops unless ICE_SHELF is true.") - call get_param(param_file, mdl, "ICE_VELOCITY_TIMESTEP", time_step, & + call get_param(param_file, mod_name, "ICE_VELOCITY_TIMESTEP", time_step, & "The time step for changing forcing, coupling with other "//& "components, or potentially writing certain diagnostics.", & units="s", fail_if_missing=.true.) @@ -224,39 +238,70 @@ program SHELF_main ! In this case, the segment starts at a time fixed by ocean_solo.res segment_start_time = set_date(date(1),date(2),date(3),date(4),date(5),date(6)) Time = segment_start_time - call initialize_ice_shelf (Time, ice_shelf_CSp) else - ! In this case, the segment starts at a time read from the MOM restart file - ! or left as Start_time by MOM_initialize. + ! In this case, the segment starts at Start_time. Time = Start_time - call initialize_ice_shelf (Time, ice_shelf_CSp) endif + + ! This is the start of the code that is the counterpart of MOM_initialization. + call callTree_waypoint("Start of ice shelf initialization.") + + call MOM_debugging_init(param_file) + call diag_mediator_infrastructure_init() + call MOM_io_init(param_file) + + ! Set up the ocean model domain and grid; the ice model grid is set in initialize_ice_shelf, + ! but the grids have strong commonalities in this configuration, and the ocean grid is required + ! to set up the diag mediator control structure. + call MOM_domains_init(ocn_grid%domain, param_file) + call hor_index_init(ocn_grid%Domain, HI, param_file) + call create_dyn_horgrid(dG, HI) + call clone_MOM_domain(ocn_grid%Domain, dG%Domain) + + ! Initialize the ocean grid and topography. + call MOM_initialize_fixed(dG, US, OBC, param_file, .true., dirs%output_directory) + call MOM_grid_init(ocn_grid, param_file, US, HI) + call copy_dyngrid_to_MOM_grid(dG, ocn_grid, US) + call destroy_dyn_horgrid(dG) + + ! Initialize the diag mediator. The ocean's vertical grid is not really used here, but at + ! present the interface to diag_mediator_init assumes the presence of ocean-specific information. + call verticalGridInit(param_file, GV, US) + call diag_mediator_init(ocn_grid, GV, US, GV%ke, param_file, diag, doc_file_dir=dirs%output_directory) + + call callTree_waypoint("returned from diag_mediator_init()") + + call initialize_ice_shelf(param_file, ocn_grid, Time, ice_shelf_CSp, diag) + + ! This is the end of the code that is the counterpart of MOM_initialization. + call callTree_waypoint("End of ice shelf initialization.") + Master_Time = Time ! grid => ice_shelf_CSp%grid segment_start_time = Time elapsed_time = 0.0 - Time_step_shelf = set_time(int(floor(time_step+0.5))) + Time_step_shelf = real_to_time(time_step) elapsed_time_master = (abs(time_step - time_type_to_real(Time_step_shelf)) > 1.0e-12*time_step) if (elapsed_time_master) & - call MOM_mesg("Using real elapsed time for the master clock.") + call MOM_mesg("Using real elapsed time for the master clock.", 2) ! Determine the segment end time, either from the namelist file or parsed input file. - call get_param(param_file, mdl, "TIMEUNIT", Time_unit, & + call get_param(param_file, mod_name, "TIMEUNIT", Time_unit, & "The time unit for DAYMAX and RESTINT.", & units="s", default=86400.0) if (years+months+days+hours+minutes+seconds > 0) then Time_end = increment_date(Time, years, months, days, hours, minutes, seconds) - call MOM_mesg('Segment run length determied from ice_solo_nml.', 2) - call get_param(param_file, mdl, "DAYMAX", daymax, & + call MOM_mesg('Segment run length determined from ice_solo_nml.', 2) + call get_param(param_file, mod_name, "DAYMAX", daymax, & "The final time of the whole simulation, in units of "//& "TIMEUNIT seconds. This also sets the potential end "//& "time of the present run segment if the end time is "//& "not set (as it was here) via ocean_solo_nml in input.nml.", & timeunit=Time_unit, default=Time_end) else - call get_param(param_file, mdl, "DAYMAX", daymax, & + call get_param(param_file, mod_name, "DAYMAX", daymax, & "The final time of the whole simulation, in units of "//& "TIMEUNIT seconds. This also sets the potential end "//& "time of the present run segment if the end time is "//& @@ -265,58 +310,62 @@ program SHELF_main Time_end = daymax endif - if (is_root_pe()) print *,"Time_step_shelf", time_type_to_real(Time_step_shelf), & - "TIme_end", time_type_to_real(Time_end) if (Time >= Time_end) call MOM_error(FATAL, & - "MOM_driver: The run has been started at or after the end time of the run.") + "Shelf_driver: The run has been started at or after the end time of the run.") - call get_param(param_file, mdl, "RESTART_CONTROL", Restart_control, & + call get_param(param_file, mod_name, "RESTART_CONTROL", Restart_control, & "An integer whose bits encode which restart files are "//& "written. Add 2 (bit 1) for a time-stamped file, and odd "//& "(bit 0) for a non-time-stamped file. A non-time-stamped "//& "restart file is saved at the end of the run segment "//& "for any non-negative value.", default=1) - call get_param(param_file, mdl, "RESTINT", restint, & + call get_param(param_file, mod_name, "RESTINT", restint, & "The interval between saves of the restart file in units "//& "of TIMEUNIT. Use 0 (the default) to not save "//& - "incremental restart files at all.", default=set_time(0), & + "incremental restart files at all.", default=real_to_time(0.0), & timeunit=Time_unit) - call log_param(param_file, mdl, "ELAPSED TIME AS MASTER", elapsed_time_master) + call get_param(param_file, mod_name, "WRITE_CPU_STEPS", cpu_steps, & + "The number of coupled timesteps between writing the cpu "//& + "time. If this is not positive, do not check cpu time, and "//& + "the segment run-length can not be set via an elapsed CPU time.", & + default=1000) -! i don't think we'll use this... - call MOM_write_cputime_init(param_file, dirs%output_directory, Start_time, & - write_CPU_CSp) - call MOM_mesg("Done MOM_write_cputime_init.", 5) + call log_param(param_file, mod_name, "ELAPSED TIME AS MASTER", elapsed_time_master) + if (cpu_steps > 0) & + call MOM_write_cputime_init(param_file, dirs%output_directory, Start_time, & + write_CPU_CSp) ! Close the param_file. No further parsing of input is possible after this. call close_param_file(param_file) -! call diag_mediator_close_registration(diag) + call diag_mediator_close_registration(diag) ! Write out a time stamp file. - call open_file(unit, 'time_stamp.out', form=ASCII_FILE, action=APPEND_FILE, & - threading=SINGLE_FILE) - call get_date(Time, date(1), date(2), date(3), date(4), date(5), date(6)) - month = month_name(date(2)) - if (is_root_pe()) write(unit,'(6i4,2x,a3)') date, month(1:3) - call get_date(Time_end, date(1), date(2), date(3), date(4), date(5), date(6)) - month = month_name(date(2)) - if (is_root_pe()) write(unit,'(6i4,2x,a3)') date, month(1:3) - call close_file(unit) - - call write_cputime(Time, 0, nmax, write_CPU_CSp) + if (calendar_type /= NO_CALENDAR) then + call open_file(unit, 'time_stamp.out', form=ASCII_FILE, action=APPEND_FILE, & + threading=SINGLE_FILE) + call get_date(Time, date(1), date(2), date(3), date(4), date(5), date(6)) + month = month_name(date(2)) + if (is_root_pe()) write(unit,'(6i4,2x,a3)') date, month(1:3) + call get_date(Time_end, date(1), date(2), date(3), date(4), date(5), date(6)) + month = month_name(date(2)) + if (is_root_pe()) write(unit,'(6i4,2x,a3)') date, month(1:3) + call close_file(unit) + endif + + if (cpu_steps > 0) call write_cputime(Time, 0, write_CPU_CSp) if (((.not.BTEST(Restart_control,1)) .and. (.not.BTEST(Restart_control,0))) & - .or. (Restart_control < 0)) permit_restart = .false. + .or. (Restart_control < 0)) permit_incr_restart = .false. - if (restint > set_time(0)) then + if (restint > real_to_time(0.0)) then ! restart_time is the next integral multiple of restint. restart_time = Start_time + restint * & - (1 + ((Time + Time_step_ocean) - Start_time) / restint) + (1 + ((Time + Time_step_shelf) - Start_time) / restint) else ! Set the time so late that there is no intermediate restart. - restart_time = Time_end + Time_step_ocean - permit_restart = .false. + restart_time = Time_end + Time_step_shelf + permit_incr_restart = .false. endif call cpu_clock_end(initClock) !end initialization @@ -325,66 +374,72 @@ program SHELF_main !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! MAIN LOOP !!!!!!!!!!!!!!!!!!!!!!!!!!!!! - n = 1 ; m = 1 - do while ((n < nmax) .and. (Time < Time_end)) + ns = 1 ; ns_ice = 1 + do while ((ns < nmax) .and. (Time < Time_end)) + call callTree_enter("Main loop, Shelf_driver.F90", ns) ! This call steps the model over a time time_step. Time1 = Master_Time ; Time = Master_Time - call solo_step_ice_shelf(ice_shelf_CSp, Time_step_shelf, m, Time) + call solo_step_ice_shelf(ice_shelf_CSp, Time_step_shelf, ns_ice, Time) -! Time = Time + Time_step_ocean -! This is here to enable fractional-second time steps. +! Time = Time + Time_step_shelf +! This is here to enable fractional-second time steps. elapsed_time = elapsed_time + time_step if (elapsed_time > 2e9) then - ! This is here to ensure that the conversion from a real to an integer - ! can be accurately represented in long runs (longer than ~63 years). - ! It will also ensure that elapsed time does not loose resolution of order - ! the timetype's resolution, provided that the timestep and tick are - ! larger than 10-5 seconds. If a clock with a finer resolution is used, - ! a smaller value would be required. - segment_start_time = segment_start_time + set_time(int(floor(elapsed_time))) - elapsed_time = elapsed_time - floor(elapsed_time) + ! This is here to ensure that the conversion from a real to an integer can be accurately + ! represented in long runs (longer than ~63 years). It will also ensure that elapsed time + ! does not lose resolution of order the timetype's resolution, provided that the timestep and + ! tick are larger than 10-5 seconds. If a clock with a finer resolution is used, a smaller + ! value would be required. + time_chg = real_to_time(elapsed_time) + segment_start_time = segment_start_time + time_chg + elapsed_time = elapsed_time - time_type_to_real(time_chg) endif if (elapsed_time_master) then - Master_Time = segment_start_time + set_time(int(floor(elapsed_time+0.5))) + Master_Time = segment_start_time + real_to_time(elapsed_time) else Master_Time = Master_Time + Time_step_shelf endif Time = Master_Time + if (cpu_steps > 0) then ; if (MOD(ns, cpu_steps) == 0) then + call write_cputime(Time, ns, write_CPU_CSp, nmax) + endif ; endif + ! See if it is time to write out a restart file - timestamped or not. - if (permit_restart) then - if (Time + (Time_step_shelf/2) > restart_time) then - if (BTEST(Restart_control,1)) then - call ice_shelf_save_restart(ice_shelf_CSp, Time, dirs%restart_output_dir, .true.) - endif - if (BTEST(Restart_control,0)) then - call ice_shelf_save_restart(ice_shelf_CSp, Time, dirs%restart_output_dir) - endif - restart_time = restart_time + restint + if ((permit_incr_restart) .and. (Time + (Time_step_shelf/2) > restart_time)) then + if (BTEST(Restart_control,1)) then + call ice_shelf_save_restart(ice_shelf_CSp, Time, dirs%restart_output_dir, .true.) endif + if (BTEST(Restart_control,0)) then + call ice_shelf_save_restart(ice_shelf_CSp, Time, dirs%restart_output_dir) + endif + restart_time = restart_time + restint endif - enddo !!!!!!! end loop + ns = ns + 1 + call callTree_leave("Main loop") + enddo call cpu_clock_end(mainClock) call cpu_clock_begin(termClock) if (Restart_control>=0) then call ice_shelf_save_restart(ice_shelf_CSp, Time, & dirs%restart_output_dir) - ! Write ocean solo restart file. + + ! Write ice shelf solo restart file. call open_file(unit, trim(dirs%restart_output_dir)//'shelf.res', nohdrs=.true.) if (is_root_pe())then write(unit, '(i6,8x,a)') calendar_type, & '(Calendar: no_calendar=0, thirty_day_months=1, julian=2, gregorian=3, noleap=4)' - call get_date(Start_time, yr, mon, day, hr, min, sec) - write(unit, '(6i6,8x,a)') yr, mon, day, hr, min, sec, & + call get_date(Start_time, yr, mon, day, hr, mins, sec) + write(unit, '(6i6,8x,a)') yr, mon, day, hr, mins, sec, & 'Model start time: year, month, day, hour, minute, second' - call get_date(Time, yr, mon, day, hr, min, sec) - write(unit, '(6i6,8x,a)') yr, mon, day, hr, min, sec, & + call get_date(Time, yr, mon, day, hr, mins, sec) + write(unit, '(6i6,8x,a)') yr, mon, day, hr, mins, sec, & 'Current model time: year, month, day, hour, minute, second' - end if + endif call close_file(unit) endif @@ -402,11 +457,13 @@ program SHELF_main close(unit) endif - call diag_mediator_end(Time, ice_shelf_CSp%diag, end_diag_manager=.true.) + call callTree_waypoint("End Shelf_main") + call diag_mediator_end(Time, diag, end_diag_manager=.true.) + if (cpu_steps > 0) call write_cputime(Time, ns-1, write_CPU_CSp, call_end=.true.) call cpu_clock_end(termClock) call io_infra_end ; call MOM_infra_end call ice_shelf_end(ice_shelf_CSp) -end program SHELF_main +end program Shelf_main diff --git a/config_src/ice_solo_driver/user_surface_forcing.F90 b/config_src/ice_solo_driver/user_surface_forcing.F90 deleted file mode 100644 index 10417d4a1e..0000000000 --- a/config_src/ice_solo_driver/user_surface_forcing.F90 +++ /dev/null @@ -1,340 +0,0 @@ -module user_surface_forcing - -! This file is part of MOM6. See LICENSE.md for the license. - -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* Rewritten by Robert Hallberg, June 2009 * -!* * -!* This file contains the subroutines that a user should modify to * -!* to set the surface wind stresses and fluxes of buoyancy or * -!* temperature and fresh water. They are called when the run-time * -!* parameters WIND_CONFIG or BUOY_CONFIG are set to "USER". The * -!* standard version has simple examples, along with run-time error * -!* messages that will cause the model to abort if this code has not * -!* been modified. This code is intended for use with relatively * -!* simple specifications of the forcing. For more complicated forms, * -!* it is probably a good idea to read the forcing from input files * -!* using "file" for WIND_CONFIG and BUOY_CONFIG. * -!* * -!* USER_wind_forcing should set the surface wind stresses (taux and * -!* tauy) perhaps along with the surface friction velocity (ustar). * -!* * -!* USER_buoyancy forcing is used to set the surface buoyancy * -!* forcing, which may include a number of fresh water flux fields * -!* (evap, lprec, fprec, lrunoff, frunoff, and * -!* vprec) and the surface heat fluxes (sw, lw, latent and sens) * -!* if temperature and salinity are state variables, or it may simply * -!* be the buoyancy flux if it is not. This routine also has coded a * -!* restoring to surface values of temperature and salinity. * -!* * -!* Macros written all in capital letters are defined in MOM_memory.h. * -!* * -!* A small fragment of the grid is shown below: * -!* * -!* j+1 x ^ x ^ x At x: q * -!* j+1 > o > o > At ^: v, tauy * -!* j x ^ x ^ x At >: u, taux * -!* j > o > o > At o: h, fluxes. * -!* j-1 x ^ x ^ x * -!* i-1 i i+1 At x & ^: * -!* i i+1 At > & o: * -!* * -!* The boundaries always run through q grid points (x). * -!* * -!********+*********+*********+*********+*********+*********+*********+** -use MOM_diag_mediator, only : post_data, query_averaging_enabled -use MOM_diag_mediator, only : register_diag_field, diag_ctrl, safe_alloc_ptr -use MOM_domains, only : pass_var, pass_vector, AGRID -use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe -use MOM_file_parser, only : get_param, param_file_type, log_version -use MOM_forcing_type, only : forcing, mech_forcing -use MOM_forcing_type, only : allocate_forcing_type, allocate_mech_forcing -use MOM_grid, only : ocean_grid_type -use MOM_io, only : file_exists, read_data -use MOM_time_manager, only : time_type, operator(+), operator(/), get_time -use MOM_tracer_flow_control, only : call_tracer_set_forcing -use MOM_tracer_flow_control, only : tracer_flow_control_CS -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : surface - -implicit none ; private - -public USER_wind_forcing, USER_buoyancy_forcing, USER_surface_forcing_init - -! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional -! consistency testing. These are noted in comments with units like Z, H, L, and T, along with -! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units -! vary with the Boussinesq approximation, the Boussinesq variant is given first. - -type, public :: user_surface_forcing_CS ; private - ! This control structure should be used to store any run-time variables - ! associated with the user-specified forcing. It can be readily modified - ! for a specific case, and because it is private there will be no changes - ! needed in other code (although they will have to be recompiled). - ! The variables in the cannonical example are used for some common - ! cases, but do not need to be used. - - logical :: use_temperature ! If true, temperature and salinity are used as - ! state variables. - logical :: restorebuoy ! If true, use restoring surface buoyancy forcing. - real :: Rho0 ! The density used in the Boussinesq approximation [R ~> kg m-3]. - real :: G_Earth ! The gravitational acceleration [L2 Z-1 T-2 ~> m s-2]. - real :: Flux_const ! The restoring rate at the surface [Z T-1 ~> m s-1]. - real :: gust_const ! A constant unresolved background gustiness - ! that contributes to ustar [R Z L T-1 ~> Pa]. - - type(diag_ctrl), pointer :: diag ! A structure that is used to regulate the - ! timing of diagnostic output. -end type user_surface_forcing_CS - -contains - -!> This subroutine sets the surface wind stresses, forces%taux and forces%tauy, in [R Z L T-2 ~> Pa]. -!! These are the stresses in the direction of the model grid (i.e. the same -!! direction as the u- and v- velocities). -subroutine USER_wind_forcing(sfc_state, forces, day, G, US, CS) - type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. - type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(time_type), intent(in) :: day !< The time of the fluxes - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(user_surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned - !! by a previous call to user_surface_forcing_init - -! This subroutine sets the surface wind stresses, forces%taux and forces%tauy [R Z L T-2 ~> Pa]. -! In addition, this subroutine can be used to set the surface friction velocity, -! forces%ustar [Z T-1 ~> m s-1], which is needed with a bulk mixed layer. - - integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB - - ! When modifying the code, comment out this error message. It is here - ! so that the original (unmodified) version is not accidentally used. - call MOM_error(FATAL, "User_wind_surface_forcing: " // & - "User forcing routine called without modification." ) - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - - ! Allocate the forcing arrays, if necessary. - call allocate_mech_forcing(G, forces, stress=.true., ustar=.true.) - - ! Set the surface wind stresses [Pa]. A positive taux - ! accelerates the ocean to the (pseudo-)east. - - ! The i-loop extends to is-1 so that taux can be used later in the - ! calculation of ustar - otherwise the lower bound would be Isq. - do j=js,je ; do I=is-1,Ieq - ! Change this to the desired expression. - forces%taux(I,j) = G%mask2dCu(I,j) * 0.0*US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z - enddo ; enddo - do J=js-1,Jeq ; do i=is,ie - forces%tauy(i,J) = G%mask2dCv(i,J) * 0.0 ! Change this to the desired expression. - enddo ; enddo - - ! Set the surface friction velocity [Z s-1 ~> m s-1]. ustar is always positive. - if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie - ! This expression can be changed if desired, but need not be. - forces%ustar(i,j) = G%mask2dT(i,j) * sqrt(US%L_to_Z * (CS%gust_const/CS%Rho0 + & - sqrt(0.5*(forces%taux(I-1,j)**2 + forces%taux(I,j)**2) + & - 0.5*(forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2))/CS%Rho0)) - enddo ; enddo ; endif - -end subroutine USER_wind_forcing - -!> This subroutine specifies the current surface fluxes of buoyancy or -!! temperature and fresh water. It may also be modified to add -!! surface fluxes of user provided tracers. -subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) - type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. - type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields - type(time_type), intent(in) :: day !< The time of the fluxes - real, intent(in) :: dt !< The amount of time over which - !! the fluxes apply [s] - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(user_surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned - !! by a previous call to user_surface_forcing_init - -! This subroutine specifies the current surface fluxes of buoyancy or -! temperature and fresh water. It may also be modified to add -! surface fluxes of user provided tracers. - -! When temperature is used, there are long list of fluxes that need to be -! set - essentially the same as for a full coupled model, but most of these -! can be simply set to zero. The net fresh water flux should probably be -! set in fluxes%evap and fluxes%lprec, with any salinity restoring -! appearing in fluxes%vprec, and the other water flux components -! (fprec, lrunoff and frunoff) left as arrays full of zeros. -! Evap is usually negative and precip is usually positive. All heat fluxes -! are in W m-2 and positive for heat going into the ocean. All fresh water -! fluxes are in [R Z T-1 ~> kg m-2 s-1] and positive for water moving into the ocean. - - real :: Temp_restore ! The temperature that is being restored toward [C]. - real :: Salin_restore ! The salinity that is being restored toward [ppt] - real :: density_restore ! The potential density that is being restored - ! toward [kg m-3]. - real :: rhoXcp ! The mean density times the heat capacity [Q R degC-1 ~> J m-3 degC-1]. - real :: buoy_rest_const ! A constant relating density anomalies to the - ! restoring buoyancy flux [L2 T-3 R-1 ~> m5 s-3 kg-1]. - - integer :: i, j, is, ie, js, je - integer :: isd, ied, jsd, jed - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - - ! When modifying the code, comment out this error message. It is here - ! so that the original (unmodified) version is not accidentally used. - call MOM_error(FATAL, "User_buoyancy_surface_forcing: " // & - "User forcing routine called without modification." ) - - ! Allocate and zero out the forcing arrays, as necessary. This portion is - ! usually not changed. - if (CS%use_temperature) then - call safe_alloc_ptr(fluxes%evap, isd, ied, jsd, jed) - call safe_alloc_ptr(fluxes%lprec, isd, ied, jsd, jed) - call safe_alloc_ptr(fluxes%fprec, isd, ied, jsd, jed) - call safe_alloc_ptr(fluxes%lrunoff, isd, ied, jsd, jed) - call safe_alloc_ptr(fluxes%frunoff, isd, ied, jsd, jed) - call safe_alloc_ptr(fluxes%vprec, isd, ied, jsd, jed) - - call safe_alloc_ptr(fluxes%sw, isd, ied, jsd, jed) - call safe_alloc_ptr(fluxes%lw, isd, ied, jsd, jed) - call safe_alloc_ptr(fluxes%latent, isd, ied, jsd, jed) - call safe_alloc_ptr(fluxes%sens, isd, ied, jsd, jed) - else ! This is the buoyancy only mode. - call safe_alloc_ptr(fluxes%buoy, isd, ied, jsd, jed) - endif - - - ! MODIFY THE CODE IN THE FOLLOWING LOOPS TO SET THE BUOYANCY FORCING TERMS. - - if ( CS%use_temperature ) then - ! Set whichever fluxes are to be used here. Any fluxes that - ! are always zero do not need to be changed here. - do j=js,je ; do i=is,ie - ! Fluxes of fresh water through the surface are in units of [kg m-2 s-1] - ! and are positive downward - i.e. evaporation should be negative. - fluxes%evap(i,j) = -0.0 * G%mask2dT(i,j) - fluxes%lprec(i,j) = 0.0 * G%mask2dT(i,j) - - ! vprec will be set later, if it is needed for salinity restoring. - fluxes%vprec(i,j) = 0.0 - - ! Heat fluxes are in units of [Q R Z T-1 ~> W m-2] and are positive into the ocean. - fluxes%lw(i,j) = 0.0 * G%mask2dT(i,j) - fluxes%latent(i,j) = 0.0 * G%mask2dT(i,j) - fluxes%sens(i,j) = 0.0 * G%mask2dT(i,j) - fluxes%sw(i,j) = 0.0 * G%mask2dT(i,j) - enddo ; enddo - else ! This is the buoyancy only mode. - do j=js,je ; do i=is,ie - ! fluxes%buoy is the buoyancy flux into the ocean [L2 T-3 ~> m2 s-3]. A positive - ! buoyancy flux is of the same sign as heating the ocean. - fluxes%buoy(i,j) = 0.0 * G%mask2dT(i,j) - enddo ; enddo - endif - - if (CS%restorebuoy) then - if (CS%use_temperature) then - call safe_alloc_ptr(fluxes%heat_added, isd, ied, jsd, jed) - ! When modifying the code, comment out this error message. It is here - ! so that the original (unmodified) version is not accidentally used. - call MOM_error(FATAL, "User_buoyancy_surface_forcing: " // & - "Temperature and salinity restoring used without modification." ) - - rhoXcp = CS%Rho0 * fluxes%C_p - do j=js,je ; do i=is,ie - ! Set Temp_restore and Salin_restore to the temperature (in degC) and - ! salinity (in ppt or PSU) that are being restored toward. - Temp_restore = 0.0 - Salin_restore = 0.0 - - fluxes%heat_added(i,j) = (G%mask2dT(i,j) * (rhoXcp * CS%Flux_const)) * & - (Temp_restore - sfc_state%SST(i,j)) - fluxes%vprec(i,j) = - (G%mask2dT(i,j) * (CS%Rho0*CS%Flux_const)) * & - ((Salin_restore - sfc_state%SSS(i,j)) / (0.5 * (Salin_restore + sfc_state%SSS(i,j)))) - enddo ; enddo - else - ! When modifying the code, comment out this error message. It is here - ! so that the original (unmodified) version is not accidentally used. - call MOM_error(FATAL, "User_buoyancy_surface_forcing: " // & - "Buoyancy restoring used without modification." ) - - ! The -1 is because density has the opposite sign to buoyancy. - buoy_rest_const = -1.0 * (CS%G_Earth * CS%Flux_const) / CS%Rho0 - do j=js,je ; do i=is,ie - ! Set density_restore to an expression for the surface potential - ! density [kg m-3] that is being restored toward. - density_restore = 1030.0 - - fluxes%buoy(i,j) = G%mask2dT(i,j) * buoy_rest_const * & - US%kg_m3_to_R*(density_restore - sfc_state%sfc_density(i,j)) - enddo ; enddo - endif - endif ! end RESTOREBUOY - -end subroutine USER_buoyancy_forcing - -!> This subroutine initializes the USER_surface_forcing module -subroutine USER_surface_forcing_init(Time, G, US, param_file, diag, CS) - type(time_type), intent(in) :: Time !< The current model time - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate diagnostic output. - type(user_surface_forcing_CS), pointer :: CS !< A pointer that is set to point to - !! the control structure for this module - - ! This include declares and sets the variable "version". -# include "version_variable.h" - character(len=40) :: mdl = "user_surface_forcing" ! This module's name. - - if (associated(CS)) then - call MOM_error(WARNING, "USER_surface_forcing_init called with an associated "// & - "control structure.") - return - endif - allocate(CS) - CS%diag => diag - - ! Read all relevant parameters and write them to the model log. - call log_version(param_file, mdl, version, "") - call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", CS%use_temperature, & - "If true, Temperature and salinity are used as state "//& - "variables.", default=.true.) - - call get_param(param_file, mdl, "G_EARTH", CS%G_Earth, & - "The gravitational acceleration of the Earth.", & - units="m s-2", default = 9.80, scale=US%m_to_L**2*US%Z_to_m*US%T_to_s**2) - call get_param(param_file, mdl, "RHO_0", CS%Rho0, & - "The mean ocean density used with BOUSSINESQ true to "//& - "calculate accelerations and the mass for conservation "//& - "properties, or with BOUSSINSEQ false to convert some "//& - "parameters from vertical units of m to kg m-2.", & - units="kg m-3", default=1035.0, scale=US%R_to_kg_m3) - call get_param(param_file, mdl, "GUST_CONST", CS%gust_const, & - "The background gustiness in the winds.", & - units="Pa", default=0.02, scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) - - call get_param(param_file, mdl, "RESTOREBUOY", CS%restorebuoy, & - "If true, the buoyancy fluxes drive the model back "//& - "toward some specified surface state with a rate "//& - "given by FLUXCONST.", default= .false.) - if (CS%restorebuoy) then - call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & - "The constant that relates the restoring surface fluxes "//& - "to the relative surface anomalies (akin to a piston "//& - "velocity). Note the non-MKS units.", & - units="m day-1", scale=US%m_to_Z*US%T_to_s/86400.0, fail_if_missing=.true.) - endif - -end subroutine USER_surface_forcing_init - -end module user_surface_forcing diff --git a/config_src/mct_driver/mom_ocean_model_mct.F90 b/config_src/mct_driver/mom_ocean_model_mct.F90 index 317a496399..2f94c9b7f9 100644 --- a/config_src/mct_driver/mom_ocean_model_mct.F90 +++ b/config_src/mct_driver/mom_ocean_model_mct.F90 @@ -11,56 +11,57 @@ module MOM_ocean_model_mct ! This code is a stop-gap wrapper of the MOM6 code to enable it to be called ! in the same way as MOM4. -use MOM, only : initialize_MOM, step_MOM, MOM_control_struct, MOM_end -use MOM, only : extract_surface_state, allocate_surface_state, finish_MOM_initialization -use MOM, only : get_MOM_state_elements, MOM_state_is_synchronized -use MOM, only : get_ocean_stocks, step_offline -use MOM_constants, only : CELSIUS_KELVIN_OFFSET, hlf -use MOM_diag_mediator, only : diag_ctrl, enable_averaging, disable_averaging -use MOM_diag_mediator, only : diag_mediator_close_registration, diag_mediator_end -use MOM_domains, only : pass_var, pass_vector, AGRID, BGRID_NE, CGRID_NE -use MOM_domains, only : TO_ALL, Omit_Corners -use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe -use MOM_error_handler, only : callTree_enter, callTree_leave -use MOM_file_parser, only : get_param, log_version, close_param_file, param_file_type -use MOM_forcing_type, only : allocate_forcing_type -use MOM_forcing_type, only : forcing, mech_forcing -use MOM_forcing_type, only : forcing_accumulate, copy_common_forcing_fields -use MOM_forcing_type, only : copy_back_forcing_fields, set_net_mass_forcing -use MOM_forcing_type, only : set_derived_forcing_fields -use MOM_forcing_type, only : forcing_diagnostics, mech_forcing_diags -use MOM_get_input, only : Get_MOM_Input, directories -use MOM_grid, only : ocean_grid_type -use MOM_io, only : close_file, file_exists, read_data, write_version_number -use MOM_marine_ice, only : iceberg_forces, iceberg_fluxes, marine_ice_init, marine_ice_CS -use MOM_restart, only : MOM_restart_CS, save_restart -use MOM_string_functions, only : uppercase -use MOM_surface_forcing_mct, only : surface_forcing_init, convert_IOB_to_fluxes -use MOM_surface_forcing_mct, only : convert_IOB_to_forces, ice_ocn_bnd_type_chksum -use MOM_surface_forcing_mct, only : ice_ocean_boundary_type, surface_forcing_CS -use MOM_surface_forcing_mct, only : forcing_save_restart -use MOM_time_manager, only : time_type, get_time, set_time, operator(>) -use MOM_time_manager, only : operator(+), operator(-), operator(*), operator(/) -use MOM_time_manager, only : operator(/=), operator(<=), operator(>=) -use MOM_time_manager, only : operator(<), real_to_time_type, time_type_to_real -use MOM_tracer_flow_control, only : call_tracer_register, tracer_flow_control_init -use MOM_tracer_flow_control, only : call_tracer_flux_init -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : surface -use MOM_verticalGrid, only : verticalGrid_type -use MOM_ice_shelf, only : initialize_ice_shelf, shelf_calc_flux, ice_shelf_CS -use MOM_ice_shelf, only : add_shelf_forces, ice_shelf_end, ice_shelf_save_restart -use coupler_types_mod, only : coupler_1d_bc_type, coupler_2d_bc_type -use coupler_types_mod, only : coupler_type_spawn, coupler_type_write_chksums -use coupler_types_mod, only : coupler_type_initialized, coupler_type_copy_data -use coupler_types_mod, only : coupler_type_set_diags, coupler_type_send_data -use mpp_domains_mod, only : domain2d, mpp_get_layout, mpp_get_global_domain -use mpp_domains_mod, only : mpp_define_domains, mpp_get_compute_domain, mpp_get_data_domain -use fms_mod, only : stdout -use mpp_mod, only : mpp_chksum -use MOM_EOS, only : gsw_sp_from_sr, gsw_pt_from_ct -use MOM_wave_interface, only: wave_parameters_CS, MOM_wave_interface_init -use MOM_wave_interface, only: MOM_wave_interface_init_lite, Update_Surface_Waves +use MOM, only : initialize_MOM, step_MOM, MOM_control_struct, MOM_end +use MOM, only : extract_surface_state, allocate_surface_state, finish_MOM_initialization +use MOM, only : get_MOM_state_elements, MOM_state_is_synchronized +use MOM, only : get_ocean_stocks, step_offline +use MOM_constants, only : CELSIUS_KELVIN_OFFSET, hlf +use MOM_diag_mediator, only : diag_ctrl, enable_averaging, disable_averaging +use MOM_diag_mediator, only : diag_mediator_close_registration, diag_mediator_end +use MOM_domains, only : pass_var, pass_vector, AGRID, BGRID_NE, CGRID_NE +use MOM_domains, only : TO_ALL, Omit_Corners +use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe +use MOM_error_handler, only : callTree_enter, callTree_leave +use MOM_file_parser, only : get_param, log_version, close_param_file, param_file_type +use MOM_forcing_type, only : allocate_forcing_type +use MOM_forcing_type, only : forcing, mech_forcing +use MOM_forcing_type, only : forcing_accumulate, copy_common_forcing_fields +use MOM_forcing_type, only : copy_back_forcing_fields, set_net_mass_forcing +use MOM_forcing_type, only : set_derived_forcing_fields +use MOM_forcing_type, only : forcing_diagnostics, mech_forcing_diags +use MOM_get_input, only : Get_MOM_Input, directories +use MOM_grid, only : ocean_grid_type +use MOM_io, only : close_file, file_exists, read_data, write_version_number +use MOM_marine_ice, only : iceberg_forces, iceberg_fluxes, marine_ice_init, marine_ice_CS +use MOM_restart, only : MOM_restart_CS, save_restart +use MOM_string_functions, only : uppercase +use MOM_surface_forcing_mct, only : surface_forcing_init, convert_IOB_to_fluxes +use MOM_surface_forcing_mct, only : convert_IOB_to_forces, ice_ocn_bnd_type_chksum +use MOM_surface_forcing_mct, only : ice_ocean_boundary_type, surface_forcing_CS +use MOM_surface_forcing_mct, only : forcing_save_restart +use MOM_time_manager, only : time_type, get_time, set_time, operator(>) +use MOM_time_manager, only : operator(+), operator(-), operator(*), operator(/) +use MOM_time_manager, only : operator(/=), operator(<=), operator(>=) +use MOM_time_manager, only : operator(<), real_to_time_type, time_type_to_real +use MOM_tracer_flow_control, only : call_tracer_register, tracer_flow_control_init +use MOM_tracer_flow_control, only : call_tracer_flux_init +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : surface +use MOM_verticalGrid, only : verticalGrid_type +use MOM_ice_shelf, only : initialize_ice_shelf, shelf_calc_flux, ice_shelf_CS +use MOM_ice_shelf, only : add_shelf_forces, ice_shelf_end, ice_shelf_save_restart +use coupler_types_mod, only : coupler_1d_bc_type, coupler_2d_bc_type +use coupler_types_mod, only : coupler_type_spawn, coupler_type_write_chksums +use coupler_types_mod, only : coupler_type_initialized, coupler_type_copy_data +use coupler_types_mod, only : coupler_type_set_diags, coupler_type_send_data +use mpp_domains_mod, only : domain2d, mpp_get_layout, mpp_get_global_domain +use mpp_domains_mod, only : mpp_define_domains, mpp_get_compute_domain, mpp_get_data_domain +use fms_mod, only : stdout +use mpp_mod, only : mpp_chksum +use MOM_EOS, only : gsw_sp_from_sr, gsw_pt_from_ct +use MOM_wave_interface, only : wave_parameters_CS, MOM_wave_interface_init +use MOM_wave_interface, only : MOM_wave_interface_init_lite, Update_Surface_Waves +use time_interp_external_mod, only : time_interp_external_init ! MCT specfic routines use MOM_domains, only : MOM_infra_end @@ -265,6 +266,8 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i OS%is_ocean_pe = Ocean_sfc%is_ocean_pe if (.not.OS%is_ocean_pe) return + call time_interp_external_init + OS%Time = Time_in call initialize_MOM(OS%Time, Time_init, param_file, OS%dirs, OS%MOM_CSp, & OS%restart_CSp, Time_in, offline_tracer_mode=OS%offline_tracer_mode, & @@ -894,52 +897,52 @@ subroutine convert_state_to_ocean_type(sfc_state, Ocean_sfc, G, US, patm, press_ if (present(patm)) then do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%sea_lev(i,j) = sfc_state%sea_lev(i+i0,j+j0) + patm(i,j) * press_to_z - Ocean_sfc%area(i,j) = US%L_to_m**2*G%areaT(i+i0,j+j0) + Ocean_sfc%sea_lev(i,j) = US%Z_to_m * sfc_state%sea_lev(i+i0,j+j0) + patm(i,j) * press_to_z + Ocean_sfc%area(i,j) = US%L_to_m**2 * G%areaT(i+i0,j+j0) enddo ; enddo else do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%sea_lev(i,j) = sfc_state%sea_lev(i+i0,j+j0) - Ocean_sfc%area(i,j) = US%L_to_m**2*G%areaT(i+i0,j+j0) + Ocean_sfc%sea_lev(i,j) = US%Z_to_m * sfc_state%sea_lev(i+i0,j+j0) + Ocean_sfc%area(i,j) = US%L_to_m**2 * G%areaT(i+i0,j+j0) enddo ; enddo endif if (allocated(sfc_state%frazil)) then do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%frazil(i,j) = sfc_state%frazil(i+i0,j+j0) + Ocean_sfc%frazil(i,j) = US%Q_to_J_kg*US%RZ_to_kg_m2 * sfc_state%frazil(i+i0,j+j0) enddo ; enddo endif if (allocated(sfc_state%melt_potential)) then do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%melt_potential(i,j) = sfc_state%melt_potential(i+i0,j+j0) + Ocean_sfc%melt_potential(i,j) = US%Q_to_J_kg*US%RZ_to_kg_m2 * sfc_state%melt_potential(i+i0,j+j0) enddo ; enddo endif if (allocated(sfc_state%Hml)) then do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%OBLD(i,j) = sfc_state%Hml(i+i0,j+j0) + Ocean_sfc%OBLD(i,j) = US%Z_to_m * sfc_state%Hml(i+i0,j+j0) enddo ; enddo endif if (Ocean_sfc%stagger == AGRID) then do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%u_surf(i,j) = G%mask2dT(i+i0,j+j0) * & + Ocean_sfc%u_surf(i,j) = G%mask2dT(i+i0,j+j0) * US%L_T_to_m_s * & 0.5*(sfc_state%u(I+i0,j+j0)+sfc_state%u(I-1+i0,j+j0)) - Ocean_sfc%v_surf(i,j) = G%mask2dT(i+i0,j+j0) * & + Ocean_sfc%v_surf(i,j) = G%mask2dT(i+i0,j+j0) * US%L_T_to_m_s * & 0.5*(sfc_state%v(i+i0,J+j0)+sfc_state%v(i+i0,J-1+j0)) enddo ; enddo elseif (Ocean_sfc%stagger == BGRID_NE) then do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%u_surf(i,j) = G%mask2dBu(I+i0,J+j0) * & + Ocean_sfc%u_surf(i,j) = G%mask2dBu(I+i0,J+j0) * US%L_T_to_m_s * & 0.5*(sfc_state%u(I+i0,j+j0)+sfc_state%u(I+i0,j+j0+1)) - Ocean_sfc%v_surf(i,j) = G%mask2dBu(I+i0,J+j0) * & + Ocean_sfc%v_surf(i,j) = G%mask2dBu(I+i0,J+j0) * US%L_T_to_m_s * & 0.5*(sfc_state%v(i+i0,J+j0)+sfc_state%v(i+i0+1,J+j0)) enddo ; enddo elseif (Ocean_sfc%stagger == CGRID_NE) then do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%u_surf(i,j) = G%mask2dCu(I+i0,j+j0)*sfc_state%u(I+i0,j+j0) - Ocean_sfc%v_surf(i,j) = G%mask2dCv(i+i0,J+j0)*sfc_state%v(i+i0,J+j0) + Ocean_sfc%u_surf(i,j) = G%mask2dCu(I+i0,j+j0) * US%L_T_to_m_s * sfc_state%u(I+i0,j+j0) + Ocean_sfc%v_surf(i,j) = G%mask2dCv(i+i0,J+j0) * US%L_T_to_m_s * sfc_state%v(i+i0,J+j0) enddo ; enddo else write(val_str, '(I8)') Ocean_sfc%stagger diff --git a/config_src/mct_driver/mom_surface_forcing_mct.F90 b/config_src/mct_driver/mom_surface_forcing_mct.F90 index 38bd54acf1..a42a8c3015 100644 --- a/config_src/mct_driver/mom_surface_forcing_mct.F90 +++ b/config_src/mct_driver/mom_surface_forcing_mct.F90 @@ -60,7 +60,7 @@ module MOM_surface_forcing_mct !! from MOM_domains) to indicate the staggering of !! the winds that are being provided in calls to !! update_ocean_model. - logical :: use_temperature !! If true, temp and saln used as state variables + logical :: use_temperature !< If true, temp and saln used as state variables real :: wind_stress_multiplier!< A multiplier applied to incoming wind stress (nondim). real :: Rho0 !< Boussinesq reference density [R ~> kg m-3] @@ -68,9 +68,9 @@ module MOM_surface_forcing_mct real :: latent_heat_fusion !< latent heat of fusion [J kg-1] real :: latent_heat_vapor !< latent heat of vaporization [J kg-1] - real :: max_p_surf !< maximum surface pressure that can be - !! exerted by the atmosphere and floating sea-ice, - !! [Pa]. This is needed because the FMS coupling + real :: max_p_surf !< The maximum surface pressure that can be exerted by + !! the atmosphere and floating sea-ice [R L2 T-2 ~> Pa]. + !! This is needed because the FMS coupling !! structure does not limit the water that can be !! frozen out of the ocean and the ice-ocean heat !! fluxes are treated explicitly. @@ -95,14 +95,14 @@ module MOM_surface_forcing_mct logical :: rigid_sea_ice !< If true, sea-ice exerts a rigidity that acts !! to damp surface deflections (especially surface !! gravity waves). The default is false. - real :: G_Earth !< Gravitational acceleration [m s-2] - real :: Kv_sea_ice !! viscosity in sea-ice that resists sheared vertical motions [m2 s-1] - real :: density_sea_ice !< typical density of sea-ice [kg m-3]. The value is + real :: g_Earth !< Gravitational acceleration [L2 Z-1 T-2 ~> m s-2] + real :: Kv_sea_ice !< Viscosity in sea-ice that resists sheared vertical motions [L4 Z-2 T-1 ~> m2 s-1] + real :: density_sea_ice !< Typical density of sea-ice [R ~> kg m-3]. The value is !! only used to convert the ice pressure into !! appropriate units for use with Kv_sea_ice. real :: rigid_sea_ice_mass !< A mass per unit area of sea-ice beyond which - !! sea-ice viscosity becomes effective, in kg m-2, - !! typically of order 1000 [kg m-2]. + !! sea-ice viscosity becomes effective [R Z ~> kg m-2], + !! typically of order 1000 kg m-2. logical :: allow_flux_adjustments !< If true, use data_override to obtain flux adjustments real :: Flux_const !< piston velocity for surface restoring [Z T-1 ~> m s-1] logical :: salt_restore_as_sflux !< If true, SSS restore as salt flux instead of water flux @@ -112,7 +112,7 @@ module MOM_surface_forcing_mct logical :: use_net_FW_adjustment_sign_bug !< use the wrong sign when adjusting net FW logical :: adjust_net_fresh_water_by_scaling !< adjust net surface fresh-water w/o moving zero contour logical :: mask_srestore_under_ice !< If true, use an ice mask defined by frazil - !< criteria for salinity restoring. + real :: ice_salt_concentration !< salt concentration for sea ice [kg/kg] logical :: mask_srestore_marginal_seas !< if true, then mask SSS restoring in marginal seas real :: max_delta_srestore !< maximum delta salinity used for restoring @@ -125,8 +125,8 @@ module MOM_surface_forcing_mct character(len=200) :: salt_restore_file !< filename for salt restoring data character(len=30) :: salt_restore_var_name !< name of surface salinity in salt_restore_file logical :: mask_srestore !< if true, apply a 2-dimensional mask to the surface - !< salinity restoring fluxes. The masking file should be - !< in inputdir/salt_restore_mask.nc and the field should + !! salinity restoring fluxes. The masking file should be + !! in inputdir/salt_restore_mask.nc and the field should !! be named 'mask' real, pointer, dimension(:,:) :: srestore_mask => NULL() !< mask for SSS restoring character(len=200) :: temp_restore_file !< filename for sst restoring data @@ -456,7 +456,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, fluxes%area_berg(i,j) = IOB%area_berg(i-i0,j-j0) * G%mask2dT(i,j) if (associated(IOB%mass_berg)) & - fluxes%mass_berg(i,j) = IOB%mass_berg(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%mass_berg(i,j) = US%m_to_Z*US%kg_m3_to_R * IOB%mass_berg(i-i0,j-j0) * G%mask2dT(i,j) ! GMM, cime does not not have an equivalent for heat_content_lrunoff and ! heat_content_frunoff. I am setting these to zero for now. @@ -527,12 +527,12 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, if (associated(IOB%p)) then if (CS%max_p_surf >= 0.0) then do j=js,je ; do i=is,ie - fluxes%p_surf_full(i,j) = G%mask2dT(i,j) * IOB%p(i-i0,j-j0) + fluxes%p_surf_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) fluxes%p_surf(i,j) = MIN(fluxes%p_surf_full(i,j),CS%max_p_surf) enddo; enddo else do j=js,je ; do i=is,ie - fluxes%p_surf_full(i,j) = G%mask2dT(i,j) * IOB%p(i-i0,j-j0) + fluxes%p_surf_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) fluxes%p_surf(i,j) = fluxes%p_surf_full(i,j) enddo; enddo endif @@ -611,7 +611,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) tauy_at_q !< Meridional wind stresses at q points [R Z L T-2 ~> Pa] real, dimension(SZI_(G),SZJ_(G)) :: & - rigidity_at_h, & !< Ice rigidity at tracer points [m3 s-1] + rigidity_at_h, & !< Ice rigidity at tracer points [L4 Z-1 T-1 ~> m3 s-1] taux_at_h, & !< Zonal wind stresses at h points [R Z L T-2 ~> Pa] tauy_at_h !< Meridional wind stresses at h points [R Z L T-2 ~> Pa] @@ -621,10 +621,10 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) real :: tau_mag !< magnitude of the wind stress [R Z L T-2 ~> Pa] real :: Pa_conversion ! A unit conversion factor from Pa to the internal wind stress units [R Z L T-2 Pa-1 ~> 1] real :: stress_conversion ! A unit conversion factor from Pa times any stress multiplier [R Z L T-2 Pa-1 ~> 1] - real :: I_GEarth !< 1.0 / G%G_Earth [s2 m-1] - real :: Kv_rho_ice !< (CS%kv_sea_ice / CS%density_sea_ice) [m5 s-1 kg-1] - real :: mass_ice !< mass of sea ice at a face [kg m-2] - real :: mass_eff !< effective mass of sea ice for rigidity [kg m-2] + real :: I_GEarth !< The inverse of the gravitational acceleration [T2 Z L-2 ~> s2 m-1] + real :: Kv_rho_ice !< (CS%Kv_sea_ice / CS%density_sea_ice) [L4 Z-2 T-1 R-1 ~> m5 s-1 kg-1] + real :: mass_ice !< mass of sea ice at a face [R Z ~> kg m-2] + real :: mass_eff !< effective mass of sea ice for rigidity [R Z ~> kg m-2] integer :: wind_stagger !< AGRID, BGRID_NE, or CGRID_NE (integers from MOM_domains) integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq, i0, j0 @@ -686,12 +686,12 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) if (associated(IOB%p)) then if (CS%max_p_surf >= 0.0) then do j=js,je ; do i=is,ie - forces%p_surf_full(i,j) = G%mask2dT(i,j) * IOB%p(i-i0,j-j0) + forces%p_surf_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) forces%p_surf(i,j) = MIN(forces%p_surf_full(i,j),CS%max_p_surf) enddo ; enddo else do j=js,je ; do i=is,ie - forces%p_surf_full(i,j) = G%mask2dT(i,j) * IOB%p(i-i0,j-j0) + forces%p_surf_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) forces%p_surf(i,j) = forces%p_surf_full(i,j) enddo ; enddo endif @@ -721,10 +721,10 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) forces%area_berg(i,j) = IOB%area_berg(i-i0,j-j0) * G%mask2dT(i,j) if (associated(IOB%mass_berg)) & - forces%mass_berg(i,j) = IOB%mass_berg(i-i0,j-j0) * G%mask2dT(i,j) + forces%mass_berg(i,j) = US%m_to_Z*US%kg_m3_to_R * IOB%mass_berg(i-i0,j-j0) * G%mask2dT(i,j) if (associated(IOB%ice_rigidity)) & - rigidity_at_h(i,j) = IOB%ice_rigidity(i-i0,j-j0) * G%mask2dT(i,j) + rigidity_at_h(i,j) = US%m_to_L**3*US%Z_to_L*US%T_to_s * IOB%ice_rigidity(i-i0,j-j0) * G%mask2dT(i,j) if (wind_stagger == BGRID_NE) then if (associated(IOB%u_flux)) taux_at_q(I,J) = IOB%u_flux(i-i0,j-j0) * stress_conversion @@ -845,14 +845,13 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) if (CS%rigid_sea_ice) then call pass_var(forces%p_surf_full, G%Domain, halo=1) - I_GEarth = 1.0 / CS%G_Earth - Kv_rho_ice = (CS%kv_sea_ice / CS%density_sea_ice) + I_GEarth = 1.0 / CS%g_Earth + Kv_rho_ice = (CS%Kv_sea_ice / CS%density_sea_ice) do I=is-1,ie ; do j=js,je mass_ice = min(forces%p_surf_full(i,j), forces%p_surf_full(i+1,j)) * I_GEarth mass_eff = 0.0 if (mass_ice > CS%rigid_sea_ice_mass) then - mass_eff = (mass_ice - CS%rigid_sea_ice_mass) **2 / & - (mass_ice + CS%rigid_sea_ice_mass) + mass_eff = (mass_ice - CS%rigid_sea_ice_mass)**2 / (mass_ice + CS%rigid_sea_ice_mass) endif forces%rigidity_ice_u(I,j) = forces%rigidity_ice_u(I,j) + Kv_rho_ice * mass_eff enddo ; enddo @@ -860,8 +859,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) mass_ice = min(forces%p_surf_full(i,j), forces%p_surf_full(i,j+1)) * I_GEarth mass_eff = 0.0 if (mass_ice > CS%rigid_sea_ice_mass) then - mass_eff = (mass_ice - CS%rigid_sea_ice_mass) **2 / & - (mass_ice + CS%rigid_sea_ice_mass) + mass_eff = (mass_ice - CS%rigid_sea_ice_mass)**2 / (mass_ice + CS%rigid_sea_ice_mass) endif forces%rigidity_ice_v(i,J) = forces%rigidity_ice_v(i,J) + Kv_rho_ice * mass_eff enddo ; enddo @@ -1077,8 +1075,8 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, "needed because the FMS coupling structure does not "//& "limit the water that can be frozen out of the ocean and "//& "the ice-ocean heat fluxes are treated explicitly. No "//& - "limit is applied if a negative value is used.", units="Pa", & - default=-1.0) + "limit is applied if a negative value is used.", & + units="Pa", default=-1.0, scale=US%kg_m3_to_R*US%m_s_to_L_T**2) call get_param(param_file, mdl, "ADJUST_NET_SRESTORE_TO_ZERO", & CS%adjust_net_srestore_to_zero, & "If true, adjusts the salinity restoring seen to zero "//& @@ -1097,7 +1095,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, call get_param(param_file, mdl, "USE_NET_FW_ADJUSTMENT_SIGN_BUG", & CS%use_net_FW_adjustment_sign_bug, & "If true, use the wrong sign for the adjustment to "//& - "the net fresh-water.", default=.false.) + "the net fresh-water.", default=.true.) call get_param(param_file, mdl, "ADJUST_NET_FRESH_WATER_BY_SCALING", & CS%adjust_net_fresh_water_by_scaling, & "If true, adjustments to net fresh water to achieve zero net are "//& @@ -1130,10 +1128,9 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, if (restore_salt) then call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & - "The constant that relates the restoring surface fluxes "//& - "to the relative surface anomalies (akin to a piston "//& - "velocity). Note the non-MKS units.", units="m day-1", scale=US%m_to_Z*US%T_to_s/86400.0, & - fail_if_missing=.true.) + "The constant that relates the restoring surface fluxes to the relative "//& + "surface anomalies (akin to a piston velocity). Note the non-MKS units.", & + default=0.0, units="m day-1", scale=US%m_to_Z*US%T_to_s/86400.0) call get_param(param_file, mdl, "SALT_RESTORE_FILE", CS%salt_restore_file, & "A file in which to find the surface salinity to use for restoring.", & default="salt_restore.nc") @@ -1176,10 +1173,9 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, if (restore_temp) then call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & - "The constant that relates the restoring surface fluxes "//& - "to the relative surface anomalies (akin to a piston "//& - "velocity). Note the non-MKS units.", units="m day-1", scale=US%m_to_Z*US%T_to_s / 86400.0, & - fail_if_missing=.true.) + "The constant that relates the restoring surface fluxes to the relative "//& + "surface anomalies (akin to a piston velocity). Note the non-MKS units.", & + default=0.0, units="m day-1", scale=US%m_to_Z*US%T_to_s/86400.0) call get_param(param_file, mdl, "SST_RESTORE_FILE", CS%temp_restore_file, & "A file in which to find the surface temperature to use for restoring.", & default="temp_restore.nc") @@ -1247,8 +1243,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, "If true, use a 2-dimensional gustiness supplied from "//& "an input file", default=.false.) call get_param(param_file, mdl, "GUST_CONST", CS%gust_const, & - "The background gustiness in the winds.", units="Pa", & - default=0.02) + "The background gustiness in the winds.", units="Pa", default=0.0) if (CS%read_gust_2d) then call get_param(param_file, mdl, "GUST_2D_FILE", gust_file, & "The file in which the wind gustiness is found in "//& @@ -1261,7 +1256,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, endif call get_param(param_file, mdl, "FIX_USTAR_GUSTLESS_BUG", CS%fix_ustar_gustless_bug, & "If true correct a bug in the time-averaging of the gustless wind friction velocity", & - default=.false.) + default=.true.) ! See whether sufficiently thick sea ice should be treated as rigid. call get_param(param_file, mdl, "USE_RIGID_SEA_ICE", CS%rigid_sea_ice, & @@ -1271,18 +1266,19 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, if (CS%rigid_sea_ice) then call get_param(param_file, mdl, "G_EARTH", CS%g_Earth, & "The gravitational acceleration of the Earth.", & - units="m s-2", default = 9.80) + 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, "SEA_ICE_MEAN_DENSITY", CS%density_sea_ice, & "A typical density of sea ice, used with the kinematic "//& - "viscosity, when USE_RIGID_SEA_ICE is true.", units="kg m-3", & - default=900.0) + "viscosity, when USE_RIGID_SEA_ICE is true.", & + units="kg m-3", default=900.0, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "SEA_ICE_VISCOSITY", CS%Kv_sea_ice, & "The kinematic viscosity of sufficiently thick sea ice "//& "for use in calculating the rigidity of sea ice.", & - units="m2 s-1", default=1.0e9) + units="m2 s-1", default=1.0e9, scale=US%Z_to_L**2*US%m_to_L**2*US%T_to_s) call get_param(param_file, mdl, "SEA_ICE_RIGID_MASS", CS%rigid_sea_ice_mass, & "The mass of sea-ice per unit area at which the sea-ice "//& - "starts to exhibit rigidity", units="kg m-2", default=1000.0) + "starts to exhibit rigidity", & + units="kg m-2", default=1000.0, scale=US%kg_m3_to_R*US%m_to_Z) endif call get_param(param_file, mdl, "ALLOW_ICEBERG_FLUX_DIAGNOSTICS", iceberg_flux_diags, & diff --git a/config_src/mct_driver/ocn_comp_mct.F90 b/config_src/mct_driver/ocn_comp_mct.F90 index b1ce9a60c0..741ce832e8 100644 --- a/config_src/mct_driver/ocn_comp_mct.F90 +++ b/config_src/mct_driver/ocn_comp_mct.F90 @@ -119,7 +119,9 @@ subroutine ocn_init_mct( EClock, cdata_o, x2o_o, o2x_o, NLFilename ) integer :: year, month, day, hour, minute, seconds, seconds_n, seconds_d, rc character(len=240) :: runid !< Run ID character(len=32) :: runtype !< Run type - character(len=240) :: restartfile !< Path/Name of restart file + character(len=512) :: restartfile !< Path/Name of restart file + character(len=2048) :: restartfiles !< Path/Name of restart files. + !! (same as restartfile if a single restart file is to be read in) integer :: nu !< i/o unit to read pointer file character(len=240) :: restart_pointer_file !< File name for restart pointer file character(len=240) :: restartpath !< Path of the restart file @@ -164,6 +166,7 @@ subroutine ocn_init_mct( EClock, cdata_o, x2o_o, o2x_o, NLFilename ) !logical :: lsend_precip_fact !< If T,send precip_fact to cpl for use in fw balance !! (partially-coupled option) character(len=128) :: err_msg !< Error message + integer :: iostat ! set the cdata pointers: call seq_cdata_setptrs(cdata_o, id=MOM_MCT_ID, mpicom=mpicom_ocn, & @@ -296,15 +299,27 @@ subroutine ocn_init_mct( EClock, cdata_o, x2o_o, o2x_o, NLFilename ) nu = shr_file_getUnit() restart_pointer_file = trim(glb%pointer_filename) if (is_root_pe()) write(glb%stdout,*) 'Reading ocn pointer file: ',restart_pointer_file + restartfile = ""; restartfiles = ""; open(nu, file=restart_pointer_file, form='formatted', status='unknown') - read(nu,'(a)') restartfile + do + read(nu,'(a)', iostat=iostat) restartfile + if (len(trim(restartfiles))>1 .and. iostat<0) then + exit ! done reading restart files list. + else if (iostat/=0) then + call MOM_error(FATAL, 'Error reading rpointer.ocn') + endif + ! check if the length of restartfiles variable is sufficient: + if (len(restartfiles)-len(trim(restartfiles)) < len(trim(restartfile))) then + call MOM_error(FATAL, "Restart file name(s) too long.") + endif + restartfiles = trim(restartfiles) // " " // trim(restartfile) + enddo close(nu) - !restartfile = trim(restartpath) // trim(restartfile) if (is_root_pe()) then - write(glb%stdout,*) 'Reading restart file: ',trim(restartfile) + write(glb%stdout,*) 'Reading restart file(s): ',trim(restartfiles) end if call shr_file_freeUnit(nu) - call ocean_model_init(glb%ocn_public, glb%ocn_state, time0, time_start, input_restart_file=trim(restartfile)) + call ocean_model_init(glb%ocn_public, glb%ocn_state, time0, time_start, input_restart_file=trim(restartfiles)) endif if (is_root_pe()) then write(glb%stdout,'(/12x,a/)') '======== COMPLETED MOM INITIALIZATION ========' @@ -434,6 +449,9 @@ subroutine ocn_run_mct( EClock, cdata_o, x2o_o, o2x_o) integer :: ocn_cpl_dt !< one ocn coupling interval in seconds. (to be received from cesm) real (kind=8) :: mom_cpl_dt !< one ocn coupling interval in seconds. (internal) integer :: ncouple_per_day !< number of ocean coupled call in one day (non-dim) + integer :: num_rest_files !< number of restart files written + integer :: i + character(len=8) :: suffix ! reset shr logging to ocn log file: if (is_root_pe()) then @@ -534,7 +552,8 @@ subroutine ocn_run_mct( EClock, cdata_o, x2o_o, o2x_o) write(restartname,'(A,".mom6.r.",I4.4,"-",I2.2,"-",I2.2,"-",I5.5)') trim(runid), year, month, day, seconds call save_restart(glb%ocn_state%dirs%restart_output_dir, glb%ocn_state%Time, glb%grid, & - glb%ocn_state%restart_CSp, .false., filename=restartname, GV=glb%ocn_state%GV) + glb%ocn_state%restart_CSp, .false., filename=restartname, GV=glb%ocn_state%GV, & + num_rest_files=num_rest_files) ! write name of restart file in the rpointer file nu = shr_file_getUnit() @@ -542,6 +561,19 @@ subroutine ocn_run_mct( EClock, cdata_o, x2o_o, o2x_o) restart_pointer_file = trim(glb%pointer_filename) open(nu, file=restart_pointer_file, form='formatted', status='unknown') write(nu,'(a)') trim(restartname) //'.nc' + + if (num_rest_files > 1) then + ! append i.th restart file name to rpointer + do i=1, num_rest_files-1 + if (i < 10) then + write(suffix,'("_",I1)') i + else + write(suffix,'("_",I2)') i + endif + write(nu,'(a)') trim(restartname) // trim(suffix) // '.nc' + enddo + endif + close(nu) write(glb%stdout,*) 'ocn restart pointer file written: ',trim(restartname) endif diff --git a/config_src/nuopc_driver/mom_cap.F90 b/config_src/nuopc_driver/mom_cap.F90 index 219245e473..c2a2e98838 100644 --- a/config_src/nuopc_driver/mom_cap.F90 +++ b/config_src/nuopc_driver/mom_cap.F90 @@ -15,7 +15,6 @@ module MOM_cap_mod use mpp_mod, only: stdlog, stdout, mpp_root_pe, mpp_clock_id use mpp_mod, only: mpp_clock_begin, mpp_clock_end, MPP_CLOCK_SYNC use mpp_mod, only: MPP_CLOCK_DETAILED, CLOCK_COMPONENT, MAXPES -use time_interp_external_mod, only: time_interp_external_init use time_manager_mod, only: set_calendar_type, time_type, increment_date use time_manager_mod, only: set_time, set_date, get_time, get_date, month_name use time_manager_mod, only: GREGORIAN, JULIAN, NOLEAP, THIRTY_DAY_MONTHS, NO_CALENDAR @@ -70,6 +69,11 @@ module MOM_cap_mod use ESMF, only: ESMF_MESHLOC_ELEMENT, ESMF_RC_VAL_OUTOFRANGE, ESMF_StateGet use ESMF, only: ESMF_TimePrint, ESMF_AlarmSet, ESMF_FieldGet, ESMF_Array use ESMF, only: ESMF_ArrayCreate +use ESMF, only: ESMF_RC_FILE_OPEN, ESMF_RC_FILE_READ, ESMF_RC_FILE_WRITE +use ESMF, only: ESMF_VMBroadcast +use ESMF, only: ESMF_AlarmCreate, ESMF_ClockGetAlarmList, ESMF_AlarmList_Flag +use ESMF, only: ESMF_AlarmGet, ESMF_AlarmIsCreated, ESMF_ALARMLIST_ALL, ESMF_AlarmIsEnabled +use ESMF, only: ESMF_STATEITEM_NOTFOUND, ESMF_FieldWrite use ESMF, only: operator(==), operator(/=), operator(+), operator(-) ! TODO ESMF_GridCompGetInternalState does not have an explicit Fortran interface. @@ -81,16 +85,17 @@ module MOM_cap_mod use NUOPC, only: NUOPC_Advertise, NUOPC_SetAttribute, NUOPC_IsUpdated, NUOPC_Write use NUOPC, only: NUOPC_IsConnected, NUOPC_Realize, NUOPC_CompAttributeSet use NUOPC_Model, only: NUOPC_ModelGet -use NUOPC_Model, & - model_routine_SS => SetServices, & - model_label_Advance => label_Advance, & - model_label_DataInitialize => label_DataInitialize, & - model_label_SetRunClock => label_SetRunClock, & - model_label_Finalize => label_Finalize +use NUOPC_Model, only: model_routine_SS => SetServices +use NUOPC_Model, only: model_label_Advance => label_Advance +use NUOPC_Model, only: model_label_DataInitialize => label_DataInitialize +use NUOPC_Model, only: model_label_SetRunClock => label_SetRunClock +use NUOPC_Model, only: model_label_Finalize => label_Finalize +use NUOPC_Model, only: SetVM implicit none; private public SetServices +public SetVM !> Internal state type with pointers to three types defined by MOM. type ocean_internalstate_type @@ -409,13 +414,6 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) return endif - call NUOPC_CompAttributeAdd(gcomp, & - attrList=(/'RestartFileToRead', 'RestartFileToWrite'/), rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - end subroutine !> Called by NUOPC to advertise import and export fields. "Advertise" @@ -462,7 +460,12 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) logical :: isPresent, isPresentDiro, isPresentLogfile, isSet logical :: existflag integer :: userRc + integer :: localPet + integer :: iostat + integer :: readunit character(len=512) :: restartfile ! Path/Name of restart file + character(len=2048) :: restartfiles ! Path/Name of restart files + ! (same as restartfile if single restart file) character(len=*), parameter :: subname='(MOM_cap:InitializeAdvertise)' character(len=32) :: calendar !-------------------------------- @@ -652,57 +655,58 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) return endif - restartfile = "" + restartfile = ""; restartfiles = "" if (runtype == "initial") then - ! startup (new run) - 'n' is needed below if we don't specify input_filename in input.nml - restartfile = "n" - else if (runtype == "continue") then ! hybrid or branch or continuos runs - ! optionally call into system-specific implementation to get restart file name - call ESMF_MethodExecute(gcomp, label="GetRestartFileToRead", & - existflag=existflag, userRc=userRc, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg="Error executing user method to get restart filename", & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - if (ESMF_LogFoundError(rcToCheck=userRc, msg="Error in method to get restart filename", & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - if (existflag) then - call ESMF_LogWrite('MOM_cap: called user GetRestartFileToRead', ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - endif + restartfiles = "n" - call NUOPC_CompAttributeGet(gcomp, name='RestartFileToRead', & - value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - if (isPresent .and. isSet) then - restartfile = trim(cvalue) - call ESMF_LogWrite('MOM_cap: RestartFileToRead = '//trim(restartfile), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - else - call ESMF_LogWrite('MOM_cap: restart requested, no RestartFileToRead attribute provided-will use input.nml',& - ESMF_LOGMSG_WARNING, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - endif + else if (runtype == "continue") then ! hybrid or branch or continuos runs + + if (cesm_coupled) then + call ESMF_LogWrite('MOM_cap: restart requested, using rpointer.ocn', ESMF_LOGMSG_WARNING) + call ESMF_GridCompGet(gcomp, vm=vm, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + call ESMF_VMGet(vm, localPet=localPet, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + + if (localPet == 0) then + ! this hard coded for rpointer.ocn right now + open(newunit=readunit, file='rpointer.ocn', form='formatted', status='old', iostat=iostat) + if (iostat /= 0) then + call ESMF_LogSetError(ESMF_RC_FILE_OPEN, msg=subname//' ERROR opening rpointer.ocn', & + line=__LINE__, file=u_FILE_u, rcToReturn=rc) + return + endif + do + read(readunit,'(a)', iostat=iostat) restartfile + if (iostat /= 0) then + if (len(trim(restartfiles))>1 .and. iostat<0) then + exit ! done reading restart files list. + else + call ESMF_LogSetError(ESMF_RC_FILE_READ, msg=subname//' ERROR reading rpointer.ocn', & + line=__LINE__, file=u_FILE_u, rcToReturn=rc) + return + endif + endif + ! check if the length of restartfiles variable is sufficient: + if (len(restartfiles)-len(trim(restartfiles)) < len(trim(restartfile))) then + call MOM_error(FATAL, "Restart file name(s) too long.") + endif + restartfiles = trim(restartfiles) // " " // trim(restartfile) + enddo + close(readunit) + endif + ! broadcast attribute set on master task to all tasks + call ESMF_VMBroadcast(vm, restartfiles, count=len(restartfiles), rootPet=0, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + else + call ESMF_LogWrite('MOM_cap: restart requested, use input.nml', ESMF_LOGMSG_WARNING) + endif endif ocean_public%is_ocean_pe = .true. - call ocean_model_init(ocean_public, ocean_state, time0, time_start, input_restart_file=trim(restartfile)) + call ocean_model_init(ocean_public, ocean_state, time0, time_start, input_restart_file=trim(restartfiles)) call ocean_model_init_sfc(ocean_state, ocean_public) @@ -1475,12 +1479,17 @@ subroutine DataInitialize(gcomp, rc) ! local variables type(ESMF_Clock) :: clock type(ESMF_State) :: importState, exportState + type(ESMF_Time) :: currTime + type(ESMF_TimeInterval) :: timeStep + type(ESMF_StateItem_Flag) :: itemType type (ocean_public_type), pointer :: ocean_public => NULL() type (ocean_state_type), pointer :: ocean_state => NULL() type(ice_ocean_boundary_type), pointer :: Ice_ocean_boundary => NULL() type(ocean_internalstate_wrapper) :: ocean_internalstate type(ocean_grid_type), pointer :: ocean_grid character(240) :: msgString + character(240) :: fldname + character(240) :: timestr integer :: fieldCount, n type(ESMF_Field) :: field character(len=64),allocatable :: fieldNameList(:) @@ -1494,6 +1503,11 @@ subroutine DataInitialize(gcomp, rc) file=__FILE__)) & return ! bail out + call ESMF_ClockGet(clock, currTime=currTime, timeStep=timeStep, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + call ESMF_TimeGet(currTime, timestring=timestr, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + call ESMF_GridCompGetInternalState(gcomp, ocean_internalstate, rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & line=__LINE__, & @@ -1542,7 +1556,6 @@ subroutine DataInitialize(gcomp, rc) ! check whether all Fields in the exportState are "Updated" if (NUOPC_IsUpdated(exportState)) then call NUOPC_CompAttributeSet(gcomp, name="InitializeDataComplete", value="true", rc=rc) - call ESMF_LogWrite("MOM6 - Initialize-Data-Dependency SATISFIED!!!", ESMF_LOGMSG_INFO, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & line=__LINE__, & @@ -1551,12 +1564,20 @@ subroutine DataInitialize(gcomp, rc) endif if(write_diagnostics) then - call NUOPC_Write(exportState, fileNamePrefix='field_init_ocn_export_', & - overwrite=overwrite_timeslice,timeslice=import_slice, relaxedFlag=.true., rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + do n = 1,fldsFrOcn_num + fldname = fldsFrOcn(n)%shortname + call ESMF_StateGet(exportState, itemName=trim(fldname), itemType=itemType, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + if (itemType /= ESMF_STATEITEM_NOTFOUND) then + call ESMF_StateGet(exportState, itemName=trim(fldname), field=field, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + call ESMF_FieldWrite(field, fileName='field_init_ocn_export_'//trim(timestr)//'.nc', & + timeslice=1, overwrite=overwrite_timeslice, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + endif + enddo endif end subroutine DataInitialize @@ -1574,13 +1595,15 @@ subroutine ModelAdvance(gcomp, rc) logical :: existflag, isPresent, isSet logical :: do_advance = .true. type(ESMF_Clock) :: clock!< ESMF Clock class definition - type(ESMF_Alarm) :: alarm + type(ESMF_Alarm) :: restart_alarm, stop_alarm type(ESMF_State) :: importState, exportState type(ESMF_Time) :: currTime type(ESMF_TimeInterval) :: timeStep type(ESMF_Time) :: startTime type(ESMF_TimeInterval) :: time_elapsed integer(ESMF_KIND_I8) :: n_interval, time_elapsed_sec + type(ESMF_Field) :: lfield + type(ESMF_StateItem_Flag) :: itemType character(len=64) :: timestamp type (ocean_public_type), pointer :: ocean_public => NULL() type (ocean_state_type), pointer :: ocean_state => NULL() @@ -1596,7 +1619,17 @@ subroutine ModelAdvance(gcomp, rc) integer :: seconds, day, year, month, hour, minute character(ESMF_MAXSTR) :: restartname, cvalue character(240) :: msgString + character(ESMF_MAXSTR) :: casename + integer :: iostat + integer :: writeunit + integer :: localPet + type(ESMF_VM) :: vm + integer :: n, i + character(240) :: import_timestr, export_timestr + character(len=128) :: fldname character(len=*),parameter :: subname='(MOM_cap:ModelAdvance)' + character(len=8) :: suffix + integer :: num_rest_files rc = ESMF_SUCCESS if(profile_memory) call ESMF_VMLogMemInfo("Entering MOM Model_ADVANCE: ") @@ -1644,6 +1677,9 @@ subroutine ModelAdvance(gcomp, rc) file=__FILE__)) & return ! bail out + call ESMF_TimeGet(currTime, timestring=import_timestr, rc=rc) + call ESMF_TimeGet(currTime+timestep, timestring=export_timestr, rc=rc) + Time_step_coupled = esmf2fms_time(timeStep) Time = esmf2fms_time(currTime) @@ -1705,13 +1741,20 @@ subroutine ModelAdvance(gcomp, rc) !--------------- if (write_diagnostics) then - call NUOPC_Write(importState, fileNamePrefix='field_ocn_import_', & - overwrite=overwrite_timeslice,timeslice=import_slice, relaxedFlag=.true., rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - import_slice = import_slice + 1 + do n = 1,fldsToOcn_num + fldname = fldsToOcn(n)%shortname + call ESMF_StateGet(importState, itemName=trim(fldname), itemType=itemType, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + if (itemType /= ESMF_STATEITEM_NOTFOUND) then + call ESMF_StateGet(importState, itemName=trim(fldname), field=lfield, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + call ESMF_FieldWrite(lfield, fileName='field_ocn_import_'//trim(import_timestr)//'.nc', & + timeslice=1, overwrite=overwrite_timeslice, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + endif + enddo endif !--------------- @@ -1751,109 +1794,107 @@ subroutine ModelAdvance(gcomp, rc) endif !--------------- - ! If restart alarm is ringing - write restart file + ! Get the stop alarm + !--------------- + + call ESMF_ClockGetAlarm(clock, alarmname='stop_alarm', alarm=stop_alarm, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out + + !--------------- + ! If restart alarm exists and is ringing - write restart file !--------------- - call ESMF_ClockGetAlarm(clock, alarmname='alarm_restart', alarm=alarm, rc=rc) + call ESMF_ClockGetAlarm(clock, alarmname='restart_alarm', alarm=restart_alarm, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & line=__LINE__, & file=__FILE__)) & return ! bail out - if (ESMF_AlarmIsRinging(alarm, rc=rc)) then - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - call ESMF_AlarmRingerOff(alarm, rc=rc ) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_AlarmIsRinging(restart_alarm, rc=rc)) then + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out - ! call into system specific method to get desired restart filename - restartname = "" - call ESMF_MethodExecute(gcomp, label="GetRestartFileToWrite", & - existflag=existflag, userRc=userRc, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg="Error executing user method to get restart filename", & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + ! turn off the alarm + call ESMF_AlarmRingerOff(restart_alarm, rc=rc ) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out - if (ESMF_LogFoundError(rcToCheck=userRc, msg="Error in method to get restart filename", & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - if (existflag) then - call ESMF_LogWrite("MOM_cap: called user GetRestartFileToWrite method", ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - call NUOPC_CompAttributeGet(gcomp, name='RestartFileToWrite', & - isPresent=isPresent, isSet=isSet, value=cvalue, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - if (isPresent .and. isSet) then - restartname = trim(cvalue) - call ESMF_LogWrite("MOM_cap: User RestartFileToWrite: "//trim(restartname), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + ! determine restart filename + call ESMF_ClockGetNextTime(clock, MyTime, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out + call ESMF_TimeGet (MyTime, yy=year, mm=month, dd=day, h=hour, m=minute, s=seconds, rc=rc ) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out + if (cesm_coupled) then + call NUOPC_CompAttributeGet(gcomp, name='case_name', value=casename, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + call ESMF_GridCompGet(gcomp, vm=vm, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + call ESMF_VMGet(vm, localPet=localPet, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + + write(restartname,'(A,".mom6.r.",I4.4,"-",I2.2,"-",I2.2,"-",I5.5)') & + trim(casename), year, month, day, seconds + + call ESMF_LogWrite("MOM_cap: Writing restart : "//trim(restartname), ESMF_LOGMSG_INFO, rc=rc) + + ! write restart file(s) + call ocean_model_restart(ocean_state, restartname=restartname, num_rest_files=num_rest_files) + + if (localPet == 0) then + ! Write name of restart file in the rpointer file - this is currently hard-coded for the ocean + open(newunit=writeunit, file='rpointer.ocn', form='formatted', status='unknown', iostat=iostat) + if (iostat /= 0) then + call ESMF_LogSetError(ESMF_RC_FILE_OPEN, & + msg=subname//' ERROR opening rpointer.ocn', line=__LINE__, file=u_FILE_u, rcToReturn=rc) + return + endif + write(writeunit,'(a)') trim(restartname)//'.nc' + + if (num_rest_files > 1) then + ! append i.th restart file name to rpointer + do i=1, num_rest_files-1 + if (i < 10) then + write(suffix,'("_",I1)') i + else + write(suffix,'("_",I2)') i + endif + write(writeunit,'(a)') trim(restartname) // trim(suffix) // '.nc' + enddo + endif + + close(writeunit) endif - endif + else + ! write the final restart without a timestamp + if (ESMF_AlarmIsRinging(stop_alarm, rc=rc)) then + write(restartname,'(A)')"MOM.res" + else + write(restartname,'(A,I4.4,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2)') & + "MOM.res.", year, month, day, hour, minute, seconds + endif - if (len_trim(restartname) == 0) then - ! none provided, so use a default restart filename - call ESMF_ClockGetNextTime(clock, MyTime, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - call ESMF_TimeGet (MyTime, yy=year, mm=month, dd=day, & - h=hour, m=minute, s=seconds, rc=rc ) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - write(restartname,'(A,".mom6.r.",I4.4,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2)') & - "ocn", year, month, day, hour, minute, seconds - call ESMF_LogWrite("MOM_cap: Using default restart filename: "//trim(restartname), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - endif + call ESMF_LogWrite("MOM_cap: Writing restart : "//trim(restartname), ESMF_LOGMSG_INFO, rc=rc) - ! TODO: address if this requirement is being met for the DA group - ! Optionally write restart files when currTime-startTime is integer multiples of restart_interval - ! if (restart_interval > 0 ) then - ! time_elapsed = currTime - startTime - ! call ESMF_TimeIntervalGet(time_elapsed, s_i8=time_elapsed_sec, rc=rc) - ! if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - ! line=__LINE__, & - ! file=__FILE__)) & - ! return ! bail out - ! n_interval = time_elapsed_sec / restart_interval - ! if ((n_interval .gt. 0) .and. (n_interval*restart_interval == time_elapsed_sec)) then - ! time_restart_current = esmf2fms_time(currTime) - ! timestamp = date_to_string(time_restart_current) - ! call ESMF_LogWrite("MOM: Writing restart at "//trim(timestamp), ESMF_LOGMSG_INFO, rc=rc) - ! write(*,*) 'calling ocean_model_restart' - ! call ocean_model_restart(ocean_state, timestamp) - ! endif - ! endif - - ! write restart file(s) - call ocean_model_restart(ocean_state, restartname=restartname) - - if (is_root_pe()) then - write(logunit,*) subname//' writing restart file ',trim(restartname) - endif + ! write restart file(s) + call ocean_model_restart(ocean_state, restartname=restartname) + end if + + if (is_root_pe()) then + write(logunit,*) subname//' writing restart file ',trim(restartname) + endif endif !--------------- @@ -1861,13 +1902,20 @@ subroutine ModelAdvance(gcomp, rc) !--------------- if (write_diagnostics) then - call NUOPC_Write(exportState, fileNamePrefix='field_ocn_export_', & - overwrite=overwrite_timeslice,timeslice=export_slice, relaxedFlag=.true., rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - export_slice = export_slice + 1 + do n = 1,fldsFrOcn_num + fldname = fldsFrOcn(n)%shortname + call ESMF_StateGet(exportState, itemName=trim(fldname), itemType=itemType, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + if (itemType /= ESMF_STATEITEM_NOTFOUND) then + call ESMF_StateGet(exportState, itemName=trim(fldname), field=lfield, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + call ESMF_FieldWrite(lfield, fileName='field_ocn_export_'//trim(export_timestr)//'.nc', & + timeslice=1, overwrite=overwrite_timeslice, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + endif + enddo endif if(profile_memory) call ESMF_VMLogMemInfo("Leaving MOM Model_ADVANCE: ") @@ -1882,17 +1930,19 @@ subroutine ModelSetRunClock(gcomp, rc) ! local variables type(ESMF_Clock) :: mclock, dclock type(ESMF_Time) :: mcurrtime, dcurrtime - type(ESMF_Time) :: mstoptime + type(ESMF_Time) :: mstoptime, dstoptime type(ESMF_TimeInterval) :: mtimestep, dtimestep character(len=128) :: mtimestring, dtimestring character(len=256) :: cvalue character(len=256) :: restart_option ! Restart option units integer :: restart_n ! Number until restart interval integer :: restart_ymd ! Restart date (YYYYMMDD) - type(ESMF_ALARM) :: restart_alarm + type(ESMF_Alarm) :: restart_alarm + type(ESMF_Alarm) :: stop_alarm logical :: isPresent, isSet logical :: first_time = .true. character(len=*),parameter :: subname='MOM_cap:(ModelSetRunClock) ' + character(len=256) :: timestr !-------------------------------- rc = ESMF_SUCCESS @@ -1904,7 +1954,8 @@ subroutine ModelSetRunClock(gcomp, rc) file=__FILE__)) & return ! bail out - call ESMF_ClockGet(dclock, currTime=dcurrtime, timeStep=dtimestep, rc=rc) + call ESMF_ClockGet(dclock, currTime=dcurrtime, timeStep=dtimestep, & + stopTime=dstoptime, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & line=__LINE__, & file=__FILE__)) & @@ -1960,33 +2011,66 @@ subroutine ModelSetRunClock(gcomp, rc) restart_n = 0 restart_ymd = 0 - call NUOPC_CompAttributeGet(gcomp, name="restart_option", isPresent=isPresent, & - isSet=isSet, value=restart_option, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - if (isPresent .and. isSet) then - call NUOPC_CompAttributeGet(gcomp, name="restart_n", value=cvalue, & - isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (cesm_coupled) then + + call NUOPC_CompAttributeGet(gcomp, name="restart_option", value=restart_option, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + + ! If restart_option is set then must also have set either restart_n or restart_ymd + call NUOPC_CompAttributeGet(gcomp, name="restart_n", value=cvalue, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return if (isPresent .and. isSet) then read(cvalue,*) restart_n endif call NUOPC_CompAttributeGet(gcomp, name="restart_ymd", value=cvalue, & isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return if (isPresent .and. isSet) then read(cvalue,*) restart_ymd endif + if (restart_n == 0 .and. restart_ymd == 0) then + call ESMF_LogSetError(ESMF_RC_VAL_WRONG, & + msg=subname//": ERROR both restart_n and restart_ymd are zero for restart_option set ", & + line=__LINE__, file=__FILE__, rcToReturn=rc) + return + endif + call ESMF_LogWrite(subname//" Set restart option = "//restart_option, ESMF_LOGMSG_INFO) + else - restart_option = "none" + call NUOPC_CompAttributeGet(gcomp, name="restart_n", value=cvalue, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return + + ! If restart_option is set then must also have set either restart_n or restart_ymd + if (isPresent .and. isSet) then + call ESMF_LogWrite(subname//" Restart_n = "//trim(cvalue), ESMF_LOGMSG_INFO, rc=rc) + read(cvalue,*) restart_n + if(restart_n /= 0)then + call NUOPC_CompAttributeGet(gcomp, name="restart_option", value=cvalue, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return + if (isPresent .and. isSet) then + read(cvalue,*) restart_option + call ESMF_LogWrite(subname//" Restart_option = "//restart_option, & + ESMF_LOGMSG_INFO, rc=rc) + endif + + call NUOPC_CompAttributeGet(gcomp, name="restart_ymd", value=cvalue, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return + if (isPresent .and. isSet) then + read(cvalue,*) restart_ymd + call ESMF_LogWrite(subname//" Restart_ymd = "//trim(cvalue), ESMF_LOGMSG_INFO, rc=rc) + endif + else + restart_option = 'none' + call ESMF_LogWrite(subname//" Set restart option = "//restart_option, ESMF_LOGMSG_INFO, rc=rc) + endif + endif endif call AlarmInit(mclock, & @@ -1995,7 +2079,7 @@ subroutine ModelSetRunClock(gcomp, rc) opt_n = restart_n, & opt_ymd = restart_ymd, & RefTime = mcurrTime, & - alarmname = 'alarm_restart', rc=rc) + alarmname = 'restart_alarm', rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & line=__LINE__, & file=__FILE__)) & @@ -2006,14 +2090,18 @@ subroutine ModelSetRunClock(gcomp, rc) line=__LINE__, & file=__FILE__)) & return ! bail out - first_time = .false. + call ESMF_LogWrite(subname//" Restart alarm is Created and Set", ESMF_LOGMSG_INFO, rc=rc) - call ESMF_LogWrite(subname//" Set restart option = "//restart_option, & - ESMF_LOGMSG_INFO, rc=rc) + ! create a 1-shot alarm at the driver stop time + stop_alarm = ESMF_AlarmCreate(mclock, ringtime=dstopTime, name = "stop_alarm", rc=rc) + call ESMF_LogWrite(subname//" Create Stop alarm", ESMF_LOGMSG_INFO, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + line=__LINE__, file=__FILE__)) return + + call ESMF_TimeGet(dstoptime, timestring=timestr, rc=rc) + call ESMF_LogWrite("Stop Alarm will ring at : "//trim(timestr), ESMF_LOGMSG_INFO, rc=rc) + + first_time = .false. endif @@ -2054,7 +2142,12 @@ subroutine ocean_model_finalize(gcomp, rc) type(TIME_TYPE) :: Time type(ESMF_Clock) :: clock type(ESMF_Time) :: currTime + type(ESMF_Alarm), allocatable :: alarmList(:) + integer :: alarmCount character(len=64) :: timestamp + character(len=64) :: alarm_name + logical :: write_restart + integer :: i character(len=*),parameter :: subname='(MOM_cap:ocean_model_finalize)' write(*,*) 'MOM: --- finalize called ---' @@ -2082,11 +2175,25 @@ subroutine ocean_model_finalize(gcomp, rc) return ! bail out Time = esmf2fms_time(currTime) - if (cesm_coupled) then - call ocean_model_end(ocean_public, ocean_State, Time, write_restart=.false.) - else - call ocean_model_end(ocean_public, ocean_State, Time, write_restart=.true.) - endif + ! Check if the clock has a restart alarm - and if it does do not write a restart + call ESMF_ClockGet(clock, alarmCount=alarmCount, rc = rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return + + allocate(alarmList(1:alarmCount)) + call ESMF_ClockGetAlarmList(clock, alarmlistflag=ESMF_ALARMLIST_ALL, alarmList=alarmList, rc = rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return + + write_restart = .true. + do i = 1,alarmCount + call ESMF_AlarmGet(alarmlist(i), name=alarm_name, rc = rc) + if(trim(alarm_name) == 'restart_alarm' .and. ESMF_AlarmIsEnabled(alarmlist(i), rc=rc))write_restart = .false. + enddo + deallocate(alarmList) + + if(write_restart)call ESMF_LogWrite("No Restart Alarm, writing restart at Finalize ", ESMF_LOGMSG_INFO, rc=rc) + call ocean_model_end(ocean_public, ocean_State, Time, write_restart=write_restart) call field_manager_end() call fms_io_exit() diff --git a/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 b/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 index ffbe73881a..1ba3484ef9 100644 --- a/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 +++ b/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 @@ -39,6 +39,7 @@ module MOM_ocean_model_nuopc use MOM_time_manager, only : operator(+), operator(-), operator(*), operator(/) use MOM_time_manager, only : operator(/=), operator(<=), operator(>=) use MOM_time_manager, only : operator(<), real_to_time_type, time_type_to_real +use time_interp_external_mod,only : time_interp_external_init use MOM_tracer_flow_control, only : call_tracer_register, tracer_flow_control_init use MOM_tracer_flow_control, only : call_tracer_flux_init use MOM_unit_scaling, only : unit_scale_type @@ -267,6 +268,8 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i OS%is_ocean_pe = Ocean_sfc%is_ocean_pe if (.not.OS%is_ocean_pe) return + call time_interp_external_init + OS%Time = Time_in call initialize_MOM(OS%Time, Time_init, param_file, OS%dirs, OS%MOM_CSp, & OS%restart_CSp, Time_in, offline_tracer_mode=OS%offline_tracer_mode, & @@ -668,7 +671,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & end subroutine update_ocean_model !> This subroutine writes out the ocean model restart file. -subroutine ocean_model_restart(OS, timestamp, restartname) +subroutine ocean_model_restart(OS, timestamp, restartname, num_rest_files) type(ocean_state_type), pointer :: OS !< A pointer to the structure containing the !! internal ocean state being saved to a restart file character(len=*), optional, intent(in) :: timestamp !< An optional timestamp string that should be @@ -676,6 +679,7 @@ subroutine ocean_model_restart(OS, timestamp, restartname) character(len=*), optional, intent(in) :: restartname !< Name of restart file to use !! This option distinguishes the cesm interface from the !! non-cesm interface + integer, optional, intent(out) :: num_rest_files !< number of restart files written if (.not.MOM_state_is_synchronized(OS%MOM_CSp)) & call MOM_error(WARNING, "End of MOM_main reached with inconsistent "//& @@ -687,7 +691,7 @@ subroutine ocean_model_restart(OS, timestamp, restartname) if (present(restartname)) then call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, GV=OS%GV, filename=restartname) + OS%restart_CSp, GV=OS%GV, filename=restartname, num_rest_files=num_rest_files) call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & OS%dirs%restart_output_dir) ! Is this needed? if (OS%use_ice_shelf) then @@ -889,52 +893,52 @@ subroutine convert_state_to_ocean_type(sfc_state, Ocean_sfc, G, US, patm, press_ if (present(patm)) then do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%sea_lev(i,j) = sfc_state%sea_lev(i+i0,j+j0) + patm(i,j) * press_to_z - Ocean_sfc%area(i,j) = US%L_to_m**2*G%areaT(i+i0,j+j0) + Ocean_sfc%sea_lev(i,j) = US%Z_to_m * sfc_state%sea_lev(i+i0,j+j0) + patm(i,j) * press_to_z + Ocean_sfc%area(i,j) = US%L_to_m**2 * G%areaT(i+i0,j+j0) enddo ; enddo else do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%sea_lev(i,j) = sfc_state%sea_lev(i+i0,j+j0) - Ocean_sfc%area(i,j) = US%L_to_m**2*G%areaT(i+i0,j+j0) + Ocean_sfc%sea_lev(i,j) = US%Z_to_m * sfc_state%sea_lev(i+i0,j+j0) + Ocean_sfc%area(i,j) = US%L_to_m**2 * G%areaT(i+i0,j+j0) enddo ; enddo endif if (allocated(sfc_state%frazil)) then do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%frazil(i,j) = sfc_state%frazil(i+i0,j+j0) + Ocean_sfc%frazil(i,j) = US%Q_to_J_kg*US%RZ_to_kg_m2 * sfc_state%frazil(i+i0,j+j0) enddo ; enddo endif if (allocated(sfc_state%melt_potential)) then do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%melt_potential(i,j) = sfc_state%melt_potential(i+i0,j+j0) + Ocean_sfc%melt_potential(i,j) = US%Q_to_J_kg*US%RZ_to_kg_m2 * sfc_state%melt_potential(i+i0,j+j0) enddo ; enddo endif if (allocated(sfc_state%Hml)) then do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%OBLD(i,j) = sfc_state%Hml(i+i0,j+j0) + Ocean_sfc%OBLD(i,j) = US%Z_to_m * sfc_state%Hml(i+i0,j+j0) enddo ; enddo endif if (Ocean_sfc%stagger == AGRID) then do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%u_surf(i,j) = G%mask2dT(i+i0,j+j0) * & + Ocean_sfc%u_surf(i,j) = G%mask2dT(i+i0,j+j0) * US%L_T_to_m_s * & 0.5*(sfc_state%u(I+i0,j+j0)+sfc_state%u(I-1+i0,j+j0)) - Ocean_sfc%v_surf(i,j) = G%mask2dT(i+i0,j+j0) * & + Ocean_sfc%v_surf(i,j) = G%mask2dT(i+i0,j+j0) * US%L_T_to_m_s * & 0.5*(sfc_state%v(i+i0,J+j0)+sfc_state%v(i+i0,J-1+j0)) enddo ; enddo elseif (Ocean_sfc%stagger == BGRID_NE) then do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%u_surf(i,j) = G%mask2dBu(I+i0,J+j0) * & + Ocean_sfc%u_surf(i,j) = G%mask2dBu(I+i0,J+j0) * US%L_T_to_m_s * & 0.5*(sfc_state%u(I+i0,j+j0)+sfc_state%u(I+i0,j+j0+1)) - Ocean_sfc%v_surf(i,j) = G%mask2dBu(I+i0,J+j0) * & + Ocean_sfc%v_surf(i,j) = G%mask2dBu(I+i0,J+j0) * US%L_T_to_m_s * & 0.5*(sfc_state%v(i+i0,J+j0)+sfc_state%v(i+i0+1,J+j0)) enddo ; enddo elseif (Ocean_sfc%stagger == CGRID_NE) then do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%u_surf(i,j) = G%mask2dCu(I+i0,j+j0)*sfc_state%u(I+i0,j+j0) - Ocean_sfc%v_surf(i,j) = G%mask2dCv(i+i0,J+j0)*sfc_state%v(i+i0,J+j0) + Ocean_sfc%u_surf(i,j) = G%mask2dCu(I+i0,j+j0) * US%L_T_to_m_s * sfc_state%u(I+i0,j+j0) + Ocean_sfc%v_surf(i,j) = G%mask2dCv(i+i0,J+j0) * US%L_T_to_m_s * sfc_state%v(i+i0,J+j0) enddo ; enddo else write(val_str, '(I8)') Ocean_sfc%stagger diff --git a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 index dea2ce1284..3d49c66ce6 100644 --- a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 +++ b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 @@ -69,9 +69,9 @@ module MOM_surface_forcing_nuopc real :: latent_heat_fusion !< latent heat of fusion [J/kg] real :: latent_heat_vapor !< latent heat of vaporization [J/kg] - real :: max_p_surf !< maximum surface pressure that can be - !! exerted by the atmosphere and floating sea-ice, - !! in Pa. This is needed because the FMS coupling + real :: max_p_surf !< maximum surface pressure that can be exerted by the + !! atmosphere and floating sea-ice [R L2 T-2 ~> Pa]. + !! This is needed because the FMS coupling !! structure does not limit the water that can be !! frozen out of the ocean and the ice-ocean heat !! fluxes are treated explicitly. @@ -98,14 +98,14 @@ module MOM_surface_forcing_nuopc logical :: rigid_sea_ice !< If true, sea-ice exerts a rigidity that acts !! to damp surface deflections (especially surface !! gravity waves). The default is false. - real :: G_Earth !< Gravitational acceleration [m s-2] - real :: Kv_sea_ice !! viscosity in sea-ice that resists sheared vertical motions [m2 s-1] - real :: density_sea_ice !< typical density of sea-ice [kg m-3]. The value is + real :: g_Earth !< Gravitational acceleration [L2 Z-1 T-2 ~> m s-2] + real :: Kv_sea_ice !< Viscosity in sea-ice that resists sheared vertical motions [L4 Z-2 T-1 ~> m2 s-1] + real :: density_sea_ice !< Typical density of sea-ice [R ~> kg m-3]. The value is !! only used to convert the ice pressure into !! appropriate units for use with Kv_sea_ice. real :: rigid_sea_ice_mass !< A mass per unit area of sea-ice beyond which - !! sea-ice viscosity becomes effective, in kg m-2, - !! typically of order 1000 [kg m-2]. + !! sea-ice viscosity becomes effective [R Z ~> kg m-2], + !! typically of order 1000 kg m-2. logical :: allow_flux_adjustments !< If true, use data_override to obtain flux adjustments logical :: liquid_runoff_from_data !< If true, use data_override to obtain liquid runoff @@ -117,7 +117,7 @@ module MOM_surface_forcing_nuopc logical :: use_net_FW_adjustment_sign_bug !< use the wrong sign when adjusting net FW logical :: adjust_net_fresh_water_by_scaling !< adjust net surface fresh-water w/o moving zero contour logical :: mask_srestore_under_ice !< If true, use an ice mask defined by frazil - !< criteria for salinity restoring. + !! criteria for salinity restoring. real :: ice_salt_concentration !< salt concentration for sea ice [kg/kg] logical :: mask_srestore_marginal_seas !< if true, then mask SSS restoring in marginal seas real :: max_delta_srestore !< maximum delta salinity used for restoring @@ -461,7 +461,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, fluxes%area_berg(i,j) = IOB%area_berg(i-i0,j-j0) * G%mask2dT(i,j) if (associated(IOB%mass_berg)) & - fluxes%mass_berg(i,j) = IOB%mass_berg(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%mass_berg(i,j) = US%m_to_Z*US%kg_m3_to_R * IOB%mass_berg(i-i0,j-j0) * G%mask2dT(i,j) if (associated(IOB%lrunoff_hflx)) & fluxes%heat_content_lrunoff(i,j) = US%W_m2_to_QRZ_T * IOB%lrunoff_hflx(i-i0,j-j0) * G%mask2dT(i,j) @@ -524,12 +524,12 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, if (associated(IOB%p)) then if (CS%max_p_surf >= 0.0) then do j=js,je ; do i=is,ie - fluxes%p_surf_full(i,j) = G%mask2dT(i,j) * IOB%p(i-i0,j-j0) + fluxes%p_surf_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) fluxes%p_surf(i,j) = MIN(fluxes%p_surf_full(i,j),CS%max_p_surf) enddo; enddo else do j=js,je ; do i=is,ie - fluxes%p_surf_full(i,j) = G%mask2dT(i,j) * IOB%p(i-i0,j-j0) + fluxes%p_surf_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) fluxes%p_surf(i,j) = fluxes%p_surf_full(i,j) enddo; enddo endif @@ -608,7 +608,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) tauy_at_q !< Meridional wind stresses at q points [Pa] real, dimension(SZI_(G),SZJ_(G)) :: & - rigidity_at_h, & !< Ice rigidity at tracer points (m3 s-1) + rigidity_at_h, & !< Ice rigidity at tracer points [L4 Z-1 T-1 ~> m3 s-1] taux_at_h, & !< Zonal wind stresses at h points [Pa] tauy_at_h !< Meridional wind stresses at h points [Pa] @@ -618,10 +618,10 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) real :: tau_mag !< magnitude of the wind stress [R Z L T-2 ~> Pa] real :: Pa_conversion ! A unit conversion factor from Pa to the internal wind stress units [R Z L T-2 Pa-1 ~> 1] real :: stress_conversion ! A unit conversion factor from Pa times any stress multiplier [R Z L T-2 Pa-1 ~> 1] - real :: I_GEarth !< 1.0 / G_Earth [s2 m-1] - real :: Kv_rho_ice !< (CS%kv_sea_ice / CS%density_sea_ice) ( m^5/(s*kg) ) - real :: mass_ice !< mass of sea ice at a face (kg/m^2) - real :: mass_eff !< effective mass of sea ice for rigidity (kg/m^2) + real :: I_GEarth !< The inverse of the gravitational acceleration [T2 Z L-2 ~> s2 m-1] + real :: Kv_rho_ice !< (CS%Kv_sea_ice / CS%density_sea_ice) [L4 Z-2 T-1 R-1 ~> m5 s-1 kg-1] + real :: mass_ice !< mass of sea ice at a face [R Z ~> kg m-2] + real :: mass_eff !< effective mass of sea ice for rigidity [R Z ~> kg m-2] integer :: wind_stagger !< AGRID, BGRID_NE, or CGRID_NE (integers from MOM_domains) integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq, i0, j0 @@ -682,12 +682,12 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) if (associated(IOB%p)) then if (CS%max_p_surf >= 0.0) then do j=js,je ; do i=is,ie - forces%p_surf_full(i,j) = G%mask2dT(i,j) * IOB%p(i-i0,j-j0) + forces%p_surf_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) forces%p_surf(i,j) = MIN(forces%p_surf_full(i,j),CS%max_p_surf) enddo ; enddo else do j=js,je ; do i=is,ie - forces%p_surf_full(i,j) = G%mask2dT(i,j) * IOB%p(i-i0,j-j0) + forces%p_surf_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) forces%p_surf(i,j) = forces%p_surf_full(i,j) enddo ; enddo endif @@ -721,10 +721,10 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) forces%area_berg(i,j) = IOB%area_berg(i-i0,j-j0) * G%mask2dT(i,j) if (associated(IOB%mass_berg)) & - forces%mass_berg(i,j) = IOB%mass_berg(i-i0,j-j0) * G%mask2dT(i,j) + forces%mass_berg(i,j) = US%m_to_Z*US%kg_m3_to_R * IOB%mass_berg(i-i0,j-j0) * G%mask2dT(i,j) if (associated(IOB%ice_rigidity)) & - rigidity_at_h(i,j) = IOB%ice_rigidity(i-i0,j-j0) * G%mask2dT(i,j) + rigidity_at_h(i,j) = US%m_to_L**3*US%Z_to_L*US%T_to_s * IOB%ice_rigidity(i-i0,j-j0) * G%mask2dT(i,j) if (wind_stagger == BGRID_NE) then if (associated(IOB%u_flux)) taux_at_q(I,J) = IOB%u_flux(i-i0,j-j0) * stress_conversion @@ -846,13 +846,12 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) if (CS%rigid_sea_ice) then call pass_var(forces%p_surf_full, G%Domain, halo=1) I_GEarth = 1.0 / CS%g_Earth - Kv_rho_ice = (CS%kv_sea_ice / CS%density_sea_ice) + Kv_rho_ice = (CS%Kv_sea_ice / CS%density_sea_ice) do I=is-1,ie ; do j=js,je mass_ice = min(forces%p_surf_full(i,j), forces%p_surf_full(i+1,j)) * I_GEarth mass_eff = 0.0 if (mass_ice > CS%rigid_sea_ice_mass) then - mass_eff = (mass_ice - CS%rigid_sea_ice_mass) **2 / & - (mass_ice + CS%rigid_sea_ice_mass) + mass_eff = (mass_ice - CS%rigid_sea_ice_mass)**2 / (mass_ice + CS%rigid_sea_ice_mass) endif forces%rigidity_ice_u(I,j) = forces%rigidity_ice_u(I,j) + Kv_rho_ice * mass_eff enddo ; enddo @@ -860,8 +859,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) mass_ice = min(forces%p_surf_full(i,j), forces%p_surf_full(i,j+1)) * I_GEarth mass_eff = 0.0 if (mass_ice > CS%rigid_sea_ice_mass) then - mass_eff = (mass_ice - CS%rigid_sea_ice_mass) **2 / & - (mass_ice + CS%rigid_sea_ice_mass) + mass_eff = (mass_ice - CS%rigid_sea_ice_mass)**2 / (mass_ice + CS%rigid_sea_ice_mass) endif forces%rigidity_ice_v(i,J) = forces%rigidity_ice_v(i,J) + Kv_rho_ice * mass_eff enddo ; enddo @@ -1076,8 +1074,8 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, "needed because the FMS coupling structure does not "//& "limit the water that can be frozen out of the ocean and "//& "the ice-ocean heat fluxes are treated explicitly. No "//& - "limit is applied if a negative value is used.", units="Pa", & - default=-1.0) + "limit is applied if a negative value is used.", & + units="Pa", default=-1.0, scale=US%kg_m3_to_R*US%m_s_to_L_T**2) call get_param(param_file, mdl, "ADJUST_NET_SRESTORE_TO_ZERO", & CS%adjust_net_srestore_to_zero, & "If true, adjusts the salinity restoring seen to zero "//& @@ -1096,7 +1094,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, call get_param(param_file, mdl, "USE_NET_FW_ADJUSTMENT_SIGN_BUG", & CS%use_net_FW_adjustment_sign_bug, & "If true, use the wrong sign for the adjustment to "//& - "the net fresh-water.", default=.false.) + "the net fresh-water.", default=.true.) call get_param(param_file, mdl, "ADJUST_NET_FRESH_WATER_BY_SCALING", & CS%adjust_net_fresh_water_by_scaling, & "If true, adjustments to net fresh water to achieve zero net are "//& @@ -1129,10 +1127,9 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, if (restore_salt) then call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & - "The constant that relates the restoring surface fluxes "//& - "to the relative surface anomalies (akin to a piston "//& - "velocity). Note the non-MKS units.", units="m day-1", scale=US%m_to_Z*US%T_to_s/86400.0, & - fail_if_missing=.true.) + "The constant that relates the restoring surface fluxes to the relative "//& + "surface anomalies (akin to a piston velocity). Note the non-MKS units.", & + default=0.0, units="m day-1", scale=US%m_to_Z*US%T_to_s/86400.0) call get_param(param_file, mdl, "SALT_RESTORE_FILE", CS%salt_restore_file, & "A file in which to find the surface salinity to use for restoring.", & default="salt_restore.nc") @@ -1175,10 +1172,9 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, if (restore_temp) then call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & - "The constant that relates the restoring surface fluxes "//& - "to the relative surface anomalies (akin to a piston "//& - "velocity). Note the non-MKS units.", units="m day-1", scale=US%m_to_Z*US%T_to_s/86400.0, & - fail_if_missing=.true.) + "The constant that relates the restoring surface fluxes to the relative "//& + "surface anomalies (akin to a piston velocity). Note the non-MKS units.", & + default=0.0, units="m day-1", scale=US%m_to_Z*US%T_to_s/86400.0) call get_param(param_file, mdl, "SST_RESTORE_FILE", CS%temp_restore_file, & "A file in which to find the surface temperature to use for restoring.", & default="temp_restore.nc") @@ -1247,7 +1243,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, "an input file", default=.false.) call get_param(param_file, mdl, "GUST_CONST", CS%gust_const, & "The background gustiness in the winds.", & - units="Pa", default=0.02, scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) + units="Pa", default=0.0, scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) if (CS%read_gust_2d) then call get_param(param_file, mdl, "GUST_2D_FILE", gust_file, & "The file in which the wind gustiness is found in "//& @@ -1260,7 +1256,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, endif call get_param(param_file, mdl, "FIX_USTAR_GUSTLESS_BUG", CS%fix_ustar_gustless_bug, & "If true correct a bug in the time-averaging of the gustless wind friction velocity", & - default=.false.) + default=.true.) ! See whether sufficiently thick sea ice should be treated as rigid. call get_param(param_file, mdl, "USE_RIGID_SEA_ICE", CS%rigid_sea_ice, & @@ -1270,18 +1266,19 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, if (CS%rigid_sea_ice) then call get_param(param_file, mdl, "G_EARTH", CS%g_Earth, & "The gravitational acceleration of the Earth.", & - units="m s-2", default = 9.80) + 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, "SEA_ICE_MEAN_DENSITY", CS%density_sea_ice, & "A typical density of sea ice, used with the kinematic "//& - "viscosity, when USE_RIGID_SEA_ICE is true.", units="kg m-3", & - default=900.0) + "viscosity, when USE_RIGID_SEA_ICE is true.", & + units="kg m-3", default=900.0, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "SEA_ICE_VISCOSITY", CS%Kv_sea_ice, & "The kinematic viscosity of sufficiently thick sea ice "//& "for use in calculating the rigidity of sea ice.", & - units="m2 s-1", default=1.0e9) + units="m2 s-1", default=1.0e9, scale=US%Z_to_L**2*US%m_to_L**2*US%T_to_s) call get_param(param_file, mdl, "SEA_ICE_RIGID_MASS", CS%rigid_sea_ice_mass, & "The mass of sea-ice per unit area at which the sea-ice "//& - "starts to exhibit rigidity", units="kg m-2", default=1000.0) + "starts to exhibit rigidity", & + units="kg m-2", default=1000.0, scale=US%kg_m3_to_R*US%m_to_Z) endif call get_param(param_file, mdl, "ALLOW_ICEBERG_FLUX_DIAGNOSTICS", iceberg_flux_diags, & diff --git a/config_src/solo_driver/MESO_surface_forcing.F90 b/config_src/solo_driver/MESO_surface_forcing.F90 index ebe98a3293..e2f0694b6c 100644 --- a/config_src/solo_driver/MESO_surface_forcing.F90 +++ b/config_src/solo_driver/MESO_surface_forcing.F90 @@ -79,8 +79,7 @@ subroutine MESO_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) real :: Temp_restore ! The temperature that is being restored toward [degC]. real :: Salin_restore ! The salinity that is being restored toward [ppt] - real :: density_restore ! The potential density that is being restored - ! toward [kg m-3]. + real :: density_restore ! The potential density that is being restored toward [R ~> kg m-3]. real :: rhoXcp ! The mean density times the heat capacity [Q R degC-1 ~> J m-3 degC-1]. real :: buoy_rest_const ! A constant relating density anomalies to the ! restoring buoyancy flux [L2 T-3 R-1 ~> m5 s-3 kg-1]. @@ -194,11 +193,11 @@ subroutine MESO_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) buoy_rest_const = -1.0 * (CS%G_Earth * CS%Flux_const) / CS%Rho0 do j=js,je ; do i=is,ie ! Set density_restore to an expression for the surface potential - ! density [kg m-3] that is being restored toward. - density_restore = 1030.0 + ! density [R ~> kg m-3] that is being restored toward. + density_restore = 1030.0 * US%kg_m3_to_R fluxes%buoy(i,j) = G%mask2dT(i,j) * buoy_rest_const * & - US%kg_m3_to_R * (density_restore - sfc_state%sfc_density(i,j)) + (density_restore - sfc_state%sfc_density(i,j)) enddo ; enddo endif endif ! end RESTOREBUOY @@ -244,8 +243,7 @@ subroutine MESO_surface_forcing_init(Time, G, US, param_file, diag, CS) "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, "GUST_CONST", CS%gust_const, & - "The background gustiness in the winds.", units="Pa", & - default=0.02) + "The background gustiness in the winds.", units="Pa", default=0.0) call get_param(param_file, mdl, "RESTOREBUOY", CS%restorebuoy, & "If true, the buoyancy fluxes drive the model back "//& @@ -254,11 +252,9 @@ subroutine MESO_surface_forcing_init(Time, G, US, param_file, diag, CS) 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.", & - units="m day-1", scale=US%m_to_Z/(86400.0*US%s_to_T), & - fail_if_missing=.true.) + "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/(86400.0*US%s_to_T)) call get_param(param_file, mdl, "SSTRESTORE_FILE", CS%SSTrestore_file, & "The file with the SST toward which to restore in "//& diff --git a/config_src/solo_driver/MOM_driver.F90 b/config_src/solo_driver/MOM_driver.F90 index dfdfeff8ef..ba52d9c02a 100644 --- a/config_src/solo_driver/MOM_driver.F90 +++ b/config_src/solo_driver/MOM_driver.F90 @@ -66,6 +66,7 @@ program MOM_main use ensemble_manager_mod, only : ensemble_pelist_setup use mpp_mod, only : set_current_pelist => mpp_set_current_pelist use time_interp_external_mod, only : time_interp_external_init + use fms_affinity_mod, only : fms_affinity_init, fms_affinity_set,fms_affinity_get use MOM_ice_shelf, only : initialize_ice_shelf, ice_shelf_end, ice_shelf_CS use MOM_ice_shelf, only : shelf_calc_flux, add_shelf_forces, ice_shelf_save_restart @@ -207,11 +208,10 @@ program MOM_main character(len=40) :: mod_name = "MOM_main (MOM_driver)" ! This module's name. integer :: ocean_nthreads = 1 - integer :: ncores_per_node = 36 logical :: use_hyper_thread = .false. - integer :: omp_get_num_threads,omp_get_thread_num,get_cpu_affinity,adder,base_cpu + integer :: omp_get_num_threads,omp_get_thread_num namelist /ocean_solo_nml/ date_init, calendar, months, days, hours, minutes, seconds,& - ocean_nthreads, ncores_per_node, use_hyper_thread + ocean_nthreads, use_hyper_thread !===================================================================== @@ -252,20 +252,11 @@ program MOM_main endif endif +!$ call fms_affinity_init +!$ call fms_affinity_set('OCEAN', use_hyper_thread, ocean_nthreads) !$ call omp_set_num_threads(ocean_nthreads) -!$ base_cpu = get_cpu_affinity() -!$OMP PARALLEL private(adder) -!$ if (use_hyper_thread) then -!$ if (mod(omp_get_thread_num(),2) == 0) then -!$ adder = omp_get_thread_num()/2 -!$ else -!$ adder = ncores_per_node + omp_get_thread_num()/2 -!$ endif -!$ else -!$ adder = omp_get_thread_num() -!$ endif -!$ call set_cpu_affinity (base_cpu + adder) -!$ write(6,*) " ocean ", base_cpu, get_cpu_affinity(), adder, omp_get_thread_num(), omp_get_num_threads() +!$OMP PARALLEL +!$ write(6,*) "ocean_solo OMPthreading ", fms_affinity_get(), omp_get_thread_num(), omp_get_num_threads() !$ call flush(6) !$OMP END PARALLEL @@ -456,7 +447,7 @@ program MOM_main call close_file(unit) endif - if (cpu_steps > 0) call write_cputime(Time, 0, nmax, write_CPU_CSp) + if (cpu_steps > 0) call write_cputime(Time, 0, write_CPU_CSp) if (((.not.BTEST(Restart_control,1)) .and. (.not.BTEST(Restart_control,0))) & .or. (Restart_control < 0)) permit_incr_restart = .false. @@ -573,7 +564,7 @@ program MOM_main Time = Master_Time if (cpu_steps > 0) then ; if (MOD(ns, cpu_steps) == 0) then - call write_cputime(Time, ns+ntstep-1, nmax, write_CPU_CSp) + call write_cputime(Time, ns+ntstep-1, write_CPU_CSp, nmax) endif ; endif call mech_forcing_diags(forces, dt_forcing, grid, Time, diag, surface_forcing_CSp%handles) @@ -661,6 +652,7 @@ program MOM_main call callTree_waypoint("End MOM_main") call diag_mediator_end(Time, diag, end_diag_manager=.true.) + if (cpu_steps > 0) call write_cputime(Time, ns-1, write_CPU_CSp, call_end=.true.) call cpu_clock_end(termClock) call io_infra_end ; call MOM_infra_end diff --git a/config_src/solo_driver/MOM_surface_forcing.F90 b/config_src/solo_driver/MOM_surface_forcing.F90 index df403712f7..3d8b398516 100644 --- a/config_src/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/solo_driver/MOM_surface_forcing.F90 @@ -39,8 +39,6 @@ module MOM_surface_forcing use MOM_variables, only : surface use MESO_surface_forcing, only : MESO_buoyancy_forcing use MESO_surface_forcing, only : MESO_surface_forcing_init, MESO_surface_forcing_CS -use Neverland_surface_forcing, only : Neverland_wind_forcing, Neverland_buoyancy_forcing -use Neverland_surface_forcing, only : Neverland_surface_forcing_init, Neverland_surface_forcing_CS use user_surface_forcing, only : USER_wind_forcing, USER_buoyancy_forcing use user_surface_forcing, only : USER_surface_forcing_init, user_surface_forcing_CS use user_revise_forcing, only : user_alter_forcing, user_revise_forcing_init @@ -95,7 +93,7 @@ module MOM_surface_forcing real, pointer :: T_Restore(:,:) => NULL() !< temperature to damp (restore) the SST to [degC] real, pointer :: S_Restore(:,:) => NULL() !< salinity to damp (restore) the SSS [ppt] - real, pointer :: Dens_Restore(:,:) => NULL() !< density to damp (restore) surface density [kg m-3] + real, pointer :: Dens_Restore(:,:) => NULL() !< density to damp (restore) surface density [R ~> kg m-3] integer :: buoy_last_lev_read = -1 !< The last time level read from buoyancy input files @@ -111,6 +109,9 @@ module MOM_surface_forcing !! the same between compilers. logical :: fix_ustar_gustless_bug !< If true correct a bug in the time-averaging of the !! gustless wind friction velocity. + ! if WIND_CONFIG=='scurves' then use the following to define a piecwise scurve profile + real :: scurves_ydata(20) = 90. !< Latitudes of scurve nodes [degreesN] + real :: scurves_taux(20) = 0. !< Zonal wind stress values at scurve nodes [Pa] real :: T_north !< target temperatures at north used in buoyancy_forcing_linear real :: T_south !< target temperatures at south used in buoyancy_forcing_linear @@ -204,7 +205,6 @@ module MOM_surface_forcing type(BFB_surface_forcing_CS), pointer :: BFB_forcing_CSp => NULL() type(dumbbell_surface_forcing_CS), pointer :: dumbbell_forcing_CSp => NULL() type(MESO_surface_forcing_CS), pointer :: MESO_forcing_CSp => NULL() - type(Neverland_surface_forcing_CS), pointer :: Neverland_forcing_CSp => NULL() type(idealized_hurricane_CS), pointer :: idealized_hurricane_CSp => NULL() type(SCM_CVmix_tests_CS), pointer :: SCM_CVmix_tests_CSp => NULL() !>@} @@ -280,8 +280,10 @@ subroutine set_forcing(sfc_state, forces, fluxes, day_start, day_interval, G, US call wind_forcing_const(sfc_state, forces, 0., 0., day_center, G, US, CS) elseif (trim(CS%wind_config) == "const") then call wind_forcing_const(sfc_state, forces, CS%tau_x0, CS%tau_y0, day_center, G, US, CS) - elseif (trim(CS%wind_config) == "Neverland") then - call Neverland_wind_forcing(sfc_state, forces, day_center, G, US, CS%Neverland_forcing_CSp) + elseif (trim(CS%wind_config) == "Neverworld" .or. trim(CS%wind_config) == "Neverland") then + call Neverworld_wind_forcing(sfc_state, forces, day_center, G, US, CS) + elseif (trim(CS%wind_config) == "scurves") then + call scurve_wind_forcing(sfc_state, forces, day_center, G, US, CS) elseif (trim(CS%wind_config) == "ideal_hurr") then call idealized_hurricane_wind_forcing(sfc_state, forces, day_center, G, US, CS%idealized_hurricane_CSp) elseif (trim(CS%wind_config) == "SCM_ideal_hurr") then @@ -300,6 +302,12 @@ subroutine set_forcing(sfc_state, forces, fluxes, day_start, day_interval, G, US endif ! calls to various buoyancy forcing options + if (CS%restorebuoy .and. .not.CS%variable_buoyforce) then + call MOM_error(FATAL, "With RESTOREBUOY = True, VARIABLE_BUOYFORCE = True should be used. "//& + "Otherwise, this can lead to diverging solutions when a simulation "//& + "is continued using a restart file.") + endif + if ((CS%variable_buoyforce .or. CS%first_call_set_forcing) .and. & (.not.CS%adiabatic)) then if (trim(CS%buoy_config) == "file") then @@ -314,8 +322,6 @@ subroutine set_forcing(sfc_state, forces, fluxes, day_start, day_interval, G, US call buoyancy_forcing_linear(sfc_state, fluxes, day_center, dt, G, US, CS) elseif (trim(CS%buoy_config) == "MESO") then call MESO_buoyancy_forcing(sfc_state, fluxes, day_center, dt, G, US, CS%MESO_forcing_CSp) - elseif (trim(CS%buoy_config) == "Neverland") then - call Neverland_buoyancy_forcing(sfc_state, fluxes, day_center, dt, G, US, CS%Neverland_forcing_CSp) elseif (trim(CS%buoy_config) == "SCM_CVmix_tests") then call SCM_CVmix_tests_buoyancy_forcing(sfc_state, fluxes, day_center, G, US, CS%SCM_CVmix_tests_CSp) elseif (trim(CS%buoy_config) == "USER") then @@ -526,6 +532,136 @@ subroutine wind_forcing_gyres(sfc_state, forces, day, G, US, CS) call callTree_leave("wind_forcing_gyres") end subroutine wind_forcing_gyres +!> Sets the surface wind stresses, forces%taux and forces%tauy for the +!! Neverworld forcing configuration. +subroutine Neverworld_wind_forcing(sfc_state, forces, day, G, US, CS) + type(surface), intent(inout) :: sfc_state !< A structure containing fields that + !! describe the surface state of the ocean. + type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces + type(time_type), intent(in) :: day !< Time used for determining the fluxes. + type(ocean_grid_type), intent(inout) :: G !< Grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + !! a previous surface_forcing_init call + ! Local variables + integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + real :: PI, I_rho, y + real :: tau_max ! The magnitude of the wind stress [R Z L T-2 ~> Pa] + real :: off + + 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.) + + ! Set the surface wind stresses, in units of 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. + PI = 4.0*atan(1.0) + forces%taux(:,:) = 0.0 + tau_max = 0.2 * US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z + off = 0.02 + do j=js,je ; do I=is-1,Ieq + y = (G%geoLatT(i,j)-G%south_lat)/G%len_lat + + if (y <= 0.29) then + forces%taux(I,j) = forces%taux(I,j) + tau_max * ( (1/0.29)*y - ( 1/(2*PI) )*sin( (2*PI*y) / 0.29 ) ) + endif + if ((y > 0.29) .and. (y <= (0.8-off))) then + forces%taux(I,j) = forces%taux(I,j) + tau_max *(0.35+0.65*cos(PI*(y-0.29)/(0.51-off)) ) + endif + if ((y > (0.8-off)) .and. (y <= (1-off))) then + forces%taux(I,j) = forces%taux(I,j) + tau_max *( 1.5*( (y-1+off) - (0.1/PI)*sin(10.0*PI*(y-0.8+off)) ) ) + endif + forces%taux(I,j) = G%mask2dCu(I,j) * forces%taux(I,j) + enddo ; enddo + + do J=js-1,Jeq ; do i=is,ie + forces%tauy(i,J) = G%mask2dCv(i,J) * 0.0 + enddo ; enddo + + ! Set the surface friction velocity, in units of m s-1. ustar is always positive. + if (associated(forces%ustar)) then + I_rho = US%L_to_Z / CS%Rho0 + do j=js,je ; do i=is,ie + forces%ustar(i,j) = sqrt( (CS%gust_const + & + sqrt(0.5*((forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2) + & + (forces%taux(I-1,j)**2 + forces%taux(I,j)**2))) ) * I_rho ) + enddo ; enddo + endif + +end subroutine Neverworld_wind_forcing + +!> Sets the zonal wind stresses to a piecewise series of s-curves. +subroutine scurve_wind_forcing(sfc_state, forces, day, G, US, CS) + type(surface), intent(inout) :: sfc_state !< A structure containing fields that + !! describe the surface state of the ocean. + type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces + type(time_type), intent(in) :: day !< Time used for determining the fluxes. + type(ocean_grid_type), intent(inout) :: G !< Grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + !! a previous surface_forcing_init call + ! Local variables + integer :: i, j, kseg + real :: lon, lat, I_rho, y, L +! real :: ydata(7) = (/ -70., -45., -15., 0., 15., 45., 70. /) +! real :: taudt(7) = (/ 0., 0.2, -0.1, -0.02, -0.1, 0.1, 0. /) + + ! Allocate the forcing arrays, if necessary. + call allocate_mech_forcing(G, forces, stress=.true.) + + kseg = 1 + do j=G%jsd,G%jed ; do I=G%IsdB,G%IedB + lon = G%geoLonCu(I,j) + lat = G%geoLatCu(I,j) + + ! Find segment k s.t. ydata(k)<= lat < ydata(k+1) + do while (lat>=CS%scurves_ydata(kseg+1) .and. kseg<6) + kseg = kseg+1 + enddo + do while (lat1) + kseg = kseg-1 + enddo + + y = lat - CS%scurves_ydata(kseg) + L = CS%scurves_ydata(kseg+1) - CS%scurves_ydata(kseg) + forces%taux(I,j) = CS%scurves_taux(kseg) + & + ( CS%scurves_taux(kseg+1) - CS%scurves_taux(kseg) ) * scurve(y, L) + forces%taux(I,j) = G%mask2dCu(I,j) * forces%taux(I,j) + enddo ; enddo + + do J=G%JsdB,G%JedB ; do i=G%isd,G%ied + forces%tauy(i,J) = G%mask2dCv(i,J) * 0.0 + enddo ; enddo + + ! Set the surface friction velocity, in units of m s-1. ustar is always positive. + if (associated(forces%ustar)) then + I_rho = US%L_to_Z / CS%Rho0 + do j=G%jsc,G%jec ; do i=G%isc,G%iec + forces%ustar(i,j) = sqrt( (CS%gust_const + & + sqrt(0.5*((forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2) + & + (forces%taux(I-1,j)**2 + forces%taux(I,j)**2))) ) * I_rho ) + enddo ; enddo + endif + +end subroutine scurve_wind_forcing + +!> Returns the value of a cosine-bell function evaluated at x/L +real function scurve(x,L) + real , intent(in) :: x !< non-dimensional position + real , intent(in) :: L !< non-dimensional width + real :: s + + s = x/L + scurve = (3. - 2.*s) * (s*s) +end function scurve ! Sets the surface wind stresses from input files. subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) @@ -1000,7 +1136,7 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) else do j=js,je ; do i=is,ie if (G%mask2dT(i,j) > 0) then - fluxes%buoy(i,j) = US%kg_m3_to_R * (CS%Dens_Restore(i,j) - sfc_state%sfc_density(i,j)) * & + fluxes%buoy(i,j) = (CS%Dens_Restore(i,j) - sfc_state%sfc_density(i,j)) * & (CS%G_Earth * CS%Flux_const / CS%Rho0) else fluxes%buoy(i,j) = 0.0 @@ -1161,7 +1297,7 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, US else do j=js,je ; do i=is,ie if (G%mask2dT(i,j) > 0) then - fluxes%buoy(i,j) = US%kg_m3_to_R * (CS%Dens_Restore(i,j) - sfc_state%sfc_density(i,j)) * & + fluxes%buoy(i,j) = (CS%Dens_Restore(i,j) - sfc_state%sfc_density(i,j)) * & (CS%G_Earth * CS%Flux_const / CS%Rho0) else fluxes%buoy(i,j) = 0.0 @@ -1362,7 +1498,7 @@ subroutine buoyancy_forcing_linear(sfc_state, fluxes, day, dt, G, US, CS) "RESTOREBUOY to linear not written yet.") !do j=js,je ; do i=is,ie ! if (G%mask2dT(i,j) > 0) then - ! fluxes%buoy(i,j) = US%kg_m3_to_R * (CS%Dens_Restore(i,j) - sfc_state%sfc_density(i,j)) * & + ! fluxes%buoy(i,j) = (CS%Dens_Restore(i,j) - sfc_state%sfc_density(i,j)) * & ! (CS%G_Earth * CS%Flux_const / CS%Rho0) ! else ! fluxes%buoy(i,j) = 0.0 @@ -1459,7 +1595,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C call get_param(param_file, mdl, "BUOY_CONFIG", CS%buoy_config, & "The character string that indicates how buoyancy forcing "//& "is specified. Valid options include (file), (zero), "//& - "(linear), (USER), (BFB) and (NONE).", fail_if_missing=.true.) + "(linear), (USER), (BFB) and (NONE).", default="zero") if (trim(CS%buoy_config) == "file") then call get_param(param_file, mdl, "ARCHAIC_OMIP_FORCING_FILE", CS%archaic_OMIP_file, & "If true, use the forcing variable decomposition from "//& @@ -1601,7 +1737,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C call get_param(param_file, mdl, "WIND_CONFIG", CS%wind_config, & "The character string that indicates how wind forcing "//& "is specified. Valid options include (file), (2gyre), "//& - "(1gyre), (gyres), (zero), and (USER).", fail_if_missing=.true.) + "(1gyre), (gyres), (zero), and (USER).", default="zero") if (trim(CS%wind_config) == "file") then call get_param(param_file, mdl, "WIND_FILE", CS%wind_file, & "The file in which the wind stresses are found in "//& @@ -1612,10 +1748,10 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C call get_param(param_file, mdl, "WINDSTRESS_Y_VAR", CS%stress_y_var, & "The name of the y-wind stress variable in WIND_FILE.", & default="STRESS_Y") - call get_param(param_file, mdl, "WINDSTRESS_STAGGER",CS%wind_stagger, & + call get_param(param_file, mdl, "WIND_STAGGER",CS%wind_stagger, & "A character indicating how the wind stress components "//& "are staggered in WIND_FILE. This may be A or C for now.", & - default="A") + default="C") call get_param(param_file, mdl, "WINDSTRESS_SCALE", CS%wind_scale, & "A value by which the wind stresses in WIND_FILE are rescaled.", & default=1.0, units="nondim") @@ -1648,7 +1784,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C units="nondim", default=0.0) call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=.true.) + default=.false.) call get_param(param_file, mdl, "WIND_GYRES_2018_ANSWERS", CS%answers_2018, & "If true, use the order of arithmetic and expressions that recover the answers "//& "from the end of 2018. Otherwise, use expressions for the gyre friction velocities "//& @@ -1657,6 +1793,16 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C else CS%answers_2018 = .false. endif + if (trim(CS%wind_config) == "scurves") then + call get_param(param_file, mdl, "WIND_SCURVES_LATS", CS%scurves_ydata, & + "A list of latitudes defining a piecewise scurve profile "//& + "for zonal wind stress.", & + units="degrees N", fail_if_missing=.true.) + call get_param(param_file, mdl, "WIND_SCURVES_TAUX", CS%scurves_taux, & + "A list of zonal wind stress values at latitudes "//& + "WIND_SCURVES_LATS defining a piecewise scurve profile.", & + units="Pa", fail_if_missing=.true.) + endif if ((trim(CS%wind_config) == "2gyre") .or. & (trim(CS%wind_config) == "1gyre") .or. & (trim(CS%wind_config) == "gyres") .or. & @@ -1683,11 +1829,10 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C if (CS%restorebuoy) then ! These three variables use non-standard time units, but are rescaled as they are read. call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & - "The constant that relates the restoring surface fluxes "//& - "to the relative surface anomalies (akin to a piston "//& - "velocity). Note the non-MKS units.", & - units="m day-1", scale=US%m_to_Z*US%T_to_s/86400.0, & - fail_if_missing=.true., unscaled=flux_const_default) + "The constant that relates the restoring surface fluxes to the relative "//& + "surface anomalies (akin to a piston velocity). Note the non-MKS units.", & + default=0.0, units="m day-1", scale=US%m_to_Z*US%T_to_s/86400.0, & + unscaled=flux_const_default) if (CS%use_temperature) then call get_param(param_file, mdl, "FLUXCONST_T", CS%Flux_const_T, & @@ -1729,10 +1874,10 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C call get_param(param_file, mdl, "GUST_CONST", CS%gust_const, & "The background gustiness in the winds.", & - units="Pa", default=0.02, scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) + units="Pa", default=0.0, scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) call get_param(param_file, mdl, "FIX_USTAR_GUSTLESS_BUG", CS%fix_ustar_gustless_bug, & "If true correct a bug in the time-averaging of the gustless wind friction velocity", & - default=.false.) + default=.true.) call get_param(param_file, mdl, "READ_GUST_2D", CS%read_gust_2d, & "If true, use a 2-dimensional gustiness supplied from "//& "an input file", default=.false.) @@ -1756,8 +1901,6 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C call dumbbell_surface_forcing_init(Time, G, US, param_file, diag, CS%dumbbell_forcing_CSp) elseif (trim(CS%wind_config) == "MESO" .or. trim(CS%buoy_config) == "MESO" ) then call MESO_surface_forcing_init(Time, G, US, param_file, diag, CS%MESO_forcing_CSp) - elseif (trim(CS%wind_config) == "Neverland") then - call Neverland_surface_forcing_init(Time, G, US, param_file, diag, CS%Neverland_forcing_CSp) elseif (trim(CS%wind_config) == "ideal_hurr" .or.& trim(CS%wind_config) == "SCM_ideal_hurr") then call idealized_hurricane_wind_init(Time, G, US, param_file, CS%idealized_hurricane_CSp) diff --git a/config_src/solo_driver/Neverland_surface_forcing.F90 b/config_src/solo_driver/Neverland_surface_forcing.F90 deleted file mode 100644 index e6b7152e86..0000000000 --- a/config_src/solo_driver/Neverland_surface_forcing.F90 +++ /dev/null @@ -1,272 +0,0 @@ -!> Wind and buoyancy forcing for the Neverland configurations -module Neverland_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, safe_alloc_ptr -use MOM_domains, only : pass_var, pass_vector, AGRID -use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe -use MOM_file_parser, only : get_param, log_version, param_file_type -use MOM_forcing_type, only : forcing, mech_forcing -use MOM_forcing_type, only : allocate_forcing_type, allocate_mech_forcing -use MOM_grid, only : ocean_grid_type -use MOM_io, only : file_exists, read_data, slasher -use MOM_time_manager, only : time_type, operator(+), operator(/) -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : surface - -implicit none ; private - -public Neverland_wind_forcing -public Neverland_buoyancy_forcing -public Neverland_surface_forcing_init - -!> This control structure should be used to store any run-time variables -!! associated with the Neverland forcing. -!! -!! It can be readily modified for a specific case, and because it is private there -!! will be no changes needed in other code (although they will have to be recompiled). -type, public :: Neverland_surface_forcing_CS ; private - - logical :: use_temperature !< If true, use temperature and salinity. - 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, dimension(:,:), pointer :: & - buoy_restore(:,:) => NULL() !< The pattern to restore buoyancy to. - character(len=200) :: inputdir !< The directory where NetCDF input files are. - type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the - !! timing of diagnostic output. - logical :: first_call = .true. !< True until Neverland_buoyancy_forcing has been called -end type Neverland_surface_forcing_CS - -contains - -!> Sets the surface wind stresses, forces%taux and forces%tauy for the -!! Neverland forcing configuration. -subroutine Neverland_wind_forcing(sfc_state, forces, day, G, US, CS) - type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. - type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(time_type), intent(in) :: day !< Time used for determining the fluxes. - type(ocean_grid_type), intent(inout) :: G !< Grid structure. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(Neverland_surface_forcing_CS), pointer :: CS !< Control structure for this module. - - ! Local variables - integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB - real :: x, y - real :: PI - real :: tau_max ! The magnitude of the wind stress [R Z L T-2 ~> Pa] - real :: off - - 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.) - - ! Set the surface wind stresses, in units of 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. - PI = 4.0*atan(1.0) - forces%taux(:,:) = 0.0 - tau_max = 0.2 * US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z - off = 0.02 - do j=js,je ; do I=is-1,Ieq -! x = (G%geoLonT(i,j)-G%west_lon)/G%len_lon - y = (G%geoLatT(i,j)-G%south_lat)/G%len_lat -! forces%taux(I,j) = G%mask2dCu(I,j) * 0.0 - - if (y <= 0.29) then - forces%taux(I,j) = forces%taux(I,j) + tau_max * ( (1/0.29)*y - ( 1/(2*PI) )*sin( (2*PI*y) / 0.29 ) ) - endif - if ((y > 0.29) .and. (y <= (0.8-off))) then - forces%taux(I,j) = forces%taux(I,j) + tau_max *(0.35+0.65*cos(PI*(y-0.29)/(0.51-off)) ) - endif - if ((y > (0.8-off)) .and. (y <= (1-off))) then - forces%taux(I,j) = forces%taux(I,j) + tau_max *( 1.5*( (y-1+off) - (0.1/PI)*sin(10.0*PI*(y-0.8+off)) ) ) - endif - enddo ; enddo - - do J=js-1,Jeq ; do i=is,ie - forces%tauy(i,J) = G%mask2dCv(i,J) * 0.0 ! Change this to the desired expression. - enddo ; enddo - - ! Set the surface friction velocity, in units of 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((CS%gust_const + & -! sqrt(0.5*(forces%taux(I-1,j)**2 + forces%taux(I,j)**2) + & -! 0.5*(forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2))) * & -! (US%L_to_Z / CS%Rho0) ) -! enddo ; enddo ; endif - -end subroutine Neverland_wind_forcing - -!> Returns the value of a cosine-bell function evaluated at x/L -real function cosbell(x,L) - - real , intent(in) :: x !< non-dimensional position - real , intent(in) :: L !< non-dimensional width - 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 - real , intent(in) :: L !< non-dimensional width - 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 - - -!> Surface fluxes of buoyancy for the Neverland configurations. -subroutine Neverland_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 !< Forcing fields. - type(time_type), intent(in) :: day !< Time used for determining the fluxes. - real, intent(in) :: dt !< Forcing time step (s). - type(ocean_grid_type), intent(inout) :: G !< Grid structure. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(Neverland_surface_forcing_CS), pointer :: CS !< Control structure for this module. - ! Local variables - real :: buoy_rest_const ! A constant relating density anomalies to the - ! restoring buoyancy flux [L2 T-3 R-1 ~> m5 s-3 kg-1]. - real :: density_restore ! De - integer :: i, j, is, ie, js, je - integer :: isd, ied, jsd, jed - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - - ! When modifying the code, comment out this error message. It is here - ! so that the original (unmodified) version is not accidentally used. - - ! Allocate and zero out the forcing arrays, as necessary. This portion is - ! usually not changed. - if (CS%use_temperature) then - call MOM_error(FATAL, "Neverland_buoyancy_forcing: " // & - "Temperature and salinity mode not coded!" ) - 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%restorebuoy .and. CS%first_call) then - call safe_alloc_ptr(CS%buoy_restore, isd, ied, jsd, jed) - CS%first_call = .false. - ! Set CS%buoy_restore(i,j) here - endif - - if ( CS%use_temperature ) then - call MOM_error(FATAL, "Neverland_buoyancy_surface_forcing: " // & - "Temperature/salinity restoring not coded!" ) - 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 MOM_error(FATAL, "Neverland_buoyancy_surface_forcing: " // & - "Temperature/salinity restoring not coded!" ) - else - ! When modifying the code, comment out this error message. It is here - ! so that the original (unmodified) version is not accidentally used. - - ! The -1 is because density has the opposite sign to buoyancy. - buoy_rest_const = -1.0 * (CS%G_Earth * CS%Flux_const) / CS%Rho0 - do j=js,je ; do i=is,ie - ! Set density_restore to an expression for the surface potential - ! density [kg m-3] that is being restored toward. - density_restore = 1030.0 - - fluxes%buoy(i,j) = G%mask2dT(i,j) * buoy_rest_const * & - US%kg_m3_to_R*(density_restore - sfc_state%sfc_density(i,j)) - enddo ; enddo - endif - endif ! end RESTOREBUOY - -end subroutine Neverland_buoyancy_forcing - -!> Initializes the Neverland control structure. -subroutine Neverland_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 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(Neverland_surface_forcing_CS), pointer :: CS !< A pointer that is set to point to the control structure - !! for this module - ! This include declares and sets the variable "version". -#include "version_variable.h" - ! Local variables - character(len=40) :: mdl = "Neverland_surface_forcing" ! This module's name. - - if (associated(CS)) then - call MOM_error(WARNING, "Neverland_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, "GUST_CONST", CS%gust_const, & -! "The background gustiness in the winds.", units="Pa", & -! default=0.02) - - 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.", & - units="m day-1", scale=US%m_to_Z*US%T_to_s, fail_if_missing=.true.) - ! Convert CS%flux_const from m day-1 to m s-1. - CS%flux_const = CS%flux_const / 86400.0 - endif - -end subroutine Neverland_surface_forcing_init - -end module Neverland_surface_forcing diff --git a/config_src/solo_driver/user_surface_forcing.F90 b/config_src/solo_driver/user_surface_forcing.F90 index 97da89e69e..f5372e07d2 100644 --- a/config_src/solo_driver/user_surface_forcing.F90 +++ b/config_src/solo_driver/user_surface_forcing.F90 @@ -226,7 +226,7 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) density_restore = 1030.0*US%kg_m3_to_R fluxes%buoy(i,j) = G%mask2dT(i,j) * buoy_rest_const * & - (density_restore - US%kg_m3_to_R*sfc_state%sfc_density(i,j)) + (density_restore - sfc_state%sfc_density(i,j)) enddo ; enddo endif endif ! end RESTOREBUOY @@ -272,7 +272,7 @@ subroutine USER_surface_forcing_init(Time, G, US, param_file, diag, CS) units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "GUST_CONST", CS%gust_const, & "The background gustiness in the winds.", & - units="Pa", default=0.02, scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) + units="Pa", default=0.0, scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) call get_param(param_file, mdl, "RESTOREBUOY", CS%restorebuoy, & "If true, the buoyancy fluxes drive the model back "//& @@ -280,12 +280,9 @@ subroutine USER_surface_forcing_init(Time, G, US, param_file, diag, CS) "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.", & - units="m day-1", scale=US%m_to_Z*US%T_to_s, fail_if_missing=.true.) - ! Convert CS%Flux_const from m day-1 to m s-1. - CS%Flux_const = CS%Flux_const / 86400.0 + "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/(86400.0*US%s_to_T)) endif end subroutine USER_surface_forcing_init diff --git a/docs/Doxyfile_nortd b/docs/Doxyfile_nortd index e07ce4f0b6..76b66b9dd3 100644 --- a/docs/Doxyfile_nortd +++ b/docs/Doxyfile_nortd @@ -794,7 +794,9 @@ INPUT = ../src \ front_page.md \ ../config_src/solo_driver \ ../config_src/dynamic_symmetric - ../config_src/coupled_driver/ocean_model_MOM.F90 + ../config_src/external + ../config_src/coupled_driver + # This tag can be used to specify the character encoding of the source files # that doxygen parses. Internally doxygen uses the UTF-8 encoding. Doxygen uses diff --git a/docs/Doxyfile_rtd b/docs/Doxyfile_rtd index 652f46f076..7a74004d19 100644 --- a/docs/Doxyfile_rtd +++ b/docs/Doxyfile_rtd @@ -783,8 +783,8 @@ WARN_LOGFILE = doxygen.log INPUT = ../src \ ../config_src/solo_driver \ ../config_src/dynamic_symmetric \ - ../config_src/coupled_driver/coupler_util.F90 \ - ../config_src/coupled_driver/ocean_model_MOM.F90 + ../config_src/external \ + ../config_src/coupled_driver # This tag can be used to specify the character encoding of the source files # that doxygen parses. Internally doxygen uses the UTF-8 encoding. Doxygen uses diff --git a/pkg/MOM6_DA_hooks b/pkg/MOM6_DA_hooks deleted file mode 160000 index 6d8834ca8c..0000000000 --- a/pkg/MOM6_DA_hooks +++ /dev/null @@ -1 +0,0 @@ -Subproject commit 6d8834ca8cf399f1a0d202239d72919907f6cd74 diff --git a/pkg/geoKdTree b/pkg/geoKdTree deleted file mode 160000 index a4670b9743..0000000000 --- a/pkg/geoKdTree +++ /dev/null @@ -1 +0,0 @@ -Subproject commit a4670b9743c883d310d821eeac5b1f77f587b9d5 diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index 5f0c8839b9..f130c2977a 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -52,6 +52,7 @@ module MOM_ALE use regrid_consts, only : coordinateUnits, coordinateMode, state_dependent use regrid_edge_values, only : edge_values_implicit_h4 use PLM_functions, only : PLM_reconstruction, PLM_boundary_extrapolation +use PLM_functions, only : PLM_extrapolate_slope, PLM_monotonized_slope, PLM_slope_wa use PPM_functions, only : PPM_reconstruction, PPM_boundary_extrapolation implicit none ; private @@ -110,8 +111,9 @@ module MOM_ALE public ALE_build_grid public ALE_regrid_accelerated public ALE_remap_scalar -public pressure_gradient_plm -public pressure_gradient_ppm +public ALE_PLM_edge_values +public TS_PLM_edge_values +public TS_PPM_edge_values public adjustGridForIntegrity public ALE_initRegridding public ALE_getCoordinate @@ -163,12 +165,11 @@ subroutine ALE_init( param_file, GV, US, max_depth, 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, & + 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=.true.) + default=.false.) ! Initialize and configure regridding call ALE_initRegridding(GV, US, max_depth, param_file, mdl, CS%regridCS) @@ -196,7 +197,7 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) "extrapolated instead of piecewise constant", default=.false.) call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=.true.) + default=.false.) call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", CS%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 "//& @@ -1007,12 +1008,9 @@ subroutine ALE_remap_scalar(CS, G, GV, nk_src, h_src, s_src, h_dst, s_dst, all_c end subroutine ALE_remap_scalar -!> Use plm reconstruction for pressure gradient (determine edge values) -!! By using a PLM (limited piecewise linear method) reconstruction, this -!! routine determines the edge values for the salinity and temperature -!! within each layer. These edge values are returned and are used to compute -!! the pressure gradient (by computing the densities). -subroutine pressure_gradient_plm( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_extrap ) +!> Calculate edge values (top and bottom of layer) for T and S consistent with a PLM reconstruction +!! in the vertical direction. Boundary reconstructions are PCM unless bdry_extrap is true. +subroutine TS_PLM_edge_values( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_extrap ) type(ocean_grid_type), intent(in) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(ALE_CS), intent(inout) :: CS !< module control structure @@ -1030,12 +1028,31 @@ subroutine pressure_gradient_plm( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_ext logical, intent(in) :: bdry_extrap !< If true, use high-order boundary !! extrapolation within boundary cells + call ALE_PLM_edge_values( CS, G, GV, h, tv%S, bdry_extrap, S_t, S_b ) + call ALE_PLM_edge_values( CS, G, GV, h, tv%T, bdry_extrap, T_t, T_b ) + +end subroutine TS_PLM_edge_values + +!> Calculate edge values (top and bottom of layer) 3d scalar array. +!! Boundary reconstructions are PCM unless bdry_extrap is true. +subroutine ALE_PLM_edge_values( CS, G, GV, h, Q, bdry_extrap, Q_t, Q_b ) + type(ALE_CS), intent(in) :: CS !< module control structure + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< layer thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: Q !< 3d scalar array + logical, intent(in) :: bdry_extrap !< If true, use high-order boundary + !! extrapolation within boundary cells + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: Q_t !< Scalar at the top edge of each layer + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: Q_b !< Scalar at the bottom edge of each layer ! Local variables integer :: i, j, k - real :: hTmp(GV%ke) - real :: tmp(GV%ke) - real, dimension(CS%nk,2) :: ppol_E !Edge value of polynomial - real, dimension(CS%nk,2) :: ppol_coefs !Coefficients of polynomial + real :: slp(GV%ke) + real :: mslp real :: h_neglect if (.not.CS%answers_2018) then @@ -1046,48 +1063,40 @@ subroutine pressure_gradient_plm( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_ext h_neglect = GV%kg_m2_to_H*1.0e-30 endif - ! Determine reconstruction within each column - !$OMP parallel do default(shared) private(hTmp,ppol_E,ppol_coefs,tmp) + !$OMP parallel do default(shared) private(slp,mslp) do j = G%jsc-1,G%jec+1 ; do i = G%isc-1,G%iec+1 - ! Build current grid - hTmp(:) = h(i,j,:) - tmp(:) = tv%S(i,j,:) - ! Reconstruct salinity profile - ppol_E(:,:) = 0.0 - ppol_coefs(:,:) = 0.0 - call PLM_reconstruction( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) - if (bdry_extrap) & - call PLM_boundary_extrapolation( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) - - do k = 1,GV%ke - S_t(i,j,k) = ppol_E(k,1) - S_b(i,j,k) = ppol_E(k,2) + slp(1) = 0. + do k = 2, GV%ke-1 + slp(k) = PLM_slope_wa(h(i,j,k-1), h(i,j,k), h(i,j,k+1), h_neglect, Q(i,j,k-1), Q(i,j,k), Q(i,j,k+1)) enddo + slp(GV%ke) = 0. - ! Reconstruct temperature profile - ppol_E(:,:) = 0.0 - ppol_coefs(:,:) = 0.0 - tmp(:) = tv%T(i,j,:) - call PLM_reconstruction( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) - if (bdry_extrap) & - call PLM_boundary_extrapolation( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) - - do k = 1,GV%ke - T_t(i,j,k) = ppol_E(k,1) - T_b(i,j,k) = ppol_E(k,2) + do k = 2, GV%ke-1 + mslp = PLM_monotonized_slope(Q(i,j,k-1), Q(i,j,k), Q(i,j,k+1), slp(k-1), slp(k), slp(k+1)) + Q_t(i,j,k) = Q(i,j,k) - 0.5 * mslp + Q_b(i,j,k) = Q(i,j,k) + 0.5 * mslp enddo + if (bdry_extrap) then + mslp = - PLM_extrapolate_slope(h(i,j,2), h(i,j,1), h_neglect, Q(i,j,2), Q(i,j,1)) + Q_t(i,j,1) = Q(i,j,1) - 0.5 * mslp + Q_b(i,j,1) = Q(i,j,1) + 0.5 * mslp + mslp = PLM_extrapolate_slope(h(i,j,GV%ke-1), h(i,j,GV%ke), h_neglect, Q(i,j,GV%ke-1), Q(i,j,GV%ke)) + Q_t(i,j,GV%ke) = Q(i,j,GV%ke) - 0.5 * mslp + Q_b(i,j,GV%ke) = Q(i,j,GV%ke) + 0.5 * mslp + else + Q_t(i,j,1) = Q(i,j,1) + Q_b(i,j,1) = Q(i,j,1) + Q_t(i,j,GV%ke) = Q(i,j,GV%ke) + Q_b(i,j,GV%ke) = Q(i,j,GV%ke) + endif enddo ; enddo -end subroutine pressure_gradient_plm - +end subroutine ALE_PLM_edge_values -!> Use ppm reconstruction for pressure gradient (determine edge values) -!> By using a PPM (limited piecewise linear method) reconstruction, this -!> routine determines the edge values for the salinity and temperature -!> within each layer. These edge values are returned and are used to compute -!> the pressure gradient (by computing the densities). -subroutine pressure_gradient_ppm( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_extrap ) +!> Calculate edge values (top and bottom of layer) for T and S consistent with a PPM reconstruction +!! in the vertical direction. Boundary reconstructions are PCM unless bdry_extrap is true. +subroutine TS_PPM_edge_values( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_extrap ) type(ocean_grid_type), intent(in) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(ALE_CS), intent(inout) :: CS !< module control structure @@ -1169,7 +1178,7 @@ subroutine pressure_gradient_ppm( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_ext enddo ; enddo -end subroutine pressure_gradient_ppm +end subroutine TS_PPM_edge_values !> Initializes regridding for the main ALE algorithm diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index bc290b3f94..2a77cb06fe 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -84,7 +84,7 @@ module MOM_regridding !> 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 [Pa] + !> 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] @@ -199,7 +199,7 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m logical :: tmpLogical, fix_haloclines, set_max, do_sum, main_parameters logical :: coord_is_state_dependent, ierr logical :: default_2018_answers, remap_answers_2018 - real :: filt_len, strat_tol, index_scale, tmpReal + real :: filt_len, strat_tol, index_scale, tmpReal, P_Ref real :: maximum_depth ! The maximum depth of the ocean [m] (not in Z). real :: dz_fixed_sfc, Rho_avg_depth, nlay_sfc_int real :: adaptTimeRatio, adaptZoom, adaptZoomCoeff, adaptBuoyCoeff, adaptAlpha @@ -260,7 +260,7 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=.true.) + default=.false.) 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 "//& @@ -375,6 +375,8 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m "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) @@ -392,7 +394,7 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m allocate(dz(ke)) call MOM_read_data(trim(fileName), trim(varName), dz) endif - if (main_parameters .and. ke/=GV%ke) then + 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 @@ -513,11 +515,16 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m call initCoord(CS, GV, US, coord_mode) if (main_parameters .and. coord_is_state_dependent) then + call get_param(param_file, mdl, "P_REF", 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%kg_m3_to_R*US%m_s_to_L_T**2) call get_param(param_file, mdl, "REGRID_COMPRESSIBILITY_FRACTION", 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) + call set_regrid_params(CS, compress_fraction=tmpReal, ref_pressure=P_Ref) endif if (main_parameters) then @@ -594,7 +601,7 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m call set_regrid_params(CS, adaptTimeRatio=adaptTimeRatio, adaptZoom=adaptZoom, & adaptZoomCoeff=adaptZoomCoeff, adaptBuoyCoeff=adaptBuoyCoeff, adaptAlpha=adaptAlpha, & - adaptDoMin=tmpLogical, adaptDrho0=US%R_to_kg_m3*adaptDrho0) + adaptDoMin=tmpLogical, adaptDrho0=adaptDrho0) endif if (main_parameters .and. coord_is_state_dependent) then @@ -865,7 +872,7 @@ subroutine regridding_main( remapCS, CS, G, GV, h, tv, h_new, dzInterface, frac_ case ( REGRIDDING_RHO ) if (do_convective_adjustment) call convective_adjustment(G, GV, h, tv) - call build_rho_grid( G, GV, h, tv, dzInterface, remapCS, CS ) + call build_rho_grid( G, GV, G%US, h, tv, dzInterface, remapCS, CS ) call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) case ( REGRIDDING_ARBITRARY ) @@ -873,14 +880,14 @@ subroutine regridding_main( remapCS, CS, G, GV, h, tv, h_new, dzInterface, frac_ call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) case ( REGRIDDING_HYCOM1 ) - call build_grid_HyCOM1( G, GV, h, tv, h_new, dzInterface, CS ) + call build_grid_HyCOM1( G, GV, G%US, h, tv, h_new, dzInterface, CS ) case ( REGRIDDING_SLIGHT ) - call build_grid_SLight( G, GV, h, tv, dzInterface, CS ) + call build_grid_SLight( G, GV, G%US, h, tv, dzInterface, CS ) call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) case ( REGRIDDING_ADAPTIVE ) - call build_grid_adaptive(G, GV, h, tv, dzInterface, remapCS, CS) + call build_grid_adaptive(G, GV, G%US, h, tv, dzInterface, remapCS, CS) call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) case default @@ -1317,7 +1324,7 @@ 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, h, tv, dzInterface, remapCS, CS ) +subroutine build_rho_grid( G, GV, US, h, tv, dzInterface, remapCS, CS ) !------------------------------------------------------------------------------ ! 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 @@ -1336,6 +1343,7 @@ subroutine build_rho_grid( G, GV, h, tv, dzInterface, remapCS, CS ) ! Arguments type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure real, dimension(SZI_(G),SZJ_(G), SZK_(GV)+1), intent(inout) :: dzInterface !< The change in interface depth @@ -1347,7 +1355,7 @@ subroutine build_rho_grid( G, GV, h, tv, dzInterface, remapCS, CS ) integer :: nz 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, zNew + real, dimension(SZK_(GV)+1) :: zOld, zNew ! Old and new interface heights [H ~> m or kg m-2] real :: h_neglect, h_neglect_edge ! Negligible thicknesses [H ~> m or kg m-2] #ifdef __DO_SAFETY_CHECKS__ real :: totalThickness @@ -1449,9 +1457,10 @@ end subroutine build_rho_grid !! \remark { Based on Bleck, 2002: An oceanice 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, h, tv, h_new, dzInterface, CS ) +subroutine build_grid_HyCOM1( G, GV, US, h, tv, h_new, dzInterface, CS ) 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] type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure type(regridding_CS), intent(in) :: CS !< Regridding control structure @@ -1462,7 +1471,8 @@ subroutine build_grid_HyCOM1( G, GV, h, tv, h_new, dzInterface, CS ) real, dimension(SZK_(GV)+1) :: z_col ! Source interface positions relative to the surface [H ~> m or kg m-2] real, dimension(CS%nk+1) :: z_col_new ! New interface positions relative to the surface [H ~> m or kg m-2] real, dimension(SZK_(GV)+1) :: dz_col ! The realized change in z_col [H ~> m or kg m-2] - real, dimension(SZK_(GV)) :: p_col ! Layer center pressure [Pa] + real, dimension(SZK_(GV)) :: p_col ! Layer center pressure [R L2 T-2 ~> Pa] + real :: ref_pres ! The reference pressure [R L2 T-2 ~> Pa] integer :: i, j, k, nki real :: depth real :: h_neglect, h_neglect_edge @@ -1489,12 +1499,12 @@ subroutine build_grid_HyCOM1( G, GV, h, tv, h_new, dzInterface, CS ) z_col(1) = 0. ! 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) = CS%ref_pressure + CS%compressibility_fraction * & - ( 0.5 * ( z_col(K) + z_col(K+1) ) * GV%H_to_Pa - CS%ref_pressure ) + 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, tv%eqn_of_state, GV%ke, depth, & - h(i, j, :), tv%T(i, j, :), tv%S(i, j, :), p_col, & + h(i,j,:), tv%T(i,j,:), tv%S(i,j,:), p_col, & z_col, z_col_new, zScale=GV%Z_to_H, & h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) @@ -1519,9 +1529,10 @@ end subroutine build_grid_HyCOM1 !> This subroutine builds an adaptive grid that follows density surfaces where !! possible, subject to constraints on the smoothness of interface heights. -subroutine build_grid_adaptive(G, GV, h, tv, dzInterface, remapCS, CS) +subroutine build_grid_adaptive(G, GV, US, 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] type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various !! thermodynamic variables @@ -1567,7 +1578,7 @@ subroutine build_grid_adaptive(G, GV, h, tv, dzInterface, remapCS, CS) cycle endif - call build_adapt_column(CS%adapt_CS, G, GV, tv, i, j, zInt, tInt, sInt, h, zNext) + call build_adapt_column(CS%adapt_CS, G, GV, US, tv, i, j, zInt, tInt, sInt, h, zNext) call filtered_grid_motion(CS, nz, zInt(i,j,:), zNext, dzInterface(i,j,:)) ! convert from depth to z @@ -1585,9 +1596,10 @@ end subroutine build_grid_adaptive !! shallow topography, this will tend to give a uniform sigma-like coordinate. !! For sufficiently shallow water, a minimum grid spacing is used to avoid !! certain instabilities. -subroutine build_grid_SLight(G, GV, h, tv, dzInterface, CS) +subroutine build_grid_SLight(G, GV, US, h, tv, dzInterface, CS) 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] type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: dzInterface !< Changes in interface position @@ -1596,7 +1608,7 @@ subroutine build_grid_SLight(G, GV, h, tv, dzInterface, CS) real, dimension(SZK_(GV)+1) :: z_col ! Interface positions relative to the surface [H ~> m or kg m-2] real, dimension(SZK_(GV)+1) :: z_col_new ! Interface positions relative to the surface [H ~> m or kg m-2] real, dimension(SZK_(GV)+1) :: dz_col ! The realized change in z_col [H ~> m or kg m-2] - real, dimension(SZK_(GV)) :: p_col ! Layer center pressure [Pa] + real, dimension(SZK_(GV)) :: p_col ! Layer center pressure [R L2 T-2 ~> Pa] real :: depth integer :: i, j, k, nz real :: h_neglect, h_neglect_edge @@ -1622,11 +1634,11 @@ subroutine build_grid_SLight(G, GV, h, tv, dzInterface, CS) z_col(1) = 0. ! Work downward rather than bottom up do K=1,nz z_col(K+1) = z_col(K) + h(i,j,k) - p_col(k) = CS%ref_pressure + CS%compressibility_fraction * & - ( 0.5 * ( z_col(K) + z_col(K+1) ) * GV%H_to_Pa - CS%ref_pressure ) + 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_slight_column(CS%slight_CS, tv%eqn_of_state, GV%H_to_Pa, & + call build_slight_column(CS%slight_CS, tv%eqn_of_state, GV%H_to_RZ*GV%g_Earth, & GV%H_subroundoff, nz, depth, h(i, j, :), & tv%T(i, j, :), tv%S(i, j, :), p_col, z_col, z_col_new, & h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) @@ -1880,8 +1892,7 @@ subroutine convective_adjustment(G, GV, h, tv) 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, 1, GV%ke, tv%eqn_of_state ) + call calculate_density( tv%T(i,j,:), tv%S(i,j,:), p_col, densities, tv%eqn_of_state) ! Repeat restratification until complete do @@ -1900,8 +1911,7 @@ subroutine convective_adjustment(G, GV, h, tv) 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), 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 ) stratified = .false. @@ -1962,7 +1972,7 @@ end function uniformResolution subroutine initCoord(CS, GV, US, coord_mode) type(regridding_CS), intent(inout) :: CS !< Regridding control structure character(len=*), intent(in) :: coord_mode !< A string indicating the coordinate mode. - !! See the documenttion for regrid_consts + !! 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 @@ -1975,16 +1985,15 @@ subroutine initCoord(CS, GV, US, coord_mode) 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, & - rho_scale=US%kg_m3_to_R) + 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, rho_scale=US%kg_m3_to_R) + CS%interp_CS) case (REGRIDDING_SLIGHT) call init_coord_slight(CS%slight_CS, CS%nk, CS%ref_pressure, CS%target_density, & - CS%interp_CS, GV%m_to_H, rho_scale=US%kg_m3_to_R) + CS%interp_CS, GV%m_to_H) case (REGRIDDING_ADAPTIVE) - call init_coord_adapt(CS%adapt_CS, CS%nk, CS%coordinateResolution, GV%m_to_H) + 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 @@ -2009,17 +2018,22 @@ 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(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 - 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 + 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 @@ -2225,7 +2239,7 @@ 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, dz_min_surface, nz_fixed_surface, Rho_ML_avg_depth, & + compress_fraction, ref_pressure, dz_min_surface, nz_fixed_surface, Rho_ML_avg_depth, & nlay_ML_to_interior, fix_haloclines, halocline_filt_len, & halocline_strat_tol, integrate_downward_for_e, remap_answers_2018, & adaptTimeRatio, adaptZoom, adaptZoomCoeff, adaptBuoyCoeff, adaptAlpha, adaptDoMin, adaptDrho0) @@ -2237,7 +2251,9 @@ subroutine set_regrid_params( CS, boundary_extrapolation, min_thickness, old_gri 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 + 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] real, optional, intent(in) :: dz_min_surface !< The fixed resolution in the topmost !! SLight_nkml_min layers [H ~> m or kg m-2] integer, optional, intent(in) :: nz_fixed_surface !< The number of fixed-thickness layers at the top of the model @@ -2264,7 +2280,7 @@ subroutine set_regrid_params( CS, boundary_extrapolation, min_thickness, old_gri !! 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. [kg m-3] + !! 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) @@ -2283,6 +2299,7 @@ subroutine set_regrid_params( CS, boundary_extrapolation, min_thickness, old_gri if (present(min_thickness)) CS%min_thickness = min_thickness if (present(compress_fraction)) CS%compressibility_fraction = compress_fraction + if (present(ref_pressure)) CS%ref_pressure = ref_pressure if (present(integrate_downward_for_e)) CS%integrate_downward_for_e = integrate_downward_for_e if (present(remap_answers_2018)) CS%remap_answers_2018 = remap_answers_2018 diff --git a/src/ALE/MOM_remapping.F90 b/src/ALE/MOM_remapping.F90 index 6255a6fce8..71ba83f3ba 100644 --- a/src/ALE/MOM_remapping.F90 +++ b/src/ALE/MOM_remapping.F90 @@ -14,6 +14,8 @@ module MOM_remapping use PPM_functions, only : PPM_reconstruction, PPM_boundary_extrapolation use PQM_functions, only : PQM_reconstruction, PQM_boundary_extrapolation_v1 +use iso_fortran_env, only : stdout=>output_unit, stderr=>error_unit + implicit none ; private #include @@ -1025,11 +1027,11 @@ real function average_value_ppoly( n0, u0, ppoly0_E, ppoly0_coefs, method, i0, x end function average_value_ppoly !> Measure totals and bounds on source grid -subroutine measure_input_bounds( n0, h0, u0, ppoly_E, h0tot, h0err, u0tot, u0err, u0min, u0max ) +subroutine measure_input_bounds( n0, h0, u0, edge_values, h0tot, h0err, u0tot, u0err, u0min, u0max ) integer, intent(in) :: n0 !< Number of cells on source grid real, dimension(n0), intent(in) :: h0 !< Cell widths on source grid real, dimension(n0), intent(in) :: u0 !< Cell averages on source grid - real, dimension(n0,2), intent(in) :: ppoly_E !< Cell edge values on source grid + real, dimension(n0,2), intent(in) :: edge_values !< Cell edge values on source grid real, intent(out) :: h0tot !< Sum of cell widths real, intent(out) :: h0err !< Magnitude of round-off error in h0tot real, intent(out) :: u0tot !< Sum of cell widths times values @@ -1045,15 +1047,15 @@ subroutine measure_input_bounds( n0, h0, u0, ppoly_E, h0tot, h0err, u0tot, u0err h0err = 0. u0tot = h0(1) * u0(1) u0err = 0. - u0min = min( ppoly_E(1,1), ppoly_E(1,2) ) - u0max = max( ppoly_E(1,1), ppoly_E(1,2) ) + u0min = min( edge_values(1,1), edge_values(1,2) ) + u0max = max( edge_values(1,1), edge_values(1,2) ) do k = 2, n0 h0tot = h0tot + h0(k) h0err = h0err + eps * max(h0tot, h0(k)) u0tot = u0tot + h0(k) * u0(k) u0err = u0err + eps * max(abs(u0tot), abs(h0(k) * u0(k))) - u0min = min( u0min, ppoly_E(k,1), ppoly_E(k,2) ) - u0max = max( u0max, ppoly_E(k,1), ppoly_E(k,2) ) + u0min = min( u0min, edge_values(k,1), edge_values(k,2) ) + u0max = max( u0max, edge_values(k,1), edge_values(k,2) ) enddo end subroutine measure_input_bounds @@ -1899,12 +1901,13 @@ logical function test_answer(verbose, n, u, u_true, label, tol) if (abs(u(k) - u_true(k)) > tolerance) test_answer = .true. enddo if (test_answer .or. verbose) then - write(*,'(a4,2a24,x,a)') 'k','Calculated value','Correct value',label + write(stdout,'(a4,2a24,x,a)') 'k','Calculated value','Correct value',label do k = 1, n if (abs(u(k) - u_true(k)) > tolerance) then - write(*,'(i4,1p2e24.16,a,1pe24.16,a)') k,u(k),u_true(k),' err=',u(k)-u_true(k),' < wrong' + 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(*,'(i4,1p2e24.16)') k,u(k),u_true(k) + write(stdout,'(i4,1p2e24.16)') k,u(k),u_true(k) endif enddo endif @@ -1918,11 +1921,11 @@ subroutine dumpGrid(n,h,x,u) real, dimension(:), intent(in) :: x !< Interface delta real, dimension(:), intent(in) :: u !< Cell average values integer :: i - write(*,'("i=",20i10)') (i,i=1,n+1) - write(*,'("x=",20es10.2)') (x(i),i=1,n+1) - write(*,'("i=",5x,20i10)') (i,i=1,n) - write(*,'("h=",5x,20es10.2)') (h(i),i=1,n) - write(*,'("u=",5x,20es10.2)') (u(i),i=1,n) + 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/src/ALE/P1M_functions.F90 b/src/ALE/P1M_functions.F90 index f2c85d9872..d99c611229 100644 --- a/src/ALE/P1M_functions.F90 +++ b/src/ALE/P1M_functions.F90 @@ -24,11 +24,11 @@ module P1M_functions !! !! It is assumed that the size of the array 'u' is equal to the number of cells !! defining 'grid' and 'ppoly'. No consistency check is performed here. -subroutine P1M_interpolation( N, h, u, ppoly_E, ppoly_coef, h_neglect, answers_2018 ) +subroutine P1M_interpolation( N, h, u, edge_values, ppoly_coef, h_neglect, answers_2018 ) integer, intent(in) :: N !< Number of cells real, dimension(:), intent(in) :: h !< cell widths (size N) [H] real, dimension(:), intent(in) :: u !< cell average properties (size N) [A] - real, dimension(:,:), intent(inout) :: ppoly_E !< Potentially modified edge values [A] + real, dimension(:,:), intent(inout) :: edge_values !< Potentially modified edge values [A] real, dimension(:,:), intent(inout) :: ppoly_coef !< Potentially modified !! piecewise polynomial coefficients, mainly [A] real, optional, intent(in) :: h_neglect !< A negligibly small width [H] @@ -39,17 +39,17 @@ subroutine P1M_interpolation( N, h, u, ppoly_E, ppoly_coef, h_neglect, answers_2 real :: u0_l, u0_r ! edge values (left and right) ! Bound edge values (routine found in 'edge_values.F90') - call bound_edge_values( N, h, u, ppoly_E, h_neglect, answers_2018 ) + call bound_edge_values( N, h, u, edge_values, h_neglect, answers_2018 ) ! Systematically average discontinuous edge values (routine found in ! 'edge_values.F90') - call average_discontinuous_edge_values( N, ppoly_E ) + call average_discontinuous_edge_values( N, edge_values ) ! Loop on interior cells to build interpolants do k = 1,N - u0_l = ppoly_E(k,1) - u0_r = ppoly_E(k,2) + u0_l = edge_values(k,1) + u0_r = edge_values(k,2) ppoly_coef(k,1) = u0_l ppoly_coef(k,2) = u0_r - u0_l @@ -65,12 +65,12 @@ end subroutine P1M_interpolation !! !! It is assumed that the size of the array 'u' is equal to the number of cells !! defining 'grid' and 'ppoly'. No consistency check is performed here. -subroutine P1M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef ) +subroutine P1M_boundary_extrapolation( N, h, u, edge_values, ppoly_coef ) ! Arguments integer, intent(in) :: N !< Number of cells real, dimension(:), intent(in) :: h !< cell widths (size N) [H] real, dimension(:), intent(in) :: u !< cell averages (size N) [A] - real, dimension(:,:), intent(inout) :: ppoly_E !< edge values of piecewise polynomials [A] + real, dimension(:,:), intent(inout) :: edge_values !< edge values of piecewise polynomials [A] real, dimension(:,:), intent(inout) :: ppoly_coef !< coefficients of piecewise polynomials, mainly [A] ! Local variables @@ -99,20 +99,20 @@ subroutine P1M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef ) ! by using the edge value in the neighboring cell. u0_r = u0 + 0.5 * slope - if ( (u1 - u0) * (ppoly_E(2,1) - u0_r) < 0.0 ) then - slope = 2.0 * ( ppoly_E(2,1) - u0 ) + if ( (u1 - u0) * (edge_values(2,1) - u0_r) < 0.0 ) then + slope = 2.0 * ( edge_values(2,1) - u0 ) endif ! Using the limited slope, the left edge value is reevaluated and ! the interpolant coefficients recomputed if ( h0 /= 0.0 ) then - ppoly_E(1,1) = u0 - 0.5 * slope + edge_values(1,1) = u0 - 0.5 * slope else - ppoly_E(1,1) = u0 + edge_values(1,1) = u0 endif - ppoly_coef(1,1) = ppoly_E(1,1) - ppoly_coef(1,2) = ppoly_E(1,2) - ppoly_E(1,1) + ppoly_coef(1,1) = edge_values(1,1) + ppoly_coef(1,2) = edge_values(1,2) - edge_values(1,1) ! ------------------------------------------ ! Right edge value in the left boundary cell @@ -127,18 +127,18 @@ subroutine P1M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef ) u0_l = u1 - 0.5 * slope - if ( (u1 - u0) * (u0_l - ppoly_E(N-1,2)) < 0.0 ) then - slope = 2.0 * ( u1 - ppoly_E(N-1,2) ) + if ( (u1 - u0) * (u0_l - edge_values(N-1,2)) < 0.0 ) then + slope = 2.0 * ( u1 - edge_values(N-1,2) ) endif if ( h1 /= 0.0 ) then - ppoly_E(N,2) = u1 + 0.5 * slope + edge_values(N,2) = u1 + 0.5 * slope else - ppoly_E(N,2) = u1 + edge_values(N,2) = u1 endif - ppoly_coef(N,1) = ppoly_E(N,1) - ppoly_coef(N,2) = ppoly_E(N,2) - ppoly_E(N,1) + ppoly_coef(N,1) = edge_values(N,1) + ppoly_coef(N,2) = edge_values(N,2) - edge_values(N,1) end subroutine P1M_boundary_extrapolation diff --git a/src/ALE/P3M_functions.F90 b/src/ALE/P3M_functions.F90 index 434668894b..e3a9f75a3c 100644 --- a/src/ALE/P3M_functions.F90 +++ b/src/ALE/P3M_functions.F90 @@ -25,11 +25,11 @@ module P3M_functions !! !! It is assumed that the size of the array 'u' is equal to the number of cells !! defining 'grid' and 'ppoly'. No consistency check is performed here. -subroutine P3M_interpolation( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect, answers_2018 ) +subroutine P3M_interpolation( N, h, u, edge_values, ppoly_S, ppoly_coef, h_neglect, answers_2018 ) integer, intent(in) :: N !< Number of cells real, dimension(:), intent(in) :: h !< cell widths (size N) [H] real, dimension(:), intent(in) :: u !< cell averages (size N) in arbitrary units [A] - real, dimension(:,:), intent(inout) :: ppoly_E !< Edge value of polynomial [A] + real, dimension(:,:), intent(inout) :: edge_values !< Edge value of polynomial [A] real, dimension(:,:), intent(inout) :: ppoly_S !< Edge slope of polynomial [A H-1]. real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial [A] real, optional, intent(in) :: h_neglect !< A negligibly small width for the @@ -41,7 +41,7 @@ subroutine P3M_interpolation( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect, ! This routine could be called directly instead of having to call ! 'P3M_interpolation' first but we do that to provide an homogeneous ! interface. - call P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect, answers_2018 ) + call P3M_limiter( N, h, u, edge_values, ppoly_S, ppoly_coef, h_neglect, answers_2018 ) end subroutine P3M_interpolation @@ -58,11 +58,11 @@ end subroutine P3M_interpolation !! c. If not, monotonize cubic curve and rebuild it !! !! Step 3 of the monotonization process leaves all edge values unchanged. -subroutine P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect, answers_2018 ) +subroutine P3M_limiter( N, h, u, edge_values, ppoly_S, ppoly_coef, h_neglect, answers_2018 ) integer, intent(in) :: N !< Number of cells real, dimension(:), intent(in) :: h !< cell widths (size N) [H] real, dimension(:), intent(in) :: u !< cell averages (size N) in arbitrary units [A] - real, dimension(:,:), intent(inout) :: ppoly_E !< Edge value of polynomial [A] + real, dimension(:,:), intent(inout) :: edge_values !< Edge value of polynomial [A] real, dimension(:,:), intent(inout) :: ppoly_S !< Edge slope of polynomial [A H-1] real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial [A] real, optional, intent(in) :: h_neglect !< A negligibly small width for @@ -86,10 +86,10 @@ subroutine P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect, answer eps = 1e-10 ! 1. Bound edge values (boundary cells are assumed to be local extrema) - call bound_edge_values( N, h, u, ppoly_E, hNeglect, answers_2018 ) + call bound_edge_values( N, h, u, edge_values, hNeglect, answers_2018 ) ! 2. Systematically average discontinuous edge values - call average_discontinuous_edge_values( N, ppoly_E ) + call average_discontinuous_edge_values( N, edge_values ) ! 3. Loop on cells and do the following @@ -99,8 +99,8 @@ subroutine P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect, answer do k = 1,N ! Get edge values, edge slopes and cell width - u0_l = ppoly_E(k,1) - u0_r = ppoly_E(k,2) + u0_l = edge_values(k,1) + u0_r = edge_values(k,2) u1_l = ppoly_S(k,1) u1_r = ppoly_S(k,2) @@ -151,7 +151,7 @@ subroutine P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect, answer endif ! Build cubic interpolant (compute the coefficients) - call build_cubic_interpolant( h, k, ppoly_E, ppoly_S, ppoly_coef ) + call build_cubic_interpolant( h, k, edge_values, ppoly_S, ppoly_coef ) ! Check whether cubic is monotonic monotonic = is_cubic_monotonic( ppoly_coef, k ) @@ -168,7 +168,7 @@ subroutine P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect, answer ppoly_S(k,2) = u1_r ! Recompute coefficients of cubic - call build_cubic_interpolant( h, k, ppoly_E, ppoly_S, ppoly_coef ) + call build_cubic_interpolant( h, k, edge_values, ppoly_S, ppoly_coef ) enddo ! loop on cells @@ -188,12 +188,12 @@ end subroutine P3M_limiter !! computing the parabola based on the cell average and the right edge value !! and slope. The resulting cubic is not necessarily monotonic and the slopes !! are subsequently modified to yield a monotonic cubic. -subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coef, & +subroutine P3M_boundary_extrapolation( N, h, u, edge_values, ppoly_S, ppoly_coef, & h_neglect, h_neglect_edge ) integer, intent(in) :: N !< Number of cells real, dimension(:), intent(in) :: h !< cell widths (size N) [H] real, dimension(:), intent(in) :: u !< cell averages (size N) in arbitrary units [A] - real, dimension(:,:), intent(inout) :: ppoly_E !< Edge value of polynomial [A] + real, dimension(:,:), intent(inout) :: edge_values !< Edge value of polynomial [A] real, dimension(:,:), intent(inout) :: ppoly_S !< Edge slope of polynomial [A H-1] real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial [A] real, optional, intent(in) :: h_neglect !< A negligibly small width for the @@ -235,7 +235,7 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coef, & ! The right edge value in the boundary cell is taken to be the left ! edge value in the neighboring cell - u0_r = ppoly_E(i1,1) + u0_r = edge_values(i1,1) ! Given the right edge value and slope, we determine the left ! edge value and slope by computing the parabola as determined by @@ -253,13 +253,13 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coef, & endif ! Store edge values and slope, build cubic and check monotonicity - ppoly_E(i0,1) = u0_l - ppoly_E(i0,2) = u0_r + edge_values(i0,1) = u0_l + edge_values(i0,2) = u0_r ppoly_S(i0,1) = u1_l ppoly_S(i0,2) = u1_r ! Store edge values and slope, build cubic and check monotonicity - call build_cubic_interpolant( h, i0, ppoly_E, ppoly_S, ppoly_coef ) + call build_cubic_interpolant( h, i0, edge_values, ppoly_S, ppoly_coef ) monotonic = is_cubic_monotonic( ppoly_coef, i0 ) if ( .not.monotonic ) then @@ -268,7 +268,7 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coef, & ! Rebuild cubic after monotonization ppoly_S(i0,1) = u1_l ppoly_S(i0,2) = u1_r - call build_cubic_interpolant( h, i0, ppoly_E, ppoly_S, ppoly_coef ) + call build_cubic_interpolant( h, i0, edge_values, ppoly_S, ppoly_coef ) endif @@ -295,7 +295,7 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coef, & ! The left edge value in the boundary cell is taken to be the right ! edge value in the neighboring cell - u0_l = ppoly_E(i0,2) + u0_l = edge_values(i0,2) ! Given the left edge value and slope, we determine the right ! edge value and slope by computing the parabola as determined by @@ -313,12 +313,12 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coef, & endif ! Store edge values and slope, build cubic and check monotonicity - ppoly_E(i1,1) = u0_l - ppoly_E(i1,2) = u0_r + edge_values(i1,1) = u0_l + edge_values(i1,2) = u0_r ppoly_S(i1,1) = u1_l ppoly_S(i1,2) = u1_r - call build_cubic_interpolant( h, i1, ppoly_E, ppoly_S, ppoly_coef ) + call build_cubic_interpolant( h, i1, edge_values, ppoly_S, ppoly_coef ) monotonic = is_cubic_monotonic( ppoly_coef, i1 ) if ( .not.monotonic ) then @@ -327,7 +327,7 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coef, & ! Rebuild cubic after monotonization ppoly_S(i1,1) = u1_l ppoly_S(i1,2) = u1_r - call build_cubic_interpolant( h, i1, ppoly_E, ppoly_S, ppoly_coef ) + call build_cubic_interpolant( h, i1, edge_values, ppoly_S, ppoly_coef ) endif @@ -340,10 +340,10 @@ end subroutine P3M_boundary_extrapolation !! !! NOTE: edge values and slopes MUST have been properly calculated prior to !! calling this routine. -subroutine build_cubic_interpolant( h, k, ppoly_E, ppoly_S, ppoly_coef ) +subroutine build_cubic_interpolant( h, k, edge_values, ppoly_S, ppoly_coef ) real, dimension(:), intent(in) :: h !< cell widths (size N) [H] integer, intent(in) :: k !< The index of the cell to work on - real, dimension(:,:), intent(in) :: ppoly_E !< Edge value of polynomial in arbitrary units [A] + real, dimension(:,:), intent(in) :: edge_values !< Edge value of polynomial in arbitrary units [A] real, dimension(:,:), intent(in) :: ppoly_S !< Edge slope of polynomial [A H-1] real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial [A] @@ -355,8 +355,8 @@ subroutine build_cubic_interpolant( h, k, ppoly_E, ppoly_S, ppoly_coef ) h_c = h(k) - u0_l = ppoly_E(k,1) - u0_r = ppoly_E(k,2) + u0_l = edge_values(k,1) + u0_r = edge_values(k,2) u1_l = ppoly_S(k,1) * h_c u1_r = ppoly_S(k,2) * h_c diff --git a/src/ALE/PCM_functions.F90 b/src/ALE/PCM_functions.F90 index 135f53a8a1..6608e85eda 100644 --- a/src/ALE/PCM_functions.F90 +++ b/src/ALE/PCM_functions.F90 @@ -15,10 +15,10 @@ module PCM_functions !! !! It is assumed that the dimension of 'u' is equal to the number of cells !! defining 'grid' and 'ppoly'. No consistency check is performed. -subroutine PCM_reconstruction( N, u, ppoly_E, ppoly_coef ) +subroutine PCM_reconstruction( N, u, edge_values, ppoly_coef ) integer, intent(in) :: N !< Number of cells real, dimension(:), intent(in) :: u !< cell averages - real, dimension(:,:), intent(inout) :: ppoly_E !< Edge value of polynomial, + real, dimension(:,:), intent(inout) :: edge_values !< Edge value of polynomial, !! with the same units as u. real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial, !! with the same units as u. @@ -32,7 +32,7 @@ subroutine PCM_reconstruction( N, u, ppoly_E, ppoly_coef ) ! The edge values are equal to the cell average do k = 1,N - ppoly_E(k,:) = u(k) + edge_values(k,:) = u(k) enddo end subroutine PCM_reconstruction diff --git a/src/ALE/PLM_functions.F90 b/src/ALE/PLM_functions.F90 index ed82ad1e0b..da60f9614a 100644 --- a/src/ALE/PLM_functions.F90 +++ b/src/ALE/PLM_functions.F90 @@ -5,21 +5,189 @@ module PLM_functions implicit none ; private -public PLM_reconstruction, PLM_boundary_extrapolation +public PLM_boundary_extrapolation +public PLM_extrapolate_slope +public PLM_monotonized_slope +public PLM_reconstruction +public PLM_slope_wa +public PLM_slope_cw real, parameter :: hNeglect_dflt = 1.E-30 !< Default negligible cell thickness contains +!> Returns a limited PLM slope following White and Adcroft, 2008. [units of u] +!! Note that this is not the same as the Colella and Woodward method. +real elemental pure function PLM_slope_wa(h_l, h_c, h_r, h_neglect, u_l, u_c, u_r) + real, intent(in) :: h_l !< Thickness of left cell [units of grid thickness] + real, intent(in) :: h_c !< Thickness of center cell [units of grid thickness] + real, intent(in) :: h_r !< Thickness of right cell [units of grid thickness] + real, intent(in) :: h_neglect !< A negligible thickness [units of grid thickness] + real, intent(in) :: u_l !< Value of left cell [units of u] + real, intent(in) :: u_c !< Value of center cell [units of u] + real, intent(in) :: u_r !< Value of right cell [units of u] + ! Local variables + real :: sigma_l, sigma_c, sigma_r ! Left, central and right slope estimates as + ! differences across the cell [units of u] + real :: u_min, u_max ! Minimum and maximum value across cell [units of u] + + ! Side differences + sigma_r = u_r - u_c + sigma_l = u_c - u_l + + ! Quasi-second order difference + sigma_c = 2.0 * ( u_r - u_l ) * ( h_c / ( h_l + 2.0*h_c + h_r + h_neglect) ) + + ! Limit slope so that reconstructions are bounded by neighbors + u_min = min( u_l, u_c, u_r ) + u_max = max( u_l, u_c, u_r ) + if ( (sigma_l * sigma_r) > 0.0 ) then + ! This limits the slope so that the edge values are bounded by the + ! two cell averages spanning the edge. + PLM_slope_wa = sign( min( abs(sigma_c), 2.*min( u_c - u_min, u_max - u_c ) ), sigma_c ) + else + ! Extrema in the mean values require a PCM reconstruction avoid generating + ! larger extreme values. + PLM_slope_wa = 0.0 + endif + + ! This block tests to see if roundoff causes edge values to be out of bounds + if (u_c - 0.5*abs(PLM_slope_wa) < u_min .or. u_c + 0.5*abs(PLM_slope_wa) > u_max) then + PLM_slope_wa = PLM_slope_wa * ( 1. - epsilon(PLM_slope_wa) ) + endif + + ! An attempt to avoid inconsistency when the values become unrepresentable. + ! ### The following 1.E-140 is dimensionally inconsistent. A newer version of + ! PLM is progress that will avoid the need for such rounding. + if (abs(PLM_slope_wa) < 1.E-140) PLM_slope_wa = 0. + +end function PLM_slope_wa + +!> Returns a limited PLM slope following Colella and Woodward 1984. +real elemental pure function PLM_slope_cw(h_l, h_c, h_r, h_neglect, u_l, u_c, u_r) + real, intent(in) :: h_l !< Thickness of left cell [units of grid thickness] + real, intent(in) :: h_c !< Thickness of center cell [units of grid thickness] + real, intent(in) :: h_r !< Thickness of right cell [units of grid thickness] + real, intent(in) :: h_neglect !< A negligible thickness [units of grid thickness] + real, intent(in) :: u_l !< Value of left cell [units of u] + real, intent(in) :: u_c !< Value of center cell [units of u] + real, intent(in) :: u_r !< Value of right cell [units of u] + ! Local variables + real :: sigma_l, sigma_c, sigma_r ! Left, central and right slope estimates as + ! differences across the cell [units of u] + real :: u_min, u_max ! Minimum and maximum value across cell [units of u] + real :: h_cn ! Thickness of center cell [units of grid thickness] + + h_cn = h_c + h_neglect + + ! Side differences + sigma_r = u_r - u_c + sigma_l = u_c - u_l + + ! This is the second order slope given by equation 1.7 of + ! Piecewise Parabolic Method, Colella and Woodward (1984), + ! http://dx.doi.org/10.1016/0021-991(84)90143-8. + ! For uniform resolution it simplifies to ( u_r - u_l )/2 . + sigma_c = ( h_c / ( h_cn + ( h_l + h_r ) ) ) * ( & + ( 2.*h_l + h_c ) / ( h_r + h_cn ) * sigma_r & + + ( 2.*h_r + h_c ) / ( h_l + h_cn ) * sigma_l ) + + ! Limit slope so that reconstructions are bounded by neighbors + u_min = min( u_l, u_c, u_r ) + u_max = max( u_l, u_c, u_r ) + if ( (sigma_l * sigma_r) > 0.0 ) then + ! This limits the slope so that the edge values are bounded by the + ! two cell averages spanning the edge. + PLM_slope_cw = sign( min( abs(sigma_c), 2.*min( u_c - u_min, u_max - u_c ) ), sigma_c ) + else + ! Extrema in the mean values require a PCM reconstruction avoid generating + ! larger extreme values. + PLM_slope_cw = 0.0 + endif + + ! This block tests to see if roundoff causes edge values to be out of bounds + if (u_c - 0.5*abs(PLM_slope_cw) < u_min .or. u_c + 0.5*abs(PLM_slope_cw) > u_max) then + PLM_slope_cw = PLM_slope_cw * ( 1. - epsilon(PLM_slope_cw) ) + endif + + ! An attempt to avoid inconsistency when the values become unrepresentable. + ! ### The following 1.E-140 is dimensionally inconsistent. A newer version of + ! PLM is progress that will avoid the need for such rounding. + if (abs(PLM_slope_cw) < 1.E-140) PLM_slope_cw = 0. + +end function PLM_slope_cw + +!> Returns a limited PLM slope following Colella and Woodward 1984. +real elemental pure function PLM_monotonized_slope(u_l, u_c, u_r, s_l, s_c, s_r) + real, intent(in) :: u_l !< Value of left cell [units of u] + real, intent(in) :: u_c !< Value of center cell [units of u] + real, intent(in) :: u_r !< Value of right cell [units of u] + real, intent(in) :: s_l !< PLM slope of left cell [units of u] + real, intent(in) :: s_c !< PLM slope of center cell [units of u] + real, intent(in) :: s_r !< PLM slope of right cell [units of u] + ! Local variables + real :: e_r, e_l, edge ! Right, left and temporary edge values [units of u] + real :: almost_two ! The number 2, almost. + real :: slp ! Magnitude of PLM central slope [units of u] + + almost_two = 2. * ( 1. - epsilon(s_c) ) + + ! Edge values of neighbors abutting this cell + e_r = u_l + 0.5*s_l + e_l = u_r - 0.5*s_r + slp = abs(s_c) + + ! Check that left edge is between right edge of cell to the left and this cell mean + edge = u_c - 0.5 * s_c + if ( ( edge - e_r ) * ( u_c - edge ) < 0. ) then + edge = 0.5 * ( edge + e_r ) + slp = min( slp, abs( edge - u_c ) * almost_two ) + endif + + ! Check that right edge is between left edge of cell to the right and this cell mean + edge = u_c + 0.5 * s_c + if ( ( edge - u_c ) * ( e_l - edge ) < 0. ) then + edge = 0.5 * ( edge + e_l ) + slp = min( slp, abs( edge - u_c ) * almost_two ) + endif + + PLM_monotonized_slope = sign( slp, s_c ) + +end function PLM_monotonized_slope + +!> Returns a PLM slope using h2 extrapolation from a cell to the left. +!! Use the negative to extrapolate from the a cell to the right. +real elemental pure function PLM_extrapolate_slope(h_l, h_c, h_neglect, u_l, u_c) + real, intent(in) :: h_l !< Thickness of left cell [units of grid thickness] + real, intent(in) :: h_c !< Thickness of center cell [units of grid thickness] + real, intent(in) :: h_neglect !< A negligible thickness [units of grid thickness] + real, intent(in) :: u_l !< Value of left cell [units of u] + real, intent(in) :: u_c !< Value of center cell [units of u] + ! Local variables + real :: left_edge ! Left edge value [units of u] + real :: hl, hc ! Left and central cell thicknesses [units of grid thickness] + + ! Avoid division by zero for vanished cells + hl = h_l + h_neglect + hc = h_c + h_neglect + + ! The h2 scheme is used to compute the left edge value + left_edge = (u_l*hc + u_c*hl) / (hl + hc) + + PLM_extrapolate_slope = 2.0 * ( u_c - left_edge ) + +end function PLM_extrapolate_slope + + !> Reconstruction by linear polynomials within each cell !! !! It is assumed that the size of the array 'u' is equal to the number of cells !! defining 'grid' and 'ppoly'. No consistency check is performed here. -subroutine PLM_reconstruction( N, h, u, ppoly_E, ppoly_coef, h_neglect ) +subroutine PLM_reconstruction( N, h, u, edge_values, ppoly_coef, h_neglect ) integer, intent(in) :: N !< Number of cells real, dimension(:), intent(in) :: h !< cell widths (size N) real, dimension(:), intent(in) :: u !< cell averages (size N) - real, dimension(:,:), intent(inout) :: ppoly_E !< edge values of piecewise polynomials, + real, dimension(:,:), intent(inout) :: edge_values !< edge values of piecewise polynomials, !! with the same units as u. real, dimension(:,:), intent(inout) :: ppoly_coef !< coefficients of piecewise polynomials, mainly !! with the same units as u. @@ -31,149 +199,45 @@ subroutine PLM_reconstruction( N, h, u, ppoly_E, ppoly_coef, h_neglect ) integer :: k ! loop index real :: u_l, u_c, u_r ! left, center and right cell averages real :: h_l, h_c, h_r, h_cn ! left, center and right cell widths - real :: sigma_l, sigma_c, sigma_r ! left, center and right - ! van Leer slopes real :: slope ! retained PLM slope real :: a, b ! auxiliary variables real :: u_min, u_max, e_l, e_r, edge - real :: almost_one, almost_two + real :: almost_one real, dimension(N) :: slp, mslp real :: hNeglect hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect almost_one = 1. - epsilon(slope) - almost_two = 2. * almost_one ! Loop on interior cells do k = 2,N-1 - - ! Get cell averages - u_l = u(k-1) ; u_c = u(k) ; u_r = u(k+1) - - ! Get cell widths - h_l = h(k-1) ; h_c = h(k) ; h_r = h(k+1) - h_cn = max( h_c, hNeglect ) ! To avoid division by zero - - ! Side differences - sigma_r = u_r - u_c - sigma_l = u_c - u_l - - ! This is the second order slope given by equation 1.7 of - ! Piecewise Parabolic Method, Colella and Woodward (1984), - ! http://dx.doi.org/10.1016/0021-991(84)90143-8. - ! For uniform resolution it simplifies to ( u_r - u_l )/2 . - ! sigma_c = ( h_c / ( h_cn + ( h_l + h_r ) ) ) * ( & - ! ( 2.*h_l + h_c ) / ( h_r + h_cn ) * sigma_r & - ! + ( 2.*h_r + h_c ) / ( h_l + h_cn ) * sigma_l ) - - ! This is the original estimate of the second order slope from Laurent - ! but multiplied by h_c - sigma_c = 2.0 * ( u_r - u_l ) * ( h_c / ( h_l + 2.0*h_c + h_r + hNeglect) ) - - if ( (sigma_l * sigma_r) > 0.0 ) then - ! This limits the slope so that the edge values are bounded by the - ! two cell averages spanning the edge. - u_min = min( u_l, u_c, u_r ) - u_max = max( u_l, u_c, u_r ) - slope = sign( min( abs(sigma_c), 2.*min( u_c - u_min, u_max - u_c ) ), sigma_c ) - else - ! Extrema in the mean values require a PCM reconstruction avoid generating - ! larger extreme values. - slope = 0.0 - endif - - ! This block tests to see if roundoff causes edge values to be out of bounds - u_min = min( u_l, u_c, u_r ) - u_max = max( u_l, u_c, u_r ) - if (u_c - 0.5*abs(slope) < u_min .or. u_c + 0.5*abs(slope) > u_max) then - slope = slope * almost_one - endif - - ! An attempt to avoid inconsistency when the values become unrepresentable. - if (abs(slope) < 1.E-140) slope = 0. - - ! Safety check - this block really should not be needed ... -! if (u_c - 0.5*abs(slope) < u_min .or. u_c + 0.5*abs(slope) > u_max) then -! write(0,*) 'l,c,r=',u_l,u_c,u_r -! write(0,*) 'min,max=',u_min,u_max -! write(0,*) 'slp=',slope -! sigma_l = u_c-0.5*abs(slope) -! sigma_r = u_c+0.5*abs(slope) -! write(0,*) 'lo,hi=',sigma_l,sigma_r -! write(0,*) 'elo,ehi=',sigma_l-u_min,sigma_r-u_max -! stop 'Limiter failed!' -! endif - - slp(k) = slope - ppoly_E(k,1) = u_c - 0.5 * slope - ppoly_E(k,2) = u_c + 0.5 * slope - + slp(k) = PLM_slope_wa(h(k-1), h(k), h(k+1), hNeglect, u(k-1), u(k), u(k+1)) enddo ! end loop on interior cells - ! Boundary cells use PCM. Extrapolation is handled in a later routine. + ! Boundary cells use PCM. Extrapolation is handled after monotonization. slp(1) = 0. - ppoly_E(1,2) = u(1) slp(N) = 0. - ppoly_E(N,1) = u(N) ! This loop adjusts the slope so that edge values are monotonic. do K = 2, N-1 - u_l = u(k-1) ; u_c = u(k) ; u_r = u(k+1) - e_r = ppoly_E(k-1,2) ! Right edge from cell k-1 - e_l = ppoly_E(k+1,1) ! Left edge from cell k - mslp(k) = abs(slp(k)) - u_min = min(e_r, u_c) - u_max = max(e_r, u_c) - edge = u_c - 0.5 * slp(k) - if ( ( edge - e_r ) * ( u_c - edge ) < 0. ) then - edge = 0.5 * ( edge + e_r ) ! * almost_one? - mslp(k) = min( mslp(k), abs( edge - u_c ) * almost_two ) - endif - edge = u_c + 0.5 * slp(k) - if ( ( edge - u_c ) * ( e_l - edge ) < 0. ) then - edge = 0.5 * ( edge + e_l ) ! * almost_one? - mslp(k) = min( mslp(k), abs( edge - u_c ) * almost_two ) - endif + mslp(k) = PLM_monotonized_slope( u(k-1), u(k), u(k+1), slp(k-1), slp(k), slp(k+1) ) enddo ! end loop on interior cells mslp(1) = 0. mslp(N) = 0. - ! Check that the above adjustment worked -! do K = 2, N-1 -! u_r = u(k-1) + 0.5 * sign( mslp(k-1), slp(k-1) ) ! Right edge from cell k-1 -! u_l = u(k) - 0.5 * sign( mslp(k), slp(k) ) ! Left edge from cell k -! if ( (u(k)-u(k-1)) * (u_l-u_r) < 0. ) then -! stop 'Adjustment failed!' -! endif -! enddo ! end loop on interior cells - ! Store and return edge values and polynomial coefficients. - ppoly_E(1,1) = u(1) - ppoly_E(1,2) = u(1) + edge_values(1,1) = u(1) + edge_values(1,2) = u(1) ppoly_coef(1,1) = u(1) ppoly_coef(1,2) = 0. do k = 2, N-1 - slope = sign( mslp(k), slp(k) ) + slope = mslp(k) u_l = u(k) - 0.5 * slope ! Left edge value of cell k u_r = u(k) + 0.5 * slope ! Right edge value of cell k - ! Check that final edge values are bounded - u_min = min( u(k-1), u(k) ) - u_max = max( u(k-1), u(k) ) - if (u_lu_max) then - write(0,*) 'u(k-1)=',u(k-1),'u(k)=',u(k),'slp=',slp(k),'u_l=',u_l - stop 'Left edge out of bounds' - endif - u_min = min( u(k+1), u(k) ) - u_max = max( u(k+1), u(k) ) - if (u_ru_max) then - write(0,*) 'u(k)=',u(k),'u(k+1)=',u(k+1),'slp=',slp(k),'u_r=',u_r - stop 'Right edge out of bounds' - endif - - ppoly_E(k,1) = u_l - ppoly_E(k,2) = u_r + edge_values(k,1) = u_l + edge_values(k,2) = u_r ppoly_coef(k,1) = u_l ppoly_coef(k,2) = ( u_r - u_l ) ! Check to see if this evaluation of the polynomial at x=1 would be @@ -184,8 +248,8 @@ subroutine PLM_reconstruction( N, h, u, ppoly_E, ppoly_coef, h_neglect ) ppoly_coef(k,2) = ppoly_coef(k,2) * almost_one endif enddo - ppoly_E(N,1) = u(N) - ppoly_E(N,2) = u(N) + edge_values(N,1) = u(N) + edge_values(N,2) = u(N) ppoly_coef(N,1) = u(N) ppoly_coef(N,2) = 0. @@ -201,70 +265,40 @@ end subroutine PLM_reconstruction !! !! It is assumed that the size of the array 'u' is equal to the number of cells !! defining 'grid' and 'ppoly'. No consistency check is performed here. - -subroutine PLM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef, h_neglect ) +subroutine PLM_boundary_extrapolation( N, h, u, edge_values, ppoly_coef, h_neglect ) integer, intent(in) :: N !< Number of cells real, dimension(:), intent(in) :: h !< cell widths (size N) real, dimension(:), intent(in) :: u !< cell averages (size N) - real, dimension(:,:), intent(inout) :: ppoly_E !< edge values of piecewise polynomials, + real, dimension(:,:), intent(inout) :: edge_values !< edge values of piecewise polynomials, !! with the same units as u. real, dimension(:,:), intent(inout) :: ppoly_coef !< coefficients of piecewise polynomials, mainly !! with the same units as u. real, optional, intent(in) :: h_neglect !< A negligibly small width for !! the purpose of cell reconstructions !! in the same units as h - ! Local variables - real :: u0, u1 ! cell averages - real :: h0, h1 ! corresponding cell widths real :: slope ! retained PLM slope real :: hNeglect hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect - ! ----------------------------------------- - ! Left edge value in the left boundary cell - ! ----------------------------------------- - h0 = h(1) + hNeglect - h1 = h(2) + hNeglect - - u0 = u(1) - u1 = u(2) - - ! The h2 scheme is used to compute the right edge value - ppoly_E(1,2) = (u0*h1 + u1*h0) / (h0 + h1) - - ! The standard PLM slope is computed as a first estimate for the - ! reconstruction within the cell - slope = 2.0 * ( ppoly_E(1,2) - u0 ) - - ppoly_E(1,1) = u0 - 0.5 * slope - ppoly_E(1,2) = u0 + 0.5 * slope - - ppoly_coef(1,1) = ppoly_E(1,1) - ppoly_coef(1,2) = ppoly_E(1,2) - ppoly_E(1,1) - - ! ------------------------------------------ - ! Right edge value in the left boundary cell - ! ------------------------------------------ - h0 = h(N-1) + hNeglect - h1 = h(N) + hNeglect + ! Extrapolate from 2 to 1 to estimate slope + slope = - PLM_extrapolate_slope( h(2), h(1), hNeglect, u(2), u(1) ) - u0 = u(N-1) - u1 = u(N) + edge_values(1,1) = u(1) - 0.5 * slope + edge_values(1,2) = u(1) + 0.5 * slope - ! The h2 scheme is used to compute the right edge value - ppoly_E(N,1) = (u0*h1 + u1*h0) / (h0 + h1) + ppoly_coef(1,1) = edge_values(1,1) + ppoly_coef(1,2) = edge_values(1,2) - edge_values(1,1) - ! The standard PLM slope is computed as a first estimate for the - ! reconstruction within the cell - slope = 2.0 * ( u1 - ppoly_E(N,1) ) + ! Extrapolate from N-1 to N to estimate slope + slope = PLM_extrapolate_slope( h(N-1), h(N), hNeglect, u(N-1), u(N) ) - ppoly_E(N,1) = u1 - 0.5 * slope - ppoly_E(N,2) = u1 + 0.5 * slope + edge_values(N,1) = u(N) - 0.5 * slope + edge_values(N,2) = u(N) + 0.5 * slope - ppoly_coef(N,1) = ppoly_E(N,1) - ppoly_coef(N,2) = ppoly_E(N,2) - ppoly_E(N,1) + ppoly_coef(N,1) = edge_values(N,1) + ppoly_coef(N,2) = edge_values(N,2) - edge_values(N,1) end subroutine PLM_boundary_extrapolation diff --git a/src/ALE/PPM_functions.F90 b/src/ALE/PPM_functions.F90 index 6d50703975..bbf93b4a81 100644 --- a/src/ALE/PPM_functions.F90 +++ b/src/ALE/PPM_functions.F90 @@ -25,11 +25,11 @@ module PPM_functions contains !> Builds quadratic polynomials coefficients from cell mean and edge values. -subroutine PPM_reconstruction( N, h, u, ppoly_E, ppoly_coef, h_neglect, answers_2018) +subroutine PPM_reconstruction( N, h, u, edge_values, ppoly_coef, h_neglect, answers_2018) integer, intent(in) :: N !< Number of cells real, dimension(N), intent(in) :: h !< Cell widths [H] real, dimension(N), intent(in) :: u !< Cell averages [A] - real, dimension(N,2), intent(inout) :: ppoly_E !< Edge values [A] + real, dimension(N,2), intent(inout) :: edge_values !< Edge values [A] real, dimension(N,3), intent(inout) :: ppoly_coef !< Polynomial coefficients, mainly [A] real, optional, intent(in) :: h_neglect !< A negligibly small width [H] logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. @@ -39,13 +39,13 @@ subroutine PPM_reconstruction( N, h, u, ppoly_E, ppoly_coef, h_neglect, answers_ real :: edge_l, edge_r ! Edge values (left and right) ! PPM limiter - call PPM_limiter_standard( N, h, u, ppoly_E, h_neglect, answers_2018 ) + call PPM_limiter_standard( N, h, u, edge_values, h_neglect, answers_2018 ) ! Loop over all cells do k = 1,N - edge_l = ppoly_E(k,1) - edge_r = ppoly_E(k,2) + edge_l = edge_values(k,1) + edge_r = edge_values(k,2) ! Store polynomial coefficients ppoly_coef(k,1) = edge_l @@ -59,11 +59,11 @@ end subroutine PPM_reconstruction !> Adjusts edge values using the standard PPM limiter (Colella & Woodward, JCP 1984) !! after first checking that the edge values are bounded by neighbors cell averages !! and that the edge values are monotonic between cell averages. -subroutine PPM_limiter_standard( N, h, u, ppoly_E, h_neglect, answers_2018 ) +subroutine PPM_limiter_standard( N, h, u, edge_values, h_neglect, answers_2018 ) integer, intent(in) :: N !< Number of cells real, dimension(:), intent(in) :: h !< cell widths (size N) [H] real, dimension(:), intent(in) :: u !< cell average properties (size N) [A] - real, dimension(:,:), intent(inout) :: ppoly_E !< Potentially modified edge values [A] + real, dimension(:,:), intent(inout) :: edge_values !< Potentially modified edge values [A] real, optional, intent(in) :: h_neglect !< A negligibly small width [H] logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. @@ -74,10 +74,10 @@ subroutine PPM_limiter_standard( N, h, u, ppoly_E, h_neglect, answers_2018 ) real :: expr1, expr2 ! Bound edge values - call bound_edge_values( N, h, u, ppoly_E, h_neglect, answers_2018 ) + call bound_edge_values( N, h, u, edge_values, h_neglect, answers_2018 ) ! Make discontinuous edge values monotonic - call check_discontinuous_edge_values( N, u, ppoly_E ) + call check_discontinuous_edge_values( N, u, edge_values ) ! Loop on interior cells to apply the standard ! PPM limiter (Colella & Woodward, JCP 84) @@ -88,8 +88,8 @@ subroutine PPM_limiter_standard( N, h, u, ppoly_E, h_neglect, answers_2018 ) u_c = u(k) u_r = u(k+1) - edge_l = ppoly_E(k,1) - edge_r = ppoly_E(k,2) + edge_l = edge_values(k,1) + edge_r = edge_values(k,2) if ( (u_r - u_c)*(u_c - u_l) <= 0.0) then ! Flatten extremum @@ -116,21 +116,21 @@ subroutine PPM_limiter_standard( N, h, u, ppoly_E, h_neglect, answers_2018 ) edge_r = u_c endif - ppoly_E(k,1) = edge_l - ppoly_E(k,2) = edge_r + edge_values(k,1) = edge_l + edge_values(k,2) = edge_r enddo ! end loop on interior cells ! PCM within boundary cells - ppoly_E(1,:) = u(1) - ppoly_E(N,:) = u(N) + edge_values(1,:) = u(1) + edge_values(N,:) = u(N) end subroutine PPM_limiter_standard !------------------------------------------------------------------------------ !> Reconstruction by parabolas within boundary cells -subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef, h_neglect) +subroutine PPM_boundary_extrapolation( N, h, u, edge_values, ppoly_coef, h_neglect) !------------------------------------------------------------------------------ ! Reconstruction by parabolas within boundary cells. ! @@ -148,7 +148,7 @@ subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef, h_neglect) ! N: number of cells in grid ! h: thicknesses of grid cells ! u: cell averages to use in constructing piecewise polynomials -! ppoly_E : edge values of piecewise polynomials +! edge_values : edge values of piecewise polynomials ! ppoly_coef : coefficients of piecewise polynomials ! ! It is assumed that the size of the array 'u' is equal to the number of cells @@ -159,7 +159,7 @@ subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef, h_neglect) integer, intent(in) :: N !< Number of cells real, dimension(:), intent(in) :: h !< cell widths (size N) [H] real, dimension(:), intent(in) :: u !< cell averages (size N) [A] - real, dimension(:,:), intent(inout) :: ppoly_E !< edge values of piecewise polynomials [A] + real, dimension(:,:), intent(inout) :: edge_values !< edge values of piecewise polynomials [A] real, dimension(:,:), intent(inout) :: ppoly_coef !< coefficients of piecewise polynomials, mainly [A] real, optional, intent(in) :: h_neglect !< A negligibly small width for !! the purpose of cell reconstructions [H] @@ -199,7 +199,7 @@ subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef, h_neglect) ! The right edge value in the boundary cell is taken to be the left ! edge value in the neighboring cell - u0_r = ppoly_E(i1,1) + u0_r = edge_values(i1,1) ! Given the right edge value and slope, we determine the left ! edge value and slope by computing the parabola as determined by @@ -218,8 +218,8 @@ subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef, h_neglect) u0_r = 3.0 * u0 - 2.0 * u0_l endif - ppoly_E(i0,1) = u0_l - ppoly_E(i0,2) = u0_r + edge_values(i0,1) = u0_l + edge_values(i0,2) = u0_r a = u0_l b = 6.0 * u0 - 4.0 * u0_l - 2.0 * u0_r @@ -252,7 +252,7 @@ subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef, h_neglect) ! The left edge value in the boundary cell is taken to be the right ! edge value in the neighboring cell - u0_l = ppoly_E(i0,2) + u0_l = edge_values(i0,2) ! Given the left edge value and slope, we determine the right ! edge value and slope by computing the parabola as determined by @@ -271,8 +271,8 @@ subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef, h_neglect) u0_r = 3.0 * u1 - 2.0 * u0_l endif - ppoly_E(i1,1) = u0_l - ppoly_E(i1,2) = u0_r + edge_values(i1,1) = u0_l + edge_values(i1,2) = u0_r a = u0_l b = 6.0 * u1 - 4.0 * u0_l - 2.0 * u0_r diff --git a/src/ALE/PQM_functions.F90 b/src/ALE/PQM_functions.F90 index a2adeb0c13..630ecb34fc 100644 --- a/src/ALE/PQM_functions.F90 +++ b/src/ALE/PQM_functions.F90 @@ -17,12 +17,12 @@ module PQM_functions !! !! It is assumed that the dimension of 'u' is equal to the number of cells !! defining 'grid' and 'ppoly'. No consistency check is performed. -subroutine PQM_reconstruction( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect, answers_2018 ) +subroutine PQM_reconstruction( N, h, u, edge_values, edge_slopes, ppoly_coef, h_neglect, answers_2018 ) integer, intent(in) :: N !< Number of cells real, dimension(:), intent(in) :: h !< cell widths (size N) [H] real, dimension(:), intent(in) :: u !< cell averages (size N) [A] - real, dimension(:,:), intent(inout) :: ppoly_E !< Edge value of polynomial [A] - real, dimension(:,:), intent(inout) :: ppoly_S !< Edge slope of polynomial [A H-1] + real, dimension(:,:), intent(inout) :: edge_values !< Edge value of polynomial [A] + real, dimension(:,:), intent(inout) :: edge_slopes !< Edge slope of polynomial [A H-1] real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial, mainly [A] real, optional, intent(in) :: h_neglect !< A negligibly small width for !! the purpose of cell reconstructions [H] @@ -36,16 +36,16 @@ subroutine PQM_reconstruction( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect, real :: a, b, c, d, e ! parabola coefficients ! PQM limiter - call PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect, answers_2018 ) + call PQM_limiter( N, h, u, edge_values, edge_slopes, h_neglect, answers_2018 ) ! Loop on cells to construct the cubic within each cell do k = 1,N - u0_l = ppoly_E(k,1) - u0_r = ppoly_E(k,2) + u0_l = edge_values(k,1) + u0_r = edge_values(k,2) - u1_l = ppoly_S(k,1) - u1_r = ppoly_S(k,2) + u1_l = edge_slopes(k,1) + u1_r = edge_slopes(k,2) h_c = h(k) @@ -72,12 +72,12 @@ end subroutine PQM_reconstruction !! !! It is assumed that the dimension of 'u' is equal to the number of cells !! defining 'grid' and 'ppoly'. No consistency check is performed. -subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect, answers_2018 ) +subroutine PQM_limiter( N, h, u, edge_values, edge_slopes, h_neglect, answers_2018 ) integer, intent(in) :: N !< Number of cells real, dimension(:), intent(in) :: h !< cell widths (size N) [H] real, dimension(:), intent(in) :: u !< cell average properties (size N) [A] - real, dimension(:,:), intent(inout) :: ppoly_E !< Potentially modified edge values [A] - real, dimension(:,:), intent(inout) :: ppoly_S !< Potentially modified edge slopes [A H-1] + real, dimension(:,:), intent(inout) :: edge_values !< Potentially modified edge values [A] + real, dimension(:,:), intent(inout) :: edge_slopes !< Potentially modified edge slopes [A H-1] real, optional, intent(in) :: h_neglect !< A negligibly small width for !! the purpose of cell reconstructions [H] logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. @@ -102,10 +102,10 @@ subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect, answers_2018 ) hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect ! Bound edge values - call bound_edge_values( N, h, u, ppoly_E, hNeglect, answers_2018 ) + call bound_edge_values( N, h, u, edge_values, hNeglect, answers_2018 ) ! Make discontinuous edge values monotonic (thru averaging) - call check_discontinuous_edge_values( N, u, ppoly_E ) + call check_discontinuous_edge_values( N, u, edge_values ) ! Loop on interior cells to apply the PQM limiter do k = 2,N-1 @@ -116,10 +116,10 @@ subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect, answers_2018 ) inflexion_r = 0 ! Get edge values, edge slopes and cell width - u0_l = ppoly_E(k,1) - u0_r = ppoly_E(k,2) - u1_l = ppoly_S(k,1) - u1_r = ppoly_S(k,2) + u0_l = edge_values(k,1) + u0_r = edge_values(k,2) + u1_l = edge_slopes(k,1) + u1_r = edge_slopes(k,2) ! Get cell widths and cell averages (boundary cells are assumed to ! be local extrema for the sake of slopes) @@ -320,19 +320,19 @@ subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect, answers_2018 ) endif ! clause to check where to collapse inflexion points ! Save edge values and edge slopes for reconstruction - ppoly_E(k,1) = u0_l - ppoly_E(k,2) = u0_r - ppoly_S(k,1) = u1_l - ppoly_S(k,2) = u1_r + edge_values(k,1) = u0_l + edge_values(k,2) = u0_r + edge_slopes(k,1) = u1_l + edge_slopes(k,2) = u1_r enddo ! end loop on interior cells ! Constant reconstruction within boundary cells - ppoly_E(1,:) = u(1) - ppoly_S(1,:) = 0.0 + edge_values(1,:) = u(1) + edge_slopes(1,:) = 0.0 - ppoly_E(N,:) = u(N) - ppoly_S(N,:) = 0.0 + edge_values(N,:) = u(N) + edge_slopes(N,:) = 0.0 end subroutine PQM_limiter @@ -351,11 +351,11 @@ end subroutine PQM_limiter !! !! It is assumed that the size of the array 'u' is equal to the number of cells !! defining 'grid' and 'ppoly'. No consistency check is performed here. -subroutine PQM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef ) +subroutine PQM_boundary_extrapolation( N, h, u, edge_values, ppoly_coef ) integer, intent(in) :: N !< Number of cells real, dimension(:), intent(in) :: h !< cell widths (size N) [H] real, dimension(:), intent(in) :: u !< cell averages (size N) [A] - real, dimension(:,:), intent(inout) :: ppoly_E !< Edge value of polynomial [A] + real, dimension(:,:), intent(inout) :: edge_values !< Edge value of polynomial [A] real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial, mainly [A] ! Local variables integer :: i0, i1 @@ -389,7 +389,7 @@ subroutine PQM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef ) ! The right edge value in the boundary cell is taken to be the left ! edge value in the neighboring cell - u0_r = ppoly_E(i1,1) + u0_r = edge_values(i1,1) ! Given the right edge value and slope, we determine the left ! edge value and slope by computing the parabola as determined by @@ -408,8 +408,8 @@ subroutine PQM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef ) u0_r = 3.0 * u0 - 2.0 * u0_l endif - ppoly_E(i0,1) = u0_l - ppoly_E(i0,2) = u0_r + edge_values(i0,1) = u0_l + edge_values(i0,2) = u0_r a = u0_l b = 6.0 * u0 - 4.0 * u0_l - 2.0 * u0_r @@ -447,7 +447,7 @@ subroutine PQM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef ) ! The left edge value in the boundary cell is taken to be the right ! edge value in the neighboring cell - u0_l = ppoly_E(i0,2) + u0_l = edge_values(i0,2) ! Given the left edge value and slope, we determine the right ! edge value and slope by computing the parabola as determined by @@ -466,8 +466,8 @@ subroutine PQM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef ) u0_r = 3.0 * u1 - 2.0 * u0_l endif - ppoly_E(i1,1) = u0_l - ppoly_E(i1,2) = u0_r + edge_values(i1,1) = u0_l + edge_values(i1,2) = u0_r a = u0_l b = 6.0 * u1 - 4.0 * u0_l - 2.0 * u0_r @@ -498,12 +498,12 @@ end subroutine PQM_boundary_extrapolation !! !! It is assumed that the size of the array 'u' is equal to the number of cells !! defining 'grid' and 'ppoly'. No consistency check is performed here. -subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect ) +subroutine PQM_boundary_extrapolation_v1( N, h, u, edge_values, edge_slopes, ppoly_coef, h_neglect ) integer, intent(in) :: N !< Number of cells real, dimension(:), intent(in) :: h !< cell widths (size N) [H] real, dimension(:), intent(in) :: u !< cell averages (size N) [A] - real, dimension(:,:), intent(inout) :: ppoly_E !< Edge value of polynomial [A] - real, dimension(:,:), intent(inout) :: ppoly_S !< Edge slope of polynomial [A H-1] + real, dimension(:,:), intent(inout) :: edge_values !< Edge value of polynomial [A] + real, dimension(:,:), intent(inout) :: edge_slopes !< Edge slope of polynomial [A H-1] real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial, mainly [A] real, optional, intent(in) :: h_neglect !< A negligibly small width for !! the purpose of cell reconstructions [H] @@ -656,10 +656,10 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coef, endif ! Store edge values, edge slopes and coefficients - ppoly_E(i0,1) = u0_l - ppoly_E(i0,2) = u0_r - ppoly_S(i0,1) = u1_l - ppoly_S(i0,2) = u1_r + edge_values(i0,1) = u0_l + edge_values(i0,2) = u0_r + edge_slopes(i0,1) = u1_l + edge_slopes(i0,2) = u1_r a = u0_l b = h0 * u1_l @@ -809,10 +809,10 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coef, endif ! Store edge values, edge slopes and coefficients - ppoly_E(i1,1) = u0_l - ppoly_E(i1,2) = u0_r - ppoly_S(i1,1) = u1_l - ppoly_S(i1,2) = u1_r + edge_values(i1,1) = u0_l + edge_values(i1,2) = u0_r + edge_slopes(i1,1) = u1_l + edge_slopes(i1,2) = u1_r a = u0_l b = h1 * u1_l diff --git a/src/ALE/coord_adapt.F90 b/src/ALE/coord_adapt.F90 index 98bbeb7b10..8fa4b09fc5 100644 --- a/src/ALE/coord_adapt.F90 +++ b/src/ALE/coord_adapt.F90 @@ -5,6 +5,7 @@ module coord_adapt 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 @@ -36,7 +37,7 @@ module coord_adapt !> Stratification-dependent diffusion coefficient real :: adaptBuoyCoeff - !> Reference density difference for stratification-dependent diffusion [kg m-3] + !> Reference density difference for stratification-dependent diffusion [R ~> kg m-3] real :: adaptDrho0 !> If true, form a HYCOM1-like mixed layet by preventing interfaces @@ -49,31 +50,28 @@ module coord_adapt contains !> Initialise an adapt_CS with parameters -subroutine init_coord_adapt(CS, nk, coordinateResolution, m_to_H) +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, optional, intent(in) :: m_to_H !< A conversion factor from m to the units of thicknesses - - real :: m_to_H_rescale ! A unit conversion factor. + real, intent(in) :: m_to_H !< A conversion factor from m to the units of thicknesses + real, intent(in) :: kg_m3_to_R !< A conversion factor from kg m-3 to the units of density if (associated(CS)) call MOM_error(FATAL, "init_coord_adapt: CS already associated") allocate(CS) allocate(CS%coordinateResolution(nk)) - m_to_H_rescale = 1.0 ; if (present(m_to_H)) m_to_H_rescale = m_to_H - 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_rescale + 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 m-3] + CS%adaptDrho0 = 0.5 * kg_m3_to_R ! [R ~> kg m-3] end subroutine init_coord_adapt @@ -98,7 +96,7 @@ subroutine set_adapt_params(CS, adaptTimeRatio, adaptAlpha, adaptZoom, adaptZoom real, optional, intent(in) :: adaptZoomCoeff !< Near-surface zooming coefficient real, optional, intent(in) :: adaptBuoyCoeff !< Stratification-dependent diffusion coefficient real, optional, intent(in) :: adaptDrho0 !< Reference density difference for - !! stratification-dependent diffusion + !! 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 @@ -114,10 +112,11 @@ subroutine set_adapt_params(CS, adaptTimeRatio, adaptAlpha, adaptZoom, adaptZoom if (present(adaptDoMin)) CS%adaptDoMin = adaptDoMin end subroutine set_adapt_params -subroutine build_adapt_column(CS, G, GV, tv, i, j, zInt, tInt, sInt, h, zNext) +subroutine build_adapt_column(CS, G, GV, US, tv, i, j, zInt, tInt, sInt, 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 @@ -130,8 +129,12 @@ subroutine build_adapt_column(CS, G, GV, tv, i, j, zInt, tInt, sInt, h, zNext) ! Local variables integer :: k, nz - real :: h_up, b1, b_denom_1, d1, depth, drdz, nominal_z, stretching - real, dimension(SZK_(GV)+1) :: alpha, beta, del2sigma ! drho/dT and drho/dS + real :: h_up, b1, b_denom_1, d1, depth, nominal_z, stretching + real :: drdz ! The vertical density gradient [R H-1 ~> kg m-4 or m-1] + real, dimension(SZK_(GV)+1) :: alpha ! drho/dT [R degC-1 ~> kg m-3 degC-1] + real, dimension(SZK_(GV)+1) :: beta ! drho/dS [R ppt-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, c1 ! grid diffusivity on layers, and tridiagonal work array nz = CS%nk @@ -143,8 +146,8 @@ subroutine build_adapt_column(CS, G, GV, tv, i, j, zInt, tInt, sInt, h, zNext) ! local depth for scaling diffusivity depth = G%bathyT(i,j) * GV%Z_to_H - ! initialize del2sigma to zero - del2sigma(:) = 0. + ! 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 @@ -155,8 +158,8 @@ subroutine build_adapt_column(CS, G, GV, tv, i, j, zInt, tInt, sInt, h, zNext) 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_Pa, & - alpha, beta, 2, nz - 1, tv%eqn_of_state) + 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)) + & @@ -167,8 +170,8 @@ subroutine build_adapt_column(CS, G, GV, tv, i, j, zInt, tInt, sInt, h, zNext) 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_Pa, & - alpha, beta, 2, nz - 1, tv%eqn_of_state) + 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)) + & @@ -179,8 +182,8 @@ subroutine build_adapt_column(CS, G, GV, tv, i, j, zInt, tInt, sInt, h, zNext) 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_Pa, & - alpha, beta, 2, nz - 1, tv%eqn_of_state) + 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)) + & @@ -191,8 +194,8 @@ subroutine build_adapt_column(CS, G, GV, tv, i, j, zInt, tInt, sInt, h, zNext) 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_Pa, & - alpha, beta, 2, nz - 1, tv%eqn_of_state) + 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)) + & @@ -205,23 +208,23 @@ subroutine build_adapt_column(CS, G, GV, tv, i, j, zInt, tInt, sInt, h, zNext) ! ! 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_Pa, & - alpha, beta, 1, nz + 1, tv%eqn_of_state) + 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 - del2sigma(K) = del2sigma(K) * (0.5 * (h(i,j,k-1) + h(i,j,k))) / & + 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) + 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), del2sigma(K) > 0.) - del2sigma(K) = 0.5 * CS%adaptAlpha * & - sign(min(abs(del2sigma(K)), 0.5 * h_up), del2sigma(K)) + 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) + del2sigma(K) + zNext(K) = zInt(i,j,K) + dh_d2s(K) enddo ! solve diffusivity equation to smooth grid @@ -233,7 +236,7 @@ subroutine build_adapt_column(CS, G, GV, tv, i, j, zInt, tInt, sInt, h, zNext) 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)) + 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 diff --git a/src/ALE/coord_hycom.F90 b/src/ALE/coord_hycom.F90 index 1686ac51c9..016e4016eb 100644 --- a/src/ALE/coord_hycom.F90 +++ b/src/ALE/coord_hycom.F90 @@ -21,9 +21,6 @@ module coord_hycom !> Nominal density of interfaces [R ~> kg m-3] real, allocatable, dimension(:) :: target_density - !> Density scaling factor [R m3 kg-1 ~> 1] - real :: kg_m3_to_R - !> Maximum depths of interfaces [H ~> m or kg m-2] real, allocatable, dimension(:) :: max_interface_depths @@ -39,13 +36,12 @@ module coord_hycom contains !> Initialise a hycom_CS with pointers to parameters -subroutine init_coord_hycom(CS, nk, coordinateResolution, target_density, interp_CS, rho_scale) +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 - real, optional, intent(in) :: rho_scale !< A dimensional scaling factor for target_density if (associated(CS)) call MOM_error(FATAL, "init_coord_hycom: CS already associated!") allocate(CS) @@ -56,7 +52,6 @@ subroutine init_coord_hycom(CS, nk, coordinateResolution, target_density, interp CS%coordinateResolution(:) = coordinateResolution(:) CS%target_density(:) = target_density(:) CS%interp_CS = interp_CS - CS%kg_m3_to_R = 1.0 ; if (present(rho_scale)) CS%kg_m3_to_R = rho_scale end subroutine init_coord_hycom @@ -109,7 +104,7 @@ subroutine build_hycom1_column(CS, eqn_of_state, nz, depth, h, T, S, p_col, & real, dimension(nz), intent(in) :: T !< Temperature of column [degC] real, dimension(nz), intent(in) :: S !< Salinity of column [ppt] real, dimension(nz), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] - real, dimension(nz), intent(in) :: p_col !< Layer pressure [Pa] + 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] @@ -136,7 +131,7 @@ subroutine build_hycom1_column(CS, eqn_of_state, nz, depth, h, T, S, p_col, & z_scale = 1.0 ; if (present(zScale)) z_scale = zScale ! Work bottom recording potential density - call calculate_density(T, S, p_col, rho_col, 1, nz, eqn_of_state, scale=CS%kg_m3_to_R) + 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 diff --git a/src/ALE/coord_rho.F90 b/src/ALE/coord_rho.F90 index a78b1dd749..dce802ff3c 100644 --- a/src/ALE/coord_rho.F90 +++ b/src/ALE/coord_rho.F90 @@ -19,7 +19,7 @@ module coord_rho !> Minimum thickness allowed for layers, often in [H ~> m or kg m-2] real :: min_thickness = 0. - !> Reference pressure for density calculations [Pa] + !> Reference pressure for density calculations [R L2 T-2 ~> Pa] real :: ref_pressure !> If true, integrate for interface positions from the top downward. @@ -29,9 +29,6 @@ module coord_rho !> Nominal density of interfaces [R ~> kg m-3] real, allocatable, dimension(:) :: target_density - !> Density scaling factor [R m3 kg-1 ~> 1] - real :: kg_m3_to_R - !> Interpolation control structure type(interp_CS_type) :: interp_CS end type rho_CS @@ -41,13 +38,12 @@ module coord_rho contains !> Initialise a rho_CS with pointers to parameters -subroutine init_coord_rho(CS, nk, ref_pressure, target_density, interp_CS, rho_scale) +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 [Pa] + 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 - real, optional, intent(in) :: rho_scale !< A dimensional scaling factor for target_density if (associated(CS)) call MOM_error(FATAL, "init_coord_rho: CS already associated!") allocate(CS) @@ -57,7 +53,6 @@ subroutine init_coord_rho(CS, nk, ref_pressure, target_density, interp_CS, rho_s CS%ref_pressure = ref_pressure CS%target_density(:) = target_density(:) CS%interp_CS = interp_CS - CS%kg_m3_to_R = 1.0 ; if (present(rho_scale)) CS%kg_m3_to_R = rho_scale end subroutine init_coord_rho @@ -96,7 +91,7 @@ subroutine build_rho_column(CS, nz, depth, h, T, S, eqn_of_state, z_interface, & 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 in m) + 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 [degC] real, dimension(nz), intent(in) :: S !< Salinity for source column [ppt] @@ -111,12 +106,12 @@ subroutine build_rho_column(CS, nz, depth, h, T, S, eqn_of_state, z_interface, & ! Local variables integer :: k, count_nonzero_layers integer, dimension(nz) :: mapping - real, dimension(nz) :: pres ! Pressures used to calculate density [Pa] + 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 + 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) @@ -129,7 +124,7 @@ subroutine build_rho_column(CS, nz, depth, h, T, S, eqn_of_state, z_interface, & ! Compute densities on source column pres(:) = CS%ref_pressure - call calculate_density(T, S, pres, densities, 1, nz, eqn_of_state, scale=CS%kg_m3_to_R) + call calculate_density(T, S, pres, densities, eqn_of_state) do k = 1,count_nonzero_layers densities(k) = densities(mapping(k)) enddo @@ -211,7 +206,7 @@ subroutine build_rho_column_iteratively(CS, remapCS, nz, depth, h, T, S, eqn_of_ ! 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 [Pa]. + 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 [degC] and salinity [ppt]. real, dimension(nz) :: Tmp ! A temporary variable holding a remapped variable. @@ -252,8 +247,7 @@ subroutine build_rho_column_iteratively(CS, remapCS, nz, depth, h, T, S, eqn_of_ enddo ! Compute densities within current water column - call calculate_density( T_tmp, S_tmp, pres, densities, & - 1, nz, eqn_of_state, scale=CS%kg_m3_to_R) + call calculate_density( T_tmp, S_tmp, pres, densities, eqn_of_state) do k = 1,count_nonzero_layers densities(k) = densities(mapping(k)) diff --git a/src/ALE/coord_slight.F90 b/src/ALE/coord_slight.F90 index 30f2597090..5cfa09213f 100644 --- a/src/ALE/coord_slight.F90 +++ b/src/ALE/coord_slight.F90 @@ -20,7 +20,7 @@ module coord_slight !> 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 [Pa] + !> Reference pressure for potential density calculations [R L2 T-2 ~> Pa] real :: ref_pressure !> Fraction (between 0 and 1) of compressibility to add to potential density @@ -54,9 +54,6 @@ module coord_slight !> Nominal density of interfaces [R ~> kg m-3]. real, allocatable, dimension(:) :: target_density - !> Density scaling factor [R m3 kg-1 ~> 1] - real :: kg_m3_to_R - !> Maximum depths of interfaces [H ~> m or kg m-2]. real, allocatable, dimension(:) :: max_interface_depths @@ -72,14 +69,13 @@ module coord_slight contains !> Initialise a slight_CS with pointers to parameters -subroutine init_coord_slight(CS, nk, ref_pressure, target_density, interp_CS, m_to_H, rho_scale) +subroutine init_coord_slight(CS, nk, ref_pressure, target_density, interp_CS, m_to_H) type(slight_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 [Pa] + 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 real, optional, intent(in) :: m_to_H !< A conversion factor from m to the units of thicknesses - real, optional, intent(in) :: rho_scale !< A dimensional scaling factor for target_density real :: m_to_H_rescale ! A unit conversion factor. @@ -101,7 +97,6 @@ subroutine init_coord_slight(CS, nk, ref_pressure, target_density, interp_CS, m_ CS%dz_ml_min = 1.0 * m_to_H_rescale CS%halocline_filter_length = 2.0 * m_to_H_rescale CS%halocline_strat_tol = 0.25 ! Nondim. - CS%kg_m3_to_R = 1.0 ; if (present(rho_scale)) CS%kg_m3_to_R = rho_scale end subroutine init_coord_slight @@ -182,19 +177,20 @@ subroutine set_slight_params(CS, max_interface_depths, max_layer_thickness, & end subroutine set_slight_params !> Build a SLight coordinate column -subroutine build_slight_column(CS, eqn_of_state, H_to_Pa, H_subroundoff, & +subroutine build_slight_column(CS, eqn_of_state, H_to_pres, H_subroundoff, & nz, depth, h_col, T_col, S_col, p_col, z_col, z_col_new, & h_neglect, h_neglect_edge) type(slight_CS), intent(in) :: CS !< Coordinate control structure type(EOS_type), pointer :: eqn_of_state !< Equation of state structure - real, intent(in) :: H_to_Pa !< GV%H_to_Pa + real, intent(in) :: H_to_pres !< A conversion factor from thicknesses to + !! scaled pressure [R L2 T-2 H-1 ~> Pa m-1 or Pa m2 kg-1] real, intent(in) :: H_subroundoff !< GV%H_subroundoff 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_col !< T for column real, dimension(nz), intent(in) :: S_col !< S for column real, dimension(nz), intent(in) :: h_col !< Layer thicknesses [H ~> m or kg m-2] - real, dimension(nz), intent(in) :: p_col !< Layer quantities + real, dimension(nz), intent(in) :: p_col !< Layer center 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(nz+1), intent(inout) :: z_col_new !< Absolute positions of interfaces [H ~> m or kg m-2] real, optional, intent(in) :: h_neglect !< A negligibly small width for the purpose of @@ -207,8 +203,8 @@ subroutine build_slight_column(CS, eqn_of_state, H_to_Pa, H_subroundoff, & logical, dimension(nz+1) :: reliable ! If true, this interface is in a reliable position. real, dimension(nz+1) :: T_int, S_int ! Temperature [degC] and salinity [ppt] interpolated to interfaces. real, dimension(nz+1) :: rho_tmp ! A temporary density [R ~> kg m-3] - real, dimension(nz+1) :: drho_dp ! The partial derivative of density with pressure [kg m-3 Pa-1] - real, dimension(nz+1) :: p_IS, p_R + real, dimension(nz+1) :: drho_dp ! The partial derivative of density with pressure [T2 L-2 ~> kg m-3 Pa-1] + real, dimension(nz+1) :: p_IS, p_R ! Pressures [R L2 T-2 ~> Pa] real, dimension(nz+1) :: drhoIS_dT ! The partial derivative of in situ density with temperature ! in [R degC-1 ~> kg m-3 degC-1] real, dimension(nz+1) :: drhoIS_dS ! The partial derivative of in situ density with salinity @@ -218,19 +214,20 @@ subroutine build_slight_column(CS, eqn_of_state, H_to_Pa, H_subroundoff, & real, dimension(nz+1) :: drhoR_dS ! The partial derivative of reference density with salinity ! in [R ppt-1 ~> kg m-3 ppt-1] real, dimension(nz+1) :: strat_rat - real :: H_to_cPa + real :: H_to_cPa ! A conversion factor from thicknesses to the compressibility fraction times + ! the units of pressure [R L2 T-2 H-1 ~> Pa m-1 or Pa m2 kg-1] real :: drIS, drR ! In situ and reference density differences [R ~> kg m-3] - real :: Fn_now, I_HStol, Fn_zero_val - real :: z_int_unst - real :: dz ! A uniform layer thickness in very shallow water [H ~> m or kg m-2]. - real :: dz_ur ! The total thickness of an unstable region [H ~> m or kg m-2]. + real :: Fn_now, I_HStol, Fn_zero_val ! Nondimensional variables [nondim] + real :: z_int_unst ! The depth where the stratification allows the interior grid to start [H ~> m or kg m-2] + real :: dz ! A uniform layer thickness in very shallow water [H ~> m or kg m-2]. + real :: dz_ur ! The total thickness of an unstable region [H ~> m or kg m-2]. real :: wgt, cowgt ! A weight and its complement [nondim]. - real :: rho_ml_av ! The average potential density in a near-surface region [R ~> kg m-3]. - real :: H_ml_av ! A thickness to try to use in taking the near-surface average [H ~> m or kg m-2]. - real :: rho_x_z ! A cumulative integral of a density [R H ~> kg m-2 or kg2 m-5]. - real :: z_wt ! The thickness actually used in taking the near-surface average [H ~> m or kg m-2]. - real :: k_interior ! The (real) value of k where the interior grid starts. - real :: k_int2 ! The (real) value of k where the interior grid starts. + real :: rho_ml_av ! The average potential density in a near-surface region [R ~> kg m-3]. + real :: H_ml_av ! A thickness to try to use in taking the near-surface average [H ~> m or kg m-2]. + real :: rho_x_z ! A cumulative integral of a density [R H ~> kg m-2 or kg2 m-5]. + real :: z_wt ! The thickness actually used in taking the near-surface average [H ~> m or kg m-2]. + real :: k_interior ! The (real) value of k where the interior grid starts [nondim]. + real :: k_int2 ! The (real) value of k where the interior grid starts [nondim]. real :: z_interior ! The depth where the interior grid starts [H ~> m or kg m-2]. real :: z_ml_fix ! The depth at which the fixed-thickness near-surface layers end [H ~> m or kg m-2]. real :: dz_dk ! The thickness of layers between the fixed-thickness @@ -254,8 +251,7 @@ subroutine build_slight_column(CS, eqn_of_state, H_to_Pa, H_subroundoff, & dz = (z_col(nz+1) - z_col(1)) / real(nz) do K=2,nz ; z_col_new(K) = z_col(1) + dz*real(K-1) ; enddo else - call calculate_density(T_col, S_col, p_col, rho_col, 1, nz, & - eqn_of_state, scale=CS%kg_m3_to_R) + call calculate_density(T_col, S_col, p_col, rho_col, eqn_of_state) ! Find the locations of the target potential densities, flagging ! locations in apparently unstable regions as not reliable. @@ -371,23 +367,22 @@ subroutine build_slight_column(CS, eqn_of_state, H_to_Pa, H_subroundoff, & T_int(1) = T_f(1) ; S_int(1) = S_f(1) do K=2,nz T_int(K) = 0.5*(T_f(k-1) + T_f(k)) ; S_int(K) = 0.5*(S_f(k-1) + S_f(k)) - p_IS(K) = z_col(K) * H_to_Pa + p_IS(K) = z_col(K) * H_to_pres p_R(K) = CS%ref_pressure + CS%compressibility_fraction * ( p_IS(K) - CS%ref_pressure ) enddo T_int(nz+1) = T_f(nz) ; S_int(nz+1) = S_f(nz) - p_IS(nz+1) = z_col(nz+1) * H_to_Pa - call calculate_density_derivs(T_int, S_int, p_IS, drhoIS_dT, drhoIS_dS, 2, nz-1, & - eqn_of_state, scale=CS%kg_m3_to_R) - call calculate_density_derivs(T_int, S_int, p_R, drhoR_dT, drhoR_dS, 2, nz-1, & - eqn_of_state, scale=CS%kg_m3_to_R) + p_IS(nz+1) = z_col(nz+1) * H_to_pres + call calculate_density_derivs(T_int, S_int, p_IS, drhoIS_dT, drhoIS_dS, & + eqn_of_state, (/2,nz/) ) + call calculate_density_derivs(T_int, S_int, p_R, drhoR_dT, drhoR_dS, & + eqn_of_state, (/2,nz/) ) if (CS%compressibility_fraction > 0.0) then - call calculate_compress(T_int, S_int, p_R, rho_tmp, drho_dp, 2, nz-1, & - eqn_of_state) + call calculate_compress(T_int, S_int, p_R(:), rho_tmp, drho_dp, 2, nz-1, eqn_of_state) else do K=2,nz ; drho_dp(K) = 0.0 ; enddo endif - H_to_cPa = CS%compressibility_fraction*CS%kg_m3_to_R*H_to_Pa + H_to_cPa = CS%compressibility_fraction * H_to_pres strat_rat(1) = 1.0 do K=2,nz drIS = drhoIS_dT(K) * (T_f(k) - T_f(k-1)) + & diff --git a/src/ALE/regrid_interp.F90 b/src/ALE/regrid_interp.F90 index 5a1d151487..1ab225474c 100644 --- a/src/ALE/regrid_interp.F90 +++ b/src/ALE/regrid_interp.F90 @@ -349,13 +349,13 @@ end subroutine build_and_interpolate_grid !! !! It is assumed that the number of cells defining 'grid' and 'ppoly' are the !! same. -function get_polynomial_coordinate( N, h, x_g, ppoly_E, ppoly_coefs, & +function get_polynomial_coordinate( N, h, x_g, edge_values, ppoly_coefs, & target_value, degree, answers_2018 ) result ( x_tgt ) ! Arguments integer, intent(in) :: N !< Number of grid cells real, dimension(N), intent(in) :: h !< Grid cell thicknesses [H] real, dimension(N+1), intent(in) :: x_g !< Grid interface locations [H] - real, dimension(N,2), intent(in) :: ppoly_E !< Edge values of interpolating polynomials [A] + real, dimension(N,2), intent(in) :: edge_values !< Edge values of interpolating polynomials [A] real, dimension(N,DEGREE_MAX+1), intent(in) :: ppoly_coefs !< Coefficients of interpolating polynomials [A] real, intent(in) :: target_value !< Target value to find position for [A] integer, intent(in) :: degree !< Degree of the interpolating polynomials @@ -383,7 +383,7 @@ function get_polynomial_coordinate( N, h, x_g, ppoly_E, ppoly_coefs, & ! If the target value is outside the range of all values, we ! force the target coordinate to be equal to the lowest or ! largest value, depending on which bound is overtaken - if ( target_value <= ppoly_E(1,1) ) then + if ( target_value <= edge_values(1,1) ) then x_tgt = x_g(1) return ! return because there is no need to look further endif @@ -391,7 +391,7 @@ function get_polynomial_coordinate( N, h, x_g, ppoly_E, ppoly_coefs, & ! Since discontinuous edge values are allowed, we check whether the target ! value lies between two discontinuous edge values at interior interfaces do k = 2,N - if ( ( target_value >= ppoly_E(k-1,2) ) .AND. ( target_value <= ppoly_E(k,1) ) ) then + if ( ( target_value >= edge_values(k-1,2) ) .AND. ( target_value <= edge_values(k,1) ) ) then x_tgt = x_g(k) return ! return because there is no need to look further endif @@ -400,7 +400,7 @@ function get_polynomial_coordinate( N, h, x_g, ppoly_E, ppoly_coefs, & ! If the target value is outside the range of all values, we ! force the target coordinate to be equal to the lowest or ! largest value, depending on which bound is overtaken - if ( target_value >= ppoly_E(N,2) ) then + if ( target_value >= edge_values(N,2) ) then x_tgt = x_g(N+1) return ! return because there is no need to look further endif @@ -411,7 +411,7 @@ function get_polynomial_coordinate( N, h, x_g, ppoly_E, ppoly_coefs, & ! contains the target value. The variable k_found holds the index value ! of the cell where the taregt value lies. do k = 1,N - if ( ( target_value > ppoly_E(k,1) ) .AND. ( target_value < ppoly_E(k,2) ) ) then + if ( ( target_value > edge_values(k,1) ) .AND. ( target_value < edge_values(k,2) ) ) then k_found = k exit endif @@ -425,7 +425,7 @@ function get_polynomial_coordinate( N, h, x_g, ppoly_E, ppoly_coefs, & if ( k_found == -1 ) then write(mesg,*) 'Could not find target coordinate', target_value, 'in get_polynomial_coordinate. This is '//& 'caused by an inconsistent interpolant (perhaps not monotonically increasing):', & - target_value, ppoly_E(1,1), ppoly_E(N,2) + target_value, edge_values(1,1), edge_values(N,2) call MOM_error( FATAL, mesg ) endif diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 78d53e0b76..e7a3e54c4e 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -4,10 +4,12 @@ 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 @@ -37,12 +39,13 @@ module MOM 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, query_initialized, save_restart +use MOM_restart, only : register_restart_field, register_restart_pair +use MOM_restart, only : query_initialized, save_restart use MOM_restart, only : restart_init, 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(>=), increment_date +use MOM_time_manager, only : operator(>=), operator(==), increment_date use MOM_unit_tests, only : unit_tests use coupler_types_mod, only : coupler_type_send_data, coupler_1d_bc_type, coupler_type_spawn @@ -50,10 +53,11 @@ module MOM use MOM_ALE, only : ALE_init, ALE_end, ALE_main, ALE_CS, adjustGridForIntegrity use MOM_ALE, only : ALE_getCoordinate, ALE_getCoordinateUnits, ALE_writeCoordinateFile use MOM_ALE, only : ALE_updateVerticalGridType, ALE_remap_init_conds, 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_coord_initialization, only : MOM_initialize_coord -use MOM_diabatic_driver, only : diabatic, diabatic_driver_init, diabatic_CS +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_diagnostics, only : calculate_diagnostic_fields, MOM_diagnostics_init use MOM_diagnostics, only : register_transport_diags, post_transport_diagnostics @@ -70,11 +74,15 @@ module MOM 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_EOS, only : EOS_init, calculate_density, calculate_TFreeze +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_grid, only : ocean_grid_type, MOM_grid_init, MOM_grid_end use MOM_grid, only : set_first_direction, rescale_grid_bathymetry use MOM_hor_index, only : hor_index_type, hor_index_init +use MOM_hor_index, only : rotate_hor_index use MOM_interface_heights, only : find_eta use MOM_lateral_mixing_coeffs, only : calc_slope_functions, VarMix_init use MOM_lateral_mixing_coeffs, only : calc_resoln_function, calc_depth_function, VarMix_CS @@ -87,6 +95,7 @@ module MOM use MOM_open_boundary, only : register_temp_salt_segments use MOM_open_boundary, only : open_boundary_register_restarts use MOM_open_boundary, only : update_segment_tracer_reservoirs +use MOM_open_boundary, only : rotate_OBC_config, rotate_OBC_init use MOM_set_visc, only : set_viscous_BBL, set_viscous_ML, set_visc_init use MOM_set_visc, only : set_visc_register_restarts, set_visc_CS use MOM_sponge, only : init_sponge_diags, sponge_CS @@ -100,7 +109,7 @@ module MOM 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 +use MOM_tracer_registry, only : register_tracer_diagnostics, post_tracer_diagnostics_at_sync use MOM_tracer_registry, only : post_tracer_transport_diagnostics use MOM_tracer_registry, only : preALE_tracer_diagnostics, postALE_tracer_diagnostics use MOM_tracer_registry, only : lock_tracer_registry, tracer_registry_end @@ -108,11 +117,13 @@ module MOM use MOM_tracer_flow_control, only : tracer_flow_control_init, call_tracer_surface_state use MOM_tracer_flow_control, only : tracer_flow_control_end 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 use MOM_unit_scaling, only : unit_scaling_end, fix_restart_unit_scaling use MOM_variables, only : surface, allocate_surface_state, deallocate_surface_state use MOM_variables, only : thermo_var_ptrs, vertvisc_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 : fix_restart_scaling use MOM_verticalGrid, only : get_thickness_units, get_flux_units, get_tr_flux_units @@ -173,14 +184,17 @@ module MOM !< 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 [m] + 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 !< structure containing metrics and grid info + 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 + type(verticalGrid_type), pointer :: & GV => NULL() !< structure containing vertical grid info type(unit_scale_type), pointer :: & @@ -238,6 +252,8 @@ module MOM logical :: mixedlayer_restrat !< If true, use submesoscale mixed layer restratifying scheme. logical :: useMEKE !< If true, call the MEKE parameterization. logical :: useWaves !< If true, update Stokes drift + logical :: use_p_surf_in_EOS !< If true, always include the surface pressure contributions + !! in equation of state calculations. real :: dtbt_reset_period !< The time interval between dynamic recalculation of the !! barotropic time step [s]. If this is negative dtbt is never !! calculated, and if it is 0, dtbt is calculated every step. @@ -264,9 +280,9 @@ module MOM !! 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 [Pa] at end previous call to step_MOM - p_surf_begin => NULL(), & !< surface pressure [Pa] at start of step_MOM_dyn_... - p_surf_end => NULL() !< surface pressure [Pa] at end of step_MOM_dyn_... + 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 @@ -280,20 +296,20 @@ module MOM !! average surface tracer properties when a bulk !! mixed layer is not used [Z ~> m], or a negative value !! if a bulk mixed layer is being used. - real :: HFrz !< If HFrz > 0, melt potential will be computed. - !! The actual depth over which melt potential is computed will - !! min(HFrz, OBLD), where OBLD is the boundary layer depth. + real :: HFrz !< If HFrz > 0, the nominal depth over which melt potential is + !! computed [Z ~> m]. The actual depth over which melt potential is + !! computed is min(HFrz, OBLD), where OBLD is the boundary layer depth. !! If HFrz <= 0 (default), melt potential will not be computed. real :: Hmix_UV !< Depth scale over which to average surface flow to !! feedback to the coupler/driver [Z ~> m] when !! 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 [m] + 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 [degC] real :: bad_val_sst_min !< Minimum SST before triggering bad value message [degC] real :: bad_val_sss_max !< Maximum SSS before triggering bad value message [ppt] - real :: bad_val_col_thick !< Minimum column thickness before triggering bad value message [m] + real :: bad_val_col_thick !< Minimum column thickness before triggering bad value message [Z ~> m] logical :: answers_2018 !< If true, use expressions for the surface properties that recover !! the answers from the end of 2018. Otherwise, use more appropriate !! expressions that differ at roundoff for non-Boussinsq cases. @@ -390,6 +406,7 @@ module MOM integer :: id_clock_ALE integer :: id_clock_other integer :: id_clock_offline_tracer +integer :: id_clock_unit_tests !>@} contains @@ -399,13 +416,13 @@ module MOM !! 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, fluxes, sfc_state, Time_start, time_int_in, CS, & +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), intent(inout) :: forces !< A structure with the driving mechanical forces - type(forcing), intent(inout) :: fluxes !< A structure with pointers to themodynamic, + 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), intent(inout) :: sfc_state !< surface ocean state + 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 [s]. type(MOM_control_struct), pointer :: CS !< control structure from initialize_MOM @@ -430,6 +447,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_int_in, CS, & ! 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 @@ -473,14 +491,20 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_int_in, CS, & 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 [Pa]. + 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, Time_temp type(group_pass_type) :: pass_tau_ustar_psurf logical :: showCallTree - G => CS%G ; GV => CS%GV ; US => CS%US + ! 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 = G%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 @@ -507,6 +531,21 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_int_in, CS, & 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 + ! First determine the time step that is consistent with this call and an ! integer fraction of time_interval. if (do_dyn) then @@ -530,6 +569,8 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_int_in, CS, & if (associated(forces%p_surf)) p_surf => forces%p_surf if (.not.associated(forces%p_surf)) CS%interp_p_surf = .false. + CS%tv%p_surf => NULL() + if (CS%use_p_surf_in_EOS .and. associated(forces%p_surf)) CS%tv%p_surf => forces%p_surf !---------- Initiate group halo pass of the forcing fields call cpu_clock_begin(id_clock_pass) @@ -553,7 +594,10 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_int_in, CS, & dt = time_interval / real(n_max) dt_therm = dt ; ntstep = 1 if (associated(fluxes%p_surf)) p_surf => fluxes%p_surf - + CS%tv%p_surf => NULL() + if (associated(fluxes%p_surf)) then + if (CS%use_p_surf_in_EOS) CS%tv%p_surf => fluxes%p_surf + endif if (CS%UseWaves) call pass_var(fluxes%ustar, G%Domain, clock=id_clock_pass) endif @@ -624,6 +668,10 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_int_in, CS, & 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. @@ -791,7 +839,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_int_in, CS, & 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(CS%Tracer_reg, h, CS%diag_pre_sync, CS%diag, G, GV, CS%t_dyn_rel_diag) + 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) @@ -838,19 +886,27 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_int_in, CS, & 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, G_in, 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, ssh) + 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, CS%tv, ssh, CS%ave_ssh_ibc) + sfc_state_diag, CS%tv, ssh, CS%ave_ssh_ibc) endif call disable_averaging(CS%diag) call cpu_clock_end(id_clock_diagnostics) @@ -868,6 +924,17 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_int_in, CS, & 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 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) @@ -879,10 +946,10 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & 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 [Pa]. + !! 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 [Pa]. + !! 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]. @@ -929,7 +996,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & call enable_averages(dt_thermo, Time_local+real_to_time(US%T_to_s*(dt_thermo-dt)), CS%diag) call cpu_clock_begin(id_clock_thick_diff) if (associated(CS%VarMix)) & - call calc_slope_functions(h, CS%tv, dt, G, GV, US, CS%VarMix) + call calc_slope_functions(h, CS%tv, dt, G, GV, US, CS%VarMix, OBC=CS%OBC) call thickness_diffuse(h, CS%uhtr, CS%vhtr, CS%tv, dt_thermo, G, GV, US, & CS%MEKE, CS%VarMix, CS%CDp, CS%thickness_diffuse_CSp) call cpu_clock_end(id_clock_thick_diff) @@ -948,7 +1015,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & 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, & + call set_viscous_BBL(CS%u, CS%v, CS%h, CS%tv, CS%visc, G, GV, US, & CS%set_visc_CSp, symmetrize=.true.) call cpu_clock_end(id_clock_BBL_visc) if (showCallTree) call callTree_wayPoint("done with set_viscous_BBL (step_MOM)") @@ -1002,7 +1069,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & if (CS%debug) call hchksum(h,"Pre-thickness_diffuse h", G%HI, haloshift=0, scale=GV%H_to_m) if (associated(CS%VarMix)) & - call calc_slope_functions(h, CS%tv, dt, G, GV, US, CS%VarMix) + call calc_slope_functions(h, CS%tv, dt, G, GV, US, CS%VarMix, OBC=CS%OBC) call thickness_diffuse(h, CS%uhtr, CS%vhtr, CS%tv, dt, G, GV, US, & CS%MEKE, CS%VarMix, CS%CDp, CS%thickness_diffuse_CSp) @@ -1071,6 +1138,7 @@ subroutine step_MOM_tracer_dyn(CS, G, GV, US, h, Time_local) 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 :: showCallTree showCallTree = callTree_showQuery() @@ -1119,12 +1187,19 @@ subroutine step_MOM_tracer_dyn(CS, G, GV, US, h, Time_local) CS%t_dyn_rel_adv = 0.0 call cpu_clock_end(id_clock_tracer) ; call cpu_clock_end(id_clock_thermo) - if (CS%diabatic_first .and. associated(CS%tv%T)) 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) + if (associated(CS%tv%T)) then + call extract_diabatic_member(CS%diabatic_CSp, diabatic_halo=halo_sz) + 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) + endif endif CS%preadv_h_stored = .false. @@ -1159,7 +1234,8 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & 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 :: i, j, k, is, ie, js, je, nz! , Isq, Ieq, Jsq, Jeq, n + 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 = G%ke showCallTree = callTree_showQuery() @@ -1174,6 +1250,13 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & call apply_oda_tracer_increments(US%T_to_s*dtdia,G,tv,h,CS%odaCS) endif + if (associated(fluxes%p_surf)) then + call extract_diabatic_member(CS%diabatic_CSp, diabatic_halo=halo_sz) + if (halo_sz > 0) then + call pass_var(fluxes%p_surf, G%Domain, clock=id_clock_pass, halo=halo_sz) + 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 @@ -1200,8 +1283,8 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & 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, Waves=Waves) + 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, OBC=CS%OBC, Waves=Waves) fluxes%fluxes_used = .true. if (showCallTree) call callTree_waypoint("finished diabatic (step_MOM_thermo)") @@ -1212,12 +1295,14 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & 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) @@ -1339,7 +1424,8 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS logical :: skip_diffusion integer :: id_eta_diff_end - integer, pointer :: accumulated_time => NULL() + type(time_type), pointer :: accumulated_time => NULL() + type(time_type), pointer :: vertical_time => NULL() integer :: i,j,k integer :: is, ie, js, je, isd, ied, jsd, jed @@ -1361,32 +1447,30 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS call cpu_clock_begin(id_clock_offline_tracer) call extract_offline_main(CS%offline_CSp, uhtr, vhtr, eatr, ebtr, h_end, accumulated_time, & - dt_offline, dt_offline_vertical, skip_diffusion) + vertical_time, dt_offline, dt_offline_vertical, skip_diffusion) Time_end = increment_date(Time_start, seconds=floor(time_interval+0.001)) call enable_averaging(time_interval, Time_end, CS%diag) ! Check to see if this is the first iteration of the offline interval - if (accumulated_time==0) then + if (accumulated_time == real_to_time(0.0)) then first_iter = .true. else ! This is probably unnecessary but is used to guard against unwanted behavior first_iter = .false. endif - ! Check to see if vertical tracer functions should be done - if ( mod(accumulated_time, floor(US%T_to_s*dt_offline_vertical + 1e-6)) == 0 ) then + ! Check to see if vertical tracer functions should be done + if (first_iter .or. (accumulated_time >= vertical_time)) then do_vertical = .true. + vertical_time = accumulated_time + real_to_time(US%T_to_s*dt_offline_vertical) else do_vertical = .false. endif ! Increment the amount of time elapsed since last read and check if it's time to roll around - accumulated_time = mod(accumulated_time + int(time_interval), floor(US%T_to_s*dt_offline+1e-6)) - if (accumulated_time==0) then - last_iter = .true. - else - last_iter = .false. - endif + accumulated_time = accumulated_time + real_to_time(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 @@ -1415,7 +1499,7 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS call pass_var(CS%h, G%Domain) call calc_resoln_function(CS%h, CS%tv, G, GV, US, CS%VarMix) call calc_depth_function(G, CS%VarMix) - call calc_slope_functions(CS%h, CS%tv, dt_offline, G, GV, US, CS%VarMix) + call calc_slope_functions(CS%h, CS%tv, dt_offline, G, GV, US, CS%VarMix, OBC=CS%OBC) endif call tracer_hordiff(CS%h, dt_offline, CS%MEKE, CS%VarMix, G, GV, US, & CS%tracer_diff_CSp, CS%tracer_Reg, CS%tv) @@ -1441,7 +1525,7 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS call pass_var(CS%h, G%Domain) call calc_resoln_function(CS%h, CS%tv, G, GV, US, CS%VarMix) call calc_depth_function(G, CS%VarMix) - call calc_slope_functions(CS%h, CS%tv, dt_offline, G, GV, US, CS%VarMix) + call calc_slope_functions(CS%h, CS%tv, dt_offline, G, GV, US, CS%VarMix, OBC=CS%OBC) endif call tracer_hordiff(CS%h, dt_offline, CS%MEKE, CS%VarMix, G, GV, US, & CS%tracer_diff_CSp, CS%tracer_Reg, CS%tv) @@ -1501,6 +1585,10 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS fluxes%fluxes_used = .true. + if (last_iter) then + accumulated_time = real_to_time(0.0) + endif + call cpu_clock_end(id_clock_offline_tracer) end subroutine step_offline @@ -1531,13 +1619,24 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & !! calls to step_MOM instead of the number of !! dynamics timesteps. ! local variables - type(ocean_grid_type), pointer :: G => NULL() ! A pointer to a structure with metrics and related - type(hor_index_type) :: HI ! A hor_index_type for array extents + 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() + type(dyn_horgrid_type), pointer :: dG_in => NULL() type(diag_ctrl), pointer :: diag => NULL() type(unit_scale_type), pointer :: US => 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, dimension(:,:,:) :: u_in, v_in, h_in + real, allocatable, dimension(:,:,:), target :: T_in, S_in + 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() ! This include declares and sets the variable "version". # include "version_variable.h" @@ -1594,6 +1693,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & integer :: dynamics_stencil ! The computational stencil for the calculations ! in the dynamic core. real :: conv2watt, conv2salt + real :: RL2_T2_rescale, Z_rescale, QRZ_rescale ! Unit conversion factors character(len=48) :: flux_units, S_flux_units type(vardesc) :: vd_T, vd_S ! Structures describing temperature and salinity variables. @@ -1608,9 +1708,6 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & endif allocate(CS) - if (test_grid_copy) then ; allocate(G) - else ; G => CS%G ; endif - CS%Time => Time id_clock_init = cpu_clock_id('Ocean Initialization', grain=CLOCK_SUBCOMPONENT) @@ -1628,8 +1725,12 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & 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, "") + 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" // & @@ -1639,14 +1740,12 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & "If True, exercises unit tests at model start up.", & default=.false., debuggingParam=.true.) if (do_unit_tests) then + id_clock_unit_tests = cpu_clock_id('(Ocean unit tests)', grain=CLOCK_MODULE) + call cpu_clock_begin(id_clock_unit_tests) call unit_tests(verbosity) + call cpu_clock_end(id_clock_unit_tests) endif - ! Determining the internal unit scaling factors for this run. - call unit_scaling_init(param_file, CS%US) - - US => CS%US - call get_param(param_file, "MOM", "SPLIT", CS%split, & "Use the split time stepping if true.", default=.true.) if (CS%split) then @@ -1785,7 +1884,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & "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) + "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 "//& @@ -1805,7 +1904,8 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & endif ! This is here in case these values are used inappropriately. - use_frazil = .false. ; bound_salinity = .false. ; CS%tv%P_Ref = 2.0e7 + use_frazil = .false. ; bound_salinity = .false. + CS%tv%P_Ref = 2.0e7*US%kg_m3_to_R*US%m_s_to_L_T**2 if (use_temperature) then call get_param(param_file, "MOM", "FRAZIL", use_frazil, & "If true, water freezes if it gets too cold, and the "//& @@ -1819,21 +1919,23 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & "model may ask for more salt than is available and "//& "drive the salinity negative otherwise.)", default=.false.) call get_param(param_file, "MOM", "MIN_SALINITY", CS%tv%min_salinity, & - "The minimum value of salinity when BOUND_SALINITY=True. "//& - "The default is 0.01 for backward compatibility but ideally "//& - "should be 0.", units="PPT", default=0.01, do_not_log=.not.bound_salinity) + "The minimum value of salinity when BOUND_SALINITY=True.", & + units="PPT", default=0.0, do_not_log=.not.bound_salinity) call get_param(param_file, "MOM", "C_P", CS%tv%C_p, & "The heat capacity of sea water, approximated as a "//& "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) + call get_param(param_file, "MOM", "USE_PSURF_IN_EOS", CS%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) + "This is only used if USE_EOS and ENABLE_THERMODYNAMICS are true.", & + units="Pa", default=2.0e7, scale=US%kg_m3_to_R*US%m_s_to_L_T**2) if (bulkmixedlayer) then call get_param(param_file, "MOM", "NKML", nkml, & @@ -1866,8 +1968,8 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & 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) + "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", & @@ -1882,12 +1984,12 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & units="deg C", default=-2.1) call get_param(param_file, "MOM", "BAD_VAL_COLUMN_THICKNESS", CS%bad_val_col_thick, & "The value of column thickness below which a bad value message is "//& - "triggered, if CHECK_BAD_SURFACE_VALS is true.", units="m", & - default=0.0) + "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_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=.true.) + default=.false.) call get_param(param_file, "MOM", "SURFACE_2018_ANSWERS", CS%answers_2018, & "If true, use expressions for the surface properties that recover the answers "//& "from the end of 2018. Otherwise, use more appropriate expressions that differ "//& @@ -1949,31 +2051,97 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call callTree_waypoint("MOM parameters read (initialize_MOM)") + ! 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.") + + 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%domain, param_file, symmetric=symmetric, & + 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%domain, param_file, symmetric=symmetric) + 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) + first_direction = modulo(first_direction + turns, 2) + else + CS%G => G_in + endif + + ! TODO: It is unlikey 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) - call hor_index_init(G%Domain, HI, 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) + + ! Allocate initialize time-invariant MOM variables. + call MOM_initialize_fixed(dG_in, US, OBC_in, param_file, write_geom_files, & + dirs%output_directory) + + call callTree_waypoint("returned from MOM_initialize_fixed() (initialize_MOM)") - call create_dyn_horgrid(dG, HI, bathymetry_at_vel=bathy_at_vel) - call clone_MOM_domain(G%Domain, dG%Domain) + ! Determine HI and dG for the model index map. + if (CS%rotate_index) then + allocate(HI) + call rotate_hor_index(HI_in, turns, HI) + call create_dyn_horgrid(dG, HI, bathymetry_at_vel=bathy_at_vel) + call clone_MOM_domain(G%Domain, dG%Domain) + call rotate_dyngrid(dG_in, dG, US, turns) + 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 unsupported.") + allocate(CS%OBC) + call rotate_OBC_config(OBC_in, dG_in, CS%OBC, dG, turns) + endif + else + HI => HI_in + dG => dG_in + CS%OBC => OBC_in + endif call verticalGridInit( param_file, CS%GV, US ) GV => CS%GV @@ -1986,10 +2154,6 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call MOM_timing_init(CS) - ! Allocate initialize time-invariant MOM variables. - call MOM_initialize_fixed(dG, US, CS%OBC, param_file, write_geom_files, dirs%output_directory) - call callTree_waypoint("returned from MOM_initialize_fixed() (initialize_MOM)") - if (associated(CS%OBC)) call call_OBC_register(param_file, CS%update_OBC_CSp, CS%OBC) call tracer_registry_init(param_file, CS%tracer_Reg) @@ -2045,6 +2209,18 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & flux_scale=conv2salt, convergence_units='kg m-2 s-1', & convergence_scale=0.001*GV%H_to_kg_m2, CMOR_tendprefix="osalt", diag_form=2) endif + ! 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. + if (CS%rotate_index .and. associated(OBC_in)) & + call register_temp_salt_segments(GV, OBC_in, CS%tracer_Reg, param_file) if (associated(CS%OBC)) & call register_temp_salt_segments(GV, CS%OBC, CS%tracer_Reg, param_file) endif @@ -2052,7 +2228,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & allocate(CS%tv%frazil(isd:ied,jsd:jed)) ; CS%tv%frazil(:,:) = 0.0 endif if (bound_salinity) then - allocate(CS%tv%salt_deficit(isd:ied,jsd:jed)) ; CS%tv%salt_deficit(:,:)=0.0 + allocate(CS%tv%salt_deficit(isd:ied,jsd:jed)) ; CS%tv%salt_deficit(:,:) = 0.0 endif if (bulkmixedlayer .or. use_temperature) then @@ -2106,7 +2282,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & ! 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) call EOS_init(param_file, CS%tv%eqn_of_state) + if (use_EOS) call EOS_init(param_file, CS%tv%eqn_of_state, US) if (use_temperature) then allocate(CS%tv%TempxPmE(isd:ied,jsd:jed)) ; CS%tv%TempxPmE(:,:) = 0.0 if (use_geothermal) then @@ -2161,9 +2337,17 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & ! (potentially static) ocean-specific grid type. ! The next line would be needed if G%Domain had not already been init'd above: ! call clone_MOM_domain(dG%Domain, G%Domain) - call MOM_grid_init(G, param_file, US, HI, bathymetry_at_vel=bathy_at_vel) - call copy_dyngrid_to_MOM_grid(dG, G, US) - call destroy_dyn_horgrid(dG) + + ! NOTE: If indices are rotated, then G and G_in must both be initialized. + ! If not rotated, then G_in and G are the same grid. + if (CS%rotate_index) then + call MOM_grid_init(G, param_file, US, HI, bathymetry_at_vel=bathy_at_vel) + call copy_dyngrid_to_MOM_grid(dG, G, US) + call destroy_dyn_horgrid(dG) + endif + call MOM_grid_init(G_in, param_file, US, HI_in, bathymetry_at_vel=bathy_at_vel) + call copy_dyngrid_to_MOM_grid(dG_in, G_in, US) + call destroy_dyn_horgrid(dG_in) ! Set a few remaining fields that are specific to the ocean grid type. call set_first_direction(G, first_direction) @@ -2175,9 +2359,65 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & ! Consider removing this later? G%ke = GV%ke - 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%OBC, Time_in) + 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)) + allocate(v_in(G_in%isd:G_in%ied, G_in%JsdB:G_in%JedB, nz)) + allocate(h_in(G_in%isd:G_in%ied, G_in%jsd:G_in%jed, nz)) + u_in(:,:,:) = 0.0 + v_in(:,:,:) = 0.0 + h_in(:,:,:) = GV%Angstrom_H + + if (use_temperature) then + allocate(T_in(G_in%isd:G_in%ied, G_in%jsd:G_in%jed, nz)) + allocate(S_in(G_in%isd:G_in%ied, G_in%jsd:G_in%jed, nz)) + T_in(:,:,:) = 0.0 + S_in(:,:,:) = 0.0 + + CS%tv%T => T_in + CS%tv%S => S_in + endif + + 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, OBC_in, Time_in) + + if (use_temperature) then + CS%tv%T => CS%T + CS%tv%S => CS%S + 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 spong 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, 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 + 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%OBC, Time_in) + endif + call cpu_clock_end(id_clock_MOM_init) call callTree_waypoint("returned from MOM_initialize_state() (initialize_MOM)") @@ -2208,7 +2448,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & 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 + else ; CS%G%Domain_aux => CS%G%Domain ; endif G%ke = GV%ke endif @@ -2447,15 +2687,51 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call register_obsolete_diagnostics(param_file, CS%diag) if (use_frazil) then - if (.not.query_initialized(CS%tv%frazil,"frazil",restart_CSp)) & + if (query_initialized(CS%tv%frazil, "frazil", restart_CSp)) then + ! Test whether the dimensional rescaling has changed for heat content. + if ((US%kg_m3_to_R_restart*US%m_to_Z_restart*US%J_kg_to_Q_restart /= 0.0) .and. & + ((US%J_kg_to_Q*US%kg_m3_to_R*US%m_to_Z) /= & + (US%J_kg_to_Q_restart*US%kg_m3_to_R_restart*US%m_to_Z_restart)) ) then + QRZ_rescale = (US%J_kg_to_Q*US%kg_m3_to_R*US%m_to_Z) / & + (US%J_kg_to_Q_restart*US%kg_m3_to_R_restart*US%m_to_Z_restart) + do j=js,je ; do i=is,ie + CS%tv%frazil(i,j) = QRZ_rescale * CS%tv%frazil(i,j) + enddo ; enddo + endif + else CS%tv%frazil(:,:) = 0.0 + endif endif if (CS%interp_p_surf) then - CS%p_surf_prev_set = & - query_initialized(CS%p_surf_prev,"p_surf_prev",restart_CSp) + CS%p_surf_prev_set = query_initialized(CS%p_surf_prev,"p_surf_prev",restart_CSp) + + if (CS%p_surf_prev_set) then + ! Test whether the dimensional rescaling has changed for pressure. + if ((US%kg_m3_to_R_restart*US%s_to_T_restart*US%m_to_L_restart /= 0.0) .and. & + ((US%kg_m3_to_R*(US%m_to_L*US%s_to_T_restart)**2) /= & + (US%kg_m3_to_R_restart*(US%m_to_L_restart*US%s_to_T)**2)) ) then + RL2_T2_rescale = (US%kg_m3_to_R*(US%m_to_L*US%s_to_T_restart)**2) / & + (US%kg_m3_to_R_restart*(US%m_to_L_restart*US%s_to_T)**2) + do j=js,je ; do i=is,ie + CS%p_surf_prev(i,j) = RL2_T2_rescale * CS%p_surf_prev(i,j) + enddo ; enddo + endif - if (CS%p_surf_prev_set) call pass_var(CS%p_surf_prev, G%domain) + call pass_var(CS%p_surf_prev, G%domain) + endif + endif + + if (use_ice_shelf .and. associated(CS%Hml)) then + if (query_initialized(CS%Hml, "hML", restart_CSp)) then + ! Test whether the dimensional rescaling has changed for depths. + if ((US%m_to_Z_restart /= 0.0) .and. (US%m_to_Z /= US%m_to_Z_restart) ) then + Z_rescale = US%m_to_Z / US%m_to_Z_restart + do j=js,je ; do i=is,ie + CS%Hml(i,j) = Z_rescale * CS%Hml(i,j) + enddo ; enddo + endif + endif endif if (.not.query_initialized(CS%ave_ssh_ibc,"ave_ssh",restart_CSp)) then @@ -2469,7 +2745,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & CS%nstep_tot = 0 if (present(count_calls)) CS%count_calls = count_calls - call MOM_sum_output_init(G, US, param_file, dirs%output_directory, & + call MOM_sum_output_init(G_in, 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. @@ -2526,7 +2802,7 @@ subroutine finish_MOM_initialization(Time, dirs, CS, restart_CSp) call register_restart_field(z_interface, "eta", .true., restart_CSp_tmp, & "Interface heights", "meter", z_grid='i') - call save_restart(dirs%output_directory, Time, G, & + call save_restart(dirs%output_directory, Time, CS%G_in, & restart_CSp_tmp, filename=CS%IC_file, GV=GV) deallocate(z_interface) deallocate(restart_CSp_tmp) @@ -2617,17 +2893,20 @@ 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 inialize_MOM + 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) + 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') + if (associated(CS%tv%T)) & call register_restart_field(CS%tv%T, "Temp", .true., restart_CSp, & "Potential Temperature", "degC") @@ -2638,11 +2917,7 @@ subroutine set_restart_fields(GV, US, param_file, CS, restart_CSp) call register_restart_field(CS%h, "h", .true., restart_CSp, & "Layer Thickness", thickness_units) - call register_restart_field(CS%u, "u", .true., restart_CSp, & - "Zonal velocity", "m s-1", hor_grid='Cu') - - call register_restart_field(CS%v, "v", .true., restart_CSp, & - "Meridional velocity", "m s-1", hor_grid='Cv') + call register_restart_pair(CS%u, CS%v, u_desc, v_desc, .true., restart_CSp) if (associated(CS%tv%frazil)) & call register_restart_field(CS%tv%frazil, "frazil", .false., restart_CSp, & @@ -2675,6 +2950,8 @@ subroutine set_restart_fields(GV, US, param_file, CS, restart_CSp) "Time unit conversion factor", "T second-1") call register_restart_field(US%kg_m3_to_R_restart, "kg_m3_to_R", .false., restart_CSp, & "Density unit conversion factor", "R m3 kg-1") + call register_restart_field(US%J_kg_to_Q_restart, "J_kg_to_Q", .false., restart_CSp, & + "Heat content unit conversion factor.", units="Q kg J-1") end subroutine set_restart_fields @@ -2686,32 +2963,37 @@ subroutine adjust_ssh_for_p_atm(tv, G, GV, US, ssh, p_atm, use_EOS) 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 [m] - real, dimension(:,:), optional, pointer :: p_atm !< atmospheric pressure [Pa] + real, dimension(:,:), optional, pointer :: p_atm !< Ocean surface pressure [R L2 T-2 ~> Pa] logical, optional, intent(in) :: use_EOS !< If true, calculate the density for !! the SSH correction using the equation of state. - real :: Rho_conv ! The density used to convert surface pressure to + 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 Pa to m [m Pa-1]. + real :: IgR0 ! The SSH conversion factor from R L2 T-2 to m [m 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 + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + EOSdom(:) = EOS_domain(G%HI) if (present(p_atm)) then ; if (associated(p_atm)) then calc_rho = associated(tv%eqn_of_state) if (present(use_EOS) .and. calc_rho) calc_rho = use_EOS - ! Correct the output sea surface height for the contribution from the - ! atmospheric pressure - do j=js,je ; do i=is,ie + ! 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(i,j,1), tv%S(i,j,1), p_atm(i,j)/2.0, & - Rho_conv, tv%eqn_of_state, scale=US%kg_m3_to_R) + 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 = US%Z_to_m / (Rho_conv(i) * GV%g_Earth) + ssh(i,j) = ssh(i,j) + p_atm(i,j) * IgR0 + enddo else - Rho_conv = GV%Rho0 + do i=is,ie + ssh(i,j) = ssh(i,j) + p_atm(i,j) * (US%Z_to_m / (GV%Rho0 * GV%g_Earth)) + enddo endif - IgR0 = 1.0 / (Rho_conv * US%R_to_kg_m3*GV%mks_g_Earth) - ssh(i,j) = ssh(i,j) + p_atm(i,j) * IgR0 - enddo ; enddo + enddo endif ; endif end subroutine adjust_ssh_for_p_atm @@ -2719,42 +3001,44 @@ 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) - type(MOM_control_struct), pointer :: CS !< Master MOM control structure - type(surface), intent(inout) :: sfc_state !< transparent ocean surface state - !! structure shared with the calling routine - !! data in this structure is intent out. +subroutine extract_surface_state(CS, sfc_state_in) + type(MOM_control_struct), pointer :: 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 => 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 [kg m-2] - real :: bathy_m !< The depth of bathymetry [m] (not Z), used for error checking. + real :: mass !< Mass per unit area of a layer [R Z ~> kg m-2] real :: T_freeze !< freezing temperature [degC] 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 :: delT(SZI_(CS%G)) !< Depth integral of T-T_freeze [m degC] + real :: delT(SZI_(CS%G)) !< Depth integral of T-T_freeze [Z degC ~> m degC] logical :: use_temperature !< If true, temp and saln 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 character(240) :: msg + integer :: turns ! Number of quarter turns call callTree_enter("extract_surface_state(), MOM.F90") - G => CS%G ; GV => CS%GV ; US => CS%US + 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 @@ -2763,21 +3047,33 @@ subroutine extract_surface_state(CS, sfc_state) use_temperature = associated(CS%tv%T) - if (.not.sfc_state%arrays_allocated) then + turns = 0 + if (CS%rotate_index) & + turns = G%HI%turns + + if (.not.sfc_state_in%arrays_allocated) & ! 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, G, use_temperature, do_integrals=.true., & - omit_frazil=.not.associated(CS%tv%frazil)) + call allocate_surface_state(sfc_state_in, G_in, use_temperature, & + do_integrals=.true., omit_frazil=.not.associated(CS%tv%frazil)) + + 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)) + 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) + sfc_state%sea_lev(i,j) = US%m_to_Z*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) = US%Q_to_J_kg*US%RZ_to_kg_m2 * CS%tv%frazil(i,j) + sfc_state%frazil(i,j) = CS%tv%frazil(i,j) enddo ; enddo ; endif ! copy Hml into sfc_state, so that caps can access it @@ -2793,10 +3089,10 @@ subroutine extract_surface_state(CS, sfc_state) 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) = US%L_T_to_m_s * CS%u(I,j,1) + 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) = US%L_T_to_m_s * CS%v(i,J,1) + sfc_state%v(i,J) = CS%v(i,J,1) enddo ; enddo else ! (CS%Hmix >= 0.0) @@ -2828,7 +3124,7 @@ subroutine extract_surface_state(CS, sfc_state) 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 * US%R_to_kg_m3*GV%Rlay(k) + sfc_state%sfc_density(i,j) = sfc_state%sfc_density(i,j) + dh * GV%Rlay(k) endif depth(i) = depth(i) + dh enddo ; enddo @@ -2852,7 +3148,7 @@ subroutine extract_surface_state(CS, sfc_state) 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*US%R_to_kg_m3*GV%Rlay(1)) * I_depth + missing_depth*GV%Rlay(1)) * I_depth endif else I_depth = 1.0 / depth(i) @@ -2889,7 +3185,7 @@ subroutine extract_surface_state(CS, sfc_state) else dh = 0.0 endif - sfc_state%v(i,J) = sfc_state%v(i,J) + dh * US%L_T_to_m_s * CS%v(i,J,k) + 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. @@ -2913,7 +3209,7 @@ subroutine extract_surface_state(CS, sfc_state) else dh = 0.0 endif - sfc_state%u(I,j) = sfc_state%u(I,j) + dh * US%L_T_to_m_s * CS%u(I,j,k) + 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. @@ -2923,17 +3219,17 @@ subroutine extract_surface_state(CS, sfc_state) enddo ! end of j loop else ! Hmix_UV<=0. do j=js,je ; do I=is-1,ie - sfc_state%u(I,j) = US%L_T_to_m_s * CS%u(I,j,1) + 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) = US%L_T_to_m_s * CS%v(i,J,1) + 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, delT) + !$OMP parallel do default(shared) private(depth_ml, dh, T_freeze, depth, delT) do j=js,je do i=is,ie depth(i) = 0.0 @@ -2942,8 +3238,8 @@ subroutine extract_surface_state(CS, sfc_state) do k=1,nz ; do i=is,ie depth_ml = min(CS%HFrz, CS%visc%MLD(i,j)) - if (depth(i) + h(i,j,k)*GV%H_to_m < depth_ml) then - dh = h(i,j,k)*GV%H_to_m + if (depth(i) + h(i,j,k)*GV%H_to_Z < depth_ml) then + dh = h(i,j,k)*GV%H_to_Z elseif (depth(i) < depth_ml) then dh = depth_ml - depth(i) else @@ -2961,8 +3257,8 @@ subroutine extract_surface_state(CS, sfc_state) sfc_state%melt_potential(i,j) = 0.0 if (G%mask2dT(i,j)>0.) then - ! instantaneous melt_potential [J m-2] - sfc_state%melt_potential(i,j) = US%Q_to_J_kg*US%R_to_kg_m3 * CS%tv%C_p * GV%Rho0 * delT(i) + ! instantaneous melt_potential [Q R Z ~> J m-2] + sfc_state%melt_potential(i,j) = CS%tv%C_p * GV%Rho0 * delT(i) endif enddo enddo ! end of j loop @@ -2972,31 +3268,31 @@ subroutine extract_surface_state(CS, sfc_state) !$OMP parallel do default(shared) do j=js,je ; do i=is,ie ! Convert from gSalt to kgSalt - sfc_state%salt_deficit(i,j) = 0.001 * US%RZ_to_kg_m2*CS%tv%salt_deficit(i,j) + sfc_state%salt_deficit(i,j) = 0.001 * CS%tv%salt_deficit(i,j) enddo ; enddo endif if (allocated(sfc_state%TempxPmE) .and. associated(CS%tv%TempxPmE)) then !$OMP parallel do default(shared) do j=js,je ; do i=is,ie - sfc_state%TempxPmE(i,j) = US%RZ_to_kg_m2*CS%tv%TempxPmE(i,j) + sfc_state%TempxPmE(i,j) = CS%tv%TempxPmE(i,j) enddo ; enddo endif if (allocated(sfc_state%internal_heat) .and. associated(CS%tv%internal_heat)) then !$OMP parallel do default(shared) do j=js,je ; do i=is,ie - sfc_state%internal_heat(i,j) = US%RZ_to_kg_m2*CS%tv%internal_heat(i,j) + sfc_state%internal_heat(i,j) = CS%tv%internal_heat(i,j) enddo ; enddo endif if (allocated(sfc_state%taux_shelf) .and. associated(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) = US%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L*CS%visc%taux_shelf(I,j) + sfc_state%taux_shelf(I,j) = CS%visc%taux_shelf(I,j) enddo ; enddo endif if (allocated(sfc_state%tauy_shelf) .and. associated(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) = US%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L*CS%visc%tauy_shelf(i,J) + sfc_state%tauy_shelf(i,J) = CS%visc%tauy_shelf(i,J) enddo ; enddo endif @@ -3009,11 +3305,10 @@ subroutine extract_surface_state(CS, sfc_state) 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_kg_m2*h(i,j,k) + 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)) + 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 @@ -3021,7 +3316,7 @@ subroutine extract_surface_state(CS, sfc_state) 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_kg_m2*h(i,j,k) + 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 @@ -3029,7 +3324,7 @@ subroutine extract_surface_state(CS, sfc_state) 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_kg_m2*h(i,j,k) + 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 @@ -3038,9 +3333,8 @@ subroutine extract_surface_state(CS, sfc_state) 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_kg_m2*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)) + 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 @@ -3053,11 +3347,10 @@ subroutine extract_surface_state(CS, sfc_state) numberOfErrors=0 ! count number of errors do j=js,je; do i=is,ie if (G%mask2dT(i,j)>0.) then - bathy_m = CS%US%Z_to_m * G%bathyT(i,j) - localError = sfc_state%sea_lev(i,j)<=-bathy_m & - .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) + bathy_m < CS%bad_val_col_thick + localError = sfc_state%sea_lev(i,j) <= -G%bathyT(i,j) & + .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) < 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 & @@ -3073,18 +3366,18 @@ subroutine extract_surface_state(CS, sfc_state) '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=',bathy_m, 'SSH=',sfc_state%sea_lev(i,j), & + 'D=',CS%US%Z_to_m*G%bathyT(i,j), 'SSH=',CS%US%Z_to_m*sfc_state%sea_lev(i,j), & 'SST=',sfc_state%SST(i,j), 'SSS=',sfc_state%SSS(i,j), & - 'U-=',sfc_state%u(I-1,j), 'U+=',sfc_state%u(I,j), & - 'V-=',sfc_state%v(i,J-1), 'V+=',sfc_state%v(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,x),4(a,f8.3,x),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=',bathy_m, 'SSH=',sfc_state%sea_lev(i,j), & - 'U-=',sfc_state%u(I-1,j), 'U+=',sfc_state%u(I,j), & - 'V-=',sfc_state%v(i,J-1), 'V+=',sfc_state%v(i,J) + 'D=',CS%US%Z_to_m*G%bathyT(i,j), 'SSH=',CS%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 @@ -3101,11 +3394,33 @@ subroutine extract_surface_state(CS, sfc_state) endif endif - if (CS%debug) call MOM_surface_chksum("Post extract_sfc", sfc_state, G) + 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, G, 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, v_in, h_in, T_in, S_in + logical, intent(in) :: use_temperature + integer, intent(in) :: turns + real, dimension(:,:,:), intent(out) :: u, v, h, T, S + + 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), pointer :: CS !< MOM control structure @@ -3138,7 +3453,7 @@ subroutine get_MOM_state_elements(CS, G, GV, US, C_p, C_p_scaled, use_temp) !! units [Q degC-1 ~> J kg degC-1] logical, optional, intent(out) :: use_temp !< True if temperature is a state variable - if (present(G)) G => CS%G + 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 * CS%tv%C_p diff --git a/src/core/MOM_CoriolisAdv.F90 b/src/core/MOM_CoriolisAdv.F90 index 2f96839ed5..c969a75313 100644 --- a/src/core/MOM_CoriolisAdv.F90 +++ b/src/core/MOM_CoriolisAdv.F90 @@ -74,6 +74,10 @@ module MOM_CoriolisAdv !>@{ Diagnostic IDs integer :: id_rv = -1, id_PV = -1, id_gKEu = -1, id_gKEv = -1 integer :: id_rvxu = -1, id_rvxv = -1 + ! integer :: id_hf_gKEu = -1, id_hf_gKEv = -1 + integer :: id_hf_gKEu_2d = -1, id_hf_gKEv_2d = -1 + ! integer :: id_hf_rvxu = -1, id_hf_rvxv = -1 + integer :: id_hf_rvxu_2d = -1, id_hf_rvxv_2d = -1 !>@} end type CoriolisAdv_CS @@ -211,6 +215,16 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS) real :: QUHeff,QVHeff ! More temporary variables [H L2 T-1 s-1 ~> m3 s-2 or kg s-2]. integer :: i, j, k, n, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz +! Diagnostics for fractional thickness-weighted terms + real, allocatable, dimension(:,:) :: & + hf_gKEu_2d, hf_gKEv_2d, & ! Depth sum of hf_gKEu, hf_gKEv [L T-2 ~> m s-2]. + hf_rvxu_2d, hf_rvxv_2d ! Depth sum of hf_rvxu, hf_rvxv [L T-2 ~> m s-2]. + !real, allocatable, dimension(:,:,:) :: & + ! hf_gKEu, hf_gKEv, & ! accel. due to KE gradient x fract. thickness [L T-2 ~> m s-2]. + ! hf_rvxu, hf_rvxv ! accel. due to RV x fract. thickness [L T-2 ~> m s-2]. + ! 3D diagnostics hf_gKEu etc. are commented because there is no clarity on proper remapping grid option. + ! The code is retained for degugging purposes in the future. + ! To work, the following fields must be set outside of the usual ! is to ie range before this subroutine is called: ! v(is-1:ie+2,js-1:je+1), u(is-1:ie+1,js-1:je+2), h(is-1:ie+2,js-1:je+2), @@ -256,7 +270,7 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS) enddo ; enddo !$OMP parallel do default(private) shared(u,v,h,uh,vh,CAu,CAv,G,CS,AD,Area_h,Area_q,& - !$OMP RV,PV,is,ie,js,je,Isq,Ieq,Jsq,Jeq,nz,h_neglect,h_tiny,OBC) + !$OMP RV,PV,is,ie,js,je,Isq,Ieq,Jsq,Jeq,nz,h_neglect,h_tiny,OBC,eps_vel) do k=1,nz ! Here the second order accurate layer potential vorticities, q, @@ -828,6 +842,82 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS) if (CS%id_gKEv>0) call post_data(CS%id_gKEv, AD%gradKEv, CS%diag) if (CS%id_rvxu > 0) call post_data(CS%id_rvxu, AD%rv_x_u, CS%diag) if (CS%id_rvxv > 0) call post_data(CS%id_rvxv, AD%rv_x_v, CS%diag) + + ! Diagnostics for terms multiplied by fractional thicknesses + + ! 3D diagnostics hf_gKEu etc. are commented because there is no clarity on proper remapping grid option. + ! The code is retained for degugging purposes in the future. + !if (CS%id_hf_gKEu > 0) then + ! allocate(hf_gKEu(G%IsdB:G%IedB,G%jsd:G%jed,G%ke)) + ! do k=1,nz ; do j=js,je ; do I=Isq,Ieq + ! hf_gKEu(I,j,k) = AD%gradKEu(I,j,k) * AD%diag_hfrac_u(I,j,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_gKEu, hf_gKEu, CS%diag) + !endif + + !if (CS%id_hf_gKEv > 0) then + ! allocate(hf_gKEv(G%isd:G%ied,G%JsdB:G%JedB,G%ke)) + ! do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + ! hf_gKEv(i,J,k) = AD%gradKEv(i,J,k) * AD%diag_hfrac_v(i,J,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_gKEv, hf_gKEv, CS%diag) + !endif + + if (CS%id_hf_gKEu_2d > 0) then + allocate(hf_gKEu_2d(G%IsdB:G%IedB,G%jsd:G%jed)) + hf_gKEu_2d(:,:) = 0.0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + hf_gKEu_2d(I,j) = hf_gKEu_2d(I,j) + AD%gradKEu(I,j,k) * AD%diag_hfrac_u(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_gKEu_2d, hf_gKEu_2d, CS%diag) + deallocate(hf_gKEu_2d) + endif + + if (CS%id_hf_gKEv_2d > 0) then + allocate(hf_gKEv_2d(G%isd:G%ied,G%JsdB:G%JedB)) + hf_gKEv_2d(:,:) = 0.0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + hf_gKEv_2d(i,J) = hf_gKEv_2d(i,J) + AD%gradKEv(i,J,k) * AD%diag_hfrac_v(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_gKEv_2d, hf_gKEv_2d, CS%diag) + deallocate(hf_gKEv_2d) + endif + + !if (CS%id_hf_rvxv > 0) then + ! allocate(hf_rvxv(G%IsdB:G%IedB,G%jsd:G%jed,G%ke)) + ! do k=1,nz ; do j=js,je ; do I=Isq,Ieq + ! hf_rvxv(I,j,k) = AD%rv_x_v(I,j,k) * AD%diag_hfrac_u(I,j,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_rvxv, hf_rvxv, CS%diag) + !endif + + !if (CS%id_hf_rvxu > 0) then + ! allocate(hf_rvxu(G%isd:G%ied,G%JsdB:G%JedB,G%ke)) + ! do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + ! hf_rvxu(i,J,k) = AD%rv_x_u(i,J,k) * AD%diag_hfrac_v(i,J,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_rvxu, hf_rvxu, CS%diag) + !endif + + if (CS%id_hf_rvxv_2d > 0) then + allocate(hf_rvxv_2d(G%IsdB:G%IedB,G%jsd:G%jed)) + hf_rvxv_2d(:,:) = 0.0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + hf_rvxv_2d(I,j) = hf_rvxv_2d(I,j) + AD%rv_x_v(I,j,k) * AD%diag_hfrac_u(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_rvxv_2d, hf_rvxv_2d, CS%diag) + deallocate(hf_rvxv_2d) + endif + + if (CS%id_hf_rvxu_2d > 0) then + allocate(hf_rvxu_2d(G%isd:G%ied,G%JsdB:G%JedB)) + hf_rvxu_2d(:,:) = 0.0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + hf_rvxu_2d(i,J) = hf_rvxu_2d(i,J) + AD%rv_x_u(i,J,k) * AD%diag_hfrac_v(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_rvxu_2d, hf_rvxu_2d, CS%diag) + deallocate(hf_rvxu_2d) + endif endif end subroutine CorAdCalc @@ -1087,6 +1177,70 @@ subroutine CoriolisAdv_init(Time, G, GV, US, param_file, diag, AD, CS) 'Zonal Acceleration from Relative Vorticity', 'm-1 s-2', conversion=US%L_T2_to_m_s2) if (CS%id_rvxv > 0) call safe_alloc_ptr(AD%rv_x_v,IsdB,IedB,jsd,jed,nz) + !CS%id_hf_gKEu = register_diag_field('ocean_model', 'hf_gKEu', diag%axesCuL, Time, & + ! 'Fractional Thickness-weighted Zonal Acceleration from Grad. Kinetic Energy', & + ! 'm-1 s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_gKEu > 0) then + ! call safe_alloc_ptr(AD%gradKEu,IsdB,IedB,jsd,jed,nz) + ! call safe_alloc_ptr(AD%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + !endif + + !CS%id_hf_gKEv = register_diag_field('ocean_model', 'hf_gKEv', diag%axesCvL, Time, & + ! 'Fractional Thickness-weighted Meridional Acceleration from Grad. Kinetic Energy', & + ! 'm-1 s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_gKEv > 0) then + ! call safe_alloc_ptr(AD%gradKEv,isd,ied,JsdB,JedB,nz) + ! call safe_alloc_ptr(AD%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + !endif + + CS%id_hf_gKEu_2d = register_diag_field('ocean_model', 'hf_gKEu_2d', diag%axesCu1, Time, & + 'Depth-sum Fractional Thickness-weighted Zonal Acceleration from Grad. Kinetic Energy', & + 'm-1 s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_hf_gKEu_2d > 0) then + call safe_alloc_ptr(AD%gradKEu,IsdB,IedB,jsd,jed,nz) + call safe_alloc_ptr(AD%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + endif + + CS%id_hf_gKEv_2d = register_diag_field('ocean_model', 'hf_gKEv_2d', diag%axesCv1, Time, & + 'Depth-sum Fractional Thickness-weighted Meridional Acceleration from Grad. Kinetic Energy', & + 'm-1 s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_hf_gKEv_2d > 0) then + call safe_alloc_ptr(AD%gradKEv,isd,ied,JsdB,JedB,nz) + call safe_alloc_ptr(AD%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + endif + + !CS%id_hf_rvxu = register_diag_field('ocean_model', 'hf_rvxu', diag%axesCvL, Time, & + ! 'Fractional Thickness-weighted Meridional Acceleration from Relative Vorticity', & + ! 'm-1 s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_rvxu > 0) then + ! call safe_alloc_ptr(AD%rv_x_u,isd,ied,JsdB,JedB,nz) + ! call safe_alloc_ptr(AD%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + !endif + + !CS%id_hf_rvxv = register_diag_field('ocean_model', 'hf_rvxv', diag%axesCuL, Time, & + ! 'Fractional Thickness-weighted Zonal Acceleration from Relative Vorticity', & + ! 'm-1 s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_rvxv > 0) then + ! call safe_alloc_ptr(AD%rv_x_v,IsdB,IedB,jsd,jed,nz) + ! call safe_alloc_ptr(AD%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + !endif + + CS%id_hf_rvxu_2d = register_diag_field('ocean_model', 'hf_rvxu_2d', diag%axesCv1, Time, & + 'Fractional Thickness-weighted Meridional Acceleration from Relative Vorticity', & + 'm-1 s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_hf_rvxu_2d > 0) then + call safe_alloc_ptr(AD%rv_x_u,isd,ied,JsdB,JedB,nz) + call safe_alloc_ptr(AD%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + endif + + CS%id_hf_rvxv_2d = register_diag_field('ocean_model', 'hf_rvxv_2d', diag%axesCu1, Time, & + 'Depth-sum Fractional Thickness-weighted Zonal Acceleration from Relative Vorticity', & + 'm-1 s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_hf_rvxv_2d > 0) then + call safe_alloc_ptr(AD%rv_x_v,IsdB,IedB,jsd,jed,nz) + call safe_alloc_ptr(AD%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + endif + end subroutine CoriolisAdv_init !> Destructor for coriolisadv_cs diff --git a/src/core/MOM_PressureForce.F90 b/src/core/MOM_PressureForce.F90 index 5579b2311f..1963a8a773 100644 --- a/src/core/MOM_PressureForce.F90 +++ b/src/core/MOM_PressureForce.F90 @@ -7,12 +7,9 @@ module MOM_PressureForce use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type -use MOM_PressureForce_AFV, only : PressureForce_AFV_Bouss, PressureForce_AFV_nonBouss -use MOM_PressureForce_AFV, only : PressureForce_AFV_init, PressureForce_AFV_end -use MOM_PressureForce_AFV, only : PressureForce_AFV_CS -use MOM_PressureForce_blk_AFV, only : PressureForce_blk_AFV_Bouss, PressureForce_blk_AFV_nonBouss -use MOM_PressureForce_blk_AFV, only : PressureForce_blk_AFV_init, PressureForce_blk_AFV_end -use MOM_PressureForce_blk_AFV, only : PressureForce_blk_AFV_CS +use MOM_PressureForce_FV, only : PressureForce_FV_Bouss, PressureForce_FV_nonBouss +use MOM_PressureForce_FV, only : PressureForce_FV_init, PressureForce_FV_end +use MOM_PressureForce_FV, only : PressureForce_FV_CS use MOM_PressureForce_Mont, only : PressureForce_Mont_Bouss, PressureForce_Mont_nonBouss use MOM_PressureForce_Mont, only : PressureForce_Mont_init, PressureForce_Mont_end use MOM_PressureForce_Mont, only : PressureForce_Mont_CS @@ -31,12 +28,8 @@ module MOM_PressureForce type, public :: PressureForce_CS ; private logical :: Analytic_FV_PGF !< If true, use the analytic finite volume form !! (Adcroft et al., Ocean Mod. 2008) of the PGF. - logical :: blocked_AFV !< If true, used the blocked version of the ANALYTIC_FV_PGF - !! code. The value of this parameter should not change answers. !> Control structure for the analytically integrated finite volume pressure force - type(PressureForce_AFV_CS), pointer :: PressureForce_AFV_CSp => NULL() - !> Control structure for the analytically integrated finite volume pressure force - type(PressureForce_blk_AFV_CS), pointer :: PressureForce_blk_AFV_CSp => NULL() + type(PressureForce_FV_CS), pointer :: PressureForce_FV_CSp => NULL() !> Control structure for the Montgomery potential form of pressure force type(PressureForce_Mont_CS), pointer :: PressureForce_Mont_CSp => NULL() end type PressureForce_CS @@ -59,28 +52,20 @@ subroutine PressureForce(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm, pbce, e type(ALE_CS), pointer :: ALE_CSp !< ALE control structure real, dimension(:,:), & optional, pointer :: p_atm !< The pressure at the ice-ocean or - !! atmosphere-ocean interface [Pa]. + !! atmosphere-ocean interface [R L2 T-2 ~> Pa]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & optional, intent(out) :: pbce !< The baroclinic pressure anomaly in each layer - !! due to eta anomalies [m2 s-2 H-1 ~> m s-2 or m4 s-2 kg-1]. + !! 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 .and. CS%blocked_AFV) then + if (CS%Analytic_FV_PGF) then if (GV%Boussinesq) then - call PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, & - CS%PressureForce_blk_AFV_CSp, ALE_CSp, p_atm, pbce, eta) - else - call PressureForce_blk_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, & - CS%PressureForce_blk_AFV_CSp, p_atm, pbce, eta) - endif - elseif (CS%Analytic_FV_PGF) then - if (GV%Boussinesq) then - call PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS%PressureForce_AFV_CSp, & + call PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS%PressureForce_FV_CSp, & ALE_CSp, p_atm, pbce, eta) else - call PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS%PressureForce_AFV_CSp, & + call PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS%PressureForce_FV_CSp, & ALE_CSp, p_atm, pbce, eta) endif else @@ -122,17 +107,10 @@ subroutine PressureForce_init(Time, G, GV, US, param_file, diag, CS, tides_CSp) "the equations of state in pressure to avoid any "//& "possibility of numerical thermobaric instability, as "//& "described in Adcroft et al., O. Mod. (2008).", default=.true.) - call get_param(param_file, mdl, "BLOCKED_ANALYTIC_FV_PGF", CS%blocked_AFV, & - "If true, used the blocked version of the ANALYTIC_FV_PGF "//& - "code. The value of this parameter should not change answers.", & - default=.false., do_not_log=.true., debuggingParam=.true.) - - if (CS%Analytic_FV_PGF .and. CS%blocked_AFV) then - call PressureForce_blk_AFV_init(Time, G, GV, US, param_file, diag, & - CS%PressureForce_blk_AFV_CSp, tides_CSp) - elseif (CS%Analytic_FV_PGF) then - call PressureForce_AFV_init(Time, G, GV, US, param_file, diag, & - CS%PressureForce_AFV_CSp, tides_CSp) + + if (CS%Analytic_FV_PGF) then + call PressureForce_FV_init(Time, G, GV, US, param_file, diag, & + CS%PressureForce_FV_CSp, tides_CSp) else call PressureForce_Mont_init(Time, G, GV, US, param_file, diag, & CS%PressureForce_Mont_CSp, tides_CSp) @@ -144,10 +122,8 @@ end subroutine PressureForce_init subroutine PressureForce_end(CS) type(PressureForce_CS), pointer :: CS !< Pressure force control structure - if (CS%Analytic_FV_PGF .and. CS%blocked_AFV) then - call PressureForce_blk_AFV_end(CS%PressureForce_blk_AFV_CSp) - elseif (CS%Analytic_FV_PGF) then - call PressureForce_AFV_end(CS%PressureForce_AFV_CSp) + if (CS%Analytic_FV_PGF) then + call PressureForce_FV_end(CS%PressureForce_FV_CSp) else call PressureForce_Mont_end(CS%PressureForce_Mont_CSp) endif diff --git a/src/core/MOM_PressureForce_analytic_FV.F90 b/src/core/MOM_PressureForce_FV.F90 similarity index 72% rename from src/core/MOM_PressureForce_analytic_FV.F90 rename to src/core/MOM_PressureForce_FV.F90 index 75a2dfad7f..4fd1b583d3 100644 --- a/src/core/MOM_PressureForce_analytic_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -1,5 +1,5 @@ -!> Analytically integrated finite volume pressure gradient -module MOM_PressureForce_AFV +!> Finite volume pressure gradient (integrated by quadrature or analytically) +module MOM_PressureForce_FV ! This file is part of MOM6. See LICENSE.md for the license. @@ -14,18 +14,18 @@ module MOM_PressureForce_AFV use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type use MOM_EOS, only : calculate_density, calculate_density_derivs -use MOM_EOS, only : int_density_dz, int_specific_vol_dp -use MOM_EOS, only : int_density_dz_generic_plm, int_density_dz_generic_ppm -use MOM_EOS, only : int_spec_vol_dp_generic_plm -use MOM_EOS, only : int_density_dz_generic, int_spec_vol_dp_generic -use MOM_ALE, only : pressure_gradient_plm, pressure_gradient_ppm, ALE_CS +use MOM_density_integrals, only : int_density_dz, int_specific_vol_dp +use MOM_density_integrals, only : int_density_dz_generic_plm, int_density_dz_generic_ppm +use MOM_density_integrals, only : int_spec_vol_dp_generic_plm +use MOM_density_integrals, only : int_density_dz_generic_pcm, int_spec_vol_dp_generic_pcm +use MOM_ALE, only : TS_PLM_edge_values, TS_PPM_edge_values, ALE_CS implicit none ; private #include -public PressureForce_AFV, PressureForce_AFV_init, PressureForce_AFV_end -public PressureForce_AFV_Bouss, PressureForce_AFV_nonBouss +public PressureForce_FV_init, PressureForce_FV_end +public PressureForce_FV_Bouss, PressureForce_FV_nonBouss ! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional ! consistency testing. These are noted in comments with units like Z, H, L, and T, along with @@ -33,10 +33,10 @@ module MOM_PressureForce_AFV ! vary with the Boussinesq approximation, the Boussinesq variant is given first. !> Finite volume pressure gradient control structure -type, public :: PressureForce_AFV_CS ; private +type, public :: PressureForce_FV_CS ; private logical :: tides !< If true, apply tidal momentum forcing. real :: Rho0 !< The density used in the Boussinesq - !! approximation [kg m-3]. + !! 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. @@ -54,42 +54,16 @@ module MOM_PressureForce_AFV integer :: Recon_Scheme !< Order of the polynomial of the reconstruction of T & S !! for the finite volume pressure gradient calculation. !! By the default (1) is for a piecewise linear method - + real :: Stanley_T2_det_coeff !< The coefficient correlating SGS temperature variance with + !! the mean temperature gradient in the deterministic part of + !! the Stanley form of the Brankart correction. integer :: id_e_tidal = -1 !< Diagnostic identifier + integer :: id_tvar_sgs = -1 !< Diagnostic identifier type(tidal_forcing_CS), pointer :: tides_CSp => NULL() !< Tides control structure -end type PressureForce_AFV_CS +end type PressureForce_FV_CS contains -!> Thin interface between the model and the Boussinesq and non-Boussinesq -!! pressure force routines. -subroutine PressureForce_AFV(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm, pbce, eta) - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] - type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamic variables - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out) :: PFu !< Zonal acceleration [L T-2 ~> m s-2] - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: PFv !< Meridional acceleration [L T-2 ~> m s-2] - type(PressureForce_AFV_CS), pointer :: CS !< Finite volume PGF control structure - type(ALE_CS), pointer :: ALE_CSp !< ALE control structure - real, dimension(:,:), optional, pointer :: p_atm !< The pressure at the ice-ocean - !! or atmosphere-ocean interface [Pa]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(out) :: pbce !< The baroclinic pressure - !! anomaly in each layer due to eta anomalies - !! [m2 s-2 H-1 ~> m s-2 or m4 s-2 kg-1]. - real, dimension(SZI_(G),SZJ_(G)), optional, intent(out) :: eta !< The bottom mass used to - !! calculate PFu and PFv [H ~> m or kg m-2], with any tidal - !! contributions or compressibility compensation. - - if (GV%Boussinesq) then - call PressureForce_AFV_bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm, pbce, eta) - else - call PressureForce_AFV_nonbouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm, pbce, eta) - endif - -end subroutine PressureForce_AFV - !> \brief Non-Boussinesq analytically-integrated finite volume form of pressure gradient !! !! Determines the acceleration due to hydrostatic pressure forces, using @@ -99,7 +73,7 @@ end subroutine PressureForce_AFV !! To work, the following fields must be set outside of the usual (is:ie,js:je) !! range before this subroutine is called: !! h(isB:ie+1,jsB:je+1), T(isB:ie+1,jsB:je+1), and S(isB:ie+1,jsB:je+1). -subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm, pbce, eta) +subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm, pbce, eta) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -107,18 +81,18 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out) :: PFu !< Zonal acceleration [L T-2 ~> m s-2] real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: PFv !< Meridional acceleration [L T-2 ~> m s-2] - type(PressureForce_AFV_CS), pointer :: CS !< Finite volume PGF control structure + type(PressureForce_FV_CS), pointer :: CS !< Finite volume PGF control structure type(ALE_CS), pointer :: ALE_CSp !< ALE control structure real, dimension(:,:), optional, pointer :: p_atm !< The pressure at the ice-ocean - !! or atmosphere-ocean interface [Pa]. + !! or atmosphere-ocean interface [R L2 T-2 ~> Pa]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(out) :: pbce !< The baroclinic pressure !! anomaly in each layer due to eta anomalies - !! [m2 s-2 H-1 ~> m s-2 or m4 s-2 kg-1]. + !! [L2 T-2 H-1 ~> m s-2 or m4 s-2 kg-1]. real, dimension(SZI_(G),SZJ_(G)), optional, intent(out) :: eta !< The bottom mass used to !! calculate PFu and PFv [H ~> m or kg m-2], with any tidal !! contributions or compressibility compensation. ! Local variables - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: p ! Interface pressure [Pa]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: p ! Interface pressure [R L2 T-2 ~> Pa]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), target :: & T_tmp, & ! Temporary array of temperatures where layers that are lighter ! than the mixed layer have the mixed layer's properties [degC]. @@ -131,61 +105,65 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p T_b ! of temperature within each layer [degC]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & dza, & ! The change in geopotential anomaly between the top and bottom - ! of a layer [m2 s-2]. + ! 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 [Pa m2 s-2]. + ! the pressure anomaly at the top of the layer [R L4 Z-4 ~> Pa m2 s-2]. real, dimension(SZI_(G),SZJ_(G)) :: & - dp, & ! The (positive) change in pressure across a layer [Pa]. + dp, & ! The (positive) change in pressure across a layer [R L2 Z-2 ~> Pa]. SSH, & ! The sea surface height anomaly, in depth units [Z ~> m]. e_tidal, & ! The bottom geopotential anomaly due to tidal forces from ! astronomical sources and self-attraction and loading [Z ~> m]. 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 [m2 s-2]. + ! 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 [m2 s-2]. + ! interface below a layer, divided by the grid spacing [L2 T-2 ~> m2 s-2]. real, dimension(SZIB_(G),SZJ_(G),SZK_(G)) :: & - intx_dza ! The change in intx_za through a layer [m2 s-2]. + 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 [m2 s-2]. + ! interface below a layer, divided by the grid spacing [L2 T-2 ~> m2 s-2]. real, dimension(SZI_(G),SZJB_(G),SZK_(G)) :: & - inty_dza ! The change in inty_za through a layer [m2 s-2]. + 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, [Pa] (usually 2e7 Pa = 2000 dbar). + ! 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 [Pa]. - real :: g_Earth_z ! A scaled version of g_Earth [m2 Z-1 s-2 ~> m s-2]. - real :: I_gEarth ! The inverse of g_Earth_z [s2 Z m-2 ~> s2 m-1] + ! in roundoff and can be neglected [R L2 T-2 ~> Pa]. + real :: I_gEarth ! The inverse of GV%g_Earth [L2 Z L-2 ~> s2 m-1] real :: alpha_anom ! The in-situ specific volume, averaged over a - ! layer, less alpha_ref [m3 kg-1]. + ! 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. + 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 [m3 kg-1], that is used - ! to reduce the impact of truncation errors. - real :: rho_in_situ(SZI_(G)) ! The in situ density [kg m-3]. - real :: Pa_to_H ! A factor to convert from Pa to the thicknesss units (H). + 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 thicknesss units (H) [H T2 R-1 L-2 ~> H Pa-1]. + real :: H_to_RL2_T2 ! A factor to convert from thicknesss units (H) to pressure units [R L2 T-2 H-1 ~> Pa H-1]. ! real :: oneatm = 101325.0 ! 1 atm in [Pa] = [kg m-1 s-2] real, parameter :: C1_6 = 1.0/6.0 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 = G%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.associated(CS)) call MOM_error(FATAL, & - "MOM_PressureForce_AFV_nonBouss: Module must be initialized before it is used.") + "MOM_PressureForce_FV_nonBouss: Module must be initialized before it is used.") + if (CS%Stanley_T2_det_coeff>=0.) call MOM_error(FATAL, & + "MOM_PressureForce_FV_nonBouss: The Stanley parameterization is not yet"//& + "implemented in non-Boussinesq mode.") use_p_atm = .false. if (present(p_atm)) then ; if (associated(p_atm)) use_p_atm = .true. ; endif @@ -193,10 +171,10 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p use_ALE = .false. if (associated(ALE_CSp)) use_ALE = CS%reconstruct .and. use_EOS - dp_neglect = GV%H_to_Pa * GV%H_subroundoff - alpha_ref = 1.0/CS%Rho0 - g_Earth_z = US%L_T_to_m_s**2 * GV%g_Earth - I_gEarth = 1.0 / g_Earth_z + 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) @@ -211,7 +189,7 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p 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) + GV%H_to_Pa * h(i,j,k-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 @@ -228,8 +206,8 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p 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(:), Isq, Ieq-Isq+2, tv%eqn_of_state, scale=US%kg_m3_to_R) + 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) @@ -250,9 +228,9 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p ! of freedeom needed to know the linear profile). if ( use_ALE ) then if ( CS%Recon_Scheme == 1 ) then - call pressure_gradient_plm(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, CS%boundary_extrap) + call TS_PLM_edge_values(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, CS%boundary_extrap) elseif ( CS%Recon_Scheme == 2) then - call pressure_gradient_ppm(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, CS%boundary_extrap) + call TS_PPM_edge_values(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, CS%boundary_extrap) endif endif @@ -263,15 +241,12 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p if (use_EOS) then if ( use_ALE ) 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, dza(:,:,k), intp_dza(:,:,k), & - intx_dza(:,:,k), inty_dza(:,:,k), & - useMassWghtInterp = CS%useMassWghtInterp) - i=k + 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_AFV_nonBouss: "//& + call MOM_error(FATAL, "PressureForce_FV_nonBouss: "//& "int_spec_vol_dp_generic_ppm does not exist yet.") ! call int_spec_vol_dp_generic_ppm ( tv%T(:,:,k), T_t(:,:,k), T_b(:,:,k), & ! tv%S(:,:,k), S_t(:,:,k), S_b(:,:,k), p(:,:,K), p(:,:,K+1), & @@ -281,14 +256,14 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p else call int_specific_vol_dp(tv_tmp%T(:,:,k), tv_tmp%S(:,:,k), p(:,:,K), & p(:,:,K+1), alpha_ref, G%HI, tv%eqn_of_state, & - dza(:,:,k), intp_dza(:,:,k), intx_dza(:,:,k), & + US, dza(:,:,k), intp_dza(:,:,k), intx_dza(:,:,k), & inty_dza(:,:,k), bathyP=p(:,:,nz+1), dP_tiny=dp_neglect, & - useMassWghtInterp = CS%useMassWghtInterp) + useMassWghtInterp=CS%useMassWghtInterp) endif else - alpha_anom = 1.0/(US%R_to_kg_m3*GV%Rlay(k)) - alpha_ref + alpha_anom = 1.0 / GV%Rlay(k) - alpha_ref do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - dp(i,j) = GV%H_to_Pa * h(i,j,k) + 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 @@ -312,7 +287,7 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p !$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) - g_Earth_z*G%bathyT(i,j) + 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) @@ -328,7 +303,7 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p call calc_tidal_forcing(CS%Time, SSH, e_tidal, G, CS%tides_CSp, m_to_Z=US%m_to_Z) !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - za(i,j) = za(i,j) - g_Earth_z * e_tidal(i,j) + za(i,j) = za(i,j) - GV%g_Earth * e_tidal(i,j) enddo ; enddo endif @@ -337,19 +312,17 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p 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, Isq, Ieq-Isq+2, tv%eqn_of_state) + 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) * US%m_s_to_L_T**2 * & - (p(i,j,1)*(1.0/rho_in_situ(i) - alpha_ref) + za(i,j)) + 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) * US%m_s_to_L_T**2 * & - (p(i,j,1)*(1.0/(US%R_to_kg_m3*GV%Rlay(1)) - alpha_ref) + za(i,j)) + 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 @@ -374,28 +347,26 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p ! 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) = GV%H_to_Pa*h(i,j,k) + 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))) * & - (US%m_s_to_L_T**2 * 2.0*G%IdxCu(I,j) / & - ((dp(i,j) + dp(i+1,j)) + dp_neglect)) + 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))) * & - (US%m_s_to_L_T**2 * 2.0*G%IdyCv(i,J) / & - ((dp(i,j) + dp(i,j+1)) + dp_neglect)) + (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 @@ -416,7 +387,7 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p endif if (present(eta)) then - Pa_to_H = 1.0 / GV%H_to_Pa + 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 @@ -432,7 +403,7 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p if (CS%id_e_tidal>0) call post_data(CS%id_e_tidal, e_tidal, CS%diag) -end subroutine PressureForce_AFV_nonBouss +end subroutine PressureForce_FV_nonBouss !> \brief Boussinesq analytically-integrated finite volume form of pressure gradient !! @@ -442,7 +413,7 @@ end subroutine PressureForce_AFV_nonBouss !! To work, the following fields must be set outside of the usual (is:ie,js:je) !! range before this subroutine is called: !! h(isB:ie+1,jsB:je+1), T(isB:ie+1,jsB:je+1), and S(isB:ie+1,jsB:je+1). -subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm, pbce, eta) +subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm, pbce, eta) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -450,13 +421,13 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out) :: PFu !< Zonal acceleration [L T-2 ~> m s-2] real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: PFv !< Meridional acceleration [L T-2 ~> m s-2] - type(PressureForce_AFV_CS), pointer :: CS !< Finite volume PGF control structure + type(PressureForce_FV_CS), pointer :: CS !< Finite volume PGF control structure type(ALE_CS), pointer :: ALE_CSp !< ALE control structure real, dimension(:,:), optional, pointer :: p_atm !< The pressure at the ice-ocean - !! or atmosphere-ocean interface [Pa]. + !! or atmosphere-ocean interface [R L2 T-2 ~> Pa]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(out) :: pbce !< The baroclinic pressure !! anomaly in each layer due to eta anomalies - !! [m2 s-2 H-1 ~> m s-2 or m4 s-2 kg-1]. + !! [L2 T-2 H-1 ~> m s-2 or m4 s-2 kg-1]. real, dimension(SZI_(G),SZJ_(G)), optional, intent(out) :: eta !< The bottom mass used to !! calculate PFu and PFv [H ~> m or kg m-2], with any !! tidal contributions or compressibility compensation. @@ -471,22 +442,21 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at 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 times some dimensional - ! rescaling factors [kg m-1 R-1 s-2 ~> m2 s-2]. + 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 [Pa]. + ! the interface atop a layer [R L2 T-2 ~> Pa]. dpa, & ! The change in pressure anomaly between the top and bottom - ! of a layer [Pa]. + ! 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 Pa ~> m Pa or kg m-2 Pa]. + ! pressure anomaly at the top of the layer [H R L2 T-2 ~> m Pa or kg m-2 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 [Pa]. - intx_dpa ! The change in intx_pa through a layer [Pa]. + ! 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 [Pa]. - inty_dpa ! The change in inty_pa through a layer [Pa]. + ! 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_(G)), target :: & T_tmp, & ! Temporary array of temperatures where layers that are lighter @@ -498,32 +468,35 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at ! of salinity and temperature within each layer. 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, [Pa] (usually 2e7 Pa = 2000 dbar). - real :: p0(SZI_(G)) ! An array of zeros to use for pressure [Pa]. + ! 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 :: g_Earth_mks_z ! A scaled version of g_Earth [m2 Z-1 s-2 ~> m s-2]. - real :: g_Earth_z_geo ! Another scaled version of g_Earth [R m5 kg-1 Z-1 s-2 ~> m s-2]. - real :: I_Rho0 ! 1/Rho0 times unit scaling factors [L2 m kg-1 s2 T-2 ~> m3 kg-1]. + 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 :: Rho_ref_mks ! The reference density in mks units [kg m-3]. + real :: rho_ref ! The reference density [R ~> kg m-3]. real :: dz_neglect ! A minimal thickness [Z ~> m], like e. 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 :: Tl(5) ! copy and T in local stencil [degC] + real :: mn_T ! mean of T in local stencil [degC] + real :: mn_T2 ! mean of T**2 in local stencil [degC] + 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, parameter :: C1_6 = 1.0/6.0 + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb integer :: i, j, k is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%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.associated(CS)) call MOM_error(FATAL, & - "MOM_PressureForce_AFV_Bouss: Module must be initialized before it is used.") + "MOM_PressureForce_FV_Bouss: Module must be initialized before it is used.") use_p_atm = .false. if (present(p_atm)) then ; if (associated(p_atm)) use_p_atm = .true. ; endif @@ -532,14 +505,54 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at use_ALE = .false. if (associated(ALE_CSp)) use_ALE = CS%reconstruct .and. use_EOS + if (CS%Stanley_T2_det_coeff>=0.) then + if (.not. associated(tv%varT)) call safe_alloc_ptr(tv%varT, G%isd, G%ied, G%jsd, G%jed, GV%ke) + do k=1, nz ; do j=js-1,je+1 ; do i=is-1,ie+1 + ! Strictly speaking we should estimate the *horizontal* grid-scale variance + ! but neither of the following blocks make a rotation to the horizontal + ! and instead work along coordinate. + + ! This block calculates a simple |delta T| along coordinates and does + ! not allow vanishing layer thicknesses or layers tracking topography + !! SGS variance in i-direction [degC2] + !dTdi2 = ( ( G%mask2dCu(I ,j) * G%IdxCu(I ,j) * ( tv%T(i+1,j,k) - tv%T(i,j,k) ) & + ! + G%mask2dCu(I-1,j) * G%IdxCu(I-1,j) * ( tv%T(i,j,k) - tv%T(i-1,j,k) ) & + ! ) * G%dxT(i,j) * 0.5 )**2 + !! SGS variance in j-direction [degC2] + !dTdj2 = ( ( G%mask2dCv(i,J ) * G%IdyCv(i,J ) * ( tv%T(i,j+1,k) - tv%T(i,j,k) ) & + ! + G%mask2dCv(i,J-1) * G%IdyCv(i,J-1) * ( tv%T(i,j,k) - tv%T(i,j-1,k) ) & + ! ) * G%dyT(i,j) * 0.5 )**2 + !tv%varT(i,j,k) = CS%Stanley_T2_det_coeff * 0.5 * ( dTdi2 + dTdj2 ) + + ! 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. + 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) + r_sm_H = 1. / ( ( hl(1) + ( ( hl(2) + hl(3) ) + ( hl(4) + hl(5) ) ) ) + GV%H_subroundoff ) + ! Mean of T + Tl(1) = tv%T(i,j,k) ; Tl(2) = tv%T(i-1,j,k) ; Tl(3) = tv%T(i+1,j,k) + Tl(4) = tv%T(i,j-1,k) ; Tl(5) = tv%T(i,j+1,k) + mn_T = ( hl(1)*Tl(1) + ( ( hl(2)*Tl(2) + hl(3)*Tl(3) ) + ( hl(4)*Tl(4) + hl(5)*Tl(5) ) ) ) * r_sm_H + ! Adjust T vectors to have zero mean + Tl(:) = Tl(:) - mn_T ; mn_T = 0. + ! Variance of T + mn_T2 = ( hl(1)*Tl(1)*Tl(1) + ( ( hl(2)*Tl(2)*Tl(2) + hl(3)*Tl(3)*Tl(3) ) & + + ( hl(4)*Tl(4)*Tl(4) + hl(5)*Tl(5)*Tl(5) ) ) ) * r_sm_H + ! Variance should be positive but round-off can violate this. Calculating + ! variance directly would fix this but requires more operations. + tv%varT(i,j,k) = CS%Stanley_T2_det_coeff * max(0., mn_T2) + enddo ; enddo ; enddo + endif + h_neglect = GV%H_subroundoff dz_neglect = GV%H_subroundoff * GV%H_to_Z - I_Rho0 = US%m_s_to_L_T**2 / (US%R_to_kg_m3*GV%Rho0) - g_Earth_mks_z = US%L_T_to_m_s**2 * GV%g_Earth - g_Earth_z_geo = US%R_to_kg_m3*US%L_T_to_m_s**2 * GV%g_Earth + I_Rho0 = 1.0 / GV%Rho0 G_Rho0 = GV%g_Earth / GV%Rho0 - rho_ref_mks = CS%Rho0 - rho_ref = rho_ref_mks*US%kg_m3_to_R + rho_ref = CS%Rho0 if (CS%tides) then ! Determine the surface height anomaly for calculating self attraction @@ -591,8 +604,8 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at 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(:), Isq, Ieq-Isq+2, tv%eqn_of_state, scale=US%kg_m3_to_R) + 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 @@ -615,10 +628,10 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at 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, & - Isq, Ieq-Isq+2, tv%eqn_of_state, scale=US%kg_m3_to_R) + tv%eqn_of_state, EOSdom) else call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p0, rho_in_situ, & - Isq, Ieq-Isq+2, tv%eqn_of_state, scale=US%kg_m3_to_R) + 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) @@ -639,9 +652,9 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at ! of freedeom needed to know the linear profile). if ( use_ALE ) then if ( CS%Recon_Scheme == 1 ) then - call pressure_gradient_plm(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, CS%boundary_extrap) + call TS_PLM_edge_values(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, CS%boundary_extrap) elseif ( CS%Recon_Scheme == 2 ) then - call pressure_gradient_ppm(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, CS%boundary_extrap) + call TS_PPM_edge_values(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, CS%boundary_extrap) endif endif @@ -651,12 +664,12 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at 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*g_Earth_z_geo)*e(i,j,1) + p_atm(i,j) + pa(i,j) = (rho_ref*GV%g_Earth)*e(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 - pa(i,j) = (rho_ref*g_Earth_z_geo)*e(i,j,1) + pa(i,j) = (rho_ref*GV%g_Earth)*e(i,j,1) enddo ; enddo endif !$OMP parallel do default(shared) @@ -680,24 +693,20 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at ! where the layers are located. if ( use_ALE ) then if ( CS%Recon_Scheme == 1 ) then - call int_density_dz_generic_plm( T_t(:,:,k), T_b(:,:,k), & - S_t(:,:,k), S_b(:,:,k), e(:,:,K), e(:,:,K+1), & - rho_ref_mks, CS%Rho0, g_Earth_mks_z, & - dz_neglect, G%bathyT, G%HI, G%HI, & - tv%eqn_of_state, dpa, intz_dpa, intx_dpa, inty_dpa, & - useMassWghtInterp = CS%useMassWghtInterp) + call int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, & + rho_ref, CS%Rho0, GV%g_Earth, dz_neglect, G%bathyT, & + G%HI, GV, tv%eqn_of_state, US, dpa, intz_dpa, intx_dpa, inty_dpa, & + useMassWghtInterp=CS%useMassWghtInterp) elseif ( CS%Recon_Scheme == 2 ) then - call int_density_dz_generic_ppm( tv%T(:,:,k), T_t(:,:,k), T_b(:,:,k), & - tv%S(:,:,k), S_t(:,:,k), S_b(:,:,k), e(:,:,K), e(:,:,K+1), & - rho_ref_mks, CS%Rho0, g_Earth_mks_z, & - G%HI, G%HI, tv%eqn_of_state, dpa, intz_dpa, & - intx_dpa, inty_dpa) + call int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & + rho_ref, CS%Rho0, GV%g_Earth, dz_neglect, G%bathyT, & + G%HI, GV, tv%eqn_of_state, US, dpa, intz_dpa, intx_dpa, inty_dpa, & + useMassWghtInterp=CS%useMassWghtInterp) endif else call int_density_dz(tv_tmp%T(:,:,k), tv_tmp%S(:,:,k), e(:,:,K), e(:,:,K+1), & - rho_ref_mks, CS%Rho0, g_Earth_mks_z, G%HI, G%HI, tv%eqn_of_state, & - dpa, intz_dpa, intx_dpa, inty_dpa, & - G%bathyT, dz_neglect, CS%useMassWghtInterp) + rho_ref, CS%Rho0, GV%g_Earth, G%HI, tv%eqn_of_state, US, dpa, & + intz_dpa, intx_dpa, inty_dpa, G%bathyT, dz_neglect, CS%useMassWghtInterp) endif !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 @@ -706,7 +715,7 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at else !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - dz_geo(i,j) = g_Earth_z_geo * GV%H_to_Z*h(i,j,k) + 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 @@ -767,15 +776,14 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at if (present(eta)) then if (CS%tides) then - ! eta is the sea surface height relative to a time-invariant geoid, for - ! comparison with what is used for eta in btstep. See how e was calculated - ! about 200 lines above. - !$OMP parallel do default(shared) + ! 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 + e_tidal(i,j)*GV%Z_to_H enddo ; enddo else - !$OMP parallel do default(shared) + !$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 @@ -783,18 +791,19 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at endif if (CS%id_e_tidal>0) call post_data(CS%id_e_tidal, e_tidal, CS%diag) + if (CS%id_tvar_sgs>0) call post_data(CS%id_tvar_sgs, tv%varT, CS%diag) -end subroutine PressureForce_AFV_Bouss +end subroutine PressureForce_FV_Bouss !> Initializes the finite volume pressure gradient control structure -subroutine PressureForce_AFV_init(Time, G, GV, US, param_file, diag, CS, tides_CSp) +subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, tides_CSp) type(time_type), target, intent(in) :: Time !< Current model time type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< Parameter file handles type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure - type(PressureForce_AFV_CS), pointer :: CS !< Finite volume PGF control structure + type(PressureForce_FV_CS), pointer :: CS !< Finite volume PGF control structure type(tidal_forcing_CS), optional, pointer :: tides_CSp !< Tides control structure ! This include declares and sets the variable "version". # include "version_variable.h" @@ -812,14 +821,14 @@ subroutine PressureForce_AFV_init(Time, G, GV, US, param_file, diag, CS, tides_C if (associated(tides_CSp)) CS%tides_CSp => tides_CSp endif - mdl = "MOM_PressureForce_AFV" + mdl = "MOM_PressureForce_FV" call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "RHO_0", CS%Rho0, & "The mean ocean density used with BOUSSINESQ true to "//& "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) + units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "TIDES", CS%tides, & "If true, apply tidal momentum forcing.", default=.false.) call get_param(param_file, "MOM", "USE_REGRIDDING", use_ALE, & @@ -827,7 +836,7 @@ subroutine PressureForce_AFV_init(Time, G, GV, US, param_file, diag, CS, tides_C "If False, use the layered isopycnal algorithm.", default=.false. ) call get_param(param_file, mdl, "MASS_WEIGHT_IN_PRESSURE_GRADIENT", CS%useMassWghtInterp, & "If true, use mass weighting when interpolating T/S for "//& - "integrals near the bathymetry in AFV pressure gradient "//& + "integrals near the bathymetry in FV pressure gradient "//& "calculations.", default=.false.) call get_param(param_file, mdl, "RECONSTRUCT_FOR_PRESSURE", CS%reconstruct, & "If True, use vertical reconstruction of T & S within "//& @@ -846,7 +855,15 @@ subroutine PressureForce_AFV_init(Time, G, GV, US, param_file, diag, CS, tides_C "boundary cells is extrapolated, rather than using PCM "//& "in these cells. If true, the same order polynomial is "//& "used as is used for the interior cells.", default=.true.) - + call get_param(param_file, mdl, "PGF_STANLEY_T2_DET_COEFF", CS%Stanley_T2_det_coeff, & + "The coefficient correlating SGS temperature variance with "// & + "the mean temperature gradient in the deterministic part of "// & + "the Stanley form of the Brankart correction. "// & + "Negative values disable the scheme.", units="nondim", default=-1.0) + if (CS%Stanley_T2_det_coeff>=0.) then + CS%id_tvar_sgs = register_diag_field('ocean_model', 'tvar_sgs_pgf', diag%axesTL, & + Time, 'SGS temperature variance used in PGF', 'degC2') + endif if (CS%tides) then CS%id_e_tidal = register_diag_field('ocean_model', 'e_tidal', diag%axesT1, & Time, 'Tidal Forcing Astronomical and SAL Height Anomaly', 'meter', conversion=US%Z_to_m) @@ -857,20 +874,21 @@ subroutine PressureForce_AFV_init(Time, G, GV, US, param_file, diag, CS, tides_C call log_param(param_file, mdl, "GFS / G_EARTH", CS%GFS_scale) -end subroutine PressureForce_AFV_init +end subroutine PressureForce_FV_init !> Deallocates the finite volume pressure gradient control structure -subroutine PressureForce_AFV_end(CS) - type(PressureForce_AFV_CS), pointer :: CS !< Finite volume pressure control structure that +subroutine PressureForce_FV_end(CS) + type(PressureForce_FV_CS), pointer :: CS !< Finite volume pressure control structure that !! will be deallocated in this subroutine. if (associated(CS)) deallocate(CS) -end subroutine PressureForce_AFV_end +end subroutine PressureForce_FV_end -!> \namespace mom_pressureforce_afv +!> \namespace mom_pressureforce_fv !! !! Provides the Boussinesq and non-Boussinesq forms of horizontal accelerations -!! due to pressure gradients using a 2nd-order analytically vertically integrated -!! finite volume form, as described by Adcroft et al., 2008. +!! due to pressure gradients using a vertically integrated finite volume form, +!! as described by Adcroft et al., 2008. Integration in the vertical is made +!! either by quadrature or analytically. !! !! This form eliminates the thermobaric instabilities that had been a problem with !! previous forms of the pressure gradient force calculation, as described by @@ -884,4 +902,4 @@ end subroutine PressureForce_AFV_end !! ocean models. Ocean Modelling, 8, 279-300. !! http://dx.doi.org/10.1016/j.ocemod.2004.01.001 -end module MOM_PressureForce_AFV +end module MOM_PressureForce_FV diff --git a/src/core/MOM_PressureForce_Montgomery.F90 b/src/core/MOM_PressureForce_Montgomery.F90 index 43de125701..cade4e074d 100644 --- a/src/core/MOM_PressureForce_Montgomery.F90 +++ b/src/core/MOM_PressureForce_Montgomery.F90 @@ -3,6 +3,7 @@ module MOM_PressureForce_Mont ! This file is part of MOM6. See LICENSE.md for the license. +use MOM_density_integrals, only : int_specific_vol_dp use MOM_diag_mediator, only : post_data, register_diag_field use MOM_diag_mediator, only : safe_alloc_ptr, diag_ctrl, time_type use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe @@ -13,7 +14,7 @@ module MOM_PressureForce_Mont use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type use MOM_EOS, only : calculate_density, calculate_density_derivs -use MOM_EOS, only : int_specific_vol_dp, query_compressible +use MOM_EOS, only : query_compressible implicit none ; private @@ -31,7 +32,7 @@ module MOM_PressureForce_Mont type, public :: PressureForce_Mont_CS ; private logical :: tides !< If true, apply tidal momentum forcing. real :: Rho0 !< The density used in the Boussinesq - !! approximation [kg m-3]. + !! 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. @@ -71,7 +72,7 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb !! (equal to -dM/dy) [L T-2 ~> m s-2]. type(PressureForce_Mont_CS), pointer :: CS !< Control structure for Montgomery potential PGF real, dimension(:,:), optional, pointer :: p_atm !< The pressure at the ice-ocean or - !! atmosphere-ocean [Pa]. + !! atmosphere-ocean [R L2 T-2 ~> Pa]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & optional, intent(out) :: pbce !< The baroclinic pressure anomaly in !! each layer due to free surface height anomalies, @@ -82,8 +83,8 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & 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 [m2 s-2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: p ! Interface pressure [Pa]. + dz_geo ! The change in geopotential across a layer [L2 T-2 ~> m2 s-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+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. @@ -97,43 +98,40 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb ! 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 - ! [m2 s-2]. - dp_star, & ! Layer thickness after compensation for compressibility [Pa]. + 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_tidal, & ! Bottom geopotential anomaly due to tidal forces from ! astronomical sources and self-attraction and loading [Z ~> m]. geopot_bot ! Bottom geopotential relative to time-mean sea level, ! including any tidal contributions [L2 T-2 ~> m2 s-2]. real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate - ! density [Pa] (usually 2e7 Pa = 2000 dbar). + ! 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 [Pa]. + ! 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. + 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 [s2 Z m-2 ~> s2 m-1] + real :: I_gEarth ! The inverse of g_Earth [T2 Z L-2 ~> s2 m-1] ! real :: dalpha - real :: Pa_to_p_dyn ! A conversion factor from Pa (= kg m-1 s-2) to the units of - ! dynamic pressure (R L2 T-2) [ R L2 T-2 m s2 kg-1 ~> nondim] - real :: Pa_to_H ! A factor to convert from Pa to the thicknesss units (H). + real :: Pa_to_H ! A factor to convert from R L2 T-2 to the thickness units (H). real :: alpha_Lay(SZK_(G)) ! The specific volume of each layer [R-1 ~> m3 kg-1]. real :: dalpha_int(SZK_(G)+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 = G%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 = .false. if (present(p_atm)) then ; if (associated(p_atm)) use_p_atm = .true. ; endif @@ -148,9 +146,8 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb "can no longer be used with a compressible EOS. Use #define ANALYTIC_FV_PGF.") endif - Pa_to_p_dyn = US%kg_m3_to_R * US%m_s_to_L_T**2 - I_gEarth = 1.0 / (US%L_T_to_m_s**2 * GV%g_Earth) - dp_neglect = GV%H_to_Pa * GV%H_subroundoff + 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 @@ -163,20 +160,20 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb 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%H_to_Pa * h(i,j,k) + 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%H_to_Pa + 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. + 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. + eta(i,j) = p(i,j,nz+1) * Pa_to_H ! eta has the same units as h. enddo ; enddo endif endif @@ -192,10 +189,10 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb !$OMP parallel do default(shared) do k=1,nz call int_specific_vol_dp(tv%T(:,:,k), tv%S(:,:,k), p(:,:,k), p(:,:,k+1), & - 0.0, G%HI, tv%eqn_of_state, dz_geo(:,:,k), halo_size=1) + 0.0, G%HI, tv%eqn_of_state, US, dz_geo(:,:,k), halo_size=1) enddo !$OMP parallel do default(shared) - do j=Jsq,Jeq+1 ; do k=1,nz; do i=Isq,Ieq+1 + 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 @@ -233,8 +230,8 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb 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(:), Isq, Ieq-Isq+2, tv%eqn_of_state, scale=US%kg_m3_to_R) + 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) @@ -250,8 +247,8 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb 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,Isq,Ieq-Isq+2,tv%eqn_of_state, scale=US%kg_m3_to_R) + 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 @@ -260,20 +257,20 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb !$OMP parallel do default(shared) do j=Jsq,Jeq+1 do i=Isq,Ieq+1 - M(i,j,nz) = geopot_bot(i,j) + Pa_to_p_dyn*p(i,j,nz+1) * alpha_star(i,j,nz) + 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) + Pa_to_p_dyn*p(i,j,K+1) * (alpha_star(i,j,k) - alpha_star(i,j,k+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) + Pa_to_p_dyn*p(i,j,nz+1) * alpha_Lay(nz) + 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) + Pa_to_p_dyn*p(i,j,K+1) * dalpha_int(K+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 @@ -296,11 +293,11 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb ! 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) - Pa_to_p_dyn*p(i,j,K) * (alpha_star(i,j,k-1) - alpha_star(i,j,k)) +! 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) - Pa_to_p_dyn*p(i,j,K) * dalpha_int(K) +! M(i,j,k) = M(i,j,k-1) - p(i,j,K) * dalpha_int(K) ! enddo ; enddo ; enddo ! endif ! use_EOS @@ -321,16 +318,16 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb 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) * Pa_to_p_dyn * & - ((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_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 (associated(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) * Pa_to_p_dyn * & - ((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_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 (associated(CS%PFv_bc)) CS%PFv_bc(i,j,k) = PFv_bc enddo ; enddo @@ -372,7 +369,7 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, !! (equal to -dM/dy) [L T-2 ~> m s2]. type(PressureForce_Mont_CS), pointer :: CS !< Control structure for Montgomery potential PGF real, dimension(:,:), optional, pointer :: p_atm !< The pressure at the ice-ocean or - !! atmosphere-ocean [Pa]. + !! atmosphere-ocean [R L2 T-2 ~> Pa]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(out) :: pbce !< The baroclinic pressure anomaly in !! each layer due to free surface height anomalies !! [L2 T-2 H-1 ~> m s-2]. @@ -400,8 +397,8 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, ! forces from astronomical sources and self- ! attraction and loading, in depth units [Z ~> m]. real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate - ! density [Pa] (usually 2e7 Pa = 2000 dbar). - real :: I_Rho0 ! 1/Rho0 [m3 kg-1]. + ! 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] @@ -414,12 +411,14 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, ! 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 = G%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 = .false. if (present(p_atm)) then ; if (associated(p_atm)) use_p_atm = .true. ; endif @@ -488,8 +487,8 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, 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(:), Isq, Ieq-Isq+2, tv%eqn_of_state, scale=US%kg_m3_to_R) + 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 @@ -508,9 +507,10 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, ! This no longer includes any pressure dependency, since this routine ! will come down with a fatal error if there is any compressibility. !$OMP parallel do default(shared) - do k=1,nz+1 ; do j=Jsq,Jeq+1 + do k=1,nz ; do j=Jsq,Jeq+1 call calculate_density(tv_tmp%T(:,j,k), tv_tmp%S(:,j,k), p_ref, rho_star(:,j,k), & - Isq, Ieq-Isq+2, tv%eqn_of_state, scale=US%kg_m3_to_R*G_Rho0) + 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 @@ -520,7 +520,7 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, 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) + US%m_s_to_L_T**2*p_atm(i,j) * I_Rho0 + 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) @@ -531,7 +531,7 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, 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) + US%m_s_to_L_T**2*p_atm(i,j) * I_Rho0 + 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) @@ -609,7 +609,7 @@ subroutine Set_pbce_Bouss(e, tv, G, GV, US, Rho0, GFS_scale, pbce, rho_star) real, dimension(SZI_(G),SZJ_(G),SZK_(G)+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 [kg m-3]. + 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. @@ -623,23 +623,25 @@ subroutine Set_pbce_Bouss(e, tv, G, GV, US, Rho0, GFS_scale, pbce, rho_star) ! 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 [Pa]. + real :: press(SZI_(G)) ! Interface pressure [R L2 T-2 ~> Pa]. real :: T_int(SZI_(G)) ! Interface temperature [degC]. real :: S_int(SZI_(G)) ! Interface salinity [ppt]. real :: dR_dT(SZI_(G)) ! Partial derivative of density with temperature [R degC-1 ~> kg m-3 degC-1]. real :: dR_dS(SZI_(G)) ! Partial derivative of density with salinity [R ppt-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 m3 Z-1 T-2 kg-1 ~> m4 s-2 kg-1] + 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 [kg s-2 m-1 Z-1 ~> kg s-2 m-2] logical :: use_EOS ! If true, density is calculated from T & S using ! an equation of state. real :: z_neglect ! A thickness that is so small it is usually lost ! 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 = G%ke + EOSdom(1) = Isq - (G%isd-1) ; EOSdom(2) = G%iec+1 - (G%isd-1) - Rho0xG = Rho0*US%L_T_to_m_s**2 * GV%g_Earth + Rho0xG = Rho0 * GV%g_Earth G_Rho0 = GV%g_Earth / GV%Rho0 use_EOS = associated(tv%eqn_of_state) z_neglect = GV%H_subroundoff*GV%H_to_Z @@ -665,7 +667,7 @@ subroutine Set_pbce_Bouss(e, tv, G, GV, US, Rho0, GFS_scale, pbce, rho_star) press(i) = -Rho0xG*e(i,j,1) enddo call calculate_density(tv%T(:,j,1), tv%S(:,j,1), press, rho_in_situ, & - Isq, Ieq-Isq+2, tv%eqn_of_state, scale=US%kg_m3_to_R) + 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 @@ -676,7 +678,7 @@ subroutine Set_pbce_Bouss(e, tv, G, GV, US, Rho0, GFS_scale, pbce, rho_star) 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, & - Isq, Ieq-Isq+2, tv%eqn_of_state, scale=US%kg_m3_to_R) + 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)) * & @@ -707,22 +709,22 @@ end subroutine Set_pbce_Bouss 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_(G)+1), intent(in) :: p !< Interface pressures [Pa]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+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 + 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_(G)), 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_(G)), 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_(G)), 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 [R L2 T-2 H-1 Pa-1 ~> m2 kg-1]. + C_htot ! dP_dH divided by the total ocean pressure [H-1 ~> m2 kg-1]. real :: T_int(SZI_(G)) ! Interface temperature [degC]. real :: S_int(SZI_(G)) ! Interface salinity [ppt]. real :: dR_dT(SZI_(G)) ! Partial derivative of density with temperature [R degC-1 ~> kg m-3 degC-1]. @@ -733,17 +735,18 @@ subroutine Set_pbce_nonBouss(p, tv, G, GV, US, GFS_scale, pbce, alpha_star) 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 [Pa]. - logical :: use_EOS ! If true, density is calculated from T & S using - ! an equation of state. + ! 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 = G%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%H_to_Pa * GV%H_subroundoff + dp_neglect = GV%g_Earth * GV%H_to_RZ * GV%H_subroundoff if (use_EOS) then if (present(alpha_star)) then @@ -761,8 +764,8 @@ subroutine Set_pbce_nonBouss(p, tv, G, GV, US, GFS_scale, pbce, alpha_star) 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, Isq, Ieq-Isq+2, tv%eqn_of_state, scale=US%kg_m3_to_R) + 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)) @@ -772,10 +775,9 @@ subroutine Set_pbce_nonBouss(p, tv, G, GV, US, GFS_scale, pbce, alpha_star) 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, & - Isq, Ieq-Isq+2, tv%eqn_of_state, scale=US%kg_m3_to_R) + 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, & - Isq, Ieq-Isq+2, tv%eqn_of_state, scale=US%kg_m3_to_R) + 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)) + & @@ -796,8 +798,7 @@ subroutine Set_pbce_nonBouss(p, tv, G, GV, US, GFS_scale, pbce, alpha_star) 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) + 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 @@ -851,7 +852,7 @@ subroutine PressureForce_Mont_init(Time, G, GV, US, param_file, diag, CS, tides_ "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) + 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, "USE_EOS", use_EOS, default=.true., & diff --git a/src/core/MOM_PressureForce_blocked_AFV.F90 b/src/core/MOM_PressureForce_blocked_AFV.F90 deleted file mode 100644 index faa7912f1e..0000000000 --- a/src/core/MOM_PressureForce_blocked_AFV.F90 +++ /dev/null @@ -1,879 +0,0 @@ -!> Analytically integrated finite volume pressure gradient -module MOM_PressureForce_blk_AFV - -! 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_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 : int_density_dz, int_specific_vol_dp -use MOM_EOS, only : int_density_dz_generic_plm, int_density_dz_generic_ppm -use MOM_EOS, only : int_spec_vol_dp_generic_plm -use MOM_EOS, only : int_density_dz_generic, int_spec_vol_dp_generic -use MOM_ALE, only : pressure_gradient_plm, pressure_gradient_ppm, ALE_CS - -implicit none ; private - -#include - -public PressureForce_blk_AFV, PressureForce_blk_AFV_init, PressureForce_blk_AFV_end -public PressureForce_blk_AFV_Bouss, PressureForce_blk_AFV_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_blk_AFV_CS ; private - logical :: tides !< If true, apply tidal momentum forcing. - real :: Rho0 !< The density used in the Boussinesq - !! approximation [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 :: 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 - - integer :: id_e_tidal = -1 !< Diagnostic identifier - type(tidal_forcing_CS), pointer :: tides_CSp => NULL() !< Tides control structure -end type PressureForce_blk_AFV_CS - -contains - -!> Thin interface between the model and the Boussinesq and non-Boussinesq -!! pressure force routines. -subroutine PressureForce_blk_AFV(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm, pbce, eta) - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] - type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamic variables - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out) :: PFu !< Zonal acceleration [L T-2 ~> m s-2] - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: PFv !< Meridional acceleration [L T-2 ~> m s-2] - type(PressureForce_blk_AFV_CS), pointer :: CS !< Finite volume PGF control structure - type(ALE_CS), pointer :: ALE_CSp !< ALE control structure - real, dimension(:,:), optional, pointer :: p_atm !< The pressure at the ice-ocean - !! or atmosphere-ocean interface [Pa]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(out) :: pbce !< The baroclinic pressure - !! anomaly in each layer due to eta anomalies - !! [m2 s-2 H-1 ~> m s-2 or m4 s-2 kg-1]. - real, dimension(SZI_(G),SZJ_(G)), optional, intent(out) :: eta !< The bottom mass used to - !! calculate PFu and PFv [H ~> m or kg m-2], with any tidal - !! contributions or compressibility compensation. - - if (GV%Boussinesq) then - call PressureForce_blk_AFV_bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm, pbce, eta) - else - call PressureForce_blk_AFV_nonbouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, eta) - endif - -end subroutine PressureForce_blk_AFV - -!> \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. This version uses code-blocking for threads. -!! -!! 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_blk_AFV_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_(G)), 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_(G)), intent(out) :: PFu !< Zonal acceleration [L T-2 ~> m s-2] - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: PFv !< Meridional acceleration [L T-2 ~> m s-2] - type(PressureForce_blk_AFV_CS), pointer :: CS !< Finite volume PGF control structure - real, dimension(:,:), optional, pointer :: p_atm !< The pressure at the ice-ocean - !! or atmosphere-ocean interface [Pa]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(out) :: pbce !< The baroclinic pressure - !! anomaly in each layer due to eta anomalies - !! [m2 s-2 H-1 ~> m s-2 or m4 s-2 kg-1]. - real, dimension(SZI_(G),SZJ_(G)), optional, intent(out) :: eta !< The bottom mass used to - !! calculate PFu and PFv [H ~> m or kg m-2], with any tidal - !! contributions or compressibility compensation. - ! Local variables - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: p ! Interface pressure [Pa]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), target :: & - T_tmp, & ! Temporary array of temperatures where layers that are lighter - ! than the mixed layer have the mixed layer's properties [degC]. - S_tmp ! Temporary array of salinities where layers that are lighter - ! than the mixed layer have the mixed layer's properties [ppt]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & - dza, & ! The change in geopotential anomaly between the top and bottom - ! of a layer [m2 s-2]. - intp_dza ! The vertical integral in depth of the pressure anomaly less - ! the pressure anomaly at the top of the layer [Pa m2 s-2]. - real, dimension(SZI_(G),SZJ_(G)) :: & - dp, & ! The (positive) change in pressure across a layer [Pa]. - SSH, & ! The sea surface height anomaly, in depth units [Z ~> m]. - e_tidal, & ! The bottom geopotential anomaly due to tidal forces from - ! astronomical sources and self-attraction and loading [Z ~> m]. - dM, & ! The barotropic adjustment to the Montgomery potential to - ! account for a reduced gravity model [m2 s-2]. - za ! The geopotential anomaly (i.e. g*e + alpha_0*pressure) at the - ! interface atop a layer [m2 s-2]. - real, dimension(SZDI_(G%Block(1)),SZDJ_(G%Block(1))) :: & ! on block indices - dp_bk, & ! The (positive) change in pressure across a layer [Pa]. - za_bk ! The geopotential anomaly (i.e. g*e + alpha_0*pressure) at the - ! interface atop a layer [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(SZDIB_(G%Block(1)),SZDJ_(G%Block(1))) :: & ! on block indices - intx_za_bk ! The zonal integral of the geopotential anomaly along the - ! interface below a layer, divided by the grid spacing [m2 s-2]. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)) :: & - intx_dza ! The change in intx_za through a layer [m2 s-2]. - real, dimension(SZDI_(G%Block(1)),SZDJB_(G%Block(1))) :: & ! on block indices - inty_za_bk ! The meridional integral of the geopotential anomaly along the - ! interface below a layer, divided by the grid spacing [m2 s-2]. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)) :: & - inty_dza ! The change in inty_za through a layer [m2 s-2]. - real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate - ! density [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 [Pa]. - real :: g_Earth_z ! A scaled version of g_Earth [m2 Z-1 s-2 ~> m s-2]. - real :: I_gEarth ! The inverse of g_Earth_z [s2 Z m-2 ~> s2 m-1] - real :: alpha_anom ! The in-situ specific volume, averaged over a - ! layer, less alpha_ref [m3 kg-1]. - 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. - type(thermo_var_ptrs) :: tv_tmp! A structure of temporary T & S. - - real :: alpha_ref ! A reference specific volume [m3 kg-1], that is used - ! to reduce the impact of truncation errors. - real :: rho_in_situ(SZI_(G)) ! The in situ density [kg m-3]. - real :: Pa_to_H ! A factor to convert from Pa to the thicknesss units (H). -! real :: oneatm = 101325.0 ! 1 atm in [Pa] = [kg m-1 s-2] - real, parameter :: C1_6 = 1.0/6.0 - integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb - integer :: is_bk, ie_bk, js_bk, je_bk, Isq_bk, Ieq_bk, Jsq_bk, Jeq_bk - integer :: i, j, k, n, ib, jb, ioff_bk, joff_bk - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke - nkmb=GV%nk_rho_varies - Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - - if (.not.associated(CS)) call MOM_error(FATAL, & - "MOM_PressureForce_AFV_nonBouss: Module must be initialized before it is used.") - - use_p_atm = .false. - if (present(p_atm)) then ; if (associated(p_atm)) use_p_atm = .true. ; endif - use_EOS = associated(tv%eqn_of_state) - - dp_neglect = GV%H_to_Pa * GV%H_subroundoff - alpha_ref = 1.0/CS%Rho0 - g_Earth_z = US%L_T_to_m_s**2 * GV%g_Earth - I_gEarth = 1.0 / g_Earth_z - - 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 ! 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) + GV%H_to_Pa * 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 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(:), Isq, Ieq-Isq+2, tv%eqn_of_state, scale=US%kg_m3_to_R) - 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 - - !$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 - call int_specific_vol_dp(tv_tmp%T(:,:,k), tv_tmp%S(:,:,k), p(:,:,K), & - p(:,:,K+1), alpha_ref, G%HI, tv%eqn_of_state, & - dza(:,:,k), intp_dza(:,:,k), intx_dza(:,:,k), & - inty_dza(:,:,k), bathyP=p(:,:,nz+1), dP_tiny=dp_neglect, & - useMassWghtInterp = CS%useMassWghtInterp) - else - alpha_anom = 1.0/(US%R_to_kg_m3*GV%Rlay(k)) - alpha_ref - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - dp(i,j) = GV%H_to_Pa * 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) - g_Earth_z*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 - - if (CS%tides) then - ! Find and add the tidal geopotential anomaly. - !$OMP parallel do default(shared) - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - SSH(i,j) = (za(i,j) - alpha_ref*p(i,j,1)) * I_gEarth - enddo ; enddo - call calc_tidal_forcing(CS%Time, SSH, e_tidal, G, CS%tides_CSp, m_to_Z=US%m_to_Z) - !$OMP parallel do default(shared) - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - za(i,j) = za(i,j) - g_Earth_z * e_tidal(i,j) - enddo ; enddo - 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, Isq, Ieq-Isq+2, tv%eqn_of_state) - - do i=Isq,Ieq+1 - dM(i,j) = (CS%GFS_scale - 1.0) * & - US%m_s_to_L_T**2*(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) * & - US%m_s_to_L_T**2*(p(i,j,1)*(1.0/(US%R_to_kg_m3*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(none) shared(nz,za,G,GV,dza,intx_dza,h,PFu, & -!$OMP intp_dza,p,dp_neglect,inty_dza,PFv,CS,dM,US) & -!$OMP private(is_bk,ie_bk,js_bk,je_bk,Isq_bk,Ieq_bk,Jsq_bk, & -!$OMP Jeq_bk,ioff_bk,joff_bk,i,j,za_bk,intx_za_bk, & -!$OMP inty_za_bk,dp_bk) - do n = 1, G%nblocks - is_bk=G%block(n)%isc ; ie_bk=G%block(n)%iec - js_bk=G%block(n)%jsc ; je_bk=G%block(n)%jec - Isq_bk=G%block(n)%IscB ; Ieq_bk=G%block(n)%IecB - Jsq_bk=G%block(n)%JscB ; Jeq_bk=G%block(n)%JecB - ioff_bk = G%Block(n)%idg_offset - G%HI%idg_offset - joff_bk = G%Block(n)%jdg_offset - G%HI%jdg_offset - do jb=Jsq_bk,Jeq_bk+1 ; do ib=Isq_bk,Ieq_bk+1 - i = ib+ioff_bk ; j = jb+joff_bk - za_bk(ib,jb) = za(i,j) - enddo ; enddo - do jb=js_bk,je_bk ; do Ib=Isq_bk,Ieq_bk - I = Ib+ioff_bk ; j = jb+joff_bk - intx_za_bk(Ib,jb) = 0.5*(za_bk(ib,jb) + za_bk(ib+1,jb)) - enddo ; enddo - do Jb=Jsq_bk,Jeq_bk ; do ib=is_bk,ie_bk - i = ib+ioff_bk ; J = Jb+joff_bk - inty_za_bk(ib,Jb) = 0.5*(za_bk(ib,jb) + za_bk(ib,jb+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. - do jb=Jsq_bk,Jeq_bk+1 ; do ib=Isq_bk,Ieq_bk+1 - i = ib+ioff_bk ; j = jb+joff_bk - dp_bk(ib,jb) = GV%H_to_Pa*h(i,j,k) - za_bk(ib,jb) = za_bk(ib,jb) - dza(i,j,k) - enddo ; enddo - do jb=js_bk,je_bk ; do Ib=Isq_bk,Ieq_bk - I = Ib+ioff_bk ; j = jb+joff_bk - intx_za_bk(Ib,jb) = intx_za_bk(Ib,jb) - intx_dza(I,j,k) - PFu(I,j,k) = (((za_bk(ib,jb)*dp_bk(ib,jb) + intp_dza(i,j,k)) - & - (za_bk(ib+1,jb)*dp_bk(ib+1,jb) + intp_dza(i+1,j,k))) + & - ((dp_bk(ib+1,jb) - dp_bk(ib,jb)) * intx_za_bk(Ib,jb) - & - (p(i+1,j,K) - p(i,j,K)) * intx_dza(I,j,k))) * & - (US%m_s_to_L_T**2 * 2.0*G%IdxCu(I,j) / & - ((dp_bk(ib,jb) + dp_bk(ib+1,jb)) + dp_neglect)) - enddo ; enddo - do Jb=Jsq_bk,Jeq_bk ; do ib=is_bk,ie_bk - i = ib+ioff_bk ; J = Jb+joff_bk - inty_za_bk(ib,Jb) = inty_za_bk(ib,Jb) - inty_dza(i,J,k) - PFv(i,J,k) = (((za_bk(ib,jb)*dp_bk(ib,jb) + intp_dza(i,j,k)) - & - (za_bk(ib,jb+1)*dp_bk(ib,jb+1) + intp_dza(i,j+1,k))) + & - ((dp_bk(ib,jb+1) - dp_bk(ib,jb)) * inty_za_bk(ib,Jb) - & - (p(i,j+1,K) - p(i,j,K)) * inty_dza(i,J,k))) * & - (US%m_s_to_L_T**2 * 2.0*G%IdyCv(i,J) / & - ((dp_bk(ib,jb) + dp_bk(ib,jb+1)) + dp_neglect)) - enddo ; enddo - - if (CS%GFS_scale < 1.0) then - ! Adjust the Montgomery potential to make this a reduced gravity model. - do j=js_bk+joff_bk,je_bk+joff_bk ; do I=Isq_bk+ioff_bk,Ieq_bk+ioff_bk - PFu(I,j,k) = PFu(I,j,k) - (dM(i+1,j) - dM(i,j)) * G%IdxCu(I,j) - enddo ; enddo - do J=Jsq_bk+joff_bk,Jeq_bk+joff_bk ; do i=is_bk+ioff_bk,ie_bk+ioff_bk - PFv(i,J,k) = PFv(i,J,k) - (dM(i,j+1) - dM(i,j)) * G%IdyCv(i,J) - enddo ; enddo - endif - enddo - 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%H_to_Pa - 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 - - if (CS%id_e_tidal>0) call post_data(CS%id_e_tidal, e_tidal, CS%diag) - -end subroutine PressureForce_blk_AFV_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, making -!! the Boussinesq approximation. This version uses code-blocking for threads. -!! -!! 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_blk_AFV_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_(G)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] - type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out) :: PFu !< Zonal acceleration [L T-2 ~> m s-2] - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: PFv !< Meridional acceleration [L T-2 ~> m s-2] - type(PressureForce_blk_AFV_CS), pointer :: CS !< Finite volume PGF control structure - type(ALE_CS), pointer :: ALE_CSp !< ALE control structure - real, dimension(:,:), optional, pointer :: p_atm !< The pressure at the ice-ocean - !! or atmosphere-ocean interface [Pa]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(out) :: pbce !< The baroclinic pressure - !! anomaly in each layer due to eta anomalies - !! [m2 s-2 H-1 ~> m s-2 or m4 s-2 kg-1]. - real, dimension(SZI_(G),SZJ_(G)), optional, intent(out) :: eta !< The bottom mass used to - !! calculate PFu and PFv [H ~> m or kg m-2], with any tidal - !! contributions or compressibility compensation. - ! Local variables - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: e ! Interface height in depth units [Z ~> m]. - real, dimension(SZI_(G),SZJ_(G)) :: & - e_tidal, & ! The bottom geopotential anomaly due to tidal forces from - ! astronomical sources and self-attraction and loading, 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(SZDI_(G%Block(1)),SZDJ_(G%Block(1))) :: & ! on block indices - dz_bk, & ! The change in geopotential thickness through a layer times some dimensional - ! rescaling factors [kg m-1 R-1 s-2 ~> m2 s-2]. - pa_bk, & ! The pressure anomaly (i.e. pressure + g*RHO_0*e) at the - ! the interface atop a layer [Pa]. - dpa_bk, & ! The change in pressure anomaly between the top and bottom - ! of a layer [Pa]. - intz_dpa_bk ! The vertical integral in depth of the pressure anomaly less the - ! pressure anomaly at the top of the layer [H Pa ~> m Pa or kg m-2 Pa]. - real, dimension(SZDIB_(G%Block(1)),SZDJ_(G%Block(1))) :: & ! on block indices - intx_pa_bk, & ! The zonal integral of the pressure anomaly along the interface - ! atop a layer, divided by the grid spacing [Pa]. - intx_dpa_bk ! The change in intx_pa through a layer [Pa]. - real, dimension(SZDI_(G%Block(1)),SZDJB_(G%Block(1))) :: & ! on block indices - inty_pa_bk, & ! The meridional integral of the pressure anomaly along the - ! interface atop a layer, divided by the grid spacing [Pa]. - inty_dpa_bk ! The change in inty_pa through a layer [Pa]. - - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), target :: & - T_tmp, & ! Temporary array of temperatures where layers that are lighter - ! than the mixed layer have the mixed layer's properties [degC]. - S_tmp ! Temporary array of salinities where layers that are lighter - ! than the mixed layer have the mixed layer's properties [ppt]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & - S_t, S_b, & ! Top and bottom edge salinities for linear reconstructions within each layer [ppt]. - T_t, T_b ! Top and bottom edge temperatures for linear reconstructions within each layer [degC]. - 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 [Pa] (usually 2e7 Pa = 2000 dbar). - real :: p0(SZI_(G)) ! An array of zeros to use for pressure [Pa]. - 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_Rho0 ! 1/Rho0 times unit scaling factors [L2 m kg-1 s2 T-2 ~> m3 kg-1]. - real :: g_Earth_mks_z ! A scaled version of g_Earth [m2 Z-1 s-2 ~> m s-2]. - real :: g_Earth_z_geo ! Another scaled version of g_Earth [R m5 kg-1 Z-1 s-2 ~> m s-2]. - real :: G_Rho0 ! G_Earth / Rho0 [L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1]. - real :: Rho_ref ! The reference density [R-1 ~> kg m-3]. - real :: Rho_ref_mks ! The reference density in mks units [kg m-3]. - real :: dz_neglect ! A minimal thickness [Z ~> m], like e. - 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 - integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb - integer :: is_bk, ie_bk, js_bk, je_bk, Isq_bk, Ieq_bk, Jsq_bk, Jeq_bk - integer :: ioff_bk, joff_bk - integer :: i, j, k, n, ib, jb - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke - nkmb=GV%nk_rho_varies - Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - - if (.not.associated(CS)) call MOM_error(FATAL, & - "MOM_PressureForce_AFV_Bouss: Module must be initialized before it is used.") - - use_p_atm = .false. - if (present(p_atm)) then ; if (associated(p_atm)) use_p_atm = .true. ; endif - 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%H_subroundoff * GV%H_to_Z - I_Rho0 = US%m_s_to_L_T**2 / (US%R_to_kg_m3*GV%Rho0) - g_Earth_mks_z = US%L_T_to_m_s**2 * GV%g_Earth - g_Earth_z_geo = US%R_to_kg_m3*US%L_T_to_m_s**2 * GV%g_Earth - G_Rho0 = GV%g_Earth / GV%Rho0 - Rho_ref_mks = CS%Rho0 - Rho_ref = Rho_ref_mks*US%kg_m3_to_R - - if (CS%tides) 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 - e(i,j,1) = -G%bathyT(i,j) - enddo - do k=1,nz ; do i=Isq,Ieq+1 - e(i,j,1) = e(i,j,1) + h(i,j,k)*GV%H_to_Z - enddo ; enddo - enddo - call calc_tidal_forcing(CS%Time, e(:,:,1), e_tidal, G, CS%tides_CSp, m_to_Z=US%m_to_Z) - endif - -! Here layer interface heights, e, are calculated. - if (CS%tides) then - !$OMP parallel do default(shared) - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - e(i,j,nz+1) = -(G%bathyT(i,j) + e_tidal(i,j)) - 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) - 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 -! With a bulk mixed layer, replace the T & S of any layers that are -! lighter than the 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(:), Isq, Ieq-Isq+2, tv%eqn_of_state, scale=US%kg_m3_to_R) - - 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, Isq, Ieq-Isq+2, tv%eqn_of_state, scale=US%kg_m3_to_R) - else - call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p0, & - rho_in_situ, Isq, Ieq-Isq+2, tv%eqn_of_state, scale=US%kg_m3_to_R) - endif - do i=Isq,Ieq+1 - dM(i,j) = (CS%GFS_scale - 1.0) * (G_Rho0 * rho_in_situ(i)) * e(i,j,1) - 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) - 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 freedeom needed to know the linear profile). - if ( use_ALE ) then - if ( CS%Recon_Scheme == 1 ) then - call pressure_gradient_plm(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, CS%boundary_extrap) - elseif ( CS%Recon_Scheme == 2 ) then - call pressure_gradient_ppm(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, CS%boundary_extrap) - endif - endif - -!$OMP parallel do default(none) shared(use_p_atm,Rho_ref,Rho_ref_mks,G,GV,e,p_atm,nz,use_EOS,& -!$OMP use_ALE,T_t,T_b,S_t,S_b,CS,tv,tv_tmp,g_Earth_z_geo, & -!$OMP g_Earth_mks_z,h,PFu,I_Rho0,h_neglect,dz_neglect,PFv,dM)& -!$OMP private(is_bk,ie_bk,js_bk,je_bk,Isq_bk,Ieq_bk,Jsq_bk, & -!$OMP Jeq_bk,ioff_bk,joff_bk,pa_bk, & -!$OMP intx_pa_bk,inty_pa_bk,dpa_bk,intz_dpa_bk, & -!$OMP intx_dpa_bk,inty_dpa_bk,dz_bk,i,j) - do n = 1, G%nblocks - is_bk=G%Block(n)%isc ; ie_bk=G%Block(n)%iec - js_bk=G%Block(n)%jsc ; je_bk=G%Block(n)%jec - Isq_bk=G%Block(n)%IscB ; Ieq_bk=G%Block(n)%IecB - Jsq_bk=G%Block(n)%JscB ; Jeq_bk=G%Block(n)%JecB - ioff_bk = G%Block(n)%idg_offset - G%HI%idg_offset - joff_bk = G%Block(n)%jdg_offset - G%HI%jdg_offset - - ! 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 - do jb=Jsq_bk,Jeq_bk+1 ; do ib=Isq_bk,Ieq_bk+1 - i = ib+ioff_bk ; j = jb+joff_bk - pa_bk(ib,jb) = (Rho_ref*g_Earth_z_geo)*e(i,j,1) + p_atm(i,j) - enddo ; enddo - else - do jb=Jsq_bk,Jeq_bk+1 ; do ib=Isq_bk,Ieq_bk+1 - i = ib+ioff_bk ; j = jb+joff_bk - pa_bk(ib,jb) = (Rho_ref*g_Earth_z_geo)*e(i,j,1) - enddo ; enddo - endif - do jb=js_bk,je_bk ; do Ib=Isq_bk,Ieq_bk - intx_pa_bk(Ib,jb) = 0.5*(pa_bk(ib,jb) + pa_bk(ib+1,jb)) - enddo ; enddo - do Jb=Jsq_bk,Jeq_bk ; do ib=is_bk,ie_bk - inty_pa_bk(ib,Jb) = 0.5*(pa_bk(ib,jb) + pa_bk(ib,jb+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 ) then - if ( CS%Recon_Scheme == 1 ) then - call int_density_dz_generic_plm( T_t(:,:,k), T_b(:,:,k), & - S_t(:,:,k), S_b(:,:,k), e(:,:,K), e(:,:,K+1), & - Rho_ref_mks, CS%Rho0, g_Earth_mks_z, & - dz_neglect, G%bathyT, G%HI, G%Block(n), & - tv%eqn_of_state, dpa_bk, intz_dpa_bk, intx_dpa_bk, inty_dpa_bk, & - useMassWghtInterp = CS%useMassWghtInterp) - elseif ( CS%Recon_Scheme == 2 ) then - call int_density_dz_generic_ppm( tv%T(:,:,k), T_t(:,:,k), T_b(:,:,k), & - tv%S(:,:,k), S_t(:,:,k), S_b(:,:,k), e(:,:,K), e(:,:,K+1), & - Rho_ref_mks, CS%Rho0, g_Earth_mks_z, & - G%HI, G%Block(n), tv%eqn_of_state, dpa_bk, intz_dpa_bk, & - intx_dpa_bk, inty_dpa_bk) - endif - else - call int_density_dz(tv_tmp%T(:,:,k), tv_tmp%S(:,:,k), e(:,:,K), e(:,:,K+1), & - Rho_ref_mks, CS%Rho0, g_Earth_mks_z, G%HI, G%Block(n), tv%eqn_of_state, & - dpa_bk, intz_dpa_bk, intx_dpa_bk, inty_dpa_bk, & - G%bathyT, dz_neglect, CS%useMassWghtInterp) - endif - do jb=Jsq_bk,Jeq_bk+1 ; do ib=Isq_bk,Ieq_bk+1 - intz_dpa_bk(ib,jb) = intz_dpa_bk(ib,jb)*GV%Z_to_H - enddo ; enddo - else - do jb=Jsq_bk,Jeq_bk+1 ; do ib=Isq_bk,Ieq_bk+1 - i = ib+ioff_bk ; j = jb+joff_bk - dz_bk(ib,jb) = g_Earth_z_geo*GV%H_to_Z*h(i,j,k) - dpa_bk(ib,jb) = (GV%Rlay(k) - Rho_ref)*dz_bk(ib,jb) - intz_dpa_bk(ib,jb) = 0.5*(GV%Rlay(k) - Rho_ref) * dz_bk(ib,jb)*h(i,j,k) - enddo ; enddo - do jb=js_bk,je_bk ; do Ib=Isq_bk,Ieq_bk - intx_dpa_bk(Ib,jb) = 0.5*(GV%Rlay(k) - Rho_ref) * (dz_bk(ib,jb)+dz_bk(ib+1,jb)) - enddo ; enddo - do Jb=Jsq_bk,Jeq_bk ; do ib=is_bk,ie_bk - inty_dpa_bk(ib,Jb) = 0.5*(GV%Rlay(k) - Rho_ref) * (dz_bk(ib,jb)+dz_bk(ib,jb+1)) - enddo ; enddo - endif - - ! Compute pressure gradient in x direction - do jb=js_bk,je_bk ; do Ib=Isq_bk,Ieq_bk - I = Ib+ioff_bk ; j = jb+joff_bk - PFu(I,j,k) = (((pa_bk(ib,jb)*h(i,j,k) + intz_dpa_bk(ib,jb)) - & - (pa_bk(ib+1,jb)*h(i+1,j,k) + intz_dpa_bk(ib+1,jb))) + & - ((h(i+1,j,k) - h(i,j,k)) * intx_pa_bk(Ib,jb) - & - (e(i+1,j,K+1) - e(i,j,K+1)) * intx_dpa_bk(Ib,jb) * 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_bk(Ib,jb) = intx_pa_bk(Ib,jb) + intx_dpa_bk(Ib,jb) - enddo ; enddo - ! Compute pressure gradient in y direction - do Jb=Jsq_bk,Jeq_bk ; do ib=is_bk,ie_bk - i = ib+ioff_bk ; J = Jb+joff_bk - PFv(i,J,k) = (((pa_bk(ib,jb)*h(i,j,k) + intz_dpa_bk(ib,jb)) - & - (pa_bk(ib,jb+1)*h(i,j+1,k) + intz_dpa_bk(ib,jb+1))) + & - ((h(i,j+1,k) - h(i,j,k)) * inty_pa_bk(ib,Jb) - & - (e(i,j+1,K+1) - e(i,j,K+1)) * inty_dpa_bk(ib,Jb) * 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_bk(ib,Jb) = inty_pa_bk(ib,Jb) + inty_dpa_bk(ib,Jb) - enddo ; enddo - do jb=Jsq_bk,Jeq_bk+1 ; do ib=Isq_bk,Ieq_bk+1 - pa_bk(ib,jb) = pa_bk(ib,jb) + dpa_bk(ib,jb) - enddo ; enddo - enddo - - if (CS%GFS_scale < 1.0) then - do k=1,nz - do j=js_bk+joff_bk,je_bk+joff_bk ; do I=Isq_bk+ioff_bk,Ieq_bk+ioff_bk - PFu(I,j,k) = PFu(I,j,k) - (dM(i+1,j) - dM(i,j)) * G%IdxCu(I,j) - enddo ; enddo - do J=Jsq_bk+joff_bk,Jeq_bk+joff_bk ; do i=is_bk+ioff_bk,ie_bk+ioff_bk - PFv(i,J,k) = PFv(i,J,k) - (dM(i,j+1) - dM(i,j)) * G%IdyCv(i,J) - enddo ; enddo - enddo - endif - enddo - - 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 - if (CS%tides) then - ! eta is the sea surface height relative to a time-invariant geoid, for - ! comparison with what is used for eta in btstep. See how e was calculated - ! about 200 lines above. - !$OMP parallel do default(shared) - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - eta(i,j) = e(i,j,1)*GV%Z_to_H + e_tidal(i,j)*GV%Z_to_H - enddo ; enddo - else - !$OMP parallel do default(shared) - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - eta(i,j) = e(i,j,1)*GV%Z_to_H - enddo ; enddo - endif - endif - - if (CS%id_e_tidal>0) call post_data(CS%id_e_tidal, e_tidal, CS%diag) - -end subroutine PressureForce_blk_AFV_Bouss - -!> Initializes the finite volume pressure gradient control structure -subroutine PressureForce_blk_AFV_init(Time, G, GV, US, param_file, diag, CS, tides_CSp) - type(time_type), target, intent(in) :: Time !< Current model time - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(param_file_type), intent(in) :: param_file !< Parameter file handles - type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure - type(PressureForce_blk_AFV_CS), pointer :: CS !< Finite volume PGF control structure - type(tidal_forcing_CS), optional, pointer :: tides_CSp !< Tides control structure -! This include declares and sets the variable "version". -#include "version_variable.h" - character(len=40) :: mdl ! This module's name. - logical :: use_ALE - - if (associated(CS)) then - call MOM_error(WARNING, "PressureForce_init called with an associated "// & - "control structure.") - return - else ; allocate(CS) ; endif - - CS%diag => diag ; CS%Time => Time - if (present(tides_CSp)) then - if (associated(tides_CSp)) CS%tides_CSp => tides_CSp - endif - - mdl = "MOM_PressureForce_blk_AFV" - call log_version(param_file, mdl, version, "") - call get_param(param_file, mdl, "RHO_0", CS%Rho0, & - "The mean ocean density used with BOUSSINESQ true to "//& - "calculate accelerations and the mass for conservation "//& - "properties, or with BOUSSINSEQ false to convert some "//& - "parameters from vertical units of m to kg m-2.", & - units="kg m-3", default=1035.0) - call get_param(param_file, mdl, "TIDES", CS%tides, & - "If true, apply tidal momentum forcing.", default=.false.) - call get_param(param_file, "MOM", "USE_REGRIDDING", use_ALE, & - "If True, use the ALE algorithm (regridding/remapping). "//& - "If False, use the layered isopycnal algorithm.", default=.false. ) - call get_param(param_file, mdl, "MASS_WEIGHT_IN_PRESSURE_GRADIENT", CS%useMassWghtInterp, & - "If true, use mass weighting when interpolating T/S for "//& - "integrals near the bathymetry in AFV pressure gradient "//& - "calculations.", 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.) - - if (CS%tides) then - CS%id_e_tidal = register_diag_field('ocean_model', 'e_tidal', diag%axesT1, & - Time, 'Tidal Forcing Astronomical and SAL Height Anomaly', 'meter', conversion=US%Z_to_m) - 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) - -end subroutine PressureForce_blk_AFV_init - -!> Deallocates the finite volume pressure gradient control structure -subroutine PressureForce_blk_AFV_end(CS) - type(PressureForce_blk_AFV_CS), pointer :: CS !< Blocked AFV pressure control structure that - !! will be deallocated in this subroutine. - if (associated(CS)) deallocate(CS) -end subroutine PressureForce_blk_AFV_end - -!> \namespace mom_pressureforce_afv -!! -!! Provides the Boussinesq and non-Boussinesq forms of horizontal accelerations -!! due to pressure gradients using a 2nd-order analytically vertically integrated -!! finite volume form, as described by Adcroft et al., 2008. -!! -!! 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_blk_AFV diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 5998f08c16..5e42a9575f 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -20,12 +20,14 @@ module MOM_barotropic use MOM_open_boundary, only : ocean_OBC_type, OBC_SIMPLE, 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, query_initialized, MOM_restart_CS +use MOM_restart, only : register_restart_field, register_restart_pair +use MOM_restart, only : query_initialized, MOM_restart_CS use MOM_tidal_forcing, only : tidal_forcing_sensitivity, tidal_forcing_CS use MOM_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 @@ -107,9 +109,6 @@ module MOM_barotropic real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_) :: lin_drag_u !< A spatially varying linear drag coefficient acting on the zonal barotropic flow !! [H T-1 ~> m s-1 or kg m-2 s-1]. - real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_) :: uhbt_IC - !< The barotropic solvers estimate of the zonal transport as the initial condition for - !! the next call to btstep [H L2 T-1 ~> m3 s-1 or kg s-1]. real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_) :: ubt_IC !< The barotropic solvers estimate of the zonal velocity that will be the initial !! condition for the next call to btstep [L T-1 ~> m s-1]. @@ -120,9 +119,6 @@ module MOM_barotropic real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_) :: lin_drag_v !< A spatially varying linear drag coefficient acting on the zonal barotropic flow !! [H T-1 ~> m s-1 or kg m-2 s-1]. - real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_) :: vhbt_IC - !< The barotropic solvers estimate of the zonal transport as the initial condition for - !! the next call to btstep [H L2 T-1 ~> m3 s-1 or kg s-1]. real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_) :: vbt_IC !< The barotropic solvers estimate of the zonal velocity that will be the initial !! condition for the next call to btstep [L T-1 ~> m s-1]. @@ -191,6 +187,11 @@ module MOM_barotropic !! otherwise the Arakawa & Hsu scheme is used. If !! the deformation radius is not resolved Sadourny's !! scheme should probably be used. + logical :: integral_bt_cont !< If true, use the time-integrated velocity over the barotropic steps + !! to determine the integrated transports used to update the continuity + !! equation. Otherwise the transports are the sum of the transports + !! based on ]a series of instantaneous velocities and the BT_CONT_TYPE + !! for transports. This is only valid if a BT_CONT_TYPE is used. logical :: Nonlinear_continuity !< If true, the barotropic continuity equation !! uses the full ocean thickness for transport. integer :: Nonlin_cont_update_period !< The number of barotropic time steps @@ -257,9 +258,8 @@ module MOM_barotropic !! times the time-derivatives of thicknesses. The !! default is 0.1, and there will probably be real !! problems if this were set close to 1. - logical :: BT_cont_bounds !< If true, use the BT_cont_type variables to set - !! limits on the magnitude of the corrective mass - !! fluxes. + logical :: BT_cont_bounds !< If true, use the BT_cont_type variables to set limits + !! on the magnitude of the corrective mass fluxes. logical :: visc_rem_u_uh0 !< If true, use the viscous remnants when estimating !! the barotropic velocities that were used to !! calculate uh0 and vh0. False is probably the @@ -301,6 +301,7 @@ module MOM_barotropic 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 @@ -311,6 +312,7 @@ module MOM_barotropic integer :: id_BTC_ubt_EE = -1, id_BTC_ubt_WW = -1 integer :: id_BTC_FA_v_NN = -1, id_BTC_FA_v_N0 = -1, id_BTC_FA_v_S0 = -1, id_BTC_FA_v_SS = -1 integer :: id_BTC_vbt_NN = -1, id_BTC_vbt_SS = -1 + integer :: id_BTC_FA_u_rat0 = -1, id_BTC_FA_v_rat0 = -1, id_BTC_FA_h_rat0 = -1 integer :: id_uhbt0 = -1, id_vhbt0 = -1 !>@} @@ -326,14 +328,20 @@ module MOM_barotropic !! drawing from nearby to the west [H L ~> m2 or kg m-1]. real :: FA_u_WW !< The effective open face area for zonal barotropic transport !! drawing from locations far to the west [H L ~> m2 or kg m-1]. - real :: uBT_WW !< uBT_WW is the barotropic velocity [L T-1 ~> m s-1], beyond which the marginal + real :: uBT_WW !< uBT_WW is the barotropic velocity [L T-1 ~> m s-1], or with INTEGRAL_BT_CONTINUITY + !! the time-integrated barotropic velocity [L ~> m], beyond which the marginal !! open face area is FA_u_WW. uBT_WW must be non-negative. - real :: uBT_EE !< uBT_EE is a barotropic velocity [L T-1 ~> m s-1], beyond which the marginal + real :: uBT_EE !< uBT_EE is a barotropic velocity [L T-1 ~> m s-1], or with INTEGRAL_BT_CONTINUITY + !! the time-integrated barotropic velocity [L ~> m], beyond which the marginal !! open face area is FA_u_EE. uBT_EE must be non-positive. - real :: uh_crvW !< The curvature of face area with velocity for flow from the west [H T2 L-1 ~> s2 or kg s2 m-3]. - real :: uh_crvE !< The curvature of face area with velocity for flow from the east [H T2 L-1 ~> s2 or kg s2 m-3]. - real :: uh_WW !< The zonal transport when ubt=ubt_WW [H L2 T-1 ~> m3 s-1 or kg s-1]. - real :: uh_EE !< The zonal transport when ubt=ubt_EE [H L2 T-1 ~> m3 s-1 or kg s-1]. + real :: uh_crvW !< The curvature of face area with velocity for flow from the west [H T2 L-1 ~> s2 or kg s2 m-3] + !! or [H L-1 ~> 1 or kg m-3] with INTEGRAL_BT_CONTINUITY. + real :: uh_crvE !< The curvature of face area with velocity for flow from the east [H T2 L-1 ~> s2 or kg s2 m-3] + !! or [H L-1 ~> 1 or kg m-3] with INTEGRAL_BT_CONTINUITY. + real :: uh_WW !< The zonal transport when ubt=ubt_WW [H L2 T-1 ~> m3 s-1 or kg s-1], or the equivalent + !! time-integrated transport with INTEGRAL_BT_CONTINUITY [H L2 ~> m3 or kg]. + real :: uh_EE !< The zonal transport when ubt=ubt_EE [H L2 T-1 ~> m3 s-1 or kg s-1], or the equivalent + !! time-integrated transport with INTEGRAL_BT_CONTINUITY [H L2 ~> m3 or kg]. end type local_BT_cont_u_type !> A desciption of the functional dependence of transport at a v-point @@ -346,14 +354,20 @@ module MOM_barotropic !! drawing from nearby to the south [H L ~> m2 or kg m-1]. real :: FA_v_SS !< The effective open face area for meridional barotropic transport !! drawing from locations far to the south [H L ~> m2 or kg m-1]. - real :: vBT_SS !< vBT_SS is the barotropic velocity [L T-1 ~> m s-1], beyond which the marginal + real :: vBT_SS !< vBT_SS is the barotropic velocity [L T-1 ~> m s-1], or with INTEGRAL_BT_CONTINUITY + !! the time-integrated barotropic velocity [L ~> m], beyond which the marginal !! open face area is FA_v_SS. vBT_SS must be non-negative. - real :: vBT_NN !< vBT_NN is the barotropic velocity [L T-1 ~> m s-1], beyond which the marginal + real :: vBT_NN !< vBT_NN is the barotropic velocity [L T-1 ~> m s-1], or with INTEGRAL_BT_CONTINUITY + !! the time-integrated barotropic velocity [L ~> m], beyond which the marginal !! open face area is FA_v_NN. vBT_NN must be non-positive. - real :: vh_crvS !< The curvature of face area with velocity for flow from the south [H T2 L-1 ~> s2 or kg s2 m-3]. - real :: vh_crvN !< The curvature of face area with velocity for flow from the north [H T2 L-1 ~> s2 or kg s2 m-3]. - real :: vh_SS !< The meridional transport when vbt=vbt_SS [H L2 T-1 ~> m3 s-1 or kg s-1]. - real :: vh_NN !< The meridional transport when vbt=vbt_NN [H L2 T-1 ~> m3 s-1 or kg s-1]. + real :: vh_crvS !< The curvature of face area with velocity for flow from the south [H T2 L-1 ~> s2 or kg s2 m-3] + !! or [H L-1 ~> 1 or kg m-3] with INTEGRAL_BT_CONTINUITY. + real :: vh_crvN !< The curvature of face area with velocity for flow from the north [H T2 L-1 ~> s2 or kg s2 m-3] + !! or [H L-1 ~> 1 or kg m-3] with INTEGRAL_BT_CONTINUITY. + real :: vh_SS !< The meridional transport when vbt=vbt_SS [H L2 T-1 ~> m3 s-1 or kg s-1], or the equivalent + !! time-integrated transport with INTEGRAL_BT_CONTINUITY [H L2 ~> m3 or kg]. + real :: vh_NN !< The meridional transport when vbt=vbt_NN [H L2 T-1 ~> m3 s-1 or kg s-1], or the equivalent + !! time-integrated transport with INTEGRAL_BT_CONTINUITY [H L2 ~> m3 or kg]. end type local_BT_cont_v_type !> A container for passing around active tracer point memory limits @@ -392,7 +406,7 @@ module MOM_barotropic subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, & eta_PF_in, U_Cor, V_Cor, accel_layer_u, accel_layer_v, & eta_out, uhbtav, vhbtav, G, GV, US, CS, & - visc_rem_u, visc_rem_v, etaav, OBC, BT_cont, eta_PF_start, & + visc_rem_u, visc_rem_v, etaav, ADp, OBC, BT_cont, eta_PF_start, & taux_bot, tauy_bot, uh0, vh0, u_uh0, v_vh0) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. @@ -445,6 +459,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: visc_rem_v !< Ditto for meridional direction [nondim]. real, dimension(SZI_(G),SZJ_(G)), optional, intent(out) :: etaav !< The free surface height or column mass !! averaged over the barotropic integration [H ~> m or kg m-2]. + type(accel_diag_ptrs), optional, pointer :: ADp !< Acceleration diagnostic pointers type(ocean_OBC_type), optional, pointer :: OBC !< The open boundary condition structure. type(BT_cont_type), optional, pointer :: BT_cont !< A structure with elements that describe !! the effective open face areas as a function of barotropic @@ -475,11 +490,16 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ! sums less than one due to viscous losses. Nondimensional. real, dimension(SZIB_(G),SZJ_(G)) :: & av_rem_u, & ! The weighted average of visc_rem_u, nondimensional. - tmp_u ! A temporary array at u points. + tmp_u, & ! A temporary array at u points. + 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, nondimensional. - tmp_v ! A temporary array at v points. + tmp_v, & ! A temporary array at v points. + vbt_st, & ! The meridional barotropic velocity at the start of timestep [L T-1 ~> m s-1]. + vbt_dt ! The meridional barotropic velocity tendency [L T-2 ~> m s-2]. real, dimension(SZI_(G),SZJ_(G)) :: & + tmp_h, & ! A temporary array at h points. e_anom ! The anomaly in the sea surface height or column mass ! averaged between the beginning and end of the time step, ! relative to eta_PF, with SAL effects included [H ~> m or kg m-2]. @@ -503,7 +523,9 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ubt_old, & ! The starting value of ubt in a barotropic step [L T-1 ~> m s-1]. ubt_first, & ! The starting value of ubt in a series of barotropic steps [L T-1 ~> m s-1]. ubt_sum, & ! The sum of ubt over the time steps [L T-1 ~> m s-1]. + ubt_int, & ! The running time integral of ubt over the time steps [L ~> m]. uhbt_sum, & ! The sum of uhbt over the time steps [H L2 T-1 ~> m3 s-1 or kg s-1]. + uhbt_int, & ! The running time integral of uhbt over the time steps [H L2 ~> m3]. ubt_wtd, & ! A weighted sum used to find the filtered final ubt [L T-1 ~> m s-1]. ubt_trans, & ! The latest value of ubt used for a transport [L T-1 ~> m s-1]. azon, bzon, & ! _zon & _mer are the values of the Coriolis force which @@ -536,7 +558,9 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, vbt_old, & ! The starting value of vbt in a barotropic step [L T-1 ~> m s-1]. vbt_first, & ! The starting value of ubt in a series of barotropic steps [L T-1 ~> m s-1]. vbt_sum, & ! The sum of vbt over the time steps [L T-1 ~> m s-1]. + vbt_int, & ! The running time integral of vbt over the time steps [L ~> m]. vhbt_sum, & ! The sum of vhbt over the time steps [H L2 T-1 ~> m3 s-1 or kg s-1]. + vhbt_int, & ! The running time integral of vhbt over the time steps [H L2 ~> m3]. vbt_wtd, & ! A weighted sum used to find the filtered final vbt [L T-1 ~> m s-1]. vbt_trans, & ! The latest value of vbt used for a transport [L T-1 ~> m s-1]. Cor_v, & ! The meridional Coriolis acceleration [L T-2 ~> m s-2]. @@ -561,6 +585,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, real, dimension(SZIW_(CS),SZJW_(CS)) :: & eta_sum, & ! eta summed across the timesteps [H ~> m or kg m-2]. eta_wtd, & ! A weighted estimate used to calculate eta_out [H ~> m or kg m-2]. + eta_IC, & ! A local copy of the initial 2-D eta field (eta_in) [H ~> m or kg m-2] eta_PF, & ! A local copy of the 2-D eta field (either SSH anomaly or ! column mass anomaly) that was used to calculate the input ! pressure gradient accelerations [H ~> m or kg m-2]. @@ -586,11 +611,16 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ! End of wide-sized variables. real, dimension(SZIBW_(CS),SZJW_(CS)) :: & - ubt_prev, uhbt_prev, ubt_sum_prev, uhbt_sum_prev, ubt_wtd_prev ! for OBC + ubt_prev, ubt_sum_prev, ubt_wtd_prev, & ! Previous velocities stored for OBCs [L T-1 ~> m s-1] + uhbt_prev, uhbt_sum_prev, & ! Previous transports stored for OBCs [L2 H T-1 ~> m3 s-1] + ubt_int_prev, & ! Previous value of time-integrated velocity stored for OBCs [L ~> m] + uhbt_int_prev ! Previous value of time-integrated transport stored for OBCs [L2 H ~> m3] real, dimension(SZIW_(CS),SZJBW_(CS)) :: & - vbt_prev, vhbt_prev, vbt_sum_prev, vhbt_sum_prev, vbt_wtd_prev ! for OBC - - real :: mass_to_Z ! The depth unit converison divided by the mean density (Rho0) [Z m-1 R-1 ~> m3 kg-1]. + vbt_prev, vbt_sum_prev, vbt_wtd_prev, & ! Previous velocities stored for OBCs [L T-1 ~> m s-1] + vhbt_prev, vhbt_sum_prev, & ! Previous transports stored for OBCs [L2 H T-1 ~> m3 s-1] + vbt_int_prev, & ! Previous value of time-integrated velocity stored for OBCs [L ~> m] + vhbt_int_prev ! Previous value of time-integrated transport stored for OBCs [L2 H ~> m3] + real :: mass_to_Z ! The depth unit conversion divided by the mean density (Rho0) [Z m-1 R-1 ~> m3 kg-1]. real :: mass_accel_to_Z ! The inverse of the mean density (Rho0) [R-1 ~> m3 kg-1]. real :: visc_rem ! A work variable that may equal visc_rem_[uv]. Nondim. real :: vel_prev ! The previous velocity [L T-1 ~> m s-1]. @@ -606,9 +636,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, real :: dgeo_de ! The constant of proportionality between geopotential and ! sea surface height. It is a nondimensional number of ! order 1. For stability, this may be made larger - ! than physical problem would suggest. - real :: Instep ! The inverse of the number of barotropic time steps - ! to take. + ! than the physical problem would suggest. + real :: Instep ! The inverse of the number of barotropic time steps to take. real :: wt_end ! The weighting of the final value of eta_PF [nondim] integer :: nstep ! The number of barotropic time steps to take. type(time_type) :: & @@ -620,6 +649,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ! velocity point [H ~> m or kg m-2] logical :: do_hifreq_output ! If true, output occurs every barotropic step. logical :: use_BT_cont, do_ave, find_etaav, find_PF, find_Cor + logical :: integral_BT_cont ! If true, update the barotropic continuity equation directly + ! from the initial condition using the time-integrated barotropic velocity. logical :: ice_is_rigid, nonblock_setup, interp_eta_PF logical :: project_velocity, add_uh0 @@ -633,17 +664,19 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, real :: H_eff_dx2 ! The effective total thickness divided by the grid spacing ! squared [H L-2 ~> m-1 or kg m-4]. real :: u_max_cor, v_max_cor ! The maximum corrective velocities [L T-1 ~> m s-1]. + real :: uint_cor, vint_cor ! The maximum time-integrated corrective velocities [L ~> m]. real :: Htot ! The total thickness [H ~> m or kg m-2]. real :: eta_cor_max ! The maximum fluid that can be added as a correction to eta [H ~> m or kg m-2]. real :: accel_underflow ! An acceleration that is so small it should be zeroed out [L T-2 ~> m s-2]. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. + real :: Idtbt ! The inverse of the barotropic time step [T-1 ~> s-1] real, allocatable, dimension(:) :: wt_vel, wt_eta, wt_accel, wt_trans, wt_accel2 real :: sum_wt_vel, sum_wt_eta, sum_wt_accel, sum_wt_trans real :: I_sum_wt_vel, I_sum_wt_eta, I_sum_wt_accel, I_sum_wt_trans real :: dt_filt ! The half-width of the barotropic filter [T ~> s]. - real :: trans_wt1, trans_wt2 ! weight used to compute ubt_trans and vbt_trans + real :: trans_wt1, trans_wt2 ! The weights used to compute ubt_trans and vbt_trans integer :: nfilter logical :: apply_OBCs, apply_OBC_flather, apply_OBC_open @@ -656,6 +689,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, integer :: is, ie, js, je, nz, Isq, Ieq, Jsq, Jeq integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB integer :: ioff, joff + integer :: l_seg if (.not.associated(CS)) call MOM_error(FATAL, & "btstep: Module MOM_barotropic must be initialized before it is used.") @@ -672,6 +706,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, use_BT_cont = .false. if (present(BT_cont)) use_BT_cont = (associated(BT_cont)) + integral_BT_cont = use_BT_cont .and. CS%integral_BT_cont interp_eta_PF = .false. if (present(eta_PF_start)) interp_eta_PF = (associated(eta_PF_start)) @@ -735,6 +770,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ! Set the actual barotropic time step. Instep = 1.0 / real(nstep) dtbt = dt * Instep + Idtbt = 1.0 / dtbt bebt = CS%bebt be_proj = CS%bebt mass_accel_to_Z = 1.0 / GV%Rho0 @@ -778,6 +814,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, else call create_group_pass(CS%pass_eta_bt_rem, eta_PF, CS%BT_Domain) endif + if (integral_BT_cont) & + call create_group_pass(CS%pass_eta_bt_rem, eta_IC, CS%BT_Domain) call create_group_pass(CS%pass_eta_bt_rem, eta_src, CS%BT_Domain) ! The following halo updates are not needed without wide halos. RWH ! We do need them after all. @@ -798,6 +836,12 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif call create_group_pass(CS%pass_eta_ubt, eta, CS%BT_Domain) call create_group_pass(CS%pass_eta_ubt, ubt, vbt, CS%BT_Domain) + if (integral_BT_cont) then + call create_group_pass(CS%pass_eta_ubt, ubt_int, vbt_int, CS%BT_Domain) + ! This is only needed with integral_BT_cont, OBCs and multiple barotropic steps between halo updates. + if (apply_OBC_open) & + call create_group_pass(CS%pass_eta_ubt, uhbt_int, vhbt_int, CS%BT_Domain) + endif call create_group_pass(CS%pass_ubt_Cor, ubt_Cor, vbt_Cor, G%Domain) ! These passes occur at the end of the routine, as data is being readied to @@ -891,6 +935,9 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (interp_eta_PF) then eta_PF_1(i,j) = 0.0 ; d_eta_PF(i,j) = 0.0 endif + if (integral_BT_cont) then + eta_IC(i,j) = 0.0 + endif p_surf_dyn(i,j) = 0.0 if (CS%dynamic_psurf) dyn_coef_eta(i,j) = 0.0 enddo ; enddo @@ -905,7 +952,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, !$OMP parallel do default(shared) do J=CS%jsdw-1,CS%jedw ; do i=CS%isdw,CS%iedw Cor_ref_v(i,J) = 0.0 ; BT_force_v(i,J) = 0.0 ; vbt(i,J) = 0.0 - Datv(i,J) = 0.0 ; bt_rem_v(i,J) = 0.0 ; vhbt0(I,j) = 0.0 + Datv(i,J) = 0.0 ; bt_rem_v(i,J) = 0.0 ; vhbt0(i,J) = 0.0 enddo ; enddo ! Copy input arrays into their wide-halo counterparts. @@ -923,6 +970,12 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, eta_PF(i,j) = eta_PF_in(i,j) enddo ; enddo endif + if (integral_BT_cont) then + !$OMP parallel do default(shared) + do j=G%jsd,G%jed ; do i=G%isd,G%ied + eta_IC(i,j) = eta_in(i,j) + enddo ; enddo + endif !$OMP parallel do default(shared) private(visc_rem) do k=1,nz ; do j=js,je ; do I=is-1,ie @@ -995,7 +1048,9 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ! Calculate the open areas at the velocity points. ! The halo updates are needed before Datu is first used, either in set_up_BT_OBC or ubt_Cor. - if (use_BT_cont) then + if (integral_BT_cont) then + call set_local_BT_cont_types(BT_cont, BTCL_u, BTCL_v, G, US, MS, CS%BT_Domain, 1+ievf-ie, dt_baroclinic=dt) + elseif (use_BT_cont) then call set_local_BT_cont_types(BT_cont, BTCL_u, BTCL_v, G, US, MS, CS%BT_Domain, 1+ievf-ie) else if (CS%Nonlinear_continuity) then @@ -1008,7 +1063,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ! Set up fields related to the open boundary conditions. if (apply_OBCs) then call set_up_BT_OBC(OBC, eta, CS%BT_OBC, CS%BT_Domain, G, GV, US, MS, ievf-ie, use_BT_cont, & - Datu, Datv, BTCL_u, BTCL_v) + integral_BT_cont, dt, Datu, Datv, BTCL_u, BTCL_v) endif ! Determine the difference between the sum of the layer fluxes and the @@ -1041,29 +1096,43 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, vbt(i,J) = vbt(i,J) + CS%frhatv(i,J,k) * v_vh0(i,J,k) enddo ; enddo ; enddo endif - if (use_BT_cont) then - if (CS%adjust_BT_cont) then - ! Use the additional input transports to broaden the fits - ! over which the bt_cont_type applies. - - ! Fill in the halo data for ubt, vbt, uhbt, and vhbt. - if (id_clock_calc_pre > 0) call cpu_clock_end(id_clock_calc_pre) - if (id_clock_pass_pre > 0) call cpu_clock_begin(id_clock_pass_pre) - call pass_vector(ubt, vbt, CS%BT_Domain, complete=.false., halo=1+ievf-ie) - call pass_vector(uhbt, vhbt, CS%BT_Domain, complete=.true., halo=1+ievf-ie) - if (id_clock_pass_pre > 0) call cpu_clock_end(id_clock_pass_pre) - if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre) - + if ((use_BT_cont .or. integral_BT_cont) .and. CS%adjust_BT_cont) then + ! Use the additional input transports to broaden the fits + ! over which the bt_cont_type applies. + + ! Fill in the halo data for ubt, vbt, uhbt, and vhbt. + if (id_clock_calc_pre > 0) call cpu_clock_end(id_clock_calc_pre) + if (id_clock_pass_pre > 0) call cpu_clock_begin(id_clock_pass_pre) + call pass_vector(ubt, vbt, CS%BT_Domain, complete=.false., halo=1+ievf-ie) + call pass_vector(uhbt, vhbt, CS%BT_Domain, complete=.true., halo=1+ievf-ie) + if (id_clock_pass_pre > 0) call cpu_clock_end(id_clock_pass_pre) + if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre) + + if (integral_BT_cont) then call adjust_local_BT_cont_types(ubt, uhbt, vbt, vhbt, BTCL_u, BTCL_v, & - G, US, MS, 1+ievf-ie) + G, US, MS, halo=1+ievf-ie, dt_baroclinic=dt) + else + call adjust_local_BT_cont_types(ubt, uhbt, vbt, vhbt, BTCL_u, BTCL_v, & + G, US, MS, halo=1+ievf-ie) endif + endif + if (integral_BT_cont) then !$OMP parallel do default(shared) do j=js,je ; do I=is-1,ie - uhbt0(I,j) = uhbt(I,j) - find_uhbt(ubt(I,j), BTCL_u(I,j), US) + uhbt0(I,j) = uhbt(I,j) - find_uhbt(dt*ubt(I,j), BTCL_u(I,j)) * Idt enddo ; enddo !$OMP parallel do default(shared) do J=js-1,je ; do i=is,ie - vhbt0(i,J) = vhbt(i,J) - find_vhbt(vbt(i,J), BTCL_v(i,J), US) + vhbt0(i,J) = vhbt(i,J) - find_vhbt(dt*vbt(i,J), BTCL_v(i,J)) * Idt + enddo ; enddo + elseif (use_BT_cont) then + !$OMP parallel do default(shared) + do j=js,je ; do I=is-1,ie + uhbt0(I,j) = uhbt(I,j) - find_uhbt(ubt(I,j), BTCL_u(I,j)) + enddo ; enddo + !$OMP parallel do default(shared) + do J=js-1,je ; do i=is,ie + vhbt0(i,J) = vhbt(i,J) - find_vhbt(vbt(i,J), BTCL_v(i,J)) enddo ; enddo else !$OMP parallel do default(shared) @@ -1090,14 +1159,27 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif ! Calculate the initial barotropic velocities from the layer's velocities. - !$OMP parallel do default(shared) - do j=jsvf-1,jevf+1 ; do I=isvf-2,ievf+1 - ubt(I,j) = 0.0 ; uhbt(I,j) = 0.0 ; u_accel_bt(I,j) = 0.0 - enddo ; enddo - !$OMP parallel do default(shared) - do J=jsvf-2,jevf+1 ; do i=isvf-1,ievf+1 - vbt(i,J) = 0.0 ; vhbt(i,J) = 0.0 ; v_accel_bt(i,J) = 0.0 - enddo ; enddo + if (integral_BT_cont) then + !$OMP parallel do default(shared) + do j=jsvf-1,jevf+1 ; do I=isvf-2,ievf+1 + ubt(I,j) = 0.0 ; uhbt(I,j) = 0.0 ; u_accel_bt(I,j) = 0.0 + ubt_int(I,j) = 0.0 ; uhbt_int(I,j) = 0.0 + enddo ; enddo + !$OMP parallel do default(shared) + do J=jsvf-2,jevf+1 ; do i=isvf-1,ievf+1 + vbt(i,J) = 0.0 ; vhbt(i,J) = 0.0 ; v_accel_bt(i,J) = 0.0 + vbt_int(i,J) = 0.0 ; vhbt_int(i,J) = 0.0 + enddo ; enddo + else + !$OMP parallel do default(shared) + do j=jsvf-1,jevf+1 ; do I=isvf-2,ievf+1 + ubt(I,j) = 0.0 ; uhbt(I,j) = 0.0 ; u_accel_bt(I,j) = 0.0 + enddo ; enddo + !$OMP parallel do default(shared) + do J=jsvf-2,jevf+1 ; do i=isvf-1,ievf+1 + vbt(i,J) = 0.0 ; vhbt(i,J) = 0.0 ; v_accel_bt(i,J) = 0.0 + enddo ; enddo + endif !$OMP parallel do default(shared) do j=js,je ; do k=1,nz ; do I=is-1,ie ubt(I,j) = ubt(I,j) + wt_u(I,j,k) * U_in(I,j,k) @@ -1136,8 +1218,11 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif if (Htot_avg*CS%dy_Cu(I,j) <= 0.0) then CS%IDatu(I,j) = 0.0 + elseif (integral_BT_cont) then + CS%IDatu(I,j) = CS%dy_Cu(I,j) / (max(find_duhbt_du(ubt(I,j)*dt, BTCL_u(I,j)), & + CS%dy_Cu(I,j)*Htot_avg) ) elseif (use_BT_cont) then ! Reconsider the max and whether there should be some scaling. - CS%IDatu(I,j) = CS%dy_Cu(I,j) / (max(find_duhbt_du(ubt(I,j), BTCL_u(I,j), US), & + CS%IDatu(I,j) = CS%dy_Cu(I,j) / (max(find_duhbt_du(ubt(I,j), BTCL_u(I,j)), & CS%dy_Cu(I,j)*Htot_avg) ) else CS%IDatu(I,j) = 1.0 / Htot_avg @@ -1159,8 +1244,11 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif if (Htot_avg*CS%dx_Cv(i,J) <= 0.0) then CS%IDatv(i,J) = 0.0 + elseif (integral_BT_cont) then + CS%IDatv(i,J) = CS%dx_Cv(i,J) / (max(find_dvhbt_dv(vbt(i,J)*dt, BTCL_v(i,J)), & + CS%dx_Cv(i,J)*Htot_avg) ) elseif (use_BT_cont) then ! Reconsider the max and whether there should be some scaling. - CS%IDatv(i,J) = CS%dx_Cv(i,J) / (max(find_dvhbt_dv(vbt(i,J), BTCL_v(i,J), US), & + CS%IDatv(i,J) = CS%dx_Cv(i,J) / (max(find_dvhbt_dv(vbt(i,J), BTCL_v(i,J)), & CS%dx_Cv(i,J)*Htot_avg) ) else CS%IDatv(i,J) = 1.0 / Htot_avg @@ -1322,15 +1410,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif if (id_clock_pass_pre > 0) call cpu_clock_end(id_clock_pass_pre) if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre) -!$OMP parallel default(none) shared(is,ie,js,je,nz,av_rem_u,av_rem_v,CS,visc_rem_u, & -!$OMP visc_rem_v,bt_rem_u,G,GV,nstep,bt_rem_v,Instep, & -!$OMP find_etaav,jsvf,jevf,isvf,ievf,eta_sum,eta_wtd, & -!$OMP ubt_sum,uhbt_sum,PFu_bt_sum,Coru_bt_sum,ubt_wtd,& -!$OMP ubt_trans,vbt_sum,vhbt_sum,PFv_bt_sum, & -!$OMP Corv_bt_sum,vbt_wtd,vbt_trans,eta_src,dt,dtbt, & -!$OMP Rayleigh_u, Rayleigh_v, & -!$OMP use_BT_Cont,BTCL_u,uhbt0,BTCL_v,vhbt0,eta,Idt,US) & -!$OMP private(u_max_cor,v_max_cor,eta_cor_max,Htot) + !$OMP parallel default(shared) private(u_max_cor,uint_cor,v_max_cor,vint_cor,eta_cor_max,Htot) !$OMP do do j=js-1,je+1 ; do I=is-1,ie ; av_rem_u(I,j) = 0.0 ; enddo ; enddo !$OMP do @@ -1400,7 +1480,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, do j=jsvf-1,jevf+1 ; do i=isvf-1,ievf+1 eta_wtd(i,j) = 0.0 enddo ; enddo - endif + endif !$OMP do do j=jsvf-1,jevf+1 ; do I=isvf-1,ievf ubt_sum(I,j) = 0.0 ; uhbt_sum(I,j) = 0.0 @@ -1411,29 +1491,37 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, do J=jsvf-1,jevf ; do i=isvf-1,ievf+1 vbt_sum(i,J) = 0.0 ; vhbt_sum(i,J) = 0.0 PFv_bt_sum(i,J) = 0.0 ; Corv_bt_sum(i,J) = 0.0 - vbt_wtd(i,J) = 0.0 ; vbt_trans(I,j) = 0.0 + vbt_wtd(i,J) = 0.0 ; vbt_trans(i,J) = 0.0 enddo ; enddo ! Set the mass source, after first initializing the halos to 0. !$OMP do do j=jsvf-1,jevf+1; do i=isvf-1,ievf+1 ; eta_src(i,j) = 0.0 ; enddo ; enddo - if (CS%bound_BT_corr) then ; if (use_BT_Cont .and. CS%BT_cont_bounds) then + if (CS%bound_BT_corr) then ; if ((use_BT_Cont.or.integral_BT_cont) .and. CS%BT_cont_bounds) then do j=js,je ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then if (CS%eta_cor(i,j) > 0.0) then ! Limit the source (outward) correction to be a fraction the mass that - ! can be transported out of the cell by velocities with a CFL number of - ! CFL_cor. - u_max_cor = G%dxT(i,j) * (CS%maxCFL_BT_cont*Idt) - v_max_cor = G%dyT(i,j) * (CS%maxCFL_BT_cont*Idt) - eta_cor_max = dt * (CS%IareaT(i,j) * & - (((find_uhbt(u_max_cor, BTCL_u(I,j), US) + uhbt0(I,j)) - & - (find_uhbt(-u_max_cor, BTCL_u(I-1,j), US) + uhbt0(I-1,j))) + & - ((find_vhbt(v_max_cor, BTCL_v(i,J), US) + vhbt0(i,J)) - & - (find_vhbt(-v_max_cor, BTCL_v(i,J-1), US) + vhbt0(i,J-1))) )) + ! can be transported out of the cell by velocities with a CFL number of CFL_cor. + if (integral_BT_cont) then + uint_cor = G%dxT(i,j) * CS%maxCFL_BT_cont + vint_cor = G%dyT(i,j) * CS%maxCFL_BT_cont + eta_cor_max = (CS%IareaT(i,j) * & + (((find_uhbt(uint_cor, BTCL_u(I,j)) + dt*uhbt0(I,j)) - & + (find_uhbt(-uint_cor, BTCL_u(I-1,j)) + dt*uhbt0(I-1,j))) + & + ((find_vhbt(vint_cor, BTCL_v(i,J)) + dt*vhbt0(i,J)) - & + (find_vhbt(-vint_cor, BTCL_v(i,J-1)) + dt*vhbt0(i,J-1))) )) + else ! (use_BT_Cont) then + u_max_cor = G%dxT(i,j) * (CS%maxCFL_BT_cont*Idt) + v_max_cor = G%dyT(i,j) * (CS%maxCFL_BT_cont*Idt) + eta_cor_max = dt * (CS%IareaT(i,j) * & + (((find_uhbt(u_max_cor, BTCL_u(I,j)) + uhbt0(I,j)) - & + (find_uhbt(-u_max_cor, BTCL_u(I-1,j)) + uhbt0(I-1,j))) + & + ((find_vhbt(v_max_cor, BTCL_v(i,J)) + vhbt0(i,J)) - & + (find_vhbt(-v_max_cor, BTCL_v(i,J-1)) + vhbt0(i,J-1))) )) + endif CS%eta_cor(i,j) = min(CS%eta_cor(i,j), max(0.0, eta_cor_max)) else - ! Limit the sink (inward) correction to the amount of mass that is already - ! inside the cell. + ! Limit the sink (inward) correction to the amount of mass that is already inside the cell. Htot = eta(i,j) if (GV%Boussinesq) Htot = CS%bathyT(i,j)*GV%Z_to_H + eta(i,j) @@ -1478,9 +1566,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, 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 [m3 s-1]. - ice_strength = US%m_to_L**4*US%Z_to_m*US%T_to_s* & - ((forces%rigidity_ice_u(I,j) + forces%rigidity_ice_u(I-1,j)) + & + ! 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) @@ -1536,11 +1623,26 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, 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, 0, .true., .true.) - call uvchksum("BT frhat[uv]", CS%frhatu, CS%frhatv, G%HI, 0, .true., .true.) + 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 bc_accel_[uv]", bc_accel_u, bc_accel_v, G%HI, haloshift=0, scale=US%L_T2_to_m_s2) - call uvchksum("BT IDat[uv]", CS%IDatu, CS%IDatv, G%HI, haloshift=0, scale=US%m_to_Z) - call uvchksum("BT visc_rem_[uv]", visc_rem_u, visc_rem_v, G%HI, haloshift=1) + call uvchksum("BT IDat[uv]", CS%IDatu, CS%IDatv, G%HI, haloshift=0, & + scale=US%m_to_Z, 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 @@ -1657,24 +1759,50 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, call find_face_areas(Datu, Datv, G, GV, US, CS, MS, eta, 1+iev-ie) endif - !GOMP parallel default(shared) + 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 (use_BT_cont) then - !GOMP do + 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), US) + uhbt0(I,j) + uhbt(I,j) = find_uhbt(ubt(I,j), BTCL_u(I,j)) + uhbt0(I,j) enddo ; enddo - !GOMP do + !$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), US) + vhbt0(i,J) + vhbt(i,J) = find_vhbt(vbt(i,J), BTCL_v(i,J)) + vhbt0(i,J) enddo ; enddo - !GOMP do + !$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 - !GOMP do + !$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)) - & @@ -1685,7 +1813,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif if (CS%dynamic_psurf) then - !GOMP do + !$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 @@ -1696,31 +1824,31 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ! eta_PF_BT => eta_pred ; if (project_velocity) eta_PF_BT => eta if (find_etaav) then - !GOMP do + !$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. - !GOMP do + !$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 - !GOMP do + !$OMP do do j=jsv,jev ; do I=isv-2,iev+1 ubt_old(I,j) = ubt(I,j) enddo ; enddo - !GOMP do + !$OMP do do J=jsv-2,jev+1 ; do i=isv,iev vbt_old(i,J) = vbt(i,J) enddo ; enddo endif - !GOMP end parallel if (apply_OBCs) then if (MOD(n+G%first_direction,2)==1) then @@ -1730,15 +1858,15 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif if (CS%BT_OBC%apply_u_OBCs) then ! save the old value of ubt and uhbt - !GOMP parallel do default(shared) - do J=jsv-joff,jev+joff ; do i=isv-1,iev - ubt_prev(i,J) = ubt(i,J) ; uhbt_prev(i,J) = uhbt(i,J) - ubt_sum_prev(i,J) = ubt_sum(i,J) ; uhbt_sum_prev(i,J) = uhbt_sum(i,J) ; ubt_wtd_prev(i,J) = ubt_wtd(i,J) + !$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 - !GOMP parallel do default(shared) + !$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) @@ -1746,10 +1874,9 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif endif - !GOMP parallel default(shared) private(vel_prev) if (MOD(n+G%first_direction,2)==1) then ! On odd-steps, update v first. - !GOMP do + !$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) @@ -1757,20 +1884,23 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, (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 - !GOMP do + !$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 - !GOMP do + !$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 - !GOMP do + !$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) + & @@ -1778,32 +1908,42 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, vbt_trans(i,J) = trans_wt1*vbt(i,J) + trans_wt2*vel_prev if (CS%linear_wave_drag) then - v_accel_bt(I,j) = v_accel_bt(I,j) + wt_accel(n) * & + v_accel_bt(i,J) = v_accel_bt(i,J) + wt_accel(n) * & ((Cor_v(i,J) + PFv(i,J)) - vbt(i,J)*Rayleigh_v(i,J)) else - v_accel_bt(I,j) = v_accel_bt(I,j) + wt_accel(n) * (Cor_v(i,J) + PFv(i,J)) + v_accel_bt(i,J) = v_accel_bt(i,J) + wt_accel(n) * (Cor_v(i,J) + PFv(i,J)) endif enddo ; enddo - if (use_BT_cont) then - !GOMP do + if (integral_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), US) + vhbt0(i,J) + vbt_int(i,J) = vbt_int(i,J) + dtbt * vbt_trans(i,J) + vhbt_int(i,J) = find_vhbt(vbt_int(i,J), BTCL_v(i,J)) + n*dtbt*vhbt0(i,J) + ! Estimate the mass flux within a single timestep to take the filtered average. + vhbt(i,J) = (vhbt_int(i,J) - vhbt_int_prev(i,J)) * Idtbt enddo ; enddo + elseif (use_BT_cont) then + !$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 - !GOMP do + !$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. - !GOMP do + !$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. - !GOMP do + !$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))) - & @@ -1812,21 +1952,24 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, (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 - !GOMP do + !$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 - !GOMP do + !$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 - !GOMP do + !$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) + & @@ -1841,27 +1984,36 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, u_accel_bt(I,j) = u_accel_bt(I,j) + wt_accel(n) * (Cor_u(I,j) + PFu(I,j)) endif enddo ; enddo + !$OMP end do nowait - if (use_BT_cont) then - !GOMP do + 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), US) + uhbt0(I,j) + uhbt(I,j) = find_uhbt(ubt_trans(I,j), BTCL_u(I,j)) + uhbt0(I,j) enddo ; enddo else - !GOMP do + !$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. - !GOMP do + 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) + 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. - !GOMP do + !$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))) - & @@ -1870,22 +2022,24 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, (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 - !GOMP do + !$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 - !GOMP do + !$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 - !GOMP do + !$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) + & @@ -1901,27 +2055,37 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif enddo ; enddo - if (use_BT_cont) then - !GOMP do + 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), US) + uhbt0(I,j) + uhbt(I,j) = find_uhbt(ubt_trans(I,j), BTCL_u(I,j)) + uhbt0(I,j) enddo ; enddo + !$OMP end do nowait else - !GOMP do + !$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. - !GOMP do + !$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) + 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 - !GOMP do + !$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) @@ -1929,8 +2093,9 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, (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 - !GOMP do + !$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) @@ -1938,23 +2103,25 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, (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 - !GOMP do + !$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 - !GOMP do + !$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 - !GOMP do + !$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) + & @@ -1963,120 +2130,167 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, vbt_trans(i,J) = trans_wt1*vbt(i,J) + trans_wt2*vel_prev if (CS%linear_wave_drag) then - v_accel_bt(I,j) = v_accel_bt(I,j) + wt_accel(n) * & + v_accel_bt(i,J) = v_accel_bt(i,J) + wt_accel(n) * & ((Cor_v(i,J) + PFv(i,J)) - vbt(i,J)*Rayleigh_v(i,J)) else - v_accel_bt(I,j) = v_accel_bt(I,j) + wt_accel(n) * (Cor_v(i,J) + PFv(i,J)) + v_accel_bt(i,J) = v_accel_bt(i,J) + wt_accel(n) * (Cor_v(i,J) + PFv(i,J)) endif enddo ; enddo - if (use_BT_cont) then - !GOMP do + !$OMP end do nowait + 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), US) + vhbt0(i,J) + vhbt(i,J) = find_vhbt(vbt_trans(i,J), BTCL_v(i,J)) + vhbt0(i,J) enddo ; enddo else - !GOMP do + !$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. - !GOMP do + !$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 - !GOMP end parallel - !GOMP parallel default(shared) + ! 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) + 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 - !GOMP do + !$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 - !GOMP do + !$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 - !GOMP do + !$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 - !GOMP do + !$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 - !GOMP do + !$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 - !GOMP do + !$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 - !GOMP end parallel + !$OMP end do nowait if (apply_OBCs) then - if (CS%BT_OBC%apply_u_OBCs) then ! copy back the value for u-points on the boundary. - !GOMP parallel do default(shared) + + !$OMP single + call apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, & + ubt_trans, vbt_trans, eta, ubt_old, vbt_old, CS%BT_OBC, & + G, MS, US, iev-ie, dtbt, bebt, use_BT_cont, integral_BT_cont, & + 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 - ubt_sum(I,j) = ubt_sum_prev(I,j) ; uhbt_sum(I,j) = uhbt_sum_prev(I,j) - ubt_wtd(I,j) = ubt_wtd_prev(I,j) + ! 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 ! copy back the value for v-points on the boundary. - !GOMP parallel do default(shared) - do J=js-1,je ; do I=is,ie + if (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 - vbt_sum(i,J) = vbt_sum_prev(i,J) ; vhbt_sum(i,J) = vhbt_sum_prev(i,J) - vbt_wtd(i,J) = vbt_wtd_prev(i,J) + ! 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 - - call apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, & - ubt_trans, vbt_trans, eta, ubt_old, vbt_old, CS%BT_OBC, & - G, MS, US, iev-ie, dtbt, bebt, use_BT_cont, Datu, Datv, BTCL_u, BTCL_v, & - uhbt0, vhbt0) - if (CS%BT_OBC%apply_u_OBCs) then ; do j=js,je ; do I=is-1,ie - if (OBC%segnum_u(I,j) /= OBC_NONE) then - ubt_sum(I,j) = ubt_sum(I,j) + wt_trans(n) * ubt_trans(I,j) - uhbt_sum(I,j) = uhbt_sum(I,j) + wt_trans(n) * uhbt(I,j) - ubt_wtd(I,j) = ubt_wtd(I,j) + wt_vel(n) * ubt(I,j) - endif - enddo ; enddo ; endif - if (CS%BT_OBC%apply_v_OBCs) then ; do J=js-1,je ; do i=is,ie - if (OBC%segnum_v(i,J) /= OBC_NONE) then - vbt_sum(i,J) = vbt_sum(i,J) + wt_trans(n) * vbt_trans(i,J) - vhbt_sum(i,J) = vhbt_sum(i,J) + wt_trans(n) * vhbt(i,J) - vbt_wtd(i,J) = vbt_wtd(i,J) + wt_vel(n) * vbt(i,J) - 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 - !$OMP parallel do default(shared) - do j=jsv,jev ; do i=isv,iev - eta(i,j) = (eta(i,j) + eta_src(i,j)) + (dtbt * CS%IareaT(i,j)) * & - ((uhbt(I-1,j) - uhbt(I,j)) + (vhbt(i,J-1) - vhbt(i,J))) - eta_wtd(i,j) = eta_wtd(i,j) + eta(i,j) * wt_eta(n) - enddo ; enddo + if (integral_BT_cont) then + !$OMP 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) @@ -2141,9 +2355,12 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (CS%BT_OBC%apply_u_OBCs) then ! copy back the value for u-points on the boundary. !GOMP parallel do default(shared) do j=js,je ; do I=is-1,ie - if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then + l_seg = OBC%segnum_u(I,j) + if (l_seg == OBC_NONE) cycle + + if (OBC%segment(l_seg)%direction == OBC_DIRECTION_E) then e_anom(i+1,j) = e_anom(i,j) - elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) then + elseif (OBC%segment(l_seg)%direction == OBC_DIRECTION_W) then e_anom(i,j) = e_anom(i+1,j) endif enddo ; enddo @@ -2152,9 +2369,12 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (CS%BT_OBC%apply_v_OBCs) then ! copy back the value for v-points on the boundary. !GOMP parallel do default(shared) do J=js-1,je ; do I=is,ie - if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then + l_seg = OBC%segnum_v(i,J) + if (l_seg == OBC_NONE) cycle + + if (OBC%segment(l_seg)%direction == OBC_DIRECTION_N) then e_anom(i,j+1) = e_anom(i,j) - elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then + elseif (OBC%segment(l_seg)%direction == OBC_DIRECTION_S) then e_anom(i,j) = e_anom(i,j+1) endif enddo ; enddo @@ -2253,22 +2473,9 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ! Calculate diagnostic quantities. if (query_averaging_enabled(CS%diag)) then - do j=js,je ; do I=is-1,ie ; CS%ubt_IC(I,j) = ubt_wtd(I,j) ; enddo ; enddo - do J=js-1,je ; do i=is,ie ; CS%vbt_IC(i,J) = vbt_wtd(i,J) ; enddo ; enddo - if (use_BT_cont) then - do j=js,je ; do I=is-1,ie - CS%uhbt_IC(I,j) = find_uhbt(ubt_wtd(I,j), BTCL_u(I,j), US) + uhbt0(I,j) - enddo ; enddo - do J=js-1,je ; do i=is,ie - CS%vhbt_IC(i,J) = find_vhbt(vbt_wtd(i,J), BTCL_v(i,J), US) + vhbt0(i,J) - enddo ; enddo - else - do j=js,je ; do I=is-1,ie - CS%uhbt_IC(I,j) = ubt_wtd(I,j) * Datu(I,j) + uhbt0(I,j) - enddo ; enddo - do J=js-1,je ; do i=is,ie - CS%vhbt_IC(i,J) = vbt_wtd(i,J) * Datv(i,J) + vhbt0(i,J) - enddo ; enddo + if (CS%gradual_BT_ICs) then + do j=js,je ; do I=is-1,ie ; CS%ubt_IC(I,j) = ubt_wtd(I,j) ; enddo ; enddo + do J=js-1,je ; do i=is,ie ; CS%vbt_IC(i,J) = vbt_wtd(i,J) ; enddo ; enddo endif ! Offer various barotropic terms for averaging. @@ -2296,6 +2503,19 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, 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) @@ -2331,18 +2551,86 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (CS%id_BTC_FA_u_WW > 0) call post_data(CS%id_BTC_FA_u_WW, BT_cont%FA_u_WW, CS%diag) if (CS%id_BTC_uBT_EE > 0) call post_data(CS%id_BTC_uBT_EE, BT_cont%uBT_EE, CS%diag) if (CS%id_BTC_uBT_WW > 0) call post_data(CS%id_BTC_uBT_WW, BT_cont%uBT_WW, CS%diag) + if (CS%id_BTC_FA_u_rat0 > 0) then + tmp_u(:,:) = 0.0 + do j=js,je ; do I=is-1,ie + if ((G%mask2dCu(I,j) > 0.0) .and. (BT_cont%FA_u_W0(I,j) > 0.0)) then + tmp_u(I,j) = (BT_cont%FA_u_E0(I,j)/ BT_cont%FA_u_W0(I,j)) + else + tmp_u(I,j) = 1.0 + endif + enddo ; enddo + call post_data(CS%id_BTC_FA_u_rat0, tmp_u, CS%diag) + endif if (CS%id_BTC_FA_v_NN > 0) call post_data(CS%id_BTC_FA_v_NN, BT_cont%FA_v_NN, CS%diag) if (CS%id_BTC_FA_v_N0 > 0) call post_data(CS%id_BTC_FA_v_N0, BT_cont%FA_v_N0, CS%diag) if (CS%id_BTC_FA_v_S0 > 0) call post_data(CS%id_BTC_FA_v_S0, BT_cont%FA_v_S0, CS%diag) if (CS%id_BTC_FA_v_SS > 0) call post_data(CS%id_BTC_FA_v_SS, BT_cont%FA_v_SS, CS%diag) if (CS%id_BTC_vBT_NN > 0) call post_data(CS%id_BTC_vBT_NN, BT_cont%vBT_NN, CS%diag) if (CS%id_BTC_vBT_SS > 0) call post_data(CS%id_BTC_vBT_SS, BT_cont%vBT_SS, CS%diag) + if (CS%id_BTC_FA_v_rat0 > 0) then + tmp_v(:,:) = 0.0 + do J=js-1,je ; do i=is,ie + if ((G%mask2dCv(i,J) > 0.0) .and. (BT_cont%FA_v_S0(i,J) > 0.0)) then + tmp_v(i,J) = (BT_cont%FA_v_N0(i,J)/ BT_cont%FA_v_S0(i,J)) + else + tmp_v(i,J) = 1.0 + endif + enddo ; enddo + call post_data(CS%id_BTC_FA_v_rat0, tmp_v, CS%diag) + endif + if (CS%id_BTC_FA_h_rat0 > 0) then + tmp_h(:,:) = 0.0 + do j=js,je ; do i=is,ie + tmp_h(i,j) = 1.0 + if ((G%mask2dCu(I,j) > 0.0) .and. (BT_cont%FA_u_W0(I,j) > 0.0) .and. (BT_cont%FA_u_E0(I,j) > 0.0)) then + if (BT_cont%FA_u_W0(I,j) > BT_cont%FA_u_E0(I,j)) then + tmp_h(i,j) = max(tmp_h(i,j), (BT_cont%FA_u_W0(I,j)/ BT_cont%FA_u_E0(I,j))) + else + tmp_h(i,j) = max(tmp_h(i,j), (BT_cont%FA_u_E0(I,j)/ BT_cont%FA_u_W0(I,j))) + endif + endif + if ((G%mask2dCu(I-1,j) > 0.0) .and. (BT_cont%FA_u_W0(I-1,j) > 0.0) .and. (BT_cont%FA_u_E0(I-1,j) > 0.0)) then + if (BT_cont%FA_u_W0(I-1,j) > BT_cont%FA_u_E0(I-1,j)) then + tmp_h(i,j) = max(tmp_h(i,j), (BT_cont%FA_u_W0(I-1,j)/ BT_cont%FA_u_E0(I-1,j))) + else + tmp_h(i,j) = max(tmp_h(i,j), (BT_cont%FA_u_E0(I-1,j)/ BT_cont%FA_u_W0(I-1,j))) + endif + endif + if ((G%mask2dCv(i,J) > 0.0) .and. (BT_cont%FA_v_S0(i,J) > 0.0) .and. (BT_cont%FA_v_N0(i,J) > 0.0)) then + if (BT_cont%FA_v_S0(i,J) > BT_cont%FA_v_N0(i,J)) then + tmp_h(i,j) = max(tmp_h(i,j), (BT_cont%FA_v_S0(i,J)/ BT_cont%FA_v_N0(i,J))) + else + tmp_h(i,j) = max(tmp_h(i,j), (BT_cont%FA_v_N0(i,J)/ BT_cont%FA_v_S0(i,J))) + endif + endif + if ((G%mask2dCv(i,J-1) > 0.0) .and. (BT_cont%FA_v_S0(i,J-1) > 0.0) .and. (BT_cont%FA_v_N0(i,J-1) > 0.0)) then + if (BT_cont%FA_v_S0(i,J-1) > BT_cont%FA_v_N0(i,J-1)) then + tmp_h(i,j) = max(tmp_h(i,j), (BT_cont%FA_v_S0(i,J-1)/ BT_cont%FA_v_N0(i,J-1))) + else + tmp_h(i,j) = max(tmp_h(i,j), (BT_cont%FA_v_N0(i,J-1)/ BT_cont%FA_v_S0(i,J-1))) + endif + endif + enddo ; enddo + call post_data(CS%id_BTC_FA_h_rat0, tmp_h, CS%diag) + endif endif else if (CS%id_frhatu1 > 0) CS%frhatu1(:,:,:) = CS%frhatu(:,:,:) if (CS%id_frhatv1 > 0) CS%frhatv1(:,:,:) = CS%frhatv(:,:,:) endif + if ((present(ADp)) .and. (associated(ADp%diag_hfrac_u))) then + do k=1,nz ; do j=js,je ; do I=is-1,ie + ADp%diag_hfrac_u(I,j,k) = CS%frhatu(I,j,k) + enddo ; enddo ; enddo + endif + if ((present(ADp)) .and. (associated(ADp%diag_hfrac_v))) then + do k=1,nz ; do J=js-1,je ; do i=is,ie + ADp%diag_hfrac_v(i,J,k) = CS%frhatv(i,J,k) + enddo ; enddo ; enddo + endif + if (G%nonblocking_updates) then if (find_etaav) call complete_group_pass(CS%pass_etaav, G%Domain) call complete_group_pass(CS%pass_ubta_uhbta, G%Domain) @@ -2471,10 +2759,10 @@ end subroutine set_dtbt !> The following 4 subroutines apply the open boundary conditions. !! This subroutine applies the open boundary conditions on barotropic !! velocities and mass transports, as developed by Mehmet Ilicak. -subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, & - eta, ubt_old, vbt_old, BT_OBC, & - G, MS, US, halo, dtbt, bebt, use_BT_cont, Datu, Datv, & - BTCL_u, BTCL_v, uhbt0, vhbt0) +subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, eta, & + ubt_old, vbt_old, BT_OBC, G, MS, US, halo, dtbt, bebt, & + use_BT_cont, integral_BT_cont, dt_elapsed, Datu, Datv, & + BTCL_u, BTCL_v, uhbt0, vhbt0, ubt_int, vbt_int, uhbt_int, vhbt_int) type(ocean_OBC_type), pointer :: OBC !< An associated pointer to an OBC type. type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(memory_size_type), intent(in) :: MS !< A type that describes the memory sizes of @@ -2506,6 +2794,11 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, !! in determining the transport. logical, intent(in) :: use_BT_cont !< If true, use the BT_cont_types to calculate !! transports. + logical, intent(in) :: integral_BT_cont !< If true, update the barotropic continuity + !! equation directly from the initial condition + !! using the time-integrated barotropic velocity. + real, intent(in) :: dt_elapsed !< The amount of time in the barotropic stepping + !! that will have elapsed [T ~> s]. real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: Datu !< A fixed estimate of the face areas at u points !! [H L ~> m2 or kg m-1]. real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: Datv !< A fixed estimate of the face areas at v points @@ -2524,6 +2817,14 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, !! the barotropic functions agree with the sum !! of the layer transports !! [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: ubt_int !< The time-integrated zonal barotropic + !! velocity before this update [L T-1 ~> m s-1]. + real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: uhbt_int !< The time-integrated zonal barotropic + !! transport [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: vbt_int !< The time-integrated meridional barotropic + !! velocity before this update [L T-1 ~> m s-1]. + real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: vhbt_int !< The time-integrated meridional barotropic + !! transport [H L2 T-1 ~> m3 s-1 or kg s-1]. ! Local variables real :: vel_prev ! The previous velocity [L T-1 ~> m s-1]. @@ -2534,14 +2835,21 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, real :: cfl ! The CFL number at the point in question [nondim] real :: u_inlet ! The zonal inflow velocity [L T-1 ~> m s-1] real :: v_inlet ! The meridional inflow velocity [L T-1 ~> m s-1] - real :: h_in + real :: uhbt_int_new ! The updated time-integrated zonal transport [H L2 ~> m3] + real :: vhbt_int_new ! The updated time-integrated meridional transport [H L2 ~> m3] + real :: h_in ! The inflow thickess [H ~> m or kg m-2]. real :: cff, Cx, Cy, tau real :: dhdt, dhdx, dhdy + real :: Idtbt ! The inverse of the barotropic time step [T-1 ~> s-1] integer :: i, j, is, ie, js, je real, dimension(SZIB_(G),SZJB_(G)) :: grad real, parameter :: eps = 1.0e-20 is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo + if (.not.(BT_OBC%apply_u_OBCs .or. BT_OBC%apply_v_OBCs)) return + + Idtbt = 1.0 / dtbt + if (BT_OBC%apply_u_OBCs) then do j=js,je ; do I=is-1,ie ; if (OBC%segnum_u(I,j) /= OBC_NONE) then if (OBC%segment(OBC%segnum_u(I,j))%specified) then @@ -2581,8 +2889,12 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, endif if (.not. OBC%segment(OBC%segnum_u(I,j))%specified) then - if (use_BT_cont) then - uhbt(I,j) = find_uhbt(vel_trans, BTCL_u(I,j), US) + uhbt0(I,j) + if (integral_BT_cont) then + uhbt_int_new = find_uhbt(ubt_int(I,j) + dtbt*vel_trans, BTCL_u(I,j)) + & + dt_elapsed*uhbt0(I,j) + uhbt(I,j) = (uhbt_int_new - uhbt_int(I,j)) * Idtbt + elseif (use_BT_cont) then + uhbt(I,j) = find_uhbt(vel_trans, BTCL_u(I,j)) + uhbt0(I,j) else uhbt(I,j) = Datu(I,j)*vel_trans + uhbt0(I,j) endif @@ -2600,7 +2912,7 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, vel_trans = vbt(i,J) elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then if (OBC%segment(OBC%segnum_v(i,J))%Flather) then - cfl = dtbt * BT_OBC%Cg_v(i,J) * G%IdyCv(I,j) ! CFL + cfl = dtbt * BT_OBC%Cg_v(i,J) * G%IdyCv(i,J) ! CFL v_inlet = cfl*vbt_old(i,J-1) + (1.0-cfl)*vbt_old(i,J) ! Valid for cfl<1 h_in = eta(i,j) + (0.5-cfl)*(eta(i,j)-eta(i,j-1)) ! internal @@ -2616,7 +2928,7 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, endif elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then if (OBC%segment(OBC%segnum_v(i,J))%Flather) then - cfl = dtbt * BT_OBC%Cg_v(i,J) * G%IdyCv(I,j) ! CFL + cfl = dtbt * BT_OBC%Cg_v(i,J) * G%IdyCv(i,J) ! CFL v_inlet = cfl*vbt_old(i,J+1) + (1.0-cfl)*vbt_old(i,J) ! Valid for cfl <1 h_in = eta(i,j+1) + (0.5-cfl)*(eta(i,j+1)-eta(i,j+2)) ! internal @@ -2633,10 +2945,14 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, endif if (.not. OBC%segment(OBC%segnum_v(i,J))%specified) then - if (use_BT_cont) then - vhbt(i,J) = find_vhbt(vel_trans, BTCL_v(i,J), US) + vhbt0(i,J) + if (integral_BT_cont) then + vhbt_int_new = find_vhbt(vbt_int(i,J) + dtbt*vel_trans, BTCL_v(i,J)) + & + dt_elapsed*vhbt0(i,J) + vhbt(i,J) = (vhbt_int_new - vhbt_int(i,J)) * Idtbt + elseif (use_BT_cont) then + vhbt(i,J) = find_vhbt(vel_trans, BTCL_v(i,J)) + vhbt0(i,J) else - vhbt(i,J) = vel_trans*Datv(i,J) + vhbt0(i,J) + vhbt(i,J) = vel_trans*Datv(i,J) + vhbt0(i,J) endif endif @@ -2648,7 +2964,8 @@ end subroutine apply_velocity_OBCs !> This subroutine sets up the private structure used to apply the open !! boundary conditions, as developed by Mehmet Ilicak. -subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_BT_cont, Datu, Datv, BTCL_u, BTCL_v) +subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_BT_cont, & + integral_BT_cont, dt_baroclinic, Datu, Datv, BTCL_u, BTCL_v) type(ocean_OBC_type), pointer :: OBC !< An associated pointer to an OBC type. type(memory_size_type), intent(in) :: MS !< A type that describes the memory sizes of the !! argument arrays. @@ -2664,6 +2981,11 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_B integer, intent(in) :: halo !< The extra halo size to use here. logical, intent(in) :: use_BT_cont !< If true, use the BT_cont_types to calculate !! transports. + logical, intent(in) :: integral_BT_cont !< If true, update the barotropic continuity + !! equation directly from the initial condition + !! using the time-integrated barotropic velocity. + real, intent(in) :: dt_baroclinic !< The baroclinic timestep for this cycle of + !! updates to the barotropic solver [T ~> s] real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: Datu !< A fixed estimate of the face areas at u points !! [H L ~> m2 or kg m-1]. real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: Datv !< A fixed estimate of the face areas at v points @@ -2676,18 +2998,19 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_B !! v-points. ! Local variables + real :: I_dt ! The inverse of the time interval of this call [T-1 ~> s-1]. integer :: i, j, k, is, ie, js, je, n, nz, Isq, Ieq, Jsq, Jeq integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB integer :: isdw, iedw, jsdw, jedw logical :: OBC_used type(OBC_segment_type), pointer :: segment !< Open boundary segment - is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = G%ke IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB isdw = MS%isdw ; iedw = MS%iedw ; jsdw = MS%jsdw ; jedw = MS%jedw + I_dt = 1.0 / dt_baroclinic if ((isdw < isd) .or. (jsdw < jsd)) then call MOM_error(FATAL, "set_up_BT_OBC: Open boundary conditions are not "//& @@ -2731,8 +3054,10 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_B do j=js,je ; do I=is-1,ie ; if (OBC%segnum_u(I,j) /= OBC_NONE) then ! Can this go in segment loop above? Is loop above wrong for wide halos?? if (OBC%segment(OBC%segnum_u(I,j))%specified) then - if (use_BT_cont) then - BT_OBC%ubt_outer(I,j) = uhbt_to_ubt(BT_OBC%uhbt(I,j), BTCL_u(I,j), US) + if (integral_BT_cont) then + BT_OBC%ubt_outer(I,j) = uhbt_to_ubt(BT_OBC%uhbt(I,j)*dt_baroclinic, BTCL_u(I,j)) * I_dt + elseif (use_BT_cont) then + BT_OBC%ubt_outer(I,j) = uhbt_to_ubt(BT_OBC%uhbt(I,j), BTCL_u(I,j)) else if (Datu(I,j) > 0.0) BT_OBC%ubt_outer(I,j) = BT_OBC%uhbt(I,j) / Datu(I,j) endif @@ -2783,8 +3108,10 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_B do J=js-1,je ; do i=is,ie ; if (OBC%segnum_v(i,J) /= OBC_NONE) then ! Can this go in segment loop above? Is loop above wrong for wide halos?? if (OBC%segment(OBC%segnum_v(i,J))%specified) then - if (use_BT_cont) then - BT_OBC%vbt_outer(i,J) = vhbt_to_vbt(BT_OBC%vhbt(i,J), BTCL_v(i,J), US) + if (integral_BT_cont) then + BT_OBC%vbt_outer(i,J) = vhbt_to_vbt(BT_OBC%vhbt(i,J)*dt_baroclinic, BTCL_v(i,J)) * I_dt + elseif (use_BT_cont) then + BT_OBC%vbt_outer(i,J) = vhbt_to_vbt(BT_OBC%vhbt(i,J), BTCL_v(i,J)) else if (Datv(i,J) > 0.0) BT_OBC%vbt_outer(i,J) = BT_OBC%vhbt(i,J) / Datv(i,J) endif @@ -3113,23 +3440,29 @@ subroutine btcalc(h, G, GV, CS, h_u, h_v, may_use_default, OBC) enddo ; endif if (CS%debug) then - call uvchksum("btcalc frhat[uv]", CS%frhatu, CS%frhatv, G%HI, 0, .true., .true.) + 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, 0, .true., .true., scale=GV%H_to_m) + call uvchksum("btcalc h_[uv]", h_u, h_v, G%HI, haloshift=0, & + symmetric=.true., omit_corners=.true., scale=GV%H_to_m, & + scalar_pair=.true.) call hchksum(h, "btcalc h",G%HI, haloshift=1, scale=GV%H_to_m) endif end subroutine btcalc -!> The function find_uhbt determines the zonal transport for a given velocity. -function find_uhbt(u, BTC, US) result(uhbt) - real, intent(in) :: u !< The local zonal velocity [L T-1 ~> m s-1] +!> The function find_uhbt determines the zonal transport for a given velocity, or with +!! INTEGRAL_BT_CONT=True it determines the time-integrated zonal transport for a given +!! time-integrated velocity. +function find_uhbt(u, BTC) result(uhbt) + real, intent(in) :: u !< The local zonal velocity [L T-1 ~> m s-1] or time integrated velocity [L ~> m] type(local_BT_cont_u_type), intent(in) :: BTC !< A structure containing various fields that !! allow the barotropic transports to be calculated consistently - !! with the layers' continuity equations. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + !! with the layers' continuity equations. The dimensions of some + !! of the elements in this type vary depending on INTEGRAL_BT_CONT. - real :: uhbt !< The zonal barotropic transport [L2 H T-1 ~> m3 s-1] + real :: uhbt !< The zonal barotropic transport [L2 H T-1 ~> m3 s-1] or time integrated transport [L2 H ~> m3] if (u == 0.0) then uhbt = 0.0 @@ -3145,14 +3478,14 @@ function find_uhbt(u, BTC, US) result(uhbt) end function find_uhbt -!> The function find_duhbt_du determines the marginal zonal face area for a given velocity. -function find_duhbt_du(u, BTC, US) result(duhbt_du) - real, intent(in) :: u !< The local zonal velocity [L T-1 ~> m s-1] +!> The function find_duhbt_du determines the marginal zonal face area for a given velocity, or +!! with INTEGRAL_BT_CONT=True for a given time-integrated velocity. +function find_duhbt_du(u, BTC) result(duhbt_du) + real, intent(in) :: u !< The local zonal velocity [L T-1 ~> m s-1] or time integrated velocity [L ~> m] type(local_BT_cont_u_type), intent(in) :: BTC !< A structure containing various fields that !! allow the barotropic transports to be calculated consistently - !! with the layers' continuity equations. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - + !! with the layers' continuity equations. The dimensions of some + !! of the elements in this type vary depending on INTEGRAL_BT_CONT. real :: duhbt_du !< The zonal barotropic face area [L H ~> m2] if (u == 0.0) then @@ -3169,25 +3502,30 @@ function find_duhbt_du(u, BTC, US) result(duhbt_du) end function find_duhbt_du - !> This function inverts the transport function to determine the barotopic -!! velocity that is consistent with a given transport. -function uhbt_to_ubt(uhbt, BTC, US, guess) result(ubt) +!! velocity that is consistent with a given transport, or if INTEGRAL_BT_CONT=True +!! this finds the time-integrated velocity that is consistent with a time-integrated transport. +function uhbt_to_ubt(uhbt, BTC, guess) result(ubt) real, intent(in) :: uhbt !< The barotropic zonal transport that should be inverted for, - !! [H L2 T-1 ~> m3 s-1 or kg s-1]. + !! [H L2 T-1 ~> m3 s-1 or kg s-1] or the time-integrated + !! transport [H L2 ~> m3 or kg]. type(local_BT_cont_u_type), intent(in) :: BTC !< A structure containing various fields that allow the !! barotropic transports to be calculated consistently with the - !! layers' continuity equations. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, optional, intent(in) :: guess !< A guess at what ubt will be [L T-1 ~> m s-1]. The result - !! is not allowed to be dramatically larger than guess. - real :: ubt !< The result - The velocity that gives uhbt transport [L T-1 ~> m s-1]. + !! layers' continuity equations. The dimensions of some + !! of the elements in this type vary depending on INTEGRAL_BT_CONT. + real, optional, intent(in) :: guess !< A guess at what ubt will be [L T-1 ~> m s-1] or [L ~> m]. + !! The result is not allowed to be dramatically larger than guess. + real :: ubt !< The result - The velocity that gives uhbt transport [L T-1 ~> m s-1] + !! or the time-integrated velocity [L ~> m]. ! Local variables - real :: ubt_min, ubt_max, uhbt_err, derr_du - real :: uherr_min, uherr_max + real :: ubt_min, ubt_max ! Bounding values of vbt [L T-1 ~> m s-1] or [L ~> m] + real :: uhbt_err ! The transport error [H L2 T-1 ~> m3 s-1 or kg s-1] or [H L2 ~> m3 or kg]. + real :: derr_du ! The change in transport error with vbt, i.e. the face area [H L ~> m2 or kg m-1]. + real :: uherr_min, uherr_max ! The bounding values of the transport error [H L2 T-1 ~> m3 s-1 or kg s-1] + ! or [H L2 ~> m3 or kg]. real, parameter :: tol = 1.0e-10 ! A fractional match tolerance [nondim] - real :: dvel ! Temporary variable used in the limiting the velocity [L T-1 ~> m s-1]. + real :: dvel ! Temporary variable used in the limiting the velocity [L T-1 ~> m s-1] or [L ~> m]. real :: vsr ! Temporary variable used in the limiting the velocity [nondim]. real, parameter :: vs1 = 1.25 ! Nondimensional parameters used in limiting real, parameter :: vs2 = 2.0 ! the velocity, starting at vs1, with the @@ -3255,7 +3593,7 @@ function uhbt_to_ubt(uhbt, BTC, US, guess) result(ubt) if (dvel > 0.0) then ! Limit the velocity if (dvel < 40.0 * (abs(guess)*(vs2-vs1)) ) then vsr = vs2 - (vs2-vs1) * exp(-dvel / (abs(guess)*(vs2-vs1))) - else ! The exp be less than 4e-18 anyway in this case, so neglect it. + else ! The exp is less than 4e-18 anyway in this case, so neglect it. vsr = vs2 endif ubt = SIGN(vsr * guess, ubt) @@ -3264,14 +3602,16 @@ function uhbt_to_ubt(uhbt, BTC, US, guess) result(ubt) end function uhbt_to_ubt -!> The function find_vhbt determines the meridional transport for a given velocity. -function find_vhbt(v, BTC, US) result(vhbt) - real, intent(in) :: v !< The local meridional velocity [L T-1 ~> m s-1] +!> The function find_vhbt determines the meridional transport for a given velocity, or with +!! INTEGRAL_BT_CONT=True it determines the time-integrated meridional transport for a given +!! time-integrated velocity. +function find_vhbt(v, BTC) result(vhbt) + real, intent(in) :: v !< The local meridional velocity [L T-1 ~> m s-1] or time integrated velocity [L ~> m] type(local_BT_cont_v_type), intent(in) :: BTC !< A structure containing various fields that !! allow the barotropic transports to be calculated consistently - !! with the layers' continuity equations. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real :: vhbt !< The meridional barotropic transport [L2 H T-1 ~> m3 s-1] + !! with the layers' continuity equations. The dimensions of some + !! of the elements in this type vary depending on INTEGRAL_BT_CONT. + real :: vhbt !< The meridional barotropic transport [L2 H T-1 ~> m3 s-1] or time integrated transport [L2 H ~> m3] if (v == 0.0) then vhbt = 0.0 @@ -3287,13 +3627,14 @@ function find_vhbt(v, BTC, US) result(vhbt) end function find_vhbt -!> The function find_vhbt determines the meridional transport for a given velocity. -function find_dvhbt_dv(v, BTC, US) result(dvhbt_dv) - real, intent(in) :: v !< The local meridional velocity [L T-1 ~> m s-1] +!> The function find_dvhbt_dv determines the marginal meridional face area for a given velocity, or +!! with INTEGRAL_BT_CONT=True for a given time-integrated velocity. +function find_dvhbt_dv(v, BTC) result(dvhbt_dv) + real, intent(in) :: v !< The local meridional velocity [L T-1 ~> m s-1] or time integrated velocity [L ~> m] type(local_BT_cont_v_type), intent(in) :: BTC !< A structure containing various fields that !! allow the barotropic transports to be calculated consistently - !! with the layers' continuity equations. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + !! with the layers' continuity equations. The dimensions of some + !! of the elements in this type vary depending on INTEGRAL_BT_CONT. real :: dvhbt_dv !< The meridional barotropic face area [L H ~> m2] if (v == 0.0) then @@ -3311,23 +3652,29 @@ function find_dvhbt_dv(v, BTC, US) result(dvhbt_dv) end function find_dvhbt_dv !> This function inverts the transport function to determine the barotopic -!! velocity that is consistent with a given transport. -function vhbt_to_vbt(vhbt, BTC, US, guess) result(vbt) +!! velocity that is consistent with a given transport, or if INTEGRAL_BT_CONT=True +!! this finds the time-integrated velocity that is consistent with a time-integrated transport. +function vhbt_to_vbt(vhbt, BTC, guess) result(vbt) real, intent(in) :: vhbt !< The barotropic meridional transport that should be - !! inverted for [H L2 T-1 ~> m3 s-1 or kg s-1]. + !! inverted for [H L2 T-1 ~> m3 s-1 or kg s-1] or the + !! time-integrated transport [H L2 ~> m3 or kg]. type(local_BT_cont_v_type), intent(in) :: BTC !< A structure containing various fields that allow the !! barotropic transports to be calculated consistently - !! with the layers' continuity equations. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, optional, intent(in) :: guess !< A guess at what vbt will be. The result is not allowed - !! to be dramatically larger than guess [L T-1 ~> m s-1]. - real :: vbt !< The result - The velocity that gives vhbt transport [L T-1 ~> m s-1]. + !! with the layers' continuity equations. The dimensions of some + !! of the elements in this type vary depending on INTEGRAL_BT_CONT. + real, optional, intent(in) :: guess !< A guess at what vbt will be [L T-1 ~> m s-1] or [L ~> m]. + !! The result is not allowed to be dramatically larger than guess. + real :: vbt !< The result - The velocity that gives vhbt transport [L T-1 ~> m s-1] + !! or the time-integrated velocity [L ~> m]. ! Local variables - real :: vbt_min, vbt_max, vhbt_err, derr_dv - real :: vherr_min, vherr_max + real :: vbt_min, vbt_max ! Bounding values of vbt [L T-1 ~> m s-1] or [L ~> m] + real :: vhbt_err ! The transport error [H L2 T-1 ~> m3 s-1 or kg s-1] or [H L2 ~> m3 or kg]. + real :: derr_dv ! The change in transport error with vbt, i.e. the face area [H L ~> m2 or kg m-1]. + real :: vherr_min, vherr_max ! The bounding values of the transport error [H L2 T-1 ~> m3 s-1 or kg s-1] + ! or [H L2 ~> m3 or kg]. real, parameter :: tol = 1.0e-10 ! A fractional match tolerance [nondim] - real :: dvel ! Temporary variable used in the limiting the velocity [L T-1 ~> m s-1]. + real :: dvel ! Temporary variable used in the limiting the velocity [L T-1 ~> m s-1] or [L ~> m]. real :: vsr ! Temporary variable used in the limiting the velocity [nondim]. real, parameter :: vs1 = 1.25 ! Nondimensional parameters used in limiting real, parameter :: vs2 = 2.0 ! the velocity, starting at vs1, with the @@ -3395,7 +3742,7 @@ function vhbt_to_vbt(vhbt, BTC, US, guess) result(vbt) if (dvel > 0.0) then ! Limit the velocity if (dvel < 40.0 * (abs(guess)*(vs2-vs1)) ) then vsr = vs2 - (vs2-vs1) * exp(-dvel / (abs(guess)*(vs2-vs1))) - else ! The exp be less than 4e-18 anyway in this case, so neglect it. + else ! The exp is less than 4e-18 anyway in this case, so neglect it. vsr = vs2 endif vbt = SIGN(guess * vsr, vbt) @@ -3406,7 +3753,7 @@ end function vhbt_to_vbt !> This subroutine sets up reordered versions of the BT_cont type in the !! local_BT_cont types, which have wide halos properly filled in. -subroutine set_local_BT_cont_types(BT_cont, BTCL_u, BTCL_v, G, US, MS, BT_Domain, halo) +subroutine set_local_BT_cont_types(BT_cont, BTCL_u, BTCL_v, G, US, MS, BT_Domain, halo, dt_baroclinic) type(BT_cont_type), intent(inout) :: BT_cont !< The BT_cont_type input to the !! barotropic solver. type(memory_size_type), intent(in) :: MS !< A type that describes the @@ -3421,16 +3768,26 @@ subroutine set_local_BT_cont_types(BT_cont, BTCL_u, BTCL_v, G, US, MS, BT_Domain type(MOM_domain_type), intent(inout) :: BT_Domain !< The domain to use for updating !! the halos of wide arrays. integer, optional, intent(in) :: halo !< The extra halo size to use here. + real, optional, intent(in) :: dt_baroclinic !< The baroclinic time step + !! [T ~> s], which is provided if + !! INTEGRAL_BT_CONTINUITY is true. ! Local variables real, dimension(SZIBW_(MS),SZJW_(MS)) :: & - u_polarity, uBT_EE, uBT_WW, FA_u_EE, FA_u_E0, FA_u_W0, FA_u_WW + u_polarity, & ! An array used to test for halo update polarity [nondim] + uBT_EE, uBT_WW, & ! Zonal velocities at which the form of the fit changes [L T-1 ~> m s-1] + FA_u_EE, FA_u_E0, FA_u_W0, FA_u_WW ! Zonal face areas [H L ~> m2 or kg m-1] real, dimension(SZIW_(MS),SZJBW_(MS)) :: & - v_polarity, vBT_NN, vBT_SS, FA_v_NN, FA_v_N0, FA_v_S0, FA_v_SS + v_polarity, & ! An array used to test for halo update polarity [nondim] + vBT_NN, vBT_SS, & ! Meridional velocities at which the form of the fit changes [L T-1 ~> m s-1] + FA_v_NN, FA_v_N0, FA_v_S0, FA_v_SS ! Meridional face areas [H L ~> m2 or kg m-1] + real :: dt ! The baroclinic timestep [T ~> s] or 1.0 [nondim] real, parameter :: C1_3 = 1.0/3.0 integer :: i, j, is, ie, js, je, hs + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec hs = 1 ; if (present(halo)) hs = max(halo,0) + dt = 1.0 ; if (present(dt_baroclinic)) dt = dt_baroclinic ! Copy the BT_cont arrays into symmetric, potentially wide haloed arrays. !$OMP parallel default(none) shared(is,ie,js,je,hs,u_polarity,uBT_EE,uBT_WW,FA_u_EE, & @@ -3480,15 +3837,12 @@ subroutine set_local_BT_cont_types(BT_cont, BTCL_u, BTCL_v, G, US, MS, BT_Domain if (id_clock_pass_pre > 0) call cpu_clock_end(id_clock_pass_pre) if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre) -!$OMP parallel default(none) shared(is,ie,js,je,hs,BTCL_u,FA_u_EE,FA_u_E0,FA_u_W0, & -!$OMP FA_u_WW,uBT_EE,uBT_WW,u_polarity,BTCL_v, & -!$OMP FA_v_NN,FA_v_N0,FA_v_S0,FA_v_SS,vBT_NN,vBT_SS, & -!$OMP v_polarity ) -!$OMP do + !$OMP parallel default(shared) + !$OMP do do j=js-hs,je+hs ; do I=is-hs-1,ie+hs BTCL_u(I,j)%FA_u_EE = FA_u_EE(I,j) ; BTCL_u(I,j)%FA_u_E0 = FA_u_E0(I,j) BTCL_u(I,j)%FA_u_W0 = FA_u_W0(I,j) ; BTCL_u(I,j)%FA_u_WW = FA_u_WW(I,j) - BTCL_u(I,j)%uBT_EE = uBT_EE(I,j) ; BTCL_u(I,j)%uBT_WW = uBT_WW(I,j) + BTCL_u(I,j)%uBT_EE = dt*uBT_EE(I,j) ; BTCL_u(I,j)%uBT_WW = dt*uBT_WW(I,j) ! Check for reversed polarity in the tripolar halo regions. if (u_polarity(I,j) < 0.0) then call swap(BTCL_u(I,j)%FA_u_EE, BTCL_u(I,j)%FA_u_WW) @@ -3507,11 +3861,11 @@ subroutine set_local_BT_cont_types(BT_cont, BTCL_u, BTCL_v, G, US, MS, BT_Domain if (abs(BTCL_u(I,j)%uBT_EE) > 0.0) BTCL_u(I,j)%uh_crvE = & (C1_3 * (BTCL_u(I,j)%FA_u_EE - BTCL_u(I,j)%FA_u_E0)) / BTCL_u(I,j)%uBT_EE**2 enddo ; enddo -!$OMP do + !$OMP do do J=js-hs-1,je+hs ; do i=is-hs,ie+hs BTCL_v(i,J)%FA_v_NN = FA_v_NN(i,J) ; BTCL_v(i,J)%FA_v_N0 = FA_v_N0(i,J) BTCL_v(i,J)%FA_v_S0 = FA_v_S0(i,J) ; BTCL_v(i,J)%FA_v_SS = FA_v_SS(i,J) - BTCL_v(i,J)%vBT_NN = vBT_NN(i,J) ; BTCL_v(i,J)%vBT_SS = vBT_SS(i,J) + BTCL_v(i,J)%vBT_NN = dt*vBT_NN(i,J) ; BTCL_v(i,J)%vBT_SS = dt*vBT_SS(i,J) ! Check for reversed polarity in the tripolar halo regions. if (v_polarity(i,J) < 0.0) then call swap(BTCL_v(i,J)%FA_v_NN, BTCL_v(i,J)%FA_v_SS) @@ -3530,14 +3884,16 @@ subroutine set_local_BT_cont_types(BT_cont, BTCL_u, BTCL_v, G, US, MS, BT_Domain if (abs(BTCL_v(i,J)%vBT_NN) > 0.0) BTCL_v(i,J)%vh_crvN = & (C1_3 * (BTCL_v(i,J)%FA_v_NN - BTCL_v(i,J)%FA_v_N0)) / BTCL_v(i,J)%vBT_NN**2 enddo ; enddo -!$OMP end parallel + !$OMP end parallel end subroutine set_local_BT_cont_types -!> Adjust_local_BT_cont_types sets up reordered versions of the BT_cont type -!! in the local_BT_cont types, which have wide halos properly filled in. +!> Adjust_local_BT_cont_types expands the range of velocities with a cubic curve +!! translating velocities into transports to match the inital values of velocities and +!! summed transports when the velocities are larger than the first guesses of the cubic +!! transition velocities used to set up the local_BT_cont types. subroutine adjust_local_BT_cont_types(ubt, uhbt, vbt, vhbt, BTCL_u, BTCL_v, & - G, US, MS, halo) + G, US, MS, halo, dt_baroclinic) type(memory_size_type), intent(in) :: MS !< A type that describes the memory sizes of the argument arrays. real, dimension(SZIBW_(MS),SZJW_(MS)), & intent(in) :: ubt !< The linearization zonal barotropic velocity [L T-1 ~> m s-1]. @@ -3556,73 +3912,78 @@ subroutine adjust_local_BT_cont_types(ubt, uhbt, vbt, vhbt, BTCL_u, BTCL_v, & type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type integer, optional, intent(in) :: halo !< The extra halo size to use here. + real, optional, intent(in) :: dt_baroclinic !< The baroclinic time step [T ~> s], which is + !! provided if INTEGRAL_BT_CONTINUITY is true. ! Local variables real, dimension(SZIBW_(MS),SZJW_(MS)) :: & u_polarity, uBT_EE, uBT_WW, FA_u_EE, FA_u_E0, FA_u_W0, FA_u_WW real, dimension(SZIW_(MS),SZJBW_(MS)) :: & v_polarity, vBT_NN, vBT_SS, FA_v_NN, FA_v_N0, FA_v_S0, FA_v_SS + real :: dt ! The baroclinic timestep [T ~> s] or 1.0 [nondim] real, parameter :: C1_3 = 1.0/3.0 integer :: i, j, is, ie, js, je, hs + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec hs = 1 ; if (present(halo)) hs = max(halo,0) + dt = 1.0 ; if (present(dt_baroclinic)) dt = dt_baroclinic !$OMP parallel do default(shared) do j=js-hs,je+hs ; do I=is-hs-1,ie+hs - if ((ubt(I,j) > BTCL_u(I,j)%uBT_WW) .and. (uhbt(I,j) > BTCL_u(I,j)%uh_WW)) then + if ((dt*ubt(I,j) > BTCL_u(I,j)%uBT_WW) .and. (dt*uhbt(I,j) > BTCL_u(I,j)%uh_WW)) then ! Expand the cubic fit to use this new point. ubt is negative. - BTCL_u(I,j)%ubt_WW = ubt(I,j) + BTCL_u(I,j)%ubt_WW = dt * ubt(I,j) if (3.0*uhbt(I,j) < 2.0*ubt(I,j) * BTCL_u(I,j)%FA_u_W0) then ! No further bounding is needed. - BTCL_u(I,j)%uh_crvW = (uhbt(I,j) - ubt(I,j) * BTCL_u(I,j)%FA_u_W0) / ubt(I,j)**3 + BTCL_u(I,j)%uh_crvW = (uhbt(I,j) - ubt(I,j) * BTCL_u(I,j)%FA_u_W0) / (dt**2 * ubt(I,j)**3) else ! This should not happen often! BTCL_u(I,j)%FA_u_W0 = 1.5*uhbt(I,j) / ubt(I,j) - BTCL_u(I,j)%uh_crvW = -0.5*uhbt(I,j) / ubt(I,j)**3 + BTCL_u(I,j)%uh_crvW = -0.5*uhbt(I,j) / (dt**2 * ubt(I,j)**3) endif - BTCL_u(I,j)%uh_WW = uhbt(I,j) + BTCL_u(I,j)%uh_WW = dt * uhbt(I,j) ! I don't know whether this is helpful. ! BTCL_u(I,j)%FA_u_WW = min(BTCL_u(I,j)%FA_u_WW, uhbt(I,j) / ubt(I,j)) - elseif ((ubt(I,j) < BTCL_u(I,j)%uBT_EE) .and. (uhbt(I,j) < BTCL_u(I,j)%uh_EE)) then + elseif ((dt*ubt(I,j) < BTCL_u(I,j)%uBT_EE) .and. (dt*uhbt(I,j) < BTCL_u(I,j)%uh_EE)) then ! Expand the cubic fit to use this new point. ubt is negative. - BTCL_u(I,j)%ubt_EE = ubt(I,j) + BTCL_u(I,j)%ubt_EE = dt * ubt(I,j) if (3.0*uhbt(I,j) < 2.0*ubt(I,j) * BTCL_u(I,j)%FA_u_E0) then ! No further bounding is needed. - BTCL_u(I,j)%uh_crvE = (uhbt(I,j) - ubt(I,j) * BTCL_u(I,j)%FA_u_E0) / ubt(I,j)**3 + BTCL_u(I,j)%uh_crvE = (uhbt(I,j) - ubt(I,j) * BTCL_u(I,j)%FA_u_E0) / (dt**2 * ubt(I,j)**3) else ! This should not happen often! BTCL_u(I,j)%FA_u_E0 = 1.5*uhbt(I,j) / ubt(I,j) - BTCL_u(I,j)%uh_crvE = -0.5*uhbt(I,j) / ubt(I,j)**3 + BTCL_u(I,j)%uh_crvE = -0.5*uhbt(I,j) / (dt**2 * ubt(I,j)**3) endif - BTCL_u(I,j)%uh_EE = uhbt(I,j) + BTCL_u(I,j)%uh_EE = dt * uhbt(I,j) ! I don't know whether this is helpful. ! BTCL_u(I,j)%FA_u_EE = min(BTCL_u(I,j)%FA_u_EE, uhbt(I,j) / ubt(I,j)) endif enddo ; enddo !$OMP parallel do default(shared) do J=js-hs-1,je+hs ; do i=is-hs,ie+hs - if ((vbt(i,J) > BTCL_v(i,J)%vBT_SS) .and. (vhbt(i,J) > BTCL_v(i,J)%vh_SS)) then + if ((dt*vbt(i,J) > BTCL_v(i,J)%vBT_SS) .and. (dt*vhbt(i,J) > BTCL_v(i,J)%vh_SS)) then ! Expand the cubic fit to use this new point. vbt is negative. - BTCL_v(i,J)%vbt_SS = vbt(i,J) + BTCL_v(i,J)%vbt_SS = dt * vbt(i,J) if (3.0*vhbt(i,J) < 2.0*vbt(i,J) * BTCL_v(i,J)%FA_v_S0) then ! No further bounding is needed. - BTCL_v(i,J)%vh_crvS = (vhbt(i,J) - vbt(i,J) * BTCL_v(i,J)%FA_v_S0) / vbt(i,J)**3 + BTCL_v(i,J)%vh_crvS = (vhbt(i,J) - vbt(i,J) * BTCL_v(i,J)%FA_v_S0) / (dt**2 * vbt(i,J)**3) else ! This should not happen often! BTCL_v(i,J)%FA_v_S0 = 1.5*vhbt(i,J) / (vbt(i,J)) - BTCL_v(i,J)%vh_crvS = -0.5*vhbt(i,J) / vbt(i,J)**3 + BTCL_v(i,J)%vh_crvS = -0.5*vhbt(i,J) / (dt**2 * vbt(i,J)**3) endif - BTCL_v(i,J)%vh_SS = vhbt(i,J) + BTCL_v(i,J)%vh_SS = dt * vhbt(i,J) ! I don't know whether this is helpful. ! BTCL_v(i,J)%FA_v_SS = min(BTCL_v(i,J)%FA_v_SS, vhbt(i,J) / vbt(i,J)) - elseif ((vbt(i,J) < BTCL_v(i,J)%vBT_NN) .and. (vhbt(i,J) < BTCL_v(i,J)%vh_NN)) then + elseif ((dt*vbt(i,J) < BTCL_v(i,J)%vBT_NN) .and. (dt*vhbt(i,J) < BTCL_v(i,J)%vh_NN)) then ! Expand the cubic fit to use this new point. vbt is negative. - BTCL_v(i,J)%vbt_NN = vbt(i,J) + BTCL_v(i,J)%vbt_NN = dt * vbt(i,J) if (3.0*vhbt(i,J) < 2.0*vbt(i,J) * BTCL_v(i,J)%FA_v_N0) then ! No further bounding is needed. - BTCL_v(i,J)%vh_crvN = (vhbt(i,J) - vbt(i,J) * BTCL_v(i,J)%FA_v_N0) / vbt(i,J)**3 + BTCL_v(i,J)%vh_crvN = (vhbt(i,J) - vbt(i,J) * BTCL_v(i,J)%FA_v_N0) / (dt**2 * vbt(i,J)**3) else ! This should not happen often! BTCL_v(i,J)%FA_v_N0 = 1.5*vhbt(i,J) / (vbt(i,J)) - BTCL_v(i,J)%vh_crvN = -0.5*vhbt(i,J) / vbt(i,J)**3 + BTCL_v(i,J)%vh_crvN = -0.5*vhbt(i,J) / (dt**2 * vbt(i,J)**3) endif - BTCL_v(i,J)%vh_NN = vhbt(i,J) + BTCL_v(i,J)%vh_NN = dt * vhbt(i,J) ! I don't know whether this is helpful. ! BTCL_v(i,J)%FA_v_NN = min(BTCL_v(i,J)%FA_v_NN, vhbt(i,J) / vbt(i,J)) endif @@ -3802,8 +4163,6 @@ subroutine bt_mass_source(h, eta, set_cor, G, GV, CS) real :: d_eta ! The difference between estimates of the total ! thicknesses [H ~> m or kg m-2]. integer :: is, ie, js, je, nz, i, j, k - real, parameter :: frac_cor = 0.25 - real, parameter :: slow_rate = 0.125 if (.not.associated(CS)) call MOM_error(FATAL, "bt_mass_source: "// & "Module MOM_barotropic must be initialized before it is used.") @@ -3929,11 +4288,26 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, 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, "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 "//& @@ -3943,11 +4317,12 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, "BT_cont_type variables to set limits determined by "//& "MAXCFL_BT_CONT on the CFL number of the velocities "//& "that are likely to be driven by the corrective mass fluxes.", & - default=.true.) !, do_not_log=.not.CS%bound_BT_corr) + default=.true., do_not_log=.not.CS%bound_BT_corr) call get_param(param_file, mdl, "ADJUST_BT_CONT", CS%adjust_BT_cont, & "If true, adjust the curve fit to the BT_cont type "//& "that is used by the barotropic solver to match the "//& - "transport about which the flow is being linearized.", default=.false.) + "transport about which the flow is being linearized.", & + default=.false., do_not_log=.not.use_BT_cont_type) call get_param(param_file, mdl, "GRADUAL_BT_ICS", CS%gradual_BT_ICs, & "If true, adjust the initial conditions for the "//& "barotropic solver to the values from the layered "//& @@ -3981,25 +4356,16 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, "The barotropic y-halo size that is actually used.", & layoutParam=.true.) - call get_param(param_file, mdl, "USE_BT_CONT_TYPE", use_BT_cont_type, & - "If true, use a structure with elements that describe "//& - "effective face areas from the summed continuity solver "//& - "as a function the barotropic flow in coupling between "//& - "the barotropic and baroclinic flow. This is only used "//& - "if SPLIT is true. \n", default=.true.) - call get_param(param_file, mdl, "NONLINEAR_BT_CONTINUITY", & - CS%Nonlinear_continuity, & + call get_param(param_file, mdl, "NONLINEAR_BT_CONTINUITY", CS%Nonlinear_continuity, & "If true, use nonlinear transports in the barotropic "//& "continuity equation. This does not apply if "//& - "USE_BT_CONT_TYPE is true.", default=.false.) - CS%Nonlin_cont_update_period = 1 - if (CS%Nonlinear_continuity) & - call get_param(param_file, mdl, "NONLIN_BT_CONT_UPDATE_PERIOD", & - CS%Nonlin_cont_update_period, & + "USE_BT_CONT_TYPE is true.", default=.false., do_not_log=use_BT_cont_type) + call get_param(param_file, mdl, "NONLIN_BT_CONT_UPDATE_PERIOD", CS%Nonlin_cont_update_period, & "If NONLINEAR_BT_CONTINUITY is true, this is the number "//& "of barotropic time steps between updates to the face "//& - "areas, or 0 to update only before the barotropic stepping.",& - units="nondim", default=1) + "areas, or 0 to update only before the barotropic stepping.", & + units="nondim", default=1, do_not_log=.not.CS%Nonlinear_continuity) + call get_param(param_file, mdl, "BT_PROJECT_VELOCITY", CS%BT_project_velocity,& "If true, step the barotropic velocity first and project "//& "out the velocity tendency by 1+BEBT when calculating the "//& @@ -4016,28 +4382,27 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, call get_param(param_file, mdl, "DYNAMIC_SURFACE_PRESSURE", CS%dynamic_psurf, & "If true, add a dynamic pressure due to a viscous ice "//& "shelf, for instance.", default=.false.) - if (CS%dynamic_psurf) then - call get_param(param_file, mdl, "ICE_LENGTH_DYN_PSURF", CS%ice_strength_length, & + call get_param(param_file, mdl, "ICE_LENGTH_DYN_PSURF", CS%ice_strength_length, & "The length scale at which the Rayleigh damping rate due "//& "to the ice strength should be the same as if a Laplacian "//& "were applied, if DYNAMIC_SURFACE_PRESSURE is true.", & - units="m", default=1.0e4, scale=US%m_to_L) - call get_param(param_file, mdl, "DEPTH_MIN_DYN_PSURF", CS%Dmin_dyn_psurf, & - "The minimum depth to use in limiting the size of the "//& - "dynamic surface pressure for stability, if "//& - "DYNAMIC_SURFACE_PRESSURE is true..", & - units="m", default=1.0e-6, scale=US%m_to_Z) - call get_param(param_file, mdl, "CONST_DYN_PSURF", CS%const_dyn_psurf, & + units="m", default=1.0e4, scale=US%m_to_L, do_not_log=.not.CS%dynamic_psurf) + call get_param(param_file, mdl, "DEPTH_MIN_DYN_PSURF", CS%Dmin_dyn_psurf, & + "The minimum depth to use in limiting the size of the "//& + "dynamic surface pressure for stability, if "//& + "DYNAMIC_SURFACE_PRESSURE is true..", & + units="m", default=1.0e-6, scale=US%m_to_Z, do_not_log=.not.CS%dynamic_psurf) + call get_param(param_file, mdl, "CONST_DYN_PSURF", CS%const_dyn_psurf, & "The constant that scales the dynamic surface pressure, "//& "if DYNAMIC_SURFACE_PRESSURE is true. Stable values "//& - "are < ~1.0.", units="nondim", default=0.9) - endif + "are < ~1.0.", units="nondim", default=0.9, do_not_log=.not.CS%dynamic_psurf) + call get_param(param_file, mdl, "BT_CORIOLIS_SCALE", CS%BT_Coriolis_scale, & "A factor by which the barotropic Coriolis anomaly terms are scaled.", & units="nondim", default=1.0) call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=.true.) + default=.false.) call get_param(param_file, mdl, "BAROTROPIC_2018_ANSWERS", CS%answers_2018, & "If true, use expressions for the barotropic solver that recover the answers "//& "from the end of 2018. Otherwise, use more efficient or general expressions.", & @@ -4235,6 +4600,7 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, 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. @@ -4255,7 +4621,7 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, CS%IdxCu(I,j) = G%IdxCu(I,j) ; CS%dy_Cu(I,j) = G%dy_Cu(I,j) enddo ; enddo do J=G%JsdB,G%JedB ; do i=G%isd,G%ied - CS%IdyCv(I,j) = G%IdyCv(I,j) ; CS%dx_Cv(i,J) = G%dx_Cv(i,J) + CS%IdyCv(i,J) = G%IdyCv(i,J) ; CS%dx_Cv(i,J) = G%dx_Cv(i,J) enddo ; enddo call create_group_pass(pass_static_data, CS%IareaT, CS%BT_domain, To_All) call create_group_pass(pass_static_data, CS%bathyT, CS%BT_domain, To_All) @@ -4345,7 +4711,7 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, call log_param(param_file, mdl, "DTBT as used", CS%dtbt*US%T_to_s) call log_param(param_file, mdl, "estimated maximum DTBT", CS%dtbt_max*US%T_to_s) - ! ubtav, vbtav, ubt_IC, vbt_IC, uhbt_IC, and vhbt_IC are allocated and + ! ubtav and vbtav, and perhaps ubt_IC and vbt_IC, are allocated and ! initialized in register_barotropic_restarts. if (GV%Boussinesq) then @@ -4370,6 +4736,10 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, '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_m) @@ -4444,6 +4814,9 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, 'BTCont type far east velocity', 'm s-1', conversion=US%L_T_to_m_s) CS%id_BTC_ubt_WW = register_diag_field('ocean_model', 'BTC_ubt_WW', diag%axesCu1, Time, & 'BTCont type far west velocity', 'm s-1', conversion=US%L_T_to_m_s) + ! This is a specialized diagnostic that is not being made widely available (yet). + ! CS%id_BTC_FA_u_rat0 = register_diag_field('ocean_model', 'BTC_FA_u_rat0', diag%axesCu1, Time, & + ! 'BTCont type ratio of near east and west face areas', 'nondim') CS%id_BTC_FA_v_NN = register_diag_field('ocean_model', 'BTC_FA_v_NN', diag%axesCv1, Time, & 'BTCont type far north face area', 'm2', conversion=US%L_to_m*GV%H_to_m) CS%id_BTC_FA_v_N0 = register_diag_field('ocean_model', 'BTC_FA_v_N0', diag%axesCv1, Time, & @@ -4456,6 +4829,11 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, 'BTCont type far north velocity', 'm s-1', conversion=US%L_T_to_m_s) CS%id_BTC_vbt_SS = register_diag_field('ocean_model', 'BTC_vbt_SS', diag%axesCv1, Time, & 'BTCont type far south velocity', 'm s-1', conversion=US%L_T_to_m_s) + ! This is a specialized diagnostic that is not being made widely available (yet). + ! CS%id_BTC_FA_v_rat0 = register_diag_field('ocean_model', 'BTC_FA_v_rat0', diag%axesCv1, Time, & + ! 'BTCont type ratio of near north and south face areas', 'nondim') + ! CS%id_BTC_FA_h_rat0 = register_diag_field('ocean_model', 'BTC_FA_h_rat0', diag%axesT1, Time, & + ! 'BTCont type maximum ratios of near face areas around cells', 'nondim') endif CS%id_uhbt0 = register_diag_field('ocean_model', 'uhbt0', diag%axesCu1, Time, & 'Barotropic zonal transport difference', 'm3 s-1', conversion=GV%H_to_m*US%L_to_m**2*US%s_to_T) @@ -4479,20 +4857,21 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, (US%m_to_L*US%s_to_T_restart) /= (US%m_to_L_restart*US%s_to_T)) then vel_rescale = (US%m_to_L*US%s_to_T_restart) / (US%m_to_L_restart*US%s_to_T) do j=js,je ; do I=is-1,ie ; CS%ubtav(I,j) = vel_rescale * CS%ubtav(I,j) ; enddo ; enddo - do J=js-1,je ; do i=is,ie ; CS%vbtav(i,J) = vel_rescale * CS%vbtav(I,j) ; enddo ; enddo + do J=js-1,je ; do i=is,ie ; CS%vbtav(i,J) = vel_rescale * CS%vbtav(i,J) ; enddo ; enddo endif - if (.NOT.query_initialized(CS%ubt_IC,"ubt_IC",restart_CS) .or. & - .NOT.query_initialized(CS%vbt_IC,"vbt_IC",restart_CS)) then - do j=js,je ; do I=is-1,ie ; CS%ubt_IC(I,j) = CS%ubtav(I,j) ; enddo ; enddo - do J=js-1,je ; do i=is,ie ; CS%vbt_IC(i,J) = CS%vbtav(i,J) ; enddo ; enddo - elseif ((US%s_to_T_restart*US%m_to_L_restart /= 0.0) .and. & - (US%m_to_L*US%s_to_T_restart) /= (US%m_to_L_restart*US%s_to_T)) then - vel_rescale = (US%m_to_L*US%s_to_T_restart) / (US%m_to_L_restart*US%s_to_T) - do j=js,je ; do I=is-1,ie ; CS%ubt_IC(I,j) = vel_rescale * CS%ubt_IC(I,j) ; enddo ; enddo - do J=js-1,je ; do i=is,ie ; CS%vbt_IC(i,J) = vel_rescale * CS%vbt_IC(I,j) ; enddo ; enddo + if (CS%gradual_BT_ICs) then + if (.NOT.query_initialized(CS%ubt_IC,"ubt_IC",restart_CS) .or. & + .NOT.query_initialized(CS%vbt_IC,"vbt_IC",restart_CS)) then + do j=js,je ; do I=is-1,ie ; CS%ubt_IC(I,j) = CS%ubtav(I,j) ; enddo ; enddo + do J=js-1,je ; do i=is,ie ; CS%vbt_IC(i,J) = CS%vbtav(i,J) ; enddo ; enddo + elseif ((US%s_to_T_restart*US%m_to_L_restart /= 0.0) .and. & + (US%m_to_L*US%s_to_T_restart) /= (US%m_to_L_restart*US%s_to_T)) then + vel_rescale = (US%m_to_L*US%s_to_T_restart) / (US%m_to_L_restart*US%s_to_T) + do j=js,je ; do I=is-1,ie ; CS%ubt_IC(I,j) = vel_rescale * CS%ubt_IC(I,j) ; enddo ; enddo + do J=js-1,je ; do i=is,ie ; CS%vbt_IC(i,J) = vel_rescale * CS%vbt_IC(i,J) ; enddo ; enddo + endif endif - ! Calculate other constants which are used for btstep. if (.not.CS%nonlin_stress) then @@ -4507,7 +4886,7 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, do J=js-1,je ; do i=is,ie if (G%mask2dCv(i,J)>0.) then CS%IDatv(i,J) = G%mask2dCv(i,J) * 2.0 / ((G%bathyT(i,j+1) + G%bathyT(i,j)) + 2.0*Mean_SL) - else ! Both neighboring H points are masked out so IDatv(I,j) is meaningless + else ! Both neighboring H points are masked out so IDatv(i,J) is meaningless CS%IDatv(i,J) = 0. endif enddo ; enddo @@ -4523,21 +4902,8 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, enddo ; enddo endif - if (.NOT.query_initialized(CS%uhbt_IC,"uhbt_IC",restart_CS) .or. & - .NOT.query_initialized(CS%vhbt_IC,"vhbt_IC",restart_CS)) then - do j=js,je ; do I=is-1,ie ; CS%uhbt_IC(I,j) = CS%ubtav(I,j) * Datu(I,j) ; enddo ; enddo - do J=js-1,je ; do i=is,ie ; CS%vhbt_IC(i,J) = CS%vbtav(i,J) * Datv(i,J) ; enddo ; enddo - elseif ((US%s_to_T_restart * US%m_to_L_restart * GV%m_to_H_restart /= 0.0) .and. & - ((US%s_to_T_restart * US%m_to_L**2 * GV%m_to_H) /= & - (US%s_to_T * US%m_to_L_restart**2 * GV%m_to_H_restart))) then - uH_rescale = (US%s_to_T_restart * US%m_to_L**2 * GV%m_to_H) / & - (US%s_to_T * US%m_to_L_restart**2 * GV%m_to_H_restart) - do j=js,je ; do I=is-1,ie ; CS%uhbt_IC(I,j) = uH_rescale * CS%uhbt_IC(I,j) ; enddo ; enddo - do J=js-1,je ; do i=is,ie ; CS%vhbt_IC(i,J) = uH_rescale * CS%vhbt_IC(I,j) ; enddo ; enddo - endif - - call create_group_pass(pass_bt_hbt_btav, CS%ubt_IC, CS%vbt_IC, G%Domain) - call create_group_pass(pass_bt_hbt_btav, CS%uhbt_IC, CS%vhbt_IC, G%Domain) + if (CS%gradual_BT_ICs) & + call create_group_pass(pass_bt_hbt_btav, CS%ubt_IC, CS%vbt_IC, G%Domain) call create_group_pass(pass_bt_hbt_btav, CS%ubtav, CS%vbtav, G%Domain) call do_group_pass(pass_bt_hbt_btav, G%Domain) @@ -4605,8 +4971,9 @@ subroutine register_barotropic_restarts(HI, GV, param_file, CS, restart_CS) ! Local variables type(vardesc) :: vd(3) - real :: slow_rate + character(len=40) :: mdl = "MOM_barotropic" ! This module's name. integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed IsdB = HI%IsdB ; IedB = HI%IedB ; JsdB = HI%JsdB ; JedB = HI%JedB @@ -4617,46 +4984,37 @@ subroutine register_barotropic_restarts(HI, GV, param_file, CS, restart_CS) endif allocate(CS) + call get_param(param_file, mdl, "GRADUAL_BT_ICS", CS%gradual_BT_ICs, & + "If true, adjust the initial conditions for the "//& + "barotropic solver to the values from the layered "//& + "solution over a whole timestep instead of instantly. "//& + "This is a decent approximation to the inclusion of "//& + "sum(u dh_dt) while also correcting for truncation errors.", & + default=.false., do_not_log=.true.) + ALLOC_(CS%ubtav(IsdB:IedB,jsd:jed)) ; CS%ubtav(:,:) = 0.0 ALLOC_(CS%vbtav(isd:ied,JsdB:JedB)) ; CS%vbtav(:,:) = 0.0 - ALLOC_(CS%ubt_IC(IsdB:IedB,jsd:jed)) ; CS%ubt_IC(:,:) = 0.0 - ALLOC_(CS%vbt_IC(isd:ied,JsdB:JedB)) ; CS%vbt_IC(:,:) = 0.0 - ALLOC_(CS%uhbt_IC(IsdB:IedB,jsd:jed)) ; CS%uhbt_IC(:,:) = 0.0 - ALLOC_(CS%vhbt_IC(isd:ied,JsdB:JedB)) ; CS%vhbt_IC(:,:) = 0.0 + if (CS%gradual_BT_ICs) then + ALLOC_(CS%ubt_IC(IsdB:IedB,jsd:jed)) ; CS%ubt_IC(:,:) = 0.0 + ALLOC_(CS%vbt_IC(isd:ied,JsdB:JedB)) ; CS%vbt_IC(:,:) = 0.0 + endif vd(2) = var_desc("ubtav","m s-1","Time mean barotropic zonal velocity", & hor_grid='u', z_grid='1') vd(3) = var_desc("vbtav","m s-1","Time mean barotropic meridional velocity",& hor_grid='v', z_grid='1') - call register_restart_field(CS%ubtav, vd(2), .false., restart_CS) - call register_restart_field(CS%vbtav, vd(3), .false., restart_CS) - - vd(2) = var_desc("ubt_IC", "m s-1", & - longname="Next initial condition for the barotropic zonal velocity", & - hor_grid='u', z_grid='1') - vd(3) = var_desc("vbt_IC", "m s-1", & - longname="Next initial condition for the barotropic meridional velocity",& - hor_grid='v', z_grid='1') - call register_restart_field(CS%ubt_IC, vd(2), .false., restart_CS) - call register_restart_field(CS%vbt_IC, vd(3), .false., restart_CS) + call register_restart_pair(CS%ubtav, CS%vbtav, vd(2), vd(3), .false., restart_CS) - if (GV%Boussinesq) then - vd(2) = var_desc("uhbt_IC", "m3 s-1", & - longname="Next initial condition for the barotropic zonal transport", & - hor_grid='u', z_grid='1') - vd(3) = var_desc("vhbt_IC", "m3 s-1", & - longname="Next initial condition for the barotropic meridional transport",& - hor_grid='v', z_grid='1') - else - vd(2) = var_desc("uhbt_IC", "kg s-1", & - longname="Next initial condition for the barotropic zonal transport", & + if (CS%gradual_BT_ICs) then + vd(2) = var_desc("ubt_IC", "m s-1", & + longname="Next initial condition for the barotropic zonal velocity", & hor_grid='u', z_grid='1') - vd(3) = var_desc("vhbt_IC", "kg s-1", & - longname="Next initial condition for the barotropic meridional transport",& + vd(3) = var_desc("vbt_IC", "m s-1", & + longname="Next initial condition for the barotropic meridional velocity",& hor_grid='v', z_grid='1') + call register_restart_pair(CS%ubt_IC, CS%vbt_IC, vd(2), vd(3), .false., restart_CS) endif - call register_restart_field(CS%uhbt_IC, vd(2), .false., restart_CS) - call register_restart_field(CS%vhbt_IC, vd(3), .false., restart_CS) + call register_restart_field(CS%dtbt, "DTBT", .false., restart_CS, & longname="Barotropic timestep", units="seconds") diff --git a/src/core/MOM_checksum_packages.F90 b/src/core/MOM_checksum_packages.F90 index bc586e1a2f..70ba32644f 100644 --- a/src/core/MOM_checksum_packages.F90 +++ b/src/core/MOM_checksum_packages.F90 @@ -6,8 +6,8 @@ module MOM_checksum_packages ! 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_domains, only : sum_across_PEs, min_across_PEs, max_across_PEs 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 @@ -132,7 +132,7 @@ subroutine MOM_thermo_chksum(mesg, tv, G, US, haloshift) if (associated(tv%T)) call hchksum(tv%T, mesg//" T", G%HI, haloshift=hs) if (associated(tv%S)) call hchksum(tv%S, mesg//" S", G%HI, haloshift=hs) if (associated(tv%frazil)) call hchksum(tv%frazil, mesg//" frazil", G%HI, haloshift=hs, & - scale=G%US%Q_to_J_kg*G%US%R_to_kg_m3*G%US%Z_to_m) + 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, scale=US%RZ_to_kg_m2) @@ -141,15 +141,16 @@ end subroutine MOM_thermo_chksum ! ============================================================================= !> Write out chksums for the ocean surface variables. -subroutine MOM_surface_chksum(mesg, sfc, G, haloshift, symmetric) - character(len=*), intent(in) :: mesg !< A message that appears on the chksum lines. - type(surface), intent(inout) :: sfc !< 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. - 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. +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 @@ -157,14 +158,19 @@ subroutine MOM_surface_chksum(mesg, sfc, G, haloshift, symmetric) sym = .false. ; if (present(symmetric)) sym = symmetric hs = 1 ; if (present(haloshift)) hs = haloshift - if (allocated(sfc%SST)) call hchksum(sfc%SST, mesg//" SST",G%HI,haloshift=hs) - if (allocated(sfc%SSS)) call hchksum(sfc%SSS, mesg//" SSS",G%HI,haloshift=hs) - if (allocated(sfc%sea_lev)) call hchksum(sfc%sea_lev, mesg//" sea_lev",G%HI,haloshift=hs) - if (allocated(sfc%Hml)) call hchksum(sfc%Hml, mesg//" Hml",G%HI,haloshift=hs) - if (allocated(sfc%u) .and. allocated(sfc%v)) & - call uvchksum(mesg//" SSU", sfc%u, sfc%v, G%HI, haloshift=hs, symmetric=sym) -! if (allocated(sfc%salt_deficit)) call hchksum(sfc%salt_deficit, mesg//" salt deficit",G%HI,haloshift=hs) - if (allocated(sfc%frazil)) call hchksum(sfc%frazil, mesg//" frazil", G%HI, haloshift=hs) + if (allocated(sfc_state%SST)) call hchksum(sfc_state%SST, mesg//" SST", G%HI, haloshift=hs) + if (allocated(sfc_state%SSS)) call hchksum(sfc_state%SSS, mesg//" SSS", G%HI, haloshift=hs) + 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%salt_deficit)) & +! call hchksum(sfc_state%salt_deficit, mesg//" salt deficit", G%HI, haloshift=hs, scale=US%RZ_to_kg_m2) + 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 @@ -251,6 +257,11 @@ subroutine MOM_state_stats(mesg, u, v, h, Temp, Salt, G, GV, US, allowChange, pe !! 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] + tmp_S ! The column-integrated salinity [ppt m3] 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] @@ -269,17 +280,22 @@ subroutine MOM_state_stats(mesg, u, v, h, Temp, Salt, G, GV, US, allowChange, pe is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke do_TS = associated(Temp) .and. associated(Salt) + tmp_A(:,:) = 0.0 + tmp_V(:,:) = 0.0 + tmp_T(:,:) = 0.0 + tmp_S(:,:) = 0.0 + ! First collect local stats - Area = 0. ; Vol = 0. - do j = js, je ; do i = is, ie - Area = Area + US%L_to_m**2*G%areaT(i,j) + 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 + 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) ; Vol = Vol + dV + 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, Temp(i,j,k) ) ; T%maximum = max( T%maximum, Temp(i,j,k) ) T%average = T%average + dV*Temp(i,j,k) @@ -289,10 +305,11 @@ subroutine MOM_state_stats(mesg, u, v, h, Temp, Salt, G, GV, US, allowChange, pe if (h_minimum > h(i,j,k)) h_minimum = h(i,j,k) endif enddo ; enddo ; enddo - call sum_across_PEs( Area ) ; call sum_across_PEs( Vol ) + 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 sum_across_PEs( T%average ) - call min_across_PEs( S%minimum ) ; call max_across_PEs( S%maximum ) ; call sum_across_PEs( S%average ) + 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 @@ -330,7 +347,7 @@ subroutine MOM_state_stats(mesg, u, v, h, Temp, Salt, G, GV, US, allowChange, pe 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 + do j=js,je ; do i=is,ie if (minval(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' @@ -343,7 +360,7 @@ subroutine MOM_state_stats(mesg, u, v, h, Temp, Salt, G, GV, US, allowChange, pe endif if (h_minimum<0.0) then - do j = js, je ; do i = is, ie + 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' diff --git a/src/core/MOM_continuity.F90 b/src/core/MOM_continuity.F90 index 9aaa6f92fc..cfb2b2e9fd 100644 --- a/src/core/MOM_continuity.F90 +++ b/src/core/MOM_continuity.F90 @@ -113,8 +113,9 @@ subroutine continuity_init(Time, G, GV, US, param_file, diag, CS) type(param_file_type), intent(in) :: param_file !< Parameter file handles. type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure. type(continuity_CS), pointer :: CS !< Control structure for mom_continuity. -! This include declares and sets the variable "version". -#include "version_variable.h" + + ! This include declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mdl = "MOM_continuity" ! This module's name. character(len=20) :: tmpstr diff --git a/src/core/MOM_continuity_PPM.F90 b/src/core/MOM_continuity_PPM.F90 index c594d31494..995827959d 100644 --- a/src/core/MOM_continuity_PPM.F90 +++ b/src/core/MOM_continuity_PPM.F90 @@ -263,6 +263,7 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, LB, uhbt, OBC, & real :: du_lim ! The velocity change that give a relative CFL of 1 [L T-1 ~> m s-1]. real :: dx_E, dx_W ! Effective x-grid spacings to the east and west [L ~> m]. integer :: i, j, k, ish, ieh, jsh, jeh, n, nz + integer :: l_seg logical :: local_specified_BC, use_visc_rem, set_BT_cont, any_simple_OBC logical :: local_Flather_OBC, local_open_BC, is_simple type(OBC_segment_type), pointer :: segment => NULL() @@ -303,7 +304,8 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, LB, uhbt, OBC, & !$OMP uh,dt,US,G,GV,CS,local_specified_BC,OBC,uhbt,set_BT_cont, & !$OMP CFL_dt,I_dt,u_cor,BT_cont, local_Flather_OBC) & !$OMP private(do_I,duhdu,du,du_max_CFL,du_min_CFL,uh_tot_0,duhdu_tot_0, & -!$OMP is_simple,FAuI,visc_rem_max,I_vrm,du_lim,dx_E,dx_W,any_simple_OBC ) & +!$OMP is_simple,FAuI,visc_rem_max,I_vrm,du_lim,dx_E,dx_W, & +!$OMP any_simple_OBC,l_seg) & !$OMP firstprivate(visc_rem) do j=jsh,jeh do I=ish-1,ieh ; do_I(I) = .true. ; visc_rem_max(I) = 0.0 ; enddo @@ -318,8 +320,12 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, LB, uhbt, OBC, & dt, G, US, j, ish, ieh, do_I, CS%vol_CFL, OBC) if (local_specified_BC) then do I=ish-1,ieh - if (OBC%segment(OBC%segnum_u(I,j))%specified) & - uh(I,j,k) = OBC%segment(OBC%segnum_u(I,j))%normal_trans(I,j,k) + l_seg = OBC%segnum_u(I,j) + + if (l_seg /= OBC_NONE) then + if (OBC%segment(l_seg)%specified) & + uh(I,j,k) = OBC%segment(l_seg)%normal_trans(I,j,k) + endif enddo endif enddo @@ -408,9 +414,13 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, LB, uhbt, OBC, & any_simple_OBC = .false. if (present(uhbt) .or. set_BT_cont) then if (local_specified_BC .or. local_Flather_OBC) then ; do I=ish-1,ieh + l_seg = OBC%segnum_u(I,j) + ! Avoid reconciling barotropic/baroclinic transports if transport is specified - is_simple = OBC%segment(OBC%segnum_u(I,j))%specified - do_I(I) = .not.(OBC%segnum_u(I,j) /= OBC_NONE .and. is_simple) + is_simple = .false. + if (l_seg /= OBC_NONE) & + is_simple = OBC%segment(l_seg)%specified + do_I(I) = .not. (l_seg /= OBC_NONE .and. is_simple) any_simple_OBC = any_simple_OBC .or. is_simple enddo ; else ; do I=ish-1,ieh do_I(I) = .true. @@ -425,8 +435,12 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, LB, uhbt, OBC, & if (present(u_cor)) then ; do k=1,nz do I=ish-1,ieh ; u_cor(I,j,k) = u(I,j,k) + du(I) * visc_rem(I,k) ; enddo if (local_specified_BC) then ; do I=ish-1,ieh - if (OBC%segment(OBC%segnum_u(I,j))%specified) & - u_cor(I,j,k) = OBC%segment(OBC%segnum_u(I,j))%normal_vel(I,j,k) + l_seg = OBC%segnum_u(I,j) + + if (l_seg /= OBC_NONE) then + if (OBC%segment(l_seg)%specified) & + u_cor(I,j,k) = OBC%segment(l_seg)%normal_vel(I,j,k) + endif enddo ; endif enddo ; endif ! u-corrected @@ -438,9 +452,15 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, LB, uhbt, OBC, & visc_rem_max, j, ish, ieh, do_I) if (any_simple_OBC) then do I=ish-1,ieh - do_I(I) = OBC%segment(OBC%segnum_u(I,j))%specified + l_seg = OBC%segnum_u(I,j) + + do_I(I) = .false. + if (l_seg /= OBC_NONE) & + do_I(I) = OBC%segment(l_seg)%specified + if (do_I(I)) FAuI(I) = GV%H_subroundoff*G%dy_Cu(I,j) enddo + ! NOTE: do_I(I) should prevent access to segment OBC_NONE do k=1,nz ; do I=ish-1,ieh ; if (do_I(I)) then if ((abs(OBC%segment(OBC%segnum_u(I,j))%normal_vel(I,j,k)) > 0.0) .and. & (OBC%segment(OBC%segnum_u(I,j))%specified)) & @@ -529,6 +549,7 @@ subroutine zonal_flux_layer(u, h, h_L, h_R, uh, duhdu, visc_rem, dt, G, US, j, & ! with the same units as h_in. real :: h_marg ! The marginal thickness of a flux [H ~> m or kg m-2]. integer :: i + integer :: l_seg logical :: local_open_BC local_open_BC = .false. @@ -561,13 +582,17 @@ subroutine zonal_flux_layer(u, h, h_L, h_R, uh, duhdu, visc_rem, dt, G, US, j, & if (local_open_BC) then do I=ish-1,ieh ; if (do_I(I)) then - if (OBC%segment(OBC%segnum_u(I,j))%open) then - if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then - uh(I) = G%dy_Cu(I,j) * u(I) * h(i) - duhdu(I) = G%dy_Cu(I,j) * h(i) * visc_rem(I) - else - uh(I) = G%dy_Cu(I,j) * u(I) * h(i+1) - duhdu(I) = G%dy_Cu(I,j) * h(i+1) * visc_rem(I) + l_seg = OBC%segnum_u(I,j) + + if (l_seg /= OBC_NONE) then + if (OBC%segment(l_seg)%open) then + if (OBC%segment(l_seg)%direction == OBC_DIRECTION_E) then + uh(I) = G%dy_Cu(I,j) * u(I) * h(i) + duhdu(I) = G%dy_Cu(I,j) * h(i) * visc_rem(I) + else + uh(I) = G%dy_Cu(I,j) * u(I) * h(i+1) + duhdu(I) = G%dy_Cu(I,j) * h(i+1) * visc_rem(I) + endif endif endif endif ; enddo @@ -1062,6 +1087,7 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, US, CS, LB, vhbt, OBC, & real :: dv_lim ! The velocity change that give a relative CFL of 1 [L T-1 ~> m s-1]. real :: dy_N, dy_S ! Effective y-grid spacings to the north and south [L ~> m]. integer :: i, j, k, ish, ieh, jsh, jeh, n, nz + integer :: l_seg logical :: local_specified_BC, use_visc_rem, set_BT_cont, any_simple_OBC logical :: local_Flather_OBC, is_simple, local_open_BC type(OBC_segment_type), pointer :: segment => NULL() @@ -1103,7 +1129,7 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, US, CS, LB, vhbt, OBC, & !$OMP set_BT_cont,CFL_dt,I_dt,v_cor,BT_cont, local_Flather_OBC ) & !$OMP private(do_I,dvhdv,dv,dv_max_CFL,dv_min_CFL,vh_tot_0, & !$OMP dvhdv_tot_0,visc_rem_max,I_vrm,dv_lim,dy_N, & -!$OMP is_simple,FAvi,dy_S,any_simple_OBC ) & +!$OMP is_simple,FAvi,dy_S,any_simple_OBC,l_seg) & !$OMP firstprivate(visc_rem) do J=jsh-1,jeh do i=ish,ieh ; do_I(i) = .true. ; visc_rem_max(I) = 0.0 ; enddo @@ -1118,8 +1144,12 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, US, CS, LB, vhbt, OBC, & dt, G, US, J, ish, ieh, do_I, CS%vol_CFL, OBC) if (local_specified_BC) then do i=ish,ieh - if (OBC%segment(OBC%segnum_v(i,J))%specified) & - vh(i,J,k) = OBC%segment(OBC%segnum_v(i,J))%normal_trans(i,J,k) + l_seg = OBC%segnum_v(i,J) + + if (l_seg /= OBC_NONE) then + if (OBC%segment(l_seg)%specified) & + vh(i,J,k) = OBC%segment(l_seg)%normal_trans(i,J,k) + endif enddo endif enddo ! k-loop @@ -1204,9 +1234,13 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, US, CS, LB, vhbt, OBC, & any_simple_OBC = .false. if (present(vhbt) .or. set_BT_cont) then if (local_specified_BC .or. local_Flather_OBC) then ; do i=ish,ieh + l_seg = OBC%segnum_v(i,J) + ! Avoid reconciling barotropic/baroclinic transports if transport is specified - is_simple = OBC%segment(OBC%segnum_v(i,J))%specified - do_I(i) = .not.(OBC%segnum_v(i,J) /= OBC_NONE .and. is_simple) + is_simple = .false. + if (l_seg /= OBC_NONE) & + is_simple = OBC%segment(l_seg)%specified + do_I(i) = .not.(l_seg /= OBC_NONE .and. is_simple) any_simple_OBC = any_simple_OBC .or. is_simple enddo ; else ; do i=ish,ieh do_I(i) = .true. @@ -1221,8 +1255,12 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, US, CS, LB, vhbt, OBC, & if (present(v_cor)) then ; do k=1,nz do i=ish,ieh ; v_cor(i,J,k) = v(i,J,k) + dv(i) * visc_rem(i,k) ; enddo if (local_specified_BC) then ; do i=ish,ieh - if (OBC%segment(OBC%segnum_v(i,J))%specified) & - v_cor(i,J,k) = OBC%segment(OBC%segnum_v(i,J))%normal_vel(i,J,k) + l_seg = OBC%segnum_v(i,J) + + if (l_seg /= OBC_NONE) then + if (OBC%segment(OBC%segnum_v(i,J))%specified) & + v_cor(i,J,k) = OBC%segment(OBC%segnum_v(i,J))%normal_vel(i,J,k) + endif enddo ; endif enddo ; endif ! v-corrected endif @@ -1233,9 +1271,15 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, US, CS, LB, vhbt, OBC, & visc_rem_max, J, ish, ieh, do_I) if (any_simple_OBC) then do i=ish,ieh - do_I(i) = (OBC%segment(OBC%segnum_v(i,J))%specified) + l_seg = OBC%segnum_v(i,J) + + do_I(I) = .false. + if(l_seg /= OBC_NONE) & + do_I(i) = (OBC%segment(l_seg)%specified) + if (do_I(i)) FAvi(i) = GV%H_subroundoff*G%dx_Cv(i,J) enddo + ! NOTE: do_I(I) should prevent access to segment OBC_NONE do k=1,nz ; do i=ish,ieh ; if (do_I(i)) then if ((abs(OBC%segment(OBC%segnum_v(i,J))%normal_vel(i,J,k)) > 0.0) .and. & (OBC%segment(OBC%segnum_v(i,J))%specified)) & @@ -1327,6 +1371,7 @@ subroutine merid_flux_layer(v, h, h_L, h_R, vh, dvhdv, visc_rem, dt, G, US, J, & ! with the same units as h, i.e. [H ~> m or kg m-2]. real :: h_marg ! The marginal thickness of a flux [H ~> m or kg m-2]. integer :: i + integer :: l_seg logical :: local_open_BC local_open_BC = .false. @@ -1360,13 +1405,17 @@ subroutine merid_flux_layer(v, h, h_L, h_R, vh, dvhdv, visc_rem, dt, G, US, J, & if (local_open_BC) then do i=ish,ieh ; if (do_I(i)) then - if (OBC%segment(OBC%segnum_v(i,J))%open) then - if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then - vh(i) = G%dx_Cv(i,J) * v(i) * h(i,j) - dvhdv(i) = G%dx_Cv(i,J) * h(i,j) * visc_rem(i) - else - vh(i) = G%dx_Cv(i,J) * v(i) * h(i,j+1) - dvhdv(i) = G%dx_Cv(i,J) * h(i,j+1) * visc_rem(i) + l_seg = OBC%segnum_v(i,J) + + if (l_seg /= OBC_NONE) then + if (OBC%segment(l_seg)%open) then + if (OBC%segment(l_seg)%direction == OBC_DIRECTION_N) then + vh(i) = G%dx_Cv(i,J) * v(i) * h(i,j) + dvhdv(i) = G%dx_Cv(i,J) * h(i,j) * visc_rem(i) + else + vh(i) = G%dx_Cv(i,J) * v(i) * h(i,j+1) + dvhdv(i) = G%dx_Cv(i,J) * h(i,j+1) * visc_rem(i) + endif endif endif endif ; enddo diff --git a/src/core/MOM_density_integrals.F90 b/src/core/MOM_density_integrals.F90 new file mode 100644 index 0000000000..d7d9c95b34 --- /dev/null +++ b/src/core/MOM_density_integrals.F90 @@ -0,0 +1,1655 @@ +!> Provides integrals of density +module MOM_density_integrals + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_EOS, only : EOS_type +use MOM_EOS, only : EOS_quadrature +use MOM_EOS, only : analytic_int_density_dz +use MOM_EOS, only : analytic_int_specific_vol_dp +use MOM_EOS, only : calculate_density +use MOM_EOS, only : calculate_spec_vol +use MOM_EOS, only : calculate_specific_vol_derivs +use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_hor_index, only : hor_index_type +use MOM_string_functions, only : uppercase +use MOM_variables, only : thermo_var_ptrs +use MOM_unit_scaling, only : unit_scale_type +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +#include + +public int_density_dz +public int_density_dz_generic_pcm +public int_density_dz_generic_plm +public int_density_dz_generic_ppm +public int_specific_vol_dp +public int_spec_vol_dp_generic_pcm +public int_spec_vol_dp_generic_plm +public find_depth_of_pressure_in_cell + +contains + +!> Calls the appropriate subroutine to calculate analytical and nearly-analytical +!! integrals in z across layers of pressure anomalies, which are +!! required for calculating the finite-volume form pressure accelerations in a +!! Boussinesq model. +subroutine int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, US, dpa, & + intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp) + type(hor_index_type), intent(in) :: HI !< Ocean horizontal index structures for the arrays + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: T !< Potential temperature referenced to the surface [degC] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: S !< Salinity [ppt] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: z_t !< Height at the top of the layer in depth units [Z ~> m] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: z_b !< Height at the bottom of the layer [Z ~> m] + real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3] or [kg m-3], that is + !! subtracted out to reduce the magnitude of each of the + !! integrals. + real, intent(in) :: rho_0 !< A density [R ~> kg m-3] or [kg m-3], that is used + !! to calculate the pressure (as p~=-z*rho_0*G_e) + !! used in the equation of state. + real, intent(in) :: G_e !< The Earth's gravitational acceleration + !! [L2 Z-1 T-2 ~> m s-2] or [m2 Z-1 s-2 ~> m s-2] + type(EOS_type), pointer :: EOS !< Equation of state structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(inout) :: dpa !< The change in the pressure anomaly + !! across the layer [R L2 T-2 ~> Pa] or [Pa] + real, dimension(SZI_(HI),SZJ_(HI)), & + optional, intent(inout) :: intz_dpa !< The integral through the thickness of the + !! layer of the pressure anomaly relative to the + !! anomaly at the top of the layer [R L2 Z T-2 ~> Pa m] + real, dimension(SZIB_(HI),SZJ_(HI)), & + optional, intent(inout) :: intx_dpa !< The integral in x of the difference between + !! the pressure anomaly at the top and bottom of the + !! layer divided by the x grid spacing [R L2 T-2 ~> Pa] + real, dimension(SZI_(HI),SZJB_(HI)), & + optional, intent(inout) :: inty_dpa !< The integral in y of the difference between + !! the pressure anomaly at the top and bottom of the + !! layer divided by the y grid spacing [R L2 T-2 ~> Pa] + real, dimension(SZI_(HI),SZJ_(HI)), & + optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m] + real, optional, intent(in) :: dz_neglect !< A minuscule thickness change [Z ~> m] + logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to + !! interpolate T/S for top and bottom integrals. + + if (EOS_quadrature(EOS)) then + call int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, US, dpa, & + intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp) + else + call analytic_int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, dpa, & + intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp) + endif + +end subroutine int_density_dz + + +!> Calculates (by numerical quadrature) integrals of pressure anomalies across layers, which +!! are required for calculating the finite-volume form pressure accelerations in a Boussinesq model. +subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & + EOS, US, dpa, intz_dpa, intx_dpa, inty_dpa, & + bathyT, dz_neglect, useMassWghtInterp) + type(hor_index_type), intent(in) :: HI !< Horizontal index type for input variables. + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: T !< Potential temperature of the layer [degC] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: S !< Salinity of the layer [ppt] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: z_t !< Height at the top of the layer in depth units [Z ~> m] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: z_b !< Height at the bottom of the layer [Z ~> m] + real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3] or [kg m-3], that is + !! subtracted out to reduce the magnitude + !! of each of the integrals. + real, intent(in) :: rho_0 !< A density [R ~> kg m-3] or [kg m-3], that is used + !! to calculate the pressure (as p~=-z*rho_0*G_e) + !! used in the equation of state. + real, intent(in) :: G_e !< The Earth's gravitational acceleration + !! [L2 Z-1 T-2 ~> m s-2] or [m2 Z-1 s-2 ~> m s-2] + type(EOS_type), pointer :: EOS !< Equation of state structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(inout) :: dpa !< The change in the pressure anomaly + !! across the layer [R L2 T-2 ~> Pa] or [Pa] + real, dimension(SZI_(HI),SZJ_(HI)), & + optional, intent(inout) :: intz_dpa !< The integral through the thickness of the + !! layer of the pressure anomaly relative to the + !! anomaly at the top of the layer [R L2 Z T-2 ~> Pa m] + real, dimension(SZIB_(HI),SZJ_(HI)), & + optional, intent(inout) :: intx_dpa !< The integral in x of the difference between + !! the pressure anomaly at the top and bottom of the + !! layer divided by the x grid spacing [R L2 T-2 ~> Pa] + real, dimension(SZI_(HI),SZJB_(HI)), & + optional, intent(inout) :: inty_dpa !< The integral in y of the difference between + !! the pressure anomaly at the top and bottom of the + !! layer divided by the y grid spacing [R L2 T-2 ~> Pa] + real, dimension(SZI_(HI),SZJ_(HI)), & + optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m] + real, optional, intent(in) :: dz_neglect !< A minuscule thickness change [Z ~> m] + logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to + !! interpolate T/S for top and bottom integrals. + ! Local variables + real :: T5(5), S5(5) ! Temperatures and salinities at five quadrature points [degC] and [ppt] + real :: p5(5) ! Pressures at five quadrature points, never rescaled from Pa [Pa] + real :: r5(5) ! Densities at five quadrature points [R ~> kg m-3] or [kg m-3] + real :: rho_anom ! The depth averaged density anomaly [R ~> kg m-3] or [kg m-3] + real :: w_left, w_right ! Left and right weights [nondim] + real, parameter :: C1_90 = 1.0/90.0 ! Rational constants. + real :: GxRho ! The gravitational acceleration times density and unit conversion factors [Pa Z-1 ~> kg m-2 s-2] + real :: I_Rho ! The inverse of the Boussinesq density [R-1 ~> m3 kg-1] or [m3 kg-1] + real :: rho_scale ! A scaling factor for densities from kg m-3 to R [R m3 kg-1 ~> 1] + real :: rho_ref_mks ! The reference density in MKS units, never rescaled from kg m-3 [kg m-3] + real :: dz ! The layer thickness [Z ~> m] + real :: hWght ! A pressure-thickness below topography [Z ~> m] + real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [Z ~> m] + real :: iDenom ! The inverse of the denominator in the weights [Z-2 ~> m-2] + real :: hWt_LL, hWt_LR ! hWt_LA is the weighted influence of A on the left column [nondim] + real :: hWt_RL, hWt_RR ! hWt_RA is the weighted influence of A on the right column [nondim] + real :: wt_L, wt_R ! The linear weights of the left and right columns [nondim] + real :: wtT_L, wtT_R ! The weights for tracers from the left and right columns [nondim] + real :: intz(5) ! The gravitational acceleration times the integrals of density + ! with height at the 5 sub-column locations [R L2 T-2 ~> Pa] or [Pa] + logical :: do_massWeight ! Indicates whether to do mass weighting. + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, i, j, m, n + + ! These array bounds work for the indexing convention of the input arrays, but + ! on the computational domain defined for the output arrays. + Isq = HI%IscB ; Ieq = HI%IecB + Jsq = HI%JscB ; Jeq = HI%JecB + is = HI%isc ; ie = HI%iec + js = HI%jsc ; je = HI%jec + + rho_scale = US%kg_m3_to_R + GxRho = US%RL2_T2_to_Pa * G_e * rho_0 + rho_ref_mks = rho_ref * US%R_to_kg_m3 + I_Rho = 1.0 / rho_0 + + do_massWeight = .false. + if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then + do_massWeight = .true. + if (.not.present(bathyT)) call MOM_error(FATAL, "int_density_dz_generic: "//& + "bathyT must be present if useMassWghtInterp is present and true.") + if (.not.present(dz_neglect)) call MOM_error(FATAL, "int_density_dz_generic: "//& + "dz_neglect must be present if useMassWghtInterp is present and true.") + endif ; endif + + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + dz = z_t(i,j) - z_b(i,j) + do n=1,5 + T5(n) = T(i,j) ; S5(n) = S(i,j) + p5(n) = -GxRho*(z_t(i,j) - 0.25*real(n-1)*dz) + enddo + if (rho_scale /= 1.0) then + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) + else + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks) + endif + + ! Use Boole's rule to estimate the pressure anomaly change. + rho_anom = C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3)) + dpa(i,j) = G_e*dz*rho_anom + ! Use a Boole's-rule-like fifth-order accurate estimate of the double integral of + ! the pressure anomaly. + if (present(intz_dpa)) intz_dpa(i,j) = 0.5*G_e*dz**2 * & + (rho_anom - C1_90*(16.0*(r5(4)-r5(2)) + 7.0*(r5(5)-r5(1))) ) + enddo ; enddo + + if (present(intx_dpa)) then ; do j=js,je ; do I=Isq,Ieq + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., -bathyT(i,j)-z_t(i+1,j), -bathyT(i+1,j)-z_t(i,j)) + if (hWght > 0.) then + hL = (z_t(i,j) - z_b(i,j)) + dz_neglect + hR = (z_t(i+1,j) - z_b(i+1,j)) + dz_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + + intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j) + do m=2,4 + ! T, S, and z are interpolated in the horizontal. The z interpolation + ! is linear, but for T and S it may be thickness weighted. + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + dz = wt_L*(z_t(i,j) - z_b(i,j)) + wt_R*(z_t(i+1,j) - z_b(i+1,j)) + T5(1) = wtT_L*T(i,j) + wtT_R*T(i+1,j) + S5(1) = wtT_L*S(i,j) + wtT_R*S(i+1,j) + p5(1) = -GxRho*(wt_L*z_t(i,j) + wt_R*z_t(i+1,j)) + do n=2,5 + T5(n) = T5(1) ; S5(n) = S5(1) ; p5(n) = p5(n-1) + GxRho*0.25*dz + enddo + if (rho_scale /= 1.0) then + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) + else + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks) + endif + + ! Use Boole's rule to estimate the pressure anomaly change. + intz(m) = G_e*dz*( C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3))) + enddo + ! Use Boole's rule to integrate the bottom pressure anomaly values in x. + intx_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & + 12.0*intz(3)) + enddo ; enddo ; endif + + if (present(inty_dpa)) then ; do J=Jsq,Jeq ; do i=is,ie + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., -bathyT(i,j)-z_t(i,j+1), -bathyT(i,j+1)-z_t(i,j)) + if (hWght > 0.) then + hL = (z_t(i,j) - z_b(i,j)) + dz_neglect + hR = (z_t(i,j+1) - z_b(i,j+1)) + dz_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + + intz(1) = dpa(i,j) ; intz(5) = dpa(i,j+1) + do m=2,4 + ! T, S, and z are interpolated in the horizontal. The z interpolation + ! is linear, but for T and S it may be thickness weighted. + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + dz = wt_L*(z_t(i,j) - z_b(i,j)) + wt_R*(z_t(i,j+1) - z_b(i,j+1)) + T5(1) = wtT_L*T(i,j) + wtT_R*T(i,j+1) + S5(1) = wtT_L*S(i,j) + wtT_R*S(i,j+1) + p5(1) = -GxRho*(wt_L*z_t(i,j) + wt_R*z_t(i,j+1)) + do n=2,5 + T5(n) = T5(1) ; S5(n) = S5(1) + p5(n) = p5(n-1) + GxRho*0.25*dz + enddo + if (rho_scale /= 1.0) then + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) + else + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks) + endif + + ! Use Boole's rule to estimate the pressure anomaly change. + intz(m) = G_e*dz*( C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3))) + enddo + ! Use Boole's rule to integrate the values. + inty_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & + 12.0*intz(3)) + enddo ; enddo ; endif +end subroutine int_density_dz_generic_pcm + + +!> Compute pressure gradient force integrals by quadrature for the case where +!! T and S are linear profiles. +subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & + rho_0, G_e, dz_subroundoff, bathyT, HI, GV, EOS, US, dpa, & + intz_dpa, intx_dpa, inty_dpa, useMassWghtInterp) + integer, intent(in) :: k !< Layer index to calculate integrals for + type(hor_index_type), intent(in) :: HI !< Ocean horizontal index structures for the input arrays + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables + real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)), & + intent(in) :: T_t !< Potential temperature at the cell top [degC] + real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)), & + intent(in) :: T_b !< Potential temperature at the cell bottom [degC] + real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)), & + intent(in) :: S_t !< Salinity at the cell top [ppt] + real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)), & + intent(in) :: S_b !< Salinity at the cell bottom [ppt] + real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)+1), & + intent(in) :: e !< Height of interfaces [Z ~> m] + real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3] or [kg m-3], that is subtracted + !! out to reduce the magnitude of each of the integrals. + real, intent(in) :: rho_0 !< A density [R ~> kg m-3] or [kg m-3], that is used to calculate + !! the pressure (as p~=-z*rho_0*G_e) used in the equation of state. + real, intent(in) :: G_e !< The Earth's gravitational acceleration [L2 Z-1 T-2 ~> m s-2] + real, intent(in) :: dz_subroundoff !< A minuscule thickness change [Z ~> m] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m] + type(EOS_type), pointer :: EOS !< Equation of state structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(inout) :: dpa !< The change in the pressure anomaly across the layer [R L2 T-2 ~> Pa] + real, dimension(SZI_(HI),SZJ_(HI)), & + optional, intent(inout) :: intz_dpa !< The integral through the thickness of the layer of + !! the pressure anomaly relative to the anomaly at the + !! top of the layer [R L2 Z T-2 ~> Pa Z] + real, dimension(SZIB_(HI),SZJ_(HI)), & + optional, intent(inout) :: intx_dpa !< The integral in x of the difference between the + !! pressure anomaly at the top and bottom of the layer + !! divided by the x grid spacing [R L2 T-2 ~> Pa] + real, dimension(SZI_(HI),SZJB_(HI)), & + optional, intent(inout) :: inty_dpa !< The integral in y of the difference between the + !! pressure anomaly at the top and bottom of the layer + !! divided by the y grid spacing [R L2 T-2 ~> Pa] + logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to + !! interpolate T/S for top and bottom integrals. + +! This subroutine calculates (by numerical quadrature) integrals of +! pressure anomalies across layers, which are required for calculating the +! finite-volume form pressure accelerations in a Boussinesq model. The one +! potentially dodgy assumption here is that rho_0 is used both in the denominator +! of the accelerations, and in the pressure used to calculated density (the +! latter being -z*rho_0*G_e). These two uses could be separated if need be. +! +! It is assumed that the salinity and temperature profiles are linear in the +! vertical. The top and bottom values within each layer are provided and +! a linear interpolation is used to compute intermediate values. + + ! Local variables + real :: T5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Temperatures along a line of subgrid locations [degC] + real :: S5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Salinities along a line of subgrid locations [ppt] + real :: T25((5*HI%iscB+1):(5*(HI%iecB+2))) ! SGS temperature variance along a line of subgrid locations [degC2] + real :: TS5((5*HI%iscB+1):(5*(HI%iecB+2))) ! SGS temp-salt covariance along a line of subgrid locations [degC ppt] + real :: S25((5*HI%iscB+1):(5*(HI%iecB+2))) ! SGS salinity variance along a line of subgrid locations [ppt2] + real :: p5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Pressures along a line of subgrid locations, never + ! rescaled from Pa [Pa] + real :: r5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Densities anomalies along a line of subgrid + ! locations [R ~> kg m-3] or [kg m-3] + real :: T15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Temperatures at an array of subgrid locations [degC] + real :: S15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Salinities at an array of subgrid locations [ppt] + real :: T215((15*HI%iscB+1):(15*(HI%iecB+1))) ! SGS temperature variance along a line of subgrid locations [degC2] + real :: TS15((15*HI%iscB+1):(15*(HI%iecB+1))) ! SGS temp-salt covariance along a line of subgrid locations [degC ppt] + real :: S215((15*HI%iscB+1):(15*(HI%iecB+1))) ! SGS salinity variance along a line of subgrid locations [ppt2] + real :: p15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Pressures at an array of subgrid locations [Pa] + real :: r15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Densities at an array of subgrid locations + ! [R ~> kg m-3] or [kg m-3] + real :: wt_t(5), wt_b(5) ! Top and bottom weights [nondim] + real :: rho_anom ! A density anomaly [R ~> kg m-3] or [kg m-3] + real :: w_left, w_right ! Left and right weights [nondim] + real :: intz(5) ! The gravitational acceleration times the integrals of density + ! with height at the 5 sub-column locations [R L2 T-2 ~> Pa] or [Pa] + real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim] + real :: GxRho ! The gravitational acceleration times density and unit conversion factors [Pa Z-1 ~> kg m-2 s-2] + real :: I_Rho ! The inverse of the Boussinesq density [R-1 ~> m3 kg-1] or [m3 kg-1] + real :: rho_scale ! A scaling factor for densities from kg m-3 to R [R m3 kg-1 ~> 1] + real :: rho_ref_mks ! The reference density in MKS units, never rescaled from kg m-3 [kg m-3] + real :: dz(HI%iscB:HI%iecB+1) ! Layer thicknesses at tracer points [Z ~> m] + real :: dz_x(5,HI%iscB:HI%iecB) ! Layer thicknesses along an x-line of subrid locations [Z ~> m] + real :: dz_y(5,HI%isc:HI%iec) ! Layer thicknesses along a y-line of subrid locations [Z ~> m] + real :: massWeightToggle ! A non-dimensional toggle factor (0 or 1) [nondim] + real :: Ttl, Tbl, Ttr, Tbr ! Temperatures at the velocity cell corners [degC] + real :: Stl, Sbl, Str, Sbr ! Salinities at the velocity cell corners [ppt] + real :: hWght ! A topographically limited thicknes weight [Z ~> m] + real :: hL, hR ! Thicknesses to the left and right [Z ~> m] + real :: iDenom ! The denominator of the thickness weight expressions [Z-2 ~> m-2] + logical :: use_stanley_eos ! True is SGS variance fields exist in tv. + logical :: use_varT, use_varS, use_covarTS + integer :: Isq, Ieq, Jsq, Jeq, i, j, m, n + integer :: pos + + Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB + + rho_scale = US%kg_m3_to_R + GxRho = US%RL2_T2_to_Pa * G_e * rho_0 + rho_ref_mks = rho_ref * US%R_to_kg_m3 + I_Rho = 1.0 / rho_0 + massWeightToggle = 0. + if (present(useMassWghtInterp)) then + if (useMassWghtInterp) massWeightToggle = 1. + endif + + use_varT = associated(tv%varT) + use_covarTS = associated(tv%covarTS) + use_varS = associated(tv%varS) + use_stanley_eos = use_varT .or. use_covarTS .or. use_varS + T25(:) = 0. + TS5(:) = 0. + S25(:) = 0. + T215(:) = 0. + TS15(:) = 0. + S215(:) = 0. + + do n = 1, 5 + wt_t(n) = 0.25 * real(5-n) + wt_b(n) = 1.0 - wt_t(n) + enddo + + ! 1. Compute vertical integrals + do j=Jsq,Jeq+1 + do i = Isq,Ieq+1 + dz(i) = e(i,j,K) - e(i,j,K+1) + do n=1,5 + p5(i*5+n) = -GxRho*(e(i,j,K) - 0.25*real(n-1)*dz(i)) + ! Salinity and temperature points are linearly interpolated + S5(i*5+n) = wt_t(n) * S_t(i,j,k) + wt_b(n) * S_b(i,j,k) + T5(i*5+n) = wt_t(n) * T_t(i,j,k) + wt_b(n) * T_b(i,j,k) + enddo + if (use_varT) T25(i*5+1:i*5+5) = tv%varT(i,j,k) + if (use_covarTS) TS5(i*5+1:i*5+5) = tv%covarTS(i,j,k) + if (use_varS) S25(i*5+1:i*5+5) = tv%varS(i,j,k) + enddo + if (use_Stanley_eos) then + if (rho_scale /= 1.0) then + call calculate_density(T5, S5, p5, T25, TS5, S25, r5, 1, (ieq-isq+2)*5, EOS, & + rho_ref=rho_ref_mks, scale=rho_scale) + else + call calculate_density(T5, S5, p5, T25, TS5, S25, r5, 1, (ieq-isq+2)*5, EOS, & + rho_ref=rho_ref_mks) + endif + else + if (rho_scale /= 1.0) then + call calculate_density(T5, S5, p5, r5, 1, (ieq-isq+2)*5, EOS, rho_ref=rho_ref_mks, & + scale=rho_scale) + else + call calculate_density(T5, S5, p5, r5, 1, (ieq-isq+2)*5, EOS, rho_ref=rho_ref_mks) + endif + endif + + do i=Isq,Ieq+1 + ! Use Boole's rule to estimate the pressure anomaly change. + rho_anom = C1_90*(7.0*(r5(i*5+1)+r5(i*5+5)) + 32.0*(r5(i*5+2)+r5(i*5+4)) + 12.0*r5(i*5+3)) + dpa(i,j) = G_e*dz(i)*rho_anom + if (present(intz_dpa)) then + ! Use a Boole's-rule-like fifth-order accurate estimate of + ! the double integral of the pressure anomaly. + intz_dpa(i,j) = 0.5*G_e*dz(i)**2 * & + (rho_anom - C1_90*(16.0*(r5(i*5+4)-r5(i*5+2)) + 7.0*(r5(i*5+5)-r5(i*5+1))) ) + endif + enddo + enddo ! end loops on j + + ! 2. Compute horizontal integrals in the x direction + if (present(intx_dpa)) then ; do j=HI%jsc,HI%jec + do I=Isq,Ieq + ! Corner values of T and S + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation + ! of T,S along the top and bottom integrals, almost like thickness + ! weighting. + ! Note: To work in terrain following coordinates we could offset + ! this distance by the layer thickness to replicate other models. + hWght = massWeightToggle * & + max(0., -bathyT(i,j)-e(i+1,j,K), -bathyT(i+1,j)-e(i,j,K)) + if (hWght > 0.) then + hL = (e(i,j,K) - e(i,j,K+1)) + dz_subroundoff + hR = (e(i+1,j,K) - e(i+1,j,K+1)) + dz_subroundoff + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1./( hWght*(hR + hL) + hL*hR ) + Ttl = ( (hWght*hR)*T_t(i+1,j,k) + (hWght*hL + hR*hL)*T_t(i,j,k) ) * iDenom + Ttr = ( (hWght*hL)*T_t(i,j,k) + (hWght*hR + hR*hL)*T_t(i+1,j,k) ) * iDenom + Tbl = ( (hWght*hR)*T_b(i+1,j,k) + (hWght*hL + hR*hL)*T_b(i,j,k) ) * iDenom + Tbr = ( (hWght*hL)*T_b(i,j,k) + (hWght*hR + hR*hL)*T_b(i+1,j,k) ) * iDenom + Stl = ( (hWght*hR)*S_t(i+1,j,k) + (hWght*hL + hR*hL)*S_t(i,j,k) ) * iDenom + Str = ( (hWght*hL)*S_t(i,j,k) + (hWght*hR + hR*hL)*S_t(i+1,j,k) ) * iDenom + Sbl = ( (hWght*hR)*S_b(i+1,j,k) + (hWght*hL + hR*hL)*S_b(i,j,k) ) * iDenom + Sbr = ( (hWght*hL)*S_b(i,j,k) + (hWght*hR + hR*hL)*S_b(i+1,j,k) ) * iDenom + else + Ttl = T_t(i,j,k); Tbl = T_b(i,j,k); Ttr = T_t(i+1,j,k); Tbr = T_b(i+1,j,k) + Stl = S_t(i,j,k); Sbl = S_b(i,j,k); Str = S_t(i+1,j,k); Sbr = S_b(i+1,j,k) + endif + + do m=2,4 + w_left = wt_t(m) ; w_right = wt_b(m) + dz_x(m,i) = w_left*(e(i,j,K) - e(i,j,K+1)) + w_right*(e(i+1,j,K) - e(i+1,j,K+1)) + + ! Salinity and temperature points are linearly interpolated in + ! the horizontal. The subscript (1) refers to the top value in + ! the vertical profile while subscript (5) refers to the bottom + ! value in the vertical profile. + pos = i*15+(m-2)*5 + T15(pos+1) = w_left*Ttl + w_right*Ttr + T15(pos+5) = w_left*Tbl + w_right*Tbr + + S15(pos+1) = w_left*Stl + w_right*Str + S15(pos+5) = w_left*Sbl + w_right*Sbr + + p15(pos+1) = -GxRho*(w_left*e(i,j,K) + w_right*e(i+1,j,K)) + + ! Pressure + do n=2,5 + p15(pos+n) = p15(pos+n-1) + GxRho*0.25*dz_x(m,i) + enddo + + ! Salinity and temperature (linear interpolation in the vertical) + do n=2,4 + S15(pos+n) = wt_t(n) * S15(pos+1) + wt_b(n) * S15(pos+5) + T15(pos+n) = wt_t(n) * T15(pos+1) + wt_b(n) * T15(pos+5) + enddo + if (use_varT) T215(pos+1:pos+5) = w_left*tv%varT(i,j,k) + w_right*tv%varT(i+1,j,k) + if (use_covarTS) TS15(pos+1:pos+5) = w_left*tv%covarTS(i,j,k) + w_right*tv%covarTS(i+1,j,k) + if (use_varS) S215(pos+1:pos+5) = w_left*tv%varS(i,j,k) + w_right*tv%varS(i+1,j,k) + enddo + enddo + + if (use_stanley_eos) then + if (rho_scale /= 1.0) then + call calculate_density(T15, S15, p15, T215, TS15, S215, r15, 1, 15*(ieq-isq+1), EOS, & + rho_ref=rho_ref_mks, scale=rho_scale) + else + call calculate_density(T15, S15, p15, T215, TS15, S215, r15, 1, 15*(ieq-isq+1), EOS, & + rho_ref=rho_ref_mks) + endif + else + if (rho_scale /= 1.0) then + call calculate_density(T15, S15, p15, r15, 1, 15*(ieq-isq+1), EOS, rho_ref=rho_ref_mks, & + scale=rho_scale) + else + call calculate_density(T15, S15, p15, r15, 1, 15*(ieq-isq+1), EOS, rho_ref=rho_ref_mks) + endif + endif + + do I=Isq,Ieq + intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j) + + ! Use Boole's rule to estimate the pressure anomaly change. + do m = 2,4 + pos = i*15+(m-2)*5 + intz(m) = G_e*dz_x(m,i)*( C1_90*(7.0*(r15(pos+1)+r15(pos+5)) + 32.0*(r15(pos+2)+r15(pos+4)) + & + 12.0*r15(pos+3))) + enddo + ! Use Boole's rule to integrate the bottom pressure anomaly values in x. + intx_dpa(I,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & + 12.0*intz(3)) + enddo + enddo ; endif + + ! 3. Compute horizontal integrals in the y direction + if (present(inty_dpa)) then ; do J=Jsq,Jeq + do i=HI%isc,HI%iec + ! Corner values of T and S + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation + ! of T,S along the top and bottom integrals, almost like thickness + ! weighting. + ! Note: To work in terrain following coordinates we could offset + ! this distance by the layer thickness to replicate other models. + hWght = massWeightToggle * & + max(0., -bathyT(i,j)-e(i,j+1,K), -bathyT(i,j+1)-e(i,j,K)) + if (hWght > 0.) then + hL = (e(i,j,K) - e(i,j,K+1)) + dz_subroundoff + hR = (e(i,j+1,K) - e(i,j+1,K+1)) + dz_subroundoff + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1./( hWght*(hR + hL) + hL*hR ) + Ttl = ( (hWght*hR)*T_t(i,j+1,k) + (hWght*hL + hR*hL)*T_t(i,j,k) ) * iDenom + Ttr = ( (hWght*hL)*T_t(i,j,k) + (hWght*hR + hR*hL)*T_t(i,j+1,k) ) * iDenom + Tbl = ( (hWght*hR)*T_b(i,j+1,k) + (hWght*hL + hR*hL)*T_b(i,j,k) ) * iDenom + Tbr = ( (hWght*hL)*T_b(i,j,k) + (hWght*hR + hR*hL)*T_b(i,j+1,k) ) * iDenom + Stl = ( (hWght*hR)*S_t(i,j+1,k) + (hWght*hL + hR*hL)*S_t(i,j,k) ) * iDenom + Str = ( (hWght*hL)*S_t(i,j,k) + (hWght*hR + hR*hL)*S_t(i,j+1,k) ) * iDenom + Sbl = ( (hWght*hR)*S_b(i,j+1,k) + (hWght*hL + hR*hL)*S_b(i,j,k) ) * iDenom + Sbr = ( (hWght*hL)*S_b(i,j,k) + (hWght*hR + hR*hL)*S_b(i,j+1,k) ) * iDenom + else + Ttl = T_t(i,j,k); Tbl = T_b(i,j,k); Ttr = T_t(i,j+1,k); Tbr = T_b(i,j+1,k) + Stl = S_t(i,j,k); Sbl = S_b(i,j,k); Str = S_t(i,j+1,k); Sbr = S_b(i,j+1,k) + endif + + do m=2,4 + w_left = wt_t(m) ; w_right = wt_b(m) + dz_y(m,i) = w_left*(e(i,j,K) - e(i,j,K+1)) + w_right*(e(i,j+1,K) - e(i,j+1,K+1)) + + ! Salinity and temperature points are linearly interpolated in + ! the horizontal. The subscript (1) refers to the top value in + ! the vertical profile while subscript (5) refers to the bottom + ! value in the vertical profile. + pos = i*15+(m-2)*5 + T15(pos+1) = w_left*Ttl + w_right*Ttr + T15(pos+5) = w_left*Tbl + w_right*Tbr + + S15(pos+1) = w_left*Stl + w_right*Str + S15(pos+5) = w_left*Sbl + w_right*Sbr + + p15(pos+1) = -GxRho*(w_left*e(i,j,K) + w_right*e(i,j+1,K)) + + ! Pressure + do n=2,5 + p15(pos+n) = p15(pos+n-1) + GxRho*0.25*dz_y(m,i) + enddo + + ! Salinity and temperature (linear interpolation in the vertical) + do n=2,4 + S15(pos+n) = wt_t(n) * S15(pos+1) + wt_b(n) * S15(pos+5) + T15(pos+n) = wt_t(n) * T15(pos+1) + wt_b(n) * T15(pos+5) + enddo + if (use_varT) T215(pos+1:pos+5) = w_left*tv%varT(i,j,k) + w_right*tv%varT(i,j+1,k) + if (use_covarTS) TS15(pos+1:pos+5) = w_left*tv%covarTS(i,j,k) + w_right*tv%covarTS(i,j+1,k) + if (use_varS) S215(pos+1:pos+5) = w_left*tv%varS(i,j,k) + w_right*tv%varS(i,j+1,k) + enddo + enddo + + if (use_stanley_eos) then + if (rho_scale /= 1.0) then + call calculate_density(T15(15*HI%isc+1:), S15(15*HI%isc+1:), p15(15*HI%isc+1:), & + T215(15*HI%isc+1:), TS15(15*HI%isc+1:), S215(15*HI%isc+1:), & + r15(15*HI%isc+1:), 1, 15*(HI%iec-HI%isc+1), EOS, & + rho_ref=rho_ref_mks, scale=rho_scale) + else + call calculate_density(T15(15*HI%isc+1:), S15(15*HI%isc+1:), p15(15*HI%isc+1:), & + T215(15*HI%isc+1:), TS15(15*HI%isc+1:), S215(15*HI%isc+1:), & + r15(15*HI%isc+1:), 1, 15*(HI%iec-HI%isc+1), EOS, rho_ref=rho_ref_mks) + endif + else + if (rho_scale /= 1.0) then + call calculate_density(T15(15*HI%isc+1:), S15(15*HI%isc+1:), p15(15*HI%isc+1:), & + r15(15*HI%isc+1:), 1, 15*(HI%iec-HI%isc+1), EOS, & + rho_ref=rho_ref_mks, scale=rho_scale) + else + call calculate_density(T15(15*HI%isc+1:), S15(15*HI%isc+1:), p15(15*HI%isc+1:), & + r15(15*HI%isc+1:), 1, 15*(HI%iec-HI%isc+1), EOS, rho_ref=rho_ref_mks) + endif + endif + + do i=HI%isc,HI%iec + intz(1) = dpa(i,j) ; intz(5) = dpa(i,j+1) + + ! Use Boole's rule to estimate the pressure anomaly change. + do m = 2,4 + pos = i*15+(m-2)*5 + intz(m) = G_e*dz_y(m,i)*( C1_90*(7.0*(r15(pos+1)+r15(pos+5)) + & + 32.0*(r15(pos+2)+r15(pos+4)) + & + 12.0*r15(pos+3))) + enddo + ! Use Boole's rule to integrate the values. + inty_dpa(i,J) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & + 12.0*intz(3)) + enddo + enddo ; endif + +end subroutine int_density_dz_generic_plm + + +!> Compute pressure gradient force integrals for layer "k" and the case where T and S +!! are parabolic profiles +subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & + rho_ref, rho_0, G_e, dz_subroundoff, bathyT, HI, GV, EOS, US, & + dpa, intz_dpa, intx_dpa, inty_dpa, useMassWghtInterp) + integer, intent(in) :: k !< Layer index to calculate integrals for + type(hor_index_type), intent(in) :: HI !< Ocean horizontal index structures for the input arrays + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables + real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)), & + intent(in) :: T_t !< Potential temperature at the cell top [degC] + real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)), & + intent(in) :: T_b !< Potential temperature at the cell bottom [degC] + real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)), & + intent(in) :: S_t !< Salinity at the cell top [ppt] + real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)), & + intent(in) :: S_b !< Salinity at the cell bottom [ppt] + real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)+1), & + intent(in) :: e !< Height of interfaces [Z ~> m] + real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3] or [kg m-3], that is + !! subtracted out to reduce the magnitude of each of the integrals. + real, intent(in) :: rho_0 !< A density [R ~> kg m-3] or [kg m-3], that is used to calculate + !! the pressure (as p~=-z*rho_0*G_e) used in the equation of state. + real, intent(in) :: G_e !< The Earth's gravitational acceleration [m s-2] + real, intent(in) :: dz_subroundoff !< A minuscule thickness change [Z ~> m] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m] + type(EOS_type), pointer :: EOS !< Equation of state structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(inout) :: dpa !< The change in the pressure anomaly across the layer [R L2 T-2 ~> Pa] + real, dimension(SZI_(HI),SZJ_(HI)), & + optional, intent(inout) :: intz_dpa !< The integral through the thickness of the layer of + !! the pressure anomaly relative to the anomaly at the + !! top of the layer [R L2 Z T-2 ~> Pa m] + real, dimension(SZIB_(HI),SZJ_(HI)), & + optional, intent(inout) :: intx_dpa !< The integral in x of the difference between the + !! pressure anomaly at the top and bottom of the layer + !! divided by the x grid spacing [R L2 T-2 ~> Pa] + real, dimension(SZI_(HI),SZJB_(HI)), & + optional, intent(inout) :: inty_dpa !< The integral in y of the difference between the + !! pressure anomaly at the top and bottom of the layer + !! divided by the y grid spacing [R L2 T-2 ~> Pa] + logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to + !! interpolate T/S for top and bottom integrals. + +! This subroutine calculates (by numerical quadrature) integrals of +! pressure anomalies across layers, which are required for calculating the +! finite-volume form pressure accelerations in a Boussinesq model. The one +! potentially dodgy assumption here is that rho_0 is used both in the denominator +! of the accelerations, and in the pressure used to calculated density (the +! latter being -z*rho_0*G_e). These two uses could be separated if need be. +! +! It is assumed that the salinity and temperature profiles are parabolic in the +! vertical. The top and bottom values within each layer are provided and +! a parabolic interpolation is used to compute intermediate values. + + ! Local variables + real :: T5(5) ! Temperatures along a line of subgrid locations [degC] + real :: S5(5) ! Salinities along a line of subgrid locations [ppt] + real :: T25(5) ! SGS temperature variance along a line of subgrid locations [degC2] + real :: TS5(5) ! SGS temperature-salinity covariance along a line of subgrid locations [degC ppt] + real :: S25(5) ! SGS salinity variance along a line of subgrid locations [ppt2] + real :: p5(5) ! Pressures at five quadrature points, never rescaled from Pa [Pa] + real :: r5(5) ! Density anomalies from rho_ref at quadrature points [R ~> kg m-3] or [kg m-3] + real :: wt_t(5), wt_b(5) ! Top and bottom weights [nondim] + real :: rho_anom ! The integrated density anomaly [R ~> kg m-3] or [kg m-3] + real :: w_left, w_right ! Left and right weights [nondim] + real :: intz(5) ! The gravitational acceleration times the integrals of density + ! with height at the 5 sub-column locations [R L2 T-2 ~> Pa] or [Pa] + real, parameter :: C1_90 = 1.0/90.0 ! Rational constants. + real :: GxRho ! The gravitational acceleration times density and unit conversion factors [Pa Z-1 ~> kg m-2 s-2] + real :: I_Rho ! The inverse of the Boussinesq density [R-1 ~> m3 kg-1] or [m3 kg-1] + real :: rho_scale ! A scaling factor for densities from kg m-3 to R [R m3 kg-1 ~> 1] + real :: rho_ref_mks ! The reference density in MKS units, never rescaled from kg m-3 [kg m-3] + real :: dz ! Layer thicknesses at tracer points [Z ~> m] + real :: massWeightToggle ! A non-dimensional toggle factor (0 or 1) [nondim] + real :: Ttl, Tbl, Tml, Ttr, Tbr, Tmr ! Temperatures at the velocity cell corners [degC] + real :: Stl, Sbl, Sml, Str, Sbr, Smr ! Salinities at the velocity cell corners [ppt] + real :: s6 ! PPM curvature coefficient for S [ppt] + real :: t6 ! PPM curvature coefficient for T [degC] + real :: T_top, T_mn, T_bot ! Left edge, cell mean and right edge values used in PPM reconstructions of T + real :: S_top, S_mn, S_bot ! Left edge, cell mean and right edge values used in PPM reconstructions of S + real :: hWght ! A topographically limited thicknes weight [Z ~> m] + real :: hL, hR ! Thicknesses to the left and right [Z ~> m] + real :: iDenom ! The denominator of the thickness weight expressions [Z-2 ~> m-2] + integer :: Isq, Ieq, Jsq, Jeq, i, j, m, n + logical :: use_PPM ! If false, assume zero curvature in reconstruction, i.e. PLM + logical :: use_stanley_eos ! True is SGS variance fields exist in tv. + logical :: use_varT, use_varS, use_covarTS + + Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB + + rho_scale = US%kg_m3_to_R + GxRho = US%RL2_T2_to_Pa * G_e * rho_0 + rho_ref_mks = rho_ref * US%R_to_kg_m3 + I_Rho = 1.0 / rho_0 + massWeightToggle = 0. + if (present(useMassWghtInterp)) then + if (useMassWghtInterp) massWeightToggle = 1. + endif + + ! In event PPM calculation is bypassed with use_PPM=False + s6 = 0. + t6 = 0. + use_PPM = .true. ! This is a place-holder to allow later re-use of this function + + use_varT = associated(tv%varT) + use_covarTS = associated(tv%covarTS) + use_varS = associated(tv%varS) + use_stanley_eos = use_varT .or. use_covarTS .or. use_varS + T25(:) = 0. + TS5(:) = 0. + S25(:) = 0. + + do n = 1, 5 + wt_t(n) = 0.25 * real(5-n) + wt_b(n) = 1.0 - wt_t(n) + enddo + + ! 1. Compute vertical integrals + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + if (use_PPM) then + ! Curvature coefficient of the parabolas + s6 = 3.0 * ( 2.0*tv%S(i,j,k) - ( S_t(i,j,k) + S_b(i,j,k) ) ) + t6 = 3.0 * ( 2.0*tv%T(i,j,k) - ( T_t(i,j,k) + T_b(i,j,k) ) ) + endif + dz = e(i,j,K) - e(i,j,K+1) + do n=1,5 + p5(n) = -GxRho*(e(i,j,K) - 0.25*real(n-1)*dz) + ! Salinity and temperature points are reconstructed with PPM + S5(n) = wt_t(n) * S_t(i,j,k) + wt_b(n) * ( S_b(i,j,k) + s6 * wt_t(n) ) + T5(n) = wt_t(n) * T_t(i,j,k) + wt_b(n) * ( T_b(i,j,k) + t6 * wt_t(n) ) + enddo + if (use_stanley_eos) then + if (use_varT) T25(:) = tv%varT(i,j,k) + if (use_covarTS) TS5(:) = tv%covarTS(i,j,k) + if (use_varS) S25(:) = tv%varS(i,j,k) + call calculate_density(T5, S5, p5, T25, TS5, S25, r5, & + 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) + else + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) + endif + + ! Use Boole's rule to estimate the pressure anomaly change. + rho_anom = C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3)) + dpa(i,j) = G_e*dz*rho_anom + if (present(intz_dpa)) then + ! Use a Boole's-rule-like fifth-order accurate estimate of + ! the double integral of the pressure anomaly. + intz_dpa(i,j) = 0.5*G_e*dz**2 * & + (rho_anom - C1_90*(16.0*(r5(4)-r5(2)) + 7.0*(r5(5)-r5(1))) ) + endif + enddo ; enddo ! end loops on j and i + + ! 2. Compute horizontal integrals in the x direction + if (present(intx_dpa)) then ; do j=HI%jsc,HI%jec ; do I=Isq,Ieq + ! Corner values of T and S + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation + ! of T,S along the top and bottom integrals, almost like thickness + ! weighting. + ! Note: To work in terrain following coordinates we could offset + ! this distance by the layer thickness to replicate other models. + hWght = massWeightToggle * & + max(0., -bathyT(i,j)-e(i+1,j,K), -bathyT(i+1,j)-e(i,j,K)) + if (hWght > 0.) then + hL = (e(i,j,K) - e(i,j,K+1)) + dz_subroundoff + hR = (e(i+1,j,K) - e(i+1,j,K+1)) + dz_subroundoff + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1./( hWght*(hR + hL) + hL*hR ) + Ttl = ( (hWght*hR)*T_t(i+1,j,k) + (hWght*hL + hR*hL)*T_t(i,j,k) ) * iDenom + Tbl = ( (hWght*hR)*T_b(i+1,j,k) + (hWght*hL + hR*hL)*T_b(i,j,k) ) * iDenom + Tml = ( (hWght*hR)*tv%T(i+1,j,k)+ (hWght*hL + hR*hL)*tv%T(i,j,k) ) * iDenom + Ttr = ( (hWght*hL)*T_t(i,j,k) + (hWght*hR + hR*hL)*T_t(i+1,j,k) ) * iDenom + Tbr = ( (hWght*hL)*T_b(i,j,k) + (hWght*hR + hR*hL)*T_b(i+1,j,k) ) * iDenom + Tmr = ( (hWght*hL)*tv%T(i,j,k) + (hWght*hR + hR*hL)*tv%T(i+1,j,k) ) * iDenom + Stl = ( (hWght*hR)*S_t(i+1,j,k) + (hWght*hL + hR*hL)*S_t(i,j,k) ) * iDenom + Sbl = ( (hWght*hR)*S_b(i+1,j,k) + (hWght*hL + hR*hL)*S_b(i,j,k) ) * iDenom + Sml = ( (hWght*hR)*tv%S(i+1,j,k) + (hWght*hL + hR*hL)*tv%S(i,j,k) ) * iDenom + Str = ( (hWght*hL)*S_t(i,j,k) + (hWght*hR + hR*hL)*S_t(i+1,j,k) ) * iDenom + Sbr = ( (hWght*hL)*S_b(i,j,k) + (hWght*hR + hR*hL)*S_b(i+1,j,k) ) * iDenom + Smr = ( (hWght*hL)*tv%S(i,j,k) + (hWght*hR + hR*hL)*tv%S(i+1,j,k) ) * iDenom + else + Ttl = T_t(i,j,k); Tbl = T_b(i,j,k); Ttr = T_t(i+1,j,k); Tbr = T_b(i+1,j,k) + Tml = tv%T(i,j,k); Tmr = tv%T(i+1,j,k) + Stl = S_t(i,j,k); Sbl = S_b(i,j,k); Str = S_t(i+1,j,k); Sbr = S_b(i+1,j,k) + Sml = tv%S(i,j,k); Smr = tv%S(i+1,j,k) + endif + + do m=2,4 + w_left = wt_t(m) ; w_right = wt_b(m) + + ! Salinity and temperature points are linearly interpolated in + ! the horizontal. The subscript (1) refers to the top value in + ! the vertical profile while subscript (5) refers to the bottom + ! value in the vertical profile. + T_top = w_left*Ttl + w_right*Ttr + T_mn = w_left*Tml + w_right*Tmr + T_bot = w_left*Tbl + w_right*Tbr + + S_top = w_left*Stl + w_right*Str + S_mn = w_left*Sml + w_right*Smr + S_bot = w_left*Sbl + w_right*Sbr + + ! Pressure + dz = w_left*(e(i,j,K) - e(i,j,K+1)) + w_right*(e(i+1,j,K) - e(i+1,j,K+1)) + p5(1) = -GxRho*(w_left*e(i,j,K) + w_right*e(i+1,j,K)) + do n=2,5 + p5(n) = p5(n-1) + GxRho*0.25*dz + enddo + + ! Parabolic reconstructions in the vertical for T and S + if (use_PPM) then + ! Coefficients of the parabolas + s6 = 3.0 * ( 2.0*S_mn - ( S_top + S_bot ) ) + t6 = 3.0 * ( 2.0*T_mn - ( T_top + T_bot ) ) + endif + do n=1,5 + S5(n) = wt_t(n) * S_top + wt_b(n) * ( S_bot + s6 * wt_t(n) ) + T5(n) = wt_t(n) * T_top + wt_b(n) * ( T_bot + t6 * wt_t(n) ) + enddo + + if (use_stanley_eos) then + if (use_varT) T25(:) = w_left*tv%varT(i,j,k) + w_right*tv%varT(i+1,j,k) + if (use_covarTS) TS5(:) = w_left*tv%covarTS(i,j,k) + w_right*tv%covarTS(i+1,j,k) + if (use_varS) S25(:) = w_left*tv%varS(i,j,k) + w_right*tv%varS(i+1,j,k) + call calculate_density(T5, S5, p5, T25, TS5, S25, r5, & + 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) + else + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) + endif + + ! Use Boole's rule to estimate the pressure anomaly change. + intz(m) = G_e*dz*( C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3)) ) + enddo ! m + intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j) + + ! Use Boole's rule to integrate the bottom pressure anomaly values in x. + intx_dpa(I,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + 12.0*intz(3)) + + enddo ; enddo ; endif + + ! 3. Compute horizontal integrals in the y direction + if (present(inty_dpa)) then ; do J=Jsq,Jeq ; do i=HI%isc,HI%iec + ! Corner values of T and S + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation + ! of T,S along the top and bottom integrals, almost like thickness + ! weighting. + ! Note: To work in terrain following coordinates we could offset + ! this distance by the layer thickness to replicate other models. + hWght = massWeightToggle * & + max(0., -bathyT(i,j)-e(i,j+1,K), -bathyT(i,j+1)-e(i,j,K)) + if (hWght > 0.) then + hL = (e(i,j,K) - e(i,j,K+1)) + dz_subroundoff + hR = (e(i,j+1,K) - e(i,j+1,K+1)) + dz_subroundoff + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1./( hWght*(hR + hL) + hL*hR ) + Ttl = ( (hWght*hR)*T_t(i,j+1,k) + (hWght*hL + hR*hL)*T_t(i,j,k) ) * iDenom + Tbl = ( (hWght*hR)*T_b(i,j+1,k) + (hWght*hL + hR*hL)*T_b(i,j,k) ) * iDenom + Tml = ( (hWght*hR)*tv%T(i,j+1,k)+ (hWght*hL + hR*hL)*tv%T(i,j,k) ) * iDenom + Ttr = ( (hWght*hL)*T_t(i,j,k) + (hWght*hR + hR*hL)*T_t(i,j+1,k) ) * iDenom + Tbr = ( (hWght*hL)*T_b(i,j,k) + (hWght*hR + hR*hL)*T_b(i,j+1,k) ) * iDenom + Tmr = ( (hWght*hL)*tv%T(i,j,k) + (hWght*hR + hR*hL)*tv%T(i,j+1,k) ) * iDenom + Stl = ( (hWght*hR)*S_t(i,j+1,k) + (hWght*hL + hR*hL)*S_t(i,j,k) ) * iDenom + Sbl = ( (hWght*hR)*S_b(i,j+1,k) + (hWght*hL + hR*hL)*S_b(i,j,k) ) * iDenom + Sml = ( (hWght*hR)*tv%S(i,j+1,k)+ (hWght*hL + hR*hL)*tv%S(i,j,k) ) * iDenom + Str = ( (hWght*hL)*S_t(i,j,k) + (hWght*hR + hR*hL)*S_t(i,j+1,k) ) * iDenom + Sbr = ( (hWght*hL)*S_b(i,j,k) + (hWght*hR + hR*hL)*S_b(i,j+1,k) ) * iDenom + Smr = ( (hWght*hL)*tv%S(i,j,k) + (hWght*hR + hR*hL)*tv%S(i,j+1,k) ) * iDenom + else + Ttl = T_t(i,j,k); Tbl = T_b(i,j,k); Ttr = T_t(i,j+1,k); Tbr = T_b(i,j+1,k) + Tml = tv%T(i,j,k); Tmr = tv%T(i,j+1,k) + Stl = S_t(i,j,k); Sbl = S_b(i,j,k); Str = S_t(i,j+1,k); Sbr = S_b(i,j+1,k) + Sml = tv%S(i,j,k); Smr = tv%S(i,j+1,k) + endif + + do m=2,4 + w_left = wt_t(m) ; w_right = wt_b(m) + + ! Salinity and temperature points are linearly interpolated in + ! the horizontal. The subscript (1) refers to the top value in + ! the vertical profile while subscript (5) refers to the bottom + ! value in the vertical profile. + T_top = w_left*Ttl + w_right*Ttr + T_mn = w_left*Tml + w_right*Tmr + T_bot = w_left*Tbl + w_right*Tbr + + S_top = w_left*Stl + w_right*Str + S_mn = w_left*Sml + w_right*Smr + S_bot = w_left*Sbl + w_right*Sbr + + ! Pressure + dz = w_left*(e(i,j,K) - e(i,j,K+1)) + w_right*(e(i,j+1,K) - e(i,j+1,K+1)) + p5(1) = -GxRho*(w_left*e(i,j,K) + w_right*e(i,j+1,K)) + do n=2,5 + p5(n) = p5(n-1) + GxRho*0.25*dz + enddo + + ! Parabolic reconstructions in the vertical for T and S + if (use_PPM) then + ! Coefficients of the parabolas + s6 = 3.0 * ( 2.0*S_mn - ( S_top + S_bot ) ) + t6 = 3.0 * ( 2.0*T_mn - ( T_top + T_bot ) ) + endif + do n=1,5 + S5(n) = wt_t(n) * S_top + wt_b(n) * ( S_bot + s6 * wt_t(n) ) + T5(n) = wt_t(n) * T_top + wt_b(n) * ( T_bot + t6 * wt_t(n) ) + enddo + + if (use_stanley_eos) then + if (use_varT) T25(:) = w_left*tv%varT(i,j,k) + w_right*tv%varT(i,j+1,k) + if (use_covarTS) TS5(:) = w_left*tv%covarTS(i,j,k) + w_right*tv%covarTS(i,j+1,k) + if (use_varS) S25(:) = w_left*tv%varS(i,j,k) + w_right*tv%varS(i,j+1,k) + call calculate_density(T5, S5, p5, T25, TS5, S25, r5, & + 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) + else + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) + endif + + ! Use Boole's rule to estimate the pressure anomaly change. + intz(m) = G_e*dz*( C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3)) ) + enddo ! m + intz(1) = dpa(i,j) ; intz(5) = dpa(i,j+1) + + ! Use Boole's rule to integrate the bottom pressure anomaly values in y. + inty_dpa(i,J) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + 12.0*intz(3)) + + enddo ; enddo ; endif + +end subroutine int_density_dz_generic_ppm + +!> Calls the appropriate subroutine to calculate analytical and nearly-analytical +!! integrals in pressure across layers of geopotential anomalies, which are +!! required for calculating the finite-volume form pressure accelerations in a +!! non-Boussinesq model. There are essentially no free assumptions, apart from the +!! use of Boole's rule to do the horizontal integrals, and from a truncation in the +!! series for log(1-eps/1+eps) that assumes that |eps| < 0.34. +subroutine int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, US, & + dza, intp_dza, intx_dza, inty_dza, halo_size, & + bathyP, dP_tiny, useMassWghtInterp) + type(hor_index_type), intent(in) :: HI !< The horizontal index structure + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: T !< Potential temperature referenced to the surface [degC] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: S !< Salinity [ppt] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: p_t !< Pressure at the top of the layer [R L2 T-2 ~> Pa] or [Pa] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: p_b !< Pressure at the bottom of the layer [R L2 T-2 ~> Pa] or [Pa] + real, intent(in) :: alpha_ref !< A mean specific volume that is subtracted out + !! to reduce the magnitude of each of the integrals [R-1 ~> m3 kg-1] + !! The calculation is mathematically identical with different values of + !! alpha_ref, but this reduces the effects of roundoff. + type(EOS_type), pointer :: EOS !< Equation of state structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(inout) :: dza !< The change in the geopotential anomaly across + !! the layer [L2 T-2 ~> m2 s-2] or [m2 s-2] + real, dimension(SZI_(HI),SZJ_(HI)), & + optional, intent(inout) :: intp_dza !< The integral in pressure through the layer of the + !! geopotential anomaly relative to the anomaly at the bottom of the + !! layer [R L4 T-4 ~> Pa m2 s-2] or [Pa m2 s-2] + real, dimension(SZIB_(HI),SZJ_(HI)), & + optional, intent(inout) :: intx_dza !< The integral in x of the difference between the + !! geopotential anomaly at the top and bottom of the layer divided by + !! the x grid spacing [L2 T-2 ~> m2 s-2] or [m2 s-2] + real, dimension(SZI_(HI),SZJB_(HI)), & + optional, intent(inout) :: inty_dza !< The integral in y of the difference between the + !! geopotential anomaly at the top and bottom of the layer divided by + !! the y grid spacing [L2 T-2 ~> m2 s-2] or [m2 s-2] + integer, optional, intent(in) :: halo_size !< The width of halo points on which to calculate dza. + real, dimension(SZI_(HI),SZJ_(HI)), & + optional, intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] or [Pa] + real, optional, intent(in) :: dP_tiny !< A minuscule pressure change with + !! the same units as p_t [R L2 T-2 ~> Pa] or [Pa] + logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting + !! to interpolate T/S for top and bottom integrals. + + if (EOS_quadrature(EOS)) then + call int_spec_vol_dp_generic_pcm(T, S, p_t, p_b, alpha_ref, HI, EOS, US, & + dza, intp_dza, intx_dza, inty_dza, halo_size, & + bathyP, dP_tiny, useMassWghtInterp) + else + call analytic_int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, & + dza, intp_dza, intx_dza, inty_dza, halo_size, & + bathyP, dP_tiny, useMassWghtInterp) + endif + +end subroutine int_specific_vol_dp + + +!> This subroutine calculates integrals of specific volume anomalies in +!! pressure across layers, which are required for calculating the finite-volume +!! form pressure accelerations in a non-Boussinesq model. There are essentially +!! no free assumptions, apart from the use of Boole's rule quadrature to do the integrals. +subroutine int_spec_vol_dp_generic_pcm(T, S, p_t, p_b, alpha_ref, HI, EOS, US, dza, & + intp_dza, intx_dza, inty_dza, halo_size, & + bathyP, dP_neglect, useMassWghtInterp) + type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: T !< Potential temperature of the layer [degC] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: S !< Salinity of the layer [ppt] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: p_t !< Pressure atop the layer [R L2 T-2 ~> Pa] or [Pa] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: p_b !< Pressure below the layer [R L2 T-2 ~> Pa] or [Pa] + real, intent(in) :: alpha_ref !< A mean specific volume that is subtracted out + !! to reduce the magnitude of each of the integrals [R-1 ~> m3 kg-1] + !! The calculation is mathematically identical with different values of + !! alpha_ref, but alpha_ref alters the effects of roundoff, and + !! answers do change. + type(EOS_type), pointer :: EOS !< Equation of state structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(inout) :: dza !< The change in the geopotential anomaly + !! across the layer [L2 T-2 ~> m2 s-2] or [m2 s-2] + real, dimension(SZI_(HI),SZJ_(HI)), & + optional, intent(inout) :: intp_dza !< The integral in pressure through the layer of + !! the geopotential anomaly relative to the anomaly at the bottom of the + !! layer [R L4 T-4 ~> Pa m2 s-2] or [Pa m2 s-2] + real, dimension(SZIB_(HI),SZJ_(HI)), & + optional, intent(inout) :: intx_dza !< The integral in x of the difference between + !! the geopotential anomaly at the top and bottom of the layer divided + !! by the x grid spacing [L2 T-2 ~> m2 s-2] or [m2 s-2] + real, dimension(SZI_(HI),SZJB_(HI)), & + optional, intent(inout) :: inty_dza !< The integral in y of the difference between + !! the geopotential anomaly at the top and bottom of the layer divided + !! by the y grid spacing [L2 T-2 ~> m2 s-2] or [m2 s-2] + integer, optional, intent(in) :: halo_size !< The width of halo points on which to calculate dza. + real, dimension(SZI_(HI),SZJ_(HI)), & + optional, intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] or [Pa] + real, optional, intent(in) :: dP_neglect !< A minuscule pressure change with + !! the same units as p_t [R L2 T-2 ~> Pa] or [Pa] + logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting + !! to interpolate T/S for top and bottom integrals. + +! This subroutine calculates analytical and nearly-analytical integrals in +! pressure across layers of geopotential anomalies, which are required for +! calculating the finite-volume form pressure accelerations in a non-Boussinesq +! model. There are essentially no free assumptions, apart from the use of +! Boole's rule to do the horizontal integrals, and from a truncation in the +! series for log(1-eps/1+eps) that assumes that |eps| < 0.34. + + ! Local variables + real :: T5(5) ! Temperatures at five quadrature points [degC] + real :: S5(5) ! Salinities at five quadrature points [ppt] + real :: p5(5) ! Pressures at five quadrature points, scaled back to Pa if necessary [Pa] + real :: a5(5) ! Specific volumes at five quadrature points [R-1 ~> m3 kg-1] or [m3 kg-1] + real :: alpha_anom ! The depth averaged specific density anomaly [R-1 ~> m3 kg-1] + real :: dp ! The pressure change through a layer [R L2 T-2 ~> Pa] + real :: hWght ! A pressure-thickness below topography [R L2 T-2 ~> Pa] + real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [R L2 T-2 ~> Pa] + real :: alpha_ref_mks ! The reference specific volume in MKS units, never rescaled from m3 kg-1 [m3 kg-1] + real :: iDenom ! The inverse of the denominator in the weights [T4 R-2 L-4 ~> Pa-2] + real :: hWt_LL, hWt_LR ! hWt_LA is the weighted influence of A on the left column [nondim] + real :: hWt_RL, hWt_RR ! hWt_RA is the weighted influence of A on the right column [nondim] + real :: wt_L, wt_R ! The linear weights of the left and right columns [nondim] + real :: wtT_L, wtT_R ! The weights for tracers from the left and right columns [nondim] + real :: intp(5) ! The integrals of specific volume with pressure at the + ! 5 sub-column locations [L2 T-2 ~> m2 s-2] + real :: RL2_T2_to_Pa ! A unit conversion factor from the rescaled units of pressure to Pa [Pa T2 R-1 L-2 ~> 1] + real :: SV_scale ! A multiplicative factor by which to scale specific + ! volume from m3 kg-1 to the desired units [kg m-3 R-1 ~> 1] + logical :: do_massWeight ! Indicates whether to do mass weighting. + real, parameter :: C1_90 = 1.0/90.0 ! A rational constant. + integer :: Isq, Ieq, Jsq, Jeq, ish, ieh, jsh, jeh, i, j, m, n, halo + + Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB + halo = 0 ; if (present(halo_size)) halo = MAX(halo_size,0) + ish = HI%isc-halo ; ieh = HI%iec+halo ; jsh = HI%jsc-halo ; jeh = HI%jec+halo + if (present(intx_dza)) then ; ish = MIN(Isq,ish) ; ieh = MAX(Ieq+1,ieh); endif + if (present(inty_dza)) then ; jsh = MIN(Jsq,jsh) ; jeh = MAX(Jeq+1,jeh); endif + + SV_scale = US%R_to_kg_m3 + RL2_T2_to_Pa = US%RL2_T2_to_Pa + alpha_ref_mks = alpha_ref * US%kg_m3_to_R + + do_massWeight = .false. + if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then + do_massWeight = .true. + if (.not.present(bathyP)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& + "bathyP must be present if useMassWghtInterp is present and true.") + if (.not.present(dP_neglect)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& + "dP_neglect must be present if useMassWghtInterp is present and true.") + endif ; endif + + do j=jsh,jeh ; do i=ish,ieh + dp = p_b(i,j) - p_t(i,j) + do n=1,5 + T5(n) = T(i,j) ; S5(n) = S(i,j) + p5(n) = RL2_T2_to_Pa * (p_b(i,j) - 0.25*real(n-1)*dp) + enddo + + if (SV_scale /= 1.0) then + call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref_mks, scale=SV_scale) + else + call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref_mks) + endif + + ! Use Boole's rule to estimate the interface height anomaly change. + alpha_anom = C1_90*(7.0*(a5(1)+a5(5)) + 32.0*(a5(2)+a5(4)) + 12.0*a5(3)) + dza(i,j) = dp*alpha_anom + ! Use a Boole's-rule-like fifth-order accurate estimate of the double integral of + ! the interface height anomaly. + if (present(intp_dza)) intp_dza(i,j) = 0.5*dp**2 * & + (alpha_anom - C1_90*(16.0*(a5(4)-a5(2)) + 7.0*(a5(5)-a5(1))) ) + enddo ; enddo + + if (present(intx_dza)) then ; do j=HI%jsc,HI%jec ; do I=Isq,Ieq + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., bathyP(i,j)-p_t(i+1,j), bathyP(i+1,j)-p_t(i,j)) + if (hWght > 0.) then + hL = (p_b(i,j) - p_t(i,j)) + dP_neglect + hR = (p_b(i+1,j) - p_t(i+1,j)) + dP_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + + intp(1) = dza(i,j) ; intp(5) = dza(i+1,j) + do m=2,4 + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + + ! T, S, and p are interpolated in the horizontal. The p interpolation + ! is linear, but for T and S it may be thickness weighted. + p5(1) = RL2_T2_to_Pa * (wt_L*p_b(i,j) + wt_R*p_b(i+1,j)) + dp = wt_L*(p_b(i,j) - p_t(i,j)) + wt_R*(p_b(i+1,j) - p_t(i+1,j)) + T5(1) = wtT_L*T(i,j) + wtT_R*T(i+1,j) + S5(1) = wtT_L*S(i,j) + wtT_R*S(i+1,j) + + do n=2,5 + T5(n) = T5(1) ; S5(n) = S5(1) ; p5(n) = p5(n-1) - RL2_T2_to_Pa * 0.25*dp + enddo + if (SV_scale /= 1.0) then + call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref_mks, scale=SV_scale) + else + call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref_mks) + endif + + ! Use Boole's rule to estimate the interface height anomaly change. + intp(m) = dp*( C1_90*(7.0*(a5(1)+a5(5)) + 32.0*(a5(2)+a5(4)) + & + 12.0*a5(3))) + enddo + ! Use Boole's rule to integrate the interface height anomaly values in x. + intx_dza(i,j) = C1_90*(7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4)) + & + 12.0*intp(3)) + enddo ; enddo ; endif + + if (present(inty_dza)) then ; do J=Jsq,Jeq ; do i=HI%isc,HI%iec + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., bathyP(i,j)-p_t(i,j+1), bathyP(i,j+1)-p_t(i,j)) + if (hWght > 0.) then + hL = (p_b(i,j) - p_t(i,j)) + dP_neglect + hR = (p_b(i,j+1) - p_t(i,j+1)) + dP_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + + intp(1) = dza(i,j) ; intp(5) = dza(i,j+1) + do m=2,4 + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + + ! T, S, and p are interpolated in the horizontal. The p interpolation + ! is linear, but for T and S it may be thickness weighted. + p5(1) = RL2_T2_to_Pa * (wt_L*p_b(i,j) + wt_R*p_b(i,j+1)) + dp = wt_L*(p_b(i,j) - p_t(i,j)) + wt_R*(p_b(i,j+1) - p_t(i,j+1)) + T5(1) = wtT_L*T(i,j) + wtT_R*T(i,j+1) + S5(1) = wtT_L*S(i,j) + wtT_R*S(i,j+1) + do n=2,5 + T5(n) = T5(1) ; S5(n) = S5(1) ; p5(n) = RL2_T2_to_Pa * (p5(n-1) - 0.25*dp) + enddo + if (SV_scale /= 1.0) then + call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref_mks, scale=SV_scale) + else + call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref_mks) + endif + + ! Use Boole's rule to estimate the interface height anomaly change. + intp(m) = dp*( C1_90*(7.0*(a5(1)+a5(5)) + 32.0*(a5(2)+a5(4)) + & + 12.0*a5(3))) + enddo + ! Use Boole's rule to integrate the interface height anomaly values in y. + inty_dza(i,j) = C1_90*(7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4)) + & + 12.0*intp(3)) + enddo ; enddo ; endif + +end subroutine int_spec_vol_dp_generic_pcm + +!> This subroutine calculates integrals of specific volume anomalies in +!! pressure across layers, which are required for calculating the finite-volume +!! form pressure accelerations in a non-Boussinesq model. There are essentially +!! no free assumptions, apart from the use of Boole's rule quadrature to do the integrals. +subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, & + dP_neglect, bathyP, HI, EOS, US, dza, & + intp_dza, intx_dza, inty_dza, useMassWghtInterp) + type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: T_t !< Potential temperature at the top of the layer [degC] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: T_b !< Potential temperature at the bottom of the layer [degC] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: S_t !< Salinity at the top the layer [ppt] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: S_b !< Salinity at the bottom the layer [ppt] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: p_t !< Pressure atop the layer [R L2 T-2 ~> Pa] or [Pa] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: p_b !< Pressure below the layer [R L2 T-2 ~> Pa] or [Pa] + real, intent(in) :: alpha_ref !< A mean specific volume that is subtracted out + !! to reduce the magnitude of each of the integrals [R-1 ~> m3 kg-1] + !! The calculation is mathematically identical with different values of + !! alpha_ref, but alpha_ref alters the effects of roundoff, and + !! answers do change. + real, intent(in) :: dP_neglect ! Pa] or [Pa] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] or [Pa] + type(EOS_type), pointer :: EOS !< Equation of state structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(inout) :: dza !< The change in the geopotential anomaly + !! across the layer [L2 T-2 ~> m2 s-2] + real, dimension(SZI_(HI),SZJ_(HI)), & + optional, intent(inout) :: intp_dza !< The integral in pressure through the layer of + !! the geopotential anomaly relative to the anomaly at the bottom of the + !! layer [R L4 T-4 ~> Pa m2 s-2] or [Pa m2 s-2] + real, dimension(SZIB_(HI),SZJ_(HI)), & + optional, intent(inout) :: intx_dza !< The integral in x of the difference between + !! the geopotential anomaly at the top and bottom of the layer divided + !! by the x grid spacing [L2 T-2 ~> m2 s-2] or [m2 s-2] + real, dimension(SZI_(HI),SZJB_(HI)), & + optional, intent(inout) :: inty_dza !< The integral in y of the difference between + !! the geopotential anomaly at the top and bottom of the layer divided + !! by the y grid spacing [L2 T-2 ~> m2 s-2] or [m2 s-2] + logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting + !! to interpolate T/S for top and bottom integrals. + +! This subroutine calculates analytical and nearly-analytical integrals in +! pressure across layers of geopotential anomalies, which are required for +! calculating the finite-volume form pressure accelerations in a non-Boussinesq +! model. There are essentially no free assumptions, apart from the use of +! Boole's rule to do the horizontal integrals, and from a truncation in the +! series for log(1-eps/1+eps) that assumes that |eps| < 0.34. + + real :: T5(5) ! Temperatures at five quadrature points [degC] + real :: S5(5) ! Salinities at five quadrature points [ppt] + real :: p5(5) ! Pressures at five quadrature points, scaled back to Pa as necessary [Pa] + real :: a5(5) ! Specific volumes at five quadrature points [R-1 ~> m3 kg-1] or [m3 kg-1] + real :: T15(15) ! Temperatures at fifteen interior quadrature points [degC] + real :: S15(15) ! Salinities at fifteen interior quadrature points [ppt] + real :: p15(15) ! Pressures at fifteen quadrature points, scaled back to Pa as necessary [Pa] + real :: a15(15) ! Specific volumes at fifteen quadrature points [R-1 ~> m3 kg-1] or [m3 kg-1] + real :: wt_t(5), wt_b(5) ! Weights of top and bottom values at quadrature points [nondim] + real :: T_top, T_bot, S_top, S_bot, P_top, P_bot + + real :: alpha_anom ! The depth averaged specific density anomaly [m3 kg-1] + real :: dp ! The pressure change through a layer [R L2 T-2 ~> Pa] + real :: dp_90(2:4) ! The pressure change through a layer divided by 90 [R L2 T-2 ~> Pa] + real :: hWght ! A pressure-thickness below topography [R L2 T-2 ~> Pa] + real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [R L2 T-2 ~> Pa] + real :: alpha_ref_mks ! The reference specific volume in MKS units, never rescaled from m3 kg-1 [m3 kg-1] + real :: iDenom ! The inverse of the denominator in the weights [T4 R-2 L-4 ~> Pa-2] + real :: hWt_LL, hWt_LR ! hWt_LA is the weighted influence of A on the left column [nondim] + real :: hWt_RL, hWt_RR ! hWt_RA is the weighted influence of A on the right column [nondim] + real :: wt_L, wt_R ! The linear weights of the left and right columns [nondim] + real :: wtT_L, wtT_R ! The weights for tracers from the left and right columns [nondim] + real :: intp(5) ! The integrals of specific volume with pressure at the + ! 5 sub-column locations [L2 T-2 ~> m2 s-2] + real :: RL2_T2_to_Pa ! A unit conversion factor from the rescaled units of pressure to Pa [Pa T2 R-1 L-2 ~> 1] + real :: SV_scale ! A multiplicative factor by which to scale specific + ! volume from m3 kg-1 to the desired units [kg m-3 R-1 ~> 1] + real, parameter :: C1_90 = 1.0/90.0 ! A rational constant. + logical :: do_massWeight ! Indicates whether to do mass weighting. + integer :: Isq, Ieq, Jsq, Jeq, i, j, m, n, pos + + Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB + + do_massWeight = .false. + if (present(useMassWghtInterp)) do_massWeight = useMassWghtInterp + + SV_scale = US%R_to_kg_m3 + RL2_T2_to_Pa = US%RL2_T2_to_Pa + alpha_ref_mks = alpha_ref * US%kg_m3_to_R + + do n = 1, 5 ! Note that these are reversed from int_density_dz. + wt_t(n) = 0.25 * real(n-1) + wt_b(n) = 1.0 - wt_t(n) + enddo + + ! 1. Compute vertical integrals + do j=Jsq,Jeq+1; do i=Isq,Ieq+1 + dp = p_b(i,j) - p_t(i,j) + do n=1,5 ! T, S and p are linearly interpolated in the vertical. + p5(n) = RL2_T2_to_Pa * (wt_t(n) * p_t(i,j) + wt_b(n) * p_b(i,j)) + S5(n) = wt_t(n) * S_t(i,j) + wt_b(n) * S_b(i,j) + T5(n) = wt_t(n) * T_t(i,j) + wt_b(n) * T_b(i,j) + enddo + if (SV_scale /= 1.0) then + call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref_mks, scale=SV_scale) + else + call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref_mks) + endif + + ! Use Boole's rule to estimate the interface height anomaly change. + alpha_anom = C1_90*((7.0*(a5(1)+a5(5)) + 32.0*(a5(2)+a5(4))) + 12.0*a5(3)) + dza(i,j) = dp*alpha_anom + ! Use a Boole's-rule-like fifth-order accurate estimate of the double integral of + ! the interface height anomaly. + if (present(intp_dza)) intp_dza(i,j) = 0.5*dp**2 * & + (alpha_anom - C1_90*(16.0*(a5(4)-a5(2)) + 7.0*(a5(5)-a5(1))) ) + enddo ; enddo + + ! 2. Compute horizontal integrals in the x direction + if (present(intx_dza)) then ; do j=HI%jsc,HI%jec ; do I=Isq,Ieq + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation + ! of T,S along the top and bottom integrals, almost like thickness + ! weighting. Note: To work in terrain following coordinates we could + ! offset this distance by the layer thickness to replicate other models. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., bathyP(i,j)-p_t(i+1,j), bathyP(i+1,j)-p_t(i,j)) + if (hWght > 0.) then + hL = (p_b(i,j) - p_t(i,j)) + dP_neglect + hR = (p_b(i+1,j) - p_t(i+1,j)) + dP_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + + do m=2,4 + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + + ! T, S, and p are interpolated in the horizontal. The p interpolation + ! is linear, but for T and S it may be thickness weighted. + P_top = wt_L*p_t(i,j) + wt_R*p_t(i+1,j) + P_bot = wt_L*p_b(i,j) + wt_R*p_b(i+1,j) + T_top = wtT_L*T_t(i,j) + wtT_R*T_t(i+1,j) + T_bot = wtT_L*T_b(i,j) + wtT_R*T_b(i+1,j) + S_top = wtT_L*S_t(i,j) + wtT_R*S_t(i+1,j) + S_bot = wtT_L*S_b(i,j) + wtT_R*S_b(i+1,j) + dp_90(m) = C1_90*(P_bot - P_top) + + ! Salinity, temperature and pressure with linear interpolation in the vertical. + pos = (m-2)*5 + do n=1,5 + p15(pos+n) = RL2_T2_to_Pa * (wt_t(n) * P_top + wt_b(n) * P_bot) + S15(pos+n) = wt_t(n) * S_top + wt_b(n) * S_bot + T15(pos+n) = wt_t(n) * T_top + wt_b(n) * T_bot + enddo + enddo + + if (SV_scale /= 1.0) then + call calculate_spec_vol(T15, S15, p15, a15, 1, 15, EOS, alpha_ref_mks, scale=SV_scale) + else + call calculate_spec_vol(T15, S15, p15, a15, 1, 15, EOS, alpha_ref_mks) + endif + + intp(1) = dza(i,j) ; intp(5) = dza(i+1,j) + do m=2,4 + ! Use Boole's rule to estimate the interface height anomaly change. + ! The integrals at the ends of the segment are already known. + pos = (m-2)*5 + intp(m) = dp_90(m)*((7.0*(a15(pos+1)+a15(pos+5)) + & + 32.0*(a15(pos+2)+a15(pos+4))) + 12.0*a15(pos+3)) + enddo + ! Use Boole's rule to integrate the interface height anomaly values in x. + intx_dza(I,j) = C1_90*((7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4))) + & + 12.0*intp(3)) + enddo ; enddo ; endif + + ! 3. Compute horizontal integrals in the y direction + if (present(inty_dza)) then ; do J=Jsq,Jeq ; do i=HI%isc,HI%iec + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation + ! of T,S along the top and bottom integrals, like thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., bathyP(i,j)-p_t(i,j+1), bathyP(i,j+1)-p_t(i,j)) + if (hWght > 0.) then + hL = (p_b(i,j) - p_t(i,j)) + dP_neglect + hR = (p_b(i,j+1) - p_t(i,j+1)) + dP_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + + do m=2,4 + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + + ! T, S, and p are interpolated in the horizontal. The p interpolation + ! is linear, but for T and S it may be thickness weighted. + P_top = wt_L*p_t(i,j) + wt_R*p_t(i,j+1) + P_bot = wt_L*p_b(i,j) + wt_R*p_b(i,j+1) + T_top = wtT_L*T_t(i,j) + wtT_R*T_t(i,j+1) + T_bot = wtT_L*T_b(i,j) + wtT_R*T_b(i,j+1) + S_top = wtT_L*S_t(i,j) + wtT_R*S_t(i,j+1) + S_bot = wtT_L*S_b(i,j) + wtT_R*S_b(i,j+1) + dp_90(m) = C1_90*(P_bot - P_top) + + ! Salinity, temperature and pressure with linear interpolation in the vertical. + pos = (m-2)*5 + do n=1,5 + p15(pos+n) = RL2_T2_to_Pa * (wt_t(n) * P_top + wt_b(n) * P_bot) + S15(pos+n) = wt_t(n) * S_top + wt_b(n) * S_bot + T15(pos+n) = wt_t(n) * T_top + wt_b(n) * T_bot + enddo + enddo + + if (SV_scale /= 1.0) then + call calculate_spec_vol(T15, S15, p15, a15, 1, 15, EOS, alpha_ref_mks, scale=SV_scale) + else + call calculate_spec_vol(T15, S15, p15, a15, 1, 15, EOS, alpha_ref_mks) + endif + + intp(1) = dza(i,j) ; intp(5) = dza(i,j+1) + do m=2,4 + ! Use Boole's rule to estimate the interface height anomaly change. + ! The integrals at the ends of the segment are already known. + pos = (m-2)*5 + intp(m) = dp_90(m) * ((7.0*(a15(pos+1)+a15(pos+5)) + & + 32.0*(a15(pos+2)+a15(pos+4))) + 12.0*a15(pos+3)) + enddo + ! Use Boole's rule to integrate the interface height anomaly values in x. + inty_dza(i,J) = C1_90*((7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4))) + & + 12.0*intp(3)) + enddo ; enddo ; endif + +end subroutine int_spec_vol_dp_generic_plm + + +!> Find the depth at which the reconstructed pressure matches P_tgt +subroutine find_depth_of_pressure_in_cell(T_t, T_b, S_t, S_b, z_t, z_b, P_t, P_tgt, & + rho_ref, G_e, EOS, US, P_b, z_out, z_tol) + real, intent(in) :: T_t !< Potential temperature at the cell top [degC] + real, intent(in) :: T_b !< Potential temperature at the cell bottom [degC] + real, intent(in) :: S_t !< Salinity at the cell top [ppt] + real, intent(in) :: S_b !< Salinity at the cell bottom [ppt] + real, intent(in) :: z_t !< Absolute height of top of cell [Z ~> m] (Boussinesq ????) + real, intent(in) :: z_b !< Absolute height of bottom of cell [Z ~> m] + real, intent(in) :: P_t !< Anomalous pressure of top of cell, relative + !! to g*rho_ref*z_t [R L2 T-2 ~> Pa] + real, intent(in) :: P_tgt !< Target pressure at height z_out, relative + !! to g*rho_ref*z_out [R L2 T-2 ~> Pa] + real, intent(in) :: rho_ref !< Reference density with which calculation + !! are anomalous to [R ~> kg m-3] + real, intent(in) :: G_e !< Gravitational acceleration [L2 Z-1 T-2 ~> m s-2] + type(EOS_type), pointer :: EOS !< Equation of state structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, intent(out) :: P_b !< Pressure at the bottom of the cell [R L2 T-2 ~> Pa] + real, intent(out) :: z_out !< Absolute depth at which anomalous pressure = p_tgt [Z ~> m] + real, optional, intent(in) :: z_tol !< The tolerance in finding z_out [Z ~> m] + + ! Local variables + real :: dp ! Pressure thickness of the layer [R L2 T-2 ~> Pa] + real :: F_guess, F_l, F_r ! Fractional positions [nondim] + real :: GxRho ! The product of the gravitational acceleration and reference density [R L2 Z-1 T-2 ~> Pa m-1] + real :: Pa, Pa_left, Pa_right, Pa_tol ! Pressure anomalies, P = integral of g*(rho-rho_ref) dz [R L2 T-2 ~> Pa] + character(len=240) :: msg + + GxRho = G_e * rho_ref + + ! Anomalous pressure difference across whole cell + dp = frac_dp_at_pos(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, G_e, 1.0, EOS) + + P_b = P_t + dp ! Anomalous pressure at bottom of cell + + if (P_tgt <= P_t ) then + z_out = z_t + return + endif + + if (P_tgt >= P_b) then + z_out = z_b + return + endif + + F_l = 0. + Pa_left = P_t - P_tgt ! Pa_left < 0 + F_r = 1. + Pa_right = P_b - P_tgt ! Pa_right > 0 + Pa_tol = GxRho * 1.0e-5*US%m_to_Z + if (present(z_tol)) Pa_tol = GxRho * z_tol + + F_guess = F_l - Pa_left / (Pa_right - Pa_left) * (F_r - F_l) + Pa = Pa_right - Pa_left ! To get into iterative loop + do while ( abs(Pa) > Pa_tol ) + + z_out = z_t + ( z_b - z_t ) * F_guess + Pa = frac_dp_at_pos(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, G_e, F_guess, EOS) - ( P_tgt - P_t ) + + if (PaPa_right) then + write(msg,*) Pa_left,Pa,Pa_right,P_t-P_tgt,P_b-P_tgt + call MOM_error(FATAL, 'find_depth_of_pressure_in_cell out of bounds positive: /n'//msg) + elseif (Pa>0.) then + Pa_right = Pa + F_r = F_guess + else ! Pa == 0 + return + endif + F_guess = F_l - Pa_left / (Pa_right - Pa_left) * (F_r - F_l) + + enddo + +end subroutine find_depth_of_pressure_in_cell + + +!> Returns change in anomalous pressure change from top to non-dimensional +!! position pos between z_t and z_b +real function frac_dp_at_pos(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, G_e, pos, EOS) + real, intent(in) :: T_t !< Potential temperature at the cell top [degC] + real, intent(in) :: T_b !< Potential temperature at the cell bottom [degC] + real, intent(in) :: S_t !< Salinity at the cell top [ppt] + real, intent(in) :: S_b !< Salinity at the cell bottom [ppt] + real, intent(in) :: z_t !< The geometric height at the top of the layer [Z ~> m] + real, intent(in) :: z_b !< The geometric height at the bottom of the layer [Z ~> m] + real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3], that is subtracted out to + !! reduce the magnitude of each of the integrals. + real, intent(in) :: G_e !< The Earth's gravitational acceleration [L2 Z-1 T-2 ~> m s-2] + real, intent(in) :: pos !< The fractional vertical position, 0 to 1 [nondim] + type(EOS_type), pointer :: EOS !< Equation of state structure + real :: fract_dp_at_pos !< The change in pressure from the layer top to + !! fractional position pos [R L2 T-2 ~> Pa] + ! Local variables + real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim] + real :: dz ! Distance from the layer top [Z ~> m] + real :: top_weight, bottom_weight ! Fractional weights at quadrature points [nondim] + real :: rho_ave ! Average density [R ~> kg m-3] + real, dimension(5) :: T5 ! Temperatures at quadrature points [degC] + real, dimension(5) :: S5 ! Salinities at quadrature points [ppt] + real, dimension(5) :: p5 ! Pressures at quadrature points [R L2 T-2 ~> Pa] + real, dimension(5) :: rho5 ! Densities at quadrature points [R ~> kg m-3] + integer :: n + + do n=1,5 + ! Evaluate density at five quadrature points + bottom_weight = 0.25*real(n-1) * pos + top_weight = 1.0 - bottom_weight + ! Salinity and temperature points are linearly interpolated + S5(n) = top_weight * S_t + bottom_weight * S_b + T5(n) = top_weight * T_t + bottom_weight * T_b + p5(n) = ( top_weight * z_t + bottom_weight * z_b ) * ( G_e * rho_ref ) + enddo + call calculate_density(T5, S5, p5, rho5, EOS) + rho5(:) = rho5(:) !- rho_ref ! Work with anomalies relative to rho_ref + + ! Use Boole's rule to estimate the average density + rho_ave = C1_90*(7.0*(rho5(1)+rho5(5)) + 32.0*(rho5(2)+rho5(4)) + 12.0*rho5(3)) + + dz = ( z_t - z_b ) * pos + frac_dp_at_pos = G_e * dz * rho_ave +end function frac_dp_at_pos + +end module MOM_density_integrals + +!> \namespace mom_density_integrals +!! diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index 8c0decd8c1..64a9c18b97 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -28,7 +28,8 @@ module MOM_dynamics_split_RK2 use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_get_input, only : directories use MOM_io, only : MOM_io_init, vardesc, var_desc -use MOM_restart, only : register_restart_field, query_initialized, save_restart +use MOM_restart, only : register_restart_field, register_restart_pair +use MOM_restart, only : query_initialized, save_restart 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(/) @@ -159,10 +160,16 @@ module MOM_dynamics_split_RK2 integer :: id_umo_2d = -1, id_vmo_2d = -1 integer :: id_PFu = -1, id_PFv = -1 integer :: id_CAu = -1, id_CAv = -1 + ! integer :: id_hf_PFu = -1, id_hf_PFv = -1 + integer :: id_hf_PFu_2d = -1, id_hf_PFv_2d = -1 + ! integer :: id_hf_CAu = -1, id_hf_CAv = -1 + integer :: id_hf_CAu_2d = -1, id_hf_CAv_2d = -1 ! Split scheme only. integer :: id_uav = -1, id_vav = -1 integer :: id_u_BT_accel = -1, id_v_BT_accel = -1 + ! integer :: id_hf_u_BT_accel = -1, id_hf_v_BT_accel = -1 + integer :: id_hf_u_BT_accel_2d = -1, id_hf_v_BT_accel_2d = -1 !>@} type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the @@ -249,10 +256,10 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s type(time_type), intent(in) :: Time_local !< model time at end of time step real, intent(in) :: dt !< time step [T ~> s] type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces - real, dimension(:,:), pointer :: p_surf_begin !< surf pressure at start of this dynamic - !! time step [Pa] - real, dimension(:,:), pointer :: p_surf_end !< surf pressure at end of this dynamic - !! time step [Pa] + real, dimension(:,:), pointer :: p_surf_begin !< surf pressure at the start of this dynamic + !! time step [R L2 T-2 ~> Pa] + real, dimension(:,:), pointer :: p_surf_end !< surf pressure at the end of this dynamic + !! time step [R L2 T-2 ~> Pa] real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & target, intent(inout) :: uh !< zonal volume/mass transport !! [H L2 T-1 ~> m3 s-1 or kg s-1] @@ -305,7 +312,8 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s ! u_old_rad_OBC and v_old_rad_OBC are the starting velocities, which are ! saved for use in the Flather open boundary condition code [L T-1 ~> m s-1]. - real :: Pa_to_eta ! A factor that converts pressures to the units of eta. + 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(), eta_PF_start => NULL(), & taux_bot => NULL(), tauy_bot => NULL(), & @@ -316,6 +324,19 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s u_av, & ! The zonal velocity time-averaged over a time step [L T-1 ~> m s-1]. v_av, & ! The meridional velocity time-averaged over a time step [L T-1 ~> m s-1]. h_av ! The layer thickness time-averaged over a time step [H ~> m or kg m-2]. + + ! real, allocatable, dimension(:,:,:) :: & + ! hf_PFu, hf_PFv, & ! Pressure force accel. x fract. thickness [L T-2 ~> m s-2]. + ! hf_CAu, hf_CAv, & ! Coriolis force accel. x fract. thickness [L T-2 ~> m s-2]. + ! hf_u_BT_accel, hf_v_BT_accel ! barotropic correction accel. x fract. thickness [L T-2 ~> m s-2]. + ! 3D diagnostics hf_PFu etc. are commented because there is no clarity on proper remapping grid option. + ! The code is retained for degugging purposes in the future. + + real, allocatable, dimension(:,:) :: & + hf_PFu_2d, hf_PFv_2d, & ! Depth integeral of hf_PFu, hf_PFv [L T-2 ~> m s-2]. + hf_CAu_2d, hf_CAv_2d, & ! Depth integeral of hf_CAu, hf_CAv [L T-2 ~> m s-2]. + hf_u_BT_accel_2d, hf_v_BT_accel_2d ! Depth integeral of hf_u_BT_accel, hf_v_BT_accel + real :: dt_pred ! The time step for the predictor part of the baroclinic time stepping [T ~> s]. logical :: dyn_p_surf @@ -386,10 +407,8 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s !--- begin set up for group halo pass cont_stencil = continuity_stencil(CS%continuity_CSp) - !### Apart from circle_OBCs halo for eta could be 1, but halo>=3 is required - !### to match circle_OBCs solutions. Why? 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_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)) @@ -412,11 +431,10 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s 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 - Pa_to_eta = 1.0 / GV%H_to_Pa + 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) - Pa_to_eta * & - (p_surf_begin(i,j) - p_surf_end(i,j)) + 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 call cpu_clock_end(id_clock_pres) @@ -533,7 +551,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s ! This is the predictor step call to btstep. call btstep(u, v, eta, dt, u_bc_accel, v_bc_accel, forces, CS%pbce, CS%eta_PF, & u_av, v_av, CS%u_accel_bt, CS%v_accel_bt, eta_pred, CS%uhbt, CS%vhbt, & - G, GV, US, CS%barotropic_CSp, CS%visc_rem_u, CS%visc_rem_v, & + G, GV, US, CS%barotropic_CSp, CS%visc_rem_u, CS%visc_rem_v, ADp=CS%ADp, & OBC=CS%OBC, BT_cont=CS%BT_cont, eta_PF_start=eta_PF_start, & taux_bot=taux_bot, tauy_bot=tauy_bot, & uh0=uh_ptr, vh0=vh_ptr, u_uh0=u_ptr, v_vh0=v_ptr) @@ -683,7 +701,8 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s call cpu_clock_begin(id_clock_horvisc) call horizontal_viscosity(u_av, v_av, h_av, CS%diffu, CS%diffv, & MEKE, Varmix, G, GV, US, CS%hor_visc_CSp, & - OBC=CS%OBC, BT=CS%barotropic_CSp, TD=thickness_diffuse_CSp) + OBC=CS%OBC, BT=CS%barotropic_CSp, TD=thickness_diffuse_CSp, & + ADp=CS%ADp) call cpu_clock_end(id_clock_horvisc) if (showCallTree) call callTree_wayPoint("done with horizontal_viscosity (step_MOM_dyn_split_RK2)") @@ -734,8 +753,8 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s call btstep(u, v, eta, dt, u_bc_accel, v_bc_accel, forces, CS%pbce, & CS%eta_PF, u_av, v_av, CS%u_accel_bt, CS%v_accel_bt, & eta_pred, CS%uhbt, CS%vhbt, G, GV, US, CS%barotropic_CSp, & - CS%visc_rem_u, CS%visc_rem_v, etaav=eta_av, OBC=CS%OBC, & - BT_cont = CS%BT_cont, eta_PF_start=eta_PF_start, & + CS%visc_rem_u, CS%visc_rem_v, etaav=eta_av, ADp=CS%ADp, & + OBC=CS%OBC, BT_cont = CS%BT_cont, eta_PF_start=eta_PF_start, & taux_bot=taux_bot, tauy_bot=tauy_bot, & uh0=uh_ptr, vh0=vh_ptr, u_uh0=u_ptr, v_vh0=v_ptr) do j=js,je ; do i=is,ie ; eta(i,j) = eta_pred(i,j) ; enddo ; enddo @@ -861,6 +880,109 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s if (CS%id_u_BT_accel > 0) call post_data(CS%id_u_BT_accel, CS%u_accel_bt, CS%diag) if (CS%id_v_BT_accel > 0) call post_data(CS%id_v_BT_accel, CS%v_accel_bt, CS%diag) + ! Diagnostics for terms multiplied by fractional thicknesses + + ! 3D diagnostics hf_PFu etc. are commented because there is no clarity on proper remapping grid option. + ! The code is retained for degugging purposes in the future. + !if (CS%id_hf_PFu > 0) then + ! allocate(hf_PFu(G%IsdB:G%IedB,G%jsd:G%jed,G%ke)) + ! do k=1,nz ; do j=js,je ; do I=Isq,Ieq + ! hf_PFu(I,j,k) = CS%PFu(I,j,k) * CS%ADp%diag_hfrac_u(I,j,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_PFu, hf_PFu, CS%diag) + !endif + !if (CS%id_hf_PFv > 0) then + ! allocate(hf_PFv(G%isd:G%ied,G%JsdB:G%JedB,G%ke)) + ! do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + ! hf_PFv(i,J,k) = CS%PFv(i,J,k) * CS%ADp%diag_hfrac_v(i,J,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_PFv, hf_PFv, CS%diag) + !endif + if (CS%id_hf_PFu_2d > 0) then + allocate(hf_PFu_2d(G%IsdB:G%IedB,G%jsd:G%jed)) + hf_PFu_2d(:,:) = 0.0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + hf_PFu_2d(I,j) = hf_PFu_2d(I,j) + CS%PFu(I,j,k) * CS%ADp%diag_hfrac_u(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_PFu_2d, hf_PFu_2d, CS%diag) + deallocate(hf_PFu_2d) + endif + if (CS%id_hf_PFv_2d > 0) then + allocate(hf_PFv_2d(G%isd:G%ied,G%JsdB:G%JedB)) + hf_PFv_2d(:,:) = 0.0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + hf_PFv_2d(i,J) = hf_PFv_2d(i,J) + CS%PFv(i,J,k) * CS%ADp%diag_hfrac_v(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_PFv_2d, hf_PFv_2d, CS%diag) + deallocate(hf_PFv_2d) + endif + + !if (CS%id_hf_CAu > 0) then + ! allocate(hf_CAu(G%IsdB:G%IedB,G%jsd:G%jed,G%ke)) + ! do k=1,nz ; do j=js,je ; do I=Isq,Ieq + ! hf_CAu(I,j,k) = CS%CAu(I,j,k) * CS%ADp%diag_hfrac_u(I,j,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_CAu, hf_CAu, CS%diag) + !endif + !if (CS%id_hf_CAv > 0) then + ! allocate(hf_CAv(G%isd:G%ied,G%JsdB:G%JedB,G%ke)) + ! do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + ! hf_CAv(i,J,k) = CS%CAv(i,J,k) * CS%ADp%diag_hfrac_v(i,J,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_CAv, hf_CAv, CS%diag) + !endif + if (CS%id_hf_CAu_2d > 0) then + allocate(hf_CAu_2d(G%IsdB:G%IedB,G%jsd:G%jed)) + hf_CAu_2d(:,:) = 0.0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + hf_CAu_2d(I,j) = hf_CAu_2d(I,j) + CS%CAu(I,j,k) * CS%ADp%diag_hfrac_u(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_CAu_2d, hf_CAu_2d, CS%diag) + deallocate(hf_CAu_2d) + endif + if (CS%id_hf_CAv_2d > 0) then + allocate(hf_CAv_2d(G%isd:G%ied,G%JsdB:G%JedB)) + hf_CAv_2d(:,:) = 0.0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + hf_CAv_2d(i,J) = hf_CAv_2d(i,J) + CS%CAv(i,J,k) * CS%ADp%diag_hfrac_v(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_CAv_2d, hf_CAv_2d, CS%diag) + deallocate(hf_CAv_2d) + endif + + !if (CS%id_hf_u_BT_accel > 0) then + ! allocate(hf_u_BT_accel(G%IsdB:G%IedB,G%jsd:G%jed,G%ke)) + ! do k=1,nz ; do j=js,je ; do I=Isq,Ieq + ! hf_u_BT_accel(I,j,k) = CS%u_accel_bt(I,j,k) * CS%ADp%diag_hfrac_u(I,j,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_u_BT_accel, hf_u_BT_accel, CS%diag) + !endif + !if (CS%id_hf_v_BT_accel > 0) then + ! allocate(hf_v_BT_accel(G%isd:G%ied,G%JsdB:G%JedB,G%ke)) + ! do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + ! hf_v_BT_accel(i,J,k) = CS%v_accel_bt(i,J,k) * CS%ADp%diag_hfrac_v(i,J,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_v_BT_accel, hf_v_BT_accel, CS%diag) + !endif + if (CS%id_hf_u_BT_accel_2d > 0) then + allocate(hf_u_BT_accel_2d(G%IsdB:G%IedB,G%jsd:G%jed)) + hf_u_BT_accel_2d(:,:) = 0.0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + hf_u_BT_accel_2d(I,j) = hf_u_BT_accel_2d(I,j) + CS%u_accel_bt(I,j,k) * CS%ADp%diag_hfrac_u(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_u_BT_accel_2d, hf_u_BT_accel_2d, CS%diag) + deallocate(hf_u_BT_accel_2d) + endif + if (CS%id_hf_v_BT_accel_2d > 0) then + allocate(hf_v_BT_accel_2d(G%isd:G%ied,G%JsdB:G%JedB)) + hf_v_BT_accel_2d(:,:) = 0.0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + hf_v_BT_accel_2d(i,J) = hf_v_BT_accel_2d(i,J) + CS%v_accel_bt(i,J,k) * CS%ADp%diag_hfrac_v(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_v_BT_accel_2d, hf_v_BT_accel_2d, CS%diag) + deallocate(hf_v_BT_accel_2d) + endif + if (CS%debug) then call MOM_state_chksum("Corrector ", u, v, h, uh, vh, G, GV, US, symmetric=sym) call uvchksum("Corrector avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, scale=US%L_T_to_m_s) @@ -886,11 +1008,12 @@ subroutine register_restarts_dyn_split_RK2(HI, GV, param_file, CS, restart_CS, u real, dimension(SZI_(HI),SZJB_(HI),SZK_(GV)), & target, intent(inout) :: vh !< merid volume/mass transport [H L2 T-1 ~> m3 s-1 or kg s-1] - type(vardesc) :: vd + type(vardesc) :: vd(2) character(len=40) :: mdl = "MOM_dynamics_split_RK2" ! This module's name. 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 @@ -918,32 +1041,26 @@ subroutine register_restarts_dyn_split_RK2(HI, GV, param_file, CS, restart_CS, u flux_units = get_flux_units(GV) if (GV%Boussinesq) then - vd = var_desc("sfc",thickness_units,"Free surface Height",'h','1') + vd(1) = var_desc("sfc",thickness_units,"Free surface Height",'h','1') else - vd = var_desc("p_bot",thickness_units,"Bottom Pressure",'h','1') + vd(1) = var_desc("p_bot",thickness_units,"Bottom Pressure",'h','1') endif - call register_restart_field(CS%eta, vd, .false., restart_CS) - - vd = var_desc("u2","m s-1","Auxiliary Zonal velocity",'u','L') - call register_restart_field(CS%u_av, vd, .false., restart_CS) - - vd = var_desc("v2","m s-1","Auxiliary Meridional velocity",'v','L') - call register_restart_field(CS%v_av, vd, .false., restart_CS) + call register_restart_field(CS%eta, vd(1), .false., restart_CS) - vd = var_desc("h2",thickness_units,"Auxiliary Layer Thickness",'h','L') - call register_restart_field(CS%h_av, vd, .false., restart_CS) + 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) - vd = var_desc("uh",flux_units,"Zonal thickness flux",'u','L') - call register_restart_field(uh, vd, .false., restart_CS) + vd(1) = var_desc("h2",thickness_units,"Auxiliary Layer Thickness",'h','L') + call register_restart_field(CS%h_av, vd(1), .false., restart_CS) - vd = var_desc("vh",flux_units,"Meridional thickness flux",'v','L') - call register_restart_field(vh, vd, .false., restart_CS) + 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) - vd = var_desc("diffu","m s-2","Zonal horizontal viscous acceleration",'u','L') - call register_restart_field(CS%diffu, vd, .false., restart_CS) - - vd = var_desc("diffv","m s-2","Meridional horizontal viscous acceleration",'v','L') - call register_restart_field(CS%diffv, vd, .false., restart_CS) + 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) call register_barotropic_restarts(HI, GV, param_file, CS%barotropic_CSp, & restart_CS) @@ -1003,6 +1120,8 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param ! local variables real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_tmp 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 real :: H_rescale ! A rescaling factor for thicknesses from the representation in ! a restart file to the internal representation in this run. @@ -1033,6 +1152,7 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param CS%diag => diag + call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "TIDES", use_tides, & "If true, apply tidal momentum forcing.", default=.false.) call get_param(param_file, mdl, "BE", CS%be, & @@ -1113,7 +1233,7 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param if (use_tides) call tidal_forcing_init(Time, G, param_file, CS%tides_CSp) call PressureForce_init(Time, G, GV, US, param_file, diag, CS%PressureForce_CSp, & CS%tides_CSp) - call hor_visc_init(Time, G, US, param_file, diag, CS%hor_visc_CSp, MEKE) + call hor_visc_init(Time, G, US, param_file, diag, CS%hor_visc_CSp, MEKE, ADp=CS%ADp) call vertvisc_init(MIS, Time, G, GV, US, param_file, diag, CS%ADp, dirs, & ntrunc, CS%vertvisc_CSp) if (.not.associated(setVisc_CSp)) call MOM_error(FATAL, & @@ -1235,6 +1355,46 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param CS%id_PFv = register_diag_field('ocean_model', 'PFv', diag%axesCvL, Time, & 'Meridional Pressure Force Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) + !CS%id_hf_PFu = register_diag_field('ocean_model', 'hf_PFu', diag%axesCuL, Time, & + ! 'Fractional Thickness-weighted Zonal Pressure Force Acceleration', 'm s-2', & + ! v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if(CS%id_hf_PFu > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + + !CS%id_hf_PFv = register_diag_field('ocean_model', 'hf_PFv', diag%axesCvL, Time, & + ! 'Fractional Thickness-weighted Meridional Pressure Force Acceleration', 'm s-2', & + ! v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if(CS%id_hf_PFv > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + + !CS%id_hf_CAu = register_diag_field('ocean_model', 'hf_CAu', diag%axesCuL, Time, & + ! 'Fractional Thickness-weighted Zonal Coriolis and Advective Acceleration', 'm s-2', & + ! v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if(CS%id_hf_CAu > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + + !CS%id_hf_CAv = register_diag_field('ocean_model', 'hf_CAv', diag%axesCvL, Time, & + ! 'Fractional Thickness-weighted Meridional Coriolis and Advective Acceleration', 'm s-2', & + ! v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if(CS%id_hf_CAv > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + + CS%id_hf_PFu_2d = register_diag_field('ocean_model', 'hf_PFu_2d', diag%axesCu1, Time, & + 'Depth-sum Fractional Thickness-weighted Zonal Pressure Force Acceleration', 'm s-2', & + conversion=US%L_T2_to_m_s2) + if(CS%id_hf_PFu_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + + CS%id_hf_PFv_2d = register_diag_field('ocean_model', 'hf_PFv_2d', diag%axesCv1, Time, & + 'Depth-sum Fractional Thickness-weighted Meridional Pressure Force Acceleration', 'm s-2', & + conversion=US%L_T2_to_m_s2) + if(CS%id_hf_PFv_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + + CS%id_hf_CAu_2d = register_diag_field('ocean_model', 'hf_CAu_2d', diag%axesCu1, Time, & + 'Depth-sum Fractional Thickness-weighted Zonal Coriolis and Advective Acceleration', 'm s-2', & + conversion=US%L_T2_to_m_s2) + if(CS%id_hf_CAu_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + + CS%id_hf_CAv_2d = register_diag_field('ocean_model', 'hf_CAv_2d', diag%axesCv1, Time, & + 'Depth-sum Fractional Thickness-weighted Meridional Coriolis and Advective Acceleration', 'm s-2', & + conversion=US%L_T2_to_m_s2) + if(CS%id_hf_CAv_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + CS%id_uav = register_diag_field('ocean_model', 'uav', diag%axesCuL, Time, & 'Barotropic-step Averaged Zonal Velocity', 'm s-1', conversion=US%L_T_to_m_s) CS%id_vav = register_diag_field('ocean_model', 'vav', diag%axesCvL, Time, & @@ -1245,6 +1405,26 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param CS%id_v_BT_accel = register_diag_field('ocean_model', 'v_BT_accel', diag%axesCvL, Time, & 'Barotropic Anomaly Meridional Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) + !CS%id_hf_u_BT_accel = register_diag_field('ocean_model', 'hf_u_BT_accel', diag%axesCuL, Time, & + ! 'Fractional Thickness-weighted Barotropic Anomaly Zonal Acceleration', 'm s-2', & + ! v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if(CS%id_hf_u_BT_accel > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + + !CS%id_hf_v_BT_accel = register_diag_field('ocean_model', 'hf_v_BT_accel', diag%axesCvL, Time, & + ! 'Fractional Thickness-weighted Barotropic Anomaly Meridional Acceleration', 'm s-2', & + ! v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if(CS%id_hf_v_BT_accel > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + + CS%id_hf_u_BT_accel_2d = register_diag_field('ocean_model', 'hf_u_BT_accel_2d', diag%axesCu1, Time, & + 'Depth-sum Fractional Thickness-weighted Barotropic Anomaly Zonal Acceleration', 'm s-2', & + conversion=US%L_T2_to_m_s2) + if(CS%id_hf_u_BT_accel_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + + CS%id_hf_v_BT_accel_2d = register_diag_field('ocean_model', 'hf_v_BT_accel_2d', diag%axesCv1, Time, & + 'Depth-sum Fractional Thickness-weighted Barotropic Anomaly Meridional Acceleration', 'm s-2', & + conversion=US%L_T2_to_m_s2) + if(CS%id_hf_v_BT_accel_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + id_clock_Cor = cpu_clock_id('(Ocean Coriolis & mom advection)', grain=CLOCK_MODULE) id_clock_continuity = cpu_clock_id('(Ocean continuity equation)', grain=CLOCK_MODULE) id_clock_pres = cpu_clock_id('(Ocean pressure force)', grain=CLOCK_MODULE) diff --git a/src/core/MOM_dynamics_unsplit.F90 b/src/core/MOM_dynamics_unsplit.F90 index a5671948b1..6b9aa8e759 100644 --- a/src/core/MOM_dynamics_unsplit.F90 +++ b/src/core/MOM_dynamics_unsplit.F90 @@ -120,6 +120,10 @@ module MOM_dynamics_unsplit real, pointer, dimension(:,:) :: tauy_bot => NULL() !< frictional y-bottom stress from the ocean !! to the seafloor [R L Z T-2 ~> Pa] + logical :: 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. The default should be true, but it is false. logical :: debug !< If true, write verbose checksums for debugging purposes. logical :: module_is_initialized = .false. !< Record whether this mouled has been initialzed. @@ -200,9 +204,9 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & 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 [Pa]. + !! 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 [Pa]. + !! pressure at the end of this dynamic step [R L2 T-2 ~> Pa]. real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), 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_(G)), intent(inout) :: vh !< The meridional volume or mass @@ -228,6 +232,7 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & real, dimension(SZI_(G),SZJB_(G),SZK_(G)) :: vp, vpp ! Predicted meridional velocities [L T-1 ~> m s-1] real, dimension(:,:), pointer :: p_surf => NULL() 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 = G%ke @@ -255,8 +260,7 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & ! 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_CSp) + call horizontal_viscosity(u, v, h, CS%diffu, CS%diffv, MEKE, Varmix, G, GV, US, CS%hor_visc_CSp) call cpu_clock_end(id_clock_horvisc) call disable_averaging(CS%diag) @@ -323,31 +327,29 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & ! 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))) + 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))) + 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,& + 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) - call set_viscous_ML(u, v, h_av, tv, forces, visc, dt*0.5, G, GV, US, & - CS%set_visc_CSp) + dt_visc = 0.5*dt ; if (CS%use_correct_dt_visc) dt_visc = 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) - !### I think that the time steps in the next two calls should be dt_pred. - call vertvisc_coef(up, vp, h_av, forces, visc, dt*0.5, G, GV, US, & - CS%vertvisc_CSp, CS%OBC) - call vertvisc(up, vp, h_av, forces, visc, dt*0.5, CS%OBC, CS%ADp, CS%CDp, & + + dt_visc = 0.5*dt ; if (CS%use_correct_dt_visc) dt_visc = dt_pred + call vertvisc_coef(up, vp, h_av, forces, visc, dt_visc, G, GV, US, CS%vertvisc_CSp, CS%OBC) + 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) @@ -355,8 +357,7 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & ! 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, OBC=CS%OBC) + call continuity(up, vp, hp, h_av, uh, vh, (0.5*dt), G, GV, US, CS%continuity_CSp, OBC=CS%OBC) 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) @@ -392,25 +393,22 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & ! 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))) + 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))) + 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,& + 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 vertvisc_coef(upp, vpp, hp, forces, visc, dt*0.5, G, GV, US, & - CS%vertvisc_CSp, CS%OBC) + call vertvisc_coef(upp, vpp, hp, forces, visc, dt*0.5, G, GV, US, CS%vertvisc_CSp, CS%OBC) 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) @@ -419,8 +417,7 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & ! 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, OBC=CS%OBC) + call continuity(upp, vpp, hp, h, uh, vh, (dt*0.5), G, GV, US, CS%continuity_CSp, OBC=CS%OBC) 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) @@ -470,12 +467,10 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & call open_boundary_zero_normal_flow(CS%OBC, G, 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))) + 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))) + 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 @@ -617,6 +612,8 @@ subroutine initialize_dyn_unsplit(u, v, h, Time, G, GV, US, param_file, diag, CS ! Local variables character(len=40) :: mdl = "MOM_dynamics_unsplit" ! This module's name. character(len=48) :: thickness_units, flux_units + ! This include declares and sets the variable "version". +# include "version_variable.h" real :: H_convert logical :: use_tides integer :: isd, ied, jsd, jed, nz, IsdB, IedB, JsdB, JedB @@ -634,6 +631,12 @@ subroutine initialize_dyn_unsplit(u, v, h, Time, G, GV, US, param_file, diag, CS CS%diag => diag + call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "FIX_UNSPLIT_DT_VISC_BUG", CS%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.) call get_param(param_file, mdl, "DEBUG", CS%debug, & "If true, write out verbose debugging data.", & default=.false., debuggingParam=.true.) diff --git a/src/core/MOM_dynamics_unsplit_RK2.F90 b/src/core/MOM_dynamics_unsplit_RK2.F90 index e88b7c32dc..4181ab519d 100644 --- a/src/core/MOM_dynamics_unsplit_RK2.F90 +++ b/src/core/MOM_dynamics_unsplit_RK2.F90 @@ -123,6 +123,9 @@ module MOM_dynamics_unsplit_RK2 !! the extent to which the treatment of gravity waves !! is forward-backward (0) or simulated backward !! Euler (1). 0 is almost always used. + logical :: use_correct_dt_visc !< If true, use the correct timestep in the calculation of the + !! turbulent mixed layer properties for viscosity. + !! The default should be true, but it is false. logical :: debug !< If true, write verbose checksums for debugging purposes. logical :: module_is_initialized = .false. !< Record whether this mouled has been initialzed. @@ -209,10 +212,10 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, 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 [Pa]. + !! 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 [Pa]. + !! this dynamic step [R L2 T-2 ~> Pa]. real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), 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_(G)), intent(inout) :: vh !< The meridional volume or mass @@ -238,8 +241,8 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, real, dimension(SZIB_(G),SZJ_(G),SZK_(G)) :: up ! Predicted zonal velocities [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(G)) :: vp ! Predicted meridional velocities [L T-1 ~> m s-1] real, dimension(:,:), pointer :: p_surf => NULL() - real :: dt_pred ! The time step for the predictor part of the baroclinic - ! time stepping [T ~> s]. + 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 = G%ke @@ -280,17 +283,15 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, 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, OBC=CS%OBC) + call continuity(u_in, v_in, h_in, hp, uh, vh, dt_pred, G, GV, US, CS%continuity_CSp, OBC=CS%OBC) 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 + 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) @@ -305,8 +306,7 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, 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 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) @@ -339,11 +339,11 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, ! 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) - call set_viscous_ML(up, vp, h_av, tv, forces, visc, dt_pred, G, GV, US, & - CS%set_visc_CSp) + dt_visc = dt_pred ; if (CS%use_correct_dt_visc) dt_visc = dt + call set_viscous_ML(u_in, v_in, h_av, tv, forces, visc, dt_visc, G, GV, US, CS%set_visc_CSp) call disable_averaging(CS%diag) - call vertvisc_coef(up, vp, h_av, forces, visc, dt_pred, G, GV, US, & - CS%vertvisc_CSp, CS%OBC) + + call vertvisc_coef(up, vp, h_av, forces, visc, dt_pred, G, GV, US, CS%vertvisc_CSp, CS%OBC) 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) @@ -394,12 +394,10 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, ! up[n] <- up* + dt d/dz visc d/dz up ! u[n] <- u*[n] + dt d/dz visc d/dz u[n] call cpu_clock_begin(id_clock_vertvisc) - call vertvisc_coef(up, vp, h_av, forces, visc, dt, G, GV, US, & - CS%vertvisc_CSp, CS%OBC) + call vertvisc_coef(up, vp, h_av, forces, visc, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC) call vertvisc(up, vp, h_av, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp, & G, GV, US, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot) - call vertvisc_coef(u_in, v_in, h_av, forces, visc, dt, G, GV, US, & - CS%vertvisc_CSp, CS%OBC) + call vertvisc_coef(u_in, v_in, h_av, forces, visc, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC) 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) @@ -557,9 +555,11 @@ subroutine initialize_dyn_unsplit_RK2(u, v, h, Time, G, GV, US, param_file, diag ! This subroutine initializes all of the variables that are used by this ! dynamic core, including diagnostics and the cpu clocks. - ! Local varaibles + ! Local variables character(len=40) :: mdl = "MOM_dynamics_unsplit_RK2" ! This module's name. character(len=48) :: thickness_units, flux_units + ! This include declares and sets the variable "version". +# include "version_variable.h" real :: H_convert logical :: use_tides integer :: isd, ied, jsd, jed, nz, IsdB, IedB, JsdB, JedB @@ -577,6 +577,7 @@ subroutine initialize_dyn_unsplit_RK2(u, v, h, Time, G, GV, US, param_file, diag 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 "//& @@ -593,6 +594,11 @@ subroutine initialize_dyn_unsplit_RK2(u, v, h, Time, G, GV, US, param_file, diag "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, "FIX_UNSPLIT_DT_VISC_BUG", CS%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.) call get_param(param_file, mdl, "DEBUG", CS%debug, & "If true, write out verbose debugging data.", & default=.false., debuggingParam=.true.) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index b7260c2da6..0ff9a4b287 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -3,13 +3,14 @@ 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_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, 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, enable_averaging, disable_averaging use MOM_error_handler, only : MOM_error, FATAL, WARNING -use MOM_EOS, only : calculate_density_derivs +use MOM_EOS, only : calculate_density_derivs, EOS_domain use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type use MOM_opacity, only : sumSWoverBands, optics_type, extract_optics_slice, optics_nbands @@ -35,6 +36,21 @@ module MOM_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 + +!> 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 ! 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 @@ -81,7 +97,7 @@ module MOM_forcing_type 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 [kg m-2 s-1]; these fluxes impact the ocean mass + ! 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] @@ -116,13 +132,13 @@ module MOM_forcing_type ! 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 [Pa]. + !< 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 [Pa] as used to drive the ocean model. + !< 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 [Pa] that is used in corrections to the sea surface + !< 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 @@ -139,7 +155,7 @@ module MOM_forcing_type real, pointer, dimension(:,:) :: & ustar_berg => NULL(), & !< iceberg contribution to top ustar [Z T-1 ~> m s-1]. area_berg => NULL(), & !< area of ocean surface covered by icebergs [m2 m-2] - mass_berg => NULL() !< mass of icebergs [kg m-2] + 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]. @@ -166,7 +182,7 @@ module MOM_forcing_type !! type variable has not yet been inialized. 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 [J kg-1 degC-1]. + real :: C_p !< heat capacity of seawater [Q degC-1 ~> J kg-1 degC-1]. !! C_p is is the same value as in thermovar_ptrs_type. ! passive tracer surface fluxes @@ -195,20 +211,20 @@ module MOM_forcing_type ! 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 [Pa]. + !< 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 [Pa] as used to drive the ocean model. + !< 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 that is used in corrections to the sea surface - !! height field that is passed back to the calling routines. + !< 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 [m2 m-2] - mass_berg => NULL() !< mass of icebergs per unit ocean area [kg m-2] + 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, @@ -218,8 +234,10 @@ module MOM_forcing_type !! 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 [m3 s-1] - rigidity_ice_v => NULL() !< Depth-integrated lateral viscosity of ice shelves or sea ice at v-points [m3 s-1] + 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 [s]. logical :: net_mass_src_set = .false. !< If true, an estimate of net_mass_src has been provided. @@ -654,7 +672,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & &" exceeds total shortwave of ",1pe17.10,& &" at ",1pg11.4,"E, "1pg11.4,"N.")') & Pen_SW_tot(i), I_Cp_Hconvert*scale*dt * fluxes%sw(i,j), & - G%geoLonT(i,j),G%geoLatT(i,j) + G%geoLonT(i,j), G%geoLatT(i,j) call MOM_error(WARNING,mesg) endif endif @@ -851,10 +869,7 @@ subroutine extractFluxes2d(G, GV, US, fluxes, optics, nsw, dt, FluxRescaleDepth, logical, intent(in) :: aggregate_FW !< For determining how to aggregate the forcing. integer :: j -!$OMP parallel do default(none) shared(G, GV, US, fluxes, optics, nsw, dt, FluxRescaleDepth, & -!$OMP useRiverHeatContent, useCalvingHeatContent, & -!$OMP h,T,netMassInOut,netMassOut,Net_heat,Net_salt,Pen_SW_bnd,tv, & -!$OMP aggregate_FW) + !$OMP parallel do default(shared) do j=G%jsc, G%jec call extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & FluxRescaleDepth, useRiverHeatContent, useCalvingHeatContent,& @@ -891,7 +906,7 @@ subroutine calculateBuoyancyFlux1d(G, GV, US, fluxes, optics, nsw, h, Temp, Salt logical, optional, intent(in) :: skip_diags !< If present and true, skip calculating !! diagnostics inside extractFluxes1d() ! local variables - integer :: start, npts, k + integer :: k real, parameter :: dt = 1. ! to return a rate from extractFluxes1d real, dimension(SZI_(G)) :: netH ! net FW flux [H s-1 ~> m s-1 or kg m-2 s-1] real, dimension(SZI_(G)) :: netEvap ! net FW flux leaving ocean via evaporation @@ -899,7 +914,7 @@ subroutine calculateBuoyancyFlux1d(G, GV, US, fluxes, optics, nsw, h, Temp, Salt real, dimension(SZI_(G)) :: netHeat ! net temp flux [degC H s-1 ~> degC m s-2 or degC kg m-2 s-1] real, dimension(max(nsw,1), SZI_(G)) :: penSWbnd ! penetrating SW radiation by band ! [degC H ~> degC m or degC kg m-2] - real, dimension(SZI_(G)) :: pressure ! pressurea the surface [Pa] + 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 degC-1 ~> kg m-3 degC-1] real, dimension(SZI_(G)) :: dRhodS ! density partial derivative wrt saln [R ppt-1 ~> kg m-3 ppt-1] real, dimension(SZI_(G),SZK_(G)+1) :: netPen ! The net penetrating shortwave radiation at each level @@ -911,16 +926,16 @@ subroutine calculateBuoyancyFlux1d(G, GV, US, fluxes, optics, nsw, h, Temp, Salt real :: GoRho ! The gravitational acceleration divided by mean density times some ! unit conversion factors [L2 H-1 s R-1 T-3 ~> m4 kg-1 s-2 or m7 kg-2 s-2] real :: H_limit_fluxes ! Another depth scale [H ~> m or kg m-2] + integer :: i ! smg: what do we do when have heat fluxes from calving and river? useRiverHeatContent = .False. useCalvingHeatContent = .False. depthBeforeScalingFluxes = max( GV%Angstrom_H, 1.e-30*GV%m_to_H ) - pressure(:) = 0. ! Ignore atmospheric pressure + pressure(:) = 0. + if (associated(tv%p_surf)) then ; do i=G%isc,G%iec ; pressure(i) = tv%p_surf(i,j) ; enddo ; endif GoRho = (GV%g_Earth * GV%H_to_Z*US%T_to_s) / GV%Rho0 - start = 1 + G%isc - G%isd - npts = 1 + G%iec - G%isc H_limit_fluxes = depthBeforeScalingFluxes @@ -931,7 +946,7 @@ subroutine calculateBuoyancyFlux1d(G, GV, US, fluxes, optics, nsw, h, Temp, Salt ! netSalt = salt via surface fluxes [ppt H s-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 - call extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt*US%s_to_T, & + call extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt*US%s_to_T, & depthBeforeScalingFluxes, useRiverHeatContent, useCalvingHeatContent, & h(:,j,:), Temp(:,j,:), netH, netEvap, netHeatMinusSW, & netSalt, penSWbnd, tv, .false., skip_diags=skip_diags) @@ -942,8 +957,8 @@ subroutine calculateBuoyancyFlux1d(G, GV, US, fluxes, optics, nsw, h, Temp, Salt H_limit_fluxes, .true., penSWbnd, netPen) ! Density derivatives - call calculate_density_derivs(Temp(:,j,1), Salt(:,j,1), pressure, & - dRhodT, dRhodS, start, npts, tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density_derivs(Temp(:,j,1), Salt(:,j,1), pressure, dRhodT, dRhodS, & + tv%eqn_of_state, EOS_domain(G%HI)) ! Adjust netSalt to reflect dilution effect of FW flux netSalt(G%isc:G%iec) = netSalt(G%isc:G%iec) - Salt(G%isc:G%iec,j,1) * netH(G%isc:G%iec) ! ppt H/s @@ -1010,12 +1025,10 @@ subroutine MOM_forcing_chksum(mesg, fluxes, G, US, haloshift) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type integer, optional, intent(in) :: haloshift !< shift in halo - real :: RZ_T_conversion ! A combination of scaling factors for mass fluxes [kg T m-2 s-1 R-1 Z-1 ~> 1] integer :: is, ie, js, je, nz, hshift is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke hshift = 1 ; if (present(haloshift)) hshift = haloshift - RZ_T_conversion = US%RZ_T_to_kg_m2s ! 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 @@ -1025,7 +1038,7 @@ subroutine MOM_forcing_chksum(mesg, fluxes, G, US, haloshift) 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) + 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)) & @@ -1048,36 +1061,36 @@ subroutine MOM_forcing_chksum(mesg, fluxes, G, US, haloshift) 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) + 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=RZ_T_conversion) + 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=RZ_T_conversion) + 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=RZ_T_conversion) + 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=RZ_T_conversion) + 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=RZ_T_conversion) + 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) + call hchksum(fluxes%p_surf, mesg//" fluxes%p_surf", G%HI, haloshift=hshift , scale=US%RL2_T2_to_Pa) if (associated(fluxes%salt_flux)) & - call hchksum(fluxes%salt_flux, mesg//" fluxes%salt_flux",G%HI,haloshift=hshift, scale=RZ_T_conversion) + 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) + 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=RZ_T_conversion) + 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=RZ_T_conversion) + 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=RZ_T_conversion) + haloshift=hshift, scale=US%RZ_T_to_kg_m2s) 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) @@ -1116,14 +1129,14 @@ subroutine MOM_mech_forcing_chksum(mesg, forces, G, US, haloshift) ! 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%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L) + haloshift=hshift, symmetric=.true., scale=US%RZ_T_to_kg_m2s*US%L_T_to_m_s) if (associated(forces%p_surf)) & - call hchksum(forces%p_surf, mesg//" forces%p_surf",G%HI,haloshift=hshift) + 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) + call hchksum(forces%ustar, mesg//" forces%ustar", G%HI, haloshift=hshift, scale=US%Z_to_m*US%s_to_T) 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.) + 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) end subroutine MOM_mech_forcing_chksum @@ -1230,17 +1243,17 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, 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%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L, & + 'Pa', conversion=US%RZ_T_to_kg_m2s*US%L_T_to_m_s, & 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%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L, & - 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') + 'Pa', conversion=US%RZ_T_to_kg_m2s*US%L_T_to_m_s, & + 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_ustar = register_diag_field('ocean_model', 'ustar', diag%axesT1, Time, & 'Surface friction velocity = [(gustiness + tau_magnitude)/rho0]^(1/2)', & @@ -1255,7 +1268,7 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, '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') + '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) @@ -1265,9 +1278,10 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, endif endif - handles%id_psurf = register_diag_field('ocean_model', 'p_surf', diag%axesT1, Time, & - 'Pressure at ice-ocean or atmosphere-ocean interface', 'Pa', cmor_field_name='pso', & - cmor_long_name='Sea Water Pressure at Sea Water Surface', & + 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, & @@ -2049,7 +2063,6 @@ subroutine copy_common_forcing_fields(forces, fluxes, G, skip_pres) type(ocean_grid_type), intent(in) :: G !< grid type logical, optional, intent(in) :: skip_pres !< If present and true, do not copy pressure fields. - real :: taux2, tauy2 ! Squared wind stress components [Pa2]. logical :: do_pres integer :: i, j, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -2187,7 +2200,6 @@ subroutine copy_back_forcing_fields(fluxes, forces, G) type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces type(ocean_grid_type), intent(in) :: G !< grid type - real :: taux2, tauy2 ! Squared wind stress components [Pa2]. integer :: i, j, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -2201,8 +2213,8 @@ 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, dt, G, time_end, diag, handles) - type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces +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 [s] type(ocean_grid_type), intent(in) :: G !< grid type type(time_type), intent(in) :: time_end !< The end time of the diagnostic interval. @@ -2211,8 +2223,22 @@ subroutine mech_forcing_diags(forces, dt, G, time_end, diag, handles) integer :: i,j,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_averaging(dt, time_end, diag) ! if (query_averaging_enabled(diag)) then @@ -2232,37 +2258,57 @@ subroutine mech_forcing_diags(forces, dt, G, time_end, diag, handles) ! 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, sfc_state, G, US, time_end, diag, handles) - type(forcing), intent(in) :: fluxes !< A structure containing thermodynamic forcing fields +subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, handles) + 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), intent(in) :: G !< grid type + 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 ! local - real, dimension(SZI_(G),SZJ_(G)) :: res + 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 real :: total_transport ! for diagnosing integrated boundary transport real :: ave_flux ! for diagnosing averaged boundary flux - real :: C_p ! seawater heat capacity [J degC-1 kg-1] real :: RZ_T_conversion ! A combination of scaling factors for mass fluxes [kg T m-2 s-1 R-1 Z-1 ~> 1] - real :: I_dt ! inverse time step [s-1] + real :: I_dt ! inverse time step [T-1 ~> s-1] real :: ppt2mks ! conversion between ppt and mks + integer :: turns ! Number of index quarter turns integer :: i,j,is,ie,js,je call cpu_clock_begin(handles%id_clock_forcing) - C_p = US%Q_to_J_kg*fluxes%C_p + ! 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 + RZ_T_conversion = US%RZ_T_to_kg_m2s - I_dt = 1.0 / (US%T_to_s*fluxes%dt_buoy_accum) + I_dt = 1.0 / fluxes%dt_buoy_accum ppt2mks = 1e-3 is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -2289,7 +2335,7 @@ subroutine forcing_diagnostics(fluxes, sfc_state, G, US, time_end, diag, handles 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) + ave_flux = global_area_mean(res, G) call post_data(handles%id_prcme_ga, ave_flux, diag) endif endif @@ -2313,7 +2359,7 @@ subroutine forcing_diagnostics(fluxes, sfc_state, G, US, time_end, diag, handles 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) + total_transport = global_area_integral(res, G) call post_data(handles%id_total_net_massout, total_transport, diag) endif endif @@ -2349,7 +2395,7 @@ subroutine forcing_diagnostics(fluxes, sfc_state, G, US, time_end, diag, handles 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) + total_transport = global_area_integral(res, G) call post_data(handles%id_total_net_massin, total_transport, diag) endif endif @@ -2360,11 +2406,11 @@ subroutine forcing_diagnostics(fluxes, sfc_state, G, US, time_end, diag, handles 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=RZ_T_conversion) + 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, scale=RZ_T_conversion) + ave_flux = global_area_mean(fluxes%evap, G, scale=US%RZ_T_to_kg_m2s) call post_data(handles%id_evap_ga, ave_flux, diag) endif @@ -2374,11 +2420,11 @@ subroutine forcing_diagnostics(fluxes, sfc_state, G, US, time_end, diag, handles 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) + total_transport = global_area_integral(res, G) 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) + ave_flux = global_area_mean(res, G) call post_data(handles%id_precip_ga, ave_flux, diag) endif endif @@ -2386,11 +2432,11 @@ subroutine forcing_diagnostics(fluxes, sfc_state, G, US, time_end, diag, handles 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=RZ_T_conversion) + 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, scale=RZ_T_conversion) + ave_flux = global_area_mean(fluxes%lprec, G, scale=US%RZ_T_to_kg_m2s) call post_data(handles%id_lprec_ga, ave_flux, diag) endif endif @@ -2398,11 +2444,11 @@ subroutine forcing_diagnostics(fluxes, sfc_state, G, US, time_end, diag, handles 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=RZ_T_conversion) + 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, scale=RZ_T_conversion) + ave_flux = global_area_mean(fluxes%fprec, G, scale=US%RZ_T_to_kg_m2s) call post_data(handles%id_fprec_ga, ave_flux, diag) endif endif @@ -2410,11 +2456,11 @@ subroutine forcing_diagnostics(fluxes, sfc_state, G, US, time_end, diag, handles 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=RZ_T_conversion) + 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, scale=RZ_T_conversion) + ave_flux = global_area_mean(fluxes%vprec, G, scale=US%RZ_T_to_kg_m2s) call post_data(handles%id_vprec_ga, ave_flux, diag) endif endif @@ -2422,7 +2468,7 @@ subroutine forcing_diagnostics(fluxes, sfc_state, G, US, time_end, diag, handles 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=RZ_T_conversion) + 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 @@ -2430,7 +2476,7 @@ subroutine forcing_diagnostics(fluxes, sfc_state, G, US, time_end, diag, handles 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=RZ_T_conversion) + 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 @@ -2438,7 +2484,7 @@ subroutine forcing_diagnostics(fluxes, sfc_state, G, US, time_end, diag, handles 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=RZ_T_conversion) + 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 @@ -2497,7 +2543,7 @@ subroutine forcing_diagnostics(fluxes, sfc_state, G, US, time_end, diag, handles 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) + 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 @@ -2538,9 +2584,9 @@ subroutine forcing_diagnostics(fluxes, sfc_state, G, US, time_end, diag, handles 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) + US%W_m2_to_QRZ_T*sfc_state%frazil(i,j) * I_dt + if (allocated(sfc_state%frazil)) res(i,j) = res(i,j) + sfc_state%frazil(i,j) * I_dt !if (associated(sfc_state%TempXpme)) then - ! res(i,j) = res(i,j) + sfc_state%TempXpme(i,j) * US%Q_to_J_kg*fluxes%C_p * I_dt + ! res(i,j) = res(i,j) + sfc_state%TempXpme(i,j) * fluxes%C_p * I_dt !else if (associated(fluxes%heat_content_lrunoff)) & res(i,j) = res(i,j) + fluxes%heat_content_lrunoff(i,j) @@ -2577,7 +2623,7 @@ subroutine forcing_diagnostics(fluxes, sfc_state, G, US, time_end, diag, handles do j=js,je ; do i=is,ie res(i,j) = 0.0 ! if (associated(sfc_state%TempXpme)) then - ! res(i,j) = res(i,j) + sfc_state%TempXpme(i,j) * US%Q_to_J_kg*fluxes%C_p * I_dt + ! res(i,j) = res(i,j) + sfc_state%TempXpme(i,j) * fluxes%C_p * I_dt ! else 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) @@ -2748,21 +2794,21 @@ subroutine forcing_diagnostics(fluxes, sfc_state, G, US, time_end, diag, handles 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=RZ_T_conversion) + 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=RZ_T_conversion) + 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=RZ_T_conversion) + 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 @@ -2806,12 +2852,18 @@ subroutine forcing_diagnostics(fluxes, sfc_state, G, US, time_end, diag, handles ! 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_type(G, fluxes, water, heat, ustar, press, shelf, iceberg, salt, fix_accum_bug) +subroutine allocate_forcing_by_group(G, fluxes, water, heat, ustar, press, & + shelf, iceberg, salt, fix_accum_bug) 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 @@ -2879,11 +2931,61 @@ subroutine allocate_forcing_type(G, fluxes, water, heat, ustar, press, shelf, ic call myAlloc(fluxes%mass_berg,isd,ied,jsd,jed, iceberg) if (present(fix_accum_bug)) fluxes%gustless_accum_bug = .not.fix_accum_bug +end subroutine allocate_forcing_by_group + + +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_water, do_heat, do_salt, do_press, do_shelf, & + do_iceberg, do_heat_added, do_buoy + + call get_forcing_groups(fluxes_ref, do_water, do_heat, do_ustar, 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) + + ! 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 -end subroutine allocate_forcing_type -!> Conditionally allocate fields within the mechanical forcing type -subroutine allocate_mech_forcing(G, forces, stress, ustar, shelf, press, iceberg) +!> Conditionally allocate fields within the mechanical forcing type using +!! control flags. +subroutine allocate_mech_forcing_by_group(G, forces, stress, ustar, shelf, & + press, iceberg) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(mech_forcing), intent(inout) :: forces !< Forcing fields structure @@ -2917,8 +3019,82 @@ subroutine allocate_mech_forcing(G, forces, stress, ustar, shelf, press, iceberg !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) +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_shelf, do_press, do_iceberg + + ! Identify the active fields in the reference forcing + call get_mech_forcing_groups(forces_ref, do_stress, do_ustar, do_shelf, & + do_press, do_iceberg) + + call allocate_mech_forcing(G, forces, do_stress, do_ustar, do_shelf, & + do_press, do_iceberg) +end subroutine allocate_mech_forcing_from_ref + + +!> Return flags indicating which groups of forcings are allocated +subroutine get_forcing_groups(fluxes, water, heat, ustar, press, shelf, & + iceberg, salt, heat_added, buoy) + type(forcing), intent(in) :: fluxes !< Reference flux fields + logical, intent(out) :: water !< True if fluxes contains water-based fluxes + logical, intent(out) :: heat !< True if fluxes contains heat-based fluxes + logical, intent(out) :: ustar !< True if fluxes contains ustar fluxes + logical, intent(out) :: 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) + ! 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, 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) :: 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) + 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 -end subroutine allocate_mech_forcing !> Allocates and zeroes-out array. subroutine myAlloc(array, is, ie, js, je, flag) @@ -3006,6 +3182,181 @@ subroutine deallocate_mech_forcing(forces) 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 struct + type(forcing), intent(inout) :: fluxes !< Rotated forcing struct + integer, intent(in) :: turns !< Number of quarter turns + + logical :: do_ustar, do_water, do_heat, do_salt, do_press, do_shelf, & + do_iceberg, do_heat_added, do_buoy + + call get_forcing_groups(fluxes_in, do_water, do_heat, do_ustar, do_press, & + do_shelf, do_iceberg, do_salt, do_heat_added, do_buoy) + + if (do_ustar) then + call rotate_array(fluxes_in%ustar, turns, fluxes%ustar) + call rotate_array(fluxes_in%ustar_gustless, turns, fluxes%ustar_gustless) + endif + + 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) + call rotate_array(fluxes_in%netSalt, turns, fluxes%netSalt) + 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_icemelt, turns, fluxes%heat_content_icemelt) + 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) + 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 + + 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) + 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) + 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) + + ! TODO: tracer flux rotation + if (coupler_type_initialized(fluxes%tr_fluxes)) & + call MOM_error(FATAL, "Rotation of tracer BC fluxes not yet implemented.") + + ! 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_shelf, do_press, do_iceberg + + call get_mech_forcing_groups(forces_in, do_stress, do_ustar, do_shelf, & + do_press, do_iceberg) + + if (do_stress) & + call rotate_vector(forces_in%taux, forces_in%tauy, turns, & + forces%taux, forces%tauy) + + if (do_ustar) & + call rotate_array(forces_in%ustar, turns, forces%ustar) + + 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 + ! NOTE: p_surf_SSH either points to p_surf or p_surf_full + 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) + 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 + !> \namespace mom_forcing_type !! !! \section section_fluxes Boundary fluxes diff --git a/src/core/MOM_grid.F90 b/src/core/MOM_grid.F90 index f2c4a7d93b..8844c65f40 100644 --- a/src/core/MOM_grid.F90 +++ b/src/core/MOM_grid.F90 @@ -210,9 +210,10 @@ subroutine MOM_grid_init(G, param_file, US, HI, global_indexing, bathymetry_at_v ! Read all relevant parameters and write them to the model log. + call get_param(param_file, mod_nm, "REFERENCE_HEIGHT", G%Z_ref, default=0.0, do_not_log=.true.) call log_version(param_file, mod_nm, version, & - "Parameters providing information about the lateral grid.") - + "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, & diff --git a/src/core/MOM_interface_heights.F90 b/src/core/MOM_interface_heights.F90 index 8dbacf6798..b8cf161148 100644 --- a/src/core/MOM_interface_heights.F90 +++ b/src/core/MOM_interface_heights.F90 @@ -9,7 +9,7 @@ module MOM_interface_heights use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type -use MOM_EOS, only : int_specific_vol_dp +use MOM_density_integrals, only : int_specific_vol_dp implicit none ; private @@ -47,12 +47,13 @@ subroutine find_eta_3d(h, tv, G, GV, US, eta, eta_bt, halo_size, eta_to_m) !! the units of eta to m; by default this is US%Z_to_m. ! Local variables - real :: p(SZI_(G),SZJ_(G),SZK_(G)+1) ! Hydrostatic pressure at each interface [Pa] + real :: p(SZI_(G),SZJ_(G),SZK_(G)+1) ! Hydrostatic pressure at each interface [R L2 T-2 ~> Pa] real :: dz_geo(SZI_(G),SZJ_(G),SZK_(G)) ! The change in geopotential height - ! across a layer [m2 s-2]. + ! across a layer [L2 T-2 ~> m2 s-2]. real :: dilate(SZI_(G)) ! non-dimensional dilation factor real :: htot(SZI_(G)) ! total thickness [H ~> m or kg m-2] - real :: I_gEarth + 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 :: Z_to_eta, H_to_eta, H_to_rho_eta ! Unit conversion factors with obvious names. integer i, j, k, isv, iev, jsv, jev, nz, halo @@ -67,7 +68,7 @@ subroutine find_eta_3d(h, tv, G, GV, US, eta, eta_bt, halo_size, eta_to_m) Z_to_eta = 1.0 ; if (present(eta_to_m)) Z_to_eta = US%Z_to_m / eta_to_m H_to_eta = GV%H_to_Z * Z_to_eta H_to_rho_eta = GV%H_to_RZ * Z_to_eta - I_gEarth = Z_to_eta / (US%Z_to_m * GV%mks_g_Earth) + I_gEarth = Z_to_eta / GV%g_Earth !$OMP parallel default(shared) private(dilate,htot) !$OMP do @@ -96,16 +97,19 @@ subroutine find_eta_3d(h, tv, G, GV, US, eta, eta_bt, halo_size, eta_to_m) if (associated(tv%eqn_of_state)) then !$OMP do do j=jsv,jev - ! ### THIS SHOULD BE P_SURF, IF AVAILABLE. - do i=isv,iev ; p(i,j,1) = 0.0 ; enddo + 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%H_to_Pa*h(i,j,k) + 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, dz_geo(:,:,k), halo_size=halo) + 0.0, G%HI, tv%eqn_of_state, US, dz_geo(:,:,k), halo_size=halo) enddo !$OMP do do j=jsv,jev @@ -159,11 +163,12 @@ subroutine find_eta_2d(h, tv, G, GV, US, eta, eta_bt, halo_size, eta_to_m) !! the units of eta to m; by default this is US%Z_to_m. ! Local variables real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: & - p ! The pressure at interfaces [Pa]. + p ! Hydrostatic pressure at each interface [R L2 T-2 ~> Pa] real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & - dz_geo ! The change in geopotential height across a layer [m2 s-2]. + 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 + 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 :: Z_to_eta, H_to_eta, H_to_rho_eta ! Unit conversion factors with obvious names. integer i, j, k, is, ie, js, je, nz, halo @@ -174,7 +179,7 @@ subroutine find_eta_2d(h, tv, G, GV, US, eta, eta_bt, halo_size, eta_to_m) Z_to_eta = 1.0 ; if (present(eta_to_m)) Z_to_eta = US%Z_to_m / eta_to_m H_to_eta = GV%H_to_Z * Z_to_eta H_to_rho_eta = GV%H_to_RZ * Z_to_eta - I_gEarth = Z_to_eta / (US%Z_to_m * GV%mks_g_Earth) + I_gEarth = Z_to_eta / GV%g_Earth !$OMP parallel default(shared) private(htot) !$OMP do @@ -196,16 +201,20 @@ subroutine find_eta_2d(h, tv, G, GV, US, eta, eta_bt, halo_size, eta_to_m) if (associated(tv%eqn_of_state)) then !$OMP do do j=js,je - do i=is,ie ; p(i,j,1) = 0.0 ; enddo + 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%H_to_Pa*h(i,j,k) + 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, dz_geo(:,:,k), halo_size=halo) + G%HI, tv%eqn_of_state, US, dz_geo(:,:,k), halo_size=halo) enddo !$OMP do do j=js,je ; do k=1,nz ; do i=is,ie diff --git a/src/core/MOM_isopycnal_slopes.F90 b/src/core/MOM_isopycnal_slopes.F90 index fc60d54f10..c134366cd0 100644 --- a/src/core/MOM_isopycnal_slopes.F90 +++ b/src/core/MOM_isopycnal_slopes.F90 @@ -7,7 +7,9 @@ module MOM_isopycnal_slopes use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type -use MOM_EOS, only : int_specific_vol_dp, calculate_density_derivs +use MOM_EOS, only : calculate_density_derivs +use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE +use MOM_open_boundary, only : OBC_DIRECTION_E, OBC_DIRECTION_W, OBC_DIRECTION_N, OBC_DIRECTION_S implicit none ; private @@ -24,7 +26,7 @@ module MOM_isopycnal_slopes !> Calculate isopycnal slopes, and optionally return N2 used in calculation. subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & - slope_x, slope_y, N2_u, N2_v, halo) !, eta_to_m) + slope_x, slope_y, N2_u, N2_v, halo, OBC) !, eta_to_m) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -44,6 +46,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & optional, intent(inout) :: N2_v !< Brunt-Vaisala frequency squared at !! interfaces between u-points [T-2 ~> s-2] integer, optional, intent(in) :: halo !< Halo width over which to compute + type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. ! real, optional, intent(in) :: eta_to_m !< The conversion factor from the units ! (This argument has been tested but for now serves no purpose.) !! of eta to m; US%Z_to_m by default. @@ -55,7 +58,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & ! in massless layers filled vertically by diffusion. ! Rho ! Density itself, when a nonlinear equation of state is not in use [R ~> kg m-3]. real, dimension(SZI_(G), SZJ_(G), SZK_(G)+1) :: & - pres ! The pressure at an interface [Pa]. + pres ! The pressure at an interface [R L2 T-2 ~> Pa]. real, dimension(SZIB_(G)) :: & drho_dT_u, & ! The derivative of density with temperature at u points [R degC-1 ~> kg m-3 degC-1]. drho_dS_u ! The derivative of density with salinity at u points [R ppt-1 ~> kg m-3 ppt-1]. @@ -65,11 +68,11 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & real, dimension(SZIB_(G)) :: & T_u, & ! Temperature on the interface at the u-point [degC]. S_u, & ! Salinity on the interface at the u-point [ppt]. - pres_u ! Pressure on the interface at the u-point [Pa]. + 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 [degC]. S_v, & ! Salinity on the interface at the v-point [ppt]. - pres_v ! Pressure on the interface at the v-point [Pa]. + pres_v ! Pressure on the interface at the v-point [R L2 T-2 ~> Pa]. real :: drdiA, drdiB ! Along layer zonal- and meridional- potential density real :: drdjA, drdjB ! gradients in the layers above (A) and below (B) the ! interface times the grid spacing [R ~> kg m-3]. @@ -99,8 +102,11 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & real :: H_to_Z ! A conversion factor from thickness units to the units of e. logical :: present_N2_u, present_N2_v + integer, dimension(2) :: EOSdom_u, EOSdom_v ! Domains for the equation of state calculations at u and v points integer :: is, ie, js, je, nz, IsdB integer :: i, j, k + integer :: l_seg + logical :: local_open_u_BC, local_open_v_BC if (present(halo)) then is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo @@ -117,6 +123,13 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & L_to_Z = 1.0 / Z_to_L dz_neglect = GV%H_subroundoff * H_to_Z + local_open_u_BC = .false. + local_open_v_BC = .false. + if (present(OBC)) then ; if (associated(OBC)) then + local_open_u_BC = OBC%open_u_BCs_exist_globally + local_open_v_BC = OBC%open_v_BCs_exist_globally + endif ; endif + use_EOS = associated(tv%eqn_of_state) present_N2_u = PRESENT(N2_u) @@ -144,25 +157,34 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & endif ! Find the maximum and minimum permitted streamfunction. - !$OMP parallel do default(shared) - do j=js-1,je+1 ; do i=is-1,ie+1 - pres(i,j,1) = 0.0 ! ### This should be atmospheric pressure. - pres(i,j,2) = pres(i,j,1) + GV%H_to_Pa*h(i,j,1) - enddo ; enddo + 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=2,nz ; do i=is-1,ie+1 - pres(i,j,K+1) = pres(i,j,K) + GV%H_to_Pa*h(i,j,k) + 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, & - !$OMP h,h_neglect,e,dz_neglect,Z_to_L,L_to_Z,H_to_Z, & - !$OMP h_neglect2,present_N2_u,G_Rho0,N2_u,slope_x) & + EOSdom_u(1) = is-1 - (G%IsdB-1) ; EOSdom_u(2) = ie - (G%IsdB-1) + + !$OMP parallel do default(none) shared(nz,is,ie,js,je,IsdB,use_EOS,G,GV,US,pres,T,S,tv,h,e, & + !$OMP h_neglect,dz_neglect,Z_to_L,L_to_Z,H_to_Z,h_neglect2, & + !$OMP present_N2_u,G_Rho0,N2_u,slope_x,EOSdom_u,local_open_u_BC, & + !$OMP OBC) & !$OMP private(drdiA,drdiB,drdkL,drdkR,pres_u,T_u,S_u, & !$OMP drho_dT_u,drho_dS_u,hg2A,hg2B,hg2L,hg2R,haA, & !$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz, & - !$OMP drdx,mag_grad2,Slope,slope2_Ratio) + !$OMP drdx,mag_grad2,Slope,slope2_Ratio,l_seg) do j=js,je ; do K=nz,2,-1 if (.not.(use_EOS)) then drdiA = 0.0 ; drdiB = 0.0 @@ -176,8 +198,8 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & 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, (is-IsdB+1)-1, ie-is+2, tv%eqn_of_state, scale=US%kg_m3_to_R) + 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 @@ -233,23 +255,42 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & slope_x(I,j,K) = 0.0 endif - if (present_N2_u) N2_u(I,j,k) = G_Rho0 * drdz * G%mask2dCu(I,j) ! Square of Brunt-Vaisala frequency [s-2] + if (present_N2_u) N2_u(I,j,k) = G_Rho0 * drdz * G%mask2dCu(I,j) ! Square of buoyancy frequency [T-2 ~> s-2] else ! With .not.use_EOS, the layers are constant density. slope_x(I,j,K) = (Z_to_L*(e(i,j,K)-e(i+1,j,K))) * G%IdxCu(I,j) endif + if (local_open_u_BC) then + l_seg = OBC%segnum_u(I,j) + if (l_seg /= OBC_NONE) then + if (OBC%segment(l_seg)%open) then + slope_x(I,j,K) = 0. + ! This and/or the masking code below is to make slopes match inside + ! land mask. Might not be necessary except for DEBUG output. +! if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then +! slope_x(I+1,j,K) = 0. +! else +! slope_x(I-1,j,K) = 0. +! endif + endif + endif + slope_x(I,j,K) = slope_x(I,j,k) * max(g%mask2dT(i,j),g%mask2dT(i+1,j)) + endif enddo ! I enddo ; enddo ! end of j-loop + EOSdom_v(1) = is - (G%isd-1) ; EOSdom_v(2) = ie - (G%isd-1) + ! Calculate the meridional isopycnal slope. !$OMP parallel do default(none) shared(nz,is,ie,js,je,IsdB,use_EOS,G,GV,US,pres,T,S,tv, & !$OMP h,h_neglect,e,dz_neglect,Z_to_L,L_to_Z,H_to_Z, & - !$OMP h_neglect2,present_N2_v,G_Rho0,N2_v,slope_y) & + !$OMP h_neglect2,present_N2_v,G_Rho0,N2_v,slope_y,EOSdom_v, & + !$OMP local_open_v_BC,OBC) & !$OMP private(drdjA,drdjB,drdkL,drdkR,pres_v,T_v,S_v, & !$OMP drho_dT_v,drho_dS_v,hg2A,hg2B,hg2L,hg2R,haA, & !$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz, & - !$OMP drdy,mag_grad2,Slope,slope2_Ratio) + !$OMP drdy,mag_grad2,Slope,slope2_Ratio,l_seg) do j=js-1,je ; do K=nz,2,-1 if (.not.(use_EOS)) then drdjA = 0.0 ; drdjB = 0.0 @@ -262,8 +303,8 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & 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, is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) + 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 if (use_EOS) then @@ -317,11 +358,27 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & slope_y(i,J,K) = 0.0 endif - if (present_N2_v) N2_v(i,J,k) = G_Rho0 * drdz * G%mask2dCv(i,J) ! Square of Brunt-Vaisala frequency [s-2] + if (present_N2_v) N2_v(i,J,k) = G_Rho0 * drdz * G%mask2dCv(i,J) ! Square of buoyancy frequency [T-2 ~> s-2] else ! With .not.use_EOS, the layers are constant density. slope_y(i,J,K) = (Z_to_L*(e(i,j,K)-e(i,j+1,K))) * G%IdyCv(i,J) endif + if (local_open_v_BC) then + l_seg = OBC%segnum_v(i,J) + if (l_seg /= OBC_NONE) then + if (OBC%segment(l_seg)%open) then + slope_y(i,J,K) = 0. + ! This and/or the masking code below is to make slopes match inside + ! land mask. Might not be necessary except for DEBUG output. +! if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then +! slope_y(i,J+1,K) = 0. +! else +! slope_y(i,J-1,K) = 0. +! endif + endif + endif + slope_y(i,J,K) = slope_y(i,J,k) * max(g%mask2dT(i,j),g%mask2dT(i,j+1)) + endif enddo ! i enddo ; enddo ! end of j-loop diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 3b1559ab81..2320c7d78a 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -3,11 +3,13 @@ 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 use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE use MOM_diag_mediator, only : diag_ctrl, time_type use MOM_domains, only : pass_var, pass_vector -use MOM_domains, only : To_All, SCALAR_PAIR, CGRID_NE +use MOM_domains, only : To_All, SCALAR_PAIR, CGRID_NE, CORNER use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, is_root_pe use MOM_error_handler, only : NOTE use MOM_file_parser, only : get_param, log_version, param_file_type, log_param @@ -16,7 +18,8 @@ module MOM_open_boundary use MOM_io, only : EAST_FACE, NORTH_FACE use MOM_io, only : slasher, read_data, field_size, SINGLE_FILE use MOM_io, only : vardesc, query_vardesc, var_desc -use MOM_restart, only : register_restart_field, query_initialized, MOM_restart_CS +use MOM_restart, only : register_restart_field, register_restart_pair +use MOM_restart, only : query_initialized, MOM_restart_CS use MOM_obsolete_params, only : obsolete_logical, obsolete_int, obsolete_real, obsolete_char use MOM_string_functions, only : extract_word, remove_spaces use MOM_time_manager, only : time_type, time_type_to_real, operator(-) @@ -57,6 +60,9 @@ module MOM_open_boundary public open_boundary_register_restarts public update_segment_tracer_reservoirs public update_OBC_ramp +public rotate_OBC_config +public rotate_OBC_init +public initialize_segment_data integer, parameter, public :: OBC_NONE = 0 !< Indicates the use of no open boundary integer, parameter, public :: OBC_SIMPLE = 1 !< Indicates the use of a simple inflow open boundary @@ -74,11 +80,11 @@ module MOM_open_boundary integer :: fid !< handle from FMS associated with segment data on disk integer :: fid_dz !< handle from FMS associated with segment thicknesses on disk character(len=8) :: name !< a name identifier for the segment data - real, pointer, dimension(:,:,:) :: buffer_src=>NULL() !< buffer for segment data located at cell faces + real, dimension(:,:,:), allocatable :: buffer_src !< buffer for segment data located at cell faces !! and on the original vertical grid integer :: nk_src !< Number of vertical levels in the source data - real, dimension(:,:,:), pointer :: dz_src=>NULL() !< vertical grid cell spacing of the incoming segment - !! data, set in [Z ~> m] then scaled to [H ~> m or kg m-2] + real, dimension(:,:,:), allocatable :: dz_src !< vertical grid cell spacing of the incoming segment + !! data, set in [Z ~> m] then scaled to [H ~> m or kg m-2] real, dimension(:,:,:), pointer :: buffer_dst=>NULL() !< buffer src data remapped to the target vertical grid real, dimension(:,:), pointer :: bt_vel=>NULL() !< barotropic velocity [L T-1 ~> m s-1] real :: value !< constant value if fid is equal to -1 @@ -240,7 +246,6 @@ module MOM_open_boundary 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. - real :: g_Earth !< The gravitational acceleration [m s-2]. logical, pointer, dimension(:) :: & tracer_x_reservoirs_used => NULL() !< Dimensioned by the number of tracers, set globally, !! true for those with x reservoirs (needed for restarts). @@ -261,12 +266,10 @@ module MOM_open_boundary !! 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, with a default of 0.3. - real :: rx_max !< The maximum magnitude of the baroclinic radiation - !! velocity (or speed of characteristics) [m s-1]. The - !! default value is 10 m s-1. - !### The description above seems inconsistent with the code, and the units should be [nondim]. + real :: rx_max !< The maximum magnitude of the baroclinic radiation velocity (or speed of + !! characteristics) in units of grid points per timestep [nondim]. logical :: OBC_pe !< Is there an open boundary on this tile? - type(remapping_CS), pointer :: remap_CS !< ALE remapping control structure for segments only + type(remapping_CS), pointer :: remap_CS=> NULL() !< ALE remapping control structure for segments only type(OBC_registry_type), pointer :: OBC_Reg => NULL() !< Registry type for boundaries real, pointer, dimension(:,:,:) :: & rx_normal => NULL(), & !< Array storage for normal phase speed for EW radiation OBCs in units of @@ -339,17 +342,22 @@ subroutine open_boundary_config(G, US, param_file, OBC) character(len=100) :: segment_str ! The contents (rhs) for parameter "segment_param_str" character(len=200) :: config1 ! String for OBC_USER_CONFIG real :: Lscale_in, Lscale_out ! parameters controlling tracer values at the boundaries [L ~> m] + character(len=128) :: inputdir + logical :: answers_2018, default_2018_answers + logical :: check_reconstruction, check_remapping, force_bounds_in_subcell + character(len=32) :: remappingScheme + allocate(OBC) + call get_param(param_file, mdl, "OBC_NUMBER_OF_SEGMENTS", OBC%number_of_segments, & + 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.") + "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, "G_EARTH", OBC%g_Earth, & - "The gravitational acceleration of the Earth.", & - units="m s-2", default = 9.80) call get_param(param_file, mdl, "OBC_USER_CONFIG", config1, & "A string that sets how the open boundary conditions are "//& " configured: \n", default="none", do_not_log=.true.) @@ -443,9 +451,8 @@ subroutine open_boundary_config(G, US, param_file, OBC) call get_param(param_file, mdl, "REENTRANT_Y", reentrant_y, default=.false.) ! Allocate everything - ! Note the 0-segment is needed when %segnum_u/v(:,:) = 0 - allocate(OBC%segment(0:OBC%number_of_segments)) - do l=0,OBC%number_of_segments + allocate(OBC%segment(1:OBC%number_of_segments)) + do l=1,OBC%number_of_segments OBC%segment(l)%Flather = .false. OBC%segment(l)%radiation = .false. OBC%segment(l)%radiation_tan = .false. @@ -496,16 +503,14 @@ subroutine open_boundary_config(G, US, param_file, OBC) enddo ! if (open_boundary_query(OBC, needs_ext_seg_data=.true.)) & - call initialize_segment_data(G, OBC, param_file) + ! call initialize_segment_data(G, OBC, param_file) if (open_boundary_query(OBC, apply_open_OBC=.true.)) then - !### I think that OBC%rx_max as used is actually nondimensional, with effective - ! units of grid points per time step. call get_param(param_file, mdl, "OBC_RADIATION_MAX", OBC%rx_max, & - "The maximum magnitude of the baroclinic radiation "//& - "velocity (or speed of characteristics). This is only "//& + "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="m s-1", default=10.0) !### Should the units here be "nondim"? + 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 "//& @@ -541,6 +546,39 @@ subroutine open_boundary_config(G, US, param_file, OBC) if (Lscale_out>0.) OBC%segment(l)%Tr_InvLscale_out = 1.0/Lscale_out enddo + call get_param(param_file, mdl, "REMAPPING_SCHEME", remappingScheme, & + "This sets the reconstruction scheme used "//& + "for vertical remapping for all variables. "//& + "It can be one of the following schemes: \n"//& + trim(remappingSchemesDoc), default=remappingDefaultScheme,do_not_log=.true.) + call get_param(param_file, mdl, "FATAL_CHECK_RECONSTRUCTIONS", check_reconstruction, & + "If true, cell-by-cell reconstructions are checked for "//& + "consistency and if non-monotonicity or an inconsistency is "//& + "detected then a FATAL error is issued.", default=.false.,do_not_log=.true.) + call get_param(param_file, mdl, "FATAL_CHECK_REMAPPING", check_remapping, & + "If true, the results of remapping are checked for "//& + "conservation and new extrema and if an inconsistency is "//& + "detected then a FATAL error is issued.", default=.false.,do_not_log=.true.) + call get_param(param_file, mdl, "BRUSHCUTTER_MODE", OBC%brushcutter_mode, & + "If true, read external OBC data on the supergrid.", & + default=.false.) + call get_param(param_file, mdl, "REMAP_BOUND_INTERMEDIATE_VALUES", force_bounds_in_subcell, & + "If true, the values on the intermediate grid used for remapping "//& + "are forced to be bounded, which might not be the case due to "//& + "round off.", default=.false.,do_not_log=.true.) + call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & + "This sets the default value for the various _2018_ANSWERS parameters.", & + default=.false.) + call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", answers_2018, & + "If true, use the order of arithmetic and expressions that recover the "//& + "answers from the end of 2018. Otherwise, use updated and more robust "//& + "forms of the same expressions.", default=default_2018_answers) + + allocate(OBC%remap_CS) + call initialize_remapping(OBC%remap_CS, remappingScheme, boundary_extrapolation = .false., & + check_reconstruction=check_reconstruction, check_remapping=check_remapping, & + force_bounds_in_subcell=force_bounds_in_subcell, answers_2018=answers_2018) + endif ! OBC%number_of_segments > 0 ! Safety check @@ -565,7 +603,7 @@ end subroutine open_boundary_config subroutine initialize_segment_data(G, OBC, PF) use mpp_mod, only : mpp_pe, mpp_set_current_pelist, mpp_get_current_pelist,mpp_npes - type(dyn_horgrid_type), intent(in) :: G !< Ocean grid structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(ocean_OBC_type), intent(inout) :: OBC !< Open boundary control structure type(param_file_type), intent(in) :: PF !< Parameter file handle @@ -577,10 +615,7 @@ subroutine initialize_segment_data(G, OBC, PF) character(len=32), dimension(MAX_OBC_FIELDS) :: fields ! segment field names character(len=128) :: inputdir type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list - character(len=32) :: remappingScheme character(len=256) :: mesg ! Message for error messages. - logical :: check_reconstruction, check_remapping, force_bounds_in_subcell - logical :: answers_2018, default_2018_answers integer, dimension(4) :: siz,siz2 integer :: is, ie, js, je integer :: isd, ied, jsd, jed @@ -600,39 +635,6 @@ subroutine initialize_segment_data(G, OBC, PF) call get_param(PF, mdl, "INPUTDIR", inputdir, default=".") inputdir = slasher(inputdir) - call get_param(PF, mdl, "REMAPPING_SCHEME", remappingScheme, & - "This sets the reconstruction scheme used "//& - "for vertical remapping for all variables. "//& - "It can be one of the following schemes: \n"//& - trim(remappingSchemesDoc), default=remappingDefaultScheme,do_not_log=.true.) - call get_param(PF, mdl, "FATAL_CHECK_RECONSTRUCTIONS", check_reconstruction, & - "If true, cell-by-cell reconstructions are checked for "//& - "consistency and if non-monotonicity or an inconsistency is "//& - "detected then a FATAL error is issued.", default=.false.,do_not_log=.true.) - call get_param(PF, mdl, "FATAL_CHECK_REMAPPING", check_remapping, & - "If true, the results of remapping are checked for "//& - "conservation and new extrema and if an inconsistency is "//& - "detected then a FATAL error is issued.", default=.false.,do_not_log=.true.) - call get_param(PF, mdl, "REMAP_BOUND_INTERMEDIATE_VALUES", force_bounds_in_subcell, & - "If true, the values on the intermediate grid used for remapping "//& - "are forced to be bounded, which might not be the case due to "//& - "round off.", default=.false.,do_not_log=.true.) - call get_param(PF, mdl, "BRUSHCUTTER_MODE", OBC%brushcutter_mode, & - "If true, read external OBC data on the supergrid.", & - default=.false.) - call get_param(PF, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=.true.) - call get_param(PF, mdl, "REMAPPING_2018_ANSWERS", answers_2018, & - "If true, use the order of arithmetic and expressions that recover the "//& - "answers from the end of 2018. Otherwise, use updated and more robust "//& - "forms of the same expressions.", default=default_2018_answers) - - allocate(OBC%remap_CS) - call initialize_remapping(OBC%remap_CS, remappingScheme, boundary_extrapolation = .false., & - check_reconstruction=check_reconstruction, check_remapping=check_remapping, & - force_bounds_in_subcell=force_bounds_in_subcell, answers_2018=answers_2018) - if (OBC%user_BCs_set_globally) return ! Try this here just for the documentation. It is repeated below. @@ -667,7 +669,7 @@ subroutine initialize_segment_data(G, OBC, PF) call MOM_error(FATAL, mesg) endif - call parse_segment_data_str(trim(segstr), fields=fields, num_fields=num_fields) + 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 @@ -688,7 +690,8 @@ subroutine initialize_segment_data(G, OBC, PF) JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB do m=1,num_fields - call parse_segment_data_str(trim(segstr), var=trim(fields(m)), value=value, filenam=filename, fieldnam=fieldname) + call parse_segment_data_str(trim(segstr), m, trim(fields(m)), & + value, filename, fieldname) 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 @@ -836,53 +839,116 @@ subroutine setup_segment_indices(G, seg, Is_obc, Ie_obc, Js_obc, Je_obc) 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 :: Isg,Ieg,Jsg,Jeg + integer :: IsgB, IegB, JsgB, JegB + integer :: isg, ieg, jsg, jeg ! Isg, Ieg will be I*_obc in global space - if (Ie_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 = Isg ; seg%HI%IegB = Ieg - seg%HI%isg = Isg+1 ; seg%HI%ieg = Ieg - seg%HI%JsgB = Jsg ; seg%HI%JegB = Jeg - seg%HI%jsg = Jsg+1 ; seg%HI%Jeg = Jeg + 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 - Isg = Isg - G%idg_offset - Jsg = Jsg - G%jdg_offset - Ieg = Ieg - G%idg_offset - Jeg = Jeg - G%jdg_offset + 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(Isg, G%HI%IsdB), G%HI%IedB) - seg%HI%IedB = min( max(Ieg, G%HI%IsdB), G%HI%IedB) - seg%HI%isd = min( max(Isg+1, G%HI%isd), G%HI%ied) - seg%HI%ied = min( max(Ieg, G%HI%isd), G%HI%ied) - seg%HI%IscB = min( max(Isg, G%HI%IscB), G%HI%IecB) - seg%HI%IecB = min( max(Ieg, G%HI%IscB), G%HI%IecB) - seg%HI%isc = min( max(Isg+1, G%HI%isc), G%HI%iec) - seg%HI%iec = min( max(Ieg, G%HI%isc), G%HI%iec) + 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(Jsg, G%HI%JsdB), G%HI%JedB) - seg%HI%JedB = min( max(Jeg, G%HI%JsdB), G%HI%JedB) - seg%HI%jsd = min( max(Jsg+1, G%HI%jsd), G%HI%jed) - seg%HI%jed = min( max(Jeg, G%HI%jsd), G%HI%jed) - seg%HI%JscB = min( max(Jsg, G%HI%JscB), G%HI%JecB) - seg%HI%JecB = min( max(Jeg, G%HI%JscB), G%HI%JecB) - seg%HI%jsc = min( max(Jsg+1, G%HI%jsc), G%HI%jec) - seg%HI%jec = min( max(Jeg, G%HI%jsc), G%HI%jec) + 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 @@ -1279,92 +1345,73 @@ integer function interpret_int_expr(string, imax) end function interpret_int_expr end subroutine parse_segment_str -!> Parse an OBC_SEGMENT_%%%_DATA string - subroutine parse_segment_data_str(segment_str, var, value, filenam, fieldnam, fields, num_fields, debug ) - character(len=*), intent(in) :: segment_str !< A string in form of - !! "VAR1=file:foo1.nc(varnam1),VAR2=file:foo2.nc(varnam2),..." - character(len=*), optional, intent(in) :: var !< The name of the variable for which parameters are needed - character(len=*), optional, intent(out) :: filenam !< The name of the input file if using "file" method - character(len=*), optional, intent(out) :: fieldnam !< 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 - character(len=*), dimension(MAX_OBC_FIELDS), & - optional, intent(out) :: fields !< List of fieldnames for each segment - integer, optional, intent(out) :: num_fields !< The number of fields in the segment data - logical, optional, intent(in) :: debug !< If present and true, write verbose debugging messages - ! Local variables - character(len=128) :: word1, word2, word3, method - integer :: lword, nfields, n, m - logical :: continue,dbg - character(len=32), dimension(MAX_OBC_FIELDS) :: flds - nfields=0 - continue=.true. - dbg=.false. - if (PRESENT(debug)) dbg=debug - - do while (continue) - word1 = extract_word(segment_str,',',nfields+1) - if (trim(word1) == '') exit - nfields=nfields+1 - word2 = extract_word(word1,'=',1) - flds(nfields) = trim(word2) - enddo +!> 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 - if (PRESENT(fields)) then - do n=1,nfields - fields(n) = flds(n) - enddo - endif + ! 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 - if (PRESENT(num_fields)) then - num_fields=nfields - return - endif - m=0 - if (PRESENT(var)) then - do n=1,nfields - if (trim(var)==trim(flds(n))) then - m=n - exit - endif - enddo - if (m==0) then - call abort() - endif +!> 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 - ! Process first word which will start with the fieldname - word3 = extract_word(segment_str,',',m) - 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) - filenam = extract_word(word1,'(',1) - fieldnam = extract_word(word1,'(',2) - lword=len_trim(fieldnam) - fieldnam = fieldnam(1:lword-1) ! remove trailing parenth - value=-999. - elseif (method(lword-4:lword) == 'value') then - filenam = 'none' - fieldnam = 'none' - word1 = extract_word(word3,':',2) - lword=len_trim(word1) - read(word1(1:lword),*,end=986,err=987) value - endif - endif + ! 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 + 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 @@ -1393,12 +1440,13 @@ subroutine parse_for_tracer_reservoirs(OBC, PF, use_temperature) call get_param(PF, mdl, segnam, segstr) if (segstr == '') cycle - call parse_segment_data_str(trim(segstr), fields=fields, num_fields=num_fields) + 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), var=trim(fields(m)), value=value, filenam=filename, fieldnam=fieldname) + 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 @@ -1527,7 +1575,7 @@ subroutine open_boundary_init(G, GV, US, param_file, OBC, restart_CSp) ! Local variables real :: vel2_rescale ! A rescaling factor for squared velocities from the representation in ! a restart file to the internal representation in this run. - integer :: i, j, k, isd, ied, jsd, jed, nz + integer :: i, j, k, isd, ied, jsd, jed, nz, m integer :: IsdB, IedB, JsdB, JedB isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB @@ -1535,6 +1583,24 @@ subroutine open_boundary_init(G, GV, US, param_file, OBC, restart_CSp) if (.not.associated(OBC)) return id_clock_pass = cpu_clock_id('(Ocean OBC halo updates)', grain=CLOCK_ROUTINE) + if (OBC%radiation_BCs_exist_globally) call pass_vector(OBC%rx_normal, OBC%ry_normal, G%Domain, & + To_All+Scalar_Pair) + if (OBC%oblique_BCs_exist_globally) call pass_vector(OBC%rx_oblique, OBC%ry_oblique, G%Domain, & + To_All+Scalar_Pair) + if (associated(OBC%cff_normal)) call pass_var(OBC%cff_normal, G%Domain, position=CORNER) + if (associated(OBC%tres_x) .and. associated(OBC%tres_y)) then + do m=1,OBC%ntr + call pass_vector(OBC%tres_x(:,:,:,m), OBC%tres_y(:,:,:,m), G%Domain, To_All+Scalar_Pair) + enddo + elseif (associated(OBC%tres_x)) then + do m=1,OBC%ntr + call pass_var(OBC%tres_x(:,:,:,m), G%Domain, position=EAST_FACE) + enddo + elseif (associated(OBC%tres_y)) then + do m=1,OBC%ntr + call pass_var(OBC%tres_y(:,:,:,m), G%Domain, position=NORTH_FACE) + enddo + endif ! The rx_normal and ry_normal arrays used with radiation OBCs are currently in units of grid ! points per timestep, but if this were to be corrected to [L T-1 ~> m s-1] or [T-1 ~> s-1] to @@ -1740,9 +1806,9 @@ subroutine open_boundary_impose_land_mask(OBC, G, areaCu, areaCv, US) 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] + 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] + areaCu(I,j) = G%areaT(i+1,j) ! Both of these are in [L2 ~> m2] endif enddo else @@ -1750,9 +1816,9 @@ subroutine open_boundary_impose_land_mask(OBC, G, areaCu, areaCv, US) 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] + areaCv(i,J) = G%areaT(i,j+1) ! Both of these are in [L2 ~> m2] else ! North - areaCu(i,J) = G%areaT(i,j) ! Both of these are in [L2] + areaCu(i,J) = G%areaT(i,j) ! Both of these are in [L2 ~> m2] endif enddo endif @@ -1787,7 +1853,7 @@ end subroutine open_boundary_impose_land_mask !> Make sure the OBC tracer reservoirs are initialized. subroutine setup_OBC_tracer_reservoirs(G, OBC) - type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure ! Local variables type(OBC_segment_type), pointer :: segment => NULL() @@ -1842,7 +1908,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) 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] or [L2 T-2 ~> m2 s-2] + 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] @@ -3453,23 +3519,28 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) character(len=200) :: filename, OBC_file, inputdir ! Strings for file/path type(OBC_segment_type), pointer :: segment => NULL() integer, dimension(4) :: siz + real, dimension(:,:,:), pointer :: tmp_buffer_in => NULL() ! Unrotated input 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 :: i2, j2 ! indices for referencing local domain array integer :: is_obc, ie_obc, js_obc, je_obc ! segment indices within local domain integer :: ishift, jshift ! offsets for staggered locations real, dimension(:,:), pointer :: seg_vel => NULL() ! pointer to segment velocity array real, dimension(:,:), pointer :: seg_trans => NULL() ! pointer to segment transport array - real, dimension(:,:,:), allocatable :: tmp_buffer + real, dimension(:,:,:), allocatable, target :: tmp_buffer real, dimension(:), allocatable :: h_stack integer :: is_obc2, js_obc2 real :: net_H_src, net_H_int, scl_fac real, pointer, dimension(:,:) :: normal_trans_bt=>NULL() ! barotropic transport + integer :: turns ! Number of index quarter 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 IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB nz=G%ke + turns = G%HI%turns + if (.not. associated(OBC)) return do n = 1, OBC%number_of_segments @@ -3477,6 +3548,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) 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) @@ -3580,6 +3652,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) 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 currrently on supergrid @@ -3594,7 +3667,44 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) endif endif - call time_interp_external(segment%field(m)%fid,Time, tmp_buffer) + ! 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_external. + ! 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 + + call time_interp_external(segment%field(m)%fid,Time, tmp_buffer_in) + ! 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 == '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 + + ! 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') 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') then @@ -3629,7 +3739,21 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) endif endif if (segment%field(m)%nk_src > 1) then - call time_interp_external(segment%field(m)%fid_dz,Time, tmp_buffer) + call time_interp_external(segment%field(m)%fid_dz,Time, tmp_buffer_in) + 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 @@ -3763,6 +3887,8 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) 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 ! fid <= 0 (Uniform value) if (.not. associated(segment%field(m)%buffer_dst)) then if (segment%is_E_or_W) then @@ -3814,7 +3940,8 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) G%dyCu(I,j) normal_trans_bt(I,j) = normal_trans_bt(I,j) + segment%normal_trans(I,j,k) enddo - segment%normal_vel_bt(I,j) = normal_trans_bt(I,j) / (max(segment%Htot(I,j),1.e-12) * G%dyCu(I,j)) + segment%normal_vel_bt(I,j) = normal_trans_bt(I,j) & + / (max(segment%Htot(I,j), 1.e-12 * GV%m_to_H) * G%dyCu(I,j)) if (associated(segment%nudged_normal_vel)) segment%nudged_normal_vel(I,j,:) = segment%normal_vel(I,j,:) enddo elseif (trim(segment%field(m)%name) == 'V' .and. segment%is_N_or_S) then @@ -3827,7 +3954,8 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) G%dxCv(i,J) normal_trans_bt(i,J) = normal_trans_bt(i,J) + segment%normal_trans(i,J,k) enddo - segment%normal_vel_bt(i,J) = normal_trans_bt(i,J) / (max(segment%Htot(i,J),1.e-12) * G%dxCv(i,J)) + segment%normal_vel_bt(i,J) = normal_trans_bt(i,J) & + / (max(segment%Htot(i,J), 1.e-12 * GV%m_to_H) * G%dxCv(i,J)) if (associated(segment%nudged_normal_vel)) segment%nudged_normal_vel(i,J,:) = segment%normal_vel(i,J,:) enddo elseif (trim(segment%field(m)%name) == 'V' .and. segment%is_E_or_W .and. & @@ -3895,13 +4023,14 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) if (OBC%ramp) then do j=js_obc2,je_obc do i=is_obc2,ie_obc - segment%eta(i,j) = OBC%ramp_value * segment%field(m)%buffer_dst(i,j,1) + segment%eta(i,j) = GV%m_to_H * OBC%ramp_value & + * segment%field(m)%buffer_dst(i,j,1) enddo enddo else do j=js_obc2,je_obc do i=is_obc2,ie_obc - segment%eta(i,j) = segment%field(m)%buffer_dst(i,j,1) + segment%eta(i,j) = GV%m_to_H * segment%field(m)%buffer_dst(i,j,1) enddo enddo endif @@ -4214,7 +4343,7 @@ subroutine register_temp_salt_segments(GV, OBC, tr_Reg, param_file) end subroutine register_temp_salt_segments subroutine fill_temp_salt_segments(G, OBC, tv) - type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(ocean_OBC_type), pointer :: OBC !< Open boundary structure type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamics structure @@ -4268,6 +4397,7 @@ subroutine fill_temp_salt_segments(G, OBC, tv) 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, OBC) end subroutine fill_temp_salt_segments @@ -4283,6 +4413,7 @@ subroutine mask_outside_OBCs(G, US, param_file, OBC) ! Local variables integer :: isd, ied, IsdB, IedB, jsd, jed, JsdB, JedB, n integer :: i, j + integer :: l_seg logical :: fatal_error = .False. real :: min_depth integer, parameter :: cin = 3, cout = 4, cland = -1, cedge = -2 @@ -4324,38 +4455,50 @@ subroutine mask_outside_OBCs(G, US, param_file, OBC) enddo do j=G%jsd,G%jed ; do i=G%IsdB+1,G%IedB-1 - if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) then + l_seg = OBC%segnum_u(I,j) + if (l_seg == OBC_NONE) cycle + + if (OBC%segment(l_seg)%direction == OBC_DIRECTION_W) then if (color(i,j) == 0.0) color(i,j) = cout if (color(i+1,j) == 0.0) color(i+1,j) = cin - elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then + elseif (OBC%segment(l_seg)%direction == OBC_DIRECTION_E) then if (color(i,j) == 0.0) color(i,j) = cin if (color(i+1,j) == 0.0) color(i+1,j) = cout endif enddo ; enddo do J=G%JsdB+1,G%JedB-1 ; do i=G%isd,G%ied - if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then + l_seg = OBC%segnum_v(i,J) + if (l_seg == OBC_NONE) cycle + + if (OBC%segment(l_seg)%direction == OBC_DIRECTION_S) then if (color(i,j) == 0.0) color(i,j) = cout if (color(i,j+1) == 0.0) color(i,j+1) = cin - elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then + elseif (OBC%segment(l_seg)%direction == OBC_DIRECTION_N) then if (color(i,j) == 0.0) color(i,j) = cin if (color(i,j+1) == 0.0) color(i,j+1) = cout endif enddo ; enddo do J=G%JsdB+1,G%JedB-1 ; do i=G%isd,G%ied - if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then + l_seg = OBC%segnum_v(i,J) + if (l_seg == OBC_NONE) cycle + + if (OBC%segment(l_seg)%direction == OBC_DIRECTION_S) then if (color2(i,j) == 0.0) color2(i,j) = cout if (color2(i,j+1) == 0.0) color2(i,j+1) = cin - elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then + elseif (OBC%segment(l_seg)%direction == OBC_DIRECTION_N) then if (color2(i,j) == 0.0) color2(i,j) = cin if (color2(i,j+1) == 0.0) color2(i,j+1) = cout endif enddo ; enddo do j=G%jsd,G%jed ; do i=G%IsdB+1,G%IedB-1 - if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) then + l_seg = OBC%segnum_u(I,j) + if (l_seg == OBC_NONE) cycle + + if (OBC%segment(l_seg)%direction == OBC_DIRECTION_W) then if (color2(i,j) == 0.0) color2(i,j) = cout if (color2(i+1,j) == 0.0) color2(i+1,j) = cin - elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then + elseif (OBC%segment(l_seg)%direction == OBC_DIRECTION_E) then if (color2(i,j) == 0.0) color2(i,j) = cin if (color2(i+1,j) == 0.0) color2(i+1,j) = cout endif @@ -4513,7 +4656,7 @@ subroutine open_boundary_register_restarts(HI, GV, OBC, Reg, param_file, restart type(MOM_restart_CS), pointer :: restart_CSp !< Restart structure, data intent(inout) logical, intent(in) :: use_temperature !< If true, T and S are used ! Local variables - type(vardesc) :: vd + type(vardesc) :: vd(2) integer :: m, n character(len=100) :: mesg type(OBC_segment_type), pointer :: segment=>NULL() @@ -4537,27 +4680,31 @@ subroutine open_boundary_register_restarts(HI, GV, OBC, Reg, param_file, restart ! 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)) - OBC%rx_normal(:,:,:) = 0.0 - vd = var_desc("rx_normal", "m s-1", "Normal Phase Speed for EW radiation OBCs", 'u', 'L') - call register_restart_field(OBC%rx_normal, vd, .false., restart_CSp) allocate(OBC%ry_normal(HI%isd:HI%ied,HI%jsdB:HI%jedB,GV%ke)) + OBC%rx_normal(:,:,:) = 0.0 OBC%ry_normal(:,:,:) = 0.0 - vd = var_desc("ry_normal", "m s-1", "Normal Phase Speed for NS radiation OBCs", 'v', 'L') - call register_restart_field(OBC%ry_normal, vd, .false., restart_CSp) + + 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_CSp) endif + if (OBC%oblique_BCs_exist_globally) then allocate(OBC%rx_oblique(HI%isdB:HI%iedB,HI%jsd:HI%jed,GV%ke)) - OBC%rx_oblique(:,:,:) = 0.0 - vd = var_desc("rx_oblique", "m2 s-2", "Radiation Speed Squared for EW oblique OBCs", 'u', 'L') - call register_restart_field(OBC%rx_oblique, vd, .false., restart_CSp) allocate(OBC%ry_oblique(HI%isd:HI%ied,HI%jsdB:HI%jedB,GV%ke)) + OBC%rx_oblique(:,:,:) = 0.0 OBC%ry_oblique(:,:,:) = 0.0 - vd = var_desc("ry_oblique", "m2 s-2", "Radiation Speed Squared for NS oblique OBCs", 'v', 'L') - call register_restart_field(OBC%ry_oblique, vd, .false., restart_CSp) + + vd(1) = var_desc("rx_oblique", "m2 s-2", "Radiation Speed Squared for EW oblique OBCs", 'u', 'L') + vd(2) = var_desc("ry_oblique", "m2 s-2", "Radiation Speed Squared for NS oblique OBCs", 'v', 'L') + call register_restart_pair(OBC%rx_oblique, OBC%ry_oblique, vd(1), vd(2), & + .false., restart_CSp) + allocate(OBC%cff_normal(HI%IsdB:HI%IedB,HI%jsdB:HI%jedB,GV%ke)) OBC%cff_normal(:,:,:) = 0.0 - vd = var_desc("cff_normal", "m2 s-2", "denominator for oblique OBCs", 'q', 'L') - call register_restart_field(OBC%cff_normal, vd, .false., restart_CSp) + vd(1) = var_desc("cff_normal", "m2 s-2", "denominator for oblique OBCs", 'q', 'L') + call register_restart_field(OBC%cff_normal, vd(1), .false., restart_CSp) endif if (Reg%ntr == 0) return @@ -4583,9 +4730,15 @@ subroutine open_boundary_register_restarts(HI, GV, OBC, Reg, param_file, restart OBC%tres_x(:,:,:,:) = 0.0 do m=1,OBC%ntr if (OBC%tracer_x_reservoirs_used(m)) then - write(mesg,'("tres_x_",I3.3)') m - vd = var_desc(mesg,"Conc", "Tracer concentration for EW OBCs",'u','L') - call register_restart_field(OBC%tres_x(:,:,:,m), vd, .false., restart_CSp) + if (modulo(HI%turns, 2) /= 0) then + write(mesg,'("tres_y_",I3.3)') m + vd(1) = var_desc(mesg,"Conc", "Tracer concentration for NS OBCs",'v','L') + call register_restart_field(OBC%tres_x(:,:,:,m), vd(1), .false., restart_CSp) + else + write(mesg,'("tres_x_",I3.3)') m + vd(1) = var_desc(mesg,"Conc", "Tracer concentration for EW OBCs",'u','L') + call register_restart_field(OBC%tres_x(:,:,:,m), vd(1), .false., restart_CSp) + endif endif enddo endif @@ -4594,13 +4747,18 @@ subroutine open_boundary_register_restarts(HI, GV, OBC, Reg, param_file, restart OBC%tres_y(:,:,:,:) = 0.0 do m=1,OBC%ntr if (OBC%tracer_y_reservoirs_used(m)) then - write(mesg,'("tres_y_",I3.3)') m - vd = var_desc(mesg,"Conc", "Tracer concentration for NS OBCs",'v','L') - call register_restart_field(OBC%tres_y(:,:,:,m), vd, .false., restart_CSp) + if (modulo(HI%turns, 2) /= 0) then + write(mesg,'("tres_x_",I3.3)') m + vd(1) = var_desc(mesg,"Conc", "Tracer concentration for EW OBCs",'u','L') + call register_restart_field(OBC%tres_y(:,:,:,m), vd(1), .false., restart_CSp) + else + write(mesg,'("tres_y_",I3.3)') m + vd(1) = var_desc(mesg,"Conc", "Tracer concentration for NS OBCs",'v','L') + call register_restart_field(OBC%tres_y(:,:,:,m), vd(1), .false., restart_CSp) + endif endif enddo endif - end subroutine open_boundary_register_restarts !> Update the OBC tracer reservoirs after the tracers have been updated. @@ -4630,8 +4788,8 @@ subroutine update_segment_tracer_reservoirs(G, GV, uhr, vhr, h, OBC, dt, Reg) 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 - I = segment%HI%IsdB ! 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 @@ -4639,10 +4797,14 @@ subroutine update_segment_tracer_reservoirs(G, GV, uhr, vhr, h, OBC, dt, Reg) 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,ntr ; if (associated(segment%tr_Reg%Tr(m)%tres)) then ; do k=1,nz - u_L_out = max(0.0, (idir*uhr(I,j,k))*segment%Tr_InvLscale_out / (h(i+ishift,j,k)*G%dyCu(I,j))) - u_L_in = min(0.0, (idir*uhr(I,j,k))*segment%Tr_InvLscale_in / (h(i+ishift,j,k)*G%dyCu(I,j))) + u_L_out = max(0.0, (idir*uhr(I,j,k))*segment%Tr_InvLscale_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 / & + ((h(i+ishift,j,k) + GV%H_subroundoff)*G%dyCu(I,j))) fac1 = 1.0 + (u_L_out-u_L_in) segment%tr_Reg%Tr(m)%tres(I,j,k) = (1.0/fac1)*(segment%tr_Reg%Tr(m)%tres(I,j,k) + & (u_L_out*Reg%Tr(m)%t(I+ishift,j,k) - & @@ -4650,9 +4812,9 @@ subroutine update_segment_tracer_reservoirs(G, GV, uhr, vhr, h, OBC, dt, Reg) if (associated(OBC%tres_x)) OBC%tres_x(I,j,k,m) = segment%tr_Reg%Tr(m)%tres(I,j,k) enddo ; endif ; enddo enddo - else + elseif (segment%is_N_or_S) then + J = segment%HI%JsdB do i=segment%HI%isd,segment%HI%ied - J = segment%HI%JsdB ! 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 @@ -4660,10 +4822,14 @@ subroutine update_segment_tracer_reservoirs(G, GV, uhr, vhr, h, OBC, dt, Reg) 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,ntr ; if (associated(segment%tr_Reg%Tr(m)%tres)) then ; do k=1,nz - v_L_out = max(0.0, (jdir*vhr(i,J,k))*segment%Tr_InvLscale_out / (h(i,j+jshift,k)*G%dxCv(i,J))) - v_L_in = min(0.0, (jdir*vhr(i,J,k))*segment%Tr_InvLscale_in / (h(i,j+jshift,k)*G%dxCv(i,J))) + v_L_out = max(0.0, (jdir*vhr(i,J,k))*segment%Tr_InvLscale_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 / & + ((h(i,j+jshift,k) + GV%H_subroundoff)*G%dxCv(i,J))) fac1 = 1.0 + (v_L_out-v_L_in) segment%tr_Reg%Tr(m)%tres(i,J,k) = (1.0/fac1)*(segment%tr_Reg%Tr(m)%tres(i,J,k) + & (v_L_out*Reg%Tr(m)%t(i,J+jshift,k) - & @@ -4725,8 +4891,8 @@ subroutine adjustSegmentEtaToFitBathymetry(G, GV, US, segment,fld) ! The normal slope at the boundary is zero by a ! previous call to open_boundary_impose_normal_slope do k=nz+1,1,-1 - if (-eta(i,j,k) > segment%Htot(i,j) + hTolerance) then - eta(i,j,k) = -segment%Htot(i,j) + if (-eta(i,j,k) > segment%Htot(i,j)*GV%H_to_Z + hTolerance) then + eta(i,j,k) = -segment%Htot(i,j)*GV%H_to_Z contractions = contractions + 1 endif enddo @@ -4744,10 +4910,10 @@ subroutine adjustSegmentEtaToFitBathymetry(G, GV, US, segment,fld) ! The whole column is dilated to accommodate deeper topography than ! the bathymetry would indicate. - if (-eta(i,j,nz+1) < segment%Htot(i,j) - hTolerance) then + if (-eta(i,j,nz+1) < (segment%Htot(i,j) * GV%H_to_Z) - hTolerance) then dilations = dilations + 1 ! expand bottom-most cell only - eta(i,j,nz+1) = -segment%Htot(i,j) + eta(i,j,nz+1) = -(segment%Htot(i,j) * GV%H_to_Z) segment%field(fld)%dz_src(i,j,nz)= eta(i,j,nz)-eta(i,j,nz+1) ! if (eta(i,j,1) <= eta(i,j,nz+1)) then ! do k=1,nz ; segment%field(fld)%dz_src(i,j,k) = (eta(i,j,1) + G%bathyT(i,j)) / real(nz) ; enddo @@ -4783,6 +4949,312 @@ subroutine adjustSegmentEtaToFitBathymetry(G, GV, US, segment,fld) 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%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_CSp, OBC) + type(ocean_OBC_type), pointer, 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), pointer, intent(in) :: restart_CSp !< 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, OBC, tv) + + call open_boundary_init(G, GV, US, param_file, OBC, restart_CSp) +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 :: is, ie, js, je, nk + 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)%fid = segment_in%field(n)%fid + segment%field(n)%fid_dz = segment_in%field(n)%fid_dz + + if (modulo(turns, 2) /= 0) then + select case (segment_in%field(n)%name) + case ('U') + segment%field(n)%name = 'V' + case ('V') + segment%field(n)%name = 'U' + 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)%buffer_dst => NULL() + segment%field(n)%bt_vel => NULL() + + 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. diff --git a/src/core/MOM_transcribe_grid.F90 b/src/core/MOM_transcribe_grid.F90 index 045fc9261c..51d44c1041 100644 --- a/src/core/MOM_transcribe_grid.F90 +++ b/src/core/MOM_transcribe_grid.F90 @@ -4,6 +4,7 @@ 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 @@ -11,9 +12,10 @@ module MOM_transcribe_grid 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 +public copy_dyngrid_to_MOM_grid, copy_MOM_grid_to_dyngrid, rotate_dyngrid contains @@ -305,4 +307,92 @@ subroutine copy_MOM_grid_to_dyngrid(oG, dG, US) end subroutine copy_MOM_grid_to_dyngrid +subroutine rotate_dyngrid(G_in, G, US, turns) + type(dyn_horgrid_type), intent(in) :: G_in !< Common horizontal grid type + type(dyn_horgrid_type), intent(inout) :: G !< Ocean grid type + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + integer, intent(in) :: turns !< Number of quarter turns + + integer :: jsc, jec, jscB, jecB + integer :: qturn + + ! 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 point + 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%areaCu, G_in%areaCv, turns, & + G%areaCu, G%areaCv) + call rotate_array_pair(G_in%IareaCu, G_in%IareaCv, turns, & + G%IareaCu, G%IareaCv) + + ! 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) + + ! Topographic + 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%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%max_depth = G_in%max_depth + + call set_derived_dyn_horgrid(G, US) +end subroutine rotate_dyngrid + end module MOM_transcribe_grid diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index 09cbd14c60..0b225f0bf7 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -3,6 +3,7 @@ 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_domains, only : MOM_domain_type, get_domain_extent, group_pass_type use MOM_debugging, only : hchksum use MOM_error_handler, only : MOM_error, FATAL @@ -11,6 +12,7 @@ module MOM_variables use coupler_types_mod, only : coupler_1d_bc_type, coupler_2d_bc_type use coupler_types_mod, only : coupler_type_spawn, coupler_type_destructor +use coupler_types_mod, only : coupler_type_initialized implicit none ; private @@ -18,6 +20,7 @@ module MOM_variables 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 @@ -39,27 +42,27 @@ module MOM_variables real, allocatable, dimension(:,:) :: & SST, & !< The sea surface temperature [degC]. SSS, & !< The sea surface salinity [ppt ~> psu or gSalt/kg]. - sfc_density, & !< The mixed layer density [kg m-3]. - Hml, & !< The mixed layer depth [m]. - u, & !< The mixed layer zonal velocity [m s-1]. - v, & !< The mixed layer meridional velocity [m s-1]. - sea_lev, & !< The sea level [m]. If a reduced surface gravity is + 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 [J m-2]. - melt_potential, & !< Instantaneous amount of heat that can be used to melt sea ice [J m-2]. + !! 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 [kg m-2]. - ocean_heat, & !< The total heat content of the ocean in [degC kg m-2]. - ocean_salt, & !< The total salt content of the ocean in [kgSalt m-2]. - taux_shelf, & !< The zonal stresses on the ocean under shelves [Pa]. - tauy_shelf, & !< The meridional stresses on the ocean under shelves [Pa]. + ocean_mass, & !< The total mass of the ocean [R Z ~> kg m-2]. + ocean_heat, & !< The total heat content of the ocean in [degC R Z ~> degC kg m-2]. + ocean_salt, & !< The total salt content of the ocean in [kgSalt kg-1 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]. TempxPmE, & !< The net inflow of water into the ocean times the temperature at which this - !! inflow occurs during the call to step_MOM [degC kg m-2]. - salt_deficit, & !< The salt needed to maintain the ocean column at a minimum - !! salinity of 0.01 PSU over the call to step_MOM [kgSalt m-2]. + !! inflow occurs during the call to step_MOM [degC R Z ~> degC kg m-2]. + salt_deficit, & !< The salt needed to maintain the ocean column above a minimum + !! salinity over the call to step_MOM [kgSalt kg-1 R Z ~> kgSalt m-2]. internal_heat !< Any internal or geothermal heat sources that are applied to the ocean - !! integrated over the call to step_MOM [degC kg m-2]. + !! integrated over the call to step_MOM [degC R Z ~> degC kg m-2]. logical :: T_is_conT = .false. !< If true, the temperature variable SST is actually the !! conservative temperature in [degC]. logical :: S_is_absS = .false. !< If true, the salinity variable SSS is actually the @@ -77,10 +80,12 @@ module MOM_variables type, public :: thermo_var_ptrs ! If allocated, the following variables have nz layers. real, pointer :: T(:,:,:) => NULL() !< Potential temperature [degC]. - real, pointer :: S(:,:,:) => NULL() !< Salnity [PSU] or [gSalt/kg], generically [ppt]. + real, pointer :: S(:,:,:) => NULL() !< Salinity [PSU] or [gSalt/kg], generically [ppt]. + real, pointer :: p_surf(:,:) => NULL() !< Ocean surface pressure used in equation of state + !! calculations [R L2 T-2 ~> Pa] type(EOS_type), pointer :: eqn_of_state => NULL() !< Type that indicates the !! equation of state to use. - real :: P_Ref !< The coordinate-density reference pressure [Pa]. + 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 degC-1 ~> J degC-1 kg-1]. @@ -111,6 +116,12 @@ module MOM_variables !< Any internal or geothermal heat sources that !! have been applied to the ocean since the last call to !! calculate_surface_state [degC R Z ~> degC kg m-2]. + ! The following variables are most normally not used but when they are they + ! will be either set by parameterizations or prognostic. + real, pointer :: varT(:,:,:) => NULL() !< SGS variance of potential temperature [degC2]. + real, pointer :: varS(:,:,:) => NULL() !< SGS variance of salinity [ppt2]. + real, pointer :: covarTS(:,:,:) => NULL() !< SGS covariance of salinity and potential + !! temperature [degC ppt]. end type thermo_var_ptrs !> Pointers to all of the prognostic variables allocated in MOM_variables.F90 and MOM.F90. @@ -174,6 +185,8 @@ module MOM_variables real, pointer :: rv_x_v(:,:,:) => NULL() !< rv_x_v = rv * v at u [L T-2 ~> m s-2] real, pointer :: rv_x_u(:,:,:) => NULL() !< rv_x_u = rv * u at v [L T-2 ~> m s-2] + real, pointer :: diag_hfrac_u(:,:,:) => NULL() !< Fractional layer thickness at u points + real, pointer :: diag_hfrac_v(:,:,:) => NULL() !< Fractional layer thickness at v points end type accel_diag_ptrs !> Pointers to arrays with transports, which can later be used for derived diagnostics, like energy balances. @@ -224,7 +237,7 @@ module MOM_variables real, pointer, dimension(:,:) :: nkml_visc_v => NULL() !< The number of layers in the viscous surface mixed layer at v-points [nondim]. real, pointer, dimension(:,:) :: & - MLD => NULL() !< Instantaneous active mixing layer depth in unscaled MKS units [m]. + MLD => NULL() !< Instantaneous active mixing layer depth [Z ~> m]. real, pointer, dimension(:,:,:) :: & Ray_u => NULL(), & !< The Rayleigh drag velocity to be applied to each layer at u-points [Z T-1 ~> m s-1]. Ray_v => NULL() !< The Rayleigh drag velocity to be applied to each layer at v-points [Z T-1 ~> m s-1]. @@ -395,6 +408,79 @@ subroutine deallocate_surface_state(sfc_state) end subroutine deallocate_surface_state +!> Rotate the surface state fields from the input to the model indices. +subroutine rotate_surface_state(sfc_state_in, G_in, sfc_state, G, turns) + type(surface), intent(in) :: sfc_state_in + type(ocean_grid_type), intent(in) :: G_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%TempxPmE) + call rotate_array(sfc_state_in%salt_deficit, turns, sfc_state%salt_deficit) + call rotate_array(sfc_state_in%internal_heat, turns, sfc_state%internal_heat) + 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 + + ! TODO: tracer field rotation + if (coupler_type_initialized(sfc_state_in%tr_fields)) & + call MOM_error(FATAL, "Rotation of surface state tracers is not yet " & + // "implemented.") +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, alloc_faces) type(BT_cont_type), pointer :: BT_cont !< The BT_cont_type whose elements will be allocated diff --git a/src/core/MOM_verticalGrid.F90 b/src/core/MOM_verticalGrid.F90 index 0608499f92..7495e0033b 100644 --- a/src/core/MOM_verticalGrid.F90 +++ b/src/core/MOM_verticalGrid.F90 @@ -92,10 +92,11 @@ subroutine verticalGridInit( param_file, GV, US ) ! 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.") - call get_param(param_file, mdl, "G_EARTH", GV%mks_g_Earth, & + "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) + 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 "//& @@ -127,7 +128,7 @@ subroutine verticalGridInit( param_file, GV, US ) "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%g_Earth = US%m_to_L**2*US%Z_to_m*US%T_to_s**2 * GV%mks_g_Earth + 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, & @@ -156,7 +157,7 @@ subroutine verticalGridInit( param_file, GV, US ) GV%H_to_MKS = GV%H_to_kg_m2 endif GV%H_subroundoff = 1e-20 * max(GV%Angstrom_H,GV%m_to_H*1e-17) - GV%H_to_Pa = GV%mks_g_Earth * GV%H_to_kg_m2 + 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_Z = GV%H_to_m * US%m_to_Z GV%Z_to_H = US%Z_to_m * GV%m_to_H @@ -173,8 +174,7 @@ subroutine verticalGridInit( param_file, GV, US ) allocate( GV%sInterface(nk+1) ) allocate( GV%sLayer(nk) ) allocate( GV%g_prime(nk+1) ) ; GV%g_prime(:) = 0.0 - ! The extent of Rlay should be changed to nk? - allocate( GV%Rlay(nk+1) ) ; GV%Rlay(:) = 0.0 + allocate( GV%Rlay(nk) ) ; GV%Rlay(:) = 0.0 end subroutine verticalGridInit diff --git a/src/diagnostics/MOM_PointAccel.F90 b/src/diagnostics/MOM_PointAccel.F90 index 4ad1b67314..f6326b06fa 100644 --- a/src/diagnostics/MOM_PointAccel.F90 +++ b/src/diagnostics/MOM_PointAccel.F90 @@ -759,7 +759,7 @@ subroutine PointAccel_init(MIS, Time, G, param_file, diag, dirs, CS) 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, "") + 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"//& @@ -771,7 +771,7 @@ subroutine PointAccel_init(MIS, Time, G, param_file, diag, dirs, CS) "Leave this empty for efficiency if this diagnostic is "//& "not needed.", default="", debuggingParam=.true.) call get_param(param_file, mdl, "MAX_TRUNC_FILE_SIZE_PER_PE", CS%max_writes, & - "The maximum number of colums of truncations that any PE "//& + "The maximum number of columns of truncations that any PE "//& "will write out during a run.", default=50, debuggingParam=.true.) if (len_trim(dirs%output_directory) > 0) then @@ -779,8 +779,8 @@ subroutine PointAccel_init(MIS, Time, G, param_file, diag, dirs, CS) 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) - call log_param(param_file, mdl, "output_dir/V_TRUNC_FILE", 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 diff --git a/src/diagnostics/MOM_debugging.F90 b/src/diagnostics/MOM_debugging.F90 index d4d267d50d..43c9c8c406 100644 --- a/src/diagnostics/MOM_debugging.F90 +++ b/src/diagnostics/MOM_debugging.F90 @@ -8,9 +8,9 @@ module MOM_debugging ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_checksums, only : hchksum, Bchksum, qchksum, uvchksum +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, sum_across_PEs +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 @@ -27,7 +27,7 @@ module MOM_debugging public :: check_column_integral, check_column_integrals ! These interfaces come from MOM_checksums. -public :: hchksum, Bchksum, qchksum, is_NaN, chksum, uvchksum +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 @@ -83,7 +83,7 @@ subroutine MOM_debugging_init(param_file) #include "version_variable.h" character(len=40) :: mdl = "MOM_debugging" ! This module's name. - call log_version(param_file, mdl, version) + 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.) @@ -730,14 +730,15 @@ function totalStuff(HI, hThick, areaT, stuff) real, dimension(HI%isd:,HI%jsd:,:), intent(in) :: stuff !< The array of stuff to be summed real :: totalStuff !< the globally integrated amoutn of stuff ! Local variables + real, dimension(HI%isc:HI%iec, HI%jsc:HI%jec) :: tmp_for_sum integer :: i, j, k, nz nz = size(hThick,3) - totalStuff = 0. - do k = 1, nz ; do j = HI%jsc, HI%jec ; do i = HI%isc, HI%iec - totalStuff = totalStuff + hThick(i,j,k) * stuff(i,j,k) * areaT(i,j) + 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 - call sum_across_PEs(totalStuff) + totalStuff = reproducing_sum(tmp_for_sum) end function totalStuff @@ -755,15 +756,16 @@ subroutine totalTandS(HI, hThick, areaT, temperature, salinity, mesg) real, save :: totalH = 0., totalT = 0., totalS = 0. ! Local variables logical, save :: firstCall = .true. + real, dimension(HI%isc:HI%iec, HI%jsc:HI%jec) :: tmp_for_sum real :: thisH, thisT, thisS, delH, delT, delS integer :: i, j, k, nz nz = size(hThick,3) - thisH = 0. - do k = 1, nz ; do j = HI%jsc, HI%jec ; do i = HI%isc, HI%iec - thisH = thisH + hThick(i,j,k) * areaT(i,j) + 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 - call sum_across_PEs(thisH) + thisH = reproducing_sum(tmp_for_sum) thisT = totalStuff(HI, hThick, areaT, temperature) thisS = totalStuff(HI, hThick, areaT, salinity) diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 95b1f450e3..3936a788d0 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -6,6 +6,7 @@ module MOM_diagnostics ! This file is part of MOM6. See LICENSE.md for the license. use MOM_coms, only : reproducing_sum +use MOM_density_integrals, only : int_density_dz use MOM_diag_mediator, only : post_data, get_diag_time_end use MOM_diag_mediator, only : register_diag_field, register_scalar_field use MOM_diag_mediator, only : register_static_field, diag_register_area_ids @@ -15,7 +16,7 @@ module MOM_diagnostics use MOM_diag_mediator, only : diag_save_grids, diag_restore_grids, diag_copy_storage_to_diag use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type use MOM_domains, only : To_North, To_East -use MOM_EOS, only : calculate_density, int_density_dz +use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_domain use MOM_EOS, only : gsw_sp_from_sr, gsw_pt_from_ct use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : get_param, log_version, param_file_type @@ -70,6 +71,9 @@ module MOM_diagnostics dv_dt => NULL(), & !< net j-acceleration [L T-2 ~> m s-2] dh_dt => NULL(), & !< thickness rate of change [H T-1 ~> m s-1 or kg m-2 s-1] p_ebt => NULL() !< Equivalent barotropic modal structure [nondim] + ! hf_du_dt => NULL(), hf_dv_dt => NULL() !< du_dt, dv_dt x fract. thickness [L T-2 ~> m s-2]. + ! 3D diagnostics hf_du(dv)_dt are commented because there is no clarity on proper remapping grid option. + ! The code is retained for degugging purposes in the future. real, pointer, dimension(:,:,:) :: h_Rlay => NULL() !< Layer thicknesses in potential density !! coordinates [H ~> m or kg m-2] @@ -109,6 +113,8 @@ module MOM_diagnostics integer :: id_u = -1, id_v = -1, id_h = -1 integer :: id_e = -1, id_e_D = -1 integer :: id_du_dt = -1, id_dv_dt = -1 + ! integer :: id_hf_du_dt = -1, id_hf_dv_dt = -1 + integer :: id_hf_du_dt_2d = -1, id_hf_dv_dt_2d = -1 integer :: id_col_ht = -1, id_dh_dt = -1 integer :: id_KE = -1, id_dKEdt = -1 integer :: id_PE_to_KE = -1, id_KE_Coradv = -1 @@ -134,6 +140,7 @@ module MOM_diagnostics integer :: id_pbo = -1 integer :: id_thkcello = -1, id_rhoinsitu = -1 integer :: id_rhopot0 = -1, id_rhopot2 = -1 + integer :: id_drho_dT = -1, id_drho_dS = -1 integer :: id_h_pre_sync = -1 !>@} !> The control structure for calculating wave speed. @@ -208,7 +215,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & !! 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 [Pa]. + 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 @@ -223,6 +230,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & !! calculating interface heights [H ~> m or kg m-2]. ! Local variables + 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 :: Rcv(SZI_(G),SZJ_(G),SZK_(G)) ! Coordinate variable potential density [R ~> kg m-3]. @@ -230,14 +238,17 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & real :: work_2d(SZI_(G),SZJ_(G)) ! A 2-d temporary work array. real :: rho_in_situ(SZI_(G)) ! In situ density [R ~> kg m-3] + real, allocatable, dimension(:,:) :: & + hf_du_dt_2d, hf_dv_dt_2d ! z integeral of hf_du_dt, hf_dv_dt [L T-2 ~> m s-2]. + ! tmp array for surface properties real :: surface_field(SZI_(G),SZJ_(G)) - real :: pressure_1d(SZI_(G)) ! Temporary array for pressure when calling EOS + real :: pressure_1d(SZI_(G)) ! Temporary array for pressure when calling EOS [R L2 T-2 ~> Pa] real :: wt, wt_p 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 ! Srequency squared used to avoid division by 0 [T-2 ~> s-2] + real :: absurdly_small_freq2 ! Frequency squared used to avoid division by 0 [T-2 ~> s-2] integer :: k_list @@ -269,6 +280,44 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & if (CS%id_dh_dt>0) call post_data(CS%id_dh_dt, CS%dh_dt, CS%diag, alt_h = diag_pre_sync%h_state) + !! Diagnostics for terms multiplied by fractional thicknesses + + ! 3D diagnostics hf_du(dv)_dt are commented because there is no clarity on proper remapping grid option. + ! The code is retained for degugging purposes in the future. + !if (CS%id_hf_du_dt > 0) then + ! do k=1,nz ; do j=js,je ; do I=Isq,Ieq + ! CS%hf_du_dt(I,j,k) = CS%du_dt(I,j,k) * ADp%diag_hfrac_u(I,j,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_du_dt, CS%hf_du_dt, CS%diag, alt_h = diag_pre_sync%h_state) + !endif + + !if (CS%id_hf_dv_dt > 0) then + ! do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + ! CS%hf_dv_dt(i,J,k) = CS%dv_dt(i,J,k) * ADp%diag_hfrac_v(i,J,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_dv_dt, CS%hf_dv_dt, CS%diag, alt_h = diag_pre_sync%h_state) + !endif + + if (CS%id_hf_du_dt_2d > 0) then + allocate(hf_du_dt_2d(G%IsdB:G%IedB,G%jsd:G%jed)) + hf_du_dt_2d(:,:) = 0.0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + hf_du_dt_2d(I,j) = hf_du_dt_2d(I,j) + CS%du_dt(I,j,k) * ADp%diag_hfrac_u(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_du_dt_2d, hf_du_dt_2d, CS%diag) + deallocate(hf_du_dt_2d) + endif + + if (CS%id_hf_dv_dt_2d > 0) then + allocate(hf_dv_dt_2d(G%isd:G%ied,G%JsdB:G%JedB)) + hf_dv_dt_2d(:,:) = 0.0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + hf_dv_dt_2d(i,J) = hf_dv_dt_2d(i,J) + CS%dv_dt(i,J,k) * ADp%diag_hfrac_v(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_dv_dt_2d, hf_dv_dt_2d, CS%diag) + deallocate(hf_dv_dt_2d) + endif + call diag_restore_grids(CS%diag) call calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS) @@ -344,8 +393,9 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & 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 [Pa] + 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 @@ -355,17 +405,17 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & enddo endif do k=1,nz ! Integrate vertically downward for pressure - do i=is,ie ! Pressure for EOS at the layer center [Pa] - pressure_1d(i) = pressure_1d(i) + 0.5*GV%H_to_Pa*h(i,j,k) + 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, is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) + 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 [Pa] - pressure_1d(i) = pressure_1d(i) + 0.5*GV%H_to_Pa*h(i,j,k) + 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 @@ -462,11 +512,12 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & associated(CS%uhGM_Rlay) .or. associated(CS%vhGM_Rlay)) 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), is-1, ie-is+3, tv%eqn_of_state , scale=US%kg_m3_to_R) + 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 @@ -584,36 +635,53 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & 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(none) shared(tv,Rcv,is,ie,js,je,nz,pressure_1d) + !$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),is,ie-is+1, tv%eqn_of_state) + 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.E7 ! 2000 dbars -!$OMP parallel do default(none) shared(tv,Rcv,is,ie,js,je,nz,pressure_1d) + pressure_1d(:) = 2.0e7*US%kg_m3_to_R*US%m_s_to_L_T**2 ! 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),is,ie-is+1, tv%eqn_of_state) + 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(none) shared(tv,Rcv,is,ie,js,je,nz,h,GV) private(pressure_1d) + !$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_Pa ! Pressure in middle of layer k - call calculate_density(tv%T(:,j,k),tv%S(:,j,k),pressure_1d, & - Rcv(:,j,k),is,ie-is+1, tv%eqn_of_state) + ! To avoid storing more arrays, put drho_dT into Rcv, and drho_dS into work3d + call calculate_density_derivs(tv%T(:,j,k),tv%S(:,j,k),pressure_1d, & + Rcv(:,j,k),work_3d(:,j,k),is,ie-is+1, tv%eqn_of_state) pressure_1d(:) = pressure_1d(:) + 0.5 * h(:,j,k) * GV%H_to_Pa ! Pressure at bottom of layer k enddo enddo - if (CS%id_rhoinsitu > 0) call post_data(CS%id_rhoinsitu, Rcv, CS%diag) + 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 @@ -769,7 +837,7 @@ subroutine calculate_vertical_integrals(h, tv, p_surf, G, GV, US, CS) 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 [Pa]. + 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 @@ -785,11 +853,11 @@ subroutine calculate_vertical_integrals(h, tv, p_surf, G, GV, US, CS) ! (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 [Pa]. - dpress, & ! Change in hydrostatic pressure across a layer [Pa]. + ! 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) [TR kg m-2]. - real :: IG_Earth ! Inverse of gravitational acceleration [s2 Z m-2 ~> s2 m-1]. + 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 = G%ke @@ -831,7 +899,7 @@ subroutine calculate_vertical_integrals(h, tv, p_surf, G, GV, US, CS) 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 / (US%Z_to_m*GV%mks_g_Earth) + IG_Earth = 1.0 / GV%g_Earth ! do j=js,je ; do i=is,ie ; z_bot(i,j) = -P_SURF(i,j)/GV%H_to_Pa ; enddo ; enddo do j=G%jscB,G%jecB+1 ; do i=G%iscB,G%iecB+1 z_bot(i,j) = 0.0 @@ -841,11 +909,10 @@ subroutine calculate_vertical_integrals(h, tv, p_surf, G, GV, US, CS) 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, US%R_to_kg_m3*GV%Rho0, GV%mks_g_Earth*US%Z_to_m, & - G%HI, G%HI, tv%eqn_of_state, dpress) + 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) * US%kg_m3_to_R*IG_Earth + mass(i,j) = mass(i,j) + dpress(i,j) * IG_Earth enddo ; enddo enddo else @@ -867,7 +934,7 @@ subroutine calculate_vertical_integrals(h, tv, p_surf, G, GV, US, CS) ! 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) = US%RZ_to_kg_m2*mass(i,j) * GV%mks_g_Earth + 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 @@ -1166,7 +1233,7 @@ subroutine post_surface_dyn_diags(IDs, G, diag, sfc_state, ssh) intent(in) :: ssh !< Time mean surface height without corrections for ice displacement [m] ! Local variables - real, dimension(SZI_(G),SZJ_(G)) :: work_2d ! A 2-d work array + 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 @@ -1182,10 +1249,10 @@ subroutine post_surface_dyn_diags(IDs, G, diag, sfc_state, ssh) if (IDs%id_speed > 0) then do j=js,je ; do i=is,ie - work_2d(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)) + 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, work_2d, diag, mask=G%mask2dT) + call post_data(IDs%id_speed, speed, diag, mask=G%mask2dT) endif end subroutine post_surface_dyn_diags @@ -1448,6 +1515,10 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag # include "version_variable.h" character(len=40) :: mdl = "MOM_diagnostics" ! This module's name. character(len=48) :: thickness_units, flux_units + 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 :: better_speed_est ! If true, use a more robust estimate of the first + ! mode wave speed as the starting point for iterations. logical :: use_temperature, adiabatic logical :: default_2018_answers, remap_answers_2018 integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nz, nkml, nkbl @@ -1471,7 +1542,7 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag do_not_log=.true.) ! Read all relevant parameters and write them to the model log. - call log_version(param_file, mdl, version) + call log_version(param_file, mdl, version, "") 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.", & @@ -1480,9 +1551,19 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag "The depth below which N2 is limited as monotonic for the "// & "purposes of calculating the equivalent barotropic wave speed.", & units='m', scale=US%m_to_Z, default=-1.) + 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=.false.) !### Change the default. call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=.true.) + default=.false.) 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 "//& @@ -1578,11 +1659,15 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag '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') + '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') + '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') + 'In situ density', 'kg m-3', conversion=US%R_to_kg_m3) + CS%id_drho_dT = register_diag_field('ocean_model', 'drho_dT', diag%axesTL, Time, & + 'Partial derivative of rhoinsitu with respect to temperature (alpha)', 'kg m-3 degC-1') + CS%id_drho_dS = register_diag_field('ocean_model', 'drho_dS', diag%axesTL, Time, & + 'Partial derivative of rhoinsitu with respect to salinity (beta)', 'kg^2 g-1 m-3') CS%id_du_dt = register_diag_field('ocean_model', 'dudt', diag%axesCuL, Time, & 'Zonal Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) @@ -1605,6 +1690,50 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag call register_time_deriv(lbound(MIS%h), MIS%h, CS%dh_dt, CS) endif + !CS%id_hf_du_dt = register_diag_field('ocean_model', 'hf_dudt', diag%axesCuL, Time, & + ! 'Fractional Thickness-weighted Zonal Acceleration', 'm s-2', v_extensive=.true., & + ! conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_du_dt > 0) then + ! call safe_alloc_ptr(CS%hf_du_dt,IsdB,IedB,jsd,jed,nz) + ! if (.not.associated(CS%du_dt)) then + ! call safe_alloc_ptr(CS%du_dt,IsdB,IedB,jsd,jed,nz) + ! call register_time_deriv(lbound(MIS%u), MIS%u, CS%du_dt, CS) + ! endif + ! call safe_alloc_ptr(ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + !endif + + !CS%id_hf_dv_dt = register_diag_field('ocean_model', 'hf_dvdt', diag%axesCvL, Time, & + ! 'Fractional Thickness-weighted Meridional Acceleration', 'm s-2', v_extensive=.true., & + ! conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_dv_dt > 0) then + ! call safe_alloc_ptr(CS%hf_dv_dt,isd,ied,JsdB,JedB,nz) + ! if (.not.associated(CS%dv_dt)) then + ! call safe_alloc_ptr(CS%dv_dt,isd,ied,JsdB,JedB,nz) + ! call register_time_deriv(lbound(MIS%v), MIS%v, CS%dv_dt, CS) + ! endif + ! call safe_alloc_ptr(ADp%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + !endif + + CS%id_hf_du_dt_2d = register_diag_field('ocean_model', 'hf_dudt_2d', diag%axesCu1, Time, & + 'Depth-sum Fractional Thickness-weighted Zonal Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_hf_du_dt_2d > 0) then + if (.not.associated(CS%du_dt)) then + call safe_alloc_ptr(CS%du_dt,IsdB,IedB,jsd,jed,nz) + call register_time_deriv(lbound(MIS%u), MIS%u, CS%du_dt, CS) + endif + call safe_alloc_ptr(ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + endif + + CS%id_hf_dv_dt_2d = register_diag_field('ocean_model', 'hf_dvdt_2d', diag%axesCv1, Time, & + 'Depth-sum Fractional Thickness-weighted Meridional Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_hf_dv_dt_2d > 0) then + if (.not.associated(CS%dv_dt)) then + call safe_alloc_ptr(CS%dv_dt,isd,ied,JsdB,JedB,nz) + call register_time_deriv(lbound(MIS%v), MIS%v, CS%dv_dt, CS) + endif + call safe_alloc_ptr(ADp%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + endif + ! layer thickness variables !if (GV%nk_rho_varies > 0) then CS%id_h_Rlay = register_diag_field('ocean_model', 'h_rho', diag%axesTL, Time, & @@ -1698,6 +1827,9 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag 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_CSp, remap_answers_2018=remap_answers_2018, & + better_speed_est=better_speed_est, min_speed=wave_speed_min, & + wave_speed_tol=wave_speed_tol) call wave_speed_init(CS%wave_speed_CSp, remap_answers_2018=remap_answers_2018) call safe_alloc_ptr(CS%cg1,isd,ied,jsd,jed) if (CS%id_Rd1>0) call safe_alloc_ptr(CS%Rd1,isd,ied,jsd,jed) @@ -1732,7 +1864,7 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag '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') + units='Pa', conversion=US%RL2_T2_to_Pa) call set_dependent_diagnostics(MIS, ADp, CDp, G, CS) @@ -1764,11 +1896,11 @@ subroutine register_surface_diags(Time, G, US, IDs, diag, tv) long_name='Area averaged sea surface height', units='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') + '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') + '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') + '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, & @@ -2136,6 +2268,9 @@ subroutine MOM_diagnostics_end(CS, ADp) if (associated(ADp%du_other)) deallocate(ADp%du_other) if (associated(ADp%dv_other)) deallocate(ADp%dv_other) + if (associated(ADp%diag_hfrac_u)) deallocate(ADp%diag_hfrac_u) + if (associated(ADp%diag_hfrac_v)) deallocate(ADp%diag_hfrac_v) + do m=1,CS%num_time_deriv ; deallocate(CS%prev_val(m)%p) ; enddo deallocate(CS) diff --git a/src/diagnostics/MOM_obsolete_params.F90 b/src/diagnostics/MOM_obsolete_params.F90 index 1f674290d3..a38f5a4b54 100644 --- a/src/diagnostics/MOM_obsolete_params.F90 +++ b/src/diagnostics/MOM_obsolete_params.F90 @@ -29,39 +29,12 @@ subroutine find_obsolete_params(param_file) if (.not.is_root_pe()) return - call obsolete_int(param_file, "NTSTEP", & - hint="Instead use DT_THERM to set the thermodynamic time-step.") - - call obsolete_logical(param_file, "JACOBIAN_PGF", .false., & - hint="Instead use ANALYTIC_FV_PGF.") - - call obsolete_logical(param_file, "SADOURNY", & - hint="Instead use CORIOLIS_SCHEME='SADOURNY'.") - - call obsolete_logical(param_file, "ARITHMETIC_BT_THICK", & - hint="Instead use BT_THICK_SCHEME='ARITHMETIC'.") - - call obsolete_logical(param_file, "HYBRID_BT_THICK", & - hint="Instead use BT_THICK_SCHEME='HYBRID'.") - - call obsolete_logical(param_file, "BT_CONT_BT_THICK", & - hint="Instead use BT_THICK_SCHEME='FROM_BT_CONT'.") + 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_logical(param_file, "APPLY_OBC_U", & - hint="Instead use OBC_NUMBER_SEGMENTS>0 and use the new segments protocol.") - call obsolete_logical(param_file, "APPLY_OBC_V", & - hint="Instead use OBC_NUMBER_SEGMENTS>0 and use the new segments protocol.") - call obsolete_logical(param_file, "APPLY_OBC_V_FLATHER_NORTH", & - hint="Instead use OBC_NUMBER_SEGMENTS>0 and use the new segments protocol.") - call obsolete_logical(param_file, "APPLY_OBC_V_FLATHER_SOUTH", & - hint="Instead use OBC_NUMBER_SEGMENTS>0 and use the new segments protocol.") - call obsolete_logical(param_file, "APPLY_OBC_U_FLATHER_EAST", & - hint="Instead use OBC_NUMBER_SEGMENTS>0 and use the new segments protocol.") - call obsolete_logical(param_file, "APPLY_OBC_U_FLATHER_WEST", & - hint="Instead use OBC_NUMBER_SEGMENTS>0 and use the new segments protocol.") 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", & @@ -83,113 +56,24 @@ subroutine find_obsolete_params(param_file) hint="Instead use OBC_SEGMENT_xxx_VELOCITY_NUDGING_TIMESCALES.") enddo - test_logic3 = .true. ; call read_param(param_file,"ENABLE_THERMODYNAMICS",test_logic3) - test_logic = .true. ; call read_param(param_file,"TEMPERATURE",test_logic) - test_logic2 = .false. ; call read_param(param_file,"TEMPERATURE",test_logic2) - if (test_logic .eqv. test_logic2) then ; if (test_logic .eqv. test_logic3) then - call MOM_ERROR(WARNING, "find_obsolete_params: "// & - "TEMPERATURE is an obsolete run-time flag, but is set consistently with \n"//& - " ENABLE_THERMODYNAMICS.") - else - call MOM_ERROR(FATAL, "find_obsolete_params: "// & - "TEMPERATURE is an obsolete run-time flag. Use ENABLE_THERMODYNAMICS instead.") - endif ; endif - - test_logic = test_logic3 ; call read_param(param_file,"NONLINEAR_EOS",test_logic) - if (test_logic .neqv. test_logic3) then - call MOM_error(WARNING, "find_obsolete_params: "// & - "NONLINEAR_EOS is an obsolete option. Instead define " // & - "USE_EOS to use an equation of state to calculate density.") - endif - -! test_logic = .true. ; call read_param(param_file,"USE_RIVER_HEAT_CONTENT",test_logic) -! test_logic2 = .false. ; call read_param(param_file,"USE_RIVER_HEAT_CONTENT",test_logic2) -! if (test_logic .eqv. test_logic2) call MOM_ERROR(FATAL, "find_obsolete_params: "// & -! "USE_RIVER_HEAT_CONTENT, is an obsolete run-time flag.") - -! test_logic = .true. ; call read_param(param_file,"USE_CALVING_HEAT_CONTENT",test_logic) -! test_logic2 = .false. ; call read_param(param_file,"USE_CALVING_HEAT_CONTENT",test_logic2) -! if (test_logic .eqv. test_logic2) call MOM_ERROR(FATAL, "find_obsolete_params: "// & -! "USE_CALVING_HEAT_CONTENT, is an obsolete run-time flag.") - - call obsolete_int(param_file, "NXTOT") - call obsolete_int(param_file, "NYTOT") - call obsolete_int(param_file, "NZ") - call obsolete_int(param_file, "NXPROC") - call obsolete_int(param_file, "NYPROC") - call obsolete_int(param_file, "NXPROC_IO") - call obsolete_int(param_file, "NYPROC_IO") - call obsolete_int(param_file, "NXHALO") - call obsolete_int(param_file, "NYHALO") - call obsolete_int(param_file, "ML_PRESORT_NZ_CONV_ADJ") - - call obsolete_int(param_file, "NIPROC_IO", hint="Use IO_LAYOUT=#,# instead.") - call obsolete_int(param_file, "NJPROC_IO", hint="Use IO_LAYOUT=#,# instead.") - - call obsolete_real(param_file, "BT_COR_SLOW_RATE", 0.0) - call obsolete_real(param_file, "BT_COR_FRAC", 1.0) - call obsolete_logical(param_file, "MASK_MASSLESS_TRACERS", .false.) - call obsolete_logical(param_file, "BT_INCLUDE_UDHDT", .false.) - - call obsolete_logical(param_file, "RIGA_SET_DIFFUSIVITY", .false.) - call obsolete_logical(param_file, "RIGA_ITIDE_BUGS", .false.) - call obsolete_logical(param_file, "RIGA_ENTRAINMENT_FOIBLES", .false.) - call obsolete_logical(param_file, "RIGA_TRACER_DIFFUSE_BUGS", .false.) - call obsolete_logical(param_file, "RIGA_KAPPA_SHEAR_BUGS1", .false.) - call obsolete_logical(param_file, "RIGA_KAPPA_SHEAR_BUGS2", .false.) - call obsolete_logical(param_file, "CONT_PPM_RIGA_BUGS", .false.) - call obsolete_logical(param_file, "USE_REPRODUCING_SUM", .true.) - call obsolete_logical(param_file, "SLOW_BITWISE_GLOBAL_FORCING_SUMS", .false.) - call obsolete_logical(param_file, "ALWAYS_WRITE_GEOM") - call obsolete_real(param_file, "I_ZETA") - - call obsolete_logical(param_file, "REF_COMPRESS_3D") - call obsolete_char(param_file, "COMPRESS_FILE") - call obsolete_char(param_file, "REF_COMPRESS_FILE_TEMP") - call obsolete_char(param_file, "REF_COMPRESS_FILE_SALT") - call obsolete_char(param_file, "REF_COMPRESS_FILE_DEPTH") - call obsolete_char(param_file, "DIAG_REMAP_Z_GRID_DEF", "Use NUM_DIAG_COORDS, DIAG_COORDS and DIAG_COORD_DEF_Z") - - call obsolete_logical(param_file, "OLD_RESTRAT_PARAM", .false.) - call obsolete_real(param_file, "ML_RESTRAT_COEF", 0.0) - call obsolete_logical(param_file, "FULL_THICKNESSDIFFUSE", .true.) - call obsolete_logical(param_file, "DIFFUSE_ISOPYCNALS", .true.) - - call obsolete_logical(param_file, "MOREL_PEN_SW") - call obsolete_logical(param_file, "MANIZZA_PEN_SW") - - call obsolete_logical(param_file, "USE_H2000_SHEAR_MIXING", .false.) - call obsolete_real(param_file, "SHEARMIX_LAT_EQ", 0.0) - call obsolete_real(param_file, "RINO_CRIT_EQ") - call obsolete_real(param_file, "SHEARMIX_RATE_EQ") + 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, "KG_BG_2D_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_logical(param_file, "ORIG_MLD_ITERATION", .false.) - call obsolete_logical(param_file, "CONTINUITY_PPM", .true.) - - call obsolete_logical(param_file, "USE_LOCAL_PREF", .true.) - call obsolete_logical(param_file, "USE_LOCAL_PREF_CORRECT", .true.) - test_logic = .false. ; call read_param(param_file, "USE_JACKSON_PARAM", test_logic) - call obsolete_logical(param_file, "RINOMIX", test_logic) - call obsolete_logical(param_file, "NORMALIZED_SUM_OUT", .true.) - - call obsolete_real(param_file, "RLAY_RANGE") - call obsolete_real(param_file, "RLAY_REF") - - call obsolete_real(param_file, "HMIX") call obsolete_real(param_file, "VSTAR_SCALE_COEF") call obsolete_real(param_file, "ZSTAR_RIGID_SURFACE_THRESHOLD") - test_int = -1 ; call read_param(param_file,"ML_RADIATION_CODING",test_int) - if (test_int == 1) call MOM_ERROR(FATAL, "find_obsolete_params: "// & - "ML_RADIATION_CODING is an obsolete option and the code previously "//& - "used by setting it to 1 has been eliminated.") - if (test_int /= -1) call MOM_ERROR(WARNING, "find_obsolete_params: "// & - "ML_RADIATION_CODING is an obsolete option.") - ! Test for inconsistent parameter settings. split = .true. ; test_logic = .false. call read_param(param_file,"SPLIT",split) @@ -198,12 +82,6 @@ subroutine find_obsolete_params(param_file) "find_obsolete_params: #define DYNAMIC_SURFACE_PRESSURE is not yet "//& "implemented without #define SPLIT.") - call obsolete_logical(param_file, "USE_LEGACY_SPLIT", .false.) - - call obsolete_logical(param_file, "FLUX_BT_COUPLING", .false.) - call obsolete_logical(param_file, "READJUST_BT_TRANS", .false.) - call obsolete_logical(param_file, "RESCALE_BT_FACE_AREAS", .false.) - call obsolete_logical(param_file, "APPLY_BT_DRAG", .true.) call obsolete_real(param_file, "BT_MASS_SOURCE_LIMIT", 0.0) call obsolete_int(param_file, "SEAMOUNT_LENGTH_SCALE", hint="Use SEAMOUNT_X_LENGTH_SCALE instead.") @@ -263,21 +141,36 @@ subroutine obsolete_logical(param_file, varname, warning_val, hint) end subroutine obsolete_logical !> Test for presence of obsolete STRING in parameter file. -subroutine obsolete_char(param_file, varname, hint) +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) call MOM_ERROR(FATAL, & - "MOM_obsolete_params: "//trim(varname)// & - " is an obsolete run-time flag, and should not be used. "// & - trim(hint_msg)) + 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. diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index 775cf39c22..2d4fb7e06f 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -5,8 +5,8 @@ module MOM_sum_output use iso_fortran_env, only : int64 use MOM_coms, only : sum_across_PEs, PE_here, root_PE, num_PEs, max_across_PEs -use MOM_coms, only : reproducing_sum, EFP_to_real, real_to_EFP -use MOM_coms, only : EFP_type, operator(+), operator(-), assignment(=) +use MOM_coms, only : reproducing_sum, reproducing_sum_EFP, EFP_to_real, real_to_EFP +use MOM_coms, only : EFP_type, operator(+), operator(-), assignment(=), EFP_sum_across_PEs use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe, MOM_mesg use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_forcing_type, only : forcing @@ -80,24 +80,18 @@ module MOM_sum_output !< Automatically update the Depth_list.nc file if the !! checksums are missing or do not match current values. logical :: use_temperature !< If true, temperature and salinity are state variables. - real :: fresh_water_input !< The total mass of fresh water added by surface fluxes - !! since the last time that write_energy was called [kg]. - real :: mass_prev !< The total ocean mass the last time that - !! write_energy was called [kg]. - real :: salt_prev !< The total amount of salt in the ocean the last - !! time that write_energy was called [ppt kg]. - real :: net_salt_input !< The total salt added by surface fluxes since the last - !! time that write_energy was called [ppt kg]. - real :: heat_prev !< The total amount of heat in the ocean the last - !! time that write_energy was called [J]. - real :: net_heat_input !< The total heat added by surface fluxes since the last - !! the last time that write_energy was called [J]. - type(EFP_type) :: fresh_water_in_EFP !< An extended fixed point version of fresh_water_input - type(EFP_type) :: net_salt_in_EFP !< An extended fixed point version of net_salt_input - type(EFP_type) :: net_heat_in_EFP !< An extended fixed point version of net_heat_input - type(EFP_type) :: heat_prev_EFP !< An extended fixed point version of heat_prev - type(EFP_type) :: salt_prev_EFP !< An extended fixed point version of salt_prev - type(EFP_type) :: mass_prev_EFP !< An extended fixed point version of mass_prev + 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 @@ -355,12 +349,9 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, OBC, dt_ ! to this subroutine divided by total mass [ppt]. real :: salin_anom ! The change in total salt that cannot be accounted for by ! the surface fluxes divided by total mass [ppt]. - real :: salin_mass_in ! The mass of salt input since the last call [kg]. 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 :: 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_chg ! The change in total heat divided by total heat capacity ! of the ocean since the last call to this subroutine, degC. @@ -373,9 +364,20 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, OBC, dt_ ! 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, & ! Extended fixed point sums of total mass, etc. - salt_EFP, heat_EFP, salt_chg_EFP, heat_chg_EFP, mass_chg_EFP, & - mass_anom_EFP, salt_anom_EFP, heat_anom_EFP + 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]. 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]. @@ -393,7 +395,7 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, OBC, dt_ ! calculation [kg T2 R-1 Z-1 L-2 s-2 ~> nondim] integer :: num_nc_fields ! The number of fields that will actually go into ! the NetCDF file. - integer :: i, j, k, is, ie, js, je, ns, nz, m, Isq, Ieq, Jsq, Jeq + integer :: i, j, k, is, ie, js, je, ns, nz, m, Isq, Ieq, Jsq, Jeq, isr, ier, jsr, jer integer :: l, lbelow, labove ! indices of deep_area_vol, used to find Z_0APE. ! lbelow & labove are lower & upper limits for l ! in the search for the entry in lH to use. @@ -481,6 +483,8 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, OBC, dt_ is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%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 @@ -525,7 +529,7 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, OBC, dt_ enddo endif - mass_tot = reproducing_sum(tmp1, sums=mass_lay, EFP_sum=mass_EFP) + 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 @@ -533,19 +537,19 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, OBC, dt_ 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, sums=mass_lay, EFP_sum=mass_EFP) + mass_tot = reproducing_sum(tmp1, isr, ier, jsr, jer, sums=mass_lay, EFP_sum=mass_EFP) call find_eta(h, tv, G, GV, US, eta) 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, sums=vol_lay) + vol_tot = reproducing_sum(tmp1, isr, ier, jsr, jer, sums=vol_lay) do k=1,nz ; vol_lay(k) = US%m_to_Z*US%m_to_L**2 * vol_lay(k) ; enddo else do k=1,nz ; do j=js,je ; do i=is,ie tmp1(i,j,k) = HL2_to_kg * h(i,j,k) * areaTm(i,j) enddo ; enddo ; enddo - mass_tot = reproducing_sum(tmp1, sums=mass_lay, EFP_sum=mass_EFP) + mass_tot = reproducing_sum(tmp1, isr, ier, jsr, jer, sums=mass_lay, EFP_sum=mass_EFP) do k=1,nz ; vol_lay(k) = US%m_to_Z*US%m_to_L**2*US%kg_m3_to_R * (mass_lay(k) / GV%Rho0) ; enddo endif endif ! Boussinesq @@ -567,10 +571,12 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, OBC, dt_ endif if (CS%previous_calls == 0) then - CS%mass_prev = mass_tot ; CS%fresh_water_input = 0.0 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 @@ -685,7 +691,7 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, OBC, dt_ enddo ; enddo endif - PE_tot = reproducing_sum(PE_pt, sums=PE) + 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 @@ -699,7 +705,7 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, OBC, dt_ 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, sums=KE) + KE_tot = reproducing_sum(tmp1, isr, ier, jsr, jer, sums=KE) toten = KE_tot + PE_tot @@ -712,28 +718,41 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, OBC, dt_ 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 = reproducing_sum(Salt_int, EFP_sum=salt_EFP) - Heat = reproducing_sum(Temp_int, EFP_sum=heat_EFP) + 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 - if (u(I,j,k) < 0.0) then - CFL_trans = (-u(I,j,k) * CS%dt_in_T) * (G%dy_Cu(I,j) * G%IareaT(i+1,j)) - else - CFL_trans = (u(I,j,k) * CS%dt_in_T) * (G%dy_Cu(I,j) * G%IareaT(i,j)) - endif + 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 - if (v(i,J,k) < 0.0) then - CFL_trans = (-v(i,J,k) * CS%dt_in_T) * (G%dx_Cv(i,J) * G%IareaT(i,j+1)) - else - CFL_trans = (v(i,J,k) * CS%dt_in_T) * (G%dx_Cv(i,J) * G%IareaT(i,j)) - endif + 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) @@ -745,38 +764,31 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, OBC, dt_ ! The sum of Tr_stocks should be reimplemented using the reproducing sums. if (nTr_stocks > 0) call sum_across_PEs(Tr_stocks,nTr_stocks) - call max_across_PEs(max_CFL(1)) - call max_across_PEs(max_CFL(2)) - if (CS%use_temperature .and. CS%previous_calls == 0) then - CS%salt_prev = Salt ; CS%net_salt_input = 0.0 - CS%heat_prev = Heat ; CS%net_heat_input = 0.0 - - 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 + call max_across_PEs(max_CFL, 2) Irho0 = 1.0 / (US%R_to_kg_m3*GV%Rho0) 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_chg = EFP_to_real(Salt_chg_EFP) ; Salt_anom = EFP_to_real(Salt_anom_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_chg = EFP_to_real(Heat_chg_EFP) ; Heat_anom = EFP_to_real(Heat_anom_EFP) + Heat_anom = EFP_to_real(Heat_anom_EFP) endif mass_chg_EFP = mass_EFP - CS%mass_prev_EFP - salin_mass_in = 0.0 - if (GV%Boussinesq) then - mass_anom_EFP = mass_chg_EFP - CS%fresh_water_in_EFP - else + 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_EFP = mass_chg_EFP - CS%fresh_water_in_EFP - if (CS%use_temperature) & - salin_mass_in = 0.001*EFP_to_real(CS%net_salt_in_EFP) + mass_anom = mass_anom - 0.001*EFP_to_real(CS%net_salt_in_EFP) endif mass_chg = EFP_to_real(mass_chg_EFP) - mass_anom = EFP_to_real(mass_anom_EFP) - salin_mass_in if (CS%use_temperature) then salin = Salt / mass_tot ; salin_anom = Salt_anom / mass_tot @@ -893,7 +905,7 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, OBC, dt_ call write_field(CS%fileenergy_nc, CS%fields(8), mass_chg, reday) call write_field(CS%fileenergy_nc, CS%fields(9), mass_anom, reday) call write_field(CS%fileenergy_nc, CS%fields(10), max_CFL(1), reday) - call write_field(CS%fileenergy_nc, CS%fields(11), max_CFL(1), reday) + call write_field(CS%fileenergy_nc, CS%fields(11), max_CFL(2), reday) if (CS%use_temperature) then call write_field(CS%fileenergy_nc, CS%fields(12), 0.001*Salt, reday) call write_field(CS%fileenergy_nc, CS%fields(13), 0.001*salt_chg, reday) @@ -925,17 +937,13 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, OBC, dt_ endif CS%ntrunc = 0 CS%previous_calls = CS%previous_calls + 1 - CS%mass_prev = mass_tot ; CS%fresh_water_input = 0.0 - if (CS%use_temperature) then - CS%salt_prev = Salt ; CS%net_salt_input = 0.0 - CS%heat_prev = Heat ; CS%net_heat_input = 0.0 - endif 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 accumates the net input of volume, salt and heat, through @@ -969,19 +977,22 @@ subroutine accumulate_net_input(fluxes, sfc_state, tv, dt, G, US, CS) 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, & ! Extended fixed point version of FW_input [kg] - salt_in_EFP, & ! Extended fixed point version of salt_input [ppt kg] - heat_in_EFP ! Extended fixed point version of heat_input [J] + 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]. real :: inputs(3) ! A mixed array for combining the sums - integer :: i, j, is, ie, js, je + 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 ; FW_input = 0.0 + 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 @@ -1059,13 +1070,12 @@ subroutine accumulate_net_input(fluxes, sfc_state, tv, dt, G, US, CS) if ((CS%use_temperature) .or. associated(fluxes%lprec) .or. & associated(fluxes%evap)) then - FW_input = reproducing_sum(FW_in, EFP_sum=FW_in_EFP) - heat_input = reproducing_sum(heat_in, EFP_sum=heat_in_EFP) - salt_input = reproducing_sum(salt_in, EFP_sum=salt_in_EFP) - - CS%fresh_water_input = CS%fresh_water_input + FW_input - CS%net_salt_input = CS%net_salt_input + salt_input - CS%net_heat_input = CS%net_heat_input + heat_input + ! 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 diff --git a/src/diagnostics/MOM_wave_speed.F90 b/src/diagnostics/MOM_wave_speed.F90 index 56545dc50d..8b50fe1acb 100644 --- a/src/diagnostics/MOM_wave_speed.F90 +++ b/src/diagnostics/MOM_wave_speed.F90 @@ -30,6 +30,8 @@ module MOM_wave_speed !! 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. This parameter controls the default behavior of @@ -38,6 +40,9 @@ module MOM_wave_speed !! calculating the equivalent barotropic wave speed [Z ~> m]. !! 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] type(remapping_CS) :: remapping_CS !< Used for vertical remapping when calculating equivalent barotropic !! mode structure. logical :: remap_answers_2018 = .true. !< If true, use the order of arithmetic and expressions that @@ -49,8 +54,8 @@ module MOM_wave_speed contains !> Calculates the wave speed of the first baroclinic mode. -subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & - mono_N2_column_fraction, mono_N2_depth, modal_structure) +subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_N2_column_fraction, & + mono_N2_depth, modal_structure, better_speed_est, min_speed, wave_speed_tol) 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 @@ -59,31 +64,38 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & 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), pointer :: CS !< Control structure for MOM_wave_speed - logical, optional, intent(in) :: full_halos !< If true, do the calculation + logical, optional, intent(in) :: full_halos !< If true, do the calculation !! over the entire computational domain. - logical, optional, intent(in) :: use_ebt_mode !< If true, use the equivalent + 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 + 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. - real, optional, intent(in) :: mono_N2_depth !< A depth below which N2 is limited as + real, optional, intent(in) :: mono_N2_depth !< A depth below which N2 is limited as !! monotonic for the purposes of calculating vertical !! modal structure [Z ~> m]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - optional, intent(out) :: modal_structure !< Normalized model structure [nondim] + optional, intent(out) :: modal_structure !< Normalized model structure [nondim] + 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] ! Local variables real, dimension(SZK_(G)+1) :: & dRho_dT, & ! Partial derivative of density with temperature [R degC-1 ~> kg m-3 degC-1] dRho_dS, & ! Partial derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1] - pres, & ! Interface pressure [Pa] + pres, & ! Interface pressure [R L2 T-2 ~> Pa] T_int, & ! Temperature interpolated to interfaces [degC] S_int, & ! Salinity interpolated to interfaces [ppt] + H_top, & ! The distance of each filtered interface from the ocean surface [Z ~> m] + H_bot, & ! The distance of each filtered interface from the bottom [Z ~> m] gprime ! The reduced gravity across each interface [L2 Z-1 T-2 ~> m s-2]. real, dimension(SZK_(G)) :: & - Igl, Igu, Igd ! The inverse of the reduced gravity across an interface times - ! the thickness of the layer below (Igl) or above (Igu) it. - ! Their sum, Igd, is provided for the tridiagonal solver. [T2 L-2 ~> s2 m-2] + 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_(G),SZI_(G)) :: & Hf, & ! Layer thicknesses after very thin layers are combined [Z ~> m] Tf, & ! Layer temperatures after very thin layers are combined [degC] @@ -95,12 +107,13 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & Sc, & ! A column of layer salinites after convective istabilities are removed [ppt] Rc, & ! A column of layer densities after convective istabilities are removed [R ~> kg m-3] Hc_H ! Hc(:) rescaled from Z to thickness units [H ~> m or kg m-2] + real :: I_Htot ! The inverse of the total filtered thicknesses [Z ~> m] real :: det, ddet, detKm1, detKm2, ddetKm1, ddetKm2 real :: lam ! The eigenvalue [T2 L-2 ~> s m-1] real :: dlam ! The change in estimates of the eigenvalue [T2 L-2 ~> s m-1] real :: lam0 ! The first guess of the eigenvalue [T2 L-2 ~> s m-1] real :: min_h_frac ! [nondim] - real :: Z_to_Pa ! A conversion factor from thicknesses (in Z) to pressure (in Pa) + real :: Z_to_pres ! A conversion factor from thicknesses to pressure [R L2 T-2 Z-1 ~> Pa m-1] real, dimension(SZI_(G)) :: & htot, hmin, & ! Thicknesses [Z ~> m] H_here, & ! A thickness [Z ~> m] @@ -108,22 +121,28 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & HxS_here, & ! A layer integrated salinity [ppt Z ~> ppt m] HxR_here ! A layer integrated density [R Z ~> kg m-2] real :: speed2_tot ! overestimate of the mode-1 speed squared [L2 T-2 ~> m2 s-2] + real :: cg1_min2 ! A floor in the squared first mode speed below which 0 is returned [L2 T-2 ~> m2 s-2] real :: I_Hnew ! The inverse of a new layer thickness [Z-1 ~> m-1] - real :: drxh_sum ! The sum of density diffrences across interfaces times thicknesses [R Z ~> kg m-2] + real :: drxh_sum ! The sum of density differences across interfaces times thicknesses [R Z ~> kg m-2] real :: L2_to_Z2 ! A scaling factor squared from units of lateral distances to depths [Z2 L-2 ~> 1]. - real, parameter :: tol1 = 0.0001, tol2 = 0.001 real, pointer, dimension(:,:,:) :: T => NULL(), S => NULL() - real :: g_Rho0 ! G_Earth/Rho0 [L2 T-2 Z-1 R-1 ~> m4 s-2 kg-1]. + real :: g_Rho0 ! G_Earth/Rho0 [L2 T-2 Z-1 R-1 ~> m4 s-2 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. 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. + 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, I_rescale - integer :: kf(SZI_(G)) + integer :: kf(SZI_(G)) ! The number of active layers after filtering. integer, parameter :: max_itt = 10 real :: lam_it(max_itt), det_it(max_itt), ddet_it(max_itt) - logical :: use_EOS ! If true, density is calculated from T & S using an - ! equation of state. - integer :: kc + logical :: use_EOS ! If true, density is calculated from T & S using an equation of state. + logical :: better_est ! If true, use an improved estimate of the first mode internal wave speed. + logical :: merge ! If true, merge the current layer with the one above. + integer :: kc ! The number of layers in the column after merging integer :: i, j, k, k2, itt, is, ie, js, je, nz real :: hw, sum_hc real :: gp ! A limited local copy of gprime [L2 Z-1 T-2 ~> m s-2] @@ -158,25 +177,42 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & S => tv%S ; T => tv%T g_Rho0 = GV%g_Earth / GV%Rho0 - Z_to_Pa = GV%Z_to_H * GV%H_to_Pa + ! Simplifying the following could change answers at roundoff. + Z_to_pres = GV%Z_to_H * (GV%H_to_RZ * GV%g_Earth) use_EOS = associated(tv%eqn_of_state) + better_est = CS%better_cg1_est ; if (present(better_speed_est)) better_est = better_speed_est + + if (better_est) then + tol_solve = CS%wave_speed_tol ; if (present(wave_speed_tol)) tol_solve = 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 ; if (present(min_speed)) cg1_min2 = min_speed**2 rescale = 1024.0**4 ; I_rescale = 1.0/rescale - ! The following two lines give identical results: - ! c2_scale = 16.0 * US%m_s_to_L_T**2 - c2_scale = US%m_s_to_L_T**2 + c2_scale = US%m_s_to_L_T**2 / 4096.0**2 ! Other powers of 2 give identical results. - min_h_frac = tol1 / real(nz) + min_h_frac = tol_Hfrac / real(nz) !$OMP parallel do default(none) shared(is,ie,js,je,nz,h,G,GV,US,min_h_frac,use_EOS,T,S,tv,& !$OMP calc_modal_structure,l_use_ebt_mode,modal_structure, & !$OMP l_mono_N2_column_fraction,l_mono_N2_depth,CS, & -!$OMP Z_to_Pa,cg1,g_Rho0,rescale,I_rescale,L2_to_Z2,c2_scale) & +!$OMP Z_to_pres,cg1,g_Rho0,rescale,I_rescale,L2_to_Z2, & +!$OMP better_est,cg1_min2,tol_merge,tol_solve,c2_scale) & !$OMP private(htot,hmin,kf,H_here,HxT_here,HxS_here,HxR_here, & -!$OMP Hf,Tf,Sf,Rf,pres,T_int,S_int,drho_dT, & -!$OMP drho_dS,drxh_sum,kc,Hc,Hc_H,Tc,Sc,I_Hnew,gprime,& -!$OMP Rc,speed2_tot,Igl,Igu,Igd,lam0,lam,lam_it,dlam, & +!$OMP Hf,Tf,Sf,Rf,pres,T_int,S_int,drho_dT,drho_dS, & +!$OMP drxh_sum,kc,Hc,Hc_H,tC,sc,I_Hnew,gprime,& +!$OMP Rc,speed2_tot,Igl,Igu,lam0,lam,lam_it,dlam, & !$OMP mode_struct,sum_hc,N2min,gp,hw, & -!$OMP ms_min,ms_max,ms_sq, & +!$OMP ms_min,ms_max,ms_sq,H_top,H_bot,I_Htot,merge, & !$OMP det,ddet,detKm1,ddetKm1,detKm2,ddetKm2,det_it,ddet_it) do j=js,je ! First merge very thin layers with the one above (or below if they are @@ -231,52 +267,85 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & endif ; enddo endif - ! From this point, we can work on individual columns without causing memory - ! to have page faults. + ! From this point, we can work on individual columns without causing memory to have page faults. do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then if (use_EOS) then - pres(1) = 0.0 - do k=2,kf(i) - pres(k) = pres(k-1) + Z_to_Pa*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)) + pres(1) = 0.0 ; H_top(1) = 0.0 + do K=2,kf(i) + pres(K) = pres(K-1) + Z_to_pres*Hf(k-1,i) + T_int(K) = 0.5*(Tf(k,i)+Tf(k-1,i)) + S_int(K) = 0.5*(Sf(k,i)+Sf(k-1,i)) + H_top(K) = H_top(K-1) + Hf(k-1,i) enddo - call calculate_density_derivs(T_int, S_int, pres, drho_dT, drho_dS, 2, & - kf(i)-1, tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density_derivs(T_int, S_int, pres, drho_dT, drho_dS, & + tv%eqn_of_state, (/2,kf(i)/) ) - ! Sum the reduced gravities to find out how small a density difference - ! is negligibly small. + ! Sum the reduced gravities to find out how small a density difference is negligibly small. drxh_sum = 0.0 - do k=2,kf(i) - drxh_sum = drxh_sum + 0.5*(Hf(k-1,i)+Hf(k,i)) * & - max(0.0,drho_dT(k)*(Tf(k,i)-Tf(k-1,i)) + & - drho_dS(k)*(Sf(k,i)-Sf(k-1,i))) - enddo + if (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 + 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 + else + ! This estimate is problematic in that it goes like 1/nz for a large number of layers, + ! but it is an overestimate (as desired) for a small number of layers, by at a factor + ! of (H1+H2)**2/(H1*H2) >= 4 for two thick layers. + do K=2,kf(i) + drxh_sum = drxh_sum + 0.5*(Hf(k-1,i)+Hf(k,i)) * & + max(0.0, drho_dT(K)*(Tf(k,i)-Tf(k-1,i)) + drho_dS(K)*(Sf(k,i)-Sf(k-1,i))) + enddo + endif else drxh_sum = 0.0 - 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 - - if (calc_modal_structure) then - mode_struct(:) = 0. + if (better_est) then + H_top(1) = 0.0 + do K=2,kf(i) ; H_top(K) = H_top(K-1) + Hf(k-1,i) ; enddo + if (H_top(kf(i)) > 0.0) then + I_Htot = 1.0 / (H_top(kf(i)) + Hf(kf(i),i)) ! = 1.0 / (H_top(K) + H_bot(K)) for all K. + H_bot(kf(i)+1) = 0.0 + do K=kf(i),2,-1 + H_bot(K) = H_bot(K+1) + Hf(k,i) + drxh_sum = drxh_sum + ((H_top(K) * H_bot(K)) * I_Htot) * max(0.0,Rf(k,i)-Rf(k-1,i)) + enddo + 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 - ! Find gprime across each internal interface, taking care of convective - ! instabilities by merging layers. - if (drxh_sum <= 0.0) then + ! Find gprime across each internal interface, taking care of convective instabilities by + ! merging layers. If the estimated wave speed is too small, simply return zero. + if (g_Rho0 * drxh_sum <= cg1_min2) then 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. + ! 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 ((drho_dT(k)*(Tf(k,i)-Tc(kc)) + drho_dS(k)*(Sf(k,i)-Sc(kc))) * & - (Hc(kc) + Hf(k,i)) < 2.0 * tol2*drxh_sum) then + if (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) + 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 @@ -285,9 +354,15 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & ! 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 ((drho_dT(k2)*(Tc(k2)-Tc(k2-1)) + drho_dS(k2)*(Sc(k2)-Sc(k2-1))) * & - (Hc(k2) + Hc(k2-1)) < tol2*drxh_sum) then + do K2=kc,2,-1 + if (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) + 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 @@ -299,21 +374,25 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & else ! Add a new layer to the column. kc = kc + 1 - drho_dS(kc) = drho_dS(k) ; drho_dT(kc) = drho_dT(k) + drho_dS(Kc) = drho_dS(K) ; drho_dT(Kc) = drho_dT(K) Tc(kc) = Tf(k,i) ; Sc(kc) = Sf(k,i) ; Hc(kc) = Hf(k,i) endif enddo ! At this point there are kc layers and the gprimes should be positive. - do k=2,kc ! Revisit this if non-Boussinesq. - gprime(k) = g_Rho0 * (drho_dT(k)*(Tc(k)-Tc(k-1)) + & - drho_dS(k)*(Sc(k)-Sc(k-1))) + do K=2,kc ! Revisit this if non-Boussinesq. + gprime(K) = g_Rho0 * (drho_dT(K)*(Tc(k)-Tc(k-1)) + drho_dS(K)*(Sc(k)-Sc(k-1))) enddo else ! .not.use_EOS ! Do the same with density directly... kc = 1 Hc(1) = Hf(1,i) ; Rc(1) = Rf(1,i) do k=2,kf(i) - if ((Rf(k,i) - Rc(kc)) * (Hc(kc) + Hf(k,i)) < 2.0*tol2*drxh_sum) then + if (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)) @@ -321,7 +400,12 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & ! that the tolerance is a factor of two larger, to avoid limit how ! far back we go. do k2=kc,2,-1 - if ((Rc(k2)-Rc(k2-1)) * (Hc(k2)+Hc(k2-1)) < tol2*drxh_sum) then + 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)) @@ -335,8 +419,8 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & endif enddo ! At this point there are kc layers and the gprimes should be positive. - do k=2,kc ! Revisit this if non-Boussinesq. - gprime(k) = g_Rho0 * (Rc(k)-Rc(k-1)) + do K=2,kc ! Revisit this if non-Boussinesq. + gprime(K) = g_Rho0 * (Rc(k)-Rc(k-1)) enddo endif ! use_EOS @@ -345,6 +429,13 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & ! 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) @@ -365,23 +456,33 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & endif Igu(k) = 1.0/(gp*Hc(k)) Igl(k-1) = 1.0/(gp*Hc(k-1)) - speed2_tot = speed2_tot + gprime(k)*(Hc(k-1)+Hc(k))*0.707 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)) - speed2_tot = speed2_tot + gprime(k)*(Hc(k-1)+Hc(k)) + 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 - ! Overestimate the speed to start with. + ! Under estimate the first eigenvalue (overestimate the speed) to start with. if (calc_modal_structure) then lam0 = 0.5 / speed2_tot ; lam = lam0 else @@ -391,57 +492,27 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & do itt=1,max_itt lam_it(itt) = lam if (l_use_ebt_mode) then - ! This initialization of det,ddet imply Neumann boundary conditions so that first 3 rows - ! of the matrix are + ! 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 ... | - ! which is consistent if the eigenvalue problem is for horizontal velocity or pressure modes. - !detKm1 = c2_scale*(Igl(1)-lam) ; ddetKm1 = -1.0*c2_scale - !det = (Igu(2)+Igl(2)-lam)*detKm1 - (Igu(2)*Igl(1)) ; ddet = (Igu(2)+Igl(2)-lam)*ddetKm1 - detKm1 - detKm1 = 1.0 ; ddetKm1 = 0.0 - det = (Igl(1)-lam) ; ddet = -1.0 - if (kc>1) then - ! Shift variables and rescale rows to avoid over- or underflow. - detKm2 = c2_scale*detKm1 ; ddetKm2 = c2_scale*ddetKm1 - detKm1 = c2_scale*det ; ddetKm1 = c2_scale*ddet - det = (Igu(2)+Igl(2)-lam)*detKm1 - (Igu(2)*Igl(1))*detKm2 - ddet = (Igu(2)+Igl(2)-lam)*ddetKm1 - (Igu(2)*Igl(1))*ddetKm2 - detKm1 - endif ! 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 so that first 3 rows - ! of the matrix are + ! 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 igu43) b(4)-lam igl(4) 0 ... | - ! which is consistent if the eigenvalue problem is for vertical velocity modes. - detKm1 = 1.0 ; ddetKm1 = 0.0 - det = (Igu(2) + Igl(2) - lam) ; ddet = -1.0 + ! | 0 igu(4) b(4)-lam igl(4) 0 ... | ! The last three rows of the w equation matrix are - ! | ... 0 igu(kc-1) b(kc-1)-lam igl(kc-1) 0 | + ! | ... 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 - do k=3,kc - ! Shift variables and rescale rows to avoid over- or underflow. - detKm2 = c2_scale*detKm1 ; ddetKm2 = c2_scale*ddetKm1 - detKm1 = c2_scale*det ; ddetKm1 = c2_scale*ddet - - det = (Igu(k)+Igl(k)-lam)*detKm1 - (Igu(k)*Igl(k-1))*detKm2 - ddet = (Igu(k)+Igl(k)-lam)*ddetKm1 - (Igu(k)*Igl(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 ! Use Newton's method iteration to find a new estimate of lam. det_it(itt) = det ; ddet_it(itt) = ddet @@ -457,10 +528,7 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & endif if (calc_modal_structure) then - do k = 1,kc - Igd(k) = Igu(k) + Igl(k) - enddo - call tdma6(kc, -Igu, Igd, -Igl, lam, mode_struct) + call tdma6(kc, Igu, Igl, lam, mode_struct) ms_min = mode_struct(1) ms_max = mode_struct(1) ms_sq = mode_struct(1)**2 @@ -478,7 +546,7 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & endif endif - if (abs(dlam) < tol2*lam) exit + if (abs(dlam) < tol_solve*lam) exit enddo cg1(i,j) = 0.0 @@ -518,55 +586,59 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & end subroutine wave_speed -!> Solve a non-symmetric tridiagonal problem with a scalar contribution to the leading diagonal. +!> Solve a non-symmetric tridiagonal problem with the sum of the upper and lower diagnonals 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, b, c, lam, y) +subroutine tdma6(n, a, c, lam, y) integer, intent(in) :: n !< Number of rows of matrix - real, dimension(n), intent(in) :: a !< Lower diagonal [T2 L-2 ~> s2 m-2] - real, dimension(n), intent(in) :: b !< Leading diagonal [T2 L-2 ~> s2 m-2] - real, dimension(n), intent(in) :: c !< Upper diagonal [T2 L-2 ~> s2 m-2] + 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(n), intent(inout) :: y !< RHS on entry, result on exit + real, dimension(:), intent(inout) :: y !< RHS on entry, result on exit + ! Local variables - integer :: k, l - real :: beta(n), lambda ! Temporary variables in [T2 L-2 ~> s2 m-2] - real :: I_beta(n) ! Temporary variables in [L2 T-2 ~> m2 s-2] - real :: yy(n) ! A temporary variable with the same units as y on entry. + 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. + integer :: k, m lambda = lam - beta(1) = b(1) - lambda + 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) = b(1) - 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) = ( b(k) - lambda ) - a(k) * c(k-1) * I_beta(k-1) + 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. / ( b(1) - lambda ) - do l = 2, k - I_beta(l) = 1. / ( ( b(l) - lambda ) - a(l) * c(l-1) * I_beta(l-1) ) - yy(l) = y(l) - a(l) * yy(l-1) * I_beta(l-1) + 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) + 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] 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) + 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, full_halos) +subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos, better_speed_est, & + min_speed, wave_speed_tol) 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 @@ -577,37 +649,45 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) type(wave_speed_CS), optional, pointer :: CS !< Control structure for MOM_wave_speed logical, optional, intent(in) :: full_halos !< If true, do the calculation !! over the entire computational domain. + 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] + ! Local variables real, dimension(SZK_(G)+1) :: & dRho_dT, & ! Partial derivative of density with temperature [R degC-1 ~> kg m-3 degC-1] dRho_dS, & ! Partial derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1] - pres, & ! Interface pressure [Pa] + pres, & ! Interface pressure [R L2 T-2 ~> Pa] T_int, & ! Temperature interpolated to interfaces [degC] S_int, & ! Salinity interpolated to interfaces [ppt] + H_top, & ! The distance of each filtered interface from the ocean surface [Z ~> m] + H_bot, & ! The distance of each filtered interface from the bottom [Z ~> m] gprime ! The reduced gravity across each interface [L2 Z-1 T-2 ~> m s-2]. - real, dimension(SZK_(G)) :: & - 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_(G)-1) :: & - a_diag, b_diag, c_diag - ! diagonals of tridiagonal matrix; one value for each - ! interface (excluding surface and bottom) [T2 L-2 ~> s2 m-2] real, dimension(SZK_(G),SZI_(G)) :: & Hf, & ! Layer thicknesses after very thin layers are combined [Z ~> m] Tf, & ! Layer temperatures after very thin layers are combined [degC] Sf, & ! Layer salinities after very thin layers are combined [ppt] Rf ! Layer densities after very thin layers are combined [R ~> kg m-3] real, dimension(SZK_(G)) :: & + 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 istabilities are removed [Z ~> m] Tc, & ! A column of layer temperatures after convective istabilities are removed [degC] Sc, & ! A column of layer salinites after convective istabilities are removed [ppt] Rc ! A column of layer densities after convective istabilities are removed [R ~> kg m-3] + real :: I_Htot ! The inverse of the total filtered thicknesses [Z ~> m] real :: c1_thresh ! if c1 is below this value, don't bother calculating ! cn values for higher modes [L T-1 ~> m s-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. The + ! exact value should not matter for the final result if it is an even power of 2. real :: det, ddet ! determinant & its derivative of eigen system 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 ! increment in lam for Newton's method [T2 L-2 ~> s2 m-2] + real :: dlam ! The change in estimates of the eigenvalue [T2 L-2 ~> s m-1] 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] @@ -620,8 +700,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) 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 :: min_h_frac - real :: Z_to_Pa ! A conversion factor from thicknesses (in Z) to pressure (in Pa) + real :: Z_to_pres ! A conversion factor from thicknesses to pressure [R L2 T-2 Z-1 ~> Pa m-1] real, dimension(SZI_(G)) :: & htot, hmin, & ! Thicknesses [Z ~> m] H_here, & ! A thickness [Z ~> m] @@ -630,24 +709,30 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) HxR_here ! A layer integrated density [R Z ~> kg m-2] 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, parameter :: reduct_factor = 0.5 - ! factor used in setting speed2_min [nondim] + ! A factor used in setting speed2_min [nondim] real :: I_Hnew ! The inverse of a new layer thickness [Z-1 ~> m-1] - real :: drxh_sum ! The sum of density diffrences across interfaces times thicknesses [R Z ~> kg m-2] - real, parameter :: tol1 = 0.0001, tol2 = 0.001 + real :: drxh_sum ! The sum of density differences across interfaces times thicknesses [R Z ~> kg m-2] real, pointer, dimension(:,:,:) :: T => NULL(), S => NULL() - real :: g_Rho0 ! G_Earth/Rho0 [L2 T-2 Z-1 R-1 ~> m4 s-2 kg-1]. - integer :: kf(SZI_(G)) + real :: g_Rho0 ! G_Earth/Rho0 [L2 T-2 Z-1 R-1 ~> m4 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. + 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 = 10 logical :: use_EOS ! If true, density is calculated from T & S using the equation of state. - real, dimension(SZK_(G)+1) :: z_int - ! real, dimension(SZK_(G)+1) :: N2 ! The local squared buoyancy frequency [T-2 ~> s-2] + 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, nrows + 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, row, iint, m, ig, jg @@ -664,13 +749,32 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) S => tv%S ; T => tv%T g_Rho0 = GV%g_Earth / GV%Rho0 + ! Simplifying the following could change answers at roundoff. + Z_to_pres = GV%Z_to_H * (GV%H_to_RZ * GV%g_Earth) use_EOS = associated(tv%eqn_of_state) - Z_to_Pa = GV%Z_to_H * GV%H_to_Pa c1_thresh = 0.01*US%m_s_to_L_T + c2_scale = US%m_s_to_L_T**2 / 4096.0**2 ! Other powers of 2 give identical results. + + better_est = .false. ; if (present(CS)) better_est = CS%better_cg1_est + if (present(better_speed_est)) better_est = better_speed_est + if (better_est) then + tol_solve = 0.001 ; if (present(CS)) tol_solve = CS%wave_speed_tol + if (present(wave_speed_tol)) tol_solve = 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 = 0.0 ; if (present(CS)) cg1_min2 = CS%min_speed2 + if (present(min_speed)) cg1_min2 = min_speed**2 + + ! Zero out all wave speeds. Values over land or for columns that are too weakly stratified + ! are not changed from this zero value. + cn(:,:,:) = 0.0 - min_h_frac = tol1 / real(nz) + min_h_frac = tol_Hfrac / real(nz) !$OMP parallel do default(private) shared(is,ie,js,je,nz,h,G,GV,US,min_h_frac,use_EOS,T,S, & - !$OMP Z_to_Pa,tv,cn,g_Rho0,nmodes) + !$OMP Z_to_pres,tv,cn,g_Rho0,nmodes,cg1_min2,better_est, & + !$OMP c1_thresh,tol_solve,tol_merge) do j=js,je ! First merge very thin layers with the one above (or below if they are ! at the top). This also transposes the row order so that columns can @@ -724,48 +828,83 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) endif ; enddo endif - ! From this point, we can work on individual columns without causing memory - ! to have page faults. + ! From this point, we can work on individual columns without causing memory to have page faults. do i=is,ie if (G%mask2dT(i,j) > 0.5) then if (use_EOS) then - pres(1) = 0.0 - do k=2,kf(i) - pres(k) = pres(k-1) + Z_to_Pa*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)) + pres(1) = 0.0 ; H_top(1) = 0.0 + do K=2,kf(i) + pres(K) = pres(K-1) + Z_to_pres*Hf(k-1,i) + T_int(K) = 0.5*(Tf(k,i)+Tf(k-1,i)) + S_int(K) = 0.5*(Sf(k,i)+Sf(k-1,i)) + H_top(K) = H_top(K-1) + Hf(k-1,i) enddo - call calculate_density_derivs(T_int, S_int, pres, drho_dT, drho_dS, 2, & - kf(i)-1, tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density_derivs(T_int, S_int, pres, drho_dT, drho_dS, & + tv%eqn_of_state, (/2,kf(i)/) ) - ! Sum the reduced gravities to find out how small a density difference - ! is negligibly small. + ! Sum the reduced gravities to find out how small a density difference is negligibly small. drxh_sum = 0.0 - do k=2,kf(i) - drxh_sum = drxh_sum + 0.5*(Hf(k-1,i)+Hf(k,i)) * & - max(0.0,drho_dT(k)*(Tf(k,i)-Tf(k-1,i)) + & - drho_dS(k)*(Sf(k,i)-Sf(k-1,i))) - enddo + if (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 + 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 + else + ! This estimate is problematic in that it goes like 1/nz for a large number of layers, + ! but it is an overestimate (as desired) for a small number of layers, by at a factor + ! of (H1+H2)**2/(H1*H2) >= 4 for two thick layers. + do K=2,kf(i) + drxh_sum = drxh_sum + 0.5*(Hf(k-1,i)+Hf(k,i)) * & + max(0.0, drho_dT(K)*(Tf(k,i)-Tf(k-1,i)) + drho_dS(K)*(Sf(k,i)-Sf(k-1,i))) + enddo + endif else drxh_sum = 0.0 - do k=2,kf(i) - drxh_sum = drxh_sum + 0.5*(Hf(k-1,i)+Hf(k,i)) * & - max(0.0,Rf(k,i)-Rf(k-1,i)) - enddo + if (better_est) then + H_top(1) = 0.0 + do K=2,kf(i) ; H_top(K) = H_top(K-1) + Hf(k-1,i) ; enddo + if (H_top(kf(i)) > 0.0) then + I_Htot = 1.0 / (H_top(kf(i)) + Hf(kf(i),i)) ! = 1.0 / (H_top(K) + H_bot(K)) for all K. + H_bot(kf(i)+1) = 0.0 + do K=kf(i),2,-1 + H_bot(K) = H_bot(K+1) + Hf(k,i) + drxh_sum = drxh_sum + ((H_top(K) * H_bot(K)) * I_Htot) * max(0.0,Rf(k,i)-Rf(k-1,i)) + enddo + 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 - ! Find gprime across each internal interface, taking care of convective - ! instabilities by merging layers. - if (drxh_sum <= 0.0) then - cn(i,j,:) = 0.0 - else + + ! Find gprime across each internal interface, taking care of convective + ! instabilities by merging layers. + if (g_Rho0 * drxh_sum > cg1_min2) then ! Merge layers to eliminate convective instabilities or exceedingly - ! small reduced gravities. + ! 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 ((drho_dT(k)*(Tf(k,i)-Tc(kc)) + drho_dS(k)*(Sf(k,i)-Sc(kc))) * & - (Hc(kc) + Hf(k,i)) < 2.0 * tol2*drxh_sum) then + if (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) + 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 @@ -774,9 +913,15 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) ! 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 ((drho_dT(k2)*(Tc(k2)-Tc(k2-1)) + drho_dS(k2)*(Sc(k2)-Sc(k2-1))) * & - (Hc(k2) + Hc(k2-1)) < tol2*drxh_sum) then + do K2=kc,2,-1 + if (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) + 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 @@ -788,21 +933,25 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) else ! Add a new layer to the column. kc = kc + 1 - drho_dS(kc) = drho_dS(k) ; drho_dT(kc) = drho_dT(k) + drho_dS(Kc) = drho_dS(K) ; drho_dT(Kc) = drho_dT(K) Tc(kc) = Tf(k,i) ; Sc(kc) = Sf(k,i) ; Hc(kc) = Hf(k,i) endif enddo ! At this point there are kc layers and the gprimes should be positive. - do k=2,kc ! Revisit this if non-Boussinesq. - gprime(k) = g_Rho0 * (drho_dT(k)*(Tc(k)-Tc(k-1)) + & - drho_dS(k)*(Sc(k)-Sc(k-1))) + do K=2,kc ! Revisit this if non-Boussinesq. + gprime(K) = g_Rho0 * (drho_dT(K)*(Tc(k)-Tc(k-1)) + drho_dS(K)*(Sc(k)-Sc(k-1))) enddo else ! .not.use_EOS ! Do the same with density directly... kc = 1 Hc(1) = Hf(1,i) ; Rc(1) = Rf(1,i) do k=2,kf(i) - if ((Rf(k,i) - Rc(kc)) * (Hc(kc) + Hf(k,i)) < 2.0*tol2*drxh_sum) then + if (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)) @@ -810,7 +959,12 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) ! that the tolerance is a factor of two larger, to avoid limit how ! far back we go. do k2=kc,2,-1 - if ((Rc(k2)-Rc(k2-1)) * (Hc(k2)+Hc(k2-1)) < tol2*drxh_sum) then + 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)) @@ -824,90 +978,68 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) endif enddo ! At this point there are kc layers and the gprimes should be positive. - do k=2,kc ! Revisit this if non-Boussinesq. - gprime(k) = g_Rho0 * (Rc(k)-Rc(k-1)) + do K=2,kc ! Revisit this if non-Boussinesq. + gprime(K) = g_Rho0 * (Rc(k)-Rc(k-1)) enddo endif ! use_EOS !-----------------NOW FIND WAVE SPEEDS--------------------------------------- - ig = i + G%idg_offset ; jg = j + G%jdg_offset + ! 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. + ! 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 - ! Set depth at surface - z_int(1) = 0.0 ! 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)] do K=2,kc Igl(K) = 1.0/(gprime(K)*Hc(k)) ; Igu(K) = 1.0/(gprime(K)*Hc(k-1)) - z_int(K) = z_int(K-1) + Hc(k-1) - ! N2(K) = US%L_to_Z**2*gprime(K)/(0.5*(Hc(k)+Hc(k-1))) - speed2_tot = speed2_tot + gprime(K)*(Hc(k-1)+Hc(k)) + 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) - ! Calculate depth at bottom - z_int(kc+1) = z_int(kc)+Hc(kc) - ! check that thicknesses sum to total depth - if (abs(z_int(kc+1)-htot(i)) > 1.e-12*htot(i)) then - call MOM_error(FATAL, "wave_structure: mismatch in total depths") - endif - ! Define the diagonals of the tridiagonal matrix - ! First, populate interior rows - do K=3,kc-1 - row = K-1 ! indexing for TD matrix rows - a_diag(row) = -Igu(K) - b_diag(row) = Igu(K)+Igl(K) - c_diag(row) = -Igl(K) - enddo - ! Populate top row of tridiagonal matrix - K=2 ; row = K-1 - a_diag(row) = 0.0 - b_diag(row) = Igu(K)+Igl(K) - c_diag(row) = -Igl(K) - ! Populate bottom row of tridiagonal matrix - K=kc ; row = K-1 - a_diag(row) = -Igu(K) - b_diag(row) = Igu(K)+Igl(K) - c_diag(row) = 0.0 - ! Total number of rows in the matrix = number of interior interfaces - nrows = kc-1 - - ! Under estimate the first eigenvalue to start with. + ! Under estimate the first eigenvalue (overestimate the speed) to start with. lam_1 = 1.0 / speed2_tot ! Find the first eigen value do itt=1,max_itt ! calculate the determinant of (A-lam_1*I) - call tridiag_det(a_diag(1:nrows),b_diag(1:nrows),c_diag(1:nrows), & - nrows,lam_1,det,ddet, row_scale=US%m_s_to_L_T**2) - ! Use Newton's method iteration to find a new estimate of lam_1 + 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. + ! 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 - if (abs(dlam) < tol2*lam_1) then - ! calculate 1st mode speed - if (lam_1 > 0.0) cn(i,j,1) = 1.0 / sqrt(lam_1) - exit - endif endif + + if (abs(dlam) < tol_solve*lam_1) exit enddo + if (lam_1 > 0.0) cn(i,j,1) = 1.0 / sqrt(lam_1) + ! 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)>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 + tol2) + 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 @@ -920,14 +1052,12 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) ! that are beyond the first root ! find det_l of first interval (det at left endpoint) - call tridiag_det(a_diag(1:nrows),b_diag(1:nrows),c_diag(1:nrows), & - nrows,lamMin,det_l,ddet_l, row_scale=US%m_s_to_L_T**2) + 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(a_diag(1:nrows),b_diag(1:nrows),c_diag(1:nrows), & - nrows,xr,det_r,ddet_r, row_scale=US%m_s_to_L_T**2) + 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 @@ -947,8 +1077,8 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) ! 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(a_diag(1:nrows),b_diag(1:nrows),c_diag(1:nrows), & - nrows,xl_sub,det_sub,ddet_sub, row_scale=US%m_s_to_L_T**2) + 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. @@ -977,7 +1107,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) 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 + ! 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 @@ -990,27 +1120,18 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) lam_n = xbl(m) ! first guess is left edge of window do itt=1,max_itt ! calculate the determinant of (A-lam_n*I) - call tridiag_det(a_diag(1:nrows),b_diag(1:nrows),c_diag(1:nrows), & - nrows,lam_n,det,ddet, row_scale=US%m_s_to_L_T**2) + 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 - if (abs(dlam) < tol2*lam_1) then - ! calculate nth mode speed - if (lam_n > 0.0) cn(i,j,m+1) = 1.0 / sqrt(lam_n) - exit - endif ! within tol + 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) enddo ! n-loop - else - cn(i,j,2:nmodes) = 0.0 ! else too small to worry about endif ! if nmodes>1 .and. kc>nmodes .and. c1>c1_thresh - else - cn(i,j,:) = 0.0 endif ! if more than 2 layers endif ! if drxh_sum < 0 - else - cn(i,j,:) = 0.0 ! This is a land point. endif ! if not land enddo ! i-loop enddo ! j-loop @@ -1021,52 +1142,52 @@ end subroutine wave_speeds !! 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, b, c, nrows, lam, det_out, ddet_out, row_scale) - real, dimension(:), intent(in) :: a !< Lower diagonal of matrix (first entry = 0) - real, dimension(:), intent(in) :: b !< Leading diagonal of matrix (excluding lam) - real, dimension(:), intent(in) :: c !< Upper diagonal of matrix (last entry = 0) - integer, intent(in) :: nrows !< Size of matrix - real, intent(in) :: lam !< Value subtracted from b - real, intent(out):: det_out !< Determinant - real, intent(out):: ddet_out !< Derivative of determinant w.r.t. lam +subroutine tridiag_det(a, c, ks, ke, lam, det, ddet, row_scale) + real, dimension(:), intent(in) :: a !< Lower diagonal of matrix (first entry unused) + real, dimension(:), intent(in) :: c !< Upper diagonal of matrix (last entry unused) + 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 + real, intent(out):: det !< Determinant + real, intent(out):: ddet !< Derivative of determinant with lam real, optional, intent(in) :: row_scale !< A scaling factor of the rows of the !! matrix to limit the growth of the determinant ! Local variables - real, dimension(nrows) :: det ! value of recursion function - real, dimension(nrows) :: ddet ! value of recursion function for derivative - real, parameter:: rescale = 1024.0**4 ! max value of determinant allowed before rescaling - real :: rscl + real :: detKm1, detKm2 ! Cumulative value of the determinant for the previous two layers. + real :: ddetKm1, ddetKm2 ! Derivative of the cumulative determinant with lam for the previous two layers. + real, parameter :: rescale = 1024.0**4 ! max value of determinant allowed before rescaling + real :: rscl ! A rescaling factor that is applied succesively to each row. real :: I_rescale ! inverse of rescale - integer :: n ! row (layer interface) index - - if (size(b) /= nrows) call MOM_error(WARNING, "Diagonal b must be same length as nrows.") - if (size(a) /= nrows) call MOM_error(WARNING, "Diagonal a must be same length as nrows.") - if (size(c) /= nrows) call MOM_error(WARNING, "Diagonal c must be same length as nrows.") + integer :: k ! row (layer interface) index - I_rescale = 1.0/rescale + I_rescale = 1.0 / rescale rscl = 1.0 ; if (present(row_scale)) rscl = row_scale - det(1) = 1.0 ; ddet(1) = 0.0 - det(2) = b(2)-lam ; ddet(2) = -1.0 - do n=3,nrows - det(n) = rscl*(b(n)-lam)*det(n-1) - rscl*(a(n)*c(n-1))*det(n-2) - ddet(n) = rscl*(b(n)-lam)*ddet(n-1) - rscl*(a(n)*c(n-1))*ddet(n-2) - det(n-1) - ! Rescale det & ddet if det is getting too large or too small to avoid overflow or underflow. - if (abs(det(n)) > rescale) then - det(n) = I_rescale*det(n) ; det(n-1) = I_rescale*det(n-1) - ddet(n) = I_rescale*ddet(n) ; ddet(n-1) = I_rescale*ddet(n-1) - elseif (abs(det(n)) < I_rescale) then - det(n) = rescale*det(n) ; det(n-1) = rescale*det(n-1) - ddet(n) = rescale*ddet(n) ; ddet(n-1) = rescale*ddet(n-1) + 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 - det_out = det(nrows) - ddet_out = ddet(nrows) / rscl 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) +subroutine wave_speed_init(CS, use_ebt_mode, mono_N2_column_fraction, mono_N2_depth, remap_answers_2018, & + better_speed_est, min_speed, wave_speed_tol) type(wave_speed_CS), pointer :: 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. @@ -1077,9 +1198,14 @@ subroutine wave_speed_init(CS, use_ebt_mode, mono_N2_column_fraction, mono_N2_de !! as monotonic for the purposes of calculating the !! vertical modal structure [Z ~> m]. 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. - + !! that recover the remapping answers from 2018. Otherwise + !! use more robust but mathematically equivalent 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] ! This include declares and sets the variable "version". # include "version_variable.h" @@ -1094,7 +1220,8 @@ subroutine wave_speed_init(CS, use_ebt_mode, mono_N2_column_fraction, mono_N2_de ! 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) + call wave_speed_set_param(CS, use_ebt_mode=use_ebt_mode, mono_N2_column_fraction=mono_N2_column_fraction, & + better_speed_est=better_speed_est, min_speed=min_speed, wave_speed_tol=wave_speed_tol) call initialize_remapping(CS%remapping_CS, 'PLM', boundary_extrapolation=.false., & answers_2018=CS%remap_answers_2018) @@ -1102,7 +1229,8 @@ subroutine wave_speed_init(CS, use_ebt_mode, mono_N2_column_fraction, mono_N2_de 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) +subroutine wave_speed_set_param(CS, use_ebt_mode, mono_N2_column_fraction, mono_N2_depth, remap_answers_2018, & + better_speed_est, min_speed, wave_speed_tol) type(wave_speed_CS), pointer :: 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. @@ -1115,6 +1243,12 @@ subroutine wave_speed_set_param(CS, use_ebt_mode, mono_N2_column_fraction, mono_ 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. + 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] if (.not.associated(CS)) call MOM_error(FATAL, & "wave_speed_set_param called with an associated control structure.") @@ -1123,6 +1257,9 @@ subroutine wave_speed_set_param(CS, use_ebt_mode, mono_N2_column_fraction, mono_ 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)) CS%remap_answers_2018 = remap_answers_2018 + 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 end subroutine wave_speed_set_param @@ -1149,7 +1286,7 @@ end subroutine wave_speed_set_param !! !! Here !! \verbatim -!! Igl(k) = 1.0/(gprime(k)*h(k)) ; Igu(k) = 1.0/(gprime(k)*h(k-1)) +!! 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 diff --git a/src/diagnostics/MOM_wave_structure.F90 b/src/diagnostics/MOM_wave_structure.F90 index 68667df71b..88b062472f 100644 --- a/src/diagnostics/MOM_wave_structure.F90 +++ b/src/diagnostics/MOM_wave_structure.F90 @@ -109,7 +109,7 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo real, dimension(SZK_(G)+1) :: & dRho_dT, & ! Partial derivative of density with temperature [R degC-1 ~> kg m-3 degC-1] dRho_dS, & ! Partial derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1] - pres, & ! Interface pressure [Pa] + pres, & ! Interface pressure [R L2 T-2 ~> Pa] T_int, & ! Temperature interpolated to interfaces [degC] S_int, & ! Salinity interpolated to interfaces [ppt] gprime ! The reduced gravity across each interface [m2 Z-1 s-2 ~> m s-2]. @@ -131,7 +131,7 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo htot ! The vertical sum of the thicknesses [Z ~> m] real :: lam real :: min_h_frac - real :: H_to_pres + real :: Z_to_pres ! A conversion factor from thicknesses to pressure [R L2 T-2 Z-1 ~> Pa m-1] real, dimension(SZI_(G)) :: & hmin, & ! Thicknesses [Z ~> m] H_here, & ! A thickness [Z ~> m] @@ -199,7 +199,8 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo cg_subRO = 1e-100*US%m_s_to_L_T ! The hard-coded value here might need to increase. use_EOS = associated(tv%eqn_of_state) - H_to_pres = GV%Z_to_H*GV%H_to_Pa + ! Simplifying the following could change answers at roundoff. + Z_to_pres = GV%Z_to_H * (GV%H_to_RZ * GV%g_Earth) ! rescale = 1024.0**4 ; I_rescale = 1.0/rescale min_h_frac = tol1 / real(nz) @@ -272,12 +273,12 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo if (use_EOS) then pres(1) = 0.0 do k=2,kf(i) - pres(k) = pres(k-1) + H_to_pres*Hf(k-1,i) + pres(k) = pres(k-1) + Z_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)) enddo - call calculate_density_derivs(T_int, S_int, pres, drho_dT, drho_dS, 2, & - kf(i)-1, tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density_derivs(T_int, S_int, pres, drho_dT, drho_dS, & + tv%eqn_of_state, (/2,kf(i)/) ) ! Sum the reduced gravities to find out how small a density difference ! is negligibly small. @@ -377,7 +378,7 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo ! Also, note that "K" refers to an interface, while "k" refers to the layer below. ! Need at least 3 layers (2 internal interfaces) to generate a matrix, also ! need number of layers to be greater than the mode number - if (kc >= ModeNum + 1) then + if (kc >= max(3, ModeNum + 1)) then ! Set depth at surface z_int(1) = 0.0 ! Calculate Igu, Igl, depth, and N2 at each interior interface @@ -484,8 +485,8 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo ! Calculate terms in vertically integrated energy equation int_dwdz2 = 0.0 ; int_w2 = 0.0 ; int_N2w2 = 0.0 - u_strct2(:) = u_strct(1:nzm)**2 - w_strct2(:) = w_strct(1:nzm)**2 + u_strct2(1:nzm) = u_strct(1:nzm)**2 + w_strct2(1:nzm) = w_strct(1:nzm)**2 ! vertical integration with Trapezoidal rule do k=1,nzm-1 int_dwdz2 = int_dwdz2 + 0.5*(u_strct2(K)+u_strct2(K+1)) * US%m_to_Z*dz(k) @@ -517,12 +518,12 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo endif ! Store values in control structure - CS%w_strct(i,j,1:nzm) = w_strct(:) - CS%u_strct(i,j,1:nzm) = u_strct(:) - CS%W_profile(i,j,1:nzm) = W_profile(:) - CS%Uavg_profile(i,j,1:nzm)= Uavg_profile(:) - CS%z_depths(i,j,1:nzm) = US%Z_to_m*z_int(:) - CS%N2(i,j,1:nzm) = N2(:) + CS%w_strct(i,j,1:nzm) = w_strct(1:nzm) + CS%u_strct(i,j,1:nzm) = u_strct(1:nzm) + CS%W_profile(i,j,1:nzm) = W_profile(1:nzm) + CS%Uavg_profile(i,j,1:nzm)= Uavg_profile(1:nzm) + CS%z_depths(i,j,1:nzm) = US%Z_to_m*z_int(1:nzm) + CS%N2(i,j,1:nzm) = N2(1:nzm) CS%num_intfaces(i,j) = nzm else ! If not enough layers, default to zero diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index 3d0cb9abc4..40ac04e9e8 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -29,27 +29,35 @@ module MOM_EOS use MOM_TFreeze, only : calculate_TFreeze_teos10 use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_hor_index, only : hor_index_type use MOM_string_functions, only : uppercase -use MOM_hor_index, only : hor_index_type +use MOM_unit_scaling, only : unit_scale_type implicit none ; private #include -public calculate_compress, calculate_density, query_compressible -public calculate_density_derivs, calculate_specific_vol_derivs +public EOS_allocate +public EOS_domain +public EOS_end +public EOS_init +public EOS_manual_init +public EOS_quadrature +public EOS_use_linear +public analytic_int_density_dz +public analytic_int_specific_vol_dp +public calculate_compress +public calculate_density +public calculate_density_derivs public calculate_density_second_derivs -public EOS_init, EOS_manual_init, EOS_end, EOS_allocate -public EOS_use_linear, calculate_spec_vol -public int_density_dz, int_specific_vol_dp -public int_density_dz_generic_plm, int_density_dz_generic_ppm -public int_spec_vol_dp_generic_plm !, int_spec_vol_dz_generic_ppm -public int_density_dz_generic, int_spec_vol_dp_generic -public find_depth_of_pressure_in_cell +public calculate_spec_vol +public calculate_specific_vol_derivs public calculate_TFreeze public convert_temp_salt_for_TEOS10 -public gsw_sp_from_sr, gsw_pt_from_ct public extract_member_EOS +public gsw_sp_from_sr +public gsw_pt_from_ct +public query_compressible ! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional ! consistency testing. These are noted in comments with units like Z, H, L, and T, along with @@ -58,19 +66,28 @@ module MOM_EOS !> Calculates density of sea water from T, S and P interface calculate_density - module procedure calculate_density_scalar, calculate_density_array + module procedure calculate_density_scalar, calculate_density_array, calculate_density_1d + module procedure calculate_stanley_density_scalar, calculate_stanley_density_array + module procedure calculate_stanley_density_1d end interface calculate_density !> Calculates specific volume of sea water from T, S and P interface calculate_spec_vol - module procedure calculate_spec_vol_scalar, calculate_spec_vol_array + module procedure calc_spec_vol_scalar, calculate_spec_vol_array, & + 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_scalar, calculate_density_derivs_array, & + 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 calculate_spec_vol_derivs_array, 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 @@ -96,14 +113,22 @@ module MOM_EOS !! 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 :: 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]. + 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]. + 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] + +! 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. + real :: kg_m3_to_R = 1. !< A constant that translates kilograms per meter cubed to the units of density. + real :: R_to_kg_m3 = 1. !< A constant that translates the units of density to kilograms per meter cubed. + real :: RL2_T2_to_Pa = 1.!< Convert pressures from R L2 T-2 to Pa. + real :: L_T_to_m_s = 1. !< Convert lateral velocities from L T-1 to m s-1. ! logical :: test_EOS = .true. ! If true, test the equation of state end type EOS_type @@ -134,56 +159,117 @@ module MOM_EOS contains !> 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. +!! If rho_ref is present, the anomaly with respect to rho_ref is returned. The pressure and +!! density can be rescaled with the US. If both the US and scale arguments are 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 [degC] real, intent(in) :: S !< Salinity [ppt] - real, intent(in) :: pressure !< Pressure [Pa] + real, intent(in) :: pressure !< Pressure [Pa] or [R L2 T-2 ~> Pa] real, intent(out) :: rho !< Density (in-situ if pressure is local) [kg m-3] or [R ~> kg m-3] type(EOS_type), pointer :: EOS !< Equation of state structure - real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. - real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density - !! from kg m-3 to the desired units [R m3 kg-1] + real, optional, intent(in) :: rho_ref !< A reference density [kg m-3] + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density in + !! combination with scaling given by US [various] + + real :: rho_scale ! A factor to convert density from kg m-3 to the desired units [R m3 kg-1 ~> 1] + real :: p_scale ! A factor to convert pressure to units of Pa [Pa T2 R-1 L-2 ~> 1] if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_density_scalar called with an unassociated EOS_type EOS.") + p_scale = EOS%RL2_T2_to_Pa + select case (EOS%form_of_EOS) case (EOS_LINEAR) - call calculate_density_linear(T, S, pressure, rho, & - EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS, rho_ref) + call calculate_density_linear(T, S, p_scale*pressure, rho, & + EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS, rho_ref) case (EOS_UNESCO) - call calculate_density_unesco(T, S, pressure, rho, rho_ref) + call calculate_density_unesco(T, S, p_scale*pressure, rho, rho_ref) case (EOS_WRIGHT) - call calculate_density_wright(T, S, pressure, rho, rho_ref) + call calculate_density_wright(T, S, p_scale*pressure, rho, rho_ref) case (EOS_TEOS10) - call calculate_density_teos10(T, S, pressure, rho, rho_ref) + call calculate_density_teos10(T, S, p_scale*pressure, rho, rho_ref) case (EOS_NEMO) - call calculate_density_nemo(T, S, pressure, rho, rho_ref) + call calculate_density_nemo(T, S, p_scale*pressure, rho, rho_ref) case default - call MOM_error(FATAL, & - "calculate_density_scalar: EOS is not valid.") + call MOM_error(FATAL, "calculate_density_scalar: EOS is not valid.") end select - if (present(scale)) then ; if (scale /= 1.0) then - rho = scale * rho - endif ; endif + rho_scale = EOS%kg_m3_to_R + if (present(scale)) rho_scale = rho_scale * scale + rho = rho_scale * rho end subroutine calculate_density_scalar +!> Calls the appropriate subroutine to calculate density of sea water for scalar inputs +!! including the variance of T, S and covariance of T-S. +!! The calculation uses only the second order correction in a series as discussed +!! in Stanley et al., 2020. +!! If rho_ref is present, the anomaly with respect to rho_ref is returned. The +!! density can be rescaled using rho_ref. +subroutine calculate_stanley_density_scalar(T, S, pressure, Tvar, TScov, Svar, rho, EOS, rho_ref, scale) + real, intent(in) :: T !< Potential temperature referenced to the surface [degC] + real, intent(in) :: S !< Salinity [ppt] + real, intent(in) :: Tvar !< Variance of potential temperature referenced to the surface [degC2] + real, intent(in) :: TScov !< Covariance of potential temperature and salinity [degC ppt] + real, intent(in) :: Svar !< Variance of salinity [ppt2] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(out) :: rho !< Density (in-situ if pressure is local) [kg m-3] or [R ~> kg m-3] + type(EOS_type), pointer :: EOS !< Equation of state structure + real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density + !! from kg m-3 to the desired units [R m3 kg-1] + ! Local variables + real :: d2RdTT, d2RdST, d2RdSS, d2RdSp, d2RdTp ! Second derivatives of density wrt T,S,p + real :: rho_scale ! A factor to convert density from kg m-3 to the desired units [R m3 kg-1 ~> 1] + real :: p_scale ! A factor to convert pressure to units of Pa [Pa T2 R-1 L-2 ~> 1] + + if (.not.associated(EOS)) call MOM_error(FATAL, & + "calculate_stanley_density_scalar called with an unassociated EOS_type EOS.") + + p_scale = EOS%RL2_T2_to_Pa + + select case (EOS%form_of_EOS) + case (EOS_LINEAR) + call calculate_density_linear(T, S, p_scale*pressure, rho, & + EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS, rho_ref) + call calculate_density_second_derivs_linear(T, S, pressure, d2RdSS, d2RdST, & + d2RdTT, d2RdSp, d2RdTP) + case (EOS_WRIGHT) + call calculate_density_wright(T, S, p_scale*pressure, rho, rho_ref) + call calculate_density_second_derivs_wright(T, S, pressure, d2RdSS, d2RdST, & + d2RdTT, d2RdSp, d2RdTP) + case (EOS_TEOS10) + call calculate_density_teos10(T, S, p_scale*pressure, rho, rho_ref) + call calculate_density_second_derivs_teos10(T, S, pressure, d2RdSS, d2RdST, & + d2RdTT, d2RdSp, d2RdTP) + case default + call MOM_error(FATAL, "calculate_stanley_density_scalar: EOS is not valid.") + end select + + ! Equation 25 of Stanley et al., 2020. + rho = rho + ( 0.5 * d2RdTT * Tvar + ( d2RdST * TScov + 0.5 * d2RdSS * Svar ) ) + + rho_scale = EOS%kg_m3_to_R + if (present(scale)) rho_scale = rho_scale * scale + rho = rho_scale * rho + +end subroutine calculate_stanley_density_scalar + !> Calls the appropriate subroutine to calculate the density of sea water for 1-D array inputs. !! If rho_ref is present, the anomaly with respect to rho_ref is returned. subroutine calculate_density_array(T, S, pressure, rho, start, npts, EOS, rho_ref, scale) real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [degC] real, dimension(:), intent(in) :: S !< Salinity [ppt] - real, dimension(:), intent(in) :: pressure !< Pressure [Pa] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] or [R L2 T-2 ~> Pa] real, dimension(:), intent(inout) :: rho !< Density (in-situ if pressure is local) [kg m-3] or [R ~> kg m-3] integer, intent(in) :: start !< Start index for computation integer, intent(in) :: npts !< Number of point to compute type(EOS_type), pointer :: EOS !< Equation of state structure - real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. - real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density - !! from kg m-3 to the desired units [R m3 kg-1] + real, optional, intent(in) :: rho_ref !< A reference density [kg m-3] + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density + !! in combination with scaling given by US [various] integer :: j if (.not.associated(EOS)) call MOM_error(FATAL, & @@ -192,7 +278,7 @@ subroutine calculate_density_array(T, S, pressure, rho, start, npts, EOS, rho_re select case (EOS%form_of_EOS) case (EOS_LINEAR) call calculate_density_linear(T, S, pressure, rho, start, npts, & - EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS, rho_ref) + EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS, rho_ref) case (EOS_UNESCO) call calculate_density_unesco(T, S, pressure, rho, start, npts, rho_ref) case (EOS_WRIGHT) @@ -200,79 +286,215 @@ subroutine calculate_density_array(T, S, pressure, rho, start, npts, EOS, rho_re case (EOS_TEOS10) call calculate_density_teos10(T, S, pressure, rho, start, npts, rho_ref) case (EOS_NEMO) - call calculate_density_nemo (T, S, pressure, rho, start, npts, rho_ref) + call calculate_density_nemo(T, S, pressure, rho, start, npts, rho_ref) case default - call MOM_error(FATAL, & - "calculate_density_array: EOS%form_of_EOS is not valid.") + call MOM_error(FATAL, "calculate_density_array: EOS%form_of_EOS is not valid.") end select - if (present(scale)) then ; if (scale /= 1.0) then - do j=start,start+npts-1 ; rho(j) = scale * rho(j) ; enddo - endif ; endif + if (present(scale)) then ; if (scale /= 1.0) then ; do j=start,start+npts-1 + rho(j) = scale * rho(j) + enddo ; endif ; endif end subroutine calculate_density_array -!> Calls the appropriate subroutine to calculate specific volume of sea water -!! for scalar inputs. -subroutine calculate_spec_vol_scalar(T, S, pressure, specvol, EOS, spv_ref, scale) - real, intent(in) :: T !< Potential temperature referenced to the surface [degC] - real, intent(in) :: S !< Salinity [ppt] - real, intent(in) :: pressure !< Pressure [Pa] - real, intent(out) :: specvol !< In situ? specific volume [m3 kg-1] or [R-1 ~> m3 kg-1] - type(EOS_type), pointer :: 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 from m3 kg-1 to the desired units [kg m-3 R-1] +!> Calls the appropriate subroutine to calculate the density of sea water for 1-D array inputs +!! including the variance of T, S and covariance of T-S. +!! The calculation uses only the second order correction in a series as discussed +!! in Stanley et al., 2020. +!! If rho_ref is present, the anomaly with respect to rho_ref is returned. +subroutine calculate_stanley_density_array(T, S, pressure, Tvar, TScov, Svar, rho, start, npts, EOS, rho_ref, scale) + real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [degC] + real, dimension(:), intent(in) :: S !< Salinity [ppt] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] + real, dimension(:), intent(in) :: Tvar !< Variance of potential temperature referenced to the surface [degC2] + real, dimension(:), intent(in) :: TScov !< Covariance of potential temperature and salinity [degC ppt] + real, dimension(:), intent(in) :: Svar !< Variance of salinity [ppt2] + real, dimension(:), intent(inout) :: rho !< Density (in-situ if pressure is local) [kg m-3] + integer, intent(in) :: start !< Start index for computation + integer, intent(in) :: npts !< Number of point to compute + type(EOS_type), pointer :: EOS !< Equation of state structure + real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density + !! from kg m-3 to the desired units [R m3 kg-1] + ! Local variables + real, dimension(size(T)) :: d2RdTT, d2RdST, d2RdSS, d2RdSp, d2RdTp ! Second derivatives of density wrt T,S,p + integer :: j + + if (.not.associated(EOS)) call MOM_error(FATAL, & + "calculate_density_array called with an unassociated EOS_type EOS.") + + select case (EOS%form_of_EOS) + case (EOS_LINEAR) + call calculate_density_linear(T, S, pressure, rho, start, npts, & + EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS, rho_ref) + call calculate_density_second_derivs_linear(T, S, pressure, d2RdSS, d2RdST, & + d2RdTT, d2RdSp, d2RdTP, start, npts) + case (EOS_WRIGHT) + call calculate_density_wright(T, S, pressure, rho, start, npts, rho_ref) + call calculate_density_second_derivs_wright(T, S, pressure, d2RdSS, d2RdST, & + d2RdTT, d2RdSp, d2RdTP, start, npts) + case (EOS_TEOS10) + call calculate_density_teos10(T, S, pressure, rho, start, npts, rho_ref) + call calculate_density_second_derivs_teos10(T, S, pressure, d2RdSS, d2RdST, & + d2RdTT, d2RdSp, d2RdTP, start, npts) + case default + call MOM_error(FATAL, "calculate_stanley_density_array: EOS%form_of_EOS is not valid.") + end select + + ! Equation 25 of Stanley et al., 2020. + do j=start,start+npts-1 + rho(j) = rho(j) & + + ( 0.5 * d2RdTT(j) * Tvar(j) + ( d2RdST(j) * TScov(j) + 0.5 * d2RdSS(j) * Svar(j) ) ) + enddo + + if (present(scale)) then ; if (scale /= 1.0) then ; do j=start,start+npts-1 + rho(j) = scale * rho(j) + enddo ; endif ; endif + +end subroutine calculate_stanley_density_array + +!> Calls the appropriate subroutine to calculate the density of sea water for 1-D array inputs, +!! potentially limiting the domain of indices that are worked on. +!! If rho_ref is present, the anomaly with respect to rho_ref is returned. +subroutine calculate_density_1d(T, S, pressure, rho, EOS, dom, rho_ref, scale) + real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [degC] + real, dimension(:), intent(in) :: S !< Salinity [ppt] + real, dimension(:), intent(in) :: pressure !< Pressure [R L2 T-2 ~> Pa] + real, dimension(:), intent(inout) :: rho !< Density (in-situ if pressure is local) [R ~> kg m-3] + type(EOS_type), pointer :: EOS !< Equation of state structure + integer, dimension(2), optional, intent(in) :: dom !< The domain of indices to work on, taking + !! into account that arrays start at 1. + real, optional, intent(in) :: rho_ref !< A reference density [kg m-3] + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density + !! in combination with scaling given by US [various] + ! Local variables + real :: p_scale ! A factor to convert pressure to units of Pa [Pa T2 R-1 L-2 ~> 1] + real :: rho_scale ! A factor to convert density from kg m-3 to the desired units [R m3 kg-1 ~> 1] + real :: rho_unscale ! A factor to convert density from R to kg m-3 [kg m-3 R-1 ~> 1] + real :: rho_reference ! rho_ref converted to [kg m-3] + real, dimension(size(rho)) :: pres ! Pressure converted to [Pa] + integer :: i, is, ie, npts - real :: rho + if (.not.associated(EOS)) call MOM_error(FATAL, & + "calculate_density_1d called with an unassociated EOS_type EOS.") + + if (present(dom)) then + is = dom(1) ; ie = dom(2) ; npts = 1 + ie - is + else + is = 1 ; ie = size(rho) ; npts = 1 + ie - is + endif + + p_scale = EOS%RL2_T2_to_Pa + rho_unscale = EOS%R_to_kg_m3 + + if ((p_scale == 1.0) .and. (rho_unscale == 1.0)) then + call calculate_density_array(T, S, pressure, rho, is, npts, EOS, rho_ref=rho_ref) + elseif (present(rho_ref)) then ! This is the same as above, but with some extra work to rescale variables. + do i=is,ie ; pres(i) = p_scale * pressure(i) ; enddo + rho_reference = rho_unscale*rho_ref + call calculate_density_array(T, S, pres, rho, is, npts, EOS, rho_ref=rho_reference) + else ! There is rescaling of variables, but rho_ref is not present. Passing a 0 value of rho_ref + ! changes answers at roundoff for some equations of state, like Wright and UNESCO. + do i=is,ie ; pres(i) = p_scale * pressure(i) ; enddo + call calculate_density_array(T, S, pres, rho, is, npts, EOS) + 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 [degC] + real, dimension(:), intent(in) :: S !< Salinity [ppt] + real, dimension(:), intent(in) :: pressure !< Pressure [R L2 T-2 ~> Pa] + real, dimension(:), intent(in) :: Tvar !< Variance of potential temperature [degC2] + real, dimension(:), intent(in) :: TScov !< Covariance of potential temperature and salinity [degC ppt] + real, dimension(:), intent(in) :: Svar !< Variance of salinity [ppt2] + real, dimension(:), intent(inout) :: rho !< Density (in-situ if pressure is local) [R ~> kg m-3] + type(EOS_type), pointer :: EOS !< Equation of state structure + integer, dimension(2), optional, intent(in) :: dom !< The domain of indices to work on, taking + !! into account that arrays start at 1. + real, optional, intent(in) :: rho_ref !< A reference density [kg m-3] + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density + !! in combination with scaling given by US [various] + ! Local variables + real :: p_scale ! A factor to convert pressure to units of Pa [Pa T2 R-1 L-2 ~> 1] + real :: rho_scale ! A factor to convert density from kg m-3 to the desired units [R m3 kg-1 ~> 1] + real, dimension(size(rho)) :: pres ! Pressure converted to [Pa] + real, dimension(size(T)) :: d2RdTT, d2RdST, d2RdSS, d2RdSp, d2RdTp ! Second derivatives of density wrt T,S,p + integer :: i, is, ie, npts if (.not.associated(EOS)) call MOM_error(FATAL, & - "calculate_spec_vol_scalar called with an unassociated EOS_type EOS.") + "calculate_density_1d called with an unassociated EOS_type EOS.") + + if (present(dom)) then + is = dom(1) ; ie = dom(2) ; npts = 1 + ie - is + else + is = 1 ; ie = size(rho) ; npts = 1 + ie - is + endif + + p_scale = EOS%RL2_T2_to_Pa + do i=is,ie + pres(i) = p_scale * pressure(i) + enddo select case (EOS%form_of_EOS) case (EOS_LINEAR) - call calculate_spec_vol_linear(T, S, pressure, specvol, & - EOS%rho_T0_S0, EOS%drho_dT, EOS%drho_dS, spv_ref) - case (EOS_UNESCO) - call calculate_spec_vol_unesco(T, S, pressure, specvol, spv_ref) + call calculate_density_linear(T, S, pres, rho, 1, npts, & + EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS, rho_ref) + call calculate_density_second_derivs_linear(T, S, pres, d2RdSS, d2RdST, & + d2RdTT, d2RdSp, d2RdTP, 1, npts) case (EOS_WRIGHT) - call calculate_spec_vol_wright(T, S, pressure, specvol, spv_ref) + call calculate_density_wright(T, S, pres, rho, 1, npts, rho_ref) + call calculate_density_second_derivs_wright(T, S, pres, d2RdSS, d2RdST, & + d2RdTT, d2RdSp, d2RdTP, 1, npts) case (EOS_TEOS10) - call calculate_spec_vol_teos10(T, S, pressure, specvol, spv_ref) - case (EOS_NEMO) - call calculate_density_nemo(T, S, pressure, rho) - if (present(spv_ref)) then - specvol = 1.0 / rho - spv_ref - else - specvol = 1.0 / rho - endif + call calculate_density_teos10(T, S, pres, rho, 1, npts, rho_ref) + call calculate_density_second_derivs_teos10(T, S, pres, d2RdSS, d2RdST, & + d2RdTT, d2RdSp, d2RdTP, 1, npts) case default - call MOM_error(FATAL, & - "calculate_spec_vol_scalar: EOS is not valid.") + call MOM_error(FATAL, "calculate_stanley_density_scalar: EOS is not valid.") end select - if (present(scale)) then ; if (scale /= 1.0) then - specvol = scale * specvol - endif ; endif + ! 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 -end subroutine calculate_spec_vol_scalar + rho_scale = EOS%kg_m3_to_R + if (present(scale)) rho_scale = rho_scale * scale + if (rho_scale /= 1.0) then ; do i=is,ie + rho(i) = rho_scale * rho(i) + enddo ; endif +end subroutine calculate_stanley_density_1d !> Calls the appropriate subroutine to calculate the specific volume of sea water !! for 1-D array inputs. subroutine calculate_spec_vol_array(T, S, pressure, specvol, start, npts, EOS, spv_ref, scale) - 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] or [R-1 ~> m3 kg-1]. + 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), pointer :: 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 - !! from m3 kg-1 to the desired units [kg m-3 R-1] + 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 given by US [various] - real, dimension(size(specvol)) :: rho + real, dimension(size(specvol)) :: rho ! Density [kg m-3] integer :: j if (.not.associated(EOS)) call MOM_error(FATAL, & @@ -289,75 +511,193 @@ subroutine calculate_spec_vol_array(T, S, pressure, specvol, start, npts, EOS, s case (EOS_TEOS10) call calculate_spec_vol_teos10(T, S, pressure, specvol, start, npts, spv_ref) case (EOS_NEMO) - call calculate_density_nemo (T, S, pressure, rho, start, npts) + call calculate_density_nemo(T, S, pressure, rho, start, npts) if (present(spv_ref)) then specvol(:) = 1.0 / rho(:) - spv_ref else specvol(:) = 1.0 / rho(:) endif case default - call MOM_error(FATAL, & - "calculate_spec_vol_array: EOS%form_of_EOS is not valid.") + call MOM_error(FATAL, "calculate_spec_vol_array: EOS%form_of_EOS is not valid.") end select if (present(scale)) then ; if (scale /= 1.0) then ; do j=start,start+npts-1 specvol(j) = scale * specvol(j) - enddo ; endif ; endif + 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 [degC] + real, intent(in) :: S !< Salinity [ppt] + real, intent(in) :: pressure !< Pressure [Pa] or [R L2 T-2 ~> Pa] + real, intent(out) :: specvol !< In situ? specific volume [m3 kg-1] or [R-1 ~> m3 kg-1] + type(EOS_type), pointer :: EOS !< Equation of state structure + real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1] or [R-1 m3 kg-1] + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale specific + !! volume in combination with scaling given by US [various] + + real, dimension(1) :: Ta, Sa, pres, spv ! Rescaled single element array versions of the arguments. + real :: spv_reference ! spv_ref converted to [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] + + if (.not.associated(EOS)) call MOM_error(FATAL, & + "calc_spec_vol_scalar called with an unassociated EOS_type EOS.") + + pres(1) = EOS%RL2_T2_to_Pa*pressure + Ta(1) = T ; Sa(1) = S + + if (present(spv_ref)) then + spv_reference = EOS%kg_m3_to_R*spv_ref + call calculate_spec_vol_array(Ta, Sa, pres, spv, 1, 1, EOS, spv_reference) + 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 [degC] + real, dimension(:), intent(in) :: S !< Salinity [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), pointer :: EOS !< Equation of state structure + integer, dimension(2), optional, intent(in) :: dom !< The domain of indices to work on, taking + !! into account that arrays start at 1. + real, optional, intent(in) :: 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 given by US [various] + ! Local variables + real, dimension(size(specvol)) :: pres ! Pressure converted to [Pa] + real :: p_scale ! A factor to convert pressure to units of Pa [Pa T2 R-1 L-2 ~> 1] + real :: spv_unscale ! A factor to convert specific volume from R-1 to m3 kg-1 [m3 kg-1 R ~> 1] + real :: spv_scale ! A factor to convert specific volume from m3 kg-1 to the desired units [kg m-3 R-1 ~> 1] + real :: spv_reference ! spv_ref converted to [m3 kg-1] + integer :: i, is, ie, npts + + if (.not.associated(EOS)) call MOM_error(FATAL, & + "calc_spec_vol_1d called with an unassociated EOS_type EOS.") + + if (present(dom)) then + is = dom(1) ; ie = dom(2) ; npts = 1 + ie - is + else + is = 1 ; ie = size(specvol) ; npts = 1 + ie - is + endif + + p_scale = EOS%RL2_T2_to_Pa + spv_unscale = EOS%kg_m3_to_R + + if ((p_scale == 1.0) .and. (spv_unscale == 1.0)) then + call calculate_spec_vol_array(T, S, pressure, specvol, is, npts, EOS, spv_ref) + elseif (present(spv_ref)) then ! This is the same as above, but with some extra work to rescale variables. + do i=is,ie ; pres(i) = p_scale * pressure(i) ; enddo + spv_reference = spv_unscale*spv_ref + call calculate_spec_vol_array(T, S, pres, specvol, is, npts, EOS, spv_reference) + 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. + do i=is,ie ; pres(i) = p_scale * pressure(i) ; enddo + call calculate_spec_vol_array(T, S, pres, specvol, is, npts, EOS) + 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) +subroutine calculate_TFreeze_scalar(S, pressure, T_fr, EOS, pres_scale) real, intent(in) :: S !< Salinity [ppt] - real, intent(in) :: pressure !< Pressure [Pa] + real, intent(in) :: pressure !< Pressure [Pa] or [other] real, intent(out) :: T_fr !< Freezing point potential temperature referenced !! to the surface [degC] type(EOS_type), pointer :: EOS !< Equation of state structure + real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure into Pa + + ! Local variables + real :: p_scale ! A factor to convert pressure to units of Pa. if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_TFreeze_scalar called with an unassociated EOS_type EOS.") + p_scale = 1.0 ; if (present(pres_scale)) p_scale = pres_scale + select case (EOS%form_of_TFreeze) case (TFREEZE_LINEAR) - call calculate_TFreeze_linear(S, pressure, T_fr, EOS%TFr_S0_P0, & + call calculate_TFreeze_linear(S, p_scale*pressure, T_fr, EOS%TFr_S0_P0, & EOS%dTFr_dS, EOS%dTFr_dp) case (TFREEZE_MILLERO) - call calculate_TFreeze_Millero(S, pressure, T_fr) + call calculate_TFreeze_Millero(S, p_scale*pressure, T_fr) case (TFREEZE_TEOS10) - call calculate_TFreeze_teos10(S, pressure, T_fr) + call calculate_TFreeze_teos10(S, p_scale*pressure, T_fr) case default - call MOM_error(FATAL, & - "calculate_TFreeze_scalar: form_of_TFreeze is not valid.") + call MOM_error(FATAL, "calculate_TFreeze_scalar: form_of_TFreeze is not valid.") end select 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) +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 [Pa] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] or [other] 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), pointer :: EOS !< Equation of state structure + real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure into Pa. + + ! Local variables + real, dimension(size(pressure)) :: pres ! Pressure converted to [Pa] + real :: p_scale ! A factor to convert pressure to units of Pa. + integer :: j if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_TFreeze_scalar called with an unassociated EOS_type EOS.") - 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_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 + 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_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 default + call MOM_error(FATAL, "calculate_TFreeze_scalar: form_of_TFreeze is not valid.") + end select + endif end subroutine calculate_TFreeze_array @@ -365,16 +705,18 @@ end subroutine calculate_TFreeze_array 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(in) :: pressure !< Pressure [Pa] or [R L2 T-2 ~> Pa] real, dimension(:), intent(inout) :: drho_dT !< The partial derivative of density with potential - !! temperature [kg m-3 degC-1] or [R degC-1 ~> kg m-3 degC-1]. + !! temperature [kg m-3 degC-1] or [R degC-1 ~> kg m-3 degC-1] real, dimension(:), intent(inout) :: drho_dS !< The partial derivative of density with salinity, - !! in [kg m-3 ppt-1] or [R degC-1 ~> kg m-3 ppt-1]. + !! in [kg m-3 ppt-1] or [R degC-1 ~> kg m-3 ppt-1] integer, intent(in) :: start !< Starting index within the array integer, intent(in) :: npts !< The number of values to calculate type(EOS_type), pointer :: EOS !< Equation of state structure - real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density - !! from kg m-3 to the desired units [R m3 kg-1] + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density + !! in combination with scaling given by US [various] + + ! Local variables integer :: j if (.not.associated(EOS)) call MOM_error(FATAL, & @@ -393,8 +735,7 @@ subroutine calculate_density_derivs_array(T, S, pressure, drho_dT, drho_dS, star case (EOS_NEMO) call calculate_density_derivs_nemo(T, S, pressure, drho_dT, drho_dS, start, npts) case default - call MOM_error(FATAL, & - "calculate_density_derivs_array: EOS%form_of_EOS is not valid.") + call MOM_error(FATAL, "calculate_density_derivs_array: EOS%form_of_EOS is not valid.") end select if (present(scale)) then ; if (scale /= 1.0) then ; do j=start,start+npts-1 @@ -404,40 +745,96 @@ subroutine calculate_density_derivs_array(T, S, pressure, drho_dT, drho_dS, star 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 [degC] + real, dimension(:), intent(in) :: S !< Salinity [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 degC-1 ~> kg m-3 degC-1] + real, dimension(:), intent(inout) :: drho_dS !< The partial derivative of density with salinity + !! [R degC-1 ~> kg m-3 ppt-1] + type(EOS_type), pointer :: EOS !< Equation of state structure + integer, dimension(2), optional, intent(in) :: dom !< The domain of indices to work on, taking + !! into account that arrays start at 1. + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density + !! in combination with scaling given by US [various] + ! Local variables + real, dimension(size(drho_dT)) :: pres ! Pressure converted to [Pa] + real :: rho_scale ! A factor to convert density from kg m-3 to the desired units [R m3 kg-1 ~> 1] + real :: p_scale ! A factor to convert pressure to units of Pa [Pa T2 R-1 L-2 ~> 1] + integer :: i, is, ie, npts + + if (.not.associated(EOS)) call MOM_error(FATAL, & + "calculate_density_derivs called with an unassociated EOS_type EOS.") + + if (present(dom)) then + is = dom(1) ; ie = dom(2) ; npts = 1 + ie - is + else + is = 1 ; ie = size(drho_dT) ; npts = 1 + ie - is + endif + + p_scale = EOS%RL2_T2_to_Pa + + if (p_scale == 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) = p_scale * pressure(i) ; enddo + call calculate_density_derivs_array(T, S, pres, drho_dT, drho_dS, is, npts, EOS) + 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_dT(i) = rho_scale * drho_dT(i) + drho_dS(i) = rho_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 [degC] real, intent(in) :: S !< Salinity [ppt] - real, intent(in) :: pressure !< Pressure [Pa] + real, intent(in) :: pressure !< Pressure [Pa] or [R L2 T-2 ~> Pa] real, intent(out) :: drho_dT !< The partial derivative of density with potential !! temperature [kg m-3 degC-1] or [R degC-1 ~> kg m-3 degC-1] real, intent(out) :: drho_dS !< The partial derivative of density with salinity, - !! in [kg m-3 ppt-1] or [R ppt-1 ~> kg m-3 ppt-1]. - type(EOS_type), pointer :: EOS !< Equation of state structure + !! in [kg m-3 ppt-1] or [R ppt-1 ~> kg m-3 ppt-1] + type(EOS_type), pointer :: EOS !< Equation of state structure real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density - !! from kg m-3 to the desired units [R m3 kg-1] + !! in combination with scaling given by US [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 :: p_scale ! A factor to convert pressure to units of Pa [Pa T2 R-1 L-2 ~> 1] + integer :: j if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_density_derivs called with an unassociated EOS_type EOS.") + p_scale = EOS%RL2_T2_to_Pa + select case (EOS%form_of_EOS) case (EOS_LINEAR) - call calculate_density_derivs_linear(T, S, pressure, drho_dT, drho_dS, & + call calculate_density_derivs_linear(T, S, p_scale*pressure, drho_dT, drho_dS, & EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS) case (EOS_WRIGHT) - call calculate_density_derivs_wright(T, S, pressure, drho_dT, drho_dS) + call calculate_density_derivs_wright(T, S, p_scale*pressure, drho_dT, drho_dS) case (EOS_TEOS10) - call calculate_density_derivs_teos10(T, S, pressure, drho_dT, drho_dS) + call calculate_density_derivs_teos10(T, S, p_scale*pressure, drho_dT, drho_dS) case default - call MOM_error(FATAL, & - "calculate_density_derivs_scalar: EOS%form_of_EOS is not valid.") + call MOM_error(FATAL, "calculate_density_derivs_scalar: EOS%form_of_EOS is not valid.") end select - if (present(scale)) then ; if (scale /= 1.0) then - drho_dT = scale * drho_dT - drho_dS = scale * drho_dS - endif ; endif + rho_scale = EOS%kg_m3_to_R + if (present(scale)) rho_scale = rho_scale * scale + if (rho_scale /= 1.0) then + drho_dT = rho_scale * drho_dT + drho_dS = rho_scale * drho_dS + endif end subroutine calculate_density_derivs_scalar @@ -446,7 +843,7 @@ subroutine calculate_density_second_derivs_array(T, S, pressure, drho_dS_dS, drh drho_dS_dP, drho_dT_dP, 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(in) :: pressure !< Pressure [Pa] or [R L2 T-2 ~> Pa] real, dimension(:), intent(inout) :: drho_dS_dS !< Partial derivative of beta with respect to S !! [kg m-3 ppt-2] or [R ppt-2 ~> kg m-3 ppt-2] real, dimension(:), intent(inout) :: drho_dS_dT !< Partial derivative of beta with respect to T @@ -458,37 +855,70 @@ subroutine calculate_density_second_derivs_array(T, S, pressure, drho_dS_dS, drh real, dimension(:), intent(inout) :: drho_dT_dP !< Partial derivative of alpha with respect to pressure !! [kg m-3 degC-1 Pa-1] or [R degC-1 Pa-1 ~> kg m-3 degC-1 Pa-1] integer, intent(in) :: start !< Starting index within the array - integer, intent(in) :: npts !< The number of values to calculate - type(EOS_type), pointer :: EOS !< Equation of state structure - real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density - !! from kg m-3 to the desired units [R m3 kg-1] + integer, intent(in) :: npts !< The number of values to calculate + type(EOS_type), pointer :: EOS !< Equation of state structure + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density + !! in combination with scaling given by US [various] + ! Local variables + real, dimension(size(pressure)) :: pres ! Pressure converted to [Pa] + real :: rho_scale ! A factor to convert density from kg m-3 to the desired units [R m3 kg-1 ~> 1] + real :: p_scale ! A factor to convert pressure to units of Pa [Pa T2 R-1 L-2 ~> 1] + real :: I_p_scale ! The inverse of the factor to convert pressure to units of Pa [R L2 T-2 Pa-1 ~> 1] integer :: j if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_density_derivs called with an unassociated EOS_type EOS.") - select case (EOS%form_of_EOS) - case (EOS_LINEAR) - call calculate_density_second_derivs_linear(T, S, pressure, drho_dS_dS, drho_dS_dT, & - drho_dT_dT, drho_dS_dP, drho_dT_dP, start, npts) - case (EOS_WRIGHT) - call calculate_density_second_derivs_wright(T, S, pressure, drho_dS_dS, drho_dS_dT, & - drho_dT_dT, drho_dS_dP, drho_dT_dP, start, npts) - case (EOS_TEOS10) - call calculate_density_second_derivs_teos10(T, S, pressure, drho_dS_dS, drho_dS_dT, & - drho_dT_dT, drho_dS_dP, drho_dT_dP, start, npts) - case default - call MOM_error(FATAL, & - "calculate_density_derivs: EOS%form_of_EOS is not valid.") - end select + p_scale = EOS%RL2_T2_to_Pa + + if (p_scale == 1.0) then + select case (EOS%form_of_EOS) + case (EOS_LINEAR) + call calculate_density_second_derivs_linear(T, S, pressure, drho_dS_dS, drho_dS_dT, & + drho_dT_dT, drho_dS_dP, drho_dT_dP, start, npts) + case (EOS_WRIGHT) + call calculate_density_second_derivs_wright(T, S, pressure, drho_dS_dS, drho_dS_dT, & + drho_dT_dT, drho_dS_dP, drho_dT_dP, start, npts) + case (EOS_TEOS10) + call calculate_density_second_derivs_teos10(T, S, pressure, drho_dS_dS, drho_dS_dT, & + drho_dT_dT, drho_dS_dP, drho_dT_dP, start, npts) + case default + call MOM_error(FATAL, "calculate_density_derivs: EOS%form_of_EOS is not valid.") + end select + else + do j=start,start+npts-1 ; pres(j) = p_scale * pressure(j) ; enddo + select case (EOS%form_of_EOS) + case (EOS_LINEAR) + call calculate_density_second_derivs_linear(T, S, pres, drho_dS_dS, drho_dS_dT, & + drho_dT_dT, drho_dS_dP, drho_dT_dP, start, npts) + case (EOS_WRIGHT) + call calculate_density_second_derivs_wright(T, S, pres, drho_dS_dS, drho_dS_dT, & + drho_dT_dT, drho_dS_dP, drho_dT_dP, start, npts) + case (EOS_TEOS10) + call calculate_density_second_derivs_teos10(T, S, pres, drho_dS_dS, drho_dS_dT, & + drho_dT_dT, drho_dS_dP, drho_dT_dP, start, npts) + case default + call MOM_error(FATAL, "calculate_density_derivs: EOS%form_of_EOS is not valid.") + end select + endif - if (present(scale)) then ; if (scale /= 1.0) then ; do j=start,start+npts-1 - drho_dS_dS(j) = scale * drho_dS_dS(j) - drho_dS_dT(j) = scale * drho_dS_dT(j) - drho_dT_dT(j) = scale * drho_dT_dT(j) - drho_dS_dP(j) = scale * drho_dS_dP(j) - drho_dT_dP(j) = scale * drho_dT_dP(j) - enddo ; endif ; endif + rho_scale = EOS%kg_m3_to_R + if (present(scale)) rho_scale = rho_scale * scale + if (rho_scale /= 1.0) then ; do j=start,start+npts-1 + drho_dS_dS(j) = rho_scale * drho_dS_dS(j) + drho_dS_dT(j) = rho_scale * drho_dS_dT(j) + drho_dT_dT(j) = rho_scale * drho_dT_dT(j) + drho_dS_dP(j) = rho_scale * drho_dS_dP(j) + drho_dT_dP(j) = rho_scale * drho_dT_dP(j) + enddo ; endif + + if (p_scale /= 1.0) then + I_p_scale = 1.0 / p_scale + do j=start,start+npts-1 + drho_dS_dP(j) = I_p_scale * drho_dS_dP(j) + drho_dT_dP(j) = I_p_scale * drho_dT_dP(j) + enddo + endif end subroutine calculate_density_second_derivs_array @@ -497,7 +927,7 @@ subroutine calculate_density_second_derivs_scalar(T, S, pressure, drho_dS_dS, dr drho_dS_dP, drho_dT_dP, EOS, scale) real, intent(in) :: T !< Potential temperature referenced to the surface [degC] real, intent(in) :: S !< Salinity [ppt] - real, intent(in) :: pressure !< Pressure [Pa] + real, intent(in) :: pressure !< Pressure [Pa] or [R L2 T-2 ~> Pa] real, intent(out) :: drho_dS_dS !< Partial derivative of beta with respect to S !! [kg m-3 ppt-2] or [R ppt-2 ~> kg m-3 ppt-2] real, intent(out) :: drho_dS_dT !< Partial derivative of beta with respect to T @@ -510,57 +940,71 @@ subroutine calculate_density_second_derivs_scalar(T, S, pressure, drho_dS_dS, dr !! [kg m-3 degC-1 Pa-1] or [R degC-1 Pa-1 ~> kg m-3 degC-1 Pa-1] type(EOS_type), pointer :: EOS !< Equation of state structure real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density - !! from kg m-3 to the desired units [R m3 kg-1] + !! in combination with scaling given by US [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 :: p_scale ! A factor to convert pressure to units of Pa [Pa T2 R-1 L-2 ~> 1] + real :: I_p_scale ! The inverse of the factor to convert pressure to units of Pa [R L2 T-2 Pa-1 ~> 1] if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_density_derivs called with an unassociated EOS_type EOS.") + p_scale = EOS%RL2_T2_to_Pa + select case (EOS%form_of_EOS) case (EOS_LINEAR) - call calculate_density_second_derivs_linear(T, S, pressure, drho_dS_dS, drho_dS_dT, & + call calculate_density_second_derivs_linear(T, S, p_scale*pressure, drho_dS_dS, drho_dS_dT, & drho_dT_dT, drho_dS_dP, drho_dT_dP) case (EOS_WRIGHT) - call calculate_density_second_derivs_wright(T, S, pressure, drho_dS_dS, drho_dS_dT, & + call calculate_density_second_derivs_wright(T, S, p_scale*pressure, drho_dS_dS, drho_dS_dT, & drho_dT_dT, drho_dS_dP, drho_dT_dP) case (EOS_TEOS10) - call calculate_density_second_derivs_teos10(T, S, pressure, drho_dS_dS, drho_dS_dT, & + call calculate_density_second_derivs_teos10(T, S, p_scale*pressure, drho_dS_dS, drho_dS_dT, & drho_dT_dT, drho_dS_dP, drho_dT_dP) case default - call MOM_error(FATAL, & - "calculate_density_derivs: EOS%form_of_EOS is not valid.") + call MOM_error(FATAL, "calculate_density_derivs: EOS%form_of_EOS is not valid.") end select - if (present(scale)) then ; if (scale /= 1.0) then - drho_dS_dS = scale * drho_dS_dS - drho_dS_dT = scale * drho_dS_dT - drho_dT_dT = scale * drho_dT_dT - drho_dS_dP = scale * drho_dS_dP - drho_dT_dP = scale * drho_dT_dP - endif ; endif + 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 (p_scale /= 1.0) then + I_p_scale = 1.0 / p_scale + drho_dS_dP = I_p_scale * drho_dS_dP + drho_dT_dP = I_p_scale * drho_dT_dP + endif end subroutine calculate_density_second_derivs_scalar !> Calls the appropriate subroutine to calculate specific volume derivatives for an array. -subroutine calculate_specific_vol_derivs(T, S, pressure, dSV_dT, dSV_dS, start, npts, EOS, scale) +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] or [R-1 degC-1 ~> m3 kg-1 degC-1] + !! 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] or [R-1 ppt-1 ~> m3 kg-1 ppt-1]. + !! [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), pointer :: EOS !< Equation of state structure - real, optional, intent(in) :: scale !< A multiplicative factor by which to scale specific volume - !! from m3 kg-1 to the desired units [kg m-3 R-1] ! Local variables - real, dimension(size(T)) :: dRho_dT, dRho_dS, rho + real, dimension(size(T)) :: press ! Pressure converted to [Pa] + real, dimension(size(T)) :: rho ! In situ density [kg m-3] + real, dimension(size(T)) :: dRho_dT ! Derivative of density with temperature [kg m-3 degC-1] + real, dimension(size(T)) :: dRho_dS ! Derivative of density with salinity [kg m-3 ppt-1] integer :: j if (.not.associated(EOS)) call MOM_error(FATAL, & - "calculate_density_derivs called with an unassociated EOS_type EOS.") + "calculate_spec_vol_derivs_array called with an unassociated EOS_type EOS.") select case (EOS%form_of_EOS) case (EOS_LINEAR) @@ -585,33 +1029,84 @@ subroutine calculate_specific_vol_derivs(T, S, pressure, dSV_dT, dSV_dS, start, dSV_dS(j) = -dRho_DS(j)/(rho(j)**2) enddo case default - call MOM_error(FATAL, & - "calculate_density_derivs: EOS%form_of_EOS is not valid.") + call MOM_error(FATAL, "calculate_spec_vol_derivs_array: EOS%form_of_EOS is not valid.") end select - if (present(scale)) then ; if (scale /= 1.0) then ; do j=start,start+npts-1 - dSV_dT(j) = scale * dSV_dT(j) - dSV_dS(j) = scale * dSV_dS(j) - enddo ; endif ; endif +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 [degC] + real, dimension(:), intent(in) :: S !< Salinity [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 degC-1 ~> m3 kg-1 degC-1] + real, dimension(:), intent(inout) :: dSV_dS !< The partial derivative of specific volume with salinity + !! [R-1 ppt-1 ~> m3 kg-1 ppt-1] + type(EOS_type), pointer :: EOS !< Equation of state structure + integer, dimension(2), optional, intent(in) :: dom !< The domain of indices to work on, taking + !! into account that arrays start at 1. + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale specific + !! volume in combination with scaling given by US [various] + ! Local variables + real, dimension(size(dSV_dT)) :: press ! Pressure converted to [Pa] + real :: spv_scale ! A factor to convert specific volume from m3 kg-1 to the desired units [kg R-1 m-3 ~> 1] + real :: p_scale ! A factor to convert pressure to units of Pa [Pa T2 R-1 L-2 ~> 1] + integer :: i, is, ie, npts -end subroutine calculate_specific_vol_derivs + if (.not.associated(EOS)) call MOM_error(FATAL, & + "calculate_spec_vol_derivs_1d called with an unassociated EOS_type EOS.") -!> Calls the appropriate subroutine to calculate the density and compressibility for 1-D array inputs. -subroutine calculate_compress_array(T, S, pressure, rho, drho_dp, start, npts, EOS) + 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 + p_scale = EOS%RL2_T2_to_Pa + + if (p_scale == 1.0) then + call calculate_spec_vol_derivs_array(T, S, pressure, dSV_dT, dSV_dS, is, npts, EOS) + else + do i=is,ie ; press(i) = p_scale * pressure(i) ; enddo + call calculate_spec_vol_derivs_array(T, S, press, dSV_dT, dSV_dS, is, npts, EOS) + 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 + dSV_dT(i) = spv_scale * dSV_dT(i) + dSV_dS(i) = spv_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. If US is present, the units of the inputs and outputs are rescaled. +subroutine calculate_compress_array(T, S, press, rho, drho_dp, start, npts, EOS) real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [degC] real, dimension(:), intent(in) :: S !< Salinity [PSU] - real, dimension(:), intent(in) :: pressure !< Pressure [Pa] - real, dimension(:), intent(inout) :: rho !< In situ density [kg m-3]. + real, dimension(:), intent(in) :: press !< Pressure [Pa] or [R L2 T-2 ~> Pa] + real, dimension(:), intent(inout) :: rho !< In situ density [kg m-3] or [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) [s2 m-2]. + !! (also the inverse of the square of sound speed) + !! [s2 m-2] or [T2 L-2] integer, intent(in) :: start !< Starting index within the array integer, intent(in) :: npts !< The number of values to calculate type(EOS_type), pointer :: EOS !< Equation of state structure + ! Local variables + real, dimension(size(press)) :: pressure ! Pressure converted to [Pa] + integer :: i, is, ie + if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_compress called with an unassociated EOS_type EOS.") + is = start ; ie = is + npts - 1 + do i=is,ie ; pressure(i) = EOS%RL2_T2_to_Pa * press(i) ; enddo + select case (EOS%form_of_EOS) case (EOS_LINEAR) call calculate_compress_linear(T, S, pressure, rho, drho_dp, start, npts, & @@ -625,23 +1120,31 @@ subroutine calculate_compress_array(T, S, pressure, rho, drho_dp, start, npts, E case (EOS_NEMO) call calculate_compress_nemo(T, S, pressure, rho, drho_dp, start, npts) case default - call MOM_error(FATAL, & - "calculate_compress: EOS%form_of_EOS is not valid.") + call MOM_error(FATAL, "calculate_compress: EOS%form_of_EOS is not valid.") end select + 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_array -!> Calculate density and compressibility for a scalar. This just promotes the scalar to an array with a singleton -!! dimension and calls calculate_compress_array +!> Calculate density and compressibility for a scalar. This just promotes the scalar to an array +!! with a singleton dimension and calls calculate_compress_array. If US is present, the units of +!! the inputs and outputs are rescaled. subroutine calculate_compress_scalar(T, S, pressure, rho, drho_dp, EOS) - real, intent(in) :: T !< Potential temperature referenced to the surface (degC) - real, intent(in) :: S !< Salinity (PSU) - real, intent(in) :: pressure !< Pressure (Pa) - real, intent(out) :: rho !< In situ density in kg m-3. - real, intent(out) :: drho_dp !< The partial derivative of density with pressure - !! (also the inverse of the square of sound speed) in s2 m-2. + real, intent(in) :: T !< Potential temperature referenced to the surface [degC] + real, intent(in) :: S !< Salinity [ppt] + real, intent(in) :: pressure !< Pressure [Pa] or [R L2 T-2 ~> Pa] + real, intent(out) :: rho !< In situ density [kg m-3] or [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) [s2 m-2] or [T2 L-2] type(EOS_type), pointer :: EOS !< Equation of state structure + ! Local variables real, dimension(1) :: Ta, Sa, pa, rhoa, drho_dpa if (.not.associated(EOS)) call MOM_error(FATAL, & @@ -652,13 +1155,34 @@ subroutine calculate_compress_scalar(T, S, pressure, rho, drho_dp, EOS) rho = rhoa(1) ; drho_dp = drho_dpa(1) end subroutine calculate_compress_scalar -!> Calls the appropriate subroutine to alculate analytical and nearly-analytical + + +!> 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 Bode's rule to do the horizontal integrals, and from a truncation in the -!! series for log(1-eps/1+eps) that assumes that |eps| < . -subroutine int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, & +!! 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 @@ -667,128 +1191,148 @@ subroutine int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, & real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: S !< Salinity [ppt] real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: p_t !< Pressure at the top of the layer [Pa]. + intent(in) :: p_t !< Pressure at the top of the layer [R L2 T-2 ~> Pa] or [Pa] real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: p_b !< Pressure at the bottom of the layer [Pa]. + intent(in) :: p_b !< Pressure at the bottom of the layer [R L2 T-2 ~> Pa] or [Pa] real, intent(in) :: alpha_ref !< A mean specific volume that is subtracted out - !! to reduce the magnitude of each of the integrals, m3 kg-1. The - !! calculation is mathematically identical with different values of + !! to reduce the magnitude of each of the integrals [R-1 ~> m3 kg-1] + !! The calculation is mathematically identical with different values of !! alpha_ref, but this reduces the effects of roundoff. type(EOS_type), pointer :: EOS !< Equation of state structure real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(inout) :: dza !< The change in the geopotential anomaly across - !! the layer [m2 s-2]. + !! the layer [L2 T-2 ~> m2 s-2] or [m2 s-2] real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & optional, intent(inout) :: intp_dza !< The integral in pressure through the layer of the !! geopotential anomaly relative to the anomaly at the bottom of the - !! layer [Pa m2 s-2]. + !! layer [R L4 T-4 ~> Pa m2 s-2] or [Pa m2 s-2] real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & optional, intent(inout) :: intx_dza !< The integral in x of the difference between the !! geopotential anomaly at the top and bottom of the layer divided by - !! the x grid spacing [m2 s-2]. + !! the x grid spacing [L2 T-2 ~> m2 s-2] or [m2 s-2] real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & optional, intent(inout) :: inty_dza !< The integral in y of the difference between the !! geopotential anomaly at the top and bottom of the layer divided by - !! the y grid spacing [m2 s-2]. + !! the y grid spacing [L2 T-2 ~> m2 s-2] or [m2 s-2] integer, optional, intent(in) :: halo_size !< The width of halo points on which to calculate dza. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - optional, intent(in) :: bathyP !< The pressure at the bathymetry [Pa] + optional, intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] or [Pa] real, optional, intent(in) :: dP_tiny !< A miniscule pressure change with - !! the same units as p_t (Pa?) + !! the same units as p_t [R L2 T-2 ~> Pa] or [Pa] logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting !! to interpolate T/S for top and bottom integrals. + ! Local variables + real :: pres_scale ! A unit conversion factor from the rescaled units of pressure to Pa [Pa T2 R-1 L-2 ~> 1] + real :: SV_scale ! A multiplicative factor by which to scale specific + ! volume from m3 kg-1 to the desired units [kg m-3 R-1 ~> 1] if (.not.associated(EOS)) call MOM_error(FATAL, & "int_specific_vol_dp called with an unassociated EOS_type EOS.") - if (EOS%EOS_quadrature) then - call int_spec_vol_dp_generic(T, S, p_t, p_b, alpha_ref, HI, EOS, & - dza, intp_dza, intx_dza, inty_dza, halo_size, & - bathyP, dP_tiny, useMassWghtInterp) - else ; select case (EOS%form_of_EOS) + ! We should never reach this point with quadrature. EOS_quadrature indicates that numerical + ! integration be used instead of analytic. This is a safety check. + if (EOS%EOS_quadrature) call MOM_error(FATAL, "EOS_quadrature is set!") + + select case (EOS%form_of_EOS) case (EOS_LINEAR) - call int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, EOS%Rho_T0_S0, & - EOS%dRho_dT, EOS%dRho_dS, dza, intp_dza, & - intx_dza, inty_dza, halo_size, & - bathyP, dP_tiny, useMassWghtInterp) + call int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, EOS%kg_m3_to_R*EOS%Rho_T0_S0, & + EOS%kg_m3_to_R*EOS%dRho_dT, EOS%kg_m3_to_R*EOS%dRho_dS, dza, & + 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) + 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) case default - call int_spec_vol_dp_generic(T, S, p_t, p_b, alpha_ref, HI, EOS, & - dza, intp_dza, intx_dza, inty_dza, halo_size, & - bathyP, dP_tiny, useMassWghtInterp) - end select ; endif + call MOM_error(FATAL, "No analytic integration option is available with this EOS!") + end select -end subroutine int_specific_vol_dp +end subroutine analytic_int_specific_vol_dp !> This subroutine calculates analytical and nearly-analytical integrals of !! pressure anomalies across layers, which are required for calculating the !! finite-volume form pressure accelerations in a Boussinesq model. -subroutine int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, EOS, & - dpa, intz_dpa, intx_dpa, inty_dpa, & - bathyT, dz_neglect, useMassWghtInterp) - type(hor_index_type), intent(in) :: HII !< Ocean horizontal index structures for the input arrays - type(hor_index_type), intent(in) :: HIO !< Ocean horizontal index structures for the output arrays - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & +subroutine analytic_int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, dpa, & + intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp) + type(hor_index_type), intent(in) :: HI !< Ocean horizontal index structure + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: T !< Potential temperature referenced to the surface [degC] - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: S !< Salinity [ppt] - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & - intent(in) :: z_t !< Height at the top of the layer in depth units [Z ~> m]. - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & - intent(in) :: z_b !< Height at the bottom of the layer [Z ~> m]. - real, intent(in) :: rho_ref !< A mean density [kg m-3], that is subtracted out to - !! reduce the magnitude of each of the integrals. - real, intent(in) :: rho_0 !< A density [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 [m2 Z-1 s-2 ~> m s-2]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: z_t !< Height at the top of the layer in depth units [Z ~> m] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: z_b !< Height at the bottom of the layer [Z ~> m] + real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3] or [kg m-3], that is + !! subtracted out to reduce the magnitude of each of the + !! integrals. + real, intent(in) :: rho_0 !< A density [R ~> kg m-3] or [kg m-3], that is used + !! to calculate the pressure (as p~=-z*rho_0*G_e) + !! used in the equation of state. + real, intent(in) :: G_e !< The Earth's gravitational acceleration + !! [L2 Z-1 T-2 ~> m s-2] or [m2 Z-1 s-2 ~> m s-2] type(EOS_type), pointer :: EOS !< Equation of state structure - real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & - intent(inout) :: dpa !< The change in the pressure anomaly across the layer [Pa]. - real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%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 [Pa Z ~> Pa m]. - real, dimension(HIO%IsdB:HIO%IedB,HIO%jsd:HIO%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 [Pa]. - real, dimension(HIO%isd:HIO%ied,HIO%JsdB:HIO%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 [Pa]. - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & - optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m]. - real, optional, intent(in) :: dz_neglect !< A miniscule thickness change [Z ~> m]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(inout) :: dpa !< The change in the pressure anomaly + !! across the layer [R L2 T-2 ~> Pa] or [Pa] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(inout) :: intz_dpa !< The integral through the thickness of the + !! layer of the pressure anomaly relative to the + !! anomaly at the top of the layer [R L2 Z T-2 ~> Pa m] + real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & + optional, intent(inout) :: intx_dpa !< The integral in x of the difference between + !! the pressure anomaly at the top and bottom of the + !! layer divided by the x grid spacing [R L2 T-2 ~> Pa] + real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & + optional, intent(inout) :: inty_dpa !< The integral in y of the difference between + !! the pressure anomaly at the top and bottom of the + !! layer divided by the y grid spacing [R L2 T-2 ~> Pa] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m] + real, optional, intent(in) :: dz_neglect !< A miniscule thickness change [Z ~> m] logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to !! interpolate T/S for top and bottom integrals. + ! Local variables + real :: rho_scale ! A multiplicative factor by which to scale density from kg m-3 to the + ! desired units [R m3 kg-1 ~> 1] + real :: pres_scale ! A multiplicative factor to convert pressure into Pa [Pa T2 R-1 L-2 ~> 1] if (.not.associated(EOS)) call MOM_error(FATAL, & "int_density_dz called with an unassociated EOS_type EOS.") - if (EOS%EOS_quadrature) then - call int_density_dz_generic(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, & - EOS, dpa, intz_dpa, intx_dpa, inty_dpa, & - bathyT, dz_neglect, useMassWghtInterp) - else ; select case (EOS%form_of_EOS) + ! We should never reach this point with quadrature. EOS_quadrature indicates that numerical + ! integration be used instead of analytic. This is a safety check. + if (EOS%EOS_quadrature) call MOM_error(FATAL, "EOS_quadrature is set!") + + select case (EOS%form_of_EOS) case (EOS_LINEAR) - call int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, & - EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS, & - dpa, intz_dpa, intx_dpa, inty_dpa, & - bathyT, dz_neglect, useMassWghtInterp) + rho_scale = EOS%kg_m3_to_R + if (rho_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, rho_scale*EOS%dRho_dT, rho_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) - call int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, & - dpa, intz_dpa, intx_dpa, inty_dpa, & - bathyT, dz_neglect, useMassWghtInterp) + rho_scale = EOS%kg_m3_to_R + pres_scale = EOS%RL2_T2_to_Pa + if ((rho_scale /= 1.0) .or. (pres_scale /= 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) + 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) + endif case default - call int_density_dz_generic(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, & - EOS, dpa, intz_dpa, intx_dpa, inty_dpa, & - bathyT, dz_neglect, useMassWghtInterp) - end select ; endif + call MOM_error(FATAL, "No analytic integration option is available with this EOS!") + end select -end subroutine int_density_dz +end subroutine analytic_int_density_dz !> Returns true if the equation of state is compressible (i.e. has pressure dependence) logical function query_compressible(EOS) @@ -801,9 +1345,11 @@ logical function query_compressible(EOS) end function query_compressible !> Initializes EOS_type by allocating and reading parameters -subroutine EOS_init(param_file, EOS) +subroutine EOS_init(param_file, EOS, US) type(param_file_type), intent(in) :: param_file !< Parameter file structure type(EOS_type), pointer :: 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. @@ -897,6 +1443,12 @@ subroutine EOS_init(param_file, EOS) "should only be used along with TFREEZE_FORM = TFREEZE_TEOS10 .") 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 end subroutine EOS_init @@ -915,11 +1467,11 @@ subroutine EOS_manual_init(EOS, form_of_EOS, form_of_TFreeze, EOS_quadrature, Co !! 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) :: 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]. + !! in [degC ppt-1] real , optional, intent(in) :: dTFr_dp !< The derivative of freezing point with pressure - !! in [degC Pa-1]. + !! in [degC Pa-1] if (present(form_of_EOS )) EOS%form_of_EOS = form_of_EOS if (present(form_of_TFreeze)) EOS%form_of_TFreeze = form_of_TFreeze @@ -974,1480 +1526,20 @@ subroutine EOS_use_linear(Rho_T0_S0, dRho_dT, dRho_dS, EOS, use_quadrature) end subroutine EOS_use_linear -!> This subroutine calculates (by numerical quadrature) integrals of -!! pressure anomalies across layers, which are required for calculating the -!! finite-volume form pressure accelerations in a Boussinesq model. -subroutine int_density_dz_generic(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, & - EOS, dpa, intz_dpa, intx_dpa, inty_dpa, & - bathyT, dz_neglect, useMassWghtInterp) - type(hor_index_type), intent(in) :: HII !< Horizontal index type for input variables. - type(hor_index_type), intent(in) :: HIO !< Horizontal index type for output variables. - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & - intent(in) :: T !< Potential temperature of the layer [degC]. - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & - intent(in) :: S !< Salinity of the layer [ppt]. - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & - intent(in) :: z_t !< Height at the top of the layer in depth units [Z ~> m]. - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & - intent(in) :: z_b !< Height at the bottom of the layer [Z ~> m]. - real, intent(in) :: rho_ref !< A mean density [kg m-3], that is - !! subtracted out to reduce the magnitude - !! of each of the integrals. - real, intent(in) :: rho_0 !< A density [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 [m2 Z-1 s-2 ~> m s-2]. - type(EOS_type), pointer :: EOS !< Equation of state structure - real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & - intent(inout) :: dpa !< The change in the pressure anomaly - !! across the layer [Pa]. - real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%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 [Pa Z ~> Pa m]. - real, dimension(HIO%IsdB:HIO%IedB,HIO%jsd:HIO%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 [Pa]. - real, dimension(HIO%isd:HIO%ied,HIO%JsdB:HIO%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 [Pa]. - real, dimension(HII%isd:HII%ied,HII%jsd:HII%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 :: T5(5), S5(5), p5(5), r5(5) - real :: rho_anom ! The depth averaged density anomaly [kg m-3]. - real :: w_left, w_right - real, parameter :: C1_90 = 1.0/90.0 ! Rational constants. - real :: GxRho, I_Rho - 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 [Pa]. - logical :: do_massWeight ! Indicates whether to do mass weighting. - integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, i, j, m, n, ioff, joff - - ioff = HIO%idg_offset - HII%idg_offset - joff = HIO%jdg_offset - HII%jdg_offset - - ! These array bounds work for the indexing convention of the input arrays, but - ! on the computational domain defined for the output arrays. - Isq = HIO%IscB + ioff ; Ieq = HIO%IecB + ioff - Jsq = HIO%JscB + joff ; Jeq = HIO%JecB + joff - is = HIO%isc + ioff ; ie = HIO%iec + ioff - js = HIO%jsc + joff ; je = HIO%jec + joff - - GxRho = G_e * rho_0 - I_Rho = 1.0 / rho_0 - - do_massWeight = .false. - if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then - do_massWeight = .true. - if (.not.present(bathyT)) call MOM_error(FATAL, "int_density_dz_generic: "//& - "bathyT must be present if useMassWghtInterp is present and true.") - if (.not.present(dz_neglect)) call MOM_error(FATAL, "int_density_dz_generic: "//& - "dz_neglect must be present if useMassWghtInterp is present and true.") - endif ; endif - - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - dz = z_t(i,j) - z_b(i,j) - do n=1,5 - T5(n) = T(i,j) ; S5(n) = S(i,j) - p5(n) = -GxRho*(z_t(i,j) - 0.25*real(n-1)*dz) - enddo - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref) - - ! Use Bode's rule to estimate the pressure anomaly change. - rho_anom = C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3)) - dpa(i-ioff,j-joff) = G_e*dz*rho_anom - ! Use a Bode's-rule-like fifth-order accurate estimate of the double integral of - ! the pressure anomaly. - if (present(intz_dpa)) intz_dpa(i-ioff,j-joff) = 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-ioff,j-joff) ; intz(5) = dpa(i+1-ioff,j-joff) - do m=2,4 - ! T, S, and z are interpolated in the horizontal. The z interpolation - ! is linear, but for T and S it may be thickness weighted. - wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L - wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR - dz = wt_L*(z_t(i,j) - z_b(i,j)) + wt_R*(z_t(i+1,j) - z_b(i+1,j)) - T5(1) = wtT_L*T(i,j) + wtT_R*T(i+1,j) - S5(1) = wtT_L*S(i,j) + wtT_R*S(i+1,j) - p5(1) = -GxRho*(wt_L*z_t(i,j) + wt_R*z_t(i+1,j)) - do n=2,5 - T5(n) = T5(1) ; S5(n) = S5(1) ; p5(n) = p5(n-1) + GxRho*0.25*dz - enddo - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref) - - ! Use Bode's rule to estimate the pressure anomaly change. - intz(m) = G_e*dz*( C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3))) - enddo - ! Use Bode's rule to integrate the bottom pressure anomaly values in x. - intx_dpa(i-ioff,j-joff) = 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-ioff,j-joff) ; intz(5) = dpa(i-ioff,j-joff+1) - do m=2,4 - ! T, S, and z are interpolated in the horizontal. The z interpolation - ! is linear, but for T and S it may be thickness weighted. - wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L - wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR - dz = wt_L*(z_t(i,j) - z_b(i,j)) + wt_R*(z_t(i,j+1) - z_b(i,j+1)) - T5(1) = wtT_L*T(i,j) + wtT_R*T(i,j+1) - S5(1) = wtT_L*S(i,j) + wtT_R*S(i,j+1) - p5(1) = -GxRho*(wt_L*z_t(i,j) + wt_R*z_t(i,j+1)) - do n=2,5 - T5(n) = T5(1) ; S5(n) = S5(1) - p5(n) = p5(n-1) + GxRho*0.25*dz - enddo - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref) - - ! Use Bode's rule to estimate the pressure anomaly change. - intz(m) = G_e*dz*( C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3))) - enddo - ! Use Bode's rule to integrate the values. - inty_dpa(i-ioff,j-joff) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & - 12.0*intz(3)) - enddo ; enddo ; endif -end subroutine int_density_dz_generic - - -! ========================================================================== -!> Compute pressure gradient force integrals by quadrature for the case where -!! T and S are linear profiles. -subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & - rho_0, G_e, dz_subroundoff, bathyT, HII, HIO, EOS, dpa, & - intz_dpa, intx_dpa, inty_dpa, & - useMassWghtInterp) - type(hor_index_type), intent(in) :: HII !< Ocean horizontal index structures for the input arrays - type(hor_index_type), intent(in) :: HIO !< Ocean horizontal index structures for the output arrays - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & - intent(in) :: T_t !< Potential temperatue at the cell top [degC] - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & - intent(in) :: T_b !< Potential temperatue at the cell bottom [degC] - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & - intent(in) :: S_t !< Salinity at the cell top [ppt] - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & - intent(in) :: S_b !< Salinity at the cell bottom [ppt] - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & - intent(in) :: z_t !< The geometric height at the top of the layer, - !! in depth units [Z ~> m]. - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & - intent(in) :: z_b !< The geometric height at the bottom of the layer [Z ~> m]. - real, intent(in) :: rho_ref !< A mean density [kg m-3], that is subtracted out to - !! reduce the magnitude of each of the integrals. - real, intent(in) :: rho_0 !< A density [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 [m2 Z-1 s-2 ~> m s-2]. - real, intent(in) :: dz_subroundoff !< A miniscule thickness change [Z ~> m]. - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & - intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m]. - type(EOS_type), pointer :: EOS !< Equation of state structure - real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & - intent(inout) :: dpa !< The change in the pressure anomaly across the layer [Pa]. - real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%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 [Pa Z]. - real, dimension(HIO%IsdB:HIO%IedB,HIO%jsd:HIO%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 [Pa]. - real, dimension(HIO%isd:HIO%ied,HIO%JsdB:HIO%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 [Pa]. - logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to - !! interpolate T/S for top and bottom integrals. -! This subroutine calculates (by numerical quadrature) integrals of -! pressure anomalies across layers, which are required for calculating the -! finite-volume form pressure accelerations in a Boussinesq model. The one -! potentially dodgy assumtion here is that rho_0 is used both in the denominator -! of the accelerations, and in the pressure used to calculated density (the -! latter being -z*rho_0*G_e). These two uses could be separated if need be. -! -! It is assumed that the salinity and temperature profiles are linear in the -! vertical. The top and bottom values within each layer are provided and -! a linear interpolation is used to compute intermediate values. - - ! Local variables - real :: T5((5*HIO%iscB+1):(5*(HIO%iecB+2))) ! Temperatures along a line of subgrid locations [degC]. - real :: S5((5*HIO%iscB+1):(5*(HIO%iecB+2))) ! Salinities along a line of subgrid locations [ppt]. - real :: p5((5*HIO%iscB+1):(5*(HIO%iecB+2))) ! Pressures along a line of subgrid locations [Pa]. - real :: r5((5*HIO%iscB+1):(5*(HIO%iecB+2))) ! Densities along a line of subgrid locations [kg m-3]. - real :: T15((15*HIO%iscB+1):(15*(HIO%iecB+1))) ! Temperatures at an array of subgrid locations [degC]. - real :: S15((15*HIO%iscB+1):(15*(HIO%iecB+1))) ! Salinities at an array of subgrid locations [ppt]. - real :: p15((15*HIO%iscB+1):(15*(HIO%iecB+1))) ! Pressures at an array of subgrid locations [Pa]. - real :: r15((15*HIO%iscB+1):(15*(HIO%iecB+1))) ! Densities at an array of subgrid locations [kg m-3]. - real :: wt_t(5), wt_b(5) ! Top and bottom weights [nondim]. - real :: rho_anom ! A density anomaly [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 [Pa]. - real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim]. - real :: GxRho ! Gravitational acceleration times density [kg m-1 Z-1 s-2 ~> kg m-2 s-2]. - real :: I_Rho ! The inverse of the reference density [m3 kg-1]. - real :: dz(HIO%iscB:HIO%iecB+1) ! Layer thicknesses at tracer points [Z ~> m]. - real :: dz_x(5,HIO%iscB:HIO%iecB) ! Layer thicknesses along an x-line of subrid locations [Z ~> m]. - real :: dz_y(5,HIO%isc:HIO%iec) ! Layer thicknesses along a y-line of subrid locations [Z ~> m]. - real :: weight_t, weight_b ! Nondimensional weights of the top and bottom. - real :: massWeightToggle ! A nondimensional toggle factor (0 or 1). - real :: Ttl, Tbl, Ttr, Tbr ! Temperatures at the velocity cell corners [degC]. - real :: Stl, Sbl, Str, Sbr ! Salinities at the velocity cell corners [ppt]. - real :: hWght ! A topographically limited thicknes weight [Z ~> m]. - real :: hL, hR ! Thicknesses to the left and right [Z ~> m]. - real :: iDenom ! The denominator of the thickness weight expressions [Z-2 ~> m-2]. - integer :: Isq, Ieq, Jsq, Jeq, i, j, m, n - integer :: iin, jin, ioff, joff - integer :: pos - - ioff = HIO%idg_offset - HII%idg_offset - joff = HIO%jdg_offset - HII%jdg_offset - - Isq = HIO%IscB ; Ieq = HIO%IecB ; Jsq = HIO%JscB ; Jeq = HIO%JecB - - GxRho = G_e * rho_0 - I_Rho = 1.0 / rho_0 - massWeightToggle = 0. - if (present(useMassWghtInterp)) then - if (useMassWghtInterp) massWeightToggle = 1. - endif - - do n = 1, 5 - wt_t(n) = 0.25 * real(5-n) - wt_b(n) = 1.0 - wt_t(n) - enddo - - ! ============================= - ! 1. Compute vertical integrals - ! ============================= - do j=Jsq,Jeq+1 - jin = j+joff - do i = Isq,Ieq+1 ; iin = i+ioff - dz(i) = z_t(iin,jin) - z_b(iin,jin) - do n=1,5 - p5(i*5+n) = -GxRho*(z_t(iin,jin) - 0.25*real(n-1)*dz(i)) - ! Salinity and temperature points are linearly interpolated - S5(i*5+n) = wt_t(n) * S_t(iin,jin) + wt_b(n) * S_b(iin,jin) - T5(i*5+n) = wt_t(n) * T_t(iin,jin) + wt_b(n) * T_b(iin,jin) - enddo - enddo - call calculate_density_array(T5, S5, p5, r5, 1, (ieq-isq+2)*5, EOS, rho_ref ) - - do i=isq,ieq+1 ; iin = i+ioff - ! Use Bode's rule to estimate the pressure anomaly change. - rho_anom = C1_90*(7.0*(r5(i*5+1)+r5(i*5+5)) + 32.0*(r5(i*5+2)+r5(i*5+4)) + 12.0*r5(i*5+3)) - dpa(i,j) = G_e*dz(i)*rho_anom - if (present(intz_dpa)) then - ! Use a Bode's-rule-like fifth-order accurate estimate of - ! the double integral of the pressure anomaly. - intz_dpa(i,j) = 0.5*G_e*dz(i)**2 * & - (rho_anom - C1_90*(16.0*(r5(i*5+4)-r5(i*5+2)) + 7.0*(r5(i*5+5)-r5(i*5+1))) ) - endif - enddo - enddo ! end loops on j - - - ! ================================================== - ! 2. Compute horizontal integrals in the x direction - ! ================================================== - if (present(intx_dpa)) then ; do j=HIO%jsc,HIO%jec ; jin = j+joff - do I=Isq,Ieq ; iin = i+ioff - ! 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(iin,jin)-z_t(iin+1,jin), -bathyT(iin+1,jin)-z_t(iin,jin)) - if (hWght > 0.) then - hL = (z_t(iin,jin) - z_b(iin,jin)) + dz_subroundoff - hR = (z_t(iin+1,jin) - z_b(iin+1,jin)) + dz_subroundoff - hWght = hWght * ( (hL-hR)/(hL+hR) )**2 - iDenom = 1./( hWght*(hR + hL) + hL*hR ) - Ttl = ( (hWght*hR)*T_t(iin+1,jin) + (hWght*hL + hR*hL)*T_t(iin,jin) ) * iDenom - Ttr = ( (hWght*hL)*T_t(iin,jin) + (hWght*hR + hR*hL)*T_t(iin+1,jin) ) * iDenom - Tbl = ( (hWght*hR)*T_b(iin+1,jin) + (hWght*hL + hR*hL)*T_b(iin,jin) ) * iDenom - Tbr = ( (hWght*hL)*T_b(iin,jin) + (hWght*hR + hR*hL)*T_b(iin+1,jin) ) * iDenom - Stl = ( (hWght*hR)*S_t(iin+1,jin) + (hWght*hL + hR*hL)*S_t(iin,jin) ) * iDenom - Str = ( (hWght*hL)*S_t(iin,jin) + (hWght*hR + hR*hL)*S_t(iin+1,jin) ) * iDenom - Sbl = ( (hWght*hR)*S_b(iin+1,jin) + (hWght*hL + hR*hL)*S_b(iin,jin) ) * iDenom - Sbr = ( (hWght*hL)*S_b(iin,jin) + (hWght*hR + hR*hL)*S_b(iin+1,jin) ) * iDenom - else - Ttl = T_t(iin,jin); Tbl = T_b(iin,jin); Ttr = T_t(iin+1,jin); Tbr = T_b(iin+1,jin) - Stl = S_t(iin,jin); Sbl = S_b(iin,jin); Str = S_t(iin+1,jin); Sbr = S_b(iin+1,jin) - endif - - do m=2,4 - w_left = 0.25*real(5-m) ; w_right = 1.0-w_left - dz_x(m,i) = w_left*(z_t(iin,jin) - z_b(iin,jin)) + w_right*(z_t(iin+1,jin) - z_b(iin+1,jin)) - - ! Salinity and temperature points are linearly interpolated in - ! the horizontal. The subscript (1) refers to the top value in - ! the vertical profile while subscript (5) refers to the bottom - ! value in the vertical profile. - pos = i*15+(m-2)*5 - T15(pos+1) = w_left*Ttl + w_right*Ttr - T15(pos+5) = w_left*Tbl + w_right*Tbr - - S15(pos+1) = w_left*Stl + w_right*Str - S15(pos+5) = w_left*Sbl + w_right*Sbr - - p15(pos+1) = -GxRho*(w_left*z_t(iin,jin) + w_right*z_t(iin+1,jin)) - - ! Pressure - do n=2,5 - p15(pos+n) = p15(pos+n-1) + GxRho*0.25*dz_x(m,i) - enddo - - ! Salinity and temperature (linear interpolation in the vertical) - do n=2,4 - weight_t = 0.25 * real(5-n) - weight_b = 1.0 - weight_t - S15(pos+n) = weight_t * S15(pos+1) + weight_b * S15(pos+5) - T15(pos+n) = weight_t * T15(pos+1) + weight_b * T15(pos+5) - enddo - enddo - enddo - - call calculate_density(T15, S15, p15, r15, 1, 15*(ieq-isq+1), EOS, rho_ref) - - do I=Isq,Ieq ; iin = i+ioff - intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j) - - ! Use Bode's rule to estimate the pressure anomaly change. - do m = 2,4 - pos = i*15+(m-2)*5 - intz(m) = G_e*dz_x(m,i)*( C1_90*(7.0*(r15(pos+1)+r15(pos+5)) + 32.0*(r15(pos+2)+r15(pos+4)) + & - 12.0*r15(pos+3))) - enddo - ! Use Bode's rule to integrate the bottom pressure anomaly values in x. - intx_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & - 12.0*intz(3)) - enddo - enddo ; endif - - ! ================================================== - ! 3. Compute horizontal integrals in the y direction - ! ================================================== - if (present(inty_dpa)) then ; do J=Jsq,Jeq ; jin = j+joff - do i=HIO%isc,HIO%iec ; iin = i+ioff - ! Corner values of T and S - ! hWght is the distance measure by which the cell is violation of - ! hydrostatic consistency. For large hWght we bias the interpolation - ! of T,S along the top and bottom integrals, almost like thickness - ! weighting. - ! Note: To work in terrain following coordinates we could offset - ! this distance by the layer thickness to replicate other models. - hWght = massWeightToggle * & - max(0., -bathyT(i,j)-z_t(iin,jin+1), -bathyT(i,j+1)-z_t(iin,jin)) - if (hWght > 0.) then - hL = (z_t(iin,jin) - z_b(iin,jin)) + dz_subroundoff - hR = (z_t(iin,jin+1) - z_b(iin,jin+1)) + dz_subroundoff - hWght = hWght * ( (hL-hR)/(hL+hR) )**2 - iDenom = 1./( hWght*(hR + hL) + hL*hR ) - Ttl = ( (hWght*hR)*T_t(iin,jin+1) + (hWght*hL + hR*hL)*T_t(iin,jin) ) * iDenom - Ttr = ( (hWght*hL)*T_t(iin,jin) + (hWght*hR + hR*hL)*T_t(iin,jin+1) ) * iDenom - Tbl = ( (hWght*hR)*T_b(iin,jin+1) + (hWght*hL + hR*hL)*T_b(iin,jin) ) * iDenom - Tbr = ( (hWght*hL)*T_b(iin,jin) + (hWght*hR + hR*hL)*T_b(iin,jin+1) ) * iDenom - Stl = ( (hWght*hR)*S_t(iin,jin+1) + (hWght*hL + hR*hL)*S_t(iin,jin) ) * iDenom - Str = ( (hWght*hL)*S_t(iin,jin) + (hWght*hR + hR*hL)*S_t(iin,jin+1) ) * iDenom - Sbl = ( (hWght*hR)*S_b(iin,jin+1) + (hWght*hL + hR*hL)*S_b(iin,jin) ) * iDenom - Sbr = ( (hWght*hL)*S_b(iin,jin) + (hWght*hR + hR*hL)*S_b(iin,jin+1) ) * iDenom - else - Ttl = T_t(iin,jin); Tbl = T_b(iin,jin); Ttr = T_t(iin,jin+1); Tbr = T_b(iin,jin+1) - Stl = S_t(iin,jin); Sbl = S_b(iin,jin); Str = S_t(iin,jin+1); Sbr = S_b(iin,jin+1) - endif - - do m=2,4 - w_left = 0.25*real(5-m) ; w_right = 1.0-w_left - dz_y(m,i) = w_left*(z_t(iin,jin) - z_b(iin,jin)) + w_right*(z_t(iin,jin+1) - z_b(iin,jin+1)) - - ! Salinity and temperature points are linearly interpolated in - ! the horizontal. The subscript (1) refers to the top value in - ! the vertical profile while subscript (5) refers to the bottom - ! value in the vertical profile. - pos = i*15+(m-2)*5 - T15(pos+1) = w_left*Ttl + w_right*Ttr - T15(pos+5) = w_left*Tbl + w_right*Tbr - - S15(pos+1) = w_left*Stl + w_right*Str - S15(pos+5) = w_left*Sbl + w_right*Sbr - - p15(pos+1) = -GxRho*(w_left*z_t(iin,jin) + w_right*z_t(iin,jin+1)) - - ! Pressure - do n=2,5 ; p15(pos+n) = p15(pos+n-1) + GxRho*0.25*dz_y(m,i) ; enddo - - ! Salinity and temperature (linear interpolation in the vertical) - do n=2,4 - weight_t = 0.25 * real(5-n) - weight_b = 1.0 - weight_t - S15(pos+n) = weight_t * S15(pos+1) + weight_b * S15(pos+5) - T15(pos+n) = weight_t * T15(pos+1) + weight_b * T15(pos+5) - enddo - enddo - enddo - - call calculate_density_array(T15(15*HIO%isc+1:), S15(15*HIO%isc+1:), p15(15*HIO%isc+1:), & - r15(15*HIO%isc+1:), 1, 15*(HIO%iec-HIO%isc+1), EOS, rho_ref) - do i=HIO%isc,HIO%iec ; iin = i+ioff - intz(1) = dpa(i,j) ; intz(5) = dpa(i,j+1) - - ! Use Bode's rule to estimate the pressure anomaly change. - do m = 2,4 - pos = i*15+(m-2)*5 - intz(m) = G_e*dz_y(m,i)*( C1_90*(7.0*(r15(pos+1)+r15(pos+5)) + & - 32.0*(r15(pos+2)+r15(pos+4)) + & - 12.0*r15(pos+3))) - enddo - ! Use Bode's rule to integrate the values. - inty_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & - 12.0*intz(3)) - enddo - enddo ; endif - -end subroutine int_density_dz_generic_plm -! ========================================================================== -! Above is the routine where only the S and T profiles are modified -! The real topography is still used -! ========================================================================== - -!> Find the depth at which the reconstructed pressure matches P_tgt -subroutine find_depth_of_pressure_in_cell(T_t, T_b, S_t, S_b, z_t, z_b, P_t, P_tgt, & - rho_ref, G_e, EOS, P_b, z_out, z_tol) - real, intent(in) :: T_t !< Potential temperatue at the cell top [degC] - real, intent(in) :: T_b !< Potential temperatue at the cell bottom [degC] - real, intent(in) :: S_t !< Salinity at the cell top [ppt] - real, intent(in) :: S_b !< Salinity at the cell bottom [ppt] - real, intent(in) :: z_t !< Absolute height of top of cell [Z ~> m]. (Boussinesq ????) - real, intent(in) :: z_b !< Absolute height of bottom of cell [Z ~> m]. - real, intent(in) :: P_t !< Anomalous pressure of top of cell, relative to g*rho_ref*z_t [Pa] - real, intent(in) :: P_tgt !< Target pressure at height z_out, relative to g*rho_ref*z_out [Pa] - real, intent(in) :: rho_ref !< Reference density with which calculation are anomalous to - real, intent(in) :: G_e !< Gravitational acceleration [m2 Z-1 s-2 ~> m s-2] - type(EOS_type), pointer :: EOS !< Equation of state structure - real, intent(out) :: P_b !< Pressure at the bottom of the cell [Pa] - real, intent(out) :: z_out !< Absolute depth at which anomalous pressure = p_tgt [Z ~> m]. - real, optional, intent(in) :: z_tol !< The tolerance in finding z_out [Z ~> m]. - ! Local variables - real :: top_weight, bottom_weight, rho_anom, w_left, w_right, GxRho, dz, dp, F_guess, F_l, F_r - real :: Pa, Pa_left, Pa_right, Pa_tol ! Pressure anomalies, P = integral of g*(rho-rho_ref) dz - - GxRho = G_e * rho_ref - - ! Anomalous pressure difference across whole cell - dp = frac_dp_at_pos(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, G_e, 1.0, EOS) - - P_b = P_t + dp ! Anomalous pressure at bottom of cell - - if (P_tgt <= P_t ) then - z_out = z_t - return - endif - - if (P_tgt >= P_b) then - z_out = z_b - return - endif - - F_l = 0. - Pa_left = P_t - P_tgt ! Pa_left < 0 - F_r = 1. - Pa_right = P_b - P_tgt ! Pa_right > 0 - Pa_tol = GxRho * 1.e-5 ! 1e-5 has dimensions of m, but should be converted to the units of z. - if (present(z_tol)) Pa_tol = GxRho * z_tol - F_guess = F_l - Pa_left / ( Pa_right -Pa_left ) * ( F_r - F_l ) - Pa = Pa_right - Pa_left ! To get into iterative loop - do while ( abs(Pa) > Pa_tol ) - - z_out = z_t + ( z_b - z_t ) * F_guess - Pa = frac_dp_at_pos(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, G_e, F_guess, EOS) - ( P_tgt - P_t ) - - if (PaPa_right) then - write(0,*) Pa_left,Pa,Pa_right,P_t-P_tgt,P_b-P_tgt - stop 'Blurgh! Too positive' - elseif (Pa>0.) then - Pa_right = Pa - F_r = F_guess - else ! Pa == 0 - return - endif - F_guess = F_l - Pa_left / ( Pa_right -Pa_left ) * ( F_r - F_l ) - - enddo - -end subroutine find_depth_of_pressure_in_cell - -!> Returns change in anomalous pressure change from top to non-dimensional -!! position pos between z_t and z_b -real function frac_dp_at_pos(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, G_e, pos, EOS) - real, intent(in) :: T_t !< Potential temperatue at the cell top [degC] - real, intent(in) :: T_b !< Potential temperatue at the cell bottom [degC] - real, intent(in) :: S_t !< Salinity at the cell top [ppt] - real, intent(in) :: S_b !< Salinity at the cell bottom [ppt] - real, intent(in) :: z_t !< The geometric height at the top of the layer [Z ~> m] - real, intent(in) :: z_b !< The geometric height at the bottom of the layer [Z ~> m] - real, intent(in) :: rho_ref !< A mean density [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 [m s-2] - real, intent(in) :: pos !< The fractional vertical position, 0 to 1 [nondim]. - type(EOS_type), pointer :: EOS !< Equation of state structure - ! Local variables - real, parameter :: C1_90 = 1.0/90.0 ! Rational constants. - real :: dz, top_weight, bottom_weight, rho_ave - real, dimension(5) :: T5, S5, p5, rho5 - integer :: n - - do n=1,5 - ! Evalute density at five quadrature points - bottom_weight = 0.25*real(n-1) * pos - top_weight = 1.0 - bottom_weight - ! Salinity and temperature points are linearly interpolated - S5(n) = top_weight * S_t + bottom_weight * S_b - T5(n) = top_weight * T_t + bottom_weight * T_b - p5(n) = ( top_weight * z_t + bottom_weight * z_b ) * ( G_e * rho_ref ) - enddo - call calculate_density_array(T5, S5, p5, rho5, 1, 5, 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 - - -! ========================================================================== -!> Compute pressure gradient force integrals for the case where T and S -!! are parabolic profiles -subroutine int_density_dz_generic_ppm (T, T_t, T_b, S, S_t, S_b, & - z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, & - EOS, dpa, intz_dpa, intx_dpa, inty_dpa) - - type(hor_index_type), intent(in) :: HII !< Ocean horizontal index structures for the input arrays - type(hor_index_type), intent(in) :: HIO !< Ocean horizontal index structures for the output arrays - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & - intent(in) :: T !< Potential temperature referenced to the surface [degC] - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & - intent(in) :: T_t !< Potential temperatue at the cell top [degC] - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & - intent(in) :: T_b !< Potential temperatue at the cell bottom [degC] - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & - intent(in) :: S !< Salinity [ppt] - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & - intent(in) :: S_t !< Salinity at the cell top [ppt] - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & - intent(in) :: S_b !< Salinity at the cell bottom [ppt] - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & - intent(in) :: z_t !< Height at the top of the layer [Z ~> m]. - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & - intent(in) :: z_b !< Height at the bottom of the layer [Z ~> m]. - real, intent(in) :: rho_ref !< A mean density [kg m-3], that is subtracted out to - !! reduce the magnitude of each of the integrals. - real, intent(in) :: rho_0 !< A density [kg m-3], that is used to calculate the - !! pressure (as p~=-z*rho_0*G_e) used in the equation of state. - real, intent(in) :: G_e !< The Earth's gravitational acceleration [m s-2] - type(EOS_type), pointer :: EOS !< Equation of state structure - real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & - intent(inout) :: dpa !< The change in the pressure anomaly across the layer [Pa]. - real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%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 [Pa Z ~> Pa m]. - real, dimension(HIO%IsdB:HIO%IedB,HIO%jsd:HIO%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 [Pa]. - real, dimension(HIO%isd:HIO%ied,HIO%JsdB:HIO%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 [Pa]. - -! This subroutine calculates (by numerical quadrature) integrals of -! pressure anomalies across layers, which are required for calculating the -! finite-volume form pressure accelerations in a Boussinesq model. The one -! potentially dodgy assumtion here is that rho_0 is used both in the denominator -! of the accelerations, and in the pressure used to calculated density (the -! latter being -z*rho_0*G_e). These two uses could be separated if need be. -! -! It is assumed that the salinity and temperature profiles are linear in the -! vertical. The top and bottom values within each layer are provided and -! a linear interpolation is used to compute intermediate values. - - ! Local variables - real :: T5(5), S5(5), p5(5), r5(5) - real :: rho_anom - real :: w_left, w_right, intz(5) - real, parameter :: C1_90 = 1.0/90.0 ! Rational constants. - real :: GxRho, I_Rho - real :: dz - real :: weight_t, weight_b - real :: s0, s1, s2 ! parabola coefficients for S [ppt] - real :: t0, t1, t2 ! parabola coefficients for T [degC] - real :: xi ! normalized coordinate - real :: T_top, T_mid, T_bot - real :: S_top, S_mid, S_bot - integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, i, j, m, n, ioff, joff - real, dimension(4) :: x, y - real, dimension(9) :: S_node, T_node, p_node, r_node - - - call MOM_error(FATAL, & - "int_density_dz_generic_ppm: the implementation is not done yet, contact developer") - - ioff = HIO%idg_offset - HII%idg_offset - joff = HIO%jdg_offset - HII%jdg_offset - - ! These array bounds work for the indexing convention of the input arrays, but - ! on the computational domain defined for the output arrays. - Isq = HIO%IscB + ioff ; Ieq = HIO%IecB + ioff - Jsq = HIO%JscB + joff ; Jeq = HIO%JecB + joff - is = HIO%isc + ioff ; ie = HIO%iec + ioff - js = HIO%jsc + joff ; je = HIO%jec + joff - - GxRho = G_e * rho_0 - I_Rho = 1.0 / rho_0 - - ! ============================= - ! 1. Compute vertical integrals - ! ============================= - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - dz = z_t(i,j) - z_b(i,j) - - ! Coefficients of the parabola for S - s0 = S_t(i,j) - s1 = 6.0 * S(i,j) - 4.0 * S_t(i,j) - 2.0 * S_b(i,j) - s2 = 3.0 * ( S_t(i,j) + S_b(i,j) - 2.0*S(i,j) ) - - ! Coefficients of the parabola for T - t0 = T_t(i,j) - t1 = 6.0 * T(i,j) - 4.0 * T_t(i,j) - 2.0 * T_b(i,j) - t2 = 3.0 * ( T_t(i,j) + T_b(i,j) - 2.0*T(i,j) ) - - do n=1,5 - p5(n) = -GxRho*(z_t(i,j) - 0.25*real(n-1)*dz) - - ! Parabolic reconstruction for T and S - xi = 0.25 * ( n - 1 ) - S5(n) = s0 + s1 * xi + s2 * xi**2 - T5(n) = t0 + t1 * xi + t2 * xi**2 - enddo - - call calculate_density(T5, S5, p5, r5, 1, 5, EOS) - - ! Use Bode's rule to estimate the pressure anomaly change. - !rho_anom = C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3)) - & - ! rho_ref - - rho_anom = 1000.0 + S(i,j) - rho_ref - dpa(i-ioff,j-joff) = G_e*dz*rho_anom - - ! Use a Bode's-rule-like fifth-order accurate estimate of - ! the double integral of the pressure anomaly. - !r5 = r5 - rho_ref - !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))) ) - - intz_dpa(i-ioff,j-joff) = 0.5 * G_e * dz**2 * ( 1000.0 - rho_ref + s0 + s1/3.0 + & - s2/6.0 ) - enddo ; enddo ! end loops on j and i - - ! ================================================== - ! 2. Compute horizontal integrals in the x direction - ! ================================================== - if (present(intx_dpa)) then ; do j=js,je ; do I=Isq,Ieq - intz(1) = dpa(i-ioff,j-joff) ; intz(5) = dpa(i+1-ioff,j-joff) - do m=2,4 - w_left = 0.25*real(5-m) ; w_right = 1.0-w_left - dz = w_left*(z_t(i,j) - z_b(i,j)) + w_right*(z_t(i+1,j) - z_b(i+1,j)) - - ! Salinity and temperature points are linearly interpolated in - ! the horizontal. The subscript (1) refers to the top value in - ! the vertical profile while subscript (5) refers to the bottom - ! value in the vertical profile. - T_top = w_left*T_t(i,j) + w_right*T_t(i+1,j) - T_mid = w_left*T(i,j) + w_right*T(i+1,j) - T_bot = w_left*T_b(i,j) + w_right*T_b(i+1,j) - - S_top = w_left*S_t(i,j) + w_right*S_t(i+1,j) - S_mid = w_left*S(i,j) + w_right*S(i+1,j) - S_bot = w_left*S_b(i,j) + w_right*S_b(i+1,j) - - p5(1) = -GxRho*(w_left*z_t(i,j) + w_right*z_t(i+1,j)) - - ! Pressure - do n=2,5 - p5(n) = p5(n-1) + GxRho*0.25*dz - enddo - - ! Coefficients of the parabola for S - s0 = S_top - s1 = 6.0 * S_mid - 4.0 * S_top - 2.0 * S_bot - s2 = 3.0 * ( S_top + S_bot - 2.0*S_mid ) - - ! Coefficients of the parabola for T - t0 = T_top - t1 = 6.0 * T_mid - 4.0 * T_top - 2.0 * T_bot - t2 = 3.0 * ( T_top + T_bot - 2.0*T_mid ) - - do n=1,5 - ! Parabolic reconstruction for T and S - xi = 0.25 * ( n - 1 ) - S5(n) = s0 + s1 * xi + s2 * xi**2 - T5(n) = t0 + t1 * xi + t2 * xi**2 - enddo - - call calculate_density(T5, S5, p5, r5, 1, 5, EOS) - - ! Use Bode's rule to estimate the pressure anomaly change. - intz(m) = G_e*dz*( C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + & - 12.0*r5(3)) - rho_ref) - enddo - intx_dpa(i-ioff,j-joff) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & - 12.0*intz(3)) - - ! Use Gauss quadrature rule to compute integral - - ! The following coordinates define the quadrilateral on which the integral - ! is computed - x(1) = 1.0 - x(2) = 0.0 - x(3) = 0.0 - x(4) = 1.0 - y(1) = z_t(i+1,j) - y(2) = z_t(i,j) - y(3) = z_b(i,j) - y(4) = z_b(i+1,j) - - T_node = 0.0 - p_node = 0.0 - - ! Nodal values for S - - ! Parabolic reconstruction on the left - s0 = S_t(i,j) - s1 = 6.0 * S(i,j) - 4.0 * S_t(i,j) - 2.0 * S_b(i,j) - s2 = 3.0 * ( S_t(i,j) + S_b(i,j) - 2.0 * S(i,j) ) - S_node(2) = s0 - S_node(6) = s0 + 0.5 * s1 + 0.25 * s2 - S_node(3) = s0 + s1 + s2 - - ! Parabolic reconstruction on the left - s0 = S_t(i+1,j) - s1 = 6.0 * S(i+1,j) - 4.0 * S_t(i+1,j) - 2.0 * S_b(i+1,j) - s2 = 3.0 * ( S_t(i+1,j) + S_b(i+1,j) - 2.0 * S(i+1,j) ) - S_node(1) = s0 - S_node(8) = s0 + 0.5 * s1 + 0.25 * s2 - S_node(4) = s0 + s1 + s2 - - S_node(5) = 0.5 * ( S_node(2) + S_node(1) ) - S_node(9) = 0.5 * ( S_node(6) + S_node(8) ) - S_node(7) = 0.5 * ( S_node(3) + S_node(4) ) - - call calculate_density( T_node, S_node, p_node, r_node, 1, 9, EOS ) - r_node = r_node - rho_ref - - call compute_integral_quadratic( x, y, r_node, intx_dpa(i-ioff,j-joff) ) - - intx_dpa(i-ioff,j-joff) = intx_dpa(i-ioff,j-joff) * G_e - - enddo ; enddo ; endif - - ! ================================================== - ! 3. Compute horizontal integrals in the y direction - ! ================================================== - if (present(inty_dpa)) then - call MOM_error(WARNING, "int_density_dz_generic_ppm still needs to be written for inty_dpa!") - do J=Jsq,Jeq ; do i=is,ie - - inty_dpa(i-ioff,j-joff) = 0.0 - - enddo ; enddo - endif - -end subroutine int_density_dz_generic_ppm - - - -! ============================================================================= -!> Compute the integral of the quadratic function -subroutine compute_integral_quadratic( x, y, f, integral ) - real, dimension(4), intent(in) :: x !< The x-position of the corners - real, dimension(4), intent(in) :: y !< The y-position of the corners - real, dimension(9), intent(in) :: f !< The function at the quadrature points - real, intent(out) :: integral !< The returned integral - - ! Local variables - integer :: i, k - real, dimension(9) :: weight, xi, eta ! integration points - real :: f_k - real :: dxdxi, dxdeta - real :: dydxi, dydeta - real, dimension(4) :: phiiso, dphiisodxi, dphiisodeta - real, dimension(9) :: phi, dphidxi, dphideta - real :: jacobian_k - real :: t - - ! Quadrature rule (4 points) - !weight(:) = 1.0 - !xi(1) = - sqrt(3.0) / 3.0 - !xi(2) = sqrt(3.0) / 3.0 - !xi(3) = sqrt(3.0) / 3.0 - !xi(4) = - sqrt(3.0) / 3.0 - !eta(1) = - sqrt(3.0) / 3.0 - !eta(2) = - sqrt(3.0) / 3.0 - !eta(3) = sqrt(3.0) / 3.0 - !eta(4) = sqrt(3.0) / 3.0 - - ! Quadrature rule (9 points) - t = sqrt(3.0/5.0) - weight(1) = 25.0/81.0 ; xi(1) = -t ; eta(1) = t - weight(2) = 40.0/81.0 ; xi(2) = .0 ; eta(2) = t - weight(3) = 25.0/81.0 ; xi(3) = t ; eta(3) = t - weight(4) = 40.0/81.0 ; xi(4) = -t ; eta(4) = .0 - weight(5) = 64.0/81.0 ; xi(5) = .0 ; eta(5) = .0 - weight(6) = 40.0/81.0 ; xi(6) = t ; eta(6) = .0 - weight(7) = 25.0/81.0 ; xi(7) = -t ; eta(7) = -t - weight(8) = 40.0/81.0 ; xi(8) = .0 ; eta(8) = -t - weight(9) = 25.0/81.0 ; xi(9) = t ; eta(9) = -t - - integral = 0.0 - - ! Integration loop - do k = 1,9 - - ! Evaluate shape functions and gradients for isomorphism - call evaluate_shape_bilinear( xi(k), eta(k), phiiso, & - dphiisodxi, dphiisodeta ) - - ! Determine gradient of global coordinate at integration point - dxdxi = 0.0 - dxdeta = 0.0 - dydxi = 0.0 - dydeta = 0.0 - - do i = 1,4 - dxdxi = dxdxi + x(i) * dphiisodxi(i) - dxdeta = dxdeta + x(i) * dphiisodeta(i) - dydxi = dydxi + y(i) * dphiisodxi(i) - dydeta = dydeta + y(i) * dphiisodeta(i) - enddo - - ! Evaluate Jacobian at integration point - jacobian_k = dxdxi*dydeta - dydxi*dxdeta - - ! Evaluate shape functions for interpolation - call evaluate_shape_quadratic( xi(k), eta(k), phi, dphidxi, dphideta ) - - ! Evaluate function at integration point - f_k = 0.0 - do i = 1,9 - f_k = f_k + f(i) * phi(i) - enddo - - integral = integral + weight(k) * f_k * jacobian_k - - enddo ! end integration loop - -end subroutine compute_integral_quadratic - - -! ============================================================================= -!> Evaluation of the four bilinear shape fn and their gradients at (xi,eta) -subroutine evaluate_shape_bilinear( xi, eta, phi, dphidxi, dphideta ) - real, intent(in) :: xi !< The x position to evaluate - real, intent(in) :: eta !< The z position to evaluate - real, dimension(4), intent(inout) :: phi !< The weights of the four corners at this point - real, dimension(4), intent(inout) :: dphidxi !< The x-gradient of the weights of the four - !! corners at this point - real, dimension(4), intent(inout) :: dphideta !< The z-gradient of the weights of the four - !! corners at this point - - ! The shape functions within the parent element are defined as shown here: - ! - ! (-1,1) 2 o------------o 1 (1,1) - ! | | - ! | | - ! | | - ! | | - ! (-1,-1) 3 o------------o 4 (1,-1) - ! - - phi(1) = 0.25 * ( 1 + xi ) * ( 1 + eta ) - phi(2) = 0.25 * ( 1 - xi ) * ( 1 + eta ) - phi(3) = 0.25 * ( 1 - xi ) * ( 1 - eta ) - phi(4) = 0.25 * ( 1 + xi ) * ( 1 - eta ) - - dphidxi(1) = 0.25 * ( 1 + eta ) - dphidxi(2) = - 0.25 * ( 1 + eta ) - dphidxi(3) = - 0.25 * ( 1 - eta ) - dphidxi(4) = 0.25 * ( 1 - eta ) - - dphideta(1) = 0.25 * ( 1 + xi ) - dphideta(2) = 0.25 * ( 1 - xi ) - dphideta(3) = - 0.25 * ( 1 - xi ) - dphideta(4) = - 0.25 * ( 1 + xi ) - -end subroutine evaluate_shape_bilinear - - -! ============================================================================= -!> Evaluation of the nine quadratic shape fn weights and their gradients at (xi,eta) -subroutine evaluate_shape_quadratic ( xi, eta, phi, dphidxi, dphideta ) - - ! Arguments - real, intent(in) :: xi !< The x position to evaluate - real, intent(in) :: eta !< The z position to evaluate - real, dimension(9), intent(inout) :: phi !< The weights of the 9 bilinear quadrature points - !! at this point - real, dimension(9), intent(inout) :: dphidxi !< The x-gradient of the weights of the 9 bilinear - !! quadrature points corners at this point - real, dimension(9), intent(inout) :: dphideta !< The z-gradient of the weights of the 9 bilinear - !! quadrature points corners at this point - - ! The quadratic shape functions within the parent element are defined as shown here: - ! - ! 5 (0,1) - ! (-1,1) 2 o------o------o 1 (1,1) - ! | | - ! | 9 (0,0) | - ! (-1,0) 6 o o o 8 (1,0) - ! | | - ! | | - ! (-1,-1) 3 o------o------o 4 (1,-1) - ! 7 (0,-1) - ! - - phi(:) = 0.0 - dphidxi(:) = 0.0 - dphideta(:) = 0.0 - - phi(1) = 0.25 * xi * ( 1 + xi ) * eta * ( 1 + eta ) - phi(2) = - 0.25 * xi * ( 1 - xi ) * eta * ( 1 + eta ) - phi(3) = 0.25 * xi * ( 1 - xi ) * eta * ( 1 - eta ) - phi(4) = - 0.25 * xi * ( 1 + xi ) * eta * ( 1 - eta ) - phi(5) = 0.5 * ( 1 + xi ) * ( 1 - xi ) * eta * ( 1 + eta ) - phi(6) = - 0.5 * xi * ( 1 - xi ) * ( 1 - eta ) * ( 1 + eta ) - phi(7) = - 0.5 * ( 1 - xi ) * ( 1 + xi ) * eta * ( 1 - eta ) - phi(8) = 0.5 * xi * ( 1 + xi ) * ( 1 - eta ) * ( 1 + eta ) - phi(9) = ( 1 - xi ) * ( 1 + xi ) * ( 1 - eta ) * ( 1 + eta ) - - !dphidxi(1) = 0.25 * ( 1 + 2*xi ) * eta * ( 1 + eta ) - !dphidxi(2) = - 0.25 * ( 1 - 2*xi ) * eta * ( 1 + eta ) - !dphidxi(3) = 0.25 * ( 1 - 2*xi ) * eta * ( 1 - eta ) - !dphidxi(4) = - 0.25 * ( 1 + 2*xi ) * eta * ( 1 - eta ) - !dphidxi(5) = - xi * eta * ( 1 + eta ) - !dphidxi(6) = - 0.5 * ( 1 - 2*xi ) * ( 1 - eta ) * ( 1 + eta ) - !dphidxi(7) = xi * eta * ( 1 - eta ) - !dphidxi(8) = 0.5 * ( 1 + 2*xi ) * ( 1 - eta ) * ( 1 + eta ) - !dphidxi(9) = - 2 * xi * ( 1 - eta ) * ( 1 + eta ) - - !dphideta(1) = 0.25 * xi * ( 1 + xi ) * ( 1 + 2*eta ) - !dphideta(2) = - 0.25 * xi * ( 1 - xi ) * ( 1 + 2*eta ) - !dphideta(3) = 0.25 * xi * ( 1 - xi ) * ( 1 - 2*eta ) - !dphideta(4) = - 0.25 * xi * ( 1 + xi ) * ( 1 - 2*eta ) - !dphideta(5) = 0.5 * ( 1 + xi ) * ( 1 - xi ) * ( 1 + 2*eta ) - !dphideta(6) = xi * ( 1 - xi ) * eta - !dphideta(7) = - 0.5 * ( 1 - xi ) * ( 1 + xi ) * ( 1 - 2*eta ) - !dphideta(8) = - xi * ( 1 + xi ) * eta - !dphideta(9) = - 2 * ( 1 - xi ) * ( 1 + xi ) * eta - -end subroutine evaluate_shape_quadratic -! ============================================================================== - -!> This subroutine calculates integrals of specific volume anomalies in -!! pressure across layers, which are required for calculating the finite-volume -!! form pressure accelerations in a non-Boussinesq model. There are essentially -!! no free assumptions, apart from the use of Bode's rule quadrature to do the integrals. -subroutine int_spec_vol_dp_generic(T, S, p_t, p_b, alpha_ref, HI, EOS, & - dza, intp_dza, intx_dza, inty_dza, halo_size, & - bathyP, dP_neglect, useMassWghtInterp) - type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: T !< Potential temperature of the layer [degC]. - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: S !< Salinity of the layer [ppt]. - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: p_t !< Pressure atop the layer [Pa]. - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: p_b !< Pressure below the layer [Pa]. - real, intent(in) :: alpha_ref !< A mean specific volume that is - !! subtracted out to reduce the magnitude of each of the - !! integrals [m3 kg-1]. The calculation is mathematically - !! identical with different values of alpha_ref, but alpha_ref - !! alters the effects of roundoff, and answers do change. - type(EOS_type), pointer :: EOS !< Equation of state structure - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(inout) :: dza !< The change in the geopotential anomaly - !! across the layer [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 [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 [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 [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 [Pa] - real, optional, intent(in) :: dP_neglect !< A miniscule pressure change with - !! the same units as p_t (Pa?) - logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting - !! to interpolate T/S for top and bottom integrals. - -! This subroutine calculates analytical and nearly-analytical integrals in -! pressure across layers of geopotential anomalies, which are required for -! calculating the finite-volume form pressure accelerations in a non-Boussinesq -! model. There are essentially no free assumptions, apart from the use of -! Bode's rule to do the horizontal integrals, and from a truncation in the -! series for log(1-eps/1+eps) that assumes that |eps| < 0.34. - - real :: T5(5), S5(5), p5(5), a5(5) - real :: alpha_anom ! The depth averaged specific density anomaly [m3 kg-1]. - real :: dp ! The pressure change through a layer [Pa]. -! real :: dp_90(2:4) ! The pressure change through a layer divided by 90 [Pa]. - real :: hWght ! A pressure-thickness below topography [Pa]. - real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [Pa]. - real :: iDenom ! The inverse of the denominator in the weights [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 [m2 s-2]. - logical :: do_massWeight ! Indicates whether to do mass weighting. - real, parameter :: C1_90 = 1.0/90.0 ! A rational constant. - integer :: Isq, Ieq, Jsq, Jeq, ish, ieh, jsh, jeh, i, j, m, n, halo - - Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB - halo = 0 ; if (present(halo_size)) halo = MAX(halo_size,0) - ish = HI%isc-halo ; ieh = HI%iec+halo ; jsh = HI%jsc-halo ; jeh = HI%jec+halo - if (present(intx_dza)) then ; ish = MIN(Isq,ish) ; ieh = MAX(Ieq+1,ieh); endif - if (present(inty_dza)) then ; jsh = MIN(Jsq,jsh) ; jeh = MAX(Jeq+1,jeh); endif - - 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, 1, 5, EOS, alpha_ref) - - ! Use Bode's rule to estimate the interface height anomaly change. - alpha_anom = C1_90*(7.0*(a5(1)+a5(5)) + 32.0*(a5(2)+a5(4)) + 12.0*a5(3)) - dza(i,j) = dp*alpha_anom - ! Use a Bode's-rule-like fifth-order accurate estimate of the double integral of - ! the interface height anomaly. - if (present(intp_dza)) intp_dza(i,j) = 0.5*dp**2 * & - (alpha_anom - C1_90*(16.0*(a5(4)-a5(2)) + 7.0*(a5(5)-a5(1))) ) - enddo ; enddo - - if (present(intx_dza)) then ; do j=HI%jsc,HI%jec ; do I=Isq,Ieq - ! hWght is the distance measure by which the cell is violation of - ! hydrostatic consistency. For large hWght we bias the interpolation of - ! T & S along the top and bottom integrals, akin to thickness weighting. - hWght = 0.0 - if (do_massWeight) & - hWght = max(0., bathyP(i,j)-p_t(i+1,j), bathyP(i+1,j)-p_t(i,j)) - if (hWght > 0.) then - hL = (p_b(i,j) - p_t(i,j)) + dP_neglect - hR = (p_b(i+1,j) - p_t(i+1,j)) + dP_neglect - hWght = hWght * ( (hL-hR)/(hL+hR) )**2 - iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) - hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom - hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom - else - hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 - endif - - intp(1) = dza(i,j) ; intp(5) = dza(i+1,j) - do m=2,4 - wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L - wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR - - ! T, S, and p are interpolated in the horizontal. The p interpolation - ! is linear, but for T and S it may be thickness wekghted. - p5(1) = 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, 1, 5, EOS, alpha_ref) - - ! Use Bode's rule to estimate the interface height anomaly change. - intp(m) = dp*( C1_90*(7.0*(a5(1)+a5(5)) + 32.0*(a5(2)+a5(4)) + & - 12.0*a5(3))) - enddo - ! Use Bode's rule to integrate the interface height anomaly values in x. - intx_dza(i,j) = C1_90*(7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4)) + & - 12.0*intp(3)) - enddo ; enddo ; endif - - if (present(inty_dza)) then ; do J=Jsq,Jeq ; do i=HI%isc,HI%iec - ! hWght is the distance measure by which the cell is violation of - ! hydrostatic consistency. For large hWght we bias the interpolation of - ! T & S along the top and bottom integrals, akin to thickness weighting. - hWght = 0.0 - if (do_massWeight) & - hWght = max(0., bathyP(i,j)-p_t(i,j+1), bathyP(i,j+1)-p_t(i,j)) - if (hWght > 0.) then - hL = (p_b(i,j) - p_t(i,j)) + dP_neglect - hR = (p_b(i,j+1) - p_t(i,j+1)) + dP_neglect - hWght = hWght * ( (hL-hR)/(hL+hR) )**2 - iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) - hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom - hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom - else - hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 - endif - - intp(1) = dza(i,j) ; intp(5) = dza(i,j+1) - do m=2,4 - wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L - wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR - - ! T, S, and p are interpolated in the horizontal. The p interpolation - ! is linear, but for T and S it may be thickness wekghted. - p5(1) = 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, 1, 5, EOS, alpha_ref) - - ! Use Bode's rule to estimate the interface height anomaly change. - intp(m) = dp*( C1_90*(7.0*(a5(1)+a5(5)) + 32.0*(a5(2)+a5(4)) + & - 12.0*a5(3))) - enddo - ! Use Bode's rule to integrate the interface height anomaly values in y. - inty_dza(i,j) = C1_90*(7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4)) + & - 12.0*intp(3)) - enddo ; enddo ; endif - -end subroutine int_spec_vol_dp_generic - -!> This subroutine calculates integrals of specific volume anomalies in -!! pressure across layers, which are required for calculating the finite-volume -!! form pressure accelerations in a non-Boussinesq model. There are essentially -!! no free assumptions, apart from the use of Bode's rule quadrature to do the integrals. -subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, & - dP_neglect, bathyP, HI, EOS, dza, & - intp_dza, intx_dza, inty_dza, useMassWghtInterp) - type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: T_t !< Potential temperature at the top of the layer [degC]. - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: T_b !< Potential temperature at the bottom of the layer [degC]. - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: S_t !< Salinity at the top the layer [ppt]. - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: S_b !< Salinity at the bottom the layer [ppt]. - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: p_t !< Pressure atop the layer [Pa]. - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: p_b !< Pressure below the layer [Pa]. - real, intent(in) :: alpha_ref !< A mean specific volume that is - !! subtracted out to reduce the magnitude of each of the - !! integrals [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 !< A miniscule pressure change with - !! the same units as p_t (Pa?) - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: bathyP !< The pressure at the bathymetry [Pa] - type(EOS_type), pointer :: EOS !< Equation of state structure - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(inout) :: dza !< The change in the geopotential anomaly - !! across the layer [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 [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 [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 [m2 s-2]. - logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting - !! to interpolate T/S for top and bottom integrals. - -! This subroutine calculates analytical and nearly-analytical integrals in -! pressure across layers of geopotential anomalies, which are required for -! calculating the finite-volume form pressure accelerations in a non-Boussinesq -! model. There are essentially no free assumptions, apart from the use of -! Bode's rule to do the horizontal integrals, and from a truncation in the -! series for log(1-eps/1+eps) that assumes that |eps| < 0.34. - - real, dimension(5) :: T5, S5, p5, a5 - real, dimension(15) :: T15, S15, p15, a15 - real :: wt_t(5), wt_b(5) - real :: T_top, T_bot, S_top, S_bot, P_top, P_bot - - real :: alpha_anom ! The depth averaged specific density anomaly [m3 kg-1]. - real :: dp ! The pressure change through a layer [Pa]. - real :: dp_90(2:4) ! The pressure change through a layer divided by 90 [Pa]. - real :: hWght ! A pressure-thickness below topography [Pa]. - real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [Pa]. - real :: iDenom ! The inverse of the denominator in the weights [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 [m2 s-2]. - real, parameter :: C1_90 = 1.0/90.0 ! A rational constant. - logical :: do_massWeight ! Indicates whether to do mass weighting. - integer :: Isq, Ieq, Jsq, Jeq, i, j, m, n, pos - - Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB - - do_massWeight = .false. - if (present(useMassWghtInterp)) do_massWeight = useMassWghtInterp - - 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, 1, 5, EOS, alpha_ref) - - ! Use Bode's rule to estimate the interface height anomaly change. - alpha_anom = C1_90*((7.0*(a5(1)+a5(5)) + 32.0*(a5(2)+a5(4))) + 12.0*a5(3)) - dza(i,j) = dp*alpha_anom - ! Use a Bode's-rule-like fifth-order accurate estimate of the double integral of - ! the interface height anomaly. - if (present(intp_dza)) intp_dza(i,j) = 0.5*dp**2 * & - (alpha_anom - C1_90*(16.0*(a5(4)-a5(2)) + 7.0*(a5(5)-a5(1))) ) - enddo ; enddo - - ! ================================================== - ! 2. Compute horizontal integrals in the x direction - ! ================================================== - if (present(intx_dza)) then ; do j=HI%jsc,HI%jec ; do I=Isq,Ieq - ! hWght is the distance measure by which the cell is violation of - ! hydrostatic consistency. For large hWght we bias the interpolation - ! of T,S along the top and bottom integrals, almost like thickness - ! weighting. Note: To work in terrain following coordinates we could - ! offset this distance by the layer thickness to replicate other models. - hWght = 0.0 - if (do_massWeight) & - hWght = max(0., bathyP(i,j)-p_t(i+1,j), bathyP(i+1,j)-p_t(i,j)) - if (hWght > 0.) then - hL = (p_b(i,j) - p_t(i,j)) + dP_neglect - hR = (p_b(i+1,j) - p_t(i+1,j)) + dP_neglect - hWght = hWght * ( (hL-hR)/(hL+hR) )**2 - iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) - hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom - hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom - else - hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 - endif - - do m=2,4 - wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L - wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR - - ! T, S, and p are interpolated in the horizontal. The p interpolation - ! is linear, but for T and S it may be thickness wekghted. - P_top = wt_L*p_t(i,j) + wt_R*p_t(i+1,j) - P_bot = wt_L*p_b(i,j) + wt_R*p_b(i+1,j) - T_top = wtT_L*T_t(i,j) + wtT_R*T_t(i+1,j) - T_bot = wtT_L*T_b(i,j) + wtT_R*T_b(i+1,j) - S_top = wtT_L*S_t(i,j) + wtT_R*S_t(i+1,j) - S_bot = wtT_L*S_b(i,j) + wtT_R*S_b(i+1,j) - dp_90(m) = C1_90*(P_bot - P_top) - - ! Salinity, temperature and pressure with linear interpolation in the vertical. - pos = (m-2)*5 - do n=1,5 - p15(pos+n) = 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, 1, 15, EOS, alpha_ref) - - intp(1) = dza(i,j) ; intp(5) = dza(i+1,j) - do m=2,4 - ! Use Bode's rule to estimate the interface height anomaly change. - ! The integrals at the ends of the segment are already known. - pos = (m-2)*5 - intp(m) = dp_90(m)*((7.0*(a15(pos+1)+a15(pos+5)) + & - 32.0*(a15(pos+2)+a15(pos+4))) + 12.0*a15(pos+3)) - enddo - ! Use Bode's rule to integrate the interface height anomaly values in x. - intx_dza(I,j) = C1_90*((7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4))) + & - 12.0*intp(3)) - enddo ; enddo ; endif - - ! ================================================== - ! 3. Compute horizontal integrals in the y direction - ! ================================================== - if (present(inty_dza)) then ; do J=Jsq,Jeq ; do i=HI%isc,HI%iec - ! hWght is the distance measure by which the cell is violation of - ! hydrostatic consistency. For large hWght we bias the interpolation - ! of T,S along the top and bottom integrals, like thickness weighting. - hWght = 0.0 - if (do_massWeight) & - hWght = max(0., bathyP(i,j)-p_t(i,j+1), bathyP(i,j+1)-p_t(i,j)) - if (hWght > 0.) then - hL = (p_b(i,j) - p_t(i,j)) + dP_neglect - hR = (p_b(i,j+1) - p_t(i,j+1)) + dP_neglect - hWght = hWght * ( (hL-hR)/(hL+hR) )**2 - iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) - hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom - hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom - else - hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 - endif - - do m=2,4 - wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L - wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR - - ! T, S, and p are interpolated in the horizontal. The p interpolation - ! is linear, but for T and S it may be thickness wekghted. - P_top = wt_L*p_t(i,j) + wt_R*p_t(i,j+1) - P_bot = wt_L*p_b(i,j) + wt_R*p_b(i,j+1) - T_top = wtT_L*T_t(i,j) + wtT_R*T_t(i,j+1) - T_bot = wtT_L*T_b(i,j) + wtT_R*T_b(i,j+1) - S_top = wtT_L*S_t(i,j) + wtT_R*S_t(i,j+1) - S_bot = wtT_L*S_b(i,j) + wtT_R*S_b(i,j+1) - dp_90(m) = C1_90*(P_bot - P_top) - - ! Salinity, temperature and pressure with linear interpolation in the vertical. - pos = (m-2)*5 - do n=1,5 - p15(pos+n) = 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, 1, 15, EOS, alpha_ref) - - intp(1) = dza(i,j) ; intp(5) = dza(i,j+1) - do m=2,4 - ! Use Bode's rule to estimate the interface height anomaly change. - ! The integrals at the ends of the segment are already known. - pos = (m-2)*5 - intp(m) = dp_90(m) * ((7.0*(a15(pos+1)+a15(pos+5)) + & - 32.0*(a15(pos+2)+a15(pos+4))) + 12.0*a15(pos+3)) - enddo - ! Use Bode's rule to integrate the interface height anomaly values in x. - inty_dza(i,J) = C1_90*((7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4))) + & - 12.0*intp(3)) - enddo ; enddo ; endif - -end subroutine int_spec_vol_dp_generic_plm !> Convert T&S to Absolute Salinity and Conservative Temperature if using TEOS10 -subroutine convert_temp_salt_for_TEOS10(T, S, press, G, kd, mask_z, EOS) - use MOM_grid, only : ocean_grid_type - - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), & +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 [degC] - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), & + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed,kd), & intent(inout) :: S !< Salinity [ppt] - real, dimension(:), intent(in) :: press !< Pressure at the top of the layer [Pa]. - type(EOS_type), pointer :: EOS !< Equation of state structure - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), & + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed,kd), & intent(in) :: mask_z !< 3d mask regulating which points to convert. - integer, intent(in) :: kd !< The number of layers to work on + type(EOS_type), pointer :: EOS !< Equation of state structure - integer :: i,j,k + integer :: i, j, k real :: gsw_sr_from_sp, gsw_ct_from_pt, gsw_sa_from_sp real :: p @@ -2456,16 +1548,26 @@ subroutine convert_temp_salt_for_TEOS10(T, S, press, G, kd, mask_z, EOS) if ((EOS%form_of_EOS /= EOS_TEOS10) .and. (EOS%form_of_EOS /= EOS_NEMO)) return - do k=1,kd ; do j=G%jsc,G%jec ; do i=G%isc,G%iec + 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) = gsw_sr_from_sp(S(i,j,k)) -! p=press(k)/10000. !convert pascal to dbar -! S(i,j,k) = gsw_sa_from_sp(S(i,j,k),p,G%geoLonT(i,j),G%geoLatT(i,j)) - T(i,j,k) = gsw_ct_from_pt(S(i,j,k),T(i,j,k)) +! Get absolute salnity from practical salinity, converting pressures from Pascal to dbar. +! If this option is activated, pressure will need to be added as an argument, and it should be +! moved out into module that is not shared between components, where the ocean_grid can be used. +! S(i,j,k) = gsw_sa_from_sp(S(i,j,k),pres(i,j,k)*1.0e-4,G%geoLonT(i,j),G%geoLatT(i,j)) + T(i,j,k) = gsw_ct_from_pt(S(i,j,k), T(i,j,k)) endif enddo ; enddo ; enddo end subroutine convert_temp_salt_for_TEOS10 +!> Return value of EOS_quadrature +logical function EOS_quadrature(EOS) + type(EOS_type), pointer :: EOS !< Equation of state structure + + EOS_quadrature = EOS%EOS_quadrature + +end function EOS_quadrature + !> Extractor routine for the EOS type if the members need to be accessed outside this module subroutine extract_member_EOS(EOS, form_of_EOS, form_of_TFreeze, EOS_quadrature, Compressible, & Rho_T0_S0, drho_dT, dRho_dS, TFr_S0_P0, dTFr_dS, dTFr_dp) @@ -2481,11 +1583,11 @@ subroutine extract_member_EOS(EOS, form_of_EOS, form_of_TFreeze, EOS_quadrature, !! in [kg m-3 degC-1] real , optional, intent(out) :: dRho_dS !< Partial derivative of density with salinity !! in [kg m-3 ppt-1] - real , optional, intent(out) :: TFr_S0_P0 !< The freezing potential temperature at S=0, P=0 [degC]. + real , optional, intent(out) :: TFr_S0_P0 !< The freezing potential temperature at S=0, P=0 [degC] real , optional, intent(out) :: dTFr_dS !< The derivative of freezing point with salinity - !! [degC PSU-1]. + !! [degC PSU-1] real , optional, intent(out) :: dTFr_dp !< The derivative of freezing point with pressure - !! [degC Pa-1]. + !! [degC Pa-1] if (present(form_of_EOS )) form_of_EOS = EOS%form_of_EOS if (present(form_of_TFreeze)) form_of_TFreeze = EOS%form_of_TFreeze diff --git a/src/equation_of_state/MOM_EOS_Wright.F90 b/src/equation_of_state/MOM_EOS_Wright.F90 index bc490ca361..57bde3938d 100644 --- a/src/equation_of_state/MOM_EOS_Wright.F90 +++ b/src/equation_of_state/MOM_EOS_Wright.F90 @@ -406,54 +406,61 @@ end subroutine calculate_compress_wright !> 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_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, & +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) - type(hor_index_type), intent(in) :: HII !< The horizontal index type for the input arrays. - type(hor_index_type), intent(in) :: HIO !< The horizontal index type for the output arrays. - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + bathyT, dz_neglect, useMassWghtInterp, rho_scale, pres_scale) + 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 !! [degC]. - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: S !< Salinity [PSU]. - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + 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(HII%isd:HII%ied,HII%jsd:HII%jed), & + 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 [kg m-3], that is subtracted out - !! to reduce the magnitude of each of the integrals. + real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3] or [kg m-3], that is subtracted + !! out to reduce the magnitude of each of the integrals. !! (The pressure is calucated as p~=-z*rho_0*G_e.) - real, intent(in) :: rho_0 !< Density [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 [m2 Z-1 s-2 ~> m s-2]. - real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & + real, intent(in) :: rho_0 !< Density [R ~> kg m-3] or [kg m-3], that is used + !! to calculate the pressure (as p~=-z*rho_0*G_e) + !! used in the equation of state. + real, intent(in) :: G_e !< The Earth's gravitational acceleration + !! [L2 Z-1 T-2 ~> m s-2] or [m2 Z-1 s-2 ~> m s-2]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(inout) :: dpa !< The change in the pressure anomaly across the - !! layer [Pa]. - real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & + !! layer [R L2 T-2 ~> Pa] or [Pa]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & optional, intent(inout) :: intz_dpa !< The integral through the thickness of the layer !! of the pressure anomaly relative to the anomaly - !! at the top of the layer [Pa Z ~> Pa m]. - real, dimension(HIO%IsdB:HIO%IedB,HIO%jsd:HIO%jed), & + !! 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 [Pa]. - real, dimension(HIO%isd:HIO%ied,HIO%JsdB:HIO%JedB), & + !! 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 [Pa]. - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + !! 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]. ! Local variables - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed) :: al0_2d, p0_2d, lambda_2d + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: al0_2d, p0_2d, lambda_2d real :: al0, p0, lambda real :: rho_anom ! The density anomaly from rho_ref [kg m-3]. real :: eps, eps2, rem - real :: GxRho, I_Rho + 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, never rescaled from kg m-3 [kg m-3] real :: p_ave, I_al0, I_Lzz real :: dz ! The layer thickness [Z ~> m]. real :: hWght ! A pressure-thickness below topography [Z ~> m]. @@ -464,24 +471,34 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, 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 [Pa]. + ! 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] or [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. real, parameter :: C1_9 = 1.0/9.0, C1_90 = 1.0/90.0 ! Rational constants. - integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, i, j, ioff, joff, m - - ioff = HIO%idg_offset - HII%idg_offset - joff = HIO%jdg_offset - HII%jdg_offset + 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 = HIO%IscB + ioff ; Ieq = HIO%IecB + ioff - Jsq = HIO%JscB + joff ; Jeq = HIO%JecB + joff - is = HIO%isc + ioff ; ie = HIO%iec + ioff - js = HIO%jsc + joff ; je = HIO%jec + joff - - GxRho = G_e * rho_0 - I_Rho = 1.0 / rho_0 + 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 do_massWeight = .false. if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then @@ -508,12 +525,12 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, ! rho(j) = (pressure(j) + p0) / (lambda + al0*(pressure(j) + p0)) - rho_anom = (p0 + p_ave)*(I_Lzz*I_al0) - rho_ref + 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-ioff,j-joff) = G_e*rho_anom*dz - 2.0*eps*rem + dpa(i,j) = Pa_to_RL2_T2 * (g_Earth*rho_anom*dz - 2.0*eps*rem) if (present(intz_dpa)) & - intz_dpa(i-ioff,j-joff) = 0.5*G_e*rho_anom*dz**2 - dz*(1.0+eps)*rem + 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 @@ -534,7 +551,7 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 endif - intz(1) = dpa(i-ioff,j-joff) ; intz(5) = dpa(i+1-ioff,j-joff) + 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 @@ -551,13 +568,11 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, I_Lzz = 1.0 / (p0 + (lambda * I_al0) + p_ave) eps = 0.5*GxRho*dz*I_Lzz ; eps2 = eps*eps - intz(m) = G_e*dz*((p0 + p_ave)*(I_Lzz*I_al0) - rho_ref) - 2.0*eps * & - I_Rho * (lambda * I_al0**2) * eps2 * & - (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2))) + 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 Bode's rule to integrate the values. - intx_dpa(i-ioff,j-joff) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & - 12.0*intz(3)) + 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 @@ -578,7 +593,7 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 endif - intz(1) = dpa(i-ioff,j-joff) ; intz(5) = dpa(i-ioff,j+1-joff) + 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 @@ -595,14 +610,13 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, I_Lzz = 1.0 / (p0 + (lambda * I_al0) + p_ave) eps = 0.5*GxRho*dz*I_Lzz ; eps2 = eps*eps - intz(m) = G_e*dz*((p0 + p_ave)*(I_Lzz*I_al0) - rho_ref) - 2.0*eps * & - I_Rho * (lambda * I_al0**2) * eps2 * & - (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2))) + 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 Bode's rule to integrate the values. - inty_dpa(i-ioff,j-joff) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & - 12.0*intz(3)) + 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 !> This subroutine calculates analytical and nearly-analytical integrals in @@ -613,7 +627,7 @@ end subroutine int_density_dz_wright !! 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) + bathyP, dP_neglect, useMassWghtInterp, SV_scale, pres_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 @@ -621,53 +635,66 @@ subroutine int_spec_vol_dp_wright(T, S, p_t, p_b, spv_ref, HI, dza, & real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: S !< Salinity [PSU]. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: p_t !< Pressure at the top of the layer [Pa]. + intent(in) :: p_t !< Pressure at the top of the layer [R L2 T-2 ~> Pa] or [Pa]. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: p_b !< Pressure at the top of the layer [Pa]. + intent(in) :: p_b !< Pressure at the top of the layer [R L2 T-2 ~> Pa] or [Pa]. real, intent(in) :: spv_ref !< A mean specific volume that is subtracted out - !! to reduce the magnitude of each of the integrals [m3 kg-1]. The calculation is - !! mathematically identical with different values of spv_ref, but this reduces the - !! effects of roundoff. + !! 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 [m2 s-2]. + !! the layer [T-2 ~> m2 s-2] or [m2 s-2]. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & optional, intent(inout) :: intp_dza !< The integral in pressure through the layer of !! the geopotential anomaly relative to the anomaly - !! at the bottom of the layer [Pa m2 s-2]. + !! at the bottom of the layer [R L4 T-4 ~> Pa m2 s-2] + !! or [Pa m2 s-2]. real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & optional, intent(inout) :: intx_dza !< The integral in x of the difference between the !! geopotential anomaly at the top and bottom of - !! the layer divided by the x grid spacing [m2 s-2]. + !! the layer divided by the x grid spacing + !! [L2 T-2 ~> m2 s-2] or [m2 s-2]. real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & optional, intent(inout) :: inty_dza !< The integral in y of the difference between the !! geopotential anomaly at the top and bottom of - !! the layer divided by the y grid spacing [m2 s-2]. + !! the layer divided by the y grid spacing + !! [L2 T-2 ~> m2 s-2] or [m2 s-2]. integer, optional, intent(in) :: halo_size !< The width of halo points on which to calculate !! dza. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - optional, intent(in) :: bathyP !< The pressure at the bathymetry [Pa] + optional, intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] or [Pa] real, optional, intent(in) :: dP_neglect !< A miniscule pressure change with - !! the same units as p_t [Pa] + !! the same units as p_t [R L2 T-2 ~> Pa] or [Pa] logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting !! to interpolate T/S for top and bottom integrals. + 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]. ! Local variables real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: al0_2d, p0_2d, lambda_2d - real :: al0, p0, lambda - real :: p_ave - real :: rem, eps, eps2 - real :: alpha_anom ! The depth averaged specific volume anomaly [m3 kg-1]. - real :: dp ! The pressure change through a layer [Pa]. - real :: hWght ! A pressure-thickness below topography [Pa]. - real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [Pa]. - real :: iDenom ! The inverse of the denominator in the weights [Pa-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 [m2 s-2]. + ! 5 sub-column locations [L2 T-2 ~> m2 s-2]. 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. real, parameter :: C1_9 = 1.0/9.0, C1_90 = 1.0/90.0 ! Rational constants. @@ -679,6 +706,14 @@ subroutine int_spec_vol_dp_wright(T, S, p_t, p_b, spv_ref, HI, dza, & 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 + do_massWeight = .false. if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then do_massWeight = .true. @@ -688,10 +723,11 @@ subroutine int_spec_vol_dp_wright(T, S, p_t, p_b, spv_ref, HI, dza, & ! "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) = (a0 + a1*T(i,j)) + a2*S(i,j) - p0_2d(i,j) = (b0 + b4*S(i,j)) + T(i,j) * (b1 + T(i,j)*((b2 + b3*T(i,j))) + b5*S(i,j)) - lambda_2d(i,j) = (c0 +c4*S(i,j)) + T(i,j) * (c1 + T(i,j)*((c2 + c3*T(i,j))) + c5*S(i,j)) + al0_2d(i,j) = al0_scale * ( (a0 + a1*T(i,j)) + a2*S(i,j) ) + p0_2d(i,j) = p0_scale * ( (b0 + b4*S(i,j)) + T(i,j) * (b1 + T(i,j)*((b2 + b3*T(i,j))) + b5*S(i,j)) ) + lambda_2d(i,j) = lam_scale * ( (c0 + c4*S(i,j)) + T(i,j) * (c1 + T(i,j)*((c2 + c3*T(i,j))) + c5*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) diff --git a/src/equation_of_state/MOM_EOS_linear.F90 b/src/equation_of_state/MOM_EOS_linear.F90 index 55b3835681..47a2bf21b0 100644 --- a/src/equation_of_state/MOM_EOS_linear.F90 +++ b/src/equation_of_state/MOM_EOS_linear.F90 @@ -325,56 +325,56 @@ end subroutine calculate_compress_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, HII, HIO, & +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) :: HII !< The horizontal index type for the input arrays. - type(hor_index_type), intent(in) :: HIO !< The horizontal index type for the output arrays. - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + 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 !! [degC]. - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: S !< Salinity [PSU]. - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + 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(HII%isd:HII%ied,HII%jsd:HII%jed), & + 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 [kg m-3], that is subtracted - !! out to reduce the magnitude of each of the - !! integrals. - real, intent(in) :: rho_0_pres !< A density [kg m-3], that is used to calculate + real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3] or [kg m-3], that + !! is subtracted out to reduce the magnitude of + !! each of the integrals. + real, intent(in) :: rho_0_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 - !! here. - real, intent(in) :: G_e !< The Earth's gravitational acceleration [m2 Z-1 s-2 ~> m s-2]. - real, intent(in) :: Rho_T0_S0 !< The density at T=0, S=0 [kg m-3]. + !! 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] or [m2 Z-1 s-2 ~> m s-2]. + real, intent(in) :: Rho_T0_S0 !< The density at T=0, S=0 [R ~> kg m-3] or [kg m-3]. real, intent(in) :: dRho_dT !< The derivative of density with temperature, - !! [kg m-3 degC-1]. + !! [R degC-1 ~> kg m-3 degC-1] or [kg m-3 degC-1]. real, intent(in) :: dRho_dS !< The derivative of density with salinity, - !! in [kg m-3 ppt-1]. - real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & + !! in [R ppt-1 ~> kg m-3 ppt-1] or [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 [Pa]. - real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & + !! layer [R L2 T-2 ~> Pa] or [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 [Pa Z]. - real, dimension(HIO%IsdB:HIO%IedB,HIO%jsd:HIO%jed), & + !! at the top of the layer [R L2 Z T-2 ~> Pa Z] or [Pa Z]. + 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 [Pa]. - real, dimension(HIO%isd:HIO%ied,HIO%JsdB:HIO%JedB), & + !! layer divided by the x grid spacing [R L2 T-2 ~> Pa] or [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 [Pa]. - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + !! layer divided by the y grid spacing [R L2 T-2 ~> Pa] or [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 [kg m-3]. - real :: raL, raR ! rho_anom to the left and right [kg m-3]. + 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]. @@ -384,20 +384,17 @@ subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HII, 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 [Pa]. + ! 5 sub-column locations [R L2 T-2 ~> Pa] or [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. - integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, i, j, ioff, joff, m - - ioff = HIO%idg_offset - HII%idg_offset - joff = HIO%jdg_offset - HII%jdg_offset + 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 = HIO%IscB + ioff ; Ieq = HIO%IecB + ioff - Jsq = HIO%JscB + joff ; Jeq = HIO%JecB + joff - is = HIO%isc + ioff ; ie = HIO%iec + ioff - js = HIO%jsc + joff ; je = HIO%jec + joff + 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 @@ -411,8 +408,8 @@ subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HII, 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-ioff,j-joff) = G_e*rho_anom*dz - if (present(intz_dpa)) intz_dpa(i-ioff,j-joff) = 0.5*G_e*rho_anom*dz**2 + 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 @@ -428,7 +425,7 @@ subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HII, 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-ioff,j-joff) = G_e*C1_6 * (dzL*(2.0*raL + raR) + dzR*(2.0*raR + raL)) + 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 @@ -437,7 +434,7 @@ subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HII, 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-ioff,j-joff) ; intz(5) = dpa(i+1-ioff,j-joff) + 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 @@ -449,7 +446,7 @@ subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HII, intz(m) = G_e*rho_anom*dz enddo ! Use Bode's rule to integrate the values. - intx_dpa(i-ioff,j-joff) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & + 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 @@ -467,7 +464,7 @@ subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HII, 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-ioff,j-joff) = G_e*C1_6 * (dzL*(2.0*raL + raR) + dzR*(2.0*raR + raL)) + 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 @@ -476,7 +473,7 @@ subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HII, 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-ioff,j-joff) ; intz(5) = dpa(i+1-ioff,j-joff) + 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 @@ -488,7 +485,7 @@ subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HII, intz(m) = G_e*rho_anom*dz enddo ! Use Bode's rule to integrate the values. - inty_dpa(i-ioff,j-joff) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & + inty_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & 12.0*intz(3)) endif @@ -509,56 +506,56 @@ subroutine int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, Rho_T0_S0, & real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: S !< Salinity [PSU]. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: p_t !< Pressure at the top of the layer [Pa]. + intent(in) :: p_t !< Pressure at the top of the layer [R L2 T-2 ~> Pa] or [Pa]. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: p_b !< Pressure at the top of the layer [Pa]. - real, intent(in) :: alpha_ref !< A mean specific volume that is subtracted out - !! to reduce the magnitude of each of the integrals, 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 [kg m-3]. + intent(in) :: p_b !< Pressure at the top of the layer [R L2 T-2 ~> Pa] or [Pa]. + real, intent(in) :: alpha_ref !< A mean specific volume that is subtracted out + !! to reduce the magnitude of each of the integrals [R-1 ~> m3 kg-1]. + !! The calculation is mathematically identical with different values of + !! alpha_ref, but this reduces the effects of roundoff. + real, intent(in) :: Rho_T0_S0 !< The density at T=0, S=0 [R ~> kg m-3] or [kg m-3]. real, intent(in) :: dRho_dT !< The derivative of density with temperature - !! [kg m-3 degC-1]. + !! [R degC-1 ~> kg m-3 degC-1] or [kg m-3 degC-1]. real, intent(in) :: dRho_dS !< The derivative of density with salinity, - !! in [kg m-3 ppt-1]. + !! in [R ppt-1 ~> kg m-3 ppt-1] or [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 [m2 s-2]. + !! the layer [L2 T-2 ~> m2 s-2] or [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 [Pa m2 s-2]. + 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] or [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 - !! [m2 s-2]. + !! [L2 T-2 ~> m2 s-2] or [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 - !! [m2 s-2]. + !! [L2 T-2 ~> m2 s-2] or [m2 s-2]. integer, optional, intent(in) :: halo_size !< The width of halo points on which to calculate dza. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - optional, intent(in) :: bathyP !< The pressure at the bathymetry [Pa] + optional, intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] or [Pa] real, optional, intent(in) :: dP_neglect !< A miniscule pressure change with - !! the same units as p_t [Pa] + !! the same units as p_t [R L2 T-2 ~> Pa] or [Pa] logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting !! to interpolate T/S for top and bottom integrals. ! Local variables - real :: dRho_TS ! The density anomaly due to T and S [kg m-3]. - real :: alpha_anom ! The specific volume anomaly from 1/rho_ref [m3 kg-1]. - real :: aaL, aaR ! rho_anom to the left and right [kg m-3]. - real :: dp, dpL, dpR ! Layer pressure thicknesses [Pa]. - real :: hWght ! A pressure-thickness below topography [Pa]. - real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [Pa]. - real :: iDenom ! The inverse of the denominator in the weights [Pa-2]. + real :: dRho_TS ! The density anomaly due to T and S [R ~> kg m-3] or [kg m-3]. + real :: alpha_anom ! The specific volume anomaly from 1/rho_ref [R-1 ~> m3 kg-1] or [m3 kg-1]. + real :: aaL, aaR ! The specific volume anomaly to the left and right [R-1 ~> m3 kg-1] or [m3 kg-1]. + real :: dp, dpL, dpR ! Layer pressure thicknesses [R L2 T-2 ~> Pa] or [Pa]. + real :: hWght ! A pressure-thickness below topography [R L2 T-2 ~> Pa] or [Pa]. + real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [R L2 T-2 ~> Pa] or [Pa]. + real :: iDenom ! The inverse of the denominator in the weights [T4 R-2 L-2 ~> Pa-2] or [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 [m2 s-2]. + ! 5 sub-column locations [L2 T-2 ~> m2 s-2] or [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. integer :: Isq, Ieq, Jsq, Jeq, ish, ieh, jsh, jeh, i, j, m, halo diff --git a/src/equation_of_state/TEOS10/gsw_chem_potential_water_t_exact.f90 b/src/equation_of_state/TEOS10/gsw_chem_potential_water_t_exact.f90 deleted file mode 100644 index ca1ac55956..0000000000 --- a/src/equation_of_state/TEOS10/gsw_chem_potential_water_t_exact.f90 +++ /dev/null @@ -1,82 +0,0 @@ -!========================================================================== -elemental function gsw_chem_potential_water_t_exact (sa, t, p) -!========================================================================== -! -! Calculates the chemical potential of water in seawater. -! -! SA = Absolute Salinity [ g/kg ] -! t = in-situ temperature (ITS-90) [ deg C ] -! p = sea pressure [ dbar ] -! ( i.e. absolute pressure - 10.1325 dbar ) -! -! chem_potential_water_t_exact = chemical potential of water in seawater -! [ J/g ] -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_sfac - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, t, p - -real (r8) :: gsw_chem_potential_water_t_exact - -real (r8) :: g03_g, g08_g, g_sa_part, x, x2, y, z - -real (r8), parameter :: kg2g = 1e-3_r8 - -x2 = gsw_sfac*sa -x = sqrt(x2) -y = t*0.025_r8 -z = p*1e-4_r8 - -g03_g = 101.342743139674_r8 + z*(100015.695367145_r8 + & - z*(-2544.5765420363_r8 + z*(284.517778446287_r8 + & - z*(-33.3146754253611_r8 + (4.20263108803084_r8 - 0.546428511471039_r8*z)*z)))) + & - y*(5.90578347909402_r8 + z*(-270.983805184062_r8 + & - z*(776.153611613101_r8 + z*(-196.51255088122_r8 + (28.9796526294175_r8 - 2.13290083518327_r8*z)*z))) + & - y*(-12357.785933039_r8 + z*(1455.0364540468_r8 + & - z*(-756.558385769359_r8 + z*(273.479662323528_r8 + z*(-55.5604063817218_r8 + 4.34420671917197_r8*z)))) + & - y*(736.741204151612_r8 + z*(-672.50778314507_r8 + & - z*(499.360390819152_r8 + z*(-239.545330654412_r8 + (48.8012518593872_r8 - 1.66307106208905_r8*z)*z))) + & - y*(-148.185936433658_r8 + z*(397.968445406972_r8 + & - z*(-301.815380621876_r8 + (152.196371733841_r8 - 26.3748377232802_r8*z)*z)) + & - y*(58.0259125842571_r8 + z*(-194.618310617595_r8 + & - z*(120.520654902025_r8 + z*(-55.2723052340152_r8 + 6.48190668077221_r8*z))) + & - y*(-18.9843846514172_r8 + y*(3.05081646487967_r8 - 9.63108119393062_r8*z) + & - z*(63.5113936641785_r8 + z*(-22.2897317140459_r8 + 8.17060541818112_r8*z)))))))) - -g08_g = x2*(1416.27648484197_r8 + & - x*(-2432.14662381794_r8 + x*(2025.80115603697_r8 + & - y*(543.835333000098_r8 + y*(-68.5572509204491_r8 + & - y*(49.3667694856254_r8 + y*(-17.1397577419788_r8 + 2.49697009569508_r8*y))) - 22.6683558512829_r8*z) + & - x*(-1091.66841042967_r8 - 196.028306689776_r8*y + & - x*(374.60123787784_r8 - 48.5891069025409_r8*x + 36.7571622995805_r8*y) + 36.0284195611086_r8*z) + & - z*(-54.7919133532887_r8 + (-4.08193978912261_r8 - 30.1755111971161_r8*z)*z)) + & - z*(199.459603073901_r8 + z*(-52.2940909281335_r8 + (68.0444942726459_r8 - 3.41251932441282_r8*z)*z)) + & - y*(-493.407510141682_r8 + z*(-175.292041186547_r8 + (83.1923927801819_r8 - 29.483064349429_r8*z)*z) + & - y*(-43.0664675978042_r8 + z*(383.058066002476_r8 + z*(-54.1917262517112_r8 + 25.6398487389914_r8*z)) + & - y*(-10.0227370861875_r8 - 460.319931801257_r8*z + y*(0.875600661808945_r8 + 234.565187611355_r8*z))))) + & - y*(168.072408311545_r8)) - -g_sa_part = 8645.36753595126_r8 + & - x*(-7296.43987145382_r8 + x*(8103.20462414788_r8 + & - y*(2175.341332000392_r8 + y*(-274.2290036817964_r8 + & - y*(197.4670779425016_r8 + y*(-68.5590309679152_r8 + 9.98788038278032_r8*y))) - 90.6734234051316_r8*z) + & - x*(-5458.34205214835_r8 - 980.14153344888_r8*y + & - x*(2247.60742726704_r8 - 340.1237483177863_r8*x + 220.542973797483_r8*y) + 180.142097805543_r8*z) + & - z*(-219.1676534131548_r8 + (-16.32775915649044_r8 - 120.7020447884644_r8*z)*z)) + & - z*(598.378809221703_r8 + z*(-156.8822727844005_r8 + (204.1334828179377_r8 - 10.23755797323846_r8*z)*z)) + & - y*(-1480.222530425046_r8 + z*(-525.876123559641_r8 + (249.57717834054571_r8 - 88.449193048287_r8*z)*z) + & - y*(-129.1994027934126_r8 + z*(1149.174198007428_r8 + z*(-162.5751787551336_r8 + 76.9195462169742_r8*z)) + & - y*(-30.0682112585625_r8 - 1380.9597954037708_r8*z + y*(2.626801985426835_r8 + 703.695562834065_r8*z))))) + & - y*(1187.3715515697959_r8) - -gsw_chem_potential_water_t_exact = kg2g*(g03_g + g08_g - 0.5_r8*x2*g_sa_part) - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_chem_potential_water_t_exact.f90 b/src/equation_of_state/TEOS10/gsw_chem_potential_water_t_exact.f90 new file mode 120000 index 0000000000..7ce7ff9e1e --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_chem_potential_water_t_exact.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_chem_potential_water_t_exact.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_ct_freezing_exact.f90 b/src/equation_of_state/TEOS10/gsw_ct_freezing_exact.f90 deleted file mode 100644 index 1627322dcd..0000000000 --- a/src/equation_of_state/TEOS10/gsw_ct_freezing_exact.f90 +++ /dev/null @@ -1,43 +0,0 @@ -!========================================================================== -elemental function gsw_ct_freezing_exact (sa, p, saturation_fraction) -!========================================================================== -! -! Calculates the Conservative Temperature at which seawater freezes. The -! Conservative Temperature freezing point is calculated from the exact -! in-situ freezing temperature which is found by a modified Newton-Raphson -! iteration (McDougall and Wotherspoon, 2013) of the equality of the -! chemical potentials of water in seawater and in ice. -! -! An alternative GSW function, gsw_CT_freezing_poly, it is based on a -! computationally-efficient polynomial, and is accurate to within -5e-4 K -! and 6e-4 K, when compared with this function. -! -! SA = Absolute Salinity [ g/kg ] -! p = sea pressure [ dbar ] -! ( i.e. absolute pressure - 10.1325 dbar ) -! saturation_fraction = the saturation fraction of dissolved air in -! seawater -! -! CT_freezing = Conservative Temperature at freezing of seawater [ deg C ] -!-------------------------------------------------------------------------- - -use gsw_mod_toolbox, only : gsw_t_freezing_exact -use gsw_mod_toolbox, only : gsw_ct_from_t - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, p, saturation_fraction - -real (r8) :: gsw_ct_freezing_exact - -real (r8) :: t_freezing - -t_freezing = gsw_t_freezing_exact(sa,p,saturation_fraction) -gsw_ct_freezing_exact = gsw_ct_from_t(sa,t_freezing,p) - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_ct_freezing_exact.f90 b/src/equation_of_state/TEOS10/gsw_ct_freezing_exact.f90 new file mode 120000 index 0000000000..696fe5c425 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_ct_freezing_exact.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_ct_freezing_exact.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_ct_freezing_poly.f90 b/src/equation_of_state/TEOS10/gsw_ct_freezing_poly.f90 deleted file mode 100644 index a6b8f08091..0000000000 --- a/src/equation_of_state/TEOS10/gsw_ct_freezing_poly.f90 +++ /dev/null @@ -1,53 +0,0 @@ -!========================================================================== -elemental function gsw_ct_freezing_poly (sa, p, saturation_fraction) -!========================================================================== -! -! Calculates the Conservative Temperature at which seawater freezes. -! The error of this fit ranges between -5e-4 K and 6e-4 K when compared -! with the Conservative Temperature calculated from the exact in-situ -! freezing temperature which is found by a Newton-Raphson iteration of the -! equality of the chemical potentials of water in seawater and in ice. -! Note that the Conservative temperature freezing temperature can be found -! by this exact method using the function gsw_CT_freezing. -! -! SA = Absolute Salinity [ g/kg ] -! p = sea pressure [ dbar ] -! ( i.e. absolute pressure - 10.1325 dbar ) -! saturation_fraction = the saturation fraction of dissolved air in -! seawater -! -! CT_freezing = Conservative Temperature at freezing of seawater [ deg C ] -! That is, the freezing temperature expressed in -! terms of Conservative Temperature (ITS-90). -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_sso - -use gsw_mod_freezing_poly_coefficients - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, p, saturation_fraction - -real (r8) :: gsw_ct_freezing_poly - -real (r8) :: p_r, sa_r, x - -sa_r = sa*1e-2_r8 -x = sqrt(sa_r) -p_r = p*1e-4_r8 - -gsw_ct_freezing_poly = c0 & - + sa_r*(c1 + x*(c2 + x*(c3 + x*(c4 + x*(c5 + c6*x))))) & - + p_r*(c7 + p_r*(c8 + c9*p_r)) + sa_r*p_r*(c10 + p_r*(c12 & - + p_r*(c15 + c21*sa_r)) + sa_r*(c13 + c17*p_r + c19*sa_r) & - + x*(c11 + p_r*(c14 + c18*p_r) + sa_r*(c16 + c20*p_r + c22*sa_r))) - -! Adjust for the effects of dissolved air -gsw_ct_freezing_poly = gsw_ct_freezing_poly - saturation_fraction* & - (1e-3_r8)*(2.4_r8 - a*sa)*(1.0_r8 + b*(1.0_r8 - sa/gsw_sso)) - -return -end function diff --git a/src/equation_of_state/TEOS10/gsw_ct_freezing_poly.f90 b/src/equation_of_state/TEOS10/gsw_ct_freezing_poly.f90 new file mode 120000 index 0000000000..84e6e12572 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_ct_freezing_poly.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_ct_freezing_poly.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_ct_from_pt.f90 b/src/equation_of_state/TEOS10/gsw_ct_from_pt.f90 deleted file mode 100644 index c4a624ed37..0000000000 --- a/src/equation_of_state/TEOS10/gsw_ct_from_pt.f90 +++ /dev/null @@ -1,52 +0,0 @@ -!========================================================================== -elemental function gsw_ct_from_pt (sa, pt) -!========================================================================== -! -! Calculates Conservative Temperature from potential temperature of seawater -! -! sa : Absolute Salinity [g/kg] -! pt : potential temperature with [deg C] -! reference pressure of 0 dbar -! -! gsw_ct_from_pt : Conservative Temperature [deg C] -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_cp0, gsw_sfac - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, pt - -real (r8) :: gsw_ct_from_pt - -real (r8) :: pot_enthalpy, x2, x, y - -x2 = gsw_sfac*sa -x = sqrt(x2) -y = pt*0.025_r8 ! normalize for F03 and F08 - -pot_enthalpy = 61.01362420681071_r8 + y*(168776.46138048015_r8 + & - y*(-2735.2785605119625_r8 + y*(2574.2164453821433_r8 + & - y*(-1536.6644434977543_r8 + y*(545.7340497931629_r8 + & - (-50.91091728474331_r8 - 18.30489878927802_r8*y)*y))))) + & - x2*(268.5520265845071_r8 + y*(-12019.028203559312_r8 + & - y*(3734.858026725145_r8 + y*(-2046.7671145057618_r8 + & - y*(465.28655623826234_r8 + (-0.6370820302376359_r8 - & - 10.650848542359153_r8*y)*y)))) + & - x*(937.2099110620707_r8 + y*(588.1802812170108_r8 + & - y*(248.39476522971285_r8 + (-3.871557904936333_r8 - & - 2.6268019854268356_r8*y)*y)) + & - x*(-1687.914374187449_r8 + x*(246.9598888781377_r8 + & - x*(123.59576582457964_r8 - 48.5891069025409_r8*x)) + & - y*(936.3206544460336_r8 + & - y*(-942.7827304544439_r8 + y*(369.4389437509002_r8 + & - (-33.83664947895248_r8 - 9.987880382780322_r8*y)*y)))))) - -gsw_ct_from_pt = pot_enthalpy/gsw_cp0 - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_ct_from_pt.f90 b/src/equation_of_state/TEOS10/gsw_ct_from_pt.f90 new file mode 120000 index 0000000000..d67d2df3e2 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_ct_from_pt.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_ct_from_pt.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_ct_from_t.f90 b/src/equation_of_state/TEOS10/gsw_ct_from_t.f90 deleted file mode 100644 index b2a0c9e354..0000000000 --- a/src/equation_of_state/TEOS10/gsw_ct_from_t.f90 +++ /dev/null @@ -1,32 +0,0 @@ -!========================================================================== -elemental function gsw_ct_from_t (sa, t, p) -!========================================================================== -! -! Calculates Conservative Temperature from in-situ temperature -! -! sa : Absolute Salinity [g/kg] -! t : in-situ temperature [deg C] -! p : sea pressure [dbar] -! -! gsw_ct_from_t : Conservative Temperature [deg C] -!-------------------------------------------------------------------------- - -use gsw_mod_toolbox, only : gsw_ct_from_pt, gsw_pt0_from_t - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, t, p - -real (r8) :: gsw_ct_from_t - -real (r8) :: pt0 - -pt0 = gsw_pt0_from_t(sa,t,p) -gsw_ct_from_t = gsw_ct_from_pt(sa,pt0) - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_ct_from_t.f90 b/src/equation_of_state/TEOS10/gsw_ct_from_t.f90 new file mode 120000 index 0000000000..6f917027b3 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_ct_from_t.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_ct_from_t.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_entropy_part.f90 b/src/equation_of_state/TEOS10/gsw_entropy_part.f90 deleted file mode 100644 index 70fcd11255..0000000000 --- a/src/equation_of_state/TEOS10/gsw_entropy_part.f90 +++ /dev/null @@ -1,62 +0,0 @@ -!========================================================================== -elemental function gsw_entropy_part (sa, t, p) -!========================================================================== -! -! entropy minus the terms that are a function of only SA -! -! sa : Absolute Salinity [g/kg] -! t : in-situ temperature [deg C] -! p : sea pressure [dbar] -! -! gsw_entropy_part : entropy part -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_sfac - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, t, p - -real (r8) :: gsw_entropy_part - -real (r8) :: x2, x, y, z, g03, g08 - -x2 = gsw_sfac*sa -x = sqrt(x2) -y = t*0.025_r8 -z = p*1e-4_r8 - -g03 = z*(-270.983805184062_r8 + & - z*(776.153611613101_r8 + z*(-196.51255088122_r8 + (28.9796526294175_r8 - 2.13290083518327_r8*z)*z))) + & - y*(-24715.571866078_r8 + z*(2910.0729080936_r8 + & - z*(-1513.116771538718_r8 + z*(546.959324647056_r8 + z*(-111.1208127634436_r8 + 8.68841343834394_r8*z)))) + & - y*(2210.2236124548363_r8 + z*(-2017.52334943521_r8 + & - z*(1498.081172457456_r8 + z*(-718.6359919632359_r8 + (146.4037555781616_r8 - 4.9892131862671505_r8*z)*z))) + & - y*(-592.743745734632_r8 + z*(1591.873781627888_r8 + & - z*(-1207.261522487504_r8 + (608.785486935364_r8 - 105.4993508931208_r8*z)*z)) + & - y*(290.12956292128547_r8 + z*(-973.091553087975_r8 + & - z*(602.603274510125_r8 + z*(-276.361526170076_r8 + 32.40953340386105_r8*z))) + & - y*(-113.90630790850321_r8 + y*(21.35571525415769_r8 - 67.41756835751434_r8*z) + & - z*(381.06836198507096_r8 + z*(-133.7383902842754_r8 + 49.023632509086724_r8*z))))))) - -g08 = x2*(z*(729.116529735046_r8 + & - z*(-343.956902961561_r8 + z*(124.687671116248_r8 + z*(-31.656964386073_r8 + 7.04658803315449_r8*z)))) + & - x*( x*(y*(-137.1145018408982_r8 + y*(148.10030845687618_r8 + y*(-68.5590309679152_r8 + 12.4848504784754_r8*y))) - & - 22.6683558512829_r8*z) + z*(-175.292041186547_r8 + (83.1923927801819_r8 - 29.483064349429_r8*z)*z) + & - y*(-86.1329351956084_r8 + z*(766.116132004952_r8 + z*(-108.3834525034224_r8 + 51.2796974779828_r8*z)) + & - y*(-30.0682112585625_r8 - 1380.9597954037708_r8*z + y*(3.50240264723578_r8 + 938.26075044542_r8*z)))) + & - y*(1760.062705994408_r8 + y*(-675.802947790203_r8 + & - y*(365.7041791005036_r8 + y*(-108.30162043765552_r8 + 12.78101825083098_r8*y) + & - z*(-1190.914967948748_r8 + (298.904564555024_r8 - 145.9491676006352_r8*z)*z)) + & - z*(2082.7344423998043_r8 + z*(-614.668925894709_r8 + (340.685093521782_r8 - 33.3848202979239_r8*z)*z))) + & - z*(-1721.528607567954_r8 + z*(674.819060538734_r8 + & - z*(-356.629112415276_r8 + (88.4080716616_r8 - 15.84003094423364_r8*z)*z))))) - -gsw_entropy_part = -(g03 + g08)*0.025_r8 - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_entropy_part.f90 b/src/equation_of_state/TEOS10/gsw_entropy_part.f90 new file mode 120000 index 0000000000..0160db551f --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_entropy_part.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_entropy_part.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_entropy_part_zerop.f90 b/src/equation_of_state/TEOS10/gsw_entropy_part_zerop.f90 deleted file mode 100644 index 2156b71c4e..0000000000 --- a/src/equation_of_state/TEOS10/gsw_entropy_part_zerop.f90 +++ /dev/null @@ -1,44 +0,0 @@ -!========================================================================== -elemental function gsw_entropy_part_zerop (sa, pt0) -!========================================================================== -! -! entropy part evaluated at the sea surface -! -! sa : Absolute Salinity [g/kg] -! pt0 : insitu temperature [deg C] -! -! gsw_entropy_part_zerop : entropy part at the sea surface -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_sfac - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, pt0 - -real (r8) :: gsw_entropy_part_zerop - -real (r8) :: x2, x, y, g03, g08 - -x2 = gsw_sfac*sa -x = sqrt(x2) -y = pt0*0.025_r8 - -g03 = y*(-24715.571866078_r8 + y*(2210.2236124548363_r8 + & - y*(-592.743745734632_r8 + y*(290.12956292128547_r8 + & - y*(-113.90630790850321_r8 + y*21.35571525415769_r8))))) - -g08 = x2*(x*(x*(y*(-137.1145018408982_r8 + y*(148.10030845687618_r8 + & - y*(-68.5590309679152_r8 + 12.4848504784754_r8*y)))) + & - y*(-86.1329351956084_r8 + y*(-30.0682112585625_r8 + y*3.50240264723578_r8))) + & - y*(1760.062705994408_r8 + y*(-675.802947790203_r8 + & - y*(365.7041791005036_r8 + y*(-108.30162043765552_r8 + 12.78101825083098_r8*y))))) - -gsw_entropy_part_zerop = -(g03 + g08)*0.025_r8 - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_entropy_part_zerop.f90 b/src/equation_of_state/TEOS10/gsw_entropy_part_zerop.f90 new file mode 120000 index 0000000000..678bce8822 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_entropy_part_zerop.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_entropy_part_zerop.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_gibbs.f90 b/src/equation_of_state/TEOS10/gsw_gibbs.f90 deleted file mode 100644 index 59f7d221ac..0000000000 --- a/src/equation_of_state/TEOS10/gsw_gibbs.f90 +++ /dev/null @@ -1,317 +0,0 @@ -!========================================================================== -elemental function gsw_gibbs (ns, nt, np, sa, t, p) -!========================================================================== -! -! seawater specific Gibbs free energy and derivatives up to order 2 -! -! ns : order of s derivative -! nt : order of t derivative -! np : order of p derivative -! sa : Absolute Salinity [g/kg] -! t : temperature [deg C] -! p : sea pressure [dbar] -! -! gsw_gibbs : specific Gibbs energy or its derivative -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_sfac - -use gsw_mod_kinds - -implicit none - -integer, intent(in) :: ns, nt, np -real (r8), intent(in) :: sa, t, p - -real (r8) :: gsw_gibbs - -real (r8) :: x2, x, y, z, g03, g08 - -x2 = gsw_sfac*sa -x = sqrt(x2) -y = t*0.025_r8 -z = p*1e-4_r8 - -if(ns.eq.0 .and. nt.eq.0 .and. np.eq.0) then - - g03 = 101.342743139674_r8 + z*(100015.695367145_r8 + & - z*(-2544.5765420363_r8 + z*(284.517778446287_r8 + & - z*(-33.3146754253611_r8 + (4.20263108803084_r8 - 0.546428511471039_r8*z)*z)))) + & - y*(5.90578347909402_r8 + z*(-270.983805184062_r8 + & - z*(776.153611613101_r8 + z*(-196.51255088122_r8 + (28.9796526294175_r8 - 2.13290083518327_r8*z)*z))) + & - y*(-12357.785933039_r8 + z*(1455.0364540468_r8 + & - z*(-756.558385769359_r8 + z*(273.479662323528_r8 + z*(-55.5604063817218_r8 + 4.34420671917197_r8*z)))) + & - y*(736.741204151612_r8 + z*(-672.50778314507_r8 + & - z*(499.360390819152_r8 + z*(-239.545330654412_r8 + (48.8012518593872_r8 - 1.66307106208905_r8*z)*z))) + & - y*(-148.185936433658_r8 + z*(397.968445406972_r8 + & - z*(-301.815380621876_r8 + (152.196371733841_r8 - 26.3748377232802_r8*z)*z)) + & - y*(58.0259125842571_r8 + z*(-194.618310617595_r8 + & - z*(120.520654902025_r8 + z*(-55.2723052340152_r8 + 6.48190668077221_r8*z))) + & - y*(-18.9843846514172_r8 + y*(3.05081646487967_r8 - 9.63108119393062_r8*z) + & - z*(63.5113936641785_r8 + z*(-22.2897317140459_r8 + 8.17060541818112_r8*z)))))))) - - g08 = x2*(1416.27648484197_r8 + z*(-3310.49154044839_r8 + & - z*(384.794152978599_r8 + z*(-96.5324320107458_r8 + (15.8408172766824_r8 - 2.62480156590992_r8*z)*z))) + & - x*(-2432.14662381794_r8 + x*(2025.80115603697_r8 + & - y*(543.835333000098_r8 + y*(-68.5572509204491_r8 + & - y*(49.3667694856254_r8 + y*(-17.1397577419788_r8 + 2.49697009569508_r8*y))) - 22.6683558512829_r8*z) + & - x*(-1091.66841042967_r8 - 196.028306689776_r8*y + & - x*(374.60123787784_r8 - 48.5891069025409_r8*x + 36.7571622995805_r8*y) + 36.0284195611086_r8*z) + & - z*(-54.7919133532887_r8 + (-4.08193978912261_r8 - 30.1755111971161_r8*z)*z)) + & - z*(199.459603073901_r8 + z*(-52.2940909281335_r8 + (68.0444942726459_r8 - 3.41251932441282_r8*z)*z)) + & - y*(-493.407510141682_r8 + z*(-175.292041186547_r8 + (83.1923927801819_r8 - 29.483064349429_r8*z)*z) + & - y*(-43.0664675978042_r8 + z*(383.058066002476_r8 + z*(-54.1917262517112_r8 + 25.6398487389914_r8*z)) + & - y*(-10.0227370861875_r8 - 460.319931801257_r8*z + y*(0.875600661808945_r8 + 234.565187611355_r8*z))))) + & - y*(168.072408311545_r8 + z*(729.116529735046_r8 + & - z*(-343.956902961561_r8 + z*(124.687671116248_r8 + z*(-31.656964386073_r8 + 7.04658803315449_r8*z)))) + & - y*(880.031352997204_r8 + y*(-225.267649263401_r8 + & - y*(91.4260447751259_r8 + y*(-21.6603240875311_r8 + 2.13016970847183_r8*y) + & - z*(-297.728741987187_r8 + (74.726141138756_r8 - 36.4872919001588_r8*z)*z)) + & - z*(694.244814133268_r8 + z*(-204.889641964903_r8 + (113.561697840594_r8 - 11.1282734326413_r8*z)*z))) + & - z*(-860.764303783977_r8 + z*(337.409530269367_r8 + & - z*(-178.314556207638_r8 + (44.2040358308_r8 - 7.92001547211682_r8*z)*z)))))) - - if(sa.gt.0.0_r8) & - g08 = g08 + x2*(5812.81456626732_r8 + 851.226734946706_r8*y)*log(x) - - gsw_gibbs = g03 + g08 - -elseif(ns.eq.1 .and. nt.eq.0 .and. np.eq.0) then - - g08 = 8645.36753595126_r8 + z*(-6620.98308089678_r8 + & - z*(769.588305957198_r8 + z*(-193.0648640214916_r8 + (31.6816345533648_r8 - 5.24960313181984_r8*z)*z))) + & - x*(-7296.43987145382_r8 + x*(8103.20462414788_r8 + & - y*(2175.341332000392_r8 + y*(-274.2290036817964_r8 + & - y*(197.4670779425016_r8 + y*(-68.5590309679152_r8 + 9.98788038278032_r8*y))) - 90.6734234051316_r8*z) + & - x*(-5458.34205214835_r8 - 980.14153344888_r8*y + & - x*(2247.60742726704_r8 - 340.1237483177863_r8*x + 220.542973797483_r8*y) + 180.142097805543_r8*z) + & - z*(-219.1676534131548_r8 + (-16.32775915649044_r8 - 120.7020447884644_r8*z)*z)) + & - z*(598.378809221703_r8 + z*(-156.8822727844005_r8 + (204.1334828179377_r8 - 10.23755797323846_r8*z)*z)) + & - y*(-1480.222530425046_r8 + z*(-525.876123559641_r8 + (249.57717834054571_r8 - 88.449193048287_r8*z)*z) + & - y*(-129.1994027934126_r8 + z*(1149.174198007428_r8 + z*(-162.5751787551336_r8 + 76.9195462169742_r8*z)) + & - y*(-30.0682112585625_r8 - 1380.9597954037708_r8*z + y*(2.626801985426835_r8 + 703.695562834065_r8*z))))) + & - y*(1187.3715515697959_r8 + z*(1458.233059470092_r8 + & - z*(-687.913805923122_r8 + z*(249.375342232496_r8 + z*(-63.313928772146_r8 + 14.09317606630898_r8*z)))) + & - y*(1760.062705994408_r8 + y*(-450.535298526802_r8 + & - y*(182.8520895502518_r8 + y*(-43.3206481750622_r8 + 4.26033941694366_r8*y) + & - z*(-595.457483974374_r8 + (149.452282277512_r8 - 72.9745838003176_r8*z)*z)) + & - z*(1388.489628266536_r8 + z*(-409.779283929806_r8 + (227.123395681188_r8 - 22.2565468652826_r8*z)*z))) + & - z*(-1721.528607567954_r8 + z*(674.819060538734_r8 + & - z*(-356.629112415276_r8 + (88.4080716616_r8 - 15.84003094423364_r8*z)*z))))) - - if(sa.gt.0_r8) then - g08 = g08 + (11625.62913253464_r8 + 1702.453469893412_r8*y)*log(x) - else - g08 = 0.0_r8 - endif - - gsw_gibbs = 0.5*gsw_sfac*g08 - -elseif(ns.eq.0 .and. nt.eq.1 .and. np.eq.0) then - - g03 = 5.90578347909402_r8 + z*(-270.983805184062_r8 + & - z*(776.153611613101_r8 + z*(-196.51255088122_r8 + (28.9796526294175_r8 - 2.13290083518327_r8*z)*z))) + & - y*(-24715.571866078_r8 + z*(2910.0729080936_r8 + & - z*(-1513.116771538718_r8 + z*(546.959324647056_r8 + z*(-111.1208127634436_r8 + 8.68841343834394_r8*z)))) + & - y*(2210.2236124548363_r8 + z*(-2017.52334943521_r8 + & - z*(1498.081172457456_r8 + z*(-718.6359919632359_r8 + (146.4037555781616_r8 - 4.9892131862671505_r8*z)*z))) + & - y*(-592.743745734632_r8 + z*(1591.873781627888_r8 + & - z*(-1207.261522487504_r8 + (608.785486935364_r8 - 105.4993508931208_r8*z)*z)) + & - y*(290.12956292128547_r8 + z*(-973.091553087975_r8 + & - z*(602.603274510125_r8 + z*(-276.361526170076_r8 + 32.40953340386105_r8*z))) + & - y*(-113.90630790850321_r8 + y*(21.35571525415769_r8 - 67.41756835751434_r8*z) + & - z*(381.06836198507096_r8 + z*(-133.7383902842754_r8 + 49.023632509086724_r8*z))))))) - - g08 = x2*(168.072408311545_r8 + z*(729.116529735046_r8 + & - z*(-343.956902961561_r8 + z*(124.687671116248_r8 + z*(-31.656964386073_r8 + 7.04658803315449_r8*z)))) + & - x*(-493.407510141682_r8 + x*(543.835333000098_r8 + x*(-196.028306689776_r8 + 36.7571622995805_r8*x) + & - y*(-137.1145018408982_r8 + y*(148.10030845687618_r8 + y*(-68.5590309679152_r8 + 12.4848504784754_r8*y))) - & - 22.6683558512829_r8*z) + z*(-175.292041186547_r8 + (83.1923927801819_r8 - 29.483064349429_r8*z)*z) + & - y*(-86.1329351956084_r8 + z*(766.116132004952_r8 + z*(-108.3834525034224_r8 + 51.2796974779828_r8*z)) + & - y*(-30.0682112585625_r8 - 1380.9597954037708_r8*z + y*(3.50240264723578_r8 + 938.26075044542_r8*z)))) + & - y*(1760.062705994408_r8 + y*(-675.802947790203_r8 + & - y*(365.7041791005036_r8 + y*(-108.30162043765552_r8 + 12.78101825083098_r8*y) + & - z*(-1190.914967948748_r8 + (298.904564555024_r8 - 145.9491676006352_r8*z)*z)) + & - z*(2082.7344423998043_r8 + z*(-614.668925894709_r8 + (340.685093521782_r8 - 33.3848202979239_r8*z)*z))) + & - z*(-1721.528607567954_r8 + z*(674.819060538734_r8 + & - z*(-356.629112415276_r8 + (88.4080716616_r8 - 15.84003094423364_r8*z)*z))))) - - if(sa.gt.0_r8) g08 = g08 + 851.226734946706_r8*x2*log(x) - - gsw_gibbs = (g03 + g08)*0.025_r8 - -elseif(ns.eq.0 .and. nt.eq.0 .and. np.eq.1) then - - g03 = 100015.695367145_r8 + z*(-5089.1530840726_r8 + & - z*(853.5533353388611_r8 + z*(-133.2587017014444_r8 + (21.0131554401542_r8 - 3.278571068826234_r8*z)*z))) + & - y*(-270.983805184062_r8 + z*(1552.307223226202_r8 + & - z*(-589.53765264366_r8 + (115.91861051767_r8 - 10.664504175916349_r8*z)*z)) + & - y*(1455.0364540468_r8 + z*(-1513.116771538718_r8 + & - z*(820.438986970584_r8 + z*(-222.2416255268872_r8 + 21.72103359585985_r8*z))) + & - y*(-672.50778314507_r8 + z*(998.720781638304_r8 + & - z*(-718.6359919632359_r8 + (195.2050074375488_r8 - 8.31535531044525_r8*z)*z)) + & - y*(397.968445406972_r8 + z*(-603.630761243752_r8 + (456.589115201523_r8 - 105.4993508931208_r8*z)*z) + & - y*(-194.618310617595_r8 + y*(63.5113936641785_r8 - 9.63108119393062_r8*y + & - z*(-44.5794634280918_r8 + 24.511816254543362_r8*z)) + & - z*(241.04130980405_r8 + z*(-165.8169157020456_r8 + & - 25.92762672308884_r8*z))))))) - - g08 = x2*(-3310.49154044839_r8 + z*(769.588305957198_r8 + & - z*(-289.5972960322374_r8 + (63.3632691067296_r8 - 13.1240078295496_r8*z)*z)) + & - x*(199.459603073901_r8 + x*(-54.7919133532887_r8 + 36.0284195611086_r8*x - 22.6683558512829_r8*y + & - (-8.16387957824522_r8 - 90.52653359134831_r8*z)*z) + & - z*(-104.588181856267_r8 + (204.1334828179377_r8 - 13.65007729765128_r8*z)*z) + & - y*(-175.292041186547_r8 + (166.3847855603638_r8 - 88.449193048287_r8*z)*z + & - y*(383.058066002476_r8 + y*(-460.319931801257_r8 + 234.565187611355_r8*y) + & - z*(-108.3834525034224_r8 + 76.9195462169742_r8*z)))) + & - y*(729.116529735046_r8 + z*(-687.913805923122_r8 + & - z*(374.063013348744_r8 + z*(-126.627857544292_r8 + 35.23294016577245_r8*z))) + & - y*(-860.764303783977_r8 + y*(694.244814133268_r8 + & - y*(-297.728741987187_r8 + (149.452282277512_r8 - 109.46187570047641_r8*z)*z) + & - z*(-409.779283929806_r8 + (340.685093521782_r8 - 44.5130937305652_r8*z)*z)) + & - z*(674.819060538734_r8 + z*(-534.943668622914_r8 + (176.8161433232_r8 - 39.600077360584095_r8*z)*z))))) - - gsw_gibbs = (g03 + g08)*1e-8_r8 - -elseif(ns.eq.0 .and. nt.eq.2 .and. np.eq.0) then - - g03 = -24715.571866078_r8 + z*(2910.0729080936_r8 + z* & - (-1513.116771538718_r8 + z*(546.959324647056_r8 + z*(-111.1208127634436_r8 + 8.68841343834394_r8*z)))) + & - y*(4420.4472249096725_r8 + z*(-4035.04669887042_r8 + & - z*(2996.162344914912_r8 + z*(-1437.2719839264719_r8 + (292.8075111563232_r8 - 9.978426372534301_r8*z)*z))) + & - y*(-1778.231237203896_r8 + z*(4775.621344883664_r8 + & - z*(-3621.784567462512_r8 + (1826.356460806092_r8 - 316.49805267936244_r8*z)*z)) + & - y*(1160.5182516851419_r8 + z*(-3892.3662123519_r8 + & - z*(2410.4130980405_r8 + z*(-1105.446104680304_r8 + 129.6381336154442_r8*z))) + & - y*(-569.531539542516_r8 + y*(128.13429152494615_r8 - 404.50541014508605_r8*z) + & - z*(1905.341809925355_r8 + z*(-668.691951421377_r8 + 245.11816254543362_r8*z)))))) - - g08 = x2*(1760.062705994408_r8 + x*(-86.1329351956084_r8 + & - x*(-137.1145018408982_r8 + y*(296.20061691375236_r8 + y*(-205.67709290374563_r8 + 49.9394019139016_r8*y))) + & - z*(766.116132004952_r8 + z*(-108.3834525034224_r8 + 51.2796974779828_r8*z)) + & - y*(-60.136422517125_r8 - 2761.9195908075417_r8*z + y*(10.50720794170734_r8 + 2814.78225133626_r8*z))) + & - y*(-1351.605895580406_r8 + y*(1097.1125373015109_r8 + y*(-433.20648175062206_r8 + 63.905091254154904_r8*y) + & - z*(-3572.7449038462437_r8 + (896.713693665072_r8 - 437.84750280190565_r8*z)*z)) + & - z*(4165.4688847996085_r8 + z*(-1229.337851789418_r8 + (681.370187043564_r8 - 66.7696405958478_r8*z)*z))) + & - z*(-1721.528607567954_r8 + z*(674.819060538734_r8 + & - z*(-356.629112415276_r8 + (88.4080716616_r8 - 15.84003094423364_r8*z)*z)))) - - gsw_gibbs = (g03 + g08)*0.000625_r8 - -elseif(ns.eq.1 .and. nt.eq.0 .and. np.eq.1) then - - g08 = -6620.98308089678_r8 + z*(1539.176611914396_r8 + & - z*(-579.1945920644748_r8 + (126.7265382134592_r8 - 26.2480156590992_r8*z)*z)) + & - x*(598.378809221703_r8 + x*(-219.1676534131548_r8 + 180.142097805543_r8*x - 90.6734234051316_r8*y + & - (-32.65551831298088_r8 - 362.10613436539325_r8*z)*z) + & - z*(-313.764545568801_r8 + (612.4004484538132_r8 - 40.95023189295384_r8*z)*z) + & - y*(-525.876123559641_r8 + (499.15435668109143_r8 - 265.347579144861_r8*z)*z + & - y*(1149.174198007428_r8 + y*(-1380.9597954037708_r8 + 703.695562834065_r8*y) + & - z*(-325.1503575102672_r8 + 230.7586386509226_r8*z)))) + & - y*(1458.233059470092_r8 + z*(-1375.827611846244_r8 + & - z*(748.126026697488_r8 + z*(-253.255715088584_r8 + 70.4658803315449_r8*z))) + & - y*(-1721.528607567954_r8 + y*(1388.489628266536_r8 + & - y*(-595.457483974374_r8 + (298.904564555024_r8 - 218.92375140095282_r8*z)*z) + & - z*(-819.558567859612_r8 + (681.370187043564_r8 - 89.0261874611304_r8*z)*z)) + & - z*(1349.638121077468_r8 + z*(-1069.887337245828_r8 + (353.6322866464_r8 - 79.20015472116819_r8*z)*z)))) - - gsw_gibbs = g08*gsw_sfac*0.5e-8_r8 - -elseif(ns.eq.0 .and. nt.eq.1 .and. np.eq.1) then - - g03 = -270.983805184062_r8 + z*(1552.307223226202_r8 + z*(-589.53765264366_r8 + & - (115.91861051767_r8 - 10.664504175916349_r8*z)*z)) + & - y*(2910.0729080936_r8 + z*(-3026.233543077436_r8 + & - z*(1640.877973941168_r8 + z*(-444.4832510537744_r8 + 43.4420671917197_r8*z))) + & - y*(-2017.52334943521_r8 + z*(2996.162344914912_r8 + & - z*(-2155.907975889708_r8 + (585.6150223126464_r8 - 24.946065931335752_r8*z)*z)) + & - y*(1591.873781627888_r8 + z*(-2414.523044975008_r8 + (1826.356460806092_r8 - 421.9974035724832_r8*z)*z) + & - y*(-973.091553087975_r8 + z*(1205.20654902025_r8 + z*(-829.084578510228_r8 + 129.6381336154442_r8*z)) + & - y*(381.06836198507096_r8 - 67.41756835751434_r8*y + z*(-267.4767805685508_r8 + 147.07089752726017_r8*z)))))) - - g08 = x2*(729.116529735046_r8 + z*(-687.913805923122_r8 + & - z*(374.063013348744_r8 + z*(-126.627857544292_r8 + 35.23294016577245_r8*z))) + & - x*(-175.292041186547_r8 - 22.6683558512829_r8*x + (166.3847855603638_r8 - 88.449193048287_r8*z)*z + & - y*(766.116132004952_r8 + y*(-1380.9597954037708_r8 + 938.26075044542_r8*y) + & - z*(-216.7669050068448_r8 + 153.8390924339484_r8*z))) + & - y*(-1721.528607567954_r8 + y*(2082.7344423998043_r8 + & - y*(-1190.914967948748_r8 + (597.809129110048_r8 - 437.84750280190565_r8*z)*z) + & - z*(-1229.337851789418_r8 + (1022.055280565346_r8 - 133.5392811916956_r8*z)*z)) + & - z*(1349.638121077468_r8 + z*(-1069.887337245828_r8 + (353.6322866464_r8 - 79.20015472116819_r8*z)*z)))) - - gsw_gibbs = (g03 + g08)*2.5e-10_r8 - -elseif(ns.eq.1 .and. nt.eq.1 .and. np.eq.0) then - - g08 = 1187.3715515697959_r8 + z*(1458.233059470092_r8 + & - z*(-687.913805923122_r8 + z*(249.375342232496_r8 + z*(-63.313928772146_r8 + 14.09317606630898_r8*z)))) + & - x*(-1480.222530425046_r8 + x*(2175.341332000392_r8 + x*(-980.14153344888_r8 + 220.542973797483_r8*x) + & - y*(-548.4580073635929_r8 + y*(592.4012338275047_r8 + y*(-274.2361238716608_r8 + 49.9394019139016_r8*y))) - & - 90.6734234051316_r8*z) + z*(-525.876123559641_r8 + (249.57717834054571_r8 - 88.449193048287_r8*z)*z) + & - y*(-258.3988055868252_r8 + z*(2298.348396014856_r8 + z*(-325.1503575102672_r8 + 153.8390924339484_r8*z)) + & - y*(-90.2046337756875_r8 - 4142.8793862113125_r8*z + y*(10.50720794170734_r8 + 2814.78225133626_r8*z)))) + & - y*(3520.125411988816_r8 + y*(-1351.605895580406_r8 + & - y*(731.4083582010072_r8 + y*(-216.60324087531103_r8 + 25.56203650166196_r8*y) + & - z*(-2381.829935897496_r8 + (597.809129110048_r8 - 291.8983352012704_r8*z)*z)) + & - z*(4165.4688847996085_r8 + z*(-1229.337851789418_r8 + (681.370187043564_r8 - 66.7696405958478_r8*z)*z))) + & - z*(-3443.057215135908_r8 + z*(1349.638121077468_r8 + & - z*(-713.258224830552_r8 + (176.8161433232_r8 - 31.68006188846728_r8*z)*z)))) - - if(sa.gt.0_r8) g08 = g08 + 1702.453469893412_r8*log(x) - - gsw_gibbs = 0.5_r8*gsw_sfac*0.025_r8*g08 - -elseif(ns.eq.2 .and. nt.eq.0 .and. np.eq.0) then - - g08 = 2.0_r8*(8103.20462414788_r8 + & - y*(2175.341332000392_r8 + y*(-274.2290036817964_r8 + & - y*(197.4670779425016_r8 + y*(-68.5590309679152_r8 + 9.98788038278032_r8*y))) - 90.6734234051316_r8*z) + & - 1.5_r8*x*(-5458.34205214835_r8 - 980.14153344888_r8*y + & - (4.0_r8/3.0_r8)*x*(2247.60742726704_r8 - 340.1237483177863_r8*1.25_r8*x + 220.542973797483_r8*y) + & - 180.142097805543_r8*z) + & - z*(-219.1676534131548_r8 + (-16.32775915649044_r8 - 120.7020447884644_r8*z)*z)) - - if (x.gt.0_r8) then - g08 = g08 + (-7296.43987145382_r8 + z*(598.378809221703_r8 + & - z*(-156.8822727844005_r8 + (204.1334828179377_r8 - 10.23755797323846_r8*z)*z)) + & - y*(-1480.222530425046_r8 + z*(-525.876123559641_r8 + & - (249.57717834054571_r8 - 88.449193048287_r8*z)*z) + & - y*(-129.1994027934126_r8 + z*(1149.174198007428_r8 + & - z*(-162.5751787551336_r8 + 76.9195462169742_r8*z)) + & - y*(-30.0682112585625_r8 - 1380.9597954037708_r8*z + & - y*(2.626801985426835_r8 + 703.695562834065_r8*z)))))/x + & - (11625.62913253464_r8 + 1702.453469893412_r8*y)/x2 - else - g08 = 0.0_r8 - end if - - gsw_gibbs = 0.25_r8*gsw_sfac*gsw_sfac*g08 - -elseif(ns.eq.0 .and. nt.eq.0 .and. np.eq.2) then - - g03 = -5089.1530840726_r8 + z*(1707.1066706777221_r8 + & - z*(-399.7761051043332_r8 + (84.0526217606168_r8 - 16.39285534413117_r8*z)*z)) + & - y*(1552.307223226202_r8 + z*(-1179.07530528732_r8 + (347.75583155301_r8 - 42.658016703665396_r8*z)*z) + & - y*(-1513.116771538718_r8 + z*(1640.877973941168_r8 + z*(-666.7248765806615_r8 + 86.8841343834394_r8*z)) + & - y*(998.720781638304_r8 + z*(-1437.2719839264719_r8 + (585.6150223126464_r8 - 33.261421241781_r8*z)*z) + & - y*(-603.630761243752_r8 + (913.178230403046_r8 - 316.49805267936244_r8*z)*z + & - y*(241.04130980405_r8 + y*(-44.5794634280918_r8 + 49.023632509086724_r8*z) + & - z*(-331.6338314040912_r8 + 77.78288016926652_r8*z)))))) - - g08 = x2*(769.588305957198_r8 + z*(-579.1945920644748_r8 + (190.08980732018878_r8 - 52.4960313181984_r8*z)*z) + & - x*(-104.588181856267_r8 + x*(-8.16387957824522_r8 - 181.05306718269662_r8*z) + & - (408.2669656358754_r8 - 40.95023189295384_r8*z)*z + & - y*(166.3847855603638_r8 - 176.898386096574_r8*z + y*(-108.3834525034224_r8 + 153.8390924339484_r8*z))) + & - y*(-687.913805923122_r8 + z*(748.126026697488_r8 + z*(-379.883572632876_r8 + 140.9317606630898_r8*z)) + & - y*(674.819060538734_r8 + z*(-1069.887337245828_r8 + (530.4484299696_r8 - 158.40030944233638_r8*z)*z) + & - y*(-409.779283929806_r8 + y*(149.452282277512_r8 - 218.92375140095282_r8*z) + & - (681.370187043564_r8 - 133.5392811916956_r8*z)*z)))) - - gsw_gibbs = (g03 + g08)*1e-16_r8 - -end if - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_gibbs.f90 b/src/equation_of_state/TEOS10/gsw_gibbs.f90 new file mode 120000 index 0000000000..6bb64d98a7 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_gibbs.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_gibbs.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_gibbs_ice.f90 b/src/equation_of_state/TEOS10/gsw_gibbs_ice.f90 deleted file mode 100644 index 0416a1eeaf..0000000000 --- a/src/equation_of_state/TEOS10/gsw_gibbs_ice.f90 +++ /dev/null @@ -1,130 +0,0 @@ -! ========================================================================= -elemental function gsw_gibbs_ice (nt, np, t, p) -! ========================================================================= -! -! Ice specific Gibbs energy and derivatives up to order 2. -! -! nt = order of t derivative [ integers 0, 1 or 2 ] -! np = order of p derivative [ integers 0, 1 or 2 ] -! t = in-situ temperature (ITS-90) [ deg C ] -! p = sea pressure [ dbar ] -! -! gibbs_ice = Specific Gibbs energy of ice or its derivatives. -! The Gibbs energy (when nt = np = 0) has units of: [ J/kg ] -! The temperature derivatives are output in units of: -! [ (J/kg) (K)^(-nt) ] -! The pressure derivatives are output in units of: -! [ (J/kg) (Pa)^(-np) ] -! The mixed derivatives are output in units of: -! [ (J/kg) (K)^(-nt) (Pa)^(-np) ] -! Note. The derivatives are taken with respect to pressure in Pa, not -! withstanding that the pressure input into this routine is in dbar. -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_t0, db2pa - -use gsw_mod_gibbs_ice_coefficients - -use gsw_mod_kinds - -implicit none - -integer, intent(in) :: nt, np -real (r8), intent(in) :: t, p - -real (r8) :: gsw_gibbs_ice - -real (r8) :: dzi, g0, g0p, g0pp, sqrec_pt -complex (r8) :: r2, r2p, r2pp, g, sqtau_t1, sqtau_t2, tau, tau_t1, tau_t2 - -real (r8), parameter :: s0 = -3.32733756492168e3_r8 - -tau = (t + gsw_t0)*rec_tt - -dzi = db2pa*p*rec_pt - -if (nt.eq.0 .and. np.eq.0) then - - tau_t1 = tau/t1 - sqtau_t1 = tau_t1*tau_t1 - tau_t2 = tau/t2 - sqtau_t2 = tau_t2*tau_t2 - - g0 = g00 + dzi*(g01 + dzi*(g02 + dzi*(g03 + g04*dzi))) - - r2 = r20 + dzi*(r21 + r22*dzi) - - g = r1*(tau*log((1.0_r8 + tau_t1)/(1.0_r8 - tau_t1)) & - + t1*(log(1.0_r8 - sqtau_t1) - sqtau_t1)) & - + r2*(tau*log((1.0_r8 + tau_t2)/(1.0_r8 - tau_t2)) & - + t2*(log(1.0_r8 - sqtau_t2) - sqtau_t2)) - - gsw_gibbs_ice = g0 - tt*(s0*tau - real(g)) - -elseif (nt.eq.1 .and. np.eq.0) then - - tau_t1 = tau/t1 - tau_t2 = tau/t2 - - r2 = r20 + dzi*(r21 + r22*dzi) - - g = r1*(log((1.0_r8 + tau_t1)/(1.0_r8 - tau_t1)) - 2.0_r8*tau_t1) & - + r2*(log((1.0_r8 + tau_t2)/(1.0_r8 - tau_t2)) - 2.0_r8*tau_t2) - - gsw_gibbs_ice = -s0 + real(g) - -elseif (nt.eq.0 .and. np.eq.1) then - - tau_t2 = tau/t2 - sqtau_t2 = tau_t2*tau_t2 - - g0p = rec_pt*(g01 + dzi*(2.0_r8*g02 + dzi*(3.0_r8*g03 + 4.0_r8*g04*dzi))) - - r2p = rec_pt*(r21 + 2.0_r8*r22*dzi) - - g = r2p*(tau*log((1.0_r8 + tau_t2)/(1.0_r8 - tau_t2)) & - + t2*(log(1.0_r8 - sqtau_t2) - sqtau_t2)) - - gsw_gibbs_ice = g0p + tt*real(g) - -elseif (nt.eq.1 .and. np.eq.1) then - - tau_t2 = tau/t2 - - r2p = rec_pt*(r21 + 2.0_r8*r22*dzi) - - g = r2p*(log((1.0_r8 + tau_t2)/(1.0_r8 - tau_t2)) - 2.0_r8*tau_t2) - - gsw_gibbs_ice = real(g) - -elseif (nt.eq.2 .and. np.eq.0) then - - r2 = r20 + dzi*(r21 + r22*dzi) - - g = r1*(1.0_r8/(t1 - tau) + 1.0_r8/(t1 + tau) - 2.0_r8/t1) & - + r2*(1.0_r8/(t2 - tau) + 1.0_r8/(t2 + tau) - 2.0_r8/t2) - - gsw_gibbs_ice = rec_tt*real(g) - -elseif (nt.eq.0 .and. np.eq.2) then - - sqrec_pt = rec_pt*rec_pt - - tau_t2 = tau/t2 - sqtau_t2 = tau_t2*tau_t2 - - g0pp = sqrec_pt*(2.0_r8*g02 + dzi*(6.0_r8*g03 + 12.0_r8*g04*dzi)) - - r2pp = 2.0_r8*r22*sqrec_pt - - g = r2pp*(tau*log((1.0_r8 + tau_t2)/(1.0_r8 - tau_t2)) & - + t2*(log(1.0_r8 - sqtau_t2) - sqtau_t2)) - - gsw_gibbs_ice = g0pp + tt*real(g) - -end if - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_gibbs_ice.f90 b/src/equation_of_state/TEOS10/gsw_gibbs_ice.f90 new file mode 120000 index 0000000000..9d1d06c481 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_gibbs_ice.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_gibbs_ice.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_gibbs_pt0_pt0.f90 b/src/equation_of_state/TEOS10/gsw_gibbs_pt0_pt0.f90 deleted file mode 100644 index 6e8bcfc779..0000000000 --- a/src/equation_of_state/TEOS10/gsw_gibbs_pt0_pt0.f90 +++ /dev/null @@ -1,47 +0,0 @@ -!========================================================================== -elemental function gsw_gibbs_pt0_pt0 (sa, pt0) -!========================================================================== -! -! gibbs_tt at (sa,pt,0) -! -! sa : Absolute Salinity [g/kg] -! pt0 : potential temperature [deg C] -! -! gsw_gibbs_pt0_pt0 : gibbs_tt at (sa,pt,0) -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_sfac - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, pt0 - -real (r8) :: gsw_gibbs_pt0_pt0 - -real (r8) :: x2, x, y, g03, g08 - -x2 = gsw_sfac*sa -x = sqrt(x2) -y = pt0*0.025_r8 - -g03 = -24715.571866078_r8 + & - y*(4420.4472249096725_r8 + & - y*(-1778.231237203896_r8 + & - y*(1160.5182516851419_r8 + & - y*(-569.531539542516_r8 + y*128.13429152494615_r8)))) - -g08 = x2*(1760.062705994408_r8 + x*(-86.1329351956084_r8 + & - x*(-137.1145018408982_r8 + y*(296.20061691375236_r8 + & - y*(-205.67709290374563_r8 + 49.9394019139016_r8*y))) + & - y*(-60.136422517125_r8 + y*10.50720794170734_r8)) + & - y*(-1351.605895580406_r8 + y*(1097.1125373015109_r8 + & - y*(-433.20648175062206_r8 + 63.905091254154904_r8*y)))) - -gsw_gibbs_pt0_pt0 = (g03 + g08)*0.000625_r8 - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_gibbs_pt0_pt0.f90 b/src/equation_of_state/TEOS10/gsw_gibbs_pt0_pt0.f90 new file mode 120000 index 0000000000..e345379f5d --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_gibbs_pt0_pt0.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_gibbs_pt0_pt0.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_mod_freezing_poly_coefficients.f90 b/src/equation_of_state/TEOS10/gsw_mod_freezing_poly_coefficients.f90 deleted file mode 100644 index d4b5052f99..0000000000 --- a/src/equation_of_state/TEOS10/gsw_mod_freezing_poly_coefficients.f90 +++ /dev/null @@ -1,63 +0,0 @@ -!========================================================================== -module gsw_mod_freezing_poly_coefficients -!========================================================================== - -use gsw_mod_kinds - -implicit none - -real (r8), parameter :: c0 = 0.017947064327968736_r8 -real (r8), parameter :: c1 = -6.076099099929818_r8 -real (r8), parameter :: c2 = 4.883198653547851_r8 -real (r8), parameter :: c3 = -11.88081601230542_r8 -real (r8), parameter :: c4 = 13.34658511480257_r8 -real (r8), parameter :: c5 = -8.722761043208607_r8 -real (r8), parameter :: c6 = 2.082038908808201_r8 -real (r8), parameter :: c7 = -7.389420998107497_r8 -real (r8), parameter :: c8 = -2.110913185058476_r8 -real (r8), parameter :: c9 = 0.2295491578006229_r8 -real (r8), parameter :: c10 = -0.9891538123307282_r8 -real (r8), parameter :: c11 = -0.08987150128406496_r8 -real (r8), parameter :: c12 = 0.3831132432071728_r8 -real (r8), parameter :: c13 = 1.054318231187074_r8 -real (r8), parameter :: c14 = 1.065556599652796_r8 -real (r8), parameter :: c15 = -0.7997496801694032_r8 -real (r8), parameter :: c16 = 0.3850133554097069_r8 -real (r8), parameter :: c17 = -2.078616693017569_r8 -real (r8), parameter :: c18 = 0.8756340772729538_r8 -real (r8), parameter :: c19 = -2.079022768390933_r8 -real (r8), parameter :: c20 = 1.596435439942262_r8 -real (r8), parameter :: c21 = 0.1338002171109174_r8 -real (r8), parameter :: c22 = 1.242891021876471_r8 - -! Note that a = 0.502500117621_r8/gsw_sso -real (r8), parameter :: a = 0.014289763856964_r8 -real (r8), parameter :: b = 0.057000649899720_r8 - -real (r8), parameter :: t0 = 0.002519_r8 -real (r8), parameter :: t1 = -5.946302841607319_r8 -real (r8), parameter :: t2 = 4.136051661346983_r8 -real (r8), parameter :: t3 = -1.115150523403847e1_r8 -real (r8), parameter :: t4 = 1.476878746184548e1_r8 -real (r8), parameter :: t5 = -1.088873263630961e1_r8 -real (r8), parameter :: t6 = 2.961018839640730_r8 -real (r8), parameter :: t7 = -7.433320943962606_r8 -real (r8), parameter :: t8 = -1.561578562479883_r8 -real (r8), parameter :: t9 = 4.073774363480365e-2_r8 -real (r8), parameter :: t10 = 1.158414435887717e-2_r8 -real (r8), parameter :: t11 = -4.122639292422863e-1_r8 -real (r8), parameter :: t12 = -1.123186915628260e-1_r8 -real (r8), parameter :: t13 = 5.715012685553502e-1_r8 -real (r8), parameter :: t14 = 2.021682115652684e-1_r8 -real (r8), parameter :: t15 = 4.140574258089767e-2_r8 -real (r8), parameter :: t16 = -6.034228641903586e-1_r8 -real (r8), parameter :: t17 = -1.205825928146808e-2_r8 -real (r8), parameter :: t18 = -2.812172968619369e-1_r8 -real (r8), parameter :: t19 = 1.877244474023750e-2_r8 -real (r8), parameter :: t20 = -1.204395563789007e-1_r8 -real (r8), parameter :: t21 = 2.349147739749606e-1_r8 -real (r8), parameter :: t22 = 2.748444541144219e-3_r8 - -end module - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_mod_freezing_poly_coefficients.f90 b/src/equation_of_state/TEOS10/gsw_mod_freezing_poly_coefficients.f90 new file mode 120000 index 0000000000..93ea8e1d2a --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_mod_freezing_poly_coefficients.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/modules/gsw_mod_freezing_poly_coefficients.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_mod_gibbs_ice_coefficients.f90 b/src/equation_of_state/TEOS10/gsw_mod_gibbs_ice_coefficients.f90 deleted file mode 100644 index e9da3baf48..0000000000 --- a/src/equation_of_state/TEOS10/gsw_mod_gibbs_ice_coefficients.f90 +++ /dev/null @@ -1,30 +0,0 @@ -!========================================================================== -module gsw_mod_gibbs_ice_coefficients -!========================================================================== - -use gsw_mod_kinds - -implicit none - -complex(r8), parameter :: t1 =( 3.68017112855051e-2_r8, 5.10878114959572e-2_r8) -complex(r8), parameter :: t2 =( 3.37315741065416e-1_r8, 3.35449415919309e-1_r8) - -complex(r8), parameter :: r1 =( 4.47050716285388e1_r8, 6.56876847463481e1_r8) -complex(r8), parameter :: r20=(-7.25974574329220e1_r8, -7.81008427112870e1_r8) -complex(r8), parameter :: r21=(-5.57107698030123e-5_r8, 4.64578634580806e-5_r8) -complex(r8), parameter :: r22=(2.34801409215913e-11_r8,-2.85651142904972e-11_r8) - -! 1./Pt, where Pt = 611.657; Experimental triple-point pressure in Pa. -real (r8), parameter :: rec_pt = 1.634903221903779e-3_r8 -real (r8), parameter :: tt = 273.16_r8 ! Triple-point temperature, kelvin (K). -real (r8), parameter :: rec_tt = 3.660858105139845e-3_r8 ! = 1/tt - -real (r8), parameter :: g00 = -6.32020233335886e5_r8 -real (r8), parameter :: g01 = 6.55022213658955e-1_r8 -real (r8), parameter :: g02 = -1.89369929326131e-8_r8 -real (r8), parameter :: g03 = 3.3974612327105304e-15_r8 -real (r8), parameter :: g04 = -5.564648690589909e-22_r8 - -end module - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_mod_gibbs_ice_coefficients.f90 b/src/equation_of_state/TEOS10/gsw_mod_gibbs_ice_coefficients.f90 new file mode 120000 index 0000000000..4c72d9079b --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_mod_gibbs_ice_coefficients.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/modules/gsw_mod_gibbs_ice_coefficients.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_mod_kinds.f90 b/src/equation_of_state/TEOS10/gsw_mod_kinds.f90 deleted file mode 100644 index 7a2a80891f..0000000000 --- a/src/equation_of_state/TEOS10/gsw_mod_kinds.f90 +++ /dev/null @@ -1,16 +0,0 @@ -!========================================================================== -module gsw_mod_kinds -!========================================================================== - -implicit none - -integer, parameter :: r4 = selected_real_kind(6,30) - -integer, parameter :: r8 = selected_real_kind(14,30) - -end module - -!-------------------------------------------------------------------------- - - - diff --git a/src/equation_of_state/TEOS10/gsw_mod_kinds.f90 b/src/equation_of_state/TEOS10/gsw_mod_kinds.f90 new file mode 120000 index 0000000000..fa0926e540 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_mod_kinds.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/modules/gsw_mod_kinds.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_mod_specvol_coefficients.f90 b/src/equation_of_state/TEOS10/gsw_mod_specvol_coefficients.f90 deleted file mode 100644 index 7bc89c7b5e..0000000000 --- a/src/equation_of_state/TEOS10/gsw_mod_specvol_coefficients.f90 +++ /dev/null @@ -1,313 +0,0 @@ -!========================================================================== -module gsw_mod_specvol_coefficients -!========================================================================== - -use gsw_mod_kinds - -implicit none - -real (r8), parameter :: a000 = -1.56497346750e-5_r8 -real (r8), parameter :: a001 = 1.85057654290e-5_r8 -real (r8), parameter :: a002 = -1.17363867310e-6_r8 -real (r8), parameter :: a003 = -3.65270065530e-7_r8 -real (r8), parameter :: a004 = 3.14540999020e-7_r8 -real (r8), parameter :: a010 = 5.55242129680e-5_r8 -real (r8), parameter :: a011 = -2.34332137060e-5_r8 -real (r8), parameter :: a012 = 4.26100574800e-6_r8 -real (r8), parameter :: a013 = 5.73918103180e-7_r8 -real (r8), parameter :: a020 = -4.95634777770e-5_r8 -real (r8), parameter :: a021 = 2.37838968519e-5_r8 -real (r8), parameter :: a022 = -1.38397620111e-6_r8 -real (r8), parameter :: a030 = 2.76445290808e-5_r8 -real (r8), parameter :: a031 = -1.36408749928e-5_r8 -real (r8), parameter :: a032 = -2.53411666056e-7_r8 -real (r8), parameter :: a040 = -4.02698077700e-6_r8 -real (r8), parameter :: a041 = 2.53683834070e-6_r8 -real (r8), parameter :: a050 = 1.23258565608e-6_r8 -real (r8), parameter :: a100 = 3.50095997640e-5_r8 -real (r8), parameter :: a101 = -9.56770881560e-6_r8 -real (r8), parameter :: a102 = -5.56991545570e-6_r8 -real (r8), parameter :: a103 = -2.72956962370e-7_r8 -real (r8), parameter :: a110 = -7.48716846880e-5_r8 -real (r8), parameter :: a111 = -4.73566167220e-7_r8 -real (r8), parameter :: a112 = 7.82747741600e-7_r8 -real (r8), parameter :: a120 = 7.24244384490e-5_r8 -real (r8), parameter :: a121 = -1.03676320965e-5_r8 -real (r8), parameter :: a122 = 2.32856664276e-8_r8 -real (r8), parameter :: a130 = -3.50383492616e-5_r8 -real (r8), parameter :: a131 = 5.18268711320e-6_r8 -real (r8), parameter :: a140 = -1.65263794500e-6_r8 -real (r8), parameter :: a200 = -4.35926785610e-5_r8 -real (r8), parameter :: a201 = 1.11008347650e-5_r8 -real (r8), parameter :: a202 = 5.46207488340e-6_r8 -real (r8), parameter :: a210 = 7.18156455200e-5_r8 -real (r8), parameter :: a211 = 5.85666925900e-6_r8 -real (r8), parameter :: a212 = -1.31462208134e-6_r8 -real (r8), parameter :: a220 = -4.30608991440e-5_r8 -real (r8), parameter :: a221 = 9.49659182340e-7_r8 -real (r8), parameter :: a230 = 1.74814722392e-5_r8 -real (r8), parameter :: a300 = 3.45324618280e-5_r8 -real (r8), parameter :: a301 = -9.84471178440e-6_r8 -real (r8), parameter :: a302 = -1.35441856270e-6_r8 -real (r8), parameter :: a310 = -3.73971683740e-5_r8 -real (r8), parameter :: a311 = -9.76522784000e-7_r8 -real (r8), parameter :: a320 = 6.85899736680e-6_r8 -real (r8), parameter :: a400 = -1.19594097880e-5_r8 -real (r8), parameter :: a401 = 2.59092252600e-6_r8 -real (r8), parameter :: a410 = 7.71906784880e-6_r8 -real (r8), parameter :: a500 = 1.38645945810e-6_r8 - -real (r8), parameter :: b000 = -3.10389819760e-4_r8 -real (r8), parameter :: b003 = 3.63101885150e-7_r8 -real (r8), parameter :: b004 = -1.11471254230e-7_r8 -real (r8), parameter :: b010 = 3.50095997640e-5_r8 -real (r8), parameter :: b013 = -2.72956962370e-7_r8 -real (r8), parameter :: b020 = -3.74358423440e-5_r8 -real (r8), parameter :: b030 = 2.41414794830e-5_r8 -real (r8), parameter :: b040 = -8.75958731540e-6_r8 -real (r8), parameter :: b050 = -3.30527589000e-7_r8 -real (r8), parameter :: b100 = 1.33856134076e-3_r8 -real (r8), parameter :: b103 = 3.34926075600e-8_r8 -real (r8), parameter :: b110 = -8.71853571220e-5_r8 -real (r8), parameter :: b120 = 7.18156455200e-5_r8 -real (r8), parameter :: b130 = -2.87072660960e-5_r8 -real (r8), parameter :: b140 = 8.74073611960e-6_r8 -real (r8), parameter :: b200 = -2.55143801811e-3_r8 -real (r8), parameter :: b210 = 1.03597385484e-4_r8 -real (r8), parameter :: b220 = -5.60957525610e-5_r8 -real (r8), parameter :: b230 = 6.85899736680e-6_r8 -real (r8), parameter :: b300 = 2.32344279772e-3_r8 -real (r8), parameter :: b310 = -4.78376391520e-5_r8 -real (r8), parameter :: b320 = 1.54381356976e-5_r8 -real (r8), parameter :: b400 = -1.05461852535e-3_r8 -real (r8), parameter :: b410 = 6.93229729050e-6_r8 -real (r8), parameter :: b500 = 1.91594743830e-4_r8 -real (r8), parameter :: b001 = 2.42624687470e-5_r8 -real (r8), parameter :: b011 = -9.56770881560e-6_r8 -real (r8), parameter :: b021 = -2.36783083610e-7_r8 -real (r8), parameter :: b031 = -3.45587736550e-6_r8 -real (r8), parameter :: b041 = 1.29567177830e-6_r8 -real (r8), parameter :: b101 = -6.95849219480e-5_r8 -real (r8), parameter :: b111 = 2.22016695300e-5_r8 -real (r8), parameter :: b121 = 5.85666925900e-6_r8 -real (r8), parameter :: b131 = 6.33106121560e-7_r8 -real (r8), parameter :: b201 = 1.12412331915e-4_r8 -real (r8), parameter :: b211 = -2.95341353532e-5_r8 -real (r8), parameter :: b221 = -1.46478417600e-6_r8 -real (r8), parameter :: b301 = -6.92888744480e-5_r8 -real (r8), parameter :: b311 = 1.03636901040e-5_r8 -real (r8), parameter :: b401 = 1.54637136265e-5_r8 -real (r8), parameter :: b002 = -5.84844329840e-7_r8 -real (r8), parameter :: b012 = -5.56991545570e-6_r8 -real (r8), parameter :: b022 = 3.91373870800e-7_r8 -real (r8), parameter :: b032 = 7.76188880920e-9_r8 -real (r8), parameter :: b102 = -9.62445031940e-6_r8 -real (r8), parameter :: b112 = 1.09241497668e-5_r8 -real (r8), parameter :: b122 = -1.31462208134e-6_r8 -real (r8), parameter :: b202 = 1.47789320994e-5_r8 -real (r8), parameter :: b212 = -4.06325568810e-6_r8 -real (r8), parameter :: b302 = -7.12478989080e-6_r8 - -real (r8), parameter :: c000 = -6.07991438090e-5_r8 -real (r8), parameter :: c001 = 1.99712338438e-5_r8 -real (r8), parameter :: c002 = -3.39280843110e-6_r8 -real (r8), parameter :: c003 = 4.21246123200e-7_r8 -real (r8), parameter :: c004 = -6.32363064300e-8_r8 -real (r8), parameter :: c005 = 1.17681023580e-8_r8 -real (r8), parameter :: c010 = 1.85057654290e-5_r8 -real (r8), parameter :: c011 = -2.34727734620e-6_r8 -real (r8), parameter :: c012 = -1.09581019659e-6_r8 -real (r8), parameter :: c013 = 1.25816399608e-6_r8 -real (r8), parameter :: c020 = -1.17166068530e-5_r8 -real (r8), parameter :: c021 = 4.26100574800e-6_r8 -real (r8), parameter :: c022 = 8.60877154770e-7_r8 -real (r8), parameter :: c030 = 7.92796561730e-6_r8 -real (r8), parameter :: c031 = -9.22650800740e-7_r8 -real (r8), parameter :: c040 = -3.41021874820e-6_r8 -real (r8), parameter :: c041 = -1.26705833028e-7_r8 -real (r8), parameter :: c050 = 5.07367668140e-7_r8 -real (r8), parameter :: c100 = 2.42624687470e-5_r8 -real (r8), parameter :: c101 = -1.16968865968e-6_r8 -real (r8), parameter :: c102 = 1.08930565545e-6_r8 -real (r8), parameter :: c103 = -4.45885016920e-7_r8 -real (r8), parameter :: c110 = -9.56770881560e-6_r8 -real (r8), parameter :: c111 = -1.11398309114e-5_r8 -real (r8), parameter :: c112 = -8.18870887110e-7_r8 -real (r8), parameter :: c120 = -2.36783083610e-7_r8 -real (r8), parameter :: c121 = 7.82747741600e-7_r8 -real (r8), parameter :: c130 = -3.45587736550e-6_r8 -real (r8), parameter :: c131 = 1.55237776184e-8_r8 -real (r8), parameter :: c140 = 1.29567177830e-6_r8 -real (r8), parameter :: c200 = -3.47924609740e-5_r8 -real (r8), parameter :: c201 = -9.62445031940e-6_r8 -real (r8), parameter :: c202 = 5.02389113400e-8_r8 -real (r8), parameter :: c210 = 1.11008347650e-5_r8 -real (r8), parameter :: c211 = 1.09241497668e-5_r8 -real (r8), parameter :: c220 = 2.92833462950e-6_r8 -real (r8), parameter :: c221 = -1.31462208134e-6_r8 -real (r8), parameter :: c230 = 3.16553060780e-7_r8 -real (r8), parameter :: c300 = 3.74707773050e-5_r8 -real (r8), parameter :: c301 = 9.85262139960e-6_r8 -real (r8), parameter :: c310 = -9.84471178440e-6_r8 -real (r8), parameter :: c311 = -2.70883712540e-6_r8 -real (r8), parameter :: c320 = -4.88261392000e-7_r8 -real (r8), parameter :: c400 = -1.73222186120e-5_r8 -real (r8), parameter :: c401 = -3.56239494540e-6_r8 -real (r8), parameter :: c410 = 2.59092252600e-6_r8 -real (r8), parameter :: c500 = 3.09274272530e-6_r8 - -real (r8), parameter :: h001 = 1.07699958620e-3_r8 -real (r8), parameter :: h002 = -3.03995719050e-5_r8 -real (r8), parameter :: h003 = 3.32853897400e-6_r8 -real (r8), parameter :: h004 = -2.82734035930e-7_r8 -real (r8), parameter :: h005 = 2.10623061600e-8_r8 -real (r8), parameter :: h006 = -2.10787688100e-9_r8 -real (r8), parameter :: h007 = 2.80192913290e-10_r8 -real (r8), parameter :: h011 = -1.56497346750e-5_r8 -real (r8), parameter :: h012 = 9.25288271450e-6_r8 -real (r8), parameter :: h013 = -3.91212891030e-7_r8 -real (r8), parameter :: h014 = -9.13175163830e-8_r8 -real (r8), parameter :: h015 = 6.29081998040e-8_r8 -real (r8), parameter :: h021 = 2.77621064840e-5_r8 -real (r8), parameter :: h022 = -5.85830342650e-6_r8 -real (r8), parameter :: h023 = 7.10167624670e-7_r8 -real (r8), parameter :: h024 = 7.17397628980e-8_r8 -real (r8), parameter :: h031 = -1.65211592590e-5_r8 -real (r8), parameter :: h032 = 3.96398280870e-6_r8 -real (r8), parameter :: h033 = -1.53775133460e-7_r8 -real (r8), parameter :: h042 = -1.70510937410e-6_r8 -real (r8), parameter :: h043 = -2.11176388380e-8_r8 -real (r8), parameter :: h041 = 6.91113227020e-6_r8 -real (r8), parameter :: h051 = -8.05396155400e-7_r8 -real (r8), parameter :: h052 = 2.53683834070e-7_r8 -real (r8), parameter :: h061 = 2.05430942680e-7_r8 -real (r8), parameter :: h101 = -3.10389819760e-4_r8 -real (r8), parameter :: h102 = 1.21312343735e-5_r8 -real (r8), parameter :: h103 = -1.94948109950e-7_r8 -real (r8), parameter :: h104 = 9.07754712880e-8_r8 -real (r8), parameter :: h105 = -2.22942508460e-8_r8 -real (r8), parameter :: h111 = 3.50095997640e-5_r8 -real (r8), parameter :: h112 = -4.78385440780e-6_r8 -real (r8), parameter :: h113 = -1.85663848520e-6_r8 -real (r8), parameter :: h114 = -6.82392405930e-8_r8 -real (r8), parameter :: h121 = -3.74358423440e-5_r8 -real (r8), parameter :: h122 = -1.18391541805e-7_r8 -real (r8), parameter :: h123 = 1.30457956930e-7_r8 -real (r8), parameter :: h131 = 2.41414794830e-5_r8 -real (r8), parameter :: h132 = -1.72793868275e-6_r8 -real (r8), parameter :: h133 = 2.58729626970e-9_r8 -real (r8), parameter :: h141 = -8.75958731540e-6_r8 -real (r8), parameter :: h142 = 6.47835889150e-7_r8 -real (r8), parameter :: h151 = -3.30527589000e-7_r8 -real (r8), parameter :: h201 = 6.69280670380e-4_r8 -real (r8), parameter :: h202 = -1.73962304870e-5_r8 -real (r8), parameter :: h203 = -1.60407505320e-6_r8 -real (r8), parameter :: h204 = 4.18657594500e-9_r8 -real (r8), parameter :: h211 = -4.35926785610e-5_r8 -real (r8), parameter :: h212 = 5.55041738250e-6_r8 -real (r8), parameter :: h213 = 1.82069162780e-6_r8 -real (r8), parameter :: h221 = 3.59078227600e-5_r8 -real (r8), parameter :: h222 = 1.46416731475e-6_r8 -real (r8), parameter :: h223 = -2.19103680220e-7_r8 -real (r8), parameter :: h231 = -1.43536330480e-5_r8 -real (r8), parameter :: h232 = 1.58276530390e-7_r8 -real (r8), parameter :: h241 = 4.37036805980e-6_r8 -real (r8), parameter :: h301 = -8.50479339370e-4_r8 -real (r8), parameter :: h302 = 1.87353886525e-5_r8 -real (r8), parameter :: h303 = 1.64210356660e-6_r8 -real (r8), parameter :: h311 = 3.45324618280e-5_r8 -real (r8), parameter :: h312 = -4.92235589220e-6_r8 -real (r8), parameter :: h313 = -4.51472854230e-7_r8 -real (r8), parameter :: h321 = -1.86985841870e-5_r8 -real (r8), parameter :: h322 = -2.44130696000e-7_r8 -real (r8), parameter :: h331 = 2.28633245560e-6_r8 -real (r8), parameter :: h401 = 5.80860699430e-4_r8 -real (r8), parameter :: h402 = -8.66110930600e-6_r8 -real (r8), parameter :: h403 = -5.93732490900e-7_r8 -real (r8), parameter :: h411 = -1.19594097880e-5_r8 -real (r8), parameter :: h421 = 3.85953392440e-6_r8 -real (r8), parameter :: h412 = 1.29546126300e-6_r8 -real (r8), parameter :: h501 = -2.10923705070e-4_r8 -real (r8), parameter :: h502 = 1.54637136265e-6_r8 -real (r8), parameter :: h511 = 1.38645945810e-6_r8 -real (r8), parameter :: h601 = 3.19324573050e-5_r8 - -real (r8), parameter :: v000 = 1.0769995862e-3_r8 -real (r8), parameter :: v001 = -6.0799143809e-5_r8 -real (r8), parameter :: v002 = 9.9856169219e-6_r8 -real (r8), parameter :: v003 = -1.1309361437e-6_r8 -real (r8), parameter :: v004 = 1.0531153080e-7_r8 -real (r8), parameter :: v005 = -1.2647261286e-8_r8 -real (r8), parameter :: v006 = 1.9613503930e-9_r8 -real (r8), parameter :: v010 = -3.1038981976e-4_r8 -real (r8), parameter :: v011 = 2.4262468747e-5_r8 -real (r8), parameter :: v012 = -5.8484432984e-7_r8 -real (r8), parameter :: v013 = 3.6310188515e-7_r8 -real (r8), parameter :: v014 = -1.1147125423e-7_r8 -real (r8), parameter :: v020 = 6.6928067038e-4_r8 -real (r8), parameter :: v021 = -3.4792460974e-5_r8 -real (r8), parameter :: v022 = -4.8122251597e-6_r8 -real (r8), parameter :: v023 = 1.6746303780e-8_r8 -real (r8), parameter :: v030 = -8.5047933937e-4_r8 -real (r8), parameter :: v031 = 3.7470777305e-5_r8 -real (r8), parameter :: v032 = 4.9263106998e-6_r8 -real (r8), parameter :: v040 = 5.8086069943e-4_r8 -real (r8), parameter :: v041 = -1.7322218612e-5_r8 -real (r8), parameter :: v042 = -1.7811974727e-6_r8 -real (r8), parameter :: v050 = -2.1092370507e-4_r8 -real (r8), parameter :: v051 = 3.0927427253e-6_r8 -real (r8), parameter :: v060 = 3.1932457305e-5_r8 -real (r8), parameter :: v100 = -1.5649734675e-5_r8 -real (r8), parameter :: v101 = 1.8505765429e-5_r8 -real (r8), parameter :: v102 = -1.1736386731e-6_r8 -real (r8), parameter :: v103 = -3.6527006553e-7_r8 -real (r8), parameter :: v104 = 3.1454099902e-7_r8 -real (r8), parameter :: v110 = 3.5009599764e-5_r8 -real (r8), parameter :: v111 = -9.5677088156e-6_r8 -real (r8), parameter :: v112 = -5.5699154557e-6_r8 -real (r8), parameter :: v113 = -2.7295696237e-7_r8 -real (r8), parameter :: v120 = -4.3592678561e-5_r8 -real (r8), parameter :: v121 = 1.1100834765e-5_r8 -real (r8), parameter :: v122 = 5.4620748834e-6_r8 -real (r8), parameter :: v130 = 3.4532461828e-5_r8 -real (r8), parameter :: v131 = -9.8447117844e-6_r8 -real (r8), parameter :: v132 = -1.3544185627e-6_r8 -real (r8), parameter :: v140 = -1.1959409788e-5_r8 -real (r8), parameter :: v141 = 2.5909225260e-6_r8 -real (r8), parameter :: v150 = 1.3864594581e-6_r8 -real (r8), parameter :: v200 = 2.7762106484e-5_r8 -real (r8), parameter :: v201 = -1.1716606853e-5_r8 -real (r8), parameter :: v202 = 2.1305028740e-6_r8 -real (r8), parameter :: v203 = 2.8695905159e-7_r8 -real (r8), parameter :: v210 = -3.7435842344e-5_r8 -real (r8), parameter :: v211 = -2.3678308361e-7_r8 -real (r8), parameter :: v212 = 3.9137387080e-7_r8 -real (r8), parameter :: v220 = 3.5907822760e-5_r8 -real (r8), parameter :: v221 = 2.9283346295e-6_r8 -real (r8), parameter :: v222 = -6.5731104067e-7_r8 -real (r8), parameter :: v230 = -1.8698584187e-5_r8 -real (r8), parameter :: v231 = -4.8826139200e-7_r8 -real (r8), parameter :: v240 = 3.8595339244e-6_r8 -real (r8), parameter :: v300 = -1.6521159259e-5_r8 -real (r8), parameter :: v301 = 7.9279656173e-6_r8 -real (r8), parameter :: v302 = -4.6132540037e-7_r8 -real (r8), parameter :: v310 = 2.4141479483e-5_r8 -real (r8), parameter :: v311 = -3.4558773655e-6_r8 -real (r8), parameter :: v312 = 7.7618888092e-9_r8 -real (r8), parameter :: v320 = -1.4353633048e-5_r8 -real (r8), parameter :: v321 = 3.1655306078e-7_r8 -real (r8), parameter :: v330 = 2.2863324556e-6_r8 -real (r8), parameter :: v400 = 6.9111322702e-6_r8 -real (r8), parameter :: v401 = -3.4102187482e-6_r8 -real (r8), parameter :: v402 = -6.3352916514e-8_r8 -real (r8), parameter :: v410 = -8.7595873154e-6_r8 -real (r8), parameter :: v411 = 1.2956717783e-6_r8 -real (r8), parameter :: v420 = 4.3703680598e-6_r8 -real (r8), parameter :: v500 = -8.0539615540e-7_r8 -real (r8), parameter :: v501 = 5.0736766814e-7_r8 -real (r8), parameter :: v510 = -3.3052758900e-7_r8 -real (r8), parameter :: v600 = 2.0543094268e-7_r8 - -end module - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_mod_specvol_coefficients.f90 b/src/equation_of_state/TEOS10/gsw_mod_specvol_coefficients.f90 new file mode 120000 index 0000000000..934f689c20 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_mod_specvol_coefficients.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/modules/gsw_mod_specvol_coefficients.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_mod_teos10_constants.f90 b/src/equation_of_state/TEOS10/gsw_mod_teos10_constants.f90 deleted file mode 100644 index e3c6afbce0..0000000000 --- a/src/equation_of_state/TEOS10/gsw_mod_teos10_constants.f90 +++ /dev/null @@ -1,71 +0,0 @@ -!========================================================================== -module gsw_mod_teos10_constants -!========================================================================== - -use gsw_mod_kinds - -implicit none - -real (r8), parameter :: db2pa = 1.0e4_r8 -real (r8), parameter :: rec_db2pa = 1.0e-4_r8 - -real (r8), parameter :: pa2db = 1.0e-4_r8 -real (r8), parameter :: rec_pa2db = 1.0e4_r8 - -real (r8), parameter :: pi = 3.141592653589793_r8 -real (r8), parameter :: deg2rad = pi/180.0_r8 -real (r8), parameter :: rad2deg = 180.0_r8/pi - -real (r8), parameter :: gamma = 2.26e-7_r8 - -! cp0 = The "specific heat" for use [ J/(kg K) ] -! with Conservative Temperature - -real (r8), parameter :: gsw_cp0 = 3991.86795711963_r8 - -! T0 = the Celcius zero point. [ K ] - -real (r8), parameter :: gsw_t0 = 273.15_r8 - -! P0 = Absolute Pressure of one standard atmosphere. [ Pa ] - -real (r8), parameter :: gsw_p0 = 101325.0_r8 - -! SSO = Standard Ocean Reference Salinity. [ g/kg ] - -real (r8), parameter :: gsw_sso = 35.16504_r8 -real (r8), parameter :: gsw_sqrtsso = 5.930011804372737_r8 - -! uPS = unit conversion factor for salinities [ g/kg ] - -real (r8), parameter :: gsw_ups = gsw_sso/35.0_r8 - -! sfac = 1/(40*gsw_ups) - -real (r8), parameter :: gsw_sfac = 0.0248826675584615_r8 - -! deltaS = 24, offset = deltaS*gsw_sfac - -real (r8), parameter :: offset = 5.971840214030754e-1_r8 - -! C3515 = Conductivity at (SP=35, t_68=15, p=0) [ mS/cm ] - -real (r8), parameter :: gsw_c3515 = 42.9140_r8 - -! SonCl = SP to Chlorinity ratio [ (g/kg)^-1 ] - -real (r8), parameter :: gsw_soncl = 1.80655_r8 - -! valence_factor = valence factor of sea salt of Reference Composition -! [ unitless ] - -real (r8), parameter :: gsw_valence_factor = 1.2452898_r8 - -! atomic_weight = mole-weighted atomic weight of sea salt of Reference -! Composition [ g/mol ] - -real (r8), parameter :: gsw_atomic_weight = 31.4038218_r8 - -end module - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_mod_teos10_constants.f90 b/src/equation_of_state/TEOS10/gsw_mod_teos10_constants.f90 new file mode 120000 index 0000000000..17dec5add5 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_mod_teos10_constants.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/modules/gsw_mod_teos10_constants.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_mod_toolbox.f90 b/src/equation_of_state/TEOS10/gsw_mod_toolbox.f90 deleted file mode 100644 index a8012e1274..0000000000 --- a/src/equation_of_state/TEOS10/gsw_mod_toolbox.f90 +++ /dev/null @@ -1,1493 +0,0 @@ -module gsw_mod_toolbox - -use gsw_mod_kinds - -implicit none - -public :: gsw_add_barrier -public :: gsw_add_mean -public :: gsw_adiabatic_lapse_rate_from_ct -public :: gsw_adiabatic_lapse_rate_ice -public :: gsw_alpha -public :: gsw_alpha_on_beta -public :: gsw_alpha_wrt_t_exact -public :: gsw_alpha_wrt_t_ice -public :: gsw_beta_const_t_exact -public :: gsw_beta -public :: gsw_cabbeling -public :: gsw_c_from_sp -public :: gsw_chem_potential_water_ice -public :: gsw_chem_potential_water_t_exact -public :: gsw_cp_ice -public :: gsw_ct_first_derivatives -public :: gsw_ct_first_derivatives_wrt_t_exact -public :: gsw_ct_freezing_exact -public :: gsw_ct_freezing -public :: gsw_ct_freezing_first_derivatives -public :: gsw_ct_freezing_first_derivatives_poly -public :: gsw_ct_freezing_poly -public :: gsw_ct_from_enthalpy_exact -public :: gsw_ct_from_enthalpy -public :: gsw_ct_from_entropy -public :: gsw_ct_from_pt -public :: gsw_ct_from_rho -public :: gsw_ct_from_t -public :: gsw_ct_maxdensity -public :: gsw_ct_second_derivatives -public :: gsw_deltasa_atlas -public :: gsw_deltasa_from_sp -public :: gsw_dilution_coefficient_t_exact -public :: gsw_dynamic_enthalpy -public :: gsw_enthalpy_ct_exact -public :: gsw_enthalpy_diff -public :: gsw_enthalpy -public :: gsw_enthalpy_first_derivatives_ct_exact -public :: gsw_enthalpy_first_derivatives -public :: gsw_enthalpy_ice -public :: gsw_enthalpy_second_derivatives_ct_exact -public :: gsw_enthalpy_second_derivatives -public :: gsw_enthalpy_sso_0 -public :: gsw_enthalpy_t_exact -public :: gsw_entropy_first_derivatives -public :: gsw_entropy_from_pt -public :: gsw_entropy_from_t -public :: gsw_entropy_ice -public :: gsw_entropy_part -public :: gsw_entropy_part_zerop -public :: gsw_entropy_second_derivatives -public :: gsw_fdelta -public :: gsw_frazil_properties -public :: gsw_frazil_properties_potential -public :: gsw_frazil_properties_potential_poly -public :: gsw_frazil_ratios_adiabatic -public :: gsw_frazil_ratios_adiabatic_poly -public :: gsw_geo_strf_dyn_height -public :: gsw_geo_strf_dyn_height_pc -public :: gsw_gibbs -public :: gsw_gibbs_ice -public :: gsw_gibbs_ice_part_t -public :: gsw_gibbs_ice_pt0 -public :: gsw_gibbs_ice_pt0_pt0 -public :: gsw_gibbs_pt0_pt0 -public :: gsw_grav -public :: gsw_helmholtz_energy_ice -public :: gsw_hill_ratio_at_sp2 -public :: gsw_ice_fraction_to_freeze_seawater -public :: gsw_internal_energy -public :: gsw_internal_energy_ice -public :: gsw_ipv_vs_fnsquared_ratio -public :: gsw_kappa_const_t_ice -public :: gsw_kappa -public :: gsw_kappa_ice -public :: gsw_kappa_t_exact -public :: gsw_latentheat_evap_ct -public :: gsw_latentheat_evap_t -public :: gsw_latentheat_melting -public :: gsw_linear_interp_sa_ct -public :: gsw_melting_ice_equilibrium_sa_ct_ratio -public :: gsw_melting_ice_equilibrium_sa_ct_ratio_poly -public :: gsw_melting_ice_into_seawater -public :: gsw_melting_ice_sa_ct_ratio -public :: gsw_melting_ice_sa_ct_ratio_poly -public :: gsw_melting_seaice_equilibrium_sa_ct_ratio -public :: gsw_melting_seaice_equilibrium_sa_ct_ratio_poly -public :: gsw_melting_seaice_into_seawater -public :: gsw_melting_seaice_sa_ct_ratio -public :: gsw_melting_seaice_sa_ct_ratio_poly -public :: gsw_nsquared -public :: gsw_pot_enthalpy_from_pt_ice -public :: gsw_pot_enthalpy_from_pt_ice_poly -public :: gsw_pot_enthalpy_ice_freezing -public :: gsw_pot_enthalpy_ice_freezing_first_derivatives -public :: gsw_pot_enthalpy_ice_freezing_first_derivatives_poly -public :: gsw_pot_enthalpy_ice_freezing_poly -public :: gsw_pot_rho_t_exact -public :: gsw_pressure_coefficient_ice -public :: gsw_pressure_freezing_ct -public :: gsw_pt0_cold_ice_poly -public :: gsw_pt0_from_t -public :: gsw_pt0_from_t_ice -public :: gsw_pt_first_derivatives -public :: gsw_pt_from_ct -public :: gsw_pt_from_entropy -public :: gsw_pt_from_pot_enthalpy_ice -public :: gsw_pt_from_pot_enthalpy_ice_poly_dh -public :: gsw_pt_from_pot_enthalpy_ice_poly -public :: gsw_pt_from_t -public :: gsw_pt_from_t_ice -public :: gsw_pt_second_derivatives -public :: gsw_rho_alpha_beta -public :: gsw_rho -public :: gsw_rho_first_derivatives -public :: gsw_rho_first_derivatives_wrt_enthalpy -public :: gsw_rho_ice -public :: gsw_rho_second_derivatives -public :: gsw_rho_second_derivatives_wrt_enthalpy -public :: gsw_rho_t_exact -public :: gsw_rr68_interp_sa_ct -public :: gsw_saar -public :: gsw_sa_freezing_estimate -public :: gsw_sa_freezing_from_ct -public :: gsw_sa_freezing_from_ct_poly -public :: gsw_sa_freezing_from_t -public :: gsw_sa_freezing_from_t_poly -public :: gsw_sa_from_rho -public :: gsw_sa_from_sp_baltic -public :: gsw_sa_from_sp -public :: gsw_sa_from_sstar -public :: gsw_sa_p_inrange -public :: gsw_seaice_fraction_to_freeze_seawater -public :: gsw_sigma0 -public :: gsw_sigma1 -public :: gsw_sigma2 -public :: gsw_sigma3 -public :: gsw_sigma4 -public :: gsw_sound_speed -public :: gsw_sound_speed_ice -public :: gsw_sound_speed_t_exact -public :: gsw_specvol_alpha_beta -public :: gsw_specvol_anom_standard -public :: gsw_specvol -public :: gsw_specvol_first_derivatives -public :: gsw_specvol_first_derivatives_wrt_enthalpy -public :: gsw_specvol_ice -public :: gsw_specvol_second_derivatives -public :: gsw_specvol_second_derivatives_wrt_enthalpy -public :: gsw_specvol_sso_0 -public :: gsw_specvol_t_exact -public :: gsw_sp_from_c -public :: gsw_sp_from_sa_baltic -public :: gsw_sp_from_sa -public :: gsw_sp_from_sk -public :: gsw_sp_from_sr -public :: gsw_sp_from_sstar -public :: gsw_spiciness0 -public :: gsw_spiciness1 -public :: gsw_spiciness2 -public :: gsw_sr_from_sp -public :: gsw_sstar_from_sa -public :: gsw_sstar_from_sp -public :: gsw_t_deriv_chem_potential_water_t_exact -public :: gsw_t_freezing_exact -public :: gsw_t_freezing -public :: gsw_t_freezing_first_derivatives -public :: gsw_t_freezing_first_derivatives_poly -public :: gsw_t_freezing_poly -public :: gsw_t_from_ct -public :: gsw_t_from_pt0_ice -public :: gsw_thermobaric -public :: gsw_turner_rsubrho -public :: gsw_util_indx -public :: gsw_util_interp1q_int -public :: gsw_util_sort_real -public :: gsw_util_xinterp1 -public :: gsw_z_from_p - -interface - - pure subroutine gsw_add_barrier (input_data, long, lat, long_grid, & - lat_grid, dlong_grid, dlat_grid, output_data) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: long, lat, long_grid, lat_grid, dlong_grid - real (r8), intent(in) :: dlat_grid - real (r8), intent(in), dimension(4) :: input_data - real (r8), intent(out), dimension(4) :: output_data - end subroutine gsw_add_barrier - - pure subroutine gsw_add_mean (data_in, data_out) - use gsw_mod_kinds - implicit none - real (r8), intent(in), dimension(4) :: data_in - real (r8), intent(out), dimension(4) :: data_out - end subroutine gsw_add_mean - - elemental function gsw_adiabatic_lapse_rate_from_ct (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_adiabatic_lapse_rate_from_ct - end function gsw_adiabatic_lapse_rate_from_ct - - elemental function gsw_adiabatic_lapse_rate_ice (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_adiabatic_lapse_rate_ice - end function gsw_adiabatic_lapse_rate_ice - - elemental function gsw_alpha (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_alpha - end function gsw_alpha - - elemental function gsw_alpha_on_beta (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_alpha_on_beta - end function gsw_alpha_on_beta - - elemental function gsw_alpha_wrt_t_exact (sa, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p - real (r8) :: gsw_alpha_wrt_t_exact - end function gsw_alpha_wrt_t_exact - - elemental function gsw_alpha_wrt_t_ice (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_alpha_wrt_t_ice - end function gsw_alpha_wrt_t_ice - - elemental function gsw_beta_const_t_exact (sa, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p - real (r8) :: gsw_beta_const_t_exact - end function gsw_beta_const_t_exact - - elemental function gsw_beta (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_beta - end function gsw_beta - - elemental function gsw_cabbeling (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_cabbeling - end function gsw_cabbeling - - elemental function gsw_c_from_sp (sp, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sp, t, p - real (r8) :: gsw_c_from_sp - end function gsw_c_from_sp - - elemental function gsw_chem_potential_water_ice (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_chem_potential_water_ice - end function gsw_chem_potential_water_ice - - elemental function gsw_chem_potential_water_t_exact (sa, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p - real (r8) :: gsw_chem_potential_water_t_exact - end function gsw_chem_potential_water_t_exact - - elemental function gsw_cp_ice (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_cp_ice - end function gsw_cp_ice - - elemental subroutine gsw_ct_first_derivatives (sa, pt, ct_sa, ct_pt) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, pt - real (r8), intent(out), optional :: ct_sa, ct_pt - end subroutine gsw_ct_first_derivatives - - elemental subroutine gsw_ct_first_derivatives_wrt_t_exact (sa, t, p, & - ct_sa_wrt_t, ct_t_wrt_t, ct_p_wrt_t) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p - real (r8), intent(out), optional :: ct_p_wrt_t, ct_sa_wrt_t, ct_t_wrt_t - end subroutine gsw_ct_first_derivatives_wrt_t_exact - - elemental function gsw_ct_freezing_exact (sa, p, saturation_fraction) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p, saturation_fraction - real (r8) :: gsw_ct_freezing_exact - end function gsw_ct_freezing_exact - - elemental function gsw_ct_freezing (sa, p, saturation_fraction, poly) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p, saturation_fraction - logical, intent(in), optional :: poly - real (r8) :: gsw_ct_freezing - end function gsw_ct_freezing - - elemental subroutine gsw_ct_freezing_first_derivatives (sa, p, & - saturation_fraction, ctfreezing_sa, ctfreezing_p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p, saturation_fraction - real (r8), intent(out), optional :: ctfreezing_sa, ctfreezing_p - end subroutine gsw_ct_freezing_first_derivatives - - elemental subroutine gsw_ct_freezing_first_derivatives_poly (sa, p, & - saturation_fraction, ctfreezing_sa, ctfreezing_p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p, saturation_fraction - real (r8), intent(out), optional :: ctfreezing_sa, ctfreezing_p - end subroutine gsw_ct_freezing_first_derivatives_poly - - elemental function gsw_ct_freezing_poly (sa, p, saturation_fraction) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p, saturation_fraction - real (r8) :: gsw_ct_freezing_poly - end function gsw_ct_freezing_poly - - elemental function gsw_ct_from_enthalpy_exact (sa, h, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, h, p - real (r8) :: gsw_ct_from_enthalpy_exact - end function gsw_ct_from_enthalpy_exact - - elemental function gsw_ct_from_enthalpy (sa, h, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, h, p - real (r8) :: gsw_ct_from_enthalpy - end function gsw_ct_from_enthalpy - - elemental function gsw_ct_from_entropy (sa, entropy) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, entropy - real (r8) :: gsw_ct_from_entropy - end function gsw_ct_from_entropy - - elemental function gsw_ct_from_pt (sa, pt) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, pt - real (r8) :: gsw_ct_from_pt - end function gsw_ct_from_pt - - elemental subroutine gsw_ct_from_rho (rho, sa, p, ct, ct_multiple) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: rho, sa, p - real (r8), intent(out) :: ct - real (r8), intent(out), optional :: ct_multiple - end subroutine gsw_ct_from_rho - - elemental function gsw_ct_from_t (sa, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p - real (r8) :: gsw_ct_from_t - end function gsw_ct_from_t - - elemental function gsw_ct_maxdensity (sa, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p - real (r8) :: gsw_ct_maxdensity - end function gsw_ct_maxdensity - - elemental subroutine gsw_ct_second_derivatives (sa, pt, ct_sa_sa, ct_sa_pt, & - ct_pt_pt) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, pt - real (r8), intent(out), optional :: ct_sa_sa, ct_sa_pt, ct_pt_pt - end subroutine gsw_ct_second_derivatives - - elemental function gsw_deltasa_atlas (p, long, lat) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: p, long, lat - real (r8) :: gsw_deltasa_atlas - end function gsw_deltasa_atlas - - elemental function gsw_deltasa_from_sp (sp, p, long, lat) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sp, p, long, lat - real (r8) :: gsw_deltasa_from_sp - end function gsw_deltasa_from_sp - - elemental function gsw_dilution_coefficient_t_exact (sa, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p - real (r8) :: gsw_dilution_coefficient_t_exact - end function gsw_dilution_coefficient_t_exact - - elemental function gsw_dynamic_enthalpy (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_dynamic_enthalpy - end function gsw_dynamic_enthalpy - - elemental function gsw_enthalpy_ct_exact (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_enthalpy_ct_exact - end function gsw_enthalpy_ct_exact - - elemental function gsw_enthalpy_diff (sa, ct, p_shallow, p_deep) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p_shallow, p_deep - real (r8) :: gsw_enthalpy_diff - end function gsw_enthalpy_diff - - elemental function gsw_enthalpy (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_enthalpy - end function gsw_enthalpy - - elemental subroutine gsw_enthalpy_first_derivatives_ct_exact (sa, ct, p, & - h_sa, h_ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8), intent(out), optional :: h_sa, h_ct - end subroutine gsw_enthalpy_first_derivatives_ct_exact - - elemental subroutine gsw_enthalpy_first_derivatives (sa, ct, p, h_sa, h_ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8), intent(out), optional :: h_sa, h_ct - end subroutine gsw_enthalpy_first_derivatives - - elemental function gsw_enthalpy_ice (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_enthalpy_ice - end function gsw_enthalpy_ice - - elemental subroutine gsw_enthalpy_second_derivatives_ct_exact (sa, ct, p, & - h_sa_sa, h_sa_ct, h_ct_ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8), intent(out), optional :: h_sa_sa, h_sa_ct, h_ct_ct - end subroutine gsw_enthalpy_second_derivatives_ct_exact - - elemental subroutine gsw_enthalpy_second_derivatives (sa, ct, p, h_sa_sa, & - h_sa_ct, h_ct_ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8), intent(out), optional :: h_sa_sa, h_sa_ct, h_ct_ct - end subroutine gsw_enthalpy_second_derivatives - - elemental function gsw_enthalpy_sso_0 (p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: p - real (r8) :: gsw_enthalpy_sso_0 - end function gsw_enthalpy_sso_0 - - elemental function gsw_enthalpy_t_exact (sa, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p - real (r8) :: gsw_enthalpy_t_exact - end function gsw_enthalpy_t_exact - - elemental subroutine gsw_entropy_first_derivatives (sa, ct, eta_sa, eta_ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct - real (r8), intent(out), optional :: eta_sa, eta_ct - end subroutine gsw_entropy_first_derivatives - - elemental function gsw_entropy_from_pt (sa, pt) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, pt - real (r8) :: gsw_entropy_from_pt - end function gsw_entropy_from_pt - - elemental function gsw_entropy_from_t (sa, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p - real (r8) :: gsw_entropy_from_t - end function gsw_entropy_from_t - - elemental function gsw_entropy_ice (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_entropy_ice - end function gsw_entropy_ice - - elemental function gsw_entropy_part (sa, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p - real (r8) :: gsw_entropy_part - end function gsw_entropy_part - - elemental function gsw_entropy_part_zerop (sa, pt0) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, pt0 - real (r8) :: gsw_entropy_part_zerop - end function gsw_entropy_part_zerop - - elemental subroutine gsw_entropy_second_derivatives (sa, ct, eta_sa_sa, & - eta_sa_ct, eta_ct_ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct - real (r8), intent(out), optional :: eta_sa_sa, eta_sa_ct, eta_ct_ct - end subroutine gsw_entropy_second_derivatives - - elemental function gsw_fdelta (p, long, lat) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: p, long, lat - real (r8) :: gsw_fdelta - end function gsw_fdelta - - elemental subroutine gsw_frazil_properties (sa_bulk, h_bulk, p, & - sa_final, ct_final, w_ih_final) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa_bulk, h_bulk, p - real (r8), intent(out) :: sa_final, ct_final, w_ih_final - end subroutine gsw_frazil_properties - - elemental subroutine gsw_frazil_properties_potential (sa_bulk, h_pot_bulk,& - p, sa_final, ct_final, w_ih_final) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa_bulk, h_pot_bulk, p - real (r8), intent(out) :: sa_final, ct_final, w_ih_final - end subroutine gsw_frazil_properties_potential - - elemental subroutine gsw_frazil_properties_potential_poly (sa_bulk, & - h_pot_bulk, p, sa_final, ct_final, w_ih_final) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa_bulk, h_pot_bulk, p - real (r8), intent(out) :: sa_final, ct_final, w_ih_final - end subroutine gsw_frazil_properties_potential_poly - - elemental subroutine gsw_frazil_ratios_adiabatic (sa, p, w_ih, & - dsa_dct_frazil, dsa_dp_frazil, dct_dp_frazil) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p, w_ih - real (r8), intent(out) :: dsa_dct_frazil, dsa_dp_frazil, dct_dp_frazil - end subroutine gsw_frazil_ratios_adiabatic - - elemental subroutine gsw_frazil_ratios_adiabatic_poly (sa, p, w_ih, & - dsa_dct_frazil, dsa_dp_frazil, dct_dp_frazil) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p, w_ih - real (r8), intent(out) :: dsa_dct_frazil, dsa_dp_frazil, dct_dp_frazil - end subroutine gsw_frazil_ratios_adiabatic_poly - - pure function gsw_geo_strf_dyn_height (sa, ct, p, p_ref) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa(:), ct(:), p(:), p_ref - real (r8) :: gsw_geo_strf_dyn_height(size(sa)) - end function gsw_geo_strf_dyn_height - - pure subroutine gsw_geo_strf_dyn_height_pc (sa, ct, delta_p, & - geo_strf_dyn_height_pc, p_mid) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa(:), ct(:), delta_p(:) - real (r8), intent(out) :: geo_strf_dyn_height_pc(:), p_mid(:) - end subroutine gsw_geo_strf_dyn_height_pc - - elemental function gsw_gibbs (ns, nt, np, sa, t, p) - use gsw_mod_kinds - implicit none - integer, intent(in) :: ns, nt, np - real (r8), intent(in) :: sa, t, p - real (r8) :: gsw_gibbs - end function gsw_gibbs - - elemental function gsw_gibbs_ice (nt, np, t, p) - use gsw_mod_kinds - implicit none - integer, intent(in) :: nt, np - real (r8), intent(in) :: t, p - real (r8) :: gsw_gibbs_ice - end function gsw_gibbs_ice - - elemental function gsw_gibbs_ice_part_t (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_gibbs_ice_part_t - end function gsw_gibbs_ice_part_t - - elemental function gsw_gibbs_ice_pt0 (pt0) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: pt0 - real (r8) :: gsw_gibbs_ice_pt0 - end function gsw_gibbs_ice_pt0 - - elemental function gsw_gibbs_ice_pt0_pt0 (pt0) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: pt0 - real (r8) :: gsw_gibbs_ice_pt0_pt0 - end function gsw_gibbs_ice_pt0_pt0 - - elemental function gsw_gibbs_pt0_pt0 (sa, pt0) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, pt0 - real (r8) :: gsw_gibbs_pt0_pt0 - end function gsw_gibbs_pt0_pt0 - - elemental function gsw_grav (lat, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: lat, p - real (r8) :: gsw_grav - end function gsw_grav - - elemental function gsw_helmholtz_energy_ice (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_helmholtz_energy_ice - end function gsw_helmholtz_energy_ice - - elemental function gsw_hill_ratio_at_sp2 (t) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t - real (r8) :: gsw_hill_ratio_at_sp2 - end function gsw_hill_ratio_at_sp2 - - elemental subroutine gsw_ice_fraction_to_freeze_seawater (sa, ct, p, & - t_ih, sa_freeze, ct_freeze, w_ih) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p, t_ih - real (r8), intent(out) :: sa_freeze, ct_freeze, w_ih - end subroutine gsw_ice_fraction_to_freeze_seawater - - elemental function gsw_internal_energy (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_internal_energy - end function gsw_internal_energy - - elemental function gsw_internal_energy_ice (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_internal_energy_ice - end function gsw_internal_energy_ice - - pure subroutine gsw_ipv_vs_fnsquared_ratio (sa, ct, p, p_ref, & - ipv_vs_fnsquared_ratio, p_mid) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa(:), ct(:), p(:), p_ref - real (r8), intent(out) :: ipv_vs_fnsquared_ratio(:), p_mid(:) - end subroutine gsw_ipv_vs_fnsquared_ratio - - elemental function gsw_kappa_const_t_ice (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_kappa_const_t_ice - end function gsw_kappa_const_t_ice - - elemental function gsw_kappa (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_kappa - end function gsw_kappa - - elemental function gsw_kappa_ice (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_kappa_ice - end function gsw_kappa_ice - - elemental function gsw_kappa_t_exact (sa, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p - real (r8) :: gsw_kappa_t_exact - end function gsw_kappa_t_exact - - elemental function gsw_latentheat_evap_ct (sa, ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct - real (r8) :: gsw_latentheat_evap_ct - end function gsw_latentheat_evap_ct - - elemental function gsw_latentheat_evap_t (sa, t) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t - real (r8) :: gsw_latentheat_evap_t - end function gsw_latentheat_evap_t - - elemental function gsw_latentheat_melting (sa, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p - real (r8) :: gsw_latentheat_melting - end function gsw_latentheat_melting - - pure subroutine gsw_linear_interp_sa_ct (sa, ct, p, p_i, sa_i, ct_i) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa(:), ct(:), p(:), p_i(:) - real (r8), intent(out) :: sa_i(:), ct_i(:) - end subroutine gsw_linear_interp_sa_ct - - elemental function gsw_melting_ice_equilibrium_sa_ct_ratio (sa, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p - real (r8) :: gsw_melting_ice_equilibrium_sa_ct_ratio - end function gsw_melting_ice_equilibrium_sa_ct_ratio - - elemental function gsw_melting_ice_equilibrium_sa_ct_ratio_poly (sa, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p - real (r8) :: gsw_melting_ice_equilibrium_sa_ct_ratio_poly - end function gsw_melting_ice_equilibrium_sa_ct_ratio_poly - - elemental subroutine gsw_melting_ice_into_seawater (sa, ct, p, w_ih, t_ih,& - sa_final, ct_final, w_ih_final) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p, w_ih, t_ih - real (r8), intent(out) :: sa_final, ct_final, w_ih_final - end subroutine gsw_melting_ice_into_seawater - - elemental function gsw_melting_ice_sa_ct_ratio (sa, ct, p, t_ih) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p, t_ih - real (r8) :: gsw_melting_ice_sa_ct_ratio - end function gsw_melting_ice_sa_ct_ratio - - elemental function gsw_melting_ice_sa_ct_ratio_poly (sa, ct, p, t_ih) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p, t_ih - real (r8) :: gsw_melting_ice_sa_ct_ratio_poly - end function gsw_melting_ice_sa_ct_ratio_poly - - elemental function gsw_melting_seaice_equilibrium_sa_ct_ratio (sa, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p - real (r8) :: gsw_melting_seaice_equilibrium_sa_ct_ratio - end function gsw_melting_seaice_equilibrium_sa_ct_ratio - - elemental function gsw_melting_seaice_equilibrium_sa_ct_ratio_poly (sa, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p - real (r8) :: gsw_melting_seaice_equilibrium_sa_ct_ratio_poly - end function gsw_melting_seaice_equilibrium_sa_ct_ratio_poly - - elemental subroutine gsw_melting_seaice_into_seawater (sa, ct, p, & - w_seaice, sa_seaice, t_seaice, sa_final, ct_final) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p, w_seaice, sa_seaice, t_seaice - real (r8), intent(out) :: sa_final, ct_final - end subroutine gsw_melting_seaice_into_seawater - - elemental function gsw_melting_seaice_sa_ct_ratio (sa, ct, p, sa_seaice, & - t_seaice) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p, sa_seaice, t_seaice - real (r8) :: gsw_melting_seaice_sa_ct_ratio - end function gsw_melting_seaice_sa_ct_ratio - - elemental function gsw_melting_seaice_sa_ct_ratio_poly (sa, ct, p, & - sa_seaice, t_seaice) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p, sa_seaice, t_seaice - real (r8) :: gsw_melting_seaice_sa_ct_ratio_poly - end function gsw_melting_seaice_sa_ct_ratio_poly - - pure subroutine gsw_nsquared (sa, ct, p, lat, n2, p_mid) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa(:), ct(:), p(:), lat(:) - real (r8), intent(out) :: n2(:), p_mid(:) - end subroutine gsw_nsquared - - elemental function gsw_pot_enthalpy_from_pt_ice (pt0_ice) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: pt0_ice - real (r8) :: gsw_pot_enthalpy_from_pt_ice - end function gsw_pot_enthalpy_from_pt_ice - - elemental function gsw_pot_enthalpy_from_pt_ice_poly (pt0_ice) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: pt0_ice - real (r8) :: gsw_pot_enthalpy_from_pt_ice_poly - end function gsw_pot_enthalpy_from_pt_ice_poly - - elemental function gsw_pot_enthalpy_ice_freezing (sa, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p - real (r8) :: gsw_pot_enthalpy_ice_freezing - end function gsw_pot_enthalpy_ice_freezing - - elemental subroutine gsw_pot_enthalpy_ice_freezing_first_derivatives (sa, & - p, pot_enthalpy_ice_freezing_sa, pot_enthalpy_ice_freezing_p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p - real (r8), intent(out), optional :: pot_enthalpy_ice_freezing_sa - real (r8), intent(out), optional :: pot_enthalpy_ice_freezing_p - end subroutine gsw_pot_enthalpy_ice_freezing_first_derivatives - - elemental subroutine gsw_pot_enthalpy_ice_freezing_first_derivatives_poly(& - sa, p, pot_enthalpy_ice_freezing_sa, pot_enthalpy_ice_freezing_p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p - real (r8), intent(out), optional :: pot_enthalpy_ice_freezing_sa - real (r8), intent(out), optional :: pot_enthalpy_ice_freezing_p - end subroutine gsw_pot_enthalpy_ice_freezing_first_derivatives_poly - - elemental function gsw_pot_enthalpy_ice_freezing_poly (sa, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p - real (r8) :: gsw_pot_enthalpy_ice_freezing_poly - end function gsw_pot_enthalpy_ice_freezing_poly - - elemental function gsw_pot_rho_t_exact (sa, t, p, p_ref) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p, p_ref - real (r8) :: gsw_pot_rho_t_exact - end function gsw_pot_rho_t_exact - - elemental function gsw_pressure_coefficient_ice (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_pressure_coefficient_ice - end function gsw_pressure_coefficient_ice - - elemental function gsw_pressure_freezing_ct (sa, ct, saturation_fraction) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, saturation_fraction - real (r8) :: gsw_pressure_freezing_ct - end function gsw_pressure_freezing_ct - - elemental function gsw_pt0_cold_ice_poly (pot_enthalpy_ice) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: pot_enthalpy_ice - real (r8) :: gsw_pt0_cold_ice_poly - end function gsw_pt0_cold_ice_poly - - elemental function gsw_pt0_from_t (sa, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p - real (r8) :: gsw_pt0_from_t - end function gsw_pt0_from_t - - elemental function gsw_pt0_from_t_ice (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_pt0_from_t_ice - end function gsw_pt0_from_t_ice - - elemental subroutine gsw_pt_first_derivatives (sa, ct, pt_sa, pt_ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct - real (r8), intent(out), optional :: pt_sa, pt_ct - end subroutine gsw_pt_first_derivatives - - elemental function gsw_pt_from_ct (sa, ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct - real (r8) :: gsw_pt_from_ct - end function gsw_pt_from_ct - - elemental function gsw_pt_from_entropy (sa, entropy) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, entropy - real (r8) :: gsw_pt_from_entropy - end function gsw_pt_from_entropy - - elemental function gsw_pt_from_pot_enthalpy_ice (pot_enthalpy_ice) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: pot_enthalpy_ice - real (r8) :: gsw_pt_from_pot_enthalpy_ice - end function gsw_pt_from_pot_enthalpy_ice - - elemental function gsw_pt_from_pot_enthalpy_ice_poly_dh (pot_enthalpy_ice) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: pot_enthalpy_ice - real (r8) :: gsw_pt_from_pot_enthalpy_ice_poly_dh - end function gsw_pt_from_pot_enthalpy_ice_poly_dh - - elemental function gsw_pt_from_pot_enthalpy_ice_poly (pot_enthalpy_ice) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: pot_enthalpy_ice - real (r8) :: gsw_pt_from_pot_enthalpy_ice_poly - end function gsw_pt_from_pot_enthalpy_ice_poly - - elemental function gsw_pt_from_t (sa, t, p, p_ref) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p, p_ref - real (r8) :: gsw_pt_from_t - end function gsw_pt_from_t - - elemental function gsw_pt_from_t_ice (t, p, p_ref) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p, p_ref - real (r8) :: gsw_pt_from_t_ice - end function gsw_pt_from_t_ice - - elemental subroutine gsw_pt_second_derivatives (sa, ct, pt_sa_sa, & - pt_sa_ct, pt_ct_ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct - real (r8), intent(out), optional :: pt_sa_sa, pt_sa_ct, pt_ct_ct - end subroutine gsw_pt_second_derivatives - - elemental subroutine gsw_rho_alpha_beta (sa, ct, p, rho, alpha, beta) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8), intent(out), optional :: rho, alpha, beta - end subroutine gsw_rho_alpha_beta - - elemental function gsw_rho (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_rho - end function gsw_rho - - elemental subroutine gsw_rho_first_derivatives (sa, ct, p, drho_dsa, & - drho_dct, drho_dp) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8), intent(out), optional :: drho_dsa, drho_dct, drho_dp - end subroutine gsw_rho_first_derivatives - - elemental subroutine gsw_rho_first_derivatives_wrt_enthalpy (sa, ct, p, & - rho_sa, rho_h) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8), intent(out), optional :: rho_sa, rho_h - end subroutine gsw_rho_first_derivatives_wrt_enthalpy - - elemental function gsw_rho_ice (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_rho_ice - end function gsw_rho_ice - - elemental subroutine gsw_rho_second_derivatives (sa, ct, p, rho_sa_sa, & - rho_sa_ct, rho_ct_ct, rho_sa_p, rho_ct_p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8), intent(out), optional :: rho_sa_sa, rho_sa_ct, rho_ct_ct - real (r8), intent(out), optional :: rho_sa_p, rho_ct_p - end subroutine gsw_rho_second_derivatives - - elemental subroutine gsw_rho_second_derivatives_wrt_enthalpy (sa, ct, p, & - rho_sa_sa, rho_sa_h, rho_h_h) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8), intent(out), optional :: rho_sa_sa, rho_sa_h, rho_h_h - end subroutine gsw_rho_second_derivatives_wrt_enthalpy - - elemental function gsw_rho_t_exact (sa, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p - real (r8) :: gsw_rho_t_exact - end function gsw_rho_t_exact - - pure subroutine gsw_rr68_interp_sa_ct (sa, ct, p, p_i, sa_i, ct_i) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa(:), ct(:), p(:), p_i(:) - real (r8), intent(out) :: sa_i(:), ct_i(:) - end subroutine gsw_rr68_interp_sa_ct - - elemental function gsw_saar (p, long, lat) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: p, long, lat - real (r8) :: gsw_saar - end function gsw_saar - - elemental function gsw_sa_freezing_estimate (p, saturation_fraction, ct, t) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: p, saturation_fraction - real (r8), intent(in), optional :: ct, t - real (r8) :: gsw_sa_freezing_estimate - end function gsw_sa_freezing_estimate - - elemental function gsw_sa_freezing_from_ct (ct, p, saturation_fraction) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: ct, p, saturation_fraction - real (r8) :: gsw_sa_freezing_from_ct - end function gsw_sa_freezing_from_ct - - elemental function gsw_sa_freezing_from_ct_poly (ct, p, saturation_fraction) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: ct, p, saturation_fraction - real (r8) :: gsw_sa_freezing_from_ct_poly - end function gsw_sa_freezing_from_ct_poly - - elemental function gsw_sa_freezing_from_t (t, p, saturation_fraction) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p, saturation_fraction - real (r8) :: gsw_sa_freezing_from_t - end function gsw_sa_freezing_from_t - - elemental function gsw_sa_freezing_from_t_poly (t, p, saturation_fraction) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p, saturation_fraction - real (r8) :: gsw_sa_freezing_from_t_poly - end function gsw_sa_freezing_from_t_poly - - elemental function gsw_sa_from_rho (rho, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: rho, ct, p - real (r8) :: gsw_sa_from_rho - end function gsw_sa_from_rho - - elemental function gsw_sa_from_sp_baltic (sp, long, lat) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sp, long, lat - real (r8) :: gsw_sa_from_sp_baltic - end function gsw_sa_from_sp_baltic - - elemental function gsw_sa_from_sp (sp, p, long, lat) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sp, p, long, lat - real (r8) :: gsw_sa_from_sp - end function gsw_sa_from_sp - - elemental function gsw_sa_from_sstar (sstar, p, long, lat) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sstar, p, long, lat - real (r8) :: gsw_sa_from_sstar - end function gsw_sa_from_sstar - - elemental function gsw_sa_p_inrange (sa, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p - logical :: gsw_sa_p_inrange - end function gsw_sa_p_inrange - - elemental subroutine gsw_seaice_fraction_to_freeze_seawater (sa, ct, p, & - sa_seaice, t_seaice, sa_freeze, ct_freeze, w_seaice) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p, sa_seaice, t_seaice - real (r8), intent(out) :: sa_freeze, ct_freeze, w_seaice - end subroutine gsw_seaice_fraction_to_freeze_seawater - - elemental function gsw_sigma0 (sa, ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct - real (r8) :: gsw_sigma0 - end function gsw_sigma0 - - elemental function gsw_sigma1 (sa, ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct - real (r8) :: gsw_sigma1 - end function gsw_sigma1 - - elemental function gsw_sigma2 (sa, ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct - real (r8) :: gsw_sigma2 - end function gsw_sigma2 - - elemental function gsw_sigma3 (sa, ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct - real (r8) :: gsw_sigma3 - end function gsw_sigma3 - - elemental function gsw_sigma4 (sa, ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct - real (r8) :: gsw_sigma4 - end function gsw_sigma4 - - elemental function gsw_sound_speed (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_sound_speed - end function gsw_sound_speed - - elemental function gsw_sound_speed_ice (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_sound_speed_ice - end function gsw_sound_speed_ice - - elemental function gsw_sound_speed_t_exact (sa, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p - real (r8) :: gsw_sound_speed_t_exact - end function gsw_sound_speed_t_exact - - elemental subroutine gsw_specvol_alpha_beta (sa, ct, p, specvol, alpha, & - beta) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8), intent(out), optional :: specvol, alpha, beta - end subroutine gsw_specvol_alpha_beta - - elemental function gsw_specvol_anom_standard (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_specvol_anom_standard - end function gsw_specvol_anom_standard - - elemental function gsw_specvol (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_specvol - end function gsw_specvol - - elemental subroutine gsw_specvol_first_derivatives (sa, ct, p, v_sa, v_ct, & - v_p, iflag) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - integer, intent(in), optional :: iflag - real (r8), intent(out), optional :: v_sa, v_ct, v_p - end subroutine gsw_specvol_first_derivatives - - elemental subroutine gsw_specvol_first_derivatives_wrt_enthalpy (sa, ct, & - p, v_sa, v_h, iflag) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - integer, intent(in), optional :: iflag - real (r8), intent(out), optional :: v_sa, v_h - end subroutine gsw_specvol_first_derivatives_wrt_enthalpy - - elemental function gsw_specvol_ice (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_specvol_ice - end function gsw_specvol_ice - - elemental subroutine gsw_specvol_second_derivatives (sa, ct, p, v_sa_sa, & - v_sa_ct, v_ct_ct, v_sa_p, v_ct_p, iflag) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - integer, intent(in), optional :: iflag - real (r8), intent(out), optional :: v_sa_sa, v_sa_ct, v_ct_ct, v_sa_p, v_ct_p - end subroutine gsw_specvol_second_derivatives - - elemental subroutine gsw_specvol_second_derivatives_wrt_enthalpy (sa, ct, & - p, v_sa_sa, v_sa_h, v_h_h, iflag) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - integer, intent(in), optional :: iflag - real (r8), intent(out), optional :: v_sa_sa, v_sa_h, v_h_h - end subroutine gsw_specvol_second_derivatives_wrt_enthalpy - - elemental function gsw_specvol_sso_0 (p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: p - real (r8) :: gsw_specvol_sso_0 - end function gsw_specvol_sso_0 - - elemental function gsw_specvol_t_exact (sa, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p - real (r8) :: gsw_specvol_t_exact - end function gsw_specvol_t_exact - - elemental function gsw_sp_from_c (c, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: c, t, p - real (r8) :: gsw_sp_from_c - end function gsw_sp_from_c - - elemental function gsw_sp_from_sa_baltic (sa, long, lat) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, long, lat - real (r8) :: gsw_sp_from_sa_baltic - end function gsw_sp_from_sa_baltic - - elemental function gsw_sp_from_sa (sa, p, long, lat) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p, long, lat - real (r8) :: gsw_sp_from_sa - end function gsw_sp_from_sa - - elemental function gsw_sp_from_sk (sk) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sk - real (r8) :: gsw_sp_from_sk - end function gsw_sp_from_sk - - elemental function gsw_sp_from_sr (sr) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sr - real (r8) :: gsw_sp_from_sr - end function gsw_sp_from_sr - - elemental function gsw_sp_from_sstar (sstar, p, long, lat) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sstar, p, long, lat - real (r8) :: gsw_sp_from_sstar - end function gsw_sp_from_sstar - - elemental function gsw_spiciness0 (sa, ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct - real (r8) :: gsw_spiciness0 - end function gsw_spiciness0 - - elemental function gsw_spiciness1 (sa, ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct - real (r8) :: gsw_spiciness1 - end function gsw_spiciness1 - - elemental function gsw_spiciness2 (sa, ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct - real (r8) :: gsw_spiciness2 - end function gsw_spiciness2 - - elemental function gsw_sr_from_sp (sp) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sp - real (r8) :: gsw_sr_from_sp - end function gsw_sr_from_sp - - elemental function gsw_sstar_from_sa (sa, p, long, lat) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p, long, lat - real (r8) :: gsw_sstar_from_sa - end function gsw_sstar_from_sa - - elemental function gsw_sstar_from_sp (sp, p, long, lat) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sp, p, long, lat - real (r8) :: gsw_sstar_from_sp - end function gsw_sstar_from_sp - - elemental function gsw_t_deriv_chem_potential_water_t_exact (sa, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p - real (r8) :: gsw_t_deriv_chem_potential_water_t_exact - end function gsw_t_deriv_chem_potential_water_t_exact - - elemental function gsw_t_freezing_exact (sa, p, saturation_fraction) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p, saturation_fraction - real (r8) :: gsw_t_freezing_exact - end function gsw_t_freezing_exact - - elemental function gsw_t_freezing (sa, p, saturation_fraction, poly) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p, saturation_fraction - logical, intent(in), optional :: poly - real (r8) :: gsw_t_freezing - end function gsw_t_freezing - - elemental subroutine gsw_t_freezing_first_derivatives (sa, p, & - saturation_fraction, tfreezing_sa, tfreezing_p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p, saturation_fraction - real (r8), intent(out), optional :: tfreezing_sa, tfreezing_p - end subroutine gsw_t_freezing_first_derivatives - - elemental subroutine gsw_t_freezing_first_derivatives_poly (sa, p, & - saturation_fraction, tfreezing_sa, tfreezing_p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p, saturation_fraction - real (r8), intent(out), optional :: tfreezing_sa, tfreezing_p - end subroutine gsw_t_freezing_first_derivatives_poly - - elemental function gsw_t_freezing_poly (sa, p, saturation_fraction, polynomial) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p - real (r8), intent(in), optional :: saturation_fraction - logical, intent(in), optional :: polynomial - real (r8) :: gsw_t_freezing_poly - end function gsw_t_freezing_poly - - elemental function gsw_t_from_ct (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_t_from_ct - end function gsw_t_from_ct - - elemental function gsw_t_from_pt0_ice (pt0_ice, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: pt0_ice, p - real (r8) :: gsw_t_from_pt0_ice - end function gsw_t_from_pt0_ice - - elemental function gsw_thermobaric (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_thermobaric - end function gsw_thermobaric - - pure subroutine gsw_turner_rsubrho (sa, ct, p, tu, rsubrho, p_mid) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa(:), ct(:), p(:) - real (r8), intent(out) :: tu(:), rsubrho(:), p_mid(:) - end subroutine gsw_turner_rsubrho - - pure subroutine gsw_util_indx (x, n, z, k) - use gsw_mod_kinds - integer, intent(in) :: n - integer, intent(out) :: k - real (r8), intent(in), dimension(n) :: x - real (r8), intent(in) :: z - end subroutine gsw_util_indx - - pure function gsw_util_interp1q_int (x, iy, x_i) result(y_i) - use gsw_mod_kinds - implicit none - integer, intent(in) :: iy(:) - real (r8), intent(in) :: x(:), x_i(:) - real (r8) :: y_i(size(x_i)) - end function gsw_util_interp1q_int - - pure function gsw_util_sort_real (rarray) result(iarray) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: rarray(:) ! Values to be sorted - integer :: iarray(size(rarray)) ! Sorted ids - end function gsw_util_sort_real - - pure function gsw_util_xinterp1 (x, y, n, x0) - use gsw_mod_kinds - implicit none - integer, intent(in) :: n - real (r8), intent(in) :: x0 - real (r8), dimension(n), intent(in) :: x, y - real (r8) :: gsw_util_xinterp1 - end function gsw_util_xinterp1 - - elemental function gsw_z_from_p (p, lat) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: p, lat - real (r8) :: gsw_z_from_p - end function gsw_z_from_p - -end interface - -end module gsw_mod_toolbox diff --git a/src/equation_of_state/TEOS10/gsw_mod_toolbox.f90 b/src/equation_of_state/TEOS10/gsw_mod_toolbox.f90 new file mode 120000 index 0000000000..f2f4761ec4 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_mod_toolbox.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/modules/gsw_mod_toolbox.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_pt0_from_t.f90 b/src/equation_of_state/TEOS10/gsw_pt0_from_t.f90 deleted file mode 100644 index 63c2c83292..0000000000 --- a/src/equation_of_state/TEOS10/gsw_pt0_from_t.f90 +++ /dev/null @@ -1,59 +0,0 @@ -!========================================================================== -elemental function gsw_pt0_from_t (sa, t, p) -!========================================================================== -! -! Calculates potential temperature with reference pressure, p_ref = 0 dbar. -! -! sa : Absolute Salinity [g/kg] -! t : in-situ temperature [deg C] -! p : sea pressure [dbar] -! -! gsw_pt0_from_t : potential temperature, p_ref = 0 [deg C] -!-------------------------------------------------------------------------- - -use gsw_mod_toolbox, only : gsw_entropy_part, gsw_entropy_part_zerop -use gsw_mod_toolbox, only : gsw_gibbs_pt0_pt0 - -use gsw_mod_teos10_constants, only : gsw_cp0, gsw_sso, gsw_t0, gsw_ups - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, t, p - -real (r8) :: gsw_pt0_from_t - -integer n, no_iter -real (r8) :: s1, true_entropy_part, pt0m -real (r8) :: pt0, pt0_old, de_dt, dentropy, dentropy_dt - -s1 = sa/gsw_ups - -pt0 = t + p*( 8.65483913395442e-6_r8 - & - s1 * 1.41636299744881e-6_r8 - & - p * 7.38286467135737e-9_r8 + & - t *(-8.38241357039698e-6_r8 + & - s1 * 2.83933368585534e-8_r8 + & - t * 1.77803965218656e-8_r8 + & - p * 1.71155619208233e-10_r8)) - -dentropy_dt = gsw_cp0/((gsw_t0 + pt0)*(1.0_r8 - 0.05_r8*(1.0_r8 - sa/gsw_sso))) - -true_entropy_part = gsw_entropy_part(sa,t,p) - -do no_iter = 1, 2 - pt0_old = pt0 - dentropy = gsw_entropy_part_zerop(sa,pt0_old) - true_entropy_part - pt0 = pt0_old - dentropy/dentropy_dt - pt0m = 0.5_r8*(pt0 + pt0_old) - dentropy_dt = -gsw_gibbs_pt0_pt0(sa,pt0m) - pt0 = pt0_old - dentropy/dentropy_dt -end do - -gsw_pt0_from_t = pt0 - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_pt0_from_t.f90 b/src/equation_of_state/TEOS10/gsw_pt0_from_t.f90 new file mode 120000 index 0000000000..79cf5b0d65 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_pt0_from_t.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_pt0_from_t.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_pt_from_ct.f90 b/src/equation_of_state/TEOS10/gsw_pt_from_ct.f90 deleted file mode 100644 index b856b923c8..0000000000 --- a/src/equation_of_state/TEOS10/gsw_pt_from_ct.f90 +++ /dev/null @@ -1,72 +0,0 @@ -!========================================================================== -elemental function gsw_pt_from_ct (sa, ct) -!========================================================================== -! -! potential temperature of seawater from conservative temperature -! -! sa : Absolute Salinity [g/kg] -! ct : Conservative Temperature [deg C] -! p : sea pressure [dbar] -! -! gsw_pt_from_ct : potential temperature with [deg C] -! reference pressure of 0 dbar -!-------------------------------------------------------------------------- - -use gsw_mod_toolbox, only : gsw_ct_from_pt, gsw_gibbs_pt0_pt0 - -use gsw_mod_teos10_constants, only : gsw_cp0, gsw_ups, gsw_t0 - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, ct - -real (r8) :: gsw_pt_from_ct - -real (r8) :: a5ct, b3ct, ct_factor, pt_num, pt_recden, ct_diff -real (r8) :: ct0, pt, pt_old, ptm, dct, dpt_dct, s1 - -real (r8), parameter :: a0 = -1.446013646344788e-2_r8 -real (r8), parameter :: a1 = -3.305308995852924e-3_r8 -real (r8), parameter :: a2 = 1.062415929128982e-4_r8 -real (r8), parameter :: a3 = 9.477566673794488e-1_r8 -real (r8), parameter :: a4 = 2.166591947736613e-3_r8 -real (r8), parameter :: a5 = 3.828842955039902e-3_r8 - -real (r8), parameter :: b0 = 1.0_r8 -real (r8), parameter :: b1 = 6.506097115635800e-4_r8 -real (r8), parameter :: b2 = 3.830289486850898e-3_r8 -real (r8), parameter :: b3 = 1.247811760368034e-6_r8 - -s1 = sa/gsw_ups - -a5ct = a5*ct -b3ct = b3*ct - -ct_factor = (a3 + a4*s1 + a5ct) -pt_num = a0 + s1*(a1 + a2*s1) + ct*ct_factor -pt_recden = 1.0_r8/(b0 + b1*s1 + ct*(b2 + b3ct)) -pt = pt_num*pt_recden - -dpt_dct = (ct_factor + a5ct - (b2 + b3ct + b3ct)*pt)*pt_recden - -! Start the 1.5 iterations through the modified Newton-Rapshon iterative, -! method, which is also known as the Newton-McDougall method. - -ct_diff = gsw_ct_from_pt(sa,pt) - ct -pt_old = pt -pt = pt_old - ct_diff*dpt_dct -ptm = 0.5_r8*(pt + pt_old) - -dpt_dct = -gsw_cp0/((ptm + gsw_t0)*gsw_gibbs_pt0_pt0(sa,ptm)) - -pt = pt_old - ct_diff*dpt_dct -ct_diff = gsw_ct_from_pt(sa,pt) - ct -pt_old = pt -gsw_pt_from_ct = pt_old - ct_diff*dpt_dct - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_pt_from_ct.f90 b/src/equation_of_state/TEOS10/gsw_pt_from_ct.f90 new file mode 120000 index 0000000000..cd794a1316 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_pt_from_ct.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_pt_from_ct.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_pt_from_t.f90 b/src/equation_of_state/TEOS10/gsw_pt_from_t.f90 deleted file mode 100644 index 46dc766fb6..0000000000 --- a/src/equation_of_state/TEOS10/gsw_pt_from_t.f90 +++ /dev/null @@ -1,61 +0,0 @@ -!========================================================================== -elemental function gsw_pt_from_t (sa, t, p, p_ref) -!========================================================================== -! -! Calculates potential temperature of seawater from in-situ temperature -! -! sa : Absolute Salinity [g/kg] -! t : in-situ temperature [deg C] -! p : sea pressure [dbar] -! p_ref : reference sea pressure [dbar] -! -! gsw_pt_from_t : potential temperature [deg C] -!-------------------------------------------------------------------------- - -use gsw_mod_toolbox, only : gsw_entropy_part, gsw_gibbs - -use gsw_mod_teos10_constants, only : gsw_cp0, gsw_sso, gsw_t0, gsw_ups - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, t, p, p_ref - -real (r8) :: gsw_pt_from_t - -integer n, no_iter -real (r8) :: s1, pt, pt_old, de_dt, dentropy, dentropy_dt -real (r8) :: true_entropy_part, ptm - -integer, parameter :: n0=0, n2=2 - -s1 = sa/gsw_ups - -pt = t + (p-p_ref)*( 8.65483913395442e-6_r8 - & - s1 * 1.41636299744881e-6_r8 - & - (p+p_ref)* 7.38286467135737e-9_r8 + & - t *(-8.38241357039698e-6_r8 + & - s1 * 2.83933368585534e-8_r8 + & - t * 1.77803965218656e-8_r8 + & - (p+p_ref)* 1.71155619208233e-10_r8)) - -dentropy_dt = gsw_cp0/((gsw_t0 + pt)*(1.0_r8 - 0.05_r8*(1.0_r8 - sa/gsw_sso))) - -true_entropy_part = gsw_entropy_part(sa,t,p) - -do no_iter = 1, 2 - pt_old = pt - dentropy = gsw_entropy_part(sa,pt_old,p_ref) - true_entropy_part - pt = pt_old - dentropy/dentropy_dt - ptm = 0.5_r8*(pt + pt_old) - dentropy_dt = -gsw_gibbs(n0,n2,n0,sa,ptm,p_ref) - pt = pt_old - dentropy/dentropy_dt -end do - -gsw_pt_from_t = pt - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_pt_from_t.f90 b/src/equation_of_state/TEOS10/gsw_pt_from_t.f90 new file mode 120000 index 0000000000..37fa5f104f --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_pt_from_t.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_pt_from_t.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_rho.f90 b/src/equation_of_state/TEOS10/gsw_rho.f90 deleted file mode 100644 index 3daa65746e..0000000000 --- a/src/equation_of_state/TEOS10/gsw_rho.f90 +++ /dev/null @@ -1,36 +0,0 @@ -!========================================================================== -elemental function gsw_rho (sa, ct, p) -!========================================================================== -! -! Calculates in-situ density from Absolute Salinity and Conservative -! Temperature, using the computationally-efficient expression for -! specific volume in terms of SA, CT and p (Roquet et al., 2014). -! -! Note that potential density with respect to reference pressure, pr, is -! obtained by calling this function with the pressure argument being pr -! (i.e. "gsw_rho(SA,CT,pr)"). -! -! SA = Absolute Salinity [ g/kg ] -! CT = Conservative Temperature (ITS-90) [ deg C ] -! p = sea pressure [ dbar ] -! ( i.e. absolute pressure - 10.1325 dbar ) -! -! rho = in-situ density [ kg/m ] -!-------------------------------------------------------------------------- - -use gsw_mod_toolbox, only : gsw_specvol - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, ct, p - -real (r8) :: gsw_rho - -gsw_rho = 1.0_r8/gsw_specvol(sa,ct,p) - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_rho.f90 b/src/equation_of_state/TEOS10/gsw_rho.f90 new file mode 120000 index 0000000000..22eea6219a --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_rho.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_rho.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_rho_first_derivatives.f90 b/src/equation_of_state/TEOS10/gsw_rho_first_derivatives.f90 deleted file mode 100644 index b4ee696a1d..0000000000 --- a/src/equation_of_state/TEOS10/gsw_rho_first_derivatives.f90 +++ /dev/null @@ -1,110 +0,0 @@ -!========================================================================== -elemental subroutine gsw_rho_first_derivatives (sa, ct, p, drho_dsa, & - drho_dct, drho_dp) -!========================================================================== -! -! Calculates the three (3) partial derivatives of in-situ density with -! respect to Absolute Salinity, Conservative Temperature and pressure. -! Note that the pressure derivative is done with respect to pressure in -! Pa, not dbar. This function uses the computationally-efficient expression -! for specific volume in terms of SA, CT and p (Roquet et al., 2014). -! -! SA = Absolute Salinity [ g/kg ] -! CT = Conservative Temperature (ITS-90) [ deg C ] -! p = sea pressure [ dbar ] -! ( i.e. absolute pressure - 10.1325 dbar ) -! -! drho_dSA = partial derivatives of density [ kg^2/(g m^3) ] -! with respect to Absolute Salinity -! drho_dCT = partial derivatives of density [ kg/(K m^3) ] -! with respect to Conservative Temperature -! drho_dP = partial derivatives of density [ kg/(Pa m^3) ] -! with respect to pressure in Pa -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : pa2db, gsw_sfac, offset - -use gsw_mod_specvol_coefficients - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, ct, p -real (r8), intent(out), optional :: drho_dsa, drho_dct, drho_dp - -real (r8) :: rho2, v_ct, v_p, v_sa, xs, ys, z, v - -xs = sqrt(gsw_sfac*sa + offset) -ys = ct*0.025_r8 -z = p*1e-4_r8 - -v = v000 + xs*(v010 + xs*(v020 + xs*(v030 + xs*(v040 + xs*(v050 & - + v060*xs))))) + ys*(v100 + xs*(v110 + xs*(v120 + xs*(v130 + xs*(v140 & - + v150*xs)))) + ys*(v200 + xs*(v210 + xs*(v220 + xs*(v230 + v240*xs))) & - + ys*(v300 + xs*(v310 + xs*(v320 + v330*xs)) + ys*(v400 + xs*(v410 & - + v420*xs) + ys*(v500 + v510*xs + v600*ys))))) + z*(v001 + xs*(v011 & - + xs*(v021 + xs*(v031 + xs*(v041 + v051*xs)))) + ys*(v101 + xs*(v111 & - + xs*(v121 + xs*(v131 + v141*xs))) + ys*(v201 + xs*(v211 + xs*(v221 & - + v231*xs)) + ys*(v301 + xs*(v311 + v321*xs) + ys*(v401 + v411*xs & - + v501*ys)))) + z*(v002 + xs*(v012 + xs*(v022 + xs*(v032 + v042*xs))) & - + ys*(v102 + xs*(v112 + xs*(v122 + v132*xs)) + ys*(v202 + xs*(v212 & - + v222*xs) + ys*(v302 + v312*xs + v402*ys))) + z*(v003 + xs*(v013 & - + v023*xs) + ys*(v103 + v113*xs + v203*ys) + z*(v004 + v014*xs + v104*ys & - + z*(v005 + v006*z))))) - -rho2 = (1.0_r8/v)**2 - -if (present(drho_dsa)) then - - v_sa = b000 + xs*(b100 + xs*(b200 + xs*(b300 + xs*(b400 + b500*xs)))) & - + ys*(b010 + xs*(b110 + xs*(b210 + xs*(b310 + b410*xs))) & - + ys*(b020 + xs*(b120 + xs*(b220 + b320*xs)) + ys*(b030 & - + xs*(b130 + b230*xs) + ys*(b040 + b140*xs + b050*ys)))) & - + z*(b001 + xs*(b101 + xs*(b201 + xs*(b301 + b401*xs))) & - + ys*(b011 + xs*(b111 + xs*(b211 + b311*xs)) + ys*(b021 & - + xs*(b121 + b221*xs) + ys*(b031 + b131*xs + b041*ys))) & - + z*(b002 + xs*(b102 + xs*(b202 + b302*xs))+ ys*(b012 & - + xs*(b112 + b212*xs) + ys*(b022 + b122*xs + b032*ys)) & - + z*(b003 + b103*xs + b013*ys + b004*z))) - - drho_dsa = -rho2*0.5_r8*gsw_sfac*v_sa/xs - -end if - -if (present(drho_dct)) then - - v_ct = a000 + xs*(a100 + xs*(a200 + xs*(a300 + xs*(a400 + a500*xs)))) & - + ys*(a010 + xs*(a110 + xs*(a210 + xs*(a310 + a410*xs))) & - + ys*(a020 + xs*(a120 + xs*(a220 + a320*xs)) + ys*(a030 & - + xs*(a130 + a230*xs) + ys*(a040 + a140*xs + a050*ys )))) & - + z*(a001 + xs*(a101 + xs*(a201 + xs*(a301 + a401*xs))) & - + ys*(a011 + xs*(a111 + xs*(a211 + a311*xs)) + ys*(a021 & - + xs*(a121 + a221*xs) + ys*(a031 + a131*xs + a041*ys))) & - + z*(a002 + xs*(a102 + xs*(a202 + a302*xs)) + ys*(a012 & - + xs*(a112 + a212*xs) + ys*(a022 + a122*xs + a032*ys)) & - + z*(a003 + a103*xs + a013*ys + a004*z))) - - drho_dct = -rho2*0.025_r8*v_ct - -end if - -if (present(drho_dp)) then - - v_p = c000 + xs*(c100 + xs*(c200 + xs*(c300 + xs*(c400 + c500*xs)))) & - + ys*(c010 + xs*(c110 + xs*(c210 + xs*(c310 + c410*xs))) + ys*(c020 & - + xs*(c120 + xs*(c220 + c320*xs)) + ys*(c030 + xs*(c130 + c230*xs) & - + ys*(c040 + c140*xs + c050*ys)))) + z*(c001 + xs*(c101 + xs*(c201 & - + xs*(c301 + c401*xs))) + ys*(c011 + xs*(c111 + xs*(c211 + c311*xs)) & - + ys*(c021 + xs*(c121 + c221*xs) + ys*(c031 + c131*xs + c041*ys))) & - + z*(c002 + xs*(c102 + c202*xs) + ys*(c012 + c112*xs + c022*ys) & - + z*(c003 + c103*xs + c013*ys + z*(c004 + c005*z)))) - - drho_dp = -rho2*1e-4_r8*pa2db*v_p - -end if - -return -end subroutine - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_rho_first_derivatives.f90 b/src/equation_of_state/TEOS10/gsw_rho_first_derivatives.f90 new file mode 120000 index 0000000000..3a8ba38824 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_rho_first_derivatives.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_rho_first_derivatives.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_rho_second_derivatives.f90 b/src/equation_of_state/TEOS10/gsw_rho_second_derivatives.f90 deleted file mode 100644 index fdf75e7a0a..0000000000 --- a/src/equation_of_state/TEOS10/gsw_rho_second_derivatives.f90 +++ /dev/null @@ -1,78 +0,0 @@ -!========================================================================== -elemental subroutine gsw_rho_second_derivatives (sa, ct, p, rho_sa_sa, & - rho_sa_ct, rho_ct_ct, rho_sa_p, rho_ct_p) -!========================================================================== -! -! Calculates five second-order derivatives of rho. Note that this function -! uses the using the computationally-efficient expression for specific -! volume (Roquet et al., 2014). -! -! SA = Absolute Salinity [ g/kg ] -! CT = Conservative Temperature (ITS-90) [ deg C ] -! p = sea pressure [ dbar ] -! ( i.e. absolute pressure - 10.1325 dbar ) -! -! rho_SA_SA = The second-order derivative of rho with respect to -! Absolute Salinity at constant CT & p. [ J/(kg (g/kg)^2) ] -! rho_SA_CT = The second-order derivative of rho with respect to -! SA and CT at constant p. [ J/(kg K(g/kg)) ] -! rho_CT_CT = The second-order derivative of rho with respect to CT at -! constant SA & p -! rho_SA_P = The second-order derivative with respect to SA & P at -! constant CT. -! rho_CT_P = The second-order derivative with respect to CT & P at -! constant SA. -!-------------------------------------------------------------------------- - -use gsw_mod_toolbox, only : gsw_specvol, gsw_specvol_first_derivatives -use gsw_mod_toolbox, only : gsw_specvol_second_derivatives - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, ct, p -real (r8), intent(out), optional :: rho_sa_sa, rho_sa_ct, rho_ct_ct -real (r8), intent(out), optional :: rho_sa_p, rho_ct_p - -integer :: iflag1, iflag2 -real (r8) :: rec_v, rec_v2, rec_v3, v_ct, v_ct_ct, v_ct_p, v_p, v_sa, v_sa_ct -real (r8) :: v_sa_p, v_sa_sa - -iflag1 = 0 -if (present(rho_sa_sa) .or. present(rho_sa_ct) & - .or. present(rho_sa_p)) iflag1 = ibset(iflag1,1) -if (present(rho_sa_ct) .or. present(rho_ct_ct) & - .or. present(rho_ct_p)) iflag1 = ibset(iflag1,2) -if (present(rho_sa_p) .or. present(rho_ct_p)) iflag1 = ibset(iflag1,3) - -call gsw_specvol_first_derivatives(sa,ct,p,v_sa,v_ct,v_p,iflag=iflag1) - -iflag2 = 0 -if (present(rho_sa_sa)) iflag2 = ibset(iflag2,1) -if (present(rho_sa_ct)) iflag2 = ibset(iflag2,2) -if (present(rho_ct_ct)) iflag2 = ibset(iflag2,3) -if (present(rho_sa_p)) iflag2 = ibset(iflag2,4) -if (present(rho_ct_p)) iflag2 = ibset(iflag2,5) - -call gsw_specvol_second_derivatives(sa,ct,p,v_sa_sa,v_sa_ct,v_ct_ct, & - v_sa_p,v_ct_p,iflag=iflag2) - -rec_v = 1.0_r8/gsw_specvol(sa,ct,p) -rec_v2 = rec_v**2 -rec_v3 = rec_v2*rec_v - -if (present(rho_sa_sa)) rho_sa_sa = -v_sa_sa*rec_v2 + 2.0_r8*v_sa*v_sa*rec_v3 - -if (present(rho_sa_ct)) rho_sa_ct = -v_sa_ct*rec_v2 + 2.0_r8*v_sa*v_ct*rec_v3 - -if (present(rho_ct_ct)) rho_ct_ct = -v_ct_ct*rec_v2 + 2.0_r8*v_ct*v_ct*rec_v3 - -if (present(rho_sa_p)) rho_sa_p = -v_sa_p*rec_v2 + 2.0_r8*v_sa*v_p*rec_v3 - -if (present(rho_ct_p)) rho_ct_p = -v_ct_p*rec_v2 + 2.0_r8*v_ct*v_p*rec_v3 - -return -end subroutine - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_rho_second_derivatives.f90 b/src/equation_of_state/TEOS10/gsw_rho_second_derivatives.f90 new file mode 120000 index 0000000000..8b38e0f56f --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_rho_second_derivatives.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_rho_second_derivatives.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_sp_from_sr.f90 b/src/equation_of_state/TEOS10/gsw_sp_from_sr.f90 deleted file mode 100644 index c01377546c..0000000000 --- a/src/equation_of_state/TEOS10/gsw_sp_from_sr.f90 +++ /dev/null @@ -1,30 +0,0 @@ -!========================================================================== -elemental function gsw_sp_from_sr (sr) -!========================================================================== -! -! Calculates Practical Salinity, sp, from Reference Salinity, sr. -! -! sr : Reference Salinity [g/kg] -! -! gsw_sp_from_sr : Practical Salinity [unitless] -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_ups - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sr - -real (r8) :: gsw_sp_from_sr - -gsw_sp_from_sr = sr/gsw_ups - -return -end function - -!-------------------------------------------------------------------------- - - - diff --git a/src/equation_of_state/TEOS10/gsw_sp_from_sr.f90 b/src/equation_of_state/TEOS10/gsw_sp_from_sr.f90 new file mode 120000 index 0000000000..d8cd41f4bf --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_sp_from_sr.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_sp_from_sr.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_specvol.f90 b/src/equation_of_state/TEOS10/gsw_specvol.f90 deleted file mode 100644 index 00cfaab125..0000000000 --- a/src/equation_of_state/TEOS10/gsw_specvol.f90 +++ /dev/null @@ -1,52 +0,0 @@ -!========================================================================== -elemental function gsw_specvol (sa, ct, p) -!========================================================================== -! -! Calculates specific volume from Absolute Salinity, Conservative -! Temperature and pressure, using the computationally-efficient -! polynomial expression for specific volume (Roquet et al., 2014). -! -! SA = Absolute Salinity [ g/kg ] -! CT = Conservative Temperature (ITS-90) [ deg C ] -! p = sea pressure [ dbar ] -! ( i.e. absolute pressure - 10.1325 dbar ) -! -! specvol = specific volume [ m^3/kg ] -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_sfac, offset - -use gsw_mod_specvol_coefficients - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, ct, p - -real (r8) :: gsw_specvol - -real (r8) :: xs, ys, z - -xs = sqrt(gsw_sfac*sa + offset) -ys = ct*0.025_r8 -z = p*1e-4_r8 - -gsw_specvol = v000 + xs*(v010 + xs*(v020 + xs*(v030 + xs*(v040 + xs*(v050 & - + v060*xs))))) + ys*(v100 + xs*(v110 + xs*(v120 + xs*(v130 + xs*(v140 & - + v150*xs)))) + ys*(v200 + xs*(v210 + xs*(v220 + xs*(v230 + v240*xs))) & - + ys*(v300 + xs*(v310 + xs*(v320 + v330*xs)) + ys*(v400 + xs*(v410 & - + v420*xs) + ys*(v500 + v510*xs + v600*ys))))) + z*(v001 + xs*(v011 & - + xs*(v021 + xs*(v031 + xs*(v041 + v051*xs)))) + ys*(v101 + xs*(v111 & - + xs*(v121 + xs*(v131 + v141*xs))) + ys*(v201 + xs*(v211 + xs*(v221 & - + v231*xs)) + ys*(v301 + xs*(v311 + v321*xs) + ys*(v401 + v411*xs & - + v501*ys)))) + z*(v002 + xs*(v012 + xs*(v022 + xs*(v032 + v042*xs))) & - + ys*(v102 + xs*(v112 + xs*(v122 + v132*xs)) + ys*(v202 + xs*(v212 & - + v222*xs) + ys*(v302 + v312*xs + v402*ys))) + z*(v003 + xs*(v013 & - + v023*xs) + ys*(v103 + v113*xs + v203*ys) + z*(v004 + v014*xs + v104*ys & - + z*(v005 + v006*z))))) - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_specvol.f90 b/src/equation_of_state/TEOS10/gsw_specvol.f90 new file mode 120000 index 0000000000..7a41a5cea0 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_specvol.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_specvol.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_specvol_first_derivatives.f90 b/src/equation_of_state/TEOS10/gsw_specvol_first_derivatives.f90 deleted file mode 100644 index 2f2a006b17..0000000000 --- a/src/equation_of_state/TEOS10/gsw_specvol_first_derivatives.f90 +++ /dev/null @@ -1,104 +0,0 @@ -!========================================================================== -elemental subroutine gsw_specvol_first_derivatives (sa, ct, p, v_sa, v_ct, & - v_p, iflag) -! ========================================================================= -! -! Calculates three first-order derivatives of specific volume (v). -! Note that this function uses the computationally-efficient -! expression for specific volume (Roquet et al., 2014). -! -! SA = Absolute Salinity [ g/kg ] -! CT = Conservative Temperature (ITS-90) [ deg C ] -! p = sea pressure [ dbar ] -! ( i.e. absolute pressure - 10.1325 dbar ) -! -! v_SA = The first derivative of specific volume with respect to -! Absolute Salinity at constant CT & p. [ J/(kg (g/kg)^2) ] -! v_CT = The first derivative of specific volume with respect to -! CT at constant SA and p. [ J/(kg K(g/kg)) ] -! v_P = The first derivative of specific volume with respect to -! P at constant SA and CT. [ J/(kg K^2) ] -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_sfac, offset - -use gsw_mod_specvol_coefficients - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, ct, p -integer, intent(in), optional :: iflag -real (r8), intent(out), optional :: v_sa, v_ct, v_p - -integer :: i -logical :: flags(3) -real (r8) :: v_ct_part, v_p_part, v_sa_part, xs, ys, z - -xs = sqrt(gsw_sfac*sa + offset) -ys = ct*0.025_r8 -z = p*1e-4_r8 - -if (present(iflag)) then - do i = 1, 3 - flags(i) = btest(iflag,i) - end do -else - flags = .true. -end if - -if (present(v_sa) .and. flags(1)) then - - v_sa_part = b000 + xs*(b100 + xs*(b200 + xs*(b300 + xs*(b400 + b500*xs)))) & - + ys*(b010 + xs*(b110 + xs*(b210 + xs*(b310 + b410*xs))) & - + ys*(b020 + xs*(b120 + xs*(b220 + b320*xs)) + ys*(b030 & - + xs*(b130 + b230*xs) + ys*(b040 + b140*xs + b050*ys)))) & - + z*(b001 + xs*(b101 + xs*(b201 + xs*(b301 + b401*xs))) & - + ys*(b011 + xs*(b111 + xs*(b211 + b311*xs)) + ys*(b021 & - + xs*(b121 + b221*xs) + ys*(b031 + b131*xs + b041*ys))) & - + z*(b002 + xs*(b102 + xs*(b202 + b302*xs))+ ys*(b012 & - + xs*(b112 + b212*xs) + ys*(b022 + b122*xs + b032*ys)) & - + z*(b003 + b103*xs + b013*ys + b004*z))) - - v_sa = 0.5_r8*gsw_sfac*v_sa_part/xs - -end if - - -if (present(v_ct) .and. flags(2)) then - - v_ct_part = a000 + xs*(a100 + xs*(a200 + xs*(a300 + xs*(a400 + a500*xs)))) & - + ys*(a010 + xs*(a110 + xs*(a210 + xs*(a310 + a410*xs))) & - + ys*(a020 + xs*(a120 + xs*(a220 + a320*xs)) + ys*(a030 & - + xs*(a130 + a230*xs) + ys*(a040 + a140*xs + a050*ys )))) & - + z*(a001 + xs*(a101 + xs*(a201 + xs*(a301 + a401*xs))) & - + ys*(a011 + xs*(a111 + xs*(a211 + a311*xs)) + ys*(a021 & - + xs*(a121 + a221*xs) + ys*(a031 + a131*xs + a041*ys))) & - + z*(a002 + xs*(a102 + xs*(a202 + a302*xs)) + ys*(a012 & - + xs*(a112 + a212*xs) + ys*(a022 + a122*xs + a032*ys)) & - + z*(a003 + a103*xs + a013*ys + a004*z))) - - v_ct = 0.025_r8*v_ct_part - -end if - -if (present(v_p) .and. flags(3)) then - - v_p_part = c000 + xs*(c100 + xs*(c200 + xs*(c300 + xs*(c400 + c500*xs)))) & - + ys*(c010 + xs*(c110 + xs*(c210 + xs*(c310 + c410*xs))) + ys*(c020 & - + xs*(c120 + xs*(c220 + c320*xs)) + ys*(c030 + xs*(c130 + c230*xs) & - + ys*(c040 + c140*xs + c050*ys)))) + z*(c001 + xs*(c101 + xs*(c201 & - + xs*(c301 + c401*xs))) + ys*(c011 + xs*(c111 + xs*(c211 + c311*xs)) & - + ys*(c021 + xs*(c121 + c221*xs) + ys*(c031 + c131*xs + c041*ys))) & - + z*( c002 + xs*(c102 + c202*xs) + ys*(c012 + c112*xs + c022*ys) & - + z*(c003 + c103*xs + c013*ys + z*(c004 + c005*z)))) - - v_p = 1e-8_r8*v_p_part - -end if - -return -end subroutine - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_specvol_first_derivatives.f90 b/src/equation_of_state/TEOS10/gsw_specvol_first_derivatives.f90 new file mode 120000 index 0000000000..ee6ee1f906 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_specvol_first_derivatives.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_specvol_first_derivatives.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_specvol_second_derivatives.f90 b/src/equation_of_state/TEOS10/gsw_specvol_second_derivatives.f90 deleted file mode 100644 index 39096109e9..0000000000 --- a/src/equation_of_state/TEOS10/gsw_specvol_second_derivatives.f90 +++ /dev/null @@ -1,131 +0,0 @@ -!========================================================================== -elemental subroutine gsw_specvol_second_derivatives (sa, ct, p, v_sa_sa, & - v_sa_ct, v_ct_ct, v_sa_p, v_ct_p, iflag) -! ========================================================================= -! -! Calculates five second-order derivatives of specific volume (v). -! Note that this function uses the computationally-efficient -! expression for specific volume (Roquet et al., 2014). -! -! SA = Absolute Salinity [ g/kg ] -! CT = Conservative Temperature (ITS-90) [ deg C ] -! p = sea pressure [ dbar ] -! ( i.e. absolute pressure - 10.1325 dbar ) -! -! v_SA_SA = The second derivative of specific volume with respect to -! Absolute Salinity at constant CT & p. [ J/(kg (g/kg)^2) ] -! v_SA_CT = The second derivative of specific volume with respect to -! SA and CT at constant p. [ J/(kg K(g/kg)) ] -! v_CT_CT = The second derivative of specific volume with respect to -! CT at constant SA and p. [ J/(kg K^2) ] -! v_SA_P = The second derivative of specific volume with respect to -! SA and P at constant CT. [ J/(kg K(g/kg)) ] -! v_CT_P = The second derivative of specific volume with respect to -! CT and P at constant SA. [ J/(kg K(g/kg)) ] -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_sfac, offset - -use gsw_mod_specvol_coefficients - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, ct, p -integer, intent(in), optional :: iflag -real (r8), intent(out), optional :: v_sa_sa, v_sa_ct, v_ct_ct, v_sa_p, v_ct_p - -integer :: i -logical :: flags(5) -real (r8) :: v_ct_ct_part, v_ct_p_part, v_sa_ct_part, v_sa_p_part -real (r8) :: v_sa_sa_part, xs, xs2, ys, z - -xs2 = gsw_sfac*sa + offset -xs = sqrt(xs2) -ys = ct*0.025_r8 -z = p*1e-4_r8 - -if (present(iflag)) then - do i = 1, 5 - flags(i) = btest(iflag,i) - end do -else - flags = .true. -end if - -if (present(v_sa_sa) .and. flags(1)) then - - v_sa_sa_part = (-b000 + xs2*(b200 + xs*(2.0_r8*b300 + xs*(3.0_r8*b400 & - + 4.0_r8*b500*xs))) + ys*(-b010 + xs2*(b210 + xs*(2.0_r8*b310 & - + 3.0_r8*b410*xs)) + ys*(-b020 + xs2*(b220 + 2.0_r8*b320*xs) & - + ys*(-b030 + b230*xs2 + ys*(-b040 - b050*ys)))) + z*(-b001 & - + xs2*(b201 + xs*(2.0_r8*b301 + 3.0_r8*b401*xs)) + ys*(-b011 & - + xs2*(b211 + 2.0_r8*b311*xs) + ys*(-b021 + b221*xs2 & - + ys*(-b031 - b041*ys))) + z*(-b002 + xs2*(b202 + 2.0_r8*b302*xs) & - + ys*(-b012 + b212*xs2 + ys*(-b022 - b032*ys)) + z*(-b003 & - - b013*ys - b004*z))))/xs2 - - v_sa_sa = 0.25_r8*gsw_sfac*gsw_sfac*v_sa_sa_part/xs - -end if - -if (present(v_sa_ct) .and. flags(2)) then - - v_sa_ct_part = (b010 + xs*(b110 + xs*(b210 + xs*(b310 + b410*xs))) & - + ys*(2.0_r8*(b020 + xs*(b120 + xs*(b220 + b320*xs))) & - + ys*(3.0_r8*(b030 + xs*(b130 + b230*xs)) + ys*(4.0_r8*(b040 + b140*xs) & - + 5.0_r8*b050*ys))) + z*(b011 + xs*(b111 + xs*(b211 + b311*xs)) & - + ys*(2.0_r8*(b021 + xs*(b121 + b221*xs)) + ys*(3.0_r8*(b031 + b131*xs) & - + 4.0_r8*b041*ys)) + z*(b012 + xs*(b112 + b212*xs) + ys*(2.0_r8*(b022 & - + b122*xs) + 3.0_r8*b032*ys) + b013*z)))/xs - - v_sa_ct = 0.025_r8*0.5_r8*gsw_sfac*v_sa_ct_part - -end if - -if (present(v_ct_ct) .and. flags(3)) then - - v_ct_ct_part = a010 + xs*(a110 + xs*(a210 + xs*(a310 + a410*xs))) & - + ys*(2.0_r8*(a020 + xs*(a120 + xs*(a220 + a320*xs))) & - + ys*(3.0_r8*(a030 + xs*(a130 + a230*xs)) + ys*(4.0_r8*(a040 & - + a140*xs) + 5.0_r8*a050*ys))) + z*( a011 + xs*(a111 + xs*(a211 & - + a311*xs)) + ys*(2.0_r8*(a021 + xs*(a121 + a221*xs)) & - + ys*(3.0_r8*(a031 + a131*xs) + 4.0_r8*a041*ys)) + z*(a012 & - + xs*(a112 + a212*xs) + ys*(2.0_r8*(a022 + a122*xs) & - + 3.0_r8*a032*ys) + a013*z)) - - v_ct_ct = 0.025_r8*0.025_r8*v_ct_ct_part - -end if - -if (present(v_sa_p) .and. flags(4)) then - - v_sa_p_part = b001 + xs*(b101 + xs*(b201 + xs*(b301 + b401*xs))) + ys*(b011 & - + xs*(b111 + xs*(b211 + b311*xs)) + ys*(b021 + xs*(b121 + b221*xs) & - + ys*(b031 + b131*xs + b041*ys))) + z*(2.0_r8*(b002 + xs*(b102 & - + xs*(b202 + b302*xs)) + ys*(b012 + xs*(b112 + b212*xs) + ys*(b022 & - + b122*xs + b032*ys))) + z*(3.0_r8*(b003 + b103*xs + b013*ys) & - + 4.0_r8*b004*z)) - - v_sa_p = 1e-8_r8*0.5_r8*gsw_sfac*v_sa_p_part - -end if - -if (present(v_ct_p) .and. flags(5)) then - - v_ct_p_part = a001 + xs*(a101 + xs*(a201 + xs*(a301 + a401*xs))) + ys*(a011 & - + xs*(a111 + xs*(a211 + a311*xs)) + ys*(a021 + xs*(a121 + a221*xs) & - + ys*(a031 + a131*xs + a041*ys))) + z*(2.0_r8*(a002 + xs*(a102 & - + xs*(a202 + a302*xs)) + ys*(a012 + xs*(a112 + a212*xs) + ys*(a022 & - + a122*xs + a032*ys))) + z*(3.0_r8*(a003 + a103*xs + a013*ys) & - + 4.0_r8*a004*z)) - - v_ct_p = 1e-8_r8*0.025_r8*v_ct_p_part - -end if - -return -end subroutine - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_specvol_second_derivatives.f90 b/src/equation_of_state/TEOS10/gsw_specvol_second_derivatives.f90 new file mode 120000 index 0000000000..cdd1c1b87a --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_specvol_second_derivatives.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_specvol_second_derivatives.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_sr_from_sp.f90 b/src/equation_of_state/TEOS10/gsw_sr_from_sp.f90 deleted file mode 100644 index cbcc4fea0b..0000000000 --- a/src/equation_of_state/TEOS10/gsw_sr_from_sp.f90 +++ /dev/null @@ -1,30 +0,0 @@ -!========================================================================== -elemental function gsw_sr_from_sp (sp) -!========================================================================== -! -! Calculates Reference Salinity, SR, from Practical Salinity, SP. -! -! sp : Practical Salinity [unitless] -! -! gsw_sr_from_sp : Reference Salinity [g/kg] -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_ups - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sp - -real (r8) :: gsw_sr_from_sp - -gsw_sr_from_sp = sp*gsw_ups - -return -end function - -!-------------------------------------------------------------------------- - - - diff --git a/src/equation_of_state/TEOS10/gsw_sr_from_sp.f90 b/src/equation_of_state/TEOS10/gsw_sr_from_sp.f90 new file mode 120000 index 0000000000..eda229ff66 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_sr_from_sp.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_sr_from_sp.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_t_deriv_chem_potential_water_t_exact.f90 b/src/equation_of_state/TEOS10/gsw_t_deriv_chem_potential_water_t_exact.f90 deleted file mode 100644 index 668184491f..0000000000 --- a/src/equation_of_state/TEOS10/gsw_t_deriv_chem_potential_water_t_exact.f90 +++ /dev/null @@ -1,88 +0,0 @@ -!========================================================================== -elemental function gsw_t_deriv_chem_potential_water_t_exact (sa, t, p) -!========================================================================== -! -! Calculates the temperature derivative of the chemical potential of water -! in seawater so that it is valid at exactly SA = 0. -! -! SA = Absolute Salinity [ g/kg ] -! t = in-situ temperature (ITS-90) [ deg C ] -! p = sea pressure [ dbar ] -! ( i.e. absolute pressure - 10.1325 dbar ) -! -! chem_potential_water_dt = temperature derivative of the chemical -! potential of water in seawater [ J g^-1 K^-1 ] -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_sfac, rec_db2pa - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, t, p - -real (r8) :: gsw_t_deriv_chem_potential_water_t_exact - -real (r8) :: g03_t, g08_sa_t, x, x2, y, z, g08_t - -real (r8), parameter :: kg2g = 1e-3_r8 - -! Note. The kg2g, a factor of 1e-3, is needed to convert the output of this -! function into units of J/g. See section (2.9) of the TEOS-10 Manual. - -x2 = gsw_sfac*sa -x = sqrt(x2) -y = t*0.025_r8 -z = p*rec_db2pa ! the input pressure (p) is sea pressure in units of dbar. - -g03_t = 5.90578347909402_r8 + z*(-270.983805184062_r8 + & - z*(776.153611613101_r8 + z*(-196.51255088122_r8 + (28.9796526294175_r8 - & - 2.13290083518327_r8*z)*z))) + & - y*(-24715.571866078_r8 + z*(2910.0729080936_r8 + & - z*(-1513.116771538718_r8 + z*(546.959324647056_r8 + & - z*(-111.1208127634436_r8 + 8.68841343834394_r8*z)))) + & - y*(2210.2236124548363_r8 + z*(-2017.52334943521_r8 + & - z*(1498.081172457456_r8 + z*(-718.6359919632359_r8 + & - (146.4037555781616_r8 - 4.9892131862671505_r8*z)*z))) + & - y*(-592.743745734632_r8 + z*(1591.873781627888_r8 + & - z*(-1207.261522487504_r8 + (608.785486935364_r8 - & - 105.4993508931208_r8*z)*z)) + & - y*(290.12956292128547_r8 + z*(-973.091553087975_r8 + & - z*(602.603274510125_r8 + z*(-276.361526170076_r8 + & - 32.40953340386105_r8*z))) + & - y*(-113.90630790850321_r8 + y*(21.35571525415769_r8 - & - 67.41756835751434_r8*z) + & - z*(381.06836198507096_r8 + z*(-133.7383902842754_r8 + & - 49.023632509086724_r8*z))))))) - -g08_t = x2*(168.072408311545_r8 + & - x*(-493.407510141682_r8 + x*(543.835333000098_r8 + & - x*(-196.028306689776_r8 + 36.7571622995805_r8*x) + & - y*(-137.1145018408982_r8 + y*(148.10030845687618_r8 + & - y*(-68.5590309679152_r8 + 12.4848504784754_r8*y))) - & - 22.6683558512829_r8*z) + z*(-175.292041186547_r8 + & - (83.1923927801819_r8 - 29.483064349429_r8*z)*z) + & - y*(-86.1329351956084_r8 + z*(766.116132004952_r8 + & - z*(-108.3834525034224_r8 + 51.2796974779828_r8*z)) + & - y*(-30.0682112585625_r8 - 1380.9597954037708_r8*z + & - y*(3.50240264723578_r8 + 938.26075044542_r8*z))))) - -g08_sa_t = 1187.3715515697959_r8 + & - x*(-1480.222530425046_r8 + x*(2175.341332000392_r8 + & - x*(-980.14153344888_r8 + 220.542973797483_r8*x) + & - y*(-548.4580073635929_r8 + y*(592.4012338275047_r8 + & - y*(-274.2361238716608_r8 + 49.9394019139016_r8*y))) - & - 90.6734234051316_r8*z) + z*(-525.876123559641_r8 + & - (249.57717834054571_r8 - 88.449193048287_r8*z)*z) + & - y*(-258.3988055868252_r8 + z*(2298.348396014856_r8 + & - z*(-325.1503575102672_r8 + 153.8390924339484_r8*z)) + & - y*(-90.2046337756875_r8 - 4142.8793862113125_r8*z + & - y*(10.50720794170734_r8 + 2814.78225133626_r8*z)))) - -gsw_t_deriv_chem_potential_water_t_exact = kg2g*((g03_t + g08_t)*0.025_r8 - & - 0.5_r8*gsw_sfac*0.025_r8*sa*g08_sa_t) -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_t_deriv_chem_potential_water_t_exact.f90 b/src/equation_of_state/TEOS10/gsw_t_deriv_chem_potential_water_t_exact.f90 new file mode 120000 index 0000000000..3194f69a64 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_t_deriv_chem_potential_water_t_exact.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_t_deriv_chem_potential_water_t_exact.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_t_freezing_exact.f90 b/src/equation_of_state/TEOS10/gsw_t_freezing_exact.f90 deleted file mode 100644 index 63c27db986..0000000000 --- a/src/equation_of_state/TEOS10/gsw_t_freezing_exact.f90 +++ /dev/null @@ -1,71 +0,0 @@ -!========================================================================== -elemental function gsw_t_freezing_exact (sa, p, saturation_fraction) -!========================================================================== -! -! Calculates the in-situ temperature at which seawater freezes. The -! in-situ temperature freezing point is calculated from the exact -! in-situ freezing temperature which is found by a modified Newton-Raphson -! iteration (McDougall and Wotherspoon, 2013) of the equality of the -! chemical potentials of water in seawater and in ice. -! -! An alternative GSW function, gsw_t_freezing_poly, it is based on a -! computationally-efficient polynomial, and is accurate to within -5e-4 K -! and 6e-4 K, when compared with this function. -! -! SA = Absolute Salinity [ g/kg ] -! p = sea pressure [ dbar ] -! ( i.e. absolute pressure - 10.1325 dbar ) -! saturation_fraction = the saturation fraction of dissolved air in -! seawater -! (i.e., saturation_fraction must be between 0 and 1, and the default -! is 1, completely saturated) -! -! t_freezing = in-situ temperature at which seawater freezes. [ deg C ] -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_sso - -use gsw_mod_toolbox, only : gsw_gibbs_ice, gsw_chem_potential_water_t_exact -use gsw_mod_toolbox, only : gsw_t_deriv_chem_potential_water_t_exact -use gsw_mod_toolbox, only : gsw_t_freezing_poly - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, p, saturation_fraction - -real (r8) :: gsw_t_freezing_exact - -real (r8) :: df_dt, p_r, sa_r, tf, tfm, tf_old, x, f - -! The initial value of t_freezing_exact (for air-free seawater) -tf = gsw_t_freezing_poly(sa,p,polynomial=.true.) - -df_dt = 1e3_r8*gsw_t_deriv_chem_potential_water_t_exact(sa,tf,p) - & - gsw_gibbs_ice(1,0,tf,p) -! df_dt here is the initial value of the derivative of the function f whose -! zero (f = 0) we are finding (see Eqn. (3.33.2) of IOC et al (2010)). - -tf_old = tf -f = 1e3_r8*gsw_chem_potential_water_t_exact(sa,tf_old,p) - & - gsw_gibbs_ice(0,0,tf_old,p) -tf = tf_old - f/df_dt -tfm = 0.5_r8*(tf + tf_old) -df_dt = 1e3_r8*gsw_t_deriv_chem_potential_water_t_exact(sa,tfm,p) - & - gsw_gibbs_ice(1,0,tfm,p) -tf = tf_old - f/df_dt - -tf_old = tf -f = 1e3_r8*gsw_chem_potential_water_t_exact(sa,tf_old,p) - & - gsw_gibbs_ice(0,0,tf_old,p) -tf = tf_old - f/df_dt - -! Adjust for the effects of dissolved air -gsw_t_freezing_exact = tf - & - saturation_fraction*(1e-3_r8)*(2.4_r8 - sa/(2.0_r8*gsw_sso)) - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_t_freezing_exact.f90 b/src/equation_of_state/TEOS10/gsw_t_freezing_exact.f90 new file mode 120000 index 0000000000..ca5434983f --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_t_freezing_exact.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_t_freezing_exact.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_t_freezing_poly.f90 b/src/equation_of_state/TEOS10/gsw_t_freezing_poly.f90 deleted file mode 100644 index 479a323d2c..0000000000 --- a/src/equation_of_state/TEOS10/gsw_t_freezing_poly.f90 +++ /dev/null @@ -1,78 +0,0 @@ -!========================================================================== -elemental function gsw_t_freezing_poly (sa, p, saturation_fraction, polynomial) -!========================================================================== -! -! Calculates the in-situ temperature at which seawater freezes from a -! computationally efficient polynomial. -! -! SA = Absolute Salinity [ g/kg ] -! p = sea pressure [ dbar ] -! ( i.e. absolute pressure - 10.1325 dbar ) -! saturation_fraction = the saturation fraction of dissolved air in -! seawater -! -! t_freezing = in-situ temperature at which seawater freezes. [ deg C ] -! (ITS-90) -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_sso - -use gsw_mod_freezing_poly_coefficients - -use gsw_mod_toolbox, only : gsw_ct_freezing_poly, gsw_t_from_ct - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, p -real (r8), intent(in), optional :: saturation_fraction -logical, intent(in), optional :: polynomial - -real (r8) :: gsw_t_freezing_poly - -real (r8) :: p_r, sa_r, x, ctf, sfrac -logical :: direct_poly - -if (present(polynomial)) then - direct_poly = polynomial -else - direct_poly = .false. -end if - -if (.not. direct_poly) then - - if (present(saturation_fraction)) then - sfrac = saturation_fraction - else - sfrac = 1.0_r8 - end if - - ctf = gsw_ct_freezing_poly(sa,p,sfrac) - gsw_t_freezing_poly = gsw_t_from_ct(sa,ctf,p) - -else - - ! Alternative calculation ... - sa_r = sa*1e-2_r8 - x = sqrt(sa_r) - p_r = p*1e-4_r8 - - gsw_t_freezing_poly = t0 & - + sa_r*(t1 + x*(t2 + x*(t3 + x*(t4 + x*(t5 + t6*x))))) & - + p_r*(t7 + p_r*(t8 + t9*p_r)) & - + sa_r*p_r*(t10 + p_r*(t12 + p_r*(t15 + t21*sa_r)) & - + sa_r*(t13 + t17*p_r + t19*sa_r) & - + x*(t11 + p_r*(t14 + t18*p_r) + sa_r*(t16 + t20*p_r + t22*sa_r))) - - if (.not. present(saturation_fraction)) return - - ! Adjust for the effects of dissolved air - gsw_t_freezing_poly = gsw_t_freezing_poly - & - saturation_fraction*(1e-3_r8)*(2.4_r8 - sa/(2.0_r8*gsw_sso)) -end if - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_t_freezing_poly.f90 b/src/equation_of_state/TEOS10/gsw_t_freezing_poly.f90 new file mode 120000 index 0000000000..fcc75a7d80 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_t_freezing_poly.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_t_freezing_poly.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_t_from_ct.f90 b/src/equation_of_state/TEOS10/gsw_t_from_ct.f90 deleted file mode 100644 index 9f85a4530c..0000000000 --- a/src/equation_of_state/TEOS10/gsw_t_from_ct.f90 +++ /dev/null @@ -1,33 +0,0 @@ -!========================================================================== -elemental function gsw_t_from_ct (sa, ct, p) -!========================================================================== -! -! Calculates in-situ temperature from Conservative Temperature of seawater -! -! sa : Absolute Salinity [g/kg] -! ct : Conservative Temperature [deg C] -! -! gsw_t_from_ct : in-situ temperature [deg C] -!-------------------------------------------------------------------------- - -use gsw_mod_toolbox, only : gsw_pt_from_ct, gsw_pt_from_t - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, ct, p - -real (r8) :: gsw_t_from_ct - -real (r8) :: pt0 - -real (r8), parameter :: p0 = 0.0_r8 - -pt0 = gsw_pt_from_ct(sa,ct) -gsw_t_from_ct = gsw_pt_from_t(sa,pt0,p0,p) - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_t_from_ct.f90 b/src/equation_of_state/TEOS10/gsw_t_from_ct.f90 new file mode 120000 index 0000000000..41a33a07b5 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_t_from_ct.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_t_from_ct.f90 \ No newline at end of file diff --git a/src/framework/MOM_array_transform.F90 b/src/framework/MOM_array_transform.F90 new file mode 100644 index 0000000000..179bd6550e --- /dev/null +++ b/src/framework/MOM_array_transform.F90 @@ -0,0 +1,358 @@ +!> 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 + integer, intent(in) :: turns !< Number of quarter turns + real, 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_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 + integer, intent(in) :: turns !< Number of quarter turns + real, intent(out) :: A(:,:,:) !< Rotated array + + 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 + integer, intent(in) :: turns !< Number of quarter turns + real, intent(out) :: A(:,:,:,:) !< Rotated array + + 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 + real, intent(in) :: B_in(:,:) !< Unrotated scalar array pair + integer, intent(in) :: turns !< Number of quarter turns + real, intent(out) :: A(:,:) !< Rotated scalar array pair + real, 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_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 + real, intent(in) :: B_in(:,:,:) !< Unrotated scalar array pair + integer, intent(in) :: turns !< Number of quarter turns + real, intent(out) :: A(:,:,:) !< Rotated scalar array pair + real, intent(out) :: B(:,:,:) !< Rotated scalar array pair + + 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 + real, intent(in) :: B_in(:,:) !< Second component of unrotated vector + integer, intent(in) :: turns !< Number of quarter turns + real, intent(out) :: A(:,:) !< First component of rotated vector + real, intent(out) :: B(:,:) !< Second component of unrotated vector + + 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 + real, intent(in) :: B_in(:,:,:) !< Second component of unrotated vector + integer, intent(in) :: turns !< Number of quarter turns + real, intent(out) :: A(:,:,:) !< First component of rotated vector + real, intent(out) :: B(:,:,:) !< Second component of unrotated vector + + 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 + real, intent(in) :: B_in(:,:,:,:) !< Second component of unrotated vector + integer, intent(in) :: turns !< Number of quarter turns + real, intent(out) :: A(:,:,:,:) !< First component of rotated vector + real, intent(out) :: B(:,:,:,:) !< Second component of unrotated vector + + 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 + integer, intent(in) :: turns !< Number of quarter turns + real, 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_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 + integer, intent(in) :: turns !< Number of quarter turns + real, allocatable, intent(inout) :: A(:,:,:) !< Array on rotated index + + 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 + integer, intent(in) :: turns !< Number of quarter turns + real, allocatable, intent(inout) :: A(:,:,:,:) !< Array on rotated index + + 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/src/framework/MOM_checksums.F90 b/src/framework/MOM_checksums.F90 index ad269f3530..3cc1f316e2 100644 --- a/src/framework/MOM_checksums.F90 +++ b/src/framework/MOM_checksums.F90 @@ -3,12 +3,13 @@ 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_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 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 +use MOM_hor_index, only : hor_index_type, rotate_hor_index use iso_fortran_env, only: error_unit @@ -191,68 +192,126 @@ subroutine subStats(array, aMean, aMin, aMax) 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) + scale, logunit, scalar_pair) character(len=*), intent(in) :: mesg !< Identifying messages - type(hor_index_type), intent(in) :: HI !< A horizontal index type - real, dimension(HI%isd:,HI%jsd:), intent(in) :: arrayA !< The first array to be checksummed - real, dimension(HI%isd:,HI%jsd:), intent(in) :: arrayB !< The second array to be checksummed + 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 + real, dimension(HI%isd:,HI%jsd:), target, intent(in) :: arrayB !< The second array to be checksummed 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 scaling factor for this array. 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 + + 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, 'x '//mesg, HI, haloshift, omit_corners, & + call chksum_h_2d(arrayA_in, 'x '//mesg, HI_in, haloshift, omit_corners, & scale=scale, logunit=logunit) - call chksum_h_2d(arrayB, 'y '//mesg, HI, haloshift, omit_corners, & + call chksum_h_2d(arrayB_in, 'y '//mesg, HI_in, haloshift, omit_corners, & scale=scale, logunit=logunit) else - call chksum_h_2d(arrayA, 'x '//mesg, HI, scale=scale, logunit=logunit) - call chksum_h_2d(arrayB, 'y '//mesg, HI, scale=scale, logunit=logunit) + 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) + scale, logunit, scalar_pair) character(len=*), intent(in) :: mesg !< Identifying messages - type(hor_index_type), intent(in) :: HI !< A horizontal index type - real, dimension(HI%isd:,HI%jsd:, :), intent(in) :: arrayA !< The first array to be checksummed - real, dimension(HI%isd:,HI%jsd:, :), intent(in) :: arrayB !< The second array to be checksummed + 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 + real, dimension(HI%isd:,HI%jsd:, :), target, intent(in) :: arrayB !< The second array to be checksummed 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 scaling factor for this array. 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 + + 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, 'x '//mesg, HI, haloshift, omit_corners, & + call chksum_h_3d(arrayA_in, 'x '//mesg, HI_in, haloshift, omit_corners, & scale=scale, logunit=logunit) - call chksum_h_3d(arrayB, 'y '//mesg, HI, haloshift, omit_corners, & + call chksum_h_3d(arrayB_in, 'y '//mesg, HI_in, haloshift, omit_corners, & scale=scale, logunit=logunit) else - call chksum_h_3d(arrayA, 'x '//mesg, HI, scale=scale, logunit=logunit) - call chksum_h_3d(arrayB, 'y '//mesg, HI, scale=scale, logunit=logunit) + 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, mesg, HI, haloshift, omit_corners, scale, logunit) - 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 +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 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 scaling factor for this array. integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, pointer :: array(:,:) ! Field array on the input grid real, allocatable, dimension(:,:) :: rescaled_array + type(hor_index_type), pointer :: HI ! Horizontal index bounds of the input grid real :: scaling integer :: iounit !< Log IO unit integer :: i, j @@ -260,6 +319,19 @@ subroutine chksum_h_2d(array, mesg, HI, haloshift, omit_corners, scale, logunit) 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))) & @@ -373,31 +445,59 @@ 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) + omit_corners, scale, logunit, scalar_pair) character(len=*), intent(in) :: mesg !< Identifying messages - type(hor_index_type), intent(in) :: HI !< A horizontal index type - real, dimension(HI%isd:,HI%jsd:), intent(in) :: arrayA !< The first array to be checksummed - real, dimension(HI%isd:,HI%jsd:), intent(in) :: arrayB !< The second array to be checksummed + 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 + real, dimension(HI%isd:,HI%jsd:), target, intent(in) :: arrayB !< The second array to be checksummed 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 scaling factor for this array. 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 + + 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, 'x '//mesg, HI, haloshift, symmetric=sym, & + 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, 'y '//mesg, HI, haloshift, symmetric=sym, & + 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, 'x '//mesg, HI, symmetric=sym, scale=scale, & + call chksum_B_2d(arrayA_in, 'x '//mesg, HI_in, symmetric=sym, scale=scale, & logunit=logunit) - call chksum_B_2d(arrayB, 'y '//mesg, HI, symmetric=sym, scale=scale, & + call chksum_B_2d(arrayB_in, 'y '//mesg, HI_in, symmetric=sym, scale=scale, & logunit=logunit) endif @@ -405,40 +505,67 @@ 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) + omit_corners, scale, logunit, scalar_pair) character(len=*), intent(in) :: mesg !< Identifying messages - type(hor_index_type), intent(in) :: HI !< A horizontal index type - real, dimension(HI%IsdB:,HI%JsdB:, :), intent(in) :: arrayA !< The first array to be checksummed - real, dimension(HI%IsdB:,HI%JsdB:, :), intent(in) :: arrayB !< The second array to be checksummed + 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 + real, dimension(HI%IsdB:,HI%JsdB:, :), target, intent(in) :: arrayB !< The second array to be checksummed 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 scaling factor for this array. 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 + + 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, 'x '//mesg, HI, haloshift, symmetric, & + call chksum_B_3d(arrayA_in, 'x '//mesg, HI_in, haloshift, symmetric, & omit_corners, scale=scale, logunit=logunit) - call chksum_B_3d(arrayB, 'y '//mesg, HI, haloshift, symmetric, & + call chksum_B_3d(arrayB_in, 'y '//mesg, HI_in, haloshift, symmetric, & omit_corners, scale=scale, logunit=logunit) else - call chksum_B_3d(arrayA, 'x '//mesg, HI, symmetric=symmetric, scale=scale, & + call chksum_B_3d(arrayA_in, 'x '//mesg, HI_in, symmetric=symmetric, scale=scale, & logunit=logunit) - call chksum_B_3d(arrayB, 'y '//mesg, HI, symmetric=symmetric, scale=scale, & + 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, mesg, HI, haloshift, symmetric, omit_corners, & +subroutine chksum_B_2d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, & scale, logunit) - 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 + 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 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 @@ -447,7 +574,9 @@ subroutine chksum_B_2d(array, mesg, HI, haloshift, symmetric, omit_corners, & real, optional, intent(in) :: scale !< A scaling factor for this array. integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, pointer :: array(:,:) ! Field array on the input grid real, allocatable, dimension(:,:) :: rescaled_array + type(hor_index_type), pointer :: HI ! Horizontal index bounds of the input grid real :: scaling integer :: iounit !< Log IO unit integer :: i, j, Is, Js @@ -455,6 +584,19 @@ subroutine chksum_B_2d(array, mesg, HI, haloshift, symmetric, omit_corners, & 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))) & @@ -585,65 +727,119 @@ 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) + omit_corners, scale, logunit, scalar_pair) character(len=*), intent(in) :: mesg !< Identifying messages - type(hor_index_type), intent(in) :: HI !< A horizontal index type - real, dimension(HI%IsdB:,HI%jsd:), intent(in) :: arrayU !< The u-component array to be checksummed - real, dimension(HI%isd:,HI%JsdB:), intent(in) :: arrayV !< The v-component array to be checksummed + 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 + real, dimension(HI%isd:,HI%JsdB:), target, intent(in) :: arrayV !< The v-component array to be checksummed 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 scaling factor for these arrays. 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 + + 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, 'u '//mesg, HI, haloshift, symmetric, & - omit_corners, scale, logunit=logunit) - call chksum_v_2d(arrayV, 'v '//mesg, HI, haloshift, symmetric, & - omit_corners, scale, logunit=logunit) + 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, 'u '//mesg, HI, symmetric=symmetric, & - logunit=logunit) - call chksum_v_2d(arrayV, 'v '//mesg, HI, symmetric=symmetric, & - logunit=logunit) + 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) + omit_corners, scale, logunit, scalar_pair) character(len=*), intent(in) :: mesg !< Identifying messages - type(hor_index_type), intent(in) :: HI !< A horizontal index type - real, dimension(HI%IsdB:,HI%jsd:,:), intent(in) :: arrayU !< The u-component array to be checksummed - real, dimension(HI%isd:,HI%JsdB:,:), intent(in) :: arrayV !< The v-component array to be checksummed + 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 + real, dimension(HI%isd:,HI%JsdB:,:), target, intent(in) :: arrayV !< The v-component array to be checksummed 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 scaling factor for these arrays. 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 + + 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, 'u '//mesg, HI, haloshift, symmetric, & - omit_corners, scale, logunit=logunit) - call chksum_v_3d(arrayV, 'v '//mesg, HI, haloshift, symmetric, & - omit_corners, scale, logunit=logunit) + 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, 'u '//mesg, HI, symmetric=symmetric, & - logunit=logunit) - call chksum_v_3d(arrayV, 'v '//mesg, HI, symmetric=symmetric, & - logunit=logunit) + 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, mesg, HI, haloshift, symmetric, omit_corners, & +subroutine chksum_u_2d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, & scale, logunit) - 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 + 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 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 @@ -652,7 +848,9 @@ subroutine chksum_u_2d(array, mesg, HI, haloshift, symmetric, omit_corners, & real, optional, intent(in) :: scale !< A scaling factor for this array. integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, pointer :: array(:,:) ! Field array on the input grid real, allocatable, dimension(:,:) :: rescaled_array + type(hor_index_type), pointer :: HI ! Horizontal index bounds of the input grid real :: scaling integer :: iounit !< Log IO unit integer :: i, j, Is @@ -660,6 +858,27 @@ subroutine chksum_u_2d(array, mesg, HI, haloshift, symmetric, omit_corners, & 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))) & @@ -794,10 +1013,10 @@ end subroutine subStats end subroutine chksum_u_2d !> Checksums a 2d array staggered at C-grid v points. -subroutine chksum_v_2d(array, mesg, HI, haloshift, symmetric, omit_corners, & +subroutine chksum_v_2d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, & scale, logunit) - 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 + 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 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 @@ -806,7 +1025,9 @@ subroutine chksum_v_2d(array, mesg, HI, haloshift, symmetric, omit_corners, & real, optional, intent(in) :: scale !< A scaling factor for this array. integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, pointer :: array(:,:) ! Field array on the input grid real, allocatable, dimension(:,:) :: rescaled_array + type(hor_index_type), pointer :: HI ! Horizontal index bounds of the input grid real :: scaling integer :: iounit !< Log IO unit integer :: i, j, Js @@ -814,6 +1035,27 @@ subroutine chksum_v_2d(array, mesg, HI, haloshift, symmetric, omit_corners, & 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))) & @@ -948,16 +1190,18 @@ end subroutine subStats end subroutine chksum_v_2d !> Checksums a 3d array staggered at tracer points. -subroutine chksum_h_3d(array, mesg, HI, haloshift, omit_corners, scale, logunit) - 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 +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 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 scaling factor for this array. integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, pointer :: array(:,:,:) ! Field array on the input grid real, allocatable, dimension(:,:,:) :: rescaled_array + type(hor_index_type), pointer :: HI ! Horizontal index bounds of the input grid real :: scaling integer :: iounit !< Log IO unit integer :: i, j, k @@ -965,6 +1209,19 @@ subroutine chksum_h_3d(array, mesg, HI, haloshift, omit_corners, scale, logunit) 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,:))) & @@ -1080,10 +1337,10 @@ end subroutine subStats end subroutine chksum_h_3d !> Checksums a 3d array staggered at corner points. -subroutine chksum_B_3d(array, mesg, HI, haloshift, symmetric, omit_corners, & +subroutine chksum_B_3d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, & scale, logunit) - 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 + 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 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 @@ -1092,7 +1349,9 @@ subroutine chksum_B_3d(array, mesg, HI, haloshift, symmetric, omit_corners, & real, optional, intent(in) :: scale !< A scaling factor for this array. integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, pointer :: array(:,:,:) ! Field array on the input grid real, allocatable, dimension(:,:,:) :: rescaled_array + type(hor_index_type), pointer :: HI ! Horizontal index bounds of the input grid real :: scaling integer :: iounit !< Log IO unit integer :: i, j, k, Is, Js @@ -1100,6 +1359,19 @@ subroutine chksum_B_3d(array, mesg, HI, haloshift, symmetric, omit_corners, & 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,:))) & @@ -1235,10 +1507,10 @@ end subroutine subStats end subroutine chksum_B_3d !> Checksums a 3d array staggered at C-grid u points. -subroutine chksum_u_3d(array, mesg, HI, haloshift, symmetric, omit_corners, & +subroutine chksum_u_3d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, & scale, logunit) - 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 + 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 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 @@ -1247,7 +1519,9 @@ subroutine chksum_u_3d(array, mesg, HI, haloshift, symmetric, omit_corners, & real, optional, intent(in) :: scale !< A scaling factor for this array. integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, pointer :: array(:,:,:) ! Field array on the input grid real, allocatable, dimension(:,:,:) :: rescaled_array + type(hor_index_type), pointer :: HI ! Horizontal index bounds of the input grid real :: scaling integer :: iounit !< Log IO unit integer :: i, j, k, Is @@ -1255,6 +1529,27 @@ subroutine chksum_u_3d(array, mesg, HI, haloshift, symmetric, omit_corners, & 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,:))) & @@ -1389,10 +1684,10 @@ end subroutine subStats end subroutine chksum_u_3d !> Checksums a 3d array staggered at C-grid v points. -subroutine chksum_v_3d(array, mesg, HI, haloshift, symmetric, omit_corners, & +subroutine chksum_v_3d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, & scale, logunit) - 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 + 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 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 @@ -1401,7 +1696,9 @@ subroutine chksum_v_3d(array, mesg, HI, haloshift, symmetric, omit_corners, & real, optional, intent(in) :: scale !< A scaling factor for this array. integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, pointer :: array(:,:,:) ! Field array on the input grid real, allocatable, dimension(:,:,:) :: rescaled_array + type(hor_index_type), pointer :: HI ! Horizontal index bounds of the input grid real :: scaling integer :: iounit !< Log IO unit integer :: i, j, k, Js @@ -1409,6 +1706,27 @@ subroutine chksum_v_3d(array, mesg, HI, haloshift, symmetric, omit_corners, & integer :: bcN, bcS, bcE, bcW real :: aMean, aMin, aMax 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,:))) & diff --git a/src/framework/MOM_coms.F90 b/src/framework/MOM_coms.F90 index b80ac56baa..0c6b948980 100644 --- a/src/framework/MOM_coms.F90 +++ b/src/framework/MOM_coms.F90 @@ -10,20 +10,19 @@ module MOM_coms use mpp_mod, only : PE_here => mpp_pe, root_PE => mpp_root_pe, num_PEs => mpp_npes use mpp_mod, only : Set_PElist => mpp_set_current_pelist, Get_PElist => mpp_get_current_pelist use mpp_mod, only : broadcast => mpp_broadcast -use mpp_mod, only : sum_across_PEs => mpp_sum, min_across_PEs => mpp_min -use mpp_mod, only : max_across_PEs => mpp_max +use mpp_mod, only : sum_across_PEs => mpp_sum, max_across_PEs => mpp_max, min_across_PEs => mpp_min implicit none ; private public :: PE_here, root_PE, num_PEs, MOM_infra_init, MOM_infra_end public :: broadcast, sum_across_PEs, min_across_PEs, max_across_PEs -public :: reproducing_sum, EFP_list_sum_across_PEs +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 public :: Set_PElist, Get_PElist -! This module provides interfaces to the non-domain-oriented communication -! subroutines. + +! 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. @@ -50,11 +49,22 @@ module MOM_coms 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 distributed 2d or 3d fields +!> 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. !! @@ -75,12 +85,12 @@ module MOM_coms 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. -!! This technique is described in Hallberg & Adcroft, 2014, Parallel Computing, +!! 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_sum_2d(array, isr, ier, jsr, jer, EFP_sum, reproducing, & - overflow_check, err) result(sum) - real, dimension(:,:), intent(in) :: array !< The array to be summed +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 @@ -89,9 +99,6 @@ function reproducing_sum_2d(array, isr, ier, jsr, jer, EFP_sum, reproducing, & !! 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 @@ -99,7 +106,9 @@ function reproducing_sum_2d(array, isr, ier, jsr, jer, EFP_sum, reproducing, & integer, optional, intent(out) :: err !< If present, return an error code instead of !! triggering any fatal errors directly from !! this routine. - real :: sum !< Result + 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 @@ -107,9 +116,9 @@ function reproducing_sum_2d(array, isr, ier, jsr, jer, EFP_sum, reproducing, & integer(kind=8), dimension(ni) :: ints_sum integer(kind=8) :: ival, prec_error - real :: rsum(1), rs + real :: rs real :: max_mag_term - logical :: repro, over_check + logical :: over_check, do_sum_across_PEs character(len=256) :: mesg integer :: i, j, n, is, ie, js, je, sgn @@ -121,94 +130,166 @@ function reproducing_sum_2d(array, isr, ier, jsr, jer, EFP_sum, reproducing, & 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.") + 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_sum_2d.") + 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_sum_2d.") + 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_sum_2d.") + if (jer > je) call MOM_error(FATAL, "Value of jer too large in reproducing_EFP_sum_2d.") je = jer endif - repro = .true. ; if (present(reproducing)) repro = reproducing 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 - if (repro) then - 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 + 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 ; 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 + call carry_overflow(ints_sum, prec_error) + enddo 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 + call increment_ints(ints_sum, real_to_ints(array(i,j), prec_error), & + prec_error) enddo ; enddo - call carry_overflow(ints_sum, prec_error) 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_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_sum(_2d) conversion of "//trim(mesg)) - endif - if (overflow_error) then - call MOM_error(FATAL, "Overflow in reproducing_sum(_2d).") - 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 - call sum_across_PEs(ints_sum, ni) + if (do_sum_across_PEs) call sum_across_PEs(ints_sum, ni) - call regularize_ints(ints_sum) - sum = ints_to_real(ints_sum) + 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), rs + 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, n, 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 - call sum_across_PEs(rsum,1) + if (do_sum_across_PEs) call sum_across_PEs(rsum,1) sum = rsum(1) if (present(err)) then ; err = 0 ; endif @@ -225,10 +306,9 @@ function reproducing_sum_2d(array, isr, ier, jsr, jer, EFP_sum, reproducing, & endif endif endif + if (present(EFP_sum)) EFP_sum%v(:) = ints_sum(:) endif - if (present(EFP_sum)) EFP_sum%v(:) = ints_sum(:) - if (debug) then write(mesg,'("2d RS: ", ES24.16, 6 Z17.16)') sum, ints_sum(1:ni) call MOM_mesg(mesg, 3) @@ -240,7 +320,7 @@ end function reproducing_sum_2d !! 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, err) & +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 @@ -253,20 +333,25 @@ function reproducing_sum_3d(array, isr, ier, jsr, jer, sums, EFP_sum, err) & !! 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 :: max_mag_term + 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, & @@ -278,30 +363,32 @@ function reproducing_sum_3d(array, isr, ier, jsr, jer, sums, EFP_sum, err) & 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).") + 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).") + 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).") + 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).") + 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 - if (present(sums)) then - if (size(sums) > ke) call MOM_error(FATAL, "Sums is smaller than "//& - "the vertical extent of array in reproducing_sum(_3d).") + 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 @@ -339,14 +426,18 @@ function reproducing_sum_3d(array, isr, ier, jsr, jer, sums, EFP_sum, err) & if (overflow_error) call MOM_error(FATAL, "Overflow in reproducing_sum(_3d).") endif - call sum_across_PEs(ints_sums(:,1:ke), ni*ke) + 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)) - sums(k) = ints_to_real(ints_sums(:,k)) - sum = sum + 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 @@ -397,7 +488,7 @@ function reproducing_sum_3d(array, isr, ier, jsr, jer, sums, EFP_sum, err) & if (overflow_error) call MOM_error(FATAL, "Overflow in reproducing_sum(_3d).") endif - call sum_across_PEs(ints_sum, ni) + if (do_sum_across_PEs) call sum_across_PEs(ints_sum, ni) call regularize_ints(ints_sum) sum = ints_to_real(ints_sum) @@ -700,7 +791,7 @@ subroutine EFP_list_sum_across_PEs(EFPs, nval, errors) !! 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 + 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. @@ -742,6 +833,54 @@ subroutine EFP_list_sum_across_PEs(EFPs, nval, errors) 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 + + !> This subroutine carries out all of the calls required to close out the infrastructure cleanly. !! This should only be called in ocean-only runs, as the coupler takes care of this in coupled runs. subroutine MOM_infra_end diff --git a/src/framework/MOM_cpu_clock.F90 b/src/framework/MOM_cpu_clock.F90 index 41849aafb7..a041b06b8b 100644 --- a/src/framework/MOM_cpu_clock.F90 +++ b/src/framework/MOM_cpu_clock.F90 @@ -3,8 +3,9 @@ module MOM_cpu_clock ! This file is part of MOM6. See LICENSE.md for the license. +use fms_mod, only : clock_flag_default use mpp_mod, only : cpu_clock_begin => mpp_clock_begin -use mpp_mod, only : cpu_clock_end => mpp_clock_end, cpu_clock_id => mpp_clock_id +use mpp_mod, only : cpu_clock_end => mpp_clock_end, mpp_clock_id use mpp_mod, only : CLOCK_COMPONENT, CLOCK_SUBCOMPONENT, CLOCK_MODULE_DRIVER use mpp_mod, only : CLOCK_MODULE, CLOCK_ROUTINE, CLOCK_LOOP, CLOCK_INFRA use mpp_mod, only : CLOCK_SYNC => MPP_CLOCK_SYNC @@ -15,4 +16,27 @@ module MOM_cpu_clock public :: CLOCK_COMPONENT, CLOCK_SUBCOMPONENT, CLOCK_MODULE_DRIVER, CLOCK_MODULE public :: CLOCK_ROUTINE, CLOCK_LOOP, CLOCK_INFRA, CLOCK_SYNC +contains + +!> cpu_clock_id returns the integer handle for a named CPU clock. +function cpu_clock_id( name, synchro_flag, grain ) + character(len=*), intent(in) :: name !< The unique name of the CPU clock + integer, intent(in), optional :: synchro_flag !< An integer flag that controls whether the PEs + !! are synchronized before the cpu clocks start counting. + !! Synchronization occurs before the start of a clock if this + !! is odd, while additional (expensive) statistics can set + !! for other values. If absent, the default is taken from the + !! settings for FMS. + integer, intent(in), optional :: grain !< The timing granularity for this clock, usually set to + !! the values of CLOCK_COMPONENT, CLOCK_ROUTINE, CLOCK_LOOP, etc. + integer :: cpu_clock_id !< The integer CPU clock handle. + + if (present(synchro_flag)) then + cpu_clock_id = mpp_clock_id(name, flags=synchro_flag, grain=grain) + else + cpu_clock_id = mpp_clock_id(name, flags=clock_flag_default, grain=grain) + endif + +end function cpu_clock_id + end module MOM_cpu_clock diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index ceb782ce4b..28c4c867d7 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -33,7 +33,7 @@ module MOM_diag_mediator use diag_axis_mod, only : get_diag_axis_name use diag_data_mod, only : null_axis_id use diag_manager_mod, only : diag_manager_init, diag_manager_end -use diag_manager_mod, only : send_data, diag_axis_init, diag_field_add_attribute +use diag_manager_mod, only : send_data, diag_axis_init, EAST, NORTH, diag_field_add_attribute ! The following module is needed for PGI since the following line does not compile with PGI 6.5.0 ! was: use diag_manager_mod, only : register_diag_field_fms=>register_diag_field use MOM_diag_manager_wrapper, only : register_diag_field_fms @@ -243,7 +243,7 @@ module MOM_diag_mediator 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 :: 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 @@ -333,6 +333,9 @@ module MOM_diag_mediator !> 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 + end type diag_ctrl !>@{ CPU clocks @@ -356,25 +359,71 @@ subroutine set_axes_info(G, GV, US, param_file, diag_cs, set_vertical) integer :: i, j, k, 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 - id_xq = diag_axis_init('xq', G%gridLonB(G%isgB:G%iegB), G%x_axis_units, 'x', & - 'q point nominal longitude', Domain2=G%Domain%mpp_domain) - id_yq = diag_axis_init('yq', G%gridLatB(G%jsgB:G%jegB), G%y_axis_units, 'y', & - 'q point nominal latitude', Domain2=G%Domain%mpp_domain) + 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', Domain2=G%Domain%mpp_domain, domain_position=EAST) + id_yq = diag_axis_init('jq', JaxB(G%jsgB:G%jegB), 'none', 'y', & + 'q point grid space latitude', Domain2=G%Domain%mpp_domain, 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', Domain2=G%Domain%mpp_domain, domain_position=EAST) + id_yq = diag_axis_init('yq', G%gridLatB(G%jsgB:G%jegB), G%y_axis_units, 'y', & + 'q point nominal latitude', Domain2=G%Domain%mpp_domain, 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', Domain2=G%Domain%mpp_domain, domain_position=EAST) + id_yq = diag_axis_init('Jq', JaxB(G%jsg:G%jeg), 'none', 'y', & + 'q point grid space latitude', Domain2=G%Domain%mpp_domain, domain_position=NORTH) + else + id_xq = diag_axis_init('xq', G%gridLonB(G%isg:G%ieg), G%x_axis_units, 'x', & + 'q point nominal longitude', Domain2=G%Domain%mpp_domain, domain_position=EAST) + id_yq = diag_axis_init('yq', G%gridLatB(G%jsg:G%jeg), G%y_axis_units, 'y', & + 'q point nominal latitude', Domain2=G%Domain%mpp_domain, 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', Domain2=G%Domain%mpp_domain, domain_position=EAST) + id_yh = diag_axis_init('jh', jax(G%jsg:G%jeg), 'none', 'y', & + 'h point grid space latitude', Domain2=G%Domain%mpp_domain, domain_position=NORTH) else - id_xq = diag_axis_init('xq', G%gridLonB(G%isg:G%ieg), G%x_axis_units, 'x', & - 'q point nominal longitude', Domain2=G%Domain%mpp_domain) - id_yq = diag_axis_init('yq', G%gridLatB(G%jsg:G%jeg), G%y_axis_units, 'y', & - 'q point nominal latitude', Domain2=G%Domain%mpp_domain) + id_xh = diag_axis_init('xh', G%gridLonT(G%isg:G%ieg), G%x_axis_units, 'x', & + 'h point nominal longitude', Domain2=G%Domain%mpp_domain) + id_yh = diag_axis_init('yh', G%gridLatT(G%jsg:G%jeg), G%y_axis_units, 'y', & + 'h point nominal latitude', Domain2=G%Domain%mpp_domain) endif - id_xh = diag_axis_init('xh', G%gridLonT(G%isg:G%ieg), G%x_axis_units, 'x', & - 'h point nominal longitude', Domain2=G%Domain%mpp_domain) - id_yh = diag_axis_init('yh', G%gridLatT(G%jsg:G%jeg), G%y_axis_units, 'y', & - 'h point nominal latitude', Domain2=G%Domain%mpp_domain) if (set_vert) then nz = GV%ke @@ -456,6 +505,10 @@ subroutine set_axes_info(G, GV, US, param_file, diag_cs, set_vertical) ! 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 @@ -524,6 +577,9 @@ subroutine set_axes_info(G, GV, US, param_file, diag_cs, set_vertical) 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) @@ -1205,6 +1261,7 @@ subroutine post_data_0d(diag_field_id, field, diag_cs, is_static) 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() @@ -1216,13 +1273,18 @@ subroutine post_data_0d(diag_field_id, field, diag_cs, is_static) 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(field, diag%debug_str, logunit=diag_cs%chksum_iounit) + call chksum0(locfield, diag%debug_str, logunit=diag_cs%chksum_iounit) else if (is_stat) then - used = send_data(diag%fms_diag_id, field) + used = send_data(diag%fms_diag_id, locfield) elseif (diag_cs%ave_enabled) then - used = send_data(diag%fms_diag_id, field, diag_cs%time_end) + used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end) endif diag => diag%next enddo @@ -1475,14 +1537,16 @@ subroutine post_data_3d(diag_field_id, field, diag_cs, is_static, mask, alt_h) logical :: staggered_in_x, staggered_in_y real, dimension(:,:,:), pointer :: h_diag => NULL() + 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 - if (id_clock_diag_mediator>0) call cpu_clock_begin(id_clock_diag_mediator) - ! 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, & @@ -1502,10 +1566,11 @@ subroutine post_data_3d(diag_field_id, field, diag_cs, is_static, mask, alt_h) 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)) - call vertically_reintegrate_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, diag_cs%missing_value, field, remapped_field) + 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) 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 @@ -1528,7 +1593,7 @@ subroutine post_data_3d(diag_field_id, field, diag_cs, is_static, mask, alt_h) allocate(remapped_field(size(field,1), size(field,2), diag%axes%nz)) call diag_remap_do_remap(diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number), & diag_cs%G, diag_cs%GV, h_diag, staggered_in_x, staggered_in_y, & - diag%axes%mask3d, diag_cs%missing_value, field, remapped_field) + diag%axes%mask3d, field, remapped_field) 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 @@ -1552,7 +1617,7 @@ subroutine post_data_3d(diag_field_id, field, diag_cs, is_static, mask, alt_h) 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, diag_cs%missing_value, field, remapped_field) + diag%axes%mask3d, field, remapped_field) 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 @@ -1769,7 +1834,7 @@ subroutine post_xy_average(diag_cs, diag, field) 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, & - diag_cs%missing_value, field, & + field, & averaged_field, averaged_mask) else nz = size(field, 3) @@ -1788,7 +1853,7 @@ subroutine post_xy_average(diag_cs, diag, field) diag_cs%diag_remap_cs(coord)%h, & staggered_in_x, staggered_in_y, & diag%axes%is_layer, diag%v_extensive, & - diag_cs%missing_value, field, & + field, & averaged_field, averaged_mask) endif @@ -3016,11 +3081,15 @@ subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir) default=1) call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=.true.) + default=.false.) call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", answers_2018, & "If true, use the order of arithmetic and expressions that recover the "//& "answers from the end of 2018. Otherwise, use updated and more robust "//& "forms of the same expressions.", default=default_2018_answers) + 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* @@ -3064,6 +3133,7 @@ subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir) diag_cs%S => null() diag_cs%eqn_of_state => 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 @@ -3192,7 +3262,7 @@ subroutine diag_set_state_ptrs(h, T, S, eqn_of_state, diag_cs) !> 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) +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] @@ -3200,11 +3270,17 @@ subroutine diag_update_remap_grids(diag_cs, alt_h, alt_T, alt_S) !! the current temperatures real, target, optional, intent(in ) :: alt_S(:,:,:) !< Used if remapped grids should be something other than !! the current salinity + 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 :: i real, dimension(:,:,:), pointer :: h_diag => NULL() ! The layer thickneses for diagnostics [H ~> m or kg m-2] real, dimension(:,:,:), pointer :: T_diag => NULL(), S_diag => NULL() + logical :: update_intensive_local, update_extensive_local + ! Set values based on optional input arguments if (present(alt_h)) then h_diag => alt_h else @@ -3223,6 +3299,15 @@ subroutine diag_update_remap_grids(diag_cs, alt_h, alt_T, alt_S) 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 @@ -3230,10 +3315,19 @@ subroutine diag_update_remap_grids(diag_cs, alt_h, alt_T, alt_S) "diagnostic structure have been overridden") endif - do i=1, diag_cs%num_diag_coords - call diag_remap_update(diag_cs%diag_remap_cs(i), diag_cs%G, diag_cs%GV, diag_cs%US, & - h_diag, T_diag, S_diag, diag_cs%eqn_of_state) - enddo + if (update_intensive_local) then + do i=1, diag_cs%num_diag_coords + call diag_remap_update(diag_cs%diag_remap_cs(i), 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(i)%h) + enddo + endif + if (update_extensive_local) then + diag_cs%h_begin(:,:,:) = diag_cs%h(:,:,:) + do i=1, diag_cs%num_diag_coords + call diag_remap_update(diag_cs%diag_remap_cs(i), 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(i)%h_extensive) + enddo + endif #if defined(DEBUG) || defined(__DO_SAFETY_CHECKS__) ! Keep a copy of H - used to check whether grids are up-to-date @@ -4223,4 +4317,3 @@ subroutine downsample_mask_3d(field_in, field_out, dl, isc_o, jsc_o, isc_d, iec_ end subroutine downsample_mask_3d end module MOM_diag_mediator - diff --git a/src/framework/MOM_diag_remap.F90 b/src/framework/MOM_diag_remap.F90 index cadd74950a..4e12abaa5b 100644 --- a/src/framework/MOM_diag_remap.F90 +++ b/src/framework/MOM_diag_remap.F90 @@ -31,11 +31,11 @@ ! ! For interpolation between h and u grids, we use the following relations: ! -! h->u: f_u[ig] = 0.5 * (f_h[ ig ] + f_h[ig+1]) -! f_u[i1] = 0.5 * (f_h[i1-1] + f_h[ i1 ]) +! h->u: f_u(ig) = 0.5 * (f_h( ig ) + f_h(ig+1)) +! f_u(i1) = 0.5 * (f_h(i1-1) + f_h( i1 )) ! -! u->h: f_h[ig] = 0.5 * (f_u[ig-1] + f_u[ ig ]) -! f_h[i1] = 0.5 * (f_u[ i1 ] + f_u[i1+1]) +! u->h: f_h(ig) = 0.5 * (f_u(ig-1) + f_u( ig )) +! f_h(i1) = 0.5 * (f_u( i1 ) + f_u(i1+1)) ! ! where ig is the grid index and i1 is the 1-based index. That is, a 1-based ! u-point is ahead of its matching h-point in non-symmetric mode, but behind @@ -57,7 +57,8 @@ module MOM_diag_remap ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_coms, only : reproducing_sum +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_diag_vkernels, only : interpolate_column, reintegrate_column use MOM_file_parser, only : get_param, log_param, param_file_type @@ -109,10 +110,11 @@ module MOM_diag_remap 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 coordiantes 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 - real, dimension(:), allocatable :: dz !< Nominal layer thicknesses + real, dimension(:,:,:), allocatable :: h !< Remap grid thicknesses [H ~> m or kg m-2] + real, dimension(:,:,:), allocatable :: h_extensive !< Remap grid thicknesses for extensive + !! variables [H ~> m or kg m-2] integer :: interface_axes_id = 0 !< Vertical axes id for remapping at interfaces integer :: layer_axes_id = 0 !< Vertical axes id for remapping on layers logical :: answers_2018 !< If true, use the order of arithmetic and expressions for remapping @@ -149,7 +151,6 @@ 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) - if (allocated(remap_cs%dz)) deallocate(remap_cs%dz) remap_cs%configured = .false. remap_cs%initialized = .false. remap_cs%used = .false. @@ -271,15 +272,16 @@ function diag_remap_axes_configured(remap_cs) !! 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) - 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(:, :, :), intent(in) :: h !< New thickness [H ~> m or kg m-2] - real, dimension(:, :, :), intent(in) :: T !< New temperatures [degC] - real, dimension(:, :, :), intent(in) :: S !< New salinities [ppt] - type(EOS_type), pointer :: eqn_of_state !< A pointer to the equation of state +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(:,:,:), intent(in) :: h !< New thickness [H ~> m or kg m-2] + real, dimension(:,:,:), intent(in) :: T !< New temperatures [degC] + real, dimension(:,:,:), intent(in) :: S !< New salinities [ppt] + type(EOS_type), pointer :: eqn_of_state !< A pointer to the equation of state + real, dimension(:,:,:), intent(inout) :: h_target !< The new diagnostic thicknesses [H ~> m or kg m-2] ! Local variables real, dimension(remap_cs%nz + 1) :: zInterfaces ! Interface positions [H ~> m or kg m-2] @@ -305,7 +307,6 @@ subroutine diag_remap_update(remap_cs, G, GV, US, h, T, S, eqn_of_state) ! Initialize remapping and regridding on the first call call initialize_remapping(remap_cs%remap_cs, 'PPM_IH4', boundary_extrapolation=.false., & answers_2018=remap_cs%answers_2018) - allocate(remap_cs%h(G%isd:G%ied,G%jsd:G%jed, nz)) remap_cs%initialized = .true. endif @@ -314,7 +315,7 @@ subroutine diag_remap_update(remap_cs, G, GV, US, h, T, S, eqn_of_state) ! assumption that h, T, S has changed. do j=G%jsc-1, G%jec+1 ; do i=G%isc-1, G%iec+1 if (G%mask2dT(i,j)==0.) then - remap_cs%h(i,j,:) = 0. + h_target(i,j,:) = 0. cycle endif @@ -326,9 +327,8 @@ subroutine diag_remap_update(remap_cs, G, GV, US, h, T, S, eqn_of_state) call build_sigma_column(get_sigma_CS(remap_cs%regrid_cs), & GV%Z_to_H*G%bathyT(i,j), sum(h(i,j,:)), zInterfaces) elseif (remap_cs%vertical_coord == coordinateMode('RHO')) then -!### I think that the conversion factor in the 2nd line should be GV%Z_to_H call build_rho_column(get_rho_CS(remap_cs%regrid_cs), G%ke, & - US%Z_to_m*G%bathyT(i,j), h(i,j,:), T(i,j,:), S(i,j,:), & + GV%Z_to_H*G%bathyT(i,j), h(i,j,:), T(i,j,:), S(i,j,:), & eqn_of_state, zInterfaces, h_neglect, h_neglect_edge) elseif (remap_cs%vertical_coord == coordinateMode('SLIGHT')) then ! call build_slight_column(remap_cs%regrid_cs,remap_cs%remap_cs, nz, & @@ -339,28 +339,29 @@ subroutine diag_remap_update(remap_cs, G, GV, US, h, T, S, eqn_of_state) ! GV%Z_to_H*G%bathyT(i,j), sum(h(i,j,:)), zInterfaces) call MOM_error(FATAL,"diag_remap_update: HYCOM1 coordinate not coded for diagnostics yet!") endif - remap_cs%h(i,j,:) = zInterfaces(1:nz) - zInterfaces(2:nz+1) + do k = 1,nz + h_target(i,j,k) = zInterfaces(k) - zInterfaces(k+1) + enddo enddo ; enddo end subroutine diag_remap_update !> Remap diagnostic field to alternative vertical grid. subroutine diag_remap_do_remap(remap_cs, G, GV, h, staggered_in_x, staggered_in_y, & - mask, missing_value, field, remapped_field) + mask, field, remapped_field) type(diag_remap_ctrl), intent(in) :: remap_cs !< Diagnostic coodinate control structure type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - real, dimension(:,:,:), intent(in) :: h !< The current thicknesses + real, dimension(:,:,:), intent(in) :: h !< The current thicknesses [H ~> m or kg m-2] 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 - real, intent(in) :: missing_value !< A missing_value to assign land/vanished points - real, dimension(:,:,:), intent(in) :: field(:,:,:) !< The diagnostic field to be remapped - real, dimension(:,:,:), intent(inout) :: remapped_field !< Field remapped to new coordinate + 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(inout) :: remapped_field !< Field remapped to new coordinate [A] ! Local variables - real, dimension(remap_cs%nz) :: h_dest - real, dimension(size(h,3)) :: h_src - real :: h_neglect, h_neglect_edge + real, dimension(remap_cs%nz) :: h_dest ! Destination thicknesses [H ~> m or kg m-2] + real, dimension(size(h,3)) :: h_src ! A column of source thicknesses [H ~> m or kg m-2] + real :: h_neglect, h_neglect_edge ! Negligible thicknesses [H ~> m or kg m-2] integer :: nz_src, nz_dest integer :: i, j, k !< Grid index integer :: i1, j1 !< 1-based index @@ -443,14 +444,15 @@ end subroutine diag_remap_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 coodinate control structure - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - real, dimension(:,:,:), intent(out) :: mask !< h-point mask for target grid + type(diag_remap_ctrl), intent(in) :: remap_cs !< Diagnostic coodinate control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + real, dimension(:,:,:), intent(out) :: mask !< h-point mask for target grid [nondim] ! Local variables - real, dimension(remap_cs%nz) :: h_dest + real, dimension(remap_cs%nz) :: h_dest ! Destination thicknesses [H ~> m or kg m-2] integer :: i, j, k logical :: mask_vanished_layers - real :: h_tot, h_err + real :: h_tot ! Sum of all thicknesses [H ~> m or kg m-2] + real :: h_err ! An estimate of a negligible thickness [H ~> m or kg m-2] call assert(remap_cs%initialized, 'diag_remap_calc_hmask: remap_cs not initialized.') @@ -485,20 +487,20 @@ subroutine diag_remap_calc_hmask(remap_cs, G, mask) 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, staggered_in_x, staggered_in_y, & - mask, missing_value, field, reintegrated_field) +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 coodinate control structure - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - real, dimension(:,:,:), intent(in) :: h !< The current thicknesses + 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] + real, dimension(:,:,:), intent(in) :: h_target !< The thicknesses of the target grid [H ~> m or kg m-2] 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 - real, intent(in) :: missing_value !< A missing_value to assign land/vanished points - real, dimension(:,:,:), intent(in) :: field !< The diagnostic field to be remapped - real, dimension(:,:,:), intent(inout) :: reintegrated_field !< Field argument remapped to alternative coordinate + 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(inout) :: reintegrated_field !< Field argument remapped to alternative coordinate [A] ! Local variables - real, dimension(remap_cs%nz) :: h_dest - real, dimension(size(h,3)) :: h_src + real, dimension(remap_cs%nz) :: h_dest ! Destination thicknesses [H ~> m or kg m-2] + real, dimension(size(h,3)) :: h_src ! A column of source thicknesses [H ~> m or kg m-2] integer :: nz_src, nz_dest integer :: i, j, k !< Grid index integer :: i1, j1 !< 1-based index @@ -526,7 +528,7 @@ subroutine vertically_reintegrate_diag_field(remap_cs, G, h, staggered_in_x, sta if (mask(I,j,1) == 0.) cycle endif h_src(:) = 0.5 * (h(i_lo,j,:) + h(i_hi,j,:)) - h_dest(:) = 0.5 * (remap_cs%h(i_lo,j,:) + remap_cs%h(i_hi,j,:)) + h_dest(:) = 0.5 * (h_target(i_lo,j,:) + h_target(i_hi,j,:)) call reintegrate_column(nz_src, h_src, field(I1,j,:), & nz_dest, h_dest, 0., reintegrated_field(I1,j,:)) enddo @@ -541,7 +543,7 @@ subroutine vertically_reintegrate_diag_field(remap_cs, G, h, staggered_in_x, sta if (mask(i,J,1) == 0.) cycle endif h_src(:) = 0.5 * (h(i,j_lo,:) + h(i,j_hi,:)) - h_dest(:) = 0.5 * (remap_cs%h(i,j_lo,:) + remap_cs%h(i,j_hi,:)) + h_dest(:) = 0.5 * (h_target(i,j_lo,:) + h_target(i,j_hi,:)) call reintegrate_column(nz_src, h_src, field(i,J1,:), & nz_dest, h_dest, 0., reintegrated_field(i,J1,:)) enddo @@ -554,7 +556,7 @@ subroutine vertically_reintegrate_diag_field(remap_cs, G, h, staggered_in_x, sta if (mask(i,j,1) == 0.) cycle endif h_src(:) = h(i,j,:) - h_dest(:) = remap_cs%h(i,j,:) + h_dest(:) = h_target(i,j,:) call reintegrate_column(nz_src, h_src, field(i,j,:), & nz_dest, h_dest, 0., reintegrated_field(i,j,:)) enddo @@ -567,19 +569,18 @@ end subroutine vertically_reintegrate_diag_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, missing_value, field, interpolated_field) + mask, field, interpolated_field) type(diag_remap_ctrl), intent(in) :: remap_cs !< Diagnostic coodinate control structure - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - real, dimension(:,:,:), intent(in) :: h !< The current thicknesses + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + real, dimension(:,:,:), intent(in) :: h !< The current thicknesses [H ~> m or kg m-2] 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 - real, intent(in) :: missing_value !< A missing_value to assign land/vanished points - real, dimension(:,:,:), intent(in) :: field !< The diagnostic field to be remapped - real, dimension(:,:,:), intent(inout) :: interpolated_field !< Field argument remapped to alternative coordinate + 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(inout) :: interpolated_field !< Field argument remapped to alternative coordinate [A] ! Local variables - real, dimension(remap_cs%nz) :: h_dest - real, dimension(size(h,3)) :: h_src + real, dimension(remap_cs%nz) :: h_dest ! Destination thicknesses [H ~> m or kg m-2] + real, dimension(size(h,3)) :: h_src ! A column of source thicknesses [H ~> m or kg m-2] integer :: nz_src, nz_dest integer :: i, j, k !< Grid index integer :: i1, j1 !< 1-based index @@ -650,24 +651,24 @@ end subroutine vertically_interpolate_diag_field !> Horizontally average field subroutine horizontally_average_diag_field(G, GV, h, staggered_in_x, staggered_in_y, & is_layer, is_extensive, & - missing_value, field, averaged_field, & + 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 + 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, intent(in) :: missing_value !< A missing_value to assign land/vanished points - real, dimension(:,:,:), intent(in) :: field !< The diagnostic field to be remapped - real, dimension(:), intent(inout) :: averaged_field !< Field argument horizontally averaged - logical, dimension(:), intent(inout) :: averaged_mask !< Mask for horizontally averaged field + real, dimension(:,:,:), intent(in) :: field !< The diagnostic field to be remapped [A] + real, dimension(:), intent(inout) :: averaged_field !< Field argument horizontally averaged [A] + logical, dimension(:), intent(inout) :: averaged_mask !< Mask for horizontally averaged field [nondim] ! Local variables real, dimension(G%isc:G%iec, G%jsc:G%jec, size(field,3)) :: volume, stuff real, dimension(size(field, 3)) :: vol_sum, stuff_sum ! nz+1 is needed for interface averages - real :: height + 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 integer :: i1, j1 !< 1-based index @@ -771,9 +772,16 @@ subroutine horizontally_average_diag_field(G, GV, h, staggered_in_x, staggered_i call assert(.false., 'horizontally_average_diag_field: Q point averaging is not coded yet.') endif - do k = 1,nz - vol_sum(k) = reproducing_sum(volume(:,:,k)) - stuff_sum(k) = reproducing_sum(stuff(:,:,k)) + ! 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. diff --git a/src/framework/MOM_diag_vkernels.F90 b/src/framework/MOM_diag_vkernels.F90 index 1b8fb58b6d..b7c1130521 100644 --- a/src/framework/MOM_diag_vkernels.F90 +++ b/src/framework/MOM_diag_vkernels.F90 @@ -4,6 +4,8 @@ module MOM_diag_vkernels ! 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 diag_vkernels_unit_tests @@ -173,8 +175,8 @@ logical function diag_vkernels_unit_tests(verbose) v = verbose - write(0,*) '==== MOM_diag_kernels: diag_vkernels_unit_tests ==========' - if (v) write(0,*) '- - - - - - - - - - interpolation tests - - - - - - - - -' + write(stdout,*) '==== MOM_diag_kernels: diag_vkernels_unit_tests ==========' + if (v) write(stdout,*) '- - - - - - - - - - interpolation tests - - - - - - - - -' fail = test_interp(v,mv,'Identity: 3 layer', & 3, (/1.,2.,3./), (/1.,2.,3.,4./), & @@ -221,7 +223,7 @@ logical function diag_vkernels_unit_tests(verbose) 4, (/0.,2.,6.,0./), (/mv,1.,3.,8.,mv/) ) diag_vkernels_unit_tests = diag_vkernels_unit_tests .or. fail - if (v) write(0,*) '- - - - - - - - - - reintegration tests - - - - - - - - -' + if (v) write(stdout,*) '- - - - - - - - - - reintegration tests - - - - - - - - -' fail = test_reintegrate(v,mv,'Identity: 3 layer', & 3, (/1.,2.,3./), (/-5.,2.,1./), & @@ -273,7 +275,7 @@ logical function diag_vkernels_unit_tests(verbose) 3, (/0.,0.,0./), (/mv, mv, mv/) ) diag_vkernels_unit_tests = diag_vkernels_unit_tests .or. fail - if (.not. fail) write(*,*) 'Pass' + if (.not. fail) write(stdout,*) 'Pass' end function diag_vkernels_unit_tests @@ -302,14 +304,15 @@ logical function test_interp(verbose, missing_value, msg, nsrc, h_src, u_src, nd if (u_dest(k)/=u_true(k)) test_interp = .true. enddo if (verbose .or. test_interp) then - write(0,'(2a)') ' Test: ',msg - write(0,'(a3,3(a24))') 'k','u_result','u_true','error' + 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(0,'(i3,3(1pe24.16))') k,u_dest(k),u_true(k),u_dest(k)-u_true(k) + write(stdout,'(i3,3(1pe24.16))') k,u_dest(k),u_true(k),u_dest(k)-u_true(k) else - write(0,'(i3,3(1pe24.16),x,a)') k,u_dest(k),u_true(k),u_dest(k)-u_true(k),'<--- WRONG!' + write(stdout,'(i3,3(1pe24.16),x,a)') k,u_dest(k),u_true(k),u_dest(k)-u_true(k),'<--- WRONG!' + write(stderr,'(i3,3(1pe24.16),x,a)') k,u_dest(k),u_true(k),u_dest(k)-u_true(k),'<--- WRONG!' endif enddo endif @@ -340,14 +343,15 @@ logical function test_reintegrate(verbose, missing_value, msg, nsrc, h_src, uh_s if (uh_dest(k)/=uh_true(k)) test_reintegrate = .true. enddo if (verbose .or. test_reintegrate) then - write(0,'(2a)') ' Test: ',msg - write(0,'(a3,3(a24))') 'k','uh_result','uh_true','error' + 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(0,'(i3,3(1pe24.16))') k,uh_dest(k),uh_true(k),uh_dest(k)-uh_true(k) + write(stdout,'(i3,3(1pe24.16))') k,uh_dest(k),uh_true(k),uh_dest(k)-uh_true(k) else - write(0,'(i3,3(1pe24.16),x,a)') k,uh_dest(k),uh_true(k),uh_dest(k)-uh_true(k),'<--- WRONG!' + write(stdout,'(i3,3(1pe24.16),x,a)') k,uh_dest(k),uh_true(k),uh_dest(k)-uh_true(k),'<--- WRONG!' + write(stderr,'(i3,3(1pe24.16),x,a)') k,uh_dest(k),uh_true(k),uh_dest(k)-uh_true(k),'<--- WRONG!' endif enddo endif diff --git a/src/framework/MOM_document.F90 b/src/framework/MOM_document.F90 index 6c4c1f1ebb..15d0839ee9 100644 --- a/src/framework/MOM_document.F90 +++ b/src/framework/MOM_document.F90 @@ -85,7 +85,7 @@ end subroutine doc_param_none !> This subroutine handles parameter documentation for logicals. subroutine doc_param_logical(doc, varname, desc, units, val, default, & - layoutParam, debuggingParam) + layoutParam, debuggingParam, like_default) type(doc_type), pointer :: doc !< A pointer to a structure that controls where the !! documentation occurs and its formatting character(len=*), intent(in) :: varname !< The name of the parameter being documented @@ -95,6 +95,8 @@ subroutine doc_param_logical(doc, varname, desc, units, val, default, & logical, optional, intent(in) :: default !< The default value of this parameter logical, optional, intent(in) :: layoutParam !< If present and true, this is a layout parameter. logical, optional, intent(in) :: debuggingParam !< If present and true, this is a debugging parameter. + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as though + !! it has the default value, even if there is no default. ! This subroutine handles parameter documentation for logicals. character(len=mLen) :: mesg logical :: equalsDefault @@ -110,6 +112,7 @@ subroutine doc_param_logical(doc, varname, desc, units, val, default, & endif equalsDefault = .false. + if (present(like_default)) equalsDefault = like_default if (present(default)) then if (val .eqv. default) equalsDefault = .true. if (default) then @@ -127,7 +130,7 @@ end subroutine doc_param_logical !> This subroutine handles parameter documentation for arrays of logicals. subroutine doc_param_logical_array(doc, varname, desc, units, vals, default, & - layoutParam, debuggingParam) + layoutParam, debuggingParam, like_default) type(doc_type), pointer :: doc !< A pointer to a structure that controls where the !! documentation occurs and its formatting character(len=*), intent(in) :: varname !< The name of the parameter being documented @@ -137,6 +140,8 @@ subroutine doc_param_logical_array(doc, varname, desc, units, vals, default, & logical, optional, intent(in) :: default !< The default value of this parameter logical, optional, intent(in) :: layoutParam !< If present and true, this is a layout parameter. logical, optional, intent(in) :: debuggingParam !< If present and true, this is a debugging parameter. + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as though + !! it has the default value, even if there is no default. ! This subroutine handles parameter documentation for arrays of logicals. integer :: i character(len=mLen) :: mesg @@ -158,7 +163,7 @@ subroutine doc_param_logical_array(doc, varname, desc, units, vals, default, & mesg = define_string(doc, varname, valstring, units) - equalsDefault = .false. + equalsDefault = .false. if (present(default)) then equalsDefault = .true. do i=1,size(vals) ; if (vals(i) .neqv. default) equalsDefault = .false. ; enddo @@ -168,6 +173,7 @@ subroutine doc_param_logical_array(doc, varname, desc, units, vals, default, & mesg = trim(mesg)//" default = "//STRING_FALSE endif endif + if (present(like_default)) then ; if (like_default) equalsDefault = .true. ; endif if (mesgHasBeenDocumented(doc, varName, mesg)) return ! Avoid duplicates call writeMessageAndDesc(doc, mesg, desc, equalsDefault, & @@ -177,7 +183,7 @@ end subroutine doc_param_logical_array !> This subroutine handles parameter documentation for integers. subroutine doc_param_int(doc, varname, desc, units, val, default, & - layoutParam, debuggingParam) + layoutParam, debuggingParam, like_default) type(doc_type), pointer :: doc !< A pointer to a structure that controls where the !! documentation occurs and its formatting character(len=*), intent(in) :: varname !< The name of the parameter being documented @@ -187,6 +193,8 @@ subroutine doc_param_int(doc, varname, desc, units, val, default, & integer, optional, intent(in) :: default !< The default value of this parameter logical, optional, intent(in) :: layoutParam !< If present and true, this is a layout parameter. logical, optional, intent(in) :: debuggingParam !< If present and true, this is a debugging parameter. + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as though + !! it has the default value, even if there is no default. ! This subroutine handles parameter documentation for integers. character(len=mLen) :: mesg character(len=doc%commentColumn) :: valstring @@ -200,6 +208,7 @@ subroutine doc_param_int(doc, varname, desc, units, val, default, & mesg = define_string(doc, varname, valstring, units) equalsDefault = .false. + if (present(like_default)) equalsDefault = like_default if (present(default)) then if (val == default) equalsDefault = .true. mesg = trim(mesg)//" default = "//(trim(int_string(default))) @@ -213,7 +222,7 @@ end subroutine doc_param_int !> This subroutine handles parameter documentation for arrays of integers. subroutine doc_param_int_array(doc, varname, desc, units, vals, default, & - layoutParam, debuggingParam) + layoutParam, debuggingParam, like_default) type(doc_type), pointer :: doc !< A pointer to a structure that controls where the !! documentation occurs and its formatting character(len=*), intent(in) :: varname !< The name of the parameter being documented @@ -223,6 +232,8 @@ subroutine doc_param_int_array(doc, varname, desc, units, vals, default, & integer, optional, intent(in) :: default !< The default value of this parameter logical, optional, intent(in) :: layoutParam !< If present and true, this is a layout parameter. logical, optional, intent(in) :: debuggingParam !< If present and true, this is a debugging parameter. + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as though + !! it has the default value, even if there is no default. ! This subroutine handles parameter documentation for arrays of integers. integer :: i character(len=mLen) :: mesg @@ -246,6 +257,7 @@ subroutine doc_param_int_array(doc, varname, desc, units, vals, default, & do i=1,size(vals) ; if (vals(i) /= default) equalsDefault = .false. ; enddo mesg = trim(mesg)//" default = "//(trim(int_string(default))) endif + if (present(like_default)) then ; if (like_default) equalsDefault = .true. ; endif if (mesgHasBeenDocumented(doc, varName, mesg)) return ! Avoid duplicates call writeMessageAndDesc(doc, mesg, desc, equalsDefault, & @@ -255,7 +267,7 @@ subroutine doc_param_int_array(doc, varname, desc, units, vals, default, & end subroutine doc_param_int_array !> This subroutine handles parameter documentation for reals. -subroutine doc_param_real(doc, varname, desc, units, val, default, debuggingParam) +subroutine doc_param_real(doc, varname, desc, units, val, default, debuggingParam, like_default) type(doc_type), pointer :: doc !< A pointer to a structure that controls where the !! documentation occurs and its formatting character(len=*), intent(in) :: varname !< The name of the parameter being documented @@ -264,6 +276,8 @@ subroutine doc_param_real(doc, varname, desc, units, val, default, debuggingPara real, intent(in) :: val !< The value of this parameter real, optional, intent(in) :: default !< The default value of this parameter logical, optional, intent(in) :: debuggingParam !< If present and true, this is a debugging parameter. + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as though + !! it has the default value, even if there is no default. ! This subroutine handles parameter documentation for reals. character(len=mLen) :: mesg character(len=doc%commentColumn) :: valstring @@ -277,6 +291,7 @@ subroutine doc_param_real(doc, varname, desc, units, val, default, debuggingPara mesg = define_string(doc, varname, valstring, units) equalsDefault = .false. + if (present(like_default)) equalsDefault = like_default if (present(default)) then if (val == default) equalsDefault = .true. mesg = trim(mesg)//" default = "//trim(real_string(default)) @@ -288,7 +303,7 @@ subroutine doc_param_real(doc, varname, desc, units, val, default, debuggingPara end subroutine doc_param_real !> This subroutine handles parameter documentation for arrays of reals. -subroutine doc_param_real_array(doc, varname, desc, units, vals, default, debuggingParam) +subroutine doc_param_real_array(doc, varname, desc, units, vals, default, debuggingParam, like_default) type(doc_type), pointer :: doc !< A pointer to a structure that controls where the !! documentation occurs and its formatting character(len=*), intent(in) :: varname !< The name of the parameter being documented @@ -297,6 +312,8 @@ subroutine doc_param_real_array(doc, varname, desc, units, vals, default, debugg real, intent(in) :: vals(:) !< The array of values to record real, optional, intent(in) :: default !< The default value of this parameter logical, optional, intent(in) :: debuggingParam !< If present and true, this is a debugging parameter. + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as though + !! it has the default value, even if there is no default. ! This subroutine handles parameter documentation for arrays of reals. integer :: i character(len=mLen) :: mesg @@ -317,6 +334,7 @@ subroutine doc_param_real_array(doc, varname, desc, units, vals, default, debugg do i=1,size(vals) ; if (vals(i) /= default) equalsDefault = .false. ; enddo mesg = trim(mesg)//" default = "//trim(real_string(default)) endif + if (present(like_default)) then ; if (like_default) equalsDefault = .true. ; endif if (mesgHasBeenDocumented(doc, varName, mesg)) return ! Avoid duplicates call writeMessageAndDesc(doc, mesg, desc, equalsDefault, debuggingParam=debuggingParam) @@ -326,7 +344,7 @@ end subroutine doc_param_real_array !> This subroutine handles parameter documentation for character strings. subroutine doc_param_char(doc, varname, desc, units, val, default, & - layoutParam, debuggingParam) + layoutParam, debuggingParam, like_default) type(doc_type), pointer :: doc !< A pointer to a structure that controls where the !! documentation occurs and its formatting character(len=*), intent(in) :: varname !< The name of the parameter being documented @@ -337,6 +355,8 @@ subroutine doc_param_char(doc, varname, desc, units, val, default, & optional, intent(in) :: default !< The default value of this parameter logical, optional, intent(in) :: layoutParam !< If present and true, this is a layout parameter. logical, optional, intent(in) :: debuggingParam !< If present and true, this is a debugging parameter. + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as though + !! it has the default value, even if there is no default. ! This subroutine handles parameter documentation for character strings. character(len=mLen) :: mesg logical :: equalsDefault @@ -348,6 +368,7 @@ subroutine doc_param_char(doc, varname, desc, units, val, default, & mesg = define_string(doc, varname, '"'//trim(val)//'"', units) equalsDefault = .false. + if (present(like_default)) equalsDefault = like_default if (present(default)) then if (trim(val) == trim(default)) equalsDefault = .true. mesg = trim(mesg)//' default = "'//trim(adjustl(default))//'"' @@ -412,7 +433,7 @@ subroutine doc_closeBlock(doc, blockName) end subroutine doc_closeBlock !> This subroutine handles parameter documentation for time-type variables. -subroutine doc_param_time(doc, varname, desc, val, default, units, debuggingParam) +subroutine doc_param_time(doc, varname, desc, val, default, units, debuggingParam, like_default) type(doc_type), pointer :: doc !< A pointer to a structure that controls where the !! documentation occurs and its formatting character(len=*), intent(in) :: varname !< The name of the parameter being documented @@ -421,6 +442,8 @@ subroutine doc_param_time(doc, varname, desc, val, default, units, debuggingPara type(time_type), optional, intent(in) :: default !< The default value of this parameter character(len=*), optional, intent(in) :: units !< The units of the parameter being documented logical, optional, intent(in) :: debuggingParam !< If present and true, this is a debugging parameter. + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as though + !! it has the default value, even if there is no default. ! Local varables character(len=mLen) :: mesg ! The output message @@ -439,6 +462,7 @@ subroutine doc_param_time(doc, varname, desc, val, default, units, debuggingPara endif equalsDefault = .false. + if (present(like_default)) equalsDefault = like_default if (present(default)) then if (val == default) equalsDefault = .true. mesg = trim(mesg)//" default = "//trim(time_string(default)) @@ -468,6 +492,9 @@ subroutine writeMessageAndDesc(doc, vmesg, desc, valueWasDefault, indent, & 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. @@ -494,16 +521,27 @@ subroutine writeMessageAndDesc(doc, vmesg, desc, valueWasDefault, indent, & do if (len_trim(desc(start_ind:)) < 1) exit - nl_ind = index(desc(start_ind:), "\n") + 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_text-msg_pad)) then + 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_text-msg_pad)), " ", back=.true.) - 1 + 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_text-msg_pad)) then + 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_text-msg_pad)), " ", back=.true.) - 1 + end_ind = scan(desc(start_ind:start_ind+len_cor), " ", back=.true.) - 1 endif reset_msg_pad = .false. @@ -742,21 +780,43 @@ end function undef_string ! ---------------------------------------------------------------------- !> This subroutine handles the module documentation -subroutine doc_module(doc, modname, desc) +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 -! This subroutine handles the module documentation + 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 - call writeMessageAndDesc(doc, '', '') ! Blank line for delineation + ! Add a blank line for delineation + call writeMessageAndDesc(doc, '', '', valueWasDefault=all_default, & + layoutParam=layoutMod, debuggingParam=debuggingMod) mesg = "! === module "//trim(modname)//" ===" - call writeMessageAndDesc(doc, mesg, desc, indent=0) + 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 diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index 64fddfe7fc..f578df61c9 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -3,6 +3,7 @@ module MOM_domains ! This file is part of MOM6. See LICENSE.md for the license. +use MOM_array_transform, only : rotate_array use MOM_coms, only : PE_here, root_PE, num_PEs, MOM_infra_init, MOM_infra_end use MOM_coms, only : broadcast, sum_across_PEs, min_across_PEs, max_across_PEs use MOM_cpu_clock, only : cpu_clock_begin, cpu_clock_end @@ -25,10 +26,12 @@ module MOM_domains use mpp_domains_mod, only : mpp_group_update_initialized use mpp_domains_mod, only : mpp_start_group_update, mpp_complete_group_update use mpp_domains_mod, only : compute_block_extent => mpp_compute_block_extent -use mpp_parameter_mod, only : AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR, BITWISE_EXACT_SUM, CORNER -use mpp_parameter_mod, only : To_East => WUPDATE, To_West => EUPDATE, Omit_Corners => EDGEUPDATE -use mpp_parameter_mod, only : To_North => SUPDATE, To_South => NUPDATE, CENTER -use fms_io_mod, only : file_exist, parse_mask_table +use mpp_domains_mod, only : AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR, BITWISE_EXACT_SUM +use mpp_domains_mod, only : To_East => WUPDATE, To_West => EUPDATE, Omit_Corners => EDGEUPDATE +use mpp_domains_mod, only : To_North => SUPDATE, To_South => NUPDATE +use mpp_domains_mod, only : CENTER, CORNER, NORTH_FACE => NORTH, EAST_FACE => EAST +use fms_io_mod, only : file_exist, parse_mask_table +use fms_affinity_mod, only : fms_affinity_init, fms_affinity_set, fms_affinity_get implicit none ; private @@ -38,12 +41,14 @@ module MOM_domains public :: pass_var_start, pass_var_complete, fill_symmetric_edges, broadcast public :: pass_vector_start, pass_vector_complete public :: global_field_sum, sum_across_PEs, min_across_PEs, max_across_PEs -public :: AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR, BITWISE_EXACT_SUM, CORNER, CENTER +public :: AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR, BITWISE_EXACT_SUM +public :: CORNER, CENTER, NORTH_FACE, EAST_FACE public :: To_East, To_West, To_North, To_South, To_All, Omit_Corners public :: create_group_pass, do_group_pass, group_pass_type public :: start_group_pass, complete_group_pass public :: compute_block_extent, get_global_shape public :: get_simple_array_i_ind, get_simple_array_j_ind +public :: domain2D !> Do a halo update on an array interface pass_var @@ -150,8 +155,8 @@ subroutine pass_var_3d(array, MOM_dom, sideflag, complete, position, halo, & !! progress resumes. Omitting complete is the !! same as setting complete to .true. integer, optional, intent(in) :: position !< An optional argument indicating the position. - !! This is usally CORNER, but is CENTER by - !! default. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. integer, optional, intent(in) :: halo !< The size of the halo to update - the full !! halo by default. integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be @@ -195,8 +200,8 @@ subroutine pass_var_2d(array, MOM_dom, sideflag, complete, position, halo, inner !! progress resumes. Omitting complete is the !! same as setting complete to .true. integer, optional, intent(in) :: position !< An optional argument indicating the position. - !! This is usally CORNER, but is CENTER - !! by default. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. integer, optional, intent(in) :: halo !< The size of the halo to update - the full halo !! by default. integer, optional, intent(in) :: inner_halo !< The size of an inner halo to avoid updating, @@ -264,6 +269,24 @@ subroutine pass_var_2d(array, MOM_dom, sideflag, complete, position, halo, inner elseif (size(array,2) == jed+1) then jsfs = jsc - j_halo ; jefs = jsc+1 ; jsfn = jec+1 ; jefn = min(jec + 1 + j_halo, jed+1) else ; call MOM_error(FATAL, "pass_var_2d: wrong j-size for CORNER array.") ; endif + elseif (pos == NORTH_FACE) then + if (size(array,1) == ied) then + isfw = isc - i_halo ; iefw = isc ; isfe = iec ; iefe = iec + i_halo + else ; call MOM_error(FATAL, "pass_var_2d: wrong i-size for NORTH_FACE array.") ; endif + if (size(array,2) == jed) then + jsfs = max(jsc - (j_halo+1), 1) ; jefs = jsc ; jsfn = jec ; jefn = jec + j_halo + elseif (size(array,2) == jed+1) then + jsfs = jsc - j_halo ; jefs = jsc+1 ; jsfn = jec+1 ; jefn = min(jec + 1 + j_halo, jed+1) + else ; call MOM_error(FATAL, "pass_var_2d: wrong j-size for NORTH_FACE array.") ; endif + elseif (pos == EAST_FACE) then + if (size(array,1) == ied) then + isfw = max(isc - (i_halo+1), 1) ; iefw = isc ; isfe = iec ; iefe = iec + i_halo + elseif (size(array,1) == ied+1) then + isfw = isc - i_halo ; iefw = isc+1 ; isfe = iec+1 ; iefe = min(iec + 1 + i_halo, ied+1) + else ; call MOM_error(FATAL, "pass_var_2d: wrong i-size for EAST_FACE array.") ; endif + if (size(array,2) == jed) then + isfw = isc - i_halo ; iefw = isc ; isfe = iec ; iefe = iec + i_halo + else ; call MOM_error(FATAL, "pass_var_2d: wrong j-size for EAST_FACE array.") ; endif else call MOM_error(FATAL, "pass_var_2d: Unrecognized position") endif @@ -294,8 +317,8 @@ function pass_var_start_2d(array, MOM_dom, sideflag, position, complete, halo, & !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, !! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted. integer, optional, intent(in) :: position !< An optional argument indicating the position. - !! This is usally CORNER, but is CENTER - !! by default. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. logical, optional, intent(in) :: complete !< An optional argument indicating whether the !! halo updates should be completed before !! progress resumes. Omitting complete is the @@ -339,8 +362,8 @@ function pass_var_start_3d(array, MOM_dom, sideflag, position, complete, halo, & !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, !! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted. integer, optional, intent(in) :: position !< An optional argument indicating the position. - !! This is usally CORNER, but is CENTER - !! by default. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. logical, optional, intent(in) :: complete !< An optional argument indicating whether the !! halo updates should be completed before !! progress resumes. Omitting complete is the @@ -387,8 +410,8 @@ subroutine pass_var_complete_2d(id_update, array, MOM_dom, sideflag, position, h !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, !! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted. integer, optional, intent(in) :: position !< An optional argument indicating the position. - !! This is usally CORNER, but is CENTER - !! by default. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. integer, optional, intent(in) :: halo !< The size of the halo to update - the full !! halo by default. integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be @@ -430,8 +453,8 @@ subroutine pass_var_complete_3d(id_update, array, MOM_dom, sideflag, position, h !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, !! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted. integer, optional, intent(in) :: position !< An optional argument indicating the position. - !! This is usally CORNER, but is CENTER - !! by default. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. integer, optional, intent(in) :: halo !< The size of the halo to update - the full !! halo by default. integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be @@ -898,8 +921,8 @@ subroutine create_var_group_pass_2d(group, array, MOM_dom, sideflag, position, & !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, !! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted. integer, optional, intent(in) :: position !< An optional argument indicating the position. - !! This is usally CORNER, but is CENTER - !! by default. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. integer, optional, intent(in) :: halo !< The size of the halo to update - the full !! halo by default. integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be @@ -943,8 +966,8 @@ subroutine create_var_group_pass_3d(group, array, MOM_dom, sideflag, position, h !! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east, !! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted. integer, optional, intent(in) :: position !< An optional argument indicating the position. - !! This is usally CORNER, but is CENTER - !! by default. + !! This is CENTER by default and is often CORNER, + !! but could also be EAST_FACE or NORTH_FACE. integer, optional, intent(in) :: halo !< The size of the halo to update - the full !! halo by default. integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be @@ -1190,7 +1213,6 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & integer, dimension(4) :: global_indices !$ integer :: ocean_nthreads ! Number of Openmp threads !$ integer :: get_cpu_affinity, omp_get_thread_num, omp_get_num_threads -!$ integer :: omp_cores_per_node, adder, base_cpu !$ logical :: ocean_omp_hyper_thread integer :: nihalo_dflt, njhalo_dflt integer :: pe, proc_used @@ -1260,7 +1282,7 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & endif ! Read all relevant parameters and write them to the model log. - call log_version(param_file, mdl, version, "") + call log_version(param_file, mdl, version, "", log_to_all=.true., layout=.true.) call get_param(param_file, mdl, "REENTRANT_X", reentrant_x, & "If true, the domain is zonally reentrant.", default=.true.) call get_param(param_file, mdl, "REENTRANT_Y", reentrant_y, & @@ -1272,6 +1294,7 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & default=.false.) #ifndef NOT_SET_AFFINITY +!$ call fms_affinity_init !$OMP PARALLEL !$OMP master !$ ocean_nthreads = omp_get_num_threads() @@ -1283,27 +1306,10 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & !$ default = 1, layoutParam=.true.) !$ call get_param(param_file, mdl, "OCEAN_OMP_HYPER_THREAD", ocean_omp_hyper_thread, & !$ "If True, use hyper-threading.", default = .false., layoutParam=.true.) -!$ if (ocean_omp_hyper_thread) then -!$ call get_param(param_file, mdl, "OMP_CORES_PER_NODE", omp_cores_per_node, & -!$ "Number of cores per node needed for hyper-threading.", & -!$ fail_if_missing=.true., layoutParam=.true.) -!$ endif +!$ call fms_affinity_set('OCEAN', ocean_omp_hyper_thread, ocean_nthreads) !$ call omp_set_num_threads(ocean_nthreads) -!$ base_cpu = get_cpu_affinity() -!$OMP PARALLEL private(adder) -!$ if (ocean_omp_hyper_thread) then -!$ if (mod(omp_get_thread_num(),2) == 0) then -!$ adder = omp_get_thread_num()/2 -!$ else -!$ adder = omp_cores_per_node + omp_get_thread_num()/2 -!$ endif -!$ else -!$ adder = omp_get_thread_num() -!$ endif -!$ call set_cpu_affinity(base_cpu + adder) -!!$ write(6,*) " ocean ", base_cpu, get_cpu_affinity(), adder, omp_get_thread_num(), omp_get_num_threads() -!!$ call flush(6) -!$OMP END PARALLEL +!$ write(6,*) "MOM_domains_mod OMPthreading ", fms_affinity_get(), omp_get_thread_num(), omp_get_num_threads() +!$ call flush(6) !$ endif #endif call log_param(param_file, mdl, "!SYMMETRIC_MEMORY_", MOM_dom%symmetric, & @@ -1335,26 +1341,6 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & "at run time. This can only be set at compile time.",& layoutParam=.true.) - call get_param(param_file, mdl, trim(nihalo_nm), MOM_dom%nihalo, & - "The number of halo points on each side in the "//& - "x-direction. With STATIC_MEMORY_ this is set as NIHALO_ "//& - "in "//trim(inc_nm)//" at compile time; without STATIC_MEMORY_ "//& - "the default is NIHALO_ in "//trim(inc_nm)//" (if defined) or 2.", & - default=4, static_value=nihalo_dflt, layoutParam=.true.) - call get_param(param_file, mdl, trim(njhalo_nm), MOM_dom%njhalo, & - "The number of halo points on each side in the "//& - "y-direction. With STATIC_MEMORY_ this is set as NJHALO_ "//& - "in "//trim(inc_nm)//" at compile time; without STATIC_MEMORY_ "//& - "the default is NJHALO_ in "//trim(inc_nm)//" (if defined) or 2.", & - default=4, static_value=njhalo_dflt, layoutParam=.true.) - if (present(min_halo)) then - MOM_dom%nihalo = max(MOM_dom%nihalo, min_halo(1)) - min_halo(1) = MOM_dom%nihalo - MOM_dom%njhalo = max(MOM_dom%njhalo, min_halo(2)) - min_halo(2) = MOM_dom%njhalo - call log_param(param_file, mdl, "!NIHALO min_halo", MOM_dom%nihalo, layoutParam=.true.) - call log_param(param_file, mdl, "!NJHALO min_halo", MOM_dom%nihalo, layoutParam=.true.) - endif if (is_static) then call get_param(param_file, mdl, "NIGLOBAL", MOM_dom%niglobal, & "The total number of thickness grid points in the "//& @@ -1371,12 +1357,6 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & if (MOM_dom%njglobal /= NJGLOBAL) call MOM_error(FATAL,"MOM_domains_init: " // & "static mismatch for NJGLOBAL_ domain size. Header file does not match input namelist") - if (.not.present(min_halo)) then - if (MOM_dom%nihalo /= NIHALO) call MOM_error(FATAL,"MOM_domains_init: " // & - "static mismatch for "//trim(nihalo_nm)//" domain size") - if (MOM_dom%njhalo /= NJHALO) call MOM_error(FATAL,"MOM_domains_init: " // & - "static mismatch for "//trim(njhalo_nm)//" domain size") - endif else call get_param(param_file, mdl, "NIGLOBAL", MOM_dom%niglobal, & "The total number of thickness grid points in the "//& @@ -1390,6 +1370,30 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & fail_if_missing=.true.) endif + call get_param(param_file, mdl, trim(nihalo_nm), MOM_dom%nihalo, & + "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, static_value=nihalo_dflt) + call get_param(param_file, mdl, trim(njhalo_nm), MOM_dom%njhalo, & + "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, static_value=njhalo_dflt) + if (present(min_halo)) then + MOM_dom%nihalo = max(MOM_dom%nihalo, min_halo(1)) + min_halo(1) = MOM_dom%nihalo + MOM_dom%njhalo = max(MOM_dom%njhalo, min_halo(2)) + min_halo(2) = MOM_dom%njhalo + ! These are generally used only with static memory, so they are considerd layout params. + call log_param(param_file, mdl, "!NIHALO min_halo", MOM_dom%nihalo, layoutParam=.true.) + call log_param(param_file, mdl, "!NJHALO min_halo", MOM_dom%nihalo, layoutParam=.true.) + endif + if (is_static .and. .not.present(min_halo)) then + if (MOM_dom%nihalo /= NIHALO) call MOM_error(FATAL,"MOM_domains_init: " // & + "static mismatch for "//trim(nihalo_nm)//" domain size") + if (MOM_dom%njhalo /= NJHALO) call MOM_error(FATAL,"MOM_domains_init: " // & + "static mismatch for "//trim(njhalo_nm)//" domain size") + endif + global_indices(1) = 1 ; global_indices(2) = MOM_dom%niglobal global_indices(3) = 1 ; global_indices(4) = MOM_dom%njglobal @@ -1599,7 +1603,7 @@ end subroutine MOM_domains_init !> clone_MD_to_MD copies one MOM_domain_type into another, while allowing !! some properties of the new type to differ from the original one. subroutine clone_MD_to_MD(MD_in, MOM_dom, min_halo, halo_size, symmetric, & - domain_name) + domain_name, turns) type(MOM_domain_type), intent(in) :: MD_in !< An existing MOM_domain type(MOM_domain_type), pointer :: MOM_dom !< A pointer to a MOM_domain that will be !! allocated if it is unassociated, and will have data @@ -1617,10 +1621,15 @@ subroutine clone_MD_to_MD(MD_in, MOM_dom, min_halo, halo_size, symmetric, & character(len=*), & optional, intent(in) :: domain_name !< A name for the new domain, "MOM" !! if missing. + integer, optional, intent(in) :: turns !< Number of quarter turns integer :: global_indices(4) logical :: mask_table_exists character(len=64) :: dom_name + integer :: qturns + + qturns = 0 + if (present(turns)) qturns = turns if (.not.associated(MOM_dom)) then allocate(MOM_dom) @@ -1629,19 +1638,37 @@ subroutine clone_MD_to_MD(MD_in, MOM_dom, min_halo, halo_size, symmetric, & endif ! Save the extra data for creating other domains of different resolution that overlay this domain - MOM_dom%niglobal = MD_in%niglobal ; MOM_dom%njglobal = MD_in%njglobal - MOM_dom%nihalo = MD_in%nihalo ; MOM_dom%njhalo = MD_in%njhalo - MOM_dom%symmetric = MD_in%symmetric MOM_dom%nonblocking_updates = MD_in%nonblocking_updates + MOM_dom%thin_halo_updates = MD_in%thin_halo_updates - MOM_dom%X_FLAGS = MD_in%X_FLAGS ; MOM_dom%Y_FLAGS = MD_in%Y_FLAGS - MOM_dom%layout(:) = MD_in%layout(:) ; MOM_dom%io_layout(:) = MD_in%io_layout(:) + if (modulo(qturns, 2) /= 0) then + MOM_dom%niglobal = MD_in%njglobal ; MOM_dom%njglobal = MD_in%niglobal + MOM_dom%nihalo = MD_in%njhalo ; MOM_dom%njhalo = MD_in%nihalo + + MOM_dom%X_FLAGS = MD_in%Y_FLAGS ; MOM_dom%Y_FLAGS = MD_in%X_FLAGS + MOM_dom%layout(:) = MD_in%layout(2:1:-1) + MOM_dom%io_layout(:) = MD_in%io_layout(2:1:-1) + else + MOM_dom%niglobal = MD_in%niglobal ; MOM_dom%njglobal = MD_in%njglobal + MOM_dom%nihalo = MD_in%nihalo ; MOM_dom%njhalo = MD_in%njhalo + + MOM_dom%X_FLAGS = MD_in%X_FLAGS ; MOM_dom%Y_FLAGS = MD_in%Y_FLAGS + MOM_dom%layout(:) = MD_in%layout(:) + MOM_dom%io_layout(:) = MD_in%io_layout(:) + endif + + global_indices(1) = 1 ; global_indices(2) = MOM_dom%niglobal + global_indices(3) = 1 ; global_indices(4) = MOM_dom%njglobal if (associated(MD_in%maskmap)) then mask_table_exists = .true. allocate(MOM_dom%maskmap(MOM_dom%layout(1), MOM_dom%layout(2))) - MOM_dom%maskmap(:,:) = MD_in%maskmap(:,:) + if (qturns /= 0) then + call rotate_array(MD_in%maskmap(:,:), qturns, MOM_dom%maskmap(:,:)) + else + MOM_dom%maskmap(:,:) = MD_in%maskmap(:,:) + endif else mask_table_exists = .false. endif @@ -1665,19 +1692,34 @@ subroutine clone_MD_to_MD(MD_in, MOM_dom, min_halo, halo_size, symmetric, & dom_name = "MOM" if (present(domain_name)) dom_name = trim(domain_name) - global_indices(1) = 1 ; global_indices(2) = MOM_dom%niglobal - global_indices(3) = 1 ; global_indices(4) = MOM_dom%njglobal if (mask_table_exists) then - call MOM_define_domain( global_indices, MOM_dom%layout, MOM_dom%mpp_domain, & + call MOM_define_domain(global_indices, MOM_dom%layout, MOM_dom%mpp_domain, & xflags=MOM_dom%X_FLAGS, yflags=MOM_dom%Y_FLAGS, & xhalo=MOM_dom%nihalo, yhalo=MOM_dom%njhalo, & - symmetry = MOM_dom%symmetric, name=dom_name, & - maskmap=MOM_dom%maskmap ) + symmetry=MOM_dom%symmetric, name=dom_name, & + maskmap=MOM_dom%maskmap) + + global_indices(2) = global_indices(2) / 2 + global_indices(4) = global_indices(4) / 2 + call MOM_define_domain(global_indices, MOM_dom%layout, & + MOM_dom%mpp_domain_d2, & + xflags=MOM_dom%X_FLAGS, yflags=MOM_dom%Y_FLAGS, & + xhalo=(MOM_dom%nihalo/2), yhalo=(MOM_dom%njhalo/2), & + symmetry=MOM_dom%symmetric, name=dom_name, & + maskmap=MOM_dom%maskmap) else - call MOM_define_domain( global_indices, MOM_dom%layout, MOM_dom%mpp_domain, & + call MOM_define_domain(global_indices, MOM_dom%layout, MOM_dom%mpp_domain, & xflags=MOM_dom%X_FLAGS, yflags=MOM_dom%Y_FLAGS, & xhalo=MOM_dom%nihalo, yhalo=MOM_dom%njhalo, & - symmetry = MOM_dom%symmetric, name=dom_name) + symmetry=MOM_dom%symmetric, name=dom_name) + + global_indices(2) = global_indices(2) / 2 + global_indices(4) = global_indices(4) / 2 + call MOM_define_domain(global_indices, MOM_dom%layout, & + MOM_dom%mpp_domain_d2, & + xflags=MOM_dom%X_FLAGS, yflags=MOM_dom%Y_FLAGS, & + xhalo=(MOM_dom%nihalo/2), yhalo=(MOM_dom%njhalo/2), & + symmetry=MOM_dom%symmetric, name=dom_name) endif if ((MOM_dom%io_layout(1) + MOM_dom%io_layout(2) > 0) .and. & @@ -1691,7 +1733,7 @@ end subroutine clone_MD_to_MD !! domain2d type, while allowing some properties of the new type to differ from !! the original one. subroutine clone_MD_to_d2D(MD_in, mpp_domain, min_halo, halo_size, symmetric, & - domain_name) + domain_name, turns) type(MOM_domain_type), intent(in) :: MD_in !< An existing MOM_domain to be cloned type(domain2d), intent(inout) :: mpp_domain !< The new mpp_domain to be set up integer, dimension(2), & @@ -1707,12 +1749,16 @@ subroutine clone_MD_to_d2D(MD_in, mpp_domain, min_halo, halo_size, symmetric, & character(len=*), & optional, intent(in) :: domain_name !< A name for the new domain, "MOM" !! if missing. + integer, optional, intent(in) :: turns !< If true, swap X and Y axes integer :: global_indices(4), layout(2), io_layout(2) integer :: X_FLAGS, Y_FLAGS, niglobal, njglobal, nihalo, njhalo logical :: symmetric_dom character(len=64) :: dom_name + if (present(turns)) & + call MOM_error(FATAL, "Rotation not supported for MOM_domain to domain2d") + ! Save the extra data for creating other domains of different resolution that overlay this domain niglobal = MD_in%niglobal ; njglobal = MD_in%njglobal nihalo = MD_in%nihalo ; njhalo = MD_in%njhalo diff --git a/src/framework/MOM_dyn_horgrid.F90 b/src/framework/MOM_dyn_horgrid.F90 index ef74a12c9d..141340047d 100644 --- a/src/framework/MOM_dyn_horgrid.F90 +++ b/src/framework/MOM_dyn_horgrid.F90 @@ -173,7 +173,7 @@ module MOM_dyn_horgrid !--------------------------------------------------------------------- !> 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 :: G !< A pointer to the dynamic horizontal grid type + 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 diff --git a/src/framework/MOM_file_parser.F90 b/src/framework/MOM_file_parser.F90 index 8109890736..2e7a14dbe4 100644 --- a/src/framework/MOM_file_parser.F90 +++ b/src/framework/MOM_file_parser.F90 @@ -24,7 +24,7 @@ module MOM_file_parser !! TODO: Eliminate this parameter !>@{ Default values for parameters -logical, parameter :: report_unused_default = .false. +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. @@ -246,6 +246,7 @@ subroutine close_param_file(CS, quiet_close, component) 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". @@ -269,8 +270,18 @@ subroutine close_param_file(CS, quiet_close, component) 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, "") + 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) @@ -282,8 +293,6 @@ subroutine close_param_file(CS, quiet_close, component) "If true, kill the run if there are any unused "//& "parameters.", default=unused_params_fatal_default, & debuggingParam=.true.) - docfile_default = "MOM_parameter_doc" - if (present(component)) docfile_default = trim(component)//"_parameter_doc" call log_param(CS, mdl, "DOCUMENT_FILE", CS%doc_file, & "The basename for files where run-time parameters, their "//& "settings, units and defaults are documented. Blank will "//& @@ -1240,11 +1249,17 @@ end function overrideWarningHasBeenIssued !> 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) +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 @@ -1254,7 +1269,7 @@ subroutine log_version_cs(CS, modulename, version, desc) if (CS%log_to_stdout) write(CS%stdout,'(a)') trim(mesg) endif - if (present(desc)) call doc_module(CS%doc, modulename, desc) + if (present(desc)) call doc_module(CS%doc, modulename, desc, log_to_all, all_default, layout, debugging) end subroutine log_version_cs @@ -1274,7 +1289,7 @@ end subroutine log_version_plain !> Log the name and value of an integer model parameter in documentation files. subroutine log_param_int(CS, modulename, varname, value, desc, units, & - default, layoutParam, debuggingParam) + default, layoutParam, debuggingParam, like_default) type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, !! it is also a structure to parse for run-time parameters character(len=*), intent(in) :: modulename !< The name of the module using this parameter @@ -1288,6 +1303,8 @@ subroutine log_param_int(CS, modulename, varname, value, desc, units, & !! logged in the layout parameter file logical, optional, intent(in) :: debuggingParam !< If present and true, this parameter is !! logged in the debugging parameter file + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as + !! though it has the default value, even if there is no default. character(len=240) :: mesg, myunits @@ -1300,13 +1317,13 @@ subroutine log_param_int(CS, modulename, varname, value, desc, units, & myunits=" "; if (present(units)) write(myunits(1:240),'(A)') trim(units) if (present(desc)) & call doc_param(CS%doc, varname, desc, myunits, value, default, & - layoutParam=layoutParam, debuggingParam=debuggingParam) + layoutParam=layoutParam, debuggingParam=debuggingParam, like_default=like_default) end subroutine log_param_int !> Log the name and values of an array of integer model parameter in documentation files. subroutine log_param_int_array(CS, modulename, varname, value, desc, & - units, default, layoutParam, debuggingParam) + units, default, layoutParam, debuggingParam, like_default) type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, !! it is also a structure to parse for run-time parameters character(len=*), intent(in) :: modulename !< The name of the module using this parameter @@ -1320,6 +1337,8 @@ subroutine log_param_int_array(CS, modulename, varname, value, desc, & !! logged in the layout parameter file logical, optional, intent(in) :: debuggingParam !< If present and true, this parameter is !! logged in the debugging parameter file + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as + !! though it has the default value, even if there is no default. character(len=1320) :: mesg character(len=240) :: myunits @@ -1333,13 +1352,13 @@ subroutine log_param_int_array(CS, modulename, varname, value, desc, & myunits=" "; if (present(units)) write(myunits(1:240),'(A)') trim(units) if (present(desc)) & call doc_param(CS%doc, varname, desc, myunits, value, default, & - layoutParam=layoutParam, debuggingParam=debuggingParam) + layoutParam=layoutParam, debuggingParam=debuggingParam, like_default=like_default) end subroutine log_param_int_array !> Log the name and value of a real model parameter in documentation files. subroutine log_param_real(CS, modulename, varname, value, desc, units, & - default, debuggingParam) + default, debuggingParam, like_default) type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, !! it is also a structure to parse for run-time parameters character(len=*), intent(in) :: modulename !< The name of the calling module @@ -1351,6 +1370,8 @@ subroutine log_param_real(CS, modulename, varname, value, desc, units, & real, optional, intent(in) :: default !< The default value of the parameter logical, optional, intent(in) :: debuggingParam !< If present and true, this parameter is !! logged in the debugging parameter file + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as + !! though it has the default value, even if there is no default. character(len=240) :: mesg, myunits @@ -1364,13 +1385,13 @@ subroutine log_param_real(CS, modulename, varname, value, desc, units, & myunits="not defined"; if (present(units)) write(myunits(1:240),'(A)') trim(units) if (present(desc)) & call doc_param(CS%doc, varname, desc, myunits, value, default, & - debuggingParam=debuggingParam) + debuggingParam=debuggingParam, like_default=like_default) end subroutine log_param_real !> Log the name and values of an array of real model parameter in documentation files. subroutine log_param_real_array(CS, modulename, varname, value, desc, & - units, default, debuggingParam) + units, default, debuggingParam, like_default) type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, !! it is also a structure to parse for run-time parameters character(len=*), intent(in) :: modulename !< The name of the calling module @@ -1382,6 +1403,8 @@ subroutine log_param_real_array(CS, modulename, varname, value, desc, & real, optional, intent(in) :: default !< The default value of the parameter logical, optional, intent(in) :: debuggingParam !< If present and true, this parameter is !! logged in the debugging parameter file + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as + !! though it has the default value, even if there is no default. character(len=1320) :: mesg character(len=240) :: myunits @@ -1399,13 +1422,13 @@ subroutine log_param_real_array(CS, modulename, varname, value, desc, & myunits="not defined"; if (present(units)) write(myunits(1:240),'(A)') trim(units) if (present(desc)) & call doc_param(CS%doc, varname, desc, myunits, value, default, & - debuggingParam=debuggingParam) + debuggingParam=debuggingParam, like_default=like_default) end subroutine log_param_real_array !> Log the name and value of a logical model parameter in documentation files. subroutine log_param_logical(CS, modulename, varname, value, desc, & - units, default, layoutParam, debuggingParam) + units, default, layoutParam, debuggingParam, like_default) type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, !! it is also a structure to parse for run-time parameters character(len=*), intent(in) :: modulename !< The name of the calling module @@ -1419,6 +1442,8 @@ subroutine log_param_logical(CS, modulename, varname, value, desc, & !! logged in the layout parameter file logical, optional, intent(in) :: debuggingParam !< If present and true, this parameter is !! logged in the debugging parameter file + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as + !! though it has the default value, even if there is no default. character(len=240) :: mesg, myunits @@ -1435,13 +1460,13 @@ subroutine log_param_logical(CS, modulename, varname, value, desc, & myunits="Boolean"; if (present(units)) write(myunits(1:240),'(A)') trim(units) if (present(desc)) & call doc_param(CS%doc, varname, desc, myunits, value, default, & - layoutParam=layoutParam, debuggingParam=debuggingParam) + layoutParam=layoutParam, debuggingParam=debuggingParam, like_default=like_default) end subroutine log_param_logical !> Log the name and value of a character string model parameter in documentation files. subroutine log_param_char(CS, modulename, varname, value, desc, units, & - default, layoutParam, debuggingParam) + default, layoutParam, debuggingParam, like_default) type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, !! it is also a structure to parse for run-time parameters character(len=*), intent(in) :: modulename !< The name of the calling module @@ -1455,6 +1480,8 @@ subroutine log_param_char(CS, modulename, varname, value, desc, units, & !! logged in the layout parameter file logical, optional, intent(in) :: debuggingParam !< If present and true, this parameter is !! logged in the debugging parameter file + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as + !! though it has the default value, even if there is no default. character(len=240) :: mesg, myunits @@ -1468,14 +1495,14 @@ subroutine log_param_char(CS, modulename, varname, value, desc, units, & myunits=" "; if (present(units)) write(myunits(1:240),'(A)') trim(units) if (present(desc)) & call doc_param(CS%doc, varname, desc, myunits, value, default, & - layoutParam=layoutParam, debuggingParam=debuggingParam) + layoutParam=layoutParam, debuggingParam=debuggingParam, like_default=like_default) end subroutine log_param_char !> This subroutine writes the value of a time-type parameter to a log file, !! along with its name and the module it came from. subroutine log_param_time(CS, modulename, varname, value, desc, units, & - default, timeunit, layoutParam, debuggingParam, log_date) + default, timeunit, layoutParam, debuggingParam, log_date, like_default) type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, !! it is also a structure to parse for run-time parameters character(len=*), intent(in) :: modulename !< The name of the calling module @@ -1493,6 +1520,8 @@ subroutine log_param_time(CS, modulename, varname, value, desc, units, & !! logged in the layout parameter file logical, optional, intent(in) :: debuggingParam !< If present and true, this parameter is !! logged in the debugging parameter file + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as + !! though it has the default value, even if there is no default. ! Local variables real :: real_time, real_default @@ -1528,10 +1557,10 @@ subroutine log_param_time(CS, modulename, varname, value, desc, units, & default_string = convert_date_to_string(default) call doc_param(CS%doc, varname, desc, myunits, date_string, & default=default_string, layoutParam=layoutParam, & - debuggingParam=debuggingParam) + debuggingParam=debuggingParam, like_default=like_default) else call doc_param(CS%doc, varname, desc, myunits, date_string, & - layoutParam=layoutParam, debuggingParam=debuggingParam) + layoutParam=layoutParam, debuggingParam=debuggingParam, like_default=like_default) endif elseif (use_timeunit) then if (present(units)) then @@ -1551,12 +1580,12 @@ subroutine log_param_time(CS, modulename, varname, value, desc, units, & real_default = (86400.0/timeunit)*days + secs/timeunit if (ticks > 0) real_default = real_default + & real(ticks) / (timeunit*get_ticks_per_second()) - call doc_param(CS%doc, varname, desc, myunits, real_time, real_default) + call doc_param(CS%doc, varname, desc, myunits, real_time, real_default, like_default=like_default) else - call doc_param(CS%doc, varname, desc, myunits, real_time) + call doc_param(CS%doc, varname, desc, myunits, real_time, like_default=like_default) endif else - call doc_param(CS%doc, varname, desc, value, default, units=units) + call doc_param(CS%doc, varname, desc, value, default, units=units, like_default=like_default) endif endif diff --git a/src/framework/MOM_get_input.F90 b/src/framework/MOM_get_input.F90 index ad48086543..b6b5b89be9 100644 --- a/src/framework/MOM_get_input.F90 +++ b/src/framework/MOM_get_input.F90 @@ -21,7 +21,8 @@ module MOM_get_input 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. + 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 @@ -46,7 +47,8 @@ subroutine get_MOM_input(param_file, dirs, check_params, default_input_filename, 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. + 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 diff --git a/src/framework/MOM_hor_index.F90 b/src/framework/MOM_hor_index.F90 index db52afcdd8..a37c76ce41 100644 --- a/src/framework/MOM_hor_index.F90 +++ b/src/framework/MOM_hor_index.F90 @@ -10,6 +10,7 @@ module MOM_hor_index 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 @@ -49,6 +50,8 @@ module MOM_hor_index 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 @@ -78,7 +81,7 @@ subroutine hor_index_init(Domain, HI, param_file, local_indexing, index_offset) ! Read all relevant parameters and write them to the model log. call log_version(param_file, "MOM_hor_index", version, & - "Sets the horizontal array index types.") + "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 @@ -92,6 +95,7 @@ subroutine hor_index_init(Domain, HI, param_file, local_indexing, index_offset) 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 @@ -110,12 +114,57 @@ subroutine HIT_assign(HI1, HI2) 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%niglobal = HI2%niglobal ; HI1%njglobal = HI2%njglobal - + 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. diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index 7c19d715db..66f58b5b9d 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -20,8 +20,9 @@ module MOM_horizontal_regridding use MOM_io, only : slasher, vardesc, write_field use MOM_string_functions, only : uppercase use MOM_time_manager, only : time_type, get_external_field_size -use MOM_time_manager, only : init_external_field, time_interp_external +use MOM_time_manager, only : init_external_field use MOM_time_manager, only : get_external_field_axes, get_external_field_missing +use MOM_transform_FMS, only : time_interp_external => rotated_time_interp_external use MOM_variables, only : thermo_var_ptrs use mpp_io_mod, only : axistype use mpp_domains_mod, only : mpp_global_field, mpp_get_compute_domain @@ -272,7 +273,7 @@ end subroutine fill_miss_2d !> Extrapolate and interpolate from a file record subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, recnum, G, tr_z, & mask_z, z_in, z_edges_in, missing_value, reentrant_x, & - tripolar_n, homogenize, m_to_Z, answers_2018) + tripolar_n, homogenize, m_to_Z, answers_2018, ongrid) character(len=*), intent(in) :: filename !< Path to file containing tracer to be !! interpolated. @@ -296,6 +297,9 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, 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 ! Local variables real, dimension(:,:), allocatable :: tr_in, tr_inp ! A 2-d array for holding input data on @@ -314,6 +318,7 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, real :: roundoff ! The magnitude of roundoff, usually ~2e-16. real :: add_offset, scale_factor logical :: add_np + logical :: is_ongrid character(len=8) :: laynum type(horiz_interp_type) :: Interp integer :: is, ie, js, je ! compute domain indices @@ -336,6 +341,8 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, id_clock_read = cpu_clock_id('(Initialize tracer from Z) read', grain=CLOCK_LOOP) + is_ongrid=.false. + if (present(ongrid)) is_ongrid=ongrid if (allocated(tr_z)) deallocate(tr_z) if (allocated(mask_z)) deallocate(mask_z) @@ -418,51 +425,52 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, if (present(m_to_Z)) then ; do k=1,kd ; z_in(k) = m_to_Z * z_in(k) ; enddo ; endif ! extrapolate the input data to the north pole using the northerm-most latitude - - max_lat = maxval(lat_in) add_np=.false. - if (max_lat < 90.0) then - 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 + jdp=jd + if (.not. is_ongrid) then + max_lat = maxval(lat_in) + if (max_lat < 90.0) then + 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 z_edges_in(1) = 0.0 do K=2,kd - z_edges_in(K)=0.5*(z_in(k-1)+z_in(k)) + 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) - call horiz_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 + if (is_ongrid) then + allocate(tr_in(is:ie,js:je)) ; tr_in(:,:)=0.0 + allocate(mask_in(is:ie,js:je)) ; mask_in(:,:)=0.0 + else + call horiz_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)) ; tr_in(:,:)=0.0 + allocate(tr_inp(id,jdp)) ; tr_inp(:,:)=0.0 + allocate(mask_in(id,jdp)) ; mask_in(:,:)=0.0 + allocate(last_row(id)) ; last_row(:)=0.0 + endif - allocate(tr_in(id,jd)) ; tr_in(:,:)=0.0 - allocate(tr_inp(id,jdp)) ; tr_inp(:,:)=0.0 - allocate(mask_in(id,jdp)) ; mask_in(:,:)=0.0 - allocate(last_row(id)) ; last_row(:)=0.0 max_depth = maxval(G%bathyT) call mpp_max(max_depth) if (z_edges_in(kd+1) abs(roundoff*missing_value)) then + mask_in(i,j) = 1.0 + tr_in(i,j) = (tr_in(i,j)*scale_factor+add_offset) * conversion + else + tr_in(i,j) = missing_value + endif + enddo + enddo - if (is_root_pe()) then - start = 1 ; start(3) = k ; count(:) = 1 ; count(1) = id ; count(2) = jd - rcode = NF90_GET_VAR(ncid,varid, tr_in, start, count) - if (rcode /= 0) call MOM_error(FATAL,"hinterp_and_extract_from_Fie: "//& - "error reading level "//trim(laynum)//" of variable "//& - trim(varnam)//" in file "// trim(filename)) + else + if (is_root_pe()) then + start = 1 ; start(3) = k ; count(:) = 1 ; count(1) = id ; count(2) = jd + rcode = NF90_GET_VAR(ncid,varid, tr_in, start, count) + if (rcode /= 0) call MOM_error(FATAL,"hinterp_and_extract_from_Fie: "//& + "error reading level "//trim(laynum)//" of variable "//& + trim(varnam)//" in file "// trim(filename)) + + if (add_np) then + last_row(:)=tr_in(:,jd); pole=0.0;npole=0.0 + do i=1,id + if (abs(tr_in(i,jd)-missing_value) > abs(roundoff*missing_value)) then + pole = pole+last_row(i) + npole = npole+1.0 + endif + enddo + if (npole > 0) then + pole=pole/npole + else + pole=missing_value + endif + tr_inp(:,1:jd) = tr_in(:,:) + tr_inp(:,jdp) = pole + else + tr_inp(:,:) = tr_in(:,:) + endif + endif - if (add_np) then - last_row(:)=tr_in(:,jd); pole=0.0;npole=0.0 + call mpp_sync() + call mpp_broadcast(tr_inp, id*jdp, root_PE()) + call mpp_sync_self() + + do j=1,jdp do i=1,id - if (abs(tr_in(i,jd)-missing_value) > abs(roundoff*missing_value)) then - pole = pole+last_row(i) - npole = npole+1.0 - endif + if (abs(tr_inp(i,j)-missing_value) > abs(roundoff*missing_value)) then + mask_in(i,j) = 1.0 + tr_inp(i,j) = (tr_inp(i,j)*scale_factor+add_offset) * conversion + else + tr_inp(i,j) = missing_value + endif enddo - if (npole > 0) then - pole=pole/npole - else - pole=missing_value - endif - tr_inp(:,1:jd) = tr_in(:,:) - tr_inp(:,jdp) = pole - else - tr_inp(:,:) = tr_in(:,:) - endif - endif + enddo - call mpp_sync() - call mpp_broadcast(tr_inp, id*jdp, root_PE()) - call mpp_sync_self() + endif - mask_in=0.0 - do j=1,jdp - do i=1,id - if (abs(tr_inp(i,j)-missing_value) > abs(roundoff*missing_value)) then - mask_in(i,j) = 1.0 - tr_inp(i,j) = (tr_inp(i,j)*scale_factor+add_offset) * conversion - 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 horiz_interp_new(Interp,x_in,y_in,lon_out(is:ie,js:je),lat_out(is:ie,js:je), & + if (.not. is_ongrid) then + if (k == 1) then + call horiz_interp_new(Interp,x_in,y_in,lon_out(is:ie,js:je),lat_out(is:ie,js:je), & interp_method='bilinear',src_modulo=.true.) - endif + endif - if (debug) then - call myStats(tr_inp,missing_value, is,ie,js,je,k,'Tracer from file') + if (debug) then + call myStats(tr_inp,missing_value, is,ie,js,je,k,'Tracer from file') + endif endif tr_out(:,:) = 0.0 - - call horiz_interp(Interp,tr_inp,tr_out(is:ie,js:je), missing_value=missing_value, new_missing_handle=.true.) + if (is_ongrid) then + tr_out(is:ie,js:je)=tr_in(is:ie,js:je) + else + call horiz_interp(Interp,tr_inp,tr_out(is:ie,js:je), missing_value=missing_value, new_missing_handle=.true.) + endif mask_out=1.0 do j=js,je @@ -658,6 +692,9 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t real, dimension(SZI_(G),SZJ_(G)) :: tr_outf,tr_prev real, dimension(SZI_(G),SZJ_(G)) :: good2,fill2 real, dimension(SZI_(G),SZJ_(G)) :: nlevs + integer :: turns + + 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 @@ -753,7 +790,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t if (.not.spongeDataOngrid) then if (is_root_pe()) & - call time_interp_external(fms_id, Time, data_in, verbose=.true.) + call time_interp_external(fms_id, Time, data_in, verbose=.true., 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 @@ -873,7 +910,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t enddo ! kd else - call time_interp_external(fms_id, Time, data_in, verbose=.true.) + call time_interp_external(fms_id, Time, data_in, verbose=.true., turns=turns) do k=1,kd do j=js,je do i=is,ie diff --git a/src/framework/MOM_random.F90 b/src/framework/MOM_random.F90 index 6e254abed2..14800df9aa 100644 --- a/src/framework/MOM_random.F90 +++ b/src/framework/MOM_random.F90 @@ -11,6 +11,8 @@ module MOM_random use MersenneTwister_mod, only : getRandomReal ! Generates a random number use MersenneTwister_mod, only : getRandomPositiveInt ! Generates a random positive integer +use iso_fortran_env, only : stdout=>output_unit, stderr=>error_unit + implicit none ; private public :: random_0d_constructor @@ -141,8 +143,9 @@ integer function seed_from_time(Time) 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+1 here. - s2 = mod(dy + 32*(mo + 13*yr), 2147483648) ! Range 0 .. 2147483647 + ! 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 @@ -205,7 +208,7 @@ logical function random_unit_tests(verbose) HI%jdg_offset = 0 random_unit_tests = .false. - stdunit = 6 + stdunit = stdout write(stdunit,'(1x,a)') '==== MOM_random: random_unit_tests =======================' if (verbose) write(stdunit,'(1x,"random: ",a)') '-- Time-based seeds ---------------------' @@ -417,15 +420,17 @@ logical function test_fn(verbose, good, label, rvalue, ivalue) if (present(ivalue)) then if (.not. good) then - write(0,'(1x,a,i10,1x,a,a)') 'random: result =',ivalue,label,' <------- FAIL!' + 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(6,'(1x,a,i10,1x,a)') 'random: result =',ivalue,label + write(stdout,'(1x,a,i10,1x,a)') 'random: result =',ivalue,label endif else if (.not. good) then - write(0,'(1x,a,1pe15.8,1x,a,a)') 'random: result =',rvalue,label,' <------- FAIL!' + 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(6,'(1x,a,1pe15.8,1x,a)') 'random: result =',rvalue,label + write(stdout,'(1x,a,1pe15.8,1x,a)') 'random: result =',rvalue,label endif endif test_fn = .not. good diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90 index ec9789c20b..7181a1f1b9 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -9,16 +9,18 @@ module MOM_restart use MOM_string_functions, only : lowercase use MOM_grid, only : ocean_grid_type use MOM_io, only : create_file, fieldtype, file_exists, open_file, close_file -use MOM_io, only : write_field, MOM_read_data, read_data, get_filename_appendix +use MOM_io, only : MOM_read_data, read_data, get_filename_appendix use MOM_io, only : get_file_info, get_file_atts, get_file_fields, get_file_times use MOM_io, only : vardesc, var_desc, query_vardesc, modify_vardesc use MOM_io, only : MULTIPLE, NETCDF_FILE, READONLY_FILE, SINGLE_FILE use MOM_io, only : CENTER, CORNER, NORTH_FACE, EAST_FACE 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_transform_FMS, only : mpp_chksum => rotated_mpp_chksum +use MOM_transform_FMS, only : write_field => rotated_write_field use MOM_verticalGrid, only : verticalGrid_type -use mpp_mod, only: mpp_chksum,mpp_pe -use mpp_io_mod, only: mpp_attribute_exist, mpp_get_atts +use mpp_io_mod, only : mpp_attribute_exist, mpp_get_atts +use mpp_mod, only : mpp_pe implicit none ; private @@ -26,6 +28,7 @@ module MOM_restart public save_restart, query_initialized, restart_init_end, vardesc public restart_files_exist, determine_is_new_run, is_new_run public register_restart_field_as_obsolete +public register_restart_pair !> A type for making arrays of pointers to 4-d arrays type p4d @@ -86,6 +89,7 @@ module MOM_restart !! 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 !> An array of descriptions of the registered fields type(field_restart), pointer :: restart_field(:) => NULL() @@ -112,6 +116,13 @@ module MOM_restart module procedure register_restart_field_ptr0d, register_restart_field_0d end interface +!> Register a pair of restart fieilds 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 @@ -287,6 +298,67 @@ subroutine register_restart_field_ptr0d(f_ptr, var_desc, mandatory, CS) 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) + real, dimension(:,:), target, intent(in) :: a_ptr !< First field pointer + real, dimension(:,:), target, intent(in) :: b_ptr !< Second field pointer + 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), pointer :: CS !< MOM restart control structure + + if (modulo(CS%turns, 2) /= 0) then + call register_restart_field(b_ptr, a_desc, mandatory, CS) + call register_restart_field(a_ptr, b_desc, mandatory, CS) + else + call register_restart_field(a_ptr, a_desc, mandatory, CS) + call register_restart_field(b_ptr, b_desc, mandatory, CS) + 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) + real, dimension(:,:,:), target, intent(in) :: a_ptr !< First field pointer + real, dimension(:,:,:), target, intent(in) :: b_ptr !< Second field pointer + 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), pointer :: CS !< MOM restart control structure + + if (modulo(CS%turns, 2) /= 0) then + call register_restart_field(b_ptr, a_desc, mandatory, CS) + call register_restart_field(a_ptr, b_desc, mandatory, CS) + else + call register_restart_field(a_ptr, a_desc, mandatory, CS) + call register_restart_field(b_ptr, b_desc, mandatory, CS) + 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) + real, dimension(:,:,:,:), target, intent(in) :: a_ptr !< First field pointer + real, dimension(:,:,:,:), target, intent(in) :: b_ptr !< Second field pointer + 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), pointer :: CS !< MOM restart control structure + + if (modulo(CS%turns, 2) /= 0) then + call register_restart_field(b_ptr, a_desc, mandatory, CS) + call register_restart_field(a_ptr, b_desc, mandatory, CS) + else + call register_restart_field(a_ptr, a_desc, mandatory, CS) + call register_restart_field(b_ptr, b_desc, mandatory, CS) + 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 @@ -777,7 +849,7 @@ function query_initialized_4d_name(f_ptr, name, CS) result(query_initialized) end function query_initialized_4d_name !> save_restart saves all registered variables to restart files. -subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV) +subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_rest_files) 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 @@ -788,6 +860,7 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV) !! 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 ! Local variables type(vardesc) :: vars(CS%max_fields) ! Descriptions of the fields that @@ -815,6 +888,9 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV) integer :: length integer(kind=8) :: check_val(CS%max_fields,1) integer :: isL, ieL, jsL, jeL, pos + integer :: turns + + turns = CS%turns if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "save_restart: Module must be initialized before it is used.") @@ -927,14 +1003,21 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV) end select !Prepare the checksum of the restart fields to be written to restart files - call get_checksum_loop_ranges(G, pos, isL, ieL, jsL, jeL) + 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 if (associated(CS%var_ptr3d(m)%p)) then - check_val(m-start_var+1,1) = mpp_chksum(CS%var_ptr3d(m)%p(isL:ieL,jsL:jeL,:)) + check_val(m-start_var+1,1) = & + mpp_chksum(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) = mpp_chksum(CS%var_ptr2d(m)%p(isL:ieL,jsL:jeL)) + check_val(m-start_var+1,1) = & + mpp_chksum(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) = mpp_chksum(CS%var_ptr4d(m)%p(isL:ieL,jsL:jeL,:,:)) + check_val(m-start_var+1,1) = & + mpp_chksum(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) = mpp_chksum(CS%var_ptr1d(m)%p) elseif (associated(CS%var_ptr0d(m)%p)) then @@ -951,16 +1034,15 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV) endif do m=start_var,next_var-1 - if (associated(CS%var_ptr3d(m)%p)) then call write_field(unit,fields(m-start_var+1), G%Domain%mpp_domain, & - CS%var_ptr3d(m)%p, restart_time) + CS%var_ptr3d(m)%p, restart_time, turns=-turns) elseif (associated(CS%var_ptr2d(m)%p)) then call write_field(unit,fields(m-start_var+1), G%Domain%mpp_domain, & - CS%var_ptr2d(m)%p, restart_time) + CS%var_ptr2d(m)%p, restart_time, turns=-turns) elseif (associated(CS%var_ptr4d(m)%p)) then call write_field(unit,fields(m-start_var+1), G%Domain%mpp_domain, & - CS%var_ptr4d(m)%p, restart_time) + CS%var_ptr4d(m)%p, restart_time, turns=-turns) elseif (associated(CS%var_ptr1d(m)%p)) then call write_field(unit, fields(m-start_var+1), CS%var_ptr1d(m)%p, & restart_time) @@ -975,6 +1057,9 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV) 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 @@ -1425,9 +1510,12 @@ subroutine restart_init(param_file, CS, restart_root) !! 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.") @@ -1435,10 +1523,25 @@ subroutine restart_init(param_file, CS, restart_root) endif allocate(CS) + ! Determine whether all paramters are set to their default values. + call get_param(param_file, mdl, "PARALLEL_RESTARTFILES", CS%parallel_restartfiles, & + default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "LARGE_FILE_SUPPORT", CS%large_file_support, & + default=.true., do_not_log=.true.) + call get_param(param_file, mdl, "MAX_FIELDS", CS%max_fields, default=100, do_not_log=.true.) + call get_param(param_file, mdl, "RESTART_CHECKSUMS_REQUIRED", CS%checksum_required, & + default=.true., do_not_log=.true.) + all_default = ((.not.CS%parallel_restartfiles) .and. (CS%large_file_support) .and. & + (CS%max_fields == 100) .and. (CS%checksum_required)) + if (.not.present(restart_root)) then + call get_param(param_file, mdl, "RESTARTFILE", CS%restartfile, & + default="MOM.res", do_not_log=.true.) + all_default = (all_default .and. (trim(CS%restartfile) == trim("MOM.res"))) + endif + ! Read all relevant parameters and write them to the model log. - call log_version(param_file, mdl, version, "") - call get_param(param_file, mdl, "PARALLEL_RESTARTFILES", & - CS%parallel_restartfiles, & + call log_version(param_file, mdl, version, "", all_default=all_default) + call get_param(param_file, mdl, "PARALLEL_RESTARTFILES", CS%parallel_restartfiles, & "If true, each processor writes its own restart file, "//& "otherwise a single restart file is generated", & default=.false.) @@ -1464,6 +1567,16 @@ subroutine restart_init(param_file, CS, restart_root) "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)) diff --git a/src/framework/MOM_spatial_means.F90 b/src/framework/MOM_spatial_means.F90 index 2423a19433..ffbdc5f810 100644 --- a/src/framework/MOM_spatial_means.F90 +++ b/src/framework/MOM_spatial_means.F90 @@ -4,8 +4,8 @@ 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_list_sum_across_PEs -use MOM_coms, only : reproducing_sum +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 @@ -88,8 +88,8 @@ function global_layer_mean(var, h, G, GV, scale) real, optional, intent(in) :: scale !< A rescaling factor for the variable real, dimension(SZK_(GV)) :: global_layer_mean - real, dimension(SZI_(G), SZJ_(G), SZK_(GV)) :: tmpForSumming, weight - real, dimension(SZK_(GV)) :: scalarij, weightij + real, dimension(G%isc:G%iec, G%jsc:G%jec, SZK_(GV)) :: tmpForSumming, weight + type(EFP_type), dimension(2*SZK_(GV)) :: laysums real, dimension(SZK_(GV)) :: global_temp_scalar, global_weight_scalar real :: scalefac ! A scaling factor for the variable. integer :: i, j, k, is, ie, js, je, nz @@ -103,11 +103,12 @@ function global_layer_mean(var, h, G, GV, scale) tmpForSumming(i,j,k) = scalefac * var(i,j,k) * weight(i,j,k) enddo ; enddo ; enddo - global_temp_scalar = reproducing_sum(tmpForSumming,sums=scalarij) - global_weight_scalar = reproducing_sum(weight,sums=weightij) + 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) = scalarij(k) / weightij(k) + global_layer_mean(k) = EFP_to_real(laysums(k)) / EFP_to_real(laysums(nz+k)) enddo end function global_layer_mean @@ -236,8 +237,8 @@ subroutine global_i_mean(array, i_mean, G, mask, scale, tmp_scale) if (query_EFP_overflow_error()) call MOM_error(FATAL, & "global_i_mean overflow error occurred before sums across PEs.") - call EFP_list_sum_across_PEs(asum(G%jsg:G%jeg), G%jeg-G%jsg+1) - call EFP_list_sum_across_PEs(mask_sum(G%jsg:G%jeg), G%jeg-G%jsg+1) + 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.") @@ -260,7 +261,7 @@ subroutine global_i_mean(array, i_mean, G, mask, scale, tmp_scale) if (query_EFP_overflow_error()) call MOM_error(FATAL, & "global_i_mean overflow error occurred before sum across PEs.") - call EFP_list_sum_across_PEs(asum(G%jsg:G%jeg), G%jeg-G%jsg+1) + 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.") @@ -322,8 +323,8 @@ subroutine global_j_mean(array, j_mean, G, mask, scale, tmp_scale) if (query_EFP_overflow_error()) call MOM_error(FATAL, & "global_j_mean overflow error occurred before sums across PEs.") - call EFP_list_sum_across_PEs(asum(G%isg:G%ieg), G%ieg-G%isg+1) - call EFP_list_sum_across_PEs(mask_sum(G%isg:G%ieg), G%ieg-G%isg+1) + 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.") @@ -346,7 +347,7 @@ subroutine global_j_mean(array, j_mean, G, mask, scale, tmp_scale) if (query_EFP_overflow_error()) call MOM_error(FATAL, & "global_j_mean overflow error occurred before sum across PEs.") - call EFP_list_sum_across_PEs(asum(G%isg:G%ieg), G%ieg-G%isg+1) + 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.") @@ -369,8 +370,9 @@ subroutine adjust_area_mean_to_zero(array, G, scaling, unit_scale) real, optional, intent(out) :: scaling !< The scaling factor used real, optional, intent(in) :: unit_scale !< A rescaling factor for the variable ! Local variables - real, dimension(SZI_(G), SZJ_(G)) :: posVals, negVals, areaXposVals, areaXnegVals + real, dimension(G%isc:G%iec, G%jsc:G%jec) :: posVals, negVals, areaXposVals, areaXnegVals integer :: i,j + type(EFP_type), dimension(2) :: areaInt_EFP real :: scalefac ! A scaling factor for the variable. real :: I_scalefac ! The Adcroft reciprocal of scalefac real :: areaIntPosVals, areaIntNegVals, posScale, negScale @@ -378,8 +380,8 @@ subroutine adjust_area_mean_to_zero(array, G, scaling, unit_scale) 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. - areaXnegVals(:,:) = 0. + ! 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)) @@ -388,8 +390,12 @@ subroutine adjust_area_mean_to_zero(array, G, scaling, unit_scale) areaXnegVals(i,j) = G%US%L_to_m**2*G%areaT(i,j) * negVals(i,j) enddo ; enddo - areaIntPosVals = reproducing_sum( areaXposVals ) - areaIntNegVals = reproducing_sum( areaXnegVals ) + ! 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 diff --git a/src/framework/MOM_string_functions.F90 b/src/framework/MOM_string_functions.F90 index 0a4058995a..1293499930 100644 --- a/src/framework/MOM_string_functions.F90 +++ b/src/framework/MOM_string_functions.F90 @@ -3,6 +3,8 @@ 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 @@ -319,7 +321,7 @@ logical function string_functions_unit_tests(verbose) logical :: fail, v fail = .false. v = verbose - write(*,*) '==== MOM_string_functions: string_functions_unit_tests ===' + 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') @@ -349,7 +351,7 @@ logical function string_functions_unit_tests(verbose) 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(*,*) 'Pass' + if (.not. fail) write(stdout,*) 'Pass' string_functions_unit_tests = fail end function string_functions_unit_tests @@ -361,8 +363,11 @@ logical function localTestS(verbose,str1,str2) localTestS=.false. if (trim(str1)/=trim(str2)) localTestS=.true. if (localTestS .or. verbose) then - write(*,*) '>'//trim(str1)//'<' - if (localTestS) write(*,*) trim(str1),':',trim(str2), '<-- FAIL' + 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 @@ -374,8 +379,11 @@ logical function localTestI(verbose,i1,i2) localTestI=.false. if (i1/=i2) localTestI=.true. if (localTestI .or. verbose) then - write(*,*) i1,i2 - if (localTestI) write(*,*) i1,'!=',i2, '<-- FAIL' + write(stdout,*) i1,i2 + if (localTestI) then + write(stdout,*) i1,'!=',i2, '<-- FAIL' + write(stderr,*) i1,'!=',i2, '<-- FAIL' + endif endif end function localTestI @@ -387,8 +395,11 @@ logical function localTestR(verbose,r1,r2) localTestR=.false. if (r1/=r2) localTestR=.true. if (localTestR .or. verbose) then - write(*,*) r1,r2 - if (localTestR) write(*,*) r1,'!=',r2, '<-- FAIL' + write(stdout,*) r1,r2 + if (localTestR) then + write(stdout,*) r1,'!=',r2, '<-- FAIL' + write(stderr,*) r1,'!=',r2, '<-- FAIL' + endif endif end function localTestR diff --git a/src/framework/MOM_transform_FMS.F90 b/src/framework/MOM_transform_FMS.F90 new file mode 100644 index 0000000000..97e0be85f6 --- /dev/null +++ b/src/framework/MOM_transform_FMS.F90 @@ -0,0 +1,405 @@ +!> Support functions and interfaces to permit transformed model domains to +!! interact with FMS operations registered on the non-transformed domains. + +module MOM_transform_FMS + +use horiz_interp_mod, only : horiz_interp_type +use MOM_error_handler, only : MOM_error, FATAL +use MOM_io, only : fieldtype, write_field +use mpp_domains_mod, only : domain2D +use fms_mod, only : mpp_chksum +use time_manager_mod, only : time_type +use time_interp_external_mod, only : time_interp_external + +use MOM_array_transform, only : allocate_rotated_array, rotate_array + +implicit none + +private +public rotated_mpp_chksum +public rotated_write_field +public rotated_time_interp_external + +!> Rotate and compute the FMS (mpp) checksum of a field +interface rotated_mpp_chksum + module procedure rotated_mpp_chksum_real_0d + module procedure rotated_mpp_chksum_real_1d + module procedure rotated_mpp_chksum_real_2d + module procedure rotated_mpp_chksum_real_3d + module procedure rotated_mpp_chksum_real_4d +end interface rotated_mpp_chksum + +!> Rotate and write a registered field to an FMS output file +interface rotated_write_field + module procedure rotated_write_field_real_0d + module procedure rotated_write_field_real_1d + module procedure rotated_write_field_real_2d + module procedure rotated_write_field_real_3d + module procedure rotated_write_field_real_4d +end interface rotated_write_field + +!> Read a field based on model time, and rotate to the model domain +interface rotated_time_interp_external + module procedure rotated_time_interp_external_0d + module procedure rotated_time_interp_external_2d + module procedure rotated_time_interp_external_3d +end interface rotated_time_interp_external + +contains + +! NOTE: No transformations are applied to the 0d and 1d field implementations, +! but are provided to maintain compatibility with the FMS interfaces. + + +!> Compute the FMS (mpp) checksum of a scalar. +!! This function is provided to support the full FMS mpp_chksum interface. +function rotated_mpp_chksum_real_0d(field, pelist, mask_val, turns) & + result(chksum) + real, intent(in) :: field !> Input scalar + integer, optional, intent(in) :: pelist(:) !> PE list of ranks to checksum + real, optional, intent(in) :: mask_val !> FMS mask value + integer, optional, intent(in) :: turns !> Number of quarter turns + integer :: chksum !> FMS checksum of scalar + + if (present(turns)) & + call MOM_error(FATAL, "Rotation not supported for 0d fields.") + + chksum = mpp_chksum(field, pelist=pelist, mask_val=mask_val) +end function rotated_mpp_chksum_real_0d + + +!> Compute the FMS (mpp) checksum of a 1d field. +!! This function is provided to support the full FMS mpp_chksum interface. +function rotated_mpp_chksum_real_1d(field, pelist, mask_val, turns) & + result(chksum) + real, intent(in) :: field(:) !> Input field + integer, optional, intent(in) :: pelist(:) !> PE list of ranks to checksum + real, optional, intent(in) :: mask_val !> FMS mask value + integer, optional, intent(in) :: turns !> Number of quarter-turns + integer :: chksum !> FMS checksum of field + + if (present(turns)) & + call MOM_error(FATAL, "Rotation not supported for 1d fields.") + + chksum = mpp_chksum(field, pelist=pelist, mask_val=mask_val) +end function rotated_mpp_chksum_real_1d + + +!> Compute the FMS (mpp) checksum of a rotated 2d field. +function rotated_mpp_chksum_real_2d(field, pelist, mask_val, turns) & + result(chksum) + real, intent(in) :: field(:,:) !> Unrotated input field + integer, optional, intent(in) :: pelist(:) !> PE list of ranks to checksum + real, optional, intent(in) :: mask_val !> FMS mask value + integer, optional, intent(in) :: turns !> Number of quarter-turns + integer :: chksum !> FMS checksum of field + + real, allocatable :: field_rot(:,:) + integer :: qturns + + qturns = 0 + if (present(turns)) & + qturns = modulo(turns, 4) + + if (qturns == 0) then + chksum = mpp_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 = mpp_chksum(field_rot, pelist=pelist, mask_val=mask_val) + deallocate(field_rot) + endif +end function rotated_mpp_chksum_real_2d + + +!> Compute the FMS (mpp) checksum of a rotated 3d field. +function rotated_mpp_chksum_real_3d(field, pelist, mask_val, turns) & + result(chksum) + real, intent(in) :: field(:,:,:) !> Unrotated input field + integer, optional, intent(in) :: pelist(:) !> PE list of ranks to checksum + real, optional, intent(in) :: mask_val !> FMS mask value + integer, optional, intent(in) :: turns !> Number of quarter-turns + integer :: chksum !> FMS checksum of field + + real, allocatable :: field_rot(:,:,:) + integer :: qturns + + qturns = 0 + if (present(turns)) & + qturns = modulo(turns, 4) + + if (qturns == 0) then + chksum = mpp_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 = mpp_chksum(field_rot, pelist=pelist, mask_val=mask_val) + deallocate(field_rot) + endif +end function rotated_mpp_chksum_real_3d + + +!> Compute the FMS (mpp) checksum of a rotated 4d field. +function rotated_mpp_chksum_real_4d(field, pelist, mask_val, turns) & + result(chksum) + real, intent(in) :: field(:,:,:,:) !> Unrotated input field + integer, optional, intent(in) :: pelist(:) !> PE list of ranks to checksum + real, optional, intent(in) :: mask_val !> FMS mask value + integer, optional, intent(in) :: turns !> Number of quarter-turns + integer :: chksum !> FMS checksum of field + + real, allocatable :: field_rot(:,:,:,:) + integer :: qturns + + qturns = 0 + if (present(turns)) & + qturns = modulo(turns, 4) + + if (qturns == 0) then + chksum = mpp_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 = mpp_chksum(field_rot, pelist=pelist, mask_val=mask_val) + deallocate(field_rot) + endif +end function rotated_mpp_chksum_real_4d + + +! NOTE: In MOM_io, write_field points to mpp_write, which supports a very broad +! range of interfaces. Here, we only support the much more narrow family of +! mpp_write_2ddecomp functions used to write tiled data. + + +!> Write the rotation of a 1d field to an FMS output file +!! This function is provided to support the full FMS write_field interface. +subroutine rotated_write_field_real_0d(io_unit, field_md, field, tstamp, turns) + integer, intent(in) :: io_unit !> File I/O unit handle + type(fieldtype), intent(in) :: field_md !> FMS field metadata + real, intent(inout) :: field !> Unrotated field array + real, optional, intent(in) :: tstamp !> Model timestamp + integer, optional, intent(in) :: turns !> Number of quarter-turns + + if (present(turns)) & + call MOM_error(FATAL, "Rotation not supported for 0d fields.") + + call write_field(io_unit, field_md, field, tstamp=tstamp) +end subroutine rotated_write_field_real_0d + + +!> Write the rotation of a 1d field to an FMS output file +!! This function is provided to support the full FMS write_field interface. +subroutine rotated_write_field_real_1d(io_unit, field_md, field, tstamp, turns) + integer, intent(in) :: io_unit !> File I/O unit handle + type(fieldtype), intent(in) :: field_md !> FMS field metadata + real, intent(inout) :: field(:) !> Unrotated field array + real, optional, intent(in) :: tstamp !> Model timestamp + integer, optional, intent(in) :: turns !> Number of quarter-turns + + if (present(turns)) & + call MOM_error(FATAL, "Rotation not supported for 0d fields.") + + call write_field(io_unit, field_md, field, tstamp=tstamp) +end subroutine rotated_write_field_real_1d + + +!> Write the rotation of a 2d field to an FMS output file +subroutine rotated_write_field_real_2d(io_unit, field_md, domain, field, & + tstamp, tile_count, default_data, turns) + integer, intent(in) :: io_unit !> File I/O unit handle + type(fieldtype), intent(in) :: field_md !> FMS field metadata + type(domain2D), intent(inout) :: domain !> FMS MPP domain + real, intent(inout) :: field(:,:) !> Unrotated field array + real, optional, intent(in) :: tstamp !> Model timestamp + integer, optional, intent(in) :: tile_count !> PEs per tile (default: 1) + real, optional, intent(in) :: default_data !> Default fill value + integer, optional, intent(in) :: turns !> Number of quarter-turns + + real, allocatable :: field_rot(:,:) + integer :: qturns + + qturns = 0 + if (present(turns)) & + qturns = modulo(turns, 4) + + if (qturns == 0) then + call write_field(io_unit, field_md, domain, field, tstamp=tstamp, & + tile_count=tile_count, default_data=default_data) + else + call allocate_rotated_array(field, [1,1], qturns, field_rot) + call rotate_array(field, qturns, field_rot) + call write_field(io_unit, field_md, domain, field_rot, tstamp=tstamp, & + tile_count=tile_count, default_data=default_data) + deallocate(field_rot) + endif +end subroutine rotated_write_field_real_2d + + +!> Write the rotation of a 3d field to an FMS output file +subroutine rotated_write_field_real_3d(io_unit, field_md, domain, field, & + tstamp, tile_count, default_data, turns) + integer, intent(in) :: io_unit !> File I/O unit handle + type(fieldtype), intent(in) :: field_md !> FMS field metadata + type(domain2D), intent(inout) :: domain !> FMS MPP domain + real, intent(inout) :: field(:,:,:) !> Unrotated field array + real, optional, intent(in) :: tstamp !> Model timestamp + integer, optional, intent(in) :: tile_count !> PEs per tile (default: 1) + real, optional, intent(in) :: default_data !> Default fill value + integer, optional, intent(in) :: turns !> Number of quarter-turns + + real, allocatable :: field_rot(:,:,:) + integer :: qturns + + qturns = 0 + if (present(turns)) & + qturns = modulo(turns, 4) + + if (qturns == 0) then + call write_field(io_unit, field_md, domain, field, tstamp=tstamp, & + tile_count=tile_count, default_data=default_data) + else + call allocate_rotated_array(field, [1,1,1], qturns, field_rot) + call rotate_array(field, qturns, field_rot) + call write_field(io_unit, field_md, domain, field_rot, tstamp=tstamp, & + tile_count=tile_count, default_data=default_data) + deallocate(field_rot) + endif +end subroutine rotated_write_field_real_3d + + +!> Write the rotation of a 4d field to an FMS output file +subroutine rotated_write_field_real_4d(io_unit, field_md, domain, field, & + tstamp, tile_count, default_data, turns) + integer, intent(in) :: io_unit !> File I/O unit handle + type(fieldtype), intent(in) :: field_md !> FMS field metadata + type(domain2D), intent(inout) :: domain !> FMS MPP domain + real, intent(inout) :: field(:,:,:,:) !> Unrotated field array + real, optional, intent(in) :: tstamp !> Model timestamp + integer, optional, intent(in) :: tile_count !> PEs per tile (default: 1) + real, optional, intent(in) :: default_data !> Default fill value + integer, optional, intent(in) :: turns !> Number of quarter-turns + + real, allocatable :: field_rot(:,:,:,:) + integer :: qturns + + qturns = 0 + if (present(turns)) & + qturns = modulo(turns, 4) + + if (qturns == 0) then + call write_field(io_unit, field_md, domain, field, tstamp=tstamp, & + tile_count=tile_count, default_data=default_data) + else + call allocate_rotated_array(field, [1,1,1,1], qturns, field_rot) + call rotate_array(field, qturns, field_rot) + call write_field(io_unit, field_md, domain, field_rot, tstamp=tstamp, & + tile_count=tile_count, default_data=default_data) + deallocate(field_rot) + endif +end subroutine rotated_write_field_real_4d + + +!> Read a scalar field based on model time +!! This function is provided to support the full FMS time_interp_external +!! interface. +subroutine rotated_time_interp_external_0d(fms_id, time, data_in, verbose, & + turns) + integer, intent(in) :: fms_id !< FMS field ID + type(time_type), intent(in) :: time !< Model time + real, intent(inout) :: data_in !< field to write data + logical, intent(in), optional :: verbose !< Verbose output + integer, intent(in), optional :: turns !< Number of quarter turns + + if (present(turns)) & + call MOM_error(FATAL, "Rotation not supported for 0d fields.") + + call time_interp_external(fms_id, time, data_in, verbose=verbose) +end subroutine rotated_time_interp_external_0d + +!> Read a 2d field based on model time, and rotate to the model grid +subroutine rotated_time_interp_external_2d(fms_id, time, data_in, interp, & + verbose, horz_interp, mask_out, is_in, ie_in, js_in, je_in, window_id, & + turns) + integer, intent(in) :: fms_id + type(time_type), intent(in) :: time + real, dimension(:,:), intent(inout) :: data_in + integer, intent(in), optional :: interp + logical, intent(in), optional :: verbose + type(horiz_interp_type),intent(in), optional :: horz_interp + logical, dimension(:,:), intent(out), optional :: mask_out + integer, intent(in), optional :: is_in, ie_in, js_in, je_in + integer, intent(in), optional :: window_id + integer, intent(in), optional :: turns + + real, allocatable :: data_pre(:,:) + integer :: qturns + + ! TODO: Mask rotation requires logical array rotation support + if (present(mask_out)) & + call MOM_error(FATAL, "Rotation of masked output not yet support") + + qturns = 0 + if (present(turns)) & + qturns = modulo(turns, 4) + + + if (qturns == 0) then + call time_interp_external(fms_id, time, data_in, interp=interp, & + verbose=verbose, horz_interp=horz_interp, mask_out=mask_out, & + is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in, & + window_id=window_id) + else + call allocate_rotated_array(data_in, [1,1], -qturns, data_pre) + call time_interp_external(fms_id, time, data_pre, interp=interp, & + verbose=verbose, horz_interp=horz_interp, mask_out=mask_out, & + is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in, & + window_id=window_id) + call rotate_array(data_pre, turns, data_in) + deallocate(data_pre) + endif +end subroutine rotated_time_interp_external_2d + + +!> Read a 3d field based on model time, and rotate to the model grid +subroutine rotated_time_interp_external_3d(fms_id, time, data_in, interp, & + verbose, horz_interp, mask_out, is_in, ie_in, js_in, je_in, window_id, & + turns) + integer, intent(in) :: fms_id + type(time_type), intent(in) :: time + real, dimension(:,:,:), intent(inout) :: data_in + integer, intent(in), optional :: interp + logical, intent(in), optional :: verbose + type(horiz_interp_type),intent(in), optional :: horz_interp + logical, dimension(:,:,:), intent(out), optional :: mask_out + integer, intent(in), optional :: is_in, ie_in, js_in, je_in + integer, intent(in), optional :: window_id + integer, intent(in), optional :: turns + + real, allocatable :: data_pre(:,:,:) + integer :: qturns + + ! TODO: Mask rotation requires logical array rotation support + if (present(mask_out)) & + call MOM_error(FATAL, "Rotation of masked output not yet support") + + qturns = 0 + if (present(turns)) & + qturns = modulo(turns, 4) + + if (qturns == 0) then + call time_interp_external(fms_id, time, data_in, interp=interp, & + verbose=verbose, horz_interp=horz_interp, mask_out=mask_out, & + is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in, & + window_id=window_id) + else + call allocate_rotated_array(data_in, [1,1,1], -qturns, data_pre) + call time_interp_external(fms_id, time, data_pre, interp=interp, & + verbose=verbose, horz_interp=horz_interp, mask_out=mask_out, & + is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in, & + window_id=window_id) + call rotate_array(data_pre, turns, data_in) + deallocate(data_pre) + endif +end subroutine rotated_time_interp_external_3d + +end module MOM_transform_FMS diff --git a/src/framework/MOM_unit_scaling.F90 b/src/framework/MOM_unit_scaling.F90 index 30e9c49850..fea1ac4910 100644 --- a/src/framework/MOM_unit_scaling.F90 +++ b/src/framework/MOM_unit_scaling.F90 @@ -24,20 +24,23 @@ module MOM_unit_scaling real :: J_kg_to_Q !< A constant that translates Joules per kilogram to the units of enthalpy. ! These are useful combinations of the fundamental scale conversion factors above. - real :: Z_to_L !< Convert vertical distances to lateral lengths - real :: L_to_Z !< Convert vertical distances to lateral lengths - real :: L_T_to_m_s !< Convert lateral velocities from L T-1 to m s-1. - real :: m_s_to_L_T !< Convert lateral velocities from m s-1 to L T-1. - real :: L_T2_to_m_s2 !< Convert lateral accelerations from L T-2 to m s-2. - real :: Z2_T_to_m2_s !< Convert vertical diffusivities from Z2 T-1 to m2 s-1. - real :: m2_s_to_Z2_T !< Convert vertical diffusivities from m2 s-1 to Z2 T-1. - real :: W_m2_to_QRZ_T !< Convert heat fluxes from W m-2 to Q R Z T-1. - real :: QRZ_T_to_W_m2 !< Convert heat fluxes from Q R Z T-1 to W m-2. + real :: Z_to_L !< Convert vertical distances to lateral lengths + real :: L_to_Z !< Convert lateral lengths to vertical distances + real :: L_T_to_m_s !< Convert lateral velocities from L T-1 to m s-1. + real :: m_s_to_L_T !< Convert lateral velocities from m s-1 to L T-1. + real :: L_T2_to_m_s2 !< Convert lateral accelerations from L T-2 to m s-2. + real :: Z2_T_to_m2_s !< Convert vertical diffusivities from Z2 T-1 to m2 s-1. + real :: m2_s_to_Z2_T !< Convert vertical diffusivities from m2 s-1 to Z2 T-1. + real :: W_m2_to_QRZ_T !< Convert heat fluxes from W m-2 to Q R Z T-1. + real :: QRZ_T_to_W_m2 !< Convert heat fluxes from Q R Z T-1 to W m-2. ! Not used enough: real :: kg_m2_to_RZ !< Convert mass loads from kg m-2 to R Z. - real :: RZ_to_kg_m2 !< Convert mass loads from R Z to kg m-2. + real :: RZ_to_kg_m2 !< Convert mass loads from R Z to kg m-2. real :: kg_m2s_to_RZ_T !< Convert mass fluxes from kg m-2 s-1 to R Z T-1. real :: RZ_T_to_kg_m2s !< Convert mass fluxes from R Z T-1 to kg m-2 s-1. real :: RZ3_T3_to_W_m2 !< Convert turbulent kinetic energy fluxes from R Z3 T-3 to W m-2. + real :: W_m2_to_RZ3_T3 !< Convert turbulent kinetic energy fluxes from W m-2 to R Z3 T-3. + real :: RL2_T2_to_Pa !< Convert pressures from R L2 T-2 to Pa. + ! Not used enough: real :: Pa_to_RL2_T2 !< Convert pressures from Pa to R L2 T-2. ! These are used for changing scaling across restarts. real :: m_to_Z_restart = 0.0 !< A copy of the m_to_Z that is used in restart files. @@ -51,8 +54,8 @@ module MOM_unit_scaling !> 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 + type(param_file_type), optional, intent(in) :: param_file !< Parameter file handle/type + type(unit_scale_type), optional, pointer :: US !< A dimensional unit scaling type ! This routine initializes a unit_scale_type structure (US). @@ -63,33 +66,40 @@ subroutine unit_scaling_init( param_file, US ) # include "version_variable.h" character(len=16) :: mdl = "MOM_unit_scaling" + if (.not.present(US)) return + 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.") - call get_param(param_file, mdl, "Z_RESCALE_POWER", Z_power, & + if (present(param_file)) then + ! 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 "//& - "intenal units of depths and heights. Valid values range from -300 to 300.", & + "internal units of depths and heights. Valid values range from -300 to 300.", & units="nondim", default=0, debuggingParam=.true.) - call get_param(param_file, mdl, "L_RESCALE_POWER", L_power, & + call get_param(param_file, mdl, "L_RESCALE_POWER", L_power, & "An integer power of 2 that is used to rescale the model's "//& - "intenal units of lateral distances. Valid values range from -300 to 300.", & + "internal units of lateral distances. Valid values range from -300 to 300.", & units="nondim", default=0, debuggingParam=.true.) - call get_param(param_file, mdl, "T_RESCALE_POWER", T_power, & + call get_param(param_file, mdl, "T_RESCALE_POWER", T_power, & "An integer power of 2 that is used to rescale the model's "//& - "intenal units of time. Valid values range from -300 to 300.", & + "internal units of time. Valid values range from -300 to 300.", & units="nondim", default=0, debuggingParam=.true.) - call get_param(param_file, mdl, "R_RESCALE_POWER", R_power, & + call get_param(param_file, mdl, "R_RESCALE_POWER", R_power, & "An integer power of 2 that is used to rescale the model's "//& - "intenal units of density. Valid values range from -300 to 300.", & + "internal units of density. Valid values range from -300 to 300.", & units="nondim", default=0, debuggingParam=.true.) - call get_param(param_file, mdl, "Q_RESCALE_POWER", Q_power, & + call get_param(param_file, mdl, "Q_RESCALE_POWER", Q_power, & "An integer power of 2 that is used to rescale the model's "//& - "intenal units of heat content. Valid values range from -300 to 300.", & - units="nondim", default=0, debuggingParam=.true.) + "internal units of heat content. Valid values range from -300 to 300.", & + units="nondim", default=0, debuggingParam=.true.) + else + Z_power = 0 ; L_power = 0 ; T_power = 0 ; R_power = 0 ; Q_power = 0 + endif + 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: "//& @@ -129,19 +139,31 @@ subroutine unit_scaling_init( param_file, US ) ! These are useful combinations of the fundamental scale conversion factors set above. 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. + ! 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 - ! It does not seem like US%kg_m2_to_RZ would be used enough in MOM6 to justify its existence. + ! 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 + ! It does not seem like US%Pa_to_RL2_T2 would be used enough in MOM6 to justify its existence. + ! US%Pa_to_RL2_T2 = US%kg_m3_to_R * US%m_s_to_L_T**2 end subroutine unit_scaling_init diff --git a/src/framework/MOM_write_cputime.F90 b/src/framework/MOM_write_cputime.F90 index 7a2fb36608..2c1cb3378a 100644 --- a/src/framework/MOM_write_cputime.F90 +++ b/src/framework/MOM_write_cputime.F90 @@ -3,15 +3,15 @@ module MOM_write_cputime ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_coms, only : sum_across_PEs, pe_here, num_pes +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_file, APPEND_FILE, ASCII_FILE, WRITEONLY_FILE +use MOM_io, only : open_file, close_file, APPEND_FILE, ASCII_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, write_cputime_start_clock +public write_cputime, MOM_write_cputime_init, MOM_write_cputime_end, write_cputime_start_clock !----------------------------------------------------------------------- @@ -33,7 +33,7 @@ module MOM_write_cputime real :: cputime2 = 0.0 !< The accumulated cpu time. 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 !< The unit number of the CPU time file. + 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 @@ -60,9 +60,10 @@ subroutine MOM_write_cputime_init(param_file, directory, Input_start_time, CS) ! Local variables integer :: new_cputime ! The CPU time returned by SYSTEM_CLOCK -! This include declares and sets the variable "version". -#include "version_variable.h" + ! This include declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mdl = 'MOM_write_cputime' ! This module's name. + logical :: all_default ! If true, all parameters are using their default values. if (.not.associated(CS)) then allocate(CS) @@ -71,7 +72,13 @@ subroutine MOM_write_cputime_init(param_file, directory, Input_start_time, CS) endif ! Read all relevant parameters and write them to the model log. - call log_version(param_file, mdl, version, "") + + ! Determine whether all paramters are set to their default values. + call get_param(param_file, mdl, "MAXCPU", CS%maxcpu, default=-1.0, do_not_log=.true.) + call get_param(param_file, mdl, "CPU_TIME_FILE", CS%CPUfile, default="CPU_stats", do_not_log=.true.) + all_default = (CS%maxcpu == -1.0) .and. (trim(CS%CPUfile) == trim("CPU_stats")) + + call log_version(param_file, mdl, version, "", all_default=all_default) call get_param(param_file, mdl, "MAXCPU", CS%maxcpu, & "The maximum amount of cpu time per processor for which "//& "MOM should run before saving a restart file and "//& @@ -94,16 +101,35 @@ subroutine MOM_write_cputime_init(param_file, directory, Input_start_time, CS) end subroutine MOM_write_cputime_init -!> 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. -subroutine write_cputime(day, n, nmax, CS) - type(time_type), intent(inout) :: day !< The current model time. - integer, intent(in) :: n !< The time step number of the current execution. - integer, intent(inout) :: nmax !< The number of iterations after which to stop so - !! that the simulation will not run out of CPU time. - type(write_cputime_CS), pointer :: CS !< The control structure set up by a previous +!> 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 + call 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. @@ -138,7 +164,7 @@ subroutine write_cputime(day, n, nmax, CS) ((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 (CS%dn_dcpu_min >= 0.0) then + 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 - & @@ -173,9 +199,15 @@ subroutine write_cputime(day, n, nmax, CS) 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) + + call 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 diff --git a/src/framework/_Diagnostics.dox b/src/framework/_Diagnostics.dox index 51a1cd35c7..3db345ca1a 100644 --- a/src/framework/_Diagnostics.dox +++ b/src/framework/_Diagnostics.dox @@ -10,7 +10,6 @@ the former being diagnostics in the actual model coordinate space, and the latte \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 syntax is documented at http://data1.gfdl.noaa.gov/~nnz/MOM/mom5_pubrel_August2012/src/shared/diag_manager/diag_table.html. 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, @@ -180,8 +179,8 @@ To obtain a diagnostic of monthly-averaged potential temperature in both these c ``` "ocean_month_z", 1, "months", 1, "days", "time" "ocean_month_abc", 1, "months", 1, "days", "time" -"ocean_model", "temp", "temp", "ocean_month_z", "all", "mean", "none",2 -"ocean_model", "temp", "temp", "ocean_month_abc", "all", "mean", "none",2 +"ocean_model_z", "temp", "temp", "ocean_month_z", "all", "mean", "none",2 +"ocean_model_abc", "temp", "temp", "ocean_month_abc", "all", "mean", "none",2 ``` diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 733245b1ce..66fd873f67 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -35,7 +35,7 @@ module MOM_ice_shelf use MOM_forcing_type, only : mech_forcing, allocate_mech_forcing, MOM_mech_forcing_chksum use MOM_forcing_type, only : copy_common_forcing_fields use MOM_get_input, only : directories, Get_MOM_input -use MOM_EOS, only : calculate_density, calculate_density_derivs, calculate_TFreeze +use MOM_EOS, only : calculate_density, calculate_density_derivs, calculate_TFreeze, EOS_domain use MOM_EOS, only : EOS_type, EOS_init use MOM_ice_shelf_dynamics, only : ice_shelf_dyn_CS, update_ice_shelf use MOM_ice_shelf_dynamics, only : register_ice_shelf_dyn_restarts, initialize_ice_shelf_dyn @@ -51,7 +51,6 @@ module MOM_ice_shelf use MOM_checksums, only : hchksum, qchksum, chksum, uchksum, vchksum, uvchksum use time_interp_external_mod, only : init_external_field, time_interp_external use time_interp_external_mod, only : time_interp_external_init -use time_manager_mod, only : print_time implicit none ; private #include @@ -92,7 +91,7 @@ module MOM_ice_shelf real :: ustar_bg !< A minimum value for ustar under ice shelves [Z T-1 ~> m s-1]. real :: cdrag !< drag coefficient under ice shelves [nondim]. - real :: g_Earth !< The gravitational acceleration [Z T-2 ~> m s-2] + real :: g_Earth !< The gravitational acceleration [L2 Z-1 T-2 ~> m s-2] real :: Cp !< The heat capacity of sea water [Q degC-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 degC-1 ~> J kg-1 degC-1]. @@ -100,7 +99,7 @@ module MOM_ice_shelf !< 2-equation formulation [Z T-1 ~> m s-1]. real :: Salin_ice !< The salinity of shelf ice [ppt]. real :: Temp_ice !< The core temperature of shelf ice [degC]. - real :: kv_ice !< The viscosity of ice [Z2 T-1 ~> m2 s-1]. + 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]. @@ -158,7 +157,8 @@ module MOM_ice_shelf 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 [degC] real :: dTFr_dS !< Partial derivative of freezing temperature with salinity [degC ppt-1] - real :: dTFr_dp !< Partial derivative of freezing temperature with pressure [degC Pa-1] + real :: dTFr_dp !< Partial derivative of freezing temperature with + !! pressure [degC T2 R-1 L-2 ~> degC Pa-1] !>@{ Diagnostic handles integer :: id_melt = -1, id_exch_vel_s = -1, id_exch_vel_t = -1, & id_tfreeze = -1, id_tfl_shelf = -1, & @@ -191,33 +191,33 @@ module MOM_ice_shelf !> 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(state, fluxes, Time, time_step, CS, forces) - type(surface), intent(inout) :: state !< A structure containing fields that +subroutine shelf_calc_flux(sfc_state, fluxes, Time, time_step, CS, forces) + type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. The !! intent is only inout to allow for halo updates. type(forcing), intent(inout) :: fluxes !< structure containing pointers to any possible - !! thermodynamic or mass-flux forcing fields. + !! thermodynamic or mass-flux forcing fields. type(time_type), intent(in) :: Time !< Start time of the fluxes. - real, intent(in) :: time_step !< Length of time over which - !! these fluxes will be applied [s]. - type(ice_shelf_CS), pointer :: CS !< A pointer to the control structure - !! returned by a previous call to - !! initialize_ice_shelf. + real, intent(in) :: time_step !< Length of time over which these fluxes + !! will be applied [s]. + type(ice_shelf_CS), pointer :: CS !< A pointer to the control structure returned + !! by a previous call to initialize_ice_shelf. type(mech_forcing), optional, intent(inout) :: forces !< A structure with the driving mechanical forces - 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 + ! 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 + !! the ice-shelf state real, dimension(SZI_(CS%grid)) :: & - Rhoml, & !< Ocean mixed layer density [kg m-3]. + Rhoml, & !< Ocean mixed layer density [R ~> kg m-3]. dR0_dT, & !< Partial derivative of the mixed layer density - !< with temperature [kg m-3 degC-1]. + !< with temperature [R degC-1 ~> kg m-3 degC-1]. dR0_dS, & !< Partial derivative of the mixed layer density - !< with salinity [kg m-3 ppt-1]. - p_int !< The pressure at the ice-ocean interface [Pa]. + !< with salinity [R ppt-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] @@ -234,8 +234,8 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) !! viscosity is linearly increasing [nondim]. (Was 1/8. Why?) real, parameter :: RC = 0.20 ! 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 VK. + 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 @@ -262,7 +262,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! boundary layer salinity times the friction velocity [ppt 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 + real :: Gam_mol_t, Gam_mol_s ! Relative coefficients of molecular diffusivites [nondim] real :: RhoCp ! A typical ocean density times the heat capacity of water [Q R ~> J m-3] real :: ln_neut real :: mass_exch ! A mass exchange rate [R Z T-1 ~> kg m-2 s-1] @@ -272,13 +272,12 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) 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 [Pa]. + 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 unit conversion factors that - ! arise because state uses MKS units [L2 m s2 kg-1 T-2 ~> m3 kg-1]. + 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 grouding line position is determined based on @@ -286,6 +285,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) 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: "// & @@ -305,8 +305,8 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) RhoCp = CS%Rho_ocn * CS%Cp !first calculate molecular component - Gam_mol_t = 12.5 * (PR**c2_3) - 6 - Gam_mol_s = 12.5 * (SC**c2_3) - 6 + 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 @@ -317,7 +317,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) 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(:,:) = state%sss(:,:) + Sbdry(:,:) = sfc_state%sss(:,:) !update time CS%Time = Time @@ -330,18 +330,19 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) if (CS%debug) then call hchksum(fluxes%frac_shelf_h, "frac_shelf_h before apply melting", G%HI, haloshift=0) - call hchksum(state%sst, "sst before apply melting", G%HI, haloshift=0) - call hchksum(state%sss, "sss before apply melting", G%HI, haloshift=0) - call hchksum(state%u, "u_ml before apply melting", G%HI, haloshift=0) - call hchksum(state%v, "v_ml before apply melting", G%HI, haloshift=0) - call hchksum(state%ocean_mass, "ocean_mass before apply melting", G%HI, haloshift=0) + call hchksum(sfc_state%sst, "sst before apply melting", G%HI, haloshift=0) + call hchksum(sfc_state%sss, "sss before apply melting", G%HI, haloshift=0) + call hchksum(sfc_state%u, "u_ml before apply melting", G%HI, haloshift=0, scale=US%L_T_to_m_s) + call hchksum(sfc_state%v, "v_ml before apply melting", G%HI, haloshift=0, scale=US%L_T_to_m_s) + call hchksum(sfc_state%ocean_mass, "ocean_mass before apply melting", G%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(state%taux_shelf) .and. allocated(state%tauy_shelf)) then - call pass_vector(state%taux_shelf, state%tauy_shelf, G%domain, TO_ALL, CGRID_NE) + 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%m_s_to_L_T**2*US%kg_m3_to_R / CS%Rho_ocn + 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)) @@ -350,12 +351,12 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) 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(state%taux_shelf) .and. allocated(state%tauy_shelf)) then - taux2 = (asu1 * state%taux_shelf(I-1,j)**2 + asu2 * state%taux_shelf(I,j)**2 ) * I_au - tauy2 = (asv1 * state%tauy_shelf(i,J-1)**2 + asv2 * state%tauy_shelf(i,J)**2 ) * I_av + 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 = US%m_s_to_L_T**2*(asu1 * state%u(I-1,j)**2 + asu2 * state%u(I,j)**2) * I_au - v2_av = US%m_s_to_L_T**2*(asv1 * state%v(i,J-1)**2 + asu2 * state%v(i,J)**2) * I_av + 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) then fluxes%ustar_shelf(i,j) = MAX(CS%ustar_bg, US%L_to_Z * & @@ -368,19 +369,20 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) 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) = US%RZ_to_kg_m2*US%Z_to_m*US%s_to_T**2*CS%g_Earth * ISS%mass_shelf(i,j) ; enddo + 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(state%sst(:,j), state%sss(:,j), p_int, & - Rhoml(:), is, ie-is+1, CS%eqn_of_state) - call calculate_density_derivs(state%sst(:,j), state%sss(:,j), p_int, & - dR0_dT, dR0_dS, is, ie-is+1, CS%eqn_of_state) + 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 ((state%ocean_mass(i,j) > US%RZ_to_kg_m2*CS%col_mass_melt_threshold) .and. & + 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 @@ -394,13 +396,13 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! 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*US%m_to_Z*state%Hml(i,j) <= VK*ustar_h) then ; hBL_neut = US%m_to_Z*state%Hml(i,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 = (CS%g_Earth / Rhoml(i)) * dR0_dS(i) - dB_dT = (CS%g_Earth / Rhoml(i)) * dR0_dT(i) + 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 @@ -411,9 +413,9 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! 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) - state%sst(i,j)) - & + 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 * state%sss(i,j) ! Always >= 0 + 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 @@ -431,7 +433,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! Safety check if (Sbdry(i,j) < 0.) then - write(mesg,*) 'state%sss(i,j) = ',state%sss(i,j), 'S_a, S_b, S_c', S_a, S_b, S_c + write(mesg,*) 'sfc_state%sss(i,j) = ',sfc_state%sss(i,j), 'S_a, S_b, S_c', S_a, S_b, S_c call MOM_error(WARNING, mesg, .true.) write(mesg,*) 'I,J,Sbdry1,Sbdry2',i,j,Sbdry1,Sbdry2 call MOM_error(WARNING, mesg, .true.) @@ -439,16 +441,17 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) endif else ! Guess sss as the iteration starting point for the boundary salinity. - Sbdry(i,j) = state%sss(i,j) ; Sb_max_set = .false. + 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. - call calculate_TFreeze(Sbdry(i,j), p_int(i), ISS%tfreeze(i,j), CS%eqn_of_state) + call calculate_TFreeze(Sbdry(i,j), p_int(i), ISS%tfreeze(i,j), CS%eqn_of_state, & + pres_scale=US%RL2_T2_to_Pa) - dT_ustar = (ISS%tfreeze(i,j) - state%sst(i,j)) * ustar_h - dS_ustar = (Sbdry(i,j) - state%sss(i,j)) * ustar_h + 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 @@ -554,10 +557,10 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) else mass_exch = exch_vel_s(i,j) * CS%Rho_ocn - Sbdry_it = (state%sss(i,j) * mass_exch + CS%Salin_ice * ISS%water_flux(i,j)) / & + 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) < 1e-4*(0.5*(state%sss(i,j) + Sbdry(i,j) + 1.e-10))) exit + if (abs(dS_it) < 1.0e-4*(0.5*(sfc_state%sss(i,j) + Sbdry(i,j) + 1.0e-10))) exit if (dS_it < 0.0) then ! Sbdry is now the upper bound. @@ -588,10 +591,11 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! is specified and large enough that the ocean salinity at the interface ! is about the same as the boundary layer salinity. - call calculate_TFreeze(state%sss(i,j), p_int(i), ISS%tfreeze(i,j), CS%eqn_of_state) + call calculate_TFreeze(sfc_state%sss(i,j), p_int(i), ISS%tfreeze(i,j), CS%eqn_of_state, & + pres_scale=US%RL2_T2_to_Pa) exch_vel_t(i,j) = CS%gamma_t - ISS%tflux_ocn(i,j) = RhoCp * exch_vel_t(i,j) * (ISS%tfreeze(i,j) - state%sst(i,j)) + 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 @@ -602,16 +606,17 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ISS%tflux_ocn(i,j) = 0.0 endif -! haline_driving(:,:) = state%sss(i,j) - Sbdry(i,j) +! haline_driving(i,j) = sfc_state%sss(i,j) - Sbdry(i,j) enddo ! i-loop enddo ! j-loop - ! ISS%water_flux = net liquid water into the ocean [R Z T-1 ~> kg m-2 s-1] - fluxes%iceshelf_melt(:,:) = ISS%water_flux(:,:) * CS%flux_factor do j=js,je ; do i=is,ie - if ((state%ocean_mass(i,j) > US%RZ_to_kg_m2*CS%col_mass_melt_threshold) .and. & + ! 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). @@ -625,11 +630,11 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) !!!!!!!!!!!!!!!!!!!!!!!!!!!!Safety checks !!!!!!!!!!!!!!!!!!!!!!!!! !1)Check if haline_driving computed above is consistent with - ! haline_driving = state%sss - Sbdry + ! haline_driving = sfc_state%sss - Sbdry !if (fluxes%iceshelf_melt(i,j) /= 0.0) then - ! if (haline_driving(i,j) /= (state%sss(i,j) - Sbdry(i,j))) 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',haline_driving(i,j), & - ! (state%sss(i,j) - Sbdry(i,j)) + ! (sfc_state%sss(i,j) - Sbdry(i,j)) ! call MOM_error(FATAL, & ! "shelf_calc_flux: Inconsistency in melt and haline_driving"//trim(mesg)) ! endif @@ -648,11 +653,10 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ISS%water_flux(i,j) = 0.0 fluxes%iceshelf_melt(i,j) = 0.0 endif ! area_shelf_h - enddo ; enddo ! i- and j-loops - ! mass flux [kg s-1], part of ISOMIP diags. - mass_flux(:,:) = 0.0 - mass_flux(:,:) = ISS%water_flux(:,:) * ISS%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) @@ -674,7 +678,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) if (CS%debug) call MOM_forcing_chksum("Before add shelf flux", fluxes, G, CS%US, haloshift=0) - call add_shelf_flux(G, US, CS, state, fluxes) + call add_shelf_flux(G, US, CS, sfc_state, fluxes) ! now the thermodynamic data is passed on... time to update the ice dynamic quantities @@ -685,7 +689,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! 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, US%s_to_T*time_step, Time, & - US%kg_m3_to_R*US%m_to_Z*state%ocean_mass(:,:), coupled_GL) + sfc_state%ocean_mass, coupled_GL) endif @@ -694,12 +698,12 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) 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_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, (state%sst-ISS%tfreeze), 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, state%u, CS%diag) - if (CS%id_v_ml > 0) call post_data(CS%id_v_ml, state%v, 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) @@ -775,8 +779,8 @@ subroutine add_shelf_forces(G, US, CS, forces, do_shelf_area) 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. - real :: kv_rho_ice ! The viscosity of ice divided by its density [m3 s-1 R-1 Z-1 ~> m5 kg-1 s-1]. - real :: press_ice ! The pressure of the ice shelf per unit area of ocean (not ice) [Pa]. + 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. type(ice_shelf_state), pointer :: ISS => NULL() ! A structure with elements that describe ! the ice-shelf state @@ -811,8 +815,7 @@ subroutine add_shelf_forces(G, US, CS, forces, do_shelf_area) endif do j=js,je ; do i=is,ie - press_ice = (ISS%area_shelf_h(i,j) * G%IareaT(i,j)) * & - US%RZ_to_kg_m2*US%Z_to_m*US%s_to_T**2*(CS%g_Earth * ISS%mass_shelf(i,j)) + 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 @@ -827,7 +830,7 @@ subroutine add_shelf_forces(G, US, CS, forces, do_shelf_area) ! 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 = US%Z_to_m*US%Z2_T_to_m2_s*CS%kv_ice / CS%density_ice + 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) + & @@ -841,7 +844,7 @@ subroutine add_shelf_forces(G, US, CS, forces, do_shelf_area) if (CS%debug) then call uvchksum("rigidity_ice_[uv]", forces%rigidity_ice_u, forces%rigidity_ice_v, & - G%HI, symmetric=.true.) + G%HI, symmetric=.true., scale=US%L_to_m**3*US%L_to_Z*US%s_to_T) call uvchksum("frac_shelf_[uv]", forces%frac_shelf_u, forces%frac_shelf_v, & G%HI, symmetric=.true.) endif @@ -855,7 +858,7 @@ subroutine add_shelf_pressure(G, US, CS, fluxes) 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. - real :: press_ice !< The pressure of the ice shelf per unit area of ocean (not ice) [Pa]. + 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, isd, ied, jsd, jed is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -864,8 +867,7 @@ subroutine add_shelf_pressure(G, US, CS, fluxes) 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)) * & - US%RZ_to_kg_m2*US%Z_to_m*US%s_to_T**2*(CS%g_Earth * CS%ISS%mass_shelf(i,j)) + 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 @@ -879,19 +881,18 @@ subroutine add_shelf_pressure(G, US, CS, fluxes) end subroutine add_shelf_pressure !> Updates surface fluxes that are influenced by sub-ice-shelf melting -subroutine add_shelf_flux(G, US, CS, state, fluxes) +subroutine add_shelf_flux(G, US, CS, sfc_state, fluxes) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(ice_shelf_CS), pointer :: CS !< This module's control structure. - type(surface), intent(inout) :: state!< Surface ocean state + type(surface), intent(inout) :: sfc_state !< Surface ocean state type(forcing), intent(inout) :: fluxes !< A structure of surface fluxes that may be used/updated. ! 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 [kg s-1] - real :: press_ice !< The pressure of the ice shelf per unit area of ocean (not ice) [Pa]. - real :: balancing_flux !< The fresh water flux that balances the integrated melt flux [R Z T-1 ~> kg m-2 s-1] + 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) @@ -903,7 +904,7 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) !! 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 + 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) @@ -929,9 +930,9 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) ! vertical decay scale. if (CS%debug) then - if (allocated(state%taux_shelf) .and. allocated(state%tauy_shelf)) then - call uvchksum("tau[xy]_shelf", state%taux_shelf, state%tauy_shelf, & - G%HI, haloshift=0) + 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 @@ -1021,7 +1022,7 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) ! 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 ((state%ocean_mass(i,j) > US%RZ_to_kg_m2*CS%min_ocean_mass_float) .and. & + 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 @@ -1050,9 +1051,9 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) balancing_area = global_area_integral(bal_frac, G) if (balancing_area > 0.0) then - balancing_flux = US%kg_m2s_to_RZ_T*(global_area_integral(ISS%water_flux, G, scale=US%RZ_T_to_kg_m2s, & - area=ISS%area_shelf_h) + & - delta_mass_shelf ) / balancing_area + balancing_flux = ( US%kg_m2s_to_RZ_T*global_area_integral(ISS%water_flux, G, scale=US%RZ_T_to_kg_m2s, & + area=ISS%area_shelf_h) + & + delta_mass_shelf ) / balancing_area else balancing_flux = 0.0 endif @@ -1121,7 +1122,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl character(len=240) :: Tideamp_file 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 [m] + ! does not occur [Z ~> m] if (associated(CS)) then call MOM_error(FATAL, "MOM_ice_shelf.F90, initialize_ice_shelf: "// & "called with an associated control structure.") @@ -1164,7 +1165,6 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl write(0,*) 'IG: ', G%isd, G%isc, G%iec, G%ied, G%jsd, G%jsc, G%jsd, G%jed endif - CS%Time = Time ! ### This might not be in the right place? CS%diag => diag ! Are we being called from the solo ice-sheet driver? When called by the ocean @@ -1275,17 +1275,16 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl "this is the freezing potential temperature at "//& "S=0, P=0.", units="degC", default=0.0, do_not_log=.true.) call get_param(param_file, mdl, "DTFREEZE_DS", CS%dTFr_dS, & - "this is the derivative of the freezing potential "//& - "temperature with salinity.", units="degC psu-1", default=-0.054, do_not_log=.true.) + "this is the derivative of the freezing potential temperature with salinity.", & + units="degC psu-1", default=-0.054, do_not_log=.true.) call get_param(param_file, mdl, "DTFREEZE_DP", CS%dTFr_dp, & - "this is the derivative of the freezing potential "//& - "temperature with pressure.", & - units="degC Pa-1", default=0.0, do_not_log=.true.) + "this is the derivative of the freezing potential temperature with pressure.", & + units="degC Pa-1", default=0.0, scale=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_to_Z*US%T_to_s**2) + 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.", & @@ -1306,7 +1305,8 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl "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%m2_s_to_Z2_T) + "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 kinimatic viscosity of sea water at the "//& "freezing temperature.", units="m2 s-1", default=1.95e-6, scale=US%m2_s_to_Z2_T) @@ -1615,9 +1615,9 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl CS%id_Sbdry = register_diag_field('ocean_model', 'sbdry', CS%diag%axesT1, CS%Time, & 'salinity at the ice-ocean interface.', 'psu') CS%id_u_ml = register_diag_field('ocean_model', 'u_ml', CS%diag%axesCu1, CS%Time, & - 'Eastward vel. in the boundary layer (used to compute ustar)', 'm s-1') + '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('ocean_model', 'v_ml', CS%diag%axesCv1, CS%Time, & - 'Northward vel. in the boundary layer (used to compute ustar)', 'm s-1') + '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('ocean_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('ocean_model', 'exch_vel_t', CS%diag%axesT1, CS%Time, & @@ -1733,7 +1733,9 @@ subroutine update_shelf_mass(G, US, CS, ISS, Time) call time_interp_external(CS%id_read_mass, Time, ISS%mass_shelf) ! This should only be done if time_interp_external did an update. - ISS%mass_shelf(:,:) = US%kg_m3_to_R*US%m_to_Z * ISS%mass_shelf(:,:) ! Rescale after time_interp + 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 diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index be3ae1ecde..0c9fe4e77e 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -1405,6 +1405,7 @@ subroutine ice_shelf_advect_thickness_y(CS, G, LB, time_step, hmask, h0, h_after real :: h_face ! Thickness at a face for transport [Z ~> m] real :: slope_lim ! The value of the slope limiter, in the range of 0 to 2 [nondim] + ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh ! hmask coded values: 1) fully covered; 2) partly covered - no export; 3) Specified boundary condition ! relevant u_face_mask coded values: 1) Normal interior point; 4) Specified flux BC diff --git a/src/ice_shelf/MOM_ice_shelf_state.F90 b/src/ice_shelf/MOM_ice_shelf_state.F90 index b3e88697f2..a3784b5a34 100644 --- a/src/ice_shelf/MOM_ice_shelf_state.F90 +++ b/src/ice_shelf/MOM_ice_shelf_state.F90 @@ -12,7 +12,6 @@ module MOM_ice_shelf_state use MOM_file_parser, only : read_param, get_param, log_param, log_version, param_file_type use MOM_grid, only : MOM_grid_init, ocean_grid_type use MOM_get_input, only : directories, Get_MOM_input -use mpp_mod, only : mpp_sum, mpp_max, mpp_min, mpp_pe, mpp_npes, mpp_sync use MOM_coms, only : reproducing_sum use MOM_checksums, only : hchksum, qchksum, chksum, uchksum, vchksum, uvchksum diff --git a/src/ice_shelf/MOM_marine_ice.F90 b/src/ice_shelf/MOM_marine_ice.F90 index 780cc8c3cd..64d4dbfdab 100644 --- a/src/ice_shelf/MOM_marine_ice.F90 +++ b/src/ice_shelf/MOM_marine_ice.F90 @@ -26,12 +26,12 @@ module MOM_marine_ice !> Control structure for MOM_marine_ice type, public :: marine_ice_CS ; private - real :: kv_iceberg !< The viscosity of the icebergs [m2 s-1] (for ice rigidity) + 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. (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 [kg m-3] (for ice rigidity) + 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. @@ -48,10 +48,10 @@ subroutine iceberg_forces(G, forces, use_ice_shelf, sfc_state, time_step, CS) 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 [s]. - type(marine_ice_CS), pointer :: CS !< Pointer to the control structure for MOM_marine_ice + real, intent(in) :: time_step !< The coupling time step [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 [m5 kg-1 s-1]. + 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) @@ -83,7 +83,7 @@ subroutine iceberg_forces(G, forces, use_ice_shelf, sfc_state, time_step, CS) (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)) + 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)) & @@ -107,18 +107,17 @@ subroutine iceberg_fluxes(G, US, fluxes, use_ice_shelf, sfc_state, time_step, CS !! 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 [s]. - type(marine_ice_CS), pointer :: CS !< Pointer to the control structure for MOM_marine_ice + 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 unit conversion - ! factors because sfc_state is in MKS units [R Z m2 J-1 T-1 ~> kg J-1 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. + ! 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. & @@ -139,7 +138,7 @@ subroutine iceberg_fluxes(G, US, fluxes, use_ice_shelf, sfc_state, time_step, CS !Zero'ing out other fluxes under the tabular icebergs if (CS%berg_area_threshold >= 0.) then - I_dt_LHF = US%W_m2_to_QRZ_T / (time_step * CS%latent_heat_fusion) + I_dt_LHF = 1.0 / (US%s_to_T*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. @@ -149,7 +148,7 @@ subroutine iceberg_fluxes(G, US, fluxes, use_ice_shelf, sfc_state, time_step, CS 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 [J m-2] in the + ! 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. @@ -190,9 +189,10 @@ subroutine marine_ice_init(Time, G, param_file, diag, CS) 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) + "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) + "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, & diff --git a/src/initialization/MOM_coord_initialization.F90 b/src/initialization/MOM_coord_initialization.F90 index 63461df157..c1ec788836 100644 --- a/src/initialization/MOM_coord_initialization.F90 +++ b/src/initialization/MOM_coord_initialization.F90 @@ -80,7 +80,7 @@ subroutine MOM_initialize_coord(GV, US, PF, write_geom, output_dir, tv, max_dept " \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.", & - fail_if_missing=.true.) + default="none") select case ( trim(config) ) case ("gprime") call set_coord_from_gprime(GV%Rlay, GV%g_prime, GV, US, PF) @@ -89,7 +89,7 @@ subroutine MOM_initialize_coord(GV, US, PF, write_geom, output_dir, tv, max_dept 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, eos, tv%P_Ref) + call set_coord_from_TS_ref(GV%Rlay, GV%g_prime, GV, US, PF, eos, tv%P_Ref) case ("ts_profile") call set_coord_from_TS_profile(GV%Rlay, GV%g_prime, GV, US, PF, eos, tv%P_Ref) case ("ts_range") @@ -105,6 +105,10 @@ subroutine MOM_initialize_coord(GV, US, PF, write_geom, output_dir, tv, max_dept 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 ) @@ -123,13 +127,13 @@ end subroutine MOM_initialize_coord !> Sets the layer densities (Rlay) and the interface reduced gravities (g). subroutine set_coord_from_gprime(Rlay, g_prime, GV, US, param_file) - real, dimension(:), intent(out) :: Rlay !< The layers' target coordinate values - !! (potential density) [R ~> kg m-3]. - real, dimension(:), intent(out) :: g_prime !< The reduced gravity across the interfaces - !! [L2 Z-1 T-2 ~> m 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 - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + 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]. @@ -141,7 +145,7 @@ subroutine set_coord_from_gprime(Rlay, g_prime, GV, US, param_file) call get_param(param_file, mdl, "GFS" , g_fs, & "The reduced gravity at the free surface.", units="m s-2", & - default=GV%mks_g_Earth, scale=US%m_s_to_L_T**2*US%Z_to_m) + 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) @@ -157,13 +161,14 @@ 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) - real, dimension(:), intent(out) :: Rlay !< The layers' target coordinate values - !! (potential density) [R ~> kg m-3]. - real, dimension(:), intent(out) :: g_prime !< The reduced gravity across the interfaces - !! [L2 Z-1 T-2 ~> m 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 - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + 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]. @@ -176,7 +181,7 @@ subroutine set_coord_from_layer_density(Rlay, g_prime, GV, US, param_file) call get_param(param_file, mdl, "GFS", g_fs, & "The reduced gravity at the free surface.", units="m s-2", & - default=GV%mks_g_Earth, scale=US%m_s_to_L_T**2*US%Z_to_m) + 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) @@ -184,32 +189,32 @@ subroutine set_coord_from_layer_density(Rlay, g_prime, GV, US, param_file) "The range of reference potential densities in the layers.", & units="kg m-3", default=2.0, scale=US%kg_m3_to_R) - g_prime(1) = g_fs Rlay(1) = Rlay_Ref do k=2,nz - Rlay(k) = Rlay(k-1) + RLay_range/(real(nz-1)) + Rlay(k) = Rlay(k-1) + RLay_range/(real(nz-1)) enddo ! These statements set the interface reduced gravities. ! + g_prime(1) = g_fs do k=2,nz - g_prime(k) = (GV%g_Earth/(GV%Rho0)) * (Rlay(k) - Rlay(k-1)) + g_prime(k) = (GV%g_Earth/(GV%Rho0)) * (Rlay(k) - Rlay(k-1)) enddo 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) - real, dimension(:), intent(out) :: Rlay !< The layers' target coordinate values - !! (potential density) [R ~> kg m-3]. - real, dimension(:), intent(out) :: g_prime !< The reduced gravity across the interfaces - !! [L2 Z-1 T-2 ~> m 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 - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time - !! parameters - type(EOS_type), pointer :: eqn_of_state !< integer selecting the equation of state. - real, intent(in) :: P_Ref !< The coordinate-density reference pressure [Pa]. +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), pointer :: 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 real :: S_ref ! Reference salinity @@ -228,11 +233,11 @@ subroutine set_coord_from_TS_ref(Rlay, g_prime, GV, US, param_file, eqn_of_state "The initial salinities.", units="PSU", default=35.0) call get_param(param_file, mdl, "GFS", g_fs, & "The reduced gravity at the free surface.", units="m s-2", & - default=GV%mks_g_Earth, scale=US%m_s_to_L_T**2*US%Z_to_m) + 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 @@ -240,7 +245,7 @@ subroutine set_coord_from_TS_ref(Rlay, g_prime, GV, US, param_file, eqn_of_state ! 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, scale=US%kg_m3_to_R) + call calculate_density(T_ref, S_ref, P_ref, Rlay(1), eqn_of_state) ! These statements set the layer densities. ! do k=2,nz ; Rlay(k) = Rlay(k-1) + g_prime(k)*(GV%Rho0/GV%g_Earth) ; enddo @@ -249,18 +254,17 @@ subroutine set_coord_from_TS_ref(Rlay, g_prime, GV, US, param_file, eqn_of_state 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) - real, dimension(:), intent(out) :: Rlay !< The layers' target coordinate values - !! (potential density) [R ~> kg m-3]. - real, dimension(:), intent(out) :: g_prime !< The reduced gravity across the interfaces - !! [L2 Z-1 T-2 ~> m 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 - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time - !! parameters - type(EOS_type), pointer :: eqn_of_state !< integer that selects equation of state. - real, intent(in) :: P_Ref !< The coordinate-density reference pressure [Pa]. +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), pointer :: 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, S0, Pref real :: g_fs ! Reduced gravity across the free surface [L2 Z-1 T-2 ~> m s-2]. @@ -273,7 +277,7 @@ subroutine set_coord_from_TS_profile(Rlay, g_prime, GV, US, param_file, & call get_param(param_file, mdl, "GFS", g_fs, & "The reduced gravity at the free surface.", units="m s-2", & - default=GV%mks_g_Earth, scale=US%m_s_to_L_T**2*US%Z_to_m) + 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.) @@ -289,26 +293,24 @@ subroutine set_coord_from_TS_profile(Rlay, g_prime, GV, US, param_file, & " 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, 1, nz, eqn_of_state, scale=US%kg_m3_to_R) + do k=1,nz ; Pref(k) = P_Ref ; enddo + call calculate_density(T0, S0, Pref, Rlay, eqn_of_state, (/1,nz/) ) do k=2,nz; g_prime(k) = (GV%g_Earth/(GV%Rho0)) * (Rlay(k) - Rlay(k-1)) ; enddo 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) - real, dimension(:), intent(out) :: Rlay !< The layers' target coordinate values - !! (potential density) [R ~> kg m-3]. - real, dimension(:), intent(out) :: g_prime !< The reduced gravity across the interfaces - !! [L2 Z-1 T-2 ~> m 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 - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time - !! parameters - type(EOS_type), pointer :: eqn_of_state !< integer that selects equation of state - real, intent(in) :: P_Ref !< The coordinate-density reference pressure [Pa] +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), pointer :: 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, S0, Pref @@ -354,7 +356,10 @@ subroutine set_coord_from_TS_range(Rlay, g_prime, GV, US, param_file, & call get_param(param_file, mdl, "GFS", g_fs, & "The reduced gravity at the free surface.", units="m s-2", & - default=GV%mks_g_Earth, scale=US%m_s_to_L_T**2*US%Z_to_m) + 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 @@ -369,26 +374,26 @@ subroutine set_coord_from_TS_range(Rlay, g_prime, GV, US, param_file, & enddo g_prime(1) = g_fs - do k=1,nz ; Pref(k) = P_ref ; enddo - call calculate_density(T0, S0, Pref, Rlay, k_light, nz-k_light+1, eqn_of_state, scale=US%kg_m3_to_R) + 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 - do k=2,nz ; g_prime(k) = (GV%g_Earth/(GV%Rho0)) * (Rlay(k) - Rlay(k-1)) ; enddo + do k=2,nz ; g_prime(k) = (GV%g_Earth/GV%Rho0) * (Rlay(k) - Rlay(k-1)) ; enddo 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) - real, dimension(:), intent(out) :: Rlay !< The layers' target coordinate values - !! (potential density) [R ~> kg m-3]. - real, dimension(:), intent(out) :: g_prime !< The reduced gravity across the interfaces - !! [L2 Z-1 T-2 ~> m 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 - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + 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 @@ -401,7 +406,7 @@ subroutine set_coord_from_file(Rlay, g_prime, GV, US, param_file) call get_param(param_file, mdl, "GFS", g_fs, & "The reduced gravity at the free surface.", units="m s-2", & - default=GV%mks_g_Earth, scale=US%m_s_to_L_T**2*US%Z_to_m) + 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, & @@ -434,13 +439,13 @@ end subroutine set_coord_from_file !! 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) - real, dimension(:), intent(out) :: Rlay !< The layers' target coordinate values - !! (potential density) [R ~> kg m-3]. - real, dimension(:), intent(out) :: g_prime !< The reduced gravity across the interfaces - !! [L2 Z-1 T-2 ~> m 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 - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + 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, g_fs @@ -457,18 +462,18 @@ subroutine set_coord_linear(Rlay, g_prime, GV, US, param_file) 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%mks_g_Earth, scale=US%m_s_to_L_T**2*US%Z_to_m) + 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 a 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)) + 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 do k=2,nz - g_prime(k) = (GV%g_Earth/(GV%Rho0)) * (Rlay(k) - Rlay(k-1)) + g_prime(k) = (GV%g_Earth/(GV%Rho0)) * (Rlay(k) - Rlay(k-1)) enddo call callTree_leave(trim(mdl)//'()') @@ -478,13 +483,12 @@ end subroutine set_coord_linear !! 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) - real, dimension(:), intent(out) :: Rlay !< The layers' target coordinate values - !! (potential density) [R ~> kg m-3]. - real, dimension(:), intent(out) :: g_prime !< The reduced gravity across the interfaces, - !! [L2 Z-1 T-2 ~> m 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 - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + 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]. character(len=40) :: mdl = "set_coord_to_none" ! This subroutine's name. @@ -495,7 +499,7 @@ subroutine set_coord_to_none(Rlay, g_prime, GV, US, param_file) call get_param(param_file, mdl, "GFS" , g_fs, & "The reduced gravity at the free surface.", units="m s-2", & - default=GV%mks_g_Earth, scale=US%m_s_to_L_T**2*US%Z_to_m) + 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) g_prime(1) = g_fs do k=2,nz ; g_prime(k) = 0. ; enddo diff --git a/src/initialization/MOM_fixed_initialization.F90 b/src/initialization/MOM_fixed_initialization.F90 index 0ddca45c51..b075da4141 100644 --- a/src/initialization/MOM_fixed_initialization.F90 +++ b/src/initialization/MOM_fixed_initialization.F90 @@ -30,8 +30,9 @@ module MOM_fixed_initialization 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 Neverland_initialization, only : Neverland_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 @@ -201,8 +202,9 @@ subroutine MOM_initialize_topography(D, max_depth, G, PF, US) " \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 Neverland - use the Neverland 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"//& @@ -226,8 +228,9 @@ subroutine MOM_initialize_topography(D, max_depth, G, PF, 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 ("Neverland"); call Neverland_initialize_topography(D, G, PF, max_depth) + 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) @@ -246,7 +249,7 @@ subroutine MOM_initialize_topography(D, max_depth, G, PF, US) else max_depth = diagnoseMaximumDepth(D,G) call log_param(PF, mdl, "!MAXIMUM_DEPTH", max_depth*Z_to_m, & - "The (diagnosed) maximum depth of the ocean.", units="m") + "The (diagnosed) maximum depth of the ocean.", units="m", like_default=.true.) endif if (trim(config) /= "DOME") then call limit_topography(D, G, PF, max_depth, US) diff --git a/src/initialization/MOM_grid_initialize.F90 b/src/initialization/MOM_grid_initialize.F90 index 1c594f45c1..88130857c7 100644 --- a/src/initialization/MOM_grid_initialize.F90 +++ b/src/initialization/MOM_grid_initialize.F90 @@ -125,7 +125,8 @@ subroutine grid_metrics_chksum(parent, G, US) 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=L_to_m) + call hchksum_pair(trim(parent)//': d[xy]T', G%dxT, G%dyT, G%HI, & + haloshift=halo, scale=L_to_m, scalar_pair=.true.) call uvchksum(trim(parent)//': dxC[uv]', G%dxCu, G%dyCv, G%HI, haloshift=halo, scale=L_to_m) @@ -133,7 +134,8 @@ subroutine grid_metrics_chksum(parent, G, US) call Bchksum_pair(trim(parent)//': dxB[uv]', G%dxBu, G%dyBu, G%HI, haloshift=halo, scale=L_to_m) - call hchksum_pair(trim(parent)//': Id[xy]T', G%IdxT, G%IdyT, G%HI, haloshift=halo, scale=m_to_L) + call hchksum_pair(trim(parent)//': Id[xy]T', G%IdxT, G%IdyT, G%HI, & + haloshift=halo, scale=m_to_L, scalar_pair=.true.) call uvchksum(trim(parent)//': Id[xy]C[uv]', G%IdxCu, G%IdyCv, G%HI, haloshift=halo, scale=m_to_L) @@ -203,7 +205,7 @@ subroutine set_grid_metrics_from_mosaic(G, param_file, US) 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=.true.) + default=.false.) call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") inputdir = slasher(inputdir) filename = trim(adjustl(inputdir)) // trim(adjustl(grid_file)) diff --git a/src/initialization/MOM_shared_initialization.F90 b/src/initialization/MOM_shared_initialization.F90 index 3338f1fedb..51676fb54d 100644 --- a/src/initialization/MOM_shared_initialization.F90 +++ b/src/initialization/MOM_shared_initialization.F90 @@ -561,7 +561,7 @@ subroutine initialize_grid_rotation_angle(G, PF) "If true, use an older algorithm to calculate the sine and "//& "cosines needed rotate between grid-oriented directions and "//& "true north and east. Differences arise at the tripolar fold.", & - default=.True.) + default=.false.) if (use_bugs) then do j=G%jsc,G%jec ; do i=G%isc,G%iec @@ -1202,6 +1202,8 @@ subroutine write_ocean_geometry_file(G, param_file, directory, geom_file, US) real, dimension(G%IsdB:G%IedB,G%jsd :G%jed ) :: out_u real, dimension(G%isd :G%ied ,G%JsdB:G%JedB) :: out_v + call callTree_enter('write_ocean_geometry_file()') + 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 @@ -1331,6 +1333,7 @@ subroutine write_ocean_geometry_file(G, param_file, directory, geom_file, US) call close_file(unit) + call callTree_leave('write_ocean_geometry_file()') end subroutine write_ocean_geometry_file end module MOM_shared_initialization diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index afadae1a1b..de33409fed 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -4,12 +4,13 @@ module MOM_state_initialization ! This file is part of MOM6. See LICENSE.md for the license. use MOM_debugging, only : hchksum, qchksum, uvchksum +use MOM_density_integrals, only : int_specific_vol_dp +use MOM_density_integrals, only : find_depth_of_pressure_in_cell use MOM_coms, only : max_across_PEs, min_across_PEs, reproducing_sum use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_ROUTINE, CLOCK_LOOP use MOM_domains, only : pass_var, pass_vector, sum_across_PEs, broadcast use MOM_domains, only : root_PE, To_All, SCALAR_PAIR, CGRID_NE, AGRID -use MOM_EOS, only : find_depth_of_pressure_in_cell use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, is_root_pe use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint use MOM_file_parser, only : get_param, read_param, log_param, param_file_type @@ -17,13 +18,11 @@ module MOM_state_initialization use MOM_get_input, only : directories use MOM_grid, only : ocean_grid_type, isPointInCell use MOM_interface_heights, only : find_eta -use MOM_io, only : file_exists -use MOM_io, only : MOM_read_data, MOM_read_vector -use MOM_io, only : slasher -use MOM_open_boundary, only : ocean_OBC_type, open_boundary_init +use MOM_io, only : file_exists, field_size, MOM_read_data, MOM_read_vector, slasher +use MOM_open_boundary, only : ocean_OBC_type, open_boundary_init, set_tracer_data use MOM_open_boundary, only : OBC_NONE, OBC_SIMPLE use MOM_open_boundary, only : open_boundary_query -use MOM_open_boundary, only : set_tracer_data +use MOM_open_boundary, only : set_tracer_data, initialize_segment_data use MOM_open_boundary, only : open_boundary_test_extern_h use MOM_open_boundary, only : fill_temp_salt_segments use MOM_open_boundary, only : update_OBC_segment_data @@ -32,20 +31,17 @@ module MOM_state_initialization use MOM_restart, only : restore_state, determine_is_new_run, MOM_restart_CS use MOM_sponge, only : set_up_sponge_field, set_up_sponge_ML_density use MOM_sponge, only : initialize_sponge, sponge_CS -use MOM_ALE_sponge, only : set_up_ALE_sponge_field, initialize_ALE_sponge -use MOM_ALE_sponge, only : ALE_sponge_CS +use MOM_ALE_sponge, only : set_up_ALE_sponge_field, initialize_ALE_sponge, ALE_sponge_CS use MOM_string_functions, only : uppercase, lowercase use MOM_time_manager, only : time_type use MOM_tracer_registry, only : tracer_registry_type use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : setVerticalGridAxes, verticalGrid_type -use MOM_ALE, only : pressure_gradient_plm -use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_type -use MOM_EOS, only : int_specific_vol_dp, convert_temp_salt_for_TEOS10 +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 -use user_initialization, only : user_set_OBC_data +use user_initialization, only : user_init_temperature_salinity, user_set_OBC_data use user_initialization, only : user_initialize_sponges use DOME_initialization, only : DOME_initialize_thickness use DOME_initialization, only : DOME_set_OBC_data @@ -57,7 +53,7 @@ module MOM_state_initialization 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 Neverland_initialization, only : Neverland_initialize_thickness +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 @@ -88,15 +84,15 @@ module MOM_state_initialization 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 : find_interfaces, tracer_Z_init_array, determine_temperature +use MOM_tracer_Z_init, only : tracer_Z_init_array, determine_temperature use MOM_ALE, only : ALE_initRegridding, ALE_CS, ALE_initThicknessToCoord use MOM_ALE, only : ALE_remap_scalar, ALE_build_grid, ALE_regrid_accelerated +use MOM_ALE, only : TS_PLM_edge_values use MOM_regridding, only : regridding_CS, set_regrid_params, getCoordinateResolution use MOM_regridding, only : regridding_main use MOM_remapping, only : remapping_CS, initialize_remapping use MOM_remapping, only : remapping_core_h use MOM_horizontal_regridding, only : horiz_interp_and_extrap_tracer -use fms_io_mod, only : field_size implicit none ; private @@ -257,7 +253,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & " \t ISOMIP - use a configuration for the \n"//& " \t\t ISOMIP test case. \n"//& " \t benchmark - use the benchmark test case thicknesses. \n"//& - " \t Neverland - use the Neverland 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"//& @@ -269,7 +265,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & " \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.", & - fail_if_missing=new_sim, do_not_log=just_read) + default="uniform", do_not_log=just_read) select case (trim(config)) case ("file") call initialize_thickness_from_file(h, G, GV, US, PF, .false., just_read_params=just_read) @@ -292,7 +288,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & just_read_params=just_read) case ("benchmark"); call benchmark_initialize_thickness(h, G, GV, US, PF, & tv%eqn_of_state, tv%P_Ref, just_read_params=just_read) - case ("Neverland"); call Neverland_initialize_thickness(h, G, GV, US, PF, & + case ("Neverwoorld","Neverland"); call Neverworld_initialize_thickness(h, G, GV, US, PF, & tv%eqn_of_state, tv%P_Ref) case ("search"); call initialize_thickness_search case ("circle_obcs"); call circle_obcs_initialize_thickness(h, G, GV, PF, & @@ -562,6 +558,8 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & ! This controls user code for setting open boundary data if (associated(OBC)) then + call initialize_segment_data(G, OBC, PF) ! call initialize_segment_data(G, OBC, param_file) +! call open_boundary_config(G, US, PF, OBC) ! Call this once to fill boundary arrays from fixed values if (.not. OBC%needs_IO_for_data) & call update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) @@ -932,59 +930,58 @@ subroutine convert_thickness(h, G, GV, US, tv) !! thermodynamic variables ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & - p_top, p_bot - real :: dz_geo(SZI_(G),SZJ_(G)) ! The change in geopotential height - ! across a layer [m2 s-2]. - real :: rho(SZI_(G)) - real :: I_gEarth - real :: Hm_rho_to_Pa ! A conversion factor from the input geometric thicknesses times the - ! layer densities into Pa [Pa m3 H-1 kg-1 ~> s-2 m2 or s-2 m5 kg-1]. - logical :: Boussinesq + p_top, p_bot ! Pressure at the interfaces above and below 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 :: I_gEarth ! Unit conversion factors divided by the gravitational acceleration + ! [H T2 R-1 L-2 ~> s2 m2 kg-1 or s2 m-1] + real :: HR_to_pres ! A conversion factor from the input geometric thicknesses times the layer + ! densities into pressure units [L2 T-2 H-1 ~> m s-2 or m4 kg-1 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 integer :: itt, max_itt is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB max_itt = 10 - Boussinesq = GV%Boussinesq - I_gEarth = 1.0 / (GV%mks_g_Earth) - Hm_rho_to_Pa = GV%mks_g_Earth * GV%H_to_m ! = GV%H_to_Pa / (US%R_to_kg_m3*GV%Rho0) - if (Boussinesq) then + if (GV%Boussinesq) then call MOM_error(FATAL,"Not yet converting thickness with Boussinesq approx.") else + I_gEarth = GV%RZ_to_H / GV%g_Earth + HR_to_pres = GV%g_Earth * GV%H_to_Z + if (associated(tv%eqn_of_state)) then do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 p_bot(i,j) = 0.0 ; p_top(i,j) = 0.0 enddo ; enddo + EOSdom(:) = EOS_domain(G%HI) do k=1,nz do j=js,je do i=is,ie ; p_top(i,j) = p_bot(i,j) ; enddo call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_top(:,j), rho, & - is, ie-is+1, tv%eqn_of_state) + tv%eqn_of_state, EOSdom) do i=is,ie - p_bot(i,j) = p_top(i,j) + Hm_rho_to_Pa * (h(i,j,k) * rho(i)) + p_bot(i,j) = p_top(i,j) + HR_to_pres * (h(i,j,k) * rho(i)) enddo enddo do itt=1,max_itt - call int_specific_vol_dp(tv%T(:,:,k), tv%S(:,:,k), p_top, p_bot, & - 0.0, G%HI, tv%eqn_of_state, dz_geo) + call int_specific_vol_dp(tv%T(:,:,k), tv%S(:,:,k), p_top, p_bot, 0.0, G%HI, & + tv%eqn_of_state, US, dz_geo) if (itt < max_itt) then ; do j=js,je call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_bot(:,j), rho, & - is, ie-is+1, tv%eqn_of_state) + tv%eqn_of_state, EOSdom) ! Use Newton's method to correct the bottom value. - ! The hydrostatic equation is linear to such a - ! high degree that no bounds-checking is needed. + ! The hydrostatic equation is sufficiently linear that no bounds-checking is needed. do i=is,ie - p_bot(i,j) = p_bot(i,j) + rho(i) * & - (Hm_rho_to_Pa*h(i,j,k) - dz_geo(i,j)) + p_bot(i,j) = p_bot(i,j) + rho(i) * (HR_to_pres*h(i,j,k) - dz_geo(i,j)) enddo enddo ; endif enddo do j=js,je ; do i=is,ie - h(i,j,k) = (p_bot(i,j) - p_top(i,j)) * GV%kg_m2_to_H * I_gEarth + h(i,j,k) = (p_bot(i,j) - p_top(i,j)) * I_gEarth enddo ; enddo enddo else @@ -1094,12 +1091,12 @@ subroutine trim_for_ice(PF, G, GV, US, ALE_CSp, tv, h, just_read_params) !! 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 [Pa] + 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_(G)) :: S_t, S_b ! Top and bottom edge values for reconstructions - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: T_t, T_b ! of salinity and temperature within each layer. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: T_t, T_b ! of salinity [ppt] and temperature [degC] within each layer. character(len=200) :: inputdir, filename, p_surf_file, p_surf_var ! Strings for file/path - real :: scale_factor ! A file-dependent scaling vactor for the input pressurs. - real :: min_thickness ! The minimum layer thickness, recast into Z units. + real :: scale_factor ! A file-dependent scaling factor for the input pressure. + real :: min_thickness ! The minimum layer thickness, recast into Z units [Z ~> m]. integer :: i, j, k logical :: default_2018_answers, remap_answers_2018 logical :: just_read ! If true, just read parameters but set nothing. @@ -1109,11 +1106,11 @@ subroutine trim_for_ice(PF, G, GV, US, ALE_CSp, tv, h, just_read_params) just_read = .false. ; if (present(just_read_params)) just_read = just_read_params call get_param(PF, mdl, "SURFACE_PRESSURE_FILE", p_surf_file, & - "The initial condition file for the surface height.", & + "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 height.", & - units="kg m-2", default="", do_not_log=just_read) + "The initial condition variable for the surface pressure exerted by ice.", & + units="Pa", 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) @@ -1131,7 +1128,7 @@ subroutine trim_for_ice(PF, G, GV, US, ALE_CSp, tv, h, just_read_params) if (use_remapping) then call get_param(PF, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=.true.) + default=.false.) call get_param(PF, mdl, "REMAPPING_2018_ANSWERS", remap_answers_2018, & "If true, use the order of arithmetic and expressions that recover the "//& "answers from the end of 2018. Otherwise, use updated and more robust "//& @@ -1140,7 +1137,8 @@ subroutine trim_for_ice(PF, G, GV, US, ALE_CSp, tv, h, just_read_params) 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) + call MOM_read_data(filename, p_surf_var, p_surf, G%Domain, & + scale=scale_factor*US%kg_m3_to_R*US%m_s_to_L_T**2) if (use_remapping) then allocate(remap_CS) @@ -1149,7 +1147,7 @@ subroutine trim_for_ice(PF, G, GV, US, ALE_CSp, tv, h, just_read_params) ! Find edge values of T and S used in reconstructions if ( associated(ALE_CSp) ) then ! This should only be associated if we are in ALE mode - call pressure_gradient_plm(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, .true.) + call TS_PLM_edge_values(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, .true.) else ! call MOM_error(FATAL, "trim_for_ice: Does not work without ALE mode") do k=1,G%ke ; do j=G%jsc,G%jec ; do i=G%isc,G%iec @@ -1159,7 +1157,7 @@ subroutine trim_for_ice(PF, G, GV, US, ALE_CSp, tv, h, just_read_params) endif do j=G%jsc,G%jec ; do i=G%isc,G%iec - call cut_off_column_top(GV%ke, tv, GV, US, GV%mks_g_Earth*US%Z_to_m, G%bathyT(i,j), & + call cut_off_column_top(GV%ke, tv, GV, US, GV%g_Earth, G%bathyT(i,j), & 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=1.0e-5*US%m_to_Z, remap_answers_2018=remap_answers_2018) @@ -1175,8 +1173,8 @@ subroutine cut_off_column_top(nk, tv, GV, US, G_earth, depth, min_thickness, T, 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 [m2 Z-1 s-2 ~> m s-2] + 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 [Z ~> m]. real, dimension(nk), intent(inout) :: T !< Layer mean temperature [degC] @@ -1185,7 +1183,7 @@ subroutine cut_off_column_top(nk, tv, GV, US, G_earth, depth, min_thickness, T, real, dimension(nk), intent(inout) :: S !< Layer mean salinity [ppt] real, dimension(nk), intent(in) :: S_t !< Salinity at top of layer [ppt] real, dimension(nk), intent(in) :: S_b !< Salinity at bottom of layer [ppt] - real, intent(in) :: p_surf !< Imposed pressure on ocean at surface [Pa] + 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 @@ -1197,9 +1195,10 @@ subroutine cut_off_column_top(nk, tv, GV, US, G_earth, depth, min_thickness, T, !! forms of the same expressions. ! Local variables - real, dimension(nk+1) :: e ! Top and bottom edge values for reconstructions + real, dimension(nk+1) :: e ! Top and bottom edge values for reconstructions [Z ~> m] real, dimension(nk) :: h0, S0, T0, h1, S1, T1 - real :: P_t, P_b, z_out, e_top + real :: P_t, P_b ! Top and bottom pressures [R L2 T-2 ~> Pa] + real :: z_out, e_top logical :: answers_2018 integer :: k @@ -1216,8 +1215,8 @@ subroutine cut_off_column_top(nk, tv, GV, US, G_earth, depth, min_thickness, T, 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, US%R_to_kg_m3*GV%Rho0, G_earth, tv%eqn_of_state, & - P_b, z_out, z_tol=z_tol) + 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 @@ -1367,10 +1366,10 @@ subroutine initialize_velocity_uniform(u, v, G, US, param_file, just_read_params call get_param(param_file, mdl, "INITIAL_U_CONST", initial_u_const, & "A initial uniform value for the zonal flow.", & - units="m s-1", scale=US%m_s_to_L_T, fail_if_missing=.not.just_read, do_not_log=just_read) + 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.", & - units="m s-1", scale=US%m_s_to_L_T, fail_if_missing=.not.just_read, do_not_log=just_read) + 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. @@ -1559,9 +1558,9 @@ subroutine initialize_temp_salt_fit(T, S, G, GV, US, param_file, eqn_of_state, P 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), pointer :: eqn_of_state !< Integer that selects the equatio of state. + type(EOS_type), pointer :: eqn_of_state !< Equation of state structure real, intent(in) :: P_Ref !< The coordinate-density reference pressure - !! [Pa]. + !! [R L2 T-2 ~> Pa]. logical, optional, intent(in) :: just_read_params !< If present and true, this call will !! only read parameters without changing h. ! Local variables @@ -1569,7 +1568,7 @@ subroutine initialize_temp_salt_fit(T, S, G, GV, US, param_file, eqn_of_state, P real :: S0(SZK_(G)) ! Layer salinities [degC] real :: T_Ref ! Reference Temperature [degC] real :: S_Ref ! Reference Salinity [ppt] - real :: pres(SZK_(G)) ! An array of the reference pressure [Pa]. + real :: pres(SZK_(G)) ! An array of the reference pressure [R L2 T-2 ~> Pa]. real :: drho_dT(SZK_(G)) ! Derivative of density with temperature [R degC-1 ~> kg m-3 degC-1]. real :: drho_dS(SZK_(G)) ! Derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1]. real :: rho_guess(SZK_(G)) ! Potential density at T0 & S0 [R ~> kg m-3]. @@ -1601,8 +1600,8 @@ subroutine initialize_temp_salt_fit(T, S, G, GV, US, param_file, eqn_of_state, P T0(k) = T_Ref enddo - call calculate_density(T0(1),S0(1),pres(1),rho_guess(1),eqn_of_state, scale=US%kg_m3_to_R) - call calculate_density_derivs(T0,S0,pres,drho_dT,drho_dS,1,1,eqn_of_state, scale=US%kg_m3_to_R) + 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. @@ -1611,8 +1610,8 @@ subroutine initialize_temp_salt_fit(T, S, G, GV, US, param_file, eqn_of_state, P enddo ! Refine the guesses for each layer. do itt=1,6 - call calculate_density(T0,S0,pres,rho_guess,1,nz,eqn_of_state, scale=US%kg_m3_to_R) - call calculate_density_derivs(T0,S0,pres,drho_dT,drho_dS,1,nz,eqn_of_state, scale=US%kg_m3_to_R) + 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 @@ -1623,8 +1622,8 @@ subroutine initialize_temp_salt_fit(T, S, G, GV, US, param_file, eqn_of_state, P 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,1,nz,eqn_of_state, scale=US%kg_m3_to_R) - call calculate_density_derivs(T0,S0,pres,drho_dT,drho_dS,1,nz,eqn_of_state, scale=US%kg_m3_to_R) + 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 @@ -1734,8 +1733,9 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, param_file, C tmp_2d ! A temporary array for tracers. real :: Idamp(SZI_(G),SZJ_(G)) ! The inverse damping rate [T-1 ~> s-1]. - real :: pres(SZI_(G)) ! An array of the reference pressure [Pa]. + 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 @@ -1865,13 +1865,13 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, param_file, C ! 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) call MOM_read_data(filename, salin_var, tmp2(:,:,:), G%Domain) do j=js,je - call calculate_density(tmp(:,j,1), tmp2(:,j,1), pres, tmp_2d(:,j), & - is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) + 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, CSp) @@ -1978,24 +1978,25 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param # 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 :: isc,iec,jsc,jec ! global compute domain indices integer :: isg, ieg, jsg, jeg ! global extent integer :: isd, ied, jsd, jed ! data domain indices integer :: i, j, k, ks, np, ni, nj - integer :: idbg, jdbg - integer :: nkml, nkbl ! number of mixed and buffer layers + integer :: nkml ! The number of layers in the mixed layer. integer :: kd, inconsistent 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 + real :: PI_180 ! for conversion from degrees to radians real, dimension(:,:), pointer :: shelf_area => NULL() - real :: min_depth ! The minimum depth [Z ~> m]. - real :: dilate + real :: Hmix_default ! The default initial mixed layer depth [m]. + real :: Hmix_depth ! The mixed layer depth in the initial condition [Z ~> m]. + real :: dilate ! A dilation factor to match topography [nondim] real :: missing_value_temp, missing_value_salt logical :: correct_thickness character(len=40) :: potemp_var, salin_var @@ -2016,7 +2017,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param real, dimension(:,:,:), allocatable :: rho_z ! Densities in Z-space [R ~> kg m-3] real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: zi ! Interface heights [Z ~> m]. integer, dimension(SZI_(G),SZJ_(G)) :: nlevs - real, dimension(SZI_(G)) :: press ! Pressures [Pa]. + real, dimension(SZI_(G)) :: press ! Pressures [R L2 T-2 ~> Pa]. ! Local variables for ALE remapping real, dimension(:), allocatable :: hTarget ! Target thicknesses [Z ~> m]. @@ -2033,6 +2034,8 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param logical :: homogenize, useALEremapping, remap_full_column, remap_general, remap_old_alg logical :: answers_2018, default_2018_answers, hor_regrid_answers_2018 logical :: use_ice_shelf + logical :: pre_gridded + logical :: separate_mixed_layer ! If true, handle the mixed layers differently. character(len=10) :: remappingScheme real :: tempAvg, saltAvg integer :: nPoints, ans @@ -2059,14 +2062,8 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param eos => tv%eqn_of_state -! call mpp_get_compute_domain(G%domain%mpp_domain,isc,iec,jsc,jec) - reentrant_x = .false. ; call get_param(PF, mdl, "REENTRANT_X", reentrant_x, default=.true.) tripolar_n = .false. ; call get_param(PF, mdl, "TRIPOLAR_N", tripolar_n, default=.false.) - call get_param(PF, mdl, "MINIMUM_DEPTH", min_depth, default=0.0, scale=US%m_to_Z) - - call get_param(PF, mdl, "NKML",nkml,default=0) - call get_param(PF, mdl, "NKBL",nkbl,default=0) call get_param(PF, mdl, "TEMP_SALT_Z_INIT_FILE",filename, & "The name of the z-space input file used to initialize "//& @@ -2108,10 +2105,15 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param 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=.true., do_not_log=just_read) + default=.false., do_not_log=just_read) call get_param(PF, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=.true.) + default=.false.) + 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.) if (useALEremapping) then call get_param(PF, mdl, "REMAPPING_2018_ANSWERS", answers_2018, & "If true, use the order of arithmetic and expressions that recover the "//& @@ -2144,6 +2146,19 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param "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, default=0.0) + 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.", default=Hmix_default, units="m", 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. endif if (just_read) then call cpu_clock_end(id_clock_routine) @@ -2170,11 +2185,11 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param call horiz_interp_and_extrap_tracer(tfilename, potemp_var, 1.0, 1, & G, temp_z, mask_z, z_in, z_edges_in, missing_value_temp, reentrant_x, & - tripolar_n, homogenize, m_to_Z=US%m_to_Z, answers_2018=hor_regrid_answers_2018) + tripolar_n, homogenize, m_to_Z=US%m_to_Z, answers_2018=hor_regrid_answers_2018, ongrid=pre_gridded) call horiz_interp_and_extrap_tracer(sfilename, salin_var, 1.0, 1, & G, salt_z, mask_z, z_in, z_edges_in, missing_value_salt, reentrant_x, & - tripolar_n, homogenize, m_to_Z=US%m_to_Z, answers_2018=hor_regrid_answers_2018) + tripolar_n, homogenize, m_to_Z=US%m_to_Z, answers_2018=hor_regrid_answers_2018, ongrid=pre_gridded) kd = size(z_in,1) @@ -2185,14 +2200,13 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param allocate(area_shelf_h(isd:ied,jsd:jed)) allocate(frac_shelf_h(isd:ied,jsd:jed)) - press(:) = tv%p_ref - ! Convert T&S to Absolute Salinity and Conservative Temperature if using TEOS10 or NEMO - call convert_temp_salt_for_TEOS10(temp_z, salt_z, press, G, kd, mask_z, eos) + call convert_temp_salt_for_TEOS10(temp_z, salt_z, G%HI, kd, mask_z, eos) + press(:) = tv%P_Ref + EOSdom(:) = EOS_domain(G%HI) do k=1,kd ; do j=js,je - call calculate_density(temp_z(:,j,k), salt_z(:,j,k), press, rho_z(:,j,k), is, ie, & - eos, scale=US%kg_m3_to_R) + call calculate_density(temp_z(:,j,k), salt_z(:,j,k), press, rho_z(:,j,k), eos, EOSdom) enddo ; enddo call pass_var(temp_z,G%Domain) @@ -2224,11 +2238,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param if (useALEremapping) then call cpu_clock_begin(id_clock_ALE) nkd = max(GV%ke, kd) - ! The regridding tools (grid generation) are coded to work on model arrays of the same - ! vertical shape. We need to re-write the regridding if the model has fewer layers - ! than the data. -AJA -! if (kd>nz) call MOM_error(FATAL,"MOM_initialize_state, MOM_temp_salt_initialize_from_Z(): "//& -! "Data has more levels than the model - this has not been coded yet!") + ! Build the source grid and copy data onto model-shaped arrays with vanished layers allocate( tmp_mask_in(isd:ied,jsd:jed,nkd) ) ; tmp_mask_in(:,:,:) = 0. allocate( h1(isd:ied,jsd:jed,nkd) ) ; h1(:,:,:) = 0. @@ -2325,10 +2335,17 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param ! 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 ; Rb(nz+1) = 2.0*GV%Rlay(nz) - GV%Rlay(nz-1) + 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 call find_interfaces(rho_z, z_in, kd, Rb, G%bathyT, zi, G, US, & - nlevs, nkml, nkbl, min_depth, eps_z=eps_z, eps_rho=eps_rho) + nlevs, nkml, hml=Hmix_depth, eps_z=eps_z, eps_rho=eps_rho) if (correct_thickness) then call adjustEtaToFitBathymetry(G, GV, US, zi, h) @@ -2355,12 +2372,8 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param endif endif - call tracer_z_init_array(temp_z(is:ie,js:je,:), z_edges_in, zi(is:ie,js:je,:), & - nkml, nkbl, missing_value, G%mask2dT(is:ie,js:je), nz, & - nlevs(is:ie,js:je), eps_z, tv%T(is:ie,js:je,:)) - call tracer_z_init_array(salt_z(is:ie,js:je,:), z_edges_in, zi(is:ie,js:je,:), & - nkml, nkbl, missing_value, G%mask2dT(is:ie,js:je), nz, & - nlevs(is:ie,js:je), eps_z, tv%S(is:ie,js:je,:)) + call tracer_z_init_array(temp_z, z_edges_in, kd, zi, missing_value, G, nz, nlevs, eps_z, tv%T) + call tracer_z_init_array(salt_z, z_edges_in, kd, zi, missing_value, G, nz, nlevs, eps_z, tv%S) do k=1,nz nPoints = 0 ; tempAvg = 0. ; saltAvg = 0. @@ -2394,13 +2407,12 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param endif enddo ; enddo ; enddo - ! Finally adjust to target density - ks = max(0,nkml)+max(0,nkbl)+1 if (adjust_temperature .and. .not. useALEremapping) then - call determine_temperature(tv%T(is:ie,js:je,:), tv%S(is:ie,js:je,:), & - GV%Rlay(1:nz), tv%p_ref, niter, missing_value, h(is:ie,js:je,:), ks, US, eos) - + ! 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), tv%P_Ref, niter, & + missing_value, h, ks, G, US, eos) endif deallocate(z_in, z_edges_in, temp_z, salt_z, mask_z) @@ -2415,57 +2427,174 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param 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, depth, zi, G, US, nlevs, nkml, hml, & + eps_z, eps_rho) + 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) :: 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_(G)+1), intent(in) :: Rb !< target interface densities [R ~> kg m-3] + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: depth !< ocean depth [Z ~> m]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+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]. + + ! Local variables + real, dimension(nk_data) :: rho_ ! A column of densities [R ~> kg m-3] + real, dimension(SZK_(G)+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 + 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 = G%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) + ! Modifiy 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 + rho_(k+1) = rho_(k-1) + eps_rho !### This should be 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*(zin(k+1)-zin(k)) + endif + endif ; enddo + work_down = .true. + endif + enddo + + ! Find and store the interface depths. + zi_(1) = 0.0 + 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), -depth(i,j)), -1.0*hml) + enddo + zi_(nz+1) = -depth(i,j) + if (nkml > 0) then ; do K=2,nkml+1 + zi_(K) = max(hml*((1.0-real(K))/real(nkml)), -depth(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, -depth(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, S, S_t, S_b, rho, h, z - real, dimension(nk+1) :: e + real, dimension(nk) :: T, T_t, T_b ! Temperatures [degC] + real, dimension(nk) :: S, S_t, S_b ! Salinities [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] integer :: k - real :: P_tot, P_t, P_b, z_out + 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] 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. + h(k) = 100.0*GV%m_to_H enddo e(1) = 0. do K = 1, nk - e(K+1) = e(K) - h(k) + e(K+1) = e(K) - GV%H_to_Z * h(k) enddo P_tot = 0. do k = 1, nk z(k) = 0.5 * ( e(K) + e(K+1) ) - T_t(k) = 20.+(0./500.)*e(k) - T(k) = 20.+(0./500.)*z(k) - T_b(k) = 20.+(0./500.)*e(k+1) - S_t(k) = 35.-(0./500.)*e(k) - S(k) = 35.+(0./500.)*z(k) - S_b(k) = 35.-(0./500.)*e(k+1) - call calculate_density(0.5*(T_t(k)+T_b(k)), 0.5*(S_t(k)+S_b(k)), -US%R_to_kg_m3*GV%Rho0*GV%mks_g_Earth*z(k), & + T_t(k) = 20. + (0. * I_z_scale) * e(k) + T(k) = 20. + (0. * I_z_scale)*z(k) + T_b(k) = 20. + (0. * I_z_scale)*e(k+1) + S_t(k) = 35. - (0. * I_z_scale)*e(k) + S(k) = 35. + (0. * I_z_scale)*z(k) + S_b(k) = 35. - (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*US%m_to_Z*z(k), & rho(k), tv%eqn_of_state) - P_tot = P_tot + GV%mks_g_Earth * rho(k) * h(k) + 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, & - US%R_to_kg_m3*GV%Rho0, GV%mks_g_Earth, tv%eqn_of_state, P_b, z_out) - write(0,*) k,P_t,P_b,0.5*P_tot,e(K),e(K+1),z_out + GV%Rho0, GV%g_Earth, tv%eqn_of_state, US, P_b, z_out) + write(0,*) k, US%RL2_T2_to_Pa*P_t, US%RL2_T2_to_Pa*P_b, 0.5*US%RL2_T2_to_Pa*P_tot, & + US%Z_to_m*e(K), US%Z_to_m*e(K+1), US%Z_to_m*z_out P_t = P_b enddo - write(0,*) P_b,P_tot + write(0,*) US%RL2_T2_to_Pa*P_b, US%RL2_T2_to_Pa*P_tot write(0,*) '' write(0,*) ' ==================================================================== ' write(0,*) '' - write(0,*) h - call cut_off_column_top(nk, tv, GV, US, GV%mks_g_Earth, -e(nk+1), GV%Angstrom_H, & + write(0,*) GV%H_to_m*h + call cut_off_column_top(nk, tv, GV, US, GV%g_Earth, -e(nk+1), GV%Angstrom_Z, & T, T_t, T_b, S, S_t, S_b, 0.5*P_tot, h, remap_CS) - write(0,*) h + write(0,*) GV%H_to_m*h end subroutine MOM_state_init_tests diff --git a/src/initialization/MOM_tracer_initialization_from_Z.F90 b/src/initialization/MOM_tracer_initialization_from_Z.F90 index 5d585466c8..1a4c5bd011 100644 --- a/src/initialization/MOM_tracer_initialization_from_Z.F90 +++ b/src/initialization/MOM_tracer_initialization_from_Z.F90 @@ -7,6 +7,7 @@ module MOM_tracer_initialization_from_Z use MOM_coms, only : max_across_PEs, min_across_PEs use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_ROUTINE, CLOCK_LOOP +use MOM_density_integrals, only : int_specific_vol_dp use MOM_domains, only : pass_var, pass_vector, sum_across_PEs, broadcast use MOM_domains, only : root_PE, To_All, SCALAR_PAIR, CGRID_NE, AGRID use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, is_root_pe @@ -24,7 +25,6 @@ module MOM_tracer_initialization_from_Z use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type, setVerticalGridAxes use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_type -use MOM_EOS, only : int_specific_vol_dp use MOM_ALE, only : ALE_remap_scalar implicit none ; private @@ -114,7 +114,7 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_ default="PLM") call get_param(PF, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=.true.) + default=.false.) if (useALE) then call get_param(PF, mdl, "REMAPPING_2018_ANSWERS", answers_2018, & "If true, use the order of arithmetic and expressions that recover the "//& diff --git a/src/ocean_data_assim/MOM_oda_driver.F90 b/src/ocean_data_assim/MOM_oda_driver.F90 index 089e1fc422..acc316cce4 100644 --- a/src/ocean_data_assim/MOM_oda_driver.F90 +++ b/src/ocean_data_assim/MOM_oda_driver.F90 @@ -1,9 +1,8 @@ !> Interfaces for MOM6 ensembles and data assimilation. module MOM_oda_driver_mod -! This file is part of MOM6. see LICENSE.md for the license. -use fms_mod, only : open_namelist_file, close_file, check_nml_error -use fms_mod, only : error_mesg, FATAL + ! This file is part of MOM6. see LICENSE.md for the license. + use mpp_mod, only : stdout, stdlog, mpp_error, npes=>mpp_npes,pe=>mpp_pe use mpp_mod, only : set_current_pelist => mpp_set_current_pelist use mpp_mod, only : set_root_pe => mpp_set_root_pe @@ -250,20 +249,6 @@ subroutine init_oda(Time, G, GV, CS) allocate(CS%tv%S(isd:ied,jsd:jed,CS%GV%ke)); CS%tv%S(:,:,:)=0.0 call set_axes_info(CS%Grid, CS%GV, CS%US, PF, CS%diag_cs, set_vertical=.true.) - do n=1,CS%ensemble_size - write(fldnam,'(a,i2.2)') 'temp_prior_',n - CS%Ocean_prior%id_t(n)=register_diag_field('ODA',trim(fldnam),CS%diag_cs%axesTL%handles,Time, & - 'ocean potential temperature','degC') - write(fldnam,'(a,i2.2)') 'salt_prior_',n - CS%Ocean_prior%id_s(n)=register_diag_field('ODA',trim(fldnam),CS%diag_cs%axesTL%handles,Time, & - 'ocean salinity','psu') - write(fldnam,'(a,i2.2)') 'temp_posterior_',n - CS%Ocean_posterior%id_t(n)=register_diag_field('ODA',trim(fldnam),CS%diag_cs%axesTL%handles,Time, & - 'ocean potential temperature','degC') - write(fldnam,'(a,i2.2)') 'salt_posterior_',n - CS%Ocean_posterior%id_s(n)=register_diag_field('ODA',trim(fldnam),CS%diag_cs%axesTL%handles,Time, & - 'ocean salinity','psu') - enddo call mpp_get_data_domain(CS%mpp_domain,isd,ied,jsd,jed) allocate(CS%oda_grid) @@ -364,10 +349,6 @@ subroutine set_prior_tracer(Time, G, GV, h, tv, CS) CS%mpp_domain, CS%Ocean_prior%T(:,:,:,m), complete=.true.) call mpp_redistribute(CS%domains(m)%mpp_domain, S,& CS%mpp_domain, CS%Ocean_prior%S(:,:,:,m), complete=.true.) - if (CS%Ocean_prior%id_t(m)>0) & - used=send_data(CS%Ocean_prior%id_t(m), CS%Ocean_prior%T(isc:iec,jsc:jec,:,m), CS%Time) - if (CS%Ocean_prior%id_s(m)>0) & - used=send_data(CS%Ocean_prior%id_s(m), CS%Ocean_prior%S(isc:iec,jsc:jec,:,m), CS%Time) enddo deallocate(T,S) @@ -478,13 +459,13 @@ subroutine init_ocean_ensemble(CS,Grid,GV,ens_size) allocate(CS%T(is:ie,js:je,nk,ens_size)) allocate(CS%S(is:ie,js:je,nk,ens_size)) allocate(CS%SSH(is:ie,js:je,ens_size)) - allocate(CS%id_t(ens_size));CS%id_t(:)=-1 - allocate(CS%id_s(ens_size));CS%id_s(:)=-1 +! allocate(CS%id_t(ens_size));CS%id_t(:)=-1 +! allocate(CS%id_s(ens_size));CS%id_s(:)=-1 ! allocate(CS%U(is:ie,js:je,nk,ens_size)) ! allocate(CS%V(is:ie,js:je,nk,ens_size)) ! allocate(CS%id_u(ens_size));CS%id_u(:)=-1 ! allocate(CS%id_v(ens_size));CS%id_v(:)=-1 - allocate(CS%id_ssh(ens_size));CS%id_ssh(:)=-1 +! allocate(CS%id_ssh(ens_size));CS%id_ssh(:)=-1 return end subroutine init_ocean_ensemble diff --git a/src/ocean_data_assim/core b/src/ocean_data_assim/core deleted file mode 120000 index e0a21d3192..0000000000 --- a/src/ocean_data_assim/core +++ /dev/null @@ -1 +0,0 @@ -../../pkg/MOM6_DA_hooks/src/core \ No newline at end of file diff --git a/src/ocean_data_assim/geoKdTree b/src/ocean_data_assim/geoKdTree deleted file mode 120000 index 61fd167bb6..0000000000 --- a/src/ocean_data_assim/geoKdTree +++ /dev/null @@ -1 +0,0 @@ -../../pkg/geoKdTree \ No newline at end of file diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index 4033d64f3c..5cbbe9b302 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -196,8 +196,10 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h if (associated(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 (associated(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) - call uvchksum("MEKE h[uv]", hu, hv, G%HI, haloshift=1, scale=GV%H_to_m*US%L_to_m**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=1, & + scale=GV%H_to_m*(US%L_to_m**2)) endif sdt = dt*CS%MEKE_dtScale ! Scaled dt to use for time-stepping @@ -287,7 +289,8 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h call MEKE_lengthScales(CS, MEKE, G, GV, US, SN_u, SN_v, MEKE%MEKE, 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=US%Z_to_m*US%s_to_T) + call uvchksum("MEKE drag_vel_[uv]", drag_vel_u, drag_vel_v, G%HI, & + scale=US%Z_to_m*US%s_to_T, scalar_pair=.true.) call hchksum(mass, 'MEKE mass',G%HI,haloshift=1, scale=US%RZ_to_kg_m2) call hchksum(drag_rate_visc, 'MEKE drag_rate_visc', G%HI, scale=US%L_T_to_m_s) call hchksum(bottomFac2, 'MEKE bottomFac2', G%HI) @@ -1004,7 +1007,8 @@ logical function MEKE_init(Time, G, US, param_file, diag, CS, MEKE, restart_CS) isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ! Determine whether this module will be used - call log_version(param_file, mdl, version, "") + 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.", & @@ -1060,7 +1064,7 @@ logical function MEKE_init(Time, G, US, param_file, diag, CS, MEKE, restart_CS) "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"//& + "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, & @@ -1151,11 +1155,11 @@ logical function MEKE_init(Time, G, US, param_file, diag, CS, MEKE, restart_CS) 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.05) + 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.05) + 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.", & diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index cf993b8aa8..76fa656942 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -19,6 +19,7 @@ module MOM_hor_visc use MOM_open_boundary, only : OBC_DIRECTION_N, OBC_DIRECTION_S, OBC_NONE use MOM_unit_scaling, only : unit_scale_type use MOM_verticalGrid, only : verticalGrid_type +use MOM_variables, only : accel_diag_ptrs implicit none ; private @@ -46,6 +47,8 @@ module MOM_hor_visc !! 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. real :: bound_coef !< The nondimensional coefficient of the ratio of !! the viscosity bounds to the theoretical maximum !! for stability without considering other terms [nondim]. @@ -67,8 +70,6 @@ module MOM_hor_visc !! 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 @@ -105,11 +106,6 @@ module MOM_hor_visc !< 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_) :: Biharm5_const2_xx - !< A constant relating the biharmonic viscosity to the - !! square of the velocity shear [L4 T ~> m4 s]. This value is - !! set to be the magnitude of the Coriolis terms once the - !! velocity differences reach a value of order 1/2 MAXVEL. real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: reduction_xx !< The amount by which stresses through h points are reduced !! due to partial barriers [nondim]. @@ -117,8 +113,9 @@ module MOM_hor_visc 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 - n1n1_m_n2n2_h !< Factor n1**2-n2**2 in the anisotropic direction tensor at h-points - + n1n1_m_n2n2_h, & !< Factor n1**2-n2**2 in the anisotropic direction tensor at h-points + 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 @@ -127,11 +124,6 @@ module MOM_hor_visc !< 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_) :: Biharm5_const2_xy - !< A constant relating the biharmonic viscosity to the - !! square of the velocity shear [L4 T ~> m4 s]. This value is - !! set to be the magnitude of the Coriolis terms once the - !! velocity differences reach a value of order 1/2 MAXVEL. real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_) :: reduction_xy !< The amount by which stresses through q points are reduced !! due to partial barriers [nondim]. @@ -162,27 +154,38 @@ module MOM_hor_visc ! parameters and metric terms. real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: & Laplac2_const_xx, & !< Laplacian metric-dependent constants [L2 ~> m2] - Biharm5_const_xx, & !< Biharmonic metric-dependent constants [L5 ~> m5] + 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] + 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] - Biharm5_const_xy, & !< Biharmonic metric-dependent constants [L5 ~> m5] + 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] + 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, pointer :: hf_diffu(:,:,:) => NULL() ! Zonal hor. visc. accel. x fract. thickness [L T-2 ~> m s-2]. + ! real, pointer :: hf_diffv(:,:,:) => NULL() ! Merdional hor. visc. accel. x fract. thickness [L T-2 ~> m s-2]. + ! 3D diagnostics hf_diffu(diffv) are commented because there is no clarity on proper remapping grid option. + ! The code is retained for degugging purposes in the future. + !>@{ !! Diagnostic id + integer :: id_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_hf_diffu_2d = -1, id_hf_diffv_2d = -1 integer :: id_Ah_h = -1, id_Ah_q = -1 integer :: id_Kh_h = -1, id_Kh_q = -1 integer :: id_GME_coeff_h = -1, id_GME_coeff_q = -1 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 !>@} @@ -205,7 +208,7 @@ module MOM_hor_visc !! v[is-2:ie+2,js-2:je+2] !! h[is-1:ie+1,js-1:je+1] subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, & - CS, OBC, BT, TD) + CS, OBC, BT, TD, ADp) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & @@ -232,6 +235,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, !! barotropic velocities. type(thickness_diffuse_CS), optional, pointer :: TD !< Pointer to a structure containing !! thickness diffusivities. + type(accel_diag_ptrs), optional, pointer :: ADp !< Acceleration diagnostic pointers + ! Local variables real, dimension(SZIB_(G),SZJ_(G)) :: & Del2u, & ! The u-compontent of the Laplacian of velocity [L-1 T-1 ~> m-1 s-1] @@ -258,6 +263,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! Leith_Ah_h, & ! Leith bi-harmonic viscosity at h-points [L4 T-1 ~> m4 s-1] 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] + Del2vort_h, & ! Laplacian of vorticity at h-points [L-2 T-1 ~> m-2 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] grad_vel_mag_h, & ! Magnitude of the velocity gradient tensor squared at h-points [T-2 ~> s-2] @@ -265,6 +271,9 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, grad_d2vel_mag_h, & ! Magnitude of the Laplacian of the velocity vector, squared [L-2 T-2 ~> m-2 s-2] boundary_mask_h ! A mask that zeroes out cells with at least one land edge [nondim] + real, allocatable, dimension(:,:) :: hf_diffu_2d ! Depth sum of hf_diffu [L T-2 ~> m s-2] + real, allocatable, dimension(:,:) :: hf_diffv_2d ! Depth sum of hf_diffv [L T-2 ~> m s-2] + real, dimension(SZIB_(G),SZJB_(G)) :: & dvdx, dudy, & ! components in the shearing strain [T-1 ~> s-1] dDel2vdx, dDel2udy, & ! Components in the biharmonic equivalent of the shearing strain [L-2 T-1 ~> m-2 s-1] @@ -279,6 +288,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, Leith_Ah_q, & ! Leith bi-harmonic viscosity at q-points [L4 T-1 ~> m4 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] grad_vel_mag_q, & ! Magnitude of the velocity gradient tensor squared at q-points [T-2 ~> s-2] hq, & ! harmonic mean of the harmonic means of the u- & v point thicknesses [H ~> m or kg m-2] @@ -290,6 +300,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, 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] max_diss_rate_q ! maximum possible energy dissipated by lateral friction [L2 T-3 ~> m2 s-3] @@ -302,9 +313,12 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, Kh_h, & ! Laplacian viscosity at thickness points [L2 T-1 ~> m2 s-1] max_diss_rate_h, & ! maximum possible energy dissipated by lateral friction [L2 T-3 ~> m2 s-3] 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] + 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] 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 coeff. at h-points [L2 T-1 ~> m2 s-1] real :: Ah ! biharmonic viscosity [L4 T-1 ~> m4 s-1] real :: Kh ! Laplacian viscosity [L2 T-1 ~> m2 s-1] @@ -337,10 +351,18 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, real :: FWfrac ! Fraction of maximum theoretical energy transfer to use when scaling GME coefficient [nondim] real :: DY_dxBu ! Ratio of meridional over zonal grid spacing at vertices [nondim] real :: DX_dyBu ! Ratio of zonal over meridiononal grid spacing at vertices [nondim] + real :: DY_dxCv ! Ratio of meridional over zonal grid spacing at faces [nondim] + real :: DX_dyCu ! Ratio of zonal over meridional grid spacing at faces [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 :: H0_GME ! Depth used to scale down GME coefficient in shallow areas [Z ~> m] + real :: KE ! Local kinetic energy [L2 T-2 ~> m2 s-2] + real, parameter :: KH_min = 1.E-30 ! This is the minimun horizontal Laplacian viscosity used to estimate the + ! grid Raynolds number [L2 T-1 ~> m2 s-1] + real, parameter :: AH_min = 1.E-30 ! This is the minimun horizontal Biharmonic viscosity used to estimate the + ! grid Raynolds number [L4 T-1 ~> m4 s-1] + logical :: rescale_Kh, legacy_bound logical :: find_FrictWork logical :: apply_OBC = .false. @@ -348,7 +370,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, logical :: use_MEKE_Au integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz integer :: i, j, k, n - real :: inv_PI3, inv_PI2, inv_PI5 + real :: inv_PI3, inv_PI2, inv_PI6 is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB @@ -356,7 +378,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, h_neglect3 = h_neglect**3 inv_PI3 = 1.0/((4.0*atan(1.0))**3) inv_PI2 = 1.0/((4.0*atan(1.0))**2) - inv_PI5 = inv_PI3 * inv_PI2 + inv_PI6 = inv_PI3 * inv_PI3 Ah_h(:,:,:) = 0.0 Kh_h(:,:,:) = 0.0 @@ -467,11 +489,11 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, !$OMP apply_OBC, rescale_Kh, legacy_bound, find_FrictWork, & !$OMP use_MEKE_Ku, use_MEKE_Au, boundary_mask_h, boundary_mask_q, & !$OMP backscat_subround, GME_coeff_limiter, & - !$OMP h_neglect, h_neglect3, FWfrac, inv_PI3, inv_PI5, H0_GME, & + !$OMP h_neglect, h_neglect3, FWfrac, inv_PI3, inv_PI6, H0_GME, & !$OMP diffu, diffv, max_diss_rate_h, max_diss_rate_q, & !$OMP Kh_h, Kh_q, Ah_h, Ah_q, FrictWork, FrictWork_GME, & - !$OMP div_xx_h, vort_xy_q, GME_coeff_h, GME_coeff_q, & - !$OMP TD, KH_u_GME, KH_v_GME & + !$OMP div_xx_h, sh_xx_h, vort_xy_q, sh_xy_q, GME_coeff_h, GME_coeff_q, & + !$OMP TD, KH_u_GME, KH_v_GME, grid_Re_Kh, grid_Re_Ah & !$OMP ) & !$OMP private( & !$OMP i, j, k, n, & @@ -485,7 +507,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, !$OMP grad_vel_mag_bt_h, grad_vel_mag_bt_q, grad_d2vel_mag_h, & !$OMP meke_res_fn, Shear_mag, vert_vort_mag, hrat_min, visc_bound_rem, & !$OMP Kh, Ah, AhSm, AhLth, local_strain, Sh_F_pow, & - !$OMP dDel2vdx, dDel2udy, & + !$OMP dDel2vdx, dDel2udy, DY_dxCv, DX_dyCu, Del2vort_q, Del2vort_h, KE, & !$OMP h2uq, h2vq, hu, hv, hq, FatH, RoScl, GME_coeff & !$OMP ) do k=1,nz @@ -504,7 +526,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, enddo ; enddo ! Components for the shearing strain - do J=js-2,Jeq+1 ; do I=is-2,Ieq+1 + 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 @@ -625,7 +647,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, 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) + h_u(I,j) = h_u(I,j+1) enddo endif elseif (OBC%segment(n)%direction == OBC_DIRECTION_E) then @@ -681,35 +703,48 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, endif; endif endif - if ((CS%Leith_Kh) .or. (CS%Leith_Ah)) then + ! 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 - ! Vorticity - if (CS%no_slip) then - do J=js-2,Jeq+1 ; do I=is-2,Ieq+1 - vort_xy(I,J) = (2.0-G%mask2dBu(I,J)) * ( dvdx(I,J) - dudy(I,J) ) - enddo ; enddo - else - do J=js-2,Jeq+1 ; do I=is-2,Ieq+1 - vort_xy(I,J) = G%mask2dBu(I,J) * ( dvdx(I,J) - dudy(I,J) ) - enddo ; enddo - 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)) then ! Vorticity gradient - do J=js-2,Jeq+1 ; do i=is-1,Ieq+1 + 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=js-1,Jeq+1 ; do I=is-2,Ieq+1 + 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 + ! 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 + do J=Jsq,Jeq+1 ; do I=Isq,Ieq+1 + Del2vort_h(i,j) = 0.25*(Del2vort_q(I,J) + Del2vort_q(I-1,J) + Del2vort_q(I,J-1) + Del2vort_q(I-1,J-1)) + enddo ; enddo + if (CS%modified_Leith) then - ! 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 ! Divergence gradient do j=Jsq-1,Jeq+2 ; do I=Isq-1,Ieq+1 @@ -839,7 +874,14 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, endif if ((CS%id_Kh_h>0) .or. find_FrictWork .or. CS%debug) Kh_h(i,j,k) = Kh + + if (CS%id_grid_Re_Kh>0) then + KE = 0.125*((u(I,j,k)+u(I-1,j,k))**2 + (v(i,J,k)+v(i,J-1,k))**2) + grid_Re_Kh(i,j,k) = (sqrt(KE) * sqrt(CS%grid_sp_h2(i,j)))/MAX(Kh,KH_min) + endif + if (CS%id_div_xx_h>0) div_xx_h(i,j,k) = div_xx(i,j) + if (CS%id_sh_xx_h>0) sh_xx_h(i,j,k) = sh_xx(i,j) str_xx(i,j) = -Kh * sh_xx(i,j) else ! not Laplacian @@ -866,7 +908,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, AhSm = CS%Biharm_const_xx(i,j) * Shear_mag endif endif - if (CS%Leith_Ah) AhLth = CS%Biharm5_const_xx(i,j) * vert_vort_mag * inv_PI5 + if (CS%Leith_Ah) AhLth = CS%Biharm6_const_xx(i,j) * abs(Del2vort_h(i,j)) * inv_PI6 Ah = MAX(MAX(CS%Ah_bg_xx(i,j), AhSm), AhLth) if (CS%bound_Ah .and. .not.CS%better_bound_Ah) & Ah = MIN(Ah, CS%Ah_Max_xx(i,j)) @@ -876,12 +918,22 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if (use_MEKE_Au) Ah = Ah + MEKE%Au(i,j) ! *Add* the MEKE contribution + if (CS%Re_Ah > 0.0) then + KE = 0.125*((u(I,j,k)+u(I-1,j,k))**2 + (v(i,J,k)+v(i,J-1,k))**2) + Ah = sqrt(KE) * CS%Re_Ah_const_xx(i,j) + endif + if (CS%better_bound_Ah) then Ah = MIN(Ah, visc_bound_rem*hrat_min*CS%Ah_Max_xx(i,j)) endif if ((CS%id_Ah_h>0) .or. find_FrictWork .or. CS%debug) Ah_h(i,j,k) = Ah + if (CS%id_grid_Re_Ah>0) then + KE = 0.125*((u(I,j,k)+u(I-1,j,k))**2 + (v(i,J,k)+v(i,J-1,k))**2) + grid_Re_Ah(i,j,k) = (sqrt(KE) * CS%grid_sp_h3(i,j))/MAX(Ah,AH_min) + endif + str_xx(i,j) = str_xx(i,j) + Ah * & (CS%DY_dxT(i,j) * (G%IdyCu(I,j)*Del2u(I,j) - G%IdyCu(I-1,j)*Del2u(I-1,j)) - & CS%DX_dyT(i,j) * (G%IdxCv(i,J)*Del2v(i,J) - G%IdxCv(i,J-1)*Del2v(i,J-1))) @@ -1010,6 +1062,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if (CS%id_Kh_q>0 .or. CS%debug) Kh_q(I,J,k) = Kh 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) str_xy(I,J) = -Kh * sh_xy(I,J) else ! not Laplacian @@ -1036,7 +1089,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, AhSm = CS%Biharm_const_xy(I,J) * Shear_mag endif endif - if (CS%Leith_Ah) AhLth = CS%Biharm5_const_xy(I,J) * vert_vort_mag * inv_PI5 + if (CS%Leith_Ah) AhLth = CS%Biharm6_const_xy(I,J) * abs(Del2vort_q(I,J)) * inv_PI6 Ah = MAX(MAX(CS%Ah_bg_xy(I,J), AhSm), AhLth) if (CS%bound_Ah .and. .not.CS%better_bound_Ah) & Ah = MIN(Ah, CS%Ah_Max_xy(I,J)) @@ -1045,8 +1098,13 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, endif ! Smagorinsky_Ah or Leith_Ah if (use_MEKE_Au) then ! *Add* the MEKE contribution - Ah = Ah + 0.25*( (MEKE%Au(I,J) + MEKE%Au(I+1,J+1)) + & - (MEKE%Au(I+1,J) + MEKE%Au(I,J+1)) ) + Ah = Ah + 0.25*( (MEKE%Au(i,j) + MEKE%Au(i+1,j+1)) + & + (MEKE%Au(i+1,j) + MEKE%Au(i,j+1)) ) + endif + + if (CS%Re_Ah > 0.0) then + KE = 0.125*((u(I,j,k)+u(I,j+1,k))**2 + (v(i,J,k)+v(i+1,J,k))**2) + Ah = sqrt(KE) * CS%Re_Ah_const_xy(i,j) endif if (CS%better_bound_Ah) then @@ -1147,7 +1205,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, 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) + G%IareaCu(I,j)) / (h_u(I,j) + h_neglect) enddo ; enddo if (apply_OBC) then @@ -1282,10 +1340,14 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if (CS%id_FrictWork>0) call post_data(CS%id_FrictWork, FrictWork, CS%diag) if (CS%id_FrictWork_GME>0) call post_data(CS%id_FrictWork_GME, FrictWork_GME, 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%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) @@ -1309,12 +1371,47 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, call post_data(CS%id_FrictWorkIntz, FrictWorkIntz, CS%diag) endif + ! Diagnostics for terms multiplied by fractional thicknesses + + ! 3D diagnostics hf_diffu(diffv) are commented because there is no clarity on proper remapping grid option. + ! The code is retained for degugging purposes in the future. + !if (present(ADp) .and. (CS%id_hf_diffu > 0)) then + ! do k=1,nz ; do j=js,je ; do I=Isq,Ieq + ! CS%hf_diffu(I,j,k) = diffu(I,j,k) * ADp%diag_hfrac_u(I,j,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_diffu, CS%hf_diffu, CS%diag) + !endif + !if (present(ADp) .and. (CS%id_hf_diffv > 0)) then + ! do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + ! CS%hf_diffv(i,J,k) = diffv(i,J,k) * ADp%diag_hfrac_v(i,J,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_diffv, CS%hf_diffv, CS%diag) + !endif + if (present(ADp) .and. (CS%id_hf_diffu_2d > 0)) then + allocate(hf_diffu_2d(G%IsdB:G%IedB,G%jsd:G%jed)) + hf_diffu_2d(:,:) = 0.0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + hf_diffu_2d(I,j) = hf_diffu_2d(I,j) + diffu(I,j,k) * ADp%diag_hfrac_u(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_diffu_2d, hf_diffu_2d, CS%diag) + deallocate(hf_diffu_2d) + endif + if (present(ADp) .and. (CS%id_hf_diffv_2d > 0)) then + allocate(hf_diffv_2d(G%isd:G%ied,G%JsdB:G%JedB)) + hf_diffv_2d(:,:) = 0.0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + hf_diffv_2d(i,J) = hf_diffv_2d(i,J) + diffv(i,J,k) * ADp%diag_hfrac_v(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_diffv_2d, hf_diffv_2d, CS%diag) + deallocate(hf_diffv_2d) + endif + end subroutine horizontal_viscosity !> Allocates space for and calculates static variables used by horizontal_viscosity(). !! hor_visc_init calculates and stores the values of a number of metric functions that !! are used in horizontal_viscosity(). -subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) +subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE, ADp) type(time_type), intent(in) :: Time !< Current model time. type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -1323,6 +1420,7 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) type(diag_ctrl), target, intent(inout) :: diag !< Structure to regulate diagnostic output. type(hor_visc_CS), pointer :: CS !< Pointer to the control structure for this module type(MEKE_type), pointer :: MEKE !< MEKE data + type(accel_diag_ptrs), optional, pointer :: ADp !< Acceleration diagnostic pointers ! Local variables real, dimension(SZIB_(G),SZJ_(G)) :: u0u, u0v real, dimension(SZI_(G),SZJB_(G)) :: v0u, v0v @@ -1365,7 +1463,6 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) logical :: split ! If true, use the split time stepping scheme. ! If false and USE_GME = True, issue a FATAL error. logical :: default_2018_answers - character(len=64) :: inputdir, filename real :: deg2rad ! Converts degrees to radians real :: slat_fn ! sin(lat)**Kh_pwr_of_sine @@ -1374,28 +1471,22 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) 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 = G%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 - if (associated(CS)) then call MOM_error(WARNING, "hor_visc_init called with an associated "// & "control structure.") return endif allocate(CS) - CS%diag => diag - ! Read parameters and write them to the model log. call log_version(param_file, mdl, version, "") - ! It is not clear whether these initialization lines are needed for the ! cases where the corresponding parameters are not read. CS%bound_Kh = .false. ; CS%better_bound_Kh = .false. ; CS%Smagorinsky_Kh = .false. ; CS%Leith_Kh = .false. @@ -1405,23 +1496,18 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) CS%Modified_Leith = .false. CS%anisotropic = .false. CS%dynamic_aniso = .false. - Kh = 0.0 ; Ah = 0.0 - ! If GET_ALL_PARAMS is true, all parameters are read in all cases to enable ! parameter spelling checks. call get_param(param_file, mdl, "GET_ALL_PARAMS", get_all, default=.false.) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=.true.) + default=.false.) call get_param(param_file, mdl, "HOR_VISC_2018_ANSWERS", CS%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) - call get_param(param_file, mdl, "DEBUG", CS%debug, default=.false.) - call get_param(param_file, mdl, "LAPLACIAN", CS%Laplacian, & "If true, use a Laplacian horizontal viscosity.", & default=.false.) @@ -1447,7 +1533,6 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) "The power used to raise SIN(LAT) when using a latitudinally "//& "dependent background viscosity.", & units = "nondim", default=4.0) - call get_param(param_file, mdl, "SMAGORINSKY_KH", CS%Smagorinsky_Kh, & "If true, use a Smagorinsky nonlinear eddy viscosity.", & default=.false.) @@ -1456,11 +1541,9 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) "The nondimensional Laplacian Smagorinsky constant, "//& "often 0.15.", units="nondim", default=0.0, & fail_if_missing = CS%Smagorinsky_Kh) - call get_param(param_file, mdl, "LEITH_KH", CS%Leith_Kh, & "If true, use a Leith nonlinear eddy viscosity.", & default=.false.) - 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.", & @@ -1468,7 +1551,6 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) call get_param(param_file, mdl, "RES_SCALE_MEKE_VISC", CS%res_scale_MEKE, & "If true, the viscosity contribution from MEKE is scaled by "//& "the resolution function.", default=.false.) - if (CS%Leith_Kh .or. get_all) then call get_param(param_file, mdl, "LEITH_LAP_CONST", Leith_Lap_const, & "The nondimensional Laplacian Leith constant, "//& @@ -1527,7 +1609,6 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) "to the spherical coordinates.", units = "nondim", fail_if_missing=.true.) end select endif - call get_param(param_file, mdl, "BIHARMONIC", CS%biharmonic, & "If true, use a biharmonic horizontal viscosity. "//& "BIHARMONIC may be used with LAPLACIAN.", & @@ -1554,7 +1635,6 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) call get_param(param_file, mdl, "LEITH_AH", CS%Leith_Ah, & "If true, use a biharmonic Leith nonlinear eddy "//& "viscosity.", default=.false.) - call get_param(param_file, mdl, "BOUND_AH", CS%bound_Ah, & "If true, the biharmonic coefficient is locally limited "//& "to be stable.", default=.true.) @@ -1562,13 +1642,16 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) "If true, the biharmonic coefficient is locally limited "//& "to be stable with a better bounding than just BOUND_AH.", & default=CS%bound_Ah) + 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) if (CS%Smagorinsky_Ah .or. get_all) then call get_param(param_file, mdl, "SMAG_BI_CONST",Smag_bi_const, & "The nondimensional biharmonic Smagorinsky constant, "//& "typically 0.015 - 0.06.", units="nondim", default=0.0, & fail_if_missing = CS%Smagorinsky_Ah) - call get_param(param_file, mdl, "BOUND_CORIOLIS", bound_Cor_def, default=.false.) call get_param(param_file, mdl, "BOUND_CORIOLIS_BIHARM", CS%bound_Coriolis, & "If true use a viscosity that increases with the square "//& @@ -1587,29 +1670,22 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) units="m s-1", default=maxvel, scale=US%m_s_to_L_T) endif endif - if (CS%Leith_Ah .or. get_all) & 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) - endif - call get_param(param_file, mdl, "USE_LAND_MASK_FOR_HVISC", CS%use_land_mask, & "If true, use Use the land mask for the computation of thicknesses "//& "at velocity locations. This eliminates the dependence on arbitrary "//& - "values over land or outside of the domain. Default is False in order to "//& - "maintain answers with legacy experiments but should be changed to True "//& - "for new experiments.", default=.false.) - + "values over land or outside of the domain.", default=.true.) if (CS%better_bound_Ah .or. CS%better_bound_Kh .or. get_all) & call get_param(param_file, mdl, "HORVISC_BOUND_COEF", CS%bound_coef, & "The nondimensional coefficient of the ratio of the "//& "viscosity bounds to the theoretical maximum for "//& "stability without considering other terms.", units="nondim", & default=0.8) - call get_param(param_file, mdl, "NOSLIP", CS%no_slip, & "If true, no slip boundary conditions are used; otherwise "//& "free slip boundary conditions are assumed. The "//& @@ -1617,52 +1693,38 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) "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.) - if (CS%use_Kh_bg_2d) then - 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.", default=.true.) - endif 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.) - if (CS%use_GME) then call get_param(param_file, mdl, "SPLIT", split, & "Use the split time stepping if true.", default=.true., & do_not_log=.true.) if (.not. split) call MOM_error(FATAL,"ERROR: Currently, USE_GME = True "// & "cannot be used with SPLIT=False.") - call get_param(param_file, mdl, "GME_H0", CS%GME_h0, & "The strength of GME tapers quadratically to zero when the bathymetric "//& "depth is shallower than GME_H0.", units="m", scale=US%m_to_Z, & default=1000.0) - 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%bound_Kh .or. CS%bound_Ah .or. CS%better_bound_Kh .or. CS%better_bound_Ah) & call get_param(param_file, mdl, "DT", dt, & "The (baroclinic) dynamics time step.", units="s", scale=US%s_to_T, & fail_if_missing=.true.) - if (CS%no_slip .and. CS%biharmonic) & call MOM_error(FATAL,"ERROR: NOSLIP and BIHARMONIC cannot be defined "// & "at the same time in MOM.") - 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, & @@ -1670,9 +1732,7 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) "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 @@ -1681,8 +1741,8 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) 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 @@ -1700,7 +1760,6 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) 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 - 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 @@ -1718,7 +1777,6 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) "Runtime parameter ANISOTROPIC_MODE is out of range.") end select endif - if (CS%use_Kh_bg_2d) then ALLOC_(CS%Kh_bg_2d(isd:ied,jsd:jed)) ; CS%Kh_bg_2d(:,:) = 0.0 call get_param(param_file, mdl, "KH_BG_2D_FILENAME", filename, & @@ -1730,15 +1788,14 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) 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 @@ -1752,11 +1809,14 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) endif endif if (CS%Leith_Ah) then - ALLOC_(CS%biharm5_const_xx(isd:ied,jsd:jed)) ; CS%biharm5_const_xx(:,:) = 0.0 - ALLOC_(CS%biharm5_const_xy(IsdB:IedB,JsdB:JedB)) ; CS%biharm5_const_xy(:,:) = 0.0 + 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%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) @@ -1765,7 +1825,6 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) 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. & @@ -1781,7 +1840,6 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) (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. & @@ -1797,38 +1855,33 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) (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 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 enddo ; enddo - ! 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 @@ -1838,23 +1891,18 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) 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, and should be obsoleted as soon as possible. - CS%Kh_bg_xy(I,J) = MAX(CS%Kh_bg_2d(i,j), CS%Kh_bg_xy(I,J)) - else + if (CS%use_Kh_bg_2d) then 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 + 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 @@ -1862,9 +1910,7 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) 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)) @@ -1873,7 +1919,6 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) 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 MOM1.10. The change in hq requires ! this to be less than 1/3, rather than 1/2 as before. @@ -1883,7 +1928,7 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) 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 @@ -1894,9 +1939,10 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) endif endif if (CS%Leith_Ah) then - CS%biharm5_const_xx(i,j) = Leith_bi_const * (grid_sp_h3 * grid_sp_h2) + CS%biharm6_const_xx(i,j) = Leith_bi_const * (grid_sp_h3 * grid_sp_h3) 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 @@ -1907,7 +1953,6 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) 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 @@ -1916,10 +1961,10 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) endif endif if (CS%Leith_Ah) then - CS%biharm5_const_xy(i,j) = Leith_bi_const * (grid_sp_q3 * grid_sp_q2) + 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 @@ -1928,7 +1973,6 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) endif enddo ; enddo endif - ! The Laplacian bounds should avoid overshoots when CS%bound_coef < 1. if (CS%Laplacian .and. CS%better_bound_Kh) then Idt = 1.0 / dt @@ -1957,7 +2001,6 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) 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 @@ -1967,7 +2010,6 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) 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)) + & @@ -1978,13 +2020,11 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) 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) * & @@ -1999,7 +2039,6 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) 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) * & @@ -2019,74 +2058,93 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) 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_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_ptr(CS%hf_diffu,G%IsdB,G%IedB,G%jsd,G%jed,G%ke) + ! call safe_alloc_ptr(ADp%diag_hfrac_u,G%IsdB,G%IedB,G%jsd,G%jed,G%ke) + !endif + + !CS%id_hf_diffv = register_diag_field('ocean_model', 'hf_diffv', diag%axesCvL, Time, & + ! 'Fractional Thickness-weighted Meridional Acceleration from Horizontal Viscosity', 'm s-2', & + ! v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if ((CS%id_hf_diffv > 0) .and. (present(ADp))) then + ! call safe_alloc_ptr(CS%hf_diffv,G%isd,G%ied,G%JsdB,G%JedB,G%ke) + ! call safe_alloc_ptr(ADp%diag_hfrac_v,G%isd,G%ied,G%JsdB,G%JedB,G%ke) + !endif + + CS%id_hf_diffu_2d = register_diag_field('ocean_model', 'hf_diffu_2d', diag%axesCu1, Time, & + 'Depth-sum Fractional Thickness-weighted Zonal Acceleration from Horizontal Viscosity', 'm s-2', & + conversion=US%L_T2_to_m_s2) + if ((CS%id_hf_diffu_2d > 0) .and. (present(ADp))) then + call safe_alloc_ptr(ADp%diag_hfrac_u,G%IsdB,G%IedB,G%jsd,G%jed,G%ke) + endif + + CS%id_hf_diffv_2d = register_diag_field('ocean_model', 'hf_diffv_2d', diag%axesCv1, Time, & + 'Depth-sum Fractional Thickness-weighted Meridional Acceleration from Horizontal Viscosity', 'm s-2', & + conversion=US%L_T2_to_m_s2) + if ((CS%id_hf_diffv_2d > 0) .and. (present(ADp))) then + call safe_alloc_ptr(ADp%diag_hfrac_v,G%isd,G%ied,G%JsdB,G%JedB,G%ke) + endif + if (CS%biharmonic) then CS%id_Ah_h = register_diag_field('ocean_model', 'Ahh', diag%axesTL, Time, & 'Biharmonic Horizontal Viscosity at h Points', 'm4 s-1', conversion=US%L_to_m**4*US%s_to_T, & 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') 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) - - if (CS%Leith_Kh) then - 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) - endif - + 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) endif - if (CS%use_GME) then 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', & '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') - if (CS%Laplacian .or. get_all) then endif - 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) @@ -2095,18 +2153,14 @@ subroutine align_aniso_tensor_to_grid(CS, n1, n2) real, intent(in) :: n2 !< j-component of direction vector [nondim] ! Local variables real :: recip_n2_norm - ! 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) @@ -2117,15 +2171,12 @@ subroutine smooth_GME(CS,G,GME_flux_h,GME_flux_q) !! at h points real, dimension(SZIB_(G),SZJB_(G)), optional, intent(inout) :: GME_flux_q!< GME diffusive flux !! at q points - ! local variables real, dimension(SZI_(G),SZJ_(G)) :: GME_flux_h_original real, dimension(SZIB_(G),SZJB_(G)) :: GME_flux_q_original real :: wc, ww, we, wn, ws ! averaging weights for smoothing integer :: i, j, k, s - do s=1,1 - ! Update halos if (present(GME_flux_h)) then call pass_var(GME_flux_h, G%Domain) @@ -2135,14 +2186,12 @@ subroutine smooth_GME(CS,G,GME_flux_h,GME_flux_q) do i = G%isc, G%iec ! 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) & @@ -2150,7 +2199,6 @@ subroutine smooth_GME(CS,G,GME_flux_h,GME_flux_q) + wn * GME_flux_h_original(i,j+1) enddo; enddo endif - ! Update halos if (present(GME_flux_q)) then call pass_var(GME_flux_q, G%Domain, position=CORNER, complete=.true.) @@ -2160,14 +2208,12 @@ subroutine smooth_GME(CS,G,GME_flux_h,GME_flux_q) do I = G%IscB, G%IecB ! 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) & @@ -2175,24 +2221,20 @@ subroutine smooth_GME(CS,G,GME_flux_h,GME_flux_q) + wn * GME_flux_q_original(I,J+1) enddo; enddo endif - enddo ! s-loop - end subroutine smooth_GME - !> Deallocates any variables allocated in hor_visc_init. subroutine hor_visc_end(CS) type(hor_visc_CS), pointer :: CS !< The control structure returned by a !! previous call to hor_visc_init. - 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 @@ -2203,8 +2245,8 @@ subroutine hor_visc_end(CS) 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) @@ -2212,14 +2254,14 @@ subroutine hor_visc_end(CS) DEALLOC_(CS%Ah_Max_xx) ; DEALLOC_(CS%Ah_Max_xy) endif if (CS%Smagorinsky_Ah) then - DEALLOC_(CS%Biharm5_const_xx) ; DEALLOC_(CS%Biharm5_const_xy) - ! if (CS%bound_Coriolis) then - ! DEALLOC_(CS%Biharm5_const2_xx) ; DEALLOC_(CS%Biharm5_const2_xy) - ! endif + DEALLOC_(CS%Biharm6_const_xx) ; DEALLOC_(CS%Biharm6_const_xy) endif if (CS%Leith_Ah) then DEALLOC_(CS%Biharm_const_xx) ; DEALLOC_(CS%Biharm_const_xy) 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) @@ -2228,10 +2270,7 @@ subroutine hor_visc_end(CS) DEALLOC_(CS%n1n1_m_n2n2_q) endif deallocate(CS) - end subroutine hor_visc_end - - !> \namespace mom_hor_visc !! !! This module contains the subroutine horizontal_viscosity() that calculates the @@ -2532,5 +2571,4 @@ end subroutine hor_visc_end !! 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/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index dda892dc3e..2bb3c3b0f1 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -15,7 +15,7 @@ module MOM_internal_tides use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg, is_root_pe use MOM_file_parser, only : read_param, get_param, log_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type -use MOM_io, only : slasher, vardesc, MOM_read_data +use MOM_io, only : slasher, vardesc, MOM_read_data, file_exists use MOM_restart, only : register_restart_field, MOM_restart_CS, restart_init, save_restart use MOM_spatial_means, only : global_area_mean use MOM_time_manager, only : time_type, time_type_to_real, operator(+), operator(/), operator(-) @@ -558,7 +558,7 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & ! Output 2-D energy loss (summed over angles) for each freq 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) + itidal_loss_mode(:,:) = 0.0 ! wave-drag processes (could do others as well) 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) @@ -886,12 +886,17 @@ subroutine PPM_angular_advect(En2d, CFL_ang, Flux_En, NAngle, dt, halo_ang) !! across angles [R Z3 T-2 ~> J m-2]. ! Local variables real :: flux - real :: u_ang - real :: Angle_size - real :: I_Angle_size - real :: I_dt + 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 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 :: dMx, dMn + 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 - real :: aR, aL, dMx, dMn, Ep, Ec, Em, dA, mA, a6 I_dt = 1 / dt Angle_size = (8.0*atan(1.0)) / (real(NAngle)) @@ -902,50 +907,55 @@ subroutine PPM_angular_advect(En2d, CFL_ang, Flux_En, NAngle, dt, halo_ang) u_ang = CFL_ang(A)*Angle_size*I_dt if (u_ang >= 0.0) then ! Implementation of PPM-H3 - Ep = En2d(a+1)*I_Angle_size !MEAN ANGULAR ENERGY DENSITY FOR WEDGE (Jm-2/rad) - Ec = En2d(a) *I_Angle_size !MEAN ANGULAR ENERGY DENSITY FOR WEDGE (Jm-2/rad) - Em = En2d(a-1)*I_Angle_size !MEAN ANGULAR ENERGY DENSITY FOR WEDGE (Jm-2/rad) - aL = ( 5.*Ec + ( 2.*Em - Ep ) )/6. ! H3 estimate + ! 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 ) )/6. ! H3 estimate + 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 ; mA = 0.5*( aR + aL ) + dA = aR - aL if ((Ep-Ec)*(Ec-Em) <= 0.) then - aL = Ec ; aR = Ec ! PCM for local extremum - elseif ( dA*(Ec-mA) > (dA*dA)/6. ) then - aL = 3.*Ec - 2.*aR !? - elseif ( dA*(Ec-mA) < - (dA*dA)/6. ) then - aR = 3.*Ec - 2.*aL !? + 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 - a6 = 6.*Ec - 3. * (aR + aL) ! Curvature - ! CALCULATE FLUX RATE (Jm-2/s) - flux = u_ang*( aR + 0.5 * CFL_ang(A) * ( ( aL - aR ) + a6 * ( 1. - 2./3. * CFL_ang(A) ) ) ) - !flux = u_ang*( aR - 0.5 * CFL_ang(A) * ( ( aR - aL ) - a6 * ( 1. - 2./3. * CFL_ang(A) ) ) ) - ! CALCULATE AMOUNT FLUXED (Jm-2) + 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 - Ep = En2d(a+2)*I_Angle_size !MEAN ANGULAR ENERGY DENSITY FOR WEDGE (Jm-2/rad) - Ec = En2d(a+1)*I_Angle_size !MEAN ANGULAR ENERGY DENSITY FOR WEDGE (Jm-2/rad) - Em = En2d(a) *I_Angle_size !MEAN ANGULAR ENERGY DENSITY FOR WEDGE (Jm-2/rad) - aL = ( 5.*Ec + ( 2.*Em - Ep ) )/6. ! H3 estimate + ! 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 ) )/6. ! H3 estimate + 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 ; mA = 0.5*( aR + aL ) + dA = aR - aL if ((Ep-Ec)*(Ec-Em) <= 0.) then - aL = Ec ; aR = Ec ! PCM for local extremum - elseif ( dA*(Ec-mA) > (dA*dA)/6. ) then - aL = 3.*Ec - 2.*aR - elseif ( dA*(Ec-mA) < - (dA*dA)/6. ) then - aR = 3.*Ec - 2.*aL + 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 - a6 = 6.*Ec - 3. * (aR + aL) ! Curvature - ! CALCULATE FLUX RATE (Jm-2/s) - flux = u_ang*( aR + 0.5 * CFL_ang(A) * ( ( aL - aR ) + a6 * ( 1. - 2./3. * CFL_ang(A) ) ) ) - !flux = u_ang*( aL + 0.5 * CFL_ang(A) * ( ( aR - aL ) + a6 * ( 1. - 2./3. * CFL_ang(A) ) ) ) - ! CALCULATE AMOUNT FLUXED (Jm-2) + 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 @@ -1014,7 +1024,7 @@ subroutine propagate(En, cn, freq, dt, G, US, CS, NAngle) ! FIND AVERAGE GROUP VELOCITY (SPEED) AT CELL CORNERS ! NOTE: THIS HAS NOT BE ADAPTED FOR REFLECTION YET (BDM)!! ! Fix indexing here later - speed(:,:) = 0 + 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) + cn(i+1,j+1) + cn(i,j+1)) * & @@ -1058,21 +1068,21 @@ subroutine propagate(En, cn, freq, dt, G, US, CS, NAngle) ! 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) + call propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, CS%nAngle, CS, LB) ! Check for energy conservation on computational domain (for debugging) - !call sum_En(G,CS,En(:,:,:),'post-propagate_x') + !call sum_En(G, CS, En, 'post-propagate_x') ! Update halos - call pass_var(En(:,:,:),G%domain) + call pass_var(En, 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) + call propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, CS%nAngle, CS, LB) ! Check for energy conservation on computational domain (for debugging) - !call sum_En(G,CS,En(:,:,:),'post-propagate_y') + !call sum_En(G, CS, En, 'post-propagate_y') endif end subroutine propagate @@ -1084,7 +1094,7 @@ subroutine propagate_corner_spread(En, energized_wedge, NAngle, speed, dt, G, CS 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], intent in/out. + !! 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]. @@ -1351,7 +1361,7 @@ subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, Nangle, CS, LB) !! 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], intent in/out. + !! 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]. @@ -1404,18 +1414,18 @@ subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, Nangle, CS, LB) enddo ! a-loop ! Only reflect newly arrived energy; existing energy in incident wedge is not reflected - ! and will eventually propagate out of cell. (Thid 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) + ! 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 (Jm-2) - do j=jsh,jeh ; do i=ish,ieh + ! 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,:) = En(i,j,:) + G%IareaT(i,j)*(Fdt_m(i,j,:) + Fdt_p(i,j,:)) - enddo ; enddo + 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 @@ -1426,7 +1436,7 @@ subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, Nangle, CS, LB) !! 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], intent in/out. + !! 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]. @@ -1486,13 +1496,13 @@ subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, Nangle, CS, LB) enddo ! a-loop ! Only reflect newly arrived energy; existing energy in incident wedge is not reflected - ! and will eventually propagate out of cell. (Thid 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) + ! 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 (Jm-2) + ! 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.) @@ -1521,8 +1531,7 @@ subroutine zonal_flux_En(u, h, hL, hR, uh, dt, G, US, j, ish, ieh, vol_CFL) !! 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 thickness curvature over a grid length, - ! with the same units as h_in. + 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 @@ -1566,8 +1575,7 @@ subroutine merid_flux_En(v, h, hL, hR, vh, dt, G, US, J, ish, ieh, vol_CFL) !! 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 thickness curvature over a grid length, - ! with the same units as h_in. + 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 @@ -1603,18 +1611,18 @@ subroutine reflect(En, NAngle, CS, G, LB) 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 boudary wrt equator + ! 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 + ! 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 :: TwoPi ! 2*pi - real :: Angle_size ! size of beam wedge (rad) - real :: angle_wall ! angle of coast/ridge/shelf wrt equator - real, dimension(1:NAngle) :: angle_i ! angle of incident ray wrt equator - real :: angle_r ! angle of reflected ray wrt equator + real :: TwoPi ! 2*pi = 6.2831853... [nondim] + real :: Angle_size ! size of beam wedge [rad] + real :: angle_wall ! angle of coast/ridge/shelf wrt equator [rad] + real, dimension(1:NAngle) :: angle_i ! angle of incident ray wrt equator [rad] + real :: angle_r ! angle of reflected ray wrt equator [rad] real, dimension(1:Nangle) :: En_reflected integer :: i, j, a, a_r, na !integer :: isd, ied, jsd, jed ! start and end local indices on data domain @@ -1623,7 +1631,6 @@ subroutine reflect(En, NAngle, CS, G, LB) ! (values exclude halos) 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 (decomp-invar) indices !isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec @@ -1643,59 +1650,54 @@ subroutine reflect(En, NAngle, CS, G, LB) ridge = CS%refl_dbl En_reflected(:) = 0.0 - !do j=jsc-1,jec+1 - do j=jsh,jeh - !do i=isc-1,iec+1 - do i=ish,ieh - ! jd_g = j + G%jdg_offset ; id_g = i + G%idg_offset - ! 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 - do a=1,NAngle - if (En(i,j,a) > 0.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 (angle_wall > TwoPi) then - angle_wall = angle_wall - TwoPi*floor(abs(angle_wall)/TwoPi) - elseif (angle_wall < 0.0) then - angle_wall = angle_wall + TwoPi*ceiling(abs(angle_wall)/TwoPi) - endif - ! if ray is not incident and not in a ridge cell, keep specified angle - else - angle_wall = angle_c(i,j) - endif - ! do reflection - if (sin(angle_i(a) - angle_wall) >= 0.0) then - angle_r = 2.0*angle_wall - angle_i(a) - if (angle_r > TwoPi) then - angle_r = angle_r - TwoPi*floor(abs(angle_r)/TwoPi) - elseif (angle_r < 0.0) then - angle_r = angle_r + TwoPi*ceiling(abs(angle_r)/TwoPi) - endif - a_r = nint(angle_r/Angle_size) + 1 - do while (a_r > Nangle) ; a_r = a_r - Nangle ; enddo - if (a /= a_r) then - En_reflected(a_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 + 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 + do a=1,NAngle ; if (En(i,j,a) > 0.0) then + if (sin(angle_i(a) - angle_c(i,j)) >= 0.0) then + ! if ray is incident, keep specified boundary angle + angle_wall = angle_c(i,j) + elseif (ridge(i,j)) then + ! if ray is not incident but in ridge cell, use complementary angle + angle_wall = angle_c(i,j) + 0.5*TwoPi + if (angle_wall > TwoPi) then + angle_wall = angle_wall - TwoPi*floor(abs(angle_wall)/TwoPi) + elseif (angle_wall < 0.0) then + angle_wall = angle_wall + TwoPi*ceiling(abs(angle_wall)/TwoPi) endif - enddo ! a-loop - En(i,j,:) = En(i,j,:) + En_reflected(:) - En_reflected(:) = 0.0 - endif - enddo ! i-loop - enddo ! j-loop + else + ! if ray is not incident and not in a ridge cell, keep specified angle + angle_wall = angle_c(i,j) + endif + + ! do reflection + if (sin(angle_i(a) - angle_wall) >= 0.0) then + angle_r = 2.0*angle_wall - angle_i(a) + if (angle_r > TwoPi) then + angle_r = angle_r - TwoPi*floor(abs(angle_r)/TwoPi) + elseif (angle_r < 0.0) then + angle_r = angle_r + TwoPi*ceiling(abs(angle_r)/TwoPi) + endif + a_r = nint(angle_r/Angle_size) + 1 + do while (a_r > Nangle) ; a_r = a_r - Nangle ; enddo + if (a /= a_r) then + En_reflected(a_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 + 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 - ! jd_g = j + G%jdg_offset ; id_g = i + G%idg_offset - ! write (mesg,*) 'En=', En(i,j,a), 'a=', a, 'ig_g=',id_g, 'jg_g=',jd_g + ! 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 @@ -1717,17 +1719,17 @@ subroutine teleport(En, NAngle, CS, G, LB) 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 boudary wrt equator + ! 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 + ! 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 ! size of beam wedge (rad) - real :: Angle_size ! size of beam wedge (rad) - real, dimension(1:NAngle) :: angle_i ! angle of incident ray wrt equator + ! 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, sin_angle real :: En_tele ! energy to be "teleported" [R Z3 T-2 ~> J m-2] character(len=160) :: mesg ! The text of an error message @@ -2295,8 +2297,8 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) CS%TKE_itidal_loss(:,:,:,:,:) = 0.0 allocate(CS%TKE_Froude_loss(isd:ied,jsd:jed,num_angle,num_freq,num_mode)) CS%TKE_Froude_loss(:,:,:,:,:) = 0.0 - allocate(CS%tot_leak_loss(isd:ied,jsd:jed)) ; CS%tot_leak_loss(:,:) = 0.0 - allocate(CS%tot_quad_loss(isd:ied,jsd:jed) ) ; CS%tot_quad_loss(:,:) = 0.0 + allocate(CS%tot_leak_loss(isd:ied,jsd:jed)) ; CS%tot_leak_loss(:,:) = 0.0 + allocate(CS%tot_quad_loss(isd:ied,jsd:jed) ) ; CS%tot_quad_loss(:,:) = 0.0 allocate(CS%tot_itidal_loss(isd:ied,jsd:jed)) ; CS%tot_itidal_loss(:,:) = 0.0 allocate(CS%tot_Froude_loss(isd:ied,jsd:jed)) ; CS%tot_Froude_loss(:,:) = 0.0 @@ -2322,12 +2324,17 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) 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.) + fail_if_missing=.false., default='') filename = trim(CS%inputdir) // trim(refl_angle_file) - call log_param(param_file, mdl, "INPUTDIR/REFL_ANGLE_FILE", filename) allocate(CS%refl_angle(isd:ied,jsd:jed)) ; CS%refl_angle(:,:) = CS%nullangle - call MOM_read_data(filename, 'refl_angle', CS%refl_angle, & - G%domain, timelevel=1) + 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, timelevel=1) + 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 @@ -2337,11 +2344,16 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) ! 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.) + fail_if_missing=.false., default='') filename = trim(CS%inputdir) // trim(refl_pref_file) - call log_param(param_file, mdl, "INPUTDIR/REFL_PREF_FILE", filename) allocate(CS%refl_pref(isd:ied,jsd:jed)) ; CS%refl_pref(:,:) = 1.0 - call MOM_read_data(filename, 'refl_pref', CS%refl_pref, G%domain, timelevel=1) + 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, timelevel=1) + 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) @@ -2360,11 +2372,16 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) ! 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.) + fail_if_missing=.false., default='') filename = trim(CS%inputdir) // trim(refl_dbl_file) - call log_param(param_file, mdl, "INPUTDIR/REFL_DBL_FILE", filename) allocate(ridge_temp(isd:ied,jsd:jed)) ; ridge_temp(:,:) = 0.0 - call MOM_read_data(filename, 'refl_dbl', ridge_temp, G%domain, timelevel=1) + 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, timelevel=1) + 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)) ; CS%refl_dbl(:,:) = .false. do i=isd,ied; do j=jsd,jed diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index 0e237fac55..c8406e8677 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -3,20 +3,21 @@ module MOM_lateral_mixing_coeffs ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_debugging, only : hchksum, uvchksum -use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg -use MOM_diag_mediator, only : register_diag_field, safe_alloc_ptr, post_data -use MOM_diag_mediator, only : diag_ctrl, time_type, query_averaging_enabled -use MOM_domains, only : create_group_pass, do_group_pass -use MOM_domains, only : group_pass_type, pass_var, pass_vector -use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_debugging, only : hchksum, uvchksum +use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg +use MOM_diag_mediator, only : register_diag_field, safe_alloc_ptr, post_data +use MOM_diag_mediator, only : diag_ctrl, time_type, query_averaging_enabled +use MOM_domains, only : create_group_pass, do_group_pass +use MOM_domains, only : group_pass_type, pass_var, pass_vector +use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_interface_heights, only : find_eta -use MOM_isopycnal_slopes, only : calc_isoneutral_slopes -use MOM_grid, only : ocean_grid_type -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : thermo_var_ptrs -use MOM_verticalGrid, only : verticalGrid_type -use MOM_wave_speed, only : wave_speed, wave_speed_CS, wave_speed_init +use MOM_isopycnal_slopes, only : calc_isoneutral_slopes +use MOM_grid, only : ocean_grid_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type +use MOM_wave_speed, only : wave_speed, wave_speed_CS, wave_speed_init +use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE implicit none ; private @@ -432,7 +433,7 @@ end subroutine calc_resoln_function !> Calculates and stores functions of isopycnal slopes, e.g. Sx, Sy, S*N, mostly used in the Visbeck et al. !! style scaling of diffusivity -subroutine calc_slope_functions(h, tv, dt, G, GV, US, CS) +subroutine calc_slope_functions(h, tv, dt, G, GV, US, CS, OBC) type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -440,6 +441,7 @@ subroutine calc_slope_functions(h, tv, dt, G, GV, US, CS) type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables real, intent(in) :: dt !< Time increment [T ~> s] type(VarMix_CS), pointer :: CS !< Variable mixing coefficients + type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. ! Local variables real, dimension(SZI_(G), SZJ_(G), SZK_(G)+1) :: & e ! The interface heights relative to mean sea level [Z ~> m]. @@ -453,12 +455,12 @@ subroutine calc_slope_functions(h, tv, dt, G, GV, US, CS) call find_eta(h, tv, G, GV, US, e, halo_size=2) if (CS%use_stored_slopes) then call calc_isoneutral_slopes(G, GV, US, h, e, tv, dt*CS%kappa_smooth, & - CS%slope_x, CS%slope_y, N2_u, N2_v, 1) - call calc_Visbeck_coeffs(h, CS%slope_x, CS%slope_y, N2_u, N2_v, G, GV, US, CS) + CS%slope_x, CS%slope_y, N2_u, N2_v, 1, OBC=OBC) + call calc_Visbeck_coeffs(h, CS%slope_x, CS%slope_y, N2_u, N2_v, G, GV, US, CS, OBC=OBC) ! call calc_slope_functions_using_just_e(h, G, CS, e, .false.) else !call calc_isoneutral_slopes(G, GV, h, e, tv, dt*CS%kappa_smooth, CS%slope_x, CS%slope_y) - call calc_slope_functions_using_just_e(h, G, GV, US, CS, e, .true.) + call calc_slope_functions_using_just_e(h, G, GV, US, CS, e, .true., OBC=OBC) endif endif @@ -476,7 +478,7 @@ subroutine calc_slope_functions(h, tv, dt, G, GV, US, CS) end subroutine calc_slope_functions !> Calculates factors used when setting diffusivity coefficients similar to Visbeck et al. -subroutine calc_Visbeck_coeffs(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, CS) +subroutine calc_Visbeck_coeffs(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, CS, OBC) type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] @@ -488,6 +490,7 @@ subroutine calc_Visbeck_coeffs(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, CS) !! at v-points [T-2 ~> s-2] type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(VarMix_CS), pointer :: CS !< Variable mixing coefficients + type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. ! Local variables real :: S2 ! Interface slope squared [nondim] @@ -496,10 +499,12 @@ subroutine calc_Visbeck_coeffs(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, CS) real :: H_geom ! The geometric mean of Hup*Hdn [H ~> m or kg m-2]. integer :: is, ie, js, je, nz integer :: i, j, k, kb_max + integer :: l_seg real :: S2max, wNE, wSE, wSW, wNW real :: H_u(SZIB_(G)), H_v(SZI_(G)) real :: S2_u(SZIB_(G), SZJ_(G)) real :: S2_v(SZI_(G), SZJB_(G)) + logical :: local_open_u_BC, local_open_v_BC if (.not. associated(CS)) call MOM_error(FATAL, "calc_slope_function:"// & "Module must be initialized before it is used.") @@ -511,6 +516,13 @@ subroutine calc_Visbeck_coeffs(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, CS) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + local_open_u_BC = .false. + local_open_v_BC = .false. + if (present(OBC)) then ; if (associated(OBC)) then + local_open_u_BC = OBC%open_u_BCs_exist_globally + local_open_v_BC = OBC%open_v_BCs_exist_globally + endif ; endif + S2max = CS%Visbeck_S_max**2 !$OMP parallel do default(shared) @@ -556,6 +568,15 @@ subroutine calc_Visbeck_coeffs(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, CS) else CS%SN_u(I,j) = 0. endif + if (local_open_u_BC) then + l_seg = OBC%segnum_u(I,j) + + if (l_seg /= OBC_NONE) then + if (OBC%segment(l_seg)%open) then + CS%SN_u(i,J) = 0. + endif + endif + endif enddo enddo @@ -592,6 +613,15 @@ subroutine calc_Visbeck_coeffs(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, CS) else CS%SN_v(i,J) = 0. endif + if (local_open_v_BC) then + l_seg = OBC%segnum_v(i,J) + + if (l_seg /= OBC_NONE) then + if (OBC%segment(OBC%segnum_v(i,J))%open) then + CS%SN_v(i,J) = 0. + endif + endif + endif enddo enddo @@ -603,15 +633,17 @@ subroutine calc_Visbeck_coeffs(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, CS) if (CS%debug) then call uvchksum("calc_Visbeck_coeffs slope_[xy]", slope_x, slope_y, G%HI, haloshift=1) - call uvchksum("calc_Visbeck_coeffs N2_u, N2_v", N2_u, N2_v, G%HI, scale=US%s_to_T**2) - call uvchksum("calc_Visbeck_coeffs SN_[uv]", CS%SN_u, CS%SN_v, G%HI, scale=US%s_to_T) + call uvchksum("calc_Visbeck_coeffs N2_u, N2_v", N2_u, N2_v, G%HI, & + scale=US%s_to_T**2, scalar_pair=.true.) + call uvchksum("calc_Visbeck_coeffs SN_[uv]", CS%SN_u, CS%SN_v, G%HI, & + scale=US%s_to_T, scalar_pair=.true.) endif end subroutine calc_Visbeck_coeffs !> The original calc_slope_function() that calculated slopes using !! interface positions only, not accounting for density variations. -subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slopes) +subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slopes, OBC) type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure @@ -620,6 +652,7 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slop real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(in) :: e !< Interface position [Z ~> m] logical, intent(in) :: calculate_slopes !< If true, calculate slopes internally !! otherwise use slopes stored in CS + type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. ! Local variables real :: E_x(SZIB_(G), SZJ_(G)) ! X-slope of interface at u points [nondim] (for diagnostics) real :: E_y(SZI_(G), SZJB_(G)) ! Y-slope of interface at v points [nondim] (for diagnostics) @@ -633,8 +666,10 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slop real :: one_meter ! One meter in thickness units [H ~> m or kg m-2]. integer :: is, ie, js, je, nz integer :: i, j, k, kb_max + integer :: l_seg real :: S2N2_u_local(SZIB_(G), SZJ_(G),SZK_(G)) real :: S2N2_v_local(SZI_(G), SZJB_(G),SZK_(G)) + logical :: local_open_u_BC, local_open_v_BC if (.not. associated(CS)) call MOM_error(FATAL, "calc_slope_function:"// & "Module must be initialized before it is used.") @@ -646,6 +681,13 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slop is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + local_open_u_BC = .false. + local_open_v_BC = .false. + if (present(OBC)) then ; if (associated(OBC)) then + local_open_u_BC = OBC%open_u_BCs_exist_globally + local_open_v_BC = OBC%open_v_BCs_exist_globally + endif ; endif + one_meter = 1.0 * GV%m_to_H h_neglect = GV%H_subroundoff H_cutoff = real(2*nz) * (GV%Angstrom_H + h_neglect) @@ -721,6 +763,15 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slop else CS%SN_u(I,j) = 0.0 endif + if (local_open_u_BC) then + l_seg = OBC%segnum_u(I,j) + + if (l_seg /= OBC_NONE) then + if (OBC%segment(l_seg)%open) then + CS%SN_u(I,j) = 0. + endif + endif + endif enddo enddo !$OMP parallel do default(shared) @@ -738,6 +789,15 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slop else CS%SN_v(I,j) = 0.0 endif + if (local_open_v_BC) then + l_seg = OBC%segnum_v(I,j) + + if (l_seg /= OBC_NONE) then + if (OBC%segment(OBC%segnum_v(I,j))%open) then + CS%SN_v(I,j) = 0. + endif + endif + endif enddo enddo @@ -749,8 +809,6 @@ subroutine calc_QG_Leith_viscosity(CS, G, GV, US, h, k, div_xx_dx, div_xx_dy, vo 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(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: u !< Zonal flow [L T-1 ~> m s-1] -! real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: v !< Meridional flow [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(G)), 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 @@ -761,15 +819,6 @@ subroutine calc_QG_Leith_viscosity(CS, G, GV, US, h, k, div_xx_dx, div_xx_dy, vo !! (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] -! real, dimension(SZI_(G),SZJ_(G)), intent(out) :: Leith_Kh_h !< Leith Laplacian viscosity - !! at h-points [L2 T-1 ~> m2 s-1] -! real, dimension(SZIB_(G),SZJB_(G)), intent(out) :: Leith_Kh_q !< Leith Laplacian viscosity - !! at q-points [L2 T-1 ~> m2 s-1] -! real, dimension(SZI_(G),SZJ_(G)), intent(out) :: Leith_Ah_h !< Leith bi-harmonic viscosity - !! at h-points [L4 T-1 ~> m4 s-1] -! real, dimension(SZIB_(G),SZJB_(G)), intent(out) :: Leith_Ah_q !< Leith bi-harmonic viscosity - !! at q-points [L4 T-1 ~> m4 s-1] - ! Local variables real, dimension(SZI_(G),SZJB_(G)) :: & dslopey_dz, & ! z-derivative of y-slope at v-points [Z-1 ~> m-1] @@ -797,16 +846,9 @@ subroutine calc_QG_Leith_viscosity(CS, G, GV, US, h, k, div_xx_dx, div_xx_dy, vo inv_PI3 = 1.0/((4.0*atan(1.0))**3) - !### I believe this halo update to be unnecessary. -RWH - call pass_var(h, G%Domain) - if ((k > 1) .and. (k < nz)) then - ! Add in stretching term for the QG Leith vsicosity -! if (CS%use_QG_Leith) then - - !### do j=js-1,je+1 ; do I=is-2,Ieq+1 - do j=js-2,Jeq+2 ; do I=is-2,Ieq+1 + 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 ) @@ -818,8 +860,7 @@ subroutine calc_QG_Leith_viscosity(CS, G, GV, US, h, k, div_xx_dx, div_xx_dy, vo h_at_u(I,j) = 2. * ( h_at_slope_above * h_at_slope_below ) * Ih enddo ; enddo - !### do J=js-2,Jeq+1 ; do i=is-1,ie+1 - do J=js-2,Jeq+1 ; do i=is-2,Ieq+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 ) @@ -831,8 +872,7 @@ subroutine calc_QG_Leith_viscosity(CS, G, GV, US, h, k, div_xx_dx, div_xx_dy, vo h_at_v(i,J) = 2. * ( h_at_slope_above * h_at_slope_below ) * Ih enddo ; enddo - !### do J=js-1,je ; do i=is-1,Ieq+1 - do J=js-2,Jeq+1 ; do i=is-1,Ieq+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 * US%L_to_Z * & ( ( h_at_u(I,j) * dslopex_dz(I,j) + h_at_u(I-1,j+1) * dslopex_dz(I-1,j+1) ) & @@ -840,33 +880,25 @@ subroutine calc_QG_Leith_viscosity(CS, G, GV, US, h, k, div_xx_dx, div_xx_dy, vo ( ( 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 - !### do j=js-1,Jeq+1 ; do I=is-1,ie - do j=js-1,Jeq+1 ; do I=is-2,Ieq+1 + do j=js-1,Jeq+1 ; do I=is-1,ie f = 0.5 * ( G%CoriolisBu(I,J) + G%CoriolisBu(I,J-1) ) - !### I think that this should be vort_xy_dy(I,j) = vort_xy_dy(I,j) - f * & - vort_xy_dy(I,j) = vort_xy_dx(I,j) - f * US%L_to_Z * & + vort_xy_dy(I,j) = vort_xy_dy(I,j) - f * US%L_to_Z * & ( ( 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 - !### I believe this halo update to be unnecessary. -RWH - call pass_vector(vort_xy_dy,vort_xy_dx,G%Domain) - if (CS%use_QG_Leith_GM) then do j=js,je ; do I=is-1,Ieq - !### These expressions are not rotationally symmetric. Add parentheses and regroup, as in: - ! 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_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) & - + vort_xy_dx(i,J-1) + vort_xy_dx(i+1,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) & - + div_xx_dy(i,J-1) + div_xx_dy(i+1,J-1)))**2) + 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) ) + 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 @@ -876,14 +908,13 @@ subroutine calc_QG_Leith_viscosity(CS, G, GV, US, h, k, div_xx_dx, div_xx_dy, vo enddo ; enddo do J=js-1,Jeq ; do i=is,ie - !### These expressions are not rotationally symmetric. Add parentheses and regroup. - 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) & - + vort_xy_dy(I,j+1) + vort_xy_dy(I-1,j+1)))**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) & - + div_xx_dx(I,j+1) + div_xx_dx(I-1,j+1)))**2) + 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) ) + 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 @@ -923,8 +954,12 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) real :: Leith_Lap_const ! The non-dimensional coefficient in the Leith viscosity 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 :: better_speed_est ! If true, use a more robust estimate of the first + ! mode wave speed as the starting point for iterations. ! This include declares and sets the variable "version". -#include "version_variable.h" +# 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 @@ -1148,7 +1183,7 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) "If true, interpolate the resolution function to the "//& "velocity points from the thickness points; otherwise "//& "interpolate the wave speed and calculate the resolution "//& - "function independently at each point.", default=.true.) + "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:"//& @@ -1157,13 +1192,12 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) "MOM_lateral_mixing_coeffs.F90, VarMix_init:"//& "When INTERPOLATE_RES_FN=True, VISC_RES_FN_POWER must equal KH_RES_FN_POWER.") endif - !### Change the default of GILL_EQUATORIAL_LD to True. call get_param(param_file, mdl, "GILL_EQUATORIAL_LD", Gill_equatorial_Ld, & "If true, uses Gill's definition of the baroclinic "//& "equatorial deformation radius, otherwise, if false, use "//& "Pedlosky's definition. These definitions differ by a factor "//& "of 2 in front of the beta term in the denominator. Gill's "//& - "is the more appropriate definition.", default=.false.) + "is the more appropriate definition.", default=.true.) if (Gill_equatorial_Ld) then oneOrTwo = 2.0 endif @@ -1242,13 +1276,25 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) allocate(CS%cg1(isd:ied,jsd:jed)) ; CS%cg1(:,:) = 0.0 call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=.true.) + default=.false.) 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) + 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=.false.) !### Change the default. call wave_speed_init(CS%wave_speed_CSp, use_ebt_mode=CS%Resoln_use_ebt, & - mono_N2_depth=N2_filter_depth, remap_answers_2018=remap_answers_2018) + mono_N2_depth=N2_filter_depth, remap_answers_2018=remap_answers_2018, & + better_speed_est=better_speed_est, min_speed=wave_speed_min, & + wave_speed_tol=wave_speed_tol) endif ! Leith parameters @@ -1279,13 +1325,12 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) 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 = sqrt(grid_sp_u2) + 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 - !### The second factor here is wrong. It should be G%dxCv(i,J). - grid_sp_v2 = G%dyCv(i,J)*G%dxCu(i,J) + 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 diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index 3ef9bd308a..37bbaa4230 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -19,7 +19,7 @@ module MOM_mixed_layer_restrat use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type -use MOM_EOS, only : calculate_density +use MOM_EOS, only : calculate_density, EOS_domain implicit none ; private @@ -56,7 +56,6 @@ module MOM_mixed_layer_restrat !! 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. - logical :: MLE_use_MLD_ave_bug !< If true, do not account for MLD mismatch to interface positions. 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. @@ -101,7 +100,7 @@ subroutine mixedlayer_restrat(h, uhtr, vhtr, tv, forces, dt, MLD, VarMix, G, GV, 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 - !! PBL scheme [H ~> m or kg m-2] + !! PBL scheme [Z ~> m] type(VarMix_CS), pointer :: VarMix !< Container for derived fields type(mixedlayer_restrat_CS), pointer :: CS !< Module control structure @@ -131,7 +130,7 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var 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 [m] (not H) + !! PBL scheme [Z ~> m] (not H) type(VarMix_CS), pointer :: VarMix !< Container for derived fields type(mixedlayer_restrat_CS), pointer :: CS !< Module control structure ! Local variables @@ -149,7 +148,7 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var Rml_av_slow ! g_Rho0 times the average mixed layer density [L2 Z-1 T-2 ~> m s-2] real :: g_Rho0 ! G_Earth/Rho0 [L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1] real :: rho_ml(SZI_(G)) ! Potential density relative to the surface [R ~> kg m-3] - real :: p0(SZI_(G)) ! A pressure of 0 [Pa] + real :: p0(SZI_(G)) ! A pressure of 0 [R L2 T-2 ~> Pa] real :: h_vel ! htot interpolated onto velocity points [Z ~> m] (not H). real :: absf ! absolute value of f, interpolated to velocity points [T-1 ~> s-1] @@ -173,16 +172,18 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var real :: vtimescale_diag(SZI_(G),SZJB_(G)) ! meridional directions [T ~> s], stored in 2-D arrays ! for diagnostic purposes. real :: uDml_diag(SZIB_(G),SZJ_(G)), vDml_diag(SZI_(G),SZJB_(G)) - integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz real, dimension(SZI_(G)) :: rhoSurf, deltaRhoAtKm1, deltaRhoAtK ! Densities [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 [Pa]. + real, dimension(SZI_(G)) :: pRef_MLD ! A reference pressure for calculating the mixed layer + ! densities [R L2 T-2 ~> Pa]. real, dimension(SZI_(G)) :: rhoAtK, rho1, d1, pRef_N2 ! Used for N2 real :: aFac, bFac ! Nondimensional ratios [nondim] real :: ddRho ! A density difference [R ~> kg m-3] real :: hAtVel, zpa, zpb, dh, res_scaling_fac real :: I_LFront ! The inverse of the frontal length scale [L-1 ~> m-1] - logical :: proper_averaging, line_is_empty, keep_going, res_upscale + 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 real :: PSI, PSI1, z, BOTTOP, XP, DD ! For the following statement functions ! Stream function as a function of non-dimensional position within mixed-layer (F77 statement function) @@ -204,10 +205,10 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var 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 - call calculate_density(tv%T(:,j,1), tv%S(:,j,1), pRef_MLD, rhoSurf, is-1, ie-is+3, & - tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density(tv%T(:,j,1), tv%S(:,j,1), pRef_MLD, rhoSurf, tv%eqn_of_state, EOSdom) deltaRhoAtK(:) = 0. MLD_fast(:,j) = 0. do k = 2, nz @@ -215,8 +216,7 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var 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 - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pRef_MLD, deltaRhoAtK, is-1, ie-is+3, & - tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pRef_MLD, deltaRhoAtK, tv%eqn_of_state, EOSdom) do i = is-1,ie+1 deltaRhoAtK(i) = deltaRhoAtK(i) - rhoSurf(i) ! Density difference between layer K and surface enddo @@ -239,7 +239,7 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var if (.not. associated(MLD_in)) call MOM_error(FATAL, "MOM_mixedlayer_restrat: "// & "Argument MLD_in was not associated!") do j = js-1, je+1 ; do i = is-1, ie+1 - MLD_fast(i,j) = (CS%MLE_MLD_stretch * GV%m_to_H) * MLD_in(i,j) + MLD_fast(i,j) = (CS%MLE_MLD_stretch * GV%Z_to_H) * MLD_in(i,j) enddo ; enddo else call MOM_error(FATAL, "MOM_mixedlayer_restrat: "// & @@ -249,8 +249,8 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var ! Apply time filter (to remove diurnal cycle) if (CS%MLE_MLD_decay_time>0.) then if (CS%debug) then - call hchksum(CS%MLD_filtered,'mixed_layer_restrat: MLD_filtered',G%HI,haloshift=1,scale=GV%H_to_m) - call hchksum(MLD_in,'mixed_layer_restrat: MLD in',G%HI,haloshift=1) + call hchksum(CS%MLD_filtered, 'mixed_layer_restrat: MLD_filtered', G%HI, haloshift=1, scale=GV%H_to_m) + 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 ) @@ -290,7 +290,6 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var g_Rho0 = GV%g_Earth / GV%Rho0 h_neglect = GV%H_subroundoff dz_neglect = GV%H_subroundoff*GV%H_to_Z - proper_averaging = .not. CS%MLE_use_MLD_ave_bug if (CS%front_length>0.) then res_upscale = .true. I_LFront = 1. / CS%front_length @@ -299,12 +298,12 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var endif p0(:) = 0.0 + EOSdom(:) = EOS_domain(G%HI, halo=1) !$OMP parallel default(none) shared(is,ie,js,je,G,GV,US,htot_fast,Rml_av_fast,tv,p0,h,h_avail,& -!$OMP h_neglect,g_Rho0,I4dt,CS,uhml,uhtr,dt,vhml,vhtr, & +!$OMP h_neglect,g_Rho0,I4dt,CS,uhml,uhtr,dt,vhml,vhtr,EOSdom, & !$OMP utimescale_diag,vtimescale_diag,forces,dz_neglect, & !$OMP htot_slow,MLD_slow,Rml_av_slow,VarMix,I_LFront, & -!$OMP res_upscale, & -!$OMP nz,MLD_fast,uDml_diag,vDml_diag,proper_averaging) & +!$OMP res_upscale, nz,MLD_fast,uDml_diag,vDml_diag) & !$OMP private(rho_ml,h_vel,u_star,absf,mom_mixrate,timescale, & !$OMP line_is_empty, keep_going,res_scaling_fac, & !$OMP a,IhTot,b,Ihtot_slow,zpb,hAtVel,zpa,dh) & @@ -321,12 +320,11 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var 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 - call calculate_density(tv%T(:,j,k),tv%S(:,j,k),p0,rho_ml(:),is-1,ie-is+3,tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p0, rho_ml(:), tv%eqn_of_state, EOSdom) line_is_empty = .true. do i=is-1,ie+1 if (htot_fast(i,j) < MLD_fast(i,j)) then - dh = h(i,j,k) - if (proper_averaging) dh = min( h(i,j,k), MLD_fast(i,j)-htot_fast(i,j) ) + dh = min( h(i,j,k), MLD_fast(i,j)-htot_fast(i,j) ) Rml_av_fast(i,j) = Rml_av_fast(i,j) + dh*rho_ml(i) htot_fast(i,j) = htot_fast(i,j) + dh line_is_empty = .false. @@ -353,7 +351,7 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var call hchksum(forces%ustar,'mixed_layer_restrat: u*', G%HI, haloshift=1, scale=US%Z_to_m*US%s_to_T) call hchksum(MLD_fast,'mixed_layer_restrat: MLD', G%HI, haloshift=1, scale=GV%H_to_m) call hchksum(Rml_av_fast,'mixed_layer_restrat: rml', G%HI, haloshift=1, & - scale=US%m_to_Z*US%L_to_m**2*US%s_to_T**2) + scale=US%m_to_Z*US%L_T_to_m_s**2) endif ! TO DO: @@ -585,7 +583,7 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) Rml_av ! g_Rho0 times the average mixed layer density [L2 Z-1 T-2 ~> m s-2] real :: g_Rho0 ! G_Earth/Rho0 [L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1] real :: Rho0(SZI_(G)) ! Potential density relative to the surface [R ~> kg m-3] - real :: p0(SZI_(G)) ! A pressure of 0 [Pa] + real :: p0(SZI_(G)) ! A pressure of 0 [R L2 T-2 ~> Pa] real :: h_vel ! htot interpolated onto velocity points [Z ~> m]. (The units are not H.) real :: absf ! absolute value of f, interpolated to velocity points [T-1 ~> s-1] @@ -611,6 +609,7 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) real :: uDml_diag(SZIB_(G),SZJ_(G)), vDml_diag(SZI_(G),SZJB_(G)) 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 = G%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB ; nkml = GV%nkml @@ -632,7 +631,8 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) ! Fix this later for nkml >= 3. p0(:) = 0.0 -!$OMP parallel default(none) shared(is,ie,js,je,G,GV,US,htot,Rml_av,tv,p0,h,h_avail, & + EOSdom(:) = EOS_domain(G%HI, halo=1) +!$OMP parallel default(none) shared(is,ie,js,je,G,GV,US,htot,Rml_av,tv,p0,h,h_avail,EOSdom, & !$OMP h_neglect,g_Rho0,I4dt,CS,uhml,uhtr,dt,vhml,vhtr, & !$OMP utimescale_diag,vtimescale_diag,forces,dz_neglect, & !$OMP uDml_diag,vDml_diag,nkml) & @@ -645,7 +645,7 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) htot(i,j) = 0.0 ; Rml_av(i,j) = 0.0 enddo do k=1,nkml - call calculate_density(tv%T(:,j,k),tv%S(:,j,k),p0,Rho0(:),is-1,ie-is+3,tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p0, Rho0(:), tv%eqn_of_state, EOSdom) do i=is-1,ie+1 Rml_av(i,j) = Rml_av(i,j) + h(i,j,k)*Rho0(i) htot(i,j) = htot(i,j) + h(i,j,k) @@ -812,7 +812,9 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, integer :: i, j ! Read all relevant parameters and write them to the model log. - call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "MIXEDLAYER_RESTRAT", mixedlayer_restrat_init, & + 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 "//& @@ -882,9 +884,6 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, "A scaling coefficient for stretching/shrinking the MLD "//& "used in the MLE scheme. This simply multiplies MLD wherever used.",& units="nondim", default=1.0) - call get_param(param_file, mdl, "MLE_USE_MLD_AVE_BUG", CS%MLE_use_MLD_ave_bug, & - "If true, do not account for MLD mismatch to interface positions.",& - default=.false.) endif CS%diag => diag diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index 4da62ed5df..3de7b0121b 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -9,7 +9,8 @@ module MOM_thickness_diffuse 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 +use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_domain +use MOM_EOS, only : calculate_density_second_derivs use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type use MOM_interface_heights, only : find_eta @@ -19,7 +20,6 @@ module MOM_thickness_diffuse use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs, cont_diag_ptrs use MOM_verticalGrid, only : verticalGrid_type - implicit none ; private #include @@ -77,6 +77,10 @@ module MOM_thickness_diffuse !! than the streamfunction for the GM source term. logical :: use_GM_work_bug !< If true, use the incorrect sign for the !! top-level work tendency on the top layer. + real :: Stanley_det_coeff !< The coefficient correlating SGS temperature variance with the mean + !! temperature gradient in the deterministic part of the Stanley parameterization. + !! Negative values disable the scheme." [nondim] + type(diag_ctrl), pointer :: diag => NULL() !< structure used to regulate timing of diagnostics real, pointer :: GMwork(:,:) => NULL() !< Work by thickness diffusivity [R Z L2 T-3 ~> W m-2] real, pointer :: diagSlopeX(:,:,:) => NULL() !< Diagnostic: zonal neutral slope [nondim] @@ -422,7 +426,8 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp 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) + 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("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) @@ -594,24 +599,27 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV hN2_x_PE ! thickness in m times Brunt-Vaisala freqeuncy at u-points [L2 Z-1 T-2 ~> m s-2], ! used for calculating PE release real, dimension(SZI_(G), SZJ_(G), SZK_(G)+1) :: & - pres, & ! The pressure at an interface [Pa]. + 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 degC-1 ~> kg m-3 degC-1] - drho_dS_u ! The derivative of density with salinity at u points [R ppt-1 ~> kg m-3 ppt-1]. + drho_dS_u, & ! The derivative of density with salinity at u points [R ppt-1 ~> kg m-3 ppt-1]. + drho_dT_dT_u ! The second derivative of density with temperature at u points [R degC-2 ~> kg m-3 degC-2] + real, dimension(SZIB_(G)) :: scrap ! An array to pass to calculate_density_second_derivs() that will be ingored. real, dimension(SZI_(G)) :: & drho_dT_v, & ! The derivative of density with temperature at v points [R degC-1 ~> kg m-3 degC-1] - drho_dS_v ! The derivative of density with salinity at v points [R ppt-1 ~> kg m-3 ppt-1]. + drho_dS_v, & ! The derivative of density with salinity at v points [R ppt-1 ~> kg m-3 ppt-1]. + drho_dT_dT_v ! The second derivative of density with temperature at v points [R degC-2 ~> kg m-3 degC-2] real :: uhtot(SZIB_(G), SZJ_(G)) ! The vertical sum of uhD [H L2 T-1 ~> m3 s-1 or kg s-1]. real :: vhtot(SZI_(G), SZJB_(G)) ! The vertical sum of vhD [H L2 T-1 ~> m3 s-1 or kg s-1]. real, dimension(SZIB_(G)) :: & T_u, & ! Temperature on the interface at the u-point [degC]. S_u, & ! Salinity on the interface at the u-point [ppt]. - pres_u ! Pressure on the interface at the u-point [Pa]. + 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 [degC]. S_v, & ! Salinity on the interface at the v-point [ppt]. - pres_v ! Pressure on the interface at the v-point [Pa]. + pres_v ! Pressure on the interface at the v-point [R L2 T-2 ~> Pa]. real :: Work_u(SZIB_(G), SZJ_(G)) ! The work being done by the thickness real :: Work_v(SZI_(G), SZJB_(G)) ! diffusion integrated over a cell [R Z L4 T-3 ~> W ] real :: Work_h ! The work averaged over an h-cell [R Z L2 T-3 ~> W m-2]. @@ -667,11 +675,23 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV real :: G_rho0 ! g/Rho0 [L2 R-1 Z-1 T-2 ~> m4 kg-1 s-2]. real :: N2_floor ! A floor for N2 to avoid degeneracy in the elliptic solver ! times unit conversion factors [T-2 L2 Z-2 ~> s-2] + real :: Tl(5) ! copy and T in local stencil [degC] + real :: mn_T ! mean of T in local stencil [degC] + real :: mn_T2 ! mean of T**2 in local stencil [degC] + 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, dimension(SZI_(G), SZJ_(G), SZK_(G)) :: Tsgs2 ! Sub-grid temperature variance [degC2] + real, dimension(SZIB_(G), SZJ_(G), SZK_(G)+1) :: diag_sfn_x, diag_sfn_unlim_x ! Diagnostics real, dimension(SZI_(G), SZJB_(G), SZK_(G)+1) :: diag_sfn_y, diag_sfn_unlim_y ! Diagnostics logical :: present_int_slope_u, present_int_slope_v logical :: present_slope_x, present_slope_y, calc_derivatives - integer :: is, ie, js, je, nz, IsdB + 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. + logical :: use_Stanley + integer :: is, ie, js, je, nz, IsdB, halo integer :: i, j, k is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke ; IsdB = G%IsdB @@ -689,6 +709,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV present_int_slope_v = PRESENT(int_slope_v) present_slope_x = PRESENT(slope_x) present_slope_y = PRESENT(slope_y) + use_Stanley = CS%Stanley_det_coeff >= 0. nk_linear = max(GV%nkml, 1) @@ -702,26 +723,65 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV find_work = (associated(CS%GMwork) .or. find_work) if (use_EOS) then - call vert_fill_TS(h, tv%T, tv%S, CS%kappa_smooth*dt, T, S, G, GV, 1, larger_h_denom=.true.) + halo = 1 ! Default halo to fill is 1 + if (use_Stanley) halo = 2 ! Need wider valid halo for gradients of T + call vert_fill_TS(h, tv%T, tv%S, CS%kappa_smooth*dt, T, S, G, GV, halo, larger_h_denom=.true.) endif if (CS%use_FGNV_streamfn .and. .not. associated(cg1)) call MOM_error(FATAL, & "cg1 must be associated when using FGNV streamfunction.") -!$OMP parallel default(none) shared(is,ie,js,je,h_avail_rsum,pres,h_avail,I4dt, & -!$OMP G,GV,h,h_frac,nz,uhtot,Work_u,vhtot,Work_v, & -!$OMP diag_sfn_x, diag_sfn_y, diag_sfn_unlim_x, diag_sfn_unlim_y ) +!$OMP parallel default(none) shared(is,ie,js,je,h_avail_rsum,pres,h_avail,I4dt, use_Stanley, & +!$OMP CS,G,GV,tv,h,h_frac,nz,uhtot,Work_u,vhtot,Work_v,Tsgs2,T, & +!$OMP diag_sfn_x, diag_sfn_y, diag_sfn_unlim_x, diag_sfn_unlim_y ) & +!$OMP private(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 ! ### This should be atmospheric pressure. + 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%H_to_Pa*h(i,j,1) + pres(i,j,2) = pres(i,j,1) + (GV%g_Earth*GV%H_to_RZ) * h(i,j,1) enddo ; enddo + if (use_Stanley) then +!$OMP do + do k=1, nz ; do j=js-1,je+1 ; do i=is-1,ie+1 + !! SGS variance in i-direction [degC2] + !dTdi2 = ( ( G%mask2dCu(I ,j) * G%IdxCu(I ,j) * ( T(i+1,j,k) - T(i,j,k) ) & + ! + G%mask2dCu(I-1,j) * G%IdxCu(I-1,j) * ( T(i,j,k) - T(i-1,j,k) ) & + ! ) * G%dxT(i,j) * 0.5 )**2 + !! SGS variance in j-direction [degC2] + !dTdj2 = ( ( G%mask2dCv(i,J ) * G%IdyCv(i,J ) * ( T(i,j+1,k) - T(i,j,k) ) & + ! + G%mask2dCv(i,J-1) * G%IdyCv(i,J-1) * ( T(i,j,k) - T(i,j-1,k) ) & + ! ) * G%dyT(i,j) * 0.5 )**2 + !Tsgs2(i,j,k) = CS%Stanley_det_coeff * 0.5 * ( dTdi2 + dTdj2 ) + ! 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. + 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) + r_sm_H = 1. / ( ( hl(1) + ( ( hl(2) + hl(3) ) + ( hl(4) + hl(5) ) ) ) + GV%H_subroundoff ) + ! Mean of T + Tl(1) = T(i,j,k) ; Tl(2) = T(i-1,j,k) ; Tl(3) = T(i+1,j,k) + Tl(4) = T(i,j-1,k) ; Tl(5) = T(i,j+1,k) + mn_T = ( hl(1)*Tl(1) + ( ( hl(2)*Tl(2) + hl(3)*Tl(3) ) + ( hl(4)*Tl(4) + hl(5)*Tl(5) ) ) ) * r_sm_H + ! Adjust T vectors to have zero mean + Tl(:) = Tl(:) - mn_T ; mn_T = 0. + ! Variance of T + mn_T2 = ( hl(1)*Tl(1)*Tl(1) + ( ( hl(2)*Tl(2)*Tl(2) + hl(3)*Tl(3)*Tl(3) ) & + + ( hl(4)*Tl(4)*Tl(4) + hl(5)*Tl(5)*Tl(5) ) ) ) * r_sm_H + ! Variance should be positive but round-off can violate this. Calculating + ! variance directly would fix this but requires more operations. + Tsgs2(i,j,k) = CS%Stanley_det_coeff * max(0., mn_T2) + enddo ; enddo ; enddo + endif !$OMP do do j=js-1,je+1 do k=2,nz ; do i=is-1,ie+1 @@ -729,7 +789,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV 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%H_to_Pa*h(i,j,k) + 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 @@ -746,15 +806,18 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV enddo ; enddo !$OMP end parallel + EOSdom_u(1) = (is-1) - (G%IsdB-1) ; EOSdom_u(2) = ie - (G%IsdB-1) !$OMP parallel do default(none) shared(nz,is,ie,js,je,find_work,use_EOS,G,GV,US,pres,T,S, & !$OMP nk_linear,IsdB,tv,h,h_neglect,e,dz_neglect, & !$OMP I_slope_max2,h_neglect2,present_int_slope_u, & !$OMP int_slope_u,KH_u,uhtot,h_frac,h_avail_rsum, & !$OMP uhD,h_avail,G_scale,Work_u,CS,slope_x,cg1, & -!$OMP diag_sfn_x, diag_sfn_unlim_x,N2_floor, & +!$OMP diag_sfn_x, diag_sfn_unlim_x,N2_floor,EOSdom_u, & +!$OMP use_stanley, Tsgs2, & !$OMP present_slope_x,G_rho0,Slope_x_PE,hN2_x_PE) & !$OMP private(drdiA,drdiB,drdkL,drdkR,pres_u,T_u,S_u, & !$OMP drho_dT_u,drho_dS_u,hg2A,hg2B,hg2L,hg2R,haA, & +!$OMP drho_dT_dT_u,scrap, & !$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz, & !$OMP drdx,mag_grad2,Slope,slope2_Ratio_u,hN2_u, & !$OMP Sfn_unlim_u,drdi_u,drdkDe_u,h_harm,c2_h_u, & @@ -768,7 +831,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV endif calc_derivatives = use_EOS .and. (k >= nk_linear) .and. & - (find_work .or. .not. present_slope_x .or. CS%use_FGNV_streamfn) + (find_work .or. .not. present_slope_x .or. CS%use_FGNV_streamfn .or. use_Stanley) ! Calculate the zonal fluxes and gradients. if (calc_derivatives) then @@ -777,8 +840,15 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV 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, (is-IsdB+1)-1, ie-is+2, tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density_derivs(T_u, S_u, pres_u, drho_dT_u, drho_dS_u, & + tv%eqn_of_state, EOSdom_u) + endif + if (use_Stanley) then + ! The second line below would correspond to arguments + ! drho_dS_dS, drho_dS_dT, drho_dT_dT, drho_dS_dP, drho_dT_dP, & + call calculate_density_second_derivs(T_u, S_u, pres_u, & + scrap, scrap, drho_dT_dT_u, scrap, scrap, & + (is-IsdB+1)-1, ie-is+2, tv%eqn_of_state) endif do I=is-1,ie @@ -798,7 +868,12 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV elseif (find_work) then ! This is used in pure stacked SW mode drdkDe_u(I,K) = drdkR * e(i+1,j,K) - drdkL * e(i,j,K) endif - + if (use_Stanley) then + ! Correction to the horizontal density gradient due to nonlinearity in + ! the EOS rectifying SGS temperature anomalies + drdiA = drdiA + drho_dT_dT_u(I) * 0.5 * ( Tsgs2(i+1,j,k-1)-Tsgs2(i,j,k-1) ) + drdiB = drdiB + drho_dT_dT_u(I) * 0.5 * ( Tsgs2(i+1,j,k)-Tsgs2(i,j,k) ) + endif if (find_work) drdi_u(I,k) = drdiB if (k > nk_linear) then @@ -999,15 +1074,18 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV enddo ! end of j-loop ! Calculate the meridional fluxes and gradients. + EOSdom_v(:) = EOS_domain(G%HI) !$OMP parallel do default(none) shared(nz,is,ie,js,je,find_work,use_EOS,G,GV,US,pres,T,S, & !$OMP nk_linear,IsdB,tv,h,h_neglect,e,dz_neglect, & !$OMP I_slope_max2,h_neglect2,present_int_slope_v, & !$OMP int_slope_v,KH_v,vhtot,h_frac,h_avail_rsum, & !$OMP vhD,h_avail,G_scale,Work_v,CS,slope_y,cg1, & -!$OMP diag_sfn_y, diag_sfn_unlim_y,N2_floor, & -!$OMP present_slope_y,G_rho0,Slope_y_PE,hN2_y_PE) & +!$OMP diag_sfn_y,diag_sfn_unlim_y,N2_floor,EOSdom_v,& +!$OMP use_stanley, Tsgs2, & +!$OMP present_slope_y,G_rho0,Slope_y_PE,hN2_y_PE) & !$OMP private(drdjA,drdjB,drdkL,drdkR,pres_v,T_v,S_v, & !$OMP drho_dT_v,drho_dS_v,hg2A,hg2B,hg2L,hg2R,haA, & +!$OMP drho_dT_dT_v,scrap, & !$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz, & !$OMP drdy,mag_grad2,Slope,slope2_Ratio_v,hN2_v, & !$OMP Sfn_unlim_v,drdj_v,drdkDe_v,h_harm,c2_h_v, & @@ -1020,7 +1098,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV endif calc_derivatives = use_EOS .and. (k >= nk_linear) .and. & - (find_work .or. .not. present_slope_y) + (find_work .or. .not. present_slope_y .or. CS%use_FGNV_streamfn .or. use_Stanley) if (calc_derivatives) then do i=is,ie @@ -1028,8 +1106,15 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV 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, is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density_derivs(T_v, S_v, pres_v, drho_dT_v, drho_dS_v, & + tv%eqn_of_state, EOSdom_v) + endif + if (use_Stanley) then + ! The second line below would correspond to arguments + ! drho_dS_dS, drho_dS_dT, drho_dT_dT, drho_dS_dP, drho_dT_dP, & + call calculate_density_second_derivs(T_v, S_v, pres_v, & + scrap, scrap, drho_dT_dT_v, scrap, scrap, & + is, ie-is+1, tv%eqn_of_state) endif do i=is,ie if (calc_derivatives) then @@ -1048,6 +1133,12 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV elseif (find_work) then ! This is used in pure stacked SW mode drdkDe_v(i,K) = drdkR * e(i,j+1,K) - drdkL * e(i,j,K) endif + if (use_Stanley) then + ! Correction to the horizontal density gradient due to nonlinearity in + ! the EOS rectifying SGS temperature anomalies + drdjA = drdjA + drho_dT_dT_v(I) * 0.5 * ( Tsgs2(i,j+1,k-1)-Tsgs2(i,j,k-1) ) + drdjB = drdjB + drho_dT_dT_v(I) * 0.5 * ( Tsgs2(i,j+1,k)-Tsgs2(i,j,k) ) + endif if (find_work) drdj_v(i,k) = drdjB @@ -1252,6 +1343,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV 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) do j=js,je if (use_EOS) then @@ -1260,8 +1352,8 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV 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, (is-IsdB+1)-1, ie-is+2, tv%eqn_of_state, scale=US%kg_m3_to_R) + 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) @@ -1282,6 +1374,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV 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) do J=js-1,je if (use_EOS) then @@ -1290,8 +1383,8 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV 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, is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) + 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) @@ -1877,6 +1970,10 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) "streamfunction formulation, expressed as a fraction of planetary "//& "rotation, OMEGA. This should be tiny but non-zero to avoid degeneracy.", & default=1.e-15, units="nondim", do_not_log=.not.CS%use_FGNV_streamfn) + call get_param(param_file, mdl, "STANLEY_PRM_DET_COEFF", CS%Stanley_det_coeff, & + "The coefficient correlating SGS temperature variance with the mean "//& + "temperature gradient in the deterministic part of the Stanley parameterization. "//& + "Negative values disable the scheme.", units="nondim", default=-1.0) call get_param(param_file, mdl, "OMEGA", omega, & "The rotation rate of the earth.", & default=7.2921e-5, units="s-1", scale=US%T_to_s, do_not_log=.not.CS%use_FGNV_streamfn) @@ -1901,7 +1998,7 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=.true.) + default=.false.) call get_param(param_file, mdl, "MEKE_GEOMETRIC_2018_ANSWERS", CS%MEKE_GEOM_answers_2018, & "If true, use expressions in the MEKE_GEOMETRIC calculation that recover the "//& "answers from the original implementation. Otherwise, use expressions that "//& @@ -1919,7 +2016,7 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) 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=.true.) + default=.false.) if (CS%use_GME_thickness_diffuse) then call safe_alloc_ptr(CS%KH_u_GME,G%IsdB,G%IedB,G%jsd,G%jed,G%ke+1) diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index ccd85280f5..27aa43274b 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -12,6 +12,7 @@ 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 @@ -54,6 +55,7 @@ module MOM_ALE_sponge 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 @@ -169,7 +171,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, param_file, CS, data_h, nz_ integer :: i, j, k, col, total_sponge_cols, total_sponge_cols_u, total_sponge_cols_v character(len=10) :: remapScheme if (associated(CS)) then - call MOM_error(WARNING, "initialize_sponge called with an associated "// & + call MOM_error(WARNING, "initialize_ALE_sponge_fixed called with an associated "// & "control structure.") return endif @@ -202,7 +204,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, param_file, CS, data_h, nz_ default=.false., do_not_log=.true.) call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=.true.) + default=.false.) call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", CS%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 "//& @@ -254,18 +256,18 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, param_file, CS, data_h, nz_ answers_2018=CS%remap_answers_2018) call log_param(param_file, mdl, "!Total sponge columns at h points", total_sponge_cols, & - "The total number of columns where sponges are applied at h points.") + "The total number of columns where sponges are applied at h points.", like_default=.true.) if (CS%sponge_uv) then - allocate(data_hu(G%isdB:G%iedB,G%jsd:G%jed,nz_data)); data_hu(:,:,:)=0.0 - allocate(data_hv(G%isd:G%ied,G%jsdB:G%jedB,nz_data)); data_hv(:,:,:)=0.0 - allocate(Iresttime_u(G%isdB:G%iedB,G%jsd:G%jed)); Iresttime_u(:,:)=0.0 - allocate(Iresttime_v(G%isd:G%ied,G%jsdB:G%jedB)); Iresttime_v(:,:)=0.0 + allocate(data_hu(G%isdB:G%iedB,G%jsd:G%jed,nz_data)) ; data_hu(:,:,:) = 0.0 + allocate(data_hv(G%isd:G%ied,G%jsdB:G%jedB,nz_data)) ; data_hv(:,:,:) = 0.0 + allocate(Iresttime_u(G%isdB:G%iedB,G%jsd:G%jed)) ; Iresttime_u(:,:) = 0.0 + allocate(Iresttime_v(G%isd:G%ied,G%jsdB:G%jedB)) ; Iresttime_v(:,:) = 0.0 ! u points CS%num_col_u = 0 ; !CS%fldno_u = 0 - do j=CS%jsc,CS%jec; do I=CS%iscB,CS%iecB + do j=CS%jsc,CS%jec ; do I=CS%iscB,CS%iecB data_hu(I,j,:) = 0.5 * (data_h(i,j,:) + data_h(i+1,j,:)) Iresttime_u(I,j) = 0.5 * (Iresttime(i,j) + Iresttime(i+1,j)) if ((Iresttime_u(I,j)>0.0) .and. (G%mask2dCu(I,j)>0)) & @@ -274,9 +276,9 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, param_file, CS, data_h, nz_ if (CS%num_col_u > 0) then - allocate(CS%Iresttime_col_u(CS%num_col_u)) ; CS%Iresttime_col_u = 0.0 - allocate(CS%col_i_u(CS%num_col_u)) ; CS%col_i_u = 0 - allocate(CS%col_j_u(CS%num_col_u)) ; CS%col_j_u = 0 + allocate(CS%Iresttime_col_u(CS%num_col_u)) ; CS%Iresttime_col_u(:) = 0.0 + allocate(CS%col_i_u(CS%num_col_u)) ; CS%col_i_u(:) = 0 + allocate(CS%col_j_u(CS%num_col_u)) ; CS%col_j_u(:) = 0 ! pass indices, restoring time to the CS structure col = 1 @@ -284,7 +286,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, param_file, CS, data_h, nz_ if ((Iresttime_u(I,j)>0.0) .and. (G%mask2dCu(I,j)>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 + col = col + 1 endif enddo ; enddo @@ -298,7 +300,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, param_file, CS, data_h, nz_ total_sponge_cols_u = CS%num_col_u call sum_across_PEs(total_sponge_cols_u) call log_param(param_file, mdl, "!Total sponge columns at u points", total_sponge_cols_u, & - "The total number of columns where sponges are applied at u points.") + "The total number of columns where sponges are applied at u points.", like_default=.true.) ! v points CS%num_col_v = 0 ; !CS%fldno_v = 0 @@ -321,7 +323,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, param_file, CS, data_h, nz_ if ((Iresttime_v(i,J)>0.0) .and. (G%mask2dCv(i,J)>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 + col = col + 1 endif enddo ; enddo @@ -334,7 +336,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, param_file, CS, data_h, nz_ total_sponge_cols_v = CS%num_col_v call sum_across_PEs(total_sponge_cols_v) call log_param(param_file, mdl, "!Total sponge columns at v points", total_sponge_cols_v, & - "The total number of columns where sponges are applied at v points.") + "The total number of columns where sponges are applied at v points.", like_default=.true.) endif end subroutine initialize_ALE_sponge_fixed @@ -413,7 +415,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) character(len=10) :: remapScheme if (associated(CS)) then - call MOM_error(WARNING, "initialize_sponge called with an associated "// & + call MOM_error(WARNING, "initialize_ALE_sponge_varying called with an associated "// & "control structure.") return endif @@ -440,7 +442,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) default=.false., do_not_log=.true.) call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=.true.) + default=.false.) call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", CS%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 "//& @@ -482,10 +484,10 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) call initialize_remapping(CS%remap_cs, remapScheme, boundary_extrapolation=bndExtrapolation, & answers_2018=CS%remap_answers_2018) call log_param(param_file, mdl, "!Total sponge columns at h points", total_sponge_cols, & - "The total number of columns where sponges are applied at h points.") + "The total number of columns where sponges are applied at h points.", like_default=.true.) if (CS%sponge_uv) then - allocate(Iresttime_u(G%isdB:G%iedB,G%jsd:G%jed)); Iresttime_u(:,:)=0.0 - allocate(Iresttime_v(G%isd:G%ied,G%jsdB:G%jedB)); Iresttime_v(:,:)=0.0 + allocate(Iresttime_u(G%isdB:G%iedB,G%jsd:G%jed)) ; Iresttime_u(:,:) = 0.0 + allocate(Iresttime_v(G%isd:G%ied,G%jsdB:G%jedB)) ; Iresttime_v(:,:) = 0.0 ! u points CS%num_col_u = 0 ; !CS%fldno_u = 0 do j=CS%jsc,CS%jec; do I=CS%iscB,CS%iecB @@ -511,7 +513,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) total_sponge_cols_u = CS%num_col_u call sum_across_PEs(total_sponge_cols_u) call log_param(param_file, mdl, "!Total sponge columns at u points", total_sponge_cols_u, & - "The total number of columns where sponges are applied at u points.") + "The total number of columns where sponges are applied at u points.", like_default=.true.) ! v points CS%num_col_v = 0 ; !CS%fldno_v = 0 do J=CS%jscB,CS%jecB; do i=CS%isc,CS%iec @@ -536,7 +538,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) total_sponge_cols_v = CS%num_col_v call sum_across_PEs(total_sponge_cols_v) call log_param(param_file, mdl, "!Total sponge columns at v points", total_sponge_cols_v, & - "The total number of columns where sponges are applied at v points.") + "The total number of columns where sponges are applied at v points.", like_default=.true.) endif end subroutine initialize_ALE_sponge_varying @@ -576,7 +578,7 @@ subroutine set_up_ALE_sponge_field_fixed(sp_val, G, f_ptr, CS) 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 + &initialize_ALE_sponge." )') CS%fldno call MOM_error(FATAL,"set_up_ALE_sponge_field: "//mesg) endif @@ -603,8 +605,8 @@ subroutine set_up_ALE_sponge_field_varying(filename, fieldname, Time, G, GV, US, 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_(G)), & + 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). type(ALE_sponge_CS), pointer :: CS !< Sponge control structure (in/out). @@ -632,7 +634,7 @@ subroutine set_up_ALE_sponge_field_varying(filename, fieldname, Time, G, GV, US, 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 + &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 ongrid, then setup @@ -786,11 +788,11 @@ subroutine apply_ALE_sponge(h, 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_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] (in) 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_sponge (in). + !! that is set by a previous call to initialize_ALE_sponge (in). type(time_type), optional, intent(in) :: Time !< The current model date real :: damp ! The timestep times the local damping coefficient [nondim]. @@ -831,8 +833,8 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) nz_data = CS%Ref_val(m)%nz_data allocate(sp_val(G%isd:G%ied,G%jsd:G%jed,1:nz_data)) allocate(mask_z(G%isd:G%ied,G%jsd:G%jed,1:nz_data)) - sp_val(:,:,:)=0.0 - mask_z(:,:,:)=0.0 + sp_val(:,:,:) = 0.0 + mask_z(:,:,:) = 0.0 call horiz_interp_and_extrap_tracer(CS%Ref_val(m)%id, Time, 1.0, G, sp_val, mask_z, z_in, & z_edges_in, missing_value, .true., .false., .false., & spongeOnGrid=CS%SpongeDataOngrid, m_to_Z=US%m_to_Z, & @@ -999,12 +1001,173 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) 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, 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. + 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, Iresttime + real, dimension(:,:,:), allocatable :: data_h_in, data_h + real, dimension(:,:,:), allocatable :: sp_val_in, sp_val + real, dimension(:,:,:), pointer :: sp_ptr => NULL() + 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)) + allocate(Iresttime(G%isd:G%ied, G%jsd:G%jed)) + Iresttime_in(:,:) = 0.0 + + if (fixed_sponge) then + nz_data = sponge_in%nz_data + allocate(data_h_in(G_in%isd:G_in%ied, G_in%jsd:G_in%jed, nz_data)) + allocate(data_h(G%isd:G%ied, G%jsd:G%jed, nz_data)) + data_h_in(:,:,:) = 0. + endif + + ! Re-populate the 2D Iresttime and data_h 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_h(c_i, c_j, k) = sponge_in%Ref_h%p(k,c) + enddo + endif + enddo + + call rotate_array(Iresttime_in, turns, Iresttime) + if (fixed_sponge) then + call rotate_array(data_h_in, turns, data_h) + call initialize_ALE_sponge_fixed(Iresttime, G, param_file, sponge, & + data_h, nz_data) + else + call initialize_ALE_sponge_varying(Iresttime, G, param_file, sponge) + endif + + deallocate(Iresttime_in) + deallocate(Iresttime) + if (fixed_sponge) then + deallocate(data_h_in) + deallocate(data_h) + 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, sp_ptr, sponge) + + 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)%id = sponge_in%Ref_val(n)%id + 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)) + allocate(sponge%Ref_val(n)%h(nz_data, sponge_in%num_col)) + sponge%Ref_val(n)%p(:,:) = 0.0 + sponge%Ref_val(n)%h(:,:) = 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 dampling 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), pointer :: sponge !< A pointer to the control structure for this module + !! that is set by a previous call to initialize_ALE_sponge. + real, dimension(:,:,:), & + target, intent(in) :: p_old !< The previous array of target values + 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 + + 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_sponge. + !! set by a previous call to initialize_ALE_sponge. integer :: m diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index 4eaf895d9b..4d92fe419e 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -12,10 +12,13 @@ module MOM_CVMix_KPP use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_file_parser, only : openParameterBlock, closeParameterBlock use MOM_grid, only : ocean_grid_type, isPointInCell -use MOM_unit_scaling, only : unit_scale_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type use MOM_wave_interface, only : wave_parameters_CS, Get_Langmuir_Number use MOM_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 CVMix_kpp, only : CVMix_init_kpp, CVMix_put_kpp, CVMix_get_kpp_real use CVMix_kpp, only : CVMix_coeffs_kpp @@ -148,7 +151,7 @@ module MOM_CVMix_KPP real, allocatable, dimension(:,:) :: kOBL !< Level (+fraction) of OBL extent real, allocatable, dimension(:,:) :: OBLdepthprev !< previous Depth (positive) of OBL [m] real, allocatable, dimension(:,:) :: La_SL !< Langmuir number used in KPP - real, allocatable, dimension(:,:,:) :: dRho !< Bulk difference in density [kg m-3] + real, allocatable, dimension(:,:,:) :: dRho !< Bulk difference in density [R ~> kg m-3] real, allocatable, dimension(:,:,:) :: Uz2 !< Square of bulk difference in resolved velocity [m2 s-2] real, allocatable, dimension(:,:,:) :: BulkRi !< Bulk Richardson number for each layer (dimensionless) real, allocatable, dimension(:,:,:) :: sigma !< Sigma coordinate (dimensionless) @@ -168,6 +171,10 @@ module MOM_CVMix_KPP 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 @@ -188,7 +195,7 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive, Waves) type(wave_parameters_CS), optional, pointer :: Waves !< Wave CS ! Local variables -#include "version_variable.h" +# include "version_variable.h" character(len=40) :: mdl = 'MOM_CVMix_KPP' !< name of this module character(len=20) :: string !< local temporary string logical :: CS_IS_ONE=.false. !< Logical for setting Cs based on Non-local @@ -198,8 +205,9 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive, Waves) '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/') + '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.", & @@ -225,11 +233,17 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive, Waves) '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 '// & @@ -475,7 +489,8 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive, Waves) 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') + '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') CS%id_BulkRi = register_diag_field('ocean_model', 'KPP_BulkRi', diag%axesTL, Time, & @@ -577,6 +592,8 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive, Waves) if (CS%id_EnhK > 0) allocate( CS%EnhK( SZI_(G), SZJ_(G), SZK_(G)+1 ) ) if (CS%id_EnhK > 0) CS%EnhK(:,:,:) = 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 @@ -624,7 +641,6 @@ subroutine KPP_calculate(CS, G, GV, US, h, uStar, & real :: LangEnhK ! Langmuir enhancement for mixing coefficient -#ifdef __DO_SAFETY_CHECKS__ if (CS%debug) then call hchksum(h, "KPP in: h",G%HI,haloshift=0, scale=GV%H_to_m) call hchksum(uStar, "KPP in: uStar",G%HI,haloshift=0, scale=US%Z_to_m*US%s_to_T) @@ -632,12 +648,12 @@ subroutine KPP_calculate(CS, G, GV, US, h, uStar, & call hchksum(Kt, "KPP in: Kt",G%HI,haloshift=0, scale=US%Z2_T_to_m2_s) call hchksum(Ks, "KPP in: Ks",G%HI,haloshift=0, scale=US%Z2_T_to_m2_s) endif -#endif nonLocalTrans(:,:) = 0.0 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) & @@ -858,13 +874,12 @@ subroutine KPP_calculate(CS, G, GV, US, h, uStar, & enddo ! i enddo ! j + call cpu_clock_end(id_clock_KPP_calc) -#ifdef __DO_SAFETY_CHECKS__ if (CS%debug) then call hchksum(Kt, "KPP out: Kt", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) call hchksum(Ks, "KPP out: Ks", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) endif -#endif ! send diagnostics to post_data if (CS%id_OBLdepth > 0) call post_data(CS%id_OBLdepth, CS%OBLdepth, CS%diag) @@ -885,7 +900,7 @@ end subroutine KPP_calculate !> Compute OBL depth -subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, EOS, uStar, buoyFlux, Waves) +subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFlux, Waves) ! Arguments type(KPP_CS), pointer :: CS !< Control structure @@ -897,7 +912,7 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, EOS, uStar, buoyF real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: Salt !< Salinity [ppt] real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: u !< Velocity i-component [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: v !< Velocity j-component [L T-1 ~> m s-1] - type(EOS_type), pointer :: EOS !< Equation of state + 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_(G)+1), intent(in) :: buoyFlux !< Surface buoyancy flux [L2 T-3 ~> m2 s-3] type(wave_parameters_CS), optional, pointer :: Waves !< Wave CS @@ -908,20 +923,21 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, EOS, uStar, buoyF real, dimension( G%ke+1 ) :: iFaceHeight ! Interface heights referenced to surface [m] (negative in ocean) real, dimension( G%ke+1 ) :: N2_1d ! Brunt-Vaisala frequency squared, at interfaces [s-2] real, dimension( G%ke ) :: Ws_1d ! Profile of vertical velocity scale for scalars [m s-1] - real, dimension( G%ke ) :: deltaRho ! delta Rho in numerator of Bulk Ri number + real, dimension( G%ke ) :: deltaRho ! delta Rho in numerator of Bulk Ri number [R ~> kg m-3] real, dimension( G%ke ) :: deltaU2 ! square of delta U (shear) in denominator of Bulk Ri [m2 s-2] real, dimension( G%ke ) :: surfBuoyFlux2 real, dimension( G%ke ) :: BulkRi_1d ! Bulk Richardson number for each layer ! for EOS calculation - real, dimension( 3*G%ke ) :: rho_1D - real, dimension( 3*G%ke ) :: pres_1D + real, dimension( 3*G%ke ) :: rho_1D ! A column of densities [R ~> kg m-3] + real, dimension( 3*G%ke ) :: pres_1D ! A column of pressures [R L2 T-2 ~> Pa] real, dimension( 3*G%ke ) :: Temp_1D real, dimension( 3*G%ke ) :: Salt_1D real :: surfFricVel, surfBuoyFlux, Coriolis - real :: GoRho ! Gravitational acceleration divided by density in MKS units [m4 s-2] - real :: pRef, rho1, rhoK, Uk, Vk, sigma, sigmaRatio + real :: GoRho ! Gravitational acceleration divided by density in MKS units [m R-1 s-2 ~> m4 kg-1 s-2] + real :: pRef ! The interface pressure [R L2 T-2 ~> Pa] + real :: rho1, rhoK, Uk, Vk, sigma, sigmaRatio real :: zBottomMinusOffset ! Height of bottom plus a little bit [m] real :: SLdepth_0d ! Surface layer depth = surf_layer_ext*OBLdepth. @@ -948,30 +964,30 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, EOS, uStar, buoyF real :: WST -#ifdef __DO_SAFETY_CHECKS__ if (CS%debug) then call hchksum(Salt, "KPP in: S",G%HI,haloshift=0) call hchksum(Temp, "KPP in: T",G%HI,haloshift=0) call hchksum(u, "KPP in: u",G%HI,haloshift=0) call hchksum(v, "KPP in: v",G%HI,haloshift=0) endif -#endif + + call cpu_clock_begin(id_clock_KPP_compute_BLD) ! some constants - GoRho = GV%mks_g_Earth / (US%R_to_kg_m3*GV%Rho0) + GoRho = US%L_T_to_m_s**2*US%m_to_Z * GV%g_Earth / GV%Rho0 buoy_scale = US%L_to_m**2*US%s_to_T**3 ! loop over horizontal points on processor - !GOMP parallel do default(none) private(surfFricVel, iFaceHeight, hcorr, dh, cellHeight, & - !GOMP surfBuoyFlux, U_H, V_H, u, v, Coriolis, pRef, SLdepth_0d, & - !GOMP ksfc, surfHtemp, surfHsalt, surfHu, surfHv, surfHuS, & - !GOMP surfHvS, hTot, delH, surftemp, surfsalt, surfu, surfv, & - !GOMP surfUs, surfVs, Uk, Vk, deltaU2, km1, kk, pres_1D, & - !GOMP Temp_1D, salt_1D, surfBuoyFlux2, MLD_GUESS, LA, rho_1D, & - !GOMP deltarho, N2_1d, ws_1d, LangEnhVT2, enhvt2, wst, & - !GOMP BulkRi_1d, zBottomMinusOffset) & - !GOMP shared(G, GV, CS, US, uStar, h, buoy_scale, buoyFlux, & - !GOMP Temp, Salt, waves, EOS, GoRho) + !$OMP parallel do default(none) private(surfFricVel, iFaceHeight, hcorr, dh, cellHeight, & + !$OMP surfBuoyFlux, U_H, V_H, Coriolis, pRef, SLdepth_0d, & + !$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, & + !$OMP Temp_1D, salt_1D, surfBuoyFlux2, MLD_GUESS, LA, rho_1D, & + !$OMP deltarho, N2_1d, ws_1d, LangEnhVT2, enhvt2, wst, & + !$OMP BulkRi_1d, zBottomMinusOffset) & + !$OMP shared(G, GV, CS, US, uStar, h, buoy_scale, buoyFlux, & + !$OMP Temp, Salt, waves, tv, GoRho, u, v) do j = G%jsc, G%jec do i = G%isc, G%iec @@ -995,7 +1011,7 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, EOS, uStar, buoyF ! 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. + pRef = 0. ; if (associated(tv%p_surf)) pRef = tv%p_surf(i,j) hcorr = 0. do k=1,G%ke @@ -1084,9 +1100,9 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, EOS, uStar, buoyF 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. + ! 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%H_to_Pa * h(i,j,k) + 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)) @@ -1102,7 +1118,7 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, EOS, uStar, buoyF ! compute in-situ density - call calculate_density(Temp_1D, Salt_1D, pres_1D, rho_1D, 1, 3*G%ke, EOS) + 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. @@ -1215,86 +1231,6 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, EOS, uStar, buoyF CS%OBLdepth(i,j) = min( CS%OBLdepth(i,j), -iFaceHeight(G%ke+1) ) ! no deeper than bottom CS%kOBL(i,j) = CVMix_kpp_compute_kOBL_depth( iFaceHeight, cellHeight, CS%OBLdepth(i,j) ) -!************************************************************************* -! smg: remove code below - -! Following "correction" step has been found to be unnecessary. -! Code should be removed after further testing. -! BGR: 03/15/2018-> Restructured code (Vt2 changed to compute from call in MOM_CVMix_KPP now) -! I have not taken this restructuring into account here. -! Do we ever run with correctSurfLayerAvg? -! smg's suggested testing and removal is advised, in the meantime -! I have added warning if correctSurfLayerAvg is attempted. - ! if (CS%correctSurfLayerAvg) then - - ! SLdepth_0d = CS%surf_layer_ext * CS%OBLdepth(i,j) - ! hTot = h(i,j,1) - ! surfTemp = Temp(i,j,1) ; surfHtemp = surfTemp * hTot - ! surfSalt = Salt(i,j,1) ; surfHsalt = surfSalt * hTot - ! surfU = 0.5*US%L_T_to_m_s*(u(i,j,1)+u(i-1,j,1)) ; surfHu = surfU * hTot - ! surfV = 0.5*US%L_T_to_m_s*(v(i,j,1)+v(i,j-1,1)) ; surfHv = surfV * hTot - ! pRef = 0.0 - - ! do k = 2, G%ke - - ! ! Recalculate differences with surface layer - ! Uk = 0.5*US%L_T_to_m_s*(u(i,j,k)+u(i-1,j,k)) - surfU - ! Vk = 0.5*US%L_T_to_m_s*(v(i,j,k)+v(i,j-1,k)) - surfV - ! deltaU2(k) = Uk**2 + Vk**2 - ! pRef = pRef + GV%H_to_Pa * h(i,j,k) - ! call calculate_density(surfTemp, surfSalt, pRef, rho1, EOS) - ! call calculate_density(Temp(i,j,k), Salt(i,j,k), pRef, rhoK, EOS) - ! deltaRho(k) = rhoK - rho1 - - ! ! Surface layer averaging (needed for next k+1 iteration of this loop) - ! if (hTot < SLdepth_0d) then - ! delH = min( max(0., SLdepth_0d - hTot), h(i,j,k)*GV%H_to_m ) - ! hTot = hTot + delH - ! surfHtemp = surfHtemp + Temp(i,j,k) * delH ; surfTemp = surfHtemp / hTot - ! surfHsalt = surfHsalt + Salt(i,j,k) * delH ; surfSalt = surfHsalt / hTot - ! surfHu = surfHu + 0.5*US%L_T_to_m_s*(u(i,j,k)+u(i-1,j,k)) * delH ; surfU = surfHu / hTot - ! surfHv = surfHv + 0.5*US%L_T_to_m_s*(v(i,j,k)+v(i,j-1,k)) * delH ; surfV = surfHv / hTot - ! endif - - ! enddo - - ! BulkRi_1d = CVMix_kpp_compute_bulk_Richardson( & - ! cellHeight(1:G%ke), & ! Depth of cell center [m] - ! GoRho*deltaRho, & ! Bulk buoyancy difference, Br-B(z) [s-1] - ! deltaU2, & ! Square of resolved velocity difference [m2 s-2] - ! ws_cntr=Ws_1d, & ! Turbulent velocity scale profile [m s-1] - ! N_iface=CS%N ) ! Buoyancy frequency [s-1] - - ! surfBuoyFlux = buoy_scale*buoyFlux(i,j,1) ! This is only used in kpp_compute_OBL_depth to limit - ! ! h to Monin-Obukov (default is false, ie. not used) - - ! call CVMix_kpp_compute_OBL_depth( & - ! BulkRi_1d, & ! (in) Bulk Richardson number - ! iFaceHeight, & ! (in) Height of interfaces [m] - ! CS%OBLdepth(i,j), & ! (out) OBL depth [m] - ! CS%kOBL(i,j), & ! (out) level (+fraction) of OBL extent - ! zt_cntr=cellHeight, & ! (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 - - ! if (CS%deepOBLoffset>0.) then - ! zBottomMinusOffset = iFaceHeight(G%ke+1) + min(CS%deepOBLoffset,-0.1*iFaceHeight(G%ke+1)) - ! CS%OBLdepth(i,j) = min( CS%OBLdepth(i,j), -zBottomMinusOffset ) - ! CS%kOBL(i,j) = CVMix_kpp_compute_kOBL_depth( iFaceHeight, cellHeight, CS%OBLdepth(i,j) ) - ! 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(G%ke+1) ) ! no deep than bottom - ! CS%kOBL(i,j) = CVMix_kpp_compute_kOBL_depth( iFaceHeight, cellHeight, CS%OBLdepth(i,j) ) - - ! endif ! endif for "correction" step - -! smg: remove code above -! ********************************************************************** ! recompute wscale for diagnostics, now that we in fact know boundary layer depth !BGR consider if LTEnhancement is wanted for diagnostics @@ -1322,6 +1258,8 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, EOS, uStar, buoyF 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) @@ -1351,7 +1289,7 @@ subroutine KPP_smooth_BLD(CS,G,GV,h) real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer/level thicknesses [H ~> m or kg m-2] ! local - real, dimension(SZI_(G),SZJ_(G)) :: OBLdepth_original ! Original OBL depths computed by CVMix + real, dimension(SZI_(G),SZJ_(G)) :: OBLdepth_prev ! OBLdepth before s.th smoothing iteration real, dimension( G%ke ) :: cellHeight ! Cell center heights referenced to surface [m] ! (negative in the ocean) real, dimension( G%ke+1 ) :: iFaceHeight ! Interface heights referenced to surface [m] @@ -1359,18 +1297,22 @@ subroutine KPP_smooth_BLD(CS,G,GV,h) real :: wc, ww, we, wn, ws ! averaging weights for smoothing real :: dh ! The local thickness used for calculating interface positions [m] real :: hcorr ! A cumulative correction arising from inflation of vanished layers [m] - real :: pref integer :: i, j, k, s - do s=1,CS%n_smooth + call cpu_clock_begin(id_clock_KPP_smoothing) + + ! Update halos + call pass_var(CS%OBLdepth, G%Domain, halo=CS%n_smooth) - ! Update halos - call pass_var(CS%OBLdepth, G%Domain) + if (CS%id_OBLdepth_original > 0) CS%OBLdepth_original = CS%OBLdepth + + do s=1,CS%n_smooth - OBLdepth_original = CS%OBLdepth - if (CS%id_OBLdepth_original > 0) CS%OBLdepth_original = OBLdepth_original + OBLdepth_prev = CS%OBLdepth ! apply smoothing on OBL depth + !$OMP parallel do default(none) shared(G, GV, CS, h, 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 @@ -1378,7 +1320,6 @@ subroutine KPP_smooth_BLD(CS,G,GV,h) if (G%mask2dT(i,j)==0.) cycle iFaceHeight(1) = 0.0 ! BBL is all relative to the surface - pRef = 0. hcorr = 0. do k=1,G%ke @@ -1398,14 +1339,14 @@ subroutine KPP_smooth_BLD(CS,G,GV,h) wn = 0.125 * G%mask2dT(i,j+1) wc = 1.0 - (ww+we+wn+ws) - CS%OBLdepth(i,j) = wc * OBLdepth_original(i,j) & - + ww * OBLdepth_original(i-1,j) & - + we * OBLdepth_original(i+1,j) & - + ws * OBLdepth_original(i,j-1) & - + wn * OBLdepth_original(i,j+1) + 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),CS%OBLdepth_original(i,j)) + 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(G%ke+1) ) ! no deeper than bottom @@ -1415,46 +1356,32 @@ subroutine KPP_smooth_BLD(CS,G,GV,h) enddo ! s-loop - ! Update kOBL for smoothed OBL depths - do j = G%jsc, G%jec - do i = G%isc, G%iec - - ! skip land points - if (G%mask2dT(i,j)==0.) cycle - - iFaceHeight(1) = 0.0 ! BBL is all relative to the surface - hcorr = 0. - do k=1,G%ke - - ! cell center and cell bottom in meters (negative values in the ocean) - dh = h(i,j,k) * GV%H_to_m ! 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 - - CS%kOBL(i,j) = CVMix_kpp_compute_kOBL_depth( iFaceHeight, cellHeight, CS%OBLdepth(i,j) ) - - enddo - enddo + call cpu_clock_end(id_clock_KPP_smoothing) end subroutine KPP_smooth_BLD -!> Copies KPP surface boundary layer depth into BLD -subroutine KPP_get_BLD(CS, BLD, G) +!> 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 - real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: BLD!< bnd. layer depth [m] + 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 ! Local variables + real :: scale ! A dimensional rescaling factor integer :: i,j + + scale = US%m_to_Z ; if (present(m_to_BLD_units)) scale = 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) = CS%OBLdepth(i,j) + BLD(i,j) = scale * CS%OBLdepth(i,j) enddo ; enddo + end subroutine KPP_get_BLD !> Apply KPP non-local transport of surface fluxes for temperature. @@ -1489,6 +1416,7 @@ subroutine KPP_NonLocalTransport_temp(CS, G, GV, h, nonLocalTrans, surfFlux, & ! Update tracer due to non-local redistribution of surface flux if (CS%applyNonLocalTrans) then + !$OMP parallel do default(none) shared(dt, scalar, dtracer, G) do k = 1, G%ke do j = G%jsc, G%jec do i = G%isc, G%iec @@ -1503,6 +1431,7 @@ subroutine KPP_NonLocalTransport_temp(CS, G, GV, h, nonLocalTrans, surfFlux, & if (CS%id_NLT_dTdt > 0) call post_data(CS%id_NLT_dTdt, dtracer, CS%diag) if (CS%id_NLT_temp_budget > 0) then dtracer(:,:,:) = 0.0 + !$OMP parallel do default(none) shared(dtracer, nonLocalTrans, surfFlux, C_p, G, GV) do k = 1, G%ke do j = G%jsc, G%jec do i = G%isc, G%iec @@ -1548,6 +1477,7 @@ subroutine KPP_NonLocalTransport_saln(CS, G, GV, h, nonLocalTrans, surfFlux, dt, ! Update tracer due to non-local redistribution of surface flux if (CS%applyNonLocalTrans) then + !$OMP parallel do default(none) shared(G, dt, scalar, dtracer) do k = 1, G%ke do j = G%jsc, G%jec do i = G%isc, G%iec @@ -1562,6 +1492,7 @@ subroutine KPP_NonLocalTransport_saln(CS, G, GV, h, nonLocalTrans, surfFlux, dt, if (CS%id_NLT_dSdt > 0) call post_data(CS%id_NLT_dSdt, dtracer, CS%diag) if (CS%id_NLT_saln_budget > 0) then dtracer(:,:,:) = 0.0 + !$OMP parallel do default(none) shared(G, GV, dtracer, nonLocalTrans, surfFlux) do k = 1, G%ke do j = G%jsc, G%jec do i = G%isc, G%iec diff --git a/src/parameterizations/vertical/MOM_CVMix_conv.F90 b/src/parameterizations/vertical/MOM_CVMix_conv.F90 index ce6a40dad2..b0cac10e03 100644 --- a/src/parameterizations/vertical/MOM_CVMix_conv.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_conv.F90 @@ -76,8 +76,10 @@ logical function CVMix_conv_init(Time, G, GV, US, param_file, diag, CS) allocate(CS) ! 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") + "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. "//& @@ -154,9 +156,9 @@ subroutine calculate_CVMix_conv(h, tv, G, GV, US, CS, hbl) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure. - type(CVMix_conv_cs), pointer :: CS !< The control structure returned + type(CVMix_conv_cs), pointer :: CS !< The control structure returned !! by a previous call to CVMix_conv_init. - real, dimension(:,:), optional, pointer :: hbl!< Depth of ocean boundary layer [m] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: hbl !< Depth of ocean boundary layer [Z ~> m] ! local variables real, dimension(SZK_(G)) :: rho_lwr !< Adiabatic Water Density, this is a dummy !! variable since here convection is always @@ -168,20 +170,20 @@ subroutine calculate_CVMix_conv(h, tv, G, GV, US, CS, hbl) real, dimension(SZK_(G)+1) :: iFaceHeight !< Height of interfaces [m] real, dimension(SZK_(G)) :: cellHeight !< Height of cell centers [m] integer :: kOBL !< level of OBL extent - real :: g_o_rho0 ! Gravitational acceleration divided by density in MKS units [m4 s-2] - real :: pref, rhok, rhokm1, dz, dh, hcorr + real :: g_o_rho0 ! Gravitational acceleration divided by density times unit convserion factors + ! [Z s-2 R-1 ~> m4 s-2 kg-1] + real :: pref ! Interface pressures [R L2 T-2 ~> Pa] + real :: rhok, rhokm1 ! In situ densities of the layers above and below at the interface pressure [R ~> kg m-3] + real :: hbl_KPP ! The depth of the ocean boundary as used by KPP [m] + real :: dz ! A thickness [Z ~> m] + real :: dh, hcorr ! Two thicknesses [m] integer :: i, j, k - g_o_rho0 = GV%mks_g_Earth / (US%R_to_kg_m3*GV%Rho0) + g_o_rho0 = US%L_to_Z**2*US%s_to_T**2 * GV%g_Earth / GV%Rho0 ! initialize dummy variables rho_lwr(:) = 0.0; rho_1d(:) = 0.0 - if (.not. associated(hbl)) then - allocate(hbl(SZI_(G), SZJ_(G))) - hbl(:,:) = 0.0 - endif - do j = G%jsc, G%jec do i = G%isc, G%iec @@ -192,16 +194,16 @@ subroutine calculate_CVMix_conv(h, tv, G, GV, US, CS, hbl) ! skip calling at land points !if (G%mask2dT(i,j) == 0.) cycle - pRef = 0. + pRef = 0. ; if (associated(tv%p_surf)) pRef = tv%p_surf(i,j) ! Compute Brunt-Vaisala frequency (static stability) on interfaces do k=2,G%ke - ! pRef is pressure at interface between k and km1. - pRef = pRef + GV%H_to_Pa * 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) + ! 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) - dz = ((0.5*(h(i,j,k-1) + h(i,j,k))+GV%H_subroundoff)*GV%H_to_m) + dz = ((0.5*(h(i,j,k-1) + h(i,j,k))+GV%H_subroundoff)*GV%H_to_Z) CS%N2(i,j,k) = g_o_rho0 * (rhok - rhokm1) / dz ! Can be negative enddo @@ -210,7 +212,7 @@ subroutine calculate_CVMix_conv(h, tv, G, GV, US, CS, hbl) hcorr = 0.0 ! compute heights at cell center and interfaces do k=1,G%ke - dh = h(i,j,k) * GV%H_to_m ! Nominal thickness to use for increment + dh = h(i,j,k) * GV%H_to_m ! Nominal thickness to use for increment, in the units used by CVMix. 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 @@ -219,7 +221,8 @@ subroutine calculate_CVMix_conv(h, tv, G, GV, US, CS, hbl) enddo ! gets index of the level and interface above hbl - kOBL = CVMix_kpp_compute_kOBL_depth(iFaceHeight, cellHeight,hbl(i,j)) + hbl_KPP = US%Z_to_m*hbl(i,j) ! Convert to the units used by CVMix. + kOBL = CVMix_kpp_compute_kOBL_depth(iFaceHeight, cellHeight, hbl_KPP) kv_col(:) = 0.0 ; kd_col(:) = 0.0 call CVMix_coeffs_conv(Mdiff_out=kv_col(:), & diff --git a/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 b/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 index 1bcb6a1266..8407cca459 100644 --- a/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 @@ -79,8 +79,10 @@ logical function CVMix_ddiff_init(Time, G, GV, US, param_file, diag, CS) allocate(CS) ! 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") + "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 "//& @@ -182,13 +184,13 @@ subroutine compute_ddiff_coeffs(h, tv, G, GV, US, j, Kd_T, Kd_S, CS) ! Local variables real, dimension(SZK_(G)) :: & cellHeight, & !< Height of cell centers [m] - dRho_dT, & !< partial derivatives of density wrt temp [kg m-3 degC-1] - dRho_dS, & !< partial derivatives of density wrt saln [kg m-3 ppt-1] - pres_int, & !< pressure at each interface [Pa] + dRho_dT, & !< partial derivatives of density wrt temp [R degC-1 ~> kg m-3 degC-1] + dRho_dS, & !< partial derivatives of density wrt saln [R ppt-1 ~> kg m-3 ppt-1] + pres_int, & !< pressure at each interface [R L2 T-2 ~> Pa] temp_int, & !< temp and at interfaces [degC] salt_int, & !< salt at at interfaces [ppt] - alpha_dT, & !< alpha*dT across interfaces - beta_dS, & !< beta*dS across interfaces + alpha_dT, & !< alpha*dT across interfaces [kg m-3] + beta_dS, & !< beta*dS across interfaces [kg m-3] dT, & !< temp. difference between adjacent layers [degC] dS !< salt difference between adjacent layers [ppt] real, dimension(SZK_(G)+1) :: & @@ -197,7 +199,7 @@ subroutine compute_ddiff_coeffs(h, tv, G, GV, US, j, Kd_T, Kd_S, CS) real, dimension(SZK_(G)+1) :: iFaceHeight !< Height of interfaces [m] integer :: kOBL !< level of OBL extent - real :: pref, g_o_rho0, rhok, rhokm1, dz, dh, hcorr + real :: dh, hcorr integer :: i, k ! initialize dummy variables @@ -219,32 +221,29 @@ subroutine compute_ddiff_coeffs(h, tv, G, GV, US, j, Kd_T, Kd_S, CS) ! skip calling at land points if (G%mask2dT(i,j) == 0.) cycle - pRef = 0. - pres_int(1) = pRef + 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,G%ke + temp_int(1) = tv%T(i,j,1); salt_int(1) = tv%S(i,j,1) + do K=2,G%ke ! pressure at interface - pres_int(k) = pRef + GV%H_to_Pa * h(i,j,k-1) + 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)) + 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)) - pRef = pRef + GV%H_to_Pa * h(i,j,k-1) + 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(:), 1, & - G%ke, TV%EQN_OF_STATE) + 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,G%ke - alpha_dT(k) = -1.0*drho_dT(k) * dT(k) - beta_dS(k) = drho_dS(k) * dS(k) + 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 (CS%id_R_rho > 0.0) then diff --git a/src/parameterizations/vertical/MOM_CVMix_shear.F90 b/src/parameterizations/vertical/MOM_CVMix_shear.F90 index 6aa01d50e5..68a56d3597 100644 --- a/src/parameterizations/vertical/MOM_CVMix_shear.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_shear.F90 @@ -13,7 +13,7 @@ module MOM_CVMix_shear 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_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 @@ -36,8 +36,8 @@ module MOM_CVMix_shear real :: Nu_zero !< LMD94 maximum interior diffusivity real :: KPP_exp !< Exponent of unitless factor of diff. !! for KPP internal shear mixing scheme. - real, allocatable, dimension(:,:,:) :: N2 !< Squared Brunt-Vaisala frequency [s-2] - real, allocatable, dimension(:,:,:) :: S2 !< Squared shear frequency [s-2] + 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 real, allocatable, dimension(:,:,:) :: ri_grad_smooth !< Gradient Richardson number !! after smoothing @@ -73,16 +73,26 @@ subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, kv, G, GV, US, CS ) !! call to CVMix_shear_init. ! Local variables integer :: i, j, k, kk, km1 - real :: GoRho ! Gravitational acceleration divided by density in MKS units [m4 s-2] - real :: pref, DU, DV, dRho, DZ, N2, S2, dummy - real, dimension(2*(G%ke)) :: pres_1d, temp_1d, salt_1d, rho_1d - real, dimension(G%ke+1) :: Ri_Grad !< Gradient Richardson number + real :: GoRho ! Gravitational acceleration divided by density [Z T-2 R-1 ~> m4 s-2 kg-2] + real :: pref ! Interface pressures [R L2 T-2 ~> Pa] + real :: DU, DV ! Velocity differences [L T-1 ~> m s-1] + real :: DZ ! Grid spacing around an interface [Z ~> m] + real :: 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(2*(G%ke)) :: pres_1d ! A column of interface pressures [R L2 T-2 ~> Pa] + real, dimension(2*(G%ke)) :: temp_1d ! A column of temperatures [degC] + real, dimension(2*(G%ke)) :: salt_1d ! A column of salinities [ppt] + real, dimension(2*(G%ke)) :: rho_1d ! A column of densities at interface pressures [R ~> kg m-3] + real, dimension(G%ke+1) :: Ri_Grad !< Gradient Richardson number [nondim] real, dimension(G%ke+1) :: Kvisc !< Vertical viscosity at interfaces [m2 s-1] real, dimension(G%ke+1) :: Kdiff !< Diapycnal diffusivity at interfaces [m2 s-1] - real, parameter :: epsln = 1.e-10 !< Threshold to identify vanished layers + real :: epsln !< Threshold to identify vanished layers [H ~> m or kg m-2] ! some constants - GoRho = GV%mks_g_Earth / (US%R_to_kg_m3*GV%Rho0) + 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 do i = G%isc, G%iec @@ -91,7 +101,7 @@ subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, kv, G, GV, US, CS ) if (G%mask2dT(i,j)==0.) cycle ! Richardson number computed for each cell in a column. - pRef = 0. + 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,G%ke ! pressure, temp, and saln for EOS @@ -101,31 +111,31 @@ subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, kv, G, GV, US, CS ) 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) + 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%H_to_Pa * h(i,j,k) + pRef = pRef + (GV%g_Earth * GV%H_to_RZ) * h(i,j,k) enddo ! k-loop finishes - ! compute in-situ density - call calculate_density(Temp_1D, Salt_1D, pres_1D, rho_1D, 1, 2*G%ke, TV%EQN_OF_STATE) + ! 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, G%ke km1 = max(1, k-1) kk = 2*(k-1) - DU = US%L_T_to_m_s*(u_h(i,j,k) - u_h(i,j,km1)) - DV = US%L_T_to_m_s*(v_h(i,j,k) - v_h(i,j,km1)) - DRHO = (GoRho * (rho_1D(kk+1) - rho_1D(kk+2)) ) - DZ = ((0.5*(h(i,j,km1) + h(i,j,k))+GV%H_subroundoff)*GV%H_to_m) - N2 = DRHO/DZ - S2 = (DU*DU+DV*DV)/(DZ*DZ) - Ri_Grad(k) = max(0.,N2)/max(S2,1.e-10) + DU = u_h(i,j,k) - u_h(i,j,km1) + DV = v_h(i,j,k) - v_h(i,j,km1) + DRHO = GoRho * (rho_1D(kk+1) - rho_1D(kk+2)) + DZ = (0.5*(h(i,j,km1) + h(i,j,k))+GV%H_subroundoff)*GV%H_to_Z + N2 = DRHO / DZ + S2 = US%L_to_Z**2*(DU*DU+DV*DV)/(DZ*DZ) + Ri_Grad(k) = max(0., N2) / max(S2, 1.e-10*US%T_to_s**2) ! fill 3d arrays, if user asks for diagsnostics if (CS%id_N2 > 0) CS%N2(i,j,k) = N2 @@ -140,7 +150,7 @@ subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, kv, G, GV, US, CS ) if (CS%smooth_ri) then ! 1) fill Ri_grad in vanished layers with adjacent value do k = 2, G%ke - if (h(i,j,k) .le. epsln) Ri_grad(k) = Ri_grad(k-1) + if (h(i,j,k) <= epsln) Ri_grad(k) = Ri_grad(k-1) enddo Ri_grad(G%ke+1) = Ri_grad(G%ke) @@ -211,8 +221,11 @@ logical function CVMix_shear_init(Time, G, GV, US, param_file, diag, CS) allocate(CS) ! Set default, read and log parameters + call get_param(param_file, mdl, "USE_LMD94", CS%use_LMD94, default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "USE_PP81", CS%use_PP81, default=.false., do_not_log=.true.) call log_version(param_file, mdl, version, & - "Parameterization of shear-driven turbulence via CVMix (various options)") + "Parameterization of shear-driven turbulence via CVMix (various options)", & + all_default=.not.(CS%use_PP81.or.CS%use_LMD94)) call get_param(param_file, mdl, "USE_LMD94", CS%use_LMD94, & "If true, use the Large-McWilliams-Doney (JGR 1994) "//& "shear mixing parameterization.", default=.false.) @@ -265,13 +278,13 @@ logical function CVMix_shear_init(Time, G, GV, US, param_file, diag, CS) 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') + '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_(G)+1 ) ) ; CS%N2(:,:,:) = 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') + '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_(G)+1 ) ) ; CS%S2(:,:,:) = 0. endif diff --git a/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 b/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 index 57199f38d0..6ad6337e28 100644 --- a/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 +++ b/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 @@ -126,7 +126,7 @@ subroutine bkgnd_mixing_init(Time, G, GV, US, param_file, diag, CS) type(bkgnd_mixing_cs), pointer :: CS !< This module's control structure. ! Local variables - real :: Kv ! The interior vertical viscosity [Z2 T-1 ~> m2 s-1] - read to set prandtl + real :: Kv ! The interior vertical viscosity [Z2 T-1 ~> m2 s-1] - read to set Prandtl ! number unless it is provided as a parameter real :: prandtl_bkgnd_comp ! Kv/CS%Kd. Gets compared with user-specified prandtl_bkgnd. @@ -147,7 +147,7 @@ subroutine bkgnd_mixing_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "KD", CS%Kd, & "The background diapycnal diffusivity of density in the "//& "interior. Zero or the molecular value, ~1e-7 m2 s-1, "//& - "may be used.", units="m2 s-1", scale=US%m2_s_to_Z2_T, fail_if_missing=.true.) + "may be used.", default=0.0, units="m2 s-1", scale=US%m2_s_to_Z2_T) call get_param(param_file, mdl, "KV", Kv, & "The background kinematic viscosity in the interior. "//& @@ -445,7 +445,7 @@ subroutine calculate_bkgnd_mixing(h, tv, N2_lay, Kd_lay, Kv, j, G, GV, US, CS) elseif ((.not. CS%Bryan_Lewis_diffusivity) .and. (.not.CS%bulkmixedlayer) .and. & (.not. CS%horiz_varying_background) .and. (CS%Kd /= CS%Kdml)) then - I_Hmix = 1.0 / CS%Hmix + I_Hmix = 1.0 / (CS%Hmix + GV%H_subroundoff*GV%H_to_Z) do i=is,ie ; depth(i) = 0.0 ; enddo do k=1,nz ; do i=is,ie depth_c = depth(i) + 0.5*GV%H_to_Z*h(i,j,k) diff --git a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 index 00686c2bbe..079655f787 100644 --- a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 +++ b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 @@ -15,7 +15,7 @@ module MOM_bulk_mixed_layer use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type -use MOM_EOS, only : calculate_density, calculate_density_derivs +use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_domain implicit none ; private @@ -110,7 +110,6 @@ module MOM_bulk_mixed_layer !! 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 :: salt_reject_below_ML !< It true, add salt below mixed layer (layer mode only) logical :: convect_mom_bug !< If true, use code with a bug that causes a loss of momentum !! conservation during mixedlayer convection. @@ -219,7 +218,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C type(optics_type), pointer :: optics !< The structure containing the inverse of the !! vertical absorption decay scale for !! penetrating shortwave radiation [m-1]. - real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [m]. + real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [Z ~> m]. logical, intent(in) :: aggregate_FW_forcing !< If true, the net incoming and !! outgoing surface freshwater fluxes are !! combined before being applied, instead of @@ -291,9 +290,9 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C Net_salt, & ! The surface salt flux into the ocean over a time step, ppt H. 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) Pa. + ! 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 [Pa]. + ! 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 degC-1 ~> kg m-3 degC-1]. dRcv_dT, & ! Partial derivative of the coordinate variable potential @@ -352,6 +351,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C real :: dt__diag ! A recaled 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, n integer :: nsw ! The number of bands of penetrating shortwave radiation. @@ -437,6 +437,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C 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) !$OMP parallel default(shared) firstprivate(dKE_CA,cTKE,h_CA,max_BL_det,p_ref,p_ref_cv) & !$OMP private(h,u,v,h_orig,eps,T,S,opacity_band,d_ea,d_eb,R0,Rcv,ksort, & @@ -461,20 +462,20 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C enddo ; enddo if (id_clock_EOS>0) call cpu_clock_begin(id_clock_EOS) - ! Calculate an estimate of the mid-mixed layer pressure [Pa] - do i=is,ie ; p_ref(i) = 0.0 ; 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_Pa*h(i,k) + p_ref(i) = p_ref(i) + 0.5*(GV%H_to_RZ*GV%g_Earth)*h(i,k) enddo ; enddo - call calculate_density_derivs(T(:,1), S(:,1), p_ref, dR0_dT, dR0_dS, & - is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) - call calculate_density_derivs(T(:,1), S(:,1), p_ref_cv, dRcv_dT, dRcv_dS, & - is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density_derivs(T(:,1), S(:,1), p_ref, dR0_dT, dR0_dS, tv%eqn_of_state, EOSdom) + call calculate_density_derivs(T(:,1), S(:,1), p_ref_cv, dRcv_dT, dRcv_dS, tv%eqn_of_state, EOSdom) do k=1,nz - call calculate_density(T(:,k), S(:,k), p_ref, R0(:,k), is, ie-is+1, & - tv%eqn_of_state, scale=US%kg_m3_to_R) - call calculate_density(T(:,k), S(:,k), p_ref_cv, Rcv(:,k), is, & - ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density(T(:,k), S(:,k), p_ref, R0(:,k), tv%eqn_of_state, EOSdom) + call calculate_density(T(:,k), S(:,k), p_ref_cv, Rcv(:,k), tv%eqn_of_state, EOSdom) enddo if (id_clock_EOS>0) call cpu_clock_end(id_clock_EOS) @@ -590,7 +591,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C CS%ML_depth(i,j) = h(i,0) * GV%H_to_m ! Rescale the diagnostic. enddo ; endif if (associated(Hml)) then ; do i=is,ie - Hml(i,j) = G%mask2dT(i,j) * (h(i,0) * GV%H_to_m) ! Rescale the diagnostic for output. + Hml(i,j) = G%mask2dT(i,j) * (h(i,0) * GV%H_to_Z) ! Rescale the diagnostic for output. enddo ; endif ! At this point, return water to the original layers, but constrained to @@ -3437,7 +3438,7 @@ subroutine bulkmixedlayer_init(Time, G, GV, US, param_file, diag, CS) "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) + "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 "//& @@ -3577,7 +3578,7 @@ subroutine bulkmixedlayer_init(Time, G, GV, US, param_file, diag, CS) 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=.true.) + "during mixedlayer convection.", default=.false.) call get_param(param_file, mdl, "ALLOW_CLOCKS_IN_OMP_LOOPS", & CS%allow_clocks_in_omp_loops, & diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index a7dbe6298e..8a256bebd6 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -8,7 +8,7 @@ module MOM_diabatic_aux 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 +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 @@ -30,8 +30,9 @@ module MOM_diabatic_aux #include public diabatic_aux_init, diabatic_aux_end -public make_frazil, adjust_salt, insert_brine, differential_diffuse_T_S, triDiagTS -public find_uv_at_h, diagnoseMLDbyDensityDifference, diagnoseMLDbyEnergy, applyBoundaryFluxesInOut, set_pen_shortwave +public make_frazil, adjust_salt, differential_diffuse_T_S, triDiagTS +public find_uv_at_h, diagnoseMLDbyDensityDifference, applyBoundaryFluxesInOut, set_pen_shortwave +public diagnoseMLDbyEnergy ! 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 @@ -110,16 +111,17 @@ subroutine make_frazil(h, tv, G, GV, US, CS, p_surf, halo) 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 [Pa]. + 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 [degC]. - ps ! pressure + ps ! Surface pressure [R L2 T-2 ~> Pa] real, dimension(SZI_(G),SZK_(G)) :: & - pressure ! The pressure at the middle of each layer [Pa]. + 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 degC-1 ~> J m-2 degC-1]. logical :: T_fr_set ! True if the freezing point has been calculated for a ! row of points. @@ -134,10 +136,11 @@ subroutine make_frazil(h, tv, G, GV, US, CS, p_surf, halo) 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(none) shared(is,ie,js,je,CS,G,GV,h,nz,tv,p_surf) & -!$OMP private(fraz_col,T_fr_set,T_freeze,hc,ps) & -!$OMP firstprivate(pressure) !pressure might be set above, so should be firstprivate + !$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 @@ -148,11 +151,11 @@ subroutine make_frazil(h, tv, G, GV, US, CS, p_surf, halo) if (CS%pressure_dependent_frazil) then do i=is,ie - pressure(i,1) = ps(i) + (0.5*GV%H_to_Pa)*h(i,j,1) + 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*GV%H_to_Pa) * (h(i,j,k) + h(i,j,k-1)) + (0.5*H_to_RL2_T2) * (h(i,j,k) + h(i,j,k-1)) enddo ; enddo endif @@ -161,7 +164,7 @@ subroutine make_frazil(h, tv, G, GV, US, CS, p_surf, halo) do i=is,ie ; if (tv%frazil(i,j) > 0.0) then if (.not.T_fr_set) then call calculate_TFreeze(tv%S(i:,j,1), pressure(i:,1), T_freeze(i:), & - 1, ie-i+1, tv%eqn_of_state) + 1, ie-i+1, tv%eqn_of_state, pres_scale=US%RL2_T2_to_Pa) T_fr_set = .true. endif @@ -187,19 +190,19 @@ subroutine make_frazil(h, tv, G, GV, US, CS, p_surf, halo) ((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:,j,k), pressure(i:,k), T_freeze(i:), & - 1, ie-i+1, tv%eqn_of_state) + 1, ie-i+1, tv%eqn_of_state, pres_scale=US%RL2_T2_to_Pa) 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) then + if (h(i,j,k) <= 10.0*(GV%Angstrom_H + GV%H_subroundoff)) then ! Very thin layers should not be cooled by the frazil flux. if (tv%T(i,j,k) < T_freeze(i)) then fraz_col(i) = fraz_col(i) + hc * (T_freeze(i) - tv%T(i,j,k)) tv%T(i,j,k) = T_freeze(i) endif - else - if (fraz_col(i) + hc * (T_freeze(i) - tv%T(i,j,k)) <= 0.0) then + elseif ((fraz_col(i) > 0.0) .or. (tv%T(i,j,k) < T_freeze(i))) then + if (fraz_col(i) + hc * (T_freeze(i) - tv%T(i,j,k)) < 0.0) then tv%T(i,j,k) = tv%T(i,j,k) - fraz_col(i) / hc fraz_col(i) = 0.0 else @@ -380,129 +383,6 @@ subroutine adjust_salt(h, tv, G, GV, CS, halo) end subroutine adjust_salt -!> Insert salt from brine rejection into the first layer below the mixed layer -!! which both contains mass and in which the change in layer density remains -!! stable after the addition of salt via brine rejection. -subroutine insert_brine(h, tv, G, GV, US, fluxes, nkmb, CS, dt, id_brine_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 - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - 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(forcing), intent(in) :: fluxes !< A structure of thermodynamic surface fluxes - integer, intent(in) :: nkmb !< The number of layers in the mixed and buffer layers - type(diabatic_aux_CS), intent(in) :: CS !< The control structure returned by a previous - !! call to diabatic_aux_init - real, intent(in) :: dt !< The thermodynamic time step [T ~> s]. - integer, intent(in) :: id_brine_lay !< The handle for a diagnostic of - !! which layer receivees the brine. - - ! local variables - real :: salt(SZI_(G)) ! The amount of salt rejected from sea ice [ppt R Z ~> gramSalt m-2] - real :: dzbr(SZI_(G)) ! Cumulative depth over which brine is distributed [H ~> m to kg m-2] - real :: inject_layer(SZI_(G),SZJ_(G)) ! diagnostic - - real :: p_ref_cv(SZI_(G)) - real :: T(SZI_(G),SZK_(G)) - real :: S(SZI_(G),SZK_(G)) - real :: h_2d(SZI_(G),SZK_(G)) ! A 2-d slice of h with a minimum thickness [H ~> m to kg m-2] - real :: Rcv(SZI_(G),SZK_(G)) - real :: s_new,R_new,t0,scale, cdz - integer :: i, j, k, is, ie, js, je, nz, ks - - real :: brine_dz ! minumum thickness over which to distribute brine [H ~> m or kg m-2] - real, parameter :: s_max = 45.0 ! salinity bound - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke - - if (.not.associated(fluxes%salt_flux)) return - - !### Injecting the brine into a single layer with a prescribed thickness seems problematic, - ! because it is not convergent when resolution becomes very fine. I think that this whole - ! subroutine needs to be revisited.- RWH - - p_ref_cv(:) = tv%P_ref - brine_dz = 1.0*GV%m_to_H - - inject_layer(:,:) = nz - - do j=js,je - - salt(:)=0.0 ; dzbr(:)=0.0 - - do i=is,ie ; if (G%mask2dT(i,j) > 0.) then - salt(i) = dt * (1000. * fluxes%salt_flux(i,j)) - endif ; enddo - - do k=1,nz - do i=is,ie - T(i,k) = tv%T(i,j,k) ; S(i,k) = tv%S(i,j,k) - ! avoid very small thickness - h_2d(i,k) = MAX(h(i,j,k), GV%Angstrom_H) - enddo - - call calculate_density(T(:,k), S(:,k), p_ref_cv, Rcv(:,k), is, & - ie-is+1, tv%eqn_of_state) - enddo - - ! First, try to find an interior layer where inserting all the salt - ! will not cause the layer to become statically unstable. - ! Bias towards deeper layers. - - do k=nkmb+1,nz-1 ; do i=is,ie - if ((G%mask2dT(i,j) > 0.0) .and. dzbr(i) < brine_dz .and. salt(i) > 0.) then - s_new = S(i,k) + salt(i) / (GV%H_to_RZ * h_2d(i,k)) - t0 = T(i,k) - call calculate_density(t0, s_new, tv%P_Ref, R_new, tv%eqn_of_state) - if (R_new < 0.5*(Rcv(i,k)+Rcv(i,k+1)) .and. s_new 0.0) .and. dzbr(i) < brine_dz .and. salt(i) > 0.) then - dzbr(i) = dzbr(i) + h_2d(i,k) - inject_layer(i,j) = min(inject_layer(i,j), real(k)) - endif - enddo ; enddo - - ! finally if unable to find a layer to insert, then place in mixed layer - - do k=1,GV%nkml ; do i=is,ie - if ((G%mask2dT(i,j) > 0.0) .and. dzbr(i) < brine_dz .and. salt(i) > 0.) then - dzbr(i) = dzbr(i) + h_2d(i,k) - inject_layer(i,j) = min(inject_layer(i,j), real(k)) - endif - enddo ; enddo - - - do i=is,ie - if ((G%mask2dT(i,j) > 0.0) .and. salt(i) > 0.) then - ! if (dzbr(i)< brine_dz) call MOM_error(FATAL,"insert_brine: failed") - ks = inject_layer(i,j) - cdz = 0.0 - do k=ks,nz - scale = h_2d(i,k) / dzbr(i) - cdz = cdz + h_2d(i,k) - !### I think that the logic of this line is wrong. Moving it down a line - ! would seem to make more sense. - RWH - if (cdz > brine_dz) exit - tv%S(i,j,k) = tv%S(i,j,k) + scale*salt(i) / (GV%H_to_RZ * h_2d(i,k)) - enddo - endif - enddo - - enddo - - if (CS%id_brine_lay > 0) call post_data(CS%id_brine_lay, inject_layer, CS%diag) - -end subroutine insert_brine - !> 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) @@ -515,9 +395,9 @@ subroutine triDiagTS(G, GV, is, ie, js, je, hold, ea, eb, T, S) real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: hold !< The layer thicknesses before entrainment, !! [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: ea !< The amount of fluid entrained from the layer - !! above within this time step [H ~> m or kg m-2]. + !! above within this time step [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: eb !< The amount of fluid entrained from the layer - !! below within this time step [H ~> m or kg m-2]. + !! below within this time step [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: T !< Layer potential temperatures [degC]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: S !< Layer salinities [ppt]. @@ -734,7 +614,7 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, ! Local variables real, dimension(SZI_(G)) :: deltaRhoAtKm1, deltaRhoAtK ! Density differences [R ~> kg m-3]. - real, dimension(SZI_(G)) :: pRef_MLD, pRef_N2 ! Reference pressures [Pa]. + real, dimension(SZI_(G)) :: pRef_MLD, pRef_N2 ! Reference pressures [R L2 T-2 ~> Pa]. real, dimension(SZI_(G)) :: H_subML, dH_N2 ! Summed thicknesses used in N2 calculation [H ~> m]. real, dimension(SZI_(G)) :: T_subML, T_deeper ! Temperatures used in the N2 calculation [degC]. real, dimension(SZI_(G)) :: S_subML, S_deeper ! Salinities used in the N2 calculation [ppt]. @@ -750,6 +630,7 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, real :: dH_subML ! Depth below ML over which to diagnose stratification [H ~> 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_N2 = -1 ; if (PRESENT(id_N2subML)) id_N2 = id_N2subML @@ -762,10 +643,10 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke pRef_MLD(:) = 0.0 + EOSdom(:) = EOS_domain(G%HI) do j=js,je do i=is,ie ; dK(i) = 0.5 * h(i,j,1) * GV%H_to_Z ; enddo ! Depth of center of surface layer - call calculate_density(tv%T(:,j,1), tv%S(:,j,1), pRef_MLD, rhoSurf, is, ie-is+1, & - tv%eqn_of_state, scale=US%kg_m3_to_R) + 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. @@ -806,8 +687,7 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, ! 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, is, ie-is+1, & - tv%eqn_of_state, scale=US%kg_m3_to_R) + 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) @@ -824,16 +704,14 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, enddo if (id_N2>0) then ! Now actually calculate stratification, N2, below the mixed layer. - do i=is,ie ; pRef_N2(i) = GV%H_to_Pa * (H_subML(i) + 0.5*dH_N2(i)) ; enddo + do i=is,ie ; pRef_N2(i) = (GV%g_Earth * GV%H_to_RZ) * (H_subML(i) + 0.5*dH_N2(i)) ; enddo ! if ((.not.N2_region_set(i)) .and. (dH_N2(i) > 0.5*dH_subML)) then ! ! Use whatever stratification we can, measured over whatever distance is available? ! T_deeper(i) = tv%T(i,j,nz) ; S_deeper(i) = tv%S(i,j,nz) ! N2_region_set(i) = .true. ! endif - call calculate_density(T_subML, S_subML, pRef_N2, rho_subML, is, ie-is+1, & - tv%eqn_of_state, scale=US%kg_m3_to_R) - call calculate_density(T_deeper, S_deeper, pRef_N2, rho_deeper, is, ie-is+1, & - tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density(T_subML, S_subML, pRef_N2, rho_subML, tv%eqn_of_state, EOSdom) + call calculate_density(T_deeper, S_deeper, pRef_N2, rho_deeper, tv%eqn_of_state, EOSdom) do i=is,ie ; if ((G%mask2dT(i,j)>0.5) .and. N2_region_set(i)) then subMLN2(i,j) = gE_rho0 * (rho_deeper(i) - rho_subML(i)) / (GV%H_to_z * dH_N2(i)) endif ; enddo @@ -1082,9 +960,9 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t real :: RivermixConst ! A constant used in implementing river mixing [R Z2 T-1 ~> Pa s]. real, dimension(SZI_(G)) :: & - d_pres, & ! pressure change across a layer [Pa] - p_lay, & ! average pressure in a layer [Pa] - pres, & ! pressure at an interface [Pa] + 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 @@ -1094,7 +972,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! [ppt H ~> ppt m or ppt kg m-2] nonpenSW, & ! non-downwelling SW, which is absorbed at ocean surface ! [degC H ~> degC m or degC kg m-2] - SurfPressure, & ! Surface pressure (approximated as 0.0) [Pa] + SurfPressure, & ! Surface pressure (approximated as 0.0) [R L2 T-2 ~> Pa] dRhodT, & ! change in density per change in temperature [R degC-1 ~> kg m-3 degC-1] dRhodS, & ! change in density per change in salinity [R ppt-1 ~> kg m-3 ppt-1] netheat_rate, & ! netheat but for dt=1 [degC H T-1 ~> degC m s-1 or degC kg m-2 s-1] @@ -1126,29 +1004,27 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! [Z T-2 R-1 ~> m4 s-2 kg-1] logical :: calculate_energetics logical :: calculate_buoyancy + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, j, is, ie, js, je, k, nz, n, nb - integer :: start, npts character(len=45) :: mesg is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke - ! Only apply forcing if fluxes%sw is associated. - if (.not.associated(fluxes%sw)) return - -#define _OLD_ALG_ Idt = 1.0 / dt calculate_energetics = (present(cTKE) .and. present(dSV_dT) .and. present(dSV_dS)) calculate_buoyancy = present(SkinBuoyFlux) if (calculate_buoyancy) SkinBuoyFlux(:,:) = 0.0 + if (present(cTKE)) cTKE(:,:,:) = 0.0 g_Hconv2 = (US%L_to_Z**2*GV%g_Earth * GV%H_to_RZ) * GV%H_to_RZ + EOSdom(:) = EOS_domain(G%HI) + + ! Only apply forcing if fluxes%sw is associated. + if (.not.associated(fluxes%sw) .and. .not.calculate_energetics) return - if (present(cTKE)) cTKE(:,:,:) = 0.0 if (calculate_buoyancy) then SurfPressure(:) = 0.0 - GoRho = US%L_to_Z**2*GV%g_Earth / GV%Rho0 - start = 1 + G%isc - G%isd - npts = 1 + G%iec - G%isc + GoRho = US%L_to_Z**2*GV%g_Earth / GV%Rho0 endif ! H_limit_fluxes is used by extractFluxes1d to scale down fluxes if the total @@ -1165,8 +1041,8 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t !$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, & - !$OMP calculate_buoyancy,netPen_rate,SkinBuoyFlux,GoRho, & + !$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 private(opacityBand,h2d,T2d,netMassInOut,netMassOut, & !$OMP netHeat,netSalt,Pen_SW_bnd,fractionOfForcing, & @@ -1176,7 +1052,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t !$OMP netmassinout_rate,netheat_rate,netsalt_rate, & !$OMP drhodt,drhods,pen_sw_bnd_rate, & !$OMP pen_TKE_2d,Temp_in,Salin_in,RivermixConst) & - !$OMP firstprivate(start,npts,SurfPressure) + !$OMP firstprivate(SurfPressure) do j=js,je ! Work in vertical slices for efficiency @@ -1185,26 +1061,34 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t h2d(i,k) = h(i,j,k) T2d(i,k) = tv%T(i,j,k) enddo ; enddo - if (nsw>0) call extract_optics_slice(optics, j, G, GV, opacity=opacityBand, opacity_scale=(1.0/GV%m_to_H)) if (calculate_energetics) then ! The partial derivatives of specific volume with temperature and ! salinity need to be precalculated to avoid having heating of ! tiny layers give nonsensical values. - do i=is,ie ; pres(i) = 0.0 ; enddo ! Add surface pressure? + 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%H_to_Pa * h2d(i,k) + 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), is, ie-is+1, tv%eqn_of_state, scale=US%R_to_kg_m3) + 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) call extract_optics_slice(optics, j, G, GV, opacity=opacityBand, opacity_scale=(1.0/GV%m_to_H)) + ! The surface forcing is contained in the fluxes type. ! We aggregate the thermodynamic forcing for a time step into the following: ! netMassInOut = surface water fluxes [H ~> m or kg m-2] over time step @@ -1540,8 +1424,9 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t do i=is,ie ; do nb=1,nsw ; netPen_rate(i) = netPen_rate(i) + pen_SW_bnd_rate(nb,i) ; enddo ; enddo ! Density derivatives - call calculate_density_derivs(T2d(:,1), tv%S(:,j,1), SurfPressure, & - dRhodT, dRhodS, start, npts, tv%eqn_of_state, scale=US%kg_m3_to_R) + if (associated(tv%p_surf)) then ; do i=is,ie ; SurfPressure(i) = tv%p_surf(i,j) ; enddo ; endif + call calculate_density_derivs(T2d(:,1), tv%S(:,j,1), SurfPressure, dRhodT, dRhodS, & + tv%eqn_of_state, EOSdom) ! 1. Adjust netSalt to reflect dilution effect of FW flux ! 2. Add in the SW heating for purposes of calculating the net ! surface buoyancy flux affecting the top layer. diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 9d37e9874c..1afaf2911f 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -12,7 +12,7 @@ module MOM_diabatic_driver 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, insert_brine, differential_diffuse_T_S, triDiagTS +use MOM_diabatic_aux, only : make_frazil, adjust_salt, differential_diffuse_T_S, triDiagTS use MOM_diabatic_aux, only : find_uv_at_h, diagnoseMLDbyDensityDifference, applyBoundaryFluxesInOut use MOM_diabatic_aux, only : diagnoseMLDbyEnergy use MOM_diabatic_aux, only : set_pen_shortwave @@ -35,8 +35,7 @@ module MOM_diabatic_driver 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_end, entrain_diffusive_CS -use MOM_EOS, only : calculate_density, calculate_TFreeze -use MOM_EOS, only : calculate_specific_vol_derivs +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 @@ -55,6 +54,7 @@ module MOM_diabatic_driver use MOM_CVMix_KPP, only : KPP_NonLocalTransport_temp, KPP_NonLocalTransport_saln 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_set_diffusivity, only : set_diffusivity, set_BBL_TKE use MOM_set_diffusivity, only : set_diffusivity_init, set_diffusivity_end @@ -156,7 +156,6 @@ module MOM_diabatic_driver integer :: halo_TS_diff = 0 !< The temperature, salinity and thickness halo size that !! must be valid for the diffusivity calculations. logical :: useKPP = .false. !< use CVMix/KPP diffusivities and non-local transport - logical :: salt_reject_below_ML !< If true, add salt below mixed layer (layer mode only) 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. @@ -178,7 +177,7 @@ module MOM_diabatic_driver integer :: id_Tdif = -1, id_Tadv = -1, id_Sdif = -1, id_Sadv = -1 integer :: id_MLD_003 = -1, id_MLD_0125 = -1, id_MLD_user = -1, id_mlotstsq = -1 integer :: id_MLD_EN25 = -1, id_MLD_EN2500 = -1, id_MLD_EN250000 = -1 - integer :: id_subMLN2 = -1, id_brine_lay = -1 + integer :: id_subMLN2 = -1 ! diagnostic for fields prior to applying diapycnal physics integer :: id_u_predia = -1, id_v_predia = -1, id_h_predia = -1 @@ -258,7 +257,7 @@ module MOM_diabatic_driver !> 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, WAVES) + G, GV, US, 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_(G)), intent(inout) :: u !< zonal velocity [L T-1 ~> m s-1] @@ -266,7 +265,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & real, dimension(SZI_(G),SZJ_(G),SZK_(G)), 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 [m] + 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 !< vertical viscosities, BBL properies, and @@ -278,6 +277,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & 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(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. type(Wave_parameters_CS), optional, pointer :: Waves !< Surface gravity waves ! local variables @@ -324,7 +324,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & call diapyc_energy_req_test(h, dt, tv, G, GV, US, CS%diapyc_en_rec_CSp) call cpu_clock_begin(id_clock_set_diffusivity) - call set_BBL_TKE(u, v, h, fluxes, visc, G, GV, US, CS%set_diff_CSp) + call set_BBL_TKE(u, v, h, 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. @@ -354,7 +354,6 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & 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 (BDM). call set_int_tide_input(u, v, h, tv, fluxes, CS%int_tide_input, dt, G, GV, US, & @@ -458,7 +457,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim real, dimension(SZI_(G),SZJ_(G),SZK_(G)), 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 [m] + 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 !< vertical viscosities, BBL properies, and @@ -570,9 +569,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim 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) ; eatr(i,j,k) = 0.0 ; ebtr(i,j,k) = 0.0 enddo ; enddo ; enddo - endif - if (CS%use_geothermal) then call cpu_clock_begin(id_clock_geothermal) call geothermal(h, tv, dt, eatr, ebtr, G, GV, US, CS%geothermal_CSp, halo=CS%halo_TS_diff) call cpu_clock_end(id_clock_geothermal) @@ -608,6 +605,8 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim call cpu_clock_begin(id_clock_set_diffusivity) ! Sets: Kd_lay, Kd_int, visc%Kd_extra_T, visc%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) call set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, CS%optics, & visc, dt, G, GV, US, CS%set_diff_CSp, Kd_lay, Kd_int) call cpu_clock_end(id_clock_set_diffusivity) @@ -663,16 +662,14 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim CS%KPP_buoy_flux, CS%KPP_temp_flux, CS%KPP_salt_flux) ! The KPP scheme calculates boundary layer diffusivities and non-local transport. - call KPP_compute_BLD(CS%KPP_CSp, G, GV, US, h, tv%T, tv%S, u, v, tv%eqn_of_state, & + call KPP_compute_BLD(CS%KPP_CSp, G, GV, US, h, tv%T, tv%S, u, v, tv, & fluxes%ustar, CS%KPP_buoy_flux, Waves=Waves) call KPP_calculate(CS%KPP_CSp, G, GV, US, h, fluxes%ustar, CS%KPP_buoy_flux, Kd_heat, & Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves) if (associated(Hml)) then - !$OMP parallel default(shared) - call KPP_get_BLD(CS%KPP_CSp, Hml(:,:), G) - !$OMP end parallel + 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(:,:) @@ -1241,7 +1238,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, real, dimension(SZI_(G),SZJ_(G),SZK_(G)), 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 [m] + 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 !< vertical viscosities, BBL properies, and @@ -1394,6 +1391,8 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, call cpu_clock_begin(id_clock_set_diffusivity) ! Sets: Kd_lay, Kd_int, visc%Kd_extra_T, visc%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) call set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, CS%optics, & visc, dt, G, GV, US,CS%set_diff_CSp, Kd_lay, Kd_int) call cpu_clock_end(id_clock_set_diffusivity) @@ -1448,16 +1447,14 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, CS%KPP_buoy_flux, CS%KPP_temp_flux, CS%KPP_salt_flux) ! The KPP scheme calculates boundary layer diffusivities and non-local transport. - call KPP_compute_BLD(CS%KPP_CSp, G, GV, US, h, tv%T, tv%S, u, v, tv%eqn_of_state, & + call KPP_compute_BLD(CS%KPP_CSp, G, GV, US, h, tv%T, tv%S, u, v, tv, & fluxes%ustar, CS%KPP_buoy_flux, Waves=Waves) call KPP_calculate(CS%KPP_CSp, G, GV, US, h, fluxes%ustar, CS%KPP_buoy_flux, Kd_heat, & Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves) if (associated(Hml)) then - !$OMP parallel default(shared) - call KPP_get_BLD(CS%KPP_CSp, Hml(:,:), G) - !$OMP end parallel + 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(:,:) @@ -1921,7 +1918,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e real, dimension(SZI_(G),SZJ_(G),SZK_(G)), 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 [m] + 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 !< vertical viscosities, BBL properies, and @@ -1985,9 +1982,8 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e 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 which defines the coordinate - ! variable, set to P_Ref [Pa]. + 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 @@ -2020,6 +2016,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e 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, m, halo integer :: ig, jg ! global indices for testing testing itide point source (BDM) @@ -2086,10 +2083,6 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e call bulkmixedlayer(h, u_h, v_h, tv, fluxes, dt*CS%ML_mix_first, & eaml,ebml, G, GV, US, CS%bulkmixedlayer_CSp, CS%optics, & Hml, CS%aggregate_FW_forcing, dt, last_call=.false.) - if (CS%salt_reject_below_ML) & - call insert_brine(h, tv, G, GV, US, fluxes, nkmb, CS%diabatic_aux_CSp, & - dt*CS%ML_mix_first, CS%id_brine_lay) - 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_CSp, CS%optics, & @@ -2137,6 +2130,8 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e if (associated(tv%T)) 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 + if (CS%debug) & + call MOM_state_chksum("before set_diffusivity", u, v, h, G, GV, US, haloshift=CS%halo_TS_diff) call set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, CS%optics, & visc, dt, G, GV, US, CS%set_diff_CSp, Kd_lay, Kd_int) call cpu_clock_end(id_clock_set_diffusivity) @@ -2183,14 +2178,14 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e enddo ; enddo ; enddo endif - call KPP_compute_BLD(CS%KPP_CSp, G, GV, US, h, tv%T, tv%S, u, v, tv%eqn_of_state, & + call KPP_compute_BLD(CS%KPP_CSp, G, GV, US, h, tv%T, tv%S, u, v, tv, & fluxes%ustar, CS%KPP_buoy_flux, Waves=Waves) call KPP_calculate(CS%KPP_CSp, G, GV, US, h, fluxes%ustar, CS%KPP_buoy_flux, Kd_heat, & Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves) if (associated(Hml)) then - call KPP_get_BLD(CS%KPP_CSp, Hml(:,:), G) + 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(:,:) @@ -2284,11 +2279,8 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e endif - ! This block sets ea, eb from Kd or Kd_int. - ! Otherwise, call entrainment_diffusive() which sets ea and eb - ! based on KD and target densities (ie. does remapping as well). - ! When not using ALE, calculate layer entrainments/detrainments from - ! diffusivities and differences between layer and target densities + ! 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 @@ -2482,10 +2474,6 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e G, GV, US, CS%bulkmixedlayer_CSp, CS%optics, & Hml, CS%aggregate_FW_forcing, dt, last_call=.true.) - if (CS%salt_reject_below_ML) & - call insert_brine(h, tv, G, GV, US, fluxes, nkmb, CS%diabatic_aux_CSp, dt_mix, & - CS%id_brine_lay) - ! 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 @@ -2688,10 +2676,11 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e ! Layer mode sponge if (CS%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), & - is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density(tv%T(:,j,1), tv%S(:,j,1), p_ref_cv, Rcv_ml(:,j), & + tv%eqn_of_state, EOSdom) enddo call apply_sponge(h, dt, G, GV, US, ea, eb, CS%sponge_CSp, Rcv_ml) else @@ -2868,8 +2857,8 @@ 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) +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) type(diabatic_CS), 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 @@ -2882,6 +2871,8 @@ subroutine extract_diabatic_member(CS, opacity_CSp, optics_CSp, evap_CFL_limit, !! and freshwater fluxes are applied [H ~> 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. ! Pointers to control structures if (present(opacity_CSp)) opacity_CSp => CS%opacity_CSp @@ -2892,6 +2883,7 @@ subroutine extract_diabatic_member(CS, opacity_CSp, optics_CSp, evap_CFL_limit, ! Constants within diabatic_CS if (present(evap_CFL_limit)) evap_CFL_limit = CS%evap_CFL_limit if (present(minimum_forcing_depth)) minimum_forcing_depth = CS%minimum_forcing_depth + if (present(diabatic_halo)) diabatic_halo = CS%halo_TS_diff end subroutine extract_diabatic_member @@ -3211,7 +3203,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di 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 - real :: Kd + real :: Kd ! A diffusivity used in the default for other tracer diffusivities, in MKS units [m2 s-1] integer :: num_mode logical :: use_temperature, differentialDiffusion @@ -3245,7 +3237,8 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di ! Set default, read and log parameters call log_version(param_file, mdl, version, & - "The following parameters are used for diabatic processes.") + "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.", & @@ -3342,7 +3335,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di "KD_MIN_TR were operating.", default=.true.) if (CS%mix_boundary_tracers) then - call get_param(param_file, mdl, "KD", Kd, fail_if_missing=.true.) + call get_param(param_file, mdl, "KD", Kd, default=0.0) 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. "//& @@ -3398,13 +3391,13 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di if (CS%use_int_tides) then CS%id_cg1 = register_diag_field('ocean_model', 'cn1', diag%axesT1, & - Time, 'First baroclinic mode (eigen) speed', 'm s-1') + Time, 'First baroclinic mode (eigen) speed', 'm s-1', conversion=US%L_T_to_m_s) allocate(CS%id_cn(CS%nMode)) ; CS%id_cn(:) = -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') + 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 endif @@ -3513,17 +3506,6 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di 'set DOUBLE_DIFFUSION=False and USE_CVMIX_DDIFF=True.') endif - call get_param(param_file, mdl, "SALT_REJECT_BELOW_ML", CS%salt_reject_below_ML, & - "If true, place salt from brine rejection below the mixed layer, "// & - "into the first non-vanished layer for which the column remains stable", & - default=.false.) - - if (CS%salt_reject_below_ML) then - CS%id_brine_lay = register_diag_field('ocean_model', 'brine_layer', diag%axesT1, Time, & - 'Brine insertion layer', 'none') - endif - - ! diagnostics for tendencies of temp and saln due to diabatic processes ! available only for ALE algorithm. ! diagnostics for tendencies of temp and heat due to frazil @@ -3704,7 +3686,8 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di ! False. CS%use_CVMix_conv = CVMix_conv_init(Time, G, GV, US, param_file, diag, CS%CVMix_conv_csp) - call entrain_diffusive_init(Time, G, GV, US, param_file, diag, CS%entrain_diffusive_CSp) + call entrain_diffusive_init(Time, G, GV, US, param_file, diag, CS%entrain_diffusive_CSp, & + just_read_params=CS%useALEalgorithm) ! initialize the geothermal heating module if (CS%use_geothermal) & @@ -3779,12 +3762,10 @@ subroutine diabatic_driver_end(CS) call entrain_diffusive_end(CS%entrain_diffusive_CSp) call set_diffusivity_end(CS%set_diff_CSp) - if (CS%useKPP) then + if (CS%useKPP) then deallocate( CS%KPP_buoy_flux ) deallocate( CS%KPP_temp_flux ) deallocate( CS%KPP_salt_flux ) - endif - if (CS%useKPP) then deallocate( CS%KPP_NLTheat ) deallocate( CS%KPP_NLTscalar ) call KPP_end(CS%KPP_CSp) diff --git a/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 b/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 index fd8d19aa61..a83b18bf2f 100644 --- a/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 +++ b/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 @@ -130,7 +130,7 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & !! [Z2 T-1 ~> m2 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 [W m-2]. + !! 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. @@ -147,9 +147,9 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & ! for other bits of code. real, dimension(GV%ke) :: & - p_lay, & ! Average pressure of a layer [Pa]. - dSV_dT, & ! Partial derivative of specific volume with temperature [m3 kg-1 degC-1]. - dSV_dS, & ! Partial derivative of specific volume with salinity [m3 kg-1 ppt-1]. + p_lay, & ! Average pressure of a layer [R L2 T-2 ~> Pa]. + dSV_dT, & ! Partial derivative of specific volume with temperature [R-1 degC-1 ~> m3 kg-1 degC-1]. + dSV_dS, & ! Partial derivative of specific volume with salinity [R-1 ppt-1 ~> m3 kg-1 ppt-1]. T0, S0, & ! Initial temperatures and salinities [degC] and [ppt]. Te, Se, & ! Running incomplete estimates of the new temperatures and salinities [degC] and [ppt]. Te_a, Se_a, & ! Running incomplete estimates of the new temperatures and salinities [degC] and [ppt]. @@ -166,8 +166,8 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & ! mixing effects with other yet lower layers [degC 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 [ppt H ~> ppt m or ppt kg m-2]. - dT_to_dPE, & ! Partial derivative of column potential energy with the temperature - dS_to_dPE, & ! and salinity changes within a layer [J m-2 degC-1] and [J m-2 ppt-1]. + dT_to_dPE, & ! Partial derivative of column potential energy with the temperature and salinity + dS_to_dPE, & ! changes within a layer [R Z L2 T-2 degC-1 ~> J m-2 degC-1] and [R Z L2 T-2 ppt-1 ~> J m-2 ppt-1]. dT_to_dColHt, & ! Partial derivatives of the total column height with the temperature dS_to_dColHt, & ! and salinity changes within a layer [Z degC-1 ~> m degC-1] and [Z ppt-1 ~> m ppt-1]. dT_to_dColHt_a, & ! Partial derivatives of the total column height with the temperature @@ -179,11 +179,11 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & dT_to_dPE_a, & ! Partial derivatives of column potential energy with the temperature dS_to_dPE_a, & ! and salinity changes within a layer, including the implicit effects ! of mixing with layers higher in the water column, in - ! units of [J m-2 degC-1] and [J m-2 ppt-1]. + ! units of [R Z L2 T-2 degC-1 ~> J m-2 degC-1] and [R Z L2 T-2 ppt-1 ~> J m-2 ppt-1]. dT_to_dPE_b, & ! Partial derivatives of column potential energy with the temperature dS_to_dPE_b, & ! and salinity changes within a layer, including the implicit effects ! of mixing with layers lower in the water column, in - ! units of [J m-2 degC-1] and [J m-2 ppt-1]. + ! units of [R Z L2 T-2 degC-1 ~> J m-2 degC-1] and [R Z L2 T-2 ppt-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. @@ -195,9 +195,9 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & 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, dimension(GV%ke+1) :: & - pres, & ! Interface pressures [Pa]. + pres, & ! Interface pressures [R L2 T-2 ~> Pa]. pres_Z, & ! Interface pressures with a rescaling factor to convert interface height - ! movements into changes in column potential energy [J m-2 Z-1 ~> J m-3]. + ! movements into changes in column potential energy [R L2 T-2 m Z-1 ~> 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 @@ -211,9 +211,9 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & 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 [J m-2]. + ! 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 [J m-2]. + ! 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 :: & @@ -227,17 +227,17 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & real :: dSe_term ! A diffusivity-independent term related to the salinity ! change in the layer below the interface [ppt H ~> ppt m or ppt kg m-2]. real :: Kddt_h_guess ! A guess of the final value of Kddt_h [H ~> m or kg m-2]. - real :: dMass ! The mass per unit area within a layer [kg m-2]. - real :: dPres ! The hydrostatic pressure change across a layer [Pa]. + 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 :: 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 [J m-2 = kg s-2]. - real :: rho_here ! The in-situ density [kg m-3]. + ! the water above the interface [R Z L2 T-2 ~> J m-2 = kg s-2]. + 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 [J m-2]. + ! 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 [J m-2]. + ! 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 :: dTe_t2, dT_km1_t2, dT_k_t2 ! Temporary arrays describing temperature changes [degC]. real :: dSe_t2, dS_km1_t2, dS_k_t2 ! Temporary arrays describing salinity changes [ppt]. @@ -280,8 +280,8 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & T0(k) = T_in(k) ; S0(k) = S_in(k) h_tr(k) = h_in(k) htot = htot + h_tr(k) - pres(K+1) = pres(K) + GV%H_to_Pa * h_tr(k) - pres_Z(K+1) = US%Z_to_m * pres(K+1) + 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 @@ -298,15 +298,15 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & ! Solve the tridiagonal equations for new temperatures. - call calculate_specific_vol_derivs(T0, S0, p_lay, dSV_dT, dSV_dS, 1, nz, tv%eqn_of_state) + 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_kg_m2 * h_tr(k) - dPres = GV%H_to_Pa * h_tr(k) + 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 * US%m_to_Z * dSV_dT(k) * CS%ColHt_scaling - dS_to_dColHt(k) = dMass * US%m_to_Z * dSV_dS(k) * CS%ColHt_scaling + 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 @@ -404,7 +404,7 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & (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) + (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 @@ -550,7 +550,7 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & (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) + (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 @@ -917,7 +917,6 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & energy_Kd = 0.0 ; do K=2,nz ; energy_Kd = energy_Kd + PE_chg_k(K,1) ; enddo energy_Kd = energy_Kd / dt - K=nz if (do_print) then if (CS%id_ERt>0) call post_data(CS%id_ERt, PE_chg_k(:,1), CS%diag) @@ -997,22 +996,22 @@ subroutine find_PE_chg(Kddt_h0, dKddt_h, hp_a, hp_b, Th_a, Sh_a, Th_b, Sh_b, & 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 [J m-2 degC-1]. + !! in the temperatures of all the layers above [R Z L2 T-2 degC-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 [J m-2 ppt-1]. + !! in the salinities of all the layers above [R Z L2 T-2 ppt-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 [J m-2 degC-1]. + !! in the temperatures of all the layers below [R Z L2 T-2 degC-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 [J m-2 ppt-1]. + !! in the salinities of all the layers below [R Z L2 T-2 ppt-1 ~> J m-2 ppt-1]. real, intent(in) :: pres_Z !< The hydrostatic interface pressure, which is used to relate !! the changes in column thickness to the energy that is radiated - !! as gravity waves and unavailable to drive mixing [J m-2 Z-1 ~> J m-3]. + !! as gravity waves and unavailable to drive mixing [R L2 T-2 m Z-1 ~> 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 @@ -1031,25 +1030,25 @@ subroutine find_PE_chg(Kddt_h0, dKddt_h, hp_a, hp_b, Th_a, Sh_a, Th_b, Sh_b, & !! in the salinities of all the layers below [Z ppt-1 ~> m ppt-1]. real, optional, intent(out) :: PE_chg !< The change in column potential energy from applying - !! Kddt_h at the present interface [J m-2]. + !! 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, - !! [J m-2 H-1 ~> J m-3 or J kg-1]. + !! [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 realizedd by applying a huge value of Kddt_h at the - !! present interface [J m-2]. + !! 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 [J m-2 H-1 ~> J m-3 or J kg-1]. + !! limit where Kddt_h = 0 [R Z L2 T-2 H-1 ~> J m-3 or J kg-1]. real, optional, intent(out) :: ColHt_cor !< The correction to PE_chg that is made due to a net - !! change in the column height [J m-2]. + !! change in the column height [R Z L2 T-2 ~> J m-2]. 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 [degC H2 ~> degC m2 or degC kg2 m-4]. real :: dS_c ! The core term in the expressions for the salinity changes [psu H2 ~> psu m2 or psu kg2 m-4]. real :: PEc_core ! The diffusivity-independent core term in the expressions - ! for the potential energy changes [J m-3]. + ! for the potential energy changes [R L2 T-2 ~> J m-3]. real :: ColHt_core ! The diffusivity-independent core term in the expressions - ! for the column height changes [J m-3]. + ! for the column height changes [R L2 T-2 ~> J m-3]. real :: ColHt_chg ! The change in the column height [Z ~> m]. real :: y1 ! A local temporary term, in [H-3] or [H-4] in various contexts. @@ -1136,23 +1135,23 @@ subroutine find_PE_chg_orig(Kddt_h, h_k, b_den_1, dTe_term, dSe_term, & !! salinity change in the layer above the interface [ppt]. real, intent(in) :: pres_Z !< The hydrostatic interface pressure, which is used to relate !! the changes in column thickness to the energy that is radiated - !! as gravity waves and unavailable to drive mixing [J m-2 Z-1 ~> J m-3]. + !! as gravity waves and unavailable to drive mixing [R L2 T-2 ~> J m-3]. real, intent(in) :: dT_to_dPE_k !< A factor (pres_lay*mass_lay*dSpec_vol/dT) relating !! a layer's temperature change to the change in column !! potential energy, including all implicit diffusive changes - !! in the temperatures of all the layers below [J m-2 degC-1]. + !! in the temperatures of all the layers below [R Z L2 T-2 degC-1 ~> J m-2 degC-1]. real, intent(in) :: dS_to_dPE_k !< A factor (pres_lay*mass_lay*dSpec_vol/dS) relating !! a layer's salinity change to the change in column !! potential energy, including all implicit diffusive changes - !! in the salinities of all the layers below [J m-2 ppt-1]. + !! in the salinities of all the layers below [R Z L2 T-2 ppt-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 [J m-2 degC-1]. + !! in the temperatures of all the layers above [R Z L2 T-2 degC-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 [J m-2 ppt-1]. + !! in the salinities of all the layers above [R Z L2 T-2 ppt-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 @@ -1171,14 +1170,14 @@ subroutine find_PE_chg_orig(Kddt_h, h_k, b_den_1, dTe_term, dSe_term, & !! in the salinities of all the layers above [Z ppt-1 ~> m ppt-1]. real, optional, intent(out) :: PE_chg !< The change in column potential energy from applying - !! Kddt_h at the present interface [J m-2]. + !! 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, - !! [J m-2 H-1 ~> J m-3 or J kg-1]. + !! [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 [J m-2]. + !! 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 [J m-2 H-1 ~> J m-3 or J kg-1]. + !! limit where Kddt_h = 0 [R Z L2 T-2 H-1 ~> J m-3 or J kg-1]. ! This subroutine determines the total potential energy change due to mixing ! at an interface, including all of the implicit effects of the prescribed @@ -1302,13 +1301,17 @@ subroutine diapyc_energy_req_init(Time, G, GV, US, param_file, diag, CS) "place of any that might be passed in as an argument.", default=.false.) CS%id_ERt = register_diag_field('ocean_model', 'EnReqTest_ERt', diag%axesZi, Time, & - "Diffusivity Energy Requirements, top-down", "J m-2") + "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") + "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") + "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") + "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, & @@ -1318,13 +1321,17 @@ subroutine diapyc_energy_req_init(Time, G, GV, US, param_file, diag, CS) 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") + "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") + "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") + "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") + "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") CS%id_Tf = register_diag_field('ocean_model', 'EnReqTest_Tf', diag%axesZL, Time, & diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 7ba477466e..5a9e67bfd9 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -4,6 +4,7 @@ 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 @@ -17,8 +18,6 @@ module MOM_energetic_PBL use MOM_verticalGrid, only : verticalGrid_type use MOM_wave_interface, only: wave_parameters_CS, Get_Langmuir_Number -! use MOM_EOS, only : calculate_density, calculate_density_derivs - implicit none ; private #include @@ -35,12 +34,12 @@ module MOM_energetic_PBL type, public :: energetic_PBL_CS ; private !/ Constants - real :: VonKar = 0.41 !< The von Karman coefficient. This should be runtime, but because - !! it is runtime in KPP and set to 0.4 it might change answers. - 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-of)*f^2 + of*4*omega^2) [nondim]. + real :: VonKar = 0.41 !< The von Karman coefficient. This should be a runtime parameter, + !! but because it is set to 0.4 at runtime in KPP it might change answers. + 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 @@ -49,9 +48,14 @@ module MOM_energetic_PBL !! TKE produced by buoyancy. !/ Mixing Length terms - logical :: Use_MLD_iteration=.false. !< False to use old ePBL method. - logical :: MLD_iteration_guess=.false. !< False to default to guessing half the - !! ocean depth for the iteration. + 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. @@ -181,11 +185,13 @@ module MOM_energetic_PBL 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_TKE_wind = -1, id_TKE_mixing = -1 + 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 @@ -217,6 +223,8 @@ module MOM_energetic_PBL 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]. @@ -507,6 +515,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS 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_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) @@ -658,7 +667,7 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs 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 :: 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 ~> kg m-1 s-2 = Pa = J m-3]. + 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 @@ -757,12 +766,15 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs ! 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 :: FIRST_OBL ! Flag for computing "found" Mixing layer depth logical :: OBL_converged ! Flag for convergence of MLD integer :: OBL_it ! Iteration counter real :: Surface_Scale ! Surface decay scale for vstar - + logical :: calc_dT_expect ! If true calculate the expected changes in temperature and salinity. + logical :: calc_Te ! If true calculate the expected final temperature and salinity values. logical :: debug=.false. ! Change this hard-coded value for debugging. ! The following arrays are used only for debugging purposes. @@ -778,7 +790,8 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs if (.not. associated(CS)) call MOM_error(FATAL, "energetic_PBL: "//& "Module must be initialized before it is used.") - debug = .false. ; if (allocated(eCD%dT_expect) .or. allocated(eCD%dS_expect)) debug = .true. + calc_dT_expect = debug ; if (allocated(eCD%dT_expect) .or. allocated(eCD%dS_expect)) calc_dT_expect = .true. + calc_Te = (calc_dT_expect .or. (.not.CS%orig_PE_calc)) h_neglect = GV%H_subroundoff @@ -805,7 +818,7 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs 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 ! Equivalent to GV%H_to_Pa * h(k) with rescaling + 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) @@ -829,8 +842,10 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs !/The following lines are for the iteration over MLD ! max_MLD will initialized as ocean bottom depth max_MLD = 0.0 ; do k=1,nz ; max_MLD = max_MLD + h(k)*GV%H_to_Z ; enddo - !min_MLD will initialize as 0. + ! 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) @@ -1273,7 +1288,7 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs 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) + 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) @@ -1369,7 +1384,7 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs htot = htot + h(k) endif - if (debug) then + if (calc_Te) then if (k==2) then Te(1) = b1*(h(1)*T0(1)) Se(1) = b1*(h(1)*S0(1)) @@ -1381,7 +1396,7 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs enddo Kd(nz+1) = 0.0 - if (debug) then + if (calc_dT_expect) 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)) @@ -1392,7 +1407,9 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs Se(k) = Se(k) + c1(K+1)*Se(k+1) eCD%dT_expect(k) = Te(k) - T0(k) ; eCD%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)) + & @@ -1410,17 +1427,37 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs !New method uses ML_DEPTH as computed in ePBL routine MLD_found = MLD_output - if (MLD_found - CS%MLD_tol > MLD_guess) then - min_MLD = MLD_guess - elseif (abs(MLD_guess - MLD_found) < CS%MLD_tol) then + 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 - max_MLD = MLD_guess ! We know this guess was too deep + else ! We know this guess was too deep + max_MLD = MLD_guess ; dMLD_max = MLD_found - MLD_guess ! < -CS%MLD_tol endif - ! For next pass, guess average of minimum and maximum values. - !### We should try using the false position method instead of simple bisection. - MLD_guess = 0.5*(min_MLD + max_MLD) + 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 @@ -1910,19 +1947,19 @@ subroutine Mstar_Langmuir(CS, US, Abs_Coriolis, Buoyancy_Flux, UStar, BLD, Langm end subroutine Mstar_Langmuir -!> Copies the ePBL active mixed layer depth into MLD +!> 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), pointer :: CS !< Control structure for ePBL 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 [m or other units] - real, optional, intent(in) :: m_to_MLD_units !< A conversion factor to the - !! desired units for MLD + 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 ! Local variables real :: scale ! A dimensional rescaling factor integer :: i,j - scale = US%Z_to_m ; if (present(m_to_MLD_units)) scale = scale * m_to_MLD_units + scale = 1.0 ; if (present(m_to_MLD_units)) scale = US%Z_to_m * m_to_MLD_units do j=G%jsc,G%jec ; do i=G%isc,G%iec MLD(i,j) = scale*CS%ML_Depth(i,j) @@ -1991,7 +2028,7 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) "decreases the PBL diffusivity.", units="nondim", default=1.0) call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=.true.) + default=.false.) call get_param(param_file, mdl, "EPBL_2018_ANSWERS", CS%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 "//& @@ -2118,11 +2155,10 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) units="nondim", default=0.0) !/ Mixing Length Options - !### THIS DEFAULT SHOULD BECOME TRUE. 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=.false.) + "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 "//& @@ -2133,16 +2169,22 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) endif call get_param(param_file, mdl, "MLD_ITERATION_GUESS", CS%MLD_ITERATION_GUESS, & - "A logical that specifies whether or not to use the "//& - "previous timestep MLD as a first guess in the MLD iteration. "//& - "The default is false to facilitate reproducibility.", default=.false.) + "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) + 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=.true., do_not_log=.not.CS%Use_MLD_iteration) !### The default should become false. 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. For now, due to the use of bisection, the maximum number "//& + "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 @@ -2297,15 +2339,19 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) !/ Logging parameters ! This gives a minimum decay scale that is typically much less than Angstrom. CS%ustar_min = 2e-4*CS%omega*(GV%Angstrom_Z + GV%H_to_Z*GV%H_subroundoff) - call log_param(param_file, mdl, "EPBL_USTAR_MIN", CS%ustar_min*US%Z_to_m*US%s_to_T, & + call log_param(param_file, mdl, "!EPBL_USTAR_MIN", CS%ustar_min*US%Z_to_m*US%s_to_T, & "The (tiny) minimum friction velocity used within the "//& - "ePBL code, derived from OMEGA and ANGSTROM.", units="m s-1") + "ePBL code, derived from OMEGA and ANGSTROM.", units="m s-1", & + like_default=.true.) !/ Checking output flags 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, & @@ -2341,6 +2387,10 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) "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 @@ -2372,6 +2422,9 @@ subroutine energetic_PBL_end(CS) type(energetic_PBL_CS), pointer :: CS !< Energetic_PBL control structure that !! will be deallocated in this subroutine. + character(len=256) :: mesg + real :: avg_its + if (.not.associated(CS)) return if (allocated(CS%ML_depth)) deallocate(CS%ML_depth) @@ -2389,6 +2442,14 @@ subroutine energetic_PBL_end(CS) 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 + deallocate(CS) end subroutine energetic_PBL_end diff --git a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 index 0fd691e7ab..4ed0dcc6bf 100644 --- a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 +++ b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 @@ -12,7 +12,7 @@ module MOM_entrain_diffusive 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 : calculate_density, calculate_density_derivs, EOS_domain implicit none ; private @@ -29,8 +29,6 @@ module MOM_entrain_diffusive type, public :: entrain_diffusive_CS ; private logical :: bulkmixedlayer !< If true, a refined bulk mixed layer is used with !! GV%nk_rho_varies variable density mixed & buffer layers. - logical :: correct_density !< If true, the layer densities are restored toward - !! their target variables by the diapycnal mixing. 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 @@ -123,7 +121,7 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & 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) [Pa]. + 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]. @@ -174,7 +172,7 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & real :: g_2dt ! 0.5 * G_Earth / dt, times unit conversion factors ! [m3 H-2 s-2 T-1 ~> m s-3 or m7 kg-2 s-3]. real, dimension(SZI_(G)) :: & - pressure, & ! The pressure at an interface [Pa]. + 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 [degC] and [ppt]. dRho_dT, dRho_dS ! The partial derivatives of potential density with temperature and @@ -198,7 +196,8 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & logical :: do_any logical :: do_entrain_eakb ! True if buffer layer is entrained - logical :: do_i(SZI_(G)), did_i(SZI_(G)), reiterate, correct_density + 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. @@ -241,17 +240,16 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & 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)) - correct_density = (CS%correct_density .and. associated(tv%eqn_of_state)) - if (correct_density) then + 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(none) shared(is,ie,js,je,nz,Kd_Lay,G,GV,US,dt,CS,h,tv, & !$OMP kmb,Angstrom,fluxes,K2,h_neglect,tolerance, & - !$OMP ea,eb,correct_density,Kd_int,Kd_eff, & - !$OMP diff_work,g_2dt, kb_out) & + !$OMP ea,eb,Kd_int,Kd_eff,EOSdom,diff_work,g_2dt, kb_out) & !$OMP firstprivate(kb,ds_dsp1,dsp1_ds,pres,kb_min) & !$OMP private(dtKd,dtKd_int,do_i,Ent_bl,dtKd_kb,h_bl, & !$OMP I2p2dsp1_ds,grats,htot,max_eakb,I_dSkbp1, & @@ -684,7 +682,7 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & ! Calculate the layer thicknesses after the entrainment to constrain the ! corrective fluxes. - if (correct_density) then + 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)) @@ -700,8 +698,7 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & 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(is:ie,j,k), tv%S(is:ie,j,k), pres(is:ie), & - Rcv(is:ie), 1, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) + 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 @@ -784,9 +781,8 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & enddo else ! not bulkmixedlayer - do k=K2,nz-1 - call calculate_density(tv%T(is:ie,j,k), tv%S(is:ie,j,k), pres(is:ie), & - Rcv(is:ie), 1, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) + 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 @@ -813,7 +809,7 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & enddo endif - endif ! correct_density + endif ! associated(tv%eqn_of_state)) if (CS%id_Kd > 0) then Idt = GV%H_to_Z**2 / dt @@ -841,7 +837,7 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & do i=is,ie ; pressure(i) = 0.0 ; enddo endif do K=2,nz - do i=is,ie ; pressure(i) = pressure(i) + GV%H_to_Pa*h(i,j,k-1) ; enddo + 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)) @@ -851,8 +847,8 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & S_eos(i) = 0.5*(tv%S(i,j,k-1) + tv%S(i,j,k)) endif enddo - call calculate_density_derivs(T_eos, S_eos, pressure, & - dRho_dT, dRho_dS, is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) + 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. (k 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) [Pa]. + 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_(G)) :: & @@ -1077,6 +1073,7 @@ subroutine set_Ent_bl(h, dtKd_int, tv, kb, kmb, do_i, G, GV, US, CS, j, Ent_bl, ! 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 = G%ke @@ -1085,9 +1082,9 @@ subroutine set_Ent_bl(h, dtKd_int, tv, kb, kmb, do_i, G, GV, US, CS, j, Ent_bl, 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(is:ie,j,k), tv%S(is:ie,j,k), pres(is:ie), & - Rcv(is:ie), 1, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) + 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 @@ -2080,7 +2077,7 @@ 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) +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. @@ -2091,18 +2088,16 @@ subroutine entrain_diffusive_init(Time, G, GV, US, param_file, diag, CS) !! output. type(entrain_diffusive_CS), pointer :: CS !< A pointer that is set to point to the control !! structure. -! for this module -! Arguments: Time - The current model time. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. -! (in) diag - A structure that is used to regulate diagnostic output. -! (in/out) CS - A pointer that is set to point to the control structure -! for this module - real :: decay_length, dt, Kd -! This include declares and sets the variable "version". -#include "version_variable.h" + logical, optional, intent(in) :: just_read_params !< If present and true, this call will + !! only read parameters logging them or registering + !! any diagnostics + + ! Local variables + real :: dt ! The dynamics timestep, used here in the default for TOLERANCE_ENT, in MKS units [s] + real :: Kd ! A diffusivity used in the default for TOLERANCE_ENT, in MKS units [m2 s-1] + logical :: just_read ! If true, just read parameters but do nothing else. + ! This include declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mdl = "MOM_entrain_diffusive" ! This module's name. if (associated(CS)) then @@ -2112,37 +2107,38 @@ subroutine entrain_diffusive_init(Time, G, GV, US, param_file, diag, CS) endif allocate(CS) + just_read = .false. ; if (present(just_read_params)) just_read = just_read_params + CS%diag => diag CS%bulkmixedlayer = (GV%nkml > 0) ! Set default, read and log parameters - call log_version(param_file, mdl, version, "") - call get_param(param_file, mdl, "CORRECT_DENSITY", CS%correct_density, & - "If true, and USE_EOS is true, the layer densities are "//& - "restored toward their target values by the diapycnal "//& - "mixing, as described in Hallberg (MWR, 2000).", & - default=.true.) + if (.not.just_read) 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) -! In this module, KD is only used to set the default for TOLERANCE_ENT. [m2 s-1] - call get_param(param_file, mdl, "KD", Kd, fail_if_missing=.true.) + "calculate the interior diapycnal entrainment.", default=5, do_not_log=just_read) + ! In this module, KD is only used to set the default for TOLERANCE_ENT. [m2 s-1] + call get_param(param_file, mdl, "KD", Kd, default=0.0) call get_param(param_file, mdl, "DT", dt, & "The (baroclinic) dynamics time step.", units = "s", & - fail_if_missing=.true.) -! CS%Tolerance_Ent = MAX(100.0*GV%Angstrom_H,1.0e-4*sqrt(dt*Kd)) ! + fail_if_missing=.true., do_not_log=just_read) call get_param(param_file, mdl, "TOLERANCE_ENT", CS%Tolerance_Ent, & "The tolerance with which to solve for entrainment values.", & - units="m", default=MAX(100.0*GV%Angstrom_m,1.0e-4*sqrt(dt*Kd)), scale=GV%m_to_H) + units="m", default=MAX(100.0*GV%Angstrom_m,1.0e-4*sqrt(dt*Kd)), scale=GV%m_to_H, & + do_not_log=just_read) CS%Rho_sig_off = 1000.0*US%kg_m3_to_R - CS%id_Kd = register_diag_field('ocean_model', 'Kd_effective', diag%axesTL, Time, & - 'Diapycnal diffusivity as applied', 'm2 s-1', conversion=US%Z2_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) + if (.not.just_read) then + CS%id_Kd = register_diag_field('ocean_model', 'Kd_effective', diag%axesTL, Time, & + 'Diapycnal diffusivity as applied', 'm2 s-1', conversion=US%Z2_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 + + if (just_read) deallocate(CS) end subroutine entrain_diffusive_init diff --git a/src/parameterizations/vertical/MOM_full_convection.F90 b/src/parameterizations/vertical/MOM_full_convection.F90 index daf41a1ad3..3be6628b14 100644 --- a/src/parameterizations/vertical/MOM_full_convection.F90 +++ b/src/parameterizations/vertical/MOM_full_convection.F90 @@ -7,7 +7,7 @@ module MOM_full_convection use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type -use MOM_EOS, only : calculate_density_derivs +use MOM_EOS, only : calculate_density_derivs, EOS_domain implicit none ; private @@ -31,7 +31,7 @@ subroutine full_convection(G, GV, US, h, tv, T_adj, S_adj, p_surf, Kddt_smooth, intent(out) :: T_adj !< Adjusted potential temperature [degC]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(out) :: S_adj !< Adjusted salinity [ppt]. - real, dimension(:,:), pointer :: p_surf !< The pressure at the ocean surface [Pa] (or NULL). + real, dimension(:,:), pointer :: p_surf !< The pressure at the ocean surface [R L2 T-2 ~> Pa] (or NULL). real, intent(in) :: Kddt_smooth !< A smoothing vertical !! diffusivity times a timestep [H2 ~> m2 or kg2 m-4]. real, optional, intent(in) :: Kddt_convect !< A large convecting vertical @@ -335,7 +335,7 @@ subroutine smoothed_dRdT_dRdS(h, tv, Kddt, dR_dT, dR_dS, G, GV, US, j, p_surf, h !! potential density with salinity [R degC-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 [Pa]. + real, dimension(:,:), pointer :: p_surf !< The pressure at the ocean surface [R L2 T-2 ~> Pa]. integer, optional, intent(in) :: halo !< Halo width over which to compute ! Local variables @@ -345,13 +345,14 @@ subroutine smoothed_dRdT_dRdS(h, tv, Kddt, dR_dT, dR_dS, G, GV, US, j, p_surf, h real :: c1(SZI_(G),SZK_(G)) ! tridiagonal solver. real :: T_f(SZI_(G),SZK_(G)) ! Filtered temperatures [degC] real :: S_f(SZI_(G),SZK_(G)) ! Filtered salinities [ppt] - real :: pres(SZI_(G)) ! Interface pressures [Pa]. + real :: pres(SZI_(G)) ! Interface pressures [R L2 T-2 ~> Pa]. real :: T_EOS(SZI_(G)) ! Filtered and vertically averaged temperatures [degC] real :: S_EOS(SZI_(G)) ! Filtered and vertically averaged salinities [ppt] real :: kap_dt_x2 ! The product of 2*kappa*dt [H2 ~> m2 or kg2 m-4]. real :: h_neglect, h0 ! Negligible thicknesses to allow for zero thicknesses, ! [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 if (present(halo)) then @@ -407,21 +408,19 @@ subroutine smoothed_dRdT_dRdS(h, tv, Kddt, dR_dT, dR_dS, G, GV, US, j, p_surf, h else do i=is,ie ; pres(i) = 0.0 ; enddo endif - call calculate_density_derivs(T_f(:,1), S_f(:,1), pres, dR_dT(:,1), dR_dS(:,1), & - is-G%isd+1, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) - do i=is,ie ; pres(i) = pres(i) + h(i,j,1)*GV%H_to_Pa ; enddo + 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), & - is-G%isd+1, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) - do i=is,ie ; pres(i) = pres(i) + h(i,j,k)*GV%H_to_Pa ; 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), & - is-G%isd+1, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) - + tv%eqn_of_state, EOSdom) end subroutine smoothed_dRdT_dRdS diff --git a/src/parameterizations/vertical/MOM_geothermal.F90 b/src/parameterizations/vertical/MOM_geothermal.F90 index e26e126db8..66116575d5 100644 --- a/src/parameterizations/vertical/MOM_geothermal.F90 +++ b/src/parameterizations/vertical/MOM_geothermal.F90 @@ -77,7 +77,7 @@ subroutine geothermal(h, tv, dt, ea, eb, G, GV, US, CS, halo) heat_rem, & ! remaining heat [H degC ~> 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 ! coordiante densities reference pressure [Pa] + 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 [degC] and [ppt] @@ -198,8 +198,8 @@ subroutine geothermal(h, tv, dt, ea, eb, G, GV, US, CS, halo) 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(:), isj, iej-isj+1, tv%eqn_of_state, scale=US%kg_m3_to_R) + 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 @@ -245,11 +245,11 @@ subroutine geothermal(h, tv, dt, ea, eb, G, GV, US, CS, halo) 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, scale=US%kg_m3_to_R) + 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_, 1, 2, tv%eqn_of_state, scale=US%kg_m3_to_R) + 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 diff --git a/src/parameterizations/vertical/MOM_internal_tide_input.F90 b/src/parameterizations/vertical/MOM_internal_tide_input.F90 index 7a0f517020..f5b9e7dbb7 100644 --- a/src/parameterizations/vertical/MOM_internal_tide_input.F90 +++ b/src/parameterizations/vertical/MOM_internal_tide_input.F90 @@ -18,7 +18,7 @@ module MOM_int_tide_input 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, calculate_density_derivs +use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_domain implicit none ; private @@ -137,7 +137,7 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, CS) if (CS%debug) then call hchksum(N2_bot,"N2_bot",G%HI,haloshift=0, scale=US%s_to_T**2) call hchksum(itide%TKE_itidal_input,"TKE_itidal_input",G%HI,haloshift=0, & - scale=US%R_to_kg_m3*US%Z_to_m**3*US%s_to_T**3) + scale=US%RZ3_T3_to_W_m2) endif if (CS%id_TKE_itidal > 0) call post_data(CS%id_TKE_itidal, itide%TKE_itidal_input, CS%diag) @@ -167,7 +167,7 @@ subroutine find_N2_bottom(h, tv, T_f, S_f, h2, fluxes, G, GV, US, N2_bot) real, dimension(SZI_(G),SZK_(G)+1) :: & dRho_int ! The unfiltered density differences across interfaces [R ~> kg m-3]. real, dimension(SZI_(G)) :: & - pres, & ! The pressure at each interface [Pa]. + pres, & ! The pressure at each interface [R L2 T-2 ~> Pa]. Temp_int, & ! The temperature at each interface [degC]. Salin_int, & ! The salinity at each interface [ppt]. drho_bot, & ! The density difference at the bottom of a layer [R ~> kg m-3] @@ -181,17 +181,19 @@ subroutine find_N2_bottom(h, tv, T_f, S_f, h2, fluxes, G, GV, US, N2_bot) real :: G_Rho0 ! The gravitation acceleration divided by the Boussinesq ! density [Z T-2 R-1 ~> m4 s-2 kg-1]. 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 = G%ke G_Rho0 = (US%L_to_Z**2*GV%g_Earth) / GV%Rho0 + EOSdom(:) = EOS_domain(G%HI) ! Find the (limited) density jump across each interface. do i=is,ie dRho_int(i,1) = 0.0 ; dRho_int(i,nz+1) = 0.0 enddo !$OMP parallel do default(none) shared(is,ie,js,je,nz,tv,fluxes,G,GV,US,h,T_f,S_f, & -!$OMP h2,N2_bot,G_Rho0) & +!$OMP h2,N2_bot,G_Rho0,EOSdom) & !$OMP private(pres,Temp_Int,Salin_Int,dRho_dT,dRho_dS, & !$OMP hb,dRho_bot,z_from_bot,do_i,h_amp, & !$OMP do_any,dz_int) & @@ -205,12 +207,12 @@ subroutine find_N2_bottom(h, tv, T_f, S_f, h2, fluxes, G, GV, US, N2_bot) endif do K=2,nz do i=is,ie - pres(i) = pres(i) + GV%H_to_Pa*h(i,j,k-1) + 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) + T_f(i,j,k-1)) Salin_Int(i) = 0.5 * (S_f(i,j,k) + S_f(i,j,k-1)) enddo - call calculate_density_derivs(Temp_int, Salin_int, pres, & - dRho_dT(:), dRho_dS(:), is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density_derivs(Temp_int, Salin_int, pres, 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) @@ -349,7 +351,7 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) 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%kg_m3_to_R*US%m_to_Z**3*US%T_to_s**3) + 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 "//& diff --git a/src/parameterizations/vertical/MOM_kappa_shear.F90 b/src/parameterizations/vertical/MOM_kappa_shear.F90 index 0cbcf235de..9705b36543 100644 --- a/src/parameterizations/vertical/MOM_kappa_shear.F90 +++ b/src/parameterizations/vertical/MOM_kappa_shear.F90 @@ -14,14 +14,11 @@ module MOM_kappa_shear 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 : calculate_density_derivs implicit none ; private #include -#ifdef use_netCDF -#include -#endif public Calculate_kappa_shear, Calc_kappa_shear_vertex, kappa_shear_init public kappa_shear_is_used, kappa_shear_at_vertex @@ -83,6 +80,9 @@ module MOM_kappa_shear !! 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 @@ -99,9 +99,6 @@ module MOM_kappa_shear ! integer :: id_clock_project, id_clock_KQ, id_clock_avg, id_clock_setup -#undef DEBUG -#undef ADD_DIAGNOSTICS - contains !> Subroutine for calculating shear-driven diffusivity and TKE in tracer columns @@ -119,7 +116,7 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & 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 [Pa] (or NULL). + real, dimension(:,:), pointer :: p_surf !< The pressure at the ocean surface [R L2 T-2 ~> Pa] (or NULL). real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & intent(inout) :: kappa_io !< The diapycnal diffusivity at each interface !! (not layer!) [Z2 T-1 ~> m2 s-1]. Initially this is the @@ -160,7 +157,7 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & kappa_avg, & ! The time-weighted average of kappa [Z2 T-1 ~> m2 s-1]. 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 [Pa]. + real :: surface_pres ! The top surface pressure [R L2 T-2 ~> Pa]. real :: dz_in_lay ! The running sum of the thickness in a layer [Z ~> m]. real :: k0dt ! The background diffusivity times the timestep [Z2 ~> m2]. @@ -177,15 +174,6 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & ! interpolating back to the original index space [nondim]. integer :: is, ie, js, je, i, j, k, nz, nzc - ! Diagnostics that should be deleted? -#ifdef ADD_DIAGNOSTICS - real, dimension(SZK_(GV)+1) :: & ! Additional diagnostics. - I_Ld2_1d, dz_Int_1d - real, dimension(SZI_(G),SZK_(GV)+1) :: & ! 2-D versions of diagnostics. - I_Ld2_2d, dz_Int_2d - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & ! 3-D versions of diagnostics. - I_Ld2_3d, dz_Int_3d -#endif is = G%isc ; ie = G%iec; js = G%jsc ; je = G%jec ; nz = GV%ke use_temperature = .false. ; if (associated(tv%T)) use_temperature = .true. @@ -195,9 +183,6 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & dz_massless = 0.1*sqrt(k0dt) !$OMP parallel do default(private) shared(js,je,is,ie,nz,h,u_in,v_in,use_temperature,new_kappa, & -#ifdef ADD_DIAGNOSTICS - !$OMP I_Ld2_3d,dz_Int_3d, & -#endif !$OMP tv,G,GV,US,CS,kappa_io,dz_massless,k0dt,p_surf,dt,tke_io,kv_io) do j=js,je do k=1,nz ; do i=is,ie @@ -295,15 +280,9 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & do K=1,nzc+1 ; kappa(K) = kappa_2d(i,K) ; enddo endif -#ifdef ADD_DIAGNOSTICS - call kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & - dz, u0xdz, v0xdz, T0xdz, S0xdz, kappa_avg, & - tke_avg, tv, CS, GV, US, I_Ld2_1d, dz_Int_1d) -#else call kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & dz, u0xdz, v0xdz, T0xdz, S0xdz, kappa_avg, & tke_avg, tv, CS, GV, US) -#endif ! call cpu_clock_begin(id_clock_setup) ! Extrapolate from the vertically reduced grid back to the original layers. @@ -329,18 +308,10 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & endif enddo endif -#ifdef ADD_DIAGNOSTICS - do K=1,nz+1 - I_Ld2_2d(i,K) = I_Ld2_1d(K) ; dz_Int_2d(i,K) = dz_Int_1d(K) - enddo -#endif ! call cpu_clock_end(id_clock_setup) else ! Land points, still inside the i-loop. do K=1,nz+1 kappa_2d(i,K) = 0.0 ; tke_2d(i,K) = 0.0 -#ifdef ADD_DIAGNOSTICS - I_Ld2_2d(i,K) = 0.0 ; dz_Int_2d(i,K) = 0.0 -#endif enddo endif ; enddo ! i-loop @@ -348,9 +319,6 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & kappa_io(i,j,K) = G%mask2dT(i,j) * kappa_2d(i,K) tke_io(i,j,K) = G%mask2dT(i,j) * tke_2d(i,K) kv_io(i,j,K) = ( G%mask2dT(i,j) * kappa_2d(i,K) ) * CS%Prandtl_turb -#ifdef ADD_DIAGNOSTICS - I_Ld2_3d(i,j,K) = I_Ld2_2d(i,K) ; dz_Int_3d(i,j,K) = dz_Int_2d(i,K) -#endif enddo ; enddo enddo ! end of j-loop @@ -362,10 +330,6 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & if (CS%id_Kd_shear > 0) call post_data(CS%id_Kd_shear, kappa_io, CS%diag) if (CS%id_TKE > 0) call post_data(CS%id_TKE, tke_io, CS%diag) -#ifdef ADD_DIAGNOSTICS - if (CS%id_ILd2 > 0) call post_data(CS%id_ILd2, I_Ld2_3d, CS%diag) - if (CS%id_dz_Int > 0) call post_data(CS%id_dz_Int, dz_Int_3d, CS%diag) -#endif end subroutine Calculate_kappa_shear @@ -389,7 +353,7 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ 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 [Pa] + 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 @@ -430,13 +394,13 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ kappa_avg, & ! The time-weighted average of kappa [Z2 T-1 ~> m2 s-1]. 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 [Pa]. + real :: surface_pres ! The top surface pressure [R L2 T-2 ~> Pa]. real :: dz_in_lay ! The running sum of the thickness in a layer [Z ~> m]. real :: k0dt ! The background diffusivity times the timestep [Z2 ~> m2]. real :: dz_massless ! A layer thickness that is considered massless [Z ~> m]. - real :: I_hwt ! The inverse of the masked thickness weights [H-1 ~> m-1 or m2 kg-1]. - real :: I_Prandtl + real :: I_hwt ! The inverse of the masked thickness weights [H-1 ~> m-1 or m2 kg-1]. + real :: I_Prandtl ! The inverse of the turbulent Prandtl number [nondim]. logical :: use_temperature ! If true, temperature and salinity have been ! allocated and are being used as state variables. logical :: new_kappa = .true. ! If true, ignore the value of kappa from the @@ -451,14 +415,6 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ integer :: IsB, IeB, JsB, JeB, i, j, k, nz, nzc, J2, J2m1 ! Diagnostics that should be deleted? -#ifdef ADD_DIAGNOSTICS - real, dimension(SZK_(GV)+1) :: & ! Additional diagnostics. - I_Ld2_1d, dz_Int_1d - real, dimension(SZI_(G),SZK_(GV)+1) :: & ! 2-D versions of diagnostics. - I_Ld2_2d, dz_Int_2d - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & ! 3-D versions of diagnostics. - I_Ld2_3d, dz_Int_3d -#endif isB = G%isc-1 ; ieB = G%iecB ; jsB = G%jsc-1 ; jeB = G%jecB ; nz = GV%ke use_temperature = .false. ; if (associated(tv%T)) use_temperature = .true. @@ -469,10 +425,7 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ I_Prandtl = 0.0 ; if (CS%Prandtl_turb > 0.0) I_Prandtl = 1.0 / CS%Prandtl_turb !$OMP parallel do default(private) shared(jsB,jeB,isB,ieB,nz,h,u_in,v_in,use_temperature,new_kappa, & -#ifdef ADD_DIAGNOSTICS - !$OMP I_Ld2_3d,dz_Int_3d, & -#endif - !$OMP tv,G,GV,US,CS,kappa_io,dz_massless,k0dt,p_surf,dt,tke_io,kv_io) + !$OMP tv,G,GV,US,CS,kappa_io,dz_massless,k0dt,p_surf,dt,tke_io,kv_io,I_Prandtl) do J=JsB,JeB J2 = mod(J,2)+1 ; J2m1 = 3-J2 ! = mod(J-1,2)+1 @@ -584,9 +537,19 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ 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)) & - surface_pres = 0.25 * ((p_surf(i,j) + p_surf(i+1,j+1)) + & - (p_surf(i+1,j) + p_surf(i,j+1))) + 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. @@ -597,15 +560,9 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ do K=1,nzc+1 ; kappa(K) = kappa_2d(I,K,J2) ; enddo endif -#ifdef ADD_DIAGNOSTICS - call kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & - dz, u0xdz, v0xdz, T0xdz, S0xdz, kappa_avg, & - tke_avg, tv, CS, GV, US, I_Ld2_1d, dz_Int_1d) -#else call kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & dz, u0xdz, v0xdz, T0xdz, S0xdz, kappa_avg, & tke_avg, tv, CS, GV, US) -#endif ! call cpu_clock_begin(Id_clock_setup) ! Extrapolate from the vertically reduced grid back to the original layers. if (nz == nzc) then @@ -628,27 +585,16 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ endif enddo endif -#ifdef ADD_DIAGNOSTICS - do K=1,nz+1 - I_Ld2_2d(i,K) = I_Ld2_1d(K) ; dz_Int_2d(i,K) = dz_Int_1d(K) - enddo -#endif ! call cpu_clock_end(Id_clock_setup) else ! Land points, still inside the i-loop. do K=1,nz+1 kappa_2d(I,K,J2) = 0.0 ; tke_2d(I,K) = 0.0 -#ifdef ADD_DIAGNOSTICS - I_Ld2_2d(I,K) = 0.0 ; dz_Int_2d(I,K) = 0.0 -#endif enddo endif ; enddo ! i-loop do K=1,nz+1 ; do I=IsB,IeB tke_io(I,J,K) = G%mask2dBu(I,J) * tke_2d(I,K) kv_io(I,J,K) = ( G%mask2dBu(I,J) * kappa_2d(I,K,J2) ) * CS%Prandtl_turb -#ifdef ADD_DIAGNOSTICS - I_Ld2_3d(I,J,K) = I_Ld2_2d(I,K) ; dz_Int_3d(I,J,K) = dz_Int_2d(I,K) -#endif enddo ; enddo if (J>=G%jsc) then ; do K=1,nz+1 ; do i=G%isc,G%iec ! Set the diffusivities in tracer columns from the values at vertices. @@ -661,15 +607,11 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ if (CS%debug) then call hchksum(kappa_io, "kappa", G%HI, scale=US%Z2_T_to_m2_s) - call Bchksum(tke_io, "tke", G%HI) + 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) -#ifdef ADD_DIAGNOSTICS - if (CS%id_ILd2 > 0) call post_data(CS%id_ILd2, I_Ld2_3d, CS%diag) - if (CS%id_dz_Int > 0) call post_data(CS%id_dz_Int, dz_Int_3d, CS%diag) -#endif end subroutine Calc_kappa_shear_vertex @@ -679,7 +621,6 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & dz, u0xdz, v0xdz, T0xdz, S0xdz, kappa_avg, & tke_avg, tv, CS, GV, US, I_Ld2_1d, dz_Int_1d) 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)+1), & intent(inout) :: kappa !< The time-weighted average of kappa [Z2 T-1 ~> m2 s-1]. real, dimension(SZK_(GV)+1), & @@ -687,7 +628,7 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & !! 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 [Pa]. + real, intent(in) :: surface_pres !< The surface pressure [R L2 T-2 ~> Pa]. real, dimension(SZK_(GV)), & intent(in) :: dz !< The layer thickness [Z ~> m]. real, dimension(SZK_(GV)), & @@ -708,12 +649,14 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & !! 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 real, dimension(SZK_(GV)+1), & optional, intent(out) :: I_Ld2_1d !< The inverse of the squared mixing length [Z-2 ~> m-2]. real, dimension(SZK_(GV)+1), & optional, intent(out) :: dz_Int_1d !< The extent of a finite-volume space surrounding an interface, !! as used in calculating kappa and TKE [Z ~> m]. + ! 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]. @@ -741,15 +684,15 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & kappa_mid, & ! The average of the initial and predictor estimates of kappa [Z2 T-1 ~> m2 s-1]. tke_pred, & ! The value of TKE from a predictor step [Z2 T-2 ~> m2 s-2]. kappa_pred, & ! The value of kappa from a predictor step [Z2 T-1 ~> m2 s-1]. - pressure, & ! The pressure at an interface [Pa]. + pressure, & ! The pressure at an interface [R L2 T-2 ~> Pa]. T_int, & ! The temperature interpolated to an interface [degC]. Sal_int, & ! The salinity interpolated to an interface [ppt]. dbuoy_dT, & ! The partial derivatives of buoyancy with changes in temperature dbuoy_dS, & ! and salinity, [Z T-2 degC-1 ~> m s-2 degC-1] and [Z T-2 ppt-1 ~> m s-2 ppt-1]. I_L2_bdry, & ! The inverse of the square of twice the harmonic mean ! distance to the top and bottom boundaries [Z-2 ~> m-2]. - K_Q, & ! Diffusivity divided by TKE [Z2 m-2 s2 T-1 ~> s]. - K_Q_tmp, & ! A temporary copy of diffusivity divided by TKE [Z2 m-2 s2 T-1 ~> s]. + K_Q, & ! Diffusivity divided by TKE [T ~> s]. + K_Q_tmp, & ! A temporary copy of diffusivity divided by TKE [T ~> s]. local_src_avg, & ! The time-integral of the local source [nondim]. 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]. @@ -762,8 +705,8 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & real :: b1 ! The inverse of the pivot in the tridiagonal equations. real :: bd1 ! A term in the denominator of b1. real :: d1 ! 1 - c1 in the tridiagonal equations. - real :: gR0 ! A conversion factor from Z to Pa equal to Rho_0 times g - ! [Pa Z-1 = kg m-1 s-2 Z-1 ~> kg m-2 s-2]. + real :: gR0 ! A conversion factor from Z to pressure, given by Rho_0 times g + ! [R L2 T-2 Z-1 ~> kg m-2 s-2]. real :: g_R0 ! g_R0 is a rescaled version of g/Rho [Z R-1 T-2 ~> m4 kg-1 s-2]. real :: Norm ! A factor that normalizes two weights to 1 [Z-2 ~> m-2]. real :: tol_dksrc ! Tolerance for the change in the kappa source within an iteration @@ -794,26 +737,13 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & ! to estimate the maximum permitted time step. I.e., ! the resolution is 1/2^dt_refinements. integer :: k, itt, itt_dt -#ifdef DEBUG - integer :: max_debug_itt ; parameter(max_debug_itt=20) - real :: wt(SZK_(GV)+1), wt_tot, I_wt_tot, wt_itt - real, dimension(SZK_(GV)+1) :: & - Ri_k, tke_prev, dtke, dkappa, dtke_norm, & - N2_debug, & ! A version of N2 for debugging [T-2 ~> s-2] - ksrc_av ! The average through the iterations of k_src [T-1 ~> s-1]. - real, dimension(SZK_(GV)+1,0:max_debug_itt) :: & - tke_it1, N2_it1, Sh2_it1, ksrc_it1, kappa_it1, kprev_it1 - real, dimension(SZK_(GV)+1,1:max_debug_itt) :: & - dkappa_it1, wt_it1, K_Q_it1, d_dkappa_it1, dkappa_norm - real, dimension(SZK_(GV),0:max_debug_itt) :: & - u_it1, v_it1, rho_it1, T_it1, S_it1 - real, dimension(0:max_debug_itt) :: & - dk_wt_it1, dkpos_wt_it1, dkneg_wt_it1, k_mag - real, dimension(max_debug_itt) :: dt_it1 -#endif + + ! This calculation of N2 is for debugging only. + ! real, dimension(SZK_(GV)+1) :: & + ! N2_debug, & ! A version of N2 for debugging [T-2 ~> s-2] Ri_crit = CS%Rino_crit - gR0 = GV%z_to_H*GV%H_to_Pa + gR0 = GV%Rho0 * GV%g_Earth g_R0 = (US%L_to_Z**2 * GV%g_Earth) / (GV%Rho0) k0dt = dt*CS%kappa_0 @@ -910,51 +840,18 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & T_int(K) = 0.5*(T(k-1) + T(k)) Sal_int(K) = 0.5*(Sal(k-1) + Sal(k)) enddo - call calculate_density_derivs(T_int, Sal_int, pressure, dbuoy_dT, & - dbuoy_dS, 2, nzc-1, tv%eqn_of_state, scale=-g_R0*US%kg_m3_to_R) + call calculate_density_derivs(T_int, Sal_int, pressure, dbuoy_dT, dbuoy_dS, & + tv%eqn_of_state, (/2,nzc/), scale=-g_R0 ) else do K=1,nzc+1 ; dbuoy_dT(K) = -g_R0 ; dbuoy_dS(K) = 0.0 ; enddo endif -#ifdef DEBUG - N2_debug(1) = 0.0 ; N2_debug(nzc+1) = 0.0 - do K=2,nzc - N2_debug(K) = max((dbuoy_dT(K) * (T0xdz(k-1)*Idz(k-1) - T0xdz(k)*Idz(k)) + & - dbuoy_dS(K) * (S0xdz(k-1)*Idz(k-1) - S0xdz(k)*Idz(k))) * & - I_dz_int(K), 0.0) - enddo - do k=1,nzc - u_it1(k,0) = u0xdz(k)*Idz(k) ; v_it1(k,0) = v0xdz(k)*Idz(k) - T_it1(k,0) = T0xdz(k)*Idz(k) ; S_it1(k,0) = S0xdz(k)*Idz(k) - enddo - do K=1,nzc+1 - kprev_it1(K,0) = kappa(K) ; kappa_it1(K,0) = kappa(K) - tke_it1(K,0) = 0.0 - N2_it1(K,0) = N2_debug(K) ; Sh2_it1(K,0) = S2(K) ; ksrc_it1(K,0) = K_src(K) - enddo - do k=nzc+1,GV%ke - u_it1(k,0) = 0.0 ; v_it1(k,0) = 0.0 - T_it1(k,0) = 0.0 ; S_it1(k,0) = 0.0 - kprev_it1(K+1,0) = 0.0 ; kappa_it1(K+1,0) = 0.0 ; tke_it1(K+1,0) = 0.0 - N2_it1(K+1,0) = 0.0 ; Sh2_it1(K+1,0) = 0.0 ; ksrc_it1(K+1,0) = 0.0 - enddo - do itt=1,max_debug_itt - dt_it1(itt) = 0.0 - do k=1,GV%ke - u_it1(k,itt) = 0.0 ; v_it1(k,itt) = 0.0 - T_it1(k,itt) = 0.0 ; S_it1(k,itt) = 0.0 - rho_it1(k,itt) = 0.0 - enddo - do K=1,GV%ke+1 - kprev_it1(K,itt) = 0.0 ; kappa_it1(K,itt) = 0.0 ; tke_it1(K,itt) = 0.0 - N2_it1(K,itt) = 0.0 ; Sh2_it1(K,itt) = 0.0 - ksrc_it1(K,itt) = 0.0 - dkappa_it1(K,itt) = 0.0 ; wt_it1(K,itt) = 0.0 - K_Q_it1(K,itt) = 0.0 ; d_dkappa_it1(K,itt) = 0.0 - enddo - enddo - do K=1,GV%ke+1 ; ksrc_av(K) = 0.0 ; enddo -#endif + ! N2_debug(1) = 0.0 ; N2_debug(nzc+1) = 0.0 + ! do K=2,nzc + ! N2_debug(K) = max((dbuoy_dT(K) * (T0xdz(k-1)*Idz(k-1) - T0xdz(k)*Idz(k)) + & + ! dbuoy_dS(K) * (S0xdz(k-1)*Idz(k-1) - S0xdz(k)*Idz(k))) * & + ! I_dz_int(K), 0.0) + ! enddo ! This call just calculates N2 and S2. call calculate_projected_state(kappa, u, v, T, Sal, 0.0, nzc, dz, I_dz_int, & @@ -981,12 +878,6 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & ! ---------------------------------------------------- ! Calculate new values of u, v, rho, N^2 and S. ! ---------------------------------------------------- -#ifdef DEBUG - do K=1,nzc+1 - Ri_k(K) = 1e3 ; if (S2(K) > 1e-3*N2(K)) Ri_k(K) = N2(K) / S2(K) - if (itt > 1) then ; tke_prev(K) = tke(K) ; else ; tke_prev(K) = 0.0 ; endif - enddo -#endif ! call cpu_clock_begin(id_clock_KQ) call find_kappa_tke(N2, S2, kappa, Idz, dz_Int, I_L2_bdry, f2, & @@ -1099,9 +990,6 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & ! This would be here but does nothing. ! kappa_avg(K) = kappa_avg(K) + kappa_mid(K)*dt_wt tke_avg(K) = tke_avg(K) + dt_wt*tke(K) -#ifdef DEBUG - tke_pred(K) = tke(K) ; kappa_pred(K) = 0.0 ; kappa(K) = 0.0 -#endif enddo ! call cpu_clock_end(id_clock_avg) else @@ -1157,63 +1045,10 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & ! call cpu_clock_end(id_clock_project) endif -#ifdef DEBUG - if (itt <= max_debug_itt) then - dt_it1(itt) = dt_now - dk_wt_it1(itt) = 0.0 ; dkpos_wt_it1(itt) = 0.0 ; dkneg_wt_it1(itt) = 0.0 - k_mag(itt) = 0.0 - wt_itt = 1.0/real(itt) ; wt_tot = 0.0 - do K=1,nzc+1 - ksrc_av(K) = (1.0-wt_itt)*ksrc_av(K) + wt_itt*K_src(K) - wt_tot = wt_tot + dz_Int(K) * ksrc_av(K) - enddo - ! Use the 1/0=0 convention. - I_wt_tot = 0.0 ; if (wt_tot > 0.0) I_wt_tot = 1.0/wt_tot - - do K=1,nzc+1 - wt(K) = (dz_Int(K)*ksrc_av(K)) * I_wt_tot - k_mag(itt) = k_mag(itt) + wt(K)*kappa_mid(K) - dkappa_it1(K,itt) = kappa_pred(K) - kappa_out(K) - dk_wt_it1(itt) = dk_wt_it1(itt) + wt(K)*dkappa_it1(K,itt) - if (dkappa_it1(K,itt) > 0.0) then - dkpos_wt_it1(itt) = dkpos_wt_it1(itt) + wt(K)*dkappa_it1(K,itt) - else - dkneg_wt_it1(itt) = dkneg_wt_it1(itt) + wt(K)*dkappa_it1(K,itt) - endif - wt_it1(K,itt) = wt(K) - enddo - endif - do K=1,nzc+1 - Ri_k(K) = 1e3 ; if (N2(K) < 1e3 * S2(K)) Ri_k(K) = N2(K) / S2(K) - dtke(K) = tke_pred(K) - tke(K) - dtke_norm(K) = dtke(K) / (0.5*(tke(K) + tke_pred(K))) - dkappa(K) = kappa_pred(K) - kappa_out(K) - enddo - if (itt <= max_debug_itt) then - do k=1,nzc - u_it1(k,itt) = u(k) ; v_it1(k,itt) = v(k) - T_it1(k,itt) = T(k) ; S_it1(k,itt) = Sal(k) - enddo - do K=1,nzc+1 - kprev_it1(K,itt) = kappa_out(K) - kappa_it1(K,itt) = kappa_mid(K) ; tke_it1(K,itt) = 0.5*(tke(K)+tke_pred(K)) - N2_it1(K,itt)=N2(K) ; Sh2_it1(K,itt)=S2(K) - ksrc_it1(K,itt) = kappa_src(K) - K_Q_it1(K,itt) = kappa_out(K) / (TKE(K)) - if (itt > 1) then - if (abs(dkappa_it1(K,itt-1)) > 1e-20) & - d_dkappa_it1(K,itt) = dkappa_it1(K,itt) / dkappa_it1(K,itt-1) - endif - dkappa_norm(K,itt) = dkappa(K) / max(0.5*(kappa_pred(K) + kappa_out(K)), US%m2_s_to_Z2_T*1e-100) - enddo - endif -#endif - if (dt_rem <= 0.0) exit enddo ! end itt loop -#ifdef ADD_DIAGNOSTICS if (present(I_Ld2_1d)) then do K=1,GV%ke+1 ; I_Ld2_1d(K) = 0.0 ; enddo do K=2,nzc ; if (TKE(K) > 0.0) & @@ -1224,7 +1059,6 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & do K=1,nzc+1 ; dz_Int_1d(K) = dz_Int(K) ; enddo do K=nzc+2,GV%ke ; dz_Int_1d(K) = 0.0 ; enddo endif -#endif end subroutine kappa_shear_column @@ -1388,7 +1222,7 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(nz+1), intent(inout) :: K_Q !< The shear-driven diapycnal diffusivity divided by !! the turbulent kinetic energy per unit mass at - !! interfaces [Z2 m-2 s2 T-1 ~> s]. + !! interfaces [T ~> s]. 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 @@ -1398,7 +1232,7 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & 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. + ! This subroutine calculates new, consistent estimates of TKE and kappa. ! Local variables real, dimension(nz) :: & @@ -1474,18 +1308,14 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & integer :: ks_kappa, ke_kappa, ke_tke ! The ranges of k-indices that are or integer :: ks_kappa_prev, ke_kappa_prev ! were being worked on. integer :: itt, k, k2 -#ifdef DEBUG - integer :: max_debug_itt ; parameter(max_debug_itt=20) + + ! These variables are used only for debugging. + logical, parameter :: debug_soln = .false. real :: K_err_lin, Q_err_lin, TKE_src_norm real, dimension(nz+1) :: & I_Ld2_debug, & ! A separate version of I_Ld2 for debugging [Z-2 ~> m-2]. kappa_prev, & ! The value of kappa at the start of the current iteration [Z2 T-1 ~> m2 s-1]. TKE_prev ! The value of TKE at the start of the current iteration [Z2 T-2 ~> m2 s-2]. - real, dimension(nz+1,1:max_debug_itt) :: & - tke_it1, kappa_it1, kprev_it1, & ! Various values from each iteration. - dkappa_it1, K_Q_it1, d_dkappa_it1, dkappa_norm_it1 - integer :: it2 -#endif c_N2 = CS%C_N**2 ; c_S2 = CS%C_S**2 q0 = CS%TKE_bg ; kappa0 = CS%kappa_0 @@ -1529,7 +1359,7 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & ! TKE_decay(K) = c_n*sqrt(N2(K)) + c_s*sqrt(S2(K)) ! The expression in JHL. TKE_decay(K) = sqrt(c_n2*N2(K) + c_s2*S2(K)) if ((kappa(K) > 0.0) .and. (K_Q(K) > 0.0)) then - TKE(K) = kappa(K) / K_Q(K) + TKE(K) = kappa(K) / K_Q(K) ! Perhaps take the max with TKE_min else TKE(K) = TKE_min endif @@ -1564,9 +1394,7 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & ! Calculate TKE ! ---------------------------------------------------- -#ifdef DEBUG - do K=1,nz+1 ; kappa_prev(K) = kappa(K) ; TKE_prev(K) = TKE(K) ; enddo -#endif + if (debug_soln) then ; do K=1,nz+1 ; kappa_prev(K) = kappa(K) ; TKE_prev(K) = TKE(K) ; enddo ; endif if (.not.do_Newton) then ! Use separate steps of the TKE and kappa equations, that are @@ -1792,25 +1620,20 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & dQ(ke_kappa+1) = dQ(ke_kappa+1) / (1.0 - cQ(ke_kappa+2)*e1(ke_kappa+2)) TKE(ke_kappa+1) = max(TKE(ke_kappa+1) + dQ(ke_kappa+1), TKE_min) do k=ke_kappa+2,nz+1 -#ifdef DEBUG - if (K < nz+1) then + if (debug_soln .and. (K < nz+1)) then ! Ignore this source? aQ(k) = (0.5*(kappa(K)+kappa(K+1))+kappa0) * Idz(k) - tke_src_norm = (dz_Int(K) * (kappa0*S2(K) - (TKE(K)-q0)*TKE_decay(K)) - & - (aQ(k) * (TKE(K) - TKE(K+1)) - aQ(k-1) * (TKE(K-1) - TKE(K))) ) / & - (aQ(k) + (aQ(k-1) + dz_Int(K)*TKE_decay(K))) + ! tke_src_norm = (dz_Int(K) * (kappa0*S2(K) - (TKE(K)-q0)*TKE_decay(K)) - & + ! (aQ(k) * (TKE(K) - TKE(K+1)) - aQ(k-1) * (TKE(K-1) - TKE(K))) ) / & + ! (aQ(k) + (aQ(k-1) + dz_Int(K)*TKE_decay(K))) endif -#endif dK(K) = 0.0 ! Ensure that TKE+dQ will not drop below 0.5*TKE. dQ(K) = max(e1(K)*dQ(K-1),-0.5*TKE(K)) TKE(K) = max(TKE(K) + dQ(K), TKE_min) if (abs(dQ(K)) < roundoff*TKE(K)) exit enddo -#ifdef DEBUG - do K2=K+1,ke_kappa_prev+1 ; dQ(K2) = 0.0 ; dK(K2) = 0.0 ; enddo - do K=K2,nz+1 ; if (dQ(K) == 0.0) exit ; dQ(K) = 0.0 ; dK(K) = 0.0 ; enddo -#endif + if (debug_soln) then ; do K2=K+1,nz+1 ; dQ(K2) = 0.0 ; dK(K2) = 0.0 ; enddo ; endif endif if (.not. abort_Newton) then do K=ke_kappa,2,-1 @@ -1837,10 +1660,9 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & dK(1) = 0.0 endif -#ifdef DEBUG ! Check these solutions for consistency. ! The unit conversions here have not been carefully tested. - do K=2,nz + if (debug_soln) then ; do K=2,nz ! In these equations, K_err_lin and Q_err_lin should be at round-off levels ! compared with the dominant terms, perhaps, dz_Int*I_Ld2*kappa and ! dz_Int*TKE_decay*TKE. The exception is where, either 1) the decay term has been @@ -1863,8 +1685,8 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & 0.5*(TKE_prev(K)-TKE_prev(K+1))*Idz(k) * (dK(K) + dK(K+1)) - & 0.5*(TKE_prev(K)-TKE_prev(K-1))*Idz(k-1)* (dK(K-1) + dK(K)) + & dz_Int(K) * (dK(K) * (S2(K) - N2(K)) - dQ(K)*TKE_decay(K)) - enddo -#endif + enddo ; endif + endif ! End of the Newton's method solver. ! Test kappa for convergence... @@ -1904,34 +1726,10 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & do K=2,nz ; K_Q(K) = kappa(K) / max(TKE(K), TKE_min) ; enddo endif -#ifdef DEBUG - if (itt <= max_debug_itt) then - do K=1,nz+1 - kprev_it1(K,itt) = kappa_prev(K) - kappa_it1(K,itt) = kappa(K) ; tke_it1(K,itt) = tke(K) - dkappa_it1(K,itt) = kappa(K) - kappa_prev(K) - dkappa_norm_it1(K,itt) = (kappa(K) - kappa_prev(K)) / & - (kappa0 + 0.5*(kappa(K) + kappa_prev(K))) - K_Q_it1(K,itt) = kappa(K) / max(TKE(K),TKE_min) - d_dkappa_it1(K,itt) = 0.0 - if (itt > 1) then ; if (abs(dkappa_it1(K,itt-1)) > 1e-20*US%m2_s_to_Z2_T) & - d_dkappa_it1(K,itt) = dkappa_it1(K,itt) / dkappa_it1(K,itt-1) - endif - enddo - endif -#endif - if (within_tolerance) exit enddo -#ifdef DEBUG - do it2=itt+1,max_debug_itt ; do K=1,nz+1 - kprev_it1(K,it2) = 0.0 ; kappa_it1(K,it2) = 0.0 ; tke_it1(K,it2) = 0.0 - dkappa_it1(K,it2) = 0.0 ; K_Q_it1(K,it2) = 0.0 ; d_dkappa_it1(K,it2) = 0.0 - enddo ; enddo -#endif - if (do_Newton) then ! K_Q needs to be calculated. do K=1,ks_kappa-1 ; K_Q(K) = 0.0 ; enddo do K=ks_kappa,ke_kappa ; K_Q(K) = kappa(K) / TKE(K) ; enddo @@ -1959,7 +1757,7 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & end subroutine find_kappa_tke -!> This subroutineinitializesthe parameters that regulate shear-driven mixing +!> 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. @@ -1975,8 +1773,10 @@ function kappa_shear_init(Time, G, GV, US, param_file, diag, CS) ! Local variables logical :: merge_mixedlayer -! This include declares and sets the variable "version". -#include "version_variable.h" + 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. real :: kappa_0_unscaled ! The value of kappa_0 in MKS units [m2 s-1] real :: KD_normal ! The KD of the main model, read here only as a parameter @@ -1999,68 +1799,72 @@ function kappa_shear_init(Time, G, GV, US, param_file, diag, CS) ! 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") + "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.) + 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) + 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) + 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) - call get_param(param_file, mdl, "KD", KD_normal, default=1.0e-7, do_not_log=.true.) + units="nondim", default=50, do_not_log=just_read) + call get_param(param_file, mdl, "KD", KD_normal, default=0.0, do_not_log=.true.) call get_param(param_file, mdl, "KD_KAPPA_SHEAR_0", CS%kappa_0, & "The background diffusivity that is used to smooth the "//& "density and shear profiles before solving for the "//& - "diffusivities. Defaults to value of KD.", & - units="m2 s-1", default=KD_normal, scale=US%m2_s_to_Z2_T, unscaled=kappa_0_unscaled) + "diffusivities. The default is the greater of KD and 1e-7 m2 s-1.", & + units="m2 s-1", default=max(KD_normal, 1.0e-7), scale=US%m2_s_to_Z2_T, & + unscaled=kappa_0_unscaled, do_not_log=just_read) 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*kappa_0_unscaled, scale=US%m2_s_to_Z2_T) + units="m2 s-1", default=0.01*kappa_0_unscaled, scale=US%m2_s_to_Z2_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) + "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) + units="nondim", default=0.24, do_not_log=just_read) ! call get_param(param_file, mdl, "LAYER_KAPPA_STAGGER", CS%layer_stagger, & -! default=.false.) +! 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) + "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) + "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) + 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) + 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.", & @@ -2070,40 +1874,47 @@ function kappa_shear_init(Time, G, GV, US, param_file, diag, CS) "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.) + 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.", units="nondim", & - default=13) + 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.) + "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) + "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") + 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=.true., do_not_log=(just_read .or. (.not.CS%KS_at_vertex))) - call get_param(param_file, mdl, "DEBUG_KAPPA_SHEAR", CS%debug, & - "If true, write debugging data for the kappa-shear code. \n"//& - "Caution: this option is _very_ verbose and should only "//& - "be used in single-column mode!", & - default=.false., debuggingParam=.true.) 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=.true.) + "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=.true.) + 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) @@ -2112,8 +1923,8 @@ function kappa_shear_init(Time, G, GV, US, param_file, diag, CS) CS%nkml = 1 if (GV%nkml>0) then call get_param(param_file, mdl, "KAPPA_SHEAR_MERGE_ML",merge_mixedlayer, & - "If true, combine the mixed layers together before "//& - "solving the kappa-shear equations.", default=.true.) + "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 @@ -2122,16 +1933,10 @@ function kappa_shear_init(Time, G, GV, US, param_file, diag, CS) CS%diag => diag - CS%id_Kd_shear = register_diag_field('ocean_model','Kd_shear',diag%axesTi,Time, & + CS%id_Kd_shear = register_diag_field('ocean_model','Kd_shear', diag%axesTi, Time, & 'Shear-driven Diapycnal Diffusivity', 'm2 s-1', conversion=US%Z2_T_to_m2_s) - CS%id_TKE = register_diag_field('ocean_model','TKE_shear',diag%axesTi,Time, & + CS%id_TKE = register_diag_field('ocean_model','TKE_shear', diag%axesTi, Time, & 'Shear-driven Turbulent Kinetic Energy', 'm2 s-2', conversion=US%Z_to_m**2*US%s_to_T**2) -#ifdef ADD_DIAGNOSTICS - CS%id_ILd2 = register_diag_field('ocean_model','ILd2_shear',diag%axesTi,Time, & - 'Inverse kappa decay scale at interfaces', 'm-2', conversion=US%m_to_Z**2) - CS%id_dz_Int = register_diag_field('ocean_model','dz_Int_shear',diag%axesTi,Time, & - 'Finite volume thickness of interfaces', 'm', conversion=US%Z_to_m) -#endif end function kappa_shear_init @@ -2139,25 +1944,30 @@ end function kappa_shear_init !! 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 -! Reads the parameter "USE_JACKSON_PARAM" and returns state. + + ! 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 without needing to duplicate the log entry. +!> 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 -! Reads the parameter "USE_JACKSON_PARAM" and returns state. - character(len=40) :: mdl = "MOM_kappa_shear" ! This module's name. + ! 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.) - kappa_shear_at_vertex = .false. if (do_Kappa_Shear) & call get_param(param_file, mdl, "VERTEX_SHEAR", kappa_shear_at_vertex, & "If true, do the calculations of the shear-driven mixing "//& diff --git a/src/parameterizations/vertical/MOM_opacity.F90 b/src/parameterizations/vertical/MOM_opacity.F90 index 8e4acf1142..7cbbc33441 100644 --- a/src/parameterizations/vertical/MOM_opacity.F90 +++ b/src/parameterizations/vertical/MOM_opacity.F90 @@ -1048,7 +1048,7 @@ subroutine opacity_init(Time, G, GV, US, param_file, diag, CS, optics) call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=.true.) + default=.false.) call get_param(param_file, mdl, "OPTICS_2018_ANSWERS", optics%answers_2018, & "If true, use the order of arithmetic and expressions that recover the "//& "answers from the end of 2018. Otherwise, use updated expressions for "//& diff --git a/src/parameterizations/vertical/MOM_regularize_layers.F90 b/src/parameterizations/vertical/MOM_regularize_layers.F90 index a4a4723092..f21faa359d 100644 --- a/src/parameterizations/vertical/MOM_regularize_layers.F90 +++ b/src/parameterizations/vertical/MOM_regularize_layers.F90 @@ -13,12 +13,11 @@ module MOM_regularize_layers 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 : calculate_density, calculate_density_derivs, EOS_domain implicit none ; private #include -#undef DEBUG_CODE public regularize_layers, regularize_layers_init @@ -58,18 +57,6 @@ module MOM_regularize_layers integer :: id_def_rat = -1 !< A diagnostic ID logical :: allow_clocks_in_omp_loops !< If true, clocks can be called from inside loops that !! can be threaded. To run with multiple threads, set to False. -#ifdef DEBUG_CODE - !>@{ Diagnostic IDs - integer :: id_def_rat_2 = -1, id_def_rat_3 = -1 - integer :: id_def_rat_u = -1, id_def_rat_v = -1 - integer :: id_e1 = -1, id_e2 = -1, id_e3 = -1 - integer :: id_def_rat_u_1b = -1, id_def_rat_v_1b = -1 - integer :: id_def_rat_u_2 = -1, id_def_rat_u_2b = -1 - integer :: id_def_rat_v_2 = -1, id_def_rat_v_2b = -1 - integer :: id_def_rat_u_3 = -1, id_def_rat_u_3b = -1 - integer :: id_def_rat_v_3 = -1, id_def_rat_v_3b = -1 - !>@} -#endif end type regularize_layers_CS !>@{ Clock IDs @@ -109,10 +96,8 @@ subroutine regularize_layers(h, tv, dt, ea, eb, G, GV, US, CS) if (.not. associated(CS)) call MOM_error(FATAL, "MOM_regularize_layers: "//& "Module must be initialized before it is used.") - if (CS%regularize_surface_layers) & - call pass_var(h, G%Domain, clock=id_clock_pass) - 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 @@ -150,17 +135,6 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: & e ! The interface depths [H ~> m or kg m-2], positive upward. -#ifdef DEBUG_CODE - real, dimension(SZIB_(G),SZJ_(G)) :: & - def_rat_u_1b, def_rat_u_2, def_rat_u_2b, def_rat_u_3, def_rat_u_3b - real, dimension(SZI_(G),SZJB_(G)) :: & - def_rat_v_1b, def_rat_v_2, def_rat_v_2b, def_rat_v_3, def_rat_v_3b - real, dimension(SZI_(G),SZJB_(G)) :: & - def_rat_h2, def_rat_h3 - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: & - ef ! The filtered interface depths [H ~> m or kg m-2], positive upward. -#endif - real, dimension(SZI_(G),SZK_(G)+1) :: & e_filt, e_2d ! The interface depths [H ~> m or kg m-2], positive upward. real, dimension(SZI_(G),SZK_(G)) :: & @@ -179,7 +153,7 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) ! 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 [Pa]. + ! the coordinate variable, set to P_Ref [R L2 T-2 ~> Pa]. Rcv_tol, & ! A tolerence, relative to the target density differences ! between layers, for detraining into the interior [nondim]. h_add_tgt, h_add_tot, & @@ -215,6 +189,7 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) 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 = G%ke @@ -230,17 +205,12 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) h_neglect = GV%H_subroundoff debug = (debug .or. CS%debug) -#ifdef DEBUG_CODE - debug = .true. - if (CS%id_def_rat_2 > 0) then ! Calculate over a slightly larger domain. - is = G%isc-1 ; ie = G%iec+1 ; js = G%jsc-1 ; je = G%jec+1 - endif -#endif I_dtol = 1.0 / max(CS%h_def_tol2 - CS%h_def_tol1, 1e-40) I_dtol34 = 1.0 / max(CS%h_def_tol4 - CS%h_def_tol3, 1e-40) 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 @@ -249,11 +219,8 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) e(i,j,K+1) = e(i,j,K) - h(i,j,k) enddo ; enddo ; enddo -#ifdef DEBUG_CODE - call find_deficit_ratios(e, def_rat_u, def_rat_v, G, GV, CS, def_rat_u_1b, def_rat_v_1b, 1, h) -#else call find_deficit_ratios(e, def_rat_u, def_rat_v, G, GV, CS, h=h) -#endif + ! Determine which columns are problematic do j=js,je ; do_j(j) = .false. ; enddo do j=js,je ; do i=is,ie @@ -262,58 +229,14 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) if (def_rat_h(i,j) > CS%h_def_tol1) do_j(j) = .true. enddo ; enddo -#ifdef DEBUG_CODE - if ((CS%id_def_rat_3 > 0) .or. (CS%id_e3 > 0) .or. & - (CS%id_def_rat_u_3 > 0) .or. (CS%id_def_rat_u_3b > 0) .or. & - (CS%id_def_rat_v_3 > 0) .or. (CS%id_def_rat_v_3b > 0) ) then - do j=js-1,je+1 ; do i=is-1,ie+1 - ef(i,j,1) = 0.0 - enddo ; enddo - do K=2,nz+1 ; do j=js,je ; do i=is,ie - if (G%mask2dCu(I,j) <= 0.0) then ; e_e = e(i,j,K) ; else - e_e = max(e(i+1,j,K) + min(e(i,j,K) - e(i+1,j,nz+1), 0.0), e(i,j,nz+1)) - endif - if (G%mask2dCu(I-1,j) <= 0.0) then ; e_w = e(i,j,K) ; else - e_w = max(e(i-1,j,K) + min(e(i,j,K) - e(i-1,j,nz+1), 0.0), e(i,j,nz+1)) - endif - if (G%mask2dCv(i,J) <= 0.0) then ; e_n = e(i,j,K) ; else - e_n = max(e(i,j+1,K) + min(e(i,j,K) - e(i,j+1,nz+1), 0.0), e(i,j,nz+1)) - endif - if (G%mask2dCv(i,J-1) <= 0.0) then ; e_s = e(i,j,K) ; else - e_s = max(e(i,j-1,K) + min(e(i,j,K) - e(i,j-1,nz+1), 0.0), e(i,j,nz+1)) - endif - - wt = 1.0 - ef(i,j,k) = (1.0 - 0.5*wt) * e(i,j,K) + & - wt * 0.125 * ((e_e + e_w) + (e_n + e_s)) - enddo ; enddo ; enddo - call find_deficit_ratios(ef, def_rat_u_3, def_rat_v_3, G, GV, CS, def_rat_u_3b, def_rat_v_3b) - - ! Determine which columns are problematic - do j=js,je ; do i=is,ie - def_rat_h3(i,j) = max(def_rat_u_3(I-1,j), def_rat_u_3(I,j), & - def_rat_v_3(i,J-1), def_rat_v_3(i,J)) - enddo ; enddo - - if (CS%id_e3 > 0) call post_data(CS%id_e3, ef, CS%diag) - if (CS%id_def_rat_3 > 0) call post_data(CS%id_def_rat_3, def_rat_h3, CS%diag) - if (CS%id_def_rat_u_3 > 0) call post_data(CS%id_def_rat_u_3, def_rat_u_3, CS%diag) - if (CS%id_def_rat_u_3b > 0) call post_data(CS%id_def_rat_u_3b, def_rat_u_3b, CS%diag) - if (CS%id_def_rat_v_3 > 0) call post_data(CS%id_def_rat_v_3, def_rat_v_3, CS%diag) - if (CS%id_def_rat_v_3b > 0) call post_data(CS%id_def_rat_v_3b, def_rat_v_3b, CS%diag) - endif -#endif - - ! Now restructure the layers. !$OMP parallel do default(private) shared(is,ie,js,je,nz,do_j,def_rat_h,CS,nkmb,G,GV,US, & !$OMP e,I_dtol,h,tv,debug,h_neglect,p_ref_cv,ea, & - !$OMP eb,id_clock_EOS,nkml) + !$OMP eb,id_clock_EOS,nkml,EOSdom) do j=js,je ; if (do_j(j)) then ! call cpu_clock_begin(id_clock_EOS) -! call calculate_density_derivs(T(:,1), S(:,1), p_ref_cv, dRcv_dT, dRcv_dS, & -! is, ie-is+1, tv%eqn_of_state) +! call calculate_density_derivs(T(:,1), S(:,1), p_ref_cv, dRcv_dT, dRcv_dS, tv%eqn_of_state, EOSdom) ! call cpu_clock_end(id_clock_EOS) do k=1,nz ; do i=is,ie ; d_ea(i,k) = 0.0 ; d_eb(i,k) = 0.0 ; enddo ; enddo @@ -445,8 +368,7 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) if (det_any) then call cpu_clock_begin(id_clock_EOS) do k=1,nkmb - call calculate_density(T_2d(:,k),S_2d(:,k),p_ref_cv,Rcv(:,k), & - is,ie-is+1,tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density(T_2d(:,k), S_2d(:,k), p_ref_cv, Rcv(:,k), tv%eqn_of_state, EOSdom) enddo call cpu_clock_end(id_clock_EOS) @@ -684,40 +606,6 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) if (CS%id_def_rat > 0) call post_data(CS%id_def_rat, def_rat_h, CS%diag) -#ifdef DEBUG_CODE - if (CS%id_e1 > 0) call post_data(CS%id_e1, e, CS%diag) - if (CS%id_def_rat_u > 0) call post_data(CS%id_def_rat_u, def_rat_u, CS%diag) - if (CS%id_def_rat_u_1b > 0) call post_data(CS%id_def_rat_u_1b, def_rat_u_1b, CS%diag) - if (CS%id_def_rat_v > 0) call post_data(CS%id_def_rat_v, def_rat_v, CS%diag) - if (CS%id_def_rat_v_1b > 0) call post_data(CS%id_def_rat_v_1b, def_rat_v_1b, CS%diag) - - if ((CS%id_def_rat_2 > 0) .or. & - (CS%id_def_rat_u_2 > 0) .or. (CS%id_def_rat_u_2b > 0) .or. & - (CS%id_def_rat_v_2 > 0) .or. (CS%id_def_rat_v_2b > 0) ) then - do j=js-1,je+1 ; do i=is-1,ie+1 - e(i,j,1) = 0.0 - enddo ; enddo - do K=1,nz ; do j=js-1,je+1 ; do i=is-1,ie+1 - e(i,j,K+1) = e(i,j,K) - h(i,j,k) - enddo ; enddo ; enddo - - call find_deficit_ratios(e, def_rat_u_2, def_rat_v_2, G, GV, CS, def_rat_u_2b, def_rat_v_2b, h=h) - - ! Determine which columns are problematic - do j=js,je ; do i=is,ie - def_rat_h2(i,j) = max(def_rat_u_2(I-1,j), def_rat_u_2(I,j), & - def_rat_v_2(i,J-1), def_rat_v_2(i,J)) - enddo ; enddo - - if (CS%id_def_rat_2 > 0) call post_data(CS%id_def_rat_2, def_rat_h2, CS%diag) - if (CS%id_e2 > 0) call post_data(CS%id_e2, e, CS%diag) - if (CS%id_def_rat_u_2 > 0) call post_data(CS%id_def_rat_u_2, def_rat_u_2, CS%diag) - if (CS%id_def_rat_u_2b > 0) call post_data(CS%id_def_rat_u_2b, def_rat_u_2b, CS%diag) - if (CS%id_def_rat_v_2 > 0) call post_data(CS%id_def_rat_v_2, def_rat_v_2, CS%diag) - if (CS%id_def_rat_v_2b > 0) call post_data(CS%id_def_rat_v_2b, def_rat_v_2b, CS%diag) - endif -#endif - end subroutine regularize_surface !> This subroutine determines the amount by which the harmonic mean @@ -891,6 +779,7 @@ subroutine regularize_layers_init(Time, G, GV, param_file, diag, CS) character(len=40) :: mdl = "MOM_regularize_layers" ! This module's name. logical :: use_temperature logical :: default_2018_answers + logical :: just_read integer :: isd, ied, jsd, jed isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -904,38 +793,42 @@ subroutine regularize_layers_init(Time, G, GV, param_file, diag, CS) CS%Time => Time ! Set default, read and log parameters - call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "REGULARIZE_SURFACE_LAYERS", CS%regularize_surface_layers, & + 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.) - call get_param(param_file, mdl, "REG_SFC_DENSE_MATCH_TOLERANCE", CS%density_match_tol, & + "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) + "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, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=.true.) + default=.false., do_not_log=just_read) call get_param(param_file, mdl, "REGULARIZE_LAYERS_2018_ANSWERS", CS%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) + "If true, use the order of arithmetic and expressions that recover the answers "//& + "from the end of 2018. Otherwise, use updated and more robust forms of the "//& + "same expressions.", default=default_2018_answers, do_not_log=just_read) 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) + "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) + 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 @@ -943,55 +836,18 @@ subroutine regularize_layers_init(Time, G, GV, param_file, diag, CS) 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.) +! "If true, monitor conservation and extrema.", default=.false., do_not_log=just_read) call get_param(param_file, mdl, "ALLOW_CLOCKS_IN_OMP_LOOPS", CS%allow_clocks_in_omp_loops, & "If true, clocks can be called from inside loops that can "//& "be threaded. To run with multiple threads, set to False.", & - default=.true.) + default=.true., 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') -#ifdef DEBUG_CODE - CS%id_def_rat_2 = register_diag_field('ocean_model', 'deficit_rat2', diag%axesT1, & - Time, 'Corrected thickness deficit ratio', 'nondim') - CS%id_def_rat_3 = register_diag_field('ocean_model', 'deficit_rat3', diag%axesT1, & - Time, 'Filtered thickness deficit ratio', 'nondim') - CS%id_e1 = register_diag_field('ocean_model', 'er_1', diag%axesTi, & - Time, 'Intial interface depths before remapping', 'm') - CS%id_e2 = register_diag_field('ocean_model', 'er_2', diag%axesTi, & - Time, 'Intial interface depths after remapping', 'm') - CS%id_e3 = register_diag_field('ocean_model', 'er_3', diag%axesTi, & - Time, 'Intial interface depths filtered', 'm') - - CS%id_def_rat_u = register_diag_field('ocean_model', 'defrat_u', diag%axesCu1, & - Time, 'U-point thickness deficit ratio', 'nondim') - CS%id_def_rat_u_1b = register_diag_field('ocean_model', 'defrat_u_1b', diag%axesCu1, & - Time, 'U-point 2-layer thickness deficit ratio', 'nondim') - CS%id_def_rat_u_2 = register_diag_field('ocean_model', 'defrat_u_2', diag%axesCu1, & - Time, 'U-point corrected thickness deficit ratio', 'nondim') - CS%id_def_rat_u_2b = register_diag_field('ocean_model', 'defrat_u_2b', diag%axesCu1, & - Time, 'U-point corrected 2-layer thickness deficit ratio', 'nondim') - CS%id_def_rat_u_3 = register_diag_field('ocean_model', 'defrat_u_3', diag%axesCu1, & - Time, 'U-point filtered thickness deficit ratio', 'nondim') - CS%id_def_rat_u_3b = register_diag_field('ocean_model', 'defrat_u_3b', diag%axesCu1, & - Time, 'U-point filtered 2-layer thickness deficit ratio', 'nondim') - - CS%id_def_rat_v = register_diag_field('ocean_model', 'defrat_v', diag%axesCv1, & - Time, 'V-point thickness deficit ratio', 'nondim') - CS%id_def_rat_v_1b = register_diag_field('ocean_model', 'defrat_v_1b', diag%axesCv1, & - Time, 'V-point 2-layer thickness deficit ratio', 'nondim') - CS%id_def_rat_v_2 = register_diag_field('ocean_model', 'defrat_v_2', diag%axesCv1, & - Time, 'V-point corrected thickness deficit ratio', 'nondim') - CS%id_def_rat_v_2b = register_diag_field('ocean_model', 'defrat_v_2b', diag%axesCv1, & - Time, 'V-point corrected 2-layer thickness deficit ratio', 'nondim') - CS%id_def_rat_v_3 = register_diag_field('ocean_model', 'defrat_v_3', diag%axesCv1, & - Time, 'V-point filtered thickness deficit ratio', 'nondim') - CS%id_def_rat_v_3b = register_diag_field('ocean_model', 'defrat_v_3b', diag%axesCv1, & - Time, 'V-point filtered 2-layer thickness deficit ratio', 'nondim') -#endif - if (CS%allow_clocks_in_omp_loops) then id_clock_EOS = cpu_clock_id('(Ocean regularize_layers EOS)', grain=CLOCK_ROUTINE) endif diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 3045639232..b81cf62631 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -3,13 +3,12 @@ module MOM_set_diffusivity ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_checksums, only : hchksum_pair 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, time_type use MOM_diag_mediator, only : post_data, register_diag_field -use MOM_debugging, only : hchksum, uvchksum, Bchksum -use MOM_EOS, only : calculate_density, calculate_density_derivs +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 @@ -31,6 +30,8 @@ module MOM_set_diffusivity use MOM_CVMix_ddiff, only : compute_ddiff_coeffs use MOM_bkgnd_mixing, only : calculate_bkgnd_mixing, bkgnd_mixing_init, bkgnd_mixing_cs use MOM_bkgnd_mixing, only : bkgnd_mixing_end, sfc_bkgnd_mixing +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_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs, vertvisc_type, p3d @@ -536,13 +537,15 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & endif if (associated(visc%kv_bbl_u) .and. associated(visc%kv_bbl_v)) then - call uvchksum("BBL Kv_bbl_[uv]", visc%kv_bbl_u, visc%kv_bbl_v, & - G%HI, 0, symmetric=.true., scale=US%Z2_T_to_m2_s) + call uvchksum("BBL Kv_bbl_[uv]", visc%kv_bbl_u, visc%kv_bbl_v, G%HI, & + haloshift=0, symmetric=.true., scale=US%Z2_T_to_m2_s, & + scalar_pair=.true.) endif if (associated(visc%bbl_thick_u) .and. associated(visc%bbl_thick_v)) then - call uvchksum("BBL bbl_thick_[uv]", visc%bbl_thick_u, & - visc%bbl_thick_v, G%HI, 0, symmetric=.true., scale=US%Z_to_m) + 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 (associated(visc%Ray_u) .and. associated(visc%Ray_v)) then @@ -661,11 +664,10 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, & real, dimension(SZI_(G)) :: & htot, & ! total thickness above or below a layer, or the ! integrated thickness in the BBL [Z ~> m]. - mFkb, & ! total thickness in the mixed and buffer layers - ! times ds_dsp1 [Z ~> m]. - p_ref, & ! array of tv%P_Ref pressures + mFkb, & ! total thickness in the mixed and buffer layers times ds_dsp1 [Z ~> m]. + 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 + 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 @@ -680,6 +682,7 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, & 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 = G%ke @@ -713,12 +716,11 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, & if (CS%bulkmixedlayer) then kmb = GV%nk_rho_varies do i=is,ie ; 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), & - is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) + 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, & - is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) + 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 @@ -868,7 +870,7 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & dRho_dS ! partial derivative of density wrt saln [R ppt-1 ~> kg m-3 ppt-1] real, dimension(SZI_(G)) :: & - pres, & ! pressure at each interface [Pa] + pres, & ! pressure at each interface [R L2 T-2 ~> Pa] Temp_int, & ! temperature at each interface [degC] Salin_int, & ! salinity at each interface [ppt] drho_bot, & ! A density difference [R ~> kg m-3] @@ -883,6 +885,7 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & real :: H_neglect ! negligibly small thickness, in the same units as h. 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 = G%ke @@ -900,14 +903,15 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & else do i=is,ie ; pres(i) = 0.0 ; enddo endif + EOSdom(:) = EOS_domain(G%HI) do K=2,nz do i=is,ie - pres(i) = pres(i) + GV%H_to_Pa*h(i,j,k-1) + 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) + T_f(i,j,k-1)) Salin_Int(i) = 0.5 * (S_f(i,j,k) + S_f(i,j,k-1)) enddo - call calculate_density_derivs(Temp_int, Salin_int, pres, & - dRho_dT(:,K), dRho_dS(:,K), is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density_derivs(Temp_int, Salin_int, pres, 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) @@ -1037,7 +1041,7 @@ subroutine double_diffusion(tv, h, T_f, S_f, j, G, GV, US, CS, Kd_T_dd, Kd_S_dd) real, dimension(SZI_(G)) :: & dRho_dT, & ! partial derivatives of density wrt temp [R degC-1 ~> kg m-3 degC-1] dRho_dS, & ! partial derivatives of density wrt saln [R ppt-1 ~> kg m-3 ppt-1] - pres, & ! pressure at each interface [Pa] + pres, & ! pressure at each interface [R L2 T-2 ~> Pa] Temp_int, & ! temperature at interfaces [degC] Salin_int ! Salinity at interfaces [ppt] @@ -1051,6 +1055,7 @@ subroutine double_diffusion(tv, h, T_f, S_f, j, G, GV, US, CS, Kd_T_dd, Kd_S_dd) 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 = G%ke @@ -1059,14 +1064,16 @@ subroutine double_diffusion(tv, h, T_f, S_f, j, G, GV, US, CS, Kd_T_dd, Kd_S_dd) 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%H_to_Pa*h(i,j,k-1) + 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(:), is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) + 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)) @@ -1404,7 +1411,7 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, & ustar2 = ustar**2 ! In add_drag_diffusivity(), fluxes%ustar_tidal is added in. This might be double counting ! since ustar_BBL should already include all contributions to u*? -AJA - !### Examine this question of whether there is double counting of fluxes%ustar_tidal. + !### Examine the question of whether there is double counting of fluxes%ustar_tidal. if (associated(fluxes%ustar_tidal)) ustar = ustar + fluxes%ustar_tidal(i,j) ! The maximum decay scale should be something of order 200 m. We use the smaller of u*/f and @@ -1631,7 +1638,7 @@ end subroutine add_MLrad_diffusivity !> This subroutine calculates several properties related to bottom !! boundary layer turbulence. -subroutine set_BBL_TKE(u, v, h, fluxes, visc, G, GV, US, CS) +subroutine set_BBL_TKE(u, v, h, 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 @@ -1645,6 +1652,7 @@ subroutine set_BBL_TKE(u, v, h, fluxes, visc, G, GV, US, CS) type(vertvisc_type), intent(in) :: visc !< Structure containing vertical viscosities, bottom !! boundary layer properies, and related fields. type(set_diffusivity_CS), pointer :: CS !< Diffusivity control structure + type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. ! This subroutine calculates several properties related to bottom ! boundary layer turbulence. @@ -1669,6 +1677,17 @@ subroutine set_BBL_TKE(u, v, h, fluxes, visc, G, GV, US, CS) 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 (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 + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke if (.not.associated(CS)) call MOM_error(FATAL,"set_BBL_TKE: "//& @@ -1686,10 +1705,8 @@ subroutine set_BBL_TKE(u, v, h, fluxes, visc, G, GV, US, CS) cdrag_sqrt = sqrt(CS%cdrag) -!$OMP parallel default(none) shared(cdrag_sqrt,is,ie,js,je,nz,visc,CS,G,GV,US,vstar,h,v, & -!$OMP v2_bbl,u) & -!$OMP private(do_i,vhtot,htot,domore,hvel,uhtot,ustar,u2_bbl) -!$OMP do + !$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 @@ -1703,7 +1720,26 @@ subroutine set_BBL_TKE(u, v, h, fluxes, visc, G, GV, US, CS) do k=nz,1,-1 domore = .false. do i=is,ie ; if (do_i(i)) then - hvel = 0.5*GV%H_to_Z*(h(i,j,k) + h(i,j+1,k)) + ! 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 = GV%H_to_Z*h(i,j,k) + else + hvel = GV%H_to_Z*h(i,j+1,k) + endif + else + hvel = 0.5*GV%H_to_Z*(h(i,j,k) + h(i,j+1,k)) + 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) @@ -1722,7 +1758,7 @@ subroutine set_BBL_TKE(u, v, h, fluxes, visc, G, GV, US, CS) v2_bbl(i,J) = 0.0 endif ; enddo enddo -!$OMP do + !$OMP do do j=js,je do I=is-1,ie ; if ((G%mask2dCu(I,j) > 0.5) .and. (cdrag_sqrt*visc%bbl_thick_u(I,j) > 0.0)) then do_i(I) = .true. ; uhtot(I) = 0.0 ; htot(I) = 0.0 @@ -1732,7 +1768,26 @@ subroutine set_BBL_TKE(u, v, h, fluxes, visc, G, GV, US, CS) endif ; enddo do k=nz,1,-1 ; domore = .false. do I=is-1,ie ; if (do_i(I)) then - hvel = 0.5*GV%H_to_Z*(h(i,j,k) + h(i+1,j,k)) + ! 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 = GV%H_to_Z*h(i,j,k) + else ! OBC_DIRECTION_W + hvel = GV%H_to_Z*h(i+1,j,k) + endif + else + hvel = 0.5*GV%H_to_Z*(h(i,j,k) + h(i+1,j,k)) + 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) @@ -1764,7 +1819,7 @@ subroutine set_BBL_TKE(u, v, h, fluxes, visc, G, GV, US, CS) G%areaCv(i,J) * (vstar(i,J)*v2_bbl(i,J))) )*G%IareaT(i,j)) enddo enddo -!$OMP end parallel + !$OMP end parallel end subroutine set_BBL_TKE @@ -1794,10 +1849,11 @@ subroutine set_density_ratios(h, tv, kb, G, GV, US, CS, j, ds_dsp1, rho_0) 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 temproray variables real :: a(SZK_(G)), a_0(SZK_(G)) ! nondimensional temporary variables - real :: p_ref(SZI_(G)) ! an array of tv%P_Ref pressures + real :: p_ref(SZI_(G)) ! an array of tv%P_Ref pressures [R L2 T-2 ~> Pa] real :: Rcv(SZI_(G),SZK_(G)) ! coordinate density in the mixed and buffer layers [R ~> kg m-3] real :: I_Drho ! temporary variable [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 = G%ke @@ -1818,9 +1874,9 @@ subroutine set_density_ratios(h, tv, kb, G, GV, US, CS, j, ds_dsp1, rho_0) 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), & - is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) + 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 @@ -1936,7 +1992,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=.true.) + default=.false.) call get_param(param_file, mdl, "SET_DIFF_2018_ANSWERS", CS%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 "//& @@ -1959,7 +2015,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ 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=.true.) + "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. "//& @@ -1976,7 +2032,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ "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) + "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) @@ -2054,8 +2110,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ call get_param(param_file, mdl, "KD", CS%Kd, & "The background diapycnal diffusivity of density in the "//& "interior. Zero or the molecular value, ~1e-7 m2 s-1, "//& - "may be used.", units="m2 s-1", scale=US%m2_s_to_Z2_T, & - fail_if_missing=.true.) + "may be used.", default=0.0, units="m2 s-1", scale=US%m2_s_to_Z2_T) call get_param(param_file, mdl, "KD_MIN", CS%Kd_min, & "The minimum diapycnal diffusivity.", & units="m2 s-1", default=0.01*CS%Kd*US%Z2_T_to_m2_s, scale=US%m2_s_to_Z2_T) @@ -2075,7 +2130,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ call get_param(param_file, mdl, "KD_SMOOTH", CS%Kd_smooth, & "A diapycnal diffusivity that is used to interpolate "//& "more sensible values of T & S into thin layers.", & - units="m2 s-1", default=1.0e-6, scale=US%m_to_Z**2*US%T_to_s) + units="m2 s-1", default=1.0e-6, scale=US%m2_s_to_Z2_T) call get_param(param_file, mdl, "DEBUG", CS%debug, & "If true, write out verbose debugging data.", & @@ -2086,18 +2141,18 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ 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%kg_m3_to_R*US%m2_s_to_Z2_T*(US%T_to_s**2)) + "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%kg_m3_to_R*US%m2_s_to_Z2_T*(US%T_to_s**2)) + 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%kg_m3_to_R*US%m2_s_to_Z2_T*US%T_to_s) + units="J m-3", default=0.0, scale=US%W_m2_to_RZ3_T3*US%Z_to_m*US%s_to_T) call get_param(param_file, mdl, "DISSIPATION_KD_MIN", CS%dissip_Kd_min, & "The minimum vertical diffusivity applied as a floor.", & units="m2 s-1", default=0.0, scale=US%m2_s_to_Z2_T) @@ -2164,7 +2219,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ "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) - if (CS%useKappaShear) CS%Vertex_Shear = kappa_shear_at_vertex(param_file) + CS%Vertex_Shear = kappa_shear_at_vertex(param_file) if (CS%useKappaShear) & id_clock_kappaShear = cpu_clock_id('(Ocean kappa_shear)', grain=CLOCK_MODULE) diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index f5412facae..02fa647e7e 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -147,7 +147,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) ! layer with temperature [R degC-1 ~> kg m-3 degC-1]. dR_dS, & ! Partial derivative of the density in the bottom boundary ! layer with salinity [R ppt-1 ~> kg m-3 ppt-1]. - press ! The pressure at which dR_dT and dR_dS are evaluated [Pa]. + press ! The pressure at which dR_dT and dR_dS are evaluated [R L2 T-2 ~> Pa]. real :: htot ! Sum of the layer thicknesses up to some point [H ~> m or kg m-2]. real :: htot_vel ! Sum of the layer thicknesses up to some point [H ~> m or kg m-2]. @@ -212,7 +212,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) 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 [Pa] (usually set to 2e7 Pa = 2000 dbar). + ! density [R L2 T-2 ~> Pa] (usually set to 2e7 Pa = 2000 dbar). real :: D_vel ! The bottom depth at a velocity point [H ~> m or kg m-2]. real :: Dp, Dm ! The depths at the edges of a velocity cell [H ~> m or kg m-2]. @@ -273,6 +273,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) ! accuracy of a single L(:) Newton iteration logical :: use_L0, do_one_L_iter ! Control flags for L(:) Newton iteration logical :: use_BBL_EOS, do_i(SZIB_(G)) + integer, dimension(2) :: EOSdom ! The computational domain for the equation of state integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, m, n, K2, nkmb, nkml integer :: itt, maxitt=20 type(ocean_OBC_type), pointer :: OBC => NULL() @@ -312,11 +313,12 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) ! if (CS%linear_drag) ustar(:) = cdrag_sqrt_Z*CS%drag_bg_vel if ((nkml>0) .and. .not.use_BBL_EOS) then - do i=Isq,Ieq+1 ; p_ref(i) = tv%P_ref ; enddo + 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 j=Jsq,Jeq+1 ; do k=1,nkmb - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_ref, & - Rml(:,j,k), Isq, Ieq-Isq+2, tv%eqn_of_state, scale=US%kg_m3_to_R) + 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 @@ -565,15 +567,18 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) endif ! Not linear_drag if (use_BBL_EOS) then - do i=is,ie - press(i) = 0.0 ! or = forces%p_surf(i,j) - if (.not.do_i(i)) then ; T_EOS(i) = 0.0 ; S_EOS(i) = 0.0 ; endif - enddo + 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_Pa * h_vel(i,k) + 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, & - is-G%IsdB+1, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) + 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 do i=is,ie ; if (do_i(i)) then @@ -943,10 +948,11 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) if (associated(visc%Ray_u) .and. associated(visc%Ray_v)) & call uvchksum("Ray [uv]", visc%Ray_u, visc%Ray_v, G%HI, haloshift=0, scale=US%Z_to_m) if (associated(visc%kv_bbl_u) .and. associated(visc%kv_bbl_v)) & - call uvchksum("kv_bbl_[uv]", visc%kv_bbl_u, visc%kv_bbl_v, G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) + call uvchksum("kv_bbl_[uv]", visc%kv_bbl_u, visc%kv_bbl_v, G%HI, & + haloshift=0, scale=US%Z2_T_to_m2_s, scalar_pair=.true.) if (associated(visc%bbl_thick_u) .and. associated(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) + 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 @@ -1086,7 +1092,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS, symmetri dR_dS, & ! Partial derivative of the density at the base of layer nkml ! (roughly the base of the mixed layer) with salinity [R ppt-1 ~> kg m-3 ppt-1]. ustar, & ! The surface friction velocity under ice shelves [Z T-1 ~> m s-1]. - press, & ! The pressure at which dR_dT and dR_dS are evaluated [Pa]. + 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 [degC] S_EOS ! The salinity at which dR_dT and dR_dS are evaluated [ppt]. real, dimension(SZIB_(G),SZJ_(G)) :: & @@ -1269,14 +1275,15 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS, symmetri if (use_EOS .and. (k==nkml+1)) then ! Find dRho/dT and dRho_dS. do I=Isq,Ieq - press(I) = GV%H_to_Pa * htot(I) + 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, & - Isq-G%IsdB+1, Ieq-Isq+1, tv%eqn_of_state, scale=US%kg_m3_to_R) + 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/) ) endif do I=Isq,Ieq ; if (do_i(I)) then @@ -1396,8 +1403,8 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS, symmetri endif ; enddo ! I-loop if (use_EOS) then - call calculate_density_derivs(T_EOS, S_EOS, forces%p_surf(:,j), & - dR_dT, dR_dS, Isq-G%IsdB+1, Ieq-Isq+1, tv%eqn_of_state, scale=US%kg_m3_to_R) + 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 @@ -1506,14 +1513,15 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS, symmetri if (use_EOS .and. (k==nkml+1)) then ! Find dRho/dT and dRho_dS. do i=is,ie - press(i) = GV%H_to_Pa * htot(i) + 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, & - is-G%IsdB+1, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) + tv%eqn_of_state, (/is-G%IsdB+1,ie-G%IsdB+1/) ) endif do i=is,ie ; if (do_i(i)) then @@ -1633,8 +1641,8 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS, symmetri endif ; enddo ! I-loop if (use_EOS) then - call calculate_density_derivs(T_EOS, S_EOS, forces%p_surf(:,j), & - dR_dT, dR_dS, is-G%IsdB+1, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) + 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 @@ -1710,8 +1718,8 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS, symmetri if (CS%debug) then if (associated(visc%nkml_visc_u) .and. associated(visc%nkml_visc_v)) & - call uvchksum("nkml_visc_[uv]", visc%nkml_visc_u, & - visc%nkml_visc_v, G%HI,haloshift=0) + 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) @@ -1836,8 +1844,9 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS integer :: i, j, k, is, ie, js, je, n integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nz logical :: default_2018_answers - logical :: use_kappa_shear, adiabatic, use_omega + logical :: use_kappa_shear, adiabatic, use_omega, MLE_use_PBL_MLD logical :: use_CVMix_ddiff, differential_diffusion, use_KPP + logical :: use_regridding character(len=200) :: filename, tideamp_file type(OBC_segment_type), pointer :: segment => NULL() ! pointer to OBC segment type ! This include declares and sets the variable "version". @@ -1867,7 +1876,7 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS CS%inputdir = slasher(CS%inputdir) call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=.true.) + default=.false.) call get_param(param_file, mdl, "SET_VISC_2018_ANSWERS", CS%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 "//& @@ -1983,10 +1992,16 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS "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, "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.", default=.false.) + "the layer target potential densities. The default of "//& + "this is determined by USE_REGRIDDING.", default=use_regridding) + 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 "//& @@ -2039,6 +2054,9 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS if (CS%c_Smag < 0.0) CS%c_Smag = 0.15 endif + call get_param(param_file, mdl, "MLE_USE_PBL_MLD", MLE_use_PBL_MLD, & + default=.false., do_not_log=.true.) + if (CS%RiNo_mix .and. kappa_shear_at_vertex(param_file)) then ! This is necessary for reproduciblity across restarts in non-symmetric mode. call pass_var(visc%Kv_shear_Bu, G%Domain, position=CORNER, complete=.true.) @@ -2132,7 +2150,14 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS visc%Kv_shear_Bu(I,J,k) = Z2_T_rescale * visc%Kv_shear_Bu(I,J,k) enddo ; enddo ; enddo endif ; endif + endif + if (MLE_use_PBL_MLD .and. (Z_rescale /= 1.0)) then + if (associated(visc%MLD)) then ; if (query_initialized(visc%MLD, "MLD", restart_CS)) then + do j=js,je ; do i=is,ie + visc%MLD(i,j) = Z_rescale * visc%MLD(i,j) + enddo ; enddo + endif ; endif endif end subroutine set_visc_init diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index 9b5f00be61..506872298d 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -249,8 +249,13 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, CS) CS%diag => diag ! Read parameters + call get_param(param_file, mdl, "USE_CVMix_TIDAL", CS%use_CVMix_tidal, & + default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "INT_TIDE_DISSIPATION", CS%int_tide_dissipation, & + default=CS%use_CVMix_tidal, do_not_log=.true.) call log_version(param_file, mdl, version, & - "Vertical Tidal Mixing Parameterization") + "Vertical Tidal Mixing Parameterization", & + all_default=.not.(CS%use_CVMix_tidal .or. CS%int_tide_dissipation)) call get_param(param_file, mdl, "USE_CVMix_TIDAL", CS%use_CVMix_tidal, & "If true, turns on tidal mixing via CVMix", & default=.false.) @@ -268,7 +273,7 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=.true.) + default=.false.) call get_param(param_file, mdl, "TIDAL_MIXING_2018_ANSWERS", CS%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 "//& @@ -440,7 +445,7 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, CS) 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%kg_m3_to_R*US%m_to_Z**3*US%T_to_s**3) + 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 "//& @@ -509,8 +514,7 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, CS) filename) call safe_alloc_ptr(CS%TKE_Niku,is,ie,js,je) ; CS%TKE_Niku(:,:) = 0.0 call MOM_read_data(filename, 'TKE_input', CS%TKE_Niku, G%domain, timelevel=1, & ! ??? timelevel -aja - scale=US%kg_m3_to_R*US%m_to_Z**3*US%T_to_s**3) - CS%TKE_Niku(:,:) = Niku_scale * CS%TKE_Niku(:,:) + 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 "//& @@ -590,7 +594,7 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, CS) 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) + 'Bouyancy frequency squared, at interfaces', 's-2', conversion=US%s_to_T**2) !> TODO: add units 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', '') @@ -688,7 +692,7 @@ subroutine calculate_tidal_mixing(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, US, C real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(inout) :: Kd_lay !< The diapycnal diffusvity in layers [Z2 T-1 ~> m2 s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), & - optional, intent(inout) :: Kd_int !< The diapycnal diffusvity at interfaces, + optional, intent(inout) :: Kd_int !< The diapycnal diffusvity at interfaces, !! [Z2 T-1 ~> m2 s-1]. real, intent(in) :: Kd_max !< The maximum increment for diapycnal !! diffusivity due to TKE-based processes, @@ -699,7 +703,7 @@ subroutine calculate_tidal_mixing(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, US, C if (CS%Int_tide_dissipation .or. CS%Lee_wave_dissipation .or. CS%Lowmode_itidal_dissipation) then if (CS%use_CVMix_tidal) then - call calculate_CVMix_tidal(h, j, G, GV, US, CS, N2_int, Kd_lay, Kv) + call calculate_CVMix_tidal(h, j, G, GV, US, CS, N2_int, Kd_lay, Kd_int, Kv) else call add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, & G, GV, US, CS, N2_lay, Kd_lay, Kd_int, Kd_max) @@ -710,7 +714,7 @@ end subroutine calculate_tidal_mixing !> Calls the CVMix routines to compute tidal dissipation and to add the effect of internal-tide-driven !! mixing to the interface diffusivities. -subroutine calculate_CVMix_tidal(h, j, G, GV, US, CS, N2_int, Kd_lay, Kv) +subroutine calculate_CVMix_tidal(h, j, G, GV, US, CS, N2_int, Kd_lay, Kd_int, Kv) integer, intent(in) :: j !< The j-index to work on type(ocean_grid_type), intent(in) :: G !< Grid structure. type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure @@ -722,6 +726,9 @@ subroutine calculate_CVMix_tidal(h, j, G, GV, US, CS, N2_int, Kd_lay, Kv) intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(inout) :: Kd_lay!< The diapycnal diffusivities in the layers [Z2 T-1 ~> m2 s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), & + optional, intent(inout) :: Kd_int !< The diapycnal diffusvity at interfaces, + !! [Z2 T-1 ~> m2 s-1]. real, dimension(:,:,:), pointer :: Kv !< The "slow" vertical viscosity at each interface !! (not layer!) [Z2 T-1 ~> m2 s-1]. ! Local variables @@ -781,8 +788,8 @@ subroutine calculate_CVMix_tidal(h, j, G, GV, US, CS, N2_int, Kd_lay, Kv) ! XXX: Temporary de-scaling of N2_int(i,:) into a temporary variable - do k = 1,G%ke+1 - N2_int_i(k) = US%s_to_T**2 * N2_int(i,k) + do K=1,G%ke+1 + N2_int_i(K) = US%s_to_T**2 * N2_int(i,K) enddo call CVMix_coeffs_tidal( Mdiff_out = Kv_tidal, & @@ -800,11 +807,15 @@ subroutine calculate_CVMix_tidal(h, j, G, GV, US, CS, N2_int, Kd_lay, Kv) do k=1,G%ke Kd_lay(i,j,k) = Kd_lay(i,j,k) + 0.5 * US%m2_s_to_Z2_T * (Kd_tidal(k) + Kd_tidal(k+1)) enddo - + if (present(Kd_int)) then + do K=1,G%ke+1 + Kd_int(i,j,K) = Kd_int(i,j,K) + (US%m2_s_to_Z2_T * Kd_tidal(K)) + enddo + endif ! Update viscosity with the proper unit conversion. if (associated(Kv)) then - do k=1,G%ke+1 - Kv(i,j,k) = Kv(i,j,k) + US%m2_s_to_Z2_T * Kv_tidal(k) ! Rescale from m2 s-1 to Z2 T-1. + do K=1,G%ke+1 + Kv(i,j,K) = Kv(i,j,K) + US%m2_s_to_Z2_T * Kv_tidal(K) ! Rescale from m2 s-1 to Z2 T-1. enddo endif @@ -876,7 +887,7 @@ subroutine calculate_CVMix_tidal(h, j, G, GV, US, CS, N2_int, Kd_lay, Kv) CVmix_tidal_params_user = CS%CVMix_tidal_params) ! XXX: Temporary de-scaling of N2_int(i,:) into a temporary variable - do k = 1,G%ke+1 + do k=1,G%ke+1 N2_int_i(k) = US%s_to_T**2 * N2_int(i,k) enddo @@ -896,11 +907,16 @@ subroutine calculate_CVMix_tidal(h, j, G, GV, US, CS, N2_int, Kd_lay, Kv) do k=1,G%ke Kd_lay(i,j,k) = Kd_lay(i,j,k) + 0.5 * US%m2_s_to_Z2_T * (Kd_tidal(k) + Kd_tidal(k+1)) enddo + if (present(Kd_int)) then + do K=1,G%ke+1 + Kd_int(i,j,K) = Kd_int(i,j,K) + (US%m2_s_to_Z2_T * Kd_tidal(K)) + enddo + endif ! Update viscosity if (associated(Kv)) then - do k=1,G%ke+1 - Kv(i,j,k) = Kv(i,j,k) + US%m2_s_to_Z2_T * Kv_tidal(k) ! Rescale from m2 s-1 to Z2 T-1. + do K=1,G%ke+1 + Kv(i,j,K) = Kv(i,j,K) + US%m2_s_to_Z2_T * Kv_tidal(K) ! Rescale from m2 s-1 to Z2 T-1. enddo endif diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index 5a610095ce..1a4fb58e02 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -124,10 +124,18 @@ module MOM_vert_friction integer :: id_h_u = -1, id_h_v = -1, id_hML_u = -1 , id_hML_v = -1 integer :: id_Ray_u = -1, id_Ray_v = -1, id_taux_bot = -1, id_tauy_bot = -1 integer :: id_Kv_slow = -1, id_Kv_u = -1, id_Kv_v = -1 + ! integer :: id_hf_du_dt_visc = -1, id_hf_dv_dt_visc = -1 + integer :: id_hf_du_dt_visc_2d = -1, id_hf_dv_dt_visc_2d = -1 !>@} type(PointAccel_CS), pointer :: PointAccel_CSp => NULL() !< A pointer to the control structure !! for recording accelerations leading to velocity truncations + + ! real, pointer :: hf_du_dt_visc(:,:,:) => NULL() ! Zonal friction accel. x fract. thickness [L T-2 ~> m s-2]. + ! real, pointer :: hf_dv_dt_visc(:,:,:) => NULL() ! Merdional friction accel. x fract. thickness [L T-2 ~> m s-2]. + ! 3D diagnostics hf_du(dv)_dt_visc are commented because there is no clarity on proper remapping grid option. + ! The code is retained for degugging purposes in the future. + end type vertvisc_CS contains @@ -175,8 +183,8 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & optional, pointer :: Waves !< Container for wave/Stokes information ! Fields from forces used in this subroutine: - ! taux: Zonal wind stress [Pa]. - ! tauy: Meridional wind stress [Pa]. + ! taux: Zonal wind stress [R L Z T-2 ~> Pa]. + ! tauy: Meridional wind stress [R L Z T-2 ~> Pa]. ! Local variables @@ -202,11 +210,14 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & real :: surface_stress(SZIB_(G))! The same as stress, unless the wind stress ! stress is applied as a body force [H L T-1 ~> m2 s-1 or kg m-1 s-1]. + real, allocatable, dimension(:,:) :: hf_du_dt_visc_2d ! Depth sum of hf_du_dt_visc [L T-2 ~> m s-2] + real, allocatable, dimension(:,:) :: hf_dv_dt_visc_2d ! Depth sum of hf_dv_dt_visc [L T-2 ~> m s-2] + logical :: do_i(SZIB_(G)) logical :: DoStokesMixing - integer :: i, j, k, is, ie, Isq, Ieq, Jsq, Jeq, nz, n - is = G%isc ; ie = G%iec + integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, n + is = G%isc ; ie = G%iec; js = G%jsc; je = G%jec Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB ; nz = G%ke if (.not.associated(CS)) call MOM_error(FATAL,"MOM_vert_friction(visc): "// & @@ -453,6 +464,41 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & if (present(tauy_bot) .and. (CS%id_tauy_bot > 0)) & call post_data(CS%id_tauy_bot, tauy_bot, CS%diag) + ! Diagnostics for terms multiplied by fractional thicknesses + + ! 3D diagnostics hf_du(dv)_dt_visc are commented because there is no clarity on proper remapping grid option. + ! The code is retained for degugging purposes in the future. + !if (CS%id_hf_du_dt_visc > 0) then + ! do k=1,nz ; do j=js,je ; do I=Isq,Ieq + ! CS%hf_du_dt_visc(I,j,k) = ADp%du_dt_visc(I,j,k) * ADp%diag_hfrac_u(I,j,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_du_dt_visc, CS%hf_du_dt_visc, CS%diag) + !endif + !if (CS%id_hf_dv_dt_visc > 0) then + ! do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + ! CS%hf_dv_dt_visc(i,J,k) = ADp%dv_dt_visc(i,J,k) * ADp%diag_hfrac_v(i,J,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_dv_dt_visc, CS%hf_dv_dt_visc, CS%diag) + !endif + if (CS%id_hf_du_dt_visc_2d > 0) then + allocate(hf_du_dt_visc_2d(G%IsdB:G%IedB,G%jsd:G%jed)) + hf_du_dt_visc_2d(:,:) = 0.0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + hf_du_dt_visc_2d(I,j) = hf_du_dt_visc_2d(I,j) + ADp%du_dt_visc(I,j,k) * ADp%diag_hfrac_u(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_du_dt_visc_2d, hf_du_dt_visc_2d, CS%diag) + deallocate(hf_du_dt_visc_2d) + endif + if (CS%id_hf_dv_dt_visc_2d > 0) then + allocate(hf_dv_dt_visc_2d(G%isd:G%ied,G%JsdB:G%JedB)) + hf_dv_dt_visc_2d(:,:) = 0.0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + hf_dv_dt_visc_2d(i,J) = hf_dv_dt_visc_2d(i,J) + ADp%dv_dt_visc(i,J,k) * ADp%diag_hfrac_v(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_dv_dt_visc_2d, hf_dv_dt_visc_2d, CS%diag) + deallocate(hf_dv_dt_visc_2d) + endif + end subroutine vertvisc !> Calculate the fraction of momentum originally in a layer that remains @@ -558,7 +604,8 @@ subroutine vertvisc_remnant(visc, visc_rem_u, visc_rem_v, dt, G, GV, US, CS) 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) + call uvchksum("visc_rem_[uv]", visc_rem_u, visc_rem_v, G%HI, haloshift=0, & + scalar_pair=.true.) endif end subroutine vertvisc_remnant @@ -628,6 +675,8 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) real :: z2 ! The distance from the bottom, normalized by Hbbl, nondim. real :: z2_wt ! A nondimensional (0-1) weight used when calculating z2. real :: z_clear ! The clearance of an interface above the surrounding topography [H ~> m or kg m-2]. + real :: a_cpl_max ! The maximum drag doefficient across interfaces, set so that it will be + ! representable as a 32-bit float in MKS units [Z T-1 ~> m s-1] real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. @@ -647,6 +696,7 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) "Module must be initialized before it is used.") h_neglect = GV%H_subroundoff + a_cpl_max = 1.0e37 * US%m_to_Z * US%T_to_s I_Hbbl(:) = 1.0 / (CS%Hbbl + h_neglect) I_valBL = 0.0 ; if (CS%harm_BL_val > 0.0) I_valBL = 1.0 / CS%harm_BL_val @@ -675,7 +725,7 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) endif !$OMP parallel do default(private) shared(G,GV,US,CS,visc,Isq,Ieq,nz,u,h,forces,hML_u, & - !$OMP OBC,h_neglect,dt,I_valBL,Kv_u) & + !$OMP OBC,h_neglect,dt,I_valBL,Kv_u,a_cpl_max) & !$OMP firstprivate(i_hbbl) do j=G%Jsc,G%Jec do I=Isq,Ieq ; do_i(I) = (G%mask2dCu(I,j) > 0) ; enddo @@ -810,13 +860,13 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) if (do_any_shelf) then do K=1,nz+1 ; do I=Isq,Ieq ; if (do_i_shelf(I)) then - CS%a_u(I,j,K) = forces%frac_shelf_u(I,j) * a_shelf(I,K) + & - (1.0-forces%frac_shelf_u(I,j)) * a_cpl(I,K) + CS%a_u(I,j,K) = min(a_cpl_max, forces%frac_shelf_u(I,j) * a_shelf(I,K) + & + (1.0-forces%frac_shelf_u(I,j)) * a_cpl(I,K)) ! This is Alistair's suggestion, but it destabilizes the model. I do not know why. RWH -! CS%a_u(I,j,K) = forces%frac_shelf_u(I,j) * max(a_shelf(I,K), a_cpl(I,K)) + & -! (1.0-forces%frac_shelf_u(I,j)) * a_cpl(I,K) +! CS%a_u(I,j,K) = min(a_cpl_max, forces%frac_shelf_u(I,j) * max(a_shelf(I,K), a_cpl(I,K)) + & +! (1.0-forces%frac_shelf_u(I,j)) * a_cpl(I,K)) elseif (do_i(I)) then - CS%a_u(I,j,K) = a_cpl(I,K) + CS%a_u(I,j,K) = min(a_cpl_max, a_cpl(I,K)) endif ; enddo ; enddo do k=1,nz ; do I=Isq,Ieq ; if (do_i_shelf(I)) then ! Should we instead take the inverse of the average of the inverses? @@ -826,7 +876,7 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) CS%h_u(I,j,k) = hvel(I,k) + h_neglect endif ; enddo ; enddo else - do K=1,nz+1 ; do I=Isq,Ieq ; if (do_i(I)) CS%a_u(I,j,K) = a_cpl(I,K) ; enddo ; enddo + do K=1,nz+1 ; do I=Isq,Ieq ; if (do_i(I)) CS%a_u(I,j,K) = min(a_cpl_max, a_cpl(I,K)) ; enddo ; enddo do k=1,nz ; do I=Isq,Ieq ; if (do_i(I)) CS%h_u(I,j,k) = hvel(I,k) + h_neglect ; enddo ; enddo endif @@ -842,7 +892,7 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) ! Now work on v-points. !$OMP parallel do default(private) shared(G,GV,CS,US,visc,is,ie,Jsq,Jeq,nz,v,h,forces,hML_v, & - !$OMP OBC,h_neglect,dt,I_valBL,Kv_v) & + !$OMP OBC,h_neglect,dt,I_valBL,Kv_v,a_cpl_max) & !$OMP firstprivate(i_hbbl) do J=Jsq,Jeq do i=is,ie ; do_i(i) = (G%mask2dCv(i,J) > 0) ; enddo @@ -978,13 +1028,13 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) if (do_any_shelf) then do K=1,nz+1 ; do i=is,ie ; if (do_i_shelf(i)) then - CS%a_v(i,J,K) = forces%frac_shelf_v(i,J) * a_shelf(i,k) + & - (1.0-forces%frac_shelf_v(i,J)) * a_cpl(i,K) + CS%a_v(i,J,K) = min(a_cpl_max, forces%frac_shelf_v(i,J) * a_shelf(i,k) + & + (1.0-forces%frac_shelf_v(i,J)) * a_cpl(i,K)) ! This is Alistair's suggestion, but it destabilizes the model. I do not know why. RWH -! CS%a_v(i,J,K) = forces%frac_shelf_v(i,J) * max(a_shelf(i,K), a_cpl(i,K)) + & -! (1.0-forces%frac_shelf_v(i,J)) * a_cpl(i,K) +! CS%a_v(i,J,K) = min(a_cpl_max, forces%frac_shelf_v(i,J) * max(a_shelf(i,K), a_cpl(i,K)) + & + ! (1.0-forces%frac_shelf_v(i,J)) * a_cpl(i,K)) elseif (do_i(i)) then - CS%a_v(i,J,K) = a_cpl(i,K) + CS%a_v(i,J,K) = min(a_cpl_max, a_cpl(i,K)) endif ; enddo ; enddo do k=1,nz ; do i=is,ie ; if (do_i_shelf(i)) then ! Should we instead take the inverse of the average of the inverses? @@ -994,7 +1044,7 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) CS%h_v(i,J,k) = hvel(i,k) + h_neglect endif ; enddo ; enddo else - do K=1,nz+1 ; do i=is,ie ; if (do_i(i)) CS%a_v(i,J,K) = a_cpl(i,K) ; enddo ; enddo + do K=1,nz+1 ; do i=is,ie ; if (do_i(i)) CS%a_v(i,J,K) = min(a_cpl_max, a_cpl(i,K)) ; enddo ; enddo do k=1,nz ; do i=is,ie ; if (do_i(i)) CS%h_v(i,J,k) = hvel(i,k) + h_neglect ; enddo ; enddo endif @@ -1008,10 +1058,13 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) 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) - call uvchksum("vertvisc_coef a_[uv]", CS%a_u, CS%a_v, G%HI, haloshift=0, scale=US%Z_to_m*US%s_to_T) + call uvchksum("vertvisc_coef h_[uv]", CS%h_u, CS%h_v, G%HI, haloshift=0, & + scale=GV%H_to_m, scalar_pair=.true.) + call uvchksum("vertvisc_coef a_[uv]", CS%a_u, CS%a_v, G%HI, haloshift=0, & + scale=US%Z_to_m*US%s_to_T, scalar_pair=.true.) if (allocated(hML_u) .and. allocated(hML_v)) & - call uvchksum("vertvisc_coef hML_[uv]", hML_u, hML_v, G%HI, haloshift=0, scale=GV%H_to_m) + call uvchksum("vertvisc_coef hML_[uv]", hML_u, hML_v, G%HI, & + haloshift=0, scale=GV%H_to_m, scalar_pair=.true.) endif ! Offer diagnostic fields for averaging. @@ -1090,12 +1143,12 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. real :: z2 ! A copy of z_i [nondim] + real :: botfn ! A function that is 1 at the bottom and small far from it [nondim] real :: topfn ! A function that is 1 at the top and small far from it [nondim] real :: kv_top ! A viscosity associated with the top boundary layer [Z2 T-1 ~> m2 s-1] logical :: do_shelf, do_OBCs integer :: i, k, is, ie, max_nk integer :: nz - real :: botfn a_cpl(:,:) = 0.0 Kv_tot(:,:) = 0.0 @@ -1105,10 +1158,10 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, nz = G%ke h_neglect = GV%H_subroundoff - ! The maximum coupling coefficent was originally introduced to avoid - ! truncation error problems in the tridiagonal solver. Effectively, the 1e-10 - ! sets the maximum coupling coefficient increment to 1e10 m per timestep. if (CS%answers_2018) then + ! The maximum coupling coefficent was originally introduced to avoid + ! truncation error problems in the tridiagonal solver. Effectively, the 1e-10 + ! sets the maximum coupling coefficient increment to 1e10 m per timestep. I_amax = (1.0e-10*US%Z_to_m) * dt else I_amax = 0.0 @@ -1567,10 +1620,10 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & CS%diag => diag ; CS%ntrunc => ntrunc ; ntrunc = 0 ! Default, read and log parameters - call log_version(param_file, mdl, version, "") + call log_version(param_file, mdl, version, "", log_to_all=.true., debugging=.true.) call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=.true.) + default=.false.) call get_param(param_file, mdl, "VERT_FRICTION_2018_ANSWERS", CS%answers_2018, & "If true, use the order of arithmetic and expressions that recover the answers "//& "from the end of 2018. Otherwise, use expressions that do not use an arbitrary "//& @@ -1753,6 +1806,40 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & Time, 'Meridional Bottom Stress from Ocean to Earth', 'Pa', & conversion=US%RZ_to_kg_m2*US%L_T2_to_m_s2) + !CS%id_hf_du_dt_visc = register_diag_field('ocean_model', 'hf_du_dt_visc', diag%axesCuL, Time, & + ! 'Fractional Thickness-weighted Zonal Acceleration from Vertical Viscosity', 'm s-2', & + ! v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_du_dt_visc > 0) then + ! call safe_alloc_ptr(CS%hf_du_dt_visc,IsdB,IedB,jsd,jed,nz) + ! call safe_alloc_ptr(ADp%du_dt_visc,IsdB,IedB,jsd,jed,nz) + ! call safe_alloc_ptr(ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + !endif + + !CS%id_hf_dv_dt_visc = register_diag_field('ocean_model', 'hf_dv_dt_visc', diag%axesCvL, Time, & + ! 'Fractional Thickness-weighted Meridional Acceleration from Vertical Viscosity', 'm s-2', & + ! v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_dv_dt_visc > 0) then + ! call safe_alloc_ptr(CS%hf_dv_dt_visc,isd,ied,JsdB,JedB,nz) + ! call safe_alloc_ptr(ADp%dv_dt_visc,isd,ied,JsdB,JedB,nz) + ! call safe_alloc_ptr(ADp%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + !endif + + CS%id_hf_du_dt_visc_2d = register_diag_field('ocean_model', 'hf_du_dt_visc_2d', diag%axesCu1, Time, & + 'Depth-sum Fractional Thickness-weighted Zonal Acceleration from Vertical Viscosity', 'm s-2', & + conversion=US%L_T2_to_m_s2) + if (CS%id_hf_du_dt_visc_2d > 0) then + call safe_alloc_ptr(ADp%du_dt_visc,IsdB,IedB,jsd,jed,nz) + call safe_alloc_ptr(ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + endif + + CS%id_hf_dv_dt_visc_2d = register_diag_field('ocean_model', 'hf_dv_dt_visc_2d', diag%axesCv1, Time, & + 'Depth-sum Fractional Thickness-weighted Meridional Acceleration from Vertical Viscosity', 'm s-2', & + conversion=US%L_T2_to_m_s2) + if (CS%id_hf_dv_dt_visc_2d > 0) then + call safe_alloc_ptr(ADp%dv_dt_visc,isd,ied,JsdB,JedB,nz) + call safe_alloc_ptr(ADp%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + endif + if ((len_trim(CS%u_trunc_file) > 0) .or. (len_trim(CS%v_trunc_file) > 0)) & call PointAccel_init(MIS, Time, G, param_file, diag, dirs, CS%PointAccel_CSp) diff --git a/src/tracer/DOME_tracer.F90 b/src/tracer/DOME_tracer.F90 index f8bc58c8d8..7396a4092a 100644 --- a/src/tracer/DOME_tracer.F90 +++ b/src/tracer/DOME_tracer.F90 @@ -338,9 +338,9 @@ 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(state, h, G, CS) +subroutine DOME_tracer_surface_state(sfc_state, h, G, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(surface), intent(inout) :: state !< A structure containing fields that + 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_(G)), & intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. @@ -361,7 +361,7 @@ subroutine DOME_tracer_surface_state(state, h, G, CS) ! This call loads the surface values into the appropriate array in the ! coupler-type structure. call coupler_type_set_data(CS%tr(:,:,1,m), CS%ind_tr(m), ind_csurf, & - state%tr_fields, idim=(/isd, is, ie, ied/), & + sfc_state%tr_fields, idim=(/isd, is, ie, ied/), & jdim=(/jsd, js, je, jed/) ) enddo endif diff --git a/src/tracer/ISOMIP_tracer.F90 b/src/tracer/ISOMIP_tracer.F90 index 95d451791e..5503287c50 100644 --- a/src/tracer/ISOMIP_tracer.F90 +++ b/src/tracer/ISOMIP_tracer.F90 @@ -287,7 +287,7 @@ subroutine ISOMIP_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, G if (.not.associated(CS)) return - melt(:,:) = fluxes%iceshelf_melt + melt(:,:) = fluxes%iceshelf_melt(:,:) ! max. melt mmax = MAXVAL(melt(is:ie,js:je)) @@ -325,9 +325,9 @@ 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(state, h, G, CS) +subroutine ISOMIP_tracer_surface_state(sfc_state, h, G, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(surface), intent(inout) :: state !< A structure containing fields that + 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_(G)), & intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. @@ -348,7 +348,7 @@ subroutine ISOMIP_tracer_surface_state(state, h, G, CS) ! This call loads the surface values into the appropriate array in the ! coupler-type structure. call coupler_type_set_data(CS%tr(:,:,1,m), CS%ind_tr(m), ind_csurf, & - state%tr_fields, idim=(/isd, is, ie, ied/), & + sfc_state%tr_fields, idim=(/isd, is, ie, ied/), & jdim=(/jsd, js, je, jed/) ) enddo endif diff --git a/src/tracer/MOM_OCMIP2_CFC.F90 b/src/tracer/MOM_OCMIP2_CFC.F90 index a95ea654f4..9aad84a6dd 100644 --- a/src/tracer/MOM_OCMIP2_CFC.F90 +++ b/src/tracer/MOM_OCMIP2_CFC.F90 @@ -542,9 +542,9 @@ 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(state, h, G, CS) +subroutine OCMIP2_CFC_surface_state(sfc_state, h, G, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(surface), intent(inout) :: state !< A structure containing fields that + 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_(G)), & intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. @@ -572,8 +572,8 @@ subroutine OCMIP2_CFC_surface_state(state, h, G, CS) if (.not.associated(CS)) return do j=js,je ; do i=is,ie - ta = max(0.01, (state%SST(i,j) + 273.15) * 0.01) ! Why is this in hectoKelvin? - sal = state%SSS(i,j) ; SST = state%SST(i,j) + ta = max(0.01, (sfc_state%SST(i,j) + 273.15) * 0.01) ! Why is this in hectoKelvin? + sal = sfc_state%SSS(i,j) ; SST = 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. @@ -603,13 +603,13 @@ subroutine OCMIP2_CFC_surface_state(state, h, G, CS) ! These calls load these values into the appropriate arrays in the ! coupler-type structure. call coupler_type_set_data(CFC11_alpha, CS%ind_cfc_11_flux, ind_alpha, & - state%tr_fields, idim=idim, jdim=jdim) + sfc_state%tr_fields, idim=idim, jdim=jdim) call coupler_type_set_data(CFC11_Csurf, CS%ind_cfc_11_flux, ind_csurf, & - state%tr_fields, idim=idim, jdim=jdim) + sfc_state%tr_fields, idim=idim, jdim=jdim) call coupler_type_set_data(CFC12_alpha, CS%ind_cfc_12_flux, ind_alpha, & - state%tr_fields, idim=idim, jdim=jdim) + sfc_state%tr_fields, idim=idim, jdim=jdim) call coupler_type_set_data(CFC12_Csurf, CS%ind_cfc_12_flux, ind_csurf, & - state%tr_fields, idim=idim, jdim=jdim) + sfc_state%tr_fields, idim=idim, jdim=jdim) end subroutine OCMIP2_CFC_surface_state diff --git a/src/tracer/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 index 83c2c9a8e7..66c0e33bac 100644 --- a/src/tracer/MOM_generic_tracer.F90 +++ b/src/tracer/MOM_generic_tracer.F90 @@ -1,14 +1,20 @@ +!> 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 -#ifdef _USE_GENERIC_TRACER -#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 - use mpp_mod, only: stdout, mpp_error, FATAL,WARNING,NOTE - use field_manager_mod, only: fm_get_index,fm_string_len + ! ### 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 @@ -46,6 +52,9 @@ module MOM_generic_tracer implicit none ; private + + !> An 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 @@ -56,25 +65,24 @@ module MOM_generic_tracer public MOM_generic_tracer_min_max public MOM_generic_tracer_fluxes_accumulate + !> Control structure for generic tracers type, public :: MOM_generic_tracer_CS ; private - character(len = 200) :: IC_file ! The file in which the generic tracer initial values can - ! be found, or an empty string for internal initialization. - logical :: Z_IC_file ! If true, the generic_tracer IC_file is in Z-space. The default is false. - real :: tracer_IC_val = 0.0 ! The initial value assigned to tracers. - real :: tracer_land_val = -1.0 ! The values of tracers used where land is masked out. - logical :: tracers_may_reinit ! If true, tracers may go through the - ! initialization code if they are not found in the - ! restart files. - - type(diag_ctrl), pointer :: diag => NULL() ! A structure that is used to - ! regulate the timing of diagnostic output. - type(MOM_restart_CS), pointer :: restart_CSp => NULL() - - ! The following pointer will be directed to the first element of the - ! linked list of generic tracers. + character(len = 200) :: IC_file !< The file in which the generic tracer initial values can + !! be found, or an empty string for internal initialization. + logical :: Z_IC_file !< If true, the generic_tracer IC_file is in Z-space. The default is false. + real :: tracer_IC_val = 0.0 !< The initial value assigned to tracers. + real :: tracer_land_val = -1.0 !< The values of tracers used where land is masked out. + logical :: tracers_may_reinit !< If true, tracers may go through the + !! initialization code if they are not found in the restart files. + + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to + !! regulate the timing of diagnostic output. + type(MOM_restart_CS), pointer :: restart_CSp => NULL() !< Restart control structure + + !> Pointer to the first element of the linked list of generic tracers. type(g_tracer_type), pointer :: g_tracer_list => NULL() - integer :: H_to_m !Auxiliary to access GV%H_to_m in routines that do not have access to GV + integer :: H_to_m !< Auxiliary to access GV%H_to_m in routines that do not have access to GV end type MOM_generic_tracer_CS @@ -98,7 +106,7 @@ function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) ! Local variables logical :: register_MOM_generic_tracer - character(len=fm_string_len), parameter :: sub_name = 'register_MOM_generic_tracer' + 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? @@ -112,7 +120,7 @@ function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) register_MOM_generic_tracer = .false. if (associated(CS)) then - call mpp_error(WARNING, "register_MOM_generic_tracer called with an "// & + call MOM_error(WARNING, "register_MOM_generic_tracer called with an "// & "associated control structure.") return endif @@ -175,7 +183,7 @@ function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) !Get the tracer list call generic_tracer_get_list(CS%g_tracer_list) - if (.NOT. associated(CS%g_tracer_list)) call mpp_error(FATAL, trim(sub_name)//& + if (.NOT. associated(CS%g_tracer_list)) call MOM_error(FATAL, trim(sub_name)//& ": No tracer in the list.") ! For each tracer name get its T_prog index and get its fields @@ -237,7 +245,7 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, US, h, param_file, type(ALE_sponge_CS), pointer :: ALE_sponge_CSp !< Pointer to the control structure for the !! ALE sponges. - character(len=fm_string_len), parameter :: sub_name = 'initialize_MOM_generic_tracer' + character(len=128), parameter :: sub_name = 'initialize_MOM_generic_tracer' logical :: OK integer :: i, j, k, isc, iec, jsc, jec, nk type(g_tracer_type), pointer :: g_tracer,g_tracer_next @@ -255,7 +263,7 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, US, h, param_file, CS%diag=>diag !Get the tracer list - if (.NOT. associated(CS%g_tracer_list)) call mpp_error(FATAL, trim(sub_name)//& + if (.NOT. associated(CS%g_tracer_list)) call MOM_error(FATAL, trim(sub_name)//& ": No tracer in the list.") !For each tracer name get its fields g_tracer=>CS%g_tracer_list @@ -388,8 +396,8 @@ end subroutine initialize_MOM_generic_tracer !! flux as a source. subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, 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 + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(in) :: h_old !< Layer thickness before entrainment [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & @@ -402,27 +410,28 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, !! 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 [H ~> m or kg m-2] - real, intent(in) :: dt !< The amount of time covered by this call [s] + 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 [s] 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(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 !< Limits how much water can be fluxed out of - !! the top layer Stored previously in diabatic CS. + !! the top layer 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. + !! 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=fm_string_len), parameter :: sub_name = 'MOM_generic_tracer_column_physics' + character(len=128), parameter :: sub_name = 'MOM_generic_tracer_column_physics' type(g_tracer_type), pointer :: g_tracer, g_tracer_next character(len=fm_string_len) :: g_tracer_name real, dimension(:,:), pointer :: stf_array,trunoff_array,runoff_tracer_flux_array real :: surface_field(SZI_(G),SZJ_(G)) + real :: dz_ml(SZI_(G),SZJ_(G)) ! The mixed layer depth in the MKS units used for generic tracers [m] real :: sosga real, dimension(G%isd:G%ied,G%jsd:G%jed,G%ke) :: rho_dzt, dzt @@ -432,7 +441,7 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec ; nk = G%ke !Get the tracer list - if (.NOT. associated(CS%g_tracer_list)) call mpp_error(FATAL,& + if (.NOT. associated(CS%g_tracer_list)) call MOM_error(FATAL,& trim(sub_name)//": No tracer in the list.") #ifdef _USE_MOM6_DIAG @@ -483,9 +492,10 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, do k = 1, nk ; do j = jsc, jec ; do i = isc, iec !{ dzt(i,j,k) = GV%H_to_m * h_old(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) + surface_field(i,j) = tv%S(i,j,1) + dz_ml(i,j) = G%US%Z_to_m * Hml(i,j) enddo ; enddo sosga = global_area_mean(surface_field, G) @@ -494,12 +504,12 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, ! if ((G%US%L_to_m == 1.0) .and. (G%US%RZ_to_kg_m2 == 1.0) .and. (G%US%s_to_T == 1.0)) then ! Avoid unnecessary copies when no unit conversion is needed. - call generic_tracer_source(tv%T, tv%S, rho_dzt, dzt, Hml, G%isd, G%jsd, 1, dt, & + 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(tv%T, tv%S, rho_dzt, dzt, Hml, G%isd, G%jsd, 1, dt, & + call generic_tracer_source(tv%T, 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, optics%sw_pen_band, optics%opacity_band, & internal_heat=G%US%RZ_to_kg_m2*tv%internal_heat(:,:), & @@ -575,7 +585,7 @@ function MOM_generic_tracer_stock(h, stocks, G, GV, CS, names, units, stock_inde type(g_tracer_type), pointer :: g_tracer, g_tracer_next real, dimension(:,:,:,:), pointer :: tr_field real, dimension(:,:,:), pointer :: tr_ptr - character(len=fm_string_len), parameter :: sub_name = 'MOM_generic_tracer_stock' + character(len=128), parameter :: sub_name = 'MOM_generic_tracer_stock' integer :: i, j, k, is, ie, js, je, nz, m is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke @@ -648,7 +658,7 @@ function MOM_generic_tracer_min_max(ind_start, got_minmax, gmin, gmax, xgmin, yg type(g_tracer_type), pointer :: g_tracer, g_tracer_next real, dimension(:,:,:,:), pointer :: tr_field real, dimension(:,:,:), pointer :: tr_ptr - character(len=fm_string_len), parameter :: sub_name = 'MOM_generic_tracer_min_max' + character(len=128), parameter :: sub_name = 'MOM_generic_tracer_min_max' real, dimension(:,:,:),pointer :: grid_tmask integer :: isc,iec,jsc,jec,isd,ied,jsd,jed,nk,ntau @@ -706,9 +716,9 @@ end function MOM_generic_tracer_min_max !! !! 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(state, h, G, CS) + subroutine MOM_generic_tracer_surface_state(sfc_state, h, G, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(surface), intent(inout) :: state !< A structure containing fields that + 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_(G)), 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. @@ -716,7 +726,7 @@ subroutine MOM_generic_tracer_surface_state(state, h, G, CS) ! Local variables real :: sosga - character(len=fm_string_len), parameter :: sub_name = 'MOM_generic_tracer_surface_state' + character(len=128), parameter :: sub_name = 'MOM_generic_tracer_surface_state' real, dimension(G%isd:G%ied,G%jsd:G%jed,1:G%ke,1) :: rho0 real, dimension(G%isd:G%ied,G%jsd:G%jed,1:G%ke) :: dzt type(g_tracer_type), pointer :: g_tracer @@ -727,18 +737,18 @@ subroutine MOM_generic_tracer_surface_state(state, h, G, CS) dzt(:,:,:) = CS%H_to_m * h(:,:,:) - sosga = global_area_mean(state%SSS, G) + sosga = global_area_mean(sfc_state%SSS, G) - call generic_tracer_coupler_set(state%tr_fields,& - ST=state%SST,& - SS=state%SSS,& + 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)) !Output diagnostics via diag_manager for all tracers in this module -! if (.NOT. associated(CS%g_tracer_list)) call mpp_error(FATAL, trim(sub_name)//& +! if (.NOT. associated(CS%g_tracer_list)) call MOM_error(FATAL, trim(sub_name)//& ! "No tracer in the list.") ! call g_tracer_send_diag(CS%g_tracer_list, get_diag_time_end(CS%diag), tau=1) !Niki: The problem with calling diagnostic outputs here is that this subroutine is called every dt_cpld @@ -755,7 +765,7 @@ subroutine MOM_generic_flux_init(verbosity) integer :: ind character(len=fm_string_len) :: g_tracer_name,longname, package,units,old_package,file_in,file_out real :: const_init_value - character(len=fm_string_len), parameter :: sub_name = 'MOM_generic_flux_init' + character(len=128), parameter :: sub_name = 'MOM_generic_flux_init' type(g_tracer_type), pointer :: g_tracer_list,g_tracer,g_tracer_next if (.not. g_registered) then @@ -765,7 +775,7 @@ subroutine MOM_generic_flux_init(verbosity) call generic_tracer_get_list(g_tracer_list) if (.NOT. associated(g_tracer_list)) then - call mpp_error(WARNING, trim(sub_name)// ": No generic tracer in the list.") + call MOM_error(WARNING, trim(sub_name)// ": No generic tracer in the list.") return endif @@ -800,7 +810,7 @@ subroutine MOM_generic_tracer_get(name,member,array, CS) type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. real, dimension(:,:,:), pointer :: array_ptr - character(len=fm_string_len), parameter :: sub_name = 'MOM_generic_tracer_get' + character(len=128), parameter :: sub_name = 'MOM_generic_tracer_get' call g_tracer_get_pointer(CS%g_tracer_list,name,member,array_ptr) array(:,:,:) = array_ptr(:,:,:) @@ -818,7 +828,6 @@ subroutine end_MOM_generic_tracer(CS) endif end subroutine end_MOM_generic_tracer -#endif /* _USE_GENERIC_TRACER */ !---------------------------------------------------------------- ! Niki Zadeh ! diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index 82e0d6a559..465174f676 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -23,6 +23,7 @@ module MOM_lateral_boundary_diffusion 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 iso_fortran_env, only : stdout=>output_unit, stderr=>error_unit implicit none ; private @@ -36,13 +37,18 @@ module MOM_lateral_boundary_diffusion !> Sets parameters for lateral boundary mixing module. type, public :: lateral_boundary_diffusion_CS ; private - integer :: method !< Determine which of the three methods calculate - !! and apply near boundary layer fluxes - !! 1. Bulk-layer approach - !! 2. Along layer - integer :: deg !< Degree of polynomial reconstruction - integer :: surface_boundary_scheme !< Which boundary layer scheme to use - !! 1. ePBL; 2. KPP + integer :: method !< Determine which of the three methods calculate + !! and apply near boundary layer fluxes + !! 1. Along layer + !! 2. Bulk-layer approach (not recommended) + integer :: deg !< Degree of polynomial reconstruction + integer :: surface_boundary_scheme !< Which boundary layer scheme to use + !! 1. ePBL; 2. KPP + logical :: limiter !< Controls wether a flux limiter is applied. + !! Only valid when method = 2. + 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. + 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 @@ -76,15 +82,16 @@ logical function lateral_boundary_diffusion_init(Time, G, param_file, diag, diab endif ! Log this module and master switch for turning it on/off + call get_param(param_file, mdl, "USE_LATERAL_BOUNDARY_DIFFUSION", lateral_boundary_diffusion_init, & + default=.false., do_not_log=.true.) call log_version(param_file, mdl, version, & - "This module implements lateral diffusion of tracers near boundaries") + "This module implements lateral diffusion of tracers near boundaries", & + all_default=.not.lateral_boundary_diffusion_init) call get_param(param_file, mdl, "USE_LATERAL_BOUNDARY_DIFFUSION", lateral_boundary_diffusion_init, & "If true, enables the lateral boundary tracer's diffusion module.", & default=.false.) - if (.not. lateral_boundary_diffusion_init) then - return - endif + if (.not. lateral_boundary_diffusion_init) return allocate(CS) CS%diag => diag @@ -99,8 +106,16 @@ logical function lateral_boundary_diffusion_init(Time, G, param_file, diag, diab ! Read all relevant parameters and write them to the model log. call get_param(param_file, mdl, "LATERAL_BOUNDARY_METHOD", CS%method, & "Determine how to apply boundary lateral diffusion of tracers: \n"//& - "1. Bulk layer approach \n"//& - "2. Along layer approach", default=1) + "1. Along layer approach \n"//& + "2. Bulk layer approach (this option is not recommended)", default=1) + if (CS%method == 2) then + call get_param(param_file, mdl, "APPLY_LIMITER", CS%limiter, & + "If True, apply a flux limiter in the LBD. This is only available \n"//& + "when LATERAL_BOUNDARY_METHOD=2.", default=.false.) + endif + call get_param(param_file, mdl, "LBD_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, "LBD_BOUNDARY_EXTRAP", boundary_extrap, & "Use boundary extrapolation in LBD code", & default=.false.) @@ -125,15 +140,15 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(in) :: h !< Layer thickness [H ~> m or kg m-2] - real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: Coef_x !< dt * Kh * dy / dx at u-points [m2] - real, dimension(SZI_(G),SZJB_(G)), intent(in) :: Coef_y !< dt * Kh * dx / dy at v-points [m2] + real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: Coef_x !< dt * Kh * dy / dx at u-points [L2 ~> m2] + real, dimension(SZI_(G),SZJB_(G)), 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) type(tracer_registry_type), pointer :: Reg !< Tracer registry type(lateral_boundary_diffusion_CS), intent(in) :: CS !< Control structure for this module ! Local variables - real, dimension(SZI_(G),SZJ_(G)) :: hbl !< bnd. layer depth [m] + real, dimension(SZI_(G),SZJ_(G)) :: hbl !< bnd. layer depth [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(G),CS%deg+1) :: ppoly0_coefs !< Coefficients of polynomial real, dimension(SZI_(G),SZJ_(G),SZK_(G),2) :: ppoly0_E !< Edge values from reconstructions real, dimension(SZK_(G),CS%deg+1) :: ppoly_S !< Slopes from reconstruction (placeholder) @@ -152,8 +167,9 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) Idt = 1./dt hbl(:,:) = 0. - if (ASSOCIATED(CS%KPP_CSp)) call KPP_get_BLD(CS%KPP_CSp, hbl, G) - if (ASSOCIATED(CS%energetic_PBL_CSp)) call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, hbl, G, US) + 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) do m = 1,Reg%ntr @@ -161,68 +177,71 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) ! for diagnostics if (tracer%id_lbdxy_conc > 0 .or. tracer%id_lbdxy_cont > 0 .or. tracer%id_lbdxy_cont_2d > 0) then - tendency(:,:,:) = 0.0 + tendency(:,:,:) = 0.0 endif - do j = G%jsc-1, G%jec+1 - ! Interpolate state to interface - do i = G%isc-1, G%iec+1 - call build_reconstructions_1d( CS%remap_CS, G%ke, h(i,j,:), tracer%t(i,j,:), ppoly0_coefs(i,j,:,:), & - ppoly0_E(i,j,:,:), ppoly_S, remap_method, GV%H_subroundoff, GV%H_subroundoff) - enddo - enddo + ! Interpolate state to interface + do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 + call build_reconstructions_1d( CS%remap_CS, G%ke, h(i,j,:), tracer%t(i,j,:), ppoly0_coefs(i,j,:,:), & + ppoly0_E(i,j,:,:), ppoly_S, remap_method, GV%H_subroundoff, GV%H_subroundoff) + enddo ; enddo + ! Diffusive fluxes in the i-direction uFlx(:,:,:) = 0. vFlx(:,:,:) = 0. uFlx_bulk(:,:) = 0. vFlx_bulk(:,:) = 0. - ! Method #1 - if ( CS%method == 1 ) then + ! Method #1 (layer by layer) + if (CS%method == 1) then do j=G%jsc,G%jec do i=G%isc-1,G%iec if (G%mask2dCu(I,j)>0.) then - call fluxes_bulk_method(SURFACE, GV%ke, CS%deg, h(I,j,:), h(I+1,j,:), hbl(I,j), hbl(I+1,j), & - G%areaT(I,j), G%areaT(I+1,j), tracer%t(I,j,:), tracer%t(I+1,j,:), & - ppoly0_coefs(I,j,:,:), ppoly0_coefs(I+1,j,:,:), ppoly0_E(I,j,:,:), & - ppoly0_E(I+1,j,:,:), remap_method, Coef_x(I,j), uFlx_bulk(I,j), uFlx(I,j,:)) + call fluxes_layer_method(SURFACE, GV%ke, CS%deg, h(I,j,:), h(I+1,j,:), hbl(I,j), hbl(I+1,j), & + G%areaT(I,j), G%areaT(I+1,j), tracer%t(I,j,:), tracer%t(I+1,j,:), ppoly0_coefs(I,j,:,:), & + ppoly0_coefs(I+1,j,:,:), ppoly0_E(I,j,:,:), ppoly0_E(I+1,j,:,:), remap_method, Coef_x(I,j), & + uFlx(I,j,:), CS%linear) 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_bulk_method(SURFACE, GV%ke, CS%deg, h(i,J,:), h(i,J+1,:), hbl(i,J), hbl(i,J+1), & - G%areaT(i,J), G%areaT(i,J+1), tracer%t(i,J,:), tracer%t(i,J+1,:), & - ppoly0_coefs(i,J,:,:), ppoly0_coefs(i,J+1,:,:), ppoly0_E(i,J,:,:), & - ppoly0_E(i,J+1,:,:), remap_method, Coef_y(i,J), vFlx_bulk(i,J), vFlx(i,J,:)) + call fluxes_layer_method(SURFACE, GV%ke, CS%deg, h(i,J,:), h(i,J+1,:), hbl(i,J), hbl(i,J+1), & + G%areaT(i,J), G%areaT(i,J+1), tracer%t(i,J,:), tracer%t(i,J+1,:), ppoly0_coefs(i,J,:,:), & + ppoly0_coefs(i,J+1,:,:), ppoly0_E(i,J,:,:), ppoly0_E(i,J+1,:,:), remap_method, Coef_y(i,J), & + vFlx(i,J,:), CS%linear) endif enddo enddo - ! Post tracer bulk diags - if (tracer%id_lbd_bulk_dfx>0) call post_data(tracer%id_lbd_bulk_dfx, uFlx_bulk*Idt, CS%diag) - if (tracer%id_lbd_bulk_dfy>0) call post_data(tracer%id_lbd_bulk_dfy, vFlx_bulk*Idt, CS%diag) - ! Method #2 + ! Method #2 (bulk approach) elseif (CS%method == 2) then 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, CS%deg, h(I,j,:), h(I+1,j,:), hbl(I,j), hbl(I+1,j), & - G%areaT(I,j), G%areaT(I+1,j), tracer%t(I,j,:), tracer%t(I+1,j,:), ppoly0_coefs(I,j,:,:), & - ppoly0_coefs(I+1,j,:,:), ppoly0_E(I,j,:,:), ppoly0_E(I+1,j,:,:), remap_method, Coef_x(I,j), uFlx(I,j,:)) + call fluxes_bulk_method(SURFACE, GV%ke, CS%deg, h(I,j,:), h(I+1,j,:), hbl(I,j), hbl(I+1,j), & + G%areaT(I,j), G%areaT(I+1,j), tracer%t(I,j,:), tracer%t(I+1,j,:), & + ppoly0_coefs(I,j,:,:), ppoly0_coefs(I+1,j,:,:), ppoly0_E(I,j,:,:), & + ppoly0_E(I+1,j,:,:), remap_method, Coef_x(I,j), uFlx_bulk(I,j), uFlx(I,j,:), CS%limiter, & + CS%linear) 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, CS%deg, h(i,J,:), h(i,J+1,:), hbl(i,J), hbl(i,J+1), & - G%areaT(i,J), G%areaT(i,J+1), tracer%t(i,J,:), tracer%t(i,J+1,:), ppoly0_coefs(i,J,:,:), & - ppoly0_coefs(i,J+1,:,:), ppoly0_E(i,J,:,:), ppoly0_E(i,J+1,:,:), remap_method, Coef_y(i,J), vFlx(i,J,:)) + call fluxes_bulk_method(SURFACE, GV%ke, CS%deg, h(i,J,:), h(i,J+1,:), hbl(i,J), hbl(i,J+1), & + G%areaT(i,J), G%areaT(i,J+1), tracer%t(i,J,:), tracer%t(i,J+1,:), & + ppoly0_coefs(i,J,:,:), ppoly0_coefs(i,J+1,:,:), ppoly0_E(i,J,:,:), & + ppoly0_E(i,J+1,:,:), remap_method, Coef_y(i,J), vFlx_bulk(i,J), vFlx(i,J,:), CS%limiter, & + CS%linear) endif enddo enddo + ! Post tracer bulk diags + if (tracer%id_lbd_bulk_dfx>0) call post_data(tracer%id_lbd_bulk_dfx, uFlx_bulk*Idt, CS%diag) + if (tracer%id_lbd_bulk_dfy>0) call post_data(tracer%id_lbd_bulk_dfy, vFlx_bulk*Idt, CS%diag) endif ! Update the tracer fluxes @@ -243,41 +262,41 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) if (tracer%id_lbd_dfy>0) call post_data(tracer%id_lbd_dfy, vFlx*Idt, CS%diag) if (tracer%id_lbd_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 + 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 + enddo ; enddo ; enddo call post_data(tracer%id_lbd_dfx_2d, uwork_2d, CS%diag) endif if (tracer%id_lbd_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 + 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 + enddo ; enddo ; enddo call post_data(tracer%id_lbd_dfy_2d, vwork_2d, CS%diag) endif ! post tendency of tracer content if (tracer%id_lbdxy_cont > 0) then - call post_data(tracer%id_lbdxy_cont, tendency(:,:,:), CS%diag) + call post_data(tracer%id_lbdxy_cont, tendency, CS%diag) endif ! post depth summed tendency for tracer content if (tracer%id_lbdxy_cont_2d > 0) then tendency_2d(:,:) = 0. - do j = G%jsc,G%jec ; do i = G%isc,G%iec - do k = 1, GV%ke + 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_lbdxy_cont_2d, tendency_2d(:,:), CS%diag) + call post_data(tracer%id_lbdxy_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. + ! the tendency array and its units. if (tracer%id_lbdxy_conc > 0) then - do k = 1, GV%ke ; do j = G%jsc,G%jec ; do i = G%isc,G%iec + 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_lbdxy_conc, tendency, CS%diag) @@ -290,24 +309,24 @@ end subroutine lateral_boundary_diffusion !< Calculate bulk layer value of a scalar quantity as the thickness weighted average real function bulk_average(boundary, nk, deg, h, hBLT, phi, ppoly0_E, ppoly0_coefs, method, k_top, zeta_top, k_bot, & zeta_bot) - integer :: boundary !< SURFACE or BOTTOM [nondim] - integer :: nk !< Number of layers [nondim] - integer :: deg !< Degree of polynomial [nondim] - real, dimension(nk) :: h !< Layer thicknesses [m] - real :: hBLT !< Depth of the boundary layer [m] + integer :: boundary !< SURFACE or BOTTOM [nondim] + integer :: nk !< Number of layers [nondim] + integer :: deg !< Degree of polynomial [nondim] + real, dimension(nk) :: h !< Layer thicknesses [H ~> m or kg m-2] + real :: hBLT !< Depth of the boundary layer [H ~> m or kg m-2] real, dimension(nk) :: phi !< Scalar quantity - real, dimension(nk,2) :: ppoly0_E(:,:) !< Edge value of polynomial - real, dimension(nk,deg+1) :: ppoly0_coefs(:,:) !< Coefficients of polynomial - integer :: method !< Remapping scheme to use + real, dimension(nk,2) :: ppoly0_E !< Edge value of polynomial + real, dimension(nk,deg+1) :: ppoly0_coefs!< Coefficients of polynomial + integer :: method !< Remapping scheme to use integer :: k_top !< Index of the first layer within the boundary real :: zeta_top !< Fraction of the layer encompassed by the bottom boundary layer !! (0 if none, 1. if all). For the surface, this is always 0. because - !! integration starts at the surface [nondim] + !! integration starts at the surface [nondim] integer :: k_bot !< Index of the last layer within the boundary real :: zeta_bot !< Fraction of the layer encompassed by the surface boundary layer !! (0 if none, 1. if all). For the bottom boundary layer, this is always 1. - !! because integration starts at the bottom [nondim] + !! because integration starts at the bottom [nondim] ! Local variables real :: htot !< Running sum of the thicknesses (top to bottom) integer :: k !< k indice @@ -355,8 +374,8 @@ end function harmonic_mean 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 [m] - real, intent(in ) :: hbl !< Thickness of the boundary layer [m] + 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 @@ -366,7 +385,7 @@ subroutine boundary_k_range(boundary, nk, h, hbl, k_top, zeta_top, k_bot, zeta_b 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 + real :: htot ! Summed thickness [H ~> m or kg m-2] integer :: k ! Surface boundary layer if ( boundary == SURFACE ) then @@ -378,7 +397,7 @@ subroutine boundary_k_range(boundary, nk, h, hbl, k_top, zeta_top, k_bot, zeta_b if (hbl == 0.) return if (hbl >= SUM(h(:))) then k_bot = nk - zeta_bot = 0. + zeta_bot = 1. return endif do k=1,nk @@ -394,12 +413,12 @@ subroutine boundary_k_range(boundary, nk, h, hbl, k_top, zeta_top, k_bot, zeta_b k_top = nk zeta_top = 1. k_bot = nk - zeta_bot = 1. + zeta_bot = 0. htot = 0. if (hbl == 0.) return if (hbl >= SUM(h(:))) then k_top = 1 - zeta_top = 0. + zeta_top = 1. return endif do k=nk,1,-1 @@ -418,42 +437,50 @@ end subroutine boundary_k_range !> Calculate the lateral boundary diffusive fluxes using the layer by layer method. -!! See \ref section_method2 +!! See \ref section_method1 subroutine fluxes_layer_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, & - ppoly0_coefs_L, ppoly0_coefs_R, ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) + ppoly0_coefs_L, ppoly0_coefs_R, ppoly0_E_L, ppoly0_E_R, method, khtr_u, & + F_layer, linear_decay) integer, intent(in ) :: boundary !< Which boundary layer SURFACE or BOTTOM [nondim] integer, intent(in ) :: nk !< Number of layers [nondim] integer, intent(in ) :: deg !< order of the polynomial reconstruction [nondim] - real, dimension(nk), intent(in ) :: h_L !< Layer thickness (left) [m] - real, dimension(nk), intent(in ) :: h_R !< Layer thickness (right) [m] + real, dimension(nk), intent(in ) :: h_L !< Layer thickness (left) [H ~> m or kg m-2] + real, dimension(nk), intent(in ) :: h_R !< Layer thickness (right) [H ~> m or kg m-2] real, intent(in ) :: hbl_L !< Thickness of the boundary boundary - !! layer (left) [m] + !! layer (left) [H ~> m or kg m-2] real, intent(in ) :: hbl_R !< Thickness of the boundary boundary - !! layer (right) [m] - real, intent(in ) :: area_L !< Area of the horizontal grid (left) [m^2] - real, intent(in ) :: area_R !< Area of the horizontal grid (right) [m^2] - real, dimension(nk), intent(in ) :: phi_L !< Tracer values (left) [conc] - real, dimension(nk), intent(in ) :: phi_R !< Tracer values (right) [conc] - real, dimension(nk,deg+1), intent(in ) :: ppoly0_coefs_L !< Tracer reconstruction (left) [conc] - real, dimension(nk,deg+1), intent(in ) :: ppoly0_coefs_R !< Tracer reconstruction (right) [conc] - real, dimension(nk,2), intent(in ) :: ppoly0_E_L !< Polynomial edge values (left) [ nondim ] - real, dimension(nk,2), intent(in ) :: ppoly0_E_R !< Polynomial edge values (right) [ nondim ] - integer, intent(in ) :: method !< Method of polynomial integration [ nondim ] - real, intent(in ) :: khtr_u !< Horizontal diffusivities times delta t at U-point [m^2] - real, dimension(nk), intent( out) :: F_layer !< Layerwise diffusive flux at U- or V-point [m^3 conc] - + !! layer (right) [H ~> m or kg m-2] + 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] + real, dimension(nk), intent(in ) :: phi_L !< Tracer values (left) [conc] + real, dimension(nk), intent(in ) :: phi_R !< Tracer values (right) [conc] + real, dimension(nk,deg+1), intent(in ) :: ppoly0_coefs_L !< Tracer reconstruction (left) [conc] + real, dimension(nk,deg+1), intent(in ) :: ppoly0_coefs_R !< Tracer reconstruction (right) [conc] + real, dimension(nk,2), intent(in ) :: ppoly0_E_L !< Polynomial edge values (left) [nondim] + real, dimension(nk,2), intent(in ) :: ppoly0_E_R !< Polynomial edge values (right) [nondim] + integer, intent(in ) :: method !< Method of polynomial integration [nondim] + real, intent(in ) :: khtr_u !< Horizontal diffusivities times delta t + !! at a velocity point [L2 ~> m2] + real, dimension(nk), intent( out) :: F_layer !< Layerwise diffusive flux at U- or V-point + !! [H L2 conc ~> m3 conc] + logical, optional, intent(in ) :: linear_decay !< If True, apply a linear transition at the base of + !! the boundary layer ! Local variables - real, dimension(nk) :: h_means !< Calculate the layer-wise harmonic means [m] + real, dimension(nk) :: h_means !< Calculate the layer-wise harmonic means [H ~> m or kg m-2] real :: khtr_avg !< Thickness-weighted diffusivity at the u-point [m^2 s^-1] !! This is just to remind developers that khtr_avg should be !! computed once khtr is 3D. - real :: heff !< Harmonic mean of layer thicknesses [m] - real :: inv_heff !< Inverse of the harmonic mean of layer thicknesses [m^[-1] + real :: heff !< Harmonic mean of layer thicknesses [H ~> m or kg m-2] + real :: inv_heff !< Inverse of the harmonic mean of layer thicknesses + !! [H-1 ~> m-1 or m2 kg-1] real :: phi_L_avg, phi_R_avg !< Bulk, thickness-weighted tracer averages (left and right column) !! [conc m^-3 ] - real :: htot !< Total column thickness [m] - integer :: k, k_bot_min, k_top_max !< k-indices, min and max for top and bottom, respectively + real :: htot !< Total column thickness [H ~> m or kg m-2] + real :: heff_tot !< Total effective column thickness in the transition layer [m] + integer :: k, k_bot_min, k_top_max !< k-indices, min and max for bottom and top, respectively + integer :: k_bot_max, k_top_min !< k-indices, max and min for bottom and top, respectively + integer :: k_bot_diff, k_top_diff !< different between left and right k-indices for bottom and top, respectively integer :: k_top_L, k_bot_L !< k-indices left integer :: k_top_R, k_bot_R !< k-indices right real :: zeta_top_L, zeta_top_R !< distance from the top of a layer to the boundary @@ -461,19 +488,30 @@ subroutine fluxes_layer_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L real :: zeta_bot_L, zeta_bot_R !< distance from the bottom of a layer to the boundary !!layer depth [nondim] real :: h_work_L, h_work_R !< dummy variables - real :: hbl_min !< minimum BLD (left and right) [m] + real :: hbl_min !< minimum BLD (left and right) [m] + real :: wgt !< weight to be used in the linear transition to the interior [nondim] + real :: a !< coefficient to be used in the linear transition to the interior [nondim] + logical :: linear !< True if apply a linear transition F_layer(:) = 0.0 if (hbl_L == 0. .or. hbl_R == 0.) then return endif + linear = .false. + if (PRESENT(linear_decay)) then + linear = linear_decay + endif + ! Calculate vertical indices containing the boundary layer call boundary_k_range(boundary, nk, h_L, hbl_L, k_top_L, zeta_top_L, k_bot_L, zeta_bot_L) call boundary_k_range(boundary, nk, h_R, 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) + ! make sure left and right k indices span same range if (k_bot_min .ne. k_bot_L) then k_bot_L = k_bot_min @@ -492,15 +530,37 @@ subroutine fluxes_layer_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L heff = harmonic_mean(h_work_L, h_work_R) ! tracer flux where the minimum BLD intersets layer ! GMM, khtr_avg should be computed once khtr is 3D - F_layer(k_bot_min) = -(heff * khtr_u) * (phi_R_avg - phi_L_avg) + if ((linear) .and. (k_bot_diff .gt. 1)) then + ! apply linear decay at the base of hbl + do k = k_bot_min,1,-1 + heff = harmonic_mean(h_L(k), h_R(k)) + F_layer(k) = -(heff * khtr_u) * (phi_R(k) - phi_L(k)) + enddo + ! heff_total + heff_tot = 0.0 + do k = k_bot_min+1,k_bot_max, 1 + heff_tot = heff_tot + harmonic_mean(h_L(k), h_R(k)) + enddo - do k = k_bot_min-1,1,-1 - heff = harmonic_mean(h_L(k), h_R(k)) - F_layer(k) = -(heff * khtr_u) * (phi_R(k) - phi_L(k)) - enddo + a = -1.0/heff_tot + heff_tot = 0.0 + do k = k_bot_min+1,k_bot_max, 1 + heff = harmonic_mean(h_L(k), h_R(k)) + wgt = (a*(heff_tot + (heff * 0.5))) + 1.0 + F_layer(k) = -(heff * khtr_u) * (phi_R(k) - phi_L(k)) * wgt + heff_tot = heff_tot + heff + enddo + else + F_layer(k_bot_min) = -(heff * khtr_u) * (phi_R_avg - phi_L_avg) + do k = k_bot_min-1,1,-1 + heff = harmonic_mean(h_L(k), h_R(k)) + F_layer(k) = -(heff * khtr_u) * (phi_R(k) - phi_L(k)) + enddo + endif endif if (boundary == BOTTOM) then + ! TODO: GMM add option to apply linear decay k_top_max = MAX(k_top_L, k_top_R) ! make sure left and right k indices span same range if (k_top_max .ne. k_top_L) then @@ -531,44 +591,53 @@ subroutine fluxes_layer_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L end subroutine fluxes_layer_method !> Apply the lateral boundary diffusive fluxes calculated from a 'bulk model' -!! See \ref section_method1 +!! See \ref section_method2 subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, ppoly0_coefs_L, & - ppoly0_coefs_R, ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer, F_limit) + ppoly0_coefs_R, ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer, F_limit, & + linear_decay) integer, intent(in ) :: boundary !< Which boundary layer SURFACE or BOTTOM [nondim] integer, intent(in ) :: nk !< Number of layers [nondim] integer, intent(in ) :: deg !< order of the polynomial reconstruction [nondim] - real, dimension(nk), intent(in ) :: h_L !< Layer thickness (left) [m] - real, dimension(nk), intent(in ) :: h_R !< Layer thickness (right) [m] + real, dimension(nk), intent(in ) :: h_L !< Layer thickness (left) [H ~> m or kg m-2] + real, dimension(nk), intent(in ) :: h_R !< Layer thickness (right) [H ~> m or kg m-2] real, intent(in ) :: hbl_L !< Thickness of the boundary boundary - !! layer (left) [m] + !! layer (left) [H ~> m or kg m-2] real, intent(in ) :: hbl_R !< Thickness of the boundary boundary - !! layer (left) [m] - real, intent(in ) :: area_L !< Area of the horizontal grid (left) [m^2] - real, intent(in ) :: area_R !< Area of the horizontal grid (right) [m^2] - real, dimension(nk), intent(in ) :: phi_L !< Tracer values (left) [conc] - real, dimension(nk), intent(in ) :: phi_R !< Tracer values (right) [conc] - real, dimension(nk,deg+1), intent(in ) :: ppoly0_coefs_L !< Tracer reconstruction (left) [conc] - real, dimension(nk,deg+1), intent(in ) :: ppoly0_coefs_R !< Tracer reconstruction (right) [conc] - real, dimension(nk,2), intent(in ) :: ppoly0_E_L !< Polynomial edge values (left) [nondim] - real, dimension(nk,2), intent(in ) :: ppoly0_E_R !< Polynomial edge values (right) [nondim] - integer, intent(in ) :: method !< Method of polynomial integration [nondim] - real, intent(in ) :: khtr_u !< Horizontal diffusivities times delta t at U-point [m^2] - real, intent( out) :: F_bulk !< The bulk mixed layer lateral flux [m^3 conc] - real, dimension(nk), intent( out) :: F_layer !< Layerwise diffusive flux at U-point [m^3 conc] - real, optional, dimension(nk), intent( out) :: F_limit !< The amount of flux not applied due to limiter - !! F_layer(k) - F_max [m^3 conc] + !! layer (left) [H ~> m or kg m-2] + 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] + real, dimension(nk), intent(in ) :: phi_L !< Tracer values (left) [conc] + real, dimension(nk), intent(in ) :: phi_R !< Tracer values (right) [conc] + real, dimension(nk,deg+1), intent(in ) :: ppoly0_coefs_L !< Tracer reconstruction (left) [conc] + real, dimension(nk,deg+1), intent(in ) :: ppoly0_coefs_R !< Tracer reconstruction (right) [conc] + real, dimension(nk,2), intent(in ) :: ppoly0_E_L !< Polynomial edge values (left) [nondim] + real, dimension(nk,2), intent(in ) :: ppoly0_E_R !< Polynomial edge values (right) [nondim] + integer, intent(in ) :: method !< Method of polynomial integration [nondim] + real, intent(in ) :: khtr_u !< Horizontal diffusivities times delta t + !! at a velocity point [L2 ~> m2] + real, intent( out) :: F_bulk !< The bulk mixed layer lateral flux + !! [H L2 conc ~> m3 conc] + real, dimension(nk), intent( out) :: F_layer !< Layerwise diffusive flux at U- or V-point + !! [H L2 conc ~> m3 conc] + logical, optional, intent(in ) :: F_limit !< If True, apply a limiter + logical, optional, intent(in ) :: linear_decay !< If True, apply a linear transition at the base of + !! the boundary layer + ! Local variables - real, dimension(nk) :: h_means !< Calculate the layer-wise harmonic means [m] + real, dimension(nk) :: h_means !< Calculate the layer-wise harmonic means [H ~> m or kg m-2] real :: khtr_avg !< Thickness-weighted diffusivity at the u-point [m^2 s^-1] !! This is just to remind developers that khtr_avg should be !! computed once khtr is 3D. - real :: heff !< Harmonic mean of layer thicknesses [m] - real :: inv_heff !< Inverse of the harmonic mean of layer thicknesses [m^[-1] + real :: heff !< Harmonic mean of layer thicknesses [H ~> m or kg m-2] + real :: heff_tot !< Total effective column thickness in the transition layer [m] + real :: inv_heff !< Inverse of the harmonic mean of layer thicknesses + !! [H-1 ~> m-1 or m2 kg-1] real :: phi_L_avg, phi_R_avg !< Bulk, thickness-weighted tracer averages (left and right column) !! [conc m^-3 ] - real :: htot ! Total column thickness [m] + real :: htot ! Total column thickness [H ~> m or kg m-2] integer :: k, k_min, k_max !< k-indices, min and max for top and bottom, respectively + integer :: k_diff !< difference between k_max and k_min integer :: k_top_L, k_bot_L !< k-indices left integer :: k_top_R, k_bot_R !< k-indices right real :: zeta_top_L, zeta_top_R !< distance from the top of a layer to the @@ -578,15 +647,30 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, real :: h_work_L, h_work_R !< dummy variables real :: F_max !< The maximum amount of flux that can leave a !! cell [m^3 conc] - logical :: limited !< True if the flux limiter was applied - real :: hfrac, F_bulk_remain - + logical :: limiter !< True if flux limiter should be applied + logical :: linear !< True if apply a linear transition + real :: hfrac !< Layer fraction wrt sum of all layers [nondim] + real :: dphi !< tracer gradient [conc m^-3] + real :: wgt !< weight to be used in the linear transition to the + !! interior [nondim] + real :: a !< coefficient to be used in the linear transition to the + !! interior [nondim] + + F_bulk = 0. + F_layer(:) = 0. if (hbl_L == 0. .or. hbl_R == 0.) then - F_bulk = 0. - F_layer(:) = 0. return endif + limiter = .false. + if (PRESENT(F_limit)) then + limiter = F_limit + endif + linear = .false. + if (PRESENT(linear_decay)) then + linear = linear_decay + endif + ! Calculate vertical indices containing the boundary layer call boundary_k_range(boundary, nk, h_L, hbl_L, k_top_L, zeta_top_L, k_bot_L, zeta_bot_L) call boundary_k_range(boundary, nk, h_R, hbl_R, k_top_R, zeta_top_R, k_bot_R, zeta_bot_R) @@ -596,40 +680,60 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, zeta_top_L, k_bot_L, zeta_bot_L) phi_R_avg = bulk_average(boundary, nk, deg, h_R, hbl_R, phi_R, ppoly0_E_R, ppoly0_coefs_R, method, k_top_R, & zeta_top_R, k_bot_R, zeta_bot_R) - ! Calculate the 'bulk' diffusive flux from the bulk averaged quantities ! GMM, khtr_avg should be computed once khtr is 3D heff = harmonic_mean(hbl_L, hbl_R) F_bulk = -(khtr_u * heff) * (phi_R_avg - phi_L_avg) - F_bulk_remain = F_bulk ! Calculate the layerwise sum of the vertical effective thickness. This is different than the heff calculated ! above, but is used as a way to decompose the fluxes onto the individual layers h_means(:) = 0. - if (boundary == SURFACE) then k_min = MIN(k_bot_L, k_bot_R) + k_max = MAX(k_bot_L, k_bot_R) + k_diff = (k_max - k_min) + if ((linear) .and. (k_diff .gt. 1)) then + do k=1,k_min + h_means(k) = harmonic_mean(h_L(k),h_R(k)) + enddo + ! heff_total + heff_tot = 0.0 + do k = k_min+1,k_max, 1 + heff_tot = heff_tot + harmonic_mean(h_L(k), h_R(k)) + enddo - ! left hand side - if (k_bot_L == k_min) then - h_work_L = h_L(k_min) * zeta_bot_L + a = -1.0/heff_tot + heff_tot = 0.0 + ! fluxes will decay linearly at base of hbl + do k = k_min+1,k_max, 1 + heff = harmonic_mean(h_L(k), h_R(k)) + wgt = (a*(heff_tot + (heff * 0.5))) + 1.0 + h_means(k) = harmonic_mean(h_L(k), h_R(k)) * wgt + heff_tot = heff_tot + heff + enddo else - h_work_L = h_L(k_min) - endif + ! left hand side + if (k_bot_L == k_min) then + h_work_L = h_L(k_min) * zeta_bot_L + else + h_work_L = h_L(k_min) + endif - ! right hand side - if (k_bot_R == k_min) then - h_work_R = h_R(k_min) * zeta_bot_R - else - h_work_R = h_R(k_min) - endif + ! right hand side + if (k_bot_R == k_min) then + h_work_R = h_R(k_min) * zeta_bot_R + else + h_work_R = h_R(k_min) + endif - h_means(k_min) = harmonic_mean(h_work_L,h_work_R) + h_means(k_min) = harmonic_mean(h_work_L,h_work_R) - do k=1,k_min-1 - h_means(k) = harmonic_mean(h_L(k),h_R(k)) - enddo + do k=1,k_min-1 + h_means(k) = harmonic_mean(h_L(k),h_R(k)) + enddo + endif elseif (boundary == BOTTOM) then + !TODO, GMM linear decay is not implemented here k_max = MAX(k_top_L, k_top_R) ! left hand side if (k_top_L == k_max) then @@ -652,57 +756,46 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, enddo endif - if ( SUM(h_means) == 0. ) then + if ( SUM(h_means) == 0. .or. F_bulk == 0.) then return - ! Decompose the bulk flux onto the individual layers + ! Decompose the bulk flux onto the individual layers else ! Initialize remaining thickness inv_heff = 1./SUM(h_means) do k=1,nk - if (h_means(k) > 0.) then + if ((h_means(k) > 0.) .and. (phi_L(k) /= phi_R(k))) then hfrac = h_means(k)*inv_heff F_layer(k) = F_bulk * hfrac - ! 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(k)*h_R(k)))-(area_L*(phi_L(k)*h_R(k)))) - - ! check if bulk flux (or F_layer) and F_max have same direction - if ( SIGN(1.,F_bulk) == SIGN(1., F_max)) then - ! Distribute bulk flux onto layers - if ( ((boundary == SURFACE) .and. (k == k_min)) .or. ((boundary == BOTTOM) .and. (k == nk)) ) then - F_layer(k) = F_bulk_remain ! GMM, are not using F_bulk_remain for now. Should we keep it? - endif - F_bulk_remain = F_bulk_remain - F_layer(k) - ! Apply flux limiter calculated above - if (F_max >= 0.) then - limited = F_layer(k) > F_max - F_layer(k) = MIN(F_layer(k),F_max) - else - limited = F_layer(k) < F_max - F_layer(k) = MAX(F_layer(k),F_max) - endif - - ! GMM, again we are not using F_limit. Should we delete it? - if (PRESENT(F_limit)) then - if (limited) then - F_limit(k) = F_layer(k) - F_max + if (limiter) then + ! 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(k)*h_R(k)))-(area_L*(phi_L(k)*h_R(k)))) + + ! check if bulk flux (or F_layer) and F_max have same direction + if ( SIGN(1.,F_bulk) == SIGN(1., F_max)) then + ! Apply flux limiter calculated above + if (F_max >= 0.) then + F_layer(k) = MIN(F_layer(k),F_max) else - F_limit(k) = 0. + F_layer(k) = MAX(F_layer(k),F_max) endif + else + ! do not apply a flux on this layer + F_layer(k) = 0. endif else - ! do not apply a flux on this layer - F_bulk_remain = F_bulk_remain - F_layer(k) - F_layer(k) = 0. - endif - else - F_layer(k) = 0. + dphi = -(phi_R(k) - phi_L(k)) + if (.not. SIGN(1.,F_bulk) == SIGN(1., dphi)) then + ! upgradient, do not apply a flux on this layer + F_layer(k) = 0. + endif + endif ! limited endif enddo endif @@ -725,7 +818,7 @@ logical function near_boundary_unit_tests( verbose ) real, dimension(nk,2) :: ppoly0_E_L, ppoly0_E_R! Polynomial edge values (left and right) [concentration] real, dimension(nk) :: h_L, h_R ! Layer thickness (left and right) [m] real :: khtr_u ! Horizontal diffusivities at U-point [m^2 s^-1] - real :: hbl_L, hbl_R ! Depth of the boundary layer (left and right) [m] + real :: hbl_L, hbl_R ! Depth of the boundary layer (left and right) [m] real :: F_bulk ! Total diffusive flux across the U point [nondim s^-1] real, dimension(nk) :: F_layer ! Diffusive flux within each layer at U-point [nondim s^-1] real :: h_u, hblt_u ! Thickness at the u-point [m] @@ -746,47 +839,56 @@ logical function near_boundary_unit_tests( verbose ) 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 = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 1, 1., test_name, verbose) + 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 = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 2, 0., test_name, verbose) + 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 = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 2, 0., 2, 1., test_name, verbose) + 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 = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 2, 1., test_name, verbose) + 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 = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 2, 0.75, test_name, verbose) + 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 = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 1, 0.25, test_name, verbose) + 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 = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 2, 0., test_name, verbose) + 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 = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0.75, 2, 1., test_name, verbose) + 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 = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 2, 0.25, 2, 1., test_name, verbose) + 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) ! 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)' @@ -802,9 +904,17 @@ logical function near_boundary_unit_tests( verbose ) ppoly0_E_R(1,1) = 1.; ppoly0_E_R(1,2) = 1. ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. khtr_u = 1. + ! Without limiter call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, phi_pp_R, & ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) - near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-5.0,-5.0/) ) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk, test_name, F_layer, (/-5.0,-5.0/) ) + + ! same as above, but with limiter + call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, phi_pp_R, & + ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer, .true.) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk, test_name, F_layer, (/-1.0,-1.0/) ) test_name = 'Equal hbl and same layer thicknesses (gradient from left to right)' hbl_L = 10.; hbl_R = 10. @@ -821,7 +931,8 @@ logical function near_boundary_unit_tests( verbose ) khtr_u = 1. call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) - near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/5.0,5.0/) ) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk, test_name, F_layer, (/5.0,5.0/) ) test_name = 'Equal hbl and same layer thicknesses (no gradient)' hbl_L = 10; hbl_R = 10 @@ -831,14 +942,15 @@ logical function near_boundary_unit_tests( verbose ) phi_pp_L(2,1) = 1.; phi_pp_L(2,2) = 0. phi_pp_R(1,1) = 1.; phi_pp_R(1,2) = 0. phi_pp_R(2,1) = 1.; phi_pp_R(2,2) = 0. - ppoly0_E_L(1,1) = 1.; ppoly0_E_L(1,2) = 0. - ppoly0_E_L(2,1) = 1.; ppoly0_E_L(2,2) = 0. + ppoly0_E_L(1,1) = 1.; ppoly0_E_L(1,2) = 1. + ppoly0_E_L(2,1) = 1.; ppoly0_E_L(2,2) = 1. ppoly0_E_R(1,1) = 1.; ppoly0_E_R(1,2) = 1. ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. khtr_u = 1. call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) - near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/0.0,0.0/) ) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk, test_name, F_layer, (/0.0,0.0/) ) test_name = 'Equal hbl and different layer thicknesses (gradient right to left)' hbl_L = 16.; hbl_R = 16. @@ -855,7 +967,8 @@ logical function near_boundary_unit_tests( verbose ) khtr_u = 1. call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) - near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-8.0,-8.0/) ) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk, test_name, F_layer, (/-8.0,-8.0/) ) test_name = 'Equal hbl and same layer thicknesses (diagonal tracer values)' hbl_L = 10.; hbl_R = 10. @@ -872,7 +985,8 @@ logical function near_boundary_unit_tests( verbose ) khtr_u = 1. call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) - near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/0.0,0.0/) ) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk, test_name, F_layer, (/0.0,0.0/) ) test_name = 'Different hbl and different layer thicknesses (gradient from right to left)' hbl_L = 12; hbl_R = 20 @@ -889,7 +1003,8 @@ logical function near_boundary_unit_tests( verbose ) khtr_u = 1. call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) - near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-7.5,-7.5/) ) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk, test_name, F_layer, (/-7.5,-7.5/) ) ! Cases where hbl < column thickness (polynomial coefficients specified for pseudo-linear reconstruction) @@ -901,10 +1016,15 @@ logical function near_boundary_unit_tests( verbose ) phi_pp_L(2,1) = 0.; phi_pp_L(2,2) = 0. phi_pp_R(1,1) = 1.; phi_pp_R(1,2) = 0. phi_pp_R(2,1) = 1.; phi_pp_R(2,2) = 0. + ppoly0_E_L(1,1) = 0.; ppoly0_E_L(1,2) = 0. + ppoly0_E_L(2,1) = 0.; ppoly0_E_L(2,2) = 0. + ppoly0_E_R(1,1) = 1.; ppoly0_E_R(1,2) = 1. + ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. khtr_u = 1. call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) - near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-1.,-1./) ) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk, test_name, F_layer, (/-1.,-1./) ) test_name = 'hbl < column thickness, hbl same, linear profile right' hbl_L = 2; hbl_R = 2 @@ -921,7 +1041,8 @@ logical function near_boundary_unit_tests( verbose ) ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 3. call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) - near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-1.,-1./) ) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk, test_name, F_layer, (/-1.,-1./) ) test_name = 'hbl < column thickness, hbl same, linear profile right, khtr=2' hbl_L = 2; hbl_R = 2 @@ -938,7 +1059,8 @@ logical function near_boundary_unit_tests( verbose ) ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 3. call fluxes_layer_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, & phi_pp_R, ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) - near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-2.,-2./) ) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk, test_name, F_layer, (/-1.,-3./) ) ! unit tests for layer by layer method test_name = 'Different hbl and different column thicknesses (gradient from right to left)' @@ -956,7 +1078,8 @@ logical function near_boundary_unit_tests( verbose ) khtr_u = 1. call fluxes_layer_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, & phi_pp_R, ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) - near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-7.5,0.0/) ) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk, test_name, F_layer, (/-7.5,-7.5/) ) test_name = 'Different hbl and different column thicknesses (linear profile right)' @@ -974,7 +1097,8 @@ logical function near_boundary_unit_tests( verbose ) khtr_u = 1. call fluxes_layer_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, & phi_pp_R, ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) - near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-3.75,0.0/) ) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk, test_name, F_layer, (/-3.75,0.0/) ) end function near_boundary_unit_tests !> Returns true if output of near-boundary unit tests does not match correct computed values @@ -987,13 +1111,13 @@ logical function test_layer_fluxes(verbose, nk, test_name, F_calc, F_ans) real, dimension(nk), intent(in) :: F_ans !< Fluxes of the unitless tracer calculated by hand [s^-1] ! Local variables integer :: k - integer, parameter :: stdunit = 6 + integer, parameter :: stdunit = stdout test_layer_fluxes = .false. do k=1,nk if ( F_calc(k) /= F_ans(k) ) then test_layer_fluxes = .true. - write(stdunit,*) "UNIT TEST FAILED: ", test_name + write(stdunit,*) "MOM_lateral_boundary_diffusion, UNIT TEST FAILED: ", test_name write(stdunit,10) k, F_calc(k), F_ans(k) elseif (verbose) then write(stdunit,10) k, F_calc(k), F_ans(k) @@ -1017,7 +1141,7 @@ logical function test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, k_top_a character(len=80) :: test_name !< Name of the unit test logical :: verbose !< If true always print output - integer, parameter :: stdunit = 6 + integer, parameter :: stdunit = stdout test_boundary_k_range = k_top .ne. k_top_ans test_boundary_k_range = test_boundary_k_range .or. (zeta_top .ne. zeta_top_ans) @@ -1052,12 +1176,37 @@ end function test_boundary_k_range !! !! Boundary lateral diffusion can be applied using one of the three methods: !! -!! * [Method #1: Bulk layer](@ref section_method1) (default); -!! * [Method #2: Along layer](@ref section_method2); +!! * [Method #1: Along layer](@ref section_method2) (default); +!! * [Method #2: Bulk layer](@ref section_method1); !! !! A brief summary of these methods is provided below. !! -!! \subsection section_method1 Bulk layer approach (Method #1) +!! \subsection section_method1 Along layer approach (Method #1) +!! +!! This is the recommended and more straight forward method where diffusion is +!! applied layer by layer using only information from neighboring cells. +!! +!! Step #1: 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. This method does not require a limiter since KHTR +!! is already limted based on a diffusive CFL condition prior to the call of this +!! module. +!! +!! Step #3: option to linearly decay the flux from k_bot_min to k_bot_max: +!! +!! If LBD_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). +!! +!! \subsection section_method2 Bulk layer approach (Method #2) !! !! Apply the lateral boundary diffusive fluxes calculated from a 'bulk model'.This !! is a lower order representation (Kraus-Turner like approach) which assumes that @@ -1087,7 +1236,14 @@ end function test_boundary_k_range !! h_u is the [harmonic mean](@ref section_harmonic_mean) of thicknesses at each layer. !! Special care (layer reconstruction) must be taken at k_min = min(k_botL, k_bot_R). !! -!! Step #4: limit the tracer flux so that 1) only down-gradient fluxes are applied, +!! Step #4: option to linearly decay the flux from k_bot_min to k_bot_max: +!! +!! If LBD_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 #5: limit the tracer flux 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: !! @@ -1098,25 +1254,6 @@ end function test_boundary_k_range !! 0 1 0 .2.2.2 !! 0 .2 !! -!! \subsection section_method2 Along layer approach (Method #2) -!! -!! This is a more straight forward method where diffusion is applied layer by layer using -!! only information from neighboring cells. -!! -!! Step #1: 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. Special care (layer reconstruction) must be taken at -!! k_min = min(k_botL, k_bot_R). This method does not require a limiter since KHTR -!! is already limted based on a diffusive CFL condition prior to the call of this -!! module. -!! !! \subsection section_harmonic_mean Harmonic Mean !! !! The harmonic mean (HM) betwen h1 and h2 is defined as: diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 26873900cc..086caf390f 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -8,8 +8,8 @@ module MOM_neutral_diffusion 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, calculate_compress, calculate_density_derivs -use MOM_EOS, only : calculate_density, calculate_density_second_derivs +use MOM_EOS, only : EOS_type, EOS_manual_init, EOS_domain +use MOM_EOS, only : calculate_density, calculate_density_derivs use MOM_EOS, only : extract_member_EOS, EOS_LINEAR, EOS_TEOS10, EOS_WRIGHT 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 @@ -28,6 +28,9 @@ module MOM_neutral_diffusion use MOM_energetic_PBL, only : energetic_PBL_get_MLD, energetic_PBL_CS use MOM_diabatic_driver, only : diabatic_CS, extract_diabatic_member use MOM_lateral_boundary_diffusion, only : boundary_k_range, SURFACE, BOTTOM + +use iso_fortran_env, only : stdout=>output_unit, stderr=>error_unit + implicit none ; private #include @@ -45,9 +48,10 @@ module MOM_neutral_diffusion 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 difference from true neutrality + 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 - real :: ref_pres !< Reference pressure, negative if using locally referenced neutral density + 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. ! Positions of neutral surfaces in both the u, v directions @@ -69,19 +73,21 @@ module MOM_neutral_diffusion real, allocatable, dimension(:,:,:,:) :: ppoly_coeffs_T !< Polynomial coefficients for temperature real, allocatable, dimension(:,:,:,:) :: ppoly_coeffs_S !< Polynomial coefficients for salinity ! Variables needed for continuous reconstructions - real, allocatable, dimension(:,:,:) :: dRdT !< dRho/dT [kg m-3 degC-1] at interfaces - real, allocatable, dimension(:,:,:) :: dRdS !< dRho/dS [kg m-3 ppt-1] at interfaces + real, allocatable, dimension(:,:,:) :: dRdT !< dRho/dT [R degC-1 ~> kg m-3 degC-1] at interfaces + real, allocatable, dimension(:,:,:) :: dRdS !< dRho/dS [R ppt-1 ~> kg m-3 ppt-1] at interfaces real, allocatable, dimension(:,:,:) :: Tint !< Interface T [degC] real, allocatable, dimension(:,:,:) :: Sint !< Interface S [ppt] - real, allocatable, dimension(:,:,:) :: Pint !< Interface pressure [Pa] + 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 (degC) - real, allocatable, dimension(:,:,:,:) :: S_i !< Top edge reconstruction of salinity (ppt) - real, allocatable, dimension(:,:,:,:) :: P_i !< Interface pressure (Pa) - real, allocatable, dimension(:,:,:,:) :: dRdT_i !< dRho/dT (kg/m3/degC) at top edge - real, allocatable, dimension(:,:,:,:) :: dRdS_i !< dRho/dS (kg/m3/ppt) at top edge + real, allocatable, dimension(:,:,:,:) :: T_i !< Top edge reconstruction of temperature [degC] + real, allocatable, dimension(:,:,:,:) :: S_i !< Top edge reconstruction of salinity [ppt] + real, allocatable, dimension(:,:,:,:) :: P_i !< Interface pressures [R L2 T-2 ~> Pa] + real, allocatable, dimension(:,:,:,:) :: dRdT_i !< dRho/dT [R degC-1 ~> kg m-3 degC-1] at top edge + real, allocatable, dimension(:,:,:,:) :: dRdS_i !< dRho/dS [R ppt-1 ~> kg m-3 ppt-1] at top edge integer, allocatable, dimension(:,:) :: ns !< Number of interfacs 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 @@ -91,7 +97,6 @@ module MOM_neutral_diffusion integer :: id_uhEff_2d = -1 !< Diagnostic IDs integer :: id_vhEff_2d = -1 !< Diagnostic IDs - real :: C_p !< heat capacity of seawater (J kg-1 K-1) type(EOS_type), pointer :: EOS !< Equation of state parameters type(remapping_CS) :: remap_CS !< Remapping control structure used to create sublayers logical :: remap_answers_2018 !< If true, use the order of arithmetic and expressions that @@ -108,9 +113,10 @@ module MOM_neutral_diffusion contains !> Read parameters and allocate control structure for neutral_diffusion module. -logical function neutral_diffusion_init(Time, G, param_file, diag, EOS, diabatic_CSp, CS) +logical function neutral_diffusion_init(Time, G, 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(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 @@ -128,17 +134,17 @@ logical function neutral_diffusion_init(Time, G, param_file, diag, EOS, diabatic 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") + "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) then - return - endif + if (.not.neutral_diffusion_init) return allocate(CS) CS%diag => diag @@ -154,9 +160,9 @@ logical function neutral_diffusion_init(Time, G, param_file, diag, EOS, diabatic "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.) - call get_param(param_file, mdl, "NDIFF_INTERIOR_ONLY", CS%interior_only, & + "the equation of state. If negative (default), local pressure is used.", & + units="Pa", default = -1., scale=US%kg_m3_to_R*US%m_s_to_L_T**2) + 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.) @@ -174,7 +180,7 @@ logical function neutral_diffusion_init(Time, G, param_file, diag, EOS, diabatic trim(remappingSchemesDoc), default=remappingDefaultScheme) call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=.true.) + default=.false.) call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", CS%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 "//& @@ -203,7 +209,7 @@ logical function neutral_diffusion_init(Time, G, param_file, diag, EOS, diabatic call get_param(param_file, mdl, "NDIFF_DRHO_TOL", CS%drho_tol, & "Sets the convergence criterion for finding the neutral\n"// & "position within a layer in kg m-3.", & - default=1.e-10) + 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 nondim\n"// & "position within a layer.", & @@ -222,6 +228,9 @@ logical function neutral_diffusion_init(Time, G, param_file, diag, EOS, diabatic default = .true.) endif + ! Store a rescaling factor for use in diagnostic messages. + CS%R_to_kg_m3 = US%R_to_kg_m3 + if (CS%interior_only) then call extract_diabatic_member(diabatic_CSp, KPP_CSp=CS%KPP_CSp) call extract_diabatic_member(diabatic_CSp, energetic_PBL_CSp=CS%energetic_PBL_CSp) @@ -271,7 +280,7 @@ 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) +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 @@ -279,15 +288,18 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS) real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: T !< Potential temperature [degC] real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: S !< Salinity [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_(G),2) :: ppoly_r_S ! Reconstruction slopes real, dimension(SZI_(G), SZJ_(G)) :: hEff_sum ! Summed effective face thicknesses [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G)) :: hbl ! Boundary layer depth [m] + real, dimension(SZI_(G),SZJ_(G)) :: hbl ! Boundary layer depth [H ~> m or kg m-2] integer :: iMethod - real, dimension(SZI_(G)) :: ref_pres ! Reference pressure used to calculate alpha/beta + real, dimension(SZI_(G)) :: ref_pres ! Reference pressure used to calculate alpha/beta [R L2 T-2 ~> Pa] real, dimension(SZI_(G)) :: rho_tmp ! Routine to calculate drho_dp, returns density which is not used 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 @@ -295,18 +307,19 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS) ! 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 - real :: pa_to_H ! A conversion factor from Pa to H [H Pa-1 ~> m Pa-1 or s2 m-2] + real :: pa_to_H ! A conversion factor from pressure to H units [H T2 R-1 Z-2 ~> m Pa-1 or s2 m-2] - pa_to_H = 1. / GV%H_to_pa + pa_to_H = 1. / (GV%H_to_RZ * GV%g_Earth) k_top(:,:) = 1 ; k_bot(:,:) = 1 - zeta_top(:,:) = 0. ; zeta_bot(:,:) = 1. + zeta_top(:,:) = 0. ; zeta_bot(:,:) = 0. ! Check if hbl needs to be extracted if (CS%interior_only) then hbl(:,:) = 0. - if (ASSOCIATED(CS%KPP_CSp)) call KPP_get_BLD(CS%KPP_CSp, hbl, G) - if (ASSOCIATED(CS%energetic_PBL_CSp)) call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, hbl, G, US) + 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) ! get k-indices and zeta do j=G%jsc-1, G%jec+1 ; do i=G%isc-1,G%iec+1 @@ -341,24 +354,38 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS) endif ! Calculate pressure at interfaces and layer averaged alpha/beta - CS%Pint(:,:,1) = 0. - do k=1,G%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%H_to_Pa + 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,G%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 tis - ! for now ensure consitency of indexing for diiscontinuous reconstructions + ! Pressures at the interfaces, this is redundant as P_i(k,1) = P_i(k-1,2) however retain this + ! for now to ensure consitency of indexing for diiscontinuous reconstructions if (.not. CS%continuous_reconstruction) then - 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_Pa - enddo ; enddo - do k=2,G%ke ; do j=G%jsc-1, G%jec+1 ; do i=G%isc-1,G%iec+1 + 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,G%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_Pa + 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 @@ -385,21 +412,19 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS) if (CS%continuous_reconstruction) then do k = 1, G%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), G%isc-1, G%iec-G%isc+3, CS%EOS) + 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, G%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), G%isc-1, G%iec-G%isc+3, CS%EOS) - if (CS%ref_pres<0) then - ref_pres(:) = CS%Pint(:,j,k+1) - endif - ! Calcualte 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), G%isc-1, G%iec-G%isc+3, CS%EOS) + 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 @@ -436,9 +461,9 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS) 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), 1.-zeta_bot(I,j), 1.-zeta_bot(I+1,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, G%ke, & + call find_neutral_surface_positions_discontinuous(CS, G%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,:,:), & @@ -456,10 +481,10 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS) call find_neutral_surface_positions_continuous(G%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), 1.-zeta_bot(i,J), 1.-zeta_bot(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, G%ke, & + call find_neutral_surface_positions_discontinuous(CS, G%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,:,:), & @@ -472,8 +497,8 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS) ! 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 fraction of the nondimensional fraction of the layer spanned by - ! adjacent neutral surfaces. + ! 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 do k = 1, CS%nsurf-1 ; do j = G%jsc, G%jec ; do I = G%isc-1, G%iec if (G%mask2dCu(I,j) > 0.) CS%uhEff(I,j,k) = CS%uhEff(I,j,k) * pa_to_H @@ -906,23 +931,24 @@ end function fvlsq_slope 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 [Pa] + 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 [degC] real, dimension(nk+1), intent(in) :: Sl !< Left-column interface salinity [ppt] - real, dimension(nk+1), intent(in) :: dRdTl !< Left-column dRho/dT [kg m-3 degC-1] - real, dimension(nk+1), intent(in) :: dRdSl !< Left-column dRho/dS [kg m-3 ppt-1] - real, dimension(nk+1), intent(in) :: Pr !< Right-column interface pressure [Pa] + real, dimension(nk+1), intent(in) :: dRdTl !< Left-column dRho/dT [R degC-1 ~> kg m-3 degC-1] + real, dimension(nk+1), intent(in) :: dRdSl !< Left-column dRho/dS [R ppt-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 [degC] real, dimension(nk+1), intent(in) :: Sr !< Right-column interface salinity [ppt] - real, dimension(nk+1), intent(in) :: dRdTr !< Left-column dRho/dT [kg m-3 degC-1] - real, dimension(nk+1), intent(in) :: dRdSr !< Left-column dRho/dS [kg m-3 ppt-1] + real, dimension(nk+1), intent(in) :: dRdTr !< Left-column dRho/dT [R degC-1 ~> kg m-3 degC-1] + real, dimension(nk+1), intent(in) :: dRdSr !< Left-column dRho/dS [R ppt-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 real, dimension(2*nk+2), intent(inout) :: PoR !< Fractional position of neutral surface within !! layer KoR of right column 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 [Pa] + 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 !< Nondimensional position of the boundary layer (left) @@ -933,14 +959,15 @@ subroutine find_neutral_surface_positions_continuous(nk, Pl, Tl, Sl, dRdTl, dRdS integer :: k_surface ! Index of neutral surface integer :: kl ! Index of left interface integer :: kr ! Index of right interface - real :: dRdT, dRdS ! dRho/dT and dRho/dS for the neutral surface + real :: dRdT, dRdS ! dRho/dT [kg m-3 degC-1] and dRho/dS [kg m-3 ppt-1] for the neutral surface 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, hL, hR - integer :: lastK_left, lastK_right - real :: lastP_left, lastP_right + 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 @@ -1003,7 +1030,7 @@ subroutine find_neutral_surface_positions_continuous(nk, Pl, Tl, Sl, dRdTl, dRdS 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. + ! 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 @@ -1032,11 +1059,11 @@ subroutine find_neutral_surface_positions_continuous(nk, Pl, Tl, Sl, dRdTl, dRdS 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) ) ) + 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) ) ) + 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) @@ -1046,7 +1073,7 @@ subroutine find_neutral_surface_positions_continuous(nk, Pl, Tl, Sl, dRdTl, dRdS 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. + ! 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 @@ -1108,21 +1135,26 @@ subroutine find_neutral_surface_positions_continuous(nk, Pl, Tl, Sl, dRdTl, dRdS 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 - real, intent(in) :: Pneg !< Position of negative density difference - real, intent(in) :: dRhoPos !< Positive density difference - real, intent(in) :: Ppos !< Position of positive density difference + 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] - if (PposdRhoPos) then - write(0,*) 'dRhoNeg, Pneg, dRhoPos, Ppos=',dRhoNeg, Pneg, dRhoPos, Ppos + character(len=120) :: mesg + + if (Ppos < Pneg) then + call MOM_error(FATAL, 'interpolate_for_nondim_position: Houston, we have a problem! PposdRhoPos) then - stop 'interpolate_for_nondim_position: Houston, we have a problem! dRhoNeg>dRhoPos' + 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 @@ -1140,42 +1172,45 @@ real function interpolate_for_nondim_position(dRhoNeg, Pneg, dRhoPos, Ppos) interpolate_for_nondim_position = 0.5 endif if ( interpolate_for_nondim_position < 0. ) & - stop 'interpolate_for_nondim_position: Houston, we have a problem! Pint < Pneg' + call MOM_error(FATAL, 'interpolate_for_nondim_position: Houston, we have a problem! Pint < Pneg') if ( interpolate_for_nondim_position > 1. ) & - stop 'interpolate_for_nondim_position: Houston, we have a problem! Pint > Ppos' + 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 reconstrcutions !! 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) +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 (Pa) - real, dimension(nk), intent(in) :: hcol_l !< Left-column layer thicknesses - real, dimension(nk,2), intent(in) :: Tl !< Left-column top interface potential temperature (degC) - real, dimension(nk,2), intent(in) :: Sl !< Left-column top interface salinity (ppt) - real, dimension(:,:), intent(in) :: ppoly_T_l !< Left-column coefficients of T reconstruction - real, dimension(:,:), intent(in) :: ppoly_S_l !< Left-column coefficients of S reconstruction - logical, dimension(nk), intent(in) :: stable_l !< Left-column, top interface dRho/dS (kg/m3/ppt) - real, dimension(nk,2), intent(in) :: Pres_r !< Right-column interface pressure (Pa) - real, dimension(nk), intent(in) :: hcol_r !< Left-column layer thicknesses - real, dimension(nk,2), intent(in) :: Tr !< Right-column top interface potential temperature (degC) - real, dimension(nk,2), intent(in) :: Sr !< Right-column top interface salinity (ppt) - real, dimension(:,:), intent(in) :: ppoly_T_r !< Right-column coefficients of T reconstruction - real, dimension(:,:), intent(in) :: ppoly_S_r !< Right-column coefficients of S reconstruction - logical, dimension(nk), intent(in) :: stable_r !< Left-column, top interface dRho/dS (kg/m3/ppt) + 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 [degC] + real, dimension(nk,2), intent(in) :: Sl !< Left-column top interface salinity [ppt] + real, dimension(:,:), intent(in) :: ppoly_T_l !< Left-column coefficients of T reconstruction [degC] + real, dimension(:,:), intent(in) :: ppoly_S_l !< Left-column coefficients of S reconstruction [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 [degC] + real, dimension(nk,2), intent(in) :: Sr !< Right-column top interface salinity [ppt] + real, dimension(:,:), intent(in) :: ppoly_T_r !< Right-column coefficients of T reconstruction [degC] + real, dimension(:,:), intent(in) :: ppoly_S_r !< Right-column coefficients of S reconstruction [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 + !! layer KoL of left column [nondim] real, dimension(4*nk), intent(inout) :: PoR !< Fractional position of neutral surface within - !! layer KoR of right column + !! 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 (Pa) + 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 !! intersetcs the cell (left) [nondim] real, optional, intent(in) :: zeta_bot_R!< Non-dimensional distance to where the boundary layer @@ -1194,17 +1229,13 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, 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 :: search_layer - logical :: fail_heff ! By default, - real :: dRho, dRhoTop, dRhoBot, hL, hR - real :: z0, pos - real :: dRdT_from_top, dRdS_from_top ! Density derivatives at the searched from interface - real :: dRdT_from_bot, dRdS_from_bot ! Density derivatives at the searched from interface - real :: dRdT_to_top, dRdS_to_top ! Density derivatives at the interfaces being searched - real :: dRdT_to_bot, dRdS_to_bot ! Density derivatives at the interfaces being searched - real :: T_ref, S_ref, P_ref, P_top, P_bot - real :: lastP_left, lastP_right - 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 + 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 @@ -1272,12 +1303,13 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, ! 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), & + 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(*,'(A,I2,A,E12.4,A,I2,A,I2,A,I2,A,I2)') "k_surface=",k_surface," dRho=",dRho, & - "kl_left=",kl_left, " ki_left=",ki_left," kl_right=",kl_right, " ki_right=",ki_right + 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 @@ -1308,11 +1340,11 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, KoL(k_surface) = kl_left if (CS%debug) then - write(*,'(A,I2)') "Searching left layer ", kl_left - write(*,'(A,I2,X,I2)') "Searching from right: ", kl_right, ki_right - write(*,*) "Temp/Salt Reference: ", Tr(kl_right,ki_right), Sr(kl_right,ki_right) - write(*,*) "Temp/Salt Top L: ", Tl(kl_left,1), Sl(kl_left,1) - write(*,*) "Temp/Salt Bot L: ", Tl(kl_left,2), Sl(kl_left,2) + write(stdout,'(A,I2)') "Searching left layer ", kl_left + write(stdout,'(A,I2,X,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) @@ -1331,11 +1363,11 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, KoR(k_surface) = kl_right if (CS%debug) then - write(*,'(A,I2)') "Searching right layer ", kl_right - write(*,'(A,I2,X,I2)') "Searching from left: ", kl_left, ki_left - write(*,*) "Temp/Salt Reference: ", Tl(kl_left,ki_left), Sl(kl_left,ki_left) - write(*,*) "Temp/Salt Top L: ", Tr(kl_right,1), Sr(kl_right,1) - write(*,*) "Temp/Salt Bot L: ", Tr(kl_right,2), Sr(kl_right,2) + write(stdout,'(A,I2)') "Searching right layer ", kl_right + write(stdout,'(A,I2,X,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) @@ -1344,7 +1376,7 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, else stop 'Else what?' endif - if (CS%debug) write(*,'(A,I3,A,ES16.6,A,I2,A,ES16.6)') "KoL:", KoL(k_surface), " PoL:", PoL(k_surface), & + 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 @@ -1365,15 +1397,15 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, endif endif elseif ( hL + hR == 0. ) then - hEff(k_surface-1) = 0. + 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 + 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. @@ -1386,53 +1418,54 @@ end subroutine find_neutral_surface_positions_discontinuous 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 - real, dimension(nk,2), intent(in) :: S !< Salinity at interfaces - real, dimension(nk,2), intent(in) :: P !< Pressure at interfaces + real, dimension(nk,2), intent(in) :: T !< Temperature at interfaces [degC] + real, dimension(nk,2), intent(in) :: S !< Salinity at interfaces [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, first_stable, prev_stable - real :: delta_rho + 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. + 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) + 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 rootfinding algorithm - real, intent(in ) :: T_from !< Temperature at the searched from interface - real, intent(in ) :: S_from !< Salinity at the searched from interface - real, intent(in ) :: P_from !< Pressure at the searched from interface - real, intent(in ) :: T_top !< Temperature at the searched to top interface - real, intent(in ) :: S_top !< Salinity at the searched to top interface - real, intent(in ) :: P_top !< Pressure at the searched to top interface - real, intent(in ) :: T_bot !< Temperature at the searched to bottom interface - real, intent(in ) :: S_bot !< Salinity at the searched to bottom interface - real, intent(in ) :: P_bot !< Pressure at the searched to bottom interface - real, dimension(:), intent(in ) :: T_poly !< Temperature polynomial reconstruction coefficients - real, dimension(:), intent(in ) :: S_poly !< Salinity polynomial reconstruction coefficients + !! bound in the root finding algorithm [nondim] + real, intent(in ) :: T_from !< Temperature at the searched from interface [degC] + real, intent(in ) :: S_from !< Salinity at the searched from interface [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 [degC] + real, intent(in ) :: S_top !< Salinity at the searched to top interface [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 [degC] + real, intent(in ) :: S_bot !< Salinity at the searched to bottom interface [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 [degC] + real, dimension(:), intent(in ) :: S_poly !< Salinity polynomial reconstruction coefficients [ppt] ! Local variables - real :: dRhotop, dRhobot - real :: dRdT_top, dRdS_top, dRdT_bot, dRdS_bot - real :: dRdT_from, dRdS_from - real :: P_mid + real :: dRhotop, dRhobot ! Density differences [R ~> kg m-3] + real :: dRdT_top, dRdT_bot, dRdT_from ! Partial derivatives of density with temperature [R degC-1 ~> kg m-3 degC-1] + real :: dRdS_top, dRdS_bot, dRdS_from ! Partial derivatives of density with salinity [R ppt-1 ~> kg m-3 ppt-1] ! Calculate the differencei 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, & + 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, & + 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 @@ -1461,9 +1494,8 @@ real function search_other_column(CS, ksurf, pos_last, T_from, S_from, P_from, T ! For the 'Linear' case of finding the neutral position, the fromerence 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, P_from, dRdT_from, dRdS_from, & - P_top, dRdT_top, dRdS_top, & - P_bot, dRdT_bot, dRdS_bot, T_poly, S_poly ) + 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 @@ -1505,43 +1537,52 @@ end subroutine increment_interface !! 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, P_ref, dRdT_ref, dRdS_ref, & - P_top, dRdT_top, dRdS_top, & - P_bot, dRdT_bot, dRdS_bot, ppoly_T, ppoly_S ) result( z ) +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 - real, intent(in) :: T_ref !< Temperature at the searched from interface - real, intent(in) :: S_ref !< Salinity at the searched from interface - real, intent(in) :: P_ref !< Pressure at the searched from interface + 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 [degC] + real, intent(in) :: S_ref !< Salinity at the searched from interface [ppt] real, intent(in) :: dRdT_ref !< dRho/dT at the searched from interface + !! [R degC-1 ~> kg m-3 degC-1] real, intent(in) :: dRdS_ref !< dRho/dS at the searched from interface - real, intent(in) :: P_top !< Pressure at top of layer being searched + !! [R ppt-1 ~> kg m-3 ppt-1] real, intent(in) :: dRdT_top !< dRho/dT at top of layer being searched + !! [R degC-1 ~> kg m-3 degC-1] real, intent(in) :: dRdS_top !< dRho/dS at top of layer being searched - real, intent(in) :: P_bot !< Pressure at bottom of layer being searched + !! [R ppt-1 ~> kg m-3 ppt-1] real, intent(in) :: dRdT_bot !< dRho/dT at bottom of layer being searched + !! [R degC-1 ~> kg m-3 degC-1] real, intent(in) :: dRdS_bot !< dRho/dS at bottom of layer being searched + !! [R ppt-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. - real, dimension(:), intent(in) :: ppoly_S !< Coefficients of the polynomial reconstruction of T within - !! the layer to be searched. - real :: z !< Position where drho = 0 + !! the layer to be searched [degC]. + real, dimension(:), intent(in) :: ppoly_S !< Coefficients of the polynomial reconstruction of S within + !! the layer to be searched [ppt]. + real :: z !< Position where drho = 0 [nondim] ! Local variables - real :: dRdT_diff, dRdS_diff - real :: drho, drho_dz, dRdT_z, dRdS_z, T_z, S_z, deltaT, deltaS, deltaP, dT_dz, dS_dz - real :: drho_min, drho_max, ztest, zmin, zmax, dRdT_sum, dRdS_sum, dz, P_z, dP_dz - real :: a1, a2 + real :: dRdT_diff ! Difference in the partial derivative of density with temperature across the + ! layer [R degC-1 ~> kg m-3 degC-1] + real :: dRdS_diff ! Difference in the partial derivative of density with salinity across the + ! layer [R ppt-1 ~> kg m-3 ppt-1] + real :: drho, drho_dz ! Density anomaly and its derivative with fracitonal position [R ~> kg m-3] + real :: dRdT_z ! Partial derivative of density with temperature at a point [R degC-1 ~> kg m-3 degC-1] + real :: dRdS_z ! Partial derivative of density with salinity at a point [R ppt-1 ~> kg m-3 ppt-1] + real :: T_z, dT_dz ! Temperature at a point and its derivative with fractional position [degC] + real :: S_z, dS_dz ! Salinity at a point and its derivative with fractional position [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 :: dz ! Change in position in the cell [nondim] + real :: a1, a2 ! Fractional weights of the top and bottom values [nondim] integer :: iter integer :: nterm - real :: T_top, T_bot, S_top, S_bot nterm = SIZE(ppoly_T) ! Position independent quantities dRdT_diff = dRdT_bot - dRdT_top dRdS_diff = dRdS_bot - dRdS_top - ! Assume a linear increase in pressure from top and bottom of the cell - dP_dz = P_bot - P_top ! Initial starting drho (used for bisection) zmin = z0 ! Lower bounding interval zmax = 1. ! Maximum bounding interval (bottom of layer) @@ -1551,14 +1592,11 @@ function find_neutral_pos_linear( CS, z0, T_ref, S_ref, P_ref, dRdT_ref, dRdS_r S_z = evaluation_polynomial( ppoly_S, nterm, zmin ) dRdT_z = a1*dRdT_top + a2*dRdT_bot dRdS_z = a1*dRdS_top + a2*dRdS_bot - P_z = a1*P_top + a2*P_bot - drho_min = delta_rho_from_derivs(T_z, S_z, P_z, dRdT_z, dRdS_z, & - T_ref, S_ref, P_ref, dRdT_ref, dRdS_ref) + 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 = delta_rho_from_derivs(T_z, S_z, P_bot, dRdT_bot, dRdS_bot, & - T_ref, S_ref, P_ref, dRdT_ref, dRdS_ref) + 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 @@ -1581,14 +1619,7 @@ function find_neutral_pos_linear( CS, z0, T_ref, S_ref, P_ref, dRdT_ref, dRdS_r dRdS_z = a1*dRdS_top + a2*dRdS_bot T_z = evaluation_polynomial( ppoly_T, nterm, z ) S_z = evaluation_polynomial( ppoly_S, nterm, z ) - P_z = a1*P_top + a2*P_bot - deltaT = T_z - T_ref - deltaS = S_z - S_ref - deltaP = P_z - P_ref - dRdT_sum = dRdT_ref + dRdT_z - dRdS_sum = dRdS_ref + dRdS_z - drho = delta_rho_from_derivs(T_z, S_z, P_z, dRdT_z, dRdS_z, & - T_ref, S_ref, P_ref, dRdT_ref, dRdS_ref) + 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 @@ -1604,7 +1635,8 @@ function find_neutral_pos_linear( CS, z0, T_ref, S_ref, P_ref, dRdT_ref, dRdS_r ! 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*deltaT + dRdT_sum*dT_dz) + (dRdS_diff*deltaS + dRdS_sum*dS_dz) ) + 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] @@ -1626,30 +1658,34 @@ 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 ) +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 - real, intent(in) :: T_ref !< Temperature at the searched from interface - real, intent(in) :: S_ref !< Salinity at the searched from interface - real, intent(in) :: P_ref !< Pressure at the searched from interface - real, intent(in) :: P_top !< Pressure at top of layer being searched - real, intent(in) :: P_bot !< Pressure at bottom of layer being searched + 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 [degC] + real, intent(in) :: S_ref !< Salinity at the searched from interface [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. + !! the layer to be searched [degC] real, dimension(:), intent(in) :: ppoly_S !< Coefficients of the polynomial reconstruction of T within - !! the layer to be searched. - real :: z !< Position where drho = 0 + !! the layer to be searched [ppt] + real :: z !< Position where drho = 0 [nondim] ! Local variables integer :: iter integer :: nterm - real :: drho_a, drho_b, drho_c - real :: a, b, c, Ta, Tb, Tc, Sa, Sb, Sc, Pa, Pb, Pc + 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 [degC] + real :: Sa, Sb, Sc ! Salinities [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 + b = z0 ; c = 1 nterm = SIZE(ppoly_T) ! Calculate drho at the minimum bound @@ -1715,23 +1751,26 @@ function find_neutral_pos_full( CS, z0, T_ref, S_ref, P_ref, P_top, P_bot, ppoly end function find_neutral_pos_full !> 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, & +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 - real, intent(in ) :: S1 !< Salinity at point 1 - real, intent(in ) :: p1_in !< Pressure at point 1 - real, intent(in ) :: T2 !< Temperature at point 2 - real, intent(in ) :: S2 !< Salinity at point 2 - real, intent(in ) :: p2_in !< Pressure at point 2 - real, intent( out) :: drho !< Difference in density between the two points - real, optional, intent( out) :: dRdT1_out !< drho_dt at point 1 - real, optional, intent( out) :: dRdS1_out !< drho_ds at point 1 - real, optional, intent( out) :: dRdT2_out !< drho_dt at point 2 - real, optional, intent( out) :: dRdS2_out !< drho_ds at point 2 + real, intent(in ) :: T1 !< Temperature at point 1 [degC] + real, intent(in ) :: S1 !< Salinity at point 1 [ppt] + real, intent(in ) :: p1_in !< Pressure at point 1 [R L2 T-2 ~> Pa] + real, intent(in ) :: T2 !< Temperature at point 2 [degC] + real, intent(in ) :: S2 !< Salinity at point 2 [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 degC-1 ~> kg m-3 degC-1] + real, optional, intent( out) :: dRdS1_out !< drho_ds at point 1 [R ppt-1 ~> kg m-3 ppt-1] + real, optional, intent( out) :: dRdT2_out !< drho_dt at point 2 [R degC-1 ~> kg m-3 degC-1] + real, optional, intent( out) :: dRdS2_out !< drho_ds at point 2 [R ppt-1 ~> kg m-3 ppt-1] ! Local variables - real :: rho1, rho2, p1, p2, pmid - real :: drdt1, drdt2, drds1, drds2, drdp1, drdp2, rho_dummy + 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 degC-1 ~> kg m-3 degC-1] + real :: drds1, drds2 ! Partial derivatives of density with salinity [R ppt-1 ~> kg m-3 ppt-1] + real :: drdp1, drdp2 ! Partial derivatives of density with pressure [T2 L-2 ~> s2 m-2] ! Use the same reference pressure or the in-situ pressure if (CS%ref_pres > 0.) then @@ -1745,8 +1784,8 @@ subroutine calc_delta_rho_and_derivs(CS, T1, S1, p1_in, T2, S2, p2_in, drho, ! 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 ) + 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 differentces int temperature elseif (TRIM(CS%delta_rho_form) == 'mid_pressure') then @@ -1754,11 +1793,11 @@ subroutine calc_delta_rho_and_derivs(CS, T1, S1, p1_in, T2, S2, p2_in, drho, 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) + 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) + 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 @@ -1776,30 +1815,33 @@ end subroutine calc_delta_rho_and_derivs !! (\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 - real :: S1 !< Salinity at point 1 - real :: P1 !< Pressure at point 1 - real :: dRdT1 !< Pressure at point 1 - real :: dRdS1 !< Pressure at point 1 - real :: T2 !< Temperature at point 2 - real :: S2 !< Salinity at point 2 - real :: P2 !< Pressure at point 2 - real :: dRdT2 !< Pressure at point 2 - real :: dRdS2 !< Pressure at point 2 + real :: T1 !< Temperature at point 1 [degC] + real :: S1 !< Salinity at point 1 [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 degC-1 ~> kg m-3 degC-1] + real :: dRdS1 !< The partial derivative of density with salinity at point 1 [R ppt-1 ~> kg m-3 ppt-1] + real :: T2 !< Temperature at point 2 [degC] + real :: S2 !< Salinity at point 2 [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 degC-1 ~> kg m-3 degC-1] + real :: dRdS2 !< The partial derivative of density with salinity at point 2 [R ppt-1 ~> kg m-3 ppt-1] ! Local variables - real :: drho + 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) -real function absolute_position(n,ns,Pint,Karr,NParr,k_surface) +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 [Pa] + 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(:) + 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 @@ -1811,13 +1853,14 @@ 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 [Pa] + 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(:) - real, dimension(ns) :: absolute_positions ! Absolute positions [Pa] + real, dimension(ns) :: absolute_positions !< Absolute positions [R L2 T-2 ~> Pa] + !! or other units following Pint ! Local variables integer :: k_surface, k @@ -1834,8 +1877,8 @@ subroutine neutral_surface_flux(nk, nsurf, deg, hl, hr, Tl, Tr, PiL, PiR, KoL, K 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 or Pa] - real, dimension(nk), intent(in) :: hr !< Right-column layer thickness [H or Pa] + 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 (conc, e.g. degC) real, dimension(nk), intent(in) :: Tr !< Right-column layer tracer (conc, e.g. degC) real, dimension(nsurf), intent(in) :: PiL !< Fractional position of neutral surface @@ -1844,16 +1887,16 @@ subroutine neutral_surface_flux(nk, nsurf, deg, hl, hr, Tl, Tr, PiL, PiR, KoL, K !! within layer KoR of right column 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 [Pa] + 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 (conc H) logical, intent(in) :: continuous !< True if using continuous reconstruction real, intent(in) :: h_neglect !< A negligibly small width for the - !! purpose of cell reconstructions - !! in the same units as h0. + !! 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. + !! edge value calculations if continuous is false [H ~> m or kg m-2] ! Local variables integer :: k_sublayer, klb, klt, krb, krt, k real :: T_right_top, T_right_bottom, T_right_layer, T_right_sub, T_right_top_int, T_right_bot_int @@ -2039,7 +2082,6 @@ logical function neutral_diffusion_unit_tests(verbose) 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. @@ -2064,7 +2106,7 @@ logical function ndiff_unit_tests_continuous(verbose) v = verbose ndiff_unit_tests_continuous = .false. ! Normally return false - write(*,*) '==== MOM_neutral_diffusion: ndiff_unit_tests_continuous =' + 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') @@ -2304,7 +2346,7 @@ logical function ndiff_unit_tests_continuous(verbose) (/0.,0.,0.,0.,0.,6.,0./), & ! hEff 'Two unstable mixed layers') - if (.not. ndiff_unit_tests_continuous) write(*,*) 'Pass' + if (.not. ndiff_unit_tests_continuous) write(stdout,*) 'Pass' end function ndiff_unit_tests_continuous @@ -2313,9 +2355,10 @@ logical function ndiff_unit_tests_discontinuous(verbose) ! Local variables integer, parameter :: nk = 3 integer, parameter :: ns = nk*4 - real, dimension(nk) :: Sl, Sr, Tl, Tr, hl, hr - real, dimension(nk,2) :: TiL, SiL, TiR, SiR - real, dimension(nk,2) :: Pres_l, Pres_r + real, dimension(nk) :: Sl, Sr, Tl, Tr ! Salinities [ppt] and temperatures [degC] + real, dimension(nk) :: hl, hr ! Thicknesses in pressure units [R L2 T-2 ~> Pa] + 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 real, dimension(ns) :: PoL, PoR real, dimension(ns-1) :: hEff, Flx @@ -2324,7 +2367,10 @@ logical function ndiff_unit_tests_discontinuous(verbose) type(remapping_CS), pointer :: remap_CS !< Remapping control structure (PLM) real, dimension(nk,2) :: ppoly_T_l, ppoly_T_r ! Linear reconstruction for T real, dimension(nk,2) :: ppoly_S_l, ppoly_S_r ! Linear reconstruction for S - real, dimension(nk,2) :: dRdT, dRdS + real, dimension(nk,2) :: dRdT !< Partial derivative of density with temperature at + !! cell edges [R degC-1 ~> kg m-3 degC-1] + real, dimension(nk,2) :: dRdS !< Partial derivative of density with salinity at + !! cell edges [R ppt-1 ~> kg m-3 ppt-1] logical, dimension(nk) :: stable_l, stable_r integer :: iMethod integer :: ns_l, ns_r @@ -2333,12 +2379,12 @@ logical function ndiff_unit_tests_discontinuous(verbose) v = verbose ndiff_unit_tests_discontinuous = .false. ! Normally return false - write(*,*) '==== MOM_neutral_diffusion: ndiff_unit_tests_discontinuous =' + 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.) + 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. @@ -2361,7 +2407,7 @@ logical function ndiff_unit_tests_discontinuous(verbose) 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) + 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 @@ -2375,7 +2421,7 @@ logical function ndiff_unit_tests_discontinuous(verbose) 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) + 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 @@ -2389,7 +2435,7 @@ logical function ndiff_unit_tests_discontinuous(verbose) 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) + 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 @@ -2403,7 +2449,7 @@ logical function ndiff_unit_tests_discontinuous(verbose) 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) + 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 @@ -2417,7 +2463,7 @@ logical function ndiff_unit_tests_discontinuous(verbose) 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) + 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 @@ -2431,7 +2477,7 @@ logical function ndiff_unit_tests_discontinuous(verbose) 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) + 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 @@ -2445,7 +2491,7 @@ logical function ndiff_unit_tests_discontinuous(verbose) 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) + 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 @@ -2459,7 +2505,7 @@ logical function ndiff_unit_tests_discontinuous(verbose) 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) + 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 @@ -2473,7 +2519,7 @@ logical function ndiff_unit_tests_discontinuous(verbose) 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) + 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 @@ -2487,7 +2533,7 @@ logical function ndiff_unit_tests_discontinuous(verbose) 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) + 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 @@ -2501,7 +2547,7 @@ logical function ndiff_unit_tests_discontinuous(verbose) 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) + 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 @@ -2515,7 +2561,7 @@ logical function ndiff_unit_tests_discontinuous(verbose) 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) + 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 @@ -2531,44 +2577,44 @@ logical function ndiff_unit_tests_discontinuous(verbose) ! 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., -0.2, 0., & - 0., -0.2, 0., 10., -0.2, 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., 0.8, & - 0., 0., 0.8, 10., 0., 0.8, & + 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., -0.5, 0.5, & - 0., -0.5, 0.5, 10., -0.5, 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., -0.2, 0., & - 0., -0.4, 0., 10., -0.6, 0., & + 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., 0.8, & - 0., 0., 1.0, 10., 0., 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(*,*) 'Pass' + 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 - real, intent(in) :: hk !< Center cell width - real, intent(in) :: hkp1 !< Right cell width + 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 real, intent(in) :: Sk !< Center cell average value real, intent(in) :: Skp1 !< Right cell average value - real, intent(in) :: Ptrue !< True answer [Pa] + real, intent(in) :: Ptrue !< True answer [nondim] character(len=*), intent(in) :: title !< Title for messages ! Local variables @@ -2579,8 +2625,8 @@ logical function test_fv_diff(verbose, hkm1, hk, hkp1, Skm1, Sk, Skp1, Ptrue, ti test_fv_diff = (Pret /= Ptrue) if (test_fv_diff .or. verbose) then - stdunit = 6 - if (test_fv_diff) stdunit = 0 ! In case of wrong results, write to error stream + 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(x,a,f20.16),x,a)') 'pRet=',Pret,'pTrue=',Ptrue,'WRONG!' @@ -2600,7 +2646,7 @@ logical function test_fvlsq_slope(verbose, hkm1, hk, hkp1, Skm1, Sk, Skp1, Ptrue real, intent(in) :: Skm1 !< Left cell average value real, intent(in) :: Sk !< Center cell average value real, intent(in) :: Skp1 !< Right cell average value - real, intent(in) :: Ptrue !< True answer [Pa] + real, intent(in) :: Ptrue !< True answer character(len=*), intent(in) :: title !< Title for messages ! Local variables @@ -2611,8 +2657,8 @@ logical function test_fvlsq_slope(verbose, hkm1, hk, hkp1, Skm1, Sk, Skp1, Ptrue test_fvlsq_slope = (Pret /= Ptrue) if (test_fvlsq_slope .or. verbose) then - stdunit = 6 - if (test_fvlsq_slope) stdunit = 0 ! In case of wrong results, write to error stream + 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(x,a,f20.16),x,a)') 'pRet=',Pret,'pTrue=',Ptrue,'WRONG!' @@ -2626,11 +2672,11 @@ 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 [kg m-3] - real, intent(in) :: Pneg !< Interface position of lighter density [Pa] - real, intent(in) :: rhoPos !< Heavier density [kg m-3] - real, intent(in) :: Ppos !< Interface position of heavier density [Pa] - real, intent(in) :: Ptrue !< True answer [Pa] + 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 @@ -2641,8 +2687,8 @@ logical function test_ifndp(verbose, rhoNeg, Pneg, rhoPos, Ppos, Ptrue, title) test_ifndp = (Pret /= Ptrue) if (test_ifndp .or. verbose) then - stdunit = 6 - if (test_ifndp) stdunit = 0 ! In case of wrong results, write to error stream + 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(x,a,f20.16),2(x,a,1pe22.15),x,a)') & @@ -2672,8 +2718,8 @@ logical function test_data1d(verbose, nk, Po, Ptrue, title) enddo if (test_data1d .or. verbose) then - stdunit = 6 - if (test_data1d) stdunit = 0 ! In case of wrong results, write to error stream + 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 @@ -2707,8 +2753,8 @@ logical function test_data1di(verbose, nk, Po, Ptrue, title) enddo if (test_data1di .or. verbose) then - stdunit = 6 - if (test_data1di) stdunit = 0 ! In case of wrong results, write to error stream + 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 @@ -2726,19 +2772,19 @@ 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 + 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 real, dimension(ns), intent(in) :: pR !< Fractional position of neutral surface within layer KoR of right column - real, dimension(ns-1), intent(in) :: hEff !< Effective thickness between two neutral surfaces [Pa] + 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 real, dimension(ns), intent(in) :: pR0 !< Correct value for pR - real, dimension(ns-1), intent(in) :: hEff0 !< Correct value for hEff - character(len=*), intent(in) :: title !< Title for messages + real, dimension(ns-1), intent(in) :: hEff0 !< Correct value for hEff + character(len=*), intent(in) :: title !< Title for messages ! Local variables integer :: k, stdunit @@ -2753,8 +2799,8 @@ logical function test_nsp(verbose, ns, KoL, KoR, pL, pR, hEff, KoL0, KoR0, pL0, enddo if (test_nsp .or. verbose) then - stdunit = 6 - if (test_nsp) stdunit = 0 ! In case of wrong results, write to error stream + 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)) @@ -2802,7 +2848,9 @@ logical function test_rnp(expected_pos, test_pos, title) real, intent(in) :: test_pos !< The position returned by the code character(len=*), intent(in) :: title !< A label for this test ! Local variables - integer :: stdunit = 6 ! Output to standard error + 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 diff --git a/src/tracer/MOM_offline_aux.F90 b/src/tracer/MOM_offline_aux.F90 index 21db2cfff4..119ad555da 100644 --- a/src/tracer/MOM_offline_aux.F90 +++ b/src/tracer/MOM_offline_aux.F90 @@ -4,7 +4,6 @@ module MOM_offline_aux ! This file is part of MOM6. See LICENSE.md for the license. -use mpp_domains_mod, only : CENTER, CORNER, NORTH, EAST use data_override_mod, only : data_override_init, data_override use MOM_time_manager, only : time_type, operator(-) use MOM_debugging, only : check_column_integrals @@ -12,7 +11,7 @@ module MOM_offline_aux use MOM_diag_vkernels, only : reintegrate_column use MOM_error_handler, only : callTree_enter, callTree_leave, MOM_error, FATAL, WARNING, is_root_pe use MOM_grid, only : ocean_grid_type -use MOM_io, only : MOM_read_data, MOM_read_vector +use MOM_io, only : MOM_read_data, MOM_read_vector, CENTER use MOM_verticalGrid, only : verticalGrid_type use MOM_file_parser, only : get_param, log_version, param_file_type use astronomy_mod, only : orbital_time, diurnal_solar, daily_mean_solar diff --git a/src/tracer/MOM_offline_main.F90 b/src/tracer/MOM_offline_main.F90 index dfdcb4c09b..3895e8a116 100644 --- a/src/tracer/MOM_offline_main.F90 +++ b/src/tracer/MOM_offline_main.F90 @@ -4,7 +4,6 @@ module MOM_offline_main ! This file is part of MOM6. See LICENSE.md for the license. -use mpp_domains_mod, only : CENTER, CORNER, NORTH, EAST use MOM_ALE, only : ALE_CS, ALE_main_offline, ALE_offline_inputs use MOM_checksums, only : hchksum, uvchksum use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end @@ -20,7 +19,7 @@ module MOM_offline_main use MOM_file_parser, only : read_param, get_param, log_version, param_file_type use MOM_forcing_type, only : forcing use MOM_grid, only : ocean_grid_type -use MOM_io, only : MOM_read_data, MOM_read_vector +use MOM_io, only : MOM_read_data, MOM_read_vector, CENTER use MOM_offline_aux, only : update_offline_from_arrays, update_offline_from_files use MOM_offline_aux, only : next_modulo_time, offline_add_diurnal_sw use MOM_offline_aux, only : update_h_horizontal_flux, update_h_vertical_flux, limit_mass_flux_3d @@ -28,7 +27,7 @@ module MOM_offline_main 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 +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 @@ -79,7 +78,8 @@ module MOM_offline_main integer :: start_index !< Timelevel to start integer :: iter_no !< Timelevel to start integer :: numtime !< How many timelevels in the input fields - integer :: accumulated_time !< Length of time accumulated in the current offline interval + 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 @@ -176,7 +176,7 @@ module MOM_offline_main real, allocatable, dimension(:,:) :: netMassIn !< Freshwater fluxes into the ocean real, allocatable, dimension(:,:) :: netMassOut !< Freshwater fluxes out of the ocean - real, allocatable, dimension(:,:) :: mld !< Mixed layer depths at thickness points [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 @@ -722,9 +722,9 @@ subroutine offline_diabatic_ale(fluxes, Time_start, Time_end, CS, h_pre, eatr, e ! 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 + sw(:,:) = fluxes%sw(:,:) + sw_vis(:,:) = fluxes%sw_vis_dir(:,:) + sw_nir(:,:) = fluxes%sw_nir_dir(:,:) call offline_add_diurnal_SW(fluxes, CS%G, Time_start, Time_end) endif @@ -738,9 +738,9 @@ subroutine offline_diabatic_ale(fluxes, Time_start, Time_end, CS, h_pre, eatr, e CS%G, CS%GV, CS%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 + fluxes%sw(:,:) = sw(:,:) + fluxes%sw_vis_dir(:,:) = sw_vis(:,:) + fluxes%sw_nir_dir(:,:) = sw_nir(:,:) endif if (CS%debug) then @@ -1200,7 +1200,7 @@ 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, & +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 @@ -1212,9 +1212,10 @@ subroutine extract_offline_main(CS, uhtr, vhtr, eatr, ebtr, h_end, accumulated_t !! 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] - !### Why are the following variables integers? - integer, optional, pointer :: accumulated_time !< Length of time accumulated in the - !! current offline interval [s] + 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] @@ -1229,6 +1230,7 @@ subroutine extract_offline_main(CS, uhtr, vhtr, eatr, ebtr, h_end, accumulated_t ! 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 @@ -1414,7 +1416,8 @@ subroutine offline_transport_init(param_file, CS, diabatic_CSp, G, GV, US) end select ! Set the accumulated time to zero - CS%accumulated_time = 0 + 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) diff --git a/src/tracer/MOM_tracer_Z_init.F90 b/src/tracer/MOM_tracer_Z_init.F90 index aaa670070b..ac6242785e 100644 --- a/src/tracer/MOM_tracer_Z_init.F90 +++ b/src/tracer/MOM_tracer_Z_init.F90 @@ -7,7 +7,7 @@ module MOM_tracer_Z_init ! 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 -use MOM_EOS, only : EOS_type, calculate_density, calculate_density_derivs +use MOM_EOS, only : EOS_type, calculate_density, calculate_density_derivs, EOS_domain use MOM_unit_scaling, only : unit_scale_type use netcdf @@ -16,7 +16,7 @@ module MOM_tracer_Z_init #include -public tracer_Z_init, tracer_Z_init_array, find_interfaces, determine_temperature +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 @@ -275,51 +275,49 @@ function tracer_Z_init(tr, h, filename, tr_name, G, US, missing_val, land_val) end function tracer_Z_init -!> Layer model routine for remapping tracers -!! from pseudo-z coordinates into layers defined +!> 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, e, nkml, nkbl, land_fill, wet, nlay, nlevs, & - eps_z, tr) - real, dimension(:,:,:), intent(in) :: tr_in !< The z-space array of tracer concentrations that is read in. - real, dimension(size(tr_in,3)+1), intent(in) :: z_edges !< The depths of the cell edges in the input z* data +subroutine tracer_z_init_array(tr_in, z_edges, nk_data, e, land_fill, G, nlay, nlevs, & + eps_z, tr) + 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. + 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(size(tr_in,1),size(tr_in,2),nlay+1), & - intent(in) :: e !< The depths of the target layer interfaces [Z ~> m or m] - integer, intent(in) :: nkml !< The number of mixed layers - integer, intent(in) :: nkbl !< The number of buffer layers - real, intent(in) :: land_fill !< fill in data over land (1) - real, dimension(size(tr_in,1),size(tr_in,2)), & - intent(in) :: wet !< The wet mask for the source data (valid points) - integer, dimension(size(tr_in,1),size(tr_in,2)), & - 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(size(tr_in,1),size(tr_in,2),nlay), intent(out) :: tr !< tracers in layer space + 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 (1) + 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 layer space ! Local variables - real, dimension(size(tr_in,3)) :: tr_1d !< a copy of the input tracer concentrations in a column. - real, dimension(nlay+1) :: e_1d ! A 1-d column of intreface heights, in the same units as e. - real, dimension(nlay) :: tr_ ! A 1-d column of tracer concentrations - integer :: n,i,j,k,l,nx,ny,nz,nt,kz - integer :: k_top,k_bot,k_bot_prev,kk,kstart + real, dimension(nk_data) :: tr_1d !< a copy of the input tracer concentrations in a column. + real, dimension(nlay+1) :: e_1d ! A 1-d column of intreface heights, in the same units as e. + real, dimension(nlay) :: tr_ ! A 1-d column of output tracer concentrations + integer :: k_top, k_bot, k_bot_prev, kstart real :: sl_tr ! The tracer concentration slope times the layer thickness, in tracer units. - real, dimension(size(tr_in,3)) :: wt !< The fractional weight for each layer in the range between z1 and z2 - real, dimension(size(tr_in,3)) :: z1, z2 ! z1 and z2 are the fractional depths of the top and bottom + real, dimension(nk_data) :: wt !< The fractional weight for each layer in the range between z1 and z2 + real, dimension(nk_data) :: z1, z2 ! z1 and z2 are the fractional 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. + integer :: i, j, k, kz, is, ie, js, je - nx = size(tr_in,1); ny=size(tr_in,2); nz = size(tr_in,3) + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - - do j=1,ny - i_loop: do i=1,nx - if (nlevs(i,j) == 0 .or. wet(i,j) == 0.) then + 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,nz + do k=1,nk_data tr_1d(k) = tr_in(i,j,k) enddo @@ -334,11 +332,11 @@ subroutine tracer_z_init_array(tr_in, z_edges, e, nkml, nkbl, land_fill, wet, nl tr(i,j,k) = tr_1d(nlevs(i,j)) else - kstart=k_bot + 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 + 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 @@ -362,8 +360,7 @@ subroutine tracer_z_init_array(tr_in, z_edges, e, nkml, nkbl, land_fill, wet, nl 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))) + 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 @@ -373,7 +370,7 @@ subroutine tracer_z_init_array(tr_in, z_edges, e, nkml, nkbl, land_fill, wet, nl 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) + if (e_1d(k)-e_1d(k+1) <= eps_z) tr(i,j,k) = tr(i,j,k-1) enddo enddo i_loop @@ -611,144 +608,21 @@ function find_limited_slope(val, e, k) result(slope) end function find_limited_slope -!> Find interface positions corresponding to density profile -subroutine find_interfaces(rho, zin, nk_data, Rb, depth, zi, G, US, nlevs, nkml, nkbl, hml, debug, eps_z, eps_rho) - 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) :: 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_(G)+1), intent(in) :: Rb !< target interface densities [R ~> kg m-3] - real, dimension(SZI_(G),SZJ_(G)), & - intent(in) :: depth !< ocean depth [Z ~> m]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+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)), & - optional, intent(in) :: nlevs !< number of valid points in each column - logical, optional, intent(in) :: debug !< optional debug flag - integer, optional, intent(in) :: nkml !< number of mixed layer pieces - integer, optional, intent(in) :: nkbl !< number of buffer layer pieces - real, optional, intent(in) :: hml !< mixed layer depth [Z ~> m]. - real, optional, intent(in) :: eps_z !< A negligibly small layer thickness [Z ~> m]. - real, optional, intent(in) :: eps_rho !< A negligibly small density difference [R ~> kg m-3]. - - ! Local variables - real, dimension(SZI_(G),nk_data) :: rho_ ! A slice of densities [R ~> kg m-3] - logical :: unstable - integer :: dir - integer, dimension(SZI_(G),SZK_(G)+1) :: ki_ - real, dimension(SZI_(G),SZK_(G)+1) :: zi_ - integer, dimension(SZI_(G),SZJ_(G)) :: nlevs_data - integer, dimension(SZI_(G)) :: lo, hi - real :: slope,rsm,drhodz,hml_ - real :: epsln_Z ! A negligibly thin layer thickness [m or Z ~> m]. - real :: epsln_rho ! A negligibly small density change [kg m-3 or R ~> kg m-3]. - real, parameter :: zoff=0.999 - integer :: kk,nkml_,nkbl_ - logical :: debug_ = .false. - integer :: i, j, k, m, n, is, ie, js, je, nz - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke - - zi(:,:,:) = 0.0 - - if (PRESENT(debug)) debug_=debug - - nlevs_data(:,:) = nz - - nkml_ = 0 ; if (PRESENT(nkml)) nkml_ = max(0, nkml) - nkbl_ = 0 ; if (PRESENT(nkbl)) nkbl_ = max(0, nkbl) - hml_ = 0.0 ; if (PRESENT(hml)) hml_ = hml - epsln_Z = 1.0e-10*US%m_to_Z ; if (PRESENT(eps_z)) epsln_Z = eps_z - epsln_rho = 1.0e-10*US%kg_m3_to_R ; if (PRESENT(eps_rho)) epsln_rho = eps_rho - - if (PRESENT(nlevs)) then - nlevs_data(:,:) = nlevs(:,:) - endif - - do j=js,je - rho_(:,:) = rho(:,j,:) - i_loop: do i=is,ie - if (debug_) then - print *,'looking for interfaces, i,j,nlevs= ',i,j,nlevs_data(i,j) - print *,'initial density profile= ', rho_(i,:) - endif - unstable=.true. - dir=1 - do while (unstable) - unstable=.false. - if (dir == 1) then - do k=2,nlevs_data(i,j)-1 - if (rho_(i,k) - rho_(i,k-1) < 0.0 ) then - if (k == 2) then - rho_(i,k-1) = rho_(i,k)-epsln_rho - else - drhodz = (rho_(i,k+1)-rho_(i,k-1)) / (zin(k+1)-zin(k-1)) - if (drhodz < 0.0) unstable=.true. - rho_(i,k) = rho_(i,k-1) + drhodz*zoff*(zin(k)-zin(k-1)) - endif - endif - enddo - dir = -1*dir - else - do k=nlevs_data(i,j)-1,2,-1 - if (rho_(i,k+1) - rho_(i,k) < 0.0) then - if (k == nlevs_data(i,j)-1) then - rho_(i,k+1) = rho_(i,k-1)+epsln_rho - else - drhodz = (rho_(i,k+1)-rho_(i,k-1))/(zin(k+1)-zin(k-1)) - if (drhodz < 0.0) unstable=.true. - rho_(i,k) = rho_(i,k+1)-drhodz*(zin(k+1)-zin(k)) - endif - endif - enddo - dir = -1*dir - endif - enddo - if (debug_) then - print *,'final density profile= ', rho_(i,:) - endif - enddo i_loop - - ki_(:,:) = 0 - zi_(:,:) = 0.0 - lo(:) = 1 - hi(:) = nlevs_data(:,j) - ki_ = bisect_fast(rho_, Rb, lo, hi) - ki_(:,:) = max(1, ki_(:,:)-1) - do i=is,ie - do m=2,nz - slope = (zin(ki_(i,m)+1) - zin(ki_(i,m))) / max(rho_(i,ki_(i,m)+1) - rho_(i,ki_(i,m)),epsln_rho) - zi_(i,m) = -1.0*(zin(ki_(i,m)) + slope*(Rb(m)-rho_(i,ki_(i,m)))) - zi_(i,m) = max(zi_(i,m), -depth(i,j)) - zi_(i,m) = min(zi_(i,m), -1.0*hml_) - enddo - zi_(i,nz+1) = -depth(i,j) - do m=2,nkml_+1 - zi_(i,m) = max(hml_*((1.0-real(m))/real(nkml_)), -depth(i,j)) - enddo - do m=nz,nkml_+2,-1 - if (zi_(i,m) < zi_(i,m+1) + epsln_Z) zi_(i,m) = zi_(i,m+1) + epsln_Z - if (zi_(i,m) > -1.0*hml_) zi_(i,m) = max(-1.0*hml_, -depth(i,j)) - enddo - enddo - zi(:,j,:) = zi_(:,:) - enddo - -end subroutine find_interfaces - !> 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, p_ref, niter, land_fill, h, k_start, US, eos, h_massless) - real, dimension(:,:,:), intent(inout) :: temp !< potential temperature [degC] - real, dimension(:,:,:), intent(inout) :: salt !< salinity [PSU] - real, dimension(size(temp,3)), intent(in) :: R_tgt !< desired potential density [R ~> kg m-3]. - real, intent(in) :: p_ref !< reference pressure [Pa]. +subroutine determine_temperature(temp, salt, R_tgt, p_ref, niter, land_fill, h, k_start, G, US, eos, h_massless) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(inout) :: temp !< potential temperature [degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(inout) :: salt !< salinity [PSU] + real, dimension(SZK_(G)), intent(in) :: R_tgt !< desired potential density [R ~> kg m-3]. + 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) real, intent(in) :: land_fill !< land fill value - real, dimension(:,:,:), intent(in) :: h !< layer thickness, used only to avoid working on + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h !< layer thickness, used only to avoid working on !! massless layers [H ~> m or kg m-2] type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(eos_type), pointer :: eos !< seawater equation of state control structure @@ -757,14 +631,13 @@ subroutine determine_temperature(temp, salt, R_tgt, p_ref, niter, land_fill, h, real, parameter :: T_max = 31.0, T_min = -2.0 ! Local variables (All of which need documentation!) - real, dimension(size(temp,1),size(temp,3)) :: & + real, dimension(SZI_(G),SZK_(G)) :: & T, S, dT, dS, & rho, & ! Layer densities [R ~> kg m-3] hin, & ! Input layer thicknesses [H ~> m or kg m-2] drho_dT, & ! Partial derivative of density with temperature [R degC-1 ~> kg m-3 degC-1] drho_dS ! Partial derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1] - real, dimension(size(temp,1)) :: press - integer :: nx, ny, nz, nt, i, j, k, n, itt + 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 [degC ppt-1]. real :: I_denom ! The inverse of the magnitude squared of the density gradient in @@ -775,6 +648,10 @@ subroutine determine_temperature(temp, salt, R_tgt, p_ref, niter, land_fill, h, real :: tol_S ! The tolerance for salinity matches [ppt] real :: tol_rho ! The tolerance for density matches [R ~> kg m-3] real :: max_t_adj, max_s_adj + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state + integer :: i, j, k, kz, is, ie, js, je, nz, itt + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke ! These hard coded parameters need to be set properly. S_min = 0.5 ; S_max = 65.0 @@ -788,11 +665,10 @@ subroutine determine_temperature(temp, salt, R_tgt, p_ref, niter, land_fill, h, ! We will switch to the newer method which simultaneously adjusts ! temp and salt based on the ratio of the thermal and haline coefficients, once it is tested. - nx=size(temp,1) ; ny=size(temp,2) ; nz=size(temp,3) - press(:) = p_ref + EOSdom(:) = EOS_domain(G%HI) - do j=1,ny + 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,:) @@ -800,13 +676,12 @@ subroutine determine_temperature(temp, salt, R_tgt, p_ref, niter, land_fill, h, 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), 1, nx, eos, scale=US%kg_m3_to_R) - call calculate_density_derivs(T(:,k), S(:,k), press, drho_dT(:,k), drho_dS(:,k), 1, nx, & - eos, scale=US%kg_m3_to_R) + 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=1,nx - + do k=k_start,nz ; do i=is,ie ! if (abs(rho(i,k)-R_tgt(k))>tol_rho .and. hin(i,k)>h_massless .and. abs(T(i,k)-land_fill) < epsln) then if (abs(rho(i,k)-R_tgt(k))>tol_rho) then if (old_fit) then @@ -824,18 +699,18 @@ subroutine determine_temperature(temp, salt, R_tgt, p_ref, niter, land_fill, h, endif enddo ; enddo if (maxval(abs(dT)) < tol_T) then - adjust_salt = .false. - exit iter_loop + adjust_salt = .false. + exit iter_loop endif enddo iter_loop if (adjust_salt .and. old_fit) then ; do itt = 1,niter - do k=1, nz - call calculate_density(T(:,k), S(:,k), press, rho(:,k), 1, nx, eos, scale=US%kg_m3_to_R) - call calculate_density_derivs(T(:,k), S(:,k), press, drho_dT(:,k), drho_dS(:,k), 1, nx, & - eos, scale=US%kg_m3_to_R) + 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=1,nx + do k=k_start,nz ; do i=is,ie ! if (abs(rho(i,k)-R_tgt(k))>tol_rho .and. hin(i,k)>h_massless .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) @@ -851,52 +726,4 @@ subroutine determine_temperature(temp, salt, R_tgt, p_ref, niter, land_fill, h, end subroutine determine_temperature -!> Return the index where to insert item x in list a, assuming a is sorted. -!! The return values [i] is such that all e in a[:i-1] have e <= x, and all e in -!! a[i:] have e > x. So if x already appears in the list, will -!! insert just after the rightmost x already there. -!! Optional args lo (default 1) and hi (default len(a)) bound the -!! slice of a to be searched. -function bisect_fast(a, x, lo, hi) result(bi_r) - real, dimension(:,:), intent(in) :: a !< Sorted list - real, dimension(:), intent(in) :: x !< Item to be inserted - integer, dimension(size(a,1)), optional, intent(in) :: lo !< Lower bracket of optional range to search - integer, dimension(size(a,1)), optional, intent(in) :: hi !< Upper bracket of optional range to search - integer, dimension(size(a,1),size(x,1)) :: bi_r - - integer :: mid,num_x,num_a,i - integer, dimension(size(a,1)) :: lo_,hi_,lo0,hi0 - integer :: nprofs,j - - lo_=1;hi_=size(a,2);num_x=size(x,1);bi_r=-1;nprofs=size(a,1) - - if (PRESENT(lo)) then - where (lo>0) lo_=lo - endif - if (PRESENT(hi)) then - where (hi>0) hi_=hi - endif - - lo0=lo_;hi0=hi_ - - do j=1,nprofs - do i=1,num_x - lo_=lo0;hi_=hi0 - do while (lo_(j) < hi_(j)) - mid = (lo_(j)+hi_(j))/2 - if (x(i) < a(j,mid)) then - hi_(j) = mid - else - lo_(j) = mid+1 - endif - enddo - bi_r(j,i)=lo_(j) - enddo - enddo - - - return - -end function bisect_fast - end module MOM_tracer_Z_init diff --git a/src/tracer/MOM_tracer_advect.F90 b/src/tracer/MOM_tracer_advect.F90 index 59131bf776..e9c8fb0e7b 100644 --- a/src/tracer/MOM_tracer_advect.F90 +++ b/src/tracer/MOM_tracer_advect.F90 @@ -140,16 +140,15 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, & !$OMP hprev,domore_k,js,je,is,ie,uhtr,vhtr,G,GV,h_end,& !$OMP uh_neglect,vh_neglect,ntr,Tr,h_prev_opt) -! This initializes the halos of uhr and vhr because pass_vector might do -! calculations on them, even though they are never used. -!$OMP do - + ! This initializes the halos of uhr and vhr because pass_vector might do + ! calculations on them, even though they are never used. + !$OMP do do k=1,nz do j=jsd,jed ; do I=IsdB,IedB ; uhr(I,j,k) = 0.0 ; enddo ; enddo do J=jsdB,jedB ; do i=Isd,Ied ; vhr(i,J,k) = 0.0 ; enddo ; enddo do j=jsd,jed ; do i=Isd,Ied ; hprev(i,j,k) = 0.0 ; enddo ; enddo domore_k(k)=1 -! Put the remaining (total) thickness fluxes into uhr and vhr. + ! Put the remaining (total) thickness fluxes into uhr and vhr. do j=js,je ; do I=is-1,ie ; uhr(I,j,k) = uhtr(I,j,k) ; enddo ; enddo do J=js-1,je ; do i=is,ie ; vhr(i,J,k) = vhtr(i,J,k) ; enddo ; enddo if (.not. present(h_prev_opt)) then @@ -173,17 +172,17 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, & enddo -!$OMP do + !$OMP do do j=jsd,jed ; do I=isd,ied-1 - uh_neglect(I,j) = GV%H_subroundoff*MIN(G%areaT(i,j),G%areaT(i+1,j)) + uh_neglect(I,j) = GV%H_subroundoff * MIN(G%areaT(i,j), G%areaT(i+1,j)) enddo ; enddo -!$OMP do + !$OMP do do J=jsd,jed-1 ; do i=isd,ied - vh_neglect(i,J) = GV%H_subroundoff*MIN(G%areaT(i,j),G%areaT(i,j+1)) + vh_neglect(i,J) = GV%H_subroundoff * MIN(G%areaT(i,j), G%areaT(i,j+1)) enddo ; enddo -!$OMP do ! initialize diagnostic fluxes and tendencies + !$OMP do do m=1,ntr if (associated(Tr(m)%ad_x)) then do k=1,nz ; do j=jsd,jed ; do i=isd,ied @@ -207,7 +206,7 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, & do J=jsd,jed ; do i=isd,ied ; Tr(m)%ad2d_y(i,J) = 0.0 ; enddo ; enddo endif enddo -!$OMP end parallel + !$OMP end parallel isv = is ; iev = ie ; jsv = js ; jev = je @@ -222,8 +221,7 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, & ! Reevaluate domore_u & domore_v unless the valid range is the same size as ! before. Also, do this if there is Strang splitting. if ((nsten_halo > 1) .or. (itt==1)) then -!$OMP parallel do default(none) shared(nz,domore_k,jsv,jev,domore_u,isv,iev,stencil, & -!$OMP uhr,domore_v,vhr) + !$OMP parallel do default(shared) do k=1,nz ; if (domore_k(k) > 0) then do j=jsv,jev ; if (.not.domore_u(j,k)) then do i=isv+stencil-1,iev-stencil; if (uhr(I,j,k) /= 0.0) then @@ -256,9 +254,7 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, & ! for all the transport to happen. The sum over domore_k keeps the processors ! synchronized. This may not be very efficient, but it should be reliable. -!$OMP parallel default(private) shared(nz,domore_k,x_first,Tr,hprev,uhr,uh_neglect, & -!$OMP OBC,domore_u,ntr,Idt,isv,iev,jsv,jev,stencil, & -!$OMP G,GV,CS,vhr,vh_neglect,domore_v,US) + !$OMP parallel default(shared) if (x_first) then @@ -305,7 +301,7 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, & endif ! x_first -!$OMP end parallel + !$OMP end parallel ! If the advection just isn't finishing after max_iter, move on. if (itt >= max_iter) then @@ -382,9 +378,10 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & 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 ! A nondimensional work variable [nondim]. + CFL ! The absolute value of the advective upwind-cell CFL number [nondim]. real :: min_h ! The minimum thickness that can be realized during ! any of the passes [H ~> m or kg m-2]. + real :: tiny_h ! The smallest numerically invertable thickness [H ~> m or kg m-2]. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. logical :: do_i(SZIB_(G),SZJ_(G)) ! If true, work on given points. @@ -406,16 +403,15 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & if (usePPM .and. .not. useHuynh) stencil = 2 min_h = 0.1*GV%Angstrom_H + tiny_h = tiny(min_h) h_neglect = GV%H_subroundoff -! do I=is-1,ie ; ts2(I) = 0.0 ; enddo do I=is-1,ie ; CFL(I) = 0.0 ; enddo do j=js,je ; if (domore_u(j,k)) then domore_u(j,k) = .false. - ! Calculate the i-direction profiles (slopes) of each tracer that - ! is being advected. + ! Calculate the i-direction profiles (slopes) of each tracer that is being advected. if (usePLMslope) then do m=1,ntr ; do i=is-stencil,ie+stencil !if (ABS(Tr(m)%t(i+1,j,k)-Tr(m)%t(i,j,k)) < & @@ -459,13 +455,13 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & if (segment%direction == OBC_DIRECTION_W) then T_tmp(i,m) = segment%tr_Reg%Tr(m)%tres(i,j,k) else - T_tmp(I+1,m) = segment%tr_Reg%Tr(m)%tres(i,j,k) + T_tmp(i+1,m) = segment%tr_Reg%Tr(m)%tres(i,j,k) endif else if (segment%direction == OBC_DIRECTION_W) then T_tmp(i,m) = segment%tr_Reg%Tr(m)%OBC_inflow_conc else - T_tmp(I+1,m) = segment%tr_Reg%Tr(m)%OBC_inflow_conc + T_tmp(i+1,m) = segment%tr_Reg%Tr(m)%OBC_inflow_conc endif endif enddo @@ -490,33 +486,33 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & ! in the cell plus whatever part of its half of the mass flux that ! the flux through the other side does not require. do I=is-1,ie - if (uhr(I,j,k) == 0.0) then + if ((uhr(I,j,k) == 0.0) .or. & + ((uhr(I,j,k) < 0.0) .and. (hprev(i+1,j,k) <= tiny_h)) .or. & + ((uhr(I,j,k) > 0.0) .and. (hprev(i,j,k) <= tiny_h)) ) then uhh(I) = 0.0 CFL(I) = 0.0 elseif (uhr(I,j,k) < 0.0) then hup = hprev(i+1,j,k) - G%areaT(i+1,j)*min_h - hlos = MAX(0.0,uhr(I+1,j,k)) + hlos = MAX(0.0, uhr(I+1,j,k)) if ((((hup - hlos) + uhr(I,j,k)) < 0.0) .and. & ((0.5*hup + uhr(I,j,k)) < 0.0)) then - uhh(I) = MIN(-0.5*hup,-hup+hlos,0.0) + uhh(I) = MIN(-0.5*hup, -hup+hlos, 0.0) domore_u(j,k) = .true. else uhh(I) = uhr(I,j,k) endif - !ts2(I) = 0.5*(1.0 + uhh(I) / (hprev(i+1,j,k) + h_neglect*G%areaT(i+1,j))) - CFL(I) = - uhh(I) / (hprev(i+1,j,k) + h_neglect*G%areaT(i+1,j)) ! CFL is positive + CFL(I) = - uhh(I) / (hprev(i+1,j,k)) ! CFL is positive else hup = hprev(i,j,k) - G%areaT(i,j)*min_h - hlos = MAX(0.0,-uhr(I-1,j,k)) + hlos = MAX(0.0, -uhr(I-1,j,k)) if ((((hup - hlos) - uhr(I,j,k)) < 0.0) .and. & ((0.5*hup - uhr(I,j,k)) < 0.0)) then - uhh(I) = MAX(0.5*hup,hup-hlos,0.0) + uhh(I) = MAX(0.5*hup, hup-hlos, 0.0) domore_u(j,k) = .true. else uhh(I) = uhr(I,j,k) endif - !ts2(I) = 0.5*(1.0 - uhh(I) / (hprev(i,j,k) + h_neglect*G%areaT(i,j))) - CFL(I) = uhh(I) / (hprev(i,j,k) + h_neglect*G%areaT(i,j)) ! CFL is positive + CFL(I) = uhh(I) / (hprev(i,j,k)) ! CFL is positive endif enddo @@ -545,11 +541,11 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & dA = aR - aL ; mA = 0.5*( aR + aL ) if (G%mask2dCu(I_up,j)*G%mask2dCu(I_up-1,j)*(Tp-Tc)*(Tc-Tm) <= 0.) then - aL = Tc ; aR = Tc ! PCM for local extremum and bounadry cells + aL = Tc ; aR = Tc ! PCM for local extremum and bounadry cells elseif ( dA*(Tc-mA) > (dA*dA)/6. ) then - aL = 3.*Tc - 2.*aR + aL = 3.*Tc - 2.*aR elseif ( dA*(Tc-mA) < - (dA*dA)/6. ) then - aR = 3.*Tc - 2.*aL + aR = 3.*Tc - 2.*aL endif a6 = 6.*Tc - 3. * (aR + aL) ! Curvature @@ -570,28 +566,17 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & !aR = Tr(m)%t(i,j,k) + 0.5 * slope_x(i,m) !flux_x(I,j,m) = uhh(I)*( aR - 0.5 * (aR-aL) * CFL(I) ) ! Alternative implementation of PLM - !aR = Tr(m)%t(i,j,k) + 0.5 * slope_x(i,m) - !flux_x(I,j,m) = uhh(I)*( aR - 0.5 * slope_x(i,m) * CFL(I) ) - ! Alternative implementation of PLM Tc = T_tmp(i,m) flux_x(I,j,m) = uhh(I)*( Tc + 0.5 * slope_x(i,m) * ( 1. - CFL(I) ) ) - ! Original implementation of PLM - !flux_x(I,j,m) = uhh(I)*(Tr(m)%t(i,j,k) + slope_x(i,m)*ts2(I)) else ! Indirect implementation of PLM !aL = Tr(m)%t(i+1,j,k) - 0.5 * slope_x(i+1,m) !aR = Tr(m)%t(i+1,j,k) + 0.5 * slope_x(i+1,m) !flux_x(I,j,m) = uhh(I)*( aL + 0.5 * (aR-aL) * CFL(I) ) ! Alternative implementation of PLM - !aL = Tr(m)%t(i+1,j,k) - 0.5 * slope_x(i+1,m) - !flux_x(I,j,m) = uhh(I)*( aL + 0.5 * slope_x(i+1,m) * CFL(I) ) - ! Alternative implementation of PLM Tc = T_tmp(i+1,m) flux_x(I,j,m) = uhh(I)*( Tc - 0.5 * slope_x(i+1,m) * ( 1. - CFL(I) ) ) - ! Original implementation of PLM - !flux_x(I,j,m) = uhh(I)*(Tr(m)%t(i+1,j,k) - slope_x(i+1,m)*ts2(I)) endif - !ts2(I) = 0.5*(1.0 - uhh(I)/(hprev(i,j,k)+h_neglect*G%areaT(i,j))) enddo ; enddo endif ! usePPM @@ -757,9 +742,10 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & 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 ! A nondimensional work variable. + CFL ! The absolute value of the advective upwind-cell CFL number [nondim]. real :: min_h ! The minimum thickness that can be realized during ! any of the passes [H ~> m or kg m-2]. + real :: tiny_h ! The smallest numerically invertable thickness [H ~> m or kg m-2]. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. logical :: do_j_tr(SZJ_(G)) ! If true, calculate the tracer profiles. @@ -777,8 +763,8 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & if (usePPM .and. .not. useHuynh) stencil = 2 min_h = 0.1*GV%Angstrom_H + tiny_h = tiny(min_h) h_neglect = GV%H_subroundoff - !do i=is,ie ; ts2(i) = 0.0 ; enddo ! We conditionally perform work on tracer points: calculating the PLM slope, ! and updating tracer concentration within a cell @@ -822,7 +808,7 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & ! make a copy of the tracers in case values need to be overridden for OBCs - do j=G%jsd,G%jed; do m=1,ntr; do i=G%isd,G%ied + do j=G%jsd,G%jed ; do m=1,ntr ; do i=G%isd,G%ied T_tmp(i,m,j) = Tr(m)%t(i,j,k) enddo ; enddo ; enddo @@ -873,33 +859,33 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & domore_v(J,k) = .false. do i=is,ie - if (vhr(i,J,k) == 0.0) then + if ((vhr(i,J,k) == 0.0) .or. & + ((vhr(i,J,k) < 0.0) .and. (hprev(i,j+1,k) <= tiny_h)) .or. & + ((vhr(i,J,k) > 0.0) .and. (hprev(i,j,k) <= tiny_h)) ) then vhh(i,J) = 0.0 CFL(i) = 0.0 elseif (vhr(i,J,k) < 0.0) then hup = hprev(i,j+1,k) - G%areaT(i,j+1)*min_h - hlos = MAX(0.0,vhr(i,J+1,k)) + hlos = MAX(0.0, vhr(i,J+1,k)) if ((((hup - hlos) + vhr(i,J,k)) < 0.0) .and. & ((0.5*hup + vhr(i,J,k)) < 0.0)) then - vhh(i,J) = MIN(-0.5*hup,-hup+hlos,0.0) + vhh(i,J) = MIN(-0.5*hup, -hup+hlos, 0.0) domore_v(J,k) = .true. else vhh(i,J) = vhr(i,J,k) endif - !ts2(i) = 0.5*(1.0 + vhh(i,J) / (hprev(i,j+1,k) + h_neglect*G%areaT(i,j+1)) - CFL(i) = - vhh(i,J) / (hprev(i,j+1,k) + h_neglect*G%areaT(i,j+1)) ! CFL is positive + CFL(i) = - vhh(i,J) / hprev(i,j+1,k) ! CFL is positive else hup = hprev(i,j,k) - G%areaT(i,j)*min_h - hlos = MAX(0.0,-vhr(i,J-1,k)) + hlos = MAX(0.0, -vhr(i,J-1,k)) if ((((hup - hlos) - vhr(i,J,k)) < 0.0) .and. & ((0.5*hup - vhr(i,J,k)) < 0.0)) then - vhh(i,J) = MAX(0.5*hup,hup-hlos,0.0) + vhh(i,J) = MAX(0.5*hup, hup-hlos, 0.0) domore_v(J,k) = .true. else vhh(i,J) = vhr(i,J,k) endif - !ts2(i) = 0.5*(1.0 - vhh(i,J) / (hprev(i,j,k) + h_neglect*G%areaT(i,j))) - CFL(i) = vhh(i,J) / (hprev(i,j,k) + h_neglect*G%areaT(i,j)) ! CFL is positive + CFL(i) = vhh(i,J) / hprev(i,j,k) ! CFL is positive endif enddo @@ -913,7 +899,7 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & endif ! Implementation of PPM-H3 - Tp = Tr(m)%t(i,j_up+1,k) ; Tc = Tr(m)%t(i,j_up,k) ; Tm = Tr(m)%t(i,j_up-1,k) + Tp = T_tmp(i,m,j_up+1) ; Tc = T_tmp(i,m,j_up) ; Tm = T_tmp(i,m,j_up-1) if (useHuynh) then aL = ( 5.*Tc + ( 2.*Tm - Tp ) )/6. ! H3 estimate @@ -952,26 +938,16 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & !aR = Tr(m)%t(i,j,k) + 0.5 * slope_y(i,m,j) !flux_y(i,m,J) = vhh(i,J)*( aR - 0.5 * (aR-aL) * CFL(i) ) ! Alternative implementation of PLM - !aR = Tr(m)%t(i,j,k) + 0.5 * slope_y(i,m,j) - !flux_y(i,m,J) = vhh(i,J)*(aR - 0.5 * slope_y(i,m,j)*CFL(i)) - ! Alternative implementation of PLM - Tc = Tr(m)%t(i,j,k) + Tc = T_tmp(i,m,j) flux_y(i,m,J) = vhh(i,J)*( Tc + 0.5 * slope_y(i,m,j) * ( 1. - CFL(i) ) ) - ! Original implementation of PLM - !flux_y(i,m,J) = vhh(i,J)*(Tr(m)%t(i,j,k) + slope_y(i,m,j)*ts2(i)) else ! Indirect implementation of PLM !aL = Tr(m)%t(i,j+1,k) - 0.5 * slope_y(i,m,j+1) !aR = Tr(m)%t(i,j+1,k) + 0.5 * slope_y(i,m,j+1) !flux_y(i,m,J) = vhh(i,J)*( aL + 0.5 * (aR-aL) * CFL(i) ) ! Alternative implementation of PLM - !aL = Tr(m)%t(i,j+1,k) - 0.5 * slope_y(i,m,j+1) - !flux_y(i,m,J) = vhh(i,J)*( aL + 0.5 * slope_y(i,m,j+1)*CFL(i) ) - ! Alternative implementation of PLM - Tc = Tr(m)%t(i,j+1,k) + Tc = T_tmp(i,m,j+1) flux_y(i,m,J) = vhh(i,J)*( Tc - 0.5 * slope_y(i,m,j+1) * ( 1. - CFL(i) ) ) - ! Original implementation of PLM - !flux_y(i,m,J) = vhh(i,J)*(Tr(m)%t(i,j+1,k) - slope_y(i,m,j+1)*ts2(i)) endif enddo ; enddo endif ! usePPM diff --git a/src/tracer/MOM_tracer_flow_control.F90 b/src/tracer/MOM_tracer_flow_control.F90 index 6e28477d26..4c7c27c7e6 100644 --- a/src/tracer/MOM_tracer_flow_control.F90 +++ b/src/tracer/MOM_tracer_flow_control.F90 @@ -51,12 +51,10 @@ module MOM_tracer_flow_control 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 -#ifdef _USE_GENERIC_TRACER 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 -#endif 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 @@ -96,9 +94,7 @@ module MOM_tracer_flow_control 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() -#ifdef _USE_GENERIC_TRACER type(MOM_generic_tracer_CS), pointer :: MOM_generic_tracer_CSp => NULL() -#endif 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() @@ -132,13 +128,7 @@ subroutine call_tracer_flux_init(verbosity) if (use_OCMIP_CFCs) call flux_init_OCMIP2_CFC(verbosity=verbosity) if (use_MOM_generic_tracer) then -#ifdef _USE_GENERIC_TRACER call MOM_generic_flux_init(verbosity=verbosity) -#else - call MOM_error(FATAL, & - "call_tracer_flux_init: use_MOM_generic_tracer=.true. but MOM6 was "//& - "not compiled with _USE_GENERIC_TRACER") -#endif endif end subroutine call_tracer_flux_init @@ -217,12 +207,6 @@ subroutine call_tracer_register(HI, GV, US, param_file, CS, tr_Reg, restart_CS) "If true, use the dyed_obc_tracer tracer package.", & default=.false.) -#ifndef _USE_GENERIC_TRACER - if (CS%use_MOM_generic_tracer) call MOM_error(FATAL, & - "call_tracer_register: use_MOM_generic_tracer=.true. but MOM6 was "//& - "not compiled with _USE_GENERIC_TRACER") -#endif - ! 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. @@ -253,11 +237,9 @@ subroutine call_tracer_register(HI, GV, US, param_file, CS, tr_Reg, restart_CS) if (CS%use_OCMIP2_CFC) CS%use_OCMIP2_CFC = & register_OCMIP2_CFC(HI, GV, param_file, CS%OCMIP2_CFC_CSp, & tr_Reg, restart_CS) -#ifdef _USE_GENERIC_TRACER if (CS%use_MOM_generic_tracer) CS%use_MOM_generic_tracer = & register_MOM_generic_tracer(HI, GV, param_file, CS%MOM_generic_tracer_CSp, & tr_Reg, restart_CS) -#endif if (CS%use_pseudo_salt_tracer) CS%use_pseudo_salt_tracer = & register_pseudo_salt_tracer(HI, GV, param_file, CS%pseudo_salt_tracer_CSp, & tr_Reg, restart_CS) @@ -282,7 +264,8 @@ subroutine tracer_flow_control_init(restart, day, G, GV, US, h, param_file, diag 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(NIMEM_,NJMEM_,NKMEM_), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] type(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 @@ -334,11 +317,9 @@ subroutine tracer_flow_control_init(restart, day, G, GV, US, h, param_file, diag if (CS%use_OCMIP2_CFC) & call initialize_OCMIP2_CFC(restart, day, G, GV, US, h, diag, OBC, CS%OCMIP2_CFC_CSp, & sponge_CSp) -#ifdef _USE_GENERIC_TRACER if (CS%use_MOM_generic_tracer) & call initialize_MOM_generic_tracer(restart, day, G, GV, US, h, param_file, diag, OBC, & CS%MOM_generic_tracer_CSp, sponge_CSp, ALE_sponge_CSp) -#endif if (CS%use_pseudo_salt_tracer) & call initialize_pseudo_salt_tracer(restart, day, G, GV, h, diag, OBC, CS%pseudo_salt_tracer_CSp, & sponge_CSp, tv) @@ -352,35 +333,28 @@ end subroutine tracer_flow_control_init !> This subroutine extracts the chlorophyll concentrations from the model state, if possible subroutine get_chl_from_model(Chl_array, G, CS) - real, dimension(NIMEM_,NJMEM_,NKMEM_), & + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(out) :: Chl_array !< The array in which to store the model's !! Chlorophyll-A concentrations in mg m-3. - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(tracer_flow_control_CS), pointer :: CS !< The control structure returned by a !! previous call to call_tracer_register. -#ifdef _USE_GENERIC_TRACER if (CS%use_MOM_generic_tracer) then - call MOM_generic_tracer_get('chl','field',Chl_array, CS%MOM_generic_tracer_CSp) + 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 -#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"// & - "_USE_GENERIC_TRACER is undefined and no other options "//& - "are currently viable.") -#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(state, fluxes, day_start, day_interval, G, CS) +subroutine call_tracer_set_forcing(sfc_state, fluxes, day_start, day_interval, G, CS) - type(surface), intent(inout) :: state !< A structure containing fields that + 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 @@ -396,7 +370,7 @@ subroutine call_tracer_set_forcing(state, fluxes, day_start, day_interval, G, CS 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(state, fluxes, day_start, day_interval, & +! call ideal_age_tracer_set_forcing(sfc_state, fluxes, day_start, day_interval, & ! G, CS%ideal_age_tracer_CSp) end subroutine call_tracer_set_forcing @@ -404,25 +378,24 @@ 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, evap_CFL_limit, minimum_forcing_depth) - real, dimension(NIMEM_,NJMEM_,NKMEM_), intent(in) :: h_old !< Layer thickness before entrainment + 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(NIMEM_,NJMEM_,NKMEM_), intent(in) :: h_new !< Layer thickness after entrainment + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_new !< Layer thickness after entrainment !! [H ~> m or kg m-2]. - real, dimension(NIMEM_,NJMEM_,NKMEM_), intent(in) :: ea !< an array to which the amount of + 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(NIMEM_,NJMEM_,NKMEM_), intent(in) :: eb !< an array to which the amount of + 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(NIMEM_,NJMEM_), intent(in) :: Hml !< Mixed layer depth [H ~> m or kg m-2] + 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(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. @@ -488,7 +461,6 @@ subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, G, GV, US, CS%OCMIP2_CFC_CSp, & evap_CFL_limit=evap_CFL_limit, & minimum_forcing_depth=minimum_forcing_depth) -#ifdef _USE_GENERIC_TRACER 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 "//& @@ -498,7 +470,6 @@ subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, evap_CFL_limit=evap_CFL_limit, & minimum_forcing_depth=minimum_forcing_depth) endif -#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, & @@ -544,7 +515,6 @@ subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, 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) -#ifdef _USE_GENERIC_TRACER 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 "//& @@ -552,7 +522,6 @@ subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, call MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, US%T_to_s*dt, & G, GV, CS%MOM_generic_tracer_CSp, tv, optics) endif -#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) @@ -573,12 +542,12 @@ end subroutine call_tracer_column_fns subroutine call_tracer_stocks(h, stock_values, G, GV, CS, stock_names, stock_units, & num_stocks, stock_index, got_min_max, global_min, global_max, & xgmin, ygmin, zgmin, xgmax, ygmax, zgmax) - real, dimension(NIMEM_,NJMEM_,NKMEM_), & + 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 integrated amounts of a tracer !! on the current PE, usually in kg x concentration [kg conc]. - 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_flow_control_CS), pointer :: CS !< The control structure returned by a !! previous call to !! call_tracer_register. @@ -661,7 +630,6 @@ subroutine call_tracer_stocks(h, stock_values, G, GV, CS, stock_names, stock_uni stock_values, set_pkg_name, max_ns, ns_tot, stock_names, stock_units) endif -#ifdef _USE_GENERIC_TRACER if (CS%use_MOM_generic_tracer) then ns = MOM_generic_tracer_stock(h, values, G, GV, CS%MOM_generic_tracer_CSp, & names, units, stock_index) @@ -673,7 +641,6 @@ subroutine call_tracer_stocks(h, stock_values, G, GV, CS, stock_names, stock_uni G, CS%MOM_generic_tracer_CSp,names, units) endif -#endif if (CS%use_pseudo_salt_tracer) then ns = pseudo_salt_stock(h, values, G, GV, CS%pseudo_salt_tracer_CSp, & names, units, stock_index) @@ -755,12 +722,12 @@ 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(state, h, G, CS) - type(surface), intent(inout) :: state !< A structure containing fields that +subroutine call_tracer_surface_state(sfc_state, h, G, CS) + type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. - real, dimension(NIMEM_,NJMEM_,NKMEM_), & - intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] type(tracer_flow_control_CS), pointer :: CS !< The control structure returned by a !! previous call to call_tracer_register. @@ -769,25 +736,23 @@ subroutine call_tracer_surface_state(state, h, G, CS) ! Add other user-provided calls here. if (CS%use_USER_tracer_example) & - call USER_tracer_surface_state(state, h, G, CS%USER_tracer_example_CSp) + call USER_tracer_surface_state(sfc_state, h, G, CS%USER_tracer_example_CSp) if (CS%use_DOME_tracer) & - call DOME_tracer_surface_state(state, h, G, CS%DOME_tracer_CSp) + call DOME_tracer_surface_state(sfc_state, h, G, CS%DOME_tracer_CSp) if (CS%use_ISOMIP_tracer) & - call ISOMIP_tracer_surface_state(state, h, G, CS%ISOMIP_tracer_CSp) + call ISOMIP_tracer_surface_state(sfc_state, h, G, CS%ISOMIP_tracer_CSp) if (CS%use_ideal_age) & - call ideal_age_tracer_surface_state(state, h, G, CS%ideal_age_tracer_CSp) + call ideal_age_tracer_surface_state(sfc_state, h, G, CS%ideal_age_tracer_CSp) if (CS%use_regional_dyes) & - call dye_tracer_surface_state(state, h, G, CS%dye_tracer_CSp) + call dye_tracer_surface_state(sfc_state, h, G, CS%dye_tracer_CSp) if (CS%use_oil) & - call oil_tracer_surface_state(state, h, G, CS%oil_tracer_CSp) + call oil_tracer_surface_state(sfc_state, h, G, CS%oil_tracer_CSp) if (CS%use_advection_test_tracer) & - call advection_test_tracer_surface_state(state, h, G, CS%advection_test_tracer_CSp) + call advection_test_tracer_surface_state(sfc_state, h, G, CS%advection_test_tracer_CSp) if (CS%use_OCMIP2_CFC) & - call OCMIP2_CFC_surface_state(state, h, G, CS%OCMIP2_CFC_CSp) -#ifdef _USE_GENERIC_TRACER + call OCMIP2_CFC_surface_state(sfc_state, h, G, CS%OCMIP2_CFC_CSp) if (CS%use_MOM_generic_tracer) & - call MOM_generic_tracer_surface_state(state, h, G, CS%MOM_generic_tracer_CSp) -#endif + call MOM_generic_tracer_surface_state(sfc_state, h, G, CS%MOM_generic_tracer_CSp) end subroutine call_tracer_surface_state @@ -805,9 +770,7 @@ subroutine tracer_flow_control_end(CS) 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) -#ifdef _USE_GENERIC_TRACER if (CS%use_MOM_generic_tracer) call end_MOM_generic_tracer(CS%MOM_generic_tracer_CSp) -#endif 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) diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index d18bb3e330..43ede7cff5 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -12,7 +12,7 @@ module MOM_tracer_hor_diff 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 +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 @@ -36,7 +36,7 @@ module MOM_tracer_hor_diff public tracer_hordiff, tracer_hor_diff_init, tracer_hor_diff_end -!> The ocntrol structure for along-layer and epineutral tracer diffusion +!> 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] @@ -122,7 +122,7 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online !! 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 velcities. + !! tracer transport with stored velocities. real, dimension(SZIB_(G),SZJ_(G)), & optional, intent(in) :: read_khdt_x !< If present, these are the zonal !! diffusivities from previous run. @@ -141,14 +141,14 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online 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]. - Coef_x, & ! The coefficients relating zonal tracer differences - ! to time-integrated fluxes [H L2 ~> m3 or kg]. + 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)) :: & khdt_y, & ! The value of Khtr*dt times the open face width divided by ! the distance between adjacent tracer points [L2 ~> m2]. - Coef_y, & ! The coefficients relating meridional tracer differences - ! to time-integrated fluxes [H L2 ~> m3 or kg]. + 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]. @@ -421,7 +421,11 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online ! lateral diffusion iterations. Otherwise the call to neutral_diffusion_calc_coeffs() ! would be inside the itt-loop. -AJA - call neutral_diffusion_calc_coeffs(G, GV, US, h, tv%T, tv%S, CS%neutral_diffusion_CSp) + 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 J=js-1,je ; do i=is,ie Coef_y(i,J) = I_numitts * khdt_y(i,J) enddo ; enddo @@ -436,7 +440,11 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online 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 - call neutral_diffusion_calc_coeffs(G, GV, US, h, tv%T, tv%S, CS%neutral_diffusion_CSp) + 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) @@ -556,10 +564,12 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online 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) + G%HI, haloshift=0, symmetric=.true., scale=US%L_to_m**2, & + scalar_pair=.true.) if (CS%use_neutral_diffusion) then call uvchksum("After tracer diffusion Coef_[xy]", Coef_x, Coef_y, & - G%HI, haloshift=0, symmetric=.true., scale=US%L_to_m**2) + G%HI, haloshift=0, symmetric=.true., scale=US%L_to_m**2, & + scalar_pair=.true.) endif endif @@ -599,7 +609,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & 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 mnemnonic is a=above,b=below,L=Left,R=Right,u=u-point,v=v-point. + ! 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]. @@ -634,10 +644,6 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & h_used_R, & ! have actually been used [H ~> m or kg m-2]. h_supply_frac_L, & ! The fraction of the demanded thickness that can h_supply_frac_R ! actually be supplied from a layer. - integer, dimension(SZK_(G)) :: & - kbs_Lp, & ! The sorted indicies of the Left and Right columns for - kbs_Rp ! each pairing. - 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 @@ -667,12 +673,20 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & 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]. - logical, dimension(SZK_(G)) :: & + + ! 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_(G)*2) :: & + kbs_Lp, & ! The sorted indices of the Left and Right columns for + kbs_Rp ! each pairing. + logical, dimension(SZK_(G)*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 - real :: p_ref_cv(SZI_(G)) + 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 @@ -693,13 +707,14 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & 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), is-2, ie-is+5, tv%eqn_of_state, scale=US%kg_m3_to_R) + 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 @@ -712,11 +727,10 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & ! 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(none) shared(is,ie,js,je,nz,nkmb,G,GV,Rml_max,max_kRho) & -!$OMP private(k_min,k_max,k_test) + !$OMP parallel do default(shared) private(k_min,k_max,k_test) do j=js-2,je+2 ; do i=is-2,ie+2 ; if (G%mask2dT(i,j) > 0.5) then - if (Rml_max(i,j) > GV%Rlay(nz)) then ; max_kRho(i,j) = nz+1 - elseif (Rml_max(i,j) <= GV%Rlay(nkmb+1)) then ; max_kRho(i,j) = nkmb+1 + 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 @@ -739,10 +753,8 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & 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(none) shared(is,ie,js,je,nkmb,G,GV,h,h_exclude,num_srt,k0_srt, & -!$OMP rho_srt,h_srt,PEmax_kRho,k_end_srt,rho_coord,max_srt) & -!$OMP private(ns,tmp,itmp) -!$OMP do + !$OMP parallel default(shared) private(ns,tmp,itmp) + !$OMP do do j=js-1,je+1 do k=1,nkmb ; do i=is-1,ie+1 ; if (G%mask2dT(i,j) > 0.5) then if (h(i,j,k) > h_exclude) then @@ -763,7 +775,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & 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 + !$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. @@ -774,12 +786,12 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & enddo endif ; enddo enddo ; enddo -!$OMP do + !$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 + !$OMP end parallel do j=js,je k_size = max(2*max_srt(j),1) @@ -1174,8 +1186,8 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & ! 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 peices exceed - ! this range equally. With downgradient fluxes and the initial tracer + ! 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 @@ -1209,8 +1221,8 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & ! 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 peices exceed - ! this range equally. With downgradient fluxes and the initial tracer + ! 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 @@ -1424,7 +1436,7 @@ subroutine tracer_hor_diff_init(Time, G, US, param_file, diag, EOS, diabatic_CSp 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(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 @@ -1495,8 +1507,8 @@ subroutine tracer_hor_diff_init(Time, G, US, param_file, diag, EOS, diabatic_CSp units="nondim", default=1.0) endif - CS%use_neutral_diffusion = neutral_diffusion_init(Time, G, param_file, diag, EOS, diabatic_CSp, & - CS%neutral_diffusion_CSp ) + CS%use_neutral_diffusion = neutral_diffusion_init(Time, G, 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_lateral_boundary_diffusion = lateral_boundary_diffusion_init(Time, G, param_file, diag, diabatic_CSp, & diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index 07ca30dec8..cb8f1716fe 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -29,7 +29,7 @@ module MOM_tracer_registry public register_tracer public MOM_tracer_chksum, MOM_tracer_chkinv -public register_tracer_diagnostics, post_tracer_diagnostics, post_tracer_transport_diagnostics +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 @@ -120,7 +120,7 @@ module MOM_tracer_registry integer :: diag_form = 1 !< An integer indicating which template is to be used to label diagnostics. !>@{ Diagnostic IDs - integer :: id_tr = -1 + integer :: id_tr = -1, id_tr_post_horzn = -1 integer :: id_adx = -1, id_ady = -1, id_dfx = -1, id_dfy = -1 integer :: id_lbd_bulk_dfx = -1, id_lbd_bulk_dfy = -1, id_lbd_dfx = -1, id_lbd_dfy = -1 integer :: id_lbd_dfx_2d = -1 , id_lbd_dfy_2d = -1 @@ -408,6 +408,10 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) 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)) 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" , & @@ -426,12 +430,12 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) 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_lbd_dfx = register_diag_field("ocean_model", trim(shortnm)//"_lbd_diffx", & - diag%axesCuL, Time, trim(flux_longname)//" diffusive zonal flux from the lateral boundary diffusion "& + diag%axesCuL, Time, trim(flux_longname)//" diffusive zonal flux from the lateral 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_lbd_dfy = register_diag_field("ocean_model", trim(shortnm)//"_lbd_diffy", & - diag%axesCvL, Time, trim(flux_longname)//" diffusive meridional flux from the lateral boundary diffusion"& - " scheme", trim(flux_units), v_extensive = .true., x_cell_method = 'sum', & + diag%axesCvL, Time, trim(flux_longname)//" diffusive meridional flux from the lateral 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", & @@ -708,9 +712,9 @@ subroutine postALE_tracer_diagnostics(Reg, G, GV, diag, dt) end subroutine postALE_tracer_diagnostics -!> post_tracer_diagnostics does post_data calls for any diagnostics that are -!! being handled via the tracer registry. -subroutine post_tracer_diagnostics(Reg, h, diag_prev, diag, G, GV, dt) +!> 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 @@ -734,6 +738,7 @@ subroutine post_tracer_diagnostics(Reg, h, diag_prev, diag, G, GV, dt) 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 @@ -759,7 +764,7 @@ subroutine post_tracer_diagnostics(Reg, h, diag_prev, diag, G, GV, dt) endif ; enddo call diag_restore_grids(diag) -end subroutine post_tracer_diagnostics +end subroutine post_tracer_diagnostics_at_sync !> Post the advective and diffusive tendencies subroutine post_tracer_transport_diagnostics(G, GV, Reg, h_diag, diag) @@ -778,7 +783,7 @@ subroutine post_tracer_transport_diagnostics(G, GV, Reg, h_diag, diag) 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_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) @@ -869,7 +874,7 @@ subroutine tracer_registry_init(param_file, Reg) else ; return ; endif ! Read all relevant parameters and write them to the model log. - call log_version(param_file, mdl, version, "") + call log_version(param_file, mdl, version, "", all_default=.true.) init_calls = init_calls + 1 if (init_calls > 1) then diff --git a/src/tracer/RGC_tracer.F90 b/src/tracer/RGC_tracer.F90 index 028718f379..44c6c2e5a1 100644 --- a/src/tracer/RGC_tracer.F90 +++ b/src/tracer/RGC_tracer.F90 @@ -19,7 +19,7 @@ module RGC_tracer use MOM_forcing_type, only : forcing use MOM_hor_index, only : hor_index_type use MOM_grid, only : ocean_grid_type -use MOM_io, only : file_exists, read_data, slasher, vardesc, var_desc, query_vardesc +use MOM_io, only : file_exists, MOM_read_data, slasher, vardesc, var_desc, query_vardesc use MOM_restart, only : MOM_restart_CS use MOM_ALE_sponge, only : set_up_ALE_sponge_field, ALE_sponge_CS, get_ALE_sponge_nz_data use MOM_sponge, only : set_up_sponge_field, sponge_CS @@ -207,8 +207,7 @@ subroutine initialize_RGC_tracer(restart, day, G, GV, h, diag, OBC, CS, & CS%tracer_IC_file) do m=1,NTR call query_vardesc(CS%tr_desc(m), name, caller="initialize_RGC_tracer") - call read_data(CS%tracer_IC_file, trim(name), & - CS%tr(:,:,:,m), domain=G%Domain%mpp_domain) + call MOM_read_data(CS%tracer_IC_file, trim(name), CS%tr(:,:,:,m), G%Domain) enddo else do m=1,NTR diff --git a/src/tracer/advection_test_tracer.F90 b/src/tracer/advection_test_tracer.F90 index 82ea38f22c..b1d657d6e2 100644 --- a/src/tracer/advection_test_tracer.F90 +++ b/src/tracer/advection_test_tracer.F90 @@ -316,9 +316,9 @@ 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(state, h, G, CS) +subroutine advection_test_tracer_surface_state(sfc_state, h, G, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(surface), intent(inout) :: state !< A structure containing fields that + 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_(G)), & intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. @@ -339,7 +339,7 @@ subroutine advection_test_tracer_surface_state(state, h, G, CS) ! This call loads the surface values into the appropriate array in the ! coupler-type structure. call coupler_type_set_data(CS%tr(:,:,1,m), CS%ind_tr(m), ind_csurf, & - state%tr_fields, idim=(/isd, is, ie, ied/), & + sfc_state%tr_fields, idim=(/isd, is, ie, ied/), & jdim=(/jsd, js, je, jed/) ) enddo endif diff --git a/src/tracer/boundary_impulse_tracer.F90 b/src/tracer/boundary_impulse_tracer.F90 index e70320a5c7..da76cb3026 100644 --- a/src/tracer/boundary_impulse_tracer.F90 +++ b/src/tracer/boundary_impulse_tracer.F90 @@ -334,9 +334,9 @@ 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(state, h, G, CS) +subroutine boundary_impulse_tracer_surface_state(sfc_state, h, G, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(surface), intent(inout) :: state !< A structure containing fields that + 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_(G)), & intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. @@ -357,7 +357,7 @@ subroutine boundary_impulse_tracer_surface_state(state, h, G, CS) ! This call loads the surface values into the appropriate array in the ! coupler-type structure. call coupler_type_set_data(CS%tr(:,:,1,m), CS%ind_tr(m), ind_csurf, & - state%tr_fields, idim=(/isd, is, ie, ied/), & + sfc_state%tr_fields, idim=(/isd, is, ie, ied/), & jdim=(/jsd, js, je, jed/) ) enddo endif diff --git a/src/tracer/dye_example.F90 b/src/tracer/dye_example.F90 index 86a4ac7aeb..cd17415b21 100644 --- a/src/tracer/dye_example.F90 +++ b/src/tracer/dye_example.F90 @@ -189,7 +189,7 @@ subroutine initialize_dye_tracer(restart, day, G, GV, h, diag, OBC, CS, sponge_C 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(NIMEM_,NJMEM_,NKMEM_), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] type(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 @@ -326,11 +326,11 @@ end subroutine dye_tracer_column_physics !! 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) - real, dimension(NIMEM_,NJMEM_,NKMEM_), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] - real, dimension(:), intent(out) :: stocks !< the mass-weighted integrated amount of - !! each tracer, in kg times concentration units [kg conc]. 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) :: 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. @@ -372,9 +372,9 @@ 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(state, h, G, CS) +subroutine dye_tracer_surface_state(sfc_state, h, G, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(surface), intent(inout) :: state !< A structure containing fields that + 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_(G)), & intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. @@ -395,7 +395,7 @@ subroutine dye_tracer_surface_state(state, h, G, CS) ! This call loads the surface values into the appropriate array in the ! coupler-type structure. call coupler_type_set_data(CS%tr(:,:,1,m), CS%ind_tr(m), ind_csurf, & - state%tr_fields, idim=(/isd, is, ie, ied/), & + sfc_state%tr_fields, idim=(/isd, is, ie, ied/), & jdim=(/jsd, js, je, jed/) ) enddo endif diff --git a/src/tracer/ideal_age_example.F90 b/src/tracer/ideal_age_example.F90 index 3ef61e1a57..8f00b0d5b9 100644 --- a/src/tracer/ideal_age_example.F90 +++ b/src/tracer/ideal_age_example.F90 @@ -420,9 +420,9 @@ 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(state, h, G, CS) +subroutine ideal_age_tracer_surface_state(sfc_state, h, G, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(surface), intent(inout) :: state !< A structure containing fields that + 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_(G)), & intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. @@ -443,7 +443,7 @@ subroutine ideal_age_tracer_surface_state(state, h, G, CS) ! This call loads the surface values into the appropriate array in the ! coupler-type structure. call coupler_type_set_data(CS%tr(:,:,1,m), CS%ind_tr(m), ind_csurf, & - state%tr_fields, idim=(/isd, is, ie, ied/), & + sfc_state%tr_fields, idim=(/isd, is, ie, ied/), & jdim=(/jsd, js, je, jed/) ) enddo endif diff --git a/src/tracer/oil_tracer.F90 b/src/tracer/oil_tracer.F90 index 4d755497c6..c07f1c03e4 100644 --- a/src/tracer/oil_tracer.F90 +++ b/src/tracer/oil_tracer.F90 @@ -454,9 +454,9 @@ 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(state, h, G, CS) +subroutine oil_tracer_surface_state(sfc_state, h, G, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(surface), intent(inout) :: state !< A structure containing fields that + 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_(G)), & intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. @@ -477,7 +477,7 @@ subroutine oil_tracer_surface_state(state, h, G, CS) ! This call loads the surface values into the appropriate array in the ! coupler-type structure. call coupler_type_set_data(CS%tr(:,:,1,m), CS%ind_tr(m), ind_csurf, & - state%tr_fields, idim=(/isd, is, ie, ied/), & + sfc_state%tr_fields, idim=(/isd, is, ie, ied/), & jdim=(/jsd, js, je, jed/) ) enddo endif diff --git a/src/tracer/pseudo_salt_tracer.F90 b/src/tracer/pseudo_salt_tracer.F90 index 5c74487c0c..95396a3b58 100644 --- a/src/tracer/pseudo_salt_tracer.F90 +++ b/src/tracer/pseudo_salt_tracer.F90 @@ -299,9 +299,9 @@ 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(state, h, G, CS) +subroutine pseudo_salt_tracer_surface_state(sfc_state, h, G, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(surface), intent(inout) :: state !< A structure containing fields that + 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_(G)), & intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. diff --git a/src/tracer/tracer_example.F90 b/src/tracer/tracer_example.F90 index c5e8f669c6..ef16cc985d 100644 --- a/src/tracer/tracer_example.F90 +++ b/src/tracer/tracer_example.F90 @@ -405,9 +405,9 @@ 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(state, h, G, CS) +subroutine USER_tracer_surface_state(sfc_state, h, G, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(surface), intent(inout) :: state !< A structure containing fields that + 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_(G)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] @@ -428,7 +428,7 @@ subroutine USER_tracer_surface_state(state, h, G, CS) ! This call loads the surface values into the appropriate array in the ! coupler-type structure. call coupler_type_set_data(CS%tr(:,:,1,m), CS%ind_tr(m), ind_csurf, & - state%tr_fields, idim=(/isd, is, ie, ied/), & + sfc_state%tr_fields, idim=(/isd, is, ie, ied/), & jdim=(/jsd, js, je, jed/) ) enddo endif diff --git a/src/user/BFB_initialization.F90 b/src/user/BFB_initialization.F90 index 9e8f612a35..5465d5fcea 100644 --- a/src/user/BFB_initialization.F90 +++ b/src/user/BFB_initialization.F90 @@ -36,14 +36,13 @@ module BFB_initialization !! 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, eqn_of_state) - real, dimension(NKMEM_), intent(out) :: Rlay !< Layer potential density [R ~> kg m-3]. - real, dimension(NKMEM_), intent(out) :: g_prime !< The reduced gravity at - !! each interface [L2 Z-1 T-2 ~> m 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 - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(EOS_type), pointer :: eqn_of_state !< Integer that selects the - !! equation of state. + 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), pointer :: eqn_of_state !< Equation of state structure ! Local variables real :: drho_dt, SST_s, T_bot, rho_top, rho_bot integer :: k, nz @@ -86,13 +85,13 @@ subroutine BFB_initialize_sponges_southonly(G, GV, US, use_temperature, tv, para 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(sponge_CS), pointer :: CSp !< A pointer to the sponge control structure - real, dimension(NIMEM_, NJMEM_, NKMEM_), & + 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_(G)+1) ! A temporary array for eta, in depth units [Z ~> m]. + 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 inverse damping rate [T-1 ~> s-1]. - real :: H0(SZK_(G)) ! Resting layer thicknesses in depth units [Z ~> m]. + real :: H0(SZK_(GV)) ! Resting layer thicknesses in depth units [Z ~> m]. real :: min_depth ! The minimum ocean depth in depth units [Z ~> m]. real :: slat, wlon, lenlat, lenlon, nlat real :: max_damping ! The maximum damping rate [T-1 ~> s-1] diff --git a/src/user/BFB_surface_forcing.F90 b/src/user/BFB_surface_forcing.F90 index 70d89497da..d06262b7cf 100644 --- a/src/user/BFB_surface_forcing.F90 +++ b/src/user/BFB_surface_forcing.F90 @@ -47,8 +47,8 @@ module BFB_surface_forcing contains !> Bouyancy forcing for the boundary-forced-basin (BFB) configuration -subroutine BFB_buoyancy_forcing(state, fluxes, day, dt, G, US, CS) - type(surface), intent(inout) :: state !< A structure containing fields that +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 @@ -136,9 +136,9 @@ subroutine BFB_buoyancy_forcing(state, fluxes, day, dt, G, US, CS) Salin_restore = 0.0 fluxes%heat_added(i,j) = (G%mask2dT(i,j) * (rhoXcp * CS%Flux_const)) * & - (Temp_restore - state%SST(i,j)) + (Temp_restore - sfc_state%SST(i,j)) fluxes%vprec(i,j) = - (G%mask2dT(i,j) * (CS%Rho0*CS%Flux_const)) * & - ((Salin_restore - state%SSS(i,j)) / (0.5 * (Salin_restore + state%SSS(i,j)))) + ((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 @@ -164,7 +164,7 @@ subroutine BFB_buoyancy_forcing(state, fluxes, day, dt, G, US, CS) density_restore = Temp_restore*CS%drho_dt + CS%Rho0 fluxes%buoy(i,j) = G%mask2dT(i,j) * buoy_rest_const * & - (density_restore - US%kg_m3_to_R*state%sfc_density(i,j)) + (density_restore - sfc_state%sfc_density(i,j)) enddo ; enddo endif endif ! end RESTOREBUOY @@ -195,8 +195,7 @@ subroutine BFB_surface_forcing_init(Time, G, US, param_file, diag, CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", CS%use_temperature, & - "If true, Temperature and salinity are used as state "//& - "variables.", default=.true.) + "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.", & @@ -223,8 +222,7 @@ subroutine BFB_surface_forcing_init(Time, G, US, param_file, diag, CS) "The rate of change of density with temperature.", & units="kg m-3 K-1", default=-0.2, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "GUST_CONST", CS%gust_const, & - "The background gustiness in the winds.", units="Pa", & - default=0.02) + "The background gustiness in the winds.", units="Pa", default=0.0) call get_param(param_file, mdl, "RESTOREBUOY", CS%restorebuoy, & "If true, the buoyancy fluxes drive the model back "//& @@ -232,10 +230,9 @@ subroutine BFB_surface_forcing_init(Time, G, US, param_file, diag, CS) "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.", & - units="m day-1", scale=US%m_to_Z*US%T_to_s, fail_if_missing=.true.) + "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 endif diff --git a/src/user/DOME2d_initialization.F90 b/src/user/DOME2d_initialization.F90 index 6d307f843a..923801db2d 100644 --- a/src/user/DOME2d_initialization.F90 +++ b/src/user/DOME2d_initialization.F90 @@ -257,9 +257,9 @@ subroutine DOME2d_initialize_temperature_salinity ( T, S, h, G, GV, param_file, default=0.3, do_not_log=.true.) call get_param(param_file, mdl, "DOME2D_SHELF_DEPTH", dome2d_depth_bay, & default=0.2, do_not_log=.true.) - call get_param(param_file, mdl,"S_REF",S_ref,'Reference salinity',units='1e-3', & - fail_if_missing=.not.just_read, do_not_log=just_read) - call get_param(param_file, mdl,"T_REF",T_ref,'Refernce temperature',units='C', & + call get_param(param_file, mdl, "S_REF", S_ref, 'Reference salinity', & + default=35.0, units='1e-3', do_not_log=just_read) + call get_param(param_file, mdl,"T_REF",T_ref,'Reference temperature', units='degC', & 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='1e-3', default=2.0, do_not_log=just_read) @@ -415,10 +415,10 @@ subroutine DOME2d_initialize_sponges(G, GV, US, tv, param_file, use_ALE, CSp, AC default=0.3, do_not_log=.true.) call get_param(param_file, mdl, "DOME2D_SHELF_DEPTH", dome2d_depth_bay, & default=0.2, do_not_log=.true.) - call get_param(param_file, mdl,"S_REF",S_ref) - call get_param(param_file, mdl,"T_REF",T_ref) - call get_param(param_file, mdl,"S_RANGE",S_range,default=2.0) - call get_param(param_file, mdl,"T_RANGE",T_range,default=0.0) + call get_param(param_file, mdl, "S_REF", S_ref, default=35.0) + call get_param(param_file, mdl, "T_REF", T_ref) + call get_param(param_file, mdl, "S_RANGE", S_range, default=2.0) + call get_param(param_file, mdl, "T_RANGE", T_range, default=0.0) ! Set the inverse damping rate as a function of position diff --git a/src/user/DOME_initialization.F90 b/src/user/DOME_initialization.F90 index f582ca0c7a..f92d2d7ac6 100644 --- a/src/user/DOME_initialization.F90 +++ b/src/user/DOME_initialization.F90 @@ -261,7 +261,7 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, US, param_file, tr_Reg) ! Local variables ! The following variables are used to set the target temperature and salinity. real :: T0(SZK_(G)), S0(SZK_(G)) - real :: pres(SZK_(G)) ! An array of the reference pressure [Pa]. + real :: pres(SZK_(G)) ! An array of the reference pressure [R L2 T-2 ~> Pa]. real :: drho_dT(SZK_(G)) ! Derivative of density with temperature [R degC-1 ~> kg m-3 degC-1]. real :: drho_dS(SZK_(G)) ! Derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1]. real :: rho_guess(SZK_(G)) ! Potential density at T0 & S0 [R ~> kg m-3]. @@ -359,13 +359,13 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, US, param_file, tr_Reg) ! target density and a salinity of 35 psu. This code is taken from ! USER_initialize_temp_sal. pres(:) = tv%P_Ref ; S0(:) = 35.0 ; T0(1) = 25.0 - call calculate_density(T0(1),S0(1),pres(1),rho_guess(1),tv%eqn_of_state, scale=US%kg_m3_to_R) - call calculate_density_derivs(T0,S0,pres,drho_dT,drho_dS,1,1,tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density(T0(1), S0(1), pres(1), rho_guess(1), tv%eqn_of_state) + call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, tv%eqn_of_state, (/1,1/) ) do k=1,nz ; 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,1,nz,tv%eqn_of_state, scale=US%kg_m3_to_R) - call calculate_density_derivs(T0,S0,pres,drho_dT,drho_dS,1,nz,tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density(T0, S0, pres, rho_guess, tv%eqn_of_state) + call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, tv%eqn_of_state) do k=1,nz ; T0(k) = T0(k) + (GV%Rlay(k)-rho_guess(k)) / drho_dT(k) ; enddo enddo diff --git a/src/user/ISOMIP_initialization.F90 b/src/user/ISOMIP_initialization.F90 index ba8dc1162f..d125495d7f 100644 --- a/src/user/ISOMIP_initialization.F90 +++ b/src/user/ISOMIP_initialization.F90 @@ -184,10 +184,10 @@ subroutine ISOMIP_initialize_thickness ( h, G, GV, US, param_file, tv, 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, scale=US%kg_m3_to_R) + 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, scale=US%kg_m3_to_R) + 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 @@ -281,7 +281,7 @@ subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, G, GV, US, param_fi real :: drho_dT(SZK_(G)) ! Derivative of density with temperature [R degC-1 ~> kg m-3 degC-1]. real :: drho_dS(SZK_(G)) ! Derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1]. real :: rho_guess(SZK_(G)) ! Potential density at T0 & S0 [R ~> kg m-3]. - real :: pres(SZK_(G)) ! An array of the reference pressure [Pa]. (zero here) + real :: pres(SZK_(G)) ! An array of the reference pressure [R L2 T-2 ~> Pa]. (zero here) real :: drho_dT1 ! A prescribed derivative of density with temperature [R degC-1 ~> kg m-3 degC-1] real :: drho_dS1 ! A prescribed derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1]. real :: T_Ref, S_Ref @@ -301,10 +301,10 @@ subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, G, GV, US, param_fi call get_param(param_file, mdl, "ISOMIP_S_BOT", s_bot, & "Salinity at the bottom (interface)", units="ppt", default=34.55, do_not_log=just_read) - call calculate_density(t_sur,s_sur,0.0,rho_sur,eqn_of_state, scale=US%kg_m3_to_R) + 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, scale=US%kg_m3_to_R) + 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) @@ -362,20 +362,20 @@ subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, G, GV, US, param_fi ! call MOM_mesg(mesg,5) enddo - call calculate_density_derivs(T0,S0,pres,drho_dT,drho_dS,1,1,eqn_of_state, scale=US%kg_m3_to_R) + 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),0.,rho_guess(1),eqn_of_state, scale=US%kg_m3_to_R) + 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) + 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,1,nz,eqn_of_state, scale=US%kg_m3_to_R) - call calculate_density_derivs(T0,S0,pres,drho_dT,drho_dS,1,nz,eqn_of_state, scale=US%kg_m3_to_R) + 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 @@ -388,8 +388,8 @@ subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, G, GV, US, param_fi enddo do itt=1,6 - call calculate_density(T0,S0,pres,rho_guess,1,nz,eqn_of_state, scale=US%kg_m3_to_R) - call calculate_density_derivs(T0,S0,pres,drho_dT,drho_dS,1,nz,eqn_of_state, scale=US%kg_m3_to_R) + 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 @@ -521,10 +521,10 @@ subroutine ISOMIP_initialize_sponges(G, GV, US, tv, PF, use_ALE, CSp, ACSp) 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, scale=US%kg_m3_to_R) + 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, scale=US%kg_m3_to_R) + 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 diff --git a/src/user/Idealized_Hurricane.F90 b/src/user/Idealized_Hurricane.F90 index 38ba0ab460..25e60d4895 100644 --- a/src/user/Idealized_Hurricane.F90 +++ b/src/user/Idealized_Hurricane.F90 @@ -170,7 +170,7 @@ subroutine idealized_hurricane_wind_init(Time, G, US, param_file, CS) "wind profile.", units='m', default=50.e3, scale=US%m_to_L) call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=.true.) + default=.false.) call get_param(param_file, mdl, "IDL_HURR_2018_ANSWERS", CS%answers_2018, & "If true, use expressions driving the idealized hurricane test case that recover "//& "the answers from the end of 2018. Otherwise use expressions that are rescalable "//& @@ -189,7 +189,6 @@ subroutine idealized_hurricane_wind_init(Time, G, US, param_file, CS) "The background gustiness in the winds.", units="Pa", & default=0.0, scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z, do_not_log=.true.) - if (CS%BR_BENCH) then CS%rho_a = 1.2*US%kg_m3_to_R endif @@ -206,8 +205,8 @@ subroutine idealized_hurricane_wind_init(Time, G, US, param_file, CS) end subroutine idealized_hurricane_wind_init !> Computes the surface wind for the idealized hurricane test cases -subroutine idealized_hurricane_wind_forcing(state, forces, day, G, US, CS) - type(surface), intent(in) :: state !< Surface state structure +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 @@ -263,13 +262,13 @@ subroutine idealized_hurricane_wind_forcing(state, forces, day, G, US, CS) !> Computes taux do j=js,je do I=is-1,Ieq - Uocn = US%m_s_to_L_T * state%u(I,j)*REL_TAU_FAC + Uocn = sfc_state%u(I,j) * REL_TAU_FAC if (CS%answers_2018) then - Vocn = US%m_s_to_L_T * 0.25*(state%v(i,J)+state%v(i+1,J-1)& - +state%v(i+1,J)+state%v(i,J-1))*REL_TAU_FAC + 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 = US%m_s_to_L_T * 0.25*((state%v(i,J)+state%v(i+1,J-1)) +& - (state%v(i+1,J)+state%v(i,J-1))) * REL_TAU_FAC + 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. @@ -288,13 +287,13 @@ subroutine idealized_hurricane_wind_forcing(state, forces, day, G, US, CS) do J=js-1,Jeq do i=is,ie if (CS%answers_2018) then - Uocn = US%m_s_to_L_T * 0.25*(state%u(I,j)+state%u(I-1,j+1) + & - state%u(I-1,j)+state%u(I,j+1))*REL_TAU_FAC + 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 = US%m_s_to_L_T * 0.25*((state%u(I,j)+state%u(I-1,j+1)) + & - (state%u(I-1,j)+state%u(I,j+1))) * REL_TAU_FAC + 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 = US%m_s_to_L_T * state%v(i,J)*REL_TAU_FAC + 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 @@ -471,8 +470,8 @@ end subroutine idealized_hurricane_wind_profile !! 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(state, forces, day, G, US, CS) - type(surface), intent(in) :: state !< Surface state structure +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 @@ -604,9 +603,9 @@ subroutine SCM_idealized_hurricane_wind_forcing(state, forces, day, G, US, CS) !/BR ! Turn off surface current for stress calculation to be ! consistent with test case. - Uocn = 0. ! state%u(I,j) - Vocn = 0. ! 0.25*( (state%v(i,J) + state%v(i+1,J-1)) & - ! +(state%v(i+1,J) + state%v(i,J-1)) ) + 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). @@ -633,9 +632,9 @@ subroutine SCM_idealized_hurricane_wind_forcing(state, forces, day, G, US, CS) !/BR ! See notes above do J=js-1,Jeq ; do i=is,ie - Uocn = 0. ! 0.25*( (state%u(I,j) + state%u(I-1,j+1)) & - ! +(state%u(I-1,j) + state%u(I,j+1)) ) - Vocn = 0. ! state%v(i,J) + 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) diff --git a/src/user/Kelvin_initialization.F90 b/src/user/Kelvin_initialization.F90 index 6eade35bad..227c814b3c 100644 --- a/src/user/Kelvin_initialization.F90 +++ b/src/user/Kelvin_initialization.F90 @@ -42,9 +42,6 @@ module Kelvin_initialization real :: F_0 !< Coriolis parameter real :: rho_range !< Density range real :: rho_0 !< Mean density - logical :: answers_2018 !< If true, use the order of arithmetic and expressions that recover the - !! answers from the end of 2018. Otherwise, use expressions that give - !! rotational symmetry and eliminate apparent bugs. end type Kelvin_OBC_CS ! This include declares and sets the variable "version". @@ -60,7 +57,6 @@ function register_Kelvin_OBC(param_file, CS, OBC_Reg) ! Local variables logical :: register_Kelvin_OBC - logical :: default_2018_answers 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 @@ -95,13 +91,6 @@ function register_Kelvin_OBC(param_file, CS, OBC_Reg) CS%coast_offset1 = CS%coast_offset1 * 1.e3 ! Convert to m CS%coast_offset2 = CS%coast_offset2 * 1.e3 ! Convert to m endif - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=.true.) - call get_param(param_file, mdl, "KELVIN_WAVE_2018_ANSWERS", CS%answers_2018, & - "If true, use the order of arithmetic and expressions that recover the "//& - "answers from the end of 2018. Otherwise, use expressions that give rotational "//& - "symmetry and eliminate apparent bugs.", default=default_2018_answers) if (CS%mode /= 0) then call get_param(param_file, mdl, "DENSITY_RANGE", CS%rho_range, & default=2.0, do_not_log=.true.) @@ -253,20 +242,21 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) x = (x1 - CS%coast_offset1) * cosa + y1 * sina y = - (x1 - CS%coast_offset1) * sina + y1 * cosa if (CS%mode == 0) then - cff = sqrt(GV%g_Earth * 0.5 * (G%bathyT(i+1,j) + G%bathyT(i,j))) + ! Use inside bathymetry + cff = sqrt(GV%g_Earth * G%bathyT(i+1,j) ) val2 = fac * exp(- US%T_to_s*CS%F_0 * US%m_to_L*y / cff) segment%eta(I,j) = val2 * cos(omega * time_sec) segment%normal_vel_bt(I,j) = (val2 * (val1 * cff * cosa / & - (0.5 * (G%bathyT(i+1,j) + G%bathyT(i,j)))) ) + (G%bathyT(i+1,j) )) ) if (segment%nudged) then do k=1,nz segment%nudged_normal_vel(I,j,k) = (val2 * (val1 * cff * cosa / & - (0.5 * (G%bathyT(i+1,j) + G%bathyT(i,j)))) ) + (G%bathyT(i+1,j))) ) enddo elseif (segment%specified) then do k=1,nz segment%normal_vel(I,j,k) = (val2 * (val1 * cff * cosa / & - (0.5 * (G%bathyT(i+1,j) + G%bathyT(i,j)))) ) + (G%bathyT(i+1,j) )) ) segment%normal_trans(I,j,k) = segment%normal_vel(I,j,k) * h(i+1,j,k) * G%dyCu(I,j) enddo endif @@ -296,16 +286,16 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) y1 = 1000. * G%geoLatBu(I,J) x = (x1 - CS%coast_offset1) * cosa + y1 * sina y = - (x1 - CS%coast_offset1) * sina + y1 * cosa - cff =sqrt(GV%g_Earth * 0.5 * (G%bathyT(i+1,j) + G%bathyT(i,j))) + cff =sqrt(GV%g_Earth * G%bathyT(i+1,j) ) val2 = fac * exp(- US%T_to_s*CS%F_0 * US%m_to_L*y / cff) if (CS%mode == 0) then ; do k=1,nz segment%tangential_vel(I,J,k) = (val1 * val2 * cff * sina) / & - ( 0.25*((G%bathyT(i,j) + G%bathyT(i+1,j+1)) + (G%bathyT(i+1,j) + G%bathyT(i,j+1))) ) + ( 0.5*(G%bathyT(i+1,j+1) + G%bathyT(i+1,j) ) ) enddo ; endif enddo ; enddo endif - else + else ! Must be south isd = segment%HI%isd ; ied = segment%HI%ied JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB do J=JsdB,JedB ; do i=isd,ied @@ -314,20 +304,20 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) x = (x1 - CS%coast_offset1) * cosa + y1 * sina y = - (x1 - CS%coast_offset1) * sina + y1 * cosa if (CS%mode == 0) then - cff = sqrt(GV%g_Earth * 0.5 * (G%bathyT(i,j+1) + G%bathyT(i,j))) + cff = sqrt(GV%g_Earth * G%bathyT(i,j+1) ) val2 = fac * exp(- 0.5 * (G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J)) * US%m_to_L*y / cff) segment%eta(I,j) = val2 * cos(omega * time_sec) segment%normal_vel_bt(I,j) = US%L_T_to_m_s * (val1 * cff * sina / & - (0.5*(G%bathyT(i+1,j) + G%bathyT(i,j)))) * val2 + (G%bathyT(i,j+1) )) * val2 if (segment%nudged) then do k=1,nz segment%nudged_normal_vel(I,j,k) = US%L_T_to_m_s * (val1 * cff * sina / & - (0.5*(G%bathyT(i+1,j) + G%bathyT(i,j)))) * val2 + (G%bathyT(i,j+1) )) * val2 enddo elseif (segment%specified) then do k=1,nz segment%normal_vel(I,j,k) = US%L_T_to_m_s * (val1 * cff * sina / & - (0.5*(G%bathyT(i+1,j) + G%bathyT(i,j)))) * val2 + (G%bathyT(i,j+1) )) * val2 segment%normal_trans(i,J,k) = segment%normal_vel(i,J,k) * h(i,j+1,k) * G%dxCv(i,J) enddo endif @@ -355,11 +345,11 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) y1 = 1000. * G%geoLatBu(I,J) x = (x1 - CS%coast_offset1) * cosa + y1 * sina y = - (x1 - CS%coast_offset1) * sina + y1 * cosa - cff = sqrt(GV%g_Earth * 0.5 * (G%bathyT(i,j+1) + G%bathyT(i,j))) + cff = sqrt(GV%g_Earth * G%bathyT(i,j+1) ) val2 = fac * exp(- 0.5 * (G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J)) * US%m_to_L*y / cff) if (CS%mode == 0) then ; do k=1,nz segment%tangential_vel(I,J,k) = ((val1 * val2 * cff * sina) / & - ( 0.25*((G%bathyT(i,j) + G%bathyT(i+1,j+1)) + (G%bathyT(i+1,j) + G%bathyT(i,j+1))) )) + ( 0.5*((G%bathyT(i+1,j+1)) + G%bathyT(i,j+1))) ) enddo ; endif enddo ; enddo endif diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index 815e4fa361..da181c5eca 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -1035,7 +1035,7 @@ subroutine get_StokesSL_LiFoxKemper(ustar, hbl, GV, US, UStokes_SL, LA) ! ! peak frequency (PM, Bouws, 1998) tmp = 2.0 * PI * u19p5_to_u10 * u10 - fp = 0.877 * GV%mks_g_Earth / tmp + fp = 0.877 * US%L_T_to_m_s**2*US%m_to_Z * GV%g_Earth / tmp ! ! mean frequency fm = fm_into_fp * fp @@ -1168,23 +1168,25 @@ subroutine DHH85_mid(GV, US, zpt, UStokes) real :: ann, Bnn, Snn, Cnn, Dnn real :: omega_peak, omega, u10, WA, domega real :: omega_min, omega_max, wavespec, Stokes + real :: g_Earth ! Gravitational acceleration [m s-2] integer :: Nomega, OI WA = WaveAge u10 = WaveWind + g_Earth = US%L_T_to_m_s**2*US%m_to_Z * GV%g_Earth !/ omega_min = 0.1 ! Hz ! Cut off at 30cm for now... - omega_max = 10. ! ~sqrt(0.2*GV%mks_g_Earth*2*pi/0.3) + omega_max = 10. ! ~sqrt(0.2*g_Earth*2*pi/0.3) NOmega = 1000 domega = (omega_max-omega_min)/real(NOmega) ! if (WaveAgePeakFreq) then - omega_peak = GV%mks_g_Earth / (WA * u10) + omega_peak = g_Earth / (WA * u10) else - omega_peak = 2. * pi * 0.13 * GV%mks_g_Earth / U10 + omega_peak = 2. * pi * 0.13 * g_Earth / U10 endif !/ Ann = 0.006 * WaveAge**(-0.55) @@ -1200,11 +1202,11 @@ subroutine DHH85_mid(GV, US, zpt, UStokes) do oi = 1,nomega-1 Dnn = exp ( -0.5 * (omega-omega_peak)**2 / (Snn**2 * omega_peak**2) ) ! wavespec units = m2s - wavespec = (Ann * GV%mks_g_Earth**2 / (omega_peak*omega**4 ) ) * & + wavespec = (Ann * g_Earth**2 / (omega_peak*omega**4 ) ) * & exp(-bnn*(omega_peak/omega)**4)*Cnn**Dnn ! Stokes units m (multiply by frequency range for units of m/s) Stokes = 2.0 * wavespec * omega**3 * & - exp( 2.0 * omega**2 * US%Z_to_m*zpt / GV%mks_g_Earth) / GV%mks_g_Earth + exp( 2.0 * omega**2 * US%Z_to_m*zpt / g_Earth) / g_Earth UStokes = UStokes + Stokes*domega omega = omega + domega enddo diff --git a/src/user/Neverland_initialization.F90 b/src/user/Neverworld_initialization.F90 similarity index 53% rename from src/user/Neverland_initialization.F90 rename to src/user/Neverworld_initialization.F90 index 949530e773..d019854310 100644 --- a/src/user/Neverland_initialization.F90 +++ b/src/user/Neverworld_initialization.F90 @@ -1,5 +1,5 @@ -!> Initialization for the "Neverland" configuration -module Neverland_initialization +!> Initialization for the "Neverworld" configuration +module Neverworld_initialization ! This file is part of MOM6. See LICENSE.md for the license. @@ -21,8 +21,8 @@ module Neverland_initialization #include -public Neverland_initialize_topography -public Neverland_initialize_thickness +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 @@ -31,8 +31,8 @@ module Neverland_initialization contains -!> This subroutine sets up the Neverland test case topography. -subroutine Neverland_initialize_topography(D, G, param_file, max_depth) +!> 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 @@ -46,13 +46,13 @@ subroutine Neverland_initialize_topography(D, G, param_file, max_depth) real :: x, y ! This include declares and sets the variable "version". # include "version_variable.h" - character(len=40) :: mdl = "Neverland_initialize_topography" ! This subroutine's name. + character(len=40) :: mdl = "Neverworld_initialize_topography" ! This subroutine's name. integer :: i, j, is, ie, js, je, isd, ied, jsd, jed real :: nl_roughness_amp, nl_top_amp 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(" Neverland_initialization.F90, Neverland_initialize_topography: setting topography", 5) + 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, & @@ -82,8 +82,7 @@ subroutine Neverland_initialize_topography(D, G, param_file, max_depth) D(i,j) = D(i,j) * max_depth enddo ; enddo -end subroutine Neverland_initialize_topography -! ----------------------------------------------------------------------------- +end subroutine Neverworld_initialize_topography !> Returns the value of a cosine-bell function evaluated at x/L real function cosbell(x, L) @@ -106,11 +105,141 @@ real function spike(x, L) spike = (1 - sin(PI*MIN(ABS(x/L),0.5))) end function spike -!> This subroutine initializes layer thicknesses for the Neverland test case, +!> 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] + real :: dx, yr, dy + + 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 ! nondim 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 Neverland_initialize_thickness(h, G, GV, US, param_file, eqn_of_state, P_ref) +subroutine Neverworld_initialize_thickness(h, G, GV, US, param_file, eqn_of_state, 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 @@ -119,10 +248,9 @@ subroutine Neverland_initialize_thickness(h, G, GV, US, param_file, eqn_of_state type(param_file_type), intent(in) :: param_file !< A structure indicating the open !! file to parse for model !! parameter values. - type(EOS_type), pointer :: eqn_of_state !< integer that selects the - !! equation of state. + type(EOS_type), pointer :: eqn_of_state !< Equation of state structure real, intent(in) :: P_Ref !< The coordinate-density - !! reference pressure [Pa]. + !! reference pressure [R L2 T-2 ~> Pa]. ! Local variables real :: e0(SZK_(G)+1) ! The resting interface heights, in depth units [Z ~> m], ! usually negative because it is positive upward. @@ -133,12 +261,12 @@ subroutine Neverland_initialize_thickness(h, G, GV, US, param_file, eqn_of_state real :: h_noise ! Amplitude of noise to scale h by real :: noise ! Noise type(randomNumberStream) :: rns ! Random numbers for stochastic tidal parameterization - character(len=40) :: mdl = "Neverland_initialize_thickness" ! This subroutine's name. + character(len=40) :: mdl = "Neverworld_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 = G%ke - call MOM_mesg(" Neverland_initialization.F90, Neverland_initialize_thickness: setting thickness", 5) + 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.) @@ -177,6 +305,6 @@ subroutine Neverland_initialize_thickness(h, G, GV, US, param_file, eqn_of_state h(i,j,1) = max( GV%Angstrom_H, h(i,j,1) ) ! Limit to non-negative enddo ; enddo -end subroutine Neverland_initialize_thickness +end subroutine Neverworld_initialize_thickness -end module Neverland_initialization +end module Neverworld_initialization diff --git a/src/user/RGC_initialization.F90 b/src/user/RGC_initialization.F90 index ae28bb36c6..70b9fcd4dc 100644 --- a/src/user/RGC_initialization.F90 +++ b/src/user/RGC_initialization.F90 @@ -35,7 +35,7 @@ module RGC_initialization 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 MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_type, EOS_domain implicit none ; private #include @@ -77,7 +77,7 @@ subroutine RGC_initialize_sponges(G, GV, US, tv, u, v, PF, use_ALE, CSp, ACSp) real :: h(SZI_(G),SZJ_(G),SZK_(G)) ! A temporary array for thickness at h points real :: Idamp(SZI_(G),SZJ_(G)) ! The inverse 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, in Pa + real :: pres(SZI_(G)) ! An array of the reference pressure [R L2 T-2 ~> Pa] real :: e0(SZK_(G)+1) ! The resting interface heights, in m, usually ! ! negative because it is positive upward. ! real :: eta(SZI_(G),SZJ_(G),SZK_(G)+1) ! A temporary array for eta. @@ -90,6 +90,7 @@ subroutine RGC_initialize_sponges(G, GV, US, tv, u, v, PF, use_ALE, CSp, ACSp) character(len=40) :: temp_var, salt_var, eta_var, inputdir, h_var character(len=40) :: mod = "RGC_initialize_sponges" ! This subroutine's name. + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, j, k, 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 = G%ke @@ -211,10 +212,9 @@ subroutine RGC_initialize_sponges(G, GV, US, tv, u, v, PF, use_ALE, CSp, ACSp) ! 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), & - is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) + 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) diff --git a/src/user/Rossby_front_2d_initialization.F90 b/src/user/Rossby_front_2d_initialization.F90 index 80b3bc6d94..ed0082c397 100644 --- a/src/user/Rossby_front_2d_initialization.F90 +++ b/src/user/Rossby_front_2d_initialization.F90 @@ -135,8 +135,8 @@ subroutine Rossby_front_initialize_temperature_salinity(T, S, h, G, GV, & 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', units='1e-3', & - fail_if_missing=.not.just_read, do_not_log=just_read) + call get_param(param_file, mdl, "S_REF", S_ref, 'Reference salinity', & + default=35.0, units='1e-3', do_not_log=just_read) call get_param(param_file, mdl,"T_REF",T_ref,'Reference temperature',units='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',& diff --git a/src/user/SCM_CVMix_tests.F90 b/src/user/SCM_CVMix_tests.F90 index be12f75c38..9f36e7033d 100644 --- a/src/user/SCM_CVMix_tests.F90 +++ b/src/user/SCM_CVMix_tests.F90 @@ -53,15 +53,15 @@ module SCM_CVMix_tests !> 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_params) - real, dimension(NIMEM_,NJMEM_, NKMEM_), intent(out) :: T !< Potential temperature [degC] - real, dimension(NIMEM_,NJMEM_, NKMEM_), intent(out) :: S !< Salinity [psu] - real, dimension(NIMEM_,NJMEM_, NKMEM_), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] - 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 !< Input parameter structure - logical, optional, intent(in) :: just_read_params !< If present and true, this call will - !! only read parameters without changing h. + 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 [degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< Salinity [psu] + 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(param_file_type), intent(in) :: param_file !< Input parameter structure + logical, optional, intent(in) :: just_read_params !< If present and true, this call + !! will only read parameters without changing h. ! Local variables real :: UpperLayerTempMLD !< Upper layer Temp MLD thickness [Z ~> m]. real :: UpperLayerSaltMLD !< Upper layer Salt MLD thickness [Z ~> m]. @@ -167,11 +167,11 @@ subroutine SCM_CVMix_tests_surface_forcing_init(Time, G, param_file, CS) 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_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z, fail_if_missing=.true.) + 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_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z, fail_if_missing=.true.) + 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", & @@ -200,8 +200,8 @@ subroutine SCM_CVMix_tests_surface_forcing_init(Time, G, param_file, CS) end subroutine SCM_CVMix_tests_surface_forcing_init -subroutine SCM_CVMix_tests_wind_forcing(state, forces, day, G, US, CS) - type(surface), intent(in) :: state !< Surface state structure +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 @@ -233,8 +233,8 @@ subroutine SCM_CVMix_tests_wind_forcing(state, forces, day, G, US, CS) end subroutine SCM_CVMix_tests_wind_forcing -subroutine SCM_CVMix_tests_buoyancy_forcing(state, fluxes, day, G, US, CS) - type(surface), intent(in) :: state !< Surface state structure +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 diff --git a/src/user/adjustment_initialization.F90 b/src/user/adjustment_initialization.F90 index e4816a1338..0ceaabbec7 100644 --- a/src/user/adjustment_initialization.F90 +++ b/src/user/adjustment_initialization.F90 @@ -70,9 +70,10 @@ subroutine adjustment_initialize_thickness ( h, G, GV, US, param_file, just_read ! 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,fail_if_missing=.true.,do_not_log=.true.) + call get_param(param_file, mdl, "S_REF", S_ref, 'Reference salinity', & + default=35.0, units='1e-3', do_not_log=just_read) call get_param(param_file, mdl,"MIN_THICKNESS",min_thickness,'Minimum layer thickness', & - units='m', default=1.0e-3, do_not_log=just_read, scale=US%m_to_Z) + default=1.0e-3, units='m', scale=US%m_to_Z, do_not_log=just_read) ! Parameters specific to this experiment configuration call get_param(param_file, mdl,"REGRIDDING_COORDINATE_MODE",verticalCoordinate, & @@ -124,8 +125,13 @@ subroutine adjustment_initialize_thickness ( h, G, GV, US, param_file, just_read e0(k) = -G%max_depth * (real(k-1) / real(nz)) enddo endif - 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)) ) + 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 @@ -219,8 +225,8 @@ subroutine adjustment_initialize_temperature_salinity(T, S, h, G, GV, param_file just_read = .false. ; if (present(just_read_params)) just_read = just_read_params ! Parameters used by main model initialization - call get_param(param_file, mdl,"S_REF",S_ref,'Reference salinity', units='1e-3', & - fail_if_missing=.not.just_read, do_not_log=just_read) + call get_param(param_file, mdl, "S_REF", S_ref, 'Reference salinity', & + default=35.0, units='1e-3', do_not_log=just_read) call get_param(param_file, mdl,"T_REF",T_ref,'Reference temperature', units='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='1e-3', & diff --git a/src/user/basin_builder.F90 b/src/user/basin_builder.F90 new file mode 100644 index 0000000000..61b65e0e9c --- /dev/null +++ b/src/user/basin_builder.F90 @@ -0,0 +1,309 @@ +!> 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)) == '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] + real :: dx, yr, dy + + 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 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/src/user/benchmark_initialization.F90 b/src/user/benchmark_initialization.F90 index 5641035ded..cc82ea6761 100644 --- a/src/user/benchmark_initialization.F90 +++ b/src/user/benchmark_initialization.F90 @@ -83,7 +83,7 @@ end subroutine benchmark_initialize_topography !! temperature profile with an exponentially decaying thermocline on top of a !! linear stratification. subroutine benchmark_initialize_thickness(h, G, GV, US, param_file, eqn_of_state, & - P_ref, just_read_params) + P_Ref, just_read_params) 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 @@ -91,10 +91,9 @@ subroutine benchmark_initialize_thickness(h, G, GV, US, param_file, eqn_of_state 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. - type(EOS_type), pointer :: eqn_of_state !< integer that selects the - !! equation of state. + type(EOS_type), pointer :: eqn_of_state !< Equation of state structure real, intent(in) :: P_Ref !< The coordinate-density - !! reference pressure [Pa]. + !! reference pressure [R L2 T-2 ~> Pa]. logical, optional, intent(in) :: just_read_params !< If present and true, this call will !! only read parameters without changing h. ! Local variables @@ -109,10 +108,11 @@ subroutine benchmark_initialize_thickness(h, G, GV, US, param_file, eqn_of_state 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, pres, S0, & ! drho + T0, S0, & ! Profiles of temperature [degC] and salinity [ppt] rho_guess, & ! Potential density at T0 & S0 [R ~> kg m-3]. drho_dT, & ! Derivative of density with temperature [R degC-1 ~> kg m-3 degC-1]. drho_dS ! Derivative of density with salinity [R ppt-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. real :: I_ts, I_md ! Inverse lengthscales [Z-1 ~> m-1]. real :: T_frac ! A ratio of the interface temperature to the range @@ -151,8 +151,8 @@ subroutine benchmark_initialize_thickness(h, G, GV, US, param_file, eqn_of_state pres(k) = P_Ref ; S0(k) = 35.0 enddo T0(k1) = 29.0 - call calculate_density(T0(k1), S0(k1), pres(k1), rho_guess(k1), eqn_of_state, scale=US%kg_m3_to_R) - call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, k1, 1, eqn_of_state, scale=US%kg_m3_to_R) + 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 @@ -161,8 +161,8 @@ subroutine benchmark_initialize_thickness(h, G, GV, US, param_file, eqn_of_state ! Refine the guesses for each layer. do itt=1,6 - call calculate_density(T0, S0, pres, rho_guess, 1, nz, eqn_of_state, scale=US%kg_m3_to_R) - call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, 1, nz, eqn_of_state, scale=US%kg_m3_to_R) + 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 @@ -216,23 +216,22 @@ subroutine benchmark_init_temperature_salinity(T, S, G, GV, US, param_file, & eqn_of_state, P_Ref, just_read_params) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: T !< The potential temperature + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: T !< The potential temperature !! that is being initialized. - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: S !< The salinity that is being + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: S !< The salinity that is being !! initialized. 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), pointer :: eqn_of_state !< integer that selects the - !! equation of state. + type(EOS_type), pointer :: eqn_of_state !< Equation of state structure real, intent(in) :: P_Ref !< The coordinate-density - !! reference pressure [Pa]. + !! reference pressure [R L2 T-2 ~> Pa]. logical, optional, intent(in) :: just_read_params !< If present and true, this call will !! only read parameters without changing h. ! Local variables real :: T0(SZK_(G)), S0(SZK_(G)) - real :: pres(SZK_(G)) ! Reference pressure [Pa]. + real :: pres(SZK_(G)) ! Reference pressure [R L2 T-2 ~> Pa]. real :: drho_dT(SZK_(G)) ! Derivative of density with temperature [R degC-1 ~> kg m-3 degC-1]. real :: drho_dS(SZK_(G)) ! Derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1]. real :: rho_guess(SZK_(G)) ! Potential density at T0 & S0 [R ~> kg m-3]. @@ -256,8 +255,8 @@ subroutine benchmark_init_temperature_salinity(T, S, G, GV, US, param_file, & enddo T0(k1) = 29.0 - call calculate_density(T0(k1),S0(k1),pres(k1),rho_guess(k1),eqn_of_state, scale=US%kg_m3_to_R) - call calculate_density_derivs(T0,S0,pres,drho_dT,drho_dS,k1,1,eqn_of_state, scale=US%kg_m3_to_R) + 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 @@ -266,8 +265,8 @@ subroutine benchmark_init_temperature_salinity(T, S, G, GV, US, param_file, & ! Refine the guesses for each layer. ! do itt = 1,6 - call calculate_density(T0,S0,pres,rho_guess,1,nz,eqn_of_state, scale=US%kg_m3_to_R) - call calculate_density_derivs(T0,S0,pres,drho_dT,drho_dS,1,nz,eqn_of_state, scale=US%kg_m3_to_R) + 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 diff --git a/src/user/dense_water_initialization.F90 b/src/user/dense_water_initialization.F90 index d591db30fb..468a5649fe 100644 --- a/src/user/dense_water_initialization.F90 +++ b/src/user/dense_water_initialization.F90 @@ -118,10 +118,12 @@ subroutine dense_water_initialize_TS(G, GV, param_file, eqn_of_state, T, S, h, j 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, do_not_log=.true.) - call get_param(param_file, mdl, "S_RANGE", S_range, do_not_log=.true.) - call get_param(param_file, mdl, "T_REF", T_ref, do_not_log=.true.) + call get_param(param_file, mdl, "S_REF", S_ref, 'Reference salinity', & + default=35.0, units='1e-3', do_not_log=just_read) + call get_param(param_file, mdl,"T_REF", T_ref, 'Reference temperature', units='degC', & + 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='1e-3', default=2.0, do_not_log=just_read) if (just_read) return ! All run-time parameters have been read, so return. @@ -195,7 +197,7 @@ subroutine dense_water_initialize_sponges(G, GV, US, tv, param_file, use_ALE, CS call get_param(param_file, mdl, "DENSE_WATER_MLD", mld, default=default_mld, do_not_log=.true.) call get_param(param_file, mdl, "DENSE_WATER_SILL_HEIGHT", sill_height, default=default_sill, do_not_log=.true.) - call get_param(param_file, mdl, "S_REF", S_ref, do_not_log=.true.) + call get_param(param_file, mdl, "S_REF", S_ref, default=35.0, do_not_log=.true.) call get_param(param_file, mdl, "S_RANGE", S_range, do_not_log=.true.) call get_param(param_file, mdl, "T_REF", T_ref, do_not_log=.true.) diff --git a/src/user/dumbbell_surface_forcing.F90 b/src/user/dumbbell_surface_forcing.F90 index c1f615fe2a..4b5bf5a2fb 100644 --- a/src/user/dumbbell_surface_forcing.F90 +++ b/src/user/dumbbell_surface_forcing.F90 @@ -24,22 +24,20 @@ module dumbbell_surface_forcing !> 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 :: use_temperature !< If true, temperature and salinity are used as state variables. logical :: restorebuoy !< If true, use restoring surface buoyancy forcing. real :: Rho0 !< The density used in the Boussinesq approximation [R ~> kg m-3]. real :: G_Earth !< The gravitational acceleration [L2 Z-1 T-2 ~> m s-2] real :: Flux_const !< The restoring rate at the surface [Z T-1 ~> m s-1]. - real :: gust_const !< A constant unresolved background gustiness - !! that contributes to ustar [Pa]. - real :: slp_amplitude !< The amplitude of pressure loading [Pa] applied +! 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 + real :: slp_period !< Period of sinusoidal pressure wave [days] real, dimension(:,:), allocatable :: & forcing_mask !< A mask regulating where forcing occurs real, dimension(:,:), allocatable :: & - S_restore !< The surface salinity field toward which to - !! restore [ppt]. + S_restore !< The surface salinity field toward which to restore [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 @@ -47,8 +45,8 @@ module dumbbell_surface_forcing contains !> Surface buoyancy (heat and fresh water) fluxes for the dumbbell test case -subroutine dumbbell_buoyancy_forcing(state, fluxes, day, dt, G, US, CS) - type(surface), intent(inout) :: state !< A structure containing fields that +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 @@ -120,7 +118,7 @@ subroutine dumbbell_buoyancy_forcing(state, fluxes, day, dt, G, US, CS) do j=js,je ; do i=is,ie if (CS%forcing_mask(i,j)>0.) then fluxes%vprec(i,j) = - (G%mask2dT(i,j) * (CS%Rho0*CS%Flux_const)) * & - ((CS%S_restore(i,j) - state%SSS(i,j)) / (0.5 * (CS%S_restore(i,j) + state%SSS(i,j)))) + ((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 @@ -129,8 +127,8 @@ subroutine dumbbell_buoyancy_forcing(state, fluxes, day, dt, G, US, CS) end subroutine dumbbell_buoyancy_forcing !> Dynamic forcing for the dumbbell test case -subroutine dumbbell_dynamic_forcing(state, fluxes, day, dt, G, CS) - type(surface), intent(inout) :: state !< A structure containing fields that +subroutine dumbbell_dynamic_forcing(sfc_state, fluxes, day, dt, G, CS) + type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. type(forcing), intent(inout) :: fluxes !< A structure containing pointers to any !! possible forcing fields. Unused fields @@ -199,8 +197,7 @@ subroutine dumbbell_surface_forcing_init(Time, G, US, param_file, diag, CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", CS%use_temperature, & - "If true, Temperature and salinity are used as state "//& - "variables.", default=.true.) + "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.", & @@ -213,10 +210,7 @@ subroutine dumbbell_surface_forcing_init(Time, G, US, param_file, diag, CS) 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="kg m2 s-1", default = 10000.0) - call get_param(param_file, mdl, "DUMBBELL_SLP_PERIOD", CS%slp_period, & - "Periodicity of SLP forcing in reservoirs.", & - units="days", default = 1.0) + units="Pa", default = 10000.0, scale=US%kg_m3_to_R*US%m_s_to_L_T**2) call get_param(param_file, mdl, "DUMBBELL_SLP_PERIOD", CS%slp_period, & "Periodicity of SLP forcing in reservoirs.", & units="days", default = 1.0) @@ -235,10 +229,9 @@ subroutine dumbbell_surface_forcing_init(Time, G, US, param_file, diag, CS) "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.", & - units="m day-1", scale=US%m_to_Z*US%T_to_s, fail_if_missing=.true.) + "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 diff --git a/src/user/sloshing_initialization.F90 b/src/user/sloshing_initialization.F90 index e099d808d5..5136775918 100644 --- a/src/user/sloshing_initialization.F90 +++ b/src/user/sloshing_initialization.F90 @@ -89,7 +89,7 @@ subroutine sloshing_initialize_thickness ( h, G, GV, US, param_file, just_read_p 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=.true., do_not_log=just_read) + default=.false., do_not_log=just_read) if (just_read) return ! All run-time parameters have been read, so return. @@ -207,17 +207,16 @@ subroutine sloshing_initialize_temperature_salinity ( T, S, h, G, GV, param_file just_read = .false. ; if (present(just_read_params)) just_read = just_read_params - call get_param(param_file, mdl,"S_REF",S_ref,'Reference value for salinity', & - units='1e-3', fail_if_missing=.not.just_read, do_not_log=just_read) - call get_param(param_file, mdl,"T_REF",T_ref,'Refernce value for temperature', & - units='C', fail_if_missing=.not.just_read, do_not_log=just_read) + call get_param(param_file, mdl, "S_REF", S_ref, 'Reference value for salinity', & + default=35.0, units='1e-3', do_not_log=just_read) + call get_param(param_file, mdl, "T_REF", T_ref, 'Reference value for temperature', & + units='degC', fail_if_missing=.not.just_read, do_not_log=just_read) - ! The default is to assume an increase by 2 for the salinity and a uniform - ! temperature + ! 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='1e-3', default=2.0, do_not_log=just_read) call get_param(param_file, mdl,"T_RANGE",T_range,'Initial temperature range', & - units='C', default=0.0, do_not_log=just_read) + units='degC', default=0.0, do_not_log=just_read) if (just_read) return ! All run-time parameters have been read, so return. diff --git a/src/user/user_change_diffusivity.F90 b/src/user/user_change_diffusivity.F90 index 86f3e6e99a..a63e7a2b89 100644 --- a/src/user/user_change_diffusivity.F90 +++ b/src/user/user_change_diffusivity.F90 @@ -10,7 +10,7 @@ module user_change_diffusivity 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 +use MOM_EOS, only : calculate_density, EOS_domain implicit none ; private @@ -66,12 +66,13 @@ subroutine user_change_diff(h, tv, G, GV, US, CS, Kd_lay, Kd_int, T_f, S_f, Kd_i !! each interface [Z2 T-1 ~> m2 s-1]. ! Local variables real :: Rcv(SZI_(G),SZK_(G)) ! The coordinate density in layers [R ~> kg m-3]. - real :: p_ref(SZI_(G)) ! An array of tv%P_Ref pressures. + 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 @@ -104,16 +105,15 @@ subroutine user_change_diff(h, tv, G, GV, US, CS, Kd_lay, Kd_int, T_f, S_f, Kd_i 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),& - is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) + 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),& - is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_ref, Rcv(:,k), tv%eqn_of_state, EOSdom) enddo endif diff --git a/src/user/user_initialization.F90 b/src/user/user_initialization.F90 index 55c609802e..a5d0fc90f7 100644 --- a/src/user/user_initialization.F90 +++ b/src/user/user_initialization.F90 @@ -38,17 +38,15 @@ module user_initialization !> Set vertical coordinates. subroutine USER_set_coord(Rlay, g_prime, GV, US, param_file, eqn_of_state) - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid - !! structure. - real, dimension(:), intent(out) :: Rlay !< Layer potential density [R ~> kg m-3]. - real, dimension(:), 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. - type(EOS_type), pointer :: eqn_of_state !< Integer that selects the - !! equation of state. + 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. + type(EOS_type), pointer :: eqn_of_state !< Equation of state structure call MOM_error(FATAL, & "USER_initialization.F90, USER_set_coord: " // & @@ -144,8 +142,7 @@ subroutine USER_init_temperature_salinity(T, S, G, param_file, eqn_of_state, jus type(param_file_type), intent(in) :: param_file !< A structure indicating the !! open file to parse for model !! parameter values. - type(EOS_type), pointer :: eqn_of_state !< Integer that selects the - !! equation of state. + type(EOS_type), pointer :: eqn_of_state !< Equation of state structure logical, optional, intent(in) :: just_read_params !< If present and true, this call will only !! read parameters without changing T & S. diff --git a/src/user/user_revise_forcing.F90 b/src/user/user_revise_forcing.F90 index d1be729734..c53451f4e8 100644 --- a/src/user/user_revise_forcing.F90 +++ b/src/user/user_revise_forcing.F90 @@ -30,8 +30,8 @@ module user_revise_forcing contains !> This subroutine sets the surface wind stresses. -subroutine user_alter_forcing(state, fluxes, day, G, CS) - type(surface), intent(in) :: state !< A structure containing fields that +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 From b2c78bea85c4cda32ad6d8168c779fb9e4aa94ed Mon Sep 17 00:00:00 2001 From: "brandon.reichl" Date: Thu, 24 Sep 2020 15:04:19 -0400 Subject: [PATCH 034/336] Setting energy values for new MLD diagnostic to be run-time parameters. --- .../vertical/MOM_diabatic_aux.F90 | 13 ++++--- .../vertical/MOM_diabatic_driver.F90 | 35 +++++++++++++------ 2 files changed, 34 insertions(+), 14 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 8a256bebd6..fc1a018036 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -726,11 +726,13 @@ 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_driver due to its position within the time stepping. -subroutine diagnoseMLDbyEnergy(id_MLD, h, tv, G, GV, US, diagPtr) +subroutine diagnoseMLDbyEnergy(id_MLD, h, tv, G, GV, US, Mixing_Energy, diagPtr) + ! Note that gravity is assumed constant everywhere and divided out of all calculations. + integer, dimension(3), intent(in) :: id_MLD !< Energy output diag 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 - integer, dimension(3), intent(in) :: id_MLD !< Handle (ID) of MLD diagnostics + real, dimension(3), intent(in) :: Mixing_Energy !< Energy values for up to 5 MLDs real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(in) :: h !< Layer thickness [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any @@ -745,7 +747,6 @@ subroutine diagnoseMLDbyEnergy(id_MLD, h, tv, G, GV, US, diagPtr) real :: Rho_MixedLayer, H_MixedLayer real, parameter :: Surface = 0.0 - real, parameter, dimension(3) :: Mixing_Energy = (/25.,2500.,250000./) real :: PE_Column_before, PE_Column_Target, PE_column_0, PE_column_N real :: Rho_MixedLayer_0, H_MixedLayer_0, Zc_MixedLayer_0, PE_MixedLayer_0 @@ -788,7 +789,7 @@ subroutine diagnoseMLDbyEnergy(id_MLD, h, tv, G, GV, US, diagPtr) rho_mixedlayer = 0. h_mixedlayer = 0. - PE_threshold = Mixing_Energy(iM)/GV%g_earth*1.e-4 + PE_threshold = Mixing_Energy(iM)/GV%g_earth*1.e-4!Fixed non-dim threshold of 0.01% do k=1,NZ @@ -886,6 +887,8 @@ subroutine diagnoseMLDbyEnergy(id_MLD, h, tv, G, GV, US, diagPtr) endif mld(i,j,iM) = H_MixedLayer enddo + else + mld(:,:,iM) = -1.e8 ! This shouldn't be seen, but if it is set it to something obviously wrong. endif enddo enddo @@ -898,6 +901,7 @@ subroutine diagnoseMLDbyEnergy(id_MLD, h, tv, G, GV, US, diagPtr) return end subroutine diagnoseMLDbyEnergy +!> Compute the integrated PE for a column, in J/m2/grav subroutine PE_Kernel(PE, NK, Z_L, Z_U, Rho_c ) integer :: NK real, intent(in), dimension(NK) :: Z_L, Z_U, Rho_c @@ -906,6 +910,7 @@ subroutine PE_Kernel(PE, NK, Z_L, Z_U, Rho_c ) PE = 0.0 do k=1,NK + !PE_layer = int rho z dz = rho_layer int z dz = rho_layer 0.5 * (Z_U^2-Z_L^2) PE = PE + (Rho_c(k))*0.5*(Z_U(k)**2-Z_L(k)**2) enddo diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 1afaf2911f..8e0e0a9f78 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -166,6 +166,7 @@ module MOM_diabatic_driver 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 !>@{ Diagnostic IDs integer :: id_cg1 = -1 ! diag handle for mode-1 speed (BDM) @@ -176,7 +177,7 @@ module MOM_diabatic_driver integer :: id_Kd_heat = -1, id_Kd_salt = -1, id_Kd_interface = -1, id_Kd_ePBL = -1 integer :: id_Tdif = -1, id_Tadv = -1, id_Sdif = -1, id_Sadv = -1 integer :: id_MLD_003 = -1, id_MLD_0125 = -1, id_MLD_user = -1, id_mlotstsq = -1 - integer :: id_MLD_EN25 = -1, id_MLD_EN2500 = -1, id_MLD_EN250000 = -1 + integer :: id_MLD_EN1 = -1, id_MLD_EN2 = -1, id_MLD_EN3= -1 integer :: id_subMLN2 = -1 ! diagnostic for fields prior to applying diapycnal physics @@ -429,9 +430,9 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & 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_EN25 > 0) .or. (CS%id_MLD_EN2500 > 0) .or. (CS%id_MLD_EN250000 > 0)) then - call diagnoseMLDbyEnergy((/CS%id_MLD_EN25, CS%id_MLD_EN2500, CS%id_MLD_EN250000/),& - h, tv, G, GV, US, CS%diag) + 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 (CS%use_int_tides) then if (CS%id_cg1 > 0) call post_data(CS%id_cg1, cn_IGW(:,:,1),CS%diag) @@ -3425,12 +3426,26 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di 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) - CS%id_MLD_EN25 = register_diag_field('ocean_model', 'MLD_EN_25', diag%axesT1, Time, & - 'Mixed layer depth (Energy = 25 J/m2)', 'm', conversion=US%Z_to_m) - CS%id_MLD_EN2500 = register_diag_field('ocean_model', 'MLD_EN_2500', diag%axesT1, Time, & - 'Mixed layer depth (Energy = 2500 J/m2)', 'm', conversion=US%Z_to_m) - CS%id_MLD_EN250000 = register_diag_field('ocean_model', 'MLD_EN_250000', diag%axesT1, Time, & - 'Mixed layer depth (Energy = 250000 J/m2)', 'm', conversion=US%Z_to_m) + CS%id_MLD_EN1 = register_diag_field('ocean_model', 'MLD_EN1', diag%axesT1, Time, & + 'Mixed layer depth for energy value 1 (Energy set by MLD_EN_VALS)', & + '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 2 (Energy set by MLD_EN_VALS)', & + '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 3 (Energy set by MLD_EN_VALS)', & + 'm', conversion=US%Z_to_m) + if ((CS%id_MLD_EN1>0) .or. (CS%id_MLD_EN2>0) .or. (CS%id_MLD_EN3>0)) then + 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%kg_m3_to_R*US%m_to_Z**3*US%T_to_s**2) + 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%kg_m3_to_R*US%m_to_Z**3*US%T_to_s**2,& + 2500.*US%kg_m3_to_R*US%m_to_Z**3*US%T_to_s**2,& + 250000.*US%kg_m3_to_R*US%m_to_Z**3*US%T_to_s**2/) + endif + endif CS%id_subMLN2 = register_diag_field('ocean_model', 'subML_N2', diag%axesT1, Time, & 'Squared buoyancy frequency below mixed layer', 's-2', conversion=US%s_to_T**2) CS%id_MLD_user = register_diag_field('ocean_model', 'MLD_user', diag%axesT1, Time, & From 1dcebcd0c33448f2d5df2405fbcf33633d91e68e Mon Sep 17 00:00:00 2001 From: "brandon.reichl" Date: Thu, 24 Sep 2020 15:09:21 -0400 Subject: [PATCH 035/336] Fix deleted empty line at beginning of MOM_diabatic_aux --- src/parameterizations/vertical/MOM_diabatic_aux.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index fc1a018036..087544bbfe 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -1,3 +1,4 @@ + !> Provides functions for some diabatic processes such as fraxil, brine rejection, !! tendency due to surface flux divergence. module MOM_diabatic_aux From de89f6a7d9e103dd5620027ee182daa571d94e14 Mon Sep 17 00:00:00 2001 From: "brandon.reichl" Date: Thu, 24 Sep 2020 15:11:08 -0400 Subject: [PATCH 036/336] Remove unused iteration tracking integer --- src/parameterizations/vertical/MOM_diabatic_aux.F90 | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 087544bbfe..6036b3d698 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -761,7 +761,7 @@ subroutine diagnoseMLDbyEnergy(id_MLD, h, tv, G, GV, US, Mixing_Energy, diagPtr) real :: Guess_Fraction, PE_Threshold real :: A, B, C, dz_increment logical :: Not_Converged - integer :: IT, ITT + integer :: IT real :: dz_max_incr integer :: i, j, is, ie, js, je, k, nz, id_N2, id_SQ, iM @@ -832,13 +832,10 @@ subroutine diagnoseMLDbyEnergy(id_MLD, h, tv, G, GV, US, Mixing_Energy, diagPtr) (/Rho_c(k)/) ) PE_column_N = PE_MixedLayer_N + PE_below + PE_interior - ITT = 0 do IT = 1,20 !Do the iteration up to 20 times Not_Converged = (abs(PE_column_N-PE_column_target)>PE_Threshold) if (Not_Converged) then - ITT = ITT+1 - A = PE_column_target - PE_column_N B = PE_column_N - PE_column_0 C = dz_mixed_N - dz_mixed_0 From ddd98dab382141e27b448af4d05209e923840072 Mon Sep 17 00:00:00 2001 From: "brandon.reichl" Date: Thu, 24 Sep 2020 16:02:51 -0400 Subject: [PATCH 037/336] Adding details of energy used for MLD_EN to NetCDF variable description --- .../vertical/MOM_diabatic_driver.F90 | 28 +++++++++++-------- 1 file changed, 16 insertions(+), 12 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 8e0e0a9f78..f81498e950 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -3207,6 +3207,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di real :: Kd ! A diffusivity used in the default for other tracer diffusivities, in MKS units [m2 s-1] integer :: num_mode logical :: use_temperature, differentialDiffusion + character(len=20) :: EN1, EN2, EN3 ! This "include" declares and sets the variable "version". #include "version_variable.h" @@ -3426,25 +3427,28 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di 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%kg_m3_to_R*US%m_to_Z**3*US%T_to_s**2) + 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%kg_m3_to_R*US%m_to_Z**3*US%T_to_s**2,& + 2500.*US%kg_m3_to_R*US%m_to_Z**3*US%T_to_s**2,& + 250000.*US%kg_m3_to_R*US%m_to_Z**3*US%T_to_s**2/) + endif + write(EN1,'(F10.2)') CS%MLD_EN_VALS(1)*US%R_to_kg_m3*US%Z_to_m**3*US%s_to_T**2 + write(EN2,'(F10.2)') CS%MLD_EN_VALS(2)*US%R_to_kg_m3*US%Z_to_m**3*US%s_to_T**2 + write(EN3,'(F10.2)') CS%MLD_EN_VALS(3)*US%R_to_kg_m3*US%Z_to_m**3*US%s_to_T**2 CS%id_MLD_EN1 = register_diag_field('ocean_model', 'MLD_EN1', diag%axesT1, Time, & - 'Mixed layer depth for energy value 1 (Energy set by MLD_EN_VALS)', & + 'Mixed layer depth for energy value set to '//trim(EN1)//' J/m2 (Energy set by 1st MLD_EN_VALS)', & '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 2 (Energy set by MLD_EN_VALS)', & + 'Mixed layer depth for energy value set to '//trim(EN2)//' J/m2 (Energy set by 2nd MLD_EN_VALS)', & '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 3 (Energy set by MLD_EN_VALS)', & + 'Mixed layer depth for energy value set to '//trim(EN3)//' J/m2 (Energy set by 3rd MLD_EN_VALS)', & 'm', conversion=US%Z_to_m) if ((CS%id_MLD_EN1>0) .or. (CS%id_MLD_EN2>0) .or. (CS%id_MLD_EN3>0)) then - 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%kg_m3_to_R*US%m_to_Z**3*US%T_to_s**2) - 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%kg_m3_to_R*US%m_to_Z**3*US%T_to_s**2,& - 2500.*US%kg_m3_to_R*US%m_to_Z**3*US%T_to_s**2,& - 250000.*US%kg_m3_to_R*US%m_to_Z**3*US%T_to_s**2/) - endif endif CS%id_subMLN2 = register_diag_field('ocean_model', 'subML_N2', diag%axesT1, Time, & 'Squared buoyancy frequency below mixed layer', 's-2', conversion=US%s_to_T**2) From 73dc15fd9f5228c73af62188a53cf1a5eed0c2ae Mon Sep 17 00:00:00 2001 From: "brandon.reichl" Date: Fri, 25 Sep 2020 09:01:18 -0400 Subject: [PATCH 038/336] Style updates to energy MLD calculation - Fixing whitespace - Fixing parenthesis in A*B/C to (A*B)/C - Moving /grav to *igrav (and computing threshold outside of i,j loop). --- .../vertical/MOM_diabatic_aux.F90 | 29 +++++++++++++------ 1 file changed, 20 insertions(+), 9 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 6036b3d698..a48b3aef20 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -1,4 +1,3 @@ - !> Provides functions for some diabatic processes such as fraxil, brine rejection, !! tendency due to surface flux divergence. module MOM_diabatic_aux @@ -758,18 +757,25 @@ subroutine diagnoseMLDbyEnergy(id_MLD, h, tv, G, GV, US, Mixing_Energy, diagPtr) real :: rho_c_mixed_n, zc_mixed_n - real :: Guess_Fraction, PE_Threshold + real :: Guess_Fraction, PE_Threshold(3), PE_Threshold_fraction real :: A, B, C, dz_increment logical :: Not_Converged integer :: IT real :: dz_max_incr - + real :: igrav integer :: i, j, is, ie, js, je, k, nz, id_N2, id_SQ, iM is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke pRef_MLD(:) = 0.0 mld(:,:,:) = 0.0 + igrav = 1./GV%g_earth + PE_Threshold_fraction = 1.e-4 !Fixed threshold of 0.01%, could be runtime. + + do iM=1,3 + PE_threshold(iM) = Mixing_Energy(iM)*igrav*PE_Threshold_fraction + enddo + do j=js,je do i=is,ie call calculate_density(tv%T(i,j,:), tv%S(i,j,:), pRef_MLD, rho_c, 1, nz, & @@ -786,11 +792,11 @@ subroutine diagnoseMLDbyEnergy(id_MLD, h, tv, G, GV, US, Mixing_Energy, diagPtr) if (id_MLD(iM)>0) then ! Compute PE of column call PE_Kernel(PE_Column_before,NZ,Z_L,Z_U,Rho_c) - PE_Column_Target = PE_Column_before + Mixing_Energy(iM)/GV%g_earth + PE_Column_Target = PE_Column_before + Mixing_Energy(iM)*igrav rho_mixedlayer = 0. h_mixedlayer = 0. - PE_threshold = Mixing_Energy(iM)/GV%g_earth*1.e-4!Fixed non-dim threshold of 0.01% + do k=1,NZ @@ -832,16 +838,21 @@ subroutine diagnoseMLDbyEnergy(id_MLD, h, tv, G, GV, US, Mixing_Energy, diagPtr) (/Rho_c(k)/) ) PE_column_N = PE_MixedLayer_N + PE_below + PE_interior + ! There is a question if an iteration is the most efficient + ! way to solve this problem. The expression for the layer fraction that + ! is not mixed is cubic and the iteration converges fairly rapidly. + ! So the answer is tbd, but this simple iteration serves the purpose + ! for now. do IT = 1,20 !Do the iteration up to 20 times - Not_Converged = (abs(PE_column_N-PE_column_target)>PE_Threshold) + Not_Converged = (abs(PE_column_N-PE_column_target)>PE_Threshold(iM)) if (Not_Converged) then A = PE_column_target - PE_column_N B = PE_column_N - PE_column_0 C = dz_mixed_N - dz_mixed_0 - if (abs(b)>PE_threshold) then - dz_increment = A*C/B + if (abs(b)>PE_threshold(iM)) then + dz_increment = (A*C)/B else dz_increment = sign(dz(k)*1.e-4,A) endif @@ -908,7 +919,7 @@ subroutine PE_Kernel(PE, NK, Z_L, Z_U, Rho_c ) PE = 0.0 do k=1,NK - !PE_layer = int rho z dz = rho_layer int z dz = rho_layer 0.5 * (Z_U^2-Z_L^2) + !PE_layer = int rho z dz = rho_layer int z dz = rho_layer 0.5 * (Z_U^2-Z_L^2) PE = PE + (Rho_c(k))*0.5*(Z_U(k)**2-Z_L(k)**2) enddo From 2ab5e96df51e38856ed74f6675dd4c4bcea9d231 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Fri, 25 Sep 2020 13:42:32 -0400 Subject: [PATCH 039/336] MOM_sum_output: Reproducibility fix to energy The total kinetic energy per unit mass, used heavily for model reproducibility tests, was being computed in a non-reproducibile form: KE_mass = 0.5 * (u(i-1)**2 + u(i)**2 + v(j-1)**2 + v**2) which uses an ambiguous order of summation. This was causing reproducibility errors in rotational tests where u and v become swapped. This patch resolves the problem by explicitly summing the u**2 and v**2 interpolations before adding together. There is an extremely high change that this will change the output of `ocean.stats`, causing most tests to report a regression. Actual model results should not be affected. --- src/diagnostics/MOM_sum_output.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index 2d4fb7e06f..1742ec1247 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -703,8 +703,9 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, OBC, dt_ 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) + ((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 From 974a25ad42663c50011b6322f716ab2bfd53248f Mon Sep 17 00:00:00 2001 From: Hemant Khatri Date: Sun, 27 Sep 2020 20:11:03 -0400 Subject: [PATCH 040/336] Diagnostic for depth-averaged zonal acceleration from diapycnal mixing. --- .../vertical/MOM_diabatic_driver.F90 | 95 ++++++++++++++++++- 1 file changed, 93 insertions(+), 2 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 62bfeb726d..d543d6e60e 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -176,6 +176,7 @@ module MOM_diabatic_driver integer :: id_Tdif = -1, id_Tadv = -1, id_Sdif = -1, id_Sadv = -1 integer :: id_MLD_003 = -1, id_MLD_0125 = -1, id_MLD_user = -1, id_mlotstsq = -1 integer :: id_subMLN2 = -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 @@ -510,6 +511,9 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim Sdif_flx, & ! diffusive diapycnal salt flux across interfaces [ppt H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] Sadv_flx ! advective diapycnal salt flux across interfaces [ppt H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] + real, allocatable, dimension(:,:) :: & + hf_dudt_dia_2d, hf_dvdt_dia_2d ! Depth sum of diapycnal mixing accelaration * fract. thickness [L T-2 ~> m s-2]. + 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 @@ -1038,7 +1042,8 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim ! Whenever thickness changes let the diag manager know, as the ! target grids for vertical remapping may need to be regenerated. - if (CS%id_dudt_dia > 0 .or. CS%id_dvdt_dia > 0) & + !if (CS%id_dudt_dia > 0 .or. CS%id_dvdt_dia > 0) & + 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) @@ -1213,6 +1218,27 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim 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 terms multiplied by fractional thicknesses + if (CS%id_hf_dudt_dia_2d > 0) then + allocate(hf_dudt_dia_2d(G%IsdB:G%IedB,G%jsd:G%jed)) + hf_dudt_dia_2d(:,:) = 0.0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + hf_dudt_dia_2d(I,j) = hf_dudt_dia_2d(I,j) + ADp%du_dt_dia(I,j,k) * ADp%diag_hfrac_u(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_dudt_dia_2d, hf_dudt_dia_2d, CS%diag) + deallocate(hf_dudt_dia_2d) + endif + + if (CS%id_hf_dvdt_dia_2d > 0) then + allocate(hf_dvdt_dia_2d(G%isd:G%ied,G%JsdB:G%JedB)) + hf_dvdt_dia_2d(:,:) = 0.0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + hf_dvdt_dia_2d(i,J) = hf_dvdt_dia_2d(i,J) + ADp%dv_dt_dia(i,J,k) * ADp%diag_hfrac_v(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_dvdt_dia_2d, hf_dvdt_dia_2d, CS%diag) + deallocate(hf_dvdt_dia_2d) + endif + call disable_averaging(CS%diag) if (showCallTree) call callTree_leave("diabatic_ALE_legacy()") @@ -1291,6 +1317,9 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, Sdif_flx, & ! diffusive diapycnal salt flux across interfaces [ppt H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] Sadv_flx ! advective diapycnal salt flux across interfaces [ppt H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] + real, allocatable, dimension(:,:) :: & + hf_dudt_dia_2d, hf_dvdt_dia_2d ! Depth sum of diapycnal mixing accelaration * fract. thickness [L T-2 ~> m s-2]. + 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 @@ -1894,6 +1923,27 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, 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 terms multiplied by fractional thicknesses + if (CS%id_hf_dudt_dia_2d > 0) then + allocate(hf_dudt_dia_2d(G%IsdB:G%IedB,G%jsd:G%jed)) + hf_dudt_dia_2d(:,:) = 0.0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + hf_dudt_dia_2d(I,j) = hf_dudt_dia_2d(I,j) + ADp%du_dt_dia(I,j,k) * ADp%diag_hfrac_u(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_dudt_dia_2d, hf_dudt_dia_2d, CS%diag) + deallocate(hf_dudt_dia_2d) + endif + + if (CS%id_hf_dvdt_dia_2d > 0) then + allocate(hf_dvdt_dia_2d(G%isd:G%ied,G%JsdB:G%JedB)) + hf_dvdt_dia_2d(:,:) = 0.0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + hf_dvdt_dia_2d(i,J) = hf_dvdt_dia_2d(i,J) + ADp%dv_dt_dia(i,J,k) * ADp%diag_hfrac_v(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_dvdt_dia_2d, hf_dvdt_dia_2d, CS%diag) + deallocate(hf_dvdt_dia_2d) + endif + call disable_averaging(CS%diag) if (showCallTree) call callTree_leave("diabatic_ALE()") @@ -1966,6 +2016,9 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e Sdif_flx, & ! diffusive diapycnal salt flux across interfaces [ppt H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] Sadv_flx ! advective diapycnal salt flux across interfaces [ppt H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] + real, allocatable, dimension(:,:) :: & + hf_dudt_dia_2d, hf_dvdt_dia_2d ! Depth sum of diapycnal mixing accelaration * fract. thickness [L T-2 ~> m s-2]. + ! The following 5 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]. @@ -2548,7 +2601,8 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e ! Whenever thickness changes let the diag manager know, as the ! target grids for vertical remapping may need to be regenerated. - if (CS%id_dudt_dia > 0 .or. CS%id_dvdt_dia > 0) & + !if (CS%id_dudt_dia > 0 .or. CS%id_dvdt_dia > 0) & + 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) @@ -2843,6 +2897,27 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e 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 terms multiplied by fractional thicknesses + if (CS%id_hf_dudt_dia_2d > 0) then + allocate(hf_dudt_dia_2d(G%IsdB:G%IedB,G%jsd:G%jed)) + hf_dudt_dia_2d(:,:) = 0.0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + hf_dudt_dia_2d(I,j) = hf_dudt_dia_2d(I,j) + ADp%du_dt_dia(I,j,k) * ADp%diag_hfrac_u(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_dudt_dia_2d, hf_dudt_dia_2d, CS%diag) + deallocate(hf_dudt_dia_2d) + endif + + if (CS%id_hf_dvdt_dia_2d > 0) then + allocate(hf_dvdt_dia_2d(G%isd:G%ied,G%JsdB:G%JedB)) + hf_dvdt_dia_2d(:,:) = 0.0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + hf_dvdt_dia_2d(i,J) = hf_dvdt_dia_2d(i,J) + ADp%dv_dt_dia(i,J,k) * ADp%diag_hfrac_v(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_dvdt_dia_2d, hf_dvdt_dia_2d, CS%diag) + deallocate(hf_dvdt_dia_2d) + endif + call disable_averaging(CS%diag) if (showCallTree) call callTree_leave("layered_diabatic()") @@ -3383,6 +3458,22 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di 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) then + call safe_alloc_ptr(ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + call safe_alloc_ptr(ADp%du_dt_dia,IsdB,IedB,jsd,jed,nz) + endif + + 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) then + call safe_alloc_ptr(ADp%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + call safe_alloc_ptr(ADp%dv_dt_dia,isd,ied,JsdB,JedB,nz) + endif + if (CS%use_int_tides) then 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) From dfc2885146649f1c2c8a83ba94519e67b91ef99d Mon Sep 17 00:00:00 2001 From: Hemant Khatri Date: Tue, 29 Sep 2020 10:20:23 -0400 Subject: [PATCH 041/336] Removed trailing spaces --- src/parameterizations/vertical/MOM_diabatic_driver.F90 | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index d543d6e60e..e837dfe9e5 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -1042,8 +1042,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim ! Whenever thickness changes let the diag manager know, as the ! target grids for vertical remapping may need to be regenerated. - !if (CS%id_dudt_dia > 0 .or. CS%id_dvdt_dia > 0) & - if (associated(ADp%du_dt_dia) .or. associated(ADp%dv_dt_dia)) & + 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) @@ -2601,7 +2600,6 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e ! Whenever thickness changes let the diag manager know, as the ! target grids for vertical remapping may need to be regenerated. - !if (CS%id_dudt_dia > 0 .or. CS%id_dvdt_dia > 0) & 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) From 22cb93ed76111e4c1fd6189ddea6590edba664b2 Mon Sep 17 00:00:00 2001 From: Hemant Khatri Date: Tue, 29 Sep 2020 10:31:40 -0400 Subject: [PATCH 042/336] spaces correction in loop --- src/parameterizations/vertical/MOM_diabatic_driver.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index e837dfe9e5..df429c4c5e 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -3460,16 +3460,16 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di '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) then - call safe_alloc_ptr(ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) - call safe_alloc_ptr(ADp%du_dt_dia,IsdB,IedB,jsd,jed,nz) + call safe_alloc_ptr(ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + call safe_alloc_ptr(ADp%du_dt_dia,IsdB,IedB,jsd,jed,nz) endif 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) then - call safe_alloc_ptr(ADp%diag_hfrac_v,isd,ied,Jsd,JedB,nz) - call safe_alloc_ptr(ADp%dv_dt_dia,isd,ied,JsdB,JedB,nz) + call safe_alloc_ptr(ADp%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + call safe_alloc_ptr(ADp%dv_dt_dia,isd,ied,JsdB,JedB,nz) endif if (CS%use_int_tides) then From 9dcb866da2eb31d9614e06f99a9ada406ca4f1de Mon Sep 17 00:00:00 2001 From: Hemant Khatri Date: Tue, 29 Sep 2020 14:38:47 -0400 Subject: [PATCH 043/336] Idamp_var change --- src/initialization/MOM_state_initialization.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index de33409fed..1398ebe406 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -1795,7 +1795,7 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, param_file, C if (new_sponges .and. .not. use_ALE) & call MOM_error(FATAL, " initialize_sponges: Newer sponges are currently unavailable in layered mode ") - call MOM_read_data(filename, "Idamp", Idamp(:,:), G%Domain, scale=US%T_to_s) + call MOM_read_data(filename, Idamp_var, Idamp(:,:), G%Domain, scale=US%T_to_s) ! Now register all of the fields which are damped in the sponge. ! By default, momentum is advected vertically within the sponge, but From 12e603f950ceef0de0a16bdc00e079f69e612665 Mon Sep 17 00:00:00 2001 From: Brandon Reichl Date: Wed, 30 Sep 2020 14:18:29 -0400 Subject: [PATCH 044/336] Adding tolerance check option in MOM_kappa_shear --- .../vertical/MOM_kappa_shear.F90 | 21 ++++++++++++++++--- 1 file changed, 18 insertions(+), 3 deletions(-) diff --git a/src/parameterizations/vertical/MOM_kappa_shear.F90 b/src/parameterizations/vertical/MOM_kappa_shear.F90 index 9705b36543..f80df2d6cb 100644 --- a/src/parameterizations/vertical/MOM_kappa_shear.F90 +++ b/src/parameterizations/vertical/MOM_kappa_shear.F90 @@ -87,6 +87,10 @@ module MOM_kappa_shear !! 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. @@ -928,9 +932,16 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & 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 + 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 @@ -1915,6 +1926,10 @@ function kappa_shear_init(Time, G, GV, US, param_file, diag, CS) "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) From 1634ceefe2f60fe9019bc147b1d2fc2a5efe34ce Mon Sep 17 00:00:00 2001 From: Brandon Reichl Date: Wed, 30 Sep 2020 14:21:13 -0400 Subject: [PATCH 045/336] Bugfix for an itt number iteration check in MOM_kappa_shear --- src/parameterizations/vertical/MOM_kappa_shear.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/parameterizations/vertical/MOM_kappa_shear.F90 b/src/parameterizations/vertical/MOM_kappa_shear.F90 index f80df2d6cb..033f717091 100644 --- a/src/parameterizations/vertical/MOM_kappa_shear.F90 +++ b/src/parameterizations/vertical/MOM_kappa_shear.F90 @@ -903,7 +903,7 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & ! 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_RiNo_it)) then + 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) From 6c7eac1ed5adc5b8b1f70e51d4598f284178d6d4 Mon Sep 17 00:00:00 2001 From: Neeraja Bhamidipati Date: Thu, 1 Oct 2020 05:21:48 -0600 Subject: [PATCH 046/336] Copied u_BT_accel and v_BT_accel to the accelaration diagnostics pointer --- src/core/MOM_dynamics_split_RK2.F90 | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index 64a9c18b97..519f510239 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -1219,6 +1219,9 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param 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 + ! Accel_diag%pbce => CS%pbce ! Accel_diag%u_accel_bt => CS%u_accel_bt ; Accel_diag%v_accel_bt => CS%v_accel_bt From 11ccaf76b3db34cfdc6658a98ea60ac915205090 Mon Sep 17 00:00:00 2001 From: Neeraja Bhamidipati Date: Thu, 1 Oct 2020 05:24:26 -0600 Subject: [PATCH 047/336] Assigned u_BT_accel and v_BT_accel to accel_diag_ptrs --- src/core/MOM_variables.F90 | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index 0b225f0bf7..5a3a4fed65 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -171,7 +171,9 @@ module MOM_variables 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_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] + 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]. From a1d28a294cd469c65127da7b73ec5e5c734dd4c5 Mon Sep 17 00:00:00 2001 From: Neeraja Bhamidipati Date: Thu, 1 Oct 2020 05:25:12 -0600 Subject: [PATCH 048/336] Added a new diagnostic for barotropic contribution to KE term (KE_BT) --- src/diagnostics/MOM_diagnostics.F90 | 40 ++++++++++++++++++++++++----- 1 file changed, 33 insertions(+), 7 deletions(-) diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 3936a788d0..b181622ac9 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -99,6 +99,7 @@ module MOM_diagnostics KE => NULL(), & !< KE per unit mass [L2 T-2 ~> m2 s-2] dKE_dt => NULL(), & !< time derivative of the layer KE [H L2 T-3 ~> m3 s-3] PE_to_KE => NULL(), & !< potential energy to KE term [m3 s-3] + KE_BT => NULL(), & !< barotropic contribution to KE term [m3 s-3] KE_CorAdv => NULL(), & !< KE source from the combined Coriolis and !! advection terms [H L2 T-3 ~> m3 s-3]. !! The Coriolis source should be zero, but is not due to truncation @@ -117,7 +118,8 @@ module MOM_diagnostics integer :: id_hf_du_dt_2d = -1, id_hf_dv_dt_2d = -1 integer :: id_col_ht = -1, id_dh_dt = -1 integer :: id_KE = -1, id_dKEdt = -1 - integer :: id_PE_to_KE = -1, id_KE_Coradv = -1 + integer :: id_PE_to_KE = -1, id_KE_BT = -1 + integer :: id_KE_Coradv = -1 integer :: id_KE_adv = -1, id_KE_visc = -1 integer :: id_KE_horvisc = -1, id_KE_dia = -1 integer :: id_uh_Rlay = -1, id_vh_Rlay = -1 @@ -994,9 +996,9 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS endif if (.not.G%symmetric) then - if (associated(CS%dKE_dt) .OR. associated(CS%PE_to_KE) .OR. associated(CS%KE_CorAdv) .OR. & - associated(CS%KE_adv) .OR. associated(CS%KE_visc) .OR. associated(CS%KE_horvisc).OR. & - associated(CS%KE_dia) ) then + if (associated(CS%dKE_dt) .OR. associated(CS%PE_to_KE) .OR. associated(CS%KE_BT) .OR. & + associated(CS%KE_CorAdv) .OR. associated(CS%KE_adv) .OR. associated(CS%KE_visc) .OR. & + associated(CS%KE_horvisc) .OR. associated(CS%KE_dia) ) then call create_group_pass(CS%pass_KE_uv, KE_u, KE_v, G%Domain, To_North+To_East) endif endif @@ -1040,6 +1042,24 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS if (CS%id_PE_to_KE > 0) call post_data(CS%id_PE_to_KE, CS%PE_to_KE, CS%diag) endif + if (associated(CS%KE_BT)) then + 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 + CS%KE_BT(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_KE_BT > 0) call post_data(CS%id_KE_BT, CS%KE_BT, CS%diag) + endif + if (associated(CS%KE_CorAdv)) then do k=1,nz do j=js,je ; do I=Isq,Ieq @@ -1779,6 +1799,11 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag 'm3 s-3', conversion=GV%H_to_m*(US%L_T_to_m_s**2)*US%s_to_T) if (CS%id_PE_to_KE>0) call safe_alloc_ptr(CS%PE_to_KE,isd,ied,jsd,jed,nz) + 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) + if (CS%id_KE_BT>0) call safe_alloc_ptr(CS%KE_BT,isd,ied,jsd,jed,nz) + 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) @@ -2192,9 +2217,9 @@ subroutine set_dependent_diagnostics(MIS, ADp, CDp, G, CS) IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB if (associated(CS%dKE_dt) .or. associated(CS%PE_to_KE) .or. & - associated(CS%KE_CorAdv) .or. associated(CS%KE_adv) .or. & - associated(CS%KE_visc) .or. associated(CS%KE_horvisc) .or. & - associated(CS%KE_dia)) & + associated(CS%KE_BT) .or. associated(CS%KE_CorAdv) .or. & + associated(CS%KE_adv) .or. associated(CS%KE_visc) .or. & + associated(CS%KE_horvisc) .or. associated(CS%KE_dia)) & call safe_alloc_ptr(CS%KE,isd,ied,jsd,jed,nz) if (associated(CS%dKE_dt)) then @@ -2245,6 +2270,7 @@ subroutine MOM_diagnostics_end(CS, ADp) if (associated(CS%KE)) deallocate(CS%KE) if (associated(CS%dKE_dt)) deallocate(CS%dKE_dt) if (associated(CS%PE_to_KE)) deallocate(CS%PE_to_KE) + if (associated(CS%KE_BT)) deallocate(CS%KE_BT) if (associated(CS%KE_Coradv)) deallocate(CS%KE_Coradv) if (associated(CS%KE_adv)) deallocate(CS%KE_adv) if (associated(CS%KE_visc)) deallocate(CS%KE_visc) From 50d10ad80a7bc0963b347ff7ab489aac4a3b29f7 Mon Sep 17 00:00:00 2001 From: "brandon.reichl" Date: Thu, 1 Oct 2020 08:36:43 -0400 Subject: [PATCH 049/336] Fixing unit scaling issue where m_to_Z should have been m_to_L --- src/parameterizations/vertical/MOM_diabatic_aux.F90 | 6 ++---- .../vertical/MOM_diabatic_driver.F90 | 12 ++++++------ 2 files changed, 8 insertions(+), 10 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index a48b3aef20..807b6f6c4e 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -732,7 +732,7 @@ subroutine diagnoseMLDbyEnergy(id_MLD, h, tv, G, GV, US, Mixing_Energy, diagPtr) 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 5 MLDs + real, dimension(3), intent(in) :: Mixing_Energy !< Energy values for up to 3 MLDs real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(in) :: h !< Layer thickness [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any @@ -781,7 +781,7 @@ subroutine diagnoseMLDbyEnergy(id_MLD, h, tv, G, GV, US, Mixing_Energy, diagPtr) call calculate_density(tv%T(i,j,:), tv%S(i,j,:), pRef_MLD, rho_c, 1, nz, & tv%eqn_of_state, scale=US%kg_m3_to_R) Z_U(1) = 0.0 - do k=2,nz ; Z_U(k) = Z_U(k-1) - h(i,j,k-1)*GV%H_to_z ; enddo + do k=2,nz ; Z_U(k) = Z_U(k-1) - h(i,j,k-1)*GV%H_to_Z ; enddo do k=1,nz Z_C(k) = Z_U(k) - 0.5 * h(i,j,k) * GV%H_to_Z Z_L(k) = Z_U(k) - h(i,j,k) * GV%H_to_Z @@ -896,8 +896,6 @@ subroutine diagnoseMLDbyEnergy(id_MLD, h, tv, G, GV, US, Mixing_Energy, diagPtr) endif mld(i,j,iM) = H_MixedLayer enddo - else - mld(:,:,iM) = -1.e8 ! This shouldn't be seen, but if it is set it to something obviously wrong. endif enddo enddo diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index f81498e950..52e469832e 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -3432,13 +3432,13 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di "default will overwrite to 25., 2500., 250000.",units='J/m2', default=0., & scale=US%kg_m3_to_R*US%m_to_Z**3*US%T_to_s**2) 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%kg_m3_to_R*US%m_to_Z**3*US%T_to_s**2,& - 2500.*US%kg_m3_to_R*US%m_to_Z**3*US%T_to_s**2,& - 250000.*US%kg_m3_to_R*US%m_to_Z**3*US%T_to_s**2/) + CS%MLD_EN_VALS = (/25.*US%kg_m3_to_R*US%m_to_Z*US%m_to_L**2*US%T_to_s**2,& + 2500.*US%kg_m3_to_R*US%m_to_Z*US%m_to_L**2*US%T_to_s**2,& + 250000.*US%kg_m3_to_R*US%m_to_Z*US%m_to_L**2*US%T_to_s**2/) endif - write(EN1,'(F10.2)') CS%MLD_EN_VALS(1)*US%R_to_kg_m3*US%Z_to_m**3*US%s_to_T**2 - write(EN2,'(F10.2)') CS%MLD_EN_VALS(2)*US%R_to_kg_m3*US%Z_to_m**3*US%s_to_T**2 - write(EN3,'(F10.2)') CS%MLD_EN_VALS(3)*US%R_to_kg_m3*US%Z_to_m**3*US%s_to_T**2 + write(EN1,'(F10.2)') CS%MLD_EN_VALS(1)*US%R_to_kg_m3*US%Z_to_m*US%L_to_m**2*US%s_to_T**2 + write(EN2,'(F10.2)') CS%MLD_EN_VALS(2)*US%R_to_kg_m3*US%Z_to_m*US%L_to_m**2*US%s_to_T**2 + write(EN3,'(F10.2)') CS%MLD_EN_VALS(3)*US%R_to_kg_m3*US%Z_to_m*US%L_to_m**2*US%s_to_T**2 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)', & 'm', conversion=US%Z_to_m) From 913830b4891ebc1220be71f6e0b9cff949f856d5 Mon Sep 17 00:00:00 2001 From: Andrew Ross Date: Fri, 2 Oct 2020 10:35:17 -0400 Subject: [PATCH 050/336] Open boundary forcing will also use TIDE_*_FREQ parameters if they are defined --- src/core/MOM_open_boundary.F90 | 74 ++++++++++--------- .../lateral/MOM_tidal_forcing.F90 | 3 +- 2 files changed, 41 insertions(+), 36 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 7863f9cf1b..46d144a8c6 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -368,9 +368,6 @@ subroutine open_boundary_config(G, US, param_file, OBC) character(len=1024) :: segment_str ! The contents (rhs) for parameter "segment_param_str" character(len=200) :: config1 ! String for OBC_USER_CONFIG real :: Lscale_in, Lscale_out ! parameters controlling tracer values at the boundaries [L ~> m] - integer, dimension(3) :: tide_ref_date, nodal_ref_date !< Reference date (t = 0) for tidal forcing - !! and fixed date for nodal modulation. - character(len=50) :: tide_constituent_str !< List of tidal constituents to add to boundary. character(len=128) :: inputdir logical :: answers_2018, default_2018_answers logical :: check_reconstruction, check_remapping, force_bounds_in_subcell @@ -462,32 +459,6 @@ subroutine open_boundary_config(G, US, param_file, OBC) if (OBC%n_tide_constituents > 0) then OBC%add_tide_constituents = .true. - 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 - else OBC%add_tide_constituents = .false. endif @@ -664,7 +635,7 @@ subroutine open_boundary_config(G, US, param_file, OBC) "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, tide_ref_date, nodal_ref_date, tide_constituent_str) + call initialize_obc_tides(OBC, 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 @@ -988,15 +959,42 @@ subroutine initialize_segment_data(G, OBC, PF) end subroutine initialize_segment_data -subroutine initialize_obc_tides(OBC, tide_ref_date, nodal_ref_date, tide_constituent_str) +subroutine initialize_obc_tides(OBC, param_file) type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure - integer, dimension(3), intent(in) :: tide_ref_date !< Reference date (t = 0) for tidal forcing. - integer, dimension(3), intent(in) :: nodal_ref_date !< Date to calculate nodal modulation for. - character(len=50), intent(in) :: tide_constituent_str !< List of tidal constituents to include on boundary. + 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 @@ -1029,7 +1027,13 @@ subroutine initialize_obc_tides(OBC, tide_ref_date, nodal_ref_date, tide_constit allocate(OBC%tide_un(OBC%n_tide_constituents)) do c=1,OBC%n_tide_constituents - OBC%tide_frequencies(c) = tidal_frequency(trim(OBC%tide_names(c))) + ! 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)))) ! Find equilibrum phase if needed if (OBC%add_eq_phase) then diff --git a/src/parameterizations/lateral/MOM_tidal_forcing.F90 b/src/parameterizations/lateral/MOM_tidal_forcing.F90 index 2907d8dd30..6788c5f91c 100644 --- a/src/parameterizations/lateral/MOM_tidal_forcing.F90 +++ b/src/parameterizations/lateral/MOM_tidal_forcing.F90 @@ -474,7 +474,8 @@ subroutine tidal_forcing_init(Time, G, param_file, CS) 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.", units="s-1", default=freq_def(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)) 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))// & From 81cf30a3edf03e3e834ef12d1fa8c74219c385cd Mon Sep 17 00:00:00 2001 From: "brandon.reichl" Date: Fri, 2 Oct 2020 17:36:25 -0400 Subject: [PATCH 051/336] Rewrite the energy MLD computation so it can use Newton's Method iterator instead of a secant method. --- .../vertical/MOM_diabatic_aux.F90 | 319 +++++++++--------- 1 file changed, 162 insertions(+), 157 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 807b6f6c4e..3efcf99f4d 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -727,7 +727,27 @@ 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_driver due to its position within the time stepping. subroutine diagnoseMLDbyEnergy(id_MLD, h, tv, G, GV, US, Mixing_Energy, diagPtr) - ! Note that gravity is assumed constant everywhere and divided out of all calculations. + ! 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 being rather + ! lienar for PE change with increasing X. + ! Input parameters: integer, dimension(3), intent(in) :: id_MLD !< Energy output diag IDs type(ocean_grid_type), intent(in) :: G !< Grid type type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure @@ -741,189 +761,174 @@ subroutine diagnoseMLDbyEnergy(id_MLD, h, tv, G, GV, US, Mixing_Energy, diagPtr) ! Local variables real, dimension(SZI_(G), SZJ_(G),3) :: MLD ! Diagnosed mixed layer depth [Z ~> m]. - real, dimension(SZK_(G)) :: Z_L, Z_C, Z_U, dZ, Rho_c, pRef_MLD + real, dimension(SZK_(G)) :: Z_L, Z_U, dZ, Rho_c, pRef_MLD + real, dimension(3) :: PE_threshold - real :: PE_Before - real :: Rho_MixedLayer, H_MixedLayer + real :: ig, E_g + real :: PE_Threshold_fraction, PE, PE_Mixed, PE_Mixed_TST + real :: RhoDZ_ML, H_ML, RhoDZ_ML_TST, H_ML_TST + real :: Rho_ML - real, parameter :: Surface = 0.0 + real :: R1, D1, R2, D2 + real :: Ca, Cb,D ,Cc, Cd, Ca2, Cb2, C, Cc2 + real :: Gx, Gpx, Hx, iHx, Hpx, Ix, Ipx, Fgx, Fpx, X, X2 - real :: PE_Column_before, PE_Column_Target, PE_column_0, PE_column_N - real :: Rho_MixedLayer_0, H_MixedLayer_0, Zc_MixedLayer_0, PE_MixedLayer_0 - real :: Rho_MixedLayer_N, H_MixedLayer_N, Zc_MixedLayer_N, PE_MixedLayer_N - real :: dz_mixed_0, dz_mixed_N - real :: PE_interior - real :: dz_below, zc_below, zl_below, zu_below, rho_c_below, PE_below - - real :: rho_c_mixed_n, zc_mixed_n - - real :: Guess_Fraction, PE_Threshold(3), PE_Threshold_fraction - real :: A, B, C, dz_increment - logical :: Not_Converged - integer :: IT - real :: dz_max_incr - real :: igrav - integer :: i, j, is, ie, js, je, k, nz, id_N2, id_SQ, iM + 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 = G%ke pRef_MLD(:) = 0.0 mld(:,:,:) = 0.0 - igrav = 1./GV%g_earth PE_Threshold_fraction = 1.e-4 !Fixed threshold of 0.01%, could be runtime. do iM=1,3 - PE_threshold(iM) = Mixing_Energy(iM)*igrav*PE_Threshold_fraction + PE_threshold(iM) = Mixing_Energy(iM)/GV%g_earth enddo - do j=js,je - do i=is,ie + do j=js,je; do i=is,ie + if (G%mask2dT(i,j) > 0.0) then + call calculate_density(tv%T(i,j,:), tv%S(i,j,:), pRef_MLD, rho_c, 1, nz, & - tv%eqn_of_state, scale=US%kg_m3_to_R) - Z_U(1) = 0.0 - do k=2,nz ; Z_U(k) = Z_U(k-1) - h(i,j,k-1)*GV%H_to_Z ; enddo + tv%eqn_of_state, scale=US%kg_m3_to_R) + do k=1,nz - Z_C(k) = Z_U(k) - 0.5 * h(i,j,k) * GV%H_to_Z - Z_L(k) = Z_U(k) - h(i,j,k) * GV%H_to_Z - dZ(k) = h(i,j,k) * GV%H_to_Z + DZ(k) = h(i,j,k) * GV%H_to_Z + enddo + Z_U(1) = 0.0 + Z_L(1) = -DZ(1) + do k=2,nz + Z_U(k) = Z_L(k-1) + Z_L(k) = Z_L(k-1)-DZ(k) enddo do iM=1,3 - if (id_MLD(iM)>0) then - ! Compute PE of column - call PE_Kernel(PE_Column_before,NZ,Z_L,Z_U,Rho_c) - PE_Column_Target = PE_Column_before + Mixing_Energy(iM)*igrav - - rho_mixedlayer = 0. - h_mixedlayer = 0. - - - do k=1,NZ - - !Compute the PE if the whole layer is mixed - Rho_MixedLayer_0 = Rho_MixedLayer + Rho_c(k)*dZ(k) - H_MixedLayer_0 = H_MixedLayer + dZ(k) - Zc_MixedLayer_0 = 0.5 * (Surface - H_MixedLayer_0) - PE_MixedLayer_0 = Rho_MixedLayer_0 * Zc_MixedLayer_0 - - !Compute the PE of the interior layers - call PE_Kernel(PE_Interior,NZ-(K),Z_L(K+1:NZ),Z_U(K+1:NZ),Rho_c(K+1:NZ)) - - PE_Column_0 = PE_MixedLayer_0+PE_Interior - - !Check if we did not have enough energy to mix the whole layer - if (PE_Column_0>PE_Column_Target) then - - ! - dz_mixed_0 = dz(k) - dz_max_incr = dz(k)*0.1 - - ! Guess the thickness of the amount that can be mixed: - Guess_fraction = 0.5 - dz_mixed_N = dZ(k)*Guess_fraction - - !Compute the PE if we mixed to the guessed thickness - Rho_MixedLayer_N = Rho_MixedLayer + Rho_c(k)*dz_mixed_N - H_MixedLayer_N = H_MixedLayer + dz_mixed_N - Zc_MixedLayer_N = 0.5 * (Surface - H_MixedLayer_N) - PE_MixedLayer_N = Rho_MixedLayer_N * Zc_MixedLayer_N - - ! The remaining thickness is not mixed - dz_below = dz(k)*(1.-Guess_fraction) - Zl_below = Z_L(k) - Zu_below = Z_L(k) + dz_below - - !Compute the PE of the fraction of the layer that wasn't mixed - call PE_Kernel(PE_below, 1, (/Zl_below/),(/zu_below/), & - (/Rho_c(k)/) ) - - PE_column_N = PE_MixedLayer_N + PE_below + PE_interior - ! There is a question if an iteration is the most efficient - ! way to solve this problem. The expression for the layer fraction that - ! is not mixed is cubic and the iteration converges fairly rapidly. - ! So the answer is tbd, but this simple iteration serves the purpose - ! for now. - do IT = 1,20 !Do the iteration up to 20 times - Not_Converged = (abs(PE_column_N-PE_column_target)>PE_Threshold(iM)) - if (Not_Converged) then - - A = PE_column_target - PE_column_N - B = PE_column_N - PE_column_0 - C = dz_mixed_N - dz_mixed_0 - - if (abs(b)>PE_threshold(iM)) then - dz_increment = (A*C)/B - else - dz_increment = sign(dz(k)*1.e-4,A) - endif - - if ( (dz_mixed_N+dz_increment > dz(k)) .or. & - (dz_mixed_N+dz_increment < 0.0) ) then - dz_increment = min(dz_max_incr,min(dz(k)-dz_mixed_n,dz_increment)) - dz_increment = max(-dz_max_incr,max(0.-dz_mixed_n,dz_increment)) - endif - - !Reset the _0's: - PE_column_0 = PE_column_N - dz_mixed_0 = dz_mixed_N - - !Compute the _N's: - ! Guess the thickness of the amount that can be mixed: - dz_mixed_N = dz_mixed_N + dz_increment - - !Compute the PE if we mixed to the guessed thickness - Rho_MixedLayer_N = Rho_MixedLayer + Rho_c(k)*dz_mixed_N - H_MixedLayer_N = H_MixedLayer + dz_mixed_N - Zc_MixedLayer_N = 0.5 * (Surface - H_MixedLayer_N) - PE_MixedLayer_N = Rho_MixedLayer_N * Zc_MixedLayer_N - - ! The remaining thickness is not mixed - dz_below = dz(k) - dz_mixed_N - Zl_below = Z_L(k) - Zu_below = Z_L(k) + dz_below - !Compute the PE of the fraction of the layer that wasn't mixed - call PE_Kernel(PE_below, 1, (/Zl_below/), (/zu_below/), & - (/Rho_c(k)/)) - - PE_column_N = PE_MixedLayer_N + PE_below + PE_interior - endif - enddo - H_MixedLayer = H_MixedLayer + dz_mixed_N - else - Rho_MixedLayer = Rho_MixedLayer_0 - H_MixedLayer = H_MixedLayer_0 - endif - mld(i,j,iM) = H_MixedLayer - enddo - endif + ! Initialize these for each columnwise 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 cummulative sum from top down + PE = PE + 0.5*rho_c(k)*(Z_U(k)**2-Z_L(k)**2) + + ! This is the depth and integral of density + H_ML_TST = H_ML + DZ(k) + RhoDZ_ML_TST = RhoDZ_ML + rho_c(k)*DZ(k) + + ! 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(k) ! The density of this layer + D2 = DZ(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(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**3+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(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 - enddo - enddo + else + MLD(i,j,:) = 0.0 + 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) - return end subroutine diagnoseMLDbyEnergy -!> Compute the integrated PE for a column, in J/m2/grav -subroutine PE_Kernel(PE, NK, Z_L, Z_U, Rho_c ) - integer :: NK - real, intent(in), dimension(NK) :: Z_L, Z_U, Rho_c - real, intent(out) :: PE - integer :: k - - PE = 0.0 - do k=1,NK - !PE_layer = int rho z dz = rho_layer int z dz = rho_layer 0.5 * (Z_U^2-Z_L^2) - PE = PE + (Rho_c(k))*0.5*(Z_U(k)**2-Z_L(k)**2) - enddo - - return -end subroutine PE_Kernel - !> 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. From d7b8e175067dbbd09bdff6e799868a0f056e3d7e Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Mon, 5 Oct 2020 14:50:38 -0400 Subject: [PATCH 052/336] Dimension: Diagnostic fixes This patch fixes the dimensional scaling of three diagnostics: - grid_Re_Ah - grid_Re_Kh - boundary_forcing_h_tendency The fix to `grid_Re_Ah` and `grid_Re_Kh` removes the `Kh_min` and `Ah_min` parameters, which could not be dimensionally scaled and replaces them with variables in the control structure. The minimum Laplacian and biharmonic viscosites are chosed to estimate the smallest viscosity which is capable to altering the velocity. We use `spacing(1.) * L^2N / T` where `spacing()` is the smallest difference in floating point. We use the minimum harmonic grid spacing, precomputed during initialization, rather than the local value, in order to avoid additional computation and memory access during timestepping. This will changes the value of grid_Re_[AK]h in certain isolated examples of negligible viscosity, but will otherwise avoid the possibility of divide-by-zero while also producing a realizable large value at near-inviscid upper limit. The second fix to `boundary_focing_h_tendency` had its T units set but not its H units. This patch fixes the dimensionality. These are required to fix the dimensional verification errors in PR 1210. --- .../lateral/MOM_hor_visc.F90 | 41 ++++++++++++++----- .../vertical/MOM_diabatic_driver.F90 | 4 +- 2 files changed, 33 insertions(+), 12 deletions(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 76fa656942..a4e2b32b80 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -93,6 +93,10 @@ module MOM_hor_visc !! depth is shallower than GME_H0 [Z ~> m] 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] real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: Kh_bg_xx !< The background Laplacian viscosity at h points [L2 T-1 ~> m2 s-1]. @@ -358,10 +362,6 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! calculation gives the same value as if f were 0 [nondim]. real :: H0_GME ! Depth used to scale down GME coefficient in shallow areas [Z ~> m] real :: KE ! Local kinetic energy [L2 T-2 ~> m2 s-2] - real, parameter :: KH_min = 1.E-30 ! This is the minimun horizontal Laplacian viscosity used to estimate the - ! grid Raynolds number [L2 T-1 ~> m2 s-1] - real, parameter :: AH_min = 1.E-30 ! This is the minimun horizontal Biharmonic viscosity used to estimate the - ! grid Raynolds number [L4 T-1 ~> m4 s-1] logical :: rescale_Kh, legacy_bound logical :: find_FrictWork @@ -877,7 +877,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if (CS%id_grid_Re_Kh>0) then KE = 0.125*((u(I,j,k)+u(I-1,j,k))**2 + (v(i,J,k)+v(i,J-1,k))**2) - grid_Re_Kh(i,j,k) = (sqrt(KE) * sqrt(CS%grid_sp_h2(i,j)))/MAX(Kh,KH_min) + grid_Re_Kh(i,j,k) = (sqrt(KE) * sqrt(CS%grid_sp_h2(i,j))) & + / max(Kh, CS%min_grid_Kh) endif if (CS%id_div_xx_h>0) div_xx_h(i,j,k) = div_xx(i,j) @@ -930,8 +931,9 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if ((CS%id_Ah_h>0) .or. find_FrictWork .or. CS%debug) Ah_h(i,j,k) = Ah if (CS%id_grid_Re_Ah>0) then - KE = 0.125*((u(I,j,k)+u(I-1,j,k))**2 + (v(i,J,k)+v(i,J-1,k))**2) - grid_Re_Ah(i,j,k) = (sqrt(KE) * CS%grid_sp_h3(i,j))/MAX(Ah,AH_min) + KE = 0.125*((u(I,j,k)+u(I-1,j,k))**2 + (v(i,J,k)+v(i,J-1,k))**2) + grid_Re_Ah(i,j,k) = (sqrt(KE) * CS%grid_sp_h3(i,j)) & + / max(Ah, CS%min_grid_Ah) endif str_xx(i,j) = str_xx(i,j) + Ah * & @@ -1430,6 +1432,8 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE, ADp) 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 @@ -1718,10 +1722,11 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE, ADp) "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%bound_Kh .or. CS%bound_Ah .or. CS%better_bound_Kh .or. CS%better_bound_Ah) & + if (CS%Laplacian .or. CS%biharmonic) & 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 if (CS%no_slip .and. CS%biharmonic) & call MOM_error(FATAL,"ERROR: NOSLIP and BIHARMONIC cannot be defined "// & "at the same time in MOM.") @@ -1860,6 +1865,8 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE, ADp) ! 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)) @@ -1881,7 +1888,9 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE, ADp) 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 + ! 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 @@ -1925,6 +1934,8 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE, ADp) 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) @@ -1949,7 +1960,9 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE, ADp) 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 + 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) @@ -1975,7 +1988,6 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE, ADp) endif ! The Laplacian bounds should avoid overshoots when CS%bound_coef < 1. if (CS%Laplacian .and. CS%better_bound_Kh) then - Idt = 1.0 / dt 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)) * & @@ -2004,7 +2016,6 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE, ADp) ! 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 - Idt = 1.0 / dt 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)) ) + & @@ -2104,6 +2115,11 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE, ADp) '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, & @@ -2123,6 +2139,11 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE, ADp) '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_GME_coeff_h = register_diag_field('ocean_model', 'GME_coeff_h', diag%axesTL, Time, & diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 62bfeb726d..3d3970f5b0 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -3575,8 +3575,8 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di units='m', conversion=GV%H_to_m, 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', 'm s-1', conversion=US%s_to_T, & - v_extensive = .true.) + 'Cell thickness tendency due to boundary forcing', 'm s-1', & + conversion=GV%H_to_m*US%s_to_T, v_extensive=.true.) if (CS%id_boundary_forcing_h_tendency > 0) then CS%boundary_forcing_tendency_diag = .true. endif From cb82761df2c54fa1d344e1f66a39fd6dc793b45d Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Mon, 5 Oct 2020 15:04:17 -0400 Subject: [PATCH 053/336] Bugfix: DT parsing in MOM_hor_visc The single-line if-block for reading the DT parameter did not contain the Idt = 1. / dt update. This patch amends this bug. --- src/parameterizations/lateral/MOM_hor_visc.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index a4e2b32b80..08b1fec20c 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -1722,11 +1722,12 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE, ADp) "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) & + 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.") From 44f64c057addb14d19058c90177b312586a8273d Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Tue, 6 Oct 2020 11:43:05 -0400 Subject: [PATCH 054/336] Add NoSt and ShSt diagnostic to openmp directives - New diagnostic variables were missing from parallel openmp directive so caused compilation errors in the Travis-CI test - https://travis-ci.com/github/ocean-eddy-cpt/MOM6/jobs/372199318#L2373-L2392 --- src/parameterizations/lateral/MOM_hor_visc.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index c4b89814ee..78d82fe311 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -484,7 +484,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, !$OMP diffu, diffv, max_diss_rate_h, max_diss_rate_q, & !$OMP Kh_h, Kh_q, Ah_h, Ah_q, FrictWork, FrictWork_GME, & !$OMP div_xx_h, vort_xy_q, GME_coeff_h, GME_coeff_q, & - !$OMP TD, KH_u_GME, KH_v_GME & + !$OMP TD, KH_u_GME, KH_v_GME, NoSt, ShSt & !$OMP ) & !$OMP private( & !$OMP i, j, k, n, & From 1c3a2015821135ae90117532fdd2c332e79ee4c0 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Tue, 6 Oct 2020 11:45:18 -0400 Subject: [PATCH 055/336] Correct dimensions of NoSt and ShSt diagnostics - The dimensions for NoSt and ShSt (s-1) were inverted which was detected in the dimensional test for T-scaling: - https://travis-ci.com/github/ocean-eddy-cpt/MOM6/jobs/372199318#L2093-L2106 --- src/parameterizations/lateral/MOM_hor_visc.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 78d82fe311..9246d06241 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -2066,10 +2066,10 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE, ADp) ! 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%T_to_s) + '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%T_to_s) + '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) From 7e1a1c916ed7cb080f4b0d351617b64ccb69b162 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Tue, 6 Oct 2020 13:14:23 -0400 Subject: [PATCH 056/336] Fixes for code compliance To fixes issues reported in https://travis-ci.com/github/ocean-eddy-cpt/MOM6/jobs/393643505#L600 - 2 trailing spaces - also noticed a mismatched indent --- src/core/MOM_variables.F90 | 2 +- src/diagnostics/MOM_diagnostics.F90 | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index 5a3a4fed65..b97d189ed4 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -173,7 +173,7 @@ module MOM_variables 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] + 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]. diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index b181622ac9..6c89776b1b 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -1042,7 +1042,7 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS if (CS%id_PE_to_KE > 0) call post_data(CS%id_PE_to_KE, CS%PE_to_KE, CS%diag) endif - if (associated(CS%KE_BT)) then + if (associated(CS%KE_BT)) then 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) @@ -2270,7 +2270,7 @@ subroutine MOM_diagnostics_end(CS, ADp) if (associated(CS%KE)) deallocate(CS%KE) if (associated(CS%dKE_dt)) deallocate(CS%dKE_dt) if (associated(CS%PE_to_KE)) deallocate(CS%PE_to_KE) - if (associated(CS%KE_BT)) deallocate(CS%KE_BT) + if (associated(CS%KE_BT)) deallocate(CS%KE_BT) if (associated(CS%KE_Coradv)) deallocate(CS%KE_Coradv) if (associated(CS%KE_adv)) deallocate(CS%KE_adv) if (associated(CS%KE_visc)) deallocate(CS%KE_visc) From b73ee1198ce8fc7d0dfce9d2c1617c2d1be89740 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Tue, 6 Oct 2020 13:19:10 -0400 Subject: [PATCH 057/336] Disable KE_BT diagnostic in unsplit mode - The diagnostic for the barotropic contribution to KE uses pointers to arrays that do not exist in the unsplit mode. This led to the fail at https://travis-ci.com/github/ocean-eddy-cpt/MOM6/jobs/393643506#L2018-L2019 - Added an `if (split)` around the KE_BT diagnostic registration. --- src/diagnostics/MOM_diagnostics.F90 | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 6c89776b1b..7ca2195ab7 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -1539,6 +1539,7 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag real :: wave_speed_tol ! The fractional tolerance for finding the wave speeds [nondim] 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 logical :: use_temperature, adiabatic logical :: default_2018_answers, remap_answers_2018 integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nz, nkml, nkbl @@ -1588,6 +1589,7 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag "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) + call get_param(param_file, mdl, "SPLIT", split, default=.true., do_not_log=.true.) if (GV%Boussinesq) then thickness_units = "m" ; flux_units = "m3 s-1" ; convert_H = GV%H_to_m @@ -1799,10 +1801,12 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag 'm3 s-3', conversion=GV%H_to_m*(US%L_T_to_m_s**2)*US%s_to_T) if (CS%id_PE_to_KE>0) call safe_alloc_ptr(CS%PE_to_KE,isd,ied,jsd,jed,nz) - 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) - if (CS%id_KE_BT>0) call safe_alloc_ptr(CS%KE_BT,isd,ied,jsd,jed,nz) + 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) + if (CS%id_KE_BT>0) call safe_alloc_ptr(CS%KE_BT,isd,ied,jsd,jed,nz) + endif CS%id_KE_Coradv = register_diag_field('ocean_model', 'KE_Coradv', diag%axesTL, Time, & 'Kinetic Energy Source from Coriolis and Advection', & From 8bf35415fc7852b2d3fef4b7a6f79e59efc0ef6d Mon Sep 17 00:00:00 2001 From: "brandon.reichl" Date: Tue, 6 Oct 2020 14:14:34 -0400 Subject: [PATCH 058/336] Delete spurious logical check --- src/parameterizations/vertical/MOM_diabatic_driver.F90 | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 52e469832e..e2fb3b6a3b 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -3448,8 +3448,6 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di 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)', & 'm', conversion=US%Z_to_m) - if ((CS%id_MLD_EN1>0) .or. (CS%id_MLD_EN2>0) .or. (CS%id_MLD_EN3>0)) then - endif CS%id_subMLN2 = register_diag_field('ocean_model', 'subML_N2', diag%axesT1, Time, & 'Squared buoyancy frequency below mixed layer', 's-2', conversion=US%s_to_T**2) CS%id_MLD_user = register_diag_field('ocean_model', 'MLD_user', diag%axesT1, Time, & From cbe88ae95796fed9bdf80eeb2f5c903130a584c5 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Tue, 6 Oct 2020 14:49:31 -0400 Subject: [PATCH 059/336] min_grid_sp_h[24] across PEs An additional `min_across_PEs` call is added to the min_grid_sp_h[24] calculations, to accommodate for parallel builds and ensure consistency across layouts. --- src/parameterizations/lateral/MOM_hor_visc.F90 | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 08b1fec20c..3c63564a30 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -4,6 +4,7 @@ module MOM_hor_visc ! This file is part of MOM6. See LICENSE.md for the license. use MOM_checksums, only : hchksum, Bchksum +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 : diag_ctrl, time_type use MOM_domains, only : pass_var, CORNER, pass_vector, AGRID, BGRID_NE @@ -1891,6 +1892,7 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE, ADp) 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 @@ -1963,6 +1965,7 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE, ADp) 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)) From bc5e023aa8191931b6beb98c04f73349f232785c Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 6 Oct 2020 18:53:07 -0400 Subject: [PATCH 060/336] (*)Add a halo update to fix VERTEX_SHEAR solutions Added halo update for fluxes%p_surf_full when VERTEX_SHEAR=true. This field is not used directly with the vertex shear code, but its halo regions are used in the frazil code when the diabatic solver is using slightly wider halos to work with the VERTEX_SHEAR option for shear mixing. Without this change, some cases using VERTEX_SHEAR=True were not reproducing across PE layout, whereas now they do. There is no flag to recover the old answers because the old answers were ill-defined. All answers in the MOM6-examples test suite are bitwise identical but there will be answer changes in some ice-ocean or coupled cases with VERTEX_SHEAR=True; these cases should now reproduce across PE layouts. --- src/core/MOM.F90 | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index e7a3e54c4e..0e736e7312 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -1250,10 +1250,13 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & call apply_oda_tracer_increments(US%T_to_s*dtdia,G,tv,h,CS%odaCS) endif - if (associated(fluxes%p_surf)) then + 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 - call pass_var(fluxes%p_surf, G%Domain, clock=id_clock_pass, halo=halo_sz) + 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 From fd0f22780b6ea54a9f2d238dffe453054f52ead9 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 15 Oct 2020 10:01:34 -0400 Subject: [PATCH 061/336] +Change default for SPONGE_IDAMP_VAR to enable PR Changed the default for SPONGE_IDAMP_VAR from "IDAMP" to "Idamp" so that when this variable is used, as it would be with the proposed change, it does not break any existing experiments. This could change some MOM_parameter_doc files, but will not change any solutions because the variable whose default is being set was not in use. --- src/initialization/MOM_state_initialization.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 1398ebe406..ceab948e2a 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -1773,7 +1773,7 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, param_file, C "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") + "SPONGE_DAMPING_FILE.", default="Idamp") call get_param(param_file, mdl, "USE_REGRIDDING", use_ALE, do_not_log = .true.) call get_param(param_file, mdl, "NEW_SPONGES", new_sponges, & From ca236a3917cb319a18f01ef5922479e6c49542a2 Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Fri, 16 Oct 2020 08:32:47 -0400 Subject: [PATCH 062/336] Sponge file init patch (#1222) * Cleanup sponge initialization from file. - Deprecating NEW_SPONGES parameter with TIME_SPACE_REGRID_SPONGE - Fixes intialization of ALE sponges with this option set to False * Change parameter name to INTERPOLATE_SPONGE_TIME_SPACE * Punctuation. * clean up sponge initialization Co-authored-by: Robert Hallberg Co-authored-by: Marshall Ward --- .../MOM_state_initialization.F90 | 154 ++++++++++-------- 1 file changed, 87 insertions(+), 67 deletions(-) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index ceab948e2a..7972b51fe4 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -1709,7 +1709,7 @@ end subroutine initialize_temp_salt_linear !! 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, param_file, CSp, ALE_CSp, Time) +subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, 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 @@ -1717,7 +1717,7 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, param_file, C 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(sponge_CS), pointer :: CSp !< A pointer that is set to point to the control + 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). @@ -1731,6 +1731,7 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, param_file, C tmp, tmp2 ! A temporary array for tracers. real, dimension (SZI_(G),SZJ_(G)) :: & tmp_2d ! A temporary array for tracers. + real, allocatable, dimension(:,:,:) :: tmp_tr ! A temporary array for reading sponge fields real :: Idamp(SZI_(G),SZJ_(G)) ! The inverse damping rate [T-1 ~> s-1]. real :: pres(SZI_(G)) ! An array of the reference pressure [R L2 T-2 ~> Pa]. @@ -1746,8 +1747,10 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, param_file, C 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 - logical :: new_sponges ! True if using the newer sponges which do not - ! need to reside on the model horizontal grid. + logical :: time_space_interp_sponge ! True if using sponge data which + ! need to be interpolated from 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 = G%ke isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -1775,25 +1778,28 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, param_file, C "The name of the inverse damping rate variable in "//& "SPONGE_DAMPING_FILE.", default="Idamp") call get_param(param_file, mdl, "USE_REGRIDDING", use_ALE, do_not_log = .true.) - - call get_param(param_file, mdl, "NEW_SPONGES", new_sponges, & + time_space_interp_sponge = .false. + call get_param(param_file, mdl, "NEW_SPONGES", time_space_interp_sponge, & "Set True if using the newer sponging code which "//& "performs on-the-fly regridding in lat-lon-time.",& "of sponge restoring data.", default=.false.) - -! if (use_ALE) then -! call get_param(param_file, mdl, "SPONGE_RESTORE_ETA", restore_eta, & -! "If true, then restore the interface positions towards "//& -! "target values (in ALE mode)", default = .false.) -! endif + if (time_space_interp_sponge) then + call MOM_error(WARNING, " initialize_sponges: NEW_SPONGES has been deprecated. "//& + "Please use INTERPOLATE_SPONGE_TIME_SPACE instead. Setting "//& + "INTERPOLATE_SPONGE_TIME_SPACE = True.") + endif + call get_param(param_file, mdl, "INTERPOLATE_SPONGE_TIME_SPACE", time_space_interp_sponge, & + "Set True if using the newer sponging code which "//& + "performs on-the-fly regridding in lat-lon-time.",& + "of sponge restoring data.", default=time_space_interp_sponge) 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 (new_sponges .and. .not. use_ALE) & - call MOM_error(FATAL, " initialize_sponges: Newer sponges are currently unavailable in layered mode ") + 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) @@ -1806,9 +1812,9 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, param_file, C if (.not.file_exists(filename, G%Domain)) & call MOM_error(FATAL, " initialize_sponges: Unable to open "//trim(filename)) - ! The first call to set_up_sponge_field is for the interface heights if in layered mode.! 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)); eta(:,:,:) = 0.0 call MOM_read_data(filename, eta_var, eta(:,:,:), G%Domain, scale=US%m_to_Z) @@ -1821,72 +1827,86 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, param_file, C enddo ; enddo ; enddo ! Set the inverse 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, CSp, GV) + call initialize_sponge(Idamp, eta, G, param_file, Layer_CSp, GV) deallocate(eta) - elseif (.not. new_sponges) then ! ALE mode - 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.") + 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) -! ALE_CSp%time_dependent_target = .false. -! if (siz(4) > 1) ALE_CSp%time_dependent_target = .true. - nz_data = siz(3)-1 - allocate(eta(isd:ied,jsd:jed,nz_data+1)) - allocate(h(isd:ied,jsd:jed,nz_data)) + call MOM_read_data(filename, potemp_var, tmp(:,:,:), G%Domain) + call MOM_read_data(filename, salin_var, tmp2(:,:,:), G%Domain) - call MOM_read_data(filename, eta_var, eta(:,:,:), G%Domain, scale=US%m_to_Z) + do j=js,je + call calculate_density(tmp(:,j,1), tmp2(:,j,1), pres, tmp_2d(:,j), tv%eqn_of_state, EOSdom) + enddo - do j=js,je ; do i=is,ie - eta(i,j,nz+1) = -G%bathyT(i,j) - enddo ; 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) + call set_up_sponge_field(tmp, tv%T, G, nz, Layer_CSp) + call MOM_read_data(filename, salin_var, tmp(:,:,:), G%Domain) + call set_up_sponge_field(tmp, tv%S, G, nz, Layer_CSp) + endif - 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 - do k=1,nz; do j=js,je ; do i=is,ie - h(i,j,k) = GV%Z_to_H*(eta(i,j,k)-eta(i,j,k+1)) - enddo ; enddo ; enddo - call initialize_ALE_sponge(Idamp, G, param_file, ALE_CSp, h, nz_data) - deallocate(eta) - deallocate(h) - else - ! Initialize sponges without supplying sponge grid - call initialize_ALE_sponge(Idamp, G, param_file, ALE_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. - if ( GV%nkml>0 .and. .not. new_sponges) 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) + if (use_ALE) then + if (.not. time_space_interp_sponge) then ! ALE mode + 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(h(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+1) = -G%bathyT(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 + do k=1,nz; do j=js,je ; do i=is,ie + h(i,j,k) = GV%Z_to_H*(eta(i,j,k)-eta(i,j,k+1)) + enddo ; enddo ; enddo + call initialize_ALE_sponge(Idamp, G, param_file, ALE_CSp, h, nz_data) + deallocate(eta) + deallocate(h) + if (use_temperature) then + allocate(tmp_tr(isd:ied,jsd:jed,nz_data)) + call MOM_read_data(filename, potemp_var, tmp_tr(:,:,:), G%Domain) + call set_up_ALE_sponge_field(tmp_tr, G, tv%T, ALE_CSp) + call MOM_read_data(filename, salin_var, tmp_tr(:,:,:), G%Domain) + call set_up_ALE_sponge_field(tmp_tr, G, tv%S, ALE_CSp) + deallocate(tmp_tr) + endif + else + ! Initialize sponges without supplying sponge grid + call initialize_ALE_sponge(Idamp, G, param_file, ALE_CSp) + ! 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) + call set_up_ALE_sponge_field(filename, salin_var, Time, G, GV, US, tv%S, ALE_CSp) + endif + endif - call MOM_read_data(filename, potemp_var, tmp(:,:,:), G%Domain) - call MOM_read_data(filename, salin_var, tmp2(:,:,:), G%Domain) - 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, CSp) endif - ! The remaining calls to set_up_sponge_field can be in any order. - if ( use_temperature .and. .not. new_sponges) then - call MOM_read_data(filename, potemp_var, tmp(:,:,:), G%Domain) - call set_up_sponge_field(tmp, tv%T, G, nz, CSp) - call MOM_read_data(filename, salin_var, tmp(:,:,:), G%Domain) - call set_up_sponge_field(tmp, tv%S, G, nz, CSp) - elseif (use_temperature) then - call set_up_ALE_sponge_field(filename, potemp_var, Time, G, GV, US, tv%T, ALE_CSp) - call set_up_ALE_sponge_field(filename, salin_var, Time, G, GV, US, tv%S, ALE_CSp) - endif end subroutine initialize_sponges_file From 136afce0b872a996289da2b50b6af8dc59d64365 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 16 Oct 2020 15:42:18 -0400 Subject: [PATCH 063/336] Change bounding of Kv_BBL and bbl_thick in set_viscous_BBL() (#1223) * set_viscous_BBL() expanded comments and small refactor - Added lots of comments explaining method/equations - Small refactor code to reduce duplicated code a smidge but really in preparation for a later solution changing fix - Also removed unused diagnostic ids frin MOM_vert_friction.F90 * Added doxygen for viscous BBL - Wrote out equations being solve with reference to model parameters. Includes references. * Update to non-English spelling of bottom-most - This must be a side effect of Brexit * Corrects kv_BBL for some limits of BBL thickness - The BBL viscosity used to be simply bounded to be no less than a minimum, KV_BBL_MIN. In some limits where the BBL thickness was smaller than the bottom layer thickness, this viscosity led to too much drag on the bottom layer. - If CORRECT_BBL_BOUNDS=True we now also adjust bbl_thick when bounding Kv_bbl so that the implied stress, viscosity and thickness are all consistent. - By default, CORRECT_BBL_BOUNDS=False so that existing answers are unchanged. Co-authored-by: Robert Hallberg --- .../vertical/MOM_set_viscosity.F90 | 250 ++++++++++++++---- .../vertical/MOM_vert_friction.F90 | 2 +- 2 files changed, 205 insertions(+), 47 deletions(-) diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index 02fa647e7e..cbca9ac6bf 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -43,12 +43,15 @@ module MOM_set_visc !> Control structure for MOM_set_visc type, public :: set_visc_CS ; private - real :: Hbbl !< The static bottom boundary layer thickness [H ~> m or kg m-2] + real :: Hbbl !< The static bottom boundary layer thickness [H ~> m or kg m-2]. + !! Runtime parameter `HBBL`. real :: cdrag !< The quadratic drag coefficient. + !! Runtime parameter `CDRAG`. real :: c_Smag !< The Laplacian Smagorinsky coefficient for !! calculating the drag in channels. real :: drag_bg_vel !< An assumed unresolved background velocity for !! calculating the bottom drag [L T-1 ~> m s-1]. + !! Runtime parameter `DRAG_BG_VEL`. real :: BBL_thick_min !< The minimum bottom boundary layer thickness [H ~> m or kg m-2]. !! This might be Kv / (cdrag * drag_bg_vel) to give !! Kv as the minimum near-bottom viscosity. @@ -60,14 +63,18 @@ module MOM_set_visc 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 + !! actual velocity in the bottommost `HBBL`, depending !! on whether linear_drag is true. + !! Runtime parameter `BOTTOMDRAGLAW`. 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. + 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. + 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. @@ -87,7 +94,7 @@ module MOM_set_visc !! 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 + !! 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 @@ -108,13 +115,80 @@ module MOM_set_visc contains !> Calculates the thickness of the bottom boundary layer and the viscosity within that 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 Killworth and Edwards, JPO 1999. It is not necessary to -!! calculate the thickness and viscosity every time step; instead -!! previous values may be used. +!! +!! 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 Killworth and Edwards, JPO 1999. It is not necessary to calculate the +!! thickness and viscosity every time step; instead previous values may be used. +!! +!! \section set_viscous_BBL Viscous Bottom Boundary Layer +!! +!! 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 Killworth and Edwards, 1999 (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 Zilitinkevich and Mironov, 1996. +!! +!! 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 . +!! +!! \todo Channel drag needs to be explained +!! +!! 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$. +!! +!! \subsection set_viscous_BBL_ref References +!! +!! \arg Killworth, P. D., and N. R. Edwards, 1999: +!! A Turbulent Bottom Boundary Layer Code for Use in Numerical Ocean Models. +!! J. Phys. Oceanogr., 29, 1221-1238, +!! doi:10.1175/1520-0485(1999)029<1221:ATBBLC>2.0.CO;2 +!! \arg Zilitinkevich, S., Mironov, D.V., 1996: +!! A multi-limit formulation for the equilibrium depth of a stably stratified boundary layer. +!! Boundary-Layer Meteorology 81, 325-351. +!! doi:10.1007/BF02430334 +!! subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. @@ -191,6 +265,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) ! the present layer [H ~> m or kg m-2]. real :: bbl_thick ! The thickness of the bottom boundary layer [H ~> m or kg m-2]. real :: bbl_thick_Z ! The thickness of the bottom boundary layer [Z ~> m]. + real :: kv_bbl ! The bottom boundary layer viscosity [Z2 T-1 ~> m2 s-1]. real :: C2f ! C2f = 2*f at velocity points [T-1 ~> s-1]. real :: U_bg_sq ! The square of an assumed background @@ -384,6 +459,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) do j=Jsq,Jeq ; do m=1,2 if (m==1) then + ! m=1 refers to u-points if (j 0) do_i(i) = .true. enddo else + ! m=2 refers to v-points is = G%isc ; ie = G%iec do i=is,ie do_i(i) = .false. @@ -398,13 +475,17 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) enddo endif - if (m==1) then + ! 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) 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)) endif endif @@ -417,13 +498,15 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) 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 - else + 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) 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)) endif endif @@ -503,10 +586,10 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) endif ; endif if (use_BBL_EOS .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 -! This block of code calculates the mean velocity magnitude over -! the bottommost CS%Hbbl of the water column for determining -! the quadratic bottom drag. htot_vel = 0.0 ; hwtot = 0.0 ; hutot = 0.0 Thtot = 0.0 ; Shtot = 0.0 do k=nz,1,-1 @@ -543,6 +626,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) endif enddo ! end of k loop + ! Set u* based on u*^2 = Cdrag u_bbl^2 if (.not.CS%linear_drag .and. (hwtot > 0.0)) then ustar(i) = cdrag_sqrt_Z*hutot/hwtot else @@ -555,6 +639,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) 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 @@ -581,35 +666,51 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) (/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<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) else + ! Use only part of the layer Dh = h_at_vel(i,k) * sqrt((ustarsq-oldfn) / (Dfn)) endif + ! Increment total BBL thickness and cumulative T and S htot = htot + Dh Thtot = Thtot + T_vel(i,k)*Dh ; Shtot = Shtot + S_vel(i,k)*Dh enddo @@ -658,13 +759,21 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) endif endif ! use_BBL_EOS -! The Coriolis limit is 0.5*ustar/f. The buoyancy limit here is htot. -! The bottom boundary layer thickness is found by solving the same -! equation as in Killworth and Edwards: (h/h_f)^2 + h/h_N = 1. - + ! 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. @@ -672,19 +781,28 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) if (htot*ustH <= (CS%BBL_thick_min+h_neglect) * (0.5*ustH + root)) then bbl_thick = CS%BBL_thick_min else + ! The following expression reads + ! h_bbl = h_N u* / ( 1/2 u* + sqrt( 1/4 u*^2 + ( 2 f h_N )^2 ) ) + ! which is h_bbl = h_N u*/(xp u*) as described above. bbl_thick = (htot * ustH) / (0.5*ustH + root) endif else + ! The following expression reads + ! h_bbl = h_N / ( 1/2 + sqrt( 1/4 + ( 2 f h_N / u* )^2 ) ) + ! which is h_bbl = h_N/xp as described above. bbl_thick = htot / (0.5 + sqrt(0.25 + htot*htot*C2f*C2f/ & ((ustar(i)*ustar(i)) * (GV%Z_to_H**2)) ) ) if (bbl_thick < CS%BBL_thick_min) bbl_thick = CS%BBL_thick_min endif -! 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. + + ! 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%Hbbl acts as an upper bound on + ! bbl_thick. if ((bbl_thick > 0.5*CS%Hbbl) .and. (CS%RiNo_mix)) bbl_thick = 0.5*CS%Hbbl if (CS%Channel_drag) then @@ -900,29 +1018,65 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) enddo ! k loop to determine L(K). + ! Set the near-bottom viscosity to a value which will give + ! the correct stress when the shear occurs over bbl_thick. + ! See next block for explanation. bbl_thick_Z = bbl_thick * GV%H_to_Z - if (m==1) then - visc%Kv_bbl_u(I,j) = max(CS%Kv_BBL_min, & - cdrag_sqrt*ustar(i)*bbl_thick_Z*BBL_visc_frac) - visc%bbl_thick_u(I,j) = bbl_thick_Z + if (CS%correct_BBL_bounds .and. & + cdrag_sqrt*ustar(i)*bbl_thick_Z*BBL_visc_frac <= CS%Kv_BBL_min) then + ! If the bottom stress implies less viscosity than Kv_BBL_min then + ! set kv_bbl to the bound and recompute bbl_thick to be consistent + ! but with a ridiculously large upper bound on thickness (for Cd u*=0) + kv_bbl = CS%Kv_BBL_min + if (cdrag_sqrt*ustar(i)*BBL_visc_frac*G%Rad_Earth*US%m_to_Z > kv_bbl) then + bbl_thick_Z = kv_bbl / ( cdrag_sqrt*ustar(i)*BBL_visc_frac ) + else + bbl_thick_Z = G%Rad_Earth * US%m_to_Z + endif else - visc%Kv_bbl_v(i,J) = max(CS%Kv_BBL_min, & - cdrag_sqrt*ustar(i)*bbl_thick_Z*BBL_visc_frac) - visc%bbl_thick_v(i,J) = bbl_thick_Z + kv_bbl = cdrag_sqrt*ustar(i)*bbl_thick_Z*BBL_visc_frac endif else ! Not Channel_drag. -! Here the near-bottom viscosity is set to a value which will give -! the correct stress when the shear occurs over bbl_thick. + ! 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%Hbbl + ! - The viscous stress kv_bbl du/dz should balance tau_b + ! Cdrag u_bbl^2 = kv_bbl du/dz + ! = 2 kv_bbl u_bbl + ! so + ! kv_bbl = 0.5 h_bbl Cdrag u_bbl + ! = 0.5 h_bbl sqrt(Cdrag) u* bbl_thick_Z = bbl_thick * GV%H_to_Z - if (m==1) then - visc%Kv_bbl_u(I,j) = max(CS%Kv_BBL_min, cdrag_sqrt*ustar(i)*bbl_thick_Z) - visc%bbl_thick_u(I,j) = bbl_thick_Z + if (CS%correct_BBL_bounds .and. & + cdrag_sqrt*ustar(i)*bbl_thick_Z <= CS%Kv_BBL_min) then + ! If the bottom stress implies less viscosity than Kv_BBL_min then + ! set kv_bbl to the bound and recompute bbl_thick to be consistent + ! but with a ridiculously large upper bound on thickness (for Cd u*=0) + kv_bbl = CS%Kv_BBL_min + if (cdrag_sqrt*ustar(i)*G%Rad_Earth*US%m_to_Z > kv_bbl) then + bbl_thick_Z = kv_bbl / ( cdrag_sqrt*ustar(i) ) + else + bbl_thick_Z = G%Rad_Earth * US%m_to_Z + endif else - visc%Kv_bbl_v(i,J) = max(CS%Kv_BBL_min, cdrag_sqrt*ustar(i)*bbl_thick_Z) - visc%bbl_thick_v(i,J) = bbl_thick_Z + kv_bbl = cdrag_sqrt*ustar(i)*bbl_thick_Z endif endif + kv_bbl = max(CS%Kv_BBL_min, kv_bbl) + if (m==1) then + visc%Kv_bbl_u(I,j) = kv_bbl + visc%bbl_thick_u(I,j) = bbl_thick_Z + else + visc%Kv_bbl_v(i,J) = kv_bbl + visc%bbl_thick_v(i,J) = bbl_thick_Z + endif endif ; enddo ! end of i loop enddo ; enddo ! end of m & j loops @@ -2037,6 +2191,10 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS 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=Kv_background, scale=US%m2_s_to_Z2_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, default=-1.0) diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index 1a4fb58e02..7786bf5b46 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -122,7 +122,7 @@ module MOM_vert_friction !>@{ Diagnostic identifiers integer :: id_du_dt_visc = -1, id_dv_dt_visc = -1, id_au_vv = -1, id_av_vv = -1 integer :: id_h_u = -1, id_h_v = -1, id_hML_u = -1 , id_hML_v = -1 - integer :: id_Ray_u = -1, id_Ray_v = -1, id_taux_bot = -1, id_tauy_bot = -1 + integer :: id_taux_bot = -1, id_tauy_bot = -1 integer :: id_Kv_slow = -1, id_Kv_u = -1, id_Kv_v = -1 ! integer :: id_hf_du_dt_visc = -1, id_hf_dv_dt_visc = -1 integer :: id_hf_du_dt_visc_2d = -1, id_hf_dv_dt_visc_2d = -1 From 449d568fec24bf0f68a0b3110b3742985d63568e Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 18 Oct 2020 09:28:31 -0400 Subject: [PATCH 064/336] +Eliminated sfc_bkgnd_mixing Merged the calculations in sfc_bkgnd_mixing into calculate_bkgnd_mixing, changed some of the arguments to calculate_bkgnd_mixing, and moved the diagnostics in MOM_bkgnd_mixing to MOM_set_diffusivity to reduce the use of elements of a control structure across modules. Also made the Kd_lay arguments to some of the internal subroutines in MOM_set_diffusivity optional. All answers are bitwise identical. --- .../vertical/MOM_bkgnd_mixing.F90 | 169 +++++++----------- .../vertical/MOM_set_diffusivity.F90 | 113 +++++++----- 2 files changed, 133 insertions(+), 149 deletions(-) diff --git a/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 b/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 index 6ad6337e28..308a7c9e83 100644 --- a/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 +++ b/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 @@ -27,7 +27,6 @@ module MOM_bkgnd_mixing public bkgnd_mixing_init public bkgnd_mixing_end public calculate_bkgnd_mixing -public sfc_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 @@ -96,12 +95,9 @@ module MOM_bkgnd_mixing !! as in the original version, concentrates buoyancy work in regions of strong stratification. logical :: bulkmixedlayer !< If true, a refined bulk mixed layer scheme is used logical :: debug !< If true, turn on debugging in this module - ! Daignostic handles and pointers + ! Diagnostic handles and pointers type(diag_ctrl), pointer :: diag => NULL() !< A structure that regulates diagnostic output - integer :: id_kd_bkgnd = -1 !< Diagnotic IDs - integer :: id_kv_bkgnd = -1 !< Diagnostic IDs - real, allocatable, dimension(:,:) :: Kd_sfc !< surface value of the diffusivity [Z2 T-1 ~> m2 s-1] ! Diagnostics arrays real, allocatable, dimension(:,:,:) :: kd_bkgnd !< Background diffusivity [Z2 T-1 ~> m2 s-1] real, allocatable, dimension(:,:,:) :: kv_bkgnd !< Background viscosity [Z2 s-1 ~> m2 s-1] @@ -285,8 +281,7 @@ subroutine bkgnd_mixing_init(Time, G, GV, US, param_file, diag, CS) 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, & + 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 "//& @@ -306,71 +301,12 @@ subroutine bkgnd_mixing_init(Time, G, GV, US, param_file, diag, CS) ! allocate arrays and set them to zero allocate(CS%Kd_bkgnd(SZI_(G), SZJ_(G), SZK_(G)+1)); CS%kd_bkgnd(:,:,:) = 0. allocate(CS%kv_bkgnd(SZI_(G), SZJ_(G), SZK_(G)+1)); CS%kv_bkgnd(:,:,:) = 0. - allocate(CS%Kd_sfc(SZI_(G), SZJ_(G))); CS%Kd_sfc(:,:) = 0. ! Register diagnostics CS%diag => diag - CS%id_kd_bkgnd = register_diag_field('ocean_model', 'Kd_bkgnd', diag%axesTi, Time, & - 'Background diffusivity added by MOM_bkgnd_mixing module', 'm2/s', conversion=US%Z2_T_to_m2_s) - CS%id_kv_bkgnd = register_diag_field('ocean_model', 'Kv_bkgnd', diag%axesTi, Time, & - 'Background viscosity added by MOM_bkgnd_mixing module', 'm2/s', conversion=US%Z2_T_to_m2_s) end subroutine bkgnd_mixing_init -!> Get surface vertical background diffusivities/viscosities. -subroutine sfc_bkgnd_mixing(G, US, CS) - - type(ocean_grid_type), intent(in) :: G !< Grid structure. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(bkgnd_mixing_cs), pointer, intent(inout) :: CS !< The control structure returned by - !! a previous call to bkgnd_mixing_init. - ! local variables - real :: I_x30 !< 2/acos(2) = 1/(sin(30 deg) * acosh(1/sin(30 deg))) - real :: deg_to_rad !< factor converting degrees to radians, pi/180. - real :: abs_sin !< absolute value of sine of latitude [nondim] - real :: epsilon - integer :: i, j, k, is, ie, js, je - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - - ! set some parameters - deg_to_rad = atan(1.0)/45.0 ! = PI/180 - epsilon = 1.e-10 - - - if (.not. (CS%Bryan_Lewis_diffusivity .or. CS%horiz_varying_background)) then -!$OMP parallel do default(none) shared(is,ie,js,je,CS) - do j=js,je ; do i=is,ie - CS%Kd_sfc(i,j) = CS%Kd - enddo ; enddo - endif - - if (CS%Henyey_IGW_background) then - I_x30 = 2.0 / invcosh(CS%N0_2Omega*2.0) ! This is evaluated at 30 deg. -!$OMP parallel do default(none) & -!$OMP shared(is,ie,js,je,CS,G,deg_to_rad,epsilon,I_x30) & -!$OMP private(abs_sin) - do j=js,je ; do i=is,ie - abs_sin = abs(sin(G%geoLatT(i,j)*deg_to_rad)) - CS%Kd_sfc(i,j) = max(CS%Kd_min, CS%Kd_sfc(i,j) * & - ((abs_sin * invcosh(CS%N0_2Omega/max(epsilon,abs_sin))) * I_x30) ) - enddo ; enddo - elseif (CS%Kd_tanh_lat_fn) then -!$OMP parallel do default(none) shared(is,ie,js,je,CS,G) - do j=js,je ; 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. - CS%Kd_sfc(i,j) = max(CS%Kd_min, CS%Kd_sfc(i,j) * (1.0 + & - CS%Kd_tanh_lat_scale * 0.5*tanh((abs(G%geoLatT(i,j)) - 35.0)/5.0) )) - enddo ; enddo - endif - - if (CS%debug) call hchksum(CS%Kd_sfc,"After sfc_bkgnd_mixing: Kd_sfc",G%HI,haloshift=0, scale=US%Z2_T_to_m2_s) - -end subroutine sfc_bkgnd_mixing - - !> Calculates the vertical background diffusivities/viscosities subroutine calculate_bkgnd_mixing(h, tv, N2_lay, Kd_lay, Kv, j, G, GV, US, CS) @@ -381,7 +317,7 @@ subroutine calculate_bkgnd_mixing(h, tv, N2_lay, Kd_lay, Kv, j, G, GV, US, CS) type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure. real, dimension(SZI_(G),SZK_(G)), intent(in) :: N2_lay !< squared buoyancy frequency associated !! with layers [T-2 ~> s-2] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: Kd_lay !< Diapycnal diffusivity of each layer + real, dimension(SZI_(G),SZK_(G)), intent(out) :: Kd_lay !< Diapycnal diffusivity of each layer !! [Z2 T-1 ~> m2 s-1]. real, dimension(:,:,:), pointer :: Kv !< The "slow" vertical viscosity at each interface !! (not layer!) [Z2 T-1 ~> m2 s-1] @@ -390,10 +326,11 @@ subroutine calculate_bkgnd_mixing(h, tv, N2_lay, Kd_lay, Kv, j, G, GV, US, CS) !! a previous call to bkgnd_mixing_init. ! local variables - real, dimension(SZK_(G)+1) :: depth_int !< distance from surface of the interfaces [m] + real, dimension(SZK_(G)+1) :: depth_int !< Distance from surface of the interfaces [m] real, dimension(SZK_(G)+1) :: Kd_col !< Diffusivities at the interfaces [m2 s-1] real, dimension(SZK_(G)+1) :: Kv_col !< Viscosities at the interfaces [m2 s-1] - real, dimension(SZI_(G)) :: depth !< distance from surface of an interface [Z ~> m] + real, dimension(SZI_(G)) :: Kd_sfc !< Surface value of the diffusivity [Z2 T-1 ~> m2 s-1] + real, dimension(SZI_(G)) :: depth !< Distance from surface of an interface [Z ~> m] real :: depth_c !< depth of the center of a layer [Z ~> m] real :: I_Hmix !< inverse of fixed mixed layer thickness [Z-1 ~> m-1] real :: I_2Omega !< 1/(2 Omega) [T ~> s] @@ -401,8 +338,8 @@ subroutine calculate_bkgnd_mixing(h, tv, N2_lay, Kd_lay, Kv, j, G, GV, US, CS) 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))) real :: deg_to_rad !< factor converting degrees to radians, pi/180. - real :: abs_sin !< absolute value of sine of latitude [nondim] - real :: epsilon ! The minimum value of the sine of latitude [nondim] + real :: abs_sinlat !< absolute value of sine of latitude [nondim] + real :: min_sinlat ! The minimum value of the sine of latitude [nondim] real :: bckgrnd_vdc_psin !< PSI diffusivity in northern hemisphere [Z2 T-1 ~> m2 s-1] real :: bckgrnd_vdc_psis !< PSI diffusivity in southern hemisphere [Z2 T-1 ~> m2 s-1] integer :: i, k, is, ie, js, je, nz @@ -411,7 +348,34 @@ subroutine calculate_bkgnd_mixing(h, tv, N2_lay, Kd_lay, Kv, j, G, GV, US, CS) ! set some parameters deg_to_rad = atan(1.0)/45.0 ! = PI/180 - epsilon = 1.e-10 + min_sinlat = 1.e-10 + + ! Start with a constant value that may be replaced below. + Kd_lay(:,:) = CS%Kd + + if (.not. (CS%Bryan_Lewis_diffusivity .or. CS%horiz_varying_background)) then + do i=is,ie + Kd_sfc(i) = CS%Kd + enddo + + 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 + endif + if (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 + endif + endif ! Set up the background diffusivity. if (CS%Bryan_Lewis_diffusivity) then @@ -439,26 +403,10 @@ subroutine calculate_bkgnd_mixing(h, tv, N2_lay, Kd_lay, Kv, j, G, GV, US, CS) CS%Kd_bkgnd(i,j,K) = US%m2_s_to_Z2_T*Kd_col(K) enddo do k=1,nz - Kd_lay(i,j,k) = Kd_lay(i,j,k) + 0.5 * US%m2_s_to_Z2_T * (Kd_col(K) + Kd_col(K+1)) + Kd_lay(i,k) = Kd_lay(i,k) + 0.5 * US%m2_s_to_Z2_T * (Kd_col(K) + Kd_col(K+1)) enddo enddo ! i loop - elseif ((.not. CS%Bryan_Lewis_diffusivity) .and. (.not.CS%bulkmixedlayer) .and. & - (.not. CS%horiz_varying_background) .and. (CS%Kd /= CS%Kdml)) then - I_Hmix = 1.0 / (CS%Hmix + GV%H_subroundoff*GV%H_to_Z) - do i=is,ie ; depth(i) = 0.0 ; enddo - do k=1,nz ; do i=is,ie - depth_c = depth(i) + 0.5*GV%H_to_Z*h(i,j,k) - if (depth_c <= CS%Hmix) then ; CS%Kd_bkgnd(i,j,k) = CS%Kdml - elseif (depth_c >= 2.0*CS%Hmix) then ; CS%Kd_bkgnd(i,j,k) = CS%Kd_sfc(i,j) - else - Kd_lay(i,j,k) = ((CS%Kd_sfc(i,j) - CS%Kdml) * I_Hmix) * depth_c + & - (2.0*CS%Kdml - CS%Kd_sfc(i,j)) - endif - - depth(i) = depth(i) + GV%H_to_Z*h(i,j,k) - enddo ; enddo - elseif (CS%horiz_varying_background) then !### Note that there are lots of hard-coded parameters (mostly latitudes and longitudes) here. do i=is,ie @@ -499,24 +447,39 @@ subroutine calculate_bkgnd_mixing(h, tv, N2_lay, Kd_lay, Kv, j, G, GV, US, CS) CS%kv_bkgnd(i,j,:) = CS%Kd_bkgnd(i,j,:) * CS%prandtl_bkgnd ! Update Kd (uniform profile; no interpolation needed) - Kd_lay(i,j,:) = CS%Kd_bkgnd(i,j,1) + Kd_lay(i,:) = CS%Kd_bkgnd(i,j,1) enddo + elseif ((.not.CS%bulkmixedlayer) .and. (CS%Kd /= CS%Kdml)) then + I_Hmix = 1.0 / (CS%Hmix + GV%H_subroundoff*GV%H_to_Z) + do i=is,ie ; depth(i) = 0.0 ; enddo + do k=1,nz ; do i=is,ie + depth_c = depth(i) + 0.5*GV%H_to_Z*h(i,j,k) + if (depth_c <= CS%Hmix) then ; CS%Kd_bkgnd(i,j,k) = CS%Kdml + elseif (depth_c >= 2.0*CS%Hmix) then ; CS%Kd_bkgnd(i,j,k) = Kd_sfc(i) + else + Kd_lay(i,k) = ((Kd_sfc(i) - CS%Kdml) * I_Hmix) * depth_c + & + (2.0*CS%Kdml - Kd_sfc(i)) + endif + + depth(i) = depth(i) + GV%H_to_Z*h(i,j,k) + enddo ; enddo + elseif (CS%Henyey_IGW_background_new) then I_x30 = 2.0 / invcosh(CS%N0_2Omega*2.0) ! This is evaluated at 30 deg. I_2Omega = 0.5 / CS%omega do k=1,nz ; do i=is,ie - abs_sin = max(epsilon, abs(sin(G%geoLatT(i,j)*deg_to_rad))) - N_2Omega = max(abs_sin, sqrt(N2_lay(i,k))*I_2Omega) + abs_sinlat = max(min_sinlat, abs(sin(G%geoLatT(i,j)*deg_to_rad))) + N_2Omega = max(abs_sinlat, sqrt(N2_lay(i,k))*I_2Omega) N02_N2 = (CS%N0_2Omega/N_2Omega)**2 - Kd_lay(i,j,k) = max(CS%Kd_min, CS%Kd_sfc(i,j) * & - ((abs_sin * invcosh(N_2Omega/abs_sin)) * I_x30)*N02_N2) + Kd_lay(i,k) = max(CS%Kd_min, CS%Kd * & + ((abs_sinlat * invcosh(N_2Omega/abs_sinlat)) * I_x30)*N02_N2) enddo ; enddo else do k=1,nz ; do i=is,ie - Kd_lay(i,j,k) = CS%Kd_sfc(i,j) + Kd_lay(i,k) = Kd_sfc(i) enddo ; enddo endif @@ -525,17 +488,17 @@ subroutine calculate_bkgnd_mixing(h, tv, N2_lay, Kd_lay, Kv, j, G, GV, US, CS) do i=is,ie CS%kd_bkgnd(i,j,1) = 0.0; CS%kv_bkgnd(i,j,1) = 0.0 CS%kd_bkgnd(i,j,nz+1) = 0.0; CS%kv_bkgnd(i,j,nz+1) = 0.0 - do k=2,nz - CS%Kd_bkgnd(i,j,k) = 0.5*(Kd_lay(i,j,K-1) + Kd_lay(i,j,K)) - CS%Kv_bkgnd(i,j,k) = CS%Kd_bkgnd(i,j,k) * CS%prandtl_bkgnd + do K=2,nz + CS%Kd_bkgnd(i,j,K) = 0.5*(Kd_lay(i,k-1) + Kd_lay(i,k)) + CS%Kv_bkgnd(i,j,K) = CS%Kd_bkgnd(i,j,K) * CS%prandtl_bkgnd enddo enddo endif ! Update Kv if (associated(kv)) then - do k=1,nz+1 ; do i=is,ie - Kv(i,j,k) = Kv(i,j,k) + CS%Kv_bkgnd(i,j,k) + do K=1,nz+1 ; do i=is,ie + Kv(i,j,K) = Kv(i,j,K) + CS%Kv_bkgnd(i,j,K) enddo ; enddo endif @@ -556,7 +519,7 @@ 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) +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 @@ -564,8 +527,8 @@ subroutine check_bkgnd_scheme(CS,str) if (trim(CS%bkgnd_scheme_str)=="none") then CS%bkgnd_scheme_str = str else - call MOM_error(FATAL, "set_diffusivity_init: Cannot activate both "//trim(str)//" and "//& - trim(CS%bkgnd_scheme_str)//".") + call MOM_error(FATAL, "set_diffusivity_init: Cannot activate both "//trim(str)//" and "//& + trim(CS%bkgnd_scheme_str)//".") endif end subroutine diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index b81cf62631..c2682d09bc 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -3,8 +3,14 @@ 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 @@ -17,22 +23,16 @@ module MOM_set_diffusivity use MOM_full_convection, only : full_convection use MOM_grid, only : ocean_grid_type use MOM_internal_tides, only : int_tide_CS, get_lowmode_loss -use MOM_isopycnal_slopes, only : vert_fill_TS -use MOM_tidal_mixing, only : tidal_mixing_CS, calculate_tidal_mixing -use MOM_tidal_mixing, only : setup_tidal_diagnostics, post_tidal_diagnostics 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_CVMix_shear, only : calculate_CVMix_shear, CVMix_shear_init, CVMix_shear_cs -use MOM_CVMix_shear, only : CVMix_shear_end -use MOM_CVMix_ddiff, only : CVMix_ddiff_init, CVMix_ddiff_end, CVMix_ddiff_cs -use MOM_CVMix_ddiff, only : compute_ddiff_coeffs -use MOM_bkgnd_mixing, only : calculate_bkgnd_mixing, bkgnd_mixing_init, bkgnd_mixing_cs -use MOM_bkgnd_mixing, only : bkgnd_mixing_end, sfc_bkgnd_mixing 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 +use MOM_tidal_mixing, only : setup_tidal_diagnostics, post_tidal_diagnostics use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs, vertvisc_type, p3d use MOM_verticalGrid, only : verticalGrid_type @@ -165,6 +165,7 @@ module MOM_set_diffusivity 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 + integer :: id_kd_bkgnd = -1, id_kv_bkgnd = -1 !>@} end type set_diffusivity_CS @@ -246,6 +247,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & real, dimension(SZI_(G),SZK_(G)) :: & N2_lay, & !< squared buoyancy frequency associated with layers [T-2 ~> s-2] + Kd_lay_2d, & !< The layer diffusivities [Z2 T-1 ~> m2 s-1 maxTKE, & !< energy required to entrain to h_max [Z3 T-3 ~> m3 s-3] TKE_to_Kd !< conversion rate (~1.0 / (G_Earth + dRho_lay)) between !< TKE dissipated within a layer and Kd in that layer @@ -296,7 +298,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & ! Set Kd_lay, Kd_int and Kv_slow to constant values. ! If nothing else is specified, this will be the value used. Kd_lay(:,:,:) = CS%Kd - Kd_int(:,:,:) = CS%Kd + if (present(Kd_int)) Kd_int(:,:,:) = CS%Kd if (associated(visc%Kv_slow)) visc%Kv_slow(:,:,:) = CS%Kv ! Set up arrays for diagnostics. @@ -388,10 +390,8 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & ! the appropriate place to add a depth-dependent parameterization or ! another explicit parameterization of Kd. - ! set surface diffusivities (CS%bkgnd_mixing_csp%Kd_sfc) - call sfc_bkgnd_mixing(G, US, CS%bkgnd_mixing_csp) - !$OMP parallel do default(shared) private(dRho_int, N2_lay, N2_int, N2_bot, KT_extra, & + !$OMP parallel do default(shared) private(dRho_int, N2_lay, Kd_lay_2d, N2_int, N2_bot, KT_extra, & !$OMP KS_extra, TKE_to_Kd, maxTKE, dissip, kb) do j=js,je @@ -403,7 +403,10 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & endif ! Add background mixing - call calculate_bkgnd_mixing(h, tv, N2_lay, Kd_lay, visc%Kv_slow, j, G, GV, US, CS%bkgnd_mixing_csp) + call calculate_bkgnd_mixing(h, tv, N2_lay, Kd_lay_2d, visc%Kv_slow, j, G, GV, US, CS%bkgnd_mixing_csp) + do k=1,nz ; do i=is,ie + Kd_lay(i,j,k) = Kd_lay_2d(i,k) + enddo ; enddo ! Double-diffusion (old method) if (CS%double_diffusion) then @@ -477,7 +480,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & ! Add the ML_Rad diffusivity. if (CS%ML_radiation) & - call add_MLrad_diffusivity(h, fluxes, j, G, GV, US, CS, Kd_lay, TKE_to_Kd, Kd_int) + call add_MLrad_diffusivity(h, fluxes, j, G, GV, US, CS, TKE_to_Kd, Kd_lay, Kd_int) ! Add the Nikurashin and / or tidal bottom-driven mixing call calculate_tidal_mixing(h, N2_bot, j, TKE_to_Kd, maxTKE, G, GV, US, CS%tm_csp, & @@ -488,7 +491,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & 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, G, GV, US, CS, & - Kd_lay, Kd_int, dd%Kd_BBL) + dd%Kd_BBL, Kd_lay, Kd_int) else call add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & maxTKE, kb, G, GV, US, CS, Kd_lay, Kd_int, dd%Kd_BBL) @@ -577,10 +580,10 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & ! post diagnostics ! background mixing - if (CS%bkgnd_mixing_csp%id_kd_bkgnd > 0) & - call post_data(CS%bkgnd_mixing_csp%id_kd_bkgnd, CS%bkgnd_mixing_csp%kd_bkgnd, CS%bkgnd_mixing_csp%diag) - if (CS%bkgnd_mixing_csp%id_kv_bkgnd > 0) & - call post_data(CS%bkgnd_mixing_csp%id_kv_bkgnd, CS%bkgnd_mixing_csp%kv_bkgnd, CS%bkgnd_mixing_csp%diag) + if (CS%id_kd_bkgnd > 0) & + call post_data(CS%id_kd_bkgnd, CS%bkgnd_mixing_csp%kd_bkgnd, CS%diag) + if (CS%id_kv_bkgnd > 0) & + call post_data(CS%id_kv_bkgnd, CS%bkgnd_mixing_csp%kv_bkgnd, CS%diag) ! double diffusive mixing if (CS%CVMix_ddiff_csp%id_KT_extra > 0) & @@ -1130,10 +1133,10 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & !! layer, or -1 without a bulk mixed layer type(set_diffusivity_CS), pointer :: CS !< Diffusivity control structure real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(inout) :: Kd_lay !< The diapycnal diffusvity in layers, + intent(inout) :: Kd_lay !< The diapycnal diffusivity in layers, !! [Z2 T-1 ~> m2 s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), & - intent(inout) :: Kd_int !< The diapycnal diffusvity at interfaces, + optional, intent(inout) :: Kd_int !< The diapycnal diffusivity at interfaces, !! [Z2 T-1 ~> m2 s-1]. real, dimension(:,:,:), pointer :: Kd_BBL !< Interface BBL diffusivity [Z2 T-1 ~> m2 s-1]. @@ -1285,8 +1288,10 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & else Kd_lay(i,j,k) = (TKE_to_layer + TKE_Ray) * TKE_to_Kd(i,k) endif - Kd_int(i,j,K) = Kd_int(i,j,K) + 0.5 * delta_Kd - Kd_int(i,j,K+1) = Kd_int(i,j,K+1) + 0.5 * delta_Kd + if (present(Kd_int)) then + Kd_int(i,j,K) = Kd_int(i,j,K) + 0.5 * delta_Kd + Kd_int(i,j,K+1) = Kd_int(i,j,K+1) + 0.5 * delta_Kd + endif 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 @@ -1310,8 +1315,10 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & delta_Kd = TKE_here * TKE_to_Kd(i,k) if (CS%Kd_max >= 0.0) delta_Kd = min(delta_Kd, CS%Kd_max) Kd_lay(i,j,k) = Kd_lay(i,j,k) + delta_Kd - Kd_int(i,j,K) = Kd_int(i,j,K) + 0.5 * delta_Kd - Kd_int(i,j,K+1) = Kd_int(i,j,K+1) + 0.5 * delta_Kd + if (present(Kd_int)) then + Kd_int(i,j,K) = Kd_int(i,j,K) + 0.5 * delta_Kd + Kd_int(i,j,K+1) = Kd_int(i,j,K+1) + 0.5 * delta_Kd + endif 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 @@ -1334,11 +1341,11 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & end subroutine add_drag_diffusivity -!> Calculates a BBL diffusivity use a Prandtl number 1 diffusivitiy with a law of the +!> 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, & - G, GV, US, CS, Kd_lay, Kd_int, Kd_BBL) + G, GV, US, CS, Kd_BBL, Kd_lay, Kd_int) 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 @@ -1357,11 +1364,11 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, & real, dimension(SZI_(G),SZK_(G)+1), & intent(in) :: N2_int !< Square of Brunt-Vaisala at interfaces [T-2 ~> s-2] type(set_diffusivity_CS), pointer :: CS !< Diffusivity control structure + real, dimension(:,:,:), pointer :: Kd_BBL !< Interface BBL diffusivity [Z2 T-1 ~> m2 s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(inout) :: Kd_lay !< Layer net diffusivity [Z2 T-1 ~> m2 s-1] + optional, intent(inout) :: Kd_lay !< Layer net diffusivity [Z2 T-1 ~> m2 s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), & - intent(inout) :: Kd_int !< Interface net diffusivity [Z2 T-1 ~> m2 s-1] - real, dimension(:,:,:), pointer :: Kd_BBL !< Interface BBL diffusivity [Z2 T-1 ~> m2 s-1] + optional, intent(inout) :: Kd_int !< Interface net diffusivity [Z2 T-1 ~> m2 s-1] ! Local variables real :: TKE_column ! net TKE input into the column [Z3 T-3 ~> m3 s-3] @@ -1488,9 +1495,9 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, & TKE_remaining = TKE_remaining - TKE_consumed ! Note this will be non-negative ! Add this BBL diffusivity to the model net diffusivity. - Kd_int(i,j,K) = Kd_int(i,j,K) + Kd_wall - Kd_lay(i,j,k) = Kd_lay(i,j,k) + 0.5 * (Kd_wall + Kd_lower) - Kd_lower = Kd_wall ! Store for next level up. + if (present(Kd_int)) Kd_int(i,j,K) = Kd_int(i,j,K) + Kd_wall + if (present(Kd_lay)) Kd_lay(i,j,k) = Kd_lay(i,j,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 @@ -1498,24 +1505,24 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, & end subroutine add_LOTW_BBL_diffusivity !> This routine adds effects of mixed layer radiation to the layer diffusivities. -subroutine add_MLrad_diffusivity(h, fluxes, j, G, GV, US, CS, Kd_lay, TKE_to_Kd, Kd_int) +subroutine add_MLrad_diffusivity(h, fluxes, j, G, GV, US, CS, TKE_to_Kd, 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_(G)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] type(forcing), intent(in) :: fluxes !< Surface fluxes structure - type(set_diffusivity_CS), pointer :: CS !< Diffusivity control structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(inout) :: Kd_lay !< The diapycnal diffusvity in layers [Z2 T-1 ~> m2 s-1]. integer, intent(in) :: j !< The j-index to work on + type(set_diffusivity_CS), pointer :: CS !< Diffusivity control structure real, dimension(SZI_(G),SZK_(G)), intent(in) :: TKE_to_Kd !< The conversion rate between the TKE !! TKE dissipated within a layer and the !! diapycnal diffusivity witin that layer, !! usually (~Rho_0 / (G_Earth * dRho_lay)) !! [Z2 T-1 / Z3 T-3 = T2 Z-1 ~> s2 m-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + optional, intent(inout) :: Kd_lay !< The diapycnal diffusivity in layers [Z2 T-1 ~> m2 s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), & - optional, intent(inout) :: Kd_int !< The diapycnal diffusvity at interfaces + optional, intent(inout) :: Kd_int !< The diapycnal diffusivity at interfaces !! [Z2 T-1 ~> m2 s-1]. ! This routine adds effects of mixed layer radiation to the layer diffusivities. @@ -1585,9 +1592,11 @@ subroutine add_MLrad_diffusivity(h, fluxes, j, G, GV, US, CS, Kd_lay, TKE_to_Kd, TKE_ml_flux(i) = TKE_ml_flux(i) * exp(-z1) endif ; enddo - do k=1,kml+1 ; do i=is,ie ; if (do_i(i)) then - Kd_lay(i,j,k) = Kd_lay(i,j,k) + Kd_mlr_ml(i) - endif ; enddo ; enddo + if (present(Kd_lay)) then + do k=1,kml+1 ; do i=is,ie ; if (do_i(i)) then + Kd_lay(i,j,k) = Kd_lay(i,j,k) + Kd_mlr_ml(i) + endif ; enddo ; enddo + endif if (present(Kd_int)) then do K=2,kml+1 ; do i=is,ie ; if (do_i(i)) then Kd_int(i,j,K) = Kd_int(i,j,K) + Kd_mlr_ml(i) @@ -1620,7 +1629,9 @@ subroutine add_MLrad_diffusivity(h, fluxes, j, G, GV, US, CS, Kd_lay, TKE_to_Kd, endif endif Kd_mlr = min(Kd_mlr, CS%ML_rad_kd_max) - Kd_lay(i,j,k) = Kd_lay(i,j,k) + Kd_mlr + if (present(Kd_lay)) then + Kd_lay(i,j,k) = Kd_lay(i,j,k) + Kd_mlr + endif if (present(Kd_int)) then Kd_int(i,j,K) = Kd_int(i,j,K) + 0.5 * Kd_mlr Kd_int(i,j,K+1) = Kd_int(i,j,K+1) + 0.5 * Kd_mlr @@ -1955,6 +1966,8 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ # include "version_variable.h" character(len=40) :: mdl = "MOM_set_diffusivity" ! This module's name. real :: omega_frac_dflt + logical :: Bryan_Lewis_diffusivity ! If true, the background diapycnal diffusivity uses + ! the Bryan-Lewis (1979) style tanh profile. integer :: i, j, is, ie, js, je integer :: isd, ied, jsd, jed @@ -2099,7 +2112,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ "calculates Kd/TKE and bounds based on exact energetics "//& "for an isopycnal layer-formulation.", default=.false.) - ! set params releted to the background mixing + ! set params related to the background mixing call bkgnd_mixing_init(Time, G, GV, US, param_file, CS%diag, CS%bkgnd_mixing_csp) call get_param(param_file, mdl, "KV", CS%Kv, & @@ -2163,10 +2176,14 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ if (CS%FluxRi_max > 0.0) & CS%dissip_N2 = CS%dissip_Kd_min * GV%Rho0 / CS%FluxRi_max + CS%id_kd_bkgnd = register_diag_field('ocean_model', 'Kd_bkgnd', diag%axesTi, Time, & + 'Background diffusivity added by MOM_bkgnd_mixing module', 'm2/s', conversion=US%Z2_T_to_m2_s) + CS%id_kv_bkgnd = register_diag_field('ocean_model', 'Kv_bkgnd', diag%axesTi, Time, & + 'Background viscosity added by MOM_bkgnd_mixing module', 'm2/s', conversion=US%Z2_T_to_m2_s) + CS%id_Kd_layer = register_diag_field('ocean_model', 'Kd_layer', diag%axesTL, Time, & 'Diapycnal diffusivity of layers (as set)', 'm2 s-1', conversion=US%Z2_T_to_m2_s) - if (CS%tm_csp%Int_tide_dissipation .or. CS%tm_csp%Lee_wave_dissipation .or. & CS%tm_csp%Lowmode_itidal_dissipation) then @@ -2214,7 +2231,11 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ call user_change_diff_init(Time, G, GV, US, param_file, diag, CS%user_change_diff_CSp) endif - if (CS%tm_csp%Int_tide_dissipation .and. CS%bkgnd_mixing_csp%Bryan_Lewis_diffusivity) & + 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%tm_csp%Int_tide_dissipation .and. Bryan_Lewis_diffusivity) & call MOM_error(FATAL,"MOM_Set_Diffusivity: "// & "Bryan-Lewis and internal tidal dissipation are both enabled. Choose one.") From 902f7a9f26da6c2ffb97647636c30e1b5d42794a Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 18 Oct 2020 09:28:59 -0400 Subject: [PATCH 065/336] +Made Kd_lay arg to calculate_tidal_mixing optional Made the Kd_lay arguments to calculate_tidal_mixing, calculate_CVMix_tidal and add_init_tide_diffusivity optional. All answers are bitwise identical. --- .../vertical/MOM_tidal_mixing.F90 | 37 +++++++++++-------- 1 file changed, 22 insertions(+), 15 deletions(-) diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index 506872298d..32b86b6cc0 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -690,9 +690,9 @@ subroutine calculate_tidal_mixing(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, US, C !! to its maximum realizable thickness [Z3 T-3 ~> m3 s-3] type(tidal_mixing_cs), pointer :: CS !< The control structure for this module real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(inout) :: Kd_lay !< The diapycnal diffusvity in layers [Z2 T-1 ~> m2 s-1]. + optional, intent(inout) :: Kd_lay !< The diapycnal diffusivity in layers [Z2 T-1 ~> m2 s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), & - optional, intent(inout) :: Kd_int !< The diapycnal diffusvity at interfaces, + optional, intent(inout) :: Kd_int !< The diapycnal diffusivity at interfaces, !! [Z2 T-1 ~> m2 s-1]. real, intent(in) :: Kd_max !< The maximum increment for diapycnal !! diffusivity due to TKE-based processes, @@ -725,10 +725,9 @@ subroutine calculate_CVMix_tidal(h, j, G, GV, US, CS, N2_int, Kd_lay, Kd_int, Kv real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(inout) :: Kd_lay!< The diapycnal diffusivities in the layers [Z2 T-1 ~> m2 s-1]. + optional, intent(inout) :: Kd_lay!< The diapycnal diffusivity in the layers [Z2 T-1 ~> m2 s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), & - optional, intent(inout) :: Kd_int !< The diapycnal diffusvity at interfaces, - !! [Z2 T-1 ~> m2 s-1]. + optional, intent(inout) :: Kd_int!< The diapycnal diffusivity at interfaces [Z2 T-1 ~> m2 s-1]. real, dimension(:,:,:), pointer :: Kv !< The "slow" vertical viscosity at each interface !! (not layer!) [Z2 T-1 ~> m2 s-1]. ! Local variables @@ -804,9 +803,11 @@ subroutine calculate_CVMix_tidal(h, j, G, GV, US, CS, N2_int, Kd_lay, Kd_int, Kv CVMix_tidal_params_user = CS%CVMix_tidal_params) ! Update diffusivity - do k=1,G%ke - Kd_lay(i,j,k) = Kd_lay(i,j,k) + 0.5 * US%m2_s_to_Z2_T * (Kd_tidal(k) + Kd_tidal(k+1)) - enddo + if (present(Kd_lay)) then + do k=1,G%ke + Kd_lay(i,j,k) = Kd_lay(i,j,k) + 0.5 * US%m2_s_to_Z2_T * (Kd_tidal(k) + Kd_tidal(k+1)) + enddo + endif if (present(Kd_int)) then do K=1,G%ke+1 Kd_int(i,j,K) = Kd_int(i,j,K) + (US%m2_s_to_Z2_T * Kd_tidal(K)) @@ -904,9 +905,11 @@ subroutine calculate_CVMix_tidal(h, j, G, GV, US, CS, N2_int, Kd_lay, Kd_int, Kv CVmix_tidal_params_user = CS%CVMix_tidal_params) ! Update diffusivity - do k=1,G%ke - Kd_lay(i,j,k) = Kd_lay(i,j,k) + 0.5 * US%m2_s_to_Z2_T * (Kd_tidal(k) + Kd_tidal(k+1)) - enddo + if (present(Kd_lay)) then + do k=1,G%ke + Kd_lay(i,j,k) = Kd_lay(i,j,k) + 0.5 * US%m2_s_to_Z2_T * (Kd_tidal(k) + Kd_tidal(k+1)) + enddo + endif if (present(Kd_int)) then do K=1,G%ke+1 Kd_int(i,j,K) = Kd_int(i,j,K) + (US%m2_s_to_Z2_T * Kd_tidal(K)) @@ -975,9 +978,9 @@ subroutine add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, US, !! to its maximum realizable thickness [Z3 T-3 ~> m3 s-3] type(tidal_mixing_cs), pointer :: CS !< The control structure for this module real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(inout) :: Kd_lay !< The diapycnal diffusvity in layers [Z2 T-1 ~> m2 s-1]. + optional, intent(inout) :: Kd_lay !< The diapycnal diffusivity in layers [Z2 T-1 ~> m2 s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), & - optional, intent(inout) :: Kd_int !< The diapycnal diffusvity at interfaces + optional, intent(inout) :: Kd_int !< The diapycnal diffusivity at interfaces !! [Z2 T-1 ~> m2 s-1]. real, intent(in) :: Kd_max !< The maximum increment for diapycnal !! diffusivity due to TKE-based processes @@ -1258,7 +1261,9 @@ subroutine add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, US, 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) - Kd_lay(i,j,k) = Kd_lay(i,j,k) + Kd_add + if (present(Kd_lay)) then + Kd_lay(i,j,k) = Kd_lay(i,j,k) + Kd_add + endif if (present(Kd_int)) then Kd_int(i,j,K) = Kd_int(i,j,K) + 0.5 * Kd_add @@ -1353,7 +1358,9 @@ subroutine add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, US, 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) - Kd_lay(i,j,k) = Kd_lay(i,j,k) + Kd_add + if (present(Kd_lay)) then + Kd_lay(i,j,k) = Kd_lay(i,j,k) + Kd_add + endif if (present(Kd_int)) then Kd_int(i,j,K) = Kd_int(i,j,K) + 0.5 * Kd_add From db4d3f0f8afd177c471d2c8e294e8f95e72c01d8 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 18 Oct 2020 09:29:37 -0400 Subject: [PATCH 066/336] White space cleanup in MOM_generic_tracer Added () to argumentless subroutine calls and corrected some indents to the 2-space MOM6 standard. All answers are bitwise identical. --- src/tracer/MOM_generic_tracer.F90 | 62 +++++++++++++++---------------- 1 file changed, 31 insertions(+), 31 deletions(-) diff --git a/src/tracer/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 index 66c0e33bac..1ecf9629d8 100644 --- a/src/tracer/MOM_generic_tracer.F90 +++ b/src/tracer/MOM_generic_tracer.F90 @@ -120,9 +120,9 @@ function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) register_MOM_generic_tracer = .false. if (associated(CS)) then - call MOM_error(WARNING, "register_MOM_generic_tracer called with an "// & + call MOM_error(WARNING, "register_MOM_generic_tracer called with an "// & "associated control structure.") - return + return endif allocate(CS) @@ -130,7 +130,7 @@ function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) !Register all the generic tracers used and create the list of them. !This can be called by ALL PE's. No array fields allocated. if (.not. g_registered) then - call generic_tracer_register + call generic_tracer_register() g_registered = .true. endif @@ -270,10 +270,10 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, US, h, param_file, do if (INDEX(CS%IC_file, '_NULL_') /= 0) then - call MOM_error(WARNING,"The name of the IC_file "//trim(CS%IC_file)//& + 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 + 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) @@ -296,20 +296,20 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, US, h, param_file, !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 + 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 + 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 @@ -362,10 +362,10 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, US, h, param_file, grid_tmask(:,:,:) = 0.0 grid_kmt(:,:) = 0 do j = G%jsd, G%jed ; do i = G%isd, G%ied - if (G%mask2dT(i,j) > 0) then - grid_tmask(i,j,:) = 1.0 - grid_kmt(i,j) = G%ke ! Tell the code that a layer thicker than 1m is the bottom layer. - endif + if (G%mask2dT(i,j) > 0) then + grid_tmask(i,j,:) = 1.0 + grid_kmt(i,j) = G%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) @@ -769,25 +769,25 @@ subroutine MOM_generic_flux_init(verbosity) 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. + 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 + 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. + 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 + ! 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 @@ -798,7 +798,7 @@ subroutine MOM_generic_tracer_fluxes_accumulate(flux_tmp, weight) !! thermodynamic and tracer forcing fields. real, intent(in) :: weight !< A weight for accumulating this flux - call generic_tracer_coupler_accumulate(flux_tmp%tr_fluxes, weight) + call generic_tracer_coupler_accumulate(flux_tmp%tr_fluxes, weight) end subroutine MOM_generic_tracer_fluxes_accumulate @@ -821,10 +821,10 @@ end subroutine MOM_generic_tracer_get 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 + call generic_tracer_end() if (associated(CS)) then - deallocate(CS) + deallocate(CS) endif end subroutine end_MOM_generic_tracer From 7c64a53557362d97add4caa327381e93199bf260 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Sun, 18 Oct 2020 21:29:57 -0800 Subject: [PATCH 067/336] Bringing parts of esmg-docs branch for a PR. --- docs/.gitignore | 1 + docs/Doxyfile_nortd | 249 +- docs/Doxyfile_nortd_latex | 2591 +++++++++++++++++ docs/Doxyfile_rtd | 84 +- docs/Doxyfile_rtd_dox | 2473 ++++++++++++++++ docs/Makefile | 53 +- docs/README.md | 536 +++- docs/about.rst | 8 +- docs/code_organization.rst | 46 +- docs/conf.py | 157 +- docs/details/Details.pm | 50 + docs/dox_rtd_footer.html | 19 +- docs/dox_rtd_header.html | 44 +- docs/images/eddy_fluxes.png | Bin 0 -> 1204712 bytes docs/images/sbl1.png | Bin 0 -> 22180 bytes docs/images/sbl2.png | Bin 0 -> 24640 bytes docs/images/shao0.png | Bin 0 -> 213737 bytes docs/images/shao1.png | Bin 0 -> 48142 bytes docs/images/shao2.png | Bin 0 -> 56790 bytes docs/images/shao3.png | Bin 0 -> 230542 bytes docs/images/shao4.png | Bin 0 -> 203213 bytes docs/images/shao5.png | Bin 0 -> 127446 bytes docs/layout.xml | 53 +- docs/ocean.bib | 72 + docs/parameterizations_lateral.rst | 19 +- docs/parameterizations_vertical.rst | 10 +- docs/postProcessEquations.py | 1064 +++++++ docs/references.bib | 88 + docs/requirements.txt | 12 +- docs/working_with_MOM6.rst | 5 +- docs/zotero.bib | 2527 ++++++++++++++++ docs/zzbibliography.rst | 5 + src/equation_of_state/MOM_EOS.F90 | 4 +- src/equation_of_state/MOM_EOS_Wright.F90 | 10 +- src/equation_of_state/MOM_EOS_linear.F90 | 8 +- src/framework/MOM_checksums.F90 | 36 +- src/framework/MOM_domains.F90 | 4 +- src/framework/MOM_hor_index.F90 | 2 +- src/framework/MOM_memory_macros.h | 2 +- src/framework/_Horizontal_indexing.dox | 5 +- src/framework/_Runtime_parameter_system.dox | 4 +- src/parameterizations/lateral/MOM_MEKE.F90 | 2 +- .../lateral/MOM_thickness_diffuse.F90 | 2 +- .../lateral/MOM_tidal_forcing.F90 | 2 +- .../vertical/MOM_CVMix_KPP.F90 | 57 - .../vertical/MOM_CVMix_shear.F90 | 3 +- src/parameterizations/vertical/_CVMix_KPP.dox | 57 + src/tracer/_Horizontal_diffusion.dox | 173 ++ 48 files changed, 10265 insertions(+), 272 deletions(-) create mode 100644 docs/Doxyfile_nortd_latex create mode 100644 docs/Doxyfile_rtd_dox create mode 100644 docs/details/Details.pm create mode 100644 docs/images/eddy_fluxes.png create mode 100644 docs/images/sbl1.png create mode 100644 docs/images/sbl2.png create mode 100644 docs/images/shao0.png create mode 100644 docs/images/shao1.png create mode 100644 docs/images/shao2.png create mode 100644 docs/images/shao3.png create mode 100644 docs/images/shao4.png create mode 100644 docs/images/shao5.png create mode 100644 docs/ocean.bib create mode 100644 docs/postProcessEquations.py create mode 100644 docs/references.bib create mode 100644 docs/zotero.bib create mode 100644 docs/zzbibliography.rst create mode 100644 src/parameterizations/vertical/_CVMix_KPP.dox create mode 100644 src/tracer/_Horizontal_diffusion.dox diff --git a/docs/.gitignore b/docs/.gitignore index de2f06d096..e7f6834342 100644 --- a/docs/.gitignore +++ b/docs/.gitignore @@ -2,6 +2,7 @@ doxygen doxygen.log APIs +MOM6.tags # Ignore sphinx-build output _build api diff --git a/docs/Doxyfile_nortd b/docs/Doxyfile_nortd index 76b66b9dd3..4c19bd4aa7 100644 --- a/docs/Doxyfile_nortd +++ b/docs/Doxyfile_nortd @@ -1,4 +1,4 @@ -# Doxyfile 1.8.15 +# Doxyfile 1.8.19 # This file describes the settings to be used by the documentation system # doxygen (www.doxygen.org) for a project. @@ -58,7 +58,7 @@ PROJECT_LOGO = # entered, it will be relative to the location where doxygen was started. If # left blank the current directory will be used. -OUTPUT_DIRECTORY = +OUTPUT_DIRECTORY = . # If the CREATE_SUBDIRS tag is set to YES then doxygen will create 4096 sub- # directories (in 2 levels) under the output directory of each output format and @@ -187,6 +187,16 @@ SHORT_NAMES = NO JAVADOC_AUTOBRIEF = NO +# If the JAVADOC_BANNER tag is set to YES then doxygen will interpret a line +# such as +# /*************** +# as being the beginning of a Javadoc-style comment "banner". If set to NO, the +# Javadoc-style will behave just like regular comments and it will not be +# interpreted by doxygen. +# The default value is: NO. + +JAVADOC_BANNER = NO + # If the QT_AUTOBRIEF tag is set to YES then doxygen will interpret the first # line (until the first dot) of a Qt-style comment as the brief description. If # set to NO, the Qt-style will behave just like regular Qt-style comments (thus @@ -236,15 +246,36 @@ TAB_SIZE = 2 # "Side Effects:". You can put \n's in the value part of an alias to insert # newlines (in the resulting output). You can put ^^ in the value part of an # alias to insert a newline as if a physical newline was in the original file. - -ALIASES = +# When you need a literal { or } or , in the value part of an alias you have to +# escape them by means of a backslash (\), this can lead to conflicts with the +# commands \{ and \} for these it is advised to use the version @{ and @} or use +# a double escape (\\{ and \\}) + +# Reference: https://git.ligo.org/lscsoft/lalsuite-archive/commit/e6e2dae8a73a73979a64854bbf697b077803697a +#ALIASES = "eqref{1}= Eq. \\eqref{\1}" \ +# "figref{1}= Fig. [\ref \1]" \ +# "tableref{1}= Table [\ref \1]" \ +# "figure{4}= \anchor \1 \image html \1.png \"Fig. [\1]: \4\"" + +# This allows doxygen passthrough of \eqref to html for mathjax +ALIASES += eqref{1}="Eq. \\eqref{\1}" + +# Large math block with multiple references +# TODO: We should be able to overload functions but recursion is happening? For now, the +# second command creates a \eqref2 that is passed to sphinx for processing. This breaks +# the html generation for doxygen +# \eqref{eq:ale-thickness-equation,ale-equations,thickness} +ALIASES += eqref{3}="\latexonly\ref{\1}\endlatexonly\htmlonly \eqref2{\2,\3}\endhtmlonly" + +# Reference: https://stackoverflow.com/questions/25290453/how-do-i-add-a-footnote-in-doxygen +# TODO: Use this simple js library to create actual footnotes in html +# Reference: https://github.com/jheftmann/footnoted +ALIASES += footnote{1}="\latexonly\footnote\{\1\}\endlatexonly\htmlonly[*]\endhtmlonly" # This tag can be used to specify a number of word-keyword mappings (TCL only). # A mapping has the form "name=value". For example adding "class=itcl::class" # will allow you to use the command class in the itcl::class meaning. -TCL_SUBST = - # Set the OPTIMIZE_OUTPUT_FOR_C tag to YES if your project consists of C sources # only. Doxygen will then generate output that is more tailored for C. For # instance, some of the names that are used will be different. The list of all @@ -273,17 +304,26 @@ OPTIMIZE_FOR_FORTRAN = YES OPTIMIZE_OUTPUT_VHDL = NO +# Set the OPTIMIZE_OUTPUT_SLICE tag to YES if your project consists of Slice +# sources only. Doxygen will then generate output that is more tailored for that +# language. For instance, namespaces will be presented as modules, types will be +# separated into more groups, etc. +# The default value is: NO. + +OPTIMIZE_OUTPUT_SLICE = NO + # Doxygen selects the parser to use depending on the extension of the files it # parses. With this tag you can assign which parser to use for a given # extension. Doxygen has a built-in mapping, but you can override or extend it # using this tag. The format is ext=language, where ext is a file extension, and -# language is one of the parsers supported by doxygen: IDL, Java, Javascript, -# C#, C, C++, D, PHP, Objective-C, Python, Fortran (fixed format Fortran: -# FortranFixed, free formatted Fortran: FortranFree, unknown formatted Fortran: -# Fortran. In the later case the parser tries to guess whether the code is fixed -# or free formatted code, this is the default for Fortran type files), VHDL. For -# instance to make doxygen treat .inc files as Fortran files (default is PHP), -# and .f files as C (default is Fortran), use: inc=Fortran f=C. +# language is one of the parsers supported by doxygen: IDL, Java, JavaScript, +# Csharp (C#), C, C++, D, PHP, md (Markdown), Objective-C, Python, Slice, VHDL, +# Fortran (fixed format Fortran: FortranFixed, free formatted Fortran: +# FortranFree, unknown formatted Fortran: Fortran. In the later case the parser +# tries to guess whether the code is fixed or free formatted code, this is the +# default for Fortran type files). For instance to make doxygen treat .inc files +# as Fortran files (default is PHP), and .f files as C (default is Fortran), +# use: inc=Fortran f=C. # # Note: For files without extension you can use no_extension as a placeholder. # @@ -294,7 +334,7 @@ EXTENSION_MAPPING = # If the MARKDOWN_SUPPORT tag is enabled then doxygen pre-processes all comments # according to the Markdown format, which allows for more readable -# documentation. See http://daringfireball.net/projects/markdown/ for details. +# documentation. See https://daringfireball.net/projects/markdown/ for details. # The output of markdown processing is further processed by doxygen, so you can # mix doxygen, HTML, and XML commands with Markdown formatting. Disable only in # case of backward compatibilities issues. @@ -306,7 +346,7 @@ MARKDOWN_SUPPORT = YES # to that level are automatically included in the table of contents, even if # they do not have an id attribute. # Note: This feature currently applies only to Markdown headings. -# Minimum value: 0, maximum value: 99, default value: 0. +# Minimum value: 0, maximum value: 99, default value: 5. # This tag requires that the tag MARKDOWN_SUPPORT is set to YES. TOC_INCLUDE_HEADINGS = 0 @@ -422,6 +462,19 @@ TYPEDEF_HIDES_STRUCT = NO LOOKUP_CACHE_SIZE = 0 +# The NUM_PROC_THREADS specifies the number threads doxygen is allowed to use +# during processing. When set to 0 doxygen will based this on the number of +# cores available in the system. You can set it explicitly to a value larger +# than 0 to get more control over the balance between CPU load and processing +# speed. At this moment only the input processing can be done using multiple +# threads. Since this is still an experimental feature the default is set to 1, +# which efficively disables parallel processing. Please report any issues you +# encounter. Generating dot graphs in parallel is controlled by the +# DOT_NUM_THREADS setting. +# Minimum value: 0, maximum value: 32, default value: 1. + +NUM_PROC_THREADS = 1 + #--------------------------------------------------------------------------- # Build related configuration options #--------------------------------------------------------------------------- @@ -442,6 +495,12 @@ EXTRACT_ALL = NO EXTRACT_PRIVATE = YES +# If the EXTRACT_PRIV_VIRTUAL tag is set to YES, documented private virtual +# methods of a class will be included in the documentation. +# The default value is: NO. + +EXTRACT_PRIV_VIRTUAL = NO + # If the EXTRACT_PACKAGE tag is set to YES, all members with package or internal # scope will be included in the documentation. # The default value is: NO. @@ -496,8 +555,8 @@ HIDE_UNDOC_MEMBERS = NO HIDE_UNDOC_CLASSES = NO # If the HIDE_FRIEND_COMPOUNDS tag is set to YES, doxygen will hide all friend -# (class|struct|union) declarations. If set to NO, these declarations will be -# included in the documentation. +# declarations. If set to NO, these declarations will be included in the +# documentation. # The default value is: NO. HIDE_FRIEND_COMPOUNDS = NO @@ -520,7 +579,7 @@ INTERNAL_DOCS = YES # names in lower-case letters. If set to YES, upper-case letters are also # allowed. This is useful if you have classes or files whose names only differ # in case and if your file system supports case sensitive file names. Windows -# and Mac users are advised to set this option to NO. +# (including Cygwin) and Mac users are advised to set this option to NO. # The default value is: system dependent. CASE_SENSE_NAMES = YES @@ -712,7 +771,7 @@ LAYOUT_FILE = layout.xml # LATEX_BIB_STYLE. To use this feature you need bibtex and perl available in the # search path. See also \cite for info how to create references. -CITE_BIB_FILES = +CITE_BIB_FILES = ocean.bib references.bib zotero.bib #--------------------------------------------------------------------------- # Configuration options related to warning and progress messages @@ -778,7 +837,7 @@ WARN_FORMAT = "$file:$line: $text" # messages should be written. If left blank the output is written to standard # error (stderr). -WARN_LOGFILE = doxygen.log +WARN_LOGFILE = _build/doxygen_warn_nortd_log.txt #--------------------------------------------------------------------------- # Configuration options related to the input files @@ -793,11 +852,10 @@ WARN_LOGFILE = doxygen.log INPUT = ../src \ front_page.md \ ../config_src/solo_driver \ - ../config_src/dynamic_symmetric - ../config_src/external + ../config_src/dynamic_symmetric \ + ../config_src/external \ ../config_src/coupled_driver - # This tag can be used to specify the character encoding of the source files # that doxygen parses. Internally doxygen uses the UTF-8 encoding. Doxygen uses # libiconv (or the iconv built into libc) for the transcoding. See the libiconv @@ -818,28 +876,58 @@ INPUT_ENCODING = UTF-8 # If left blank the following patterns are tested:*.c, *.cc, *.cxx, *.cpp, # *.c++, *.java, *.ii, *.ixx, *.ipp, *.i++, *.inl, *.idl, *.ddl, *.odl, *.h, # *.hh, *.hxx, *.hpp, *.h++, *.cs, *.d, *.php, *.php4, *.php5, *.phtml, *.inc, -# *.m, *.markdown, *.md, *.mm, *.dox, *.py, *.pyw, *.f90, *.f95, *.f03, *.f08, -# *.f, *.for, *.tcl, *.vhd, *.vhdl, *.ucf and *.qsf. +# *.m, *.markdown, *.md, *.mm, *.dox (to be provided as doxygen C comment), +# *.doc (to be provided as doxygen C comment), *.txt (to be provided as doxygen +# C comment), *.py, *.pyw, *.f90, *.f95, *.f03, *.f08, *.f18, *.f, *.for, *.vhd, +# *.vhdl, *.ucf, *.qsf and *.ice. FILE_PATTERNS = *.c \ *.cc \ *.cxx \ *.cpp \ *.c++ \ + *.java \ + *.ii \ + *.ixx \ + *.ipp \ + *.i++ \ + *.inl \ + *.idl \ + *.ddl \ + *.odl \ *.h \ *.hh \ *.hxx \ *.hpp \ *.h++ \ + *.cs \ + *.d \ + *.php \ + *.php4 \ + *.php5 \ + *.phtml \ *.inc \ *.m \ *.markdown \ *.md \ *.mm \ *.dox \ + *.doc \ + *.txt \ + *.py \ + *.pyw \ *.f90 \ + *.f95 \ + *.f03 \ + *.f08 \ + *.f18 \ *.f \ *.for \ + *.vhd \ + *.vhdl \ + *.ucf \ + *.qsf \ + *.ice \ *.F90 # The RECURSIVE tag can be used to specify whether or not subdirectories should @@ -1096,7 +1184,7 @@ GENERATE_HTML = YES # The default directory is: html. # This tag requires that the tag GENERATE_HTML is set to YES. -HTML_OUTPUT = APIs +HTML_OUTPUT = _build/APIs # The HTML_FILE_EXTENSION tag can be used to specify the file extension for each # generated HTML page (for example: .htm, .php, .asp). @@ -1211,9 +1299,9 @@ HTML_TIMESTAMP = NO # If the HTML_DYNAMIC_MENUS tag is set to YES then the generated HTML # documentation will contain a main index with vertical navigation menus that -# are dynamically created via Javascript. If disabled, the navigation index will +# are dynamically created via JavaScript. If disabled, the navigation index will # consists of multiple levels of tabs that are statically embedded in every HTML -# page. Disable this option to support browsers that do not have Javascript, +# page. Disable this option to support browsers that do not have JavaScript, # like the Qt help browser. # The default value is: YES. # This tag requires that the tag GENERATE_HTML is set to YES. @@ -1243,13 +1331,13 @@ HTML_INDEX_NUM_ENTRIES = 900 # If the GENERATE_DOCSET tag is set to YES, additional index files will be # generated that can be used as input for Apple's Xcode 3 integrated development -# environment (see: https://developer.apple.com/tools/xcode/), introduced with -# OSX 10.5 (Leopard). To create a documentation set, doxygen will generate a +# environment (see: https://developer.apple.com/xcode/), introduced with OSX +# 10.5 (Leopard). To create a documentation set, doxygen will generate a # Makefile in the HTML output directory. Running make will produce the docset in # that directory and running make install will install the docset in # ~/Library/Developer/Shared/Documentation/DocSets so that Xcode will find it at -# startup. See https://developer.apple.com/tools/creatingdocsetswithdoxygen.html -# for more information. +# startup. See https://developer.apple.com/library/archive/featuredarticles/Doxy +# genXcode/_index.html for more information. # The default value is: NO. # This tag requires that the tag GENERATE_HTML is set to YES. @@ -1288,7 +1376,7 @@ DOCSET_PUBLISHER_NAME = Publisher # If the GENERATE_HTMLHELP tag is set to YES then doxygen generates three # additional HTML index files: index.hhp, index.hhc, and index.hhk. The # index.hhp is a project file that can be read by Microsoft's HTML Help Workshop -# (see: http://www.microsoft.com/en-us/download/details.aspx?id=21138) on +# (see: https://www.microsoft.com/en-us/download/details.aspx?id=21138) on # Windows. # # The HTML Help Workshop contains a compiler that can convert all HTML output @@ -1319,7 +1407,7 @@ CHM_FILE = HHC_LOCATION = # The GENERATE_CHI flag controls if a separate .chi index file is generated -# (YES) or that it should be included in the master .chm file (NO). +# (YES) or that it should be included in the main .chm file (NO). # The default value is: NO. # This tag requires that the tag GENERATE_HTMLHELP is set to YES. @@ -1364,7 +1452,7 @@ QCH_FILE = # The QHP_NAMESPACE tag specifies the namespace to use when generating Qt Help # Project output. For more information please see Qt Help Project / Namespace -# (see: http://doc.qt.io/qt-4.8/qthelpproject.html#namespace). +# (see: https://doc.qt.io/archives/qt-4.8/qthelpproject.html#namespace). # The default value is: org.doxygen.Project. # This tag requires that the tag GENERATE_QHP is set to YES. @@ -1372,7 +1460,8 @@ QHP_NAMESPACE = org.doxygen.Project # The QHP_VIRTUAL_FOLDER tag specifies the namespace to use when generating Qt # Help Project output. For more information please see Qt Help Project / Virtual -# Folders (see: http://doc.qt.io/qt-4.8/qthelpproject.html#virtual-folders). +# Folders (see: https://doc.qt.io/archives/qt-4.8/qthelpproject.html#virtual- +# folders). # The default value is: doc. # This tag requires that the tag GENERATE_QHP is set to YES. @@ -1380,21 +1469,23 @@ QHP_VIRTUAL_FOLDER = doc # If the QHP_CUST_FILTER_NAME tag is set, it specifies the name of a custom # filter to add. For more information please see Qt Help Project / Custom -# Filters (see: http://doc.qt.io/qt-4.8/qthelpproject.html#custom-filters). +# Filters (see: https://doc.qt.io/archives/qt-4.8/qthelpproject.html#custom- +# filters). # This tag requires that the tag GENERATE_QHP is set to YES. QHP_CUST_FILTER_NAME = # The QHP_CUST_FILTER_ATTRS tag specifies the list of the attributes of the # custom filter to add. For more information please see Qt Help Project / Custom -# Filters (see: http://doc.qt.io/qt-4.8/qthelpproject.html#custom-filters). +# Filters (see: https://doc.qt.io/archives/qt-4.8/qthelpproject.html#custom- +# filters). # This tag requires that the tag GENERATE_QHP is set to YES. QHP_CUST_FILTER_ATTRS = # The QHP_SECT_FILTER_ATTRS tag specifies the list of the attributes this # project's filter section matches. Qt Help Project / Filter Attributes (see: -# http://doc.qt.io/qt-4.8/qthelpproject.html#filter-attributes). +# https://doc.qt.io/archives/qt-4.8/qthelpproject.html#filter-attributes). # This tag requires that the tag GENERATE_QHP is set to YES. QHP_SECT_FILTER_ATTRS = @@ -1478,6 +1569,17 @@ TREEVIEW_WIDTH = 250 EXT_LINKS_IN_WINDOW = NO +# If the HTML_FORMULA_FORMAT option is set to svg, doxygen will use the pdf2svg +# tool (see https://github.com/dawbarton/pdf2svg) or inkscape (see +# https://inkscape.org) to generate formulas as SVG images instead of PNGs for +# the HTML output. These images will generally look nicer at scaled resolutions. +# Possible values are: png (the default) and svg (looks nicer but requires the +# pdf2svg or inkscape tool). +# The default value is: png. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_FORMULA_FORMAT = svg + # Use this tag to change the font size of LaTeX formulas included as images in # the HTML documentation. When you change the font size after a successful # doxygen run you need to manually remove any form_*.png images from the HTML @@ -1498,8 +1600,14 @@ FORMULA_FONTSIZE = 10 FORMULA_TRANSPARENT = YES +# The FORMULA_MACROFILE can contain LaTeX \newcommand and \renewcommand commands +# to create new LaTeX commands to be used in formulas as building blocks. See +# the section "Including formulas" for details. + +FORMULA_MACROFILE = + # Enable the USE_MATHJAX option to render LaTeX formulas using MathJax (see -# https://www.mathjax.org) which uses client side Javascript for the rendering +# https://www.mathjax.org) which uses client side JavaScript for the rendering # instead of using pre-rendered bitmaps. Use this if you do not have LaTeX # installed or if you want to formulas look prettier in the HTML output. When # enabled you may also need to install MathJax separately and configure the path @@ -1527,10 +1635,10 @@ MATHJAX_FORMAT = HTML-CSS # Content Delivery Network so you can quickly see the result without installing # MathJax. However, it is strongly recommended to install a local copy of # MathJax from https://www.mathjax.org before deployment. -# The default value is: https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.2/. +# The default value is: https://cdn.jsdelivr.net/npm/mathjax@2. # This tag requires that the tag USE_MATHJAX is set to YES. -MATHJAX_RELPATH = http://cdn.mathjax.org/mathjax/latest +MATHJAX_RELPATH = https://cdn.jsdelivr.net/npm/mathjax@2 # The MATHJAX_EXTENSIONS tag can be used to specify one or more MathJax # extension names that should be enabled during MathJax rendering. For example @@ -1569,7 +1677,7 @@ MATHJAX_CODEFILE = SEARCHENGINE = YES # When the SERVER_BASED_SEARCH tag is enabled the search engine will be -# implemented using a web server instead of a web client using Javascript. There +# implemented using a web server instead of a web client using JavaScript. There # are two flavors of web server based searching depending on the EXTERNAL_SEARCH # setting. When disabled, doxygen will generate a PHP script for searching and # an index file used by the script. When EXTERNAL_SEARCH is enabled the indexing @@ -1664,11 +1772,24 @@ LATEX_CMD_NAME = latex # The MAKEINDEX_CMD_NAME tag can be used to specify the command name to generate # index for LaTeX. +# Note: This tag is used in the Makefile / make.bat. +# See also: LATEX_MAKEINDEX_CMD for the part in the generated output file +# (.tex). # The default file is: makeindex. # This tag requires that the tag GENERATE_LATEX is set to YES. MAKEINDEX_CMD_NAME = makeindex +# The LATEX_MAKEINDEX_CMD tag can be used to specify the command name to +# generate index for LaTeX. In case there is no backslash (\) as first character +# it will be automatically added in the LaTeX code. +# Note: This tag is used in the generated output file (.tex). +# See also: MAKEINDEX_CMD_NAME for the part in the Makefile / make.bat. +# The default value is: makeindex. +# This tag requires that the tag GENERATE_LATEX is set to YES. + +LATEX_MAKEINDEX_CMD = makeindex + # If the COMPACT_LATEX tag is set to YES, doxygen generates more compact LaTeX # documents. This may be useful for small projects and may help to save some # trees in general. @@ -1696,7 +1817,7 @@ PAPER_TYPE = a4 # If left blank no extra packages will be included. # This tag requires that the tag GENERATE_LATEX is set to YES. -EXTRA_PACKAGES = +EXTRA_PACKAGES =amsmath amstext # The LATEX_HEADER tag can be used to specify a personal LaTeX header for the # generated LaTeX document. The header should contain everything until the first @@ -1753,9 +1874,11 @@ LATEX_EXTRA_FILES = PDF_HYPERLINKS = YES -# If the USE_PDFLATEX tag is set to YES, doxygen will use pdflatex to generate -# the PDF file directly from the LaTeX files. Set this option to YES, to get a -# higher quality PDF documentation. +# If the USE_PDFLATEX tag is set to YES, doxygen will use the engine as +# specified with LATEX_CMD_NAME to generate the PDF file directly from the LaTeX +# files. Set this option to YES, to get a higher quality PDF documentation. +# +# See also section LATEX_CMD_NAME for selecting the engine. # The default value is: YES. # This tag requires that the tag GENERATE_LATEX is set to YES. @@ -1803,6 +1926,14 @@ LATEX_BIB_STYLE = plain LATEX_TIMESTAMP = NO +# The LATEX_EMOJI_DIRECTORY tag is used to specify the (relative or absolute) +# path from which the emoji images will be read. If a relative path is entered, +# it will be relative to the LATEX_OUTPUT directory. If left blank the +# LATEX_OUTPUT directory will be used. +# This tag requires that the tag GENERATE_LATEX is set to YES. + +LATEX_EMOJI_DIRECTORY = + #--------------------------------------------------------------------------- # Configuration options related to the RTF output #--------------------------------------------------------------------------- @@ -1940,6 +2071,13 @@ XML_OUTPUT = xml XML_PROGRAMLISTING = YES +# If the XML_NS_MEMB_FILE_SCOPE tag is set to YES, doxygen will include +# namespace members in file scope as well, matching the HTML output. +# The default value is: NO. +# This tag requires that the tag GENERATE_XML is set to YES. + +XML_NS_MEMB_FILE_SCOPE = NO + #--------------------------------------------------------------------------- # Configuration options related to the DOCBOOK output #--------------------------------------------------------------------------- @@ -2119,7 +2257,7 @@ TAGFILES = # tag file that is based on the input files it reads. See section "Linking to # external documentation" for more information about the usage of tag files. -GENERATE_TAGFILE = +GENERATE_TAGFILE = MOM6.tags # If the ALLEXTERNALS tag is set to YES, all external class will be listed in # the class index. If set to NO, only the inherited external classes will be @@ -2142,12 +2280,6 @@ EXTERNAL_GROUPS = YES EXTERNAL_PAGES = YES -# The PERL_PATH should be the absolute path and name of the perl script -# interpreter (i.e. the result of 'which perl'). -# The default file (with absolute path) is: /usr/bin/perl. - -PERL_PATH = /usr/bin/perl - #--------------------------------------------------------------------------- # Configuration options related to the dot tool #--------------------------------------------------------------------------- @@ -2161,15 +2293,6 @@ PERL_PATH = /usr/bin/perl CLASS_DIAGRAMS = YES -# You can define message sequence charts within doxygen comments using the \msc -# command. Doxygen will then run the mscgen tool (see: -# http://www.mcternan.me.uk/mscgen/)) to produce the chart and insert it in the -# documentation. The MSCGEN_PATH tag allows you to specify the directory where -# the mscgen tool resides. If left empty the tool is assumed to be found in the -# default search path. - -MSCGEN_PATH = - # You can include diagrams made with dia in doxygen documentation. Doxygen will # then run dia to produce the diagram and insert it in the documentation. The # DIA_PATH tag allows you to specify the directory where the dia binary resides. diff --git a/docs/Doxyfile_nortd_latex b/docs/Doxyfile_nortd_latex new file mode 100644 index 0000000000..aa7ac83c22 --- /dev/null +++ b/docs/Doxyfile_nortd_latex @@ -0,0 +1,2591 @@ +# Doxyfile 1.8.19 + +# This file describes the settings to be used by the documentation system +# doxygen (www.doxygen.org) for a project. +# +# All text after a double hash (##) is considered a comment and is placed in +# front of the TAG it is preceding. +# +# All text after a single hash (#) is considered a comment and will be ignored. +# The format is: +# TAG = value [value, ...] +# For lists, items can also be appended using: +# TAG += value [value, ...] +# Values that contain spaces should be placed between quotes (\" \"). + +#--------------------------------------------------------------------------- +# Project related configuration options +#--------------------------------------------------------------------------- + +# This tag specifies the encoding used for all characters in the configuration +# file that follow. The default is UTF-8 which is also the encoding used for all +# text before the first occurrence of this tag. Doxygen uses libiconv (or the +# iconv built into libc) for the transcoding. See +# https://www.gnu.org/software/libiconv/ for the list of possible encodings. +# The default value is: UTF-8. + +DOXYFILE_ENCODING = UTF-8 + +# The PROJECT_NAME tag is a single word (or a sequence of words surrounded by +# double-quotes, unless you are using Doxywizard) that should identify the +# project for which the documentation is generated. This name is used in the +# title of most generated pages and in a few other places. +# The default value is: My Project. + +PROJECT_NAME = "MOM6" + +# The PROJECT_NUMBER tag can be used to enter a project or revision number. This +# could be handy for archiving the generated documentation or if some version +# control system is used. + +PROJECT_NUMBER = + +# Using the PROJECT_BRIEF tag one can provide an optional one line description +# for a project that appears at the top of each page and should give viewer a +# quick idea about the purpose of the project. Keep the description short. + +PROJECT_BRIEF = + +# With the PROJECT_LOGO tag one can specify a logo or an icon that is included +# in the documentation. The maximum height of the logo should not exceed 55 +# pixels and the maximum width should not exceed 200 pixels. Doxygen will copy +# the logo to the output directory. + +PROJECT_LOGO = + +# The OUTPUT_DIRECTORY tag is used to specify the (relative or absolute) path +# into which the generated documentation will be written. If a relative path is +# entered, it will be relative to the location where doxygen was started. If +# left blank the current directory will be used. + +OUTPUT_DIRECTORY = . + +# If the CREATE_SUBDIRS tag is set to YES then doxygen will create 4096 sub- +# directories (in 2 levels) under the output directory of each output format and +# will distribute the generated files over these directories. Enabling this +# option can be useful when feeding doxygen a huge amount of source files, where +# putting all generated files in the same directory would otherwise causes +# performance problems for the file system. +# The default value is: NO. + +CREATE_SUBDIRS = NO + +# If the ALLOW_UNICODE_NAMES tag is set to YES, doxygen will allow non-ASCII +# characters to appear in the names of generated files. If set to NO, non-ASCII +# characters will be escaped, for example _xE3_x81_x84 will be used for Unicode +# U+3044. +# The default value is: NO. + +ALLOW_UNICODE_NAMES = NO + +# The OUTPUT_LANGUAGE tag is used to specify the language in which all +# documentation generated by doxygen is written. Doxygen will use this +# information to generate all constant output in the proper language. +# Possible values are: Afrikaans, Arabic, Armenian, Brazilian, Catalan, Chinese, +# Chinese-Traditional, Croatian, Czech, Danish, Dutch, English (United States), +# Esperanto, Farsi (Persian), Finnish, French, German, Greek, Hungarian, +# Indonesian, Italian, Japanese, Japanese-en (Japanese with English messages), +# Korean, Korean-en (Korean with English messages), Latvian, Lithuanian, +# Macedonian, Norwegian, Persian (Farsi), Polish, Portuguese, Romanian, Russian, +# Serbian, Serbian-Cyrillic, Slovak, Slovene, Spanish, Swedish, Turkish, +# Ukrainian and Vietnamese. +# The default value is: English. + +OUTPUT_LANGUAGE = English + +# The OUTPUT_TEXT_DIRECTION tag is used to specify the direction in which all +# documentation generated by doxygen is written. Doxygen will use this +# information to generate all generated output in the proper direction. +# Possible values are: None, LTR, RTL and Context. +# The default value is: None. + +OUTPUT_TEXT_DIRECTION = None + +# If the BRIEF_MEMBER_DESC tag is set to YES, doxygen will include brief member +# descriptions after the members that are listed in the file and class +# documentation (similar to Javadoc). Set to NO to disable this. +# The default value is: YES. + +BRIEF_MEMBER_DESC = YES + +# If the REPEAT_BRIEF tag is set to YES, doxygen will prepend the brief +# description of a member or function before the detailed description +# +# Note: If both HIDE_UNDOC_MEMBERS and BRIEF_MEMBER_DESC are set to NO, the +# brief descriptions will be completely suppressed. +# The default value is: YES. + +REPEAT_BRIEF = YES + +# This tag implements a quasi-intelligent brief description abbreviator that is +# used to form the text in various listings. Each string in this list, if found +# as the leading text of the brief description, will be stripped from the text +# and the result, after processing the whole list, is used as the annotated +# text. Otherwise, the brief description is used as-is. If left blank, the +# following values are used ($name is automatically replaced with the name of +# the entity):The $name class, The $name widget, The $name file, is, provides, +# specifies, contains, represents, a, an and the. + +ABBREVIATE_BRIEF = + +# If the ALWAYS_DETAILED_SEC and REPEAT_BRIEF tags are both set to YES then +# doxygen will generate a detailed section even if there is only a brief +# description. +# The default value is: NO. + +ALWAYS_DETAILED_SEC = NO + +# If the INLINE_INHERITED_MEMB tag is set to YES, doxygen will show all +# inherited members of a class in the documentation of that class as if those +# members were ordinary class members. Constructors, destructors and assignment +# operators of the base classes will not be shown. +# The default value is: NO. + +INLINE_INHERITED_MEMB = NO + +# If the FULL_PATH_NAMES tag is set to YES, doxygen will prepend the full path +# before files name in the file list and in the header files. If set to NO the +# shortest path that makes the file name unique will be used +# The default value is: YES. + +FULL_PATH_NAMES = YES + +# The STRIP_FROM_PATH tag can be used to strip a user-defined part of the path. +# Stripping is only done if one of the specified strings matches the left-hand +# part of the path. The tag can be used to show relative paths in the file list. +# If left blank the directory from which doxygen is run is used as the path to +# strip. +# +# Note that you can specify absolute paths here, but also relative paths, which +# will be relative from the directory where doxygen is started. +# This tag requires that the tag FULL_PATH_NAMES is set to YES. + +STRIP_FROM_PATH = + +# The STRIP_FROM_INC_PATH tag can be used to strip a user-defined part of the +# path mentioned in the documentation of a class, which tells the reader which +# header file to include in order to use a class. If left blank only the name of +# the header file containing the class definition is used. Otherwise one should +# specify the list of include paths that are normally passed to the compiler +# using the -I flag. + +STRIP_FROM_INC_PATH = + +# If the SHORT_NAMES tag is set to YES, doxygen will generate much shorter (but +# less readable) file names. This can be useful is your file systems doesn't +# support long names like on DOS, Mac, or CD-ROM. +# The default value is: NO. + +SHORT_NAMES = NO + +# If the JAVADOC_AUTOBRIEF tag is set to YES then doxygen will interpret the +# first line (until the first dot) of a Javadoc-style comment as the brief +# description. If set to NO, the Javadoc-style will behave just like regular Qt- +# style comments (thus requiring an explicit @brief command for a brief +# description.) +# The default value is: NO. + +JAVADOC_AUTOBRIEF = NO + +# If the JAVADOC_BANNER tag is set to YES then doxygen will interpret a line +# such as +# /*************** +# as being the beginning of a Javadoc-style comment "banner". If set to NO, the +# Javadoc-style will behave just like regular comments and it will not be +# interpreted by doxygen. +# The default value is: NO. + +JAVADOC_BANNER = NO + +# If the QT_AUTOBRIEF tag is set to YES then doxygen will interpret the first +# line (until the first dot) of a Qt-style comment as the brief description. If +# set to NO, the Qt-style will behave just like regular Qt-style comments (thus +# requiring an explicit \brief command for a brief description.) +# The default value is: NO. + +QT_AUTOBRIEF = NO + +# The MULTILINE_CPP_IS_BRIEF tag can be set to YES to make doxygen treat a +# multi-line C++ special comment block (i.e. a block of //! or /// comments) as +# a brief description. This used to be the default behavior. The new default is +# to treat a multi-line C++ comment block as a detailed description. Set this +# tag to YES if you prefer the old behavior instead. +# +# Note that setting this tag to YES also means that rational rose comments are +# not recognized any more. +# The default value is: NO. + +MULTILINE_CPP_IS_BRIEF = NO + +# If the INHERIT_DOCS tag is set to YES then an undocumented member inherits the +# documentation from any documented member that it re-implements. +# The default value is: YES. + +INHERIT_DOCS = YES + +# If the SEPARATE_MEMBER_PAGES tag is set to YES then doxygen will produce a new +# page for each member. If set to NO, the documentation of a member will be part +# of the file/class/namespace that contains it. +# The default value is: NO. + +SEPARATE_MEMBER_PAGES = NO + +# The TAB_SIZE tag can be used to set the number of spaces in a tab. Doxygen +# uses this value to replace tabs by spaces in code fragments. +# Minimum value: 1, maximum value: 16, default value: 4. + +TAB_SIZE = 2 + +# This tag can be used to specify a number of aliases that act as commands in +# the documentation. An alias has the form: +# name=value +# For example adding +# "sideeffect=@par Side Effects:\n" +# will allow you to put the command \sideeffect (or @sideeffect) in the +# documentation, which will result in a user-defined paragraph with heading +# "Side Effects:". You can put \n's in the value part of an alias to insert +# newlines (in the resulting output). You can put ^^ in the value part of an +# alias to insert a newline as if a physical newline was in the original file. +# When you need a literal { or } or , in the value part of an alias you have to +# escape them by means of a backslash (\), this can lead to conflicts with the +# commands \{ and \} for these it is advised to use the version @{ and @} or use +# a double escape (\\{ and \\}) + +# Reference: https://git.ligo.org/lscsoft/lalsuite-archive/commit/e6e2dae8a73a73979a64854bbf697b077803697a +#ALIASES = "eqref{1}= Eq. \\eqref{\1}" \ +# "figref{1}= Fig. [\ref \1]" \ +# "tableref{1}= Table [\ref \1]" \ +# "figure{4}= \anchor \1 \image html \1.png \"Fig. [\1]: \4\"" + +# This allows doxygen passthrough of \eqref to html for mathjax +ALIASES += eqref{1}="Eq. \\eqref{\1}" + +# Large math block with multiple references +# TODO: We should be able to overload functions but recursion is happening? For now, the +# second command creates a \eqref2 that is passed to sphinx for processing. This breaks +# the html generation for doxygen +# \eqref{eq:ale-thickness-equation,ale-equations,thickness} +ALIASES += eqref{3}="\latexonly\ref{\1}\endlatexonly\htmlonly \eqref2{\2,\3}\endhtmlonly" + +# Reference: https://stackoverflow.com/questions/25290453/how-do-i-add-a-footnote-in-doxygen +# TODO: Use this simple js library to create actual footnotes in html +# Reference: https://github.com/jheftmann/footnoted +ALIASES += footnote{1}="\latexonly\footnote\{\1\}\endlatexonly\htmlonly[*]\endhtmlonly" + +# This tag can be used to specify a number of word-keyword mappings (TCL only). +# A mapping has the form "name=value". For example adding "class=itcl::class" +# will allow you to use the command class in the itcl::class meaning. + +# Set the OPTIMIZE_OUTPUT_FOR_C tag to YES if your project consists of C sources +# only. Doxygen will then generate output that is more tailored for C. For +# instance, some of the names that are used will be different. The list of all +# members will be omitted, etc. +# The default value is: NO. + +OPTIMIZE_OUTPUT_FOR_C = NO + +# Set the OPTIMIZE_OUTPUT_JAVA tag to YES if your project consists of Java or +# Python sources only. Doxygen will then generate output that is more tailored +# for that language. For instance, namespaces will be presented as packages, +# qualified scopes will look different, etc. +# The default value is: NO. + +OPTIMIZE_OUTPUT_JAVA = NO + +# Set the OPTIMIZE_FOR_FORTRAN tag to YES if your project consists of Fortran +# sources. Doxygen will then generate output that is tailored for Fortran. +# The default value is: NO. + +OPTIMIZE_FOR_FORTRAN = YES + +# Set the OPTIMIZE_OUTPUT_VHDL tag to YES if your project consists of VHDL +# sources. Doxygen will then generate output that is tailored for VHDL. +# The default value is: NO. + +OPTIMIZE_OUTPUT_VHDL = NO + +# Set the OPTIMIZE_OUTPUT_SLICE tag to YES if your project consists of Slice +# sources only. Doxygen will then generate output that is more tailored for that +# language. For instance, namespaces will be presented as modules, types will be +# separated into more groups, etc. +# The default value is: NO. + +OPTIMIZE_OUTPUT_SLICE = NO + +# Doxygen selects the parser to use depending on the extension of the files it +# parses. With this tag you can assign which parser to use for a given +# extension. Doxygen has a built-in mapping, but you can override or extend it +# using this tag. The format is ext=language, where ext is a file extension, and +# language is one of the parsers supported by doxygen: IDL, Java, JavaScript, +# Csharp (C#), C, C++, D, PHP, md (Markdown), Objective-C, Python, Slice, VHDL, +# Fortran (fixed format Fortran: FortranFixed, free formatted Fortran: +# FortranFree, unknown formatted Fortran: Fortran. In the later case the parser +# tries to guess whether the code is fixed or free formatted code, this is the +# default for Fortran type files). For instance to make doxygen treat .inc files +# as Fortran files (default is PHP), and .f files as C (default is Fortran), +# use: inc=Fortran f=C. +# +# Note: For files without extension you can use no_extension as a placeholder. +# +# Note that for custom extensions you also need to set FILE_PATTERNS otherwise +# the files are not read by doxygen. + +EXTENSION_MAPPING = + +# If the MARKDOWN_SUPPORT tag is enabled then doxygen pre-processes all comments +# according to the Markdown format, which allows for more readable +# documentation. See https://daringfireball.net/projects/markdown/ for details. +# The output of markdown processing is further processed by doxygen, so you can +# mix doxygen, HTML, and XML commands with Markdown formatting. Disable only in +# case of backward compatibilities issues. +# The default value is: YES. + +MARKDOWN_SUPPORT = YES + +# When the TOC_INCLUDE_HEADINGS tag is set to a non-zero value, all headings up +# to that level are automatically included in the table of contents, even if +# they do not have an id attribute. +# Note: This feature currently applies only to Markdown headings. +# Minimum value: 0, maximum value: 99, default value: 5. +# This tag requires that the tag MARKDOWN_SUPPORT is set to YES. + +TOC_INCLUDE_HEADINGS = 0 + +# When enabled doxygen tries to link words that correspond to documented +# classes, or namespaces to their corresponding documentation. Such a link can +# be prevented in individual cases by putting a % sign in front of the word or +# globally by setting AUTOLINK_SUPPORT to NO. +# The default value is: YES. + +AUTOLINK_SUPPORT = YES + +# If you use STL classes (i.e. std::string, std::vector, etc.) but do not want +# to include (a tag file for) the STL sources as input, then you should set this +# tag to YES in order to let doxygen match functions declarations and +# definitions whose arguments contain STL classes (e.g. func(std::string); +# versus func(std::string) {}). This also make the inheritance and collaboration +# diagrams that involve STL classes more complete and accurate. +# The default value is: NO. + +BUILTIN_STL_SUPPORT = NO + +# If you use Microsoft's C++/CLI language, you should set this option to YES to +# enable parsing support. +# The default value is: NO. + +CPP_CLI_SUPPORT = NO + +# Set the SIP_SUPPORT tag to YES if your project consists of sip (see: +# https://www.riverbankcomputing.com/software/sip/intro) sources only. Doxygen +# will parse them like normal C++ but will assume all classes use public instead +# of private inheritance when no explicit protection keyword is present. +# The default value is: NO. + +SIP_SUPPORT = NO + +# For Microsoft's IDL there are propget and propput attributes to indicate +# getter and setter methods for a property. Setting this option to YES will make +# doxygen to replace the get and set methods by a property in the documentation. +# This will only work if the methods are indeed getting or setting a simple +# type. If this is not the case, or you want to show the methods anyway, you +# should set this option to NO. +# The default value is: YES. + +IDL_PROPERTY_SUPPORT = YES + +# If member grouping is used in the documentation and the DISTRIBUTE_GROUP_DOC +# tag is set to YES then doxygen will reuse the documentation of the first +# member in the group (if any) for the other members of the group. By default +# all members of a group must be documented explicitly. +# The default value is: NO. + +DISTRIBUTE_GROUP_DOC = YES + +# If one adds a struct or class to a group and this option is enabled, then also +# any nested class or struct is added to the same group. By default this option +# is disabled and one has to add nested compounds explicitly via \ingroup. +# The default value is: NO. + +GROUP_NESTED_COMPOUNDS = NO + +# Set the SUBGROUPING tag to YES to allow class member groups of the same type +# (for instance a group of public functions) to be put as a subgroup of that +# type (e.g. under the Public Functions section). Set it to NO to prevent +# subgrouping. Alternatively, this can be done per class using the +# \nosubgrouping command. +# The default value is: YES. + +SUBGROUPING = YES + +# When the INLINE_GROUPED_CLASSES tag is set to YES, classes, structs and unions +# are shown inside the group in which they are included (e.g. using \ingroup) +# instead of on a separate page (for HTML and Man pages) or section (for LaTeX +# and RTF). +# +# Note that this feature does not work in combination with +# SEPARATE_MEMBER_PAGES. +# The default value is: NO. + +INLINE_GROUPED_CLASSES = NO + +# When the INLINE_SIMPLE_STRUCTS tag is set to YES, structs, classes, and unions +# with only public data fields or simple typedef fields will be shown inline in +# the documentation of the scope in which they are defined (i.e. file, +# namespace, or group documentation), provided this scope is documented. If set +# to NO, structs, classes, and unions are shown on a separate page (for HTML and +# Man pages) or section (for LaTeX and RTF). +# The default value is: NO. + +INLINE_SIMPLE_STRUCTS = NO + +# When TYPEDEF_HIDES_STRUCT tag is enabled, a typedef of a struct, union, or +# enum is documented as struct, union, or enum with the name of the typedef. So +# typedef struct TypeS {} TypeT, will appear in the documentation as a struct +# with name TypeT. When disabled the typedef will appear as a member of a file, +# namespace, or class. And the struct will be named TypeS. This can typically be +# useful for C code in case the coding convention dictates that all compound +# types are typedef'ed and only the typedef is referenced, never the tag name. +# The default value is: NO. + +TYPEDEF_HIDES_STRUCT = NO + +# The size of the symbol lookup cache can be set using LOOKUP_CACHE_SIZE. This +# cache is used to resolve symbols given their name and scope. Since this can be +# an expensive process and often the same symbol appears multiple times in the +# code, doxygen keeps a cache of pre-resolved symbols. If the cache is too small +# doxygen will become slower. If the cache is too large, memory is wasted. The +# cache size is given by this formula: 2^(16+LOOKUP_CACHE_SIZE). The valid range +# is 0..9, the default is 0, corresponding to a cache size of 2^16=65536 +# symbols. At the end of a run doxygen will report the cache usage and suggest +# the optimal cache size from a speed point of view. +# Minimum value: 0, maximum value: 9, default value: 0. + +LOOKUP_CACHE_SIZE = 0 + +# The NUM_PROC_THREADS specifies the number threads doxygen is allowed to use +# during processing. When set to 0 doxygen will based this on the number of +# cores available in the system. You can set it explicitly to a value larger +# than 0 to get more control over the balance between CPU load and processing +# speed. At this moment only the input processing can be done using multiple +# threads. Since this is still an experimental feature the default is set to 1, +# which efficively disables parallel processing. Please report any issues you +# encounter. Generating dot graphs in parallel is controlled by the +# DOT_NUM_THREADS setting. +# Minimum value: 0, maximum value: 32, default value: 1. + +NUM_PROC_THREADS = 1 + +#--------------------------------------------------------------------------- +# Build related configuration options +#--------------------------------------------------------------------------- + +# If the EXTRACT_ALL tag is set to YES, doxygen will assume all entities in +# documentation are documented, even if no documentation was available. Private +# class members and static file members will be hidden unless the +# EXTRACT_PRIVATE respectively EXTRACT_STATIC tags are set to YES. +# Note: This will also disable the warnings about undocumented members that are +# normally produced when WARNINGS is set to YES. +# The default value is: NO. + +EXTRACT_ALL = NO + +# If the EXTRACT_PRIVATE tag is set to YES, all private members of a class will +# be included in the documentation. +# The default value is: NO. + +EXTRACT_PRIVATE = YES + +# If the EXTRACT_PRIV_VIRTUAL tag is set to YES, documented private virtual +# methods of a class will be included in the documentation. +# The default value is: NO. + +EXTRACT_PRIV_VIRTUAL = NO + +# If the EXTRACT_PACKAGE tag is set to YES, all members with package or internal +# scope will be included in the documentation. +# The default value is: NO. + +EXTRACT_PACKAGE = YES + +# If the EXTRACT_STATIC tag is set to YES, all static members of a file will be +# included in the documentation. +# The default value is: NO. + +EXTRACT_STATIC = YES + +# If the EXTRACT_LOCAL_CLASSES tag is set to YES, classes (and structs) defined +# locally in source files will be included in the documentation. If set to NO, +# only classes defined in header files are included. Does not have any effect +# for Java sources. +# The default value is: YES. + +EXTRACT_LOCAL_CLASSES = YES + +# This flag is only useful for Objective-C code. If set to YES, local methods, +# which are defined in the implementation section but not in the interface are +# included in the documentation. If set to NO, only methods in the interface are +# included. +# The default value is: NO. + +EXTRACT_LOCAL_METHODS = YES + +# If this flag is set to YES, the members of anonymous namespaces will be +# extracted and appear in the documentation as a namespace called +# 'anonymous_namespace{file}', where file will be replaced with the base name of +# the file that contains the anonymous namespace. By default anonymous namespace +# are hidden. +# The default value is: NO. + +EXTRACT_ANON_NSPACES = YES + +# If the HIDE_UNDOC_MEMBERS tag is set to YES, doxygen will hide all +# undocumented members inside documented classes or files. If set to NO these +# members will be included in the various overviews, but no documentation +# section is generated. This option has no effect if EXTRACT_ALL is enabled. +# The default value is: NO. + +HIDE_UNDOC_MEMBERS = NO + +# If the HIDE_UNDOC_CLASSES tag is set to YES, doxygen will hide all +# undocumented classes that are normally visible in the class hierarchy. If set +# to NO, these classes will be included in the various overviews. This option +# has no effect if EXTRACT_ALL is enabled. +# The default value is: NO. + +HIDE_UNDOC_CLASSES = NO + +# If the HIDE_FRIEND_COMPOUNDS tag is set to YES, doxygen will hide all friend +# declarations. If set to NO, these declarations will be included in the +# documentation. +# The default value is: NO. + +HIDE_FRIEND_COMPOUNDS = NO + +# If the HIDE_IN_BODY_DOCS tag is set to YES, doxygen will hide any +# documentation blocks found inside the body of a function. If set to NO, these +# blocks will be appended to the function's detailed documentation block. +# The default value is: NO. + +HIDE_IN_BODY_DOCS = NO + +# The INTERNAL_DOCS tag determines if documentation that is typed after a +# \internal command is included. If the tag is set to NO then the documentation +# will be excluded. Set it to YES to include the internal documentation. +# The default value is: NO. + +INTERNAL_DOCS = YES + +# If the CASE_SENSE_NAMES tag is set to NO then doxygen will only generate file +# names in lower-case letters. If set to YES, upper-case letters are also +# allowed. This is useful if you have classes or files whose names only differ +# in case and if your file system supports case sensitive file names. Windows +# (including Cygwin) and Mac users are advised to set this option to NO. +# The default value is: system dependent. + +CASE_SENSE_NAMES = YES + +# If the HIDE_SCOPE_NAMES tag is set to NO then doxygen will show members with +# their full class and namespace scopes in the documentation. If set to YES, the +# scope will be hidden. +# The default value is: NO. + +HIDE_SCOPE_NAMES = NO + +# If the HIDE_COMPOUND_REFERENCE tag is set to NO (default) then doxygen will +# append additional text to a page's title, such as Class Reference. If set to +# YES the compound reference will be hidden. +# The default value is: NO. + +HIDE_COMPOUND_REFERENCE= NO + +# If the SHOW_INCLUDE_FILES tag is set to YES then doxygen will put a list of +# the files that are included by a file in the documentation of that file. +# The default value is: YES. + +SHOW_INCLUDE_FILES = YES + +# If the SHOW_GROUPED_MEMB_INC tag is set to YES then Doxygen will add for each +# grouped member an include statement to the documentation, telling the reader +# which file to include in order to use the member. +# The default value is: NO. + +SHOW_GROUPED_MEMB_INC = NO + +# If the FORCE_LOCAL_INCLUDES tag is set to YES then doxygen will list include +# files with double quotes in the documentation rather than with sharp brackets. +# The default value is: NO. + +FORCE_LOCAL_INCLUDES = NO + +# If the INLINE_INFO tag is set to YES then a tag [inline] is inserted in the +# documentation for inline members. +# The default value is: YES. + +INLINE_INFO = YES + +# If the SORT_MEMBER_DOCS tag is set to YES then doxygen will sort the +# (detailed) documentation of file and class members alphabetically by member +# name. If set to NO, the members will appear in declaration order. +# The default value is: YES. + +SORT_MEMBER_DOCS = YES + +# If the SORT_BRIEF_DOCS tag is set to YES then doxygen will sort the brief +# descriptions of file, namespace and class members alphabetically by member +# name. If set to NO, the members will appear in declaration order. Note that +# this will also influence the order of the classes in the class list. +# The default value is: NO. + +SORT_BRIEF_DOCS = NO + +# If the SORT_MEMBERS_CTORS_1ST tag is set to YES then doxygen will sort the +# (brief and detailed) documentation of class members so that constructors and +# destructors are listed first. If set to NO the constructors will appear in the +# respective orders defined by SORT_BRIEF_DOCS and SORT_MEMBER_DOCS. +# Note: If SORT_BRIEF_DOCS is set to NO this option is ignored for sorting brief +# member documentation. +# Note: If SORT_MEMBER_DOCS is set to NO this option is ignored for sorting +# detailed member documentation. +# The default value is: NO. + +SORT_MEMBERS_CTORS_1ST = NO + +# If the SORT_GROUP_NAMES tag is set to YES then doxygen will sort the hierarchy +# of group names into alphabetical order. If set to NO the group names will +# appear in their defined order. +# The default value is: NO. + +SORT_GROUP_NAMES = NO + +# If the SORT_BY_SCOPE_NAME tag is set to YES, the class list will be sorted by +# fully-qualified names, including namespaces. If set to NO, the class list will +# be sorted only by class name, not including the namespace part. +# Note: This option is not very useful if HIDE_SCOPE_NAMES is set to YES. +# Note: This option applies only to the class list, not to the alphabetical +# list. +# The default value is: NO. + +SORT_BY_SCOPE_NAME = NO + +# If the STRICT_PROTO_MATCHING option is enabled and doxygen fails to do proper +# type resolution of all parameters of a function it will reject a match between +# the prototype and the implementation of a member function even if there is +# only one candidate or it is obvious which candidate to choose by doing a +# simple string match. By disabling STRICT_PROTO_MATCHING doxygen will still +# accept a match between prototype and implementation in such cases. +# The default value is: NO. + +STRICT_PROTO_MATCHING = NO + +# The GENERATE_TODOLIST tag can be used to enable (YES) or disable (NO) the todo +# list. This list is created by putting \todo commands in the documentation. +# The default value is: YES. + +GENERATE_TODOLIST = YES + +# The GENERATE_TESTLIST tag can be used to enable (YES) or disable (NO) the test +# list. This list is created by putting \test commands in the documentation. +# The default value is: YES. + +GENERATE_TESTLIST = YES + +# The GENERATE_BUGLIST tag can be used to enable (YES) or disable (NO) the bug +# list. This list is created by putting \bug commands in the documentation. +# The default value is: YES. + +GENERATE_BUGLIST = YES + +# The GENERATE_DEPRECATEDLIST tag can be used to enable (YES) or disable (NO) +# the deprecated list. This list is created by putting \deprecated commands in +# the documentation. +# The default value is: YES. + +GENERATE_DEPRECATEDLIST= YES + +# The ENABLED_SECTIONS tag can be used to enable conditional documentation +# sections, marked by \if ... \endif and \cond +# ... \endcond blocks. + +ENABLED_SECTIONS = + +# The MAX_INITIALIZER_LINES tag determines the maximum number of lines that the +# initial value of a variable or macro / define can have for it to appear in the +# documentation. If the initializer consists of more lines than specified here +# it will be hidden. Use a value of 0 to hide initializers completely. The +# appearance of the value of individual variables and macros / defines can be +# controlled using \showinitializer or \hideinitializer command in the +# documentation regardless of this setting. +# Minimum value: 0, maximum value: 10000, default value: 30. + +MAX_INITIALIZER_LINES = 30 + +# Set the SHOW_USED_FILES tag to NO to disable the list of files generated at +# the bottom of the documentation of classes and structs. If set to YES, the +# list will mention the files that were used to generate the documentation. +# The default value is: YES. + +SHOW_USED_FILES = YES + +# Set the SHOW_FILES tag to NO to disable the generation of the Files page. This +# will remove the Files entry from the Quick Index and from the Folder Tree View +# (if specified). +# The default value is: YES. + +SHOW_FILES = YES + +# Set the SHOW_NAMESPACES tag to NO to disable the generation of the Namespaces +# page. This will remove the Namespaces entry from the Quick Index and from the +# Folder Tree View (if specified). +# The default value is: YES. + +SHOW_NAMESPACES = YES + +# The FILE_VERSION_FILTER tag can be used to specify a program or script that +# doxygen should invoke to get the current version for each file (typically from +# the version control system). Doxygen will invoke the program by executing (via +# popen()) the command command input-file, where command is the value of the +# FILE_VERSION_FILTER tag, and input-file is the name of an input file provided +# by doxygen. Whatever the program writes to standard output is used as the file +# version. For an example see the documentation. + +FILE_VERSION_FILTER = + +# The LAYOUT_FILE tag can be used to specify a layout file which will be parsed +# by doxygen. The layout file controls the global structure of the generated +# output files in an output format independent way. To create the layout file +# that represents doxygen's defaults, run doxygen with the -l option. You can +# optionally specify a file name after the option, if omitted DoxygenLayout.xml +# will be used as the name of the layout file. +# +# Note that if you run doxygen from a directory containing a file called +# DoxygenLayout.xml, doxygen will parse it automatically even if the LAYOUT_FILE +# tag is left empty. + +LAYOUT_FILE = layout.xml + +# The CITE_BIB_FILES tag can be used to specify one or more bib files containing +# the reference definitions. This must be a list of .bib files. The .bib +# extension is automatically appended if omitted. This requires the bibtex tool +# to be installed. See also https://en.wikipedia.org/wiki/BibTeX for more info. +# For LaTeX the style of the bibliography can be controlled using +# LATEX_BIB_STYLE. To use this feature you need bibtex and perl available in the +# search path. See also \cite for info how to create references. + +CITE_BIB_FILES = ocean.bib references.bib zotero.bib + +#--------------------------------------------------------------------------- +# Configuration options related to warning and progress messages +#--------------------------------------------------------------------------- + +# The QUIET tag can be used to turn on/off the messages that are generated to +# standard output by doxygen. If QUIET is set to YES this implies that the +# messages are off. +# The default value is: NO. + +QUIET = NO + +# The WARNINGS tag can be used to turn on/off the warning messages that are +# generated to standard error (stderr) by doxygen. If WARNINGS is set to YES +# this implies that the warnings are on. +# +# Tip: Turn warnings on while writing the documentation. +# The default value is: YES. + +WARNINGS = YES + +# If the WARN_IF_UNDOCUMENTED tag is set to YES then doxygen will generate +# warnings for undocumented members. If EXTRACT_ALL is set to YES then this flag +# will automatically be disabled. +# The default value is: YES. + +WARN_IF_UNDOCUMENTED = YES + +# If the WARN_IF_DOC_ERROR tag is set to YES, doxygen will generate warnings for +# potential errors in the documentation, such as not documenting some parameters +# in a documented function, or documenting parameters that don't exist or using +# markup commands wrongly. +# The default value is: YES. + +WARN_IF_DOC_ERROR = YES + +# This WARN_NO_PARAMDOC option can be enabled to get warnings for functions that +# are documented, but have no documentation for their parameters or return +# value. If set to NO, doxygen will only warn about wrong or incomplete +# parameter documentation, but not about the absence of documentation. If +# EXTRACT_ALL is set to YES then this flag will automatically be disabled. +# The default value is: NO. + +WARN_NO_PARAMDOC = NO + +# If the WARN_AS_ERROR tag is set to YES then doxygen will immediately stop when +# a warning is encountered. +# The default value is: NO. + +WARN_AS_ERROR = NO + +# The WARN_FORMAT tag determines the format of the warning messages that doxygen +# can produce. The string should contain the $file, $line, and $text tags, which +# will be replaced by the file and line number from which the warning originated +# and the warning text. Optionally the format may contain $version, which will +# be replaced by the version of the file (if it could be obtained via +# FILE_VERSION_FILTER) +# The default value is: $file:$line: $text. + +WARN_FORMAT = "$file:$line: $text" + +# The WARN_LOGFILE tag can be used to specify a file to which warning and error +# messages should be written. If left blank the output is written to standard +# error (stderr). + +WARN_LOGFILE = _build/doxygen_warn_nortd_latex_log.txt + +#--------------------------------------------------------------------------- +# Configuration options related to the input files +#--------------------------------------------------------------------------- + +# The INPUT tag is used to specify the files and/or directories that contain +# documented source files. You may enter file names like myfile.cpp or +# directories like /usr/src/myproject. Separate the files or directories with +# spaces. See also FILE_PATTERNS and EXTENSION_MAPPING +# Note: If this tag is empty the current directory is searched. + +INPUT = ../src \ + front_page.md \ + ../config_src/solo_driver \ + ../config_src/dynamic_symmetric \ + ../config_src/external \ + ../config_src/coupled_driver + +# This tag can be used to specify the character encoding of the source files +# that doxygen parses. Internally doxygen uses the UTF-8 encoding. Doxygen uses +# libiconv (or the iconv built into libc) for the transcoding. See the libiconv +# documentation (see: https://www.gnu.org/software/libiconv/) for the list of +# possible encodings. +# The default value is: UTF-8. + +INPUT_ENCODING = UTF-8 + +# If the value of the INPUT tag contains directories, you can use the +# FILE_PATTERNS tag to specify one or more wildcard patterns (like *.cpp and +# *.h) to filter out the source-files in the directories. +# +# Note that for custom extensions or not directly supported extensions you also +# need to set EXTENSION_MAPPING for the extension otherwise the files are not +# read by doxygen. +# +# If left blank the following patterns are tested:*.c, *.cc, *.cxx, *.cpp, +# *.c++, *.java, *.ii, *.ixx, *.ipp, *.i++, *.inl, *.idl, *.ddl, *.odl, *.h, +# *.hh, *.hxx, *.hpp, *.h++, *.cs, *.d, *.php, *.php4, *.php5, *.phtml, *.inc, +# *.m, *.markdown, *.md, *.mm, *.dox (to be provided as doxygen C comment), +# *.doc (to be provided as doxygen C comment), *.txt (to be provided as doxygen +# C comment), *.py, *.pyw, *.f90, *.f95, *.f03, *.f08, *.f18, *.f, *.for, *.vhd, +# *.vhdl, *.ucf, *.qsf and *.ice. + +FILE_PATTERNS = *.c \ + *.cc \ + *.cxx \ + *.cpp \ + *.c++ \ + *.java \ + *.ii \ + *.ixx \ + *.ipp \ + *.i++ \ + *.inl \ + *.idl \ + *.ddl \ + *.odl \ + *.h \ + *.hh \ + *.hxx \ + *.hpp \ + *.h++ \ + *.cs \ + *.d \ + *.php \ + *.php4 \ + *.php5 \ + *.phtml \ + *.inc \ + *.m \ + *.markdown \ + *.md \ + *.mm \ + *.dox \ + *.doc \ + *.txt \ + *.py \ + *.pyw \ + *.f90 \ + *.f95 \ + *.f03 \ + *.f08 \ + *.f18 \ + *.f \ + *.for \ + *.vhd \ + *.vhdl \ + *.ucf \ + *.qsf \ + *.ice \ + *.F90 + +# The RECURSIVE tag can be used to specify whether or not subdirectories should +# be searched for input files as well. +# The default value is: NO. + +RECURSIVE = YES + +# The EXCLUDE tag can be used to specify files and/or directories that should be +# excluded from the INPUT source files. This way you can easily exclude a +# subdirectory from a directory tree whose root is specified with the INPUT tag. +# +# Note that relative paths are relative to the directory from which doxygen is +# run. + +EXCLUDE = ../src/equation_of_state/TEOS10 + +# The EXCLUDE_SYMLINKS tag can be used to select whether or not files or +# directories that are symbolic links (a Unix file system feature) are excluded +# from the input. +# The default value is: NO. + +EXCLUDE_SYMLINKS = NO + +# If the value of the INPUT tag contains directories, you can use the +# EXCLUDE_PATTERNS tag to specify one or more wildcard patterns to exclude +# certain files from those directories. +# +# Note that the wildcards are matched against the file with absolute path, so to +# exclude all test directories for example use the pattern */test/* + +EXCLUDE_PATTERNS = makedep.py \ + Makefile \ + INSTALL + +# The EXCLUDE_SYMBOLS tag can be used to specify one or more symbol names +# (namespaces, classes, functions, etc.) that should be excluded from the +# output. The symbol name can be a fully qualified name, a word, or if the +# wildcard * is used, a substring. Examples: ANamespace, AClass, +# AClass::ANamespace, ANamespace::*Test +# +# Note that the wildcards are matched against the file with absolute path, so to +# exclude all test directories use the pattern */test/* + +EXCLUDE_SYMBOLS = + +# The EXAMPLE_PATH tag can be used to specify one or more files or directories +# that contain example code fragments that are included (see the \include +# command). + +EXAMPLE_PATH = ../src + +# If the value of the EXAMPLE_PATH tag contains directories, you can use the +# EXAMPLE_PATTERNS tag to specify one or more wildcard pattern (like *.cpp and +# *.h) to filter out the source-files in the directories. If left blank all +# files are included. + +EXAMPLE_PATTERNS = * + +# If the EXAMPLE_RECURSIVE tag is set to YES then subdirectories will be +# searched for input files to be used with the \include or \dontinclude commands +# irrespective of the value of the RECURSIVE tag. +# The default value is: NO. + +EXAMPLE_RECURSIVE = NO + +# The IMAGE_PATH tag can be used to specify one or more files or directories +# that contain images that are to be included in the documentation (see the +# \image command). + +IMAGE_PATH = images \ + ../src + +# The INPUT_FILTER tag can be used to specify a program that doxygen should +# invoke to filter for each input file. Doxygen will invoke the filter program +# by executing (via popen()) the command: +# +# +# +# where is the value of the INPUT_FILTER tag, and is the +# name of an input file. Doxygen will then use the output that the filter +# program writes to standard output. If FILTER_PATTERNS is specified, this tag +# will be ignored. +# +# Note that the filter must not add or remove lines; it is applied before the +# code is scanned, but not when the output code is generated. If lines are added +# or removed, the anchors will not be placed correctly. +# +# Note that for custom extensions or not directly supported extensions you also +# need to set EXTENSION_MAPPING for the extension otherwise the files are not +# properly processed by doxygen. + +INPUT_FILTER = + +# The FILTER_PATTERNS tag can be used to specify filters on a per file pattern +# basis. Doxygen will compare the file name with each pattern and apply the +# filter if there is a match. The filters are a list of the form: pattern=filter +# (like *.cpp=my_cpp_filter). See INPUT_FILTER for further information on how +# filters are used. If the FILTER_PATTERNS tag is empty or if none of the +# patterns match the file name, INPUT_FILTER is applied. +# +# Note that for custom extensions or not directly supported extensions you also +# need to set EXTENSION_MAPPING for the extension otherwise the files are not +# properly processed by doxygen. + +FILTER_PATTERNS = + +# If the FILTER_SOURCE_FILES tag is set to YES, the input filter (if set using +# INPUT_FILTER) will also be used to filter the input files that are used for +# producing the source files to browse (i.e. when SOURCE_BROWSER is set to YES). +# The default value is: NO. + +FILTER_SOURCE_FILES = NO + +# The FILTER_SOURCE_PATTERNS tag can be used to specify source filters per file +# pattern. A pattern will override the setting for FILTER_PATTERN (if any) and +# it is also possible to disable source filtering for a specific pattern using +# *.ext= (so without naming a filter). +# This tag requires that the tag FILTER_SOURCE_FILES is set to YES. + +FILTER_SOURCE_PATTERNS = + +# If the USE_MDFILE_AS_MAINPAGE tag refers to the name of a markdown file that +# is part of the input, its contents will be placed on the main page +# (index.html). This can be useful if you have a project on for instance GitHub +# and want to reuse the introduction page also for the doxygen output. + +USE_MDFILE_AS_MAINPAGE = front_page.md + +#--------------------------------------------------------------------------- +# Configuration options related to source browsing +#--------------------------------------------------------------------------- + +# If the SOURCE_BROWSER tag is set to YES then a list of source files will be +# generated. Documented entities will be cross-referenced with these sources. +# +# Note: To get rid of all source code in the generated output, make sure that +# also VERBATIM_HEADERS is set to NO. +# The default value is: NO. + +SOURCE_BROWSER = YES + +# Setting the INLINE_SOURCES tag to YES will include the body of functions, +# classes and enums directly into the documentation. +# The default value is: NO. + +INLINE_SOURCES = YES + +# Setting the STRIP_CODE_COMMENTS tag to YES will instruct doxygen to hide any +# special comment blocks from generated source code fragments. Normal C, C++ and +# Fortran comments will always remain visible. +# The default value is: YES. + +STRIP_CODE_COMMENTS = NO + +# If the REFERENCED_BY_RELATION tag is set to YES then for each documented +# entity all documented functions referencing it will be listed. +# The default value is: NO. + +REFERENCED_BY_RELATION = YES + +# If the REFERENCES_RELATION tag is set to YES then for each documented function +# all documented entities called/used by that function will be listed. +# The default value is: NO. + +REFERENCES_RELATION = YES + +# If the REFERENCES_LINK_SOURCE tag is set to YES and SOURCE_BROWSER tag is set +# to YES then the hyperlinks from functions in REFERENCES_RELATION and +# REFERENCED_BY_RELATION lists will link to the source code. Otherwise they will +# link to the documentation. +# The default value is: YES. + +REFERENCES_LINK_SOURCE = YES + +# If SOURCE_TOOLTIPS is enabled (the default) then hovering a hyperlink in the +# source code will show a tooltip with additional information such as prototype, +# brief description and links to the definition and documentation. Since this +# will make the HTML file larger and loading of large files a bit slower, you +# can opt to disable this feature. +# The default value is: YES. +# This tag requires that the tag SOURCE_BROWSER is set to YES. + +SOURCE_TOOLTIPS = YES + +# If the USE_HTAGS tag is set to YES then the references to source code will +# point to the HTML generated by the htags(1) tool instead of doxygen built-in +# source browser. The htags tool is part of GNU's global source tagging system +# (see https://www.gnu.org/software/global/global.html). You will need version +# 4.8.6 or higher. +# +# To use it do the following: +# - Install the latest version of global +# - Enable SOURCE_BROWSER and USE_HTAGS in the configuration file +# - Make sure the INPUT points to the root of the source tree +# - Run doxygen as normal +# +# Doxygen will invoke htags (and that will in turn invoke gtags), so these +# tools must be available from the command line (i.e. in the search path). +# +# The result: instead of the source browser generated by doxygen, the links to +# source code will now point to the output of htags. +# The default value is: NO. +# This tag requires that the tag SOURCE_BROWSER is set to YES. + +USE_HTAGS = NO + +# If the VERBATIM_HEADERS tag is set the YES then doxygen will generate a +# verbatim copy of the header file for each class for which an include is +# specified. Set to NO to disable this. +# See also: Section \class. +# The default value is: YES. + +VERBATIM_HEADERS = YES + +#--------------------------------------------------------------------------- +# Configuration options related to the alphabetical class index +#--------------------------------------------------------------------------- + +# If the ALPHABETICAL_INDEX tag is set to YES, an alphabetical index of all +# compounds will be generated. Enable this if the project contains a lot of +# classes, structs, unions or interfaces. +# The default value is: YES. + +ALPHABETICAL_INDEX = YES + +# The COLS_IN_ALPHA_INDEX tag can be used to specify the number of columns in +# which the alphabetical index list will be split. +# Minimum value: 1, maximum value: 20, default value: 5. +# This tag requires that the tag ALPHABETICAL_INDEX is set to YES. + +COLS_IN_ALPHA_INDEX = 1 + +# In case all classes in a project start with a common prefix, all classes will +# be put under the same header in the alphabetical index. The IGNORE_PREFIX tag +# can be used to specify a prefix (or a list of prefixes) that should be ignored +# while generating the index headers. +# This tag requires that the tag ALPHABETICAL_INDEX is set to YES. + +IGNORE_PREFIX = + +#--------------------------------------------------------------------------- +# Configuration options related to the HTML output +#--------------------------------------------------------------------------- + +# If the GENERATE_HTML tag is set to YES, doxygen will generate HTML output +# The default value is: YES. + +GENERATE_HTML = YES + +# The HTML_OUTPUT tag is used to specify where the HTML docs will be put. If a +# relative path is entered the value of OUTPUT_DIRECTORY will be put in front of +# it. +# The default directory is: html. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_OUTPUT = _build/APIs + +# The HTML_FILE_EXTENSION tag can be used to specify the file extension for each +# generated HTML page (for example: .htm, .php, .asp). +# The default value is: .html. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_FILE_EXTENSION = .html + +# The HTML_HEADER tag can be used to specify a user-defined HTML header file for +# each generated HTML page. If the tag is left blank doxygen will generate a +# standard header. +# +# To get valid HTML the header file that includes any scripts and style sheets +# that doxygen needs, which is dependent on the configuration options used (e.g. +# the setting GENERATE_TREEVIEW). It is highly recommended to start with a +# default header using +# doxygen -w html new_header.html new_footer.html new_stylesheet.css +# YourConfigFile +# and then modify the file new_header.html. See also section "Doxygen usage" +# for information on how to generate the default header that doxygen normally +# uses. +# Note: The header is subject to change so you typically have to regenerate the +# default header when upgrading to a newer version of doxygen. For a description +# of the possible markers and block names see the documentation. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_HEADER = + +# The HTML_FOOTER tag can be used to specify a user-defined HTML footer for each +# generated HTML page. If the tag is left blank doxygen will generate a standard +# footer. See HTML_HEADER for more information on how to generate a default +# footer and what special commands can be used inside the footer. See also +# section "Doxygen usage" for information on how to generate the default footer +# that doxygen normally uses. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_FOOTER = + +# The HTML_STYLESHEET tag can be used to specify a user-defined cascading style +# sheet that is used by each HTML page. It can be used to fine-tune the look of +# the HTML output. If left blank doxygen will generate a default style sheet. +# See also section "Doxygen usage" for information on how to generate the style +# sheet that doxygen normally uses. +# Note: It is recommended to use HTML_EXTRA_STYLESHEET instead of this tag, as +# it is more robust and this tag (HTML_STYLESHEET) will in the future become +# obsolete. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_STYLESHEET = + +# The HTML_EXTRA_STYLESHEET tag can be used to specify additional user-defined +# cascading style sheets that are included after the standard style sheets +# created by doxygen. Using this option one can overrule certain style aspects. +# This is preferred over using HTML_STYLESHEET since it does not replace the +# standard style sheet and is therefore more robust against future updates. +# Doxygen will copy the style sheet files to the output directory. +# Note: The order of the extra style sheet files is of importance (e.g. the last +# style sheet in the list overrules the setting of the previous ones in the +# list). For an example see the documentation. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_EXTRA_STYLESHEET = + +# The HTML_EXTRA_FILES tag can be used to specify one or more extra images or +# other source files which should be copied to the HTML output directory. Note +# that these files will be copied to the base HTML output directory. Use the +# $relpath^ marker in the HTML_HEADER and/or HTML_FOOTER files to load these +# files. In the HTML_STYLESHEET file, use the file name only. Also note that the +# files will be copied as-is; there are no commands or markers available. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_EXTRA_FILES = + +# The HTML_COLORSTYLE_HUE tag controls the color of the HTML output. Doxygen +# will adjust the colors in the style sheet and background images according to +# this color. Hue is specified as an angle on a colorwheel, see +# https://en.wikipedia.org/wiki/Hue for more information. For instance the value +# 0 represents red, 60 is yellow, 120 is green, 180 is cyan, 240 is blue, 300 +# purple, and 360 is red again. +# Minimum value: 0, maximum value: 359, default value: 220. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_COLORSTYLE_HUE = 220 + +# The HTML_COLORSTYLE_SAT tag controls the purity (or saturation) of the colors +# in the HTML output. For a value of 0 the output will use grayscales only. A +# value of 255 will produce the most vivid colors. +# Minimum value: 0, maximum value: 255, default value: 100. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_COLORSTYLE_SAT = 100 + +# The HTML_COLORSTYLE_GAMMA tag controls the gamma correction applied to the +# luminance component of the colors in the HTML output. Values below 100 +# gradually make the output lighter, whereas values above 100 make the output +# darker. The value divided by 100 is the actual gamma applied, so 80 represents +# a gamma of 0.8, The value 220 represents a gamma of 2.2, and 100 does not +# change the gamma. +# Minimum value: 40, maximum value: 240, default value: 80. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_COLORSTYLE_GAMMA = 80 + +# If the HTML_TIMESTAMP tag is set to YES then the footer of each generated HTML +# page will contain the date and time when the page was generated. Setting this +# to YES can help to show when doxygen was last run and thus if the +# documentation is up to date. +# The default value is: NO. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_TIMESTAMP = NO + +# If the HTML_DYNAMIC_MENUS tag is set to YES then the generated HTML +# documentation will contain a main index with vertical navigation menus that +# are dynamically created via JavaScript. If disabled, the navigation index will +# consists of multiple levels of tabs that are statically embedded in every HTML +# page. Disable this option to support browsers that do not have JavaScript, +# like the Qt help browser. +# The default value is: YES. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_DYNAMIC_MENUS = YES + +# If the HTML_DYNAMIC_SECTIONS tag is set to YES then the generated HTML +# documentation will contain sections that can be hidden and shown after the +# page has loaded. +# The default value is: NO. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_DYNAMIC_SECTIONS = NO + +# With HTML_INDEX_NUM_ENTRIES one can control the preferred number of entries +# shown in the various tree structured indices initially; the user can expand +# and collapse entries dynamically later on. Doxygen will expand the tree to +# such a level that at most the specified number of entries are visible (unless +# a fully collapsed tree already exceeds this amount). So setting the number of +# entries 1 will produce a full collapsed tree by default. 0 is a special value +# representing an infinite number of entries and will result in a full expanded +# tree by default. +# Minimum value: 0, maximum value: 9999, default value: 100. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_INDEX_NUM_ENTRIES = 900 + +# If the GENERATE_DOCSET tag is set to YES, additional index files will be +# generated that can be used as input for Apple's Xcode 3 integrated development +# environment (see: https://developer.apple.com/xcode/), introduced with OSX +# 10.5 (Leopard). To create a documentation set, doxygen will generate a +# Makefile in the HTML output directory. Running make will produce the docset in +# that directory and running make install will install the docset in +# ~/Library/Developer/Shared/Documentation/DocSets so that Xcode will find it at +# startup. See https://developer.apple.com/library/archive/featuredarticles/Doxy +# genXcode/_index.html for more information. +# The default value is: NO. +# This tag requires that the tag GENERATE_HTML is set to YES. + +GENERATE_DOCSET = NO + +# This tag determines the name of the docset feed. A documentation feed provides +# an umbrella under which multiple documentation sets from a single provider +# (such as a company or product suite) can be grouped. +# The default value is: Doxygen generated docs. +# This tag requires that the tag GENERATE_DOCSET is set to YES. + +DOCSET_FEEDNAME = "Doxygen generated docs" + +# This tag specifies a string that should uniquely identify the documentation +# set bundle. This should be a reverse domain-name style string, e.g. +# com.mycompany.MyDocSet. Doxygen will append .docset to the name. +# The default value is: org.doxygen.Project. +# This tag requires that the tag GENERATE_DOCSET is set to YES. + +DOCSET_BUNDLE_ID = org.doxygen.Project + +# The DOCSET_PUBLISHER_ID tag specifies a string that should uniquely identify +# the documentation publisher. This should be a reverse domain-name style +# string, e.g. com.mycompany.MyDocSet.documentation. +# The default value is: org.doxygen.Publisher. +# This tag requires that the tag GENERATE_DOCSET is set to YES. + +DOCSET_PUBLISHER_ID = org.doxygen.Publisher + +# The DOCSET_PUBLISHER_NAME tag identifies the documentation publisher. +# The default value is: Publisher. +# This tag requires that the tag GENERATE_DOCSET is set to YES. + +DOCSET_PUBLISHER_NAME = Publisher + +# If the GENERATE_HTMLHELP tag is set to YES then doxygen generates three +# additional HTML index files: index.hhp, index.hhc, and index.hhk. The +# index.hhp is a project file that can be read by Microsoft's HTML Help Workshop +# (see: https://www.microsoft.com/en-us/download/details.aspx?id=21138) on +# Windows. +# +# The HTML Help Workshop contains a compiler that can convert all HTML output +# generated by doxygen into a single compiled HTML file (.chm). Compiled HTML +# files are now used as the Windows 98 help format, and will replace the old +# Windows help format (.hlp) on all Windows platforms in the future. Compressed +# HTML files also contain an index, a table of contents, and you can search for +# words in the documentation. The HTML workshop also contains a viewer for +# compressed HTML files. +# The default value is: NO. +# This tag requires that the tag GENERATE_HTML is set to YES. + +GENERATE_HTMLHELP = NO + +# The CHM_FILE tag can be used to specify the file name of the resulting .chm +# file. You can add a path in front of the file if the result should not be +# written to the html output directory. +# This tag requires that the tag GENERATE_HTMLHELP is set to YES. + +CHM_FILE = + +# The HHC_LOCATION tag can be used to specify the location (absolute path +# including file name) of the HTML help compiler (hhc.exe). If non-empty, +# doxygen will try to run the HTML help compiler on the generated index.hhp. +# The file has to be specified with full path. +# This tag requires that the tag GENERATE_HTMLHELP is set to YES. + +HHC_LOCATION = + +# The GENERATE_CHI flag controls if a separate .chi index file is generated +# (YES) or that it should be included in the main .chm file (NO). +# The default value is: NO. +# This tag requires that the tag GENERATE_HTMLHELP is set to YES. + +GENERATE_CHI = NO + +# The CHM_INDEX_ENCODING is used to encode HtmlHelp index (hhk), content (hhc) +# and project file content. +# This tag requires that the tag GENERATE_HTMLHELP is set to YES. + +CHM_INDEX_ENCODING = + +# The BINARY_TOC flag controls whether a binary table of contents is generated +# (YES) or a normal table of contents (NO) in the .chm file. Furthermore it +# enables the Previous and Next buttons. +# The default value is: NO. +# This tag requires that the tag GENERATE_HTMLHELP is set to YES. + +BINARY_TOC = NO + +# The TOC_EXPAND flag can be set to YES to add extra items for group members to +# the table of contents of the HTML help documentation and to the tree view. +# The default value is: NO. +# This tag requires that the tag GENERATE_HTMLHELP is set to YES. + +TOC_EXPAND = NO + +# If the GENERATE_QHP tag is set to YES and both QHP_NAMESPACE and +# QHP_VIRTUAL_FOLDER are set, an additional index file will be generated that +# can be used as input for Qt's qhelpgenerator to generate a Qt Compressed Help +# (.qch) of the generated HTML documentation. +# The default value is: NO. +# This tag requires that the tag GENERATE_HTML is set to YES. + +GENERATE_QHP = NO + +# If the QHG_LOCATION tag is specified, the QCH_FILE tag can be used to specify +# the file name of the resulting .qch file. The path specified is relative to +# the HTML output folder. +# This tag requires that the tag GENERATE_QHP is set to YES. + +QCH_FILE = + +# The QHP_NAMESPACE tag specifies the namespace to use when generating Qt Help +# Project output. For more information please see Qt Help Project / Namespace +# (see: https://doc.qt.io/archives/qt-4.8/qthelpproject.html#namespace). +# The default value is: org.doxygen.Project. +# This tag requires that the tag GENERATE_QHP is set to YES. + +QHP_NAMESPACE = org.doxygen.Project + +# The QHP_VIRTUAL_FOLDER tag specifies the namespace to use when generating Qt +# Help Project output. For more information please see Qt Help Project / Virtual +# Folders (see: https://doc.qt.io/archives/qt-4.8/qthelpproject.html#virtual- +# folders). +# The default value is: doc. +# This tag requires that the tag GENERATE_QHP is set to YES. + +QHP_VIRTUAL_FOLDER = doc + +# If the QHP_CUST_FILTER_NAME tag is set, it specifies the name of a custom +# filter to add. For more information please see Qt Help Project / Custom +# Filters (see: https://doc.qt.io/archives/qt-4.8/qthelpproject.html#custom- +# filters). +# This tag requires that the tag GENERATE_QHP is set to YES. + +QHP_CUST_FILTER_NAME = + +# The QHP_CUST_FILTER_ATTRS tag specifies the list of the attributes of the +# custom filter to add. For more information please see Qt Help Project / Custom +# Filters (see: https://doc.qt.io/archives/qt-4.8/qthelpproject.html#custom- +# filters). +# This tag requires that the tag GENERATE_QHP is set to YES. + +QHP_CUST_FILTER_ATTRS = + +# The QHP_SECT_FILTER_ATTRS tag specifies the list of the attributes this +# project's filter section matches. Qt Help Project / Filter Attributes (see: +# https://doc.qt.io/archives/qt-4.8/qthelpproject.html#filter-attributes). +# This tag requires that the tag GENERATE_QHP is set to YES. + +QHP_SECT_FILTER_ATTRS = + +# The QHG_LOCATION tag can be used to specify the location of Qt's +# qhelpgenerator. If non-empty doxygen will try to run qhelpgenerator on the +# generated .qhp file. +# This tag requires that the tag GENERATE_QHP is set to YES. + +QHG_LOCATION = + +# If the GENERATE_ECLIPSEHELP tag is set to YES, additional index files will be +# generated, together with the HTML files, they form an Eclipse help plugin. To +# install this plugin and make it available under the help contents menu in +# Eclipse, the contents of the directory containing the HTML and XML files needs +# to be copied into the plugins directory of eclipse. The name of the directory +# within the plugins directory should be the same as the ECLIPSE_DOC_ID value. +# After copying Eclipse needs to be restarted before the help appears. +# The default value is: NO. +# This tag requires that the tag GENERATE_HTML is set to YES. + +GENERATE_ECLIPSEHELP = NO + +# A unique identifier for the Eclipse help plugin. When installing the plugin +# the directory name containing the HTML and XML files should also have this +# name. Each documentation set should have its own identifier. +# The default value is: org.doxygen.Project. +# This tag requires that the tag GENERATE_ECLIPSEHELP is set to YES. + +ECLIPSE_DOC_ID = org.doxygen.Project + +# If you want full control over the layout of the generated HTML pages it might +# be necessary to disable the index and replace it with your own. The +# DISABLE_INDEX tag can be used to turn on/off the condensed index (tabs) at top +# of each HTML page. A value of NO enables the index and the value YES disables +# it. Since the tabs in the index contain the same information as the navigation +# tree, you can set this option to YES if you also set GENERATE_TREEVIEW to YES. +# The default value is: NO. +# This tag requires that the tag GENERATE_HTML is set to YES. + +DISABLE_INDEX = NO + +# The GENERATE_TREEVIEW tag is used to specify whether a tree-like index +# structure should be generated to display hierarchical information. If the tag +# value is set to YES, a side panel will be generated containing a tree-like +# index structure (just like the one that is generated for HTML Help). For this +# to work a browser that supports JavaScript, DHTML, CSS and frames is required +# (i.e. any modern browser). Windows users are probably better off using the +# HTML help feature. Via custom style sheets (see HTML_EXTRA_STYLESHEET) one can +# further fine-tune the look of the index. As an example, the default style +# sheet generated by doxygen has an example that shows how to put an image at +# the root of the tree instead of the PROJECT_NAME. Since the tree basically has +# the same information as the tab index, you could consider setting +# DISABLE_INDEX to YES when enabling this option. +# The default value is: NO. +# This tag requires that the tag GENERATE_HTML is set to YES. + +GENERATE_TREEVIEW = YES + +# The ENUM_VALUES_PER_LINE tag can be used to set the number of enum values that +# doxygen will group on one line in the generated HTML documentation. +# +# Note that a value of 0 will completely suppress the enum values from appearing +# in the overview section. +# Minimum value: 0, maximum value: 20, default value: 4. +# This tag requires that the tag GENERATE_HTML is set to YES. + +ENUM_VALUES_PER_LINE = 4 + +# If the treeview is enabled (see GENERATE_TREEVIEW) then this tag can be used +# to set the initial width (in pixels) of the frame in which the tree is shown. +# Minimum value: 0, maximum value: 1500, default value: 250. +# This tag requires that the tag GENERATE_HTML is set to YES. + +TREEVIEW_WIDTH = 250 + +# If the EXT_LINKS_IN_WINDOW option is set to YES, doxygen will open links to +# external symbols imported via tag files in a separate window. +# The default value is: NO. +# This tag requires that the tag GENERATE_HTML is set to YES. + +EXT_LINKS_IN_WINDOW = NO + +# If the HTML_FORMULA_FORMAT option is set to svg, doxygen will use the pdf2svg +# tool (see https://github.com/dawbarton/pdf2svg) or inkscape (see +# https://inkscape.org) to generate formulas as SVG images instead of PNGs for +# the HTML output. These images will generally look nicer at scaled resolutions. +# Possible values are: png (the default) and svg (looks nicer but requires the +# pdf2svg or inkscape tool). +# The default value is: png. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_FORMULA_FORMAT = svg + +# Use this tag to change the font size of LaTeX formulas included as images in +# the HTML documentation. When you change the font size after a successful +# doxygen run you need to manually remove any form_*.png images from the HTML +# output directory to force them to be regenerated. +# Minimum value: 8, maximum value: 50, default value: 10. +# This tag requires that the tag GENERATE_HTML is set to YES. + +FORMULA_FONTSIZE = 10 + +# Use the FORMULA_TRANSPARENT tag to determine whether or not the images +# generated for formulas are transparent PNGs. Transparent PNGs are not +# supported properly for IE 6.0, but are supported on all modern browsers. +# +# Note that when changing this option you need to delete any form_*.png files in +# the HTML output directory before the changes have effect. +# The default value is: YES. +# This tag requires that the tag GENERATE_HTML is set to YES. + +FORMULA_TRANSPARENT = YES + +# The FORMULA_MACROFILE can contain LaTeX \newcommand and \renewcommand commands +# to create new LaTeX commands to be used in formulas as building blocks. See +# the section "Including formulas" for details. + +FORMULA_MACROFILE = + +# Enable the USE_MATHJAX option to render LaTeX formulas using MathJax (see +# https://www.mathjax.org) which uses client side JavaScript for the rendering +# instead of using pre-rendered bitmaps. Use this if you do not have LaTeX +# installed or if you want to formulas look prettier in the HTML output. When +# enabled you may also need to install MathJax separately and configure the path +# to it using the MATHJAX_RELPATH option. +# The default value is: NO. +# This tag requires that the tag GENERATE_HTML is set to YES. + +USE_MATHJAX = YES + +# When MathJax is enabled you can set the default output format to be used for +# the MathJax output. See the MathJax site (see: +# http://docs.mathjax.org/en/latest/output.html) for more details. +# Possible values are: HTML-CSS (which is slower, but has the best +# compatibility), NativeMML (i.e. MathML) and SVG. +# The default value is: HTML-CSS. +# This tag requires that the tag USE_MATHJAX is set to YES. + +MATHJAX_FORMAT = HTML-CSS + +# When MathJax is enabled you need to specify the location relative to the HTML +# output directory using the MATHJAX_RELPATH option. The destination directory +# should contain the MathJax.js script. For instance, if the mathjax directory +# is located at the same level as the HTML output directory, then +# MATHJAX_RELPATH should be ../mathjax. The default value points to the MathJax +# Content Delivery Network so you can quickly see the result without installing +# MathJax. However, it is strongly recommended to install a local copy of +# MathJax from https://www.mathjax.org before deployment. +# The default value is: https://cdn.jsdelivr.net/npm/mathjax@2. +# This tag requires that the tag USE_MATHJAX is set to YES. + +MATHJAX_RELPATH = https://cdn.jsdelivr.net/npm/mathjax@2 + +# The MATHJAX_EXTENSIONS tag can be used to specify one or more MathJax +# extension names that should be enabled during MathJax rendering. For example +# MATHJAX_EXTENSIONS = TeX/AMSmath TeX/AMSsymbols +# This tag requires that the tag USE_MATHJAX is set to YES. + +MATHJAX_EXTENSIONS = + +# The MATHJAX_CODEFILE tag can be used to specify a file with javascript pieces +# of code that will be used on startup of the MathJax code. See the MathJax site +# (see: http://docs.mathjax.org/en/latest/output.html) for more details. For an +# example see the documentation. +# This tag requires that the tag USE_MATHJAX is set to YES. + +MATHJAX_CODEFILE = + +# When the SEARCHENGINE tag is enabled doxygen will generate a search box for +# the HTML output. The underlying search engine uses javascript and DHTML and +# should work on any modern browser. Note that when using HTML help +# (GENERATE_HTMLHELP), Qt help (GENERATE_QHP), or docsets (GENERATE_DOCSET) +# there is already a search function so this one should typically be disabled. +# For large projects the javascript based search engine can be slow, then +# enabling SERVER_BASED_SEARCH may provide a better solution. It is possible to +# search using the keyboard; to jump to the search box use + S +# (what the is depends on the OS and browser, but it is typically +# , /