From 2316ae56e1c030bcf638a89309f2bf94c939c525 Mon Sep 17 00:00:00 2001 From: raphael dussin Date: Mon, 9 Sep 2024 12:05:20 -0400 Subject: [PATCH 1/5] diffusivities from internal tides ray tracing algo (#677) * (*)bugfixes for internal tides - TKE_itidal_input values are set to zero where it is not applied to the model so that diagnostics are consistent - removed useless halo updates - diagnose energy loss terms as dE/dt instead of equivalent loss rate to properly close energy budget - tot_vel_btTide2 was already a velocity squared, no need to square again - Froude loss term was not properly initialized - add missing halo updates for internal tide speed - compute residual/critical slopes loss only where it has a meaning, allows to clean up noise in field - uh/vh in energy flux routines do not need to be inout * Refactor debugging internal tides - put test for negative energt behind debug flag - do energy budget in debug mode - add flags to skip refraction, propagation for debugging - add option to input TKE only at first step for debugging - add checksums for unit scaling testing - rewrite terms in refraction to avoid substractions of velocities - rewrite gradient of coriolis in rotationally invariant form * Add internal tides diffusivities - MOM_internal_tides gets new routine that converts TKE losses into diffusivities using the TKE_to_Kd array - MOM_set_diffusivities handles the diagnostics * extend find_rho_bottom to get bbl thickness/index * new calculation of BBL, profiles in H units --- src/core/MOM.F90 | 2 +- src/core/MOM_interface_heights.F90 | 60 +- .../lateral/MOM_internal_tides.F90 | 1738 +++++++++++++---- .../vertical/MOM_diabatic_driver.F90 | 5 +- .../vertical/MOM_internal_tide_input.F90 | 59 +- .../vertical/MOM_set_diffusivity.F90 | 201 +- 6 files changed, 1604 insertions(+), 461 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 8d45114a39..2f5ac6e489 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2890,7 +2890,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & endif if (.not. CS%adiabatic) then - call register_diabatic_restarts(G, US, param_file, CS%int_tide_CSp, restart_CSp) + call register_diabatic_restarts(G, GV, US, param_file, CS%int_tide_CSp, restart_CSp) endif call callTree_waypoint("restart registration complete (initialize_MOM)") diff --git a/src/core/MOM_interface_heights.F90 b/src/core/MOM_interface_heights.F90 index 6e272f7b41..c594aed206 100644 --- a/src/core/MOM_interface_heights.F90 +++ b/src/core/MOM_interface_heights.F90 @@ -394,10 +394,12 @@ end subroutine find_col_avg_SpV !> Determine the in situ density averaged over a specified distance from the bottom, !! calculating it as the inverse of the mass-weighted average specific volume. -subroutine find_rho_bottom(h, dz, pres_int, dz_avg, tv, j, G, GV, US, Rho_bot) +subroutine find_rho_bottom(G, GV, US, tv, h, dz, pres_int, dz_avg, j, Rho_bot, h_bot, k_bot) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any available + !! thermodynamic fields. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] real, dimension(SZI_(G),SZK_(GV)), & @@ -405,10 +407,10 @@ subroutine find_rho_bottom(h, dz, pres_int, dz_avg, tv, j, G, GV, US, Rho_bot) real, dimension(SZI_(G),SZK_(GV)+1), & intent(in) :: pres_int !< Pressure at each interface [R L2 T-2 ~> Pa] real, dimension(SZI_(G)), intent(in) :: dz_avg !< The vertical distance over which to average [Z ~> m] - type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any available - !! thermodynamic fields. integer, intent(in) :: j !< j-index of row to work on real, dimension(SZI_(G)), intent(out) :: Rho_bot !< Near-bottom density [R ~> kg m-3]. + real, dimension(SZI_(G)), intent(out) :: h_bot !< Bottom boundary layer thickness [H ~> m or kg m-2] + integer, dimension(SZI_(G)), intent(out) :: k_bot !< Bottom boundary layer top layer index ! Local variables real :: hb(SZI_(G)) ! Running sum of the thickness in the bottom boundary layer [H ~> m or kg m-2] @@ -441,6 +443,53 @@ subroutine find_rho_bottom(h, dz, pres_int, dz_avg, tv, j, G, GV, US, Rho_bot) do i=is,ie rho_bot(i) = GV%Rho0 enddo + + ! Obtain bottom boundary layer thickness and index of top layer + do i=is,ie + hb(i) = 0.0 ; h_bot(i) = 0.0 ; k_bot(i) = nz + dz_bbl_rem(i) = G%mask2dT(i,j) * max(0.0, dz_avg(i)) + do_i(i) = .true. + if (G%mask2dT(i,j) <= 0.0) then + h_bbl_frac(i) = 0.0 + do_i(i) = .false. + endif + enddo + + do k=nz,1,-1 + do_any = .false. + do i=is,ie ; if (do_i(i)) then + if (dz(i,k) < dz_bbl_rem(i)) then + ! This layer is fully within the averaging depth. + dz_bbl_rem(i) = dz_bbl_rem(i) - dz(i,k) + hb(i) = hb(i) + h(i,j,k) + k_bot(i) = k + do_any = .true. + else + if (dz(i,k) > 0.0) then + frac_in = dz_bbl_rem(i) / dz(i,k) + if (frac_in >= 0.5) k_bot(i) = k ! update bbl top index if >= 50% of layer + else + frac_in = 0.0 + endif + h_bbl_frac(i) = frac_in * h(i,j,k) + dz_bbl_rem(i) = 0.0 + do_i(i) = .false. + endif + endif ; enddo + if (.not.do_any) exit + enddo + do i=is,ie ; if (do_i(i)) then + ! The nominal bottom boundary layer is thicker than the water column, but layer 1 is + ! already included in the averages. These values are set so that the call to find + ! the layer-average specific volume will behave sensibly. + h_bbl_frac(i) = 0.0 + endif ; enddo + + do i=is,ie + if (hb(i) + h_bbl_frac(i) < GV%H_subroundoff) h_bbl_frac(i) = GV%H_subroundoff + h_bot(i) = hb(i) + h_bbl_frac(i) + enddo + else ! Check that SpV_avg has been set. if (tv%valid_SpV_halo < 0) call MOM_error(FATAL, & @@ -450,7 +499,7 @@ subroutine find_rho_bottom(h, dz, pres_int, dz_avg, tv, j, G, GV, US, Rho_bot) ! specified distance, with care taken to avoid having compressibility lead to an imprint ! of the layer thicknesses on this density. do i=is,ie - hb(i) = 0.0 ; SpV_h_bot(i) = 0.0 + hb(i) = 0.0 ; SpV_h_bot(i) = 0.0 ; h_bot(i) = 0.0 ; k_bot(i) = nz dz_bbl_rem(i) = G%mask2dT(i,j) * max(0.0, dz_avg(i)) do_i(i) = .true. if (G%mask2dT(i,j) <= 0.0) then @@ -470,10 +519,12 @@ subroutine find_rho_bottom(h, dz, pres_int, dz_avg, tv, j, G, GV, US, Rho_bot) SpV_h_bot(i) = SpV_h_bot(i) + h(i,j,k) * tv%SpV_avg(i,j,k) dz_bbl_rem(i) = dz_bbl_rem(i) - dz(i,k) hb(i) = hb(i) + h(i,j,k) + k_bot(i) = k do_any = .true. else if (dz(i,k) > 0.0) then frac_in = dz_bbl_rem(i) / dz(i,k) + if (frac_in >= 0.5) k_bot(i) = k ! update bbl top index if >= 50% of layer else frac_in = 0.0 endif @@ -516,6 +567,7 @@ subroutine find_rho_bottom(h, dz, pres_int, dz_avg, tv, j, G, GV, US, Rho_bot) do i=is,ie if (hb(i) + h_bbl_frac(i) < GV%H_subroundoff) h_bbl_frac(i) = GV%H_subroundoff rho_bot(i) = G%mask2dT(i,j) * (hb(i) + h_bbl_frac(i)) / (SpV_h_bot(i) + h_bbl_frac(i)*SpV_bbl(i)) + h_bot(i) = hb(i) + h_bbl_frac(i) enddo endif diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index e6981496bc..819e77b2c2 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -5,27 +5,29 @@ module MOM_internal_tides ! This file is part of MOM6. See LICENSE.md for the license. +use MOM_checksums, only : hchksum use MOM_debugging, only : is_NaN use MOM_diag_mediator, only : post_data, query_averaging_enabled, diag_axis_init use MOM_diag_mediator, only : disable_averaging, enable_averages use MOM_diag_mediator, only : register_diag_field, diag_ctrl, safe_alloc_ptr use MOM_diag_mediator, only : axes_grp, define_axes_group -use MOM_domains, only : AGRID, To_South, To_West, To_All -use MOM_domains, only : create_group_pass, do_group_pass, pass_var +use MOM_domains, only : AGRID, To_South, To_West, To_All, CGRID_NE +use MOM_domains, only : create_group_pass, pass_var, pass_vector use MOM_domains, only : group_pass_type, start_group_pass, complete_group_pass use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg, is_root_pe use MOM_file_parser, only : read_param, get_param, log_param, log_version, param_file_type +use MOM_forcing_type,only : forcing use MOM_grid, only : ocean_grid_type use MOM_int_tide_input, only: int_tide_input_CS, get_input_TKE, get_barotropic_tidal_vel use MOM_io, only : slasher, MOM_read_data, file_exists, axis_info -use MOM_io, only : set_axis_info, get_axis_info +use MOM_io, only : set_axis_info, get_axis_info, stdout use MOM_restart, only : register_restart_field, MOM_restart_CS, restart_init, save_restart use MOM_restart, only : lock_check, restart_registry_lock use MOM_spatial_means, only : global_area_integral use MOM_string_functions, only: extract_real use MOM_time_manager, only : time_type, time_type_to_real, operator(+), operator(/), operator(-) use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : surface, thermo_var_ptrs +use MOM_variables, only : surface, thermo_var_ptrs, vertvisc_type use MOM_verticalGrid, only : verticalGrid_type use MOM_wave_speed, only : wave_speeds, wave_speed_CS, wave_speed_init @@ -35,7 +37,7 @@ module MOM_internal_tides public propagate_int_tide, register_int_tide_restarts public internal_tides_init, internal_tides_end -public get_lowmode_loss +public get_lowmode_loss, get_lowmode_diffusivity !> This control structure has parameters for the MOM_internal_tides module type, public :: int_tide_CS ; private @@ -55,6 +57,13 @@ module MOM_internal_tides !! areas when estimating CFL numbers. Without aggress_adjust, !! the default is false; it is always true with aggress_adjust. logical :: use_PPMang !< If true, use PPM for advection of energy in angular space. + logical :: update_Kd !< If true, the scheme will modify the diffusivities seen by the dynamics + logical :: apply_refraction !< If false, skip refraction (for debugging) + logical :: apply_propagation !< If False, do not propagate energy (for debugging) + logical :: debug !< If true, use debugging prints + logical :: init_forcing_only !< if True, add TKE forcing only at first step (for debugging) + logical :: force_posit_En !< if True, remove subroundoff negative values (needs enhancement) + logical :: add_tke_forcing = .true. !< Whether to add forcing, used by init_forcing_only real, allocatable, dimension(:,:) :: fraction_tidal_input !< how the energy from one tidal component is distributed @@ -80,32 +89,48 @@ module MOM_internal_tides real, allocatable, dimension(:,:,:,:) :: cp !< horizontal phase speed [L T-1 ~> m s-1] real, allocatable, dimension(:,:,:,:,:) :: TKE_leak_loss - !< energy lost due to misc background processes [R Z3 T-3 ~> W m-2] + !< energy lost due to misc background processes [H Z2 T-3 ~> m3 s-3 or W m-2] real, allocatable, dimension(:,:,:,:,:) :: TKE_quad_loss - !< energy lost due to quadratic bottom drag [R Z3 T-3 ~> W m-2] + !< energy lost due to quadratic bottom drag [H Z2 T-3 ~> m3 s-3 or W m-2] real, allocatable, dimension(:,:,:,:,:) :: TKE_Froude_loss - !< energy lost due to wave breaking [R Z3 T-3 ~> W m-2] + !< energy lost due to wave breaking [H Z2 T-3 ~> m3 s-3 or W m-2] real, allocatable, dimension(:,:) :: TKE_itidal_loss_fixed - !< Fixed part of the energy lost due to small-scale drag [R Z3 L-2 ~> kg m-2] here; + !< Fixed part of the energy lost due to small-scale drag [H Z2 L-2 ~> kg m-2] here; !! This will be multiplied by N and the squared near-bottom velocity (and by !! the near-bottom density in non-Boussinesq mode) to get the energy losses !! in [R Z4 H-1 L-2 ~> kg m-2 or m] real, allocatable, dimension(:,:,:,:,:) :: TKE_itidal_loss - !< energy lost due to small-scale wave drag [R Z3 T-3 ~> W m-2] + !< energy lost due to small-scale wave drag [H Z2 T-3 ~> m3 s-3 or W m-2] real, allocatable, dimension(:,:,:,:,:) :: TKE_residual_loss - !< internal tide energy loss due to the residual at slopes [R Z3 T-3 ~> W m-2] + !< internal tide energy loss due to the residual at slopes [H Z2 T-3 ~> m3 s-3 or W m-2] + real, allocatable, dimension(:,:,:,:,:) :: TKE_slope_loss + !< internal tide energy loss due to the residual at slopes [H Z2 T-3 ~> m3 s-3 or W m-2] + real, allocatable, dimension(:,:) :: TKE_input_glo_dt + !< The energy input to the internal waves * dt [H Z2 T-2 ~> m3 s-2 or J m-2]. + real, allocatable, dimension(:,:) :: TKE_leak_loss_glo_dt + !< energy lost due to misc background processes * dt [H Z2 T-2 ~> m3 s-2 or J m-2] + real, allocatable, dimension(:,:) :: TKE_quad_loss_glo_dt + !< energy lost due to quadratic bottom drag * dt [H Z2 T-2 ~> m3 s-2 or J m-2] + real, allocatable, dimension(:,:) :: TKE_Froude_loss_glo_dt + !< energy lost due to wave breaking [H Z2 T-2 ~> m3 s-2 or J m-2] + real, allocatable, dimension(:,:) :: TKE_itidal_loss_glo_dt + !< energy lost due to small-scale wave drag [H Z2 T-2 ~> m3 s-2 or J m-2] + real, allocatable, dimension(:,:) :: TKE_residual_loss_glo_dt + !< internal tide energy loss due to the residual at slopes [H Z2 T-2 ~> m3 s-2 or J m-2] + real, allocatable, dimension(:,:) :: error_mode + !< internal tide energy budget error for each mode [H Z2 T-2 ~> m3 s-2 or J m-2] real, allocatable, dimension(:,:) :: tot_leak_loss !< Energy loss rates due to misc background processes, - !! summed over angle, frequency and mode [R Z3 T-3 ~> W m-2] + !! summed over angle, frequency and mode [H Z2 T-3 ~> m3 s-3 or W m-2] real, allocatable, dimension(:,:) :: tot_quad_loss !< Energy loss rates due to quadratic bottom drag, - !! summed over angle, frequency and mode [R Z3 T-3 ~> W m-2] + !! summed over angle, frequency and mode [H Z2 T-3 ~> m3 s-3 or W m-2] real, allocatable, dimension(:,:) :: tot_itidal_loss !< Energy loss rates due to small-scale drag, - !! summed over angle, frequency and mode [R Z3 T-3 ~> W m-2] + !! summed over angle, frequency and mode [H Z2 T-3 ~> m3 s-3 or W m-2] real, allocatable, dimension(:,:) :: tot_Froude_loss !< Energy loss rates due to wave breaking, - !! summed over angle, frequency and mode [R Z3 T-3 ~> W m-2] + !! summed over angle, frequency and mode [H Z2 T-3 ~> m3 s-3 or W m-2] real, allocatable, dimension(:,:) :: tot_residual_loss !< Energy loss rates due to residual on slopes, - !! summed over angle, frequency and mode [R Z3 T-3 ~> W m-2] + !! summed over angle, frequency and mode [H Z2 T-3 ~> m3 s-3 or W m-2] real, allocatable, dimension(:,:) :: tot_allprocesses_loss !< Energy loss rates due to all processes, - !! summed over angle, frequency and mode [R Z3 T-3 ~> W m-2] + !! summed over angle, frequency and mode [H Z2 T-3 ~> m3 s-3 or W m-2] real, allocatable, dimension(:,:,:,:) :: w_struct !< Vertical structure of vertical velocity (normalized) !! for each frequency and each mode [nondim] real, allocatable, dimension(:,:,:,:) :: u_struct !< Vertical structure of horizontal velocity (normalized and @@ -121,7 +146,9 @@ module MOM_internal_tides real, allocatable, dimension(:,:,:) :: int_N2w2 !< Depth-integrated Brunt Vaissalla freqency times !! vertical profile squared, for each mode [H T-2 ~> m s-2 or kg m-2 s-2] real :: q_itides !< fraction of local dissipation [nondim] - real :: En_sum !< global sum of energy for use in debugging, in MKS units [J] + real :: En_sum !< global sum of energy for use in debugging, in MKS units [H Z2 T-2 L2 ~> m5 s-2 or J] + real :: En_underflow !< A minuscule amount of energy [H Z2 T-2 ~> m3 s-2 or J m-2] + integer :: En_restart_power !< A power factor of 2 by which to multiply the energy in restart [nondim] type(time_type), pointer :: Time => NULL() !< A pointer to the model's clock. character(len=200) :: inputdir !< directory to look for coastline angle file real :: decay_rate !< A constant rate at which internal tide energy is @@ -130,6 +157,10 @@ module MOM_internal_tides real :: drag_min_depth !< The minimum total ocean thickness that will be used in the denominator !! of the quadratic drag terms for internal tides when !! INTERNAL_TIDE_QUAD_DRAG is true [H ~> m or kg m-2] + real :: gamma_osborn !< Mixing efficiency from Osborn 1980 [nondim] + real :: Kd_min !< The minimum diapycnal diffusivity. [L2 T-1 ~> m2 s-1] + real :: max_TKE_to_Kd !< Maximum allowed value for TKE_to_kd [H Z2 T-3 ~> m3 s-3 or W m-2] + real :: min_thick_layer_Kd !< minimum layer thickness allowed to use with TKE_to_kd [H ~> m] logical :: apply_background_drag !< If true, apply a drag due to background processes as a sink. logical :: apply_bottom_drag @@ -138,30 +169,40 @@ module MOM_internal_tides !< If true, apply scattering due to small-scale roughness as a sink. logical :: apply_Froude_drag !< If true, apply wave breaking as a sink. - real :: En_check_tol !< An energy density tolerance for flagging points with an imbalance in the - !! internal tide energy budget when apply_Froude_drag is True [R Z3 T-2 ~> J m-2] + real :: En_check_tol !< An energy density tolerance for flagging points with small negative + !! internal tide energy [H Z2 T-2 ~> m3 s-2 or J m-2] logical :: apply_residual_drag !< If true, apply sink from residual term of reflection/transmission. real, allocatable :: En(:,:,:,:,:) !< The internal wave energy density as a function of (i,j,angle,frequency,mode) - !! integrated within an angular and frequency band [R Z3 T-2 ~> J m-2] + !! integrated within an angular and frequency band [H Z2 T-2 ~> m3 s-2 or J m-2] + real, allocatable :: En_ini_glo(:,:) + !< The internal wave energy density as a function of (frequency,mode) + !! integrated within an angular and frequency band [H Z2 T-2 ~> m3 s-2 or J m-2] + !! only at the start of the routine (for diags) + real, allocatable :: En_end_glo(:,:) + !< The internal wave energy density as a function of (frequency,mode) + !! integrated within an angular and frequency band [H Z2 T-2 ~> m3 s-2 or J m-2] + !! only at the end of the routine (for diags) real, allocatable :: En_restart_mode1(:,:,:,:) !< The internal wave energy density as a function of (i,j,angle,freq) - !! for mode 1 [R Z3 T-2 ~> J m-2] + !! for mode 1 [H Z2 T-2 ~> m3 s-2 or J m-2] real, allocatable :: En_restart_mode2(:,:,:,:) !< The internal wave energy density as a function of (i,j,angle,freq) - !! for mode 2 [R Z3 T-2 ~> J m-2] + !! for mode 2 [H Z2 T-2 ~> m3 s-2 or J m-2] real, allocatable :: En_restart_mode3(:,:,:,:) !< The internal wave energy density as a function of (i,j,angle,freq) - !! for mode 3 [R Z3 T-2 ~> J m-2] + !! for mode 3 [H Z2 T-2 ~> m3 s-2 or J m-2] real, allocatable :: En_restart_mode4(:,:,:,:) !< The internal wave energy density as a function of (i,j,angle,freq) - !! for mode 4 [R Z3 T-2 ~> J m-2] + !! for mode 4 [H Z2 T-2 ~> m3 s-2 or J m-2] real, allocatable :: En_restart_mode5(:,:,:,:) !< The internal wave energy density as a function of (i,j,angle,freq) - !! for mode 5 [R Z3 T-2 ~> J m-2] + !! for mode 5 [H Z2 T-2 ~> m3 s-2 or J m-2] real, allocatable, dimension(:) :: frequency !< The frequency of each band [T-1 ~> s-1]. + real :: Int_tide_decay_scale !< vertical decay scale for St Laurent profile [Z ~> m] + real :: Int_tide_decay_scale_slope !< vertical decay scale for St Laurent profile on slopes [Z ~> m] type(wave_speed_CS) :: wave_speed !< Wave speed control structure type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to regulate the @@ -236,7 +277,7 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C ! Local variables real, dimension(SZI_(G),SZJ_(G),CS%nFreq) :: & - TKE_itidal_input, & !< The energy input to the internal waves [R Z3 T-3 ~> W m-2]. + TKE_itidal_input, & !< The energy input to the internal waves [H Z2 T-3 ~> m3 s-3 or W m-2]. vel_btTide !< Barotropic velocity read from file [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJ_(G),2) :: & @@ -244,30 +285,32 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C real, dimension(SZI_(G),SZJ_(G),CS%nMode) :: & cn ! baroclinic internal gravity wave speeds for each mode [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJ_(G),CS%nFreq,CS%nMode) :: & - tot_En_mode, & ! energy summed over angles only [R Z3 T-2 ~> J m-2] + tot_En_mode, & ! energy summed over angles only [H Z2 T-2 ~> m3 s-2 or J m-2] Ub, & ! near-bottom horizontal velocity of wave (modal) [L T-1 ~> m s-1] Umax ! Maximum horizontal velocity of wave (modal) [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJ_(G),CS%nFreq,CS%nMode) :: & drag_scale ! bottom drag scale [T-1 ~> s-1] real, dimension(SZI_(G),SZJ_(G)) :: & - tot_vel_btTide2, & - tot_En, & ! energy summed over angles, modes, frequencies [R Z3 T-2 ~> J m-2] + tot_vel_btTide2, & ! [L2 T-2 ~> m2 s-2] + tot_En, & ! energy summed over angles, modes, frequencies [H Z2 T-2 ~> m3 s-2 or J m-2] tot_leak_loss, tot_quad_loss, tot_itidal_loss, tot_Froude_loss, tot_residual_loss, tot_allprocesses_loss, & - ! energy loss rates summed over angle, freq, and mode [R Z3 T-3 ~> W m-2] + ! energy loss rates summed over angle, freq, and mode [H Z2 T-3 ~> m3 s-3 or W m-2] htot, & ! The vertical sum of the layer thicknesses [H ~> m or kg m-2] - itidal_loss_mode, & ! Energy lost due to small-scale wave drag, summed over angles [R Z3 T-3 ~> W m-2] + itidal_loss_mode, & ! Energy lost due to small-scale wave drag, summed over angles [H Z2 T-3 ~> m3 s-3 or W m-2] leak_loss_mode, & quad_loss_mode, & Froude_loss_mode, & residual_loss_mode, & allprocesses_loss_mode ! Total energy loss rates for a given mode and frequency (summed over - ! all angles) [R Z3 T-3 ~> W m-2] - + ! all angles) [H Z2 T-3 ~> m3 s-3 or W m-2] real :: frac_per_sector ! The inverse of the number of angular, modal and frequency bins [nondim] real :: f2 ! The squared Coriolis parameter interpolated to a tracer point [T-2 ~> s-2] real :: Kmag2 ! A squared horizontal wavenumber [L-2 ~> m-2] real :: I_D_here ! The inverse of the local water column thickness [H-1 ~> m-1 or m2 kg-1] real :: I_mass ! The inverse of the local water mass [R-1 Z-1 ~> m2 kg-1] + real :: I_dt ! The inverse of the timestep [T-1 ~> s-1] + real :: En_restart_factor ! A multiplicative factor of the form 2**En_restart_power [nondim] + real :: I_En_restart_factor ! The inverse of the restart mult factor [nondim] real :: freq2 ! The frequency squared [T-2 ~> s-2] real :: PE_term ! total potential energy of profile [R Z ~> kg m-2] real :: KE_term ! total kinetic energy of profile [R Z ~> kg m-2] @@ -277,10 +320,20 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C real :: loss_rate ! An energy loss rate [T-1 ~> s-1] real :: Fr2_max ! The column maximum internal wave Froude number squared [nondim] real :: cn_subRO ! A tiny wave speed to prevent division by zero [L T-1 ~> m s-1] - real :: en_subRO ! A tiny energy to prevent division by zero [R Z3 T-2 ~> J m-2] - real :: En_new, En_check ! Energies for debugging [R Z3 T-2 ~> J m-2] - real :: En_initial, Delta_E_check ! Energies for debugging [R Z3 T-2 ~> J m-2] - real :: TKE_Froude_loss_check, TKE_Froude_loss_tot ! Energy losses for debugging [R Z3 T-3 ~> W m-2] + real :: en_subRO ! A tiny energy to prevent division by zero [H Z2 T-2 ~> m3 s-2 or J m-2] + real :: En_a, En_b ! Energies for time stepping [H Z2 T-2 ~> m3 s-2 or J m-2] + real :: En_new, En_check ! Energies for debugging [H Z2 T-2 ~> m3 s-2 or J m-2] + real :: En_sumtmp ! Energies for debugging [H Z2 T-2 ~> m3 s-2 or J m-2] + real :: En_initial, Delta_E_check ! Energies for debugging [H Z2 T-2 ~> m3 s-2 or J m-2] + real :: TKE_Froude_loss_check, TKE_Froude_loss_tot ! Energy losses for debugging [H Z2 T-3 ~> m3 s-3 or W m-2] + real :: HZ2_T3_to_W_m2 ! unit conversion factor for TKE from internal to mks + ! [H Z2 T-3 ~> m3 s-3 or W m-2] + real :: HZ2_T2_to_J_m2 ! unit conversion factor for Energy from internal to mks + ! [H Z2 T-2 ~> m3 s-2 or J m-2] + real :: W_m2_to_HZ2_T3 ! unit conversion factor for TKE from mks to internal + ! [m3 s-3 or W m-2 ~> H Z2 T-3] + real :: J_m2_to_HZ2_T2 ! unit conversion factor for Energy from mks to internal + ! [m3 s-2 or J m-2 ~> H Z2 T-2] character(len=160) :: mesg ! The text of an error message integer :: En_halo_ij_stencil ! The halo size needed for energy advection integer :: a, m, fr, i, j, k, is, ie, js, je, isd, ied, jsd, jed, nAngle @@ -292,8 +345,17 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nAngle = CS%NAngle + HZ2_T3_to_W_m2 = GV%H_to_kg_m2*(US%Z_to_m**2)*(US%s_to_T**3) + HZ2_T2_to_J_m2 = GV%H_to_kg_m2*(US%Z_to_m**2)*(US%s_to_T**2) + W_m2_to_HZ2_T3 = GV%kg_m2_to_H*(US%m_to_Z**2)*(US%T_to_s**3) + J_m2_to_HZ2_T2 = GV%kg_m2_to_H*(US%m_to_Z**2)*(US%T_to_s**2) + cn_subRO = 1e-30*US%m_s_to_L_T - en_subRO = 1e-30*US%W_m2_to_RZ3_T3*US%s_to_T + en_subRO = 1e-30*J_m2_to_HZ2_T2 + + I_dt = 1.0 / dt + En_restart_factor = 2**CS%En_restart_power + I_En_restart_factor = 1.0 / En_restart_factor ! initialize local arrays TKE_itidal_input(:,:,:) = 0. @@ -307,33 +369,44 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C ! Rebuild energy density array from multiple restarts do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied - CS%En(i,j,a,fr,1) = CS%En_restart_mode1(i,j,a,fr) + CS%En(i,j,a,fr,1) = CS%En_restart_mode1(i,j,a,fr) * I_En_restart_factor enddo ; enddo ; enddo ; enddo if (CS%nMode >= 2) then do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied - CS%En(i,j,a,fr,2) = CS%En_restart_mode2(i,j,a,fr) + CS%En(i,j,a,fr,2) = CS%En_restart_mode2(i,j,a,fr) * I_En_restart_factor enddo ; enddo ; enddo ; enddo endif if (CS%nMode >= 3) then do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied - CS%En(i,j,a,fr,3) = CS%En_restart_mode3(i,j,a,fr) + CS%En(i,j,a,fr,3) = CS%En_restart_mode3(i,j,a,fr) * I_En_restart_factor enddo ; enddo ; enddo ; enddo endif if (CS%nMode >= 4) then do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied - CS%En(i,j,a,fr,4) = CS%En_restart_mode4(i,j,a,fr) + CS%En(i,j,a,fr,4) = CS%En_restart_mode4(i,j,a,fr) * I_En_restart_factor enddo ; enddo ; enddo ; enddo endif if (CS%nMode >= 5) then do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied - CS%En(i,j,a,fr,5) = CS%En_restart_mode5(i,j,a,fr) + CS%En(i,j,a,fr,5) = CS%En_restart_mode5(i,j,a,fr) * I_En_restart_factor enddo ; enddo ; enddo ; enddo endif + if (CS%debug) then + ! save initial energy for online budget + do m=1,CS%nMode ; do fr=1,CS%nFreq + En_sumtmp = 0. + do a=1,CS%nAngle + En_sumtmp = En_sumtmp + global_area_integral(CS%En(:,:,a,fr,m), G, scale=HZ2_T2_to_J_m2) + enddo + CS%En_ini_glo(fr,m) = En_sumtmp + enddo ; enddo + endif + ! Set properties related to the internal tides, such as the wave speeds, storing some ! of them in the control structure for this module. if (CS%uniform_test_cg > 0.0) then @@ -347,6 +420,19 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C ! It can be 1 point smaller if teleport is not used. endif + call pass_var(cn,G%Domain) + + if (CS%debug) then + call hchksum(cn(:,:,1), "CN mode 1", G%HI, haloshift=0, scale=US%L_to_m*US%s_to_T) + call hchksum(CS%w_struct(:,:,:,1), "Wstruct mode 1", G%HI, haloshift=0) + call hchksum(CS%u_struct(:,:,:,1), "Ustruct mode 1", G%HI, haloshift=0, scale=US%m_to_Z) + call hchksum(CS%u_struct_bot(:,:,1), "Ustruct_bot mode 1", G%HI, haloshift=0, scale=US%m_to_Z) + call hchksum(CS%u_struct_max(:,:,1), "Ustruct_max mode 1", G%HI, haloshift=0, scale=US%m_to_Z) + call hchksum(CS%int_w2(:,:,1), "int_w2", G%HI, haloshift=0, scale=GV%H_to_MKS) + call hchksum(CS%int_U2(:,:,1), "int_U2", G%HI, haloshift=0, scale=GV%H_to_mks*US%m_to_Z**2) + call hchksum(CS%int_N2w2(:,:,1), "int_N2w2", G%HI, haloshift=0, scale=GV%H_to_mks*US%s_to_T**2) + endif + ! Set the wave speeds for the modes, using cg(n) ~ cg(1)/n.********************** ! This is wrong, of course, but it works reasonably in some cases. ! Uncomment if wave_speed is not used to calculate the true values (BDM). @@ -356,62 +442,116 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C ! Add the forcing.*************************************************************** - call get_input_TKE(G, TKE_itidal_input, CS%nFreq, inttide_input_CSp) + if (CS%add_tke_forcing) then - if (CS%energized_angle <= 0) then - frac_per_sector = 1.0 / real(CS%nAngle) - do m=1,CS%nMode ; do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=js,je ; do i=is,ie - f2 = 0.25*((G%Coriolis2Bu(I,J) + G%Coriolis2Bu(I-1,J-1)) + & - (G%Coriolis2Bu(I-1,J) + G%Coriolis2Bu(I,J-1))) - if (CS%frequency(fr)**2 > f2) & - CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) + dt*frac_per_sector*(1.0-CS%q_itides) * & - CS%fraction_tidal_input(fr,m) * TKE_itidal_input(i,j,fr) - enddo ; enddo ; enddo ; enddo ; enddo - elseif (CS%energized_angle <= CS%nAngle) then - frac_per_sector = 1.0 - a = CS%energized_angle - do m=1,CS%nMode ; do fr=1,CS%nFreq ; do j=js,je ; do i=is,ie - f2 = 0.25*((G%Coriolis2Bu(I,J) + G%Coriolis2Bu(I-1,J-1)) + & - (G%Coriolis2Bu(I-1,J) + G%Coriolis2Bu(I,J-1))) - if (CS%frequency(fr)**2 > f2) & - CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) + dt*frac_per_sector*(1.0-CS%q_itides) * & - CS%fraction_tidal_input(fr,m) * TKE_itidal_input(i,j,fr) - enddo ; enddo ; enddo ; enddo - else - call MOM_error(WARNING, "Internal tide energy is being put into a angular "//& - "band that does not exist.") + call get_input_TKE(G, TKE_itidal_input, CS%nFreq, inttide_input_CSp) + + if (CS%debug) then + call hchksum(TKE_itidal_input(:,:,1), "TKE_itidal_input", G%HI, haloshift=0, & + scale=GV%H_to_m*(US%Z_to_m**2)*(US%s_to_T)**3) + call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides bf input", G%HI, haloshift=0, scale=HZ2_T2_to_J_m2) + endif + + if (CS%energized_angle <= 0) then + frac_per_sector = 1.0 / real(CS%nAngle) + do m=1,CS%nMode ; do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=js,je ; do i=is,ie + f2 = 0.25*((G%Coriolis2Bu(I,J) + G%Coriolis2Bu(I-1,J-1)) + & + (G%Coriolis2Bu(I-1,J) + G%Coriolis2Bu(I,J-1))) + if (CS%frequency(fr)**2 > f2) then + CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) + (dt*frac_per_sector*(1.0-CS%q_itides) * & + CS%fraction_tidal_input(fr,m) * TKE_itidal_input(i,j,fr)) + else + ! zero out input TKE value to get correct diagnostics + TKE_itidal_input(i,j,fr) = 0. + endif + enddo ; enddo ; enddo ; enddo ; enddo + elseif (CS%energized_angle <= CS%nAngle) then + frac_per_sector = 1.0 + a = CS%energized_angle + do m=1,CS%nMode ; do fr=1,CS%nFreq ; do j=js,je ; do i=is,ie + f2 = 0.25*((G%Coriolis2Bu(I,J) + G%Coriolis2Bu(I-1,J-1)) + & + (G%Coriolis2Bu(I-1,J) + G%Coriolis2Bu(I,J-1))) + if (CS%frequency(fr)**2 > f2) then + CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) + (dt*frac_per_sector*(1.0-CS%q_itides) * & + CS%fraction_tidal_input(fr,m) * TKE_itidal_input(i,j,fr)) + else + ! zero out input TKE value to get correct diagnostics + TKE_itidal_input(i,j,fr) = 0. + endif + enddo ; enddo ; enddo ; enddo + else + call MOM_error(WARNING, "Internal tide energy is being put into a angular "//& + "band that does not exist.") + endif + endif ! add tke forcing + + if (CS%init_forcing_only) CS%add_tke_forcing=.false. + + if (CS%debug) then + call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides af input", G%HI, haloshift=0, scale=HZ2_T2_to_J_m2) + ! save forcing for online budget + do m=1,CS%nMode ; do fr=1,CS%nFreq + En_sumtmp = 0. + do a=1,CS%nAngle + En_sumtmp = En_sumtmp + global_area_integral(dt*frac_per_sector*(1.0-CS%q_itides)* & + CS%fraction_tidal_input(fr,m)*TKE_itidal_input(:,:,fr), & + G, scale=HZ2_T2_to_J_m2) + enddo + CS%TKE_input_glo_dt(fr,m) = En_sumtmp + enddo ; enddo endif ! Pass a test vector to check for grid rotation in the halo updates. do j=jsd,jed ; do i=isd,ied ; test(i,j,1) = 1.0 ; test(i,j,2) = 0.0 ; enddo ; enddo - do m=1,CS%nMode ; do fr=1,CS%nFreq - call create_group_pass(pass_En, CS%En(:,:,:,fr,m), G%domain) - enddo ; enddo call create_group_pass(pass_test, test(:,:,1), test(:,:,2), G%domain, stagger=AGRID) call start_group_pass(pass_test, G%domain) + if (CS%debug) then + call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides af halo", G%HI, haloshift=0, scale=HZ2_T2_to_J_m2) + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'prop_int_tide: after forcing') + if (is_root_pe()) write(stdout,'(A,E18.10)'), 'prop_int_tide: after forcing', CS%En_sum + enddo ; enddo + endif + ! Apply half the refraction. - do m=1,CS%nMode ; do fr=1,CS%nFreq - call refract(CS%En(:,:,:,fr,m), cn(:,:,m), CS%frequency(fr), 0.5*dt, & - G, US, CS%nAngle, CS%use_PPMang) - enddo ; enddo + if (CS%apply_refraction) then + do m=1,CS%nMode ; do fr=1,CS%nFreq + call refract(CS%En(:,:,:,fr,m), cn(:,:,m), CS%frequency(fr), 0.5*dt, & + G, US, CS%nAngle, CS%use_PPMang) + enddo ; enddo + endif ! A this point, CS%En is only valid on the computational domain. - ! Check for En<0 - for debugging, delete later - do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle - do j=js,je ; do i=is,ie - if (CS%En(i,j,a,fr,m)<0.0) then - id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging - write(mesg,*) 'After first refraction: En<0.0 at ig=', id_g, ', jg=', jd_g, & - 'En=',CS%En(i,j,a,fr,m) - call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg)) - CS%En(i,j,a,fr,m) = 0.0 -! call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") - endif - enddo ; enddo - enddo ; enddo ; enddo + if (CS%force_posit_En) then + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=jsd,jed ; do i=isd,ied + if (CS%En(i,j,a,fr,m)<0.0) then + CS%En(i,j,a,fr,m) = 0.0 + endif + enddo ; enddo + enddo ; enddo ; enddo + endif - call do_group_pass(pass_En, G%domain) + if (CS%debug) then + call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides af refr", G%HI, haloshift=0, scale=HZ2_T2_to_J_m2) + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'prop_int_tide: after 1/2 refraction') + if (is_root_pe()) write(stdout,'(A,E18.10)'), 'prop_int_tide: after 1/2 refraction', CS%En_sum + enddo ; enddo + ! Check for En<0 - for debugging, delete later + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=js,je ; do i=is,ie + if (CS%En(i,j,a,fr,m)<0.0) then + id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging + write(mesg,*) 'After first refraction: En<0.0 at ig=', id_g, ', jg=', jd_g, & + 'En=',CS%En(i,j,a,fr,m) + call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg)) + !call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") + endif + enddo ; enddo + enddo ; enddo ; enddo + endif call complete_group_pass(pass_test, G%domain) @@ -423,52 +563,98 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C ! Rotate points in the halos as necessary. call correct_halo_rotation(CS%En, test, G, CS%nAngle, halo=En_halo_ij_stencil) + if (CS%debug) then + call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides af halo R", G%HI, haloshift=0, scale=HZ2_T2_to_J_m2) + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'prop_int_tide: after correct halo rotation') + if (is_root_pe()) write(stdout,'(A,E18.10)'), 'prop_int_tide: after correct halo rotation', CS%En_sum + enddo ; enddo + endif + ! Propagate the waves. do m=1,CS%nMode ; do fr=1,CS%Nfreq ! initialize residual loss, will be computed in propagate CS%TKE_residual_loss(:,:,:,fr,m) = 0. + CS%TKE_slope_loss(:,:,:,fr,m) = 0. - call propagate(CS%En(:,:,:,fr,m), cn(:,:,m), CS%frequency(fr), dt, & - G, US, CS, CS%NAngle, CS%TKE_residual_loss(:,:,:,fr,m)) + if (CS%apply_propagation) then + call propagate(CS%En(:,:,:,fr,m), cn(:,:,m), CS%frequency(fr), dt, & + G, GV, US, CS, CS%NAngle, CS%TKE_slope_loss(:,:,:,fr,m)) + endif enddo ; enddo - ! Check for En<0 - for debugging, delete later - do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle - do j=js,je ; do i=is,ie - if (CS%En(i,j,a,fr,m)<0.0) then - id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset - if (abs(CS%En(i,j,a,fr,m))>1.0) then ! only print if large - write(mesg,*) 'After propagation: En<0.0 at ig=', id_g, ', jg=', jd_g, & - 'En=', CS%En(i,j,a,fr,m) - call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg)) -! call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") + if (CS%force_posit_En) then + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=jsd,jed ; do i=isd,ied + if (CS%En(i,j,a,fr,m)<0.0) then + CS%En(i,j,a,fr,m) = 0.0 endif - CS%En(i,j,a,fr,m) = 0.0 - endif + enddo ; enddo + enddo ; enddo ; enddo + endif + + if (CS%debug) then + call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides af prop", G%HI, haloshift=0, scale=HZ2_T2_to_J_m2) + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'prop_int_tide: after propagate') + if (is_root_pe()) write(stdout,'(A,E18.10)'), 'prop_int_tide: after propagate', CS%En_sum enddo ; enddo - enddo ; enddo ; enddo + ! Check for En<0 - for debugging, delete later + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=js,je ; do i=is,ie + if (CS%En(i,j,a,fr,m)<0.0) then + id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset + if (abs(CS%En(i,j,a,fr,m))>CS%En_check_tol) then ! only print if large + write(mesg,*) 'After propagation: En<0.0 at ig=', id_g, ', jg=', jd_g, & + 'En=', CS%En(i,j,a,fr,m) + call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg)) + ! RD propagate produces very little negative energy (diff 2 large numbers), needs fix + !call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") + endif + endif + enddo ; enddo + enddo ; enddo ; enddo + endif - ! Apply the other half of the refraction. - do m=1,CS%nMode ; do fr=1,CS%Nfreq - call refract(CS%En(:,:,:,fr,m), cn(:,:,m), CS%frequency(fr), 0.5*dt, & - G, US, CS%NAngle, CS%use_PPMang) - enddo ; enddo - ! A this point, CS%En is only valid on the computational domain. + if (CS%apply_refraction) then + ! Apply the other half of the refraction. + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call refract(CS%En(:,:,:,fr,m), cn(:,:,m), CS%frequency(fr), 0.5*dt, & + G, US, CS%NAngle, CS%use_PPMang) + enddo ; enddo + ! A this point, CS%En is only valid on the computational domain. + endif - ! Check for En<0 - for debugging, delete later - do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle - do j=js,je ; do i=is,ie - if (CS%En(i,j,a,fr,m)<0.0) then - id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging - write(mesg,*) 'After second refraction: En<0.0 at ig=', id_g, ', jg=', jd_g, & - 'En=', CS%En(i,j,a,fr,m) - call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg)) - CS%En(i,j,a,fr,m) = 0.0 -! call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") - endif + if (CS%force_posit_En) then + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=jsd,jed ; do i=isd,ied + if (CS%En(i,j,a,fr,m)<0.0) then + CS%En(i,j,a,fr,m) = 0.0 + endif + enddo ; enddo + enddo ; enddo ; enddo + endif + + if (CS%debug) then + call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides af refr2", G%HI, haloshift=0, scale=HZ2_T2_to_J_m2) + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'prop_int_tide: after 2/2 refraction') + if (is_root_pe()) write(stdout,'(A,E18.10)'), 'prop_int_tide: after 2/2 refraction', CS%En_sum enddo ; enddo - enddo ; enddo ; enddo + ! Check for En<0 - for debugging, delete later + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=js,je ; do i=is,ie + if (CS%En(i,j,a,fr,m)<0.0) then + id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging + write(mesg,*) 'After second refraction: En<0.0 at ig=', id_g, ', jg=', jd_g, & + 'En=', CS%En(i,j,a,fr,m) + call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg)) + !call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") + endif + enddo ; enddo + enddo ; enddo ; enddo + endif ! Apply various dissipation mechanisms. if (CS%apply_background_drag .or. CS%apply_bottom_drag & @@ -487,25 +673,55 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C ! Extract the energy for mixing due to misc. processes (background leakage)------ if (CS%apply_background_drag) then do m=1,CS%nMode ; do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=js,je ; do i=is,ie - ! Calculate loss rate and apply loss over the time step ; apply the same drag timescale - ! to each En component (technically not correct; fix later) - CS%TKE_leak_loss(i,j,a,fr,m) = CS%En(i,j,a,fr,m) * CS%decay_rate ! loss rate [R Z3 T-3 ~> W m-2] - CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) / (1.0 + dt * CS%decay_rate) ! implicit update + ! Calculate loss rate and apply loss over the time step ; apply the same drag timescale + ! to each En component (technically not correct; fix later) + En_b = CS%En(i,j,a,fr,m) ! save previous value + En_a = CS%En(i,j,a,fr,m) / (1.0 + (dt * CS%decay_rate)) ! implicit update + CS%TKE_leak_loss(i,j,a,fr,m) = (En_b - En_a) * I_dt ! compute exact loss rate [H Z2 T-3 ~> m3 s-3 or W m-2] + CS%En(i,j,a,fr,m) = En_a ! update value enddo ; enddo ; enddo ; enddo ; enddo endif - ! Check for En<0 - for debugging, delete later - do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle - do j=js,je ; do i=is,ie - if (CS%En(i,j,a,fr,m)<0.0) then - id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging - write(mesg,*) 'After leak loss: En<0.0 at ig=', id_g, ', jg=', jd_g, & - 'En=',CS%En(i,j,a,fr,m) - call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg), all_print=.true.) - CS%En(i,j,a,fr,m) = 0.0 -! call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") - endif + + if (CS%force_posit_En) then + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=jsd,jed ; do i=isd,ied + if (CS%En(i,j,a,fr,m)<0.0) then + CS%En(i,j,a,fr,m) = 0.0 + endif + enddo ; enddo + enddo ; enddo ; enddo + endif + + if (CS%debug) then + call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides after leak", G%HI, haloshift=0, scale=HZ2_T2_to_J_m2) + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'prop_int_tide: after background drag') + if (is_root_pe()) write(stdout,'(A,E18.10)'), 'prop_int_tide: after background drag', CS%En_sum + call sum_En(G, GV, US, CS, CS%TKE_leak_loss(:,:,:,fr,m) * dt, 'prop_int_tide: loss after background drag') + if (is_root_pe()) write(stdout,'(A,E18.10)'), 'prop_int_tide: loss after background drag', CS%En_sum enddo ; enddo - enddo ; enddo ; enddo + ! Check for En<0 - for debugging, delete later + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=js,je ; do i=is,ie + if (CS%En(i,j,a,fr,m)<0.0) then + id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging + write(mesg,*) 'After leak loss: En<0.0 at ig=', id_g, ', jg=', jd_g, & + 'En=',CS%En(i,j,a,fr,m) + call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg), all_print=.true.) + !call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") + endif + enddo ; enddo + enddo ; enddo ; enddo + ! save loss term for online budget + do m=1,CS%nMode ; do fr=1,CS%nFreq + En_sumtmp = 0. + do a=1,CS%nAngle + En_sumtmp = En_sumtmp + global_area_integral(CS%TKE_leak_loss(:,:,a,fr,m)*dt, G, & + scale=HZ2_T2_to_J_m2) + enddo + CS%TKE_leak_loss_glo_dt(fr,m) = En_sumtmp + enddo ; enddo + endif ! Extract the energy for mixing due to bottom drag------------------------------- if (CS%apply_bottom_drag) then @@ -514,7 +730,7 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C call get_barotropic_tidal_vel(G, vel_btTide, CS%nFreq, inttide_input_CSp) do fr=1,CS%Nfreq ; do j=jsd,jed ; do i=isd,ied - tot_vel_btTide2(i,j) = tot_vel_btTide2(i,j) + vel_btTide(i,j,fr)**2 + tot_vel_btTide2(i,j) = tot_vel_btTide2(i,j) + (vel_btTide(i,j,fr)**2) enddo ; enddo ; enddo do k=1,GV%ke ; do j=jsd,jed ; do i=isd,ied @@ -524,38 +740,66 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C ! This is mathematically equivalent to the form in the option below, but they differ at roundoff. do m=1,CS%NMode ; do fr=1,CS%Nfreq ; do j=jsd,jed ; do i=isd,ied I_D_here = 1.0 / (max(htot(i,j), CS%drag_min_depth)) - drag_scale(i,j,fr,m) = CS%cdrag * sqrt(max(0.0, US%L_to_Z**2*tot_vel_btTide2(i,j)**2 + & - tot_En_mode(i,j,fr,m) * GV%RZ_to_H * I_D_here)) * GV%Z_to_H*I_D_here + drag_scale(i,j,fr,m) = CS%cdrag * sqrt(max(0.0, US%L_to_Z**2*tot_vel_btTide2(i,j) + & + (tot_En_mode(i,j,fr,m) * I_D_here))) * GV%Z_to_H*I_D_here enddo ; enddo ; enddo ; enddo else do m=1,CS%NMode ; do fr=1,CS%Nfreq ; do j=jsd,jed ; do i=isd,ied - I_mass = GV%RZ_to_H / (max(htot(i,j), CS%drag_min_depth)) + I_D_here = 1.0 / (max(htot(i,j), CS%drag_min_depth)) + I_mass = GV%RZ_to_H * I_D_here drag_scale(i,j,fr,m) = (CS%cdrag * (Rho_bot(i,j)*I_mass)) * & - sqrt(max(0.0, US%L_to_Z**2*tot_vel_btTide2(i,j)**2 + & - tot_En_mode(i,j,fr,m) * I_mass)) + sqrt(max(0.0, US%L_to_Z**2*tot_vel_btTide2(i,j) + & + (tot_En_mode(i,j,fr,m) * I_D_here))) enddo ; enddo ; enddo ; enddo endif + + if (CS%debug) call hchksum(drag_scale(:,:,1,1), "dragscale", G%HI, haloshift=0, scale=US%s_to_T) + if (CS%debug) call hchksum(tot_vel_btTide2(:,:), "tot_vel_btTide2", G%HI, haloshift=0, scale=US%L_T_to_m_s**2) + do m=1,CS%nMode ; do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=js,je ; do i=is,ie ! Calculate loss rate and apply loss over the time step ; apply the same drag timescale ! to each En component (technically not correct; fix later) - CS%TKE_quad_loss(i,j,a,fr,m) = CS%En(i,j,a,fr,m) * drag_scale(i,j,fr,m) ! loss rate - CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) / (1.0 + dt * drag_scale(i,j,fr,m)) ! implicit update + En_b = CS%En(i,j,a,fr,m) + En_a = CS%En(i,j,a,fr,m) / (1.0 + (dt * drag_scale(i,j,fr,m))) ! implicit update + CS%TKE_quad_loss(i,j,a,fr,m) = (En_b - En_a) * I_dt + CS%En(i,j,a,fr,m) = En_a enddo ; enddo ; enddo ; enddo ; enddo endif - ! Check for En<0 - for debugging, delete later - do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle - do j=js,je ; do i=is,ie - if (CS%En(i,j,a,fr,m)<0.0) then - id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging - write(mesg,*) 'After bottom loss: En<0.0 at ig=', id_g, ', jg=', jd_g, & - 'En=',CS%En(i,j,a,fr,m) - call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg), all_print=.true.) - CS%En(i,j,a,fr,m) = 0.0 -! call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") - !stop - endif + + if (CS%force_posit_En) then + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=jsd,jed ; do i=isd,ied + if (CS%En(i,j,a,fr,m)<0.0) then + CS%En(i,j,a,fr,m) = 0.0 + endif + enddo ; enddo + enddo ; enddo ; enddo + endif + + if (CS%debug) then + call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides after quad", G%HI, haloshift=0, scale=HZ2_T2_to_J_m2) + ! save loss term for online budget + do m=1,CS%nMode ; do fr=1,CS%nFreq + En_sumtmp = 0. + do a=1,CS%nAngle + En_sumtmp = En_sumtmp + global_area_integral(CS%TKE_quad_loss(:,:,a,fr,m)*dt, G, & + scale=HZ2_T2_to_J_m2) + enddo + CS%TKE_quad_loss_glo_dt(fr,m) = En_sumtmp enddo ; enddo - enddo ; enddo ; enddo + ! Check for En<0 - for debugging, delete later + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=js,je ; do i=is,ie + if (CS%En(i,j,a,fr,m)<0.0) then + id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging + write(mesg,*) 'After bottom loss: En<0.0 at ig=', id_g, ', jg=', jd_g, & + 'En=',CS%En(i,j,a,fr,m) + call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg), all_print=.true.) + !call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") + endif + enddo ; enddo + enddo ; enddo ; enddo + endif ! Extract the energy for mixing due to scattering (wave-drag)-------------------- ! still need to allow a portion of the extracted energy to go to higher modes. @@ -572,18 +816,18 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C f2 = (0.25*(G%CoriolisBu(I,J) + G%CoriolisBu(max(I-1,1),max(J-1,1)) + & G%CoriolisBu(I,max(J-1,1)) + G%CoriolisBu(max(I-1,1),J)))**2 - Kmag2 = (freq2 - f2) / (cn(i,j,m)**2 + cn_subRO**2) + Kmag2 = (freq2 - f2) / ((cn(i,j,m)**2) + (cn_subRO**2)) ! Back-calculate amplitude from energy equation if ( (G%mask2dT(i,j) > 0.5) .and. (freq2*Kmag2 > 0.0)) then ! Units here are [R Z ~> kg m-2] - KE_term = 0.25*GV%H_to_RZ*( ((freq2 + f2) / (freq2*Kmag2))*US%L_to_Z**2*CS%int_U2(i,j,m) + & + KE_term = 0.25*GV%H_to_RZ*( (((freq2 + f2) / (freq2*Kmag2))*US%L_to_Z**2*CS%int_U2(i,j,m)) + & CS%int_w2(i,j,m) ) PE_term = 0.25*GV%H_to_RZ*( CS%int_N2w2(i,j,m) / freq2 ) if (KE_term + PE_term > 0.0) then - W0 = sqrt( tot_En_mode(i,j,fr,m) / (KE_term + PE_term) ) + W0 = sqrt( GV%H_to_RZ * tot_En_mode(i,j,fr,m) / (KE_term + PE_term) ) else !call MOM_error(WARNING, "MOM internal tides: KE + PE <= 0.0; setting to W0 to 0.0") W0 = 0.0 @@ -608,19 +852,45 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C call itidal_lowmode_loss(G, GV, US, CS, Nb, Rho_bot, Ub, CS%En, CS%TKE_itidal_loss_fixed, & CS%TKE_itidal_loss, dt, halo_size=0) endif - ! Check for En<0 - for debugging, delete later - do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle - do j=js,je ; do i=is,ie - if (CS%En(i,j,a,fr,m)<0.0) then - id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging - write(mesg,*) 'After wave drag loss: En<0.0 at ig=', id_g, ', jg=', jd_g, & - 'En=',CS%En(i,j,a,fr,m) - call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg), all_print=.true.) - CS%En(i,j,a,fr,m) = 0.0 -! call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") - endif + + if (CS%force_posit_En) then + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=jsd,jed ; do i=isd,ied + if (CS%En(i,j,a,fr,m)<0.0) then + CS%En(i,j,a,fr,m) = 0.0 + endif + enddo ; enddo + enddo ; enddo ; enddo + endif + + if (CS%debug) then + call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides after wave", G%HI, haloshift=0, scale=HZ2_T2_to_J_m2) + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'prop_int_tide: before Froude drag') + if (is_root_pe()) write(stdout,'(A,E18.10)'), 'prop_int_tide: before Froude drag', CS%En_sum enddo ; enddo - enddo ; enddo ; enddo + ! save loss term for online budget, may want to add a debug flag later + do m=1,CS%nMode ; do fr=1,CS%nFreq + En_sumtmp = 0. + do a=1,CS%nAngle + En_sumtmp = En_sumtmp + global_area_integral(CS%TKE_itidal_loss(:,:,a,fr,m)*dt, G, & + scale=HZ2_T2_to_J_m2) + enddo + CS%TKE_itidal_loss_glo_dt(fr,m) = En_sumtmp + enddo ; enddo + ! Check for En<0 - for debugging, delete later + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=js,je ; do i=is,ie + if (CS%En(i,j,a,fr,m)<0.0) then + id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging + write(mesg,*) 'After wave drag loss: En<0.0 at ig=', id_g, ', jg=', jd_g, & + 'En=',CS%En(i,j,a,fr,m) + call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg), all_print=.true.) + !call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") + endif + enddo ; enddo + enddo ; enddo ; enddo + endif ! Extract the energy for mixing due to wave breaking----------------------------- if (CS%apply_Froude_drag) then @@ -632,85 +902,131 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C ! Calculate horizontal phase velocity magnitudes f2 = 0.25*((G%Coriolis2Bu(I,J) + G%Coriolis2Bu(I-1,J-1)) + & (G%Coriolis2Bu(I-1,J) + G%Coriolis2Bu(I,J-1))) - Kmag2 = (freq2 - f2) / (cn(i,j,m)**2 + cn_subRO**2) + Kmag2 = (freq2 - f2) / ((cn(i,j,m)**2) + (cn_subRO**2)) c_phase = 0.0 + CS%TKE_Froude_loss(i,j,:,fr,m) = 0. ! init for all angles if (Kmag2 > 0.0) then c_phase = sqrt(freq2/Kmag2) Fr2_max = (Umax(i,j,fr,m) / c_phase)**2 ! Dissipate energy if Fr>1; done here with an arbitrary time scale if (Fr2_max > 1.0) then - En_initial = sum(CS%En(i,j,:,fr,m)) ! for debugging ! Calculate effective decay rate [T-1 ~> s-1] if breaking occurs over a time step - loss_rate = (1.0 - Fr2_max) / (Fr2_max * dt) + !loss_rate = (1.0 - Fr2_max) / (Fr2_max * dt) do a=1,CS%nAngle ! Determine effective dissipation rate (Wm-2) - CS%TKE_Froude_loss(i,j,a,fr,m) = CS%En(i,j,a,fr,m) * abs(loss_rate) - ! Update energy - En_new = CS%En(i,j,a,fr,m)/Fr2_max ! for debugging - En_check = CS%En(i,j,a,fr,m) - CS%TKE_Froude_loss(i,j,a,fr,m)*dt ! for debugging - ! Re-scale (reduce) energy due to breaking - CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m)/Fr2_max - ! Check (for debugging only) - if (abs(En_new - En_check) > CS%En_check_tol) then - call MOM_error(WARNING, "MOM_internal_tides: something is wrong with Fr-breaking.", & - all_print=.true.) - write(mesg,*) "En_new=", En_new , "En_check=", En_check - call MOM_error(WARNING, "MOM_internal_tides: "//trim(mesg), all_print=.true.) - endif + !CS%TKE_Froude_loss(i,j,a,fr,m) = CS%En(i,j,a,fr,m) * abs(loss_rate) + En_b = CS%En(i,j,a,fr,m) + En_a = CS%En(i,j,a,fr,m)/Fr2_max + CS%TKE_Froude_loss(i,j,a,fr,m) = (En_b - En_a) * I_dt + CS%En(i,j,a,fr,m) = En_a enddo - ! Check (for debugging) - Delta_E_check = En_initial - sum(CS%En(i,j,:,fr,m)) - TKE_Froude_loss_check = abs(Delta_E_check)/dt - TKE_Froude_loss_tot = sum(CS%TKE_Froude_loss(i,j,:,fr,m)) - if (abs(TKE_Froude_loss_check - TKE_Froude_loss_tot)*dt > CS%En_check_tol) then - call MOM_error(WARNING, "MOM_internal_tides: something is wrong with Fr energy update.", & - all_print=.true.) - write(mesg,*) "TKE_Froude_loss_check=", TKE_Froude_loss_check, & - "TKE_Froude_loss_tot=", TKE_Froude_loss_tot - call MOM_error(WARNING, "MOM_internal_tides: "//trim(mesg), all_print=.true.) - endif endif ! Fr2>1 endif ! Kmag2>0 CS%cp(i,j,fr,m) = c_phase enddo ; enddo enddo ; enddo endif - ! Check for En<0 - for debugging, delete later - do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle - do j=js,je ; do i=is,ie - if (CS%En(i,j,a,fr,m)<0.0) then - id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset - write(mesg,*) 'After Froude loss: En<0.0 at ig=', id_g, ', jg=', jd_g, & - 'En=',CS%En(i,j,a,fr,m) - call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg), all_print=.true.) - CS%En(i,j,a,fr,m) = 0.0 -! call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") - !stop - endif + + if (CS%force_posit_En) then + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=jsd,jed ; do i=isd,ied + if (CS%En(i,j,a,fr,m)<0.0) then + CS%En(i,j,a,fr,m) = 0.0 + endif + enddo ; enddo + enddo ; enddo ; enddo + endif + + if (CS%debug) then + call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides after froude", G%HI, haloshift=0, scale=HZ2_T2_to_J_m2) + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'prop_int_tide: after Froude drag') + if (is_root_pe()) write(stdout,'(A,E18.10)'), 'prop_int_tide: after Froude drag', CS%En_sum + call sum_En(G, GV, US, CS, CS%TKE_Froude_loss(:,:,:,fr,m) * dt, 'prop_int_tide: loss after Froude drag') + if (is_root_pe()) write(stdout,'(A,E18.10)'), 'prop_int_tide: loss after Froude drag', CS%En_sum enddo ; enddo - enddo ; enddo ; enddo + ! save loss term for online budget, may want to add a debug flag later + do m=1,CS%nMode ; do fr=1,CS%nFreq + En_sumtmp = 0. + do a=1,CS%nAngle + En_sumtmp = En_sumtmp + global_area_integral(CS%TKE_Froude_loss(:,:,a,fr,m)*dt, G, & + scale=HZ2_T2_to_J_m2) + enddo + CS%TKE_Froude_loss_glo_dt(fr,m) = En_sumtmp + enddo ; enddo + ! Check for En<0 - for debugging, delete later + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=js,je ; do i=is,ie + if (CS%En(i,j,a,fr,m)<0.0) then + id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset + write(mesg,*) 'After Froude loss: En<0.0 at ig=', id_g, ', jg=', jd_g, & + 'En=',CS%En(i,j,a,fr,m) + call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg), all_print=.true.) + !call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") + endif + enddo ; enddo + enddo ; enddo ; enddo + endif ! loss from residual of reflection/transmission coefficients if (CS%apply_residual_drag) then do m=1,CS%nMode ; do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=js,je ; do i=is,ie - ! implicit form + ! implicit form is rewritten to minimize number of divisions !CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) / (1.0 + dt * CS%TKE_residual_loss(i,j,a,fr,m) / & ! (CS%En(i,j,a,fr,m) + en_subRO)) - ! rewritten to minimize number of divisions: - CS%En(i,j,a,fr,m) = (CS%En(i,j,a,fr,m) * (CS%En(i,j,a,fr,m) + en_subRO)) / & - ((CS%En(i,j,a,fr,m) + en_subRO) + dt * CS%TKE_residual_loss(i,j,a,fr,m)) + ! only compute when partial reflection is present not to create noise elsewhere + if (CS%refl_pref_logical(i,j)) then + En_b = CS%En(i,j,a,fr,m) + En_a = (CS%En(i,j,a,fr,m) * (CS%En(i,j,a,fr,m) + en_subRO)) / & + ((CS%En(i,j,a,fr,m) + en_subRO) + (dt * CS%TKE_slope_loss(i,j,a,fr,m))) + CS%TKE_residual_loss(i,j,a,fr,m) = (En_b - En_a) * I_dt + CS%En(i,j,a,fr,m) = En_a + endif + enddo ; enddo ; enddo ; enddo ; enddo - ! explicit form - !CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) - dt * CS%TKE_residual_loss(i,j,a,fr,m) + else + ! zero out the residual loss term so it does not count towards diagnostics + do m=1,CS%nMode ; do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=js,je ; do i=is,ie + CS%TKE_residual_loss(i,j,a,fr,m) = 0. enddo ; enddo ; enddo ; enddo ; enddo endif + if (CS%debug) then + call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides after slope", G%HI, haloshift=0, scale=HZ2_T2_to_J_m2) + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'prop_int_tide') + enddo ; enddo + ! save loss term for online budget + do m=1,CS%nMode ; do fr=1,CS%nFreq + En_sumtmp = 0. + do a=1,CS%nAngle + En_sumtmp = En_sumtmp + global_area_integral(CS%TKE_residual_loss(:,:,a,fr,m)*dt, G, & + scale=HZ2_T2_to_J_m2) + enddo + CS%TKE_residual_loss_glo_dt(fr,m) = En_sumtmp + enddo ; enddo + endif - ! Check for energy conservation on computational domain.************************* - do m=1,CS%nMode ; do fr=1,CS%Nfreq - call sum_En(G, US, CS, CS%En(:,:,:,fr,m), 'prop_int_tide') - enddo ; enddo + !---- energy budget ---- + if (CS%debug) then + ! save final energy for online budget + do m=1,CS%nMode ; do fr=1,CS%nFreq + En_sumtmp = 0. + do a=1,CS%nAngle + En_sumtmp = En_sumtmp + global_area_integral(CS%En(:,:,a,fr,m), G, scale=HZ2_T2_to_J_m2) + enddo + CS%En_end_glo(fr,m) = En_sumtmp + enddo ; enddo + + do m=1,CS%nMode ; do fr=1,CS%nFreq + CS%error_mode(fr,m) = CS%En_ini_glo(fr,m) + CS%TKE_input_glo_dt(fr,m) - CS%TKE_leak_loss_glo_dt(fr,m) - & + CS%TKE_quad_loss_glo_dt(fr,m) - CS%TKE_itidal_loss_glo_dt(fr,m) - & + CS%TKE_Froude_loss_glo_dt(fr,m) - CS%TKE_residual_loss_glo_dt(fr,m) - & + CS%En_end_glo(fr,m) + if (is_root_pe()) write(stdout,'(A,F18.10)'), "error in Energy budget", CS%error_mode(fr,m) + enddo ; enddo + endif ! Output diagnostics.************************************************************ avg_enabled = query_averaging_enabled(CS%diag, time_end=time_end) @@ -743,30 +1059,30 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C ! split energy array into multiple restarts do fr=1,CS%Nfreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied - CS%En_restart_mode1(i,j,a,fr) = CS%En(i,j,a,fr,1) + CS%En_restart_mode1(i,j,a,fr) = CS%En(i,j,a,fr,1) * En_restart_factor enddo ; enddo ; enddo ; enddo if (CS%nMode >= 2) then do fr=1,CS%Nfreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied - CS%En_restart_mode2(i,j,a,fr) = CS%En(i,j,a,fr,2) + CS%En_restart_mode2(i,j,a,fr) = CS%En(i,j,a,fr,2) * En_restart_factor enddo ; enddo ; enddo ; enddo endif if (CS%nMode >= 3) then do fr=1,CS%Nfreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied - CS%En_restart_mode3(i,j,a,fr) = CS%En(i,j,a,fr,3) + CS%En_restart_mode3(i,j,a,fr) = CS%En(i,j,a,fr,3) * En_restart_factor enddo ; enddo ; enddo ; enddo endif if (CS%nMode >= 4) then do fr=1,CS%Nfreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied - CS%En_restart_mode4(i,j,a,fr) = CS%En(i,j,a,fr,4) + CS%En_restart_mode4(i,j,a,fr) = CS%En(i,j,a,fr,4) * En_restart_factor enddo ; enddo ; enddo ; enddo endif if (CS%nMode >= 5) then do fr=1,CS%Nfreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied - CS%En_restart_mode5(i,j,a,fr) = CS%En(i,j,a,fr,5) + CS%En_restart_mode5(i,j,a,fr) = CS%En(i,j,a,fr,5) * En_restart_factor enddo ; enddo ; enddo ; enddo endif @@ -889,12 +1205,13 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C end subroutine propagate_int_tide !> Checks for energy conservation on computational domain -subroutine sum_En(G, US, CS, En, label) +subroutine sum_En(G, GV, US, CS, En, label) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type),intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(int_tide_CS), intent(inout) :: CS !< Internal tide control structure real, dimension(G%isd:G%ied,G%jsd:G%jed,CS%NAngle), & - intent(in) :: En !< The energy density of the internal tides [R Z3 T-2 ~> J m-2]. + intent(in) :: En !< The energy density of the internal tides [H Z2 T-2 ~> m3 s-2 or J m-2]. character(len=*), intent(in) :: label !< A label to use in error messages ! Local variables real :: En_sum ! The total energy in MKS units for potential output [J] @@ -906,7 +1223,7 @@ subroutine sum_En(G, US, CS, En, label) En_sum = 0.0 do a=1,CS%nAngle - En_sum = En_sum + global_area_integral(En(:,:,a), G, unscale=US%RZ3_T3_to_W_m2*US%T_to_s) + En_sum = En_sum + global_area_integral(En(:,:,a), G, unscale=GV%H_to_m*(US%Z_to_m**2)*(US%s_to_T)**2) enddo CS%En_sum = En_sum !En_sum_diff = En_sum - CS%En_sum @@ -945,32 +1262,49 @@ subroutine itidal_lowmode_loss(G, GV, US, CS, Nb, Rho_bot, Ub, En, TKE_loss_fixe intent(in) :: TKE_loss_fixed !< Fixed part of energy loss [R Z4 H-1 L-2 ~> kg m-2 or m] !! (rho*kappa*h^2) or (kappa*h^2). real, dimension(G%isd:G%ied,G%jsd:G%jed,CS%NAngle,CS%nFreq,CS%nMode), & - intent(inout) :: En !< Energy density of the internal waves [R Z3 T-2 ~> J m-2]. + intent(inout) :: En !< Energy density of the internal waves [H Z2 T-2 ~> m3 s-2 or J m-2]. real, dimension(G%isd:G%ied,G%jsd:G%jed,CS%NAngle,CS%nFreq,CS%nMode), & - intent(out) :: TKE_loss !< Energy loss rate [R Z3 T-3 ~> W m-2] + intent(out) :: TKE_loss !< Energy loss rate [H Z2 T-3 ~> m3 s-3 or W m-2] !! (q*rho*kappa*h^2*N*U^2). real, intent(in) :: dt !< Time increment [T ~> s]. integer, optional, intent(in) :: halo_size !< The halo size over which to do the calculations ! Local variables integer :: j, i, m, fr, a, is, ie, js, je, halo - real :: En_tot ! energy for a given mode, frequency, and point summed over angles [R Z3 T-2 ~> J m-2] - real :: TKE_loss_tot ! dissipation for a given mode, frequency, and point summed over angles [R Z3 T-3 ~> W m-2] + real :: En_tot ! energy for a given mode, frequency + ! and point summed over angles [H Z2 T-2 ~> m3 s-2 or J m-2] + real :: TKE_loss_tot ! dissipation for a given mode, frequency + ! and point summed over angles [H Z2 T-3 ~> m3 s-3 or W m-2] real :: frac_per_sector ! fraction of energy in each wedge [nondim] real :: q_itides ! fraction of energy actually lost to mixing (remainder, 1-q, is ! assumed to stay in propagating mode for now - BDM) [nondim] real :: loss_rate ! approximate loss rate for implicit calc [T-1 ~> s-1] - real :: En_negl ! negligibly small number to prevent division by zero [R Z3 T-2 ~> J m-2] + real :: En_negl ! negligibly small number to prevent division by zero [H Z2 T-2 ~> m3 s-2 or J m-2] + real :: En_a, En_b ! energy before and after timestep [H Z2 T-2 ~> m3 s-2 or J m-2] + real :: I_dt ! The inverse of the timestep [T-1 ~> s-1] + real :: J_m2_to_HZ2_T2 ! unit conversion factor for Energy from mks to internal [m3 s-2 or J m-2 ~> H Z2 T-2] + real :: HZ2_T3_to_W_m2 ! unit conversion factor for Energy from internal to mks [H Z2 T-3 ~> m3 s-3 or W m-2] is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + J_m2_to_HZ2_T2 = GV%m_to_H*(US%m_to_Z**2)*(US%T_to_s**2) + HZ2_T3_to_W_m2 = GV%H_to_m*(US%Z_to_m**2)*(US%s_to_T**3) + + I_dt = 1.0 / dt q_itides = CS%q_itides - En_negl = 1e-30*US%kg_m3_to_R*US%m_to_Z**3*US%T_to_s**2 + En_negl = 1e-30*J_m2_to_HZ2_T2 if (present(halo_size)) then halo = halo_size is = G%isc - halo ; ie = G%iec + halo ; js = G%jsc - halo ; je = G%jec + halo endif + if (CS%debug) then + call hchksum(TKE_loss_fixed, "TKE loss fixed", G%HI, haloshift=0, & + scale=US%RZ_to_kg_m2*(US%Z_to_m**3)*GV%m_to_H*(US%m_to_L**2)) + call hchksum(Nb(:,:), "Nbottom", G%HI, haloshift=0, scale=US%s_to_T) + call hchksum(Ub(:,:,1,1), "Ubottom", G%HI, haloshift=0, scale=US%L_to_m*US%s_to_T) + endif + do j=js,je ; do i=is,ie ; do m=1,CS%nMode ; do fr=1,CS%nFreq ! Sum energy across angles @@ -979,11 +1313,11 @@ subroutine itidal_lowmode_loss(G, GV, US, CS, Nb, Rho_bot, Ub, En, TKE_loss_fixe En_tot = En_tot + En(i,j,a,fr,m) enddo - ! Calculate TKE loss rate; units of [R Z3 T-3 ~> W m-2] here. + ! Calculate TKE loss rate; units of [H Z2 T-3 ~> m3 s-3 or W m-2] here. if (GV%Boussinesq .or. GV%semi_Boussinesq) then - TKE_loss_tot = q_itides * GV%Z_to_H * TKE_loss_fixed(i,j) * Nb(i,j) * Ub(i,j,fr,m)**2 + TKE_loss_tot = q_itides * GV%RZ_to_H*GV%Z_to_H*TKE_loss_fixed(i,j)*Nb(i,j)*Ub(i,j,fr,m)**2 else - TKE_loss_tot = q_itides * (GV%RZ_to_H * Rho_bot(i,j)) * TKE_loss_fixed(i,j) * Nb(i,j) * Ub(i,j,fr,m)**2 + TKE_loss_tot = q_itides * (GV%RZ_to_H*GV%RZ_to_H*Rho_bot(i,j))*TKE_loss_fixed(i,j)*Nb(i,j)*Ub(i,j,fr,m)**2 endif ! Update energy remaining (this is a pseudo implicit calc) @@ -991,9 +1325,12 @@ subroutine itidal_lowmode_loss(G, GV, US, CS, Nb, Rho_bot, Ub, En, TKE_loss_fixe if (En_tot > 0.0) then do a=1,CS%nAngle frac_per_sector = En(i,j,a,fr,m)/En_tot - TKE_loss(i,j,a,fr,m) = frac_per_sector*TKE_loss_tot ! [R Z3 T-3 ~> W m-2] + TKE_loss(i,j,a,fr,m) = frac_per_sector*TKE_loss_tot ! [H Z2 T-3 ~> m3 s-3 or W m-2] loss_rate = TKE_loss(i,j,a,fr,m) / (En(i,j,a,fr,m) + En_negl) ! [T-1 ~> s-1] - En(i,j,a,fr,m) = En(i,j,a,fr,m) / (1.0 + dt*loss_rate) + En_b = En(i,j,a,fr,m) + En_a = En(i,j,a,fr,m) / (1.0 + (dt*loss_rate)) + TKE_loss(i,j,a,fr,m) = (En_b - En_a) * I_dt ! overwrite with exact value + En(i,j,a,fr,m) = En_a enddo else ! no loss if no energy @@ -1002,24 +1339,6 @@ subroutine itidal_lowmode_loss(G, GV, US, CS, Nb, Rho_bot, Ub, En, TKE_loss_fixe enddo endif - ! Update energy remaining (this is the old explicit calc) - !if (En_tot > 0.0) then - ! do a=1,CS%nAngle - ! frac_per_sector = En(i,j,a,fr,m)/En_tot - ! TKE_loss(i,j,a,fr,m) = frac_per_sector*TKE_loss_tot - ! if (TKE_loss(i,j,a,fr,m)*dt <= En(i,j,a,fr,m))then - ! En(i,j,a,fr,m) = En(i,j,a,fr,m) - TKE_loss(i,j,a,fr,m)*dt - ! else - ! call MOM_error(WARNING, "itidal_lowmode_loss: energy loss greater than available, "// & - ! " setting En to zero.", all_print=.true.) - ! En(i,j,a,fr,m) = 0.0 - ! endif - ! enddo - !else - ! ! no loss if no energy - ! TKE_loss(i,j,:,fr,m) = 0.0 - !endif - enddo ; enddo ; enddo ; enddo end subroutine itidal_lowmode_loss @@ -1035,15 +1354,451 @@ subroutine get_lowmode_loss(i,j,G,CS,mechanism,TKE_loss_sum) type(int_tide_CS), intent(in) :: CS !< Internal tide control structure character(len=*), intent(in) :: mechanism !< The named mechanism of loss to return real, intent(out) :: TKE_loss_sum !< Total energy loss rate due to specified - !! mechanism [R Z3 T-3 ~> W m-2]. + !! mechanism [H Z2 T-3 ~> m3 s-3 or W m-2]. - if (mechanism == 'LeakDrag') TKE_loss_sum = CS%tot_leak_loss(i,j) ! not used for mixing yet - if (mechanism == 'QuadDrag') TKE_loss_sum = CS%tot_quad_loss(i,j) ! not used for mixing yet - if (mechanism == 'WaveDrag') TKE_loss_sum = CS%tot_itidal_loss(i,j) ! currently used for mixing - if (mechanism == 'Froude') TKE_loss_sum = CS%tot_Froude_loss(i,j) ! not used for mixing yet + if (mechanism == 'LeakDrag') TKE_loss_sum = CS%tot_leak_loss(i,j) + if (mechanism == 'QuadDrag') TKE_loss_sum = CS%tot_quad_loss(i,j) + if (mechanism == 'WaveDrag') TKE_loss_sum = CS%tot_itidal_loss(i,j) + if (mechanism == 'Froude') TKE_loss_sum = CS%tot_Froude_loss(i,j) + if (mechanism == 'SlopeDrag') TKE_loss_sum = CS%tot_residual_loss(i,j) end subroutine get_lowmode_loss + +!> Returns the values of diffusivity corresponding to various mechanisms +subroutine get_lowmode_diffusivity(G, GV, h, tv, US, h_bot, k_bot, j, N2_lay, N2_int, TKE_to_Kd, Kd_max, CS, & + Kd_leak, Kd_quad, Kd_itidal, Kd_Froude, Kd_slope, & + Kd_lay, Kd_int, profile_leak, profile_quad, profile_itidal, & + profile_Froude, profile_slope) + + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any available + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G)), intent(in) :: h_bot !< Bottom boundary layer thickness [H ~> m or kg m-2] + integer, dimension(SZI_(G)), intent(in) :: k_bot !< Bottom boundary layer top layer index + integer, intent(in) :: j !< The j-index to work on + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: N2_lay !< The squared buoyancy frequency of the + !! layers [T-2 ~> s-2]. + real, dimension(SZI_(G),SZK_(GV)+1), intent(in) :: N2_int !< The squared buoyancy frequency of the + !! interfaces [T-2 ~> s-2]. + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: TKE_to_Kd !< The conversion rate between the TKE + !! dissipated within a layer and the + !! diapycnal diffusivity within that layer, + !! usually (~Rho_0 / (G_Earth * dRho_lay)) + !! [H Z T-1 / H Z2 T-3 = T2 Z-1 ~> s2 m-1] + real, intent(in) :: Kd_max !< The maximum increment for diapycnal + !! diffusivity due to TKE-based processes + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + !! Set this to a negative value to have no limit. + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + type(int_tide_cs), intent(in) :: CS !< The control structure for this module + + real, dimension(SZI_(G),SZK_(GV)+1), intent(out) :: Kd_leak !< Diffusivity due to background drag + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + real, dimension(SZI_(G),SZK_(GV)+1), intent(out) :: Kd_quad !< Diffusivity due to bottom drag + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + real, dimension(SZI_(G),SZK_(GV)+1), intent(out) :: Kd_itidal !< Diffusivity due to wave drag + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + real, dimension(SZI_(G),SZK_(GV)+1), intent(out) :: Kd_Froude !< Diffusivity due to high Froude breaking + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + real, dimension(SZI_(G),SZK_(GV)+1), intent(out) :: Kd_slope !< Diffusivity due to critical slopes + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + real, dimension(SZI_(G),SZK_(GV)), intent(inout) :: Kd_lay !< The diapycnal diffusivity in layers + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + real, dimension(SZI_(G),SZK_(GV)+1), intent(inout) :: Kd_int !< The diapycnal diffusivity at interfaces + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + real, dimension(SZI_(G), SZK_(GV)), intent(out) :: profile_leak !< Normalized profile for background drag + !! [H-1 ~> m-1] + real, dimension(SZI_(G), SZK_(GV)), intent(out) :: profile_quad !< Normalized profile for bottom drag + !! [H-1 ~> m-1] + real, dimension(SZI_(G), SZK_(GV)), intent(out) :: profile_itidal !< Normalized profile for wave drag + !! [H-1 ~> m-1] + real, dimension(SZI_(G), SZK_(GV)), intent(out) :: profile_Froude !< Normalized profile for Froude drag + !! [H-1 ~> m-1] + real, dimension(SZI_(G), SZK_(GV)), intent(out) :: profile_slope !< Normalized profile for critical slopes + !! [H-1 ~> m-1] + + ! local variables + real :: TKE_loss ! temp variable to pass value of internal tides TKE loss [R Z-3 T-3 ~> W/m2] + real :: renorm_N ! renormalization for N profile [H T-1 ~> m s-1] + real :: renorm_N2 ! renormalization for N2 profile [H T-2 ~> m s-2] + real :: tmp_StLau ! tmp var for renormalization for StLaurent profile [nondim] + real :: tmp_StLau_slope ! tmp var for renormalization for StLaurent profile [nondim] + real :: renorm_StLau ! renormalization for StLaurent profile [nondim] + real :: renorm_StLau_slope! renormalization for StLaurent profile [nondim] + real :: htot ! total depth of water column [H ~> m] + real :: htmp ! local value of thickness in layers [H ~> m] + real :: h_d ! expomential decay length scale [H ~> m] + real :: h_s ! expomential decay length scale on the slope [H ~> m] + real :: I_h_d ! inverse of expomential decay length scale [H-1 ~> m-1] + real :: I_h_s ! inverse of expomential decay length scale on the slope [H-1 ~> m-1] + real :: TKE_to_Kd_lim ! limited version of TKE_to_Kd [T2 Z-1 ~> s2 m-1] + + ! vertical profiles have units Z-1 for conversion to Kd to be dim correct (see eq 2 of St Laurent GRL 2002) + real, dimension(SZK_(GV)) :: profile_N ! vertical profile varying with N [H-1 ~> m-1] + real, dimension(SZK_(GV)) :: profile_N2 ! vertical profile varying with N2 [H-1 ~> m-1] + real, dimension(SZK_(GV)) :: profile_StLaurent ! vertical profile according to St Laurent 2002 [H-1 ~> m-1] + real, dimension(SZK_(GV)) :: profile_StLaurent_slope ! vertical profile according to St Laurent 2002 [H-1 ~> m-1] + real, dimension(SZK_(GV)) :: profile_BBL ! vertical profile Heavyside BBL [H-1 ~> m-1] + real, dimension(SZK_(GV)) :: Kd_leak_lay ! Diffusivity due to background drag [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real, dimension(SZK_(GV)) :: Kd_quad_lay ! Diffusivity due to bottom drag [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real, dimension(SZK_(GV)) :: Kd_itidal_lay ! Diffusivity due to wave drag [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real, dimension(SZK_(GV)) :: Kd_Froude_lay ! Diffusivity due to high Froude breaking [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real, dimension(SZK_(GV)) :: Kd_slope_lay ! Diffusivity due to critical slopes [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + + real :: hmin ! A minimum allowable thickness [H ~> m] + real :: h_rmn ! Remaining thickness in k-loop [H ~> m] + real :: frac ! A fraction of thicknesses [nondim] + real :: verif_N, & ! profile verification [nondim] + verif_N2, & ! profile verification [nondim] + verif_bbl, & ! profile verification [nondim] + verif_stl1,& ! profile verification [nondim] + verif_stl2,& ! profile verification [nondim] + threshold_renorm_N2,& ! Maximum allowable error on N2 profile [H T-2 ~> m.s-2] + threshold_renorm_N, & ! Maximum allowable error on N profile [H T-1 ~> m.s-1] + threshold_verif ! Maximum allowable error on verification [nondim] + + logical :: non_Bous ! fully Non-Boussinesq + integer :: i, k, is, ie, nz + + is=G%isc ; ie=G%iec ; nz=GV%ke + + non_Bous = .not.(GV%Boussinesq .or. GV%semi_Boussinesq) + + h_d = CS%Int_tide_decay_scale + h_s = CS%Int_tide_decay_scale_slope + I_h_d = 1 / h_d + I_h_s = 1 / h_s + + hmin = 1.0e-6*GV%m_to_H + threshold_renorm_N2 = 1.0e-13 * GV%m_to_H * US%T_to_s**2 + threshold_renorm_N = 1.0e-13 * GV%m_to_H * US%T_to_s + threshold_verif = 1.0e-13 + + ! init output arrays + profile_leak(:,:) = 0.0 + profile_quad(:,:) = 0.0 + profile_slope(:,:) = 0.0 + profile_itidal(:,:) = 0.0 + profile_Froude(:,:) = 0.0 + + Kd_leak_lay(:) = 0.0 + Kd_quad_lay(:) = 0.0 + Kd_itidal_lay(:) = 0.0 + Kd_Froude_lay(:) = 0.0 + Kd_slope_lay(:) = 0.0 + + Kd_leak(:,:) = 0.0 + Kd_quad(:,:) = 0.0 + Kd_itidal(:,:) = 0.0 + Kd_Froude(:,:) = 0.0 + Kd_slope(:,:) = 0.0 + + do i=is,ie + + ! create vertical profiles for diffusivites in layers + renorm_N = 0.0 + renorm_N2 = 0.0 + renorm_StLau = 0.0 + renorm_StLau_slope = 0.0 + tmp_StLau = 0.0 + tmp_StLau_slope = 0.0 + htot = 0.0 + htmp = 0.0 + + do k=1,nz + ! N-profile + if (N2_lay(i,k) < 0.) call MOM_error(WARNING, "negative buoyancy freq") + renorm_N = renorm_N + (sqrt(max(N2_lay(i,k), 0.)) * h(i,j,k)) + ! N2-profile + renorm_N2 = renorm_N2 + (max(N2_lay(i,k), 0.) * h(i,j,k)) + ! total depth + htot = htot + h(i,j,k) + enddo + + profile_N2(:) = 0.0 + profile_N(:) = 0.0 + profile_BBL(:) = 0.0 + profile_StLaurent(:) = 0.0 + profile_StLaurent_slope(:) = 0.0 + + ! BBL-profile + h_rmn = h_bot(i) + do k=nz,1,-1 + if (G%mask2dT(i,j) > 0.0) then + profile_BBL(k) = 0.0 + if (h(i,j,k) <= h_rmn) then + profile_BBL(k) = 1.0 / h_bot(i) + h_rmn = h_rmn - h(i,j,k) + else + if (h_rmn > 0.0) then + frac = h_rmn / h(i,j,k) + profile_BBL(k) = frac / h_bot(i) + h_rmn = h_rmn - frac*h(i,j,k) + endif + endif + endif + enddo + + do k=1,nz + if (G%mask2dT(i,j) > 0.0) then + ! N - profile + if (renorm_N > threshold_renorm_N) then + profile_N(k) = sqrt(max(N2_lay(i,k), 0.)) / renorm_N + else + profile_N(k) = 1 / htot + endif + + ! N2 - profile + if (renorm_N2 > threshold_renorm_N2) then + profile_N2(k) = max(N2_lay(i,k), 0.) / renorm_N2 + else + profile_N2(k) = 1 / htot + endif + + ! slope intensified (St Laurent GRL 2002) - profile + ! in paper, z is defined positive upwards, range 0 to -H + ! here depth positive downwards + ! profiles are almost normalized but differ from a few percent + ! so we add a second renormalization factor + + ! add first half of layer: get to the layer center + htmp = htmp + 0.5*h(i,j,k) + + profile_StLaurent(k) = exp(-I_h_d*(htot-htmp)) / & + (h_d*(1 - exp(-I_h_d*htot))) + + profile_StLaurent_slope(k) = exp(-I_h_s*(htot-htmp)) / & + (h_s*(1 - exp(-I_h_s*htot))) + + tmp_StLau = tmp_StLau + (profile_StLaurent(k) * h(i,j,k)) + tmp_StLau_slope = tmp_StLau_slope + (profile_StLaurent_slope(k) * h(i,j,k)) + + ! add second half of layer: get to the next interface + htmp = htmp + 0.5*h(i,j,k) + endif + enddo + + if (G%mask2dT(i,j) > 0.0) then + ! allow for difference less than verification threshold + renorm_StLau = 1.0 + renorm_StLau_slope = 1.0 + if (abs(tmp_StLau -1.0) > threshold_verif) renorm_StLau = 1.0 / tmp_StLau + if (abs(tmp_StLau_slope -1.0) > threshold_verif) renorm_StLau_slope = 1.0 / tmp_StLau_slope + + do k=1,nz + profile_StLaurent(k) = profile_StLaurent(k) * renorm_StLau + profile_StLaurent_slope(k) = profile_StLaurent_slope(k) * renorm_StLau_slope + enddo + endif + + ! verif integrals + if (CS%debug) then + if (G%mask2dT(i,j) > 0.0) then + verif_N = 0.0 + verif_N2 = 0.0 + verif_bbl = 0.0 + verif_stl1 = 0.0 + verif_stl2 = 0.0 + do k=1,nz + verif_N = verif_N + (profile_N(k) * h(i,j,k)) + verif_N2 = verif_N2 + (profile_N2(k) * h(i,j,k)) + verif_bbl = verif_bbl + (profile_BBL(k) * h(i,j,k)) + verif_stl1 = verif_stl1 + (profile_StLaurent(k) * h(i,j,k)) + verif_stl2 = verif_stl2 + (profile_StLaurent_slope(k) * h(i,j,k)) + enddo + + if (abs(verif_N -1.0) > threshold_verif) then + write(stdout,'(I5,I5,F18.10)'), i, j, verif_N + call MOM_error(FATAL, "mismatch integral for N profile") + endif + if (abs(verif_N2 -1.0) > threshold_verif) then + write(stdout,'(I5,I5,F18.10)'), i, j, verif_N2 + call MOM_error(FATAL, "mismatch integral for N2 profile") + endif + if (abs(verif_bbl -1.0) > threshold_verif) then + write(stdout,'(I5,I5,F18.10)'), i, j, verif_bbl + call MOM_error(FATAL, "mismatch integral for bbl profile") + endif + if (abs(verif_stl1 -1.0) > threshold_verif) then + write(stdout,'(I5,I5,F18.10)'), i, j, verif_stl1 + call MOM_error(FATAL, "mismatch integral for stl1 profile") + endif + if (abs(verif_stl2 -1.0) > threshold_verif) then + write(stdout,'(I5,I5,F18.10)'), i, j, verif_stl2 + call MOM_error(FATAL, "mismatch integral for stl2 profile") + endif + + endif + endif + + ! note on units: TKE_to_Kd = 1 / ((g/rho0) * drho) Z-1 T2 + ! mult by dz gives -1/N2 in T2 + + ! get TKE loss value and compute diffusivites in layers + if (CS%apply_background_drag) then + call get_lowmode_loss(i, j, G, CS, "LeakDrag", TKE_loss) + ! insert logic to switch between profiles here + ! if trim(CS%leak_profile) == "N2" then + profile_leak(i,:) = profile_N2(:) + ! elseif trim(CS%leak_profile) == "N" then + ! profile_leak(:) = profile_N(:) + ! something else + ! endif + Kd_leak_lay(:) = 0. + do k=1,nz + ! layer diffusivity for processus + if (h(i,j,k) >= CS%min_thick_layer_Kd) then + TKE_to_Kd_lim = min(TKE_to_Kd(i,k), CS%max_TKE_to_Kd) + Kd_leak_lay(k) = TKE_loss * TKE_to_Kd_lim * profile_leak(i,k) * h(i,j,k) + else + Kd_leak_lay(k) = 0. + endif + ! add to total Kd in layer + if (CS%update_Kd) Kd_lay(i,k) = Kd_lay(i,k) + min(Kd_leak_lay(k), Kd_max) + enddo + endif + + if (CS%apply_Froude_drag) then + call get_lowmode_loss(i, j, G, CS, "Froude", TKE_loss) + ! insert logic to switch between profiles here + ! if trim(CS%Froude_profile) == "N" then + profile_Froude(i,:) = profile_N(:) + ! elseif trim(CS%Froude_profile) == "N2" then + ! profile_Froude(:) = profile_N2(:) + ! something else + ! endif + do k=1,nz + ! layer diffusivity for processus + if (h(i,j,k) >= CS%min_thick_layer_Kd) then + TKE_to_Kd_lim = min(TKE_to_Kd(i,k), CS%max_TKE_to_Kd) + Kd_Froude_lay(k) = TKE_loss * TKE_to_Kd_lim * profile_Froude(i,k) * h(i,j,k) + else + Kd_Froude_lay(k) = 0. + endif + ! add to total Kd in layer + if (CS%update_Kd) Kd_lay(i,k) = Kd_lay(i,k) + min(Kd_Froude_lay(k), Kd_max) + enddo + endif + + if (CS%apply_wave_drag) then + call get_lowmode_loss(i, j, G, CS, "WaveDrag", TKE_loss) + ! insert logic to switch between profiles here + ! if trim(CS%wave_profile) == "StLaurent" then + profile_itidal(i,:) = profile_StLaurent(:) + ! elseif trim(CS%Froude_profile) == "N2" then + ! profile_itidal(:) = profile_N2(:) + ! something else + ! endif + do k=1,nz + ! layer diffusivity for processus + if (h(i,j,k) >= CS%min_thick_layer_Kd) then + TKE_to_Kd_lim = min(TKE_to_Kd(i,k), CS%max_TKE_to_Kd) + Kd_itidal_lay(k) = TKE_loss * TKE_to_Kd_lim * profile_itidal(i,k) * h(i,j,k) + else + Kd_itidal_lay(k) = 0. + endif + ! add to total Kd in layer + if (CS%update_Kd) Kd_lay(i,k) = Kd_lay(i,k) + min(Kd_itidal_lay(k), Kd_max) + enddo + endif + + if (CS%apply_residual_drag) then + call get_lowmode_loss(i, j, G, CS, "SlopeDrag", TKE_loss) + ! insert logic to switch between profiles here + ! if trim(CS%wave_profile) == "StLaurent" then + profile_slope(i,:) = profile_StLaurent_slope(:) + ! elseif trim(CS%Froude_profile) == "N2" then + ! profile_itidal(:) = profile_N2(:) + ! something else + ! endif + do k=1,nz + ! layer diffusivity for processus + if (h(i,j,k) >= CS%min_thick_layer_Kd) then + TKE_to_Kd_lim = min(TKE_to_Kd(i,k), CS%max_TKE_to_Kd) + Kd_slope_lay(k) = TKE_loss * TKE_to_Kd_lim * profile_slope(i,k) * h(i,j,k) + else + Kd_slope_lay(k) = 0. + endif + ! add to total Kd in layer + if (CS%update_Kd) Kd_lay(i,k) = Kd_lay(i,k) + min(Kd_slope_lay(k), Kd_max) + enddo + endif + + if (CS%apply_bottom_drag) then + call get_lowmode_loss(i, j, G, CS, "QuadDrag", TKE_loss) + ! insert logic to switch between profiles here + ! if trim(CS%bottom_profile) == "BBL" then + profile_quad(i,:) = profile_BBL(:) + ! elseif trim(CS%bottom_profile) == "N2" then + ! profile_quad(:) = profile_N2(:) + ! something else + ! endif + do k=1,nz + ! layer diffusivity for processus + if (h(i,j,k) >= CS%min_thick_layer_Kd) then + TKE_to_Kd_lim = min(TKE_to_Kd(i,k), CS%max_TKE_to_Kd) + Kd_quad_lay(k) = TKE_loss * TKE_to_Kd_lim * profile_quad(i,k) * h(i,j,k) + else + Kd_quad_lay(k) = 0. + endif + ! add to total Kd in layer + if (CS%update_Kd) Kd_lay(i,k) = Kd_lay(i,k) + min(Kd_quad_lay(k), Kd_max) + enddo + endif + + ! interpolate Kd_[] to interfaces and add to Kd_int + if (CS%apply_background_drag) then + do k=1,nz+1 + if (k>1) Kd_leak(i,K) = 0.5*Kd_leak_lay(k-1) + if (k1) Kd_itidal(i,K) = 0.5*Kd_itidal_lay(k-1) + if (k1) Kd_Froude(i,K) = 0.5*Kd_Froude_lay(k-1) + if (k1) Kd_slope(i,K) = 0.5*Kd_slope_lay(k-1) + if (k1) Kd_quad(i,K) = 0.5*Kd_quad_lay(k-1) + if (k Implements refraction on the internal waves at a single frequency. subroutine refract(En, cn, freq, dt, G, US, NAngle, use_PPMang) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. @@ -1052,7 +1807,7 @@ subroutine refract(En, cn, freq, dt, G, US, NAngle, use_PPMang) real, dimension(G%isd:G%ied,G%jsd:G%jed,NAngle), & intent(inout) :: En !< The internal gravity wave energy density as a !! function of space and angular resolution, - !! [R Z3 T-2 ~> J m-2]. + !! [H Z2 T-2 ~> m3 s-2 or J m-2]. real, dimension(G%isd:G%ied,G%jsd:G%jed), & intent(in) :: cn !< Baroclinic mode speed [L T-1 ~> m s-1]. real, intent(in) :: freq !< Wave frequency [T-1 ~> s-1]. @@ -1063,13 +1818,14 @@ subroutine refract(En, cn, freq, dt, G, US, NAngle, use_PPMang) ! Local variables integer, parameter :: stencil = 2 real, dimension(SZI_(G),1-stencil:NAngle+stencil) :: & - En2d ! The internal gravity wave energy density in zonal slices [R Z3 T-2 ~> J m-2] + En2d ! The internal gravity wave energy density in zonal slices [H Z2 T-2 ~> m3 s-2 or J m-2] real, dimension(1-stencil:NAngle+stencil) :: & cos_angle, sin_angle ! The cosine and sine of each angle [nondim] real, dimension(SZI_(G)) :: & Dk_Dt_Kmag, Dl_Dt_Kmag ! Rates of angular refraction [T-1 ~> s-1] real, dimension(SZI_(G),0:nAngle) :: & - Flux_E ! The flux of energy between successive angular wedges within a timestep [R Z3 T-2 ~> J m-2] + Flux_E ! The flux of energy between successive angular wedges + ! within a timestep [H Z2 T-2 ~> m3 s-2 or J m-2] real, dimension(SZI_(G),SZJ_(G),1-stencil:NAngle+stencil) :: & CFL_ang ! The CFL number of angular refraction [nondim] real, dimension(G%IsdB:G%IedB,G%jsd:G%jed) :: cn_u !< Internal wave group velocity at U-point [L T-1 ~> m s-1] @@ -1099,15 +1855,15 @@ subroutine refract(En, cn, freq, dt, G, US, NAngle, use_PPMang) do j=js,je ; do I=is-1,ie ! wgt = 0 if local cn == 0, wgt = 0.5 if both contiguous values != 0 ! and wgt = 1 if neighbour cn == 0 - wgt1 = cnmask(i,j) - 0.5 * cnmask(i,j) * cnmask(i+1,j) - wgt2 = cnmask(i+1,j) - 0.5 * cnmask(i,j) * cnmask(i+1,j) - cn_u(I,j) = wgt1*cn(i,j) + wgt2*cn(i+1,j) + wgt1 = cnmask(i,j) - (0.5 * cnmask(i,j) * cnmask(i+1,j)) + wgt2 = cnmask(i+1,j) - (0.5 * cnmask(i,j) * cnmask(i+1,j)) + cn_u(I,j) = (wgt1*cn(i,j)) + (wgt2*cn(i+1,j)) enddo ; enddo do J=js-1,je ; do i=is,ie - wgt1 = cnmask(i,j) - 0.5 * cnmask(i,j) * cnmask(i,j+1) - wgt2 = cnmask(i,j+1) - 0.5 * cnmask(i,j) * cnmask(i,j+1) - cn_v(i,J) = wgt1*cn(i,j) + wgt2*cn(i,j+1) + wgt1 = cnmask(i,j) - (0.5 * cnmask(i,j) * cnmask(i,j+1)) + wgt2 = cnmask(i,j+1) - (0.5 * cnmask(i,j) * cnmask(i,j+1)) + cn_v(i,J) = (wgt1*cn(i,j)) + (wgt2*cn(i,j+1)) enddo ; enddo Ifreq = 1.0 / freq @@ -1138,10 +1894,10 @@ subroutine refract(En, cn, freq, dt, G, US, NAngle, use_PPMang) (G%Coriolis2Bu(I,J-1) + G%Coriolis2Bu(I-1,J))) favg = 0.25*((G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J-1)) + & (G%CoriolisBu(I,J-1) + G%CoriolisBu(I-1,J))) - df_dx = 0.5*((G%CoriolisBu(I,J) + G%CoriolisBu(I,J-1)) - & - (G%CoriolisBu(I-1,J) + G%CoriolisBu(I-1,J-1))) * G%IdxT(i,j) - df_dy = 0.5*((G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J)) - & - (G%CoriolisBu(I,J-1) + G%CoriolisBu(I-1,J-1))) * G%IdyT(i,j) + df_dx = 0.5*G%IdxT(i,j)*((G%CoriolisBu(I,J) - G%CoriolisBu(I-1,J-1)) + & + (G%CoriolisBu(I,J-1) - G%CoriolisBu(I-1,J))) + df_dy = 0.5*G%IdyT(i,j)*((G%CoriolisBu(I,J) - G%CoriolisBu(I-1,J-1)) + & + (G%CoriolisBu(I-1,J) - G%CoriolisBu(I,J-1))) dlnCn_dx = G%IdxT(i,j) * (cn_u(I,j) - cn_u(I-1,j)) / (0.5 * (cn_u(I,j) + cn_u(I-1,j)) + cn_subRO) dlnCn_dy = G%IdyT(i,j) * (cn_v(i,J) - cn_v(i,J-1)) / (0.5 * (cn_v(i,J) + cn_v(i,J-1)) + cn_subRO) @@ -1159,10 +1915,10 @@ subroutine refract(En, cn, freq, dt, G, US, NAngle, use_PPMang) ! Determine the energy fluxes in angular orientation space. do A=asd,aed ; do i=is,ie - CFL_ang(i,j,A) = (cos_angle(A) * Dl_Dt_Kmag(i) - sin_angle(A) * Dk_Dt_Kmag(i)) * dt_Angle_size + CFL_ang(i,j,A) = ((cos_angle(A) * Dl_Dt_Kmag(i)) - (sin_angle(A) * Dk_Dt_Kmag(i))) * dt_Angle_size if (abs(CFL_ang(i,j,A)) > 1.0) then call MOM_error(WARNING, "refract: CFL exceeds 1.", .true.) - if (CFL_ang(i,j,A) > 0.0) then ; CFL_ang(i,j,A) = 1.0 ; else ; CFL_ang(i,j,A) = -1.0 ; endif + if (CFL_ang(i,j,A) > 1.0) then ; CFL_ang(i,j,A) = 1.0 ; else ; CFL_ang(i,j,A) = -1.0 ; endif endif enddo ; enddo @@ -1202,25 +1958,25 @@ subroutine PPM_angular_advect(En2d, CFL_ang, Flux_En, NAngle, dt, halo_ang) integer, intent(in) :: halo_ang !< The halo size in angular space real, dimension(1-halo_ang:NAngle+halo_ang), & intent(in) :: En2d !< The internal gravity wave energy density as a - !! function of angular resolution [R Z3 T-2 ~> J m-2]. + !! function of angular resolution [H Z2 T-2 ~> m3 s-2 or J m-2]. real, dimension(1-halo_ang:NAngle+halo_ang), & intent(in) :: CFL_ang !< The CFL number of the energy advection across angles [nondim] real, dimension(0:NAngle), intent(out) :: Flux_En !< The time integrated internal wave energy flux - !! across angles [R Z3 T-2 ~> J m-2]. + !! across angles [H Z2 T-2 ~> m3 s-2 or J m-2]. ! Local variables - real :: flux ! The internal wave energy flux across angles [R Z3 T-3 ~> W m-2]. + real :: flux ! The internal wave energy flux across angles [H Z2 T-3 ~> m3 s-3 or W m-2]. real :: u_ang ! Angular propagation speed [Rad T-1 ~> Rad s-1] real :: Angle_size ! The size of each orientation wedge in radians [Rad] real :: I_Angle_size ! The inverse of the orientation wedges [Rad-1] real :: I_dt ! The inverse of the timestep [T-1 ~> s-1] - real :: aR, aL ! Left and right edge estimates of energy density [R Z3 T-2 rad-1 ~> J m-2 rad-1] + real :: aR, aL ! Left and right edge estimates of energy density [H Z2 T-2 rad-1 ~> m3 s-2 rad-1 or J m-2 rad-1] real :: Ep, Ec, Em ! Mean angular energy density for three successive wedges in angular - ! orientation [R Z3 T-2 rad-1 ~> J m-2 rad-1] - real :: dA, curv_3 ! Difference and curvature of energy density [R Z3 T-2 rad-1 ~> J m-2 rad-1] + ! orientation [H Z2 T-2 rad-1 ~> m3 s-2 rad-1 or J m-2 rad-1] + real :: dA, curv_3 ! Difference and curvature of energy density [H Z2 T-2 rad-1 ~> m3 s-2 rad-1 or J m-2 rad-1] real, parameter :: oneSixth = 1.0/6.0 ! One sixth [nondim] integer :: a - I_dt = 1 / dt + I_dt = 1.0 / dt Angle_size = (8.0*atan(1.0)) / (real(NAngle)) I_Angle_size = 1 / Angle_size Flux_En(:) = 0 @@ -1230,7 +1986,7 @@ subroutine PPM_angular_advect(En2d, CFL_ang, Flux_En, NAngle, dt, halo_ang) if (u_ang >= 0.0) then ! Implementation of PPM-H3 ! Convert wedge-integrated energy density into angular energy densities for three successive - ! wedges around the source wedge for this flux [R Z3 T-2 rad-1 ~> J m-2 rad-1]. + ! wedges around the source wedge for this flux [H Z2 T-2 rad-1 ~> m3 s-2 rad-1 or 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 @@ -1248,15 +2004,15 @@ subroutine PPM_angular_advect(En2d, CFL_ang, Flux_En, NAngle, dt, halo_ang) aR = 3.*Ec - 2.*aL ! Flatten the profile to move the extremum to the right edge endif curv_3 = (aR + aL) - 2.0*Ec ! Curvature - ! Calculate angular flux rate [R Z3 T-3 ~> W m-2] + ! Calculate angular flux rate [H Z2 T-3 ~> m3 s-3 or 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] + ! Calculate amount of energy fluxed between wedges [H Z2 T-2 ~> m3 s-2 or J m-2] Flux_En(A) = dt * flux !Flux_En(A) = (dt * I_Angle_size) * flux else ! Implementation of PPM-H3 ! Convert wedge-integrated energy density into angular energy densities for three successive - ! wedges around the source wedge for this flux [R Z3 T-2 rad-1 ~> J m-2 rad-1]. + ! wedges around the source wedge for this flux [H Z2 T-2 rad-1 ~> m3 s-2 rad-1 or 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 @@ -1274,10 +2030,10 @@ subroutine PPM_angular_advect(En2d, CFL_ang, Flux_En, NAngle, dt, halo_ang) aR = 3.*Ec - 2.*aL ! Flatten the profile to move the extremum to the right edge endif curv_3 = (aR + aL) - 2.0*Ec ! Curvature - ! Calculate angular flux rate [R Z3 T-3 ~> W m-2] + ! Calculate angular flux rate [H Z2 T-3 ~> m3 s-3 or 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] + ! Calculate amount of energy fluxed between wedges [H Z2 T-2 ~> m3 s-2 or J m-2] Flux_En(A) = dt * flux !Flux_En(A) = (dt * I_Angle_size) * flux endif @@ -1285,23 +2041,24 @@ subroutine PPM_angular_advect(En2d, CFL_ang, Flux_En, NAngle, dt, halo_ang) end subroutine PPM_angular_advect !> Propagates internal waves at a single frequency. -subroutine propagate(En, cn, freq, dt, G, US, CS, NAngle, residual_loss) +subroutine propagate(En, cn, freq, dt, G, GV, US, CS, NAngle, residual_loss) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. integer, intent(in) :: NAngle !< The number of wave orientations in the !! discretized wave energy spectrum. real, dimension(G%isd:G%ied,G%jsd:G%jed,NAngle), & intent(inout) :: En !< The internal gravity wave energy density as a !! function of space and angular resolution, - !! [R Z3 T-2 ~> J m-2]. + !! [H Z2 T-2 ~> m3 s-2 or J m-2]. real, dimension(G%isd:G%ied,G%jsd:G%jed), & intent(in) :: cn !< Baroclinic mode speed [L T-1 ~> m s-1]. real, intent(in) :: freq !< Wave frequency [T-1 ~> s-1]. real, intent(in) :: dt !< Time step [T ~> s]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(int_tide_CS), intent(in) :: CS !< Internal tide control structure + type(int_tide_CS), intent(inout) :: CS !< Internal tide control structure real, dimension(G%isd:G%ied,G%jsd:G%jed,NAngle), & intent(inout) :: residual_loss !< internal tide energy loss due - !! to the residual at slopes [R Z3 T-3 ~> W m-2]. + !! to the residual at slopes [H Z2 T-3 ~> m3 s-3 or W m-2]. ! Local variables real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB) :: & speed ! The magnitude of the group velocity at the q points for corner adv [L T-1 ~> m s-1]. @@ -1326,7 +2083,7 @@ subroutine propagate(En, cn, freq, dt, G, US, CS, NAngle, residual_loss) type(loop_bounds_type) :: LB integer :: is, ie, js, je, asd, aed, na integer :: ish, ieh, jsh, jeh - integer :: i, j, a + integer :: i, j, a, fr, m is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; na = size(En,3) asd = 1-stencil ; aed = NAngle+stencil @@ -1348,6 +2105,13 @@ subroutine propagate(En, cn, freq, dt, G, US, CS, NAngle, residual_loss) Angle_size = (8.0*atan(1.0)) / real(NAngle) I_Angle_size = 1.0 / Angle_size + if (CS%debug) then + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'propagate: top of routine') + if (is_root_pe()) write(stdout,'(A,E18.10)'), 'propagate: top of routine', CS%En_sum + enddo ; enddo + endif + if (CS%corner_adv) then ! IMPLEMENT CORNER ADVECTION IN HORIZONTAL-------------------- ! FIND AVERAGE GROUP VELOCITY (SPEED) AT CELL CORNERS @@ -1359,6 +2123,9 @@ subroutine propagate(En, cn, freq, dt, G, US, CS, NAngle, residual_loss) speed(I,J) = 0.25*((cn(i,j) + cn(i+1,j+1)) + (cn(i+1,j) + cn(i,j+1))) * & sqrt(max(freq2 - f2, 0.0)) * Ifreq enddo ; enddo + + call pass_var(speed, G%Domain) + do a=1,na ! Apply the propagation WITH CORNER ADVECTION/FINITE VOLUME APPROACH. LB%jsh = js ; LB%jeh = je ; LB%ish = is ; LB%ieh = ie @@ -1384,35 +2151,76 @@ subroutine propagate(En, cn, freq, dt, G, US, CS, NAngle, residual_loss) Cgy_av(a)**2) enddo + speed_x(:,:) = 0. do j=jsh,jeh ; do I=ish-1,ieh f2 = 0.5 * (G%Coriolis2Bu(I,J) + G%Coriolis2Bu(I,J-1)) speed_x(I,j) = 0.5*(cn(i,j) + cn(i+1,j)) * G%mask2dCu(I,j) * & sqrt(max(freq2 - f2, 0.0)) * Ifreq enddo ; enddo + + speed_y(:,:) = 0. do J=jsh-1,jeh ; do i=ish,ieh f2 = 0.5 * (G%Coriolis2Bu(I,J) + G%Coriolis2Bu(I-1,J)) speed_y(i,J) = 0.5*(cn(i,j) + cn(i,j+1)) * G%mask2dCv(i,J) * & sqrt(max(freq2 - f2, 0.0)) * Ifreq enddo ; enddo + call pass_vector(speed_x, speed_y, G%Domain, stagger=CGRID_NE) + call pass_var(En, G%domain) + ! Apply propagation in x-direction (reflection included) LB%jsh = jsh ; LB%jeh = jeh ; LB%ish = ish ; LB%ieh = ieh call propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, CS%nAngle, CS, LB, residual_loss) - ! Check for energy conservation on computational domain (for debugging) - !call sum_En(G, US, CS, En, 'post-propagate_x') + ! fix underflows + do a=1,na ; do j=jsh,jeh ; do i=ish,ieh + if (abs(En(i,j,a)) < CS%En_underflow) En(i,j,a) = 0.0 + enddo ; enddo ; enddo + + if (CS%debug) then + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'propagate: after propagate_x') + if (is_root_pe()) write(stdout,'(A,E18.10)'), 'propagate: after propagate_x', CS%En_sum + enddo ; enddo + endif ! Update halos call pass_var(En, G%domain) call pass_var(residual_loss, G%domain) + if (CS%debug) then + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'propagate: after halo update') + if (is_root_pe()) write(stdout,'(A,E18.10)'), 'propagate: after halo update', CS%En_sum + enddo ; enddo + endif ! Apply propagation in y-direction (reflection included) ! LB%jsh = js ; LB%jeh = je ; LB%ish = is ; LB%ieh = ie ! Use if no teleport LB%jsh = jsh ; LB%jeh = jeh ; LB%ish = ish ; LB%ieh = ieh call propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, CS%nAngle, CS, LB, residual_loss) - ! Check for energy conservation on computational domain (for debugging) - !call sum_En(G, US, CS, En, 'post-propagate_y') + ! fix underflows + do a=1,na ; do j=jsh,jeh ; do i=ish,ieh + if (abs(En(i,j,a)) < CS%En_underflow) En(i,j,a) = 0.0 + enddo ; enddo ; enddo + + call pass_var(En, G%domain) + call pass_var(residual_loss, G%domain) + + if (CS%debug) then + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'propagate: after propagate_y') + if (is_root_pe()) write(stdout,'(A,E18.10)'), 'propagate: after propagate_y', CS%En_sum + enddo ; enddo + endif + + endif + + if (CS%debug) then + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'propagate: bottom of routine') + if (is_root_pe()) write(stdout,'(A,E18.10)'), 'propagate: bottom of routine', CS%En_sum + enddo ; enddo endif end subroutine propagate @@ -1424,7 +2232,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]. + !! band [H Z2 T-2 ~> m3 s-2 or 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]. @@ -1462,7 +2270,7 @@ subroutine propagate_corner_spread(En, energized_wedge, NAngle, speed, dt, G, CS real, dimension(G%IsdB:G%IedB,G%Jsd:G%Jed) :: x, y ! coordinates of cell corners [L ~> m] real, dimension(G%IsdB:G%IedB,G%Jsd:G%Jed) :: Idx, Idy ! inverse of dx,dy at cell corners [L-1 ~> m-1] real, dimension(G%IsdB:G%IedB,G%Jsd:G%Jed) :: dx, dy ! dx,dy at cell corners [L ~> m] - real, dimension(2) :: E_new ! Energy in cell after advection for subray [R Z3 T-2 ~> J m-2]; set size + real, dimension(2) :: E_new ! Energy in cell after advection for subray [H Z2 T-2 ~> m3 s-2 or J m-2]; set size ! here to define Nsubrays - this should be made an input option later! ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh @@ -1715,7 +2523,7 @@ subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, Nangle, CS, LB, res !! 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]. + !! band [H Z2 T-2 ~> m3 s-2 or 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]. @@ -1728,17 +2536,17 @@ subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, Nangle, CS, LB, res type(loop_bounds_type), intent(in) :: LB !< A structure with the active energy loop bounds. real, dimension(G%isd:G%ied,G%jsd:G%jed,Nangle), & intent(inout) :: residual_loss !< internal tide energy loss due - !! to the residual at slopes [R Z3 T-3 ~> W m-2]. + !! to the residual at slopes [H Z2 T-3 ~> m3 s-3 or W m-2]. ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & - EnL, EnR ! Left and right face energy densities [R Z3 T-2 ~> J m-2]. + EnL, EnR ! Left and right face energy densities [H Z2 T-2 ~> m3 s-2 or J m-2]. real, dimension(SZIB_(G),SZJ_(G)) :: & - flux_x ! The internal wave energy flux [R Z3 L2 T-3 ~> J s-1]. + flux_x ! The internal wave energy flux [H Z2 L2 T-3 ~> m5 s-3 or J s-1]. real, dimension(SZIB_(G)) :: & cg_p, & ! The x-direction group velocity [L T-1 ~> m s-1] - flux1 ! A 1-d copy of the x-direction internal wave energy flux [R Z3 L2 T-3 ~> J s-1]. + flux1 ! A 1-d copy of the x-direction internal wave energy flux [H Z2 L2 T-3 ~> m5 s-3 or J s-1]. real, dimension(G%isd:G%ied,G%jsd:G%jed,Nangle) :: & - Fdt_m, Fdt_p! Left and right energy fluxes [R Z3 L2 T-2 ~> J] + Fdt_m, Fdt_p! Left and right energy fluxes [H Z2 L2 T-2 ~> m5 s-2 or J] integer :: i, j, ish, ieh, jsh, jeh, a ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh @@ -1763,12 +2571,15 @@ subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, Nangle, CS, LB, res enddo do j=jsh,jeh ; do i=ish,ieh - Fdt_m(i,j,a) = dt*flux_x(I-1,j) ! left face influx [R Z3 L2 T-2 ~> J] - Fdt_p(i,j,a) = -dt*flux_x(I,j) ! right face influx [R Z3 L2 T-2 ~> J] - - residual_loss(i,j,a) = residual_loss(i,j,a) + & - ((abs(flux_x(I-1,j)) * CS%residual(i,j) * G%IareaT(i,j)) + & - (abs(flux_x(I,j)) * CS%residual(i,j) * G%IareaT(i,j))) + Fdt_m(i,j,a) = dt*flux_x(I-1,j) ! left face influx [H Z2 L2 T-2 ~> m5 s-2 or J] + Fdt_p(i,j,a) = -dt*flux_x(I,j) ! right face influx [H Z2 L2 T-2 ~> m5 s-2 or J] + + ! only compute residual loss on partial reflection cells, remove numerical noise elsewhere + if (CS%refl_pref_logical(i,j)) then + residual_loss(i,j,a) = residual_loss(i,j,a) + & + ((abs(flux_x(I-1,j)) * CS%residual(i,j) * G%IareaT(i,j)) + & + (abs(flux_x(I,j)) * CS%residual(i,j) * G%IareaT(i,j))) + endif enddo ; enddo enddo ! a-loop @@ -1780,11 +2591,9 @@ subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, Nangle, CS, LB, res call reflect(Fdt_p, Nangle, CS, G, LB) !call teleport(Fdt_p, Nangle, CS, G, LB) - ! Update reflected energy [R Z3 T-2 ~> J m-2] + ! Update reflected energy [H Z2 T-2 ~> m3 s-2 or J m-2] do a=1,Nangle ; do j=jsh,jeh ; do i=ish,ieh - ! if ((En(i,j,a) + G%IareaT(i,j)*(Fdt_m(i,j,a) + Fdt_p(i,j,a))) < 0.0) & ! for debugging - ! call MOM_error(FATAL, "propagate_x: OutFlux>Available") - En(i,j,a) = En(i,j,a) + G%IareaT(i,j)*(Fdt_m(i,j,a) + Fdt_p(i,j,a)) + 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 @@ -1796,7 +2605,7 @@ subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, Nangle, CS, LB, res !! 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]. + !! band [H Z2 T-2 ~> m3 s-2 or 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]. @@ -1809,17 +2618,17 @@ subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, Nangle, CS, LB, res type(loop_bounds_type), intent(in) :: LB !< A structure with the active energy loop bounds. real, dimension(G%isd:G%ied,G%jsd:G%jed,Nangle), & intent(inout) :: residual_loss !< internal tide energy loss due - !! to the residual at slopes [R Z3 T-3 ~> W m-2]. + !! to the residual at slopes [H Z2 T-3 ~> m3 s-3 or W m-2]. ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & - EnL, EnR ! South and north face energy densities [R Z3 T-2 ~> J m-2]. + EnL, EnR ! South and north face energy densities [H Z2 T-2 ~> m3 s-2 or J m-2]. real, dimension(SZI_(G),SZJB_(G)) :: & - flux_y ! The internal wave energy flux [R Z3 L2 T-3 ~> J s-1]. + flux_y ! The internal wave energy flux [H Z2 L2 T-3 ~> m5 s-3 or J s-1]. real, dimension(SZI_(G)) :: & cg_p, & ! The y-direction group velocity [L T-1 ~> m s-1] - flux1 ! A 1-d copy of the y-direction internal wave energy flux [R Z3 L2 T-3 ~> J s-1]. + flux1 ! A 1-d copy of the y-direction internal wave energy flux [H Z2 L2 T-3 ~> m5 s-3 or J s-1]. real, dimension(G%isd:G%ied,G%jsd:G%jed,Nangle) :: & - Fdt_m, Fdt_p! South and north energy fluxes [R Z3 L2 T-2 ~> J] + Fdt_m, Fdt_p! South and north energy fluxes [H Z2 L2 T-2 ~> m5 s-2 or J] integer :: i, j, ish, ieh, jsh, jeh, a ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh @@ -1844,19 +2653,15 @@ subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, Nangle, CS, LB, res enddo do j=jsh,jeh ; do i=ish,ieh - Fdt_m(i,j,a) = dt*flux_y(i,J-1) ! south face influx [R Z3 L2 T-2 ~> J] - Fdt_p(i,j,a) = -dt*flux_y(i,J) ! north face influx [R Z3 L2 T-2 ~> J] - - residual_loss(i,j,a) = residual_loss(i,j,a) + & - ((abs(flux_y(i,J-1)) * CS%residual(i,j) * G%IareaT(i,j)) + & - (abs(flux_y(i,J)) * CS%residual(i,j) * G%IareaT(i,j))) - - !if ((En(i,j,a) + G%IareaT(i,j)*(Fdt_m(i,j,a) + Fdt_p(i,j,a))) < 0.0) then ! for debugging - ! call MOM_error(WARNING, "propagate_y: OutFlux>Available prior to reflection", .true.) - ! write(mesg,*) "flux_y_south=",flux_y(i,J-1),"flux_y_north=",flux_y(i,J),"En=",En(i,j,a), & - ! "cn_south=", speed_y(i,J-1) * (Cgy_av(a)), "cn_north=", speed_y(i,J) * (Cgy_av(a)) - ! call MOM_error(WARNING, mesg, .true.) - !endif + Fdt_m(i,j,a) = dt*flux_y(i,J-1) ! south face influx [H Z2 L2 T-2 ~> m5 s-2 or J] + Fdt_p(i,j,a) = -dt*flux_y(i,J) ! north face influx [H Z2 L2 T-2 ~> m5 s-2 or J] + + ! only compute residual loss on partial reflection cells, remove numerical noise elsewhere + if (CS%refl_pref_logical(i,j)) then + residual_loss(i,j,a) = residual_loss(i,j,a) + & + ((abs(flux_y(i,J-1)) * CS%residual(i,j) * G%IareaT(i,j)) + & + (abs(flux_y(i,J)) * CS%residual(i,j) * G%IareaT(i,j))) + endif enddo ; enddo enddo ! a-loop @@ -1868,10 +2673,8 @@ subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, Nangle, CS, LB, res call reflect(Fdt_p, Nangle, CS, G, LB) !call teleport(Fdt_p, Nangle, CS, G, LB) - ! Update reflected energy [R Z3 T-2 ~> J m-2] + ! Update reflected energy [H Z2 T-2 ~> m3 s-2 or J m-2] do a=1,Nangle ; do j=jsh,jeh ; do i=ish,ieh - ! if ((En(i,j,a) + G%IareaT(i,j)*(Fdt_m(i,j,a) + Fdt_p(i,j,a))) < 0.0) & ! for debugging - ! call MOM_error(FATAL, "propagate_y: OutFlux>Available", .true.) En(i,j,a) = En(i,j,a) + G%IareaT(i,j)*(Fdt_m(i,j,a) + Fdt_p(i,j,a)) enddo ; enddo ; enddo @@ -1882,12 +2685,12 @@ subroutine zonal_flux_En(u, h, hL, hR, uh, dt, G, US, j, ish, ieh, vol_CFL) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. real, dimension(SZIB_(G)), intent(in) :: u !< The zonal velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G)), intent(in) :: h !< Energy density used to calculate the fluxes - !! [R Z3 T-2 ~> J m-2]. + !! [H Z2 T-2 ~> m3 s-2 or J m-2]. real, dimension(SZI_(G)), intent(in) :: hL !< Left- Energy densities in the reconstruction - !! [R Z3 T-2 ~> J m-2]. + !! [H Z2 T-2 ~> m3 s-2 or J m-2]. real, dimension(SZI_(G)), intent(in) :: hR !< Right- Energy densities in the reconstruction - !! [R Z3 T-2 ~> J m-2]. - real, dimension(SZIB_(G)), intent(inout) :: uh !< The zonal energy transport [R Z3 L2 T-3 ~> J s-1]. + !! [H Z2 T-2 ~> m3 s-2 or J m-2]. + real, dimension(SZIB_(G)), intent(out) :: uh !< The zonal energy transport [H Z2 L2 T-3 ~> m5 s-3 or J s-1]. real, intent(in) :: dt !< Time increment [T ~> s]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type integer, intent(in) :: j !< The j-index to work on. @@ -1897,7 +2700,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 energy density curvature over a grid length [R Z3 T-2 ~> J m-2] + real :: curv_3 ! A measure of the energy density curvature over a grid length [H Z2 T-2 ~> m3 s-2 or J m-2] integer :: i do I=ish-1,ieh @@ -1925,12 +2728,13 @@ subroutine merid_flux_En(v, h, hL, hR, vh, dt, G, US, J, ish, ieh, vol_CFL) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. real, dimension(SZI_(G)), intent(in) :: v !< The meridional velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h !< Energy density used to calculate the - !! fluxes [R Z3 T-2 ~> J m-2]. + !! fluxes [H Z2 T-2 ~> m3 s-2 or J m-2]. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: hL !< Left- Energy densities in the - !! reconstruction [R Z3 T-2 ~> J m-2]. + !! reconstruction [H Z2 T-2 ~> m3 s-2 or J m-2]. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: hR !< Right- Energy densities in the - !! reconstruction [R Z3 T-2 ~> J m-2]. - real, dimension(SZI_(G)), intent(inout) :: vh !< The meridional energy transport [R Z3 L2 T-3 ~> J s-1]. + !! reconstruction [H Z2 T-2 ~> m3 s-2 or J m-2]. + real, dimension(SZI_(G)), intent(out) :: vh !< The meridional energy transport + !! [H Z2 L2 T-3 ~> m5 s-3 or J s-1]. real, intent(in) :: dt !< Time increment [T ~> s]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type integer, intent(in) :: J !< The j-index to work on. @@ -1941,7 +2745,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 energy density curvature over a grid length [R Z3 T-2 ~> J m-2] + real :: curv_3 ! A measure of the energy density curvature over a grid length [H Z2 T-2 ~> m3 s-2 or J m-2] integer :: i do i=ish,ieh @@ -1971,7 +2775,7 @@ subroutine reflect(En, NAngle, CS, G, LB) real, dimension(G%isd:G%ied,G%jsd:G%jed,NAngle), & intent(inout) :: En !< The internal gravity wave energy density as a !! function of space and angular resolution - !! [R Z3 T-2 ~> J m-2]. + !! [H Z2 T-2 ~> m3 s-2 or J m-2]. type(int_tide_CS), intent(in) :: CS !< Internal tide control structure type(loop_bounds_type), intent(in) :: LB !< A structure with the active energy loop bounds. @@ -1983,7 +2787,7 @@ subroutine reflect(En, NAngle, CS, G, LB) ! values should collocate with angle_c [nondim] logical, dimension(G%isd:G%ied,G%jsd:G%jed) :: ridge ! tags of cells with double reflection - real, dimension(1:Nangle) :: En_reflected ! Energy reflected [R Z3 T-2 ~> J m-2]. + real, dimension(1:Nangle) :: En_reflected ! Energy reflected [H Z2 T-2 ~> m3 s-2 or J m-2]. real :: TwoPi ! 2*pi = 6.2831853... [nondim] real :: Angle_size ! size of beam wedge [rad] @@ -2078,7 +2882,7 @@ subroutine teleport(En, NAngle, CS, G, LB) real, dimension(G%isd:G%ied,G%jsd:G%jed,NAngle), & intent(inout) :: En !< The internal gravity wave energy density as a !! function of space and angular resolution - !! [R Z3 T-2 ~> J m-2]. + !! [H Z2 T-2 ~> m3 s-2 or J m-2]. type(int_tide_CS), intent(in) :: CS !< Internal tide control structure type(loop_bounds_type), intent(in) :: LB !< A structure with the active energy loop bounds. ! Local variables @@ -2096,7 +2900,7 @@ subroutine teleport(En, NAngle, CS, G, LB) real, dimension(1:NAngle) :: angle_i ! angle of incident ray wrt equator [rad] real, dimension(1:NAngle) :: cos_angle ! Cosine of the beam angle relative to eastward [nondim] real, dimension(1:NAngle) :: sin_angle ! Sine of the beam angle relative to eastward [nondim] - real :: En_tele ! energy to be "teleported" [R Z3 T-2 ~> J m-2] + real :: En_tele ! energy to be "teleported" [H Z2 T-2 ~> m3 s-2 or J m-2] character(len=160) :: mesg ! The text of an error message integer :: i, j, a integer :: ish, ieh, jsh, jeh ! start and end local indices on data domain @@ -2171,7 +2975,7 @@ subroutine correct_halo_rotation(En, test, G, NAngle, halo) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure real, dimension(:,:,:,:,:), intent(inout) :: En !< The internal gravity wave energy density as a !! function of space, angular orientation, frequency, - !! and vertical mode [R Z3 T-2 ~> J m-2]. + !! and vertical mode [H Z2 T-2 ~> m3 s-2 or J m-2]. real, dimension(SZI_(G),SZJ_(G),2), & intent(in) :: test !< An x-unit vector that has been passed through !! the halo updates, to enable the rotation of the @@ -2181,7 +2985,7 @@ subroutine correct_halo_rotation(En, test, G, NAngle, halo) integer, intent(in) :: halo !< The halo size over which to do the calculations ! Local variables real, dimension(G%isd:G%ied,NAngle) :: En2d ! A zonal row of the internal gravity wave energy density - ! in a frequency band and mode [R Z3 T-2 ~> J m-2]. + ! in a frequency band and mode [H Z2 T-2 ~> m3 s-2 or J m-2]. integer, dimension(G%isd:G%ied) :: a_shift integer :: i_first, i_last, a_new integer :: a, i, j, ish, ieh, jsh, jeh, m, fr @@ -2228,19 +3032,23 @@ end subroutine correct_halo_rotation !> Calculates left/right edge values for PPM reconstruction in x-direction. subroutine PPM_reconstruction_x(h_in, h_l, h_r, G, LB, simple_2nd) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Energy density in a sector (2D) [R Z3 T-2 ~> J m-2] - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_l !< Left edge value of reconstruction (2D) [R Z3 T-2 ~> J m-2] - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_r !< Right edge value of reconstruction (2D) [R Z3 T-2 ~> J m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Energy density in a sector (2D) + !! [H Z2 T-2 ~> m3 s-2 or J m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_l !< Left edge value of reconstruction (2D) + !! [H Z2 T-2 ~> m3 s-2 or J m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_r !< Right edge value of reconstruction (2D) + !! [H Z2 T-2 ~> m3 s-2 or J m-2] type(loop_bounds_type), intent(in) :: LB !< A structure with the active loop bounds. logical, intent(in) :: simple_2nd !< If true, use the arithmetic mean !! energy densities as default edge values !! for a simple 2nd order scheme. ! Local variables - real, dimension(SZI_(G),SZJ_(G)) :: slp ! The slope in energy density times the cell width [R Z3 T-2 ~> J m-2] + real, dimension(SZI_(G),SZJ_(G)) :: slp ! The slope in energy density times the cell width + ! [H Z2 T-2 ~> m3 s-2 or J m-2] real, parameter :: oneSixth = 1./6. ! One sixth [nondim] - real :: h_ip1, h_im1 ! The energy densities at adjacent points [R Z3 T-2 ~> J m-2] + real :: h_ip1, h_im1 ! The energy densities at adjacent points [H Z2 T-2 ~> m3 s-2 or J m-2] real :: dMx, dMn ! The maximum and minimum of values of energy density at adjacent points - ! relative to the center point [R Z3 T-2 ~> J m-2] + ! relative to the center point [H Z2 T-2 ~> m3 s-2 or J m-2] character(len=256) :: mesg ! The text of an error message integer :: i, j, isl, iel, jsl, jel, stencil @@ -2303,19 +3111,23 @@ end subroutine PPM_reconstruction_x !> Calculates left/right edge valus for PPM reconstruction in y-direction. subroutine PPM_reconstruction_y(h_in, h_l, h_r, G, LB, simple_2nd) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Energy density in a sector (2D) [R Z3 T-2 ~> J m-2] - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_l !< Left edge value of reconstruction (2D) [R Z3 T-2 ~> J m-2] - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_r !< Right edge value of reconstruction (2D) [R Z3 T-2 ~> J m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Energy density in a sector (2D) + !! [H Z2 T-2 ~> m3 s-2 or J m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_l !< Left edge value of reconstruction (2D) + !! [H Z2 T-2 ~> m3 s-2 or J m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_r !< Right edge value of reconstruction (2D) + !! [H Z2 T-2 ~> m3 s-2 or J m-2] type(loop_bounds_type), intent(in) :: LB !< A structure with the active loop bounds. logical, intent(in) :: simple_2nd !< If true, use the arithmetic mean !! energy densities as default edge values !! for a simple 2nd order scheme. ! Local variables - real, dimension(SZI_(G),SZJ_(G)) :: slp ! The slope in energy density times the cell width [R Z3 T-2 ~> J m-2] + real, dimension(SZI_(G),SZJ_(G)) :: slp ! The slope in energy density times the cell width + ! [H Z2 T-2 ~> m3 s-2 or J m-2] real, parameter :: oneSixth = 1./6. ! One sixth [nondim] - real :: h_jp1, h_jm1 ! The energy densities at adjacent points [R Z3 T-2 ~> J m-2] + real :: h_jp1, h_jm1 ! The energy densities at adjacent points [H Z2 T-2 ~> m3 s-2 or J m-2] real :: dMx, dMn ! The maximum and minimum of values of energy density at adjacent points - ! relative to the center point [R Z3 T-2 ~> J m-2] + ! relative to the center point [H Z2 T-2 ~> m3 s-2 or J m-2] character(len=256) :: mesg ! The text of an error message integer :: i, j, isl, iel, jsl, jel, stencil @@ -2379,18 +3191,22 @@ end subroutine PPM_reconstruction_y !! than h_min, with a minimum of h_min otherwise. subroutine PPM_limit_pos(h_in, h_L, h_R, h_min, G, iis, iie, jis, jie) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Energy density in each sector (2D) [R Z3 T-2 ~> J m-2] - real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: h_L !< Left edge value of reconstruction [R Z3 T-2 ~> J m-2] - real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: h_R !< Right edge value of reconstruction [R Z3 T-2 ~> J m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Energy density in each sector (2D) + !! [H Z2 T-2 ~> m3 s-2 or J m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: h_L !< Left edge value of reconstruction + !! [H Z2 T-2 ~> m3 s-2 or J m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: h_R !< Right edge value of reconstruction + !! [H Z2 T-2 ~> m3 s-2 or J m-2] real, intent(in) :: h_min !< The minimum value that can be - !! obtained by a concave parabolic fit [R Z3 T-2 ~> J m-2] + !! obtained by a concave parabolic fit + !! [H Z2 T-2 ~> m3 s-2 or J m-2] integer, intent(in) :: iis !< Start i-index for computations integer, intent(in) :: iie !< End i-index for computations integer, intent(in) :: jis !< Start j-index for computations integer, intent(in) :: jie !< End j-index for computations ! Local variables - real :: curv ! The cell-area normalized curvature [R Z3 T-2 ~> J m-2] - real :: dh ! The difference between the edge values [R Z3 T-2 ~> J m-2] + real :: curv ! The cell-area normalized curvature [H Z2 T-2 ~> m3 s-2 or J m-2] + real :: dh ! The difference between the edge values [H Z2 T-2 ~> m3 s-2 or J m-2] real :: scale ! A rescaling factor used to give a minimum cell value of at least h_min [nondim] integer :: i, j @@ -2415,8 +3231,9 @@ subroutine PPM_limit_pos(h_in, h_L, h_R, h_min, G, iis, iie, jis, jie) enddo ; enddo end subroutine PPM_limit_pos -subroutine register_int_tide_restarts(G, US, param_file, CS, restart_CS) +subroutine register_int_tide_restarts(G, GV, US, param_file, CS, restart_CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type),intent(in):: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters type(int_tide_CS), pointer :: CS !< Internal tide control structure @@ -2424,16 +3241,22 @@ subroutine register_int_tide_restarts(G, US, param_file, CS, restart_CS) ! This subroutine is used to allocate and register any fields in this module ! that should be written to or read from the restart file. + logical :: non_Bous ! If true, this run is fully non-Boussinesq + logical :: Boussinesq ! If true, this run is fully Boussinesq + logical :: semi_Boussinesq ! If true, this run is partially non-Boussinesq logical :: use_int_tides integer :: num_freq, num_angle , num_mode, period_1 integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, i, j, a, fr - character(64) :: var_name, cfr + character(64) :: var_name, cfr, units type(axis_info) :: axes_inttides(2) real, dimension(:), allocatable :: angles, freqs ! Lables for angles and frequencies [nondim] + real :: HZ2_T2_to_J_m2 ! unit conversion factor for Energy from internal to mks [H Z2 T-2 ~> m3 s-2 or J m-2] isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + HZ2_T2_to_J_m2 = GV%H_to_MKS*(US%Z_to_m**2)*(US%s_to_T**2) + if (associated(CS)) then call MOM_error(WARNING, "register_int_tide_restarts called "//& "with an associated control structure.") @@ -2447,6 +3270,19 @@ subroutine register_int_tide_restarts(G, US, param_file, CS, restart_CS) call get_param(param_file, "MOM", "INTERNAL_TIDE_FREQS", num_freq, default=1) call get_param(param_file, "MOM", "INTERNAL_TIDE_MODES", num_mode, default=1) + ! define restart units depemding on Boussinesq + call get_param(param_file, "MOM", "BOUSSINESQ", Boussinesq, & + "If true, make the Boussinesq approximation.", default=.true., do_not_log=.true.) + call get_param(param_file, "MOM", "SEMI_BOUSSINESQ", semi_Boussinesq, & + "If true, do non-Boussinesq pressure force calculations and use mass-based "//& + "thicknesses, but use RHO_0 to convert layer thicknesses into certain "//& + "height changes. This only applies if BOUSSINESQ is false.", & + default=.true., do_not_log=.true.) + non_Bous = .not.(Boussinesq .or. semi_Boussinesq) + + units="J m-2" + if (non_Bous) units="m3 s-2" + allocate (angles(num_angle)) allocate (freqs(num_freq)) @@ -2473,7 +3309,7 @@ subroutine register_int_tide_restarts(G, US, param_file, CS, restart_CS) ! register all 4d restarts and copy into full Energy array when restarting from previous state call register_restart_field(CS%En_restart_mode1(:,:,:,:), "IW_energy_mode1", .false., restart_CS, & longname="The internal wave energy density f(i,j,angle,freq) for mode 1", & - units="J m-2", conversion=US%RZ3_T3_to_W_m2*US%T_to_s, z_grid='1', t_grid="s", & + units=units, conversion=HZ2_T2_to_J_m2, z_grid='1', t_grid="s", & extra_axes=axes_inttides) do fr=1,num_freq ; do a=1,num_angle ; do j=jsd,jed ; do i=isd,ied @@ -2483,7 +3319,7 @@ subroutine register_int_tide_restarts(G, US, param_file, CS, restart_CS) if (num_mode >= 2) then call register_restart_field(CS%En_restart_mode2(:,:,:,:), "IW_energy_mode2", .false., restart_CS, & longname="The internal wave energy density f(i,j,angle,freq) for mode 2", & - units="J m-2", conversion=US%RZ3_T3_to_W_m2*US%T_to_s, z_grid='1', t_grid="s", & + units=units, conversion=HZ2_T2_to_J_m2, z_grid='1', t_grid="s", & extra_axes=axes_inttides) do fr=1,num_freq ; do a=1,num_angle ; do j=jsd,jed ; do i=isd,ied @@ -2495,7 +3331,7 @@ subroutine register_int_tide_restarts(G, US, param_file, CS, restart_CS) if (num_mode >= 3) then call register_restart_field(CS%En_restart_mode3(:,:,:,:), "IW_energy_mode3", .false., restart_CS, & longname="The internal wave energy density f(i,j,angle,freq) for mode 3", & - units="J m-2", conversion=US%RZ3_T3_to_W_m2*US%T_to_s, z_grid='1', t_grid="s", & + units=units, conversion=HZ2_T2_to_J_m2, z_grid='1', t_grid="s", & extra_axes=axes_inttides) do fr=1,num_freq ; do a=1,num_angle ; do j=jsd,jed ; do i=isd,ied @@ -2507,7 +3343,7 @@ subroutine register_int_tide_restarts(G, US, param_file, CS, restart_CS) if (num_mode >= 4) then call register_restart_field(CS%En_restart_mode4(:,:,:,:), "IW_energy_mode4", .false., restart_CS, & longname="The internal wave energy density f(i,j,angle,freq) for mode 4", & - units="J m-2", conversion=US%RZ3_T3_to_W_m2*US%T_to_s, z_grid='1', t_grid="s", & + units=units, conversion=HZ2_T2_to_J_m2, z_grid='1', t_grid="s", & extra_axes=axes_inttides) do fr=1,num_freq ; do a=1,num_angle ; do j=jsd,jed ; do i=isd,ied @@ -2519,7 +3355,7 @@ subroutine register_int_tide_restarts(G, US, param_file, CS, restart_CS) if (num_mode >= 5) then call register_restart_field(CS%En_restart_mode5(:,:,:,:), "IW_energy_mode5", .false., restart_CS, & longname="The internal wave energy density f(i,j,angle,freq) for mode 5", & - units="J m-2", conversion=US%RZ3_T3_to_W_m2*US%T_to_s, z_grid='1', t_grid="s", & + units=units, conversion=HZ2_T2_to_J_m2, z_grid='1', t_grid="s", & extra_axes=axes_inttides) do fr=1,num_freq ; do a=1,num_angle ; do j=jsd,jed ; do i=isd,ied @@ -2533,7 +3369,7 @@ end subroutine register_int_tide_restarts !> This subroutine initializes the internal tides module. subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) type(time_type), target, intent(in) :: Time !< The current model time. - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time @@ -2558,6 +3394,10 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) ! nominal ocean depth, or a negative value for no limit [nondim] real :: period_1 ! The period of the gravest modeled mode [T ~> s] real :: period ! A tidal period read from namelist [T ~> s] + real :: HZ2_T2_to_J_m2 ! unit conversion factor for Energy from internal to mks [H Z2 T-2 ~> m3 s-2 or J m-2] + real :: HZ2_T3_to_W_m2 ! unit conversion factor for TKE from internal to mks [H Z2 T-3 ~> m3 s-3 or W m-2] + real :: W_m2_to_HZ2_T3 ! unit conversion factor for TKE from mks to internal [m3 s-3 or W m-2 ~> H Z2 T-3] + real :: J_m2_to_HZ2_T2 ! unit conversion factor for Energy from mks to internal [m3 s-2 or J m-2 ~> H Z2 T-2] integer :: num_angle, num_freq, num_mode, m, fr integer :: isd, ied, jsd, jed, a, id_ang, i, j, nz type(axes_grp) :: axes_ang @@ -2579,6 +3419,11 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed nz = GV%ke + HZ2_T2_to_J_m2 = GV%H_to_kg_m2*(US%Z_to_m**2)*(US%s_to_T**2) + HZ2_T3_to_W_m2 = GV%H_to_kg_m2*(US%Z_to_m**2)*(US%s_to_T**3) + W_m2_to_HZ2_T3 = GV%kg_m2_to_H*(US%m_to_Z**2)*(US%T_to_s**3) + J_m2_to_HZ2_T2 = GV%kg_m2_to_H*(US%m_to_Z**2)*(US%T_to_s**2) + CS%initialized = .true. use_int_tides = .false. @@ -2615,11 +3460,15 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) allocate(CS%frequency(num_freq)) + call get_param(param_file, mdl, "DEBUG", CS%debug, & + "If true, write out verbose debugging data.", & + default=.false., debuggingParam=.true.) + ! The periods of the tidal constituents for internal tides raytracing call read_param(param_file, "TIDAL_PERIODS", periods) do fr=1,num_freq - period = extract_real(periods, " ,", fr, 0.) + period = US%s_to_T*extract_real(periods, " ,", fr, 0.) if (period == 0.) call MOM_error(FATAL, "MOM_internal_tides: invalid tidal period") CS%frequency(fr) = 8.0*atan(1.0)/period enddo @@ -2669,6 +3518,30 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) CS%diag => diag + call get_param(param_file, mdl, "INTERNAL_TIDES_UPDATE_KD", CS%update_Kd, & + "If true, internal tides ray tracing changes Kd for dynamics.", & + default=.false.) + call get_param(param_file, mdl, "INTERNAL_TIDES_REFRACTION", CS%apply_refraction, & + "If true, internal tides ray tracing does refraction.", & + default=.true.) + call get_param(param_file, mdl, "INTERNAL_TIDES_PROPAGATION", CS%apply_propagation, & + "If true, internal tides ray tracing does propagate.", & + default=.true.) + call get_param(param_file, mdl, "INTERNAL_TIDES_ONLY_INIT_FORCING", CS%init_forcing_only, & + "If true, internal tides ray tracing only applies forcing at first step (debugging).", & + default=.false.) + call get_param(param_file, mdl, "INTERNAL_TIDES_FORCE_POS_EN", CS%force_posit_En, & + "If true, force energy to be positive by removing subroundoff negative values.", & + default=.true.) + call get_param(param_file, mdl, "KD_MIN", CS%Kd_min, & + "The minimum diapycnal diffusivity.", & + units="m2 s-1", default=2e-6, scale=GV%m2_s_to_HZ_T) + call get_param(param_file, mdl, "MINTHICK_TKE_TO_KD", CS%min_thick_layer_Kd, & + "The minimum thickness allowed with TKE_to_Kd.", & + units="m", default=1e-6, scale=GV%m_to_H) + call get_param(param_file, mdl, "MAX_TKE_TO_KD", CS%max_TKE_to_Kd, & + "Limiter for TKE_to_Kd.", & + units="", default=1e9, scale=US%Z_to_m*US%s_to_T**2) call get_param(param_file, mdl, "INTERNAL_TIDE_DECAY_RATE", CS%decay_rate, & "The rate at which internal tide energy is lost to the "//& "interior ocean internal wave field.", & @@ -2703,7 +3576,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) "If true, apply scattering due to small-scale roughness as a sink.", & default=.false.) call get_param(param_file, mdl, "INTERNAL_TIDE_RESIDUAL_DRAG", CS%apply_residual_drag, & - "If true, TBD", & + "If true, apply drag due to critical slopes", & default=.false.) call get_param(param_file, mdl, "INTERNAL_TIDE_DRAG_MIN_DEPTH", CS%drag_min_depth, & "The minimum total ocean thickness that will be used in the denominator "//& @@ -2714,10 +3587,16 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) "If true, apply wave breaking as a sink.", & default=.false.) call get_param(param_file, mdl, "EN_CHECK_TOLERANCE", CS%En_check_tol, & - "An energy density tolerance for flagging points with an imbalance in the "//& - "internal tide energy budget when INTERNAL_TIDE_FROUDE_DRAG is True.", & - units="J m-2", default=1.0e-10, scale=US%W_m2_to_RZ3_T3*US%s_to_T, & + "An energy density tolerance for flagging points with small negative "//& + "internal tide energy.", & + units="J m-2", default=1.0, scale=J_m2_to_HZ2_T2, & do_not_log=.not.CS%apply_Froude_drag) + call get_param(param_file, mdl, "EN_UNDERFLOW", CS%En_underflow, & + "A small energy density below which Energy is set to zero.", & + units="J m-2", default=1.0e-100, scale=J_m2_to_HZ2_T2) + call get_param(param_file, mdl, "EN_RESTART_POWER", CS%En_restart_power, & + "A power factor to save larger values x 2**(power) in restart files.", & + units="nondim", default=0) call get_param(param_file, mdl, "CDRAG", CS%cdrag, & "CDRAG is the drag coefficient relating the magnitude of "//& "the velocity field to the bottom stress.", & @@ -2731,7 +3610,6 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) "If true, use the OM4 remapping-via-subcells algorithm for calculating EBT structure. "//& "See REMAPPING_USE_OM4_SUBCELLS for details. "//& "We recommend setting this option to false.", default=.true.) - call get_param(param_file, mdl, "UNIFORM_TEST_CG", CS%uniform_test_cg, & "If positive, a uniform group velocity of internal tide for test case", & default=-1., units="m s-1", scale=US%m_s_to_L_T) @@ -2753,6 +3631,17 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "KAPPA_H2_FACTOR", kappa_h2_factor, & "A scaling factor for the roughness amplitude with "//& "INT_TIDE_DISSIPATION.", units="nondim", default=1.0) + call get_param(param_file, mdl, "GAMMA_OSBORN", CS%gamma_osborn, & + "The mixing efficiency for internan tides from Osborn 1980 ", & + units="nondim", default=0.2) + call get_param(param_file, mdl, "INT_TIDE_DECAY_SCALE", CS%Int_tide_decay_scale, & + "The decay scale away from the bottom for tidal TKE with "//& + "the new coding when INT_TIDE_DISSIPATION is used.", & + units="m", default=500.0, scale=GV%m_to_H) + call get_param(param_file, mdl, "INT_TIDE_DECAY_SCALE_SLOPES", CS%Int_tide_decay_scale_slope, & + "The slope decay scale away from the bottom for tidal TKE with "//& + "the new coding when INT_TIDE_DISSIPATION is used.", & + units="m", default=100.0, scale=GV%m_to_H) ! Allocate various arrays needed for loss rates allocate(h2(isd:ied,jsd:jed), source=0.0) @@ -2762,6 +3651,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) allocate(CS%TKE_itidal_loss(isd:ied,jsd:jed,num_angle,num_freq,num_mode), source=0.0) allocate(CS%TKE_Froude_loss(isd:ied,jsd:jed,num_angle,num_freq,num_mode), source=0.0) allocate(CS%TKE_residual_loss(isd:ied,jsd:jed,num_angle,num_freq,num_mode), source=0.0) + allocate(CS%TKE_slope_loss(isd:ied,jsd:jed,num_angle,num_freq,num_mode), source=0.0) allocate(CS%tot_leak_loss(isd:ied,jsd:jed), source=0.0) allocate(CS%tot_quad_loss(isd:ied,jsd:jed), source=0.0) allocate(CS%tot_itidal_loss(isd:ied,jsd:jed), source=0.0) @@ -2774,6 +3664,15 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) allocate(CS%int_N2w2(isd:ied,jsd:jed,num_mode), source=0.0) allocate(CS%w_struct(isd:ied,jsd:jed,1:nz+1,num_mode), source=0.0) allocate(CS%u_struct(isd:ied,jsd:jed,1:nz,num_mode), source=0.0) + allocate(CS%error_mode(num_freq,num_mode), source=0.0) + allocate(CS%En_ini_glo(num_freq,num_mode), source=0.0) + allocate(CS%En_end_glo(num_freq,num_mode), source=0.0) + allocate(CS%TKE_leak_loss_glo_dt(num_freq,num_mode), source=0.0) + allocate(CS%TKE_quad_loss_glo_dt(num_freq,num_mode), source=0.0) + allocate(CS%TKE_Froude_loss_glo_dt(num_freq,num_mode), source=0.0) + allocate(CS%TKE_itidal_loss_glo_dt(num_freq,num_mode), source=0.0) + allocate(CS%TKE_residual_loss_glo_dt(num_freq,num_mode), source=0.0) + allocate(CS%TKE_input_glo_dt(num_freq,num_mode), source=0.0) ! Compute the fixed part of the bottom drag loss from baroclinic modes call get_param(param_file, mdl, "H2_FILE", h2_file, & @@ -2799,7 +3698,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) endif ! Compute the fixed part; units are [R Z4 H-1 L-2 ~> kg m-2 or m] here ! will be multiplied by N and the squared near-bottom velocity (and by the - ! near-bottom density in non-Boussinesq mode) to get into [R Z3 T-3 ~> W m-2] + ! near-bottom density in non-Boussinesq mode) to get into [H Z2 T-3 ~> m3 s-3 or W m-2] CS%TKE_itidal_loss_fixed(i,j) = 0.5*kappa_h2_factor* GV%H_to_RZ * US%L_to_Z*kappa_itides * h2(i,j) enddo ; enddo @@ -2888,12 +3787,23 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) ! residual allocate(CS%residual(isd:ied,jsd:jed), source=0.0) - do j=G%jsc,G%jec ; do i=G%isc,G%iec - if (CS%refl_pref_logical(i,j)) then - CS%residual(i,j) = 1. - CS%refl_pref(i,j) - CS%trans(i,j) - endif - enddo ; enddo - call pass_var(CS%residual, G%domain) + if (CS%apply_residual_drag) then + do j=G%jsc,G%jec ; do i=G%isc,G%iec + if (CS%refl_pref_logical(i,j)) then + CS%residual(i,j) = 1. - (CS%refl_pref(i,j) - CS%trans(i,j)) + endif + enddo ; enddo + call pass_var(CS%residual, G%domain) + else + ! report residual of transmission/reflection onto reflection + ! this ensure energy budget is conserved + do j=G%jsc,G%jec ; do i=G%isc,G%iec + if (CS%refl_pref_logical(i,j)) then + CS%refl_pref(i,j) = 1. - CS%trans(i,j) + endif + enddo ; enddo + call pass_var(CS%refl_pref, G%domain) + endif 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) @@ -2933,7 +3843,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) ! Register 2-D energy density (summed over angles, freq, modes) CS%id_tot_En = register_diag_field('ocean_model', 'ITide_tot_En', diag%axesT1, & Time, 'Internal tide total energy density', & - 'J m-2', conversion=US%RZ3_T3_to_W_m2*US%T_to_s) + 'J m-2', conversion=HZ2_T2_to_J_m2) allocate(CS%id_itide_drag(CS%nFreq, CS%nMode), source=-1) allocate(CS%id_TKE_itidal_input(CS%nFreq), source=-1) @@ -2944,27 +3854,27 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) CS%id_TKE_itidal_input(fr) = register_diag_field('ocean_model', var_name, diag%axesT1, & Time, 'Conversion from barotropic to baroclinic tide, '//& - var_descript, 'W m-2', conversion=US%RZ3_T3_to_W_m2) + var_descript, 'W m-2', conversion=HZ2_T3_to_W_m2) enddo ! Register 2-D energy losses (summed over angles, freq, modes) CS%id_tot_leak_loss = register_diag_field('ocean_model', 'ITide_tot_leak_loss', diag%axesT1, & Time, 'Internal tide energy loss to background drag', & - 'W m-2', conversion=US%RZ3_T3_to_W_m2) + 'W m-2', conversion=HZ2_T3_to_W_m2) CS%id_tot_quad_loss = register_diag_field('ocean_model', 'ITide_tot_quad_loss', diag%axesT1, & Time, 'Internal tide energy loss to bottom drag', & - 'W m-2', conversion=US%RZ3_T3_to_W_m2) + 'W m-2', conversion=HZ2_T3_to_W_m2) CS%id_tot_itidal_loss = register_diag_field('ocean_model', 'ITide_tot_itidal_loss', diag%axesT1, & Time, 'Internal tide energy loss to wave drag', & - 'W m-2', conversion=US%RZ3_T3_to_W_m2) + 'W m-2', conversion=HZ2_T3_to_W_m2) CS%id_tot_Froude_loss = register_diag_field('ocean_model', 'ITide_tot_Froude_loss', diag%axesT1, & Time, 'Internal tide energy loss to wave breaking', & - 'W m-2', conversion=US%RZ3_T3_to_W_m2) + 'W m-2', conversion=HZ2_T3_to_W_m2) CS%id_tot_residual_loss = register_diag_field('ocean_model', 'ITide_tot_residual_loss', diag%axesT1, & Time, 'Internal tide energy loss to residual on slopes', & - 'W m-2', conversion=US%RZ3_T3_to_W_m2) + 'W m-2', conversion=HZ2_T3_to_W_m2) CS%id_tot_allprocesses_loss = register_diag_field('ocean_model', 'ITide_tot_allprocesses_loss', diag%axesT1, & Time, 'Internal tide energy loss summed over all processes', & - 'W m-2', conversion=US%RZ3_T3_to_W_m2) + 'W m-2', conversion=HZ2_T3_to_W_m2) allocate(CS%id_En_mode(CS%nFreq,CS%nMode), source=-1) allocate(CS%id_En_ang_mode(CS%nFreq,CS%nMode), source=-1) @@ -2996,14 +3906,14 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) write(var_name, '("Itide_En_freq",i1,"_mode",i1)') fr, m write(var_descript, '("Internal tide energy density in frequency ",i1," mode ",i1)') fr, m CS%id_En_mode(fr,m) = register_diag_field('ocean_model', var_name, & - diag%axesT1, Time, var_descript, 'J m-2', conversion=US%RZ3_T3_to_W_m2*US%T_to_s) + diag%axesT1, Time, var_descript, 'J m-2', conversion=HZ2_T2_to_J_m2) call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) ! Register 3-D (i,j,a) energy density for each frequency and mode write(var_name, '("Itide_En_ang_freq",i1,"_mode",i1)') fr, m write(var_descript, '("Internal tide angular energy density in frequency ",i1," mode ",i1)') fr, m CS%id_En_ang_mode(fr,m) = register_diag_field('ocean_model', var_name, & - axes_ang, Time, var_descript, 'J m-2 band-1', conversion=US%RZ3_T3_to_W_m2*US%T_to_s) + axes_ang, Time, var_descript, 'J m-2 band-1', conversion=HZ2_T2_to_J_m2) call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) ! Register 2-D energy loss (summed over angles) for each frequency and mode @@ -3011,37 +3921,37 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) write(var_name, '("Itide_wavedrag_loss_freq",i1,"_mode",i1)') fr, m write(var_descript, '("Internal tide energy loss due to wave-drag from frequency ",i1," mode ",i1)') fr, m CS%id_itidal_loss_mode(fr,m) = register_diag_field('ocean_model', var_name, & - diag%axesT1, Time, var_descript, 'W m-2', conversion=US%RZ3_T3_to_W_m2) + diag%axesT1, Time, var_descript, 'W m-2', conversion=HZ2_T3_to_W_m2) call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) ! Leakage loss write(var_name, '("Itide_leak_loss_freq",i1,"_mode",i1)') fr, m write(var_descript, '("Internal tide energy loss due to leakage from frequency ",i1," mode ",i1)') fr, m CS%id_leak_loss_mode(fr,m) = register_diag_field('ocean_model', var_name, & - diag%axesT1, Time, var_descript, 'W m-2', conversion=US%RZ3_T3_to_W_m2) + diag%axesT1, Time, var_descript, 'W m-2', conversion=HZ2_T3_to_W_m2) call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) ! Quad loss write(var_name, '("Itide_quad_loss_freq",i1,"_mode",i1)') fr, m write(var_descript, '("Internal tide energy quad loss from frequency ",i1," mode ",i1)') fr, m CS%id_quad_loss_mode(fr,m) = register_diag_field('ocean_model', var_name, & - diag%axesT1, Time, var_descript, 'W m-2', conversion=US%RZ3_T3_to_W_m2) + diag%axesT1, Time, var_descript, 'W m-2', conversion=HZ2_T3_to_W_m2) call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) ! Froude loss write(var_name, '("Itide_froude_loss_freq",i1,"_mode",i1)') fr, m write(var_descript, '("Internal tide energy Froude loss from frequency ",i1," mode ",i1)') fr, m CS%id_froude_loss_mode(fr,m) = register_diag_field('ocean_model', var_name, & - diag%axesT1, Time, var_descript, 'W m-2', conversion=US%RZ3_T3_to_W_m2) + diag%axesT1, Time, var_descript, 'W m-2', conversion=HZ2_T3_to_W_m2) call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) ! residual losses write(var_name, '("Itide_residual_loss_freq",i1,"_mode",i1)') fr, m write(var_descript, '("Internal tide energy residual loss from frequency ",i1," mode ",i1)') fr, m CS%id_residual_loss_mode(fr,m) = register_diag_field('ocean_model', var_name, & - diag%axesT1, Time, var_descript, 'W m-2', conversion=US%RZ3_T3_to_W_m2) + diag%axesT1, Time, var_descript, 'W m-2', conversion=HZ2_T3_to_W_m2) call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) ! all loss processes write(var_name, '("Itide_allprocesses_loss_freq",i1,"_mode",i1)') fr, m write(var_descript, '("Internal tide energy loss due to all processes from frequency ",i1," mode ",i1)') fr, m CS%id_allprocesses_loss_mode(fr,m) = register_diag_field('ocean_model', var_name, & - diag%axesT1, Time, var_descript, 'W m-2', conversion=US%RZ3_T3_to_W_m2) + diag%axesT1, Time, var_descript, 'W m-2', conversion=HZ2_T3_to_W_m2) call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) ! Register 3-D (i,j,a) energy loss for each frequency and mode @@ -3049,7 +3959,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) write(var_name, '("Itide_wavedrag_loss_ang_freq",i1,"_mode",i1)') fr, m write(var_descript, '("Internal tide energy loss due to wave-drag from frequency ",i1," mode ",i1)') fr, m CS%id_itidal_loss_ang_mode(fr,m) = register_diag_field('ocean_model', var_name, & - axes_ang, Time, var_descript, 'W m-2 band-1', conversion=US%RZ3_T3_to_W_m2) + axes_ang, Time, var_descript, 'W m-2 band-1', conversion=HZ2_T3_to_W_m2) call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) ! Register 2-D period-averaged near-bottom horizontal velocity for each frequency and mode diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 6631298690..c5297a3cf0 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -3588,8 +3588,9 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di end subroutine diabatic_driver_init !> Routine to register restarts, pass-through to children modules -subroutine register_diabatic_restarts(G, US, param_file, int_tide_CSp, restart_CSp) +subroutine register_diabatic_restarts(G, GV, US, param_file, int_tide_CSp, restart_CSp) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters type(int_tide_CS), pointer :: int_tide_CSp !< Internal tide control structure @@ -3602,7 +3603,7 @@ subroutine register_diabatic_restarts(G, US, param_file, int_tide_CSp, restart_C call read_param(param_file, "INTERNAL_TIDES", use_int_tides) if (use_int_tides) then - call register_int_tide_restarts(G, US, param_file, int_tide_CSp, restart_CSp) + call register_int_tide_restarts(G, GV, US, param_file, int_tide_CSp, restart_CSp) endif end subroutine register_diabatic_restarts diff --git a/src/parameterizations/vertical/MOM_internal_tide_input.F90 b/src/parameterizations/vertical/MOM_internal_tide_input.F90 index aa02a42ea9..f4ef901868 100644 --- a/src/parameterizations/vertical/MOM_internal_tide_input.F90 +++ b/src/parameterizations/vertical/MOM_internal_tide_input.F90 @@ -42,8 +42,8 @@ module MOM_int_tide_input logical :: debug !< If true, write verbose checksums for debugging. type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to !! regulate the timing of diagnostic output. - real :: TKE_itide_max !< Maximum Internal tide conversion - !! available to mix above the BBL [R Z3 T-3 ~> W m-2] + real :: TKE_itide_maxi !< Maximum Internal tide conversion + !! available to mix above the BBL [H Z2 T-3 ~> m3 s-3 or W m-2] real :: kappa_fill !< Vertical diffusivity used to interpolate sensible values !! of T & S into thin layers [H Z T-1 ~> m2 s-1 or kg m-1 s-1] @@ -51,7 +51,7 @@ module MOM_int_tide_input !< The time-invariant field that enters the TKE_itidal input calculation noting that the !! stratification and perhaps density are time-varying [R Z4 H-1 T-2 ~> J m-2 or J m kg-1]. real, allocatable, dimension(:,:,:) :: & - TKE_itidal_input, & !< The internal tide TKE input at the bottom of the ocean [R Z3 T-3 ~> W m-2]. + TKE_itidal_input, & !< The internal tide TKE input at the bottom of the ocean [H Z2 T-3 ~> m3 s-3 or W m-2]. tideamp !< The amplitude of the tidal velocities [Z T-1 ~> m s-1]. character(len=200) :: inputdir !< The directory for input files. @@ -105,7 +105,9 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, CS) real, dimension(SZI_(G),SZJ_(G)) :: & N2_bot ! The bottom squared buoyancy frequency [T-2 ~> s-2]. real, dimension(SZI_(G),SZJ_(G)) :: & - Rho_bot ! The average near-bottom density or the Boussinesq reference density [R ~> kg m-3]. + Rho_bot, & ! The average near-bottom density or the Boussinesq reference density [R ~> kg m-3]. + h_bot ! Bottom boundary layer thickness [H ~> m or kg m-2]. + integer, dimension(SZI_(G),SZJ_(G)) :: k_bot ! Bottom boundary layer top layer index. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & T_f, S_f ! The temperature and salinity in [C ~> degC] and [S ~> ppt] with the values in @@ -114,11 +116,16 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, CS) ! equation of state. logical :: avg_enabled ! for testing internal tides (BDM) type(time_type) :: time_end !< For use in testing internal tides (BDM) + real :: HZ2_T3_to_W_m2 ! unit conversion factor for TKE from internal to mks [H Z2 T-3 ~> m3 s-3 or W m-2] + real :: W_m2_to_HZ2_T3 ! unit conversion factor for TKE from mks to internal [m3 s-3 or W m-2 ~> H Z2 T-3] integer :: i, j, is, ie, js, je, nz, isd, ied, jsd, jed integer :: i_global, j_global integer :: fr + HZ2_T3_to_W_m2 = GV%H_to_kg_m2*(US%Z_to_m**2)*(US%s_to_T**3) + W_m2_to_HZ2_T3 = GV%kg_m2_to_H*(US%m_to_Z**2)*(US%T_to_s**3) + 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 @@ -135,7 +142,7 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, CS) call vert_fill_TS(h, tv%T, tv%S, CS%kappa_fill*dt, T_f, S_f, G, GV, US, larger_h_denom=.true.) endif - call find_N2_bottom(h, tv, T_f, S_f, itide%h2, fluxes, G, GV, US, N2_bot, Rho_bot) + call find_N2_bottom(G, GV, US, tv, fluxes, h, T_f, S_f, itide%h2, N2_bot, Rho_bot, h_bot, k_bot) avg_enabled = query_averaging_enabled(CS%diag, time_end=time_end) @@ -143,15 +150,16 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, CS) !$OMP parallel do default(shared) do fr=1,CS%nFreq ; do j=js,je ; do i=is,ie itide%Nb(i,j) = G%mask2dT(i,j) * sqrt(N2_bot(i,j)) - CS%TKE_itidal_input(i,j,fr) = min(GV%Z_to_H*CS%TKE_itidal_coef(i,j,fr)*itide%Nb(i,j), CS%TKE_itide_max) + CS%TKE_itidal_input(i,j,fr) = min(GV%RZ_to_H*GV%Z_to_H*CS%TKE_itidal_coef(i,j,fr)*itide%Nb(i,j), & + CS%TKE_itide_maxi) enddo ; enddo ; enddo else !$OMP parallel do default(shared) do fr=1,CS%nFreq ; do j=js,je ; do i=is,ie itide%Nb(i,j) = G%mask2dT(i,j) * sqrt(N2_bot(i,j)) itide%Rho_bot(i,j) = G%mask2dT(i,j) * Rho_bot(i,j) - CS%TKE_itidal_input(i,j,fr) = min((GV%RZ_to_H*Rho_bot(i,j)) * CS%TKE_itidal_coef(i,j,fr)*itide%Nb(i,j), & - CS%TKE_itide_max) + CS%TKE_itidal_input(i,j,fr) = min((GV%RZ_to_H*GV%RZ_to_H*Rho_bot(i,j))*CS%TKE_itidal_coef(i,j,fr)*itide%Nb(i,j), & + CS%TKE_itide_maxi) enddo ; enddo ; enddo endif @@ -163,7 +171,7 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, CS) i_global = i + G%idg_offset j_global = j + G%jdg_offset if ((i_global == CS%int_tide_source_i) .and. (j_global == CS%int_tide_source_j)) then - CS%TKE_itidal_input(i,j,fr) = 1.0*US%kg_m3_to_R*US%m_to_Z**3*US%T_to_s**3 + CS%TKE_itidal_input(i,j,fr) = 1.0*W_m2_to_HZ2_T3 endif enddo ; enddo ; enddo else @@ -171,7 +179,7 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, CS) ! Input an arbitrary energy point source.id_ if (((G%geoLonCu(I-1,j)-CS%int_tide_source_x) * (G%geoLonBu(I,j)-CS%int_tide_source_x) <= 0.0) .and. & ((G%geoLatCv(i,J-1)-CS%int_tide_source_y) * (G%geoLatCv(i,j)-CS%int_tide_source_y) <= 0.0)) then - CS%TKE_itidal_input(i,j,fr) = 1.0*US%kg_m3_to_R*US%m_to_Z**3*US%T_to_s**3 + CS%TKE_itidal_input(i,j,fr) = 1.0*W_m2_to_HZ2_T3 endif enddo ; enddo ; enddo endif @@ -181,7 +189,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, unscale=US%s_to_T**2) call hchksum(CS%TKE_itidal_input,"TKE_itidal_input", G%HI, haloshift=0, & - unscale=US%RZ3_T3_to_W_m2) + unscale=HZ2_T3_to_W_m2) endif call enable_averages(dt, time_end, CS%diag) @@ -198,23 +206,26 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, CS) end subroutine set_int_tide_input !> Estimates the near-bottom buoyancy frequency (N^2). -subroutine find_N2_bottom(h, tv, T_f, S_f, h2, fluxes, G, GV, US, N2_bot, rho_bot) +subroutine find_N2_bottom(G, GV, US, tv, fluxes, h, T_f, S_f, h2, N2_bot, Rho_bot, h_bot, k_bot) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to the !! thermodynamic fields + type(forcing), intent(in) :: fluxes !< A structure of thermodynamic surface fluxes + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: T_f !< Temperature after vertical filtering to !! smooth out the values in thin layers [C ~> degC]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: S_f !< Salinity after vertical filtering to !! smooth out the values in thin layers [S ~> ppt]. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h2 !< Bottom topographic roughness [Z2 ~> m2]. - type(forcing), intent(in) :: fluxes !< A structure of thermodynamic surface fluxes real, dimension(SZI_(G),SZJ_(G)), intent(out) :: N2_bot !< The squared buoyancy frequency at the !! ocean bottom [T-2 ~> s-2]. - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: rho_bot !< The average density near the ocean + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: Rho_bot !< The average density near the ocean !! bottom [R ~> kg m-3] + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_bot !< Bottom boundary layer thickness [H ~> m or kg m-2] + integer, dimension(SZI_(G),SZJ_(G)), intent(out) :: k_bot !< Bottom boundary layer top layer index + ! Local variables real, dimension(SZI_(G),SZK_(GV)+1) :: & pres, & ! The pressure at each interface [R L2 T-2 ~> Pa]. @@ -247,7 +258,7 @@ subroutine find_N2_bottom(h, tv, T_f, S_f, h2, fluxes, G, GV, US, N2_bot, rho_bo enddo !$OMP parallel do default(none) shared(is,ie,js,je,nz,tv,fluxes,G,GV,US,h,T_f,S_f, & - !$OMP h2,N2_bot,rho_bot,G_Rho0,EOSdom) & + !$OMP h2,N2_bot,Rho_bot,h_bot,k_bot,G_Rho0,EOSdom) & !$OMP private(pres,Temp_Int,Salin_Int,dRho_dT,dRho_dS, & !$OMP dz,hb,dRho_bot,z_from_bot,do_i,h_amp,do_any,dz_int) & !$OMP firstprivate(dRho_int) @@ -324,7 +335,7 @@ subroutine find_N2_bottom(h, tv, T_f, S_f, h2, fluxes, G, GV, US, N2_bot, rho_bo enddo else ! Average the density over the envelope of the topography. - call find_rho_bottom(h, dz, pres, h_amp, tv, j, G, GV, US, Rho_bot(:,j)) + call find_rho_bottom(G, GV, US, tv, h, dz, pres, h_amp, j, Rho_bot(:,j), h_bot(:,j), k_bot(:,j)) endif enddo @@ -334,7 +345,8 @@ end subroutine find_N2_bottom subroutine get_input_TKE(G, TKE_itidal_input, nFreq, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure (in). real, dimension(SZI_(G),SZJ_(G),nFreq), & - intent(out) :: TKE_itidal_input !< The energy input to the internal waves [R Z3 T-3 ~> W m-2]. + intent(out) :: TKE_itidal_input !< The energy input to the internal waves + !! [H Z2 T-3 ~> m3 s-3 or W m-2]. integer, intent(in) :: nFreq !< number of frequencies type(int_tide_input_CS), target :: CS !< A pointer that is set to point to the control !! structure for the internal tide input module. @@ -392,6 +404,8 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) real :: kappa_h2_factor ! factor for the product of wavenumber * rms sgs height [nondim]. real :: kappa_itides ! topographic wavenumber and non-dimensional scaling [L-1 ~> m-1] real :: min_zbot_itides ! Minimum ocean depth for internal tide conversion [Z ~> m]. + real :: HZ2_T3_to_W_m2 ! unit conversion factor for TKE from internal to mks [H Z2 T-3 ~> m3 s-3 or W m-2] + real :: W_m2_to_HZ2_T3 ! unit conversion factor for TKE from mks to internal [m3 s-3 or W m-2 ~> H Z2 T-3] integer :: tlen_days !< Time interval from start for adding wave source !! for testing internal tides (BDM) integer :: i, j, is, ie, js, je, isd, ied, jsd, jed @@ -417,6 +431,9 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) CS%diag => diag + HZ2_T3_to_W_m2 = GV%H_to_kg_m2*(US%Z_to_m**2)*(US%s_to_T**3) + W_m2_to_HZ2_T3 = GV%kg_m2_to_H*(US%m_to_Z**2)*(US%T_to_s**3) + ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") @@ -455,10 +472,10 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) call get_param(param_file, mdl, "KAPPA_H2_FACTOR", kappa_h2_factor, & "A scaling factor for the roughness amplitude with "//& "INT_TIDE_DISSIPATION.", units="nondim", default=1.0) - call get_param(param_file, mdl, "TKE_ITIDE_MAX", CS%TKE_itide_max, & + call get_param(param_file, mdl, "TKE_ITIDE_MAX", CS%TKE_itide_maxi, & "The maximum internal tide energy source available to mix "//& "above the bottom boundary layer with INT_TIDE_DISSIPATION.", & - units="W m-2", default=1.0e3, scale=US%W_m2_to_RZ3_T3) + units="W m-2", default=1.0e3, scale=W_m2_to_HZ2_T3) call get_param(param_file, mdl, "READ_TIDEAMP", read_tideamp, & "If true, read a file (given by TIDEAMP_FILE) containing "//& @@ -551,7 +568,7 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) write(var_descript, '("Internal Tide Driven Turbulent Kinetic Energy in frequency ",i1)') fr CS%id_TKE_itidal_itide(fr) = register_diag_field('ocean_model',var_name,diag%axesT1,Time, & - var_descript, 'W m-2', conversion=US%RZ3_T3_to_W_m2) + var_descript, 'W m-2', conversion=HZ2_T3_to_W_m2) enddo CS%id_Nb = register_diag_field('ocean_model','Nb_itide',diag%axesT1,Time, & diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 4efee8d561..9a87b085a6 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -23,7 +23,7 @@ module MOM_set_diffusivity use MOM_full_convection, only : full_convection use MOM_grid, only : ocean_grid_type use MOM_interface_heights, only : thickness_to_dz, find_rho_bottom -use MOM_internal_tides, only : int_tide_CS, get_lowmode_loss +use MOM_internal_tides, only : int_tide_CS, get_lowmode_loss, get_lowmode_diffusivity use MOM_intrinsic_functions, only : invcosh use MOM_io, only : slasher, MOM_read_data use MOM_isopycnal_slopes, only : vert_fill_TS @@ -148,6 +148,7 @@ module MOM_set_diffusivity logical :: double_diffusion !< If true, enable double-diffusive mixing using an old method. logical :: use_CVMix_ddiff !< If true, enable double-diffusive mixing via CVMix. logical :: use_tidal_mixing !< If true, activate tidal mixing diffusivity. + logical :: use_int_tides !< If true, use internal tides ray tracing logical :: simple_TKE_to_Kd !< If true, uses a simple estimate of Kd/TKE that !! does not rely on a layer-formulation. real :: Max_Rrho_salt_fingers !< max density ratio for salt fingering [nondim] @@ -176,8 +177,11 @@ module MOM_set_diffusivity !>@{ Diagnostic IDs integer :: id_maxTKE = -1, id_TKE_to_Kd = -1, id_Kd_user = -1 integer :: id_Kd_layer = -1, id_Kd_BBL = -1, id_N2 = -1 - integer :: id_Kd_Work = -1, id_KT_extra = -1, id_KS_extra = -1, id_R_rho = -1 - integer :: id_Kd_bkgnd = -1, id_Kv_bkgnd = -1 + integer :: id_Kd_Work = -1, id_KT_extra = -1, id_KS_extra = -1, id_R_rho = -1 + integer :: id_Kd_bkgnd = -1, id_Kv_bkgnd = -1, id_Kd_leak = -1 + integer :: id_Kd_quad = -1, id_Kd_itidal = -1, id_Kd_Froude = -1, id_Kd_slope = -1 + integer :: id_prof_leak = -1, id_prof_quad = -1, id_prof_itidal= -1 + integer :: id_prof_Froude= -1, id_prof_slope = -1, id_bbl_thick = -1, id_kbbl = -1 !>@} end type set_diffusivity_CS @@ -185,16 +189,29 @@ module MOM_set_diffusivity !> This structure has memory for used in calculating diagnostics of diffusivity type diffusivity_diags real, pointer, dimension(:,:,:) :: & - N2_3d => NULL(), & !< squared buoyancy frequency at interfaces [T-2 ~> s-2] - Kd_user => NULL(), & !< user-added diffusivity at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] - Kd_BBL => NULL(), & !< BBL diffusivity at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] - Kd_work => NULL(), & !< layer integrated work by diapycnal mixing [R Z3 T-3 ~> W m-2] - maxTKE => NULL(), & !< energy required to entrain to h_max [H Z2 T-3 ~> m3 s-3 or W m-2] - Kd_bkgnd => NULL(), & !< Background diffusivity at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] - Kv_bkgnd => NULL(), & !< Viscosity from background diffusivity at interfaces [H Z T-1 ~> m2 s-1 or Pa s] - KT_extra => NULL(), & !< Double diffusion diffusivity for temperature [H Z T-1 ~> m2 s-1 or kg m-1 s-1] - KS_extra => NULL(), & !< Double diffusion diffusivity for salinity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] - drho_rat => NULL() !< The density difference ratio used in double diffusion [nondim]. + N2_3d => NULL(), & !< squared buoyancy frequency at interfaces [T-2 ~> s-2] + Kd_user => NULL(), & !< user-added diffusivity at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_BBL => NULL(), & !< BBL diffusivity at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_work => NULL(), & !< layer integrated work by diapycnal mixing [R Z3 T-3 ~> W m-2] + maxTKE => NULL(), & !< energy required to entrain to h_max [H Z2 T-3 ~> m3 s-3 or W m-2] + Kd_bkgnd => NULL(), & !< Background diffusivity at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kv_bkgnd => NULL(), & !< Viscosity from background diffusivity at interfaces [H Z T-1 ~> m2 s-1 or Pa s] + KT_extra => NULL(), & !< Double diffusion diffusivity for temperature [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + KS_extra => NULL(), & !< Double diffusion diffusivity for salinity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + drho_rat => NULL(), & !< The density difference ratio used in double diffusion [nondim]. + Kd_leak => NULL(), & !< internal tides leakage diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_quad => NULL(), & !< internal tides bottom drag diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_itidal => NULL(), & !< internal tides wave drag diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_Froude => NULL(), & !< internal tides high Froude diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_slope => NULL(), & !< internal tides critical slopes diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + prof_leak => NULL(), & !< vertical profile for leakage [H-1 ~> m-1 or m2 kg-1] + prof_quad => NULL(), & !< vertical profile for bottom drag [H-1 ~> m-1 or m2 kg-1] + prof_itidal => NULL(), & !< vertical profile for wave drag [H-1 ~> m-1 or m2 kg-1] + prof_Froude => NULL(), & !< vertical profile for Froude drag [H-1 ~> m-1 or m2 kg-1] + prof_slope => NULL() !< vertical profile for critical slopes [H-1 ~> m-1 or m2 kg-1] + real, pointer, dimension(:,:) :: bbl_thick => NULL(), & !< bottom boundary layer thickness [H ~> m or kg m-2] + kbbl => NULL() !< top of bottom boundary layer + real, pointer, dimension(:,:,:) :: TKE_to_Kd => NULL() !< conversion rate (~1.0 / (G_Earth + dRho_lay)) between TKE !! dissipated within a layer and Kd in that layer @@ -252,6 +269,8 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i ! local variables real :: N2_bot(SZI_(G)) ! Bottom squared buoyancy frequency [T-2 ~> s-2] real :: rho_bot(SZI_(G)) ! In situ near-bottom density [T-2 ~> s-2] + real :: h_bot(SZI_(G)) ! Bottom boundary layer thickness [H ~> m or kg m-2] + integer :: k_bot(SZI_(G)) ! Bottom boundary layer thickness top layer index type(diffusivity_diags) :: dd ! structure with arrays of available diags @@ -264,6 +283,11 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i Kd_lay_2d, & !< The layer diffusivities [H Z T-1 ~> m2 s-1 or kg m-1 s-1] dz, & !< Height change across layers [Z ~> m] maxTKE, & !< Energy required to entrain to h_max [H Z2 T-3 ~> m3 s-3 or W m-2] + prof_leak_2d, & !< vertical profile for leakage [Z-1 ~> m-1] + prof_quad_2d, & !< vertical profile for bottom drag [Z-1 ~> m-1] + prof_itidal_2d, & !< vertical profile for wave drag [Z-1 ~> m-1] + prof_Froude_2d, & !< vertical profile for Froude drag [Z-1 ~> m-1] + prof_slope_2d, & !< vertical profile for critical slopes [Z-1 ~> m-1] TKE_to_Kd !< Conversion rate (~1.0 / (G_Earth + dRho_lay)) between !< TKE dissipated within a layer and Kd in that layer !< [H Z T-1 / H Z2 T-3 = T2 Z-1 ~> s2 m-1] @@ -272,6 +296,11 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i N2_int, & !< squared buoyancy frequency associated at interfaces [T-2 ~> s-2] Kd_int_2d, & !< The interface diffusivities [H Z T-1 ~> m2 s-1 or kg m-1 s-1] Kv_bkgnd, & !< The background diffusion related interface viscosities [H Z T-1 ~> m2 s-1 or Pa s] + Kd_leak_2d, & !< internal tides leakage diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_quad_2d, & !< internal tides bottom drag diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_itidal_2d, & !< internal tides wave drag diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_Froude_2d, & !< internal tides high Froude diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_slope_2d, & !< internal tides critical slopes diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] dRho_int, & !< Locally referenced potential density difference across interfaces [R ~> kg m-3] KT_extra, & !< Double diffusion diffusivity of temperature [H Z T-1 ~> m2 s-1 or kg m-1 s-1] KS_extra !< Double diffusion diffusivity of salinity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] @@ -316,6 +345,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i "when USE_CVMIX_DDIFF or DOUBLE_DIFFUSION are true.") TKE_to_Kd_used = (CS%use_tidal_mixing .or. CS%ML_radiation .or. & + CS%use_int_tides .or. & (CS%bottomdraglaw .and. .not.CS%use_LOTW_BBL_diffusivity)) ! Set Kd_lay, Kd_int and Kv_slow to constant values, mostly to fill the halos. @@ -342,6 +372,20 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i if (CS%id_Kd_bkgnd > 0) allocate(dd%Kd_bkgnd(isd:ied,jsd:jed,nz+1), source=0.) if (CS%id_Kv_bkgnd > 0) allocate(dd%Kv_bkgnd(isd:ied,jsd:jed,nz+1), source=0.) + if (CS%id_kbbl > 0) allocate(dd%kbbl(isd:ied,jsd:jed), source=0.) + if (CS%id_bbl_thick > 0) allocate(dd%bbl_thick(isd:ied,jsd:jed), source=0.) + if (CS%id_Kd_leak > 0) allocate(dd%Kd_leak(isd:ied,jsd:jed,nz+1), source=0.) + if (CS%id_Kd_quad > 0) allocate(dd%Kd_quad(isd:ied,jsd:jed,nz+1), source=0.) + if (CS%id_Kd_itidal > 0) allocate(dd%Kd_itidal(isd:ied,jsd:jed,nz+1), source=0.) + if (CS%id_Kd_Froude > 0) allocate(dd%Kd_Froude(isd:ied,jsd:jed,nz+1), source=0.) + if (CS%id_Kd_slope > 0) allocate(dd%Kd_slope(isd:ied,jsd:jed,nz+1), source=0.) + + if (CS%id_prof_leak > 0) allocate(dd%prof_leak(isd:ied,jsd:jed,nz), source=0.) + if (CS%id_prof_quad > 0) allocate(dd%prof_quad(isd:ied,jsd:jed,nz), source=0.) + if (CS%id_prof_itidal > 0) allocate(dd%prof_itidal(isd:ied,jsd:jed,nz), source=0.) + if (CS%id_prof_Froude > 0) allocate(dd%prof_Froude(isd:ied,jsd:jed,nz), source=0.) + if (CS%id_prof_slope > 0) allocate(dd%prof_slope(isd:ied,jsd:jed,nz), source=0.) + ! set up arrays for tidal mixing diagnostics if (CS%use_tidal_mixing) & call setup_tidal_diagnostics(G, GV, CS%tidal_mixing) @@ -406,12 +450,12 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i ! parameterization of Kd. !$OMP parallel do default(shared) private(dRho_int,N2_lay,Kd_lay_2d,Kd_int_2d,Kv_bkgnd,N2_int,dz, & - !$OMP N2_bot,rho_bot,KT_extra,KS_extra,TKE_to_Kd,maxTKE,dissip,kb) & + !$OMP N2_bot,rho_bot,h_bot,k_bot,KT_extra,KS_extra,TKE_to_Kd,maxTKE,dissip,kb) & !$OMP if(.not. CS%use_CVMix_ddiff) do j=js,je ! Set up variables related to the stratification. - call find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, N2_lay, N2_int, N2_bot, rho_bot) + call find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, N2_lay, N2_int, N2_bot, rho_bot, h_bot, k_bot) if (associated(dd%N2_3d)) then do K=1,nz+1 ; do i=is,ie ; dd%N2_3d(i,j,K) = N2_int(i,K) ; enddo ; enddo @@ -520,6 +564,53 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i maxTKE, G, GV, US, CS%tidal_mixing, & CS%Kd_max, visc%Kv_slow, Kd_lay_2d, Kd_int_2d) + ! Add diffusivity from internal tides ray tracing + if (CS%use_int_tides) then + + call get_lowmode_diffusivity(G, GV, h, tv, US, h_bot, k_bot, j, N2_lay, N2_int, TKE_to_Kd, CS%Kd_max, & + CS%int_tide_CSp, Kd_leak_2d, Kd_quad_2d, Kd_itidal_2d, Kd_Froude_2d, Kd_slope_2d, & + Kd_lay_2d, Kd_int_2d, prof_leak_2d, prof_quad_2d, prof_itidal_2d, prof_froude_2d, & + prof_slope_2d) + + if (CS%id_kbbl > 0) then ; do i=is,ie + dd%kbbl(i,j) = k_bot(i) + enddo ; endif + if (CS%id_bbl_thick > 0) then ; do i=is,ie + dd%bbl_thick(i,j) = h_bot(i) + enddo ; endif + if (CS%id_Kd_leak > 0) then ; do K=1,nz+1 ; do i=is,ie + dd%Kd_leak(i,j,K) = Kd_leak_2d(i,K) + enddo ; enddo ; endif + if (CS%id_Kd_quad > 0) then ; do K=1,nz+1 ; do i=is,ie + dd%Kd_quad(i,j,K) = Kd_quad_2d(i,K) + enddo ; enddo ; endif + if (CS%id_Kd_itidal > 0) then ; do K=1,nz+1 ; do i=is,ie + dd%Kd_itidal(i,j,K) = Kd_itidal_2d(i,K) + enddo ; enddo ; endif + if (CS%id_Kd_Froude > 0) then ; do K=1,nz+1 ; do i=is,ie + dd%Kd_Froude(i,j,K) = Kd_Froude_2d(i,K) + enddo ; enddo ; endif + if (CS%id_Kd_slope > 0) then ; do K=1,nz+1 ; do i=is,ie + dd%Kd_slope(i,j,K) = Kd_slope_2d(i,K) + enddo ; enddo ; endif + + if (CS%id_prof_leak > 0) then ; do k=1,nz; do i=is,ie + dd%prof_leak(i,j,k) = prof_leak_2d(i,k) + enddo ; enddo ; endif + if (CS%id_prof_quad > 0) then ; do k=1,nz; do i=is,ie + dd%prof_quad(i,j,k) = prof_quad_2d(i,k) + enddo ; enddo ; endif + if (CS%id_prof_itidal > 0) then ; do k=1,nz; do i=is,ie + dd%prof_itidal(i,j,k) = prof_itidal_2d(i,k) + enddo ; enddo ; endif + if (CS%id_prof_Froude > 0) then ; do k=1,nz; do i=is,ie + dd%prof_Froude(i,j,k) = prof_Froude_2d(i,k) + enddo ; enddo ; endif + if (CS%id_prof_slope > 0) then ; do k=1,nz; do i=is,ie + dd%prof_slope(i,j,k) = prof_slope_2d(i,k) + enddo ; enddo ; endif + endif + ! This adds the diffusion sustained by the energy extracted from the flow by the bottom drag. if (CS%bottomdraglaw .and. (CS%BBL_effic > 0.0)) then if (CS%use_LOTW_BBL_diffusivity) then @@ -624,6 +715,20 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i endif + if (CS%debug) then + if (CS%id_prof_leak > 0) call hchksum(dd%prof_leak, "leakage_profile", G%HI, haloshift=0, scale=GV%m_to_H) + if (CS%id_prof_slope > 0) call hchksum(dd%prof_slope, "slope_profile", G%HI, haloshift=0, scale=GV%m_to_H) + if (CS%id_prof_Froude > 0) call hchksum(dd%prof_Froude, "Froude_profile", G%HI, haloshift=0, scale=GV%m_to_H) + if (CS%id_prof_quad > 0) call hchksum(dd%prof_quad, "quad_profile", G%HI, haloshift=0, scale=GV%m_to_H) + if (CS%id_prof_itidal > 0) call hchksum(dd%prof_itidal, "itidal_profile", G%HI, haloshift=0, scale=GV%m_to_H) + if (CS%id_TKE_to_Kd > 0) call hchksum(dd%TKE_to_Kd, "TKE_to_Kd", G%HI, haloshift=0, scale=US%m_to_Z*US%T_to_s**2) + if (CS%id_Kd_leak > 0) call hchksum(dd%Kd_leak, "Kd_leak", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + if (CS%id_Kd_quad > 0) call hchksum(dd%Kd_quad, "Kd_quad", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + if (CS%id_Kd_itidal > 0) call hchksum(dd%Kd_itidal, "Kd_itidal", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + if (CS%id_Kd_Froude > 0) call hchksum(dd%Kd_Froude, "Kd_Froude", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + if (CS%id_Kd_slope > 0) call hchksum(dd%Kd_slope, "Kd_slope", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + endif + ! post diagnostics if (present(Kd_lay) .and. (CS%id_Kd_layer > 0)) call post_data(CS%id_Kd_layer, Kd_lay, CS%diag) @@ -631,6 +736,20 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i if (CS%id_Kd_bkgnd > 0) call post_data(CS%id_Kd_bkgnd, dd%Kd_bkgnd, CS%diag) if (CS%id_Kv_bkgnd > 0) call post_data(CS%id_Kv_bkgnd, dd%Kv_bkgnd, CS%diag) + if (CS%id_kbbl > 0) call post_data(CS%id_kbbl, dd%kbbl, CS%diag) + if (CS%id_bbl_thick > 0) call post_data(CS%id_bbl_thick, dd%bbl_thick, CS%diag) + if (CS%id_Kd_leak > 0) call post_data(CS%id_Kd_leak, dd%Kd_leak, CS%diag) + if (CS%id_Kd_slope > 0) call post_data(CS%id_Kd_slope, dd%Kd_slope, CS%diag) + if (CS%id_Kd_Froude > 0) call post_data(CS%id_Kd_Froude, dd%Kd_Froude, CS%diag) + if (CS%id_Kd_quad > 0) call post_data(CS%id_Kd_quad, dd%Kd_quad, CS%diag) + if (CS%id_Kd_itidal > 0) call post_data(CS%id_Kd_itidal, dd%Kd_itidal, CS%diag) + + if (CS%id_prof_leak > 0) call post_data(CS%id_prof_leak, dd%prof_leak, CS%diag) + if (CS%id_prof_slope > 0) call post_data(CS%id_prof_slope, dd%prof_slope, CS%diag) + if (CS%id_prof_Froude > 0) call post_data(CS%id_prof_Froude, dd%prof_Froude, CS%diag) + if (CS%id_prof_quad > 0) call post_data(CS%id_prof_quad, dd%prof_quad, CS%diag) + if (CS%id_prof_itidal > 0) call post_data(CS%id_prof_itidal, dd%prof_itidal, CS%diag) + ! tidal mixing if (CS%use_tidal_mixing) & call post_tidal_diagnostics(G, GV, h, CS%tidal_mixing) @@ -665,6 +784,17 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i if (associated(dd%Kd_bkgnd)) deallocate(dd%Kd_bkgnd) if (associated(dd%Kv_bkgnd)) deallocate(dd%Kv_bkgnd) + if (associated(dd%Kd_leak)) deallocate(dd%Kd_leak) + if (associated(dd%Kd_quad)) deallocate(dd%Kd_quad) + if (associated(dd%Kd_itidal)) deallocate(dd%Kd_itidal) + if (associated(dd%Kd_Froude)) deallocate(dd%Kd_Froude) + if (associated(dd%Kd_slope)) deallocate(dd%Kd_slope) + if (associated(dd%prof_leak)) deallocate(dd%prof_leak) + if (associated(dd%prof_quad)) deallocate(dd%prof_quad) + if (associated(dd%prof_itidal)) deallocate(dd%prof_itidal) + if (associated(dd%prof_Froude)) deallocate(dd%prof_Froude) + if (associated(dd%prof_slope)) deallocate(dd%prof_slope) + if (showCallTree) call callTree_leave("set_diffusivity()") end subroutine set_diffusivity @@ -895,7 +1025,7 @@ end subroutine find_TKE_to_Kd !> Calculate Brunt-Vaisala frequency, N^2. subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & - N2_lay, N2_int, N2_bot, Rho_bot) + N2_lay, N2_int, N2_bot, Rho_bot, h_bot, k_bot) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -921,6 +1051,8 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & intent(out) :: N2_lay !< The squared buoyancy frequency of the layers [T-2 ~> s-2]. real, dimension(SZI_(G)), intent(out) :: N2_bot !< The near-bottom squared buoyancy frequency [T-2 ~> s-2]. real, dimension(SZI_(G)), intent(out) :: Rho_bot !< Near-bottom density [R ~> kg m-3]. + real, dimension(SZI_(G)), optional, intent(out) :: h_bot !< Bottom boundary layer thickness [H ~> m or kg m-2]. + integer, dimension(SZI_(G)), optional, intent(out) :: k_bot !< Bottom boundary layer top layer index. ! Local variables real, dimension(SZI_(G),SZK_(GV)+1) :: & @@ -1065,7 +1197,7 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & ! Average over the larger of the envelope of the topography or a minimal distance. do i=is,ie ; dz_BBL_avg(i) = max(h_amp(i), CS%dz_BBL_avg_min) ; enddo - call find_rho_bottom(h, dz, pres, dz_BBL_avg, tv, j, G, GV, US, Rho_bot) + call find_rho_bottom(G, GV, US, tv, h, dz, pres, dz_BBL_avg, j, Rho_bot, h_bot, k_bot) end subroutine find_N2 @@ -2071,7 +2203,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ type(diag_ctrl), target, intent(inout) :: diag !< A structure used to regulate diagnostic output. type(set_diffusivity_CS), pointer :: CS !< pointer set to point to the module control !! structure. - type(int_tide_CS), pointer :: int_tide_CSp !< Internal tide control structure + type(int_tide_CS), intent(in), target :: int_tide_CSp !< Internal tide control structure integer, intent(out) :: halo_TS !< The halo size of tracer points that must be !! valid for the calculations in set_diffusivity. logical, intent(out) :: double_diffuse !< This indicates whether some version @@ -2116,7 +2248,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed CS%diag => diag - if (associated(int_tide_CSp)) CS%int_tide_CSp => int_tide_CSp + CS%int_tide_CSp => int_tide_CSp ! These default values always need to be set. CS%BBL_mixing_as_max = .true. @@ -2273,6 +2405,10 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ "for an isopycnal layer-formulation.", & default=.false., do_not_log=.not.TKE_to_Kd_used) + call get_param(param_file, mdl, "INTERNAL_TIDES", CS%use_int_tides, & + "If true, use the code that advances a separate set of "//& + "equations for the internal tide energy density.", default=.false.) + ! set parameters related to the background mixing call bkgnd_mixing_init(Time, G, GV, US, param_file, CS%diag, CS%bkgnd_mixing_csp, physical_OBL_scheme) @@ -2350,6 +2486,33 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ CS%id_Kv_bkgnd = register_diag_field('ocean_model', 'Kv_bkgnd', diag%axesTi, Time, & 'Background viscosity added by MOM_bkgnd_mixing module', 'm2/s', conversion=GV%HZ_T_to_m2_s) + if (CS%use_int_tides) then + CS%id_kbbl = register_diag_field('ocean_model', 'kbbl', diag%axesT1, Time, & + 'BBL index at h points', 'nondim') + CS%id_bbl_thick = register_diag_field('ocean_model', 'bbl_thick', diag%axesT1, Time, & + 'BBL thickness at h points', 'm', conversion=US%Z_to_m) + CS%id_Kd_leak = register_diag_field('ocean_model', 'Kd_leak', diag%axesTi, Time, & + 'internal tides leakage viscosity added by MOM_internal tides module', 'm2/s', conversion=GV%HZ_T_to_m2_s) + CS%id_Kd_Froude = register_diag_field('ocean_model', 'Kd_Froude', diag%axesTi, Time, & + 'internal tides Froude viscosity added by MOM_internal tides module', 'm2/s', conversion=GV%HZ_T_to_m2_s) + CS%id_Kd_itidal = register_diag_field('ocean_model', 'Kd_itidal', diag%axesTi, Time, & + 'internal tides wave drag viscosity added by MOM_internal tides module', 'm2/s', conversion=GV%HZ_T_to_m2_s) + CS%id_Kd_quad = register_diag_field('ocean_model', 'Kd_quad', diag%axesTi, Time, & + 'internal tides bottom viscosity added by MOM_internal tides module', 'm2/s', conversion=GV%HZ_T_to_m2_s) + CS%id_Kd_slope = register_diag_field('ocean_model', 'Kd_slope', diag%axesTi, Time, & + 'internal tides slope viscosity added by MOM_internal tides module', 'm2/s', conversion=GV%HZ_T_to_m2_s) + CS%id_prof_leak = register_diag_field('ocean_model', 'prof_leak', diag%axesTl, Time, & + 'internal tides leakage profile added by MOM_internal tides module', 'm-1', conversion=GV%m_to_H) + CS%id_prof_Froude = register_diag_field('ocean_model', 'prof_Froude', diag%axesTl, Time, & + 'internal tides Froude profile added by MOM_internal tides module', 'm-1', conversion=GV%m_to_H) + CS%id_prof_itidal = register_diag_field('ocean_model', 'prof_itidal', diag%axesTl, Time, & + 'internal tides wave drag profile added by MOM_internal tides module', 'm-1', conversion=GV%m_to_H) + CS%id_prof_quad = register_diag_field('ocean_model', 'prof_quad', diag%axesTl, Time, & + 'internal tides bottom profile added by MOM_internal tides module', 'm-1', conversion=GV%m_to_H) + CS%id_prof_slope = register_diag_field('ocean_model', 'prof_slope', diag%axesTl, Time, & + 'internal tides slope profile added by MOM_internal tides module', 'm-1', conversion=GV%m_to_H) + endif + CS%id_Kd_layer = register_diag_field('ocean_model', 'Kd_layer', diag%axesTL, Time, & 'Diapycnal diffusivity of layers (as set)', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) From 95744a71bf558c9802d02ee8562d6c1d1c147c83 Mon Sep 17 00:00:00 2001 From: Chengzhu Xu <135884058+c2xu@users.noreply.github.com> Date: Tue, 10 Sep 2024 09:16:08 -0600 Subject: [PATCH 2/5] Streaming filter (#675) In the MOM_streaming_filter module, a system of two coupled ODEs is configured as a streaming band-pass filter that takes the broadband model output as the input and returns the filtered signal at a user specified tidal frequency as the output. It is capable of detecting the instantaneous tidal signals while the model is running, and can be used to impose frequency-dependent wave drag or to de-tide model output. An example of filtering the M2 and K1 barotropic velocities is provided in the MOM_barotropic module. Added runtime flags for the M2 and K1 filters. Simplified the code by removing the control structure of the linked list, and now each filter has its own control structure. Using hor_index_type argument to avoid calculation in halo regions. --- src/core/MOM_barotropic.F90 | 70 +++++++++++ .../lateral/MOM_streaming_filter.F90 | 119 ++++++++++++++++++ 2 files changed, 189 insertions(+) create mode 100644 src/parameterizations/lateral/MOM_streaming_filter.F90 diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index e97e794cd6..0ac3e52a62 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -26,6 +26,8 @@ module MOM_barotropic use MOM_restart, only : query_initialized, MOM_restart_CS use MOM_self_attr_load, only : scalar_SAL_sensitivity use MOM_self_attr_load, only : SAL_CS +use MOM_streaming_filter, only : Filt_register, Filt_accum, Filter_CS +use MOM_tidal_forcing, only : tidal_frequency 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 @@ -248,6 +250,10 @@ module MOM_barotropic logical :: linearized_BT_PV !< If true, the PV and interface thicknesses used !! in the barotropic Coriolis calculation is time !! invariant and linearized. + logical :: use_filter_m2 !< If true, apply streaming band-pass filter for detecting + !! instantaneous tidal signals. + logical :: use_filter_k1 !< If true, apply streaming band-pass filter for detecting + !! instantaneous tidal signals. logical :: use_wide_halos !< If true, use wide halos and march in during the !! barotropic time stepping for efficiency. logical :: clip_velocity !< If true, limit any velocity components that are @@ -291,6 +297,10 @@ module MOM_barotropic type(hor_index_type), pointer :: debug_BT_HI => NULL() !< debugging copy of horizontal index_type type(SAL_CS), pointer :: SAL_CSp => NULL() !< Control structure for SAL type(harmonic_analysis_CS), pointer :: HA_CSp => NULL() !< Control structure for harmonic analysis + type(Filter_CS) :: Filt_CS_um2, & !< Control structures for the M2 streaming filter + Filt_CS_vm2, & !< Control structures for the M2 streaming filter + Filt_CS_uk1, & !< Control structures for the K1 streaming filter + Filt_CS_vk1 !< Control structures for the K1 streaming filter logical :: module_is_initialized = .false. !< If true, module has been initialized integer :: isdw !< The lower i-memory limit for the wide halo arrays. @@ -598,6 +608,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, DCor_v, & ! An averaged total thickness at v points [H ~> m or kg m-2]. Datv ! Basin depth at v-velocity grid points times the x-grid ! spacing [H L ~> m2 or kg m-1]. + real, dimension(:,:), pointer :: um2, uk1, vm2, vk1 + ! M2 and K1 velocities from the output of streaming filters [m s-1] real, target, dimension(SZIW_(CS),SZJW_(CS)) :: & eta, & ! The barotropic free surface height anomaly or column mass ! anomaly [H ~> m or kg m-2] @@ -1586,6 +1598,17 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif ; enddo ; enddo endif + ! Here is an example of how the filter equations are time stepped to determine the M2 and K1 velocities. + ! The filters are initialized and registered in subroutine barotropic_init. + if (CS%use_filter_m2) then + call Filt_accum(ubt, um2, CS%Time, US, CS%Filt_CS_um2) + call Filt_accum(vbt, vm2, CS%Time, US, CS%Filt_CS_vm2) + endif + if (CS%use_filter_k1) then + call Filt_accum(ubt, uk1, CS%Time, US, CS%Filt_CS_uk1) + call Filt_accum(vbt, vk1, CS%Time, US, CS%Filt_CS_vk1) + endif + ! Zero out the arrays for various time-averaged quantities. if (find_etaav) then !$OMP do @@ -5247,6 +5270,8 @@ subroutine register_barotropic_restarts(HI, GV, US, param_file, CS, restart_CS) type(vardesc) :: vd(3) character(len=40) :: mdl = "MOM_barotropic" ! This module's name. integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + real :: am2, ak1 !< Bandwidth parameters of the M2 and K1 streaming filters [nondim] + real :: om2, ok1 !< Target frequencies of the M2 and K1 streaming filters [T-1 ~> s-1] isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed IsdB = HI%IsdB ; IedB = HI%IedB ; JsdB = HI%JsdB ; JedB = HI%JedB @@ -5259,6 +5284,33 @@ subroutine register_barotropic_restarts(HI, GV, US, param_file, CS, restart_CS) "sum(u dh_dt) while also correcting for truncation errors.", & default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "STREAMING_FILTER_M2", CS%use_filter_m2, & + "If true, turn on streaming band-pass filter for detecting "//& + "instantaneous tidal signals.", default=.false.) + call get_param(param_file, mdl, "STREAMING_FILTER_K1", CS%use_filter_k1, & + "If true, turn on streaming band-pass filter for detecting "//& + "instantaneous tidal signals.", default=.false.) + call get_param(param_file, mdl, "FILTER_ALPHA_M2", am2, & + "Bandwidth parameter of the streaming filter targeting the M2 frequency. "//& + "Must be positive. To turn off filtering, set FILTER_ALPHA_M2 <= 0.0.", & + default=0.0, units="nondim", do_not_log=.not.CS%use_filter_m2) + call get_param(param_file, mdl, "FILTER_ALPHA_K1", ak1, & + "Bandwidth parameter of the streaming filter targeting the K1 frequency. "//& + "Must be positive. To turn off filtering, set FILTER_ALPHA_K1 <= 0.0.", & + default=0.0, units="nondim", do_not_log=.not.CS%use_filter_k1) + call get_param(param_file, mdl, "TIDE_M2_FREQ", om2, & + "Frequency of the M2 tidal constituent. "//& + "This is only used if TIDES and TIDE_M2"// & + " are true, or if OBC_TIDE_N_CONSTITUENTS > 0 and M2"// & + " is in OBC_TIDE_CONSTITUENTS.", units="s-1", default=tidal_frequency("M2"), & + scale=US%T_to_s, do_not_log=.true.) + call get_param(param_file, mdl, "TIDE_K1_FREQ", ok1, & + "Frequency of the K1 tidal constituent. "//& + "This is only used if TIDES and TIDE_K1"// & + " are true, or if OBC_TIDE_N_CONSTITUENTS > 0 and K1"// & + " is in OBC_TIDE_CONSTITUENTS.", units="s-1", default=tidal_frequency("K1"), & + scale=US%T_to_s, do_not_log=.true.) + ALLOC_(CS%ubtav(IsdB:IedB,jsd:jed)) ; CS%ubtav(:,:) = 0.0 ALLOC_(CS%vbtav(isd:ied,JsdB:JedB)) ; CS%vbtav(:,:) = 0.0 if (CS%gradual_BT_ICs) then @@ -5287,6 +5339,24 @@ subroutine register_barotropic_restarts(HI, GV, US, param_file, CS, restart_CS) call register_restart_field(CS%dtbt, "DTBT", .false., restart_CS, & longname="Barotropic timestep", units="seconds", conversion=US%T_to_s) + ! Initialize and register streaming filters + if (CS%use_filter_m2) then + if (am2 > 0.0 .and. om2 > 0.0) then + call Filt_register(am2, om2, 'u', HI, CS%Filt_CS_um2) + call Filt_register(am2, om2, 'v', HI, CS%Filt_CS_vm2) + else + CS%use_filter_m2 = .false. + endif + endif + if (CS%use_filter_k1) then + if (ak1 > 0.0 .and. ok1 > 0.0) then + call Filt_register(ak1, ok1, 'u', HI, CS%Filt_CS_uk1) + call Filt_register(ak1, ok1, 'v', HI, CS%Filt_CS_vk1) + else + CS%use_filter_k1 = .false. + endif + endif + end subroutine register_barotropic_restarts !> \namespace mom_barotropic diff --git a/src/parameterizations/lateral/MOM_streaming_filter.F90 b/src/parameterizations/lateral/MOM_streaming_filter.F90 new file mode 100644 index 0000000000..a91f6661f2 --- /dev/null +++ b/src/parameterizations/lateral/MOM_streaming_filter.F90 @@ -0,0 +1,119 @@ +!> Streaming band-pass filter for detecting the instantaneous tidal signals in the simulation +module MOM_streaming_filter + +use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL +use MOM_hor_index, only : hor_index_type +use MOM_time_manager, only : time_type, time_type_to_real +use MOM_unit_scaling, only : unit_scale_type + +implicit none ; private + +public Filt_register, Filt_accum + +#include + +!> The control structure for storing the filter infomation of a particular field +type, public :: Filter_CS ; private + real :: a, & !< Parameter that determines the bandwidth [nondim] + om, & !< Target frequency of the filter [T-1 ~> s-1] + old_time = -1.0 !< The time of the previous accumulating step [T ~> s] + real, allocatable, dimension(:,:) :: s1, & !< Dummy variable [A] + u1 !< Filtered data [A] + !>@{ Lower and upper bounds of input data + integer :: is, ie, js, je + !>@} +end type Filter_CS + +contains + +!> This subroutine registers each of the fields to be filtered. +subroutine Filt_register(a, om, grid, HI, CS) + real, intent(in) :: a !< Parameter that determines the bandwidth [nondim] + real, intent(in) :: om !< Target frequency of the filter [T-1 ~> s-1] + character(len=*), intent(in) :: grid !< Horizontal grid location: h, u, or v + type(hor_index_type), intent(in) :: HI !< Horizontal index type structure + type(Filter_CS), intent(out) :: CS !< Control structure for the current field + + ! Local variables + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + + if (a <= 0.0) call MOM_error(FATAL, "MOM_streaming_filter: bandwidth <= 0") + if (om <= 0.0) call MOM_error(FATAL, "MOM_streaming_filter: target frequency <= 0") + + CS%a = a + CS%om = om + + isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed + IsdB = HI%IsdB ; IedB = HI%IedB ; JsdB = HI%JsdB ; JedB = HI%JedB + + select case (trim(grid)) + case ('h') + allocate(CS%s1(isd:ied,jsd:jed)) ; CS%s1(:,:) = 0.0 + allocate(CS%u1(isd:ied,jsd:jed)) ; CS%u1(:,:) = 0.0 + CS%is = isd ; CS%ie = ied ; CS%js = jsd ; CS%je = jed + case ('u') + allocate(CS%s1(IsdB:IedB,jsd:jed)) ; CS%s1(:,:) = 0.0 + allocate(CS%u1(IsdB:IedB,jsd:jed)) ; CS%u1(:,:) = 0.0 + CS%is = IsdB ; CS%ie = IedB ; CS%js = jsd ; CS%je = jed + case ('v') + allocate(CS%s1(isd:ied,JsdB:JedB)) ; CS%s1(:,:) = 0.0 + allocate(CS%u1(isd:ied,JsdB:JedB)) ; CS%u1(:,:) = 0.0 + CS%is = isd ; CS%ie = ied ; CS%js = JsdB ; CS%je = JedB + case default + call MOM_error(FATAL, "MOM_streaming_filter: horizontal grid not supported") + end select + +end subroutine Filt_register + +!> This subroutine timesteps the filter equations. It takes model output u at the current time step as the input, +!! and returns tidal signal u1 as the output, which is the solution of a set of two ODEs (the filter equations). +subroutine Filt_accum(u, u1, Time, US, CS) + real, dimension(:,:), pointer, intent(out) :: u1 !< Output of the filter [A] + type(time_type), intent(in) :: Time !< The current model time + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(Filter_CS), target, intent(inout) :: CS !< Control structure of the MOM_streaming_filter module + real, dimension(CS%is:CS%ie,CS%js:CS%je), intent(in) :: u !< Input into the filter [A] + + ! Local variables + real :: now, & !< The current model time [T ~> s] + dt, & !< Time step size for the filter equations [T ~> s] + c1, c2 !< Coefficients for the filter equations [nondim] + integer :: i, j, is, ie, js, je + + now = US%s_to_T * time_type_to_real(Time) + is = CS%is ; ie = CS%ie ; js = CS%js ; je = CS%je + + ! Initialize u1 + if (CS%old_time < 0.0) then + CS%old_time = now + CS%u1(:,:) = u(:,:) + endif + + dt = now - CS%old_time + CS%old_time = now + + ! Timestepping + c1 = CS%om * dt + c2 = 1.0 - CS%a * c1 + + do j=js,je ; do i=is,ie + CS%s1(i,j) = c1 * CS%u1(i,j) + CS%s1(i,j) + CS%u1(i,j) = -c1 * (CS%s1(i,j) - CS%a * u(i,j)) + c2 * CS%u1(i,j) + enddo; enddo + u1 => CS%u1 + +end subroutine Filt_accum + +!> \namespace streaming_filter +!! +!! This module detects instantaneous tidal signals in the model output using a set of coupled ODEs (the filter +!! equations), given the target frequency (om) and the bandwidth parameter (a) of the filter. At each timestep, +!! the filter takes model output (u) as the input and returns a time series consisting of sinusoidal motions (u1) +!! near its target frequency. The filtered tidal signals can be used to parameterize frequency-dependent drag, or +!! to detide the model output. See Xu & Zaron (2024) for detail. +!! +!! Reference: Xu, C., & Zaron, E. D. (2024). Detecting instantaneous tidal signals in ocean models utilizing +!! streaming band-pass filters. Journal of Advances in Modeling Earth Systems. Under review. + +end module MOM_streaming_filter + From ffff6f3308f7c1aa9cf6a073eefff40e59ece57d Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 29 Jul 2024 04:33:44 -0400 Subject: [PATCH 3/5] +Optionally use SSH in calculate density for PGF Added the option of including the atmospheric or ice pressure and sea surface height displacements from the global reference height in the pressures used in the density calculations for Boussinesq pressure gradient calculations. Note that the full pressures were already being used everywhere apart from the calculation of the equation of state. This capability is controlled by the new runtime parameter SSH_IN_EOS_PRESSURE_FOR_PGF. This commit changes the Z_0p argument to int_density_dz and 8 other routines (int_density_dz_generic_pcm, int_density_dz_generic_plm, int_density_dz_generic_ppm, analytic_int_density_dz, int_density_dz_wright, int_density_dz_wright_full, int_density_dz_wright_red and int_density_dz_linear) from scalars into 2-d arrays, as were the internal z0pres arrays in most of these routines. By default, all answers are bitwise identical, but there is a new runtime parameter in the MOM_parameter_doc files for Boussinesq cases. --- src/core/MOM_PressureForce_FV.F90 | 32 ++++++++- src/core/MOM_density_integrals.F90 | 66 +++++++++++++------ src/equation_of_state/MOM_EOS.F90 | 3 +- src/equation_of_state/MOM_EOS_Wright.F90 | 21 ++++-- src/equation_of_state/MOM_EOS_Wright_full.F90 | 21 ++++-- src/equation_of_state/MOM_EOS_Wright_red.F90 | 22 +++++-- 6 files changed, 124 insertions(+), 41 deletions(-) diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90 index 9c4f355692..7b970f5686 100644 --- a/src/core/MOM_PressureForce_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -63,6 +63,9 @@ module MOM_PressureForce_FV !! for the finite volume pressure gradient calculation. !! By the default (1) is for a piecewise linear method + logical :: use_SSH_in_Z0p !< If true, adjust the height at which the pressure used in the + !! equation of state is 0 to account for the displacement of the sea + !! surface including adjustments for atmospheric or sea-ice pressure. logical :: use_stanley_pgf !< If true, turn on Stanley parameterization in the PGF integer :: tides_answer_date !< Recover old answers with tides in Boussinesq mode integer :: id_e_tide = -1 !< Diagnostic identifier @@ -522,6 +525,7 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm ! [Z ~> m]. e_tide_sal, & ! The bottom geopotential anomaly due to harmonic self-attraction and loading ! specific to tides [Z ~> m]. + Z_0p, & ! The height at which the pressure used in the equation of state is 0 [Z ~> m] SSH, & ! The sea surface height anomaly, in depth units [Z ~> m]. dM ! The barotropic adjustment to the Montgomery potential to ! account for a reduced gravity model [L2 T-2 ~> m2 s-2]. @@ -577,6 +581,7 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm ! in roundoff and can be neglected [H ~> m]. real :: I_Rho0 ! The inverse of the Boussinesq reference density [R-1 ~> m3 kg-1]. real :: G_Rho0 ! G_Earth / Rho0 in [L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1]. + real :: I_g_rho ! The inverse of the density times the gravitational acceleration [Z T2 L-2 R-1 ~> m Pa-1] real :: rho_ref ! The reference density [R ~> kg m-3]. real :: dz_neglect ! A minimal thickness [Z ~> m], like e. real :: H_to_RL2_T2 ! A factor to convert from thickness units (H) to pressure @@ -753,6 +758,21 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm enddo ; enddo endif + if (CS%use_SSH_in_Z0p .and. use_p_atm) then + I_g_rho = 1.0 / (CS%rho0*GV%g_Earth) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + Z_0p(i,j) = e(i,j,1) + p_atm(i,j) * I_g_rho + enddo ; enddo + elseif (CS%use_SSH_in_Z0p) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + Z_0p(i,j) = e(i,j,1) + enddo ; enddo + else + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + Z_0p(i,j) = G%Z_ref + enddo ; enddo + endif + do k=1,nz ! Calculate 4 integrals through the layer that are required in the ! subsequent calculation. @@ -769,19 +789,19 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm G%HI, GV, tv%eqn_of_state, US, CS%use_stanley_pgf, dpa(:,:,k), intz_dpa(:,:,k), & intx_dpa(:,:,k), inty_dpa(:,:,k), & MassWghtInterp=CS%MassWghtInterp, & - use_inaccurate_form=CS%use_inaccurate_pgf_rho_anom, Z_0p=G%Z_ref) + use_inaccurate_form=CS%use_inaccurate_pgf_rho_anom, Z_0p=Z_0p) elseif ( CS%Recon_Scheme == 2 ) then call int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & rho_ref, CS%Rho0, GV%g_Earth, dz_neglect, G%bathyT, & G%HI, GV, tv%eqn_of_state, US, CS%use_stanley_pgf, dpa(:,:,k), intz_dpa(:,:,k), & intx_dpa(:,:,k), inty_dpa(:,:,k), & - MassWghtInterp=CS%MassWghtInterp, Z_0p=G%Z_ref) + MassWghtInterp=CS%MassWghtInterp, Z_0p=Z_0p) endif else call int_density_dz(tv_tmp%T(:,:,k), tv_tmp%S(:,:,k), e(:,:,K), e(:,:,K+1), & rho_ref, CS%Rho0, GV%g_Earth, G%HI, tv%eqn_of_state, US, dpa(:,:,k), & intz_dpa(:,:,k), intx_dpa(:,:,k), inty_dpa(:,:,k), G%bathyT, dz_neglect, & - CS%MassWghtInterp, Z_0p=G%Z_ref) + CS%MassWghtInterp, Z_0p=Z_0p) endif if (GV%Z_to_H /= 1.0) then !$OMP parallel do default(shared) @@ -1042,6 +1062,12 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, SAL_CSp, endif call get_param(param_file, mdl, "CALCULATE_SAL", CS%calculate_SAL, & "If true, calculate self-attraction and loading.", default=CS%tides) + call get_param(param_file, mdl, "SSH_IN_EOS_PRESSURE_FOR_PGF", CS%use_SSH_in_Z0p, & + "If true, include contributions from the sea surface height in the height-based "//& + "pressure used in the equation of state calculations for the Boussinesq pressure "//& + "gradient forces, including adjustments for atmospheric or sea-ice pressure.", & + default=.false., do_not_log=.not.GV%Boussinesq) + 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. ) diff --git a/src/core/MOM_density_integrals.F90 b/src/core/MOM_density_integrals.F90 index 8d30ba28e3..03d5b6131c 100644 --- a/src/core/MOM_density_integrals.F90 +++ b/src/core/MOM_density_integrals.F90 @@ -80,7 +80,8 @@ subroutine int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, US, dpa, real, optional, intent(in) :: dz_neglect !< A minuscule thickness change [Z ~> m] integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use !! mass weighting to interpolate T/S in integrals - real, optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] if (EOS_quadrature(EOS)) then call int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, US, dpa, & @@ -139,7 +140,8 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & !! mass weighting to interpolate T/S in integrals logical, optional, intent(in) :: use_inaccurate_form !< If true, uses an inaccurate form of !! density anomalies, as was used prior to March 2018. - real, optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] ! Local variables real :: T5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Temperatures along a line of subgrid locations [C ~> degC] @@ -157,7 +159,7 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & real :: dz ! The layer thickness [Z ~> m] real :: dz_x(5,HI%iscB:HI%iecB) ! Layer thicknesses along an x-line of subgrid locations [Z ~> m] real :: dz_y(5,HI%isc:HI%iec) ! Layer thicknesses along a y-line of subgrid locations [Z ~> m] - real :: z0pres ! The height at which the pressure is zero [Z ~> m] + real :: z0pres(HI%isd:HI%ied,HI%jsd:HI%jed) ! The height at which the pressure is zero [Z ~> m] real :: hWght ! A pressure-thickness below topography [Z ~> m] real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [Z ~> m] real :: iDenom ! The inverse of the denominator in the weights [Z-2 ~> m-2] @@ -184,7 +186,13 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & GxRho = G_e * rho_0 I_Rho = 1.0 / rho_0 - z0pres = 0.0 ; if (present(Z_0p)) z0pres = Z_0p + if (present(Z_0p)) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + z0pres(i,j) = Z_0p(i,j) + enddo ; enddo + else + z0pres(:,:) = 0.0 + endif use_rho_ref = .true. if (present(use_inaccurate_form)) then if (use_inaccurate_form) use_rho_ref = .not. use_inaccurate_form @@ -209,7 +217,7 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & dz = z_t(i,j) - z_b(i,j) do n=1,5 T5(i*5+n) = T(i,j) ; S5(i*5+n) = S(i,j) - p5(i*5+n) = -GxRho*((z_t(i,j) - z0pres) - 0.25*real(n-1)*dz) + p5(i*5+n) = -GxRho*((z_t(i,j) - z0pres(i,j)) - 0.25*real(n-1)*dz) enddo enddo @@ -260,7 +268,8 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & pos = i*15+(m-2)*5 T15(pos+1) = (wtT_L*T(i,j)) + (wtT_R*T(i+1,j)) S15(pos+1) = (wtT_L*S(i,j)) + (wtT_R*S(i+1,j)) - p15(pos+1) = -GxRho*(((wt_L*z_t(i,j)) + (wt_R*z_t(i+1,j))) - z0pres) + p15(pos+1) = -GxRho * ( ((wt_L*z_t(i,j)) + (wt_R*z_t(i+1,j))) - & + ((wt_L*z0pres(i,j)) + (wt_R*z0pres(i+1,j))) ) do n=2,5 T15(pos+n) = T15(pos+1) ; S15(pos+n) = S15(pos+1) p15(pos+n) = p15(pos+n-1) + GxRho*0.25*dz_x(m,i) @@ -326,7 +335,8 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & pos = i*15+(m-2)*5 T15(pos+1) = (wtT_L*T(i,j)) + (wtT_R*T(i,j+1)) S15(pos+1) = (wtT_L*S(i,j)) + (wtT_R*S(i,j+1)) - p15(pos+1) = -GxRho*(((wt_L*z_t(i,j)) + (wt_R*z_t(i,j+1))) - z0pres) + p15(pos+1) = -GxRho * ( ((wt_L*z_t(i,j)) + (wt_R*z_t(i,j+1))) - & + ((wt_L*z0pres(i,j)) + (wt_R*z0pres(i,j+1))) ) do n=2,5 T15(pos+n) = T15(pos+1) ; S15(pos+n) = S15(pos+1) p15(pos+n) = p15(pos+n-1) + GxRho*0.25*dz_y(m,i) @@ -414,7 +424,8 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & !! mass weighting to interpolate T/S in integrals logical, optional, intent(in) :: use_inaccurate_form !< If true, uses an inaccurate form of !! density anomalies, as was used prior to March 2018. - real, optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] ! This subroutine calculates (by numerical quadrature) integrals of ! pressure anomalies across layers, which are required for calculating the @@ -464,7 +475,7 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & real :: massWeightToggle ! A non-dimensional toggle factor (0 or 1) [nondim] real :: Ttl, Tbl, Ttr, Tbr ! Temperatures at the velocity cell corners [C ~> degC] real :: Stl, Sbl, Str, Sbr ! Salinities at the velocity cell corners [S ~> ppt] - real :: z0pres ! The height at which the pressure is zero [Z ~> m] + real :: z0pres(HI%isd:HI%ied,HI%jsd:HI%jed) ! The height at which the pressure is zero [Z ~> m] real :: hWght ! A topographically limited thickness weight [Z ~> m] real :: hL, hR ! Thicknesses to the left and right [Z ~> m] real :: iDenom ! The denominator of the thickness weight expressions [Z-2 ~> m-2] @@ -480,7 +491,13 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & GxRho = G_e * rho_0 I_Rho = 1.0 / rho_0 - z0pres = 0.0 ; if (present(Z_0p)) z0pres = Z_0p + if (present(Z_0p)) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + z0pres(i,j) = Z_0p(i,j) + enddo ; enddo + else + z0pres(:,:) = 0.0 + endif massWeightToggle = 0. if (present(MassWghtInterp)) then ; if (BTEST(MassWghtInterp, 0)) massWeightToggle = 1. ; endif use_rho_ref = .true. @@ -517,7 +534,7 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & do i = Isq,Ieq+1 dz(i) = e(i,j,K) - e(i,j,K+1) do n=1,5 - p5(i*5+n) = -GxRho*((e(i,j,K) - z0pres) - 0.25*real(n-1)*dz(i)) + p5(i*5+n) = -GxRho*((e(i,j,K) - z0pres(i,j)) - 0.25*real(n-1)*dz(i)) ! Salinity and temperature points are linearly interpolated S5(i*5+n) = wt_t(n) * S_t(i,j,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) @@ -610,7 +627,8 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & S15(pos+1) = (w_left*Stl) + (w_right*Str) S15(pos+5) = (w_left*Sbl) + (w_right*Sbr) - p15(pos+1) = -GxRho*(((w_left*e(i,j,K)) + (w_right*e(i+1,j,K))) - z0pres) + p15(pos+1) = -GxRho * ( ((w_left*e(i,j,K)) + (w_right*e(i+1,j,K))) - & + ((w_left*z0pres(i,j)) + (w_right*z0pres(i+1,j))) ) ! Pressure do n=2,5 @@ -706,7 +724,8 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & S15(pos+1) = (w_left*Stl) + (w_right*Str) S15(pos+5) = (w_left*Sbl) + (w_right*Sbr) - p15(pos+1) = -GxRho*(((w_left*e(i,j,K)) + (w_right*e(i,j+1,K))) - z0pres) + p15(pos+1) = -GxRho * ( ((w_left*e(i,j,K)) + (w_right*e(i,j+1,K))) - & + ((w_left*z0pres(i,j)) + (w_right*z0pres(i,j+1))) ) ! Pressure do n=2,5 @@ -812,7 +831,8 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & !! divided by the y grid spacing [R L2 T-2 ~> Pa] integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use !! mass weighting to interpolate T/S in integrals - real, optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] ! This subroutine calculates (by numerical quadrature) integrals of ! pressure anomalies across layers, which are required for calculating the @@ -864,7 +884,7 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & real :: t6 ! PPM curvature coefficient for T [C ~> degC] real :: T_top, T_mn, T_bot ! Left edge, cell mean and right edge values used in PPM reconstructions of T [C ~> degC] real :: S_top, S_mn, S_bot ! Left edge, cell mean and right edge values used in PPM reconstructions of S [S ~> ppt] - real :: z0pres ! The height at which the pressure is zero [Z ~> m] + real :: z0pres(HI%isd:HI%ied,HI%jsd:HI%jed) ! The height at which the pressure is zero [Z ~> m] real :: hWght ! A topographically limited thickness weight [Z ~> m] real :: hL, hR ! Thicknesses to the left and right [Z ~> m] real :: iDenom ! The denominator of the thickness weight expressions [Z-2 ~> m-2] @@ -879,7 +899,13 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & GxRho = G_e * rho_0 I_Rho = 1.0 / rho_0 - z0pres = 0.0 ; if (present(Z_0p)) z0pres = Z_0p + if (present(Z_0p)) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + z0pres(i,j) = Z_0p(i,j) + enddo ; enddo + else + z0pres(:,:) = 0.0 + endif massWeightToggle = 0. if (present(MassWghtInterp)) then ; if (BTEST(MassWghtInterp, 0)) massWeightToggle = 1. ; endif @@ -924,7 +950,7 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & endif dz = e(i,j,K) - e(i,j,K+1) do n=1,5 - p5(I*5+n) = -GxRho*((e(i,j,K) - z0pres) - 0.25*real(n-1)*dz) + p5(I*5+n) = -GxRho*((e(i,j,K) - z0pres(i,j)) - 0.25*real(n-1)*dz) ! Salinity and temperature points are reconstructed with PPM S5(I*5+n) = wt_t(n) * S_t(i,j,k) + wt_b(n) * ( S_b(i,j,k) + s6 * wt_t(n) ) T5(I*5+n) = wt_t(n) * T_t(i,j,k) + wt_b(n) * ( T_b(i,j,k) + t6 * wt_t(n) ) @@ -1011,7 +1037,8 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & 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))) pos = i*15+(m-2)*5 - p15(pos+1) = -GxRho*(((w_left*e(i,j,K)) + (w_right*e(i+1,j,K))) - z0pres) + p15(pos+1) = -GxRho * ( ((w_left*e(i,j,K)) + (w_right*e(i+1,j,K))) - & + ((w_left*z0pres(i,j)) + (w_right*z0pres(i+1,j))) ) do n=2,5 p15(pos+n) = p15(pos+n-1) + GxRho*0.25*dz_x(m,i) enddo @@ -1116,7 +1143,8 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & 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))) pos = i*15+(m-2)*5 - p15(pos+1) = -GxRho*(((w_left*e(i,j,K)) + (w_right*e(i,j+1,K))) - z0pres) + p15(pos+1) = -GxRho * ( ((w_left*e(i,j,K)) + (w_right*e(i,j+1,K))) - & + ((w_left*z0pres(i,j)) + (w_right*z0pres(i,j+1))) ) do n=2,5 p15(pos+n) = p15(pos+n-1) + GxRho*0.25*dz_y(m,i) enddo diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index a66b53656c..74f540f64f 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -1345,7 +1345,8 @@ subroutine analytic_int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, real, optional, intent(in) :: dz_neglect !< A miniscule thickness change [Z ~> m] integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use !! mass weighting to interpolate T/S in integrals - real, optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] ! Local variables real :: rho_scale ! A multiplicative factor by which to scale density from kg m-3 to the diff --git a/src/equation_of_state/MOM_EOS_Wright.F90 b/src/equation_of_state/MOM_EOS_Wright.F90 index f1893ae80f..6fbff16f11 100644 --- a/src/equation_of_state/MOM_EOS_Wright.F90 +++ b/src/equation_of_state/MOM_EOS_Wright.F90 @@ -435,12 +435,14 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & !! temperature into degC [degC C-1 ~> 1] real, optional, intent(in) :: saln_scale !< A multiplicative factor to convert pressure !! into PSU [PSU S-1 ~> 1]. - real, optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] ! Local variables real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: al0_2d ! A term in the Wright EOS [m3 kg-1] real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: p0_2d ! A term in the Wright EOS [Pa] real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: lambda_2d ! A term in the Wright EOS [m2 s-2] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: z0pres ! The height at which the pressure is zero [Z ~> m] real :: al0 ! A term in the Wright EOS [m3 kg-1] real :: p0 ! A term in the Wright EOS [Pa] real :: lambda ! A term in the Wright EOS [m2 s-2] @@ -466,7 +468,6 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & ! with height at the 5 sub-column locations [R L2 T-2 ~> Pa]. real :: Pa_to_RL2_T2 ! A conversion factor of pressures from Pa to the output units indicated by ! pres_scale [R L2 T-2 Pa-1 ~> 1]. - real :: z0pres ! The height at which the pressure is zero [Z ~> m] real :: a1s ! Partly rescaled version of a1 [m3 kg-1 C-1 ~> m3 kg-1 degC-1] real :: a2s ! Partly rescaled version of a2 [m3 kg-1 S-1 ~> m3 kg-1 PSU-1] real :: b1s ! Partly rescaled version of b1 [Pa C-1 ~> Pa degC-1] @@ -504,7 +505,13 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & else rho_ref_mks = rho_ref ; I_Rho = 1.0 / rho_0 endif - z0pres = 0.0 ; if (present(Z_0p)) z0pres = Z_0p + if (present(Z_0p)) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + z0pres(i,j) = Z_0p(i,j) + enddo ; enddo + else + z0pres(:,:) = 0.0 + endif a1s = a1 ; a2s = a2 b1s = b1 ; b2s = b2 ; b3s = b3 ; b4s = b4 ; b5s = b5 @@ -541,7 +548,7 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & al0 = al0_2d(i,j) ; p0 = p0_2d(i,j) ; lambda = lambda_2d(i,j) dz = z_t(i,j) - z_b(i,j) - p_ave = -GxRho*(0.5*(z_t(i,j)+z_b(i,j)) - z0pres) + p_ave = -GxRho*(0.5*(z_t(i,j)+z_b(i,j)) - z0pres(i,j)) I_al0 = 1.0 / al0 I_Lzz = 1.0 / (p0 + (lambda * I_al0) + p_ave) @@ -585,7 +592,8 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & lambda = (wtT_L*lambda_2d(i,j)) + (wtT_R*lambda_2d(i+1,j)) dz = (wt_L*(z_t(i,j) - z_b(i,j))) + (wt_R*(z_t(i+1,j) - z_b(i+1,j))) - p_ave = -GxRho*(0.5*((wt_L*(z_t(i,j)+z_b(i,j))) + (wt_R*(z_t(i+1,j)+z_b(i+1,j)))) - z0pres) + p_ave = -GxRho*(0.5*((wt_L*(z_t(i,j)+z_b(i,j))) + (wt_R*(z_t(i+1,j)+z_b(i+1,j)))) - & + ((wt_L*z0pres(i,j)) + (wt_R*z0pres(i+1,j)))) I_al0 = 1.0 / al0 I_Lzz = 1.0 / (p0 + (lambda * I_al0) + p_ave) @@ -626,7 +634,8 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & lambda = (wtT_L*lambda_2d(i,j)) + (wtT_R*lambda_2d(i,j+1)) dz = (wt_L*(z_t(i,j) - z_b(i,j))) + (wt_R*(z_t(i,j+1) - z_b(i,j+1))) - p_ave = -GxRho*(0.5*((wt_L*(z_t(i,j)+z_b(i,j))) + (wt_R*(z_t(i,j+1)+z_b(i,j+1)))) - z0pres) + p_ave = -GxRho*(0.5*((wt_L*(z_t(i,j)+z_b(i,j))) + (wt_R*(z_t(i,j+1)+z_b(i,j+1)))) - & + ((wt_L*z0pres(i,j)) + (wt_R*z0pres(i,j+1)))) I_al0 = 1.0 / al0 I_Lzz = 1.0 / (p0 + (lambda * I_al0) + p_ave) diff --git a/src/equation_of_state/MOM_EOS_Wright_full.F90 b/src/equation_of_state/MOM_EOS_Wright_full.F90 index 576f390c70..1f03c1f4aa 100644 --- a/src/equation_of_state/MOM_EOS_Wright_full.F90 +++ b/src/equation_of_state/MOM_EOS_Wright_full.F90 @@ -441,12 +441,14 @@ subroutine int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & !! temperature into degC [degC C-1 ~> 1] real, optional, intent(in) :: saln_scale !< A multiplicative factor to convert pressure !! into PSU [PSU S-1 ~> 1]. - real, optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] ! Local variables real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: al0_2d ! A term in the Wright EOS [m3 kg-1] real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: p0_2d ! A term in the Wright EOS [Pa] real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: lambda_2d ! A term in the Wright EOS [m2 s-2] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: z0pres ! The height at which the pressure is zero [Z ~> m] real :: al0 ! A term in the Wright EOS [m3 kg-1] real :: p0 ! A term in the Wright EOS [Pa] real :: lambda ! A term in the Wright EOS [m2 s-2] @@ -472,7 +474,6 @@ subroutine int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & ! with height at the 5 sub-column locations [R L2 T-2 ~> Pa]. real :: Pa_to_RL2_T2 ! A conversion factor of pressures from Pa to the output units indicated by ! pres_scale [R L2 T-2 Pa-1 ~> 1]. - real :: z0pres ! The height at which the pressure is zero [Z ~> m] real :: a1s ! Partly rescaled version of a1 [m3 kg-1 C-1 ~> m3 kg-1 degC-1] real :: a2s ! Partly rescaled version of a2 [m3 kg-1 S-1 ~> m3 kg-1 PSU-1] real :: b1s ! Partly rescaled version of b1 [Pa C-1 ~> Pa degC-1] @@ -510,7 +511,13 @@ subroutine int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & else rho_ref_mks = rho_ref ; I_Rho = 1.0 / rho_0 endif - z0pres = 0.0 ; if (present(Z_0p)) z0pres = Z_0p + if (present(Z_0p)) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + z0pres(i,j) = Z_0p(i,j) + enddo ; enddo + else + z0pres(:,:) = 0.0 + endif a1s = a1 ; a2s = a2 b1s = b1 ; b2s = b2 ; b3s = b3 ; b4s = b4 ; b5s = b5 @@ -547,7 +554,7 @@ subroutine int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & al0 = al0_2d(i,j) ; p0 = p0_2d(i,j) ; lambda = lambda_2d(i,j) dz = z_t(i,j) - z_b(i,j) - p_ave = -GxRho*(0.5*(z_t(i,j)+z_b(i,j)) - z0pres) + p_ave = -GxRho*(0.5*(z_t(i,j)+z_b(i,j)) - z0pres(i,j)) I_al0 = 1.0 / al0 I_Lzz = 1.0 / ((p0 + p_ave) + lambda * I_al0) @@ -590,7 +597,8 @@ subroutine int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & lambda = (wtT_L*lambda_2d(i,j)) + (wtT_R*lambda_2d(i+1,j)) dz = (wt_L*(z_t(i,j) - z_b(i,j))) + (wt_R*(z_t(i+1,j) - z_b(i+1,j))) - p_ave = -GxRho*(0.5*((wt_L*(z_t(i,j)+z_b(i,j))) + (wt_R*(z_t(i+1,j)+z_b(i+1,j)))) - z0pres) + p_ave = -GxRho*(0.5*((wt_L*(z_t(i,j)+z_b(i,j))) + (wt_R*(z_t(i+1,j)+z_b(i+1,j)))) - & + ((wt_L*z0pres(i,j)) + (wt_R*z0pres(i+1,j)))) I_al0 = 1.0 / al0 I_Lzz = 1.0 / ((p0 + p_ave) + lambda * I_al0) @@ -631,7 +639,8 @@ subroutine int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & lambda = (wtT_L*lambda_2d(i,j)) + (wtT_R*lambda_2d(i,j+1)) dz = (wt_L*(z_t(i,j) - z_b(i,j))) + (wt_R*(z_t(i,j+1) - z_b(i,j+1))) - p_ave = -GxRho*(0.5*((wt_L*(z_t(i,j)+z_b(i,j))) + (wt_R*(z_t(i,j+1)+z_b(i,j+1)))) - z0pres) + p_ave = -GxRho*(0.5*((wt_L*(z_t(i,j)+z_b(i,j))) + (wt_R*(z_t(i,j+1)+z_b(i,j+1)))) - & + ((wt_L*z0pres(i,j)) + (wt_R*z0pres(i,j+1)))) I_al0 = 1.0 / al0 I_Lzz = 1.0 / ((p0 + p_ave) + lambda * I_al0) diff --git a/src/equation_of_state/MOM_EOS_Wright_red.F90 b/src/equation_of_state/MOM_EOS_Wright_red.F90 index 58a9e2bce1..d46707e911 100644 --- a/src/equation_of_state/MOM_EOS_Wright_red.F90 +++ b/src/equation_of_state/MOM_EOS_Wright_red.F90 @@ -443,12 +443,14 @@ subroutine int_density_dz_wright_red(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & !! temperature into degC [degC C-1 ~> 1] real, optional, intent(in) :: saln_scale !< A multiplicative factor to convert pressure !! into PSU [PSU S-1 ~> 1]. - real, optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] ! Local variables real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: al0_2d ! A term in the Wright EOS [m3 kg-1] real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: p0_2d ! A term in the Wright EOS [Pa] real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: lambda_2d ! A term in the Wright EOS [m2 s-2] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: z0pres ! The height at which the pressure is zero [Z ~> m] real :: al0 ! A term in the Wright EOS [m3 kg-1] real :: p0 ! A term in the Wright EOS [Pa] real :: lambda ! A term in the Wright EOS [m2 s-2] @@ -474,7 +476,6 @@ subroutine int_density_dz_wright_red(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & ! with height at the 5 sub-column locations [R L2 T-2 ~> Pa]. real :: Pa_to_RL2_T2 ! A conversion factor of pressures from Pa to the output units indicated by ! pres_scale [R L2 T-2 Pa-1 ~> 1]. - real :: z0pres ! The height at which the pressure is zero [Z ~> m] real :: a1s ! Partly rescaled version of a1 [m3 kg-1 C-1 ~> m3 kg-1 degC-1] real :: a2s ! Partly rescaled version of a2 [m3 kg-1 S-1 ~> m3 kg-1 PSU-1] real :: b1s ! Partly rescaled version of b1 [Pa C-1 ~> Pa degC-1] @@ -512,7 +513,13 @@ subroutine int_density_dz_wright_red(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & else rho_ref_mks = rho_ref ; I_Rho = 1.0 / rho_0 endif - z0pres = 0.0 ; if (present(Z_0p)) z0pres = Z_0p + if (present(Z_0p)) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + z0pres(i,j) = Z_0p(i,j) + enddo ; enddo + else + z0pres(:,:) = 0.0 + endif a1s = a1 ; a2s = a2 b1s = b1 ; b2s = b2 ; b3s = b3 ; b4s = b4 ; b5s = b5 @@ -549,7 +556,7 @@ subroutine int_density_dz_wright_red(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & al0 = al0_2d(i,j) ; p0 = p0_2d(i,j) ; lambda = lambda_2d(i,j) dz = z_t(i,j) - z_b(i,j) - p_ave = -GxRho*(0.5*(z_t(i,j)+z_b(i,j)) - z0pres) + p_ave = -GxRho*(0.5*(z_t(i,j)+z_b(i,j)) - z0pres(i,j)) I_al0 = 1.0 / al0 I_Lzz = 1.0 / ((p0 + p_ave) + lambda * I_al0) @@ -592,7 +599,8 @@ subroutine int_density_dz_wright_red(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & lambda = (wtT_L*lambda_2d(i,j)) + (wtT_R*lambda_2d(i+1,j)) dz = (wt_L*(z_t(i,j) - z_b(i,j))) + (wt_R*(z_t(i+1,j) - z_b(i+1,j))) - p_ave = -GxRho*(0.5*((wt_L*(z_t(i,j)+z_b(i,j))) + (wt_R*(z_t(i+1,j)+z_b(i+1,j)))) - z0pres) + p_ave = -GxRho*(0.5*((wt_L*(z_t(i,j)+z_b(i,j))) + (wt_R*(z_t(i+1,j)+z_b(i+1,j)))) - & + ((wt_L*z0pres(i,j)) + (wt_R*z0pres(i+1,j)))) I_al0 = 1.0 / al0 I_Lzz = 1.0 / ((p0 + p_ave) + lambda * I_al0) @@ -633,7 +641,9 @@ subroutine int_density_dz_wright_red(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & lambda = (wtT_L*lambda_2d(i,j)) + (wtT_R*lambda_2d(i,j+1)) dz = (wt_L*(z_t(i,j) - z_b(i,j))) + (wt_R*(z_t(i,j+1) - z_b(i,j+1))) - p_ave = -GxRho*(0.5*((wt_L*(z_t(i,j)+z_b(i,j))) + (wt_R*(z_t(i,j+1)+z_b(i,j+1)))) - z0pres) + p_ave = -GxRho*(0.5*((wt_L*(z_t(i,j)+z_b(i,j))) + (wt_R*(z_t(i,j+1)+z_b(i,j+1)))) - & + ((wt_L*z0pres(i,j)) + (wt_R*z0pres(i,j+1)))) + I_al0 = 1.0 / al0 I_Lzz = 1.0 / ((p0 + p_ave) + lambda * I_al0) From 9b9c165500e2742741a82a52fd69762647ea5303 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 7 Sep 2024 13:53:55 -0400 Subject: [PATCH 4/5] (*)Refactor p_ave calculation Rearranged the calculation of the layer average pressure used in the density integrals to have one less multiply and be clearer to read. This could change answers at roundoff if REFERENCE_HEIGHT is nonzero (it is 0 by default and in all known cases) or if SSH_IN_EOS_PRESSURE_FOR_PGF is set to true. Because the former is mostly used for approximate self-consistency testing and the latter option has just been added, it is unlikely that answers will change for any production runs. --- src/core/MOM_density_integrals.F90 | 18 ++++++------------ src/equation_of_state/MOM_EOS_Wright.F90 | 8 ++++---- src/equation_of_state/MOM_EOS_Wright_full.F90 | 8 ++++---- src/equation_of_state/MOM_EOS_Wright_red.F90 | 9 ++++----- 4 files changed, 18 insertions(+), 25 deletions(-) diff --git a/src/core/MOM_density_integrals.F90 b/src/core/MOM_density_integrals.F90 index 03d5b6131c..8b820594aa 100644 --- a/src/core/MOM_density_integrals.F90 +++ b/src/core/MOM_density_integrals.F90 @@ -268,8 +268,7 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & pos = i*15+(m-2)*5 T15(pos+1) = (wtT_L*T(i,j)) + (wtT_R*T(i+1,j)) S15(pos+1) = (wtT_L*S(i,j)) + (wtT_R*S(i+1,j)) - p15(pos+1) = -GxRho * ( ((wt_L*z_t(i,j)) + (wt_R*z_t(i+1,j))) - & - ((wt_L*z0pres(i,j)) + (wt_R*z0pres(i+1,j))) ) + p15(pos+1) = -GxRho * ((wt_L*(z_t(i,j)-z0pres(i,j))) + (wt_R*(z_t(i+1,j)-z0pres(i+1,j)))) do n=2,5 T15(pos+n) = T15(pos+1) ; S15(pos+n) = S15(pos+1) p15(pos+n) = p15(pos+n-1) + GxRho*0.25*dz_x(m,i) @@ -335,8 +334,7 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & pos = i*15+(m-2)*5 T15(pos+1) = (wtT_L*T(i,j)) + (wtT_R*T(i,j+1)) S15(pos+1) = (wtT_L*S(i,j)) + (wtT_R*S(i,j+1)) - p15(pos+1) = -GxRho * ( ((wt_L*z_t(i,j)) + (wt_R*z_t(i,j+1))) - & - ((wt_L*z0pres(i,j)) + (wt_R*z0pres(i,j+1))) ) + p15(pos+1) = -GxRho * ((wt_L*(z_t(i,j)-z0pres(i,j))) + (wt_R*(z_t(i,j+1)-z0pres(i,j+1)))) do n=2,5 T15(pos+n) = T15(pos+1) ; S15(pos+n) = S15(pos+1) p15(pos+n) = p15(pos+n-1) + GxRho*0.25*dz_y(m,i) @@ -627,8 +625,7 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & 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))) - & - ((w_left*z0pres(i,j)) + (w_right*z0pres(i+1,j))) ) + p15(pos+1) = -GxRho * ((w_left*(e(i,j,K)-z0pres(i,j))) + (w_right*(e(i+1,j,K)-z0pres(i+1,j)))) ! Pressure do n=2,5 @@ -724,8 +721,7 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & 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))) - & - ((w_left*z0pres(i,j)) + (w_right*z0pres(i,j+1))) ) + p15(pos+1) = -GxRho * ((w_left*(e(i,j,K)-z0pres(i,j))) + (w_right*(e(i,j+1,K)-z0pres(i,j+1)))) ! Pressure do n=2,5 @@ -1037,8 +1033,7 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & 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))) pos = i*15+(m-2)*5 - p15(pos+1) = -GxRho * ( ((w_left*e(i,j,K)) + (w_right*e(i+1,j,K))) - & - ((w_left*z0pres(i,j)) + (w_right*z0pres(i+1,j))) ) + p15(pos+1) = -GxRho * ((w_left*(e(i,j,K)-z0pres(i,j))) + (w_right*(e(i+1,j,K)-z0pres(i+1,j)))) do n=2,5 p15(pos+n) = p15(pos+n-1) + GxRho*0.25*dz_x(m,i) enddo @@ -1143,8 +1138,7 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & 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))) pos = i*15+(m-2)*5 - p15(pos+1) = -GxRho * ( ((w_left*e(i,j,K)) + (w_right*e(i,j+1,K))) - & - ((w_left*z0pres(i,j)) + (w_right*z0pres(i,j+1))) ) + p15(pos+1) = -GxRho * ((w_left*(e(i,j,K)-z0pres(i,j))) + (w_right*(e(i,j+1,K)-z0pres(i,j+1)))) do n=2,5 p15(pos+n) = p15(pos+n-1) + GxRho*0.25*dz_y(m,i) enddo diff --git a/src/equation_of_state/MOM_EOS_Wright.F90 b/src/equation_of_state/MOM_EOS_Wright.F90 index 6fbff16f11..11fa57644d 100644 --- a/src/equation_of_state/MOM_EOS_Wright.F90 +++ b/src/equation_of_state/MOM_EOS_Wright.F90 @@ -592,8 +592,8 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & lambda = (wtT_L*lambda_2d(i,j)) + (wtT_R*lambda_2d(i+1,j)) dz = (wt_L*(z_t(i,j) - z_b(i,j))) + (wt_R*(z_t(i+1,j) - z_b(i+1,j))) - p_ave = -GxRho*(0.5*((wt_L*(z_t(i,j)+z_b(i,j))) + (wt_R*(z_t(i+1,j)+z_b(i+1,j)))) - & - ((wt_L*z0pres(i,j)) + (wt_R*z0pres(i+1,j)))) + p_ave = -GxRho*((wt_L * (0.5*(z_t(i,j)+z_b(i,j)) - z0pres(i,j))) + & + (wt_R * (0.5*(z_t(i+1,j)+z_b(i+1,j)) - z0pres(i+1,j)))) I_al0 = 1.0 / al0 I_Lzz = 1.0 / (p0 + (lambda * I_al0) + p_ave) @@ -634,8 +634,8 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & lambda = (wtT_L*lambda_2d(i,j)) + (wtT_R*lambda_2d(i,j+1)) dz = (wt_L*(z_t(i,j) - z_b(i,j))) + (wt_R*(z_t(i,j+1) - z_b(i,j+1))) - p_ave = -GxRho*(0.5*((wt_L*(z_t(i,j)+z_b(i,j))) + (wt_R*(z_t(i,j+1)+z_b(i,j+1)))) - & - ((wt_L*z0pres(i,j)) + (wt_R*z0pres(i,j+1)))) + p_ave = -GxRho*((wt_L*(0.5*(z_t(i,j)+z_b(i,j))-z0pres(i,j))) + & + (wt_R*(0.5*(z_t(i,j+1)+z_b(i,j+1))-z0pres(i,j+1)))) I_al0 = 1.0 / al0 I_Lzz = 1.0 / (p0 + (lambda * I_al0) + p_ave) diff --git a/src/equation_of_state/MOM_EOS_Wright_full.F90 b/src/equation_of_state/MOM_EOS_Wright_full.F90 index 1f03c1f4aa..6dba8444dd 100644 --- a/src/equation_of_state/MOM_EOS_Wright_full.F90 +++ b/src/equation_of_state/MOM_EOS_Wright_full.F90 @@ -597,8 +597,8 @@ subroutine int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & lambda = (wtT_L*lambda_2d(i,j)) + (wtT_R*lambda_2d(i+1,j)) dz = (wt_L*(z_t(i,j) - z_b(i,j))) + (wt_R*(z_t(i+1,j) - z_b(i+1,j))) - p_ave = -GxRho*(0.5*((wt_L*(z_t(i,j)+z_b(i,j))) + (wt_R*(z_t(i+1,j)+z_b(i+1,j)))) - & - ((wt_L*z0pres(i,j)) + (wt_R*z0pres(i+1,j)))) + p_ave = -GxRho*((wt_L * (0.5*(z_t(i,j)+z_b(i,j)) - z0pres(i,j))) + & + (wt_R * (0.5*(z_t(i+1,j)+z_b(i+1,j)) - z0pres(i+1,j)))) I_al0 = 1.0 / al0 I_Lzz = 1.0 / ((p0 + p_ave) + lambda * I_al0) @@ -639,8 +639,8 @@ subroutine int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & lambda = (wtT_L*lambda_2d(i,j)) + (wtT_R*lambda_2d(i,j+1)) dz = (wt_L*(z_t(i,j) - z_b(i,j))) + (wt_R*(z_t(i,j+1) - z_b(i,j+1))) - p_ave = -GxRho*(0.5*((wt_L*(z_t(i,j)+z_b(i,j))) + (wt_R*(z_t(i,j+1)+z_b(i,j+1)))) - & - ((wt_L*z0pres(i,j)) + (wt_R*z0pres(i,j+1)))) + p_ave = -GxRho*((wt_L*(0.5*(z_t(i,j)+z_b(i,j))-z0pres(i,j))) + & + (wt_R*(0.5*(z_t(i,j+1)+z_b(i,j+1))-z0pres(i,j+1)))) I_al0 = 1.0 / al0 I_Lzz = 1.0 / ((p0 + p_ave) + lambda * I_al0) diff --git a/src/equation_of_state/MOM_EOS_Wright_red.F90 b/src/equation_of_state/MOM_EOS_Wright_red.F90 index d46707e911..87d6a16dba 100644 --- a/src/equation_of_state/MOM_EOS_Wright_red.F90 +++ b/src/equation_of_state/MOM_EOS_Wright_red.F90 @@ -599,8 +599,8 @@ subroutine int_density_dz_wright_red(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & lambda = (wtT_L*lambda_2d(i,j)) + (wtT_R*lambda_2d(i+1,j)) dz = (wt_L*(z_t(i,j) - z_b(i,j))) + (wt_R*(z_t(i+1,j) - z_b(i+1,j))) - p_ave = -GxRho*(0.5*((wt_L*(z_t(i,j)+z_b(i,j))) + (wt_R*(z_t(i+1,j)+z_b(i+1,j)))) - & - ((wt_L*z0pres(i,j)) + (wt_R*z0pres(i+1,j)))) + p_ave = -GxRho*((wt_L * (0.5*(z_t(i,j)+z_b(i,j)) - z0pres(i,j))) + & + (wt_R * (0.5*(z_t(i+1,j)+z_b(i+1,j)) - z0pres(i+1,j)))) I_al0 = 1.0 / al0 I_Lzz = 1.0 / ((p0 + p_ave) + lambda * I_al0) @@ -641,9 +641,8 @@ subroutine int_density_dz_wright_red(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & lambda = (wtT_L*lambda_2d(i,j)) + (wtT_R*lambda_2d(i,j+1)) dz = (wt_L*(z_t(i,j) - z_b(i,j))) + (wt_R*(z_t(i,j+1) - z_b(i,j+1))) - p_ave = -GxRho*(0.5*((wt_L*(z_t(i,j)+z_b(i,j))) + (wt_R*(z_t(i,j+1)+z_b(i,j+1)))) - & - ((wt_L*z0pres(i,j)) + (wt_R*z0pres(i,j+1)))) - + p_ave = -GxRho*((wt_L*(0.5*(z_t(i,j)+z_b(i,j))-z0pres(i,j))) + & + (wt_R*(0.5*(z_t(i,j+1)+z_b(i,j+1))-z0pres(i,j+1)))) I_al0 = 1.0 / al0 I_Lzz = 1.0 / ((p0 + p_ave) + lambda * I_al0) From 5fc90ebcf25ce99693e4805f64978c18c69d36d3 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 17 Aug 2024 06:58:47 -0400 Subject: [PATCH 5/5] Rotate ice shelf forcing and initialization Added the ability to rotate the ice shelf forcing and initialization. The specific changes include correcting the grid passed to a call to initialize_ice_shelf in initialize_MOM, using a temporary mech_forcing type in add_shelf_forces when the grid is rotated, uncommenting and correcting the draft rotate_index code in initialize_ice_shelf, and correcting some error-checking and the grid passed to add_shelf_fluxes in initialize_ice_shelf_forces. In addition, unused hor_index_type elements were removed from the ice_shelf_CS, and some callTree calls were added to save_MOM_restart and initialize_ice_shelf. Without rotation, all answers are bitwise identical, but some cases that would have failed previously will now work. --- src/core/MOM.F90 | 11 ++- src/ice_shelf/MOM_ice_shelf.F90 | 158 +++++++++++++++++--------------- 2 files changed, 92 insertions(+), 77 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 2f5ac6e489..47971029cc 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2955,20 +2955,20 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & ! These arrays are not initialized in most solo cases, but are needed ! when using an ice shelf. Passing the ice shelf diagnostics CS from MOM ! for legacy reasons. The actual ice shelf diag CS is internal to the ice shelf - call initialize_ice_shelf(param_file, G_in, Time, ice_shelf_CSp, diag_ptr, & + call initialize_ice_shelf(param_file, G, Time, ice_shelf_CSp, diag_ptr, & Time_init, dirs%output_directory, calve_ice_shelf_bergs=point_calving) allocate(frac_shelf_in(G_in%isd:G_in%ied, G_in%jsd:G_in%jed), source=0.0) allocate(mass_shelf_in(G_in%isd:G_in%ied, G_in%jsd:G_in%jed), source=0.0) allocate(CS%frac_shelf_h(isd:ied, jsd:jed), source=0.0) allocate(CS%mass_shelf(isd:ied, jsd:jed), source=0.0) - call ice_shelf_query(ice_shelf_CSp,G,CS%frac_shelf_h, CS%mass_shelf) + call ice_shelf_query(ice_shelf_CSp, G, CS%frac_shelf_h, CS%mass_shelf) ! MOM_initialize_state is using the unrotated metric call rotate_array(CS%frac_shelf_h, -turns, frac_shelf_in) call rotate_array(CS%mass_shelf, -turns, mass_shelf_in) call MOM_initialize_state(u_in, v_in, h_in, CS%tv, Time, G_in, GV, US, & param_file, dirs, restart_CSp, CS%ALE_CSp, CS%tracer_Reg, & sponge_in_CSp, ALE_sponge_in_CSp, oda_incupd_in_CSp, OBC_in, Time_in, & - frac_shelf_h=frac_shelf_in, mass_shelf = mass_shelf_in) + frac_shelf_h=frac_shelf_in, mass_shelf=mass_shelf_in) else call MOM_initialize_state(u_in, v_in, h_in, CS%tv, Time, G_in, GV, US, & param_file, dirs, restart_CSp, CS%ALE_CSp, CS%tracer_Reg, & @@ -4173,9 +4173,14 @@ subroutine save_MOM_restart(CS, directory, time, G, time_stamped, filename, & logical, optional, intent(in) :: write_IC !< If present and true, initial conditions are being written + logical :: showCallTree + showCallTree = callTree_showQuery() + + if (showCallTree) call callTree_waypoint("About to call save_restart (step_MOM)") call save_restart(directory, time, G, CS%restart_CS, & time_stamped=time_stamped, filename=filename, GV=GV, & num_rest_files=num_rest_files, write_IC=write_IC) + if (showCallTree) call callTree_waypoint("Done with call to save_restart (step_MOM)") if (CS%use_particles) call particles_save_restart(CS%particles, CS%h, directory, time, time_stamped) end subroutine save_MOM_restart diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index eb021d8ffb..4f811cac87 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -24,6 +24,8 @@ module MOM_ice_shelf use MOM_domains, only : TO_ALL, CGRID_NE, BGRID_NE, CORNER use MOM_dyn_horgrid, only : dyn_horgrid_type, create_dyn_horgrid, destroy_dyn_horgrid use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe +use MOM_error_handler, only : callTree_showQuery +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_grid, only : MOM_grid_init, ocean_grid_type use MOM_grid_initialize, only : set_grid_metrics @@ -39,12 +41,12 @@ module MOM_ice_shelf use MOM_restart, only : restart_init, restore_state, MOM_restart_CS, register_restart_pair use MOM_time_manager, only : time_type, time_type_to_real, real_to_time, operator(>), operator(-) use MOM_transcribe_grid, only : copy_dyngrid_to_MOM_grid, copy_MOM_grid_to_dyngrid -use MOM_transcribe_grid, only : rotate_dyngrid +use MOM_transcribe_grid, only : rotate_dyngrid use MOM_unit_scaling, only : unit_scale_type, unit_scaling_init, fix_restart_unit_scaling use MOM_variables, only : surface, allocate_surface_state, deallocate_surface_state use MOM_variables, only : rotate_surface_state use MOM_forcing_type, only : forcing, allocate_forcing_type, deallocate_forcing_type, MOM_forcing_chksum -use MOM_forcing_type, only : mech_forcing, allocate_mech_forcing, MOM_mech_forcing_chksum +use MOM_forcing_type, only : mech_forcing, allocate_mech_forcing, deallocate_mech_forcing, MOM_mech_forcing_chksum use MOM_forcing_type, only : copy_common_forcing_fields, rotate_forcing, rotate_mech_forcing use MOM_get_input, only : directories, Get_MOM_input use MOM_EOS, only : calculate_density, calculate_density_derivs, calculate_TFreeze, EOS_domain @@ -59,7 +61,6 @@ module MOM_ice_shelf use MOM_ice_shelf_state, only : ice_shelf_state, ice_shelf_state_end, ice_shelf_state_init use user_shelf_init, only : USER_initialize_shelf_mass, USER_update_shelf_mass use user_shelf_init, only : user_ice_shelf_CS -use MOM_coms, only : reproducing_sum use MOM_spatial_means, only : global_area_integral use MOM_checksums, only : hchksum, qchksum, chksum, uchksum, vchksum, uvchksum use MOM_interpolate, only : init_external_field, time_interp_external, time_interp_external_init @@ -90,10 +91,6 @@ module MOM_ice_shelf type(MOM_restart_CS), pointer :: restart_CSp => NULL() !< A pointer to the restart control !! structure for the ice shelves type(ocean_grid_type), pointer :: Grid_in => NULL() !< un-rotated input grid metric - type(hor_index_type), pointer :: HI_in => NULL() !< Pointer to a horizontal indexing structure for - !! incoming data which has not been rotated. - type(hor_index_type), pointer :: HI => NULL() !< Pointer to a horizontal indexing structure for - !! incoming data which has not been rotated. logical :: rotate_index = .false. !< True if index map is rotated integer :: turns !< The number of quarter turns for rotation testing. type(ocean_grid_type), pointer :: Grid => NULL() !< Grid for the ice-shelf model @@ -1020,18 +1017,18 @@ end subroutine change_thickness_using_melt !> This subroutine adds the mechanical forcing fields and perhaps shelf areas, based on !! the ice state in ice_shelf_CS. -subroutine add_shelf_forces(Ocn_grid, US, CS, forces, do_shelf_area, external_call) +subroutine add_shelf_forces(Ocn_grid, US, CS, forces_in, do_shelf_area, external_call) type(ocean_grid_type), intent(in) :: Ocn_grid !< The ocean's grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(ice_shelf_CS), pointer :: CS !< This module's control structure. - type(mech_forcing), intent(inout) :: forces !< A structure with the + type(mech_forcing), target, intent(inout) :: forces_in !< A structure with the !! driving mechanical forces logical, optional, intent(in) :: do_shelf_area !< If true find the shelf-covered areas. logical, optional, intent(in) :: external_call !< If true the incoming forcing type - !! is using the input grid metric and needs + !! is using the unrotated input grid and may need !! to be rotated. type(ocean_grid_type), pointer :: G => NULL() !< A pointer to the ocean grid metric. -! type(mech_forcing), target :: forces !< A structure with the driving mechanical forces + type(mech_forcing), pointer :: forces !< A structure with the driving mechanical forces real :: kv_rho_ice ! The viscosity of ice divided by its density [L4 T-1 R-1 Z-2 ~> m5 kg-1 s-1]. real :: press_ice ! The pressure of the ice shelf per unit area of ocean (not ice) [R L2 T-2 ~> Pa]. logical :: find_area ! If true find the shelf areas at u & v points. @@ -1041,29 +1038,25 @@ subroutine add_shelf_forces(Ocn_grid, US, CS, forces, do_shelf_area, external_ca integer :: i, j, is, ie, js, je, isd, ied, jsd, jed - if (present(external_call)) rotate=external_call - - if ((Ocn_grid%isc /= CS%Grid_in%isc) .or. (Ocn_grid%iec /= CS%Grid_in%iec) .or. & - (Ocn_grid%jsc /= CS%Grid_in%jsc) .or. (Ocn_grid%jec /= CS%Grid_in%jec)) & - call MOM_error(FATAL,"add_shelf_forces: Incompatible Ocean and Ice shelf grids.") + rotate = .false. ; if (present(external_call)) rotate = external_call if (CS%rotate_index .and. rotate) then - call MOM_error(FATAL,"add_shelf_forces: Rotation not implemented for ice shelves.") - ! allocate(forces) - ! call allocate_mech_forcing(forces_in, CS%Grid, forces) - ! call rotate_mech_forcing(forces_in, CS%turns, forces) - ! else - ! if ((Ocn_grid%isc /= CS%Grid%isc) .or. (Ocn_grid%iec /= CS%Grid%iec) .or. & - ! (Ocn_grid%jsc /= CS%Grid%jsc) .or. (Ocn_grid%jec /= CS%Grid%jec)) & - ! call MOM_error(FATAL,"add_shelf_forces: Incompatible Ocean and Ice shelf grids.") - - ! forces=>forces_in + if ((Ocn_grid%isc /= CS%Grid_in%isc) .or. (Ocn_grid%iec /= CS%Grid_in%iec) .or. & + (Ocn_grid%jsc /= CS%Grid_in%jsc) .or. (Ocn_grid%jec /= CS%Grid_in%jec)) & + call MOM_error(FATAL,"add_shelf_forces: Incompatible Ocean and external Ice shelf grids.") + allocate(forces) + call allocate_mech_forcing(forces_in, CS%Grid, forces) + call rotate_mech_forcing(forces_in, CS%turns, forces) + else + if ((Ocn_grid%isc /= CS%Grid%isc) .or. (Ocn_grid%iec /= CS%Grid%iec) .or. & + (Ocn_grid%jsc /= CS%Grid%jsc) .or. (Ocn_grid%jec /= CS%Grid%jec)) & + call MOM_error(FATAL,"add_shelf_forces: Incompatible Ocean and internal Ice shelf grids.") + + forces=>forces_in endif G=>CS%Grid - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed @@ -1125,10 +1118,10 @@ subroutine add_shelf_forces(Ocn_grid, US, CS, forces, do_shelf_area, external_ca scalar_pair=.true.) endif - ! if (CS%rotate_index .and. rotate) then - ! call rotate_mech_forcing(forces, -CS%turns, forces_in) - ! ! TODO: deallocate mech forcing? - ! endif + if (CS%rotate_index .and. rotate) then + call rotate_mech_forcing(forces, -CS%turns, forces_in) + call deallocate_mech_forcing(forces) + endif end subroutine add_shelf_forces @@ -1411,6 +1404,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, Time_init, !! the ice-shelf state type(directories) :: dirs type(dyn_horgrid_type), pointer :: dG => NULL() + type(dyn_horgrid_type), pointer :: dG_in => NULL() real :: meltrate_conversion ! The conversion factor to use for in the melt rate diagnostic. real :: dz_ocean_min_float ! The minimum ocean thickness above which the ice shelf is considered ! to be floating when CONST_SEA_LEVEL = True [Z ~> m]. @@ -1422,6 +1416,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, Time_init, character(len=40) :: mdl = "MOM_ice_shelf" ! This module's name. integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, Isdq, Iedq, Jsdq, Jedq integer :: wd_halos(2) + logical :: showCallTree logical :: read_TideAmp, debug logical :: global_indexing character(len=240) :: Tideamp_file ! Input file names @@ -1463,55 +1458,57 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, Time_init, ! Set up the ice-shelf domain and grid wd_halos(:)=0 - allocate(CS%Grid) - call MOM_domains_init(CS%Grid%domain, param_file, min_halo=wd_halos, symmetric=GRID_SYM_,& + allocate(CS%Grid_in) + call MOM_domains_init(CS%Grid_in%domain, param_file, min_halo=wd_halos, symmetric=GRID_SYM_,& domain_name='MOM_Ice_Shelf_in', US=CS%US) !allocate(CS%Grid_in%HI) !call hor_index_init(CS%Grid%Domain, CS%Grid%HI, param_file, & ! local_indexing=.not.global_indexing) - call MOM_grid_init(CS%Grid, param_file, CS%US) + call MOM_grid_init(CS%Grid_in, param_file, CS%US) - ! if (CS%rotate_index) then + if (CS%rotate_index) then ! ! TODO: Index rotation currently only works when index rotation does not ! ! change the MPI rank of each domain. Resolving this will require a ! ! modification to FMS PE assignment. ! ! For now, we only permit single-core runs. - ! if (num_PEs() /= 1) & - ! call MOM_error(FATAL, "Index rotation is only supported on one PE.") - - ! call get_param(param_file, mdl, "INDEX_TURNS", CS%turns, & - ! "Number of counterclockwise quarter-turn index rotations.", & - ! default=1, debuggingParam=.true.) - ! ! NOTE: If indices are rotated, then CS%Grid and CS%Grid_in must both be initialized. - ! ! If not rotated, then CS%Grid_in and CS%Ggrid are the same grid. - ! allocate(CS%Grid) - ! !allocate(CS%HI) - ! call clone_MOM_domain(CS%Grid_in%Domain, CS%Grid%Domain,turns=CS%turns) - ! call rotate_hor_index(CS%Grid_in%HI, CS%turns, CS%Grid%HI) - ! call MOM_grid_init(CS%Grid, param_file, CS%US, CS%HI) - ! call create_dyn_horgrid(dG, CS%Grid%HI) - ! call create_dyn_horgrid(dG_in, CS%Grid_in%HI) - ! call clone_MOM_domain(CS%Grid_in%Domain, dG_in%Domain) - ! ! Set up the bottom depth, G%D either analytically or from file - ! call set_grid_metrics(dG_in,param_file,CS%US) - ! call MOM_initialize_topography(dG_in%bathyT, CS%Grid_in%max_depth, dG_in, param_file) - ! call rescale_dyn_horgrid_bathymetry(dG_in, CS%US%Z_to_m) - ! call rotate_dyngrid(dG_in, dG, CS%US, CS%turns) - ! call copy_dyngrid_to_MOM_grid(dG,CS%Grid,CS%US) - ! else - !CS%Grid=>CS%Grid_in - dG => NULL() - !CS%Grid%HI=>CS%Grid_in%HI - call create_dyn_horgrid(dG, CS%Grid%HI) - call clone_MOM_domain(CS%Grid%Domain,dG%Domain) - call set_grid_metrics(dG,param_file,CS%US) - ! Set up the bottom depth, dG%bathyT, either analytically or from file - call MOM_initialize_topography(dG%bathyT, CS%Grid%max_depth, dG, param_file, CS%US) - call copy_dyngrid_to_MOM_grid(dG, CS%Grid, CS%US) - call destroy_dyn_horgrid(dG) -! endif - G => CS%Grid ; CS%Grid_in => CS%Grid + if (num_PEs() /= 1) call MOM_error(FATAL, "Index rotation is only supported on one PE.") + + call get_param(param_file, mdl, "INDEX_TURNS", CS%turns, & + "Number of counterclockwise quarter-turn index rotations.", & + default=1, debuggingParam=.true.) + ! NOTE: If indices are rotated, then CS%Grid and CS%Grid_in must both be initialized. + ! If not rotated, then CS%Grid_in and CS%Ggrid are the same grid. + call create_dyn_horgrid(dG_in, CS%Grid_in%HI) + call clone_MOM_domain(CS%Grid_in%Domain, dG_in%Domain) + call set_grid_metrics(dG_in, param_file, CS%US) + ! Set up the bottom depth, dG_in%bathyT, either analytically or from file + call MOM_initialize_topography(dG_in%bathyT, CS%Grid_in%max_depth, dG_in, param_file, CS%US) + call copy_dyngrid_to_MOM_grid(dG_in, CS%Grid_in, CS%US) + + ! Now set up the rotated ice-shelf grid. + allocate(CS%Grid) + call clone_MOM_domain(CS%Grid_in%Domain, CS%Grid%Domain, turns=CS%turns) + call rotate_hor_index(CS%Grid_in%HI, CS%turns, CS%Grid%HI) + call MOM_grid_init(CS%Grid, param_file, CS%US, CS%Grid%HI) + call create_dyn_horgrid(dG, CS%Grid%HI) + call rotate_dyngrid(dG_in, dG, CS%US, CS%turns) + call copy_dyngrid_to_MOM_grid(dG, CS%Grid, CS%US) + + call destroy_dyn_horgrid(dG_in) + call destroy_dyn_horgrid(dG) + else + CS%Grid => CS%Grid_in + dG => NULL() + call create_dyn_horgrid(dG, CS%Grid%HI) + call clone_MOM_domain(CS%Grid%Domain, dG%Domain) + call set_grid_metrics(dG, param_file, CS%US) + ! Set up the bottom depth, dG%bathyT, either analytically or from file + call MOM_initialize_topography(dG%bathyT, CS%Grid%max_depth, dG, param_file, CS%US) + call copy_dyngrid_to_MOM_grid(dG, CS%Grid, CS%US) + call destroy_dyn_horgrid(dG) + endif + G => CS%Grid allocate(CS%diag) call MOM_IS_diag_mediator_init(G, CS%US, param_file, CS%diag, component='MOM_IceShelf') @@ -1979,8 +1976,11 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, Time_init, if (save_IC .and. .not.((dirs%input_filename(1:1) == 'r') .and. & (LEN_TRIM(dirs%input_filename) == 1))) then + showCallTree = callTree_showQuery() + if (showCallTree) call callTree_waypoint("About to call save_restart (MOM_ice_shelf)") call save_restart(dirs%output_directory, CS%Time, CS%Grid_in, CS%restart_CSp, & filename=IC_file, write_ic=.true.) + if (showCallTree) call callTree_waypoint("Done with call to save_restart (MOM_ice_shelf)") endif CS%id_area_shelf_h = register_diag_field('ice_shelf_model', 'area_shelf_h', CS%diag%axesT1, CS%Time, & @@ -2130,16 +2130,23 @@ subroutine initialize_ice_shelf_fluxes(CS, ocn_grid, US, fluxes_in) end subroutine initialize_ice_shelf_fluxes +!> Allocate and initialize the ice-shelf forcing elements of a mechanical forcing type. +!! This forcing type is on the unrotated grid that is used outside of the MOM6 ice shelf code. subroutine initialize_ice_shelf_forces(CS, ocn_grid, US, forces_in) type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure type(ocean_grid_type), pointer :: ocn_grid !< The calling ocean model's horizontal grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(mech_forcing), target, intent(inout) :: forces_in !< A structure with the driving mechanical forces ! Local variables type(mech_forcing), pointer :: forces => NULL() call MOM_mesg("MOM_ice_shelf.F90, initialize_ice_shelf: allocating forces.") + + if ((Ocn_grid%isc /= CS%Grid_in%isc) .or. (Ocn_grid%iec /= CS%Grid_in%iec) .or. & + (Ocn_grid%jsc /= CS%Grid_in%jsc) .or. (Ocn_grid%jec /= CS%Grid_in%jec)) & + call MOM_error(FATAL,"initialize_ice_shelf_forces: Incompatible ocean and external ice shelf grids.") + call allocate_mech_forcing(CS%Grid_in, forces_in, ustar=.true., shelf=.true., press=.true., tau_mag=.true.) if (CS%rotate_index) then allocate(forces) @@ -2149,10 +2156,13 @@ subroutine initialize_ice_shelf_forces(CS, ocn_grid, US, forces_in) forces=>forces_in endif - call add_shelf_forces(ocn_grid, US, CS, forces, do_shelf_area=.not.CS%solo_ice_sheet) + call add_shelf_forces(CS%grid, US, CS, forces, do_shelf_area=.not.CS%solo_ice_sheet, & + external_call=.false.) - if (CS%rotate_index) & + if (CS%rotate_index) then call rotate_mech_forcing(forces, -CS%turns, forces_in) + call deallocate_mech_forcing(forces) + endif end subroutine initialize_ice_shelf_forces