src/parameterizations/lateral/MOM_hor_visc.F90

portedportable, not yet portedexecuted, not portableexecutable, not hit by this run

1		! This file is part of MOM6, the Modular Ocean Model version 6.
2		! See the LICENSE file for licensing information.
3		! SPDX-License-Identifier: Apache-2.0
4
5		#include "do_concurrent_compat.h"
6
7		!> Calculates horizontal viscosity and viscous stresses
8		module MOM_hor_visc
9
10		use MOM_checksums, only : hchksum, Bchksum, uvchksum
11		use MOM_coms, only : min_across_PEs
12		use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr
13		use MOM_diag_mediator, only : post_product_u, post_product_sum_u
14		use MOM_diag_mediator, only : post_product_v, post_product_sum_v
15		use MOM_diag_mediator, only : diag_ctrl, time_type
16		use MOM_domains, only : pass_var, CORNER, pass_vector, AGRID, BGRID_NE
17		use MOM_domains, only : To_All, Scalar_Pair
18		use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe
19		use MOM_file_parser, only : get_param, log_version, param_file_type
20		use MOM_grid, only : ocean_grid_type
21		use MOM_interface_heights, only : thickness_to_dz
22		use MOM_lateral_mixing_coeffs, only : VarMix_CS, calc_QG_slopes, calc_QG_Leith_viscosity
23		use MOM_barotropic, only : barotropic_CS, barotropic_get_tav
24		use MOM_thickness_diffuse, only : thickness_diffuse_CS, thickness_diffuse_get_KH
25		use MOM_io, only : MOM_read_data, slasher
26		use MOM_MEKE_types, only : MEKE_type
27		use MOM_open_boundary, only : ocean_OBC_type, OBC_DIRECTION_E, OBC_DIRECTION_W
28		use MOM_open_boundary, only : OBC_DIRECTION_N, OBC_DIRECTION_S
29		use MOM_open_boundary, only : OBC_STRAIN_NONE, OBC_STRAIN_ZERO, OBC_STRAIN_FREESLIP
30		use MOM_open_boundary, only : OBC_STRAIN_COMPUTED, OBC_STRAIN_SPECIFIED
31		use MOM_stochastics, only : stochastic_CS
32		use MOM_unit_scaling, only : unit_scale_type
33		use MOM_verticalGrid, only : verticalGrid_type
34		use MOM_variables, only : accel_diag_ptrs, thermo_var_ptrs
35		use MOM_Zanna_Bolton, only : ZB2020_lateral_stress, ZB2020_init, ZB2020_end
36		use MOM_Zanna_Bolton, only : ZB2020_CS, ZB2020_copy_gradient_and_thickness
37
38		implicit none ; private
39
40		#include <MOM_memory.h>
41
42		public horizontal_viscosity, hor_visc_nkblock, hor_visc_init, hor_visc_end, hor_visc_vel_stencil
43
44		!> Control structure for horizontal viscosity
45		type, public :: hor_visc_CS ; private
46		logical :: initialized = .false. !< True if this control structure has been initialized.
47		logical :: Laplacian !< Use a Laplacian horizontal viscosity if true.
48		logical :: biharmonic !< Use a biharmonic horizontal viscosity if true.
49		logical :: debug !< If true, write verbose checksums for debugging purposes.
50		logical :: no_slip !< If true, no slip boundary conditions are used.
51		!! Otherwise free slip boundary conditions are assumed.
52		!! The implementation of the free slip boundary
53		!! conditions on a C-grid is much cleaner than the
54		!! no slip boundary conditions. The use of free slip
55		!! b.c.s is strongly encouraged. The no slip b.c.s
56		!! are not implemented with the biharmonic viscosity.
57		logical :: bound_Kh !< If true, the Laplacian coefficient is locally
58		!! limited to guarantee stability.
59		logical :: EY24_EBT_BS !! If true, use an equivalent barotropic backscatter
60		!! with a stabilizing kill switch in MEKE,
61		!< developed by Yankovsky et al. 2024
62		logical :: bound_Ah !< If true, the biharmonic coefficient is locally
63		!! limited to guarantee stability.
64		real :: Re_Ah !! If nonzero, the biharmonic coefficient is scaled
65		!< so that the biharmonic Reynolds number is equal to this [nondim].
66		real :: bound_coef !< The nondimensional coefficient of the ratio of
67		!! the viscosity bounds to the theoretical maximum
68		!! for stability without considering other terms [nondim].
69		!! The default is 0.8.
70		real :: KS_coef !< A nondimensional coefficient on the biharmonic viscosity that sets the
71		!! kill switch for backscatter. Default is 1.0 [nondim].
72		real :: KS_timescale !< A timescale for computing CFL limit for turning off backscatter [T ~> s].
73		logical :: backscatter_underbound !< If true, the bounds on the biharmonic viscosity are allowed
74		!! to increase where the Laplacian viscosity is negative (due to
75		!! backscatter parameterizations) beyond the largest timestep-dependent
76		!! stable values of biharmonic viscosity when no Laplacian viscosity is
77		!! applied. The default is true for historical reasons, but this option
78		!! probably should not be used as it can lead to numerical instabilities.
79		logical :: Smagorinsky_Kh !< If true, use Smagorinsky nonlinear eddy
80		!! viscosity. KH is the background value.
81		logical :: Smagorinsky_Ah !< If true, use a biharmonic form of Smagorinsky
82		!! nonlinear eddy viscosity. AH is the background.
83		logical :: Leith_Kh !< If true, use 2D Leith nonlinear eddy
84		!! viscosity. KH is the background value.
85		logical :: Modified_Leith !< If true, use extra component of Leith viscosity
86		!! to damp divergent flow. To use, still set Leith_Kh=.TRUE.
87		logical :: use_beta_in_Leith !< If true, includes the beta term in the Leith viscosity
88		logical :: Leith_Ah !< If true, use a biharmonic form of 2D Leith
89		!! nonlinear eddy viscosity. AH is the background.
90		logical :: use_Leithy !< If true, use a biharmonic form of 2D Leith
91		!! nonlinear eddy viscosity with harmonic backscatter.
92		!! Ah is the background. Leithy = Leith+E
93		real :: c_K !< Fraction of energy dissipated by the biharmonic term
94		!! that gets backscattered in the Leith+E scheme. [nondim]
95		logical :: smooth_Ah !< If true (default), then Ah and m_leithy are smoothed.
96		!! This smoothing requires a lot of blocking communication.
97		logical :: use_QG_Leith_visc !< If true, use QG Leith nonlinear eddy viscosity.
98		!! KH is the background value.
99		logical :: bound_Coriolis !< If true & SMAGORINSKY_AH is used, the biharmonic
100		!! viscosity is modified to include a term that
101		!! scales quadratically with the velocity shears.
102		logical :: use_Kh_bg_2d !< Read 2d background viscosity from a file.
103		logical :: Kh_bg_2d_bug !< If true, retain an answer-changing horizontal indexing bug
104		!! in setting the corner-point viscosities when USE_KH_BG_2D=True.
105		real :: Kh_bg_min !< The minimum value allowed for Laplacian horizontal
106		!! viscosity [L2 T-1 ~> m2 s-1]. The default is 0.0.
107		logical :: FrictWork_bug !< If true, retain an answer-changing bug in calculating FrictWork,
108		!! which cancels the h in thickness flux and the h at velocity point.
109		logical :: OBC_strain_bug !< If true, recover a bug that specified shear strain option at open
110		!! boundaries cannot be applied.
111		logical :: use_land_mask !< Use the land mask for the computation of thicknesses
112		!! at velocity locations. This eliminates the dependence on
113		!! arbitrary values over land or outside of the domain.
114		!! Default is False to maintain answers with legacy experiments
115		!! but should be changed to True for new experiments.
116		logical :: anisotropic !< If true, allow anisotropic component to the viscosity.
117		logical :: add_LES_viscosity!< If true, adds the viscosity from Smagorinsky and Leith to
118		!! the background viscosity instead of taking the maximum.
119		real :: Kh_aniso !< The anisotropic viscosity [L2 T-1 ~> m2 s-1].
120		logical :: dynamic_aniso !< If true, the anisotropic viscosity is recomputed as a function
121		!! of state. This is set depending on ANISOTROPIC_MODE.
122		logical :: res_scale_MEKE !< If true, the viscosity contribution from MEKE is scaled by
123		!! the resolution function.
124		logical :: use_GME !< If true, use GME backscatter scheme.
125		integer :: nkblock !< The k block size used in horizontal viscosity calculations [nondim].
126		integer :: answer_date !< The vintage of the order of arithmetic and expressions in the
127		!! horizontal viscosity calculations. Values below 20190101 recover
128		!! the answers from the end of 2018, while higher values use updated
129		!! and more robust forms of the same expressions.
130		real :: GME_h0 !< The strength of GME tapers quadratically to zero when the bathymetric
131		!! total water column thickness is less than GME_H0 [H ~> m or kg m-2]
132		real :: GME_efficiency !< The nondimensional prefactor multiplying the GME coefficient [nondim]
133		real :: GME_limiter !< The absolute maximum value the GME coefficient is allowed to take [L2 T-1 ~> m2 s-1].
134		real :: min_grid_Kh !< Minimum horizontal Laplacian viscosity used to
135		!! limit the grid Reynolds number [L2 T-1 ~> m2 s-1]
136		real :: min_grid_Ah !< Minimun horizontal biharmonic viscosity used to
137		!! limit grid Reynolds number [L4 T-1 ~> m4 s-1]
138		logical :: use_cont_thick !< If true, thickness at velocity points adopts h[uv] in BT_cont from continuity solver.
139		logical :: use_cont_thick_bug !< If true, retain an answer-changing bug for thickness at velocity points.
140		type(ZB2020_CS) :: ZB2020 !< Zanna-Bolton 2020 control structure.
141		logical :: use_ZB2020 !< If true, use Zanna-Bolton 2020 parameterization.
142		logical :: use_circulation !< If true, use circulation theorem to compute vorticity (for ZB20 or Leith)
143
144		real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: Kh_bg_xx
145		!< The background Laplacian viscosity at h points [L2 T-1 ~> m2 s-1].
146		!! The actual viscosity may be the larger of this
147		!! viscosity and the Smagorinsky and Leith viscosities.
148		real, allocatable :: Kh_bg_2d(:,:)
149		!< The background Laplacian viscosity at h points [L2 T-1 ~> m2 s-1].
150		!! The actual viscosity may be the larger of this
151		!! viscosity and the Smagorinsky and Leith viscosities.
152		real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: Ah_bg_xx
153		!< The background biharmonic viscosity at h points [L4 T-1 ~> m4 s-1].
154		!! The actual viscosity may be the larger of this
155		!! viscosity and the Smagorinsky and Leith viscosities.
156		real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: reduction_xx
157		!< The amount by which stresses through h points are reduced
158		!! due to partial barriers [nondim].
159		real, allocatable :: Kh_Max_xx(:,:) !< The maximum permitted Laplacian viscosity [L2 T-1 ~> m2 s-1].
160		real, allocatable :: Ah_Max_xx(:,:) !< The maximum permitted biharmonic viscosity [L4 T-1 ~> m4 s-1].
161		real, allocatable :: Ah_Max_xx_KS(:,:) !< The maximum permitted biharmonic viscosity for
162		!! the kill switch [L4 T-1 ~> m4 s-1].
163		real, allocatable :: n1n2_h(:,:) !< Factor n1*n2 in the anisotropic direction tensor at h-points [nondim]
164		real, allocatable :: n1n1_m_n2n2_h(:,:) !< Factor n12-n22 in the anisotropic direction tensor at h-points [nondim]
165		real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: &
166		grid_sp_h2, & !< Harmonic mean of the squares of the grid [L2 ~> m2]
167		grid_sp_h3 !< Harmonic mean of the squares of the grid^(3/2) [L3 ~> m3]
168		real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_) :: Kh_bg_xy
169		!< The background Laplacian viscosity at q points [L2 T-1 ~> m2 s-1].
170		!! The actual viscosity may be the larger of this
171		!! viscosity and the Smagorinsky and Leith viscosities.
172		real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_) :: Ah_bg_xy
173		!< The background biharmonic viscosity at q points [L4 T-1 ~> m4 s-1].
174		!! The actual viscosity may be the larger of this
175		!! viscosity and the Smagorinsky and Leith viscosities.
176		real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_) :: reduction_xy
177		!< The amount by which stresses through q points are reduced
178		!! due to partial barriers [nondim].
179		real, allocatable :: Kh_Max_xy(:,:) !< The maximum permitted Laplacian viscosity [L2 T-1 ~> m2 s-1].
180		real, allocatable :: Ah_Max_xy(:,:) !< The maximum permitted biharmonic viscosity [L4 T-1 ~> m4 s-1].
181		real, allocatable :: Ah_Max_xy_KS(:,:) !< The maximum permitted biharmonic viscosity for
182		!! the kill switch [L4 T-1 ~> m4 s-1].
183		real, allocatable :: n1n2_q(:,:) !< Factor n1*n2 in the anisotropic direction tensor at q-points [nondim]
184		real, allocatable :: n1n1_m_n2n2_q(:,:) !< Factor n12-n22 in the anisotropic direction tensor at q-points [nondim]
185
186		real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: &
187		dx2h, & !< Pre-calculated dx^2 at h points [L2 ~> m2]
188		dy2h, & !< Pre-calculated dy^2 at h points [L2 ~> m2]
189		dx_dyT, & !< Pre-calculated dx/dy at h points [nondim]
190		dy_dxT !< Pre-calculated dy/dx at h points [nondim]
191		real, allocatable :: m_const_leithy(:,:) !< Pre-calculated .5sqrt(c_K)max{dx,dy} [L ~> m]
192		real, allocatable :: m_leithy_max(:,:) !< Pre-calculated 4./max(dx,dy)^2 at h points [L-2 ~> m-2]
193		real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_) :: &
194		dx2q, & !< Pre-calculated dx^2 at q points [L2 ~> m2]
195		dy2q, & !< Pre-calculated dy^2 at q points [L2 ~> m2]
196		dx_dyBu, & !< Pre-calculated dx/dy at q points [nondim]
197		dy_dxBu !< Pre-calculated dy/dx at q points [nondim]
198		real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_) :: &
199		Idx2dyCu, & !< 1/(dx^2 dy) at u points [L-3 ~> m-3]
200		Idxdy2u !< 1/(dx dy^2) at u points [L-3 ~> m-3]
201		real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_) :: &
202		Idx2dyCv, & !< 1/(dx^2 dy) at v points [L-3 ~> m-3]
203		Idxdy2v !< 1/(dx dy^2) at v points [L-3 ~> m-3]
204
205		! The following variables are precalculated time-invariant combinations of
206		! parameters and metric terms.
207		real, allocatable :: Laplac2_const_xx(:,:) !< Laplacian metric-dependent constants [L2 ~> m2]
208		real, allocatable :: Biharm6_const_xx(:,:) !< Biharmonic metric-dependent constants [L6 ~> m6]
209		real, allocatable :: Laplac3_const_xx(:,:) !< Laplacian metric-dependent constants [L3 ~> m3]
210		real, allocatable :: Biharm_const_xx(:,:) !< Biharmonic metric-dependent constants [L4 ~> m4]
211		real, allocatable :: Biharm_const2_xx(:,:) !< Biharmonic metric-dependent constants [T L4 ~> s m4]
212		real, allocatable :: Re_Ah_const_xx(:,:) !< Biharmonic metric-dependent constants [L3 ~> m3]
213
214		real, allocatable :: Laplac2_const_xy(:,:) !< Laplacian metric-dependent constants [L2 ~> m2]
215		real, allocatable :: Biharm6_const_xy(:,:) !< Biharmonic metric-dependent constants [L6 ~> m6]
216		real, allocatable :: Laplac3_const_xy(:,:) !< Laplacian metric-dependent constants [L3 ~> m3]
217		real, allocatable :: Biharm_const_xy(:,:) !< Biharmonic metric-dependent constants [L4 ~> m4]
218		real, allocatable :: Biharm_const2_xy(:,:) !< Biharmonic metric-dependent constants [T L4 ~> s m4]
219		real, allocatable :: Re_Ah_const_xy(:,:) !< Biharmonic metric-dependent constants [L3 ~> m3]
220
221		type(diag_ctrl), pointer :: diag => NULL() !< structure to regulate diagnostics
222
223		! real, allocatable :: hf_diffu(:,:,:) ! Zonal horizontal viscous acceleleration times
224		! ! fractional thickness [L T-2 ~> m s-2].
225		! real, allocatable :: hf_diffv(:,:,:) ! Meridional horizontal viscous acceleleration times
226		! ! fractional thickness [L T-2 ~> m s-2].
227		! 3D diagnostics hf_diffu(diffv) are commented because there is no clarity on proper remapping grid option.
228		! The code is retained for debugging purposes in the future.
229
230		integer :: num_smooth_gme !< number of smoothing passes for the GME fluxes.
231		!>@{
232		!! Diagnostic id
233		integer :: id_grid_Re_Ah = -1, id_grid_Re_Kh = -1
234		integer :: id_diffu = -1, id_diffv = -1
235		! integer :: id_hf_diffu = -1, id_hf_diffv = -1
236		integer :: id_h_diffu = -1, id_h_diffv = -1
237		integer :: id_hf_diffu_2d = -1, id_hf_diffv_2d = -1
238		integer :: id_intz_diffu_2d = -1, id_intz_diffv_2d = -1
239		integer :: id_diffu_visc_rem = -1, id_diffv_visc_rem = -1
240		integer :: id_Ah_h = -1, id_Ah_q = -1
241		integer :: id_Kh_h = -1, id_Kh_q = -1
242		integer :: id_GME_coeff_h = -1, id_GME_coeff_q = -1
243		integer :: id_dudx_bt = -1, id_dvdy_bt = -1
244		integer :: id_dudy_bt = -1, id_dvdx_bt = -1
245		integer :: id_vort_xy_q = -1, id_div_xx_h = -1
246		integer :: id_sh_xy_q = -1, id_sh_xx_h = -1
247		integer :: id_FrictWork = -1, id_FrictWorkIntz = -1
248		integer :: id_FrictWork_bh = -1, id_FrictWorkIntz_bh = -1
249		integer :: id_FrictWork_GME = -1
250		integer :: id_normstress = -1, id_shearstress = -1
251		integer :: id_visc_limit_h = -1, id_visc_limit_q = -1
252		integer :: id_visc_limit_h_flag = -1, id_visc_limit_q_flag = -1
253		integer :: id_visc_limit_h_frac = -1, id_visc_limit_q_frac = -1
254		integer :: id_BS_coeff_h = -1, id_BS_coeff_q = -1
255		!>@}
256
257		end type hor_visc_CS
258
259		contains
260
261		!> Calculates the acceleration due to the horizontal viscosity.
262		!!
263		!! A combination of biharmonic and Laplacian forms can be used. The coefficient
264		!! may either be a constant or a shear-dependent form. The biharmonic is
265		!! determined by twice taking the divergence of an appropriately defined stress
266		!! tensor. The Laplacian is determined by doing so once.
267		!!
268		!! To work, the following fields must be set outside of the usual
269		!! is:ie range before this subroutine is called:
270		!! u(is-2:ie+2,js-2:je+2)
271		!! v(is-2:ie+2,js-2:je+2)
272		!! h(is-1:ie+1,js-1:je+1) or up to h(is-2:ie+2,js-2:je+2) with some Leith options.
273	50	subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, GV, US, &
274	50	CS, nkblock, tv, dt, OBC, BT, TD, ADp, hu_cont, hv_cont, STOCH)
275		type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure.
276		type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure.
277		real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), &
278		intent(in) :: u !< The zonal velocity [L T-1 ~> m s-1].
279		real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), &
280		intent(in) :: v !< The meridional velocity [L T-1 ~> m s-1].
281		real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), &
282		intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2].
283		real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), &
284		intent(in) :: uh !< The zonal volume transport [H L2 T-1 ~> m3 s-1].
285		real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), &
286		intent(in) :: vh !< The meridional volume transport [H L2 T-1 ~> m3 s-1].
287		real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), &
288		intent(out) :: diffu !< Zonal acceleration due to convergence of
289		!! along-coordinate stress tensor [L T-2 ~> m s-2]
290		real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), &
291		intent(out) :: diffv !< Meridional acceleration due to convergence
292		!! of along-coordinate stress tensor [L T-2 ~> m s-2].
293		type(MEKE_type), intent(inout) :: MEKE !< MEKE fields
294		!! related to Mesoscale Eddy Kinetic Energy.
295		type(VarMix_CS), intent(inout) :: VarMix !< Variable mixing control structure
296		type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
297		type(hor_visc_CS), intent(inout) :: CS !< Horizontal viscosity control structure
298		integer, intent(in) :: nkblock !< The effective k-block size [nondim]
299		type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various
300		!! thermodynamic variables
301		real, intent(in) :: dt !< Time increment [T ~> s]
302		type(ocean_OBC_type), optional, pointer :: OBC !< Pointer to an open boundary condition type
303		type(barotropic_CS), optional, intent(in) :: BT !< Barotropic control structure
304		type(thickness_diffuse_CS), optional, intent(in) :: TD !< Thickness diffusion control structure
305		type(accel_diag_ptrs), optional, intent(in) :: ADp !< Acceleration diagnostics
306		real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), &
307		optional, intent(inout) :: hu_cont !< Layer thickness at u-points [H ~> m or kg m-2].
308		real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), &
309		optional, intent(inout) :: hv_cont !< Layer thickness at v-points [H ~> m or kg m-2].
310		type(stochastic_CS), intent(inout), optional :: STOCH !< Stochastic control structure
311
312		! Local variables
313		real, dimension(SZIB_(G),SZJ_(G),nkblock) :: &
314	50	Del2u, & ! The u-component of the Laplacian of velocity [L-1 T-1 ~> m-1 s-1]
315	50	h_u ! Thickness interpolated to u points [H ~> m or kg m-2].
316		real, dimension(SZI_(G),SZJB_(G),nkblock) :: &
317	50	Del2v, & ! The v-component of the Laplacian of velocity [L-1 T-1 ~> m-1 s-1]
318	50	h_v ! Thickness interpolated to v points [H ~> m or kg m-2].
319		real, dimension(SZI_(G),SZJB_(G)) :: &
320	50	dudx_bt, dvdy_bt ! components in the barotropic horizontal tension [T-1 ~> s-1]
321		real, dimension(SZI_(G),SZJ_(G),nkblock) :: &
322	50	sh_xx, & ! horizontal tension (du/dx - dv/dy) including metric terms [T-1 ~> s-1]
323	50	sh_xx_smooth ! horizontal tension from smoothed velocity including metric terms [T-1 ~> s-1]
324		real, dimension(SZI_(G),SZJ_(G)) :: &
325	50	sh_xx_bt ! barotropic horizontal tension (du/dx - dv/dy) including metric terms [T-1 ~> s-1]
326		real, dimension(SZI_(G),SZJ_(G),nkblock) :: &
327	50	str_xx, & ! str_xx is the diagonal term in the stress tensor [H L2 T-2 ~> m3 s-2 or kg s-2], but
328		! at some points in the code it is not yet layer integrated, so is in [L2 T-2 ~> m2 s-2].
329	50	str_xx_GME, & ! smoothed diagonal term in the stress tensor from GME [L2 T-2 ~> m2 s-2]
330	50	bhstr_xx, & ! A copy of str_xx that only contains the biharmonic contribution [H L2 T-2 ~> m3 s-2 or kg s-2]
331	50	FrictWorkIntz, & ! depth integrated energy dissipated by lateral friction [R Z L2 T-3 ~> W m-2]
332	50	FrictWorkIntz_bh, & ! depth integrated energy dissipated by biharmonic lateral friction [R Z L2 T-3 ~> W m-2]
333	50	grad_vort_mag_h, & ! Magnitude of vorticity gradient at h-points [L-1 T-1 ~> m-1 s-1]
334	50	grad_vort_mag_h_2d, & ! Magnitude of 2d vorticity gradient at h-points [L-1 T-1 ~> m-1 s-1]
335	50	grad_div_mag_h, & ! Magnitude of divergence gradient at h-points [L-1 T-1 ~> m-1 s-1]
336	50	dudx, dvdy ! components in the horizontal tension [T-1 ~> s-1]
337		real, dimension(SZI_(G),SZJ_(G)) :: &
338	50	GME_effic_h ! The filtered efficiency of the GME terms at h points [nondim]
339		real, dimension(SZI_(G),SZJ_(G),nkblock) :: &
340	50	m_leithy ! Kh=m_leithy*Ah in Leith+E parameterization [L-2 ~> m-2]
341		real :: Del2vort_h ! Laplacian of vorticity at h-points [L-2 T-1 ~> m-2 s-1]
342
343		real, dimension(SZIB_(G),SZJB_(G),nkblock) :: &
344	50	dvdx, dudy, & ! components in the shearing strain [T-1 ~> s-1]
345	50	dvdx_smooth, dudy_smooth, & ! components in the shearing strain from smoothed velocity [T-1 ~> s-1]
346	50	dDel2vdx, dDel2udy ! Components in the biharmonic equivalent of the shearing strain [L-2 T-1 ~> m-2 s-1]
347		real, dimension(SZIB_(G),SZJB_(G)) :: &
348	50	dvdx_bt, dudy_bt ! components in the barotropic shearing strain [T-1 ~> s-1]
349		real, dimension(SZIB_(G),SZJB_(G),nkblock) :: &
350	50	sh_xy, & ! horizontal shearing strain (du/dy + dv/dx) including metric terms [T-1 ~> s-1]
351	50	sh_xy_smooth ! horizontal shearing strain from smoothed velocity including metric terms [T-1 ~> s-1]
352		real, dimension(SZIB_(G),SZJB_(G)) :: &
353	50	sh_xy_bt ! barotropic horizontal shearing strain (du/dy + dv/dx) inc. metric terms [T-1 ~> s-1]
354		real, dimension(SZIB_(G),SZJB_(G),nkblock) :: &
355	50	str_xy, & ! str_xy is the cross term in the stress tensor [H L2 T-2 ~> m3 s-2 or kg s-2], but
356		! at some points in the code it is not yet layer integrated, so is in [L2 T-2 ~> m2 s-2].
357	50	str_xy_GME, & ! smoothed cross term in the stress tensor from GME [L2 T-2 ~> m2 s-2]
358	50	bhstr_xy, & ! A copy of str_xy that only contains the biharmonic contribution [H L2 T-2 ~> m3 s-2 or kg s-2]
359	50	vort_xy, & ! Vertical vorticity (dv/dx - du/dy) including metric terms [T-1 ~> s-1]
360	50	vort_xy_smooth, & ! Vertical vorticity including metric terms, smoothed [T-1 ~> s-1]
361	50	grad_vort_mag_q, & ! Magnitude of vorticity gradient at q-points [L-1 T-1 ~> m-1 s-1]
362	50	grad_vort_mag_q_2d, & ! Magnitude of 2d vorticity gradient at q-points [L-1 T-1 ~> m-1 s-1]
363	50	Del2vort_q, & ! Laplacian of vorticity at q-points [L-2 T-1 ~> m-2 s-1]
364	50	grad_div_mag_q, & ! Magnitude of divergence gradient at q-points [L-1 T-1 ~> m-1 s-1]
365	50	hq ! harmonic mean of the harmonic means of the u- & v point thicknesses [H ~> m or kg m-2]
366		! This form guarantees that hq/hu < 4.
367		real, dimension(SZIB_(G),SZJB_(G)) :: &
368	50	GME_effic_q ! The filtered efficiency of the GME terms at q points [nondim]
369
370		real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)) :: &
371	50	Ah_q, & ! biharmonic viscosity at corner points [L4 T-1 ~> m4 s-1]
372	50	Kh_q, & ! Laplacian viscosity at corner points [L2 T-1 ~> m2 s-1]
373	50	vort_xy_q, & ! vertical vorticity at corner points [T-1 ~> s-1]
374	50	sh_xy_q, & ! horizontal shearing strain at corner points [T-1 ~> s-1]
375	50	GME_coeff_q, & !< GME coeff. at q-points [L2 T-1 ~> m2 s-1]
376	50	visc_limit_q, & ! used to stabilize the EY24_EBT_BS backscatter [nondim]
377	50	visc_limit_q_flag, & ! determines whether backscatter is shut off [nondim]
378	50	visc_limit_q_frac, & ! determines how close backscatter is to shutting off [nondim]
379	50	BS_coeff_q, & ! A diagnostic array of the backscatter coefficient [L2 T-1 ~> m2 s-1]
380	50	ShSt ! A diagnostic array of shear stress [T-1 ~> s-1].
381		real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: &
382	50	KH_u_GME, & !< Isopycnal height diffusivities in u-columns [L2 T-1 ~> m2 s-1]
383	50	slope_x !< Isopycnal slope in i-direction [Z L-1 ~> nondim]
384		real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: &
385	50	KH_v_GME, & !< Isopycnal height diffusivities in v-columns [L2 T-1 ~> m2 s-1]
386	50	slope_y !< Isopycnal slope in j-direction [Z L-1 ~> nondim]
387		real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: &
388	50	Ah_h, & ! biharmonic viscosity at thickness points [L4 T-1 ~> m4 s-1]
389	50	Kh_h, & ! Laplacian viscosity at thickness points [L2 T-1 ~> m2 s-1]
390	50	dz, & ! Height change across layers [Z ~> m]
391	50	FrictWork, & ! work done by MKE dissipation mechanisms [R Z L2 T-3 ~> W m-2]
392	50	FrictWork_bh, & ! work done by the biharmonic MKE dissipation mechanisms [R Z L2 T-3 ~> W m-2]
393	50	FrictWork_GME, & ! work done by GME [R Z L2 T-3 ~> W m-2]
394	50	div_xx_h, & ! horizontal divergence [T-1 ~> s-1]
395	50	sh_xx_h, & ! horizontal tension (du/dx - dv/dy) including metric terms [T-1 ~> s-1]
396	50	NoSt, & ! A diagnostic array of normal stress [T-1 ~> s-1].
397	50	BS_coeff_h ! A diagnostic array of the backscatter coefficient [L2 T-1 ~> m2 s-1]
398		real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: &
399	50	grid_Re_Kh, & ! Grid Reynolds number for Laplacian horizontal viscosity at h points [nondim]
400	50	grid_Re_Ah, & ! Grid Reynolds number for Biharmonic horizontal viscosity at h points [nondim]
401	50	GME_coeff_h, & ! GME coefficient at h-points [L2 T-1 ~> m2 s-1]
402	50	visc_limit_h, & ! Used to stabilize the EY24_EBT_BS backscatter [nondim]
403	50	visc_limit_h_flag, & ! determines whether backscatter is shut off [nondim]
404	50	visc_limit_h_frac ! determines how close backscatter is to shutting off [nondim]
405		real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: &
406	50	u_smooth ! Zonal velocity, smoothed with a spatial low-pass filter [L T-1 ~> m s-1]
407		real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: &
408	50	v_smooth ! Meridional velocity, smoothed with a spatial low-pass filter [L T-1 ~> m s-1]
409		real :: AhSm ! Smagorinsky biharmonic viscosity [L4 T-1 ~> m4 s-1]
410		real :: AhLth ! 2D Leith biharmonic viscosity [L4 T-1 ~> m4 s-1]
411		real :: Shear_mag_bc ! Shear_mag value in backscatter [T-1 ~> s-1]
412		real :: sh_xx_sq ! Square of tension (sh_xx) [T-2 ~> s-2]
413		real :: sh_xy_sq ! Square of shearing strain (sh_xy) [T-2 ~> s-2]
414		real :: h2uq, h2vq ! temporary variables [H2 ~> m2 or kg2 m-4].
415		real :: hu, hv ! Thicknesses interpolated by arithmetic means to corner
416		! points; these are first interpolated to u or v velocity
417		! points where masks are applied [H ~> m or kg m-2].
418		real :: h_neglect ! thickness so small it can be lost in roundoff and so neglected [H ~> m or kg m-2]
419		real :: h_neglect3 ! h_neglect^3 [H3 ~> m3 or kg3 m-6]
420		real :: h_min ! Minimum h at the 4 neighboring velocity points [H ~> m]
421		real :: Kh_max_here ! The local maximum Laplacian viscosity for stability [L2 T-1 ~> m2 s-1]
422		real :: RoScl ! The scaling function for MEKE source term [nondim]
423		real :: FatH ! abs(f) at h-point for MEKE source term [T-1 ~> s-1]
424		real :: local_strain ! Local variable for interpolating computed strain rates [T-1 ~> s-1].
425		real :: meke_res_fn ! A copy of the resolution scaling factor if being applied to MEKE [nondim]. Otherwise = 1.
426		real :: GME_coeff ! The GME (negative) viscosity coefficient [L2 T-1 ~> m2 s-1]
427		real :: DY_dxBu ! Ratio of meridional over zonal grid spacing at vertices [nondim]
428		real :: DX_dyBu ! Ratio of zonal over meridional grid spacing at vertices [nondim]
429		real :: Sh_F_pow ! The ratio of shear over the absolute value of f raised to some power and rescaled [nondim]
430		real :: backscat_subround ! The ratio of f over Shear_mag that is so small that the backscatter
431		! calculation gives the same value as if f were 0 [nondim].
432		real :: KE ! Local kinetic energy [L2 T-2 ~> m2 s-2]
433		real :: d_del2u ! dy-weighted Laplacian(u) diff in x [L-2 T-1 ~> m-2 s-1]
434		real :: d_del2v ! dx-weighted Laplacian(v) diff in y [L-2 T-1 ~> m-2 s-1]
435		real :: d_str ! Stress tensor update [L2 T-2 ~> m2 s-2]
436		real :: grad_vort ! Vorticity gradient magnitude [L-1 T-1 ~> m-1 s-1]
437		real :: grad_vort_qg ! QG-based vorticity gradient magnitude [L-1 T-1 ~> m-1 s-1]
438		real :: grid_Kh ! Laplacian viscosity bound by grid [L2 T-1 ~> m2 s-1]
439		real :: grid_Ah ! Biharmonic viscosity bound by grid [L4 T-1 ~> m4 s-1]
440		real :: dudx_smooth, dvdy_smooth ! components in the horizontal tension from smoothed velocity [T-1 ~> s-1]
441
442		logical :: rescale_Kh
443		logical :: find_FrictWork
444		logical :: apply_OBC = .false.
445		logical :: apply_OBC_strain
446		logical :: use_MEKE_Ku
447		logical :: use_MEKE_Au
448		logical :: skeb_use_frict
449		logical :: use_cont_huv
450		logical :: use_kh_struct
451		logical :: use_Leith ! True if any Leith parameterizations are enabled
452		logical :: use_vort_xy ! True if vort_xy must be computed
453		logical :: use_Smag ! True if a Smagorinsky viscosity is enabled
454		integer :: is_vort, ie_vort, js_vort, je_vort ! Loop ranges for vorticity terms
455		integer :: is_Kh, ie_Kh, js_Kh, je_Kh ! Loop ranges for thickness point viscosities
456		integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz
457		integer :: i, j, k, kk, n, kstart, kend, kmax
458		real :: inv_PI3, inv_PI2, inv_PI6 ! Powers of the inverse of pi [nondim]
459		real :: tmp
460
461		! Fields evaluated on active layers, used for constructing 3D stress fields
462		! NOTE: The position of these declarations can impact performance, due to the
463		! very large number of stack arrays in this function. Move with caution!
464		! NOTE: Several of these are declared with the memory extent of q-points, but the
465		! same arrays are also used at h-points to reduce the memory footprint of this
466		! module, so they should never be used in halo point or checksum calls.
467		real, dimension(SZIB_(G),SZJB_(G),nkblock) :: &
468	25	Ah, & ! biharmonic viscosity (h or q) [L4 T-1 ~> m4 s-1]
469	50	Kh, & ! Laplacian viscosity (h or q) [L2 T-1 ~> m2 s-1]
470	50	Shear_mag, & ! magnitude of the shear (h or q) [T-1 ~> s-1]
471	50	vert_vort_mag, & ! magnitude of the vertical vorticity gradient (h or q) [L-1 T-1 ~> m-1 s-1]
472	50	vert_vort_mag_smooth, & ! magnitude of gradient of smoothed vertical vorticity (h or q) [L-1 T-1 ~> m-1 s-1]
473	50	hrat_min, & ! h_min divided by the thickness at the stress point (h or q) [nondim]
474	25	visc_bound_rem ! fraction of overall viscous bounds that remain to be applied (h or q) [nondim]
475
476	25	is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke
477	25	Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB
478
479	25	h_neglect = GV%H_subroundoff
480		!h_neglect3 = h_neglect**3
481	25	h_neglect3 = h_neglecth_neglecth_neglect
482	25	inv_PI3 = 1.0/((4.0atan(1.0))*3)
483	25	inv_PI2 = 1.0/((4.0atan(1.0))*2)
484	25	inv_PI6 = inv_PI3 * inv_PI3
485
486	25	if (CS%EY24_EBT_BS) then
487	0	visc_limit_h(:,:,:) = 0.
488	0	visc_limit_q(:,:,:) = 0.
489	0	visc_limit_h_flag(:,:,:) = 0.
490	0	visc_limit_q_flag(:,:,:) = 0.
491	0	visc_limit_h_frac(:,:,:) = 0.
492	0	visc_limit_q_frac(:,:,:) = 0.
493		endif
494
495	25	skeb_use_frict = .false.
496	25	if (present(STOCH)) skeb_use_frict = STOCH%skeb_use_frict
497
498	25	if (CS%use_Leithy) m_leithy(:,:,:) = 0.0 ! Initialize
499
500	25	if (present(OBC)) then ; if (associated(OBC)) then ; if (OBC%OBC_pe) then
501	0	apply_OBC = OBC%Flather_u_BCs_exist_globally .or. OBC%Flather_v_BCs_exist_globally
502	0	apply_OBC = .true.
503		endif ; endif ; endif
504
505	25	apply_OBC_strain = .false.
506	25	if (present(OBC)) then ; if (associated(OBC)) then
507		apply_OBC_strain = (OBC%strain_config /= OBC_STRAIN_NONE) &
508	0	.and. ((.not. CS%OBC_strain_bug) .or. (OBC%strain_config /= OBC_STRAIN_SPECIFIED))
509		endif ; endif
510
511	25	if (.not.CS%initialized) call MOM_error(FATAL, &
512	0	"MOM_hor_visc: Module must be initialized before it is used.")
513
514	25	if (.not.(CS%Laplacian .or. CS%biharmonic)) return
515
516	25	find_FrictWork = (CS%id_FrictWork > 0)
517	25	if (CS%id_FrictWorkIntz > 0) find_FrictWork = .true.
518
519	25	if (allocated(MEKE%mom_src)) find_FrictWork = .true.
520	25	use_kh_struct = allocated(VarMix%BS_struct)
521	25	backscat_subround = 0.0
522	25	if (find_FrictWork .and. allocated(MEKE%mom_src) .and. (MEKE%backscatter_Ro_c > 0.0) .and. &
523		(MEKE%backscatter_Ro_Pow /= 0.0)) &
524	0	backscat_subround = (1.0e-16/MEKE%backscatter_Ro_c)**(1.0/MEKE%backscatter_Ro_Pow)
525
526		! Toggle whether to use a Laplacian viscosity derived from MEKE
527	25	use_MEKE_Ku = allocated(MEKE%Ku)
528	25	use_MEKE_Au = allocated(MEKE%Au)
529
530	25	use_cont_huv = CS%use_cont_thick .and. present(hu_cont) .and. present(hv_cont)
531	25	if (use_cont_huv .and. .not.CS%use_cont_thick_bug) then
532	0	call pass_vector(hu_cont, hv_cont, G%domain, To_All+Scalar_Pair, halo=2)
533		endif
534
535	25	rescale_Kh = .false.
536	25	if (VarMix%use_variable_mixing) then
537	25	rescale_Kh = VarMix%Resoln_scaled_Kh
538		if ((rescale_Kh .or. CS%res_scale_MEKE) &
539	25	.and. (.not. allocated(VarMix%Res_fn_h) .or. .not. allocated(VarMix%Res_fn_q))) &
540		call MOM_error(FATAL, "MOM_hor_visc: VarMix%Res_fn_h and VarMix%Res_fn_q "//&
541	0	"both need to be associated with Resoln_scaled_Kh or RES_SCALE_MEKE_VISC.")
542	0	elseif (CS%res_scale_MEKE) then
543		call MOM_error(FATAL, "MOM_hor_visc: VarMix needs to be associated if "//&
544	0	"RES_SCALE_MEKE_VISC is True.")
545		endif
546
547		! Set the halo sizes used for the thickness-point viscosities.
548	25	if (CS%use_Leithy .or. CS%debug) then
549	0	js_Kh = js-1 ; je_Kh = je+1 ; is_Kh = is-1 ; ie_Kh = ie+1
550		else
551	25	js_Kh = Jsq ; je_Kh = je+1 ; is_Kh = Isq ; ie_Kh = ie+1
552		endif
553
554		! Set the halo sizes used for the vorticity calculations.
555	25	if ((CS%Leith_Kh) .or. (CS%Leith_Ah) .or. (CS%use_Leithy)) then
556	0	js_vort = js_Kh-2 ; je_vort = Jeq+2 ; is_vort = is_Kh-2 ; ie_vort = Ieq+2
557	0	if ((G%isc-G%isd < 3) .or. (G%isc-G%isd < 3)) call MOM_error(FATAL, &
558	0	"The minimum halo size is 3 when a Leith viscosity is being used.")
559		else
560	25	js_vort = js-2 ; je_vort = Jeq+1 ; is_vort = is-2 ; ie_vort = Ieq+1
561		endif
562
563	25	if (CS%use_GME) then
564		call hor_visc_GME_setup(G, GV, US, CS, h, BT, TD, nkblock, &
565		dudx_bt, dvdy_bt, dvdx_bt, dudy_bt, sh_xx_bt, sh_xy_bt, &
566		GME_effic_h, GME_effic_q, KH_u_GME, KH_v_GME, &
567	0	GME_coeff_h, GME_coeff_q, str_xx_GME, str_xy_GME)
568		! NOTE: sh_xx_bt, sh_xy_bt, GME_effic_h, GME_effic_q, KH_u_GME and KH_v_GME
569		! are computed on the host above and are only read (never written) on the
570		! device. dudx_bt, dvdy_bt, dvdx_bt and dudy_bt are only used on the
571		! host (post_data diagnostics), so they are not mapped at all.
572		!$omp target enter data map(to: sh_xx_bt, sh_xy_bt, GME_effic_h, GME_effic_q, KH_u_GME, KH_v_GME)
573		! NOTE: GME_coeff_h, GME_coeff_q, str_xx_GME and str_xy_GME are written and
574		! read entirely on the device (aside from the smooth_GME host round-trip
575		! below), so a bare alloc is enough on entry.
576		!$omp target enter data map(alloc: GME_coeff_h, GME_coeff_q, str_xx_GME, str_xy_GME)
577		endif
578
579	25	if (CS%use_Leithy) then
580		! Smooth the velocity. Right now it happens twice. In the future
581		! one might make the number of smoothing cycles a user-specified parameter
582	0	do k=1,nz
583		! One call applies the filter twice
584	0	u_smooth(:,:,k) = u(:,:,k)
585	0	v_smooth(:,:,k) = v(:,:,k)
586	0	call smooth_x9_uv(G, u_smooth(:,:,k), v_smooth(:,:,k), zero_land=.false.)
587		enddo
588	0	call pass_vector(u_smooth, v_smooth, G%Domain)
589		endif
590
591	25	if (CS%use_QG_Leith_visc .and. ((CS%Leith_Kh) .or. (CS%Leith_Ah))) then
592	0	call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=2)
593		! Calculate isopycnal slopes that will be used for some forms of viscosity.
594	0	call calc_QG_slopes(h, tv, dt, G, GV, US, slope_x, slope_y, VarMix, OBC)
595		! If the following halo update is added, the calculations in calc_QG_slopes could work on just
596		! the computational domains, and some halo updates outside of this routine could be smaller.
597		! call pass_vector(slope_x, slope_y, G%Domain, halo=2)
598		endif
599
600	25	if (find_FrictWork .and. allocated(MEKE%mom_src)) then
601	0	do j=js,je ; do i=is,ie
602	0	MEKE%mom_src(i,j) = 0.
603		enddo ; enddo
604
605	0	if (allocated(MEKE%mom_src_bh)) then
606	0	do j=js,je ; do i=is,ie
607	0	MEKE%mom_src_bh(i,j) = 0.
608		enddo ; enddo
609		endif
610
611	0	if (allocated(MEKE%GME_snk)) then
612	0	do j=js,je ; do i=is,ie
613	0	MEKE%GME_snk(i,j) = 0.
614		enddo ; enddo
615		endif
616		endif
617
618	25	use_Leith = CS%Leith_Kh .or. CS%Leith_Ah .or. CS%use_Leithy
619	25	use_vort_xy = use_Leith .or. CS%id_vort_xy_q > 0 .or. CS%use_ZB2020
620	25	use_Smag = CS%Smagorinsky_Kh .or. CS%Smagorinsky_Ah
621
622		!$omp target enter data map(alloc: dudx, dudy, dvdx, dvdy, sh_xx, sh_xy)
623		!$omp target enter data map(alloc: h_u, h_v, hq)
624		!$omp target enter data map(alloc: str_xx, str_xy, ShSt)
625		!$omp target enter data map(alloc: Del2u, Del2v) if (CS%biharmonic)
626		!$omp target enter data map(alloc: dDel2vdx, dDel2udy) if (CS%biharmonic)
627		!$omp target enter data map(alloc: Shear_mag) if (use_Smag)
628		!$omp target enter data map(alloc: Kh) if (CS%Laplacian .or. CS%biharmonic)
629		!$omp target enter data map(alloc: Ah) if (CS%biharmonic)
630		! TODO: Only needed if FrictWork_bh is true, and currently only used on CPU,
631		! but I do not yet see any benefit to breaking up the calculation.
632		!$omp target enter data map(alloc: bhstr_xx, bhstr_xy) if (CS%biharmonic)
633
634		!$omp target enter data map(alloc: hrat_min) &
635		!$omp if (CS%bound_Kh .or. CS%bound_Ah)
636		!$omp target enter data map(alloc: visc_bound_rem) &
637		!$omp if (CS%bound_Kh .or. CS%bound_Ah)
638		!$omp target enter data map(alloc: sh_xy_q) &
639		!$omp if (CS%id_sh_xy_q > 0)
640
641		!$omp target enter data map(alloc: vert_vort_mag)
642		!$omp target enter data map(alloc: sh_xx_smooth) if (CS%use_Leithy .or. CS%biharmonic)
643		!!$omp target enter data map(alloc: CS%use_Leithy)
644
645	1900	do kstart=1,nz,nkblock
646	1875	kend = min(kstart+nkblock-1,nz)
647	1875	kmax = kend-kstart+1
648	1875	k=kstart
649
650		! The following are the forms of the horizontal tension and horizontal
651		! shearing strain advocated by Smagorinsky (1993) and discussed in
652		! Griffies and Hallberg (2000).
653
654		! NOTE: There is a ~1% speedup when the tension and shearing loops below
655		! are fused (presumably due to shared access of Id[xy]C[uv]). However,
656		! this breaks the center/vertex index case convention, and also evaluates
657		! the dudx and dvdy terms beyond their valid bounds.
658		! TODO: Explore methods for retaining both the syntax and speedup.
659
660		! Calculate horizontal tension
661	234375	do concurrent (kk=1:kmax, j=Jsq-1:Jeq+2, i=Isq-1:Ieq+2) DO_LOCALITY(local(k))
662	14880000	k = kstart + kk - 1
663		dudx(i,j,kk) = CS%DY_dxT(i,j)((G%IdyCu(I,j) u(I,j,k)) - &
664	14880000	(G%IdyCu(I-1,j) * u(I-1,j,k)))
665		dvdy(i,j,kk) = CS%DX_dyT(i,j)((G%IdxCv(i,J) v(i,J,k)) - &
666	14880000	(G%IdxCv(i,J-1) * v(i,J-1,k)))
667	29994375	sh_xx(i,j,kk) = dudx(i,j,kk) - dvdy(i,j,kk)
668		enddo
669
670		! Components for the shearing strain
671	1875	do concurrent (kk=1:kmax, J=js_vort:je_vort, I=is_vort:ie_vort) DO_LOCALITY(local(k))
672	14529375	k = kstart + kk - 1
673	14529375	dvdx(I,J,kk) = CS%DY_dxBu(I,J)((v(i+1,J,k)G%IdyCv(i+1,J)) - (v(i,J,k)*G%IdyCv(i,J)))
674	29291250	dudy(I,J,kk) = CS%DX_dyBu(I,J)((u(I,j+1,k)G%IdxCu(I,j+1)) - (u(I,j,k)*G%IdxCu(I,j)))
675		enddo
676
677	1875	if (CS%use_Leithy) then
678		! Calculate horizontal tension from smoothed velocity
679	0	do concurrent (kk=1:kmax, j=Jsq:Jeq+1, i=Isq:Ieq+1) DO_LOCALITY(local(k, dudx_smooth, dvdy_smooth))
680	0	k = kstart + kk - 1
681		dudx_smooth = CS%DY_dxT(i,j)((G%IdyCu(I,j) u_smooth(I,j,k)) - &
682	0	(G%IdyCu(I-1,j) * u_smooth(I-1,j,k)))
683		dvdy_smooth = CS%DX_dyT(i,j)((G%IdxCv(i,J) v_smooth(i,J,k)) - &
684	0	(G%IdxCv(i,J-1) * v_smooth(i,J-1,k)))
685	0	sh_xx_smooth(i,j,kk) = dudx_smooth - dvdy_smooth
686		enddo
687
688		! Components for the shearing strain from smoothed velocity
689	0	do concurrent (kk=1:kmax, J=js_Kh-1:je_Kh, I=is_Kh-1:ie_Kh) DO_LOCALITY(local(k))
690	0	k = kstart + kk - 1
691		dvdx_smooth(I,J,kk) = CS%DY_dxBu(I,J) * &
692	0	((v_smooth(i+1,J,k)G%IdyCv(i+1,J)) - (v_smooth(i,J,k)G%IdyCv(i,J)))
693		dudy_smooth(I,J,kk) = CS%DX_dyBu(I,J) * &
694	0	((u_smooth(I,j+1,k)G%IdxCu(I,j+1)) - (u_smooth(I,j,k)G%IdxCu(I,j)))
695		enddo
696		endif ! use Leith+E
697
698	1875	if (CS%id_normstress > 0) then
699	0	do concurrent (kk=1:kmax, j=js:je, i=is:ie) DO_LOCALITY(local(k))
700	0	k = kstart + kk - 1
701	0	NoSt(i,j,k) = sh_xx(i,j,kk)
702		enddo
703		endif
704
705		! Interpolate the thicknesses to velocity points.
706		! The extra wide halos are to accommodate the cross-corner-point projections
707		! in OBCs, which are not ordinarily be necessary, and might not be necessary
708		! even with OBCs if the accelerations are zeroed at OBC points, in which
709		! case the j-loop for h_u could collapse to j=js=1,je+1. -RWH
710	1875	if (use_cont_huv) then
711	0	do concurrent (kk=1:kmax, j=js-2:je+2, I=Isq-1:Ieq+1) DO_LOCALITY(local(k))
712	0	k = kstart + kk - 1
713	0	h_u(I,j,kk) = hu_cont(I,j,k)
714		enddo
715	0	do concurrent (kk=1:kmax, J=Jsq-1:Jeq+1, i=is-2:ie+2) DO_LOCALITY(local(k))
716	0	k = kstart + kk - 1
717	0	h_v(i,J,kk) = hv_cont(i,J,k)
718		enddo
719	1875	elseif (CS%use_land_mask) then
720	0	do concurrent (kk=1:kmax, j=js-2:je+2, I=is-2:Ieq+1) DO_LOCALITY(local(k))
721	0	k = kstart + kk - 1
722	0	h_u(I,j,kk) = 0.5 * (G%mask2dT(i,j)h(i,j,k) + G%mask2dT(i+1,j)h(i+1,j,k))
723		enddo
724	0	do concurrent (kk=1:kmax, J=js-2:Jeq+1, i=is-2:ie+2) DO_LOCALITY(local(k))
725	0	k = kstart + kk - 1
726	0	h_v(i,J,kk) = 0.5 * (G%mask2dT(i,j)h(i,j,k) + G%mask2dT(i,j+1)h(i,j+1,k))
727		enddo
728		else
729	232500	do concurrent (kk=1:kmax, j=js-2:je+2, I=is-2:Ieq+1) DO_LOCALITY(local(k))
730	14760000	k = kstart + kk - 1
731	29752500	h_u(I,j,kk) = 0.5 * (h(i,j,k) + h(i+1,j,k))
732		enddo
733	234375	do concurrent (kk=1:kmax, J=js-2:Jeq+1, i=is-2:ie+2) DO_LOCALITY(local(k))
734	14647500	k = kstart + kk - 1
735	29529375	h_v(i,J,kk) = 0.5 * (h(i,j,k) + h(i,j+1,k))
736		enddo
737		endif
738
739		! Adjust contributions to shearing strain and interpolated values of
740		! thicknesses on open boundaries.
741	1875	if (apply_OBC) then ; do n=1,OBC%number_of_segments
742	0	J = OBC%segment(n)%HI%JsdB ; I = OBC%segment(n)%HI%IsdB
743	0	if (apply_OBC_strain) then
744	0	if (OBC%segment(n)%is_N_or_S .and. (J >= Js_vort) .and. (J <= Je_vort)) then
745		do concurrent (kk=1:kmax, &
746		I=max(OBC%segment(n)%HI%IsdB,Is_vort):min(OBC%segment(n)%HI%IedB,Ie_vort)) &
747	0	DO_LOCALITY(local(k))
748	0	k = kstart + kk - 1
749	0	select case (OBC%strain_config)
750		case (OBC_STRAIN_ZERO)
751	0	dvdx(I,J,kk) = 0. ; dudy(I,J,kk) = 0.
752		case (OBC_STRAIN_FREESLIP)
753	0	dudy(I,J,kk) = 0.
754		case (OBC_STRAIN_COMPUTED)
755	0	if (OBC%segment(n)%direction == OBC_DIRECTION_N) then
756		dudy(I,J,kk) = 2.0CS%DX_dyBu(I,J) &
757	0	(OBC%segment(n)%tangential_vel(I,J,k) - u(I,j,k))*G%IdxCu(I,j)
758		else
759		dudy(I,J,kk) = 2.0CS%DX_dyBu(I,J) &
760	0	(u(I,j+1,k) - OBC%segment(n)%tangential_vel(I,J,k))*G%IdxCu(I,j+1)
761		endif
762		case (OBC_STRAIN_SPECIFIED)
763	0	if (OBC%segment(n)%direction == OBC_DIRECTION_N) then
764	0	dudy(I,J,kk) = CS%DX_dyBu(I,J)OBC%segment(n)%tangential_grad(I,J,k)G%IdxCu(I,j)*G%dxBu(I,J)
765		else
766	0	dudy(I,J,kk) = CS%DX_dyBu(I,J)OBC%segment(n)%tangential_grad(I,J,k)G%IdxCu(I,j+1)*G%dxBu(I,J)
767		endif
768		end select
769	0	if (CS%use_Leithy) then
770	0	dvdx_smooth(I,J,kk) = dvdx(I,J,kk)
771	0	dudy_smooth(I,J,kk) = dudy(I,J,kk)
772		endif
773		enddo
774	0	elseif (OBC%segment(n)%is_E_or_W .and. (I >= is_vort) .and. (I <= ie_vort)) then
775		do concurrent (kk=1:kmax, &
776		J=max(OBC%segment(n)%HI%JsdB,js_vort):min(OBC%segment(n)%HI%JedB,je_vort)) &
777	0	DO_LOCALITY(local(k))
778	0	k = kstart + kk - 1
779	0	select case (OBC%strain_config)
780		case (OBC_STRAIN_ZERO)
781	0	dvdx(I,J,kk) = 0. ; dudy(I,J,kk) = 0.
782		case (OBC_STRAIN_FREESLIP)
783	0	dvdx(I,J,kk) = 0.
784		case (OBC_STRAIN_COMPUTED)
785	0	if (OBC%segment(n)%direction == OBC_DIRECTION_E) then
786		dvdx(I,J,kk) = 2.0CS%DY_dxBu(I,J) &
787	0	(OBC%segment(n)%tangential_vel(I,J,k) - v(i,J,k))*G%IdyCv(i,J)
788		else
789		dvdx(I,J,kk) = 2.0CS%DY_dxBu(I,J) &
790	0	(v(i+1,J,k) - OBC%segment(n)%tangential_vel(I,J,k))*G%IdyCv(i+1,J)
791		endif
792		case (OBC_STRAIN_SPECIFIED)
793	0	if (OBC%segment(n)%direction == OBC_DIRECTION_E) then
794	0	dvdx(I,J,kk) = CS%DY_dxBu(I,J)OBC%segment(n)%tangential_grad(I,J,k)G%IdyCv(i,J)*G%dxBu(I,J)
795		else
796	0	dvdx(I,J,kk) = CS%DY_dxBu(I,J)OBC%segment(n)%tangential_grad(I,J,k)G%IdyCv(i+1,J)*G%dxBu(I,J)
797		endif
798		end select
799	0	if (CS%use_Leithy) then
800	0	dvdx_smooth(I,J,kk) = dvdx(I,J,kk)
801	0	dudy_smooth(I,J,kk) = dudy(I,J,kk)
802		endif
803		enddo
804		endif
805		endif
806
807	0	if (OBC%segment(n)%direction == OBC_DIRECTION_N) then
808		! There are extra wide halos here to accommodate the cross-corner-point
809		! OBC projections, but they might not be necessary if the accelerations
810		! are always zeroed out at OBC points, in which case the i-loop below
811		! becomes do i=is-1,ie+1. -RWH
812	0	if ((J >= js-2) .and. (J <= Jeq+1)) then
813		do concurrent (kk=1:kmax, &
814	0	i=max(is-2,OBC%segment(n)%HI%isd):min(ie+2,OBC%segment(n)%HI%ied)) DO_LOCALITY(local(k))
815	0	k = kstart + kk - 1
816	0	h_v(i,J,kk) = h(i,j,k)
817		enddo
818		endif
819	0	elseif (OBC%segment(n)%direction == OBC_DIRECTION_S) then
820	0	if ((J >= js-2) .and. (J <= Jeq+1)) then
821		do concurrent (kk=1:kmax, &
822	0	i=max(is-2,OBC%segment(n)%HI%isd):min(ie+2,OBC%segment(n)%HI%ied)) DO_LOCALITY(local(k))
823	0	k = kstart + kk - 1
824	0	h_v(i,J,kk) = h(i,j+1,k)
825		enddo
826		endif
827	0	elseif (OBC%segment(n)%direction == OBC_DIRECTION_E) then
828	0	if ((I >= is-2) .and. (I <= Ieq+1)) then
829		do concurrent (kk=1:kmax, &
830	0	j=max(js-2,OBC%segment(n)%HI%jsd):min(je+2,OBC%segment(n)%HI%jed)) DO_LOCALITY(local(k))
831	0	k = kstart + kk - 1
832	0	h_u(I,j,kk) = h(i,j,k)
833		enddo
834		endif
835	0	elseif (OBC%segment(n)%direction == OBC_DIRECTION_W) then
836	0	if ((I >= is-2) .and. (I <= Ieq+1)) then
837		do concurrent (kk=1:kmax, &
838	0	j=max(js-2,OBC%segment(n)%HI%jsd):min(je+2,OBC%segment(n)%HI%jed)) DO_LOCALITY(local(k))
839	0	k = kstart + kk - 1
840	0	h_u(I,j,kk) = h(i+1,j,k)
841		enddo
842		endif
843		endif
844		enddo ; endif
845		! Now project thicknesses across corner points on OBCs.
846	1875	if (apply_OBC) then ; do n=1,OBC%number_of_segments
847	0	J = OBC%segment(n)%HI%JsdB ; I = OBC%segment(n)%HI%IsdB
848	0	if (OBC%segment(n)%direction == OBC_DIRECTION_N) then
849	0	if ((J >= js-2) .and. (J <= je)) then
850	0	do concurrent (kk=1:kmax, I=max(is-2,OBC%segment(n)%HI%IsdB):min(Ieq+1,OBC%segment(n)%HI%IedB))
851	0	h_u(I,j+1,kk) = h_u(I,j,kk)
852		enddo
853		endif
854	0	elseif (OBC%segment(n)%direction == OBC_DIRECTION_S) then
855	0	if ((J >= js-1) .and. (J <= je+1)) then
856	0	do concurrent (kk=1:kmax, I=max(is-2,OBC%segment(n)%HI%isd):min(Ieq+1,OBC%segment(n)%HI%ied))
857	0	h_u(I,j,kk) = h_u(I,j+1,kk)
858		enddo
859		endif
860	0	elseif (OBC%segment(n)%direction == OBC_DIRECTION_E) then
861	0	if ((I >= is-2) .and. (I <= ie)) then
862	0	do concurrent (kk=1:kmax, J=max(js-2,OBC%segment(n)%HI%jsd):min(Jeq+1,OBC%segment(n)%HI%jed))
863	0	h_v(i+1,J,kk) = h_v(i,J,kk)
864		enddo
865		endif
866	0	elseif (OBC%segment(n)%direction == OBC_DIRECTION_W) then
867	0	if ((I >= is-1) .and. (I <= ie+1)) then
868	0	do concurrent (kk=1:kmax, J=max(js-2,OBC%segment(n)%HI%jsd):min(Jeq+1,OBC%segment(n)%HI%jed))
869	0	h_v(i,J,kk) = h_v(i+1,J,kk)
870		enddo
871		endif
872		endif
873		enddo ; endif
874
875		! Shearing strain (including no-slip boundary conditions at the 2-D land-sea mask).
876		! dudy and dvdx include modifications at OBCs from above.
877	1875	if (CS%no_slip) then
878	0	do concurrent (kk=1:kmax, J=js-2:Jeq+1, I=is-2:Ieq+1) DO_LOCALITY(local(k))
879	0	k = kstart + kk - 1
880	0	sh_xy(I,J,kk) = (2.0-G%mask2dBu(I,J)) * ( dvdx(I,J,kk) + dudy(I,J,kk) )
881	0	if (CS%id_shearstress > 0) ShSt(I,J,k) = sh_xy(I,J,kk)
882		enddo
883		else
884	232500	do concurrent (kk=1:kmax, J=js-2:Jeq+1, I=is-2:Ieq+1) DO_LOCALITY(local(k))
885	14529375	k = kstart + kk - 1
886	14529375	sh_xy(I,J,kk) = G%mask2dBu(I,J) * ( dvdx(I,J,kk) + dudy(I,J,kk) )
887	29291250	if (CS%id_shearstress > 0) ShSt(I,J,k) = sh_xy(I,J,kk)
888		enddo
889		endif
890
891	1875	if (CS%use_Leithy) then
892		! Shearing strain (including no-slip boundary conditions at the 2-D land-sea mask).
893		! dudy_smooth and dvdx_smooth do not (yet) include modifications at OBCs from above.
894	0	if (CS%no_slip) then
895	0	do concurrent (kk=1:kmax, J=js-1:Jeq, I=is-1:Ieq)
896	0	sh_xy_smooth(I,J,kk) = (2.0-G%mask2dBu(I,J)) * ( dvdx_smooth(I,J,kk) + dudy_smooth(I,J,kk) )
897		enddo
898		else
899	0	do concurrent (kk=1:kmax, J=js-1:Jeq, I=is-1:Ieq)
900	0	sh_xy_smooth(I,J,kk) = G%mask2dBu(I,J) * ( dvdx_smooth(I,J,kk) + dudy_smooth(I,J,kk) )
901		enddo
902		endif
903		endif ! use Leith+E
904
905		! Evaluate Del2u = x.Div(Grad u) and Del2v = y.Div( Grad u)
906	1875	if (CS%biharmonic) then
907	232500	do concurrent (kk=1:kmax, j=js-1:Jeq+1, I=Isq-1:Ieq+1)
908		Del2u(I,j,kk) = CS%Idx2dyCu(I,j) * ((CS%dx2q(I,J)sh_xy(I,J,kk)) - (CS%dx2q(I,J-1)sh_xy(I,J-1,kk))) + &
909	28830000	CS%Idxdy2u(I,j) * ((CS%dy2h(i+1,j)sh_xx(i+1,j,kk)) - (CS%dy2h(i,j)sh_xx(i,j,kk)))
910		enddo
911	230625	do concurrent (kk=1:kmax, J=Jsq-1:Jeq+1, i=is-1:Ieq+1)
912		Del2v(i,J,kk) = CS%Idxdy2v(i,J) * ((CS%dy2q(I,J)sh_xy(I,J,kk)) - (CS%dy2q(I-1,J)sh_xy(I-1,J,kk))) - &
913	29053125	CS%Idx2dyCv(i,J) * ((CS%dx2h(i,j+1)sh_xx(i,j+1,kk)) - (CS%dx2h(i,j)sh_xx(i,j,kk)))
914		enddo
915	1875	if (apply_OBC) then ; if (OBC%zero_biharmonic) then
916	0	do n=1,OBC%number_of_segments
917	0	I = OBC%segment(n)%HI%IsdB ; J = OBC%segment(n)%HI%JsdB
918	0	if (OBC%segment(n)%is_N_or_S .and. (J >= Jsq-1) .and. (J <= Jeq+1)) then
919	0	do concurrent (kk=1:kmax, I=OBC%segment(n)%HI%isd:OBC%segment(n)%HI%ied)
920	0	Del2v(i,J,kk) = 0.
921		enddo
922	0	elseif (OBC%segment(n)%is_E_or_W .and. (I >= Isq-1) .and. (I <= Ieq+1)) then
923	0	do concurrent (kk=1:kmax, j=OBC%segment(n)%HI%jsd:OBC%segment(n)%HI%jed)
924	0	Del2u(I,j,kk) = 0.
925		enddo
926		endif
927		enddo
928		endif ; endif
929		endif
930
931		! Vorticity
932	1875	if (use_vort_xy) then
933	0	if (CS%no_slip) then
934	0	do concurrent (kk=1:kmax, J=js_vort:je_vort, I=is_vort:ie_vort)
935	0	vort_xy(I,J,kk) = (2.0-G%mask2dBu(I,J)) * ( dvdx(I,J,kk) - dudy(I,J,kk) )
936		enddo
937		else
938	0	if (CS%use_circulation) then
939	0	do concurrent (kk=1:kmax, J=js_vort:je_vort, I=is_vort:ie_vort) DO_LOCALITY(local(k))
940	0	k = kstart + kk - 1
941		vort_xy(I,J,kk) = G%mask2dBu(I,J) * G%IareaBu(I,J) * ( &
942		((v(i+1,J,k)G%dyCv(i+1,J)) - (v(i,J,k)G%dyCv(i,J))) &
943		- ((u(I,j+1,k)G%dxCu(I,j+1)) - (u(I,j,k)G%dxCu(I,j))) &
944	0	)
945		enddo
946		else
947	0	do concurrent (kk=1:kmax, J=js_vort:je_vort, I=is_vort:ie_vort)
948	0	vort_xy(I,J,kk) = G%mask2dBu(I,J) * ( dvdx(I,J,kk) - dudy(I,J,kk) )
949		enddo
950		endif
951		endif
952		endif
953
954	1875	if (CS%use_Leithy) then
955	0	if (CS%no_slip) then
956	0	do concurrent (kk=1:kmax, J=js_Kh-1:je_Kh, I=is_Kh-1:ie_Kh)
957	0	vort_xy_smooth(I,J,kk) = (2.0-G%mask2dBu(I,J)) * ( dvdx_smooth(I,J,kk) - dudy_smooth(I,J,kk) )
958		enddo
959		else
960	0	do concurrent (kk=1:kmax, J=js_Kh-1:je_Kh, I=is_Kh-1:ie_Kh)
961	0	vort_xy_smooth(I,J,kk) = G%mask2dBu(I,J) * ( dvdx_smooth(I,J,kk) - dudy_smooth(I,J,kk) )
962		enddo
963		endif
964		endif
965
966
967	1875	if (use_Leith) then
968		call hor_visc_Leith_grad(G, GV, US, CS, VarMix, nkblock, kstart, kmax, &
969		is, ie, js, je, is_Kh, ie_Kh, js_Kh, je_Kh, Ieq, Jeq, &
970		h, dz, slope_x, slope_y, dudx, dvdy, vort_xy, vort_xy_smooth, &
971		grad_vort_mag_h, grad_vort_mag_h_2d, grad_div_mag_h, &
972		grad_vort_mag_q, grad_vort_mag_q_2d, grad_div_mag_q, &
973	0	vert_vort_mag_smooth, Del2vort_q)
974		endif ! CS%Leith_Kh
975
976	1875	if ((CS%Smagorinsky_Kh) .or. (CS%Smagorinsky_Ah)) then
977	1875	do concurrent (kk=1:kmax, j=js_Kh:je_Kh, i=is_Kh:ie_Kh) DO_LOCALITY(local(sh_xx_sq, sh_xy_sq))
978	14182500	sh_xx_sq = sh_xx(i,j,kk)**2
979		sh_xy_sq = 0.25 * ( ((sh_xy(I-1,J-1,kk)2) + (sh_xy(I,J,kk)2)) &
980	14182500	+ ((sh_xy(I-1,J,kk)2) + (sh_xy(I,J-1,kk)2)) )
981	28595625	Shear_mag(i,j,kk) = sqrt(sh_xx_sq + sh_xy_sq)
982		enddo
983		endif
984
985	1875	if (CS%bound_Ah .or. CS%bound_Kh) then
986	1875	do concurrent (kk=1:kmax, j=js_Kh:je_Kh, i=is_Kh:ie_Kh) DO_LOCALITY(local(k, h_min))
987	14182500	k = kstart + kk - 1
988	14182500	h_min = min(h_u(I,j,kk), h_u(I-1,j,kk), h_v(i,J,kk), h_v(i,J-1,kk))
989	28595625	hrat_min(i,j,kk) = min(1.0, h_min / (h(i,j,k) + h_neglect))
990		enddo
991		endif
992
993	1875	if (CS%Laplacian) then
994		! Determine the Laplacian viscosity at h points, using the
995		! largest value from several parameterizations. Also get
996		! the Laplacian component of str_xx.
997
998	1875	if ((CS%Leith_Kh) .or. (CS%Leith_Ah) .or. (CS%use_Leithy)) then
999	0	if (CS%use_QG_Leith_visc) then
1000	0	do concurrent (kk=1:kmax, j=js_Kh:je_Kh, i=is_Kh:ie_Kh) DO_LOCALITY(local(grad_vort, grad_vort_qg))
1001	0	grad_vort = grad_vort_mag_h(i,j,kk) + grad_div_mag_h(i,j,kk)
1002	0	grad_vort_qg = 3. * grad_vort_mag_h_2d(i,j,kk)
1003	0	vert_vort_mag(i,j,kk) = min(grad_vort, grad_vort_qg)
1004		enddo
1005		else
1006	0	do concurrent (kk=1:kmax, j=js_Kh:je_Kh, i=is_Kh:ie_Kh)
1007	0	vert_vort_mag(i,j,kk) = grad_vort_mag_h(i,j,kk) + grad_div_mag_h(i,j,kk)
1008		enddo
1009		endif
1010		endif
1011
1012		! Static (pre-computed) background viscosity
1013	1875	do concurrent (kk=1:kmax, j=js_Kh:je_Kh, i=is_Kh:ie_Kh)
1014	28595625	Kh(i,j,kk) = CS%Kh_bg_xx(i,j)
1015		enddo
1016
1017		! NOTE: The following do-block can be decomposed and vectorized after the
1018		! stack size has been reduced.
1019	1875	do concurrent (kk=1:kmax, j=js_Kh:je_Kh, i=is_Kh:ie_Kh)
1020	28595625	if (CS%add_LES_viscosity) then
1021	0	if (CS%Smagorinsky_Kh) &
1022	0	Kh(i,j,kk) = Kh(i,j,kk) + CS%Laplac2_const_xx(i,j) * Shear_mag(i,j,kk)
1023	0	if (CS%Leith_Kh) &
1024	0	Kh(i,j,kk) = Kh(i,j,kk) + CS%Laplac3_const_xx(i,j) * vert_vort_mag(i,j,kk) * inv_PI3
1025		else
1026	14182500	if (CS%Smagorinsky_Kh) &
1027	0	Kh(i,j,kk) = max(Kh(i,j,kk), CS%Laplac2_const_xx(i,j) * Shear_mag(i,j,kk))
1028	14182500	if (CS%Leith_Kh) &
1029	0	Kh(i,j,kk) = max(Kh(i,j,kk), CS%Laplac3_const_xx(i,j) * vert_vort_mag(i,j,kk) * inv_PI3)
1030		endif
1031		enddo
1032
1033		! All viscosity contributions above are subject to resolution scaling
1034
1035	1875	if (rescale_Kh) then
1036		!$omp target update from(Kh)
1037	14302500	do kk=1,kmax ; do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh
1038	14298750	Kh(i,j,kk) = VarMix%Res_fn_h(i,j) * Kh(i,j,kk)
1039		enddo ; enddo ; enddo
1040		!$omp target update to(Kh)
1041		endif
1042
1043		! Place a floor on the viscosity, if desired.
1044	1875	do concurrent (kk=1:kmax, j=js_Kh:je_Kh, i=is_Kh:ie_Kh)
1045	28595625	Kh(i,j,kk) = max(Kh(i,j,kk), CS%Kh_bg_min)
1046		enddo
1047
1048	1875	if (use_MEKE_Ku .and. .not. CS%EY24_EBT_BS) then
1049		!$omp target update from(Kh)
1050		! Add the MEKE contribution (which might be negative)
1051	0	if (use_kh_struct) then
1052	0	if (CS%res_scale_MEKE) then
1053	0	do kk=1,kmax ; do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh
1054	0	k = kstart + kk - 1
1055	0	Kh(i,j,kk) = Kh(i,j,kk) + MEKE%Ku(i,j) * VarMix%Res_fn_h(i,j) * VarMix%BS_struct(i,j,k)
1056		enddo ; enddo ; enddo
1057		else
1058	0	do kk=1,kmax ; do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh
1059	0	k = kstart + kk - 1
1060	0	Kh(i,j,kk) = Kh(i,j,kk) + MEKE%Ku(i,j) * VarMix%BS_struct(i,j,k)
1061		enddo ; enddo ; enddo
1062		endif
1063		else
1064	0	if (CS%res_scale_MEKE) then
1065	0	do kk=1,kmax ; do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh
1066	0	Kh(i,j,kk) = Kh(i,j,kk) + MEKE%Ku(i,j) * VarMix%Res_fn_h(i,j)
1067		enddo ; enddo ; enddo
1068		else
1069	0	do kk=1,kmax ; do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh
1070	0	Kh(i,j,kk) = Kh(i,j,kk) + MEKE%Ku(i,j)
1071		enddo ; enddo ; enddo
1072		endif
1073		endif
1074		!$omp target update to(Kh)
1075		endif
1076
1077	1875	if (CS%anisotropic) then
1078	0	do concurrent (kk=1:kmax, j=js_Kh:je_Kh, i=is_Kh:ie_Kh)
1079		! Add the tension component of anisotropic viscosity
1080	0	Kh(i,j,kk) = Kh(i,j,kk) + CS%Kh_aniso * (1. - CS%n1n2_h(i,j)**2)
1081		enddo
1082		endif
1083
1084		! Newer method of bounding for stability
1085	1875	if ((CS%bound_Kh) .and. (CS%bound_Ah)) then
1086	1875	do concurrent (kk=1:kmax, j=js_Kh:je_Kh, i=is_Kh:ie_Kh) DO_LOCALITY(local(Kh_max_here))
1087	14182500	visc_bound_rem(i,j,kk) = 1.0
1088	14182500	Kh_max_here = hrat_min(i,j,kk) * CS%Kh_Max_xx(i,j)
1089	28595625	if (Kh(i,j,kk) >= Kh_max_here) then
1090	4713750	visc_bound_rem(i,j,kk) = 0.0
1091	4713750	Kh(i,j,kk) = Kh_max_here
1092	9468750	elseif ((Kh(i,j,kk) > 0.0) .or. (CS%backscatter_underbound .and. (Kh_max_here > 0.0))) then
1093	0	visc_bound_rem(i,j,kk) = 1.0 - Kh(i,j,kk) / Kh_max_here
1094		endif
1095		enddo
1096	0	elseif (CS%bound_Kh) then
1097	0	do concurrent (kk=1:kmax, j=js_Kh:je_Kh, i=is_Kh:ie_Kh)
1098	0	Kh(i,j,kk) = min(Kh(i,j,kk), hrat_min(i,j,kk) * CS%Kh_Max_xx(i,j))
1099		enddo
1100		endif
1101
1102		! In Leith+E parameterization Kh is computed after Ah in the biharmonic loop.
1103		! The harmonic component of str_xx is added in the biharmonic loop.
1104	1875	if (CS%use_Leithy) then
1105	0	do concurrent (kk=1:kmax, j=js_Kh:je_Kh, i=is_Kh:ie_Kh)
1106	0	Kh(i,j,kk) = 0.
1107		enddo
1108		endif
1109
1110	1875	if (CS%id_Kh_h>0 .or. CS%debug) then
1111	0	do concurrent (kk=1:kmax, j=js_Kh:je_Kh, i=is_Kh:ie_Kh) DO_LOCALITY(local(k))
1112	0	k = kstart + kk - 1
1113	0	Kh_h(i,j,k) = Kh(i,j,kk)
1114		enddo
1115		endif
1116
1117	1875	if (CS%id_grid_Re_Kh>0) then
1118	0	do concurrent (kk=1:kmax, j=js:je, i=is:ie) DO_LOCALITY(local(k, KE, grid_Kh))
1119	0	k = kstart + kk - 1
1120	0	KE = 0.125(((u(I,j,k)+u(I-1,j,k))2) + ((v(i,J,k)+v(i,J-1,k))*2))
1121	0	grid_Kh = max(Kh(i,j,kk), CS%min_grid_Kh)
1122	0	grid_Re_Kh(i,j,k) = (sqrt(KE) * sqrt(CS%grid_sp_h2(i,j))) / grid_Kh
1123		enddo
1124		endif
1125
1126	1875	if (CS%id_div_xx_h>0) then
1127	0	do concurrent (kk=1:kmax, j=js:je, i=is:ie) DO_LOCALITY(local(k))
1128	0	k = kstart + kk - 1
1129	0	div_xx_h(i,j,k) = dudx(i,j,kk) + dvdy(i,j,kk)
1130		enddo
1131		endif
1132
1133	1875	if (CS%id_sh_xx_h>0) then
1134	0	do concurrent (kk=1:kmax, j=js:je, i=is:ie) DO_LOCALITY(local(k))
1135	0	k = kstart + kk - 1
1136	0	sh_xx_h(i,j,k) = sh_xx(i,j,kk)
1137		enddo
1138		endif
1139
1140	230625	do concurrent (kk=1:kmax, j=Jsq:Jeq+1, i=Isq:Ieq+1)
1141	28595625	str_xx(i,j,kk) = -Kh(i,j,kk) * sh_xx(i,j,kk)
1142		enddo
1143		else
1144	0	do concurrent (kk=1:kmax, j=Jsq:Jeq+1, i=Isq:Ieq+1)
1145	0	str_xx(i,j,kk) = 0.0
1146		enddo
1147		endif ! Get Kh at h points and get Laplacian component of str_xx
1148
1149	1875	if (CS%anisotropic) then
1150	0	do concurrent (kk=1:kmax, j=Jsq:Jeq+1, i=Isq:Ieq+1) DO_LOCALITY(local(local_strain))
1151		! Shearing-strain averaged to h-points
1152	0	local_strain = 0.25 * ( (sh_xy(I,J,kk) + sh_xy(I-1,J-1,kk)) + (sh_xy(I-1,J,kk) + sh_xy(I,J-1,kk)) )
1153		! Add the shear-strain contribution to the xx-component of stress
1154	0	str_xx(i,j,kk) = str_xx(i,j,kk) - CS%Kh_aniso * CS%n1n2_h(i,j) * CS%n1n1_m_n2n2_h(i,j) * local_strain
1155		enddo
1156		endif
1157
1158	1875	if (CS%biharmonic) then
1159		! Determine the biharmonic viscosity at h points, using the
1160		! largest value from several parameterizations. Also get the
1161		! biharmonic component of str_xx.
1162	1875	do concurrent (kk=1:kmax, j=js_Kh:je_Kh, i=is_Kh:ie_Kh)
1163	28595625	Ah(i,j,kk) = CS%Ah_bg_xx(i,j)
1164		enddo
1165
1166	1875	if ((CS%Smagorinsky_Ah) .or. (CS%Leith_Ah) .or. (CS%use_Leithy)) then
1167	1875	if (CS%Smagorinsky_Ah) then
1168	1875	if (CS%bound_Coriolis) then
1169	1875	do concurrent (kk=1:kmax, j=js_Kh:je_Kh, i=is_Kh:ie_Kh) DO_LOCALITY(local(AhSm))
1170		AhSm = Shear_mag(i,j,kk) * (CS%Biharm_const_xx(i,j) &
1171	14182500	+ CS%Biharm_const2_xx(i,j) * Shear_mag(i,j,kk))
1172	28595625	Ah(i,j,kk) = max(Ah(i,j,kk), AhSm)
1173		enddo
1174		else
1175	0	do concurrent (kk=1:kmax, j=js_Kh:je_Kh, i=is_Kh:ie_Kh) DO_LOCALITY(local(AhSm))
1176	0	AhSm = CS%Biharm_const_xx(i,j) * Shear_mag(i,j,kk)
1177	0	Ah(i,j,kk) = max(Ah(i,j,kk), AhSm)
1178		enddo
1179		endif
1180		endif
1181
1182	1875	if (CS%Leith_Ah) then
1183	0	do concurrent (kk=1:kmax, j=js_Kh:je_Kh, i=is_Kh:ie_Kh) DO_LOCALITY(local(Del2vort_h, AhLth))
1184		Del2vort_h = 0.25 * ((Del2vort_q(I,J,kk) + Del2vort_q(I-1,J-1,kk)) + &
1185	0	(Del2vort_q(I-1,J,kk) + Del2vort_q(I,J-1,kk)))
1186	0	AhLth = CS%Biharm6_const_xx(i,j) * abs(Del2vort_h) * inv_PI6
1187	0	Ah(i,j,kk) = max(Ah(i,j,kk), AhLth)
1188		enddo
1189		endif
1190
1191	1875	if (CS%use_Leithy) then
1192		call hor_visc_Leithy_Ah(G, GV, CS, nkblock, kstart, kmax, is_Kh, ie_Kh, js_Kh, je_Kh, inv_PI6, &
1193		Del2vort_q, vert_vort_mag, vert_vort_mag_smooth, vort_xy_smooth, &
1194	0	Ah, Ah_h, m_leithy)
1195		endif
1196
1197		endif ! Smagorinsky_Ah or Leith_Ah or Leith+E
1198
1199	1875	if (use_MEKE_Au) then
1200		! Add the MEKE contribution
1201		!$omp target update from(Ah)
1202	0	do kk=1,kmax ; do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh
1203	0	Ah(i,j,kk) = Ah(i,j,kk) + MEKE%Au(i,j)
1204		enddo ; enddo ; enddo
1205		!$omp target update to(Ah)
1206		endif
1207
1208	1875	if (CS%Re_Ah > 0.0) then
1209		!$omp target update from(Ah)
1210	0	do kk=1,kmax ; do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh
1211	0	k = kstart + kk - 1
1212	0	KE = 0.125(((u(I,j,k)+u(I-1,j,k))2) + ((v(i,J,k)+v(i,J-1,k))*2))
1213	0	Ah(i,j,kk) = sqrt(KE) * CS%Re_Ah_const_xx(i,j)
1214		enddo ; enddo ; enddo
1215		!$omp target update to(Ah)
1216		endif
1217
1218	1875	if (CS%bound_Ah) then
1219	1875	if (CS%bound_Kh) then
1220	1875	do concurrent (kk=1:kmax, j=js_Kh:je_Kh, i=is_Kh:ie_Kh)
1221	28595625	Ah(i,j,kk) = min(Ah(i,j,kk), visc_bound_rem(i,j,kk) * hrat_min(i,j,kk) * CS%Ah_Max_xx(i,j))
1222		enddo
1223		else
1224	0	do concurrent (kk=1:kmax, j=js_Kh:je_Kh, i=is_Kh:ie_Kh)
1225	0	Ah(i,j,kk) = min(Ah(i,j,kk), hrat_min(i,j,kk) * CS%Ah_Max_xx(i,j))
1226		enddo
1227		endif
1228		endif
1229
1230	1875	if (CS%EY24_EBT_BS) then
1231	0	do concurrent (kk=1:kmax, j=js_Kh:je_Kh, i=is_Kh:ie_Kh) DO_LOCALITY(local(k, tmp))
1232	0	k = kstart + kk - 1
1233	0	tmp = CS%KS_coef * hrat_min(i,j,kk) * CS%Ah_Max_xx_KS(i,j)
1234	0	visc_limit_h(i,j,k) = tmp
1235	0	visc_limit_h_frac(i,j,k) = Ah(i,j,kk) / (CS%KS_coef * hrat_min(i,j,kk) * CS%Ah_Max_xx_KS(i,j))
1236	0	if (Ah(i,j,kk) >= tmp) then
1237	0	visc_limit_h_flag(i,j,k) = 1.
1238		endif
1239		enddo
1240		endif
1241
1242	1875	if ((CS%id_Ah_h>0) .or. CS%debug .or. CS%use_Leithy) then
1243	0	do concurrent (kk=1:kmax, j=js_Kh:je_Kh, i=is_Kh:ie_Kh) DO_LOCALITY(local(k))
1244	0	k = kstart + kk - 1
1245	0	Ah_h(i,j,k) = Ah(i,j,kk)
1246		enddo
1247		endif
1248
1249	1875	if (CS%use_Leithy) then
1250		! Compute Leith+E Kh after bounds have been applied to Ah
1251		! and after it has been smoothed. Kh = -m_leithy * Ah
1252	0	do concurrent (kk=1:kmax, j=js_Kh:je_Kh, i=is_Kh:ie_Kh) DO_LOCALITY(local(k))
1253	0	k = kstart + kk - 1
1254	0	Kh(i,j,kk) = -m_leithy(i,j,kk) * Ah(i,j,kk)
1255	0	Kh_h(i,j,k) = Kh(i,j,kk)
1256		enddo
1257		endif
1258
1259	1875	if (CS%id_grid_Re_Ah > 0) then
1260	0	do concurrent (kk=1:kmax, j=js:je, i=is:ie) DO_LOCALITY(local(k, KE, grid_Ah))
1261	0	k = kstart + kk - 1
1262	0	KE = 0.125 * (((u(I,j,k) + u(I-1,j,k))2) + ((v(i,J,k) + v(i,J-1,k))2))
1263	0	grid_Ah = max(Ah(i,j,kk), CS%min_grid_Ah)
1264	0	grid_Re_Ah(i,j,k) = (sqrt(KE) * CS%grid_sp_h3(i,j)) / grid_Ah
1265		enddo
1266		endif
1267
1268	230625	do concurrent (kk=1:kmax, j=Jsq:Jeq+1, i=Isq:Ieq+1) DO_LOCALITY(local(k, d_del2u, d_del2v, d_str))
1269	14182500	k = kstart + kk - 1
1270	14182500	d_del2u = (G%IdyCu(I,j) * Del2u(I,j,kk)) - (G%IdyCu(I-1,j) * Del2u(I-1,j,kk))
1271	14182500	d_del2v = (G%IdxCv(i,J) * Del2v(i,J,kk)) - (G%IdxCv(i,J-1) * Del2v(i,J-1,kk))
1272	14182500	d_str = Ah(i,j,kk) * ((CS%DY_dxT(i,j) * d_del2u) - (CS%DX_dyT(i,j) * d_del2v))
1273
1274	14182500	str_xx(i,j,kk) = str_xx(i,j,kk) + d_str
1275
1276	14182500	if (CS%use_Leithy) str_xx(i,j,kk) = str_xx(i,j,kk) - Kh(i,j,kk) * sh_xx_smooth(i,j,kk)
1277
1278		! Keep a copy of the biharmonic contribution for backscatter parameterization
1279	28595625	bhstr_xx(i,j,kk) = d_str * (h(i,j,k) * CS%reduction_xx(i,j))
1280		enddo
1281		endif ! Get biharmonic coefficient at h points and biharmonic part of str_xx
1282
1283		! Backscatter using MEKE
1284	1875	if (CS%EY24_EBT_BS) then
1285		call hor_visc_backscatter_h(G, CS, MEKE, VarMix, use_kh_struct, nkblock, kstart, kmax, &
1286	0	Isq, Ieq, Jsq, Jeq, visc_limit_h_flag, sh_xx, str_xx, BS_coeff_h)
1287		endif ! Backscatter
1288
1289	1875	if (CS%biharmonic) then
1290		! Gradient of Laplacian, for use in bi-harmonic term
1291	228750	do concurrent (kk=1:kmax, J=js-1:Jeq, I=is-1:Ieq)
1292	13839375	dDel2vdx(I,J,kk) = CS%DY_dxBu(I,J)((Del2v(i+1,J,kk)G%IdyCv(i+1,J)) - (Del2v(i,J,kk)*G%IdyCv(i,J)))
1293	27907500	dDel2udy(I,J,kk) = CS%DX_dyBu(I,J)((Del2u(I,j+1,kk)G%IdxCu(I,j+1)) - (Del2u(I,j,kk)*G%IdxCu(I,j)))
1294		enddo
1295		! Adjust contributions to shearing strain on open boundaries.
1296	1875	if (apply_OBC) then ; if ((OBC%strain_config == OBC_STRAIN_ZERO) .or. &
1297		(OBC%strain_config == OBC_STRAIN_FREESLIP)) then
1298	0	do n=1,OBC%number_of_segments
1299	0	J = OBC%segment(n)%HI%JsdB ; I = OBC%segment(n)%HI%IsdB
1300	0	if (OBC%segment(n)%is_N_or_S .and. (J >= js-1) .and. (J <= Jeq)) then
1301	0	do concurrent (kk=1:kmax, I=OBC%segment(n)%HI%IsdB:OBC%segment(n)%HI%IedB)
1302	0	if (OBC%strain_config == OBC_STRAIN_ZERO) then
1303	0	dDel2vdx(I,J,kk) = 0. ; dDel2udy(I,J,kk) = 0.
1304	0	elseif (OBC%strain_config == OBC_STRAIN_FREESLIP) then
1305	0	dDel2udy(I,J,kk) = 0.
1306		endif
1307		enddo
1308	0	elseif (OBC%segment(n)%is_E_or_W .and. (I >= is-1) .and. (I <= Ieq)) then
1309	0	do concurrent (kk=1:kmax, J=OBC%segment(n)%HI%JsdB:OBC%segment(n)%HI%JedB)
1310	0	if (OBC%strain_config == OBC_STRAIN_ZERO) then
1311	0	dDel2vdx(I,J,kk) = 0. ; dDel2udy(I,J,kk) = 0.
1312	0	elseif (OBC%strain_config == OBC_STRAIN_FREESLIP) then
1313	0	dDel2vdx(I,J,kk) = 0.
1314		endif
1315		enddo
1316		endif
1317		enddo
1318		endif ; endif
1319		endif
1320
1321	1875	if ((CS%Smagorinsky_Kh) .or. (CS%Smagorinsky_Ah)) then
1322	228750	do concurrent (kk=1:kmax, J=js-1:Jeq, I=is-1:Ieq) DO_LOCALITY(local(sh_xy_sq, sh_xx_sq))
1323	13839375	sh_xy_sq = sh_xy(I,J,kk)**2
1324		sh_xx_sq = 0.25 * ( ((sh_xx(i,j,kk)2) + (sh_xx(i+1,j+1,kk)2)) &
1325	13839375	+ ((sh_xx(i,j+1,kk)2) + (sh_xx(i+1,j,kk)2)) )
1326	27907500	Shear_mag(I,J,kk) = sqrt(sh_xy_sq + sh_xx_sq)
1327		enddo
1328		endif
1329
1330	228750	do concurrent (kk=1:kmax, J=js-1:Jeq, I=is-1:Ieq) DO_LOCALITY(local(h2uq, h2vq))
1331	13839375	h2uq = 4.0 * (h_u(I,j,kk) * h_u(I,j+1,kk))
1332	13839375	h2vq = 4.0 * (h_v(i,J,kk) * h_v(i+1,J,kk))
1333		hq(I,J,kk) = (2.0 * (h2uq * h2vq)) &
1334	27907500	/ (h_neglect3 + (h2uq + h2vq) * ((h_u(I,j,kk) + h_u(I,j+1,kk)) + (h_v(i,J,kk) + h_v(i+1,J,kk))))
1335		enddo
1336
1337	1875	if (CS%bound_Ah .or. CS%bound_Kh) then
1338	228750	do concurrent (kk=1:kmax, J=js-1:Jeq, I=is-1:Ieq) DO_LOCALITY(local(h_min))
1339	13839375	h_min = min(h_u(I,j,kk), h_u(I,j+1,kk), h_v(i,J,kk), h_v(i+1,J,kk))
1340	27907500	hrat_min(I,J,kk) = min(1.0, h_min / (hq(I,J,kk) + h_neglect))
1341		enddo
1342
1343		endif
1344
1345	1875	if (CS%no_slip) then
1346	0	do concurrent (kk=1:kmax, J=js-1:Jeq, I=is-1:Ieq) DO_LOCALITY(local(hu, hv))
1347	0	if (CS%no_slip .and. (G%mask2dBu(I,J) < 0.5)) then
1348	0	if ((G%mask2dCu(I,j) + G%mask2dCu(I,j+1)) + &
1349		(G%mask2dCv(i,J) + G%mask2dCv(i+1,J)) > 0.0) then
1350		! This is a coastal vorticity point, so modify hq and hrat_min.
1351
1352	0	hu = G%mask2dCu(I,j) * h_u(I,j,kk) + G%mask2dCu(I,j+1) * h_u(I,j+1,kk)
1353	0	hv = G%mask2dCv(i,J) * h_v(i,J,kk) + G%mask2dCv(i+1,J) * h_v(i+1,J,kk)
1354	0	if ((G%mask2dCu(I,j) + G%mask2dCu(I,j+1)) * &
1355		(G%mask2dCv(i,J) + G%mask2dCv(i+1,J)) == 0.0) then
1356		! Only one of hu and hv is nonzero, so just add them.
1357	0	hq(I,J,kk) = hu + hv
1358	0	hrat_min(I,J,kk) = 1.0
1359		else
1360		! Both hu and hv are nonzero, so take the harmonic mean.
1361	0	hq(I,J,kk) = 2.0 * (hu * hv) / ((hu + hv) + h_neglect)
1362	0	hrat_min(I,J,kk) = min(1.0, min(hu, hv) / (hq(I,J,kk) + h_neglect) )
1363		endif
1364		endif
1365		endif
1366		enddo
1367		endif
1368
1369		! Pass the velocity gradients and thickness to ZB2020
1370	1875	if (CS%use_ZB2020) then
1371	0	do kk=1,kmax
1372	0	k = kstart + kk - 1
1373		call ZB2020_copy_gradient_and_thickness(sh_xx(:,:,kk), sh_xy(:,:,kk), vort_xy(:,:,kk), hq(:,:,kk), &
1374	0	G, GV, CS%ZB2020, k)
1375		enddo
1376		endif
1377
1378	1875	if (CS%Laplacian) then
1379		! Determine the Laplacian viscosity at q points, using the
1380		! largest value from several parameterizations. Also get the
1381		! Laplacian component of str_xy.
1382
1383	1875	if ((CS%Leith_Kh) .or. (CS%Leith_Ah)) then
1384	0	if (CS%use_QG_Leith_visc) then
1385	0	do concurrent (kk=1:kmax, J=js-1:Jeq, I=is-1:Ieq) DO_LOCALITY(local(grad_vort, grad_vort_qg))
1386	0	grad_vort = grad_vort_mag_q(I,J,kk) + grad_div_mag_q(I,J,kk)
1387	0	grad_vort_qg = 3. * grad_vort_mag_q_2d(I,J,kk)
1388	0	vert_vort_mag(I,J,kk) = min(grad_vort, grad_vort_qg)
1389		enddo
1390		else
1391	0	do concurrent (kk=1:kmax, J=js-1:Jeq, I=is-1:Ieq)
1392	0	vert_vort_mag(I,J,kk) = grad_vort_mag_q(I,J,kk) + grad_div_mag_q(I,J,kk)
1393		enddo
1394		endif
1395		endif
1396
1397		! Static (pre-computed) background viscosity
1398	228750	do concurrent (kk=1:kmax, J=js-1:Jeq, I=is-1:Ieq)
1399	27907500	Kh(I,J,kk) = CS%Kh_bg_xy(I,J)
1400		enddo
1401
1402	1875	if (CS%Smagorinsky_Kh) then
1403	0	if (CS%add_LES_viscosity) then
1404	0	do concurrent (kk=1:kmax, J=js-1:Jeq, I=is-1:Ieq)
1405	0	Kh(I,J,kk) = Kh(I,J,kk) + CS%Laplac2_const_xy(I,J) * Shear_mag(I,J,kk)
1406		enddo
1407		else
1408	0	do concurrent (kk=1:kmax, J=js-1:Jeq, I=is-1:Ieq)
1409	0	Kh(I,J,kk) = max(Kh(I,J,kk), CS%Laplac2_const_xy(I,J) * Shear_mag(I,J,kk) )
1410		enddo
1411		endif
1412		endif
1413
1414	1875	if (CS%Leith_Kh) then
1415	0	if (CS%add_LES_viscosity) then
1416	0	do concurrent (kk=1:kmax, J=js-1:Jeq, I=is-1:Ieq)
1417	0	Kh(I,J,kk) = Kh(I,J,kk) + CS%Laplac3_const_xy(I,J) * vert_vort_mag(I,J,kk) * inv_PI3 ! Is this right? -AJA
1418		enddo
1419		else
1420	0	do concurrent (kk=1:kmax, J=js-1:Jeq, I=is-1:Ieq)
1421	0	Kh(I,J,kk) = max(Kh(I,J,kk), CS%Laplac3_const_xy(I,J) * vert_vort_mag(I,J,kk) * inv_PI3)
1422		enddo
1423		endif
1424		endif
1425
1426		! All viscosity contributions above are subject to resolution scaling
1427
1428	1875	if (rescale_Kh) then
1429		!$omp target update from(Kh)
1430	13957500	do kk=1,kmax ; do J=js-1,Jeq ; do I=is-1,Ieq
1431	13953750	Kh(I,J,kk) = VarMix%Res_fn_q(I,J) * Kh(I,J,kk)
1432		enddo ; enddo ; enddo
1433		!$omp target update to(Kh)
1434		endif
1435
1436	228750	do concurrent (kk=1:kmax, J=js-1:Jeq, I=is-1:Ieq)
1437	27907500	Kh(I,J,kk) = max(Kh(I,J,kk), CS%Kh_bg_min) ! Place a floor on the viscosity, if desired.
1438		enddo
1439
1440	1875	if (use_MEKE_Ku .and. .not. CS%EY24_EBT_BS) then
1441		!$omp target update from(Kh)
1442	0	if (use_kh_struct) then
1443	0	do kk=1,kmax ; do J=js-1,Jeq ; do I=is-1,Ieq
1444	0	k = kstart + kk - 1
1445	0	meke_res_fn = 1.
1446	0	if (CS%res_scale_MEKE) meke_res_fn = VarMix%Res_fn_q(I,J)
1447
1448		Kh(I,J,kk) = Kh(I,J,kk) + 0.25( ((MEKE%Ku(i,j)VarMix%BS_struct(i,j,k)) + &
1449		(MEKE%Ku(i+1,j+1)*VarMix%BS_struct(i+1,j+1,k))) + &
1450		((MEKE%Ku(i+1,j)*VarMix%BS_struct(i+1,j,k)) + &
1451	0	(MEKE%Ku(i,j+1)VarMix%BS_struct(i,j+1,k))) ) meke_res_fn
1452		enddo ; enddo ; enddo
1453		else
1454	0	do kk=1,kmax ; do J=js-1,Jeq ; do I=is-1,Ieq
1455	0	meke_res_fn = 1.
1456	0	if (CS%res_scale_MEKE) meke_res_fn = VarMix%Res_fn_q(I,J)
1457
1458		Kh(I,J,kk) = Kh(I,J,kk) + 0.25 * ( &
1459		(MEKE%Ku(i,j) + MEKE%Ku(i+1,j+1)) + &
1460		(MEKE%Ku(i+1,j) + &
1461	0	MEKE%Ku(i,j+1)) ) * meke_res_fn
1462		enddo ; enddo ; enddo
1463		endif
1464		!$omp target update to(Kh)
1465		endif
1466
1467	1875	if (CS%anisotropic) then
1468		! Add the shear component of anisotropic viscosity
1469	0	do concurrent (kk=1:kmax, J=js-1:Jeq, I=is-1:Ieq)
1470	0	Kh(I,J,kk) = Kh(I,J,kk) + CS%Kh_aniso * CS%n1n2_q(I,J)**2
1471		enddo
1472		endif
1473
1474	228750	do concurrent (kk=1:kmax, J=js-1:Jeq, I=is-1:Ieq) DO_LOCALITY(local(Kh_max_here))
1475		! Newer method of bounding for stability
1476	27907500	if ((CS%bound_Kh) .and. (CS%bound_Ah)) then
1477	13839375	visc_bound_rem(I,J,kk) = 1.0
1478	13839375	Kh_max_here = hrat_min(I,J,kk) * CS%Kh_Max_xy(I,J)
1479	13839375	if (Kh(I,J,kk) >= Kh_max_here) then
1480	4185000	visc_bound_rem(I,J,kk) = 0.0
1481	4185000	Kh(I,J,kk) = Kh_max_here
1482	9654375	elseif ((Kh(I,J,kk) > 0.0) .or. (CS%backscatter_underbound .and. (Kh_max_here > 0.0))) then
1483	0	visc_bound_rem(I,J,kk) = 1.0 - Kh(I,J,kk) / Kh_max_here
1484		endif
1485	0	elseif (CS%bound_Kh) then
1486	0	Kh(I,J,kk) = min(Kh(I,J,kk), hrat_min(I,J,kk) * CS%Kh_Max_xy(I,J))
1487		endif
1488		enddo
1489
1490	1875	if (CS%use_Leithy) then
1491		! Leith+E doesn't recompute Kh at q points, it just interpolates it from h to q points
1492	0	do concurrent (kk=1:kmax, J=js-1:Jeq, I=is-1:Ieq) DO_LOCALITY(local(k))
1493	0	k = kstart + kk - 1
1494	0	Kh(I,J,kk) = 0.25 * ((Kh_h(i,j,k) + Kh_h(i+1,j+1,k)) + (Kh_h(i,j+1,k) + Kh_h(i+1,j,k)))
1495		enddo
1496		endif
1497
1498	1875	if (CS%id_Kh_q > 0 .or. CS%debug) then
1499	0	do concurrent (kk=1:kmax, J=js-1:Jeq, I=is-1:Ieq) DO_LOCALITY(local(k))
1500	0	k = kstart + kk - 1
1501	0	Kh_q(I,J,k) = Kh(I,J,kk)
1502		enddo
1503		endif
1504
1505	1875	if (CS%id_vort_xy_q > 0) then
1506	0	do concurrent (kk=1:kmax, J=js-1:Jeq, I=is-1:Ieq) DO_LOCALITY(local(k))
1507	0	k = kstart + kk - 1
1508	0	vort_xy_q(I,J,k) = vort_xy(I,J,kk)
1509		enddo
1510		endif
1511
1512	1875	if (CS%id_sh_xy_q > 0) then
1513	0	do concurrent (kk=1:kmax, J=js-1:Jeq, I=is-1:Ieq) DO_LOCALITY(local(k))
1514	0	k = kstart + kk - 1
1515	0	sh_xy_q(I,J,k) = sh_xy(I,J,kk)
1516		enddo
1517		endif
1518
1519	1875	if (.not. CS%use_Leithy) then
1520	228750	do concurrent (kk=1:kmax, J=js-1:Jeq, I=is-1:Ieq)
1521	27907500	str_xy(I,J,kk) = -Kh(I,J,kk) * sh_xy(I,J,kk)
1522		enddo
1523		else
1524	0	do concurrent (kk=1:kmax, J=js-1:Jeq, I=is-1:Ieq)
1525	0	str_xy(I,J,kk) = -Kh(I,J,kk) * sh_xy_smooth(I,J,kk)
1526		enddo
1527		endif
1528		else
1529	0	do concurrent (kk=1:kmax, J=js-1:Jeq, I=is-1:Ieq)
1530	0	str_xy(I,J,kk) = 0.
1531		enddo
1532		endif ! get harmonic coefficient Kh at q points and harmonic part of str_xy
1533
1534	1875	if (CS%anisotropic) then
1535	0	do concurrent (kk=1:kmax, J=js-1:Jeq, I=is-1:Ieq) DO_LOCALITY(local(local_strain))
1536		! Horizontal-tension averaged to q-points
1537	0	local_strain = 0.25 * ( (sh_xx(i,j,kk) + sh_xx(i+1,j+1,kk)) + (sh_xx(i+1,j,kk) + sh_xx(i,j+1,kk)) )
1538		! Add the tension contribution to the xy-component of stress
1539	0	str_xy(I,J,kk) = str_xy(I,J,kk) - CS%Kh_aniso * CS%n1n2_q(I,J) * CS%n1n1_m_n2n2_q(I,J) * local_strain
1540		enddo
1541		endif
1542
1543	1875	if (CS%biharmonic) then
1544		! Determine the biharmonic viscosity at q points, using the
1545		! largest value from several parameterizations. Also get the
1546		! biharmonic component of str_xy.
1547	228750	do concurrent (kk=1:kmax, J=js-1:Jeq, I=is-1:Ieq)
1548	27907500	Ah(I,J,kk) = CS%Ah_bg_xy(I,J)
1549		enddo
1550
1551	1875	if (CS%Smagorinsky_Ah .or. CS%Leith_Ah) then
1552	1875	if (CS%Smagorinsky_Ah) then
1553	1875	if (CS%bound_Coriolis) then
1554	228750	do concurrent (kk=1:kmax, J=js-1:Jeq, I=is-1:Ieq) DO_LOCALITY(local(AhSm))
1555		AhSm = Shear_mag(I,J,kk) * (CS%Biharm_const_xy(I,J) &
1556	13839375	+ CS%Biharm_const2_xy(I,J) * Shear_mag(I,J,kk))
1557	27907500	Ah(I,J,kk) = max(Ah(I,J,kk), AhSm)
1558		enddo
1559		else
1560	0	do concurrent (kk=1:kmax, J=js-1:Jeq, I=is-1:Ieq) DO_LOCALITY(local(AhSm))
1561	0	AhSm = CS%Biharm_const_xy(I,J) * Shear_mag(I,J,kk)
1562	0	Ah(I,J,kk) = max(Ah(I,J,kk), AhSm)
1563		enddo
1564		endif
1565		endif
1566
1567	1875	if (CS%Leith_Ah) then
1568	0	do concurrent (kk=1:kmax, J=js-1:Jeq, I=is-1:Ieq) DO_LOCALITY(local(AhLth))
1569	0	AhLth = CS%Biharm6_const_xy(I,J) * abs(Del2vort_q(I,J,kk)) * inv_PI6
1570	0	Ah(I,J,kk) = max(Ah(I,J,kk), AhLth)
1571		enddo
1572		endif
1573		endif ! Smagorinsky_Ah or Leith_Ah
1574
1575	1875	if (use_MEKE_Au) then
1576		! Add the MEKE contribution
1577		!$omp target update from(Ah)
1578	0	do kk=1,kmax ; do J=js-1,Jeq ; do I=is-1,Ieq
1579		Ah(I,J,kk) = Ah(I,J,kk) + 0.25 * ( &
1580	0	(MEKE%Au(i,j) + MEKE%Au(i+1,j+1)) + (MEKE%Au(i+1,j) + MEKE%Au(i,j+1)) )
1581		enddo ; enddo ; enddo
1582		!$omp target update to(Ah)
1583		endif
1584
1585	1875	if (CS%Re_Ah > 0.0) then
1586	0	do concurrent (kk=1:kmax, J=js-1:Jeq, I=is-1:Ieq) DO_LOCALITY(local(k, KE))
1587	0	k = kstart + kk - 1
1588	0	KE = 0.125 * (((u(I,j,k) + u(I,j+1,k))2) + ((v(i,J,k) + v(i+1,J,k))2))
1589	0	Ah(I,J,kk) = sqrt(KE) * CS%Re_Ah_const_xy(I,J)
1590		enddo
1591		endif
1592
1593	1875	if (CS%bound_Ah) then
1594	1875	if (CS%bound_Kh) then
1595	228750	do concurrent (kk=1:kmax, J=js-1:Jeq, I=is-1:Ieq)
1596	27907500	Ah(I,J,kk) = min(Ah(I,J,kk), visc_bound_rem(I,J,kk) * hrat_min(I,J,kk) * CS%Ah_Max_xy(I,J))
1597		enddo
1598		else
1599	0	do concurrent (kk=1:kmax, J=js-1:Jeq, I=is-1:Ieq)
1600	0	Ah(I,J,kk) = min(Ah(I,J,kk), hrat_min(I,J,kk) * CS%Ah_Max_xy(I,J))
1601		enddo
1602		endif
1603		endif
1604
1605	1875	if (CS%EY24_EBT_BS) then
1606	0	do concurrent (kk=1:kmax, J=js-1:Jeq, I=is-1:Ieq) DO_LOCALITY(local(k, tmp))
1607	0	k = kstart + kk - 1
1608	0	tmp = CS%KS_coef hrat_min(I,J,kk) CS%Ah_Max_xy_KS(I,J)
1609	0	visc_limit_q(I,J,k) = tmp
1610	0	visc_limit_q_frac(i,j,k) = Ah(i,j,kk) / (CS%KS_coef * hrat_min(i,j,kk) * CS%Ah_Max_xy_KS(i,j))
1611	0	if (Ah(I,J,kk) >= tmp) then
1612	0	visc_limit_q_flag(I,J,k) = 1.
1613		endif
1614		enddo
1615		endif
1616
1617		! Leith+E doesn't recompute Ah at q points, it just interpolates it from h to q points
1618	1875	if (CS%use_Leithy) then
1619	0	do concurrent (kk=1:kmax, J=js-1:Jeq, I=is-1:Ieq) DO_LOCALITY(local(k))
1620	0	k = kstart + kk - 1
1621	0	Ah(I,J,kk) = 0.25 * ((Ah_h(i,j,k) + Ah_h(i+1,j+1,k)) + (Ah_h(i,j+1,k) + Ah_h(i+1,j,k)))
1622		enddo
1623		endif
1624
1625	1875	if (CS%id_Ah_q>0 .or. CS%debug) then
1626	0	do concurrent (kk=1:kmax, J=js-1:Jeq, I=is-1:Ieq) DO_LOCALITY(local(k))
1627	0	k = kstart + kk - 1
1628	0	Ah_q(I,J,k) = Ah(I,J,kk)
1629		enddo
1630		endif
1631
1632		! Again, need to initialize str_xy as if its biharmonic
1633	228750	do concurrent (kk=1:kmax, J=js-1:Jeq, I=is-1:Ieq) DO_LOCALITY(local(d_str))
1634	13839375	d_str = Ah(I,J,kk) * (dDel2vdx(I,J,kk) + dDel2udy(I,J,kk))
1635
1636	13839375	str_xy(I,J,kk) = str_xy(I,J,kk) + d_str
1637
1638		! Keep a copy of the biharmonic contribution for backscatter parameterization
1639	27907500	bhstr_xy(I,J,kk) = d_str * (hq(I,J,kk) * G%mask2dBu(I,J) * CS%reduction_xy(I,J))
1640		enddo
1641		endif ! Get Ah at q points and biharmonic part of str_xy
1642
1643		! Backscatter using MEKE
1644	1875	if (CS%EY24_EBT_BS) then
1645		call hor_visc_backscatter_q(G, GV, CS, MEKE, VarMix, use_kh_struct, nkblock, kstart, kmax, &
1646	0	is, js, Ieq, Jeq, visc_limit_q_flag, sh_xy, str_xy, BS_coeff_q)
1647		endif ! Backscatter
1648
1649	1875	if (CS%use_GME) then
1650		! The wider halo here is to permit one pass of smoothing without a halo update.
1651	0	do concurrent (kk=1:kmax, j=Jsq-1:Jeq+2, i=Isq-1:Ieq+2) DO_LOCALITY(local(k, GME_coeff))
1652	0	k = kstart + kk - 1
1653		GME_coeff = GME_effic_h(i,j) * 0.25 * &
1654	0	((KH_u_GME(I,j,k)+KH_u_GME(I-1,j,k)) + (KH_v_GME(i,J,k)+KH_v_GME(i,J-1,k)))
1655	0	GME_coeff = MIN(GME_coeff, CS%GME_limiter)
1656
1657	0	if ((CS%id_GME_coeff_h>0) .or. find_FrictWork) GME_coeff_h(i,j,k) = GME_coeff
1658	0	str_xx_GME(i,j,kk) = GME_coeff * sh_xx_bt(i,j)
1659		enddo
1660
1661		! The wider halo here is to permit one pass of smoothing without a halo update.
1662	0	do concurrent (kk=1:kmax, J=js-2:je+1, I=is-2:ie+1) DO_LOCALITY(local(k, GME_coeff))
1663	0	k = kstart + kk - 1
1664		GME_coeff = GME_effic_q(I,J) * 0.25 * &
1665	0	((KH_u_GME(I,j,k)+KH_u_GME(I,j+1,k)) + (KH_v_GME(i,J,k)+KH_v_GME(i+1,J,k)))
1666	0	GME_coeff = MIN(GME_coeff, CS%GME_limiter)
1667
1668	0	if (CS%id_GME_coeff_q>0) GME_coeff_q(I,J,k) = GME_coeff
1669	0	str_xy_GME(I,J,kk) = GME_coeff * sh_xy_bt(I,J)
1670		enddo
1671
1672		! Applying GME diagonal term. This is linear and the arguments can be rescaled.
1673		! smooth_GME is an impure host routine, so str_xx_GME/str_xy_GME must be brought back
1674		! from the device before this loop and pushed back afterward.
1675		!$omp target update from(str_xx_GME, str_xy_GME)
1676	0	do kk=1,kmax
1677	0	call smooth_GME(CS, G, GME_flux_h=str_xx_GME(:,:,kk))
1678	0	call smooth_GME(CS, G, GME_flux_q=str_xy_GME(:,:,kk))
1679		enddo
1680		!$omp target update to(str_xx_GME, str_xy_GME)
1681
1682		! This changes the units of str_xx from [L2 T-2 ~> m2 s-2] to [H L2 T-2 ~> m3 s-2 or kg s-2].
1683	0	do concurrent (kk=1:kmax, j=Jsq:Jeq+1, i=Isq:Ieq+1) DO_LOCALITY(local(k))
1684	0	k = kstart + kk - 1
1685	0	str_xx(i,j,kk) = (str_xx(i,j,kk) + str_xx_GME(i,j,kk)) * (h(i,j,k) * CS%reduction_xx(i,j))
1686		enddo
1687
1688		! This adds in GME and changes the units of str_xx from [L2 T-2 ~> m2 s-2] to [H L2 T-2 ~> m3 s-2 or kg s-2].
1689	0	if (CS%no_slip) then
1690	0	do concurrent (kk=1:kmax, J=js-1:Jeq, I=is-1:Ieq)
1691	0	str_xy(I,J,kk) = (str_xy(I,J,kk) + str_xy_GME(I,J,kk)) * (hq(I,J,kk) * CS%reduction_xy(I,J))
1692		enddo
1693		else
1694	0	do concurrent (kk=1:kmax, J=js-1:Jeq, I=is-1:Ieq)
1695	0	str_xy(I,J,kk) = (str_xy(I,J,kk) + str_xy_GME(I,J,kk)) * (hq(I,J,kk) * G%mask2dBu(I,J) * CS%reduction_xy(I,J))
1696		enddo
1697		endif
1698
1699		else ! .not. use_GME
1700		! This changes the units of str_xx from [L2 T-2 ~> m2 s-2] to [H L2 T-2 ~> m3 s-2 or kg s-2].
1701	230625	do concurrent (kk=1:kmax, j=Jsq:Jeq+1, i=Isq:Ieq+1) DO_LOCALITY(local(k))
1702	14182500	k = kstart + kk - 1
1703	28595625	str_xx(i,j,kk) = str_xx(i,j,kk) * (h(i,j,k) * CS%reduction_xx(i,j))
1704		enddo
1705
1706		! This changes the units of str_xy from [L2 T-2 ~> m2 s-2] to [H L2 T-2 ~> m3 s-2 or kg s-2].
1707	1875	if (CS%no_slip) then
1708	0	do concurrent (kk=1:kmax, J=js-1:Jeq, I=is-1:Ieq)
1709	0	str_xy(I,J,kk) = str_xy(I,J,kk) * (hq(I,J,kk) * CS%reduction_xy(I,J))
1710		enddo
1711		else
1712	228750	do concurrent (kk=1:kmax, J=js-1:Jeq, I=is-1:Ieq)
1713	27907500	str_xy(I,J,kk) = str_xy(I,J,kk) * (hq(I,J,kk) * G%mask2dBu(I,J) * CS%reduction_xy(I,J))
1714		enddo
1715		endif
1716		endif ! use_GME
1717
1718		! Evaluate 1/h x.Div(h Grad u) or the biharmonic equivalent.
1719	1875	do concurrent (kk=1:kmax, j=js:je, I=Isq:Ieq) DO_LOCALITY(local(k))
1720	13612500	k = kstart + kk - 1
1721		diffu(I,j,k) = ((G%IdxCu(I,j)((CS%dx2q(I,J-1)str_xy(I,J-1,kk)) - (CS%dx2q(I,J)*str_xy(I,J,kk))) + &
1722		G%IdyCu(I,j)((CS%dy2h(i,j)str_xx(i,j,kk)) - (CS%dy2h(i+1,j)str_xx(i+1,j,kk)))) &
1723	27453750	G%IareaCu(I,j)) / (h_u(I,j,kk) + h_neglect)
1724		enddo
1725
1726	1875	if (apply_OBC) then
1727		! This is not the right boundary condition. If all the masking of tendencies are done
1728		! correctly later then eliminating this block should not change answers.
1729	0	do n=1,OBC%number_of_segments
1730	0	if (OBC%segment(n)%is_E_or_W) then
1731	0	I = OBC%segment(n)%HI%IsdB
1732	0	do concurrent (kk=1:kmax, j=OBC%segment(n)%HI%jsd:OBC%segment(n)%HI%jed) DO_LOCALITY(local(k))
1733	0	k = kstart + kk - 1
1734	0	diffu(I,j,k) = 0.
1735		enddo
1736		endif
1737		enddo
1738		endif
1739
1740		! Evaluate 1/h y.Div(h Grad u) or the biharmonic equivalent.
1741	1875	do concurrent (kk=1:kmax, J=Jsq:Jeq, i=is:ie) DO_LOCALITY(local(k))
1742	13725000	k = kstart + kk - 1
1743		diffv(i,J,k) = ((G%IdyCv(i,J)((CS%dy2q(I-1,J)str_xy(I-1,J,kk)) - (CS%dy2q(I,J)*str_xy(I,J,kk))) - &
1744		G%IdxCv(i,J)((CS%dx2h(i,j)str_xx(i,j,kk)) - (CS%dx2h(i,j+1)str_xx(i,j+1,kk)))) &
1745	27676875	G%IareaCv(i,J)) / (h_v(i,J,kk) + h_neglect)
1746		enddo
1747
1748	1875	if (apply_OBC) then
1749		! This is not the right boundary condition. If all the masking of tendencies are done
1750		! correctly later then eliminating this block should not change answers.
1751	0	do n=1,OBC%number_of_segments
1752	0	if (OBC%segment(n)%is_N_or_S) then
1753	0	J = OBC%segment(n)%HI%JsdB
1754	0	do concurrent (kk=1:kmax, i=OBC%segment(n)%HI%isd:OBC%segment(n)%HI%ied) DO_LOCALITY(local(k))
1755	0	k = kstart + kk - 1
1756	0	diffv(i,J,k) = 0.
1757		enddo
1758		endif
1759		enddo
1760		endif
1761
1762	1875	if (find_FrictWork) then
1763	0	if (CS%FrictWork_bug) then
1764		! Diagnose str_xxd_x u - str_yyd_y v + str_xy*(d_y u + d_x v)
1765		! This is the old formulation that includes energy diffusion
1766	0	do concurrent (kk=1:kmax, j=js:je, i=is:ie) DO_LOCALITY(local(k))
1767	0	k = kstart + kk - 1
1768		FrictWork(i,j,k) = GV%H_to_RZ * ( &
1769		((str_xx(i,j,kk) * (u(I,j,k)-u(I-1,j,k))*G%IdxT(i,j)) &
1770		- (str_xx(i,j,kk) * (v(i,J,k)-v(i,J-1,k))*G%IdyT(i,j))) &
1771		+ 0.25(( (str_xy(I,J,kk) &
1772		(((u(I,j+1,k)-u(I,j,k))*G%IdyBu(I,J)) &
1773		+ ((v(i+1,J,k)-v(i,J,k))*G%IdxBu(I,J)))) &
1774		+ (str_xy(I-1,J-1,kk) * &
1775		(((u(I-1,j,k)-u(I-1,j-1,k))*G%IdyBu(I-1,J-1)) &
1776		+ ((v(i,J-1,k)-v(i-1,J-1,k))*G%IdxBu(I-1,J-1)))) ) &
1777		+ ( (str_xy(I-1,J,kk) * &
1778		(((u(I-1,j+1,k)-u(I-1,j,k))*G%IdyBu(I-1,J)) &
1779		+ ((v(i,J,k)-v(i-1,J,k))*G%IdxBu(I-1,J)))) &
1780		+ (str_xy(I,J-1,kk) * &
1781		(((u(I,j,k)-u(I,j-1,k))*G%IdyBu(I,J-1)) &
1782	0	+ ((v(i+1,J-1,k)-v(i,J-1,k))*G%IdxBu(I,J-1)))) ) ) )
1783		enddo
1784		else
1785	0	do concurrent (kk=1:kmax, j=js:je, i=is:ie) DO_LOCALITY(local(k))
1786	0	k = kstart + kk - 1
1787		FrictWork(i,j,k) = GV%H_to_RZ * G%IareaT(i,j) * ( &
1788		((str_xx(i,j,kk)CS%dy2h(i,j) ( &
1789		(uh(I,j,k)G%dxCu(I,j)G%IdyCu(I,j)*G%IareaCu(I,j)/(h_u(I,j,kk)+h_neglect)) &
1790		- (uh(I-1,j,k)G%dxCu(I-1,j)G%IdyCu(I-1,j)*G%IareaCu(I-1,j)/(h_u(I-1,j,kk)+h_neglect)) ) ) &
1791		- (str_xx(i,j,kk)CS%dx2h(i,j) ( &
1792		(vh(i,J,k)G%dyCv(i,J)G%IdxCv(i,J)*G%IareaCv(i,J)/(h_v(i,J,kk)+h_neglect)) &
1793		- (vh(i,J-1,k)G%dyCv(i,J-1)G%IdxCv(i,J-1)*G%IareaCv(i,J-1)/(h_v(i,J-1,kk)+h_neglect)) ) )) &
1794		+ (0.25(((str_xy(I,J,kk)( &
1795		(CS%dx2q(I,J)((uh(I,j+1,k)G%IareaCu(I,j+1)/(h_u(I,j+1,kk)+h_neglect)) &
1796		- (uh(I,j,k)*G%IareaCu(I,j)/(h_u(I,j,kk)+h_neglect)))) &
1797		+ (CS%dy2q(I,J)((vh(i+1,J,k)G%IareaCv(i+1,J)/(h_v(i+1,J,kk)+h_neglect)) &
1798		- (vh(i,J,k)*G%IareaCv(i,J)/(h_v(i,J,kk)+h_neglect)))) )) &
1799		+(str_xy(I-1,J-1,kk)*( &
1800		(CS%dx2q(I-1,J-1)((uh(I-1,j,k)G%IareaCu(I-1,j)/(h_u(I-1,j,kk)+h_neglect)) &
1801		- (uh(I-1,j-1,k)*G%IareaCu(I-1,j-1)/(h_u(I-1,j-1,kk)+h_neglect)))) &
1802		+ (CS%dy2q(I-1,J-1)((vh(i,J-1,k)G%IareaCv(i,J-1)/(h_v(i,J-1,kk)+h_neglect)) &
1803		- (vh(i-1,J-1,k)*G%IareaCv(i-1,J-1)/(h_v(i-1,J-1,kk)+h_neglect)))) )) ) &
1804		+((str_xy(I-1,J,kk)*( &
1805		(CS%dx2q(I-1,J)((uh(I-1,j+1,k)G%IareaCu(I-1,j+1)/(h_u(I-1,j+1,kk)+h_neglect)) &
1806		- (uh(I-1,j,k)*G%IareaCu(I-1,j)/(h_u(I-1,j,kk)+h_neglect)))) &
1807		+ (CS%dy2q(I-1,J)((vh(i,J,k)G%IareaCv(i,J)/(h_v(i,J,kk)+h_neglect)) &
1808		- (vh(i-1,J,k)*G%IareaCv(i-1,J)/(h_v(i-1,J,kk)+h_neglect)))) )) &
1809		+(str_xy(I,J-1,kk)*( &
1810		(CS%dx2q(I,J-1)((uh(I,j,k)G%IareaCu(I,j)/(h_u(I,j,kk)+h_neglect)) &
1811		- (uh(I,j-1,k)*G%IareaCu(I,j-1)/(h_u(I,j-1,kk)+h_neglect)))) &
1812		+ (CS%dy2q(I,J-1)((vh(i+1,J-1,k)G%IareaCv(i+1,J-1)/(h_v(i+1,J-1,kk)+h_neglect)) &
1813	0	- (vh(i,J-1,k)*G%IareaCv(i,J-1)/(h_v(i,J-1,kk)+h_neglect)))) )) ) )) )
1814
1815		enddo
1816		endif
1817
1818	0	if (CS%EY24_EBT_BS) then
1819	0	do concurrent (kk=1:kmax, j=js:je, i=is:ie) DO_LOCALITY(local(k))
1820	0	k = kstart + kk - 1
1821	0	FrictWork(i,j,k) = (1. - visc_limit_h_flag(i,j,k)) * FrictWork(i,j,k)
1822		enddo
1823		endif
1824		endif
1825
1826	1875	if (CS%id_FrictWork_bh>0 .or. CS%id_FrictWorkIntz_bh > 0 .or. allocated(MEKE%mom_src_bh)) then
1827	0	if (CS%FrictWork_bug) then
1828		! Diagnose bhstr_xxd_x u - bhstr_yyd_y v + bhstr_xy*(d_y u + d_x v)
1829		! This is the old formulation that includes energy diffusion !cyc
1830	0	do concurrent (kk=1:kmax, j=js:je, i=is:ie) DO_LOCALITY(local(k))
1831	0	k = kstart + kk - 1
1832		FrictWork_bh(i,j,k) = GV%H_to_RZ * ( &
1833		((bhstr_xx(i,j,kk) * (u(I,j,k)-u(I-1,j,k))*G%IdxT(i,j)) &
1834		- (bhstr_xx(i,j,kk) * (v(i,J,k)-v(i,J-1,k))*G%IdyT(i,j))) &
1835		+ 0.25(( (bhstr_xy(I,J,kk) &
1836		(((u(I,j+1,k)-u(I,j,k))*G%IdyBu(I,J)) &
1837		+ ((v(i+1,J,k)-v(i,J,k))*G%IdxBu(I,J)))) &
1838		+ (bhstr_xy(I-1,J-1,kk) * &
1839		(((u(I-1,j,k)-u(I-1,j-1,k))*G%IdyBu(I-1,J-1)) &
1840		+ ((v(i,J-1,k)-v(i-1,J-1,k))*G%IdxBu(I-1,J-1)))) ) &
1841		+ ( (bhstr_xy(I-1,J,kk) * &
1842		(((u(I-1,j+1,k)-u(I-1,j,k))*G%IdyBu(I-1,J)) &
1843		+ ((v(i,J,k)-v(i-1,J,k))*G%IdxBu(I-1,J)))) &
1844		+ (bhstr_xy(I,J-1,kk) * &
1845		(((u(I,j,k)-u(I,j-1,k))*G%IdyBu(I,J-1)) &
1846	0	+ ((v(i+1,J-1,k)-v(i,J-1,k))*G%IdxBu(I,J-1)))) ) ) )
1847		enddo
1848		else
1849	0	do concurrent (kk=1:kmax, j=js:je, i=is:ie) DO_LOCALITY(local(k))
1850	0	k = kstart + kk - 1
1851		! Diagnose bhstr_xxd_x u - bhstr_yyd_y v + bhstr_xy*(d_y u + d_x v)
1852		FrictWork_bh(i,j,k) = GV%H_to_RZ * G%IareaT(i,j) * ( &
1853		((bhstr_xx(i,j,kk)CS%dy2h(i,j) ( &
1854		(uh(I,j,k)G%dxCu(I,j)G%IdyCu(I,j)*G%IareaCu(I,j)/(h_u(I,j,kk)+h_neglect)) &
1855		- (uh(I-1,j,k)G%dxCu(I-1,j)G%IdyCu(I-1,j)*G%IareaCu(I-1,j)/(h_u(I-1,j,kk)+h_neglect)) ) ) &
1856		- (bhstr_xx(i,j,kk)CS%dx2h(i,j) ( &
1857		(vh(i,J,k)G%dyCv(i,J)G%IdxCv(i,J)*G%IareaCv(i,J)/(h_v(i,J,kk)+h_neglect)) &
1858		- (vh(i,J-1,k)G%dyCv(i,J-1)G%IdxCv(i,J-1)*G%IareaCv(i,J-1)/(h_v(i,J-1,kk)+h_neglect)) ) )) &
1859		+ (0.25(((bhstr_xy(I,J,kk)( &
1860		(CS%dx2q(I,J)((uh(I,j+1,k)G%IareaCu(I,j+1)/(h_u(I,j+1,kk)+h_neglect)) &
1861		- (uh(I,j,k)*G%IareaCu(I,j)/(h_u(I,j,kk)+h_neglect)))) &
1862		+ (CS%dy2q(I,J)((vh(i+1,J,k)G%IareaCv(i+1,J)/(h_v(i+1,J,kk)+h_neglect)) &
1863		- (vh(i,J,k)*G%IareaCv(i,J)/(h_v(i,J,kk)+h_neglect)))) )) &
1864		+(bhstr_xy(I-1,J-1,kk)*( &
1865		(CS%dx2q(I-1,J-1)((uh(I-1,j,k)G%IareaCu(I-1,j)/(h_u(I-1,j,kk)+h_neglect)) &
1866		- (uh(I-1,j-1,k)*G%IareaCu(I-1,j-1)/(h_u(I-1,j-1,kk)+h_neglect)))) &
1867		+ (CS%dy2q(I-1,J-1)((vh(i,J-1,k)G%IareaCv(i,J-1)/(h_v(i,J-1,kk)+h_neglect)) &
1868		- (vh(i-1,J-1,k)*G%IareaCv(i-1,J-1)/(h_v(i-1,J-1,kk)+h_neglect)))) )) ) &
1869		+((bhstr_xy(I-1,J,kk)*( &
1870		(CS%dx2q(I-1,J)((uh(I-1,j+1,k)G%IareaCu(I-1,j+1)/(h_u(I-1,j+1,kk)+h_neglect)) &
1871		- (uh(I-1,j,k)*G%IareaCu(I-1,j)/(h_u(I-1,j,kk)+h_neglect)))) &
1872		+ (CS%dy2q(I-1,J)((vh(i,J,k)G%IareaCv(i,J)/(h_v(i,J,kk)+h_neglect)) &
1873		- (vh(i-1,J,k)*G%IareaCv(i-1,J)/(h_v(i-1,J,kk)+h_neglect)))) )) &
1874		+(bhstr_xy(I,J-1,kk)*( &
1875		(CS%dx2q(I,J-1)((uh(I,j,k)G%IareaCu(I,j)/(h_u(I,j,kk)+h_neglect)) &
1876		- (uh(I,j-1,k)*G%IareaCu(I,j-1)/(h_u(I,j-1,kk)+h_neglect)))) &
1877		+ (CS%dy2q(I,J-1)((vh(i+1,J-1,k)G%IareaCv(i+1,J-1)/(h_v(i+1,J-1,kk)+h_neglect)) &
1878	0	- (vh(i,J-1,k)*G%IareaCv(i,J-1)/(h_v(i,J-1,kk)+h_neglect)))) )) ) )) )
1879		enddo
1880		endif
1881
1882	0	if (CS%EY24_EBT_BS) then
1883	0	do concurrent (kk=1:kmax, j=js:je, i=is:ie) DO_LOCALITY(local(k))
1884	0	k = kstart + kk - 1
1885	0	FrictWork_bh(i,j,k) = (1. - visc_limit_h_flag(i,j,k)) * FrictWork_bh(i,j,k)
1886		enddo
1887		endif
1888		endif
1889
1890	1875	if (CS%use_GME) then
1891	0	if (CS%FrictWork_bug) then ; do concurrent (kk=1:kmax, j=js:je, i=is:ie) DO_LOCALITY(local(k))
1892	0	k = kstart + kk - 1
1893		! Diagnose str_xx_GMEd_x u - str_yy_GMEd_y v + str_xy_GME*(d_y u + d_x v)
1894		! This is the old formulation that includes energy diffusion
1895		FrictWork_GME(i,j,k) = GV%H_to_RZ * ( &
1896		((str_xx_GME(i,j,kk)(u(I,j,k)-u(I-1,j,k))G%IdxT(i,j)) &
1897		- (str_xx_GME(i,j,kk)(v(i,J,k)-v(i,J-1,k))G%IdyT(i,j))) &
1898		+ 0.25(( (str_xy_GME(I,J,kk) &
1899		(((u(I,j+1,k)-u(I,j,k))*G%IdyBu(I,J)) &
1900		+ ((v(i+1,J,k)-v(i,J,k))*G%IdxBu(I,J)))) &
1901		+ (str_xy_GME(I-1,J-1,kk) * &
1902		(((u(I-1,j,k)-u(I-1,j-1,k))*G%IdyBu(I-1,J-1)) &
1903		+ ((v(i,J-1,k)-v(i-1,J-1,k))*G%IdxBu(I-1,J-1)))) ) &
1904		+ ( (str_xy_GME(I-1,J,kk) * &
1905		(((u(I-1,j+1,k)-u(I-1,j,k))*G%IdyBu(I-1,J)) &
1906		+ ((v(i,J,k)-v(i-1,J,k))*G%IdxBu(I-1,J)))) &
1907		+ (str_xy_GME(I,J-1,kk) * &
1908		(((u(I,j,k)-u(I,j-1,k))*G%IdyBu(I,J-1)) &
1909	0	+ ((v(i+1,J-1,k)-v(i,J-1,k))*G%IdxBu(I,J-1)))) ) ) )
1910		enddo
1911	0	else ; do concurrent (kk=1:kmax, j=js:je, i=is:ie) DO_LOCALITY(local(k))
1912	0	k = kstart + kk - 1
1913		FrictWork_GME(i,j,k) = GV%H_to_RZ * G%IareaT(i,j) * ( &
1914		((str_xx_GME(i,j,kk)CS%dy2h(i,j) ( &
1915		(uh(I,j,k)G%dxCu(I,j)G%IdyCu(I,j)*G%IareaCu(I,j)/(h_u(I,j,kk)+h_neglect)) &
1916		- (uh(I-1,j,k)G%dxCu(I-1,j)G%IdyCu(I-1,j)*G%IareaCu(I-1,j)/(h_u(I-1,j,kk)+h_neglect)) ) ) &
1917		- (str_xx_GME(i,j,kk)CS%dx2h(i,j) ( &
1918		(vh(i,J,k)G%dyCv(i,J)G%IdxCv(i,J)*G%IareaCv(i,J)/(h_v(i,J,kk)+h_neglect)) &
1919		- (vh(i,J-1,k)G%dyCv(i,J-1)G%IdxCv(i,J-1)*G%IareaCv(i,J-1)/(h_v(i,J-1,kk)+h_neglect)) ) )) &
1920		+ (0.25(((str_xy_GME(I,J,kk)( &
1921		(CS%dx2q(I,J)((uh(I,j+1,k)G%IareaCu(I,j+1)/(h_u(I,j+1,kk)+h_neglect)) &
1922		- (uh(I,j,k)*G%IareaCu(I,j)/(h_u(I,j,kk)+h_neglect)))) &
1923		+ (CS%dy2q(I,J)((vh(i+1,J,k)G%IareaCv(i+1,J)/(h_v(i+1,J,kk)+h_neglect)) &
1924		- (vh(i,J,k)*G%IareaCv(i,J)/(h_v(i,J,kk)+h_neglect)))) )) &
1925		+(str_xy_GME(I-1,J-1,kk)*( &
1926		(CS%dx2q(I-1,J-1)((uh(I-1,j,k)G%IareaCu(I-1,j)/(h_u(I-1,j,kk)+h_neglect)) &
1927		- (uh(I-1,j-1,k)*G%IareaCu(I-1,j-1)/(h_u(I-1,j-1,kk)+h_neglect)))) &
1928		+ (CS%dy2q(I-1,J-1)((vh(i,J-1,k)G%IareaCv(i,J-1)/(h_v(i,J-1,kk)+h_neglect)) &
1929		- (vh(i-1,J-1,k)*G%IareaCv(i-1,J-1)/(h_v(i-1,J-1,kk)+h_neglect)))) )) ) &
1930		+((str_xy_GME(I-1,J,kk)*( &
1931		(CS%dx2q(I-1,J)((uh(I-1,j+1,k)G%IareaCu(I-1,j+1)/(h_u(I-1,j+1,kk)+h_neglect)) &
1932		- (uh(I-1,j,k)*G%IareaCu(I-1,j)/(h_u(I-1,j,kk)+h_neglect)))) &
1933		+ (CS%dy2q(I-1,J)((vh(i,J,k)G%IareaCv(i,J)/(h_v(i,J,kk)+h_neglect)) &
1934		- (vh(i-1,J,k)*G%IareaCv(i-1,J)/(h_v(i-1,J,kk)+h_neglect)))) )) &
1935		+(str_xy_GME(I,J-1,kk)*( &
1936		(CS%dx2q(I,J-1)((uh(I,j,k)G%IareaCu(I,j)/(h_u(I,j,kk)+h_neglect)) &
1937		- (uh(I,j-1,k)*G%IareaCu(I,j-1)/(h_u(I,j-1,kk)+h_neglect)))) &
1938		+ (CS%dy2q(I,J-1)((vh(i+1,J-1,k)G%IareaCv(i+1,J-1)/(h_v(i+1,J-1,kk)+h_neglect)) &
1939	0	- (vh(i,J-1,k)*G%IareaCv(i,J-1)/(h_v(i,J-1,kk)+h_neglect)))) )) ) )) )
1940		enddo ; endif
1941	0	if (find_FrictWork .and. allocated(MEKE%mom_src) .and. allocated(MEKE%GME_snk)) then
1942		!$omp target update from(FrictWork_GME)
1943	0	do kk=1,kmax ; do j=js,je ; do i=is,ie
1944	0	k = kstart+kk-1
1945	0	MEKE%GME_snk(i,j) = MEKE%GME_snk(i,j) + FrictWork_GME(i,j,k)
1946		enddo ; enddo ; enddo
1947		endif
1948		endif
1949
1950	1875	if (skeb_use_frict) then ; do concurrent (kk=1:kmax, j=js:je, i=is:ie) DO_LOCALITY(local(k))
1951	0	k = kstart + kk - 1
1952		! Note that the sign convention is FrictWork < 0 means energy dissipation.
1953		STOCH%skeb_diss(i,j,k) = STOCH%skeb_diss(i,j,k) - STOCH%skeb_frict_coef * &
1954	0	FrictWork(i,j,k) / (GV%H_to_RZ * (h(i,j,k) + h_neglect))
1955		enddo ; endif
1956
1957		! Make a similar calculation as for FrictWork above but accumulating into
1958		! the vertically integrated MEKE source term, and adjusting for any
1959		! energy loss seen as a reduction in the (biharmonic) frictional source term.
1960	1900	if (find_FrictWork .and. allocated(MEKE%mom_src)) then
1961	0	if (MEKE%backscatter_Ro_c /= 0.) then
1962		!$omp target update from(FrictWork, FrictWork_bh, sh_xx, sh_xy)
1963	0	do kk=1,kmax ; do j=js,je ; do i=is,ie
1964	0	k = kstart + kk - 1
1965		FatH = 0.25*( (abs(G%CoriolisBu(I-1,J-1)) + abs(G%CoriolisBu(I,J))) + &
1966	0	(abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J-1))) )
1967		Shear_mag_bc = sqrt(sh_xx(i,j,kk) * sh_xx(i,j,kk) + &
1968		0.25(((sh_xy(I-1,J-1,kk)sh_xy(I-1,J-1,kk)) + (sh_xy(I,J,kk)*sh_xy(I,J,kk))) + &
1969	0	((sh_xy(I-1,J,kk)sh_xy(I-1,J,kk)) + (sh_xy(I,J-1,kk)sh_xy(I,J-1,kk)))))
1970	0	if ((CS%answer_date > 20190101) .and. (CS%answer_date < 20241201)) then
1971	0	FatH = (US%s_to_TFatH)*MEKE%backscatter_Ro_pow ! f^n
1972		! Note the hard-coded dimensional constant in the following line that can not
1973		! be rescaled for dimensional consistency.
1974		Shear_mag_bc = (((US%s_to_T * Shear_mag_bc)**MEKE%backscatter_Ro_pow) + 1.e-30) &
1975	0	* MEKE%backscatter_Ro_c ! c * D^n
1976		! The Rossby number function is g(Ro) = 1/(1+c.Ro^n)
1977		! RoScl = 1 - g(Ro)
1978	0	RoScl = Shear_mag_bc / (FatH + Shear_mag_bc) ! = 1 - f^n/(f^n+c*D^n)
1979		else
1980	0	if (FatH <= backscat_subround*Shear_mag_bc) then
1981	0	RoScl = 1.0
1982		else
1983	0	Sh_F_pow = MEKE%backscatter_Ro_c * (Shear_mag_bc / FatH)**MEKE%backscatter_Ro_pow
1984	0	RoScl = Sh_F_pow / (1.0 + Sh_F_pow) ! = 1 - f^n/(f^n+c*D^n)
1985		endif
1986		endif
1987
1988	0	MEKE%mom_src(i,j) = MEKE%mom_src(i,j) + (FrictWork(i,j,k) - RoScl*FrictWork_bh(i,j,k))
1989
1990	0	if (allocated(MEKE%mom_src_bh)) &
1991		MEKE%mom_src_bh(i,j) = MEKE%mom_src_bh(i,j) &
1992	0	+ (FrictWork_bh(i,j,k) - RoScl * FrictWork_bh(i,j,k))
1993		enddo ; enddo ; enddo
1994		else
1995		!$omp target update from(FrictWork)
1996	0	do kk=1,kmax ; do j=js,je ; do i=is,ie
1997	0	k = kstart + kk - 1
1998	0	MEKE%mom_src(i,j) = MEKE%mom_src(i,j) + FrictWork(i,j,k)
1999		enddo ; enddo ; enddo
2000
2001	0	if (allocated(MEKE%mom_src_bh)) then
2002		!$omp target update from(FrictWork_bh)
2003	0	do kk=1,kmax ; do j=js,je ; do i=is,ie
2004	0	k = kstart + kk - 1
2005	0	MEKE%mom_src_bh(i,j) = MEKE%mom_src_bh(i,j) + FrictWork_bh(i,j,k)
2006		enddo ; enddo ; enddo
2007		endif
2008		endif ! MEKE%backscatter_Ro_c
2009
2010		endif ! find_FrictWork and associated(mom_src)
2011		enddo ! end of kstart block loop
2012
2013		!$omp target exit data map(delete: dudx, dudy, dvdx, dvdy, sh_xx, sh_xy)
2014		!$omp target exit data map(delete: h_u, h_v, hq)
2015		!$omp target exit data map(delete: str_xx, str_xy, ShSt)
2016		!$omp target exit data map(delete: Del2u, Del2v) if (CS%biharmonic)
2017		!$omp target exit data map(delete: dDel2vdx, dDel2udy) if (CS%biharmonic)
2018		!$omp target exit data map(delete: Shear_mag) if (use_Smag)
2019		!$omp target exit data map(delete: Kh) if (CS%Laplacian .or. CS%biharmonic)
2020		!$omp target exit data map(delete: Ah) if (CS%biharmonic)
2021		!$omp target exit data map(delete: bhstr_xx, bhstr_xy) if (CS%biharmonic)
2022
2023		!$omp target exit data map(delete: hrat_min) &
2024		!$omp if (CS%bound_Kh .or. CS%bound_Ah)
2025		!$omp target exit data map(delete: visc_bound_rem) &
2026		!$omp if (CS%bound_Kh .or. CS%bound_Ah)
2027
2028		!$omp target exit data map(delete: vert_vort_mag)
2029		!$omp target exit data map(delete: sh_xx_smooth) if (CS%use_Leithy .or. CS%biharmonic)
2030
2031		! Offer fields for diagnostic averaging.
2032	25	if (CS%id_normstress > 0) call post_data(CS%id_normstress, NoSt, CS%diag)
2033		!$omp target update from(ShSt) if (CS%id_shearstress > 0)
2034	25	if (CS%id_shearstress > 0) call post_data(CS%id_shearstress, ShSt, CS%diag)
2035	25	if (CS%id_diffu>0) call post_data(CS%id_diffu, diffu, CS%diag)
2036	25	if (CS%id_diffv>0) call post_data(CS%id_diffv, diffv, CS%diag)
2037	25	if (CS%id_FrictWork>0) call post_data(CS%id_FrictWork, FrictWork, CS%diag)
2038	25	if (CS%id_FrictWork_bh>0) call post_data(CS%id_FrictWork_bh, FrictWork_bh, CS%diag)
2039	25	if (CS%id_Ah_h>0) call post_data(CS%id_Ah_h, Ah_h, CS%diag)
2040	25	if (CS%id_grid_Re_Ah>0) call post_data(CS%id_grid_Re_Ah, grid_Re_Ah, CS%diag)
2041	25	if (CS%id_div_xx_h>0) call post_data(CS%id_div_xx_h, div_xx_h, CS%diag)
2042	25	if (CS%id_vort_xy_q>0) call post_data(CS%id_vort_xy_q, vort_xy_q, CS%diag)
2043	25	if (CS%id_sh_xx_h>0) call post_data(CS%id_sh_xx_h, sh_xx_h, CS%diag)
2044	25	if (CS%id_sh_xy_q>0) call post_data(CS%id_sh_xy_q, sh_xy_q, CS%diag)
2045	25	if (CS%id_Ah_q>0) call post_data(CS%id_Ah_q, Ah_q, CS%diag)
2046	25	if (CS%id_Kh_h>0) call post_data(CS%id_Kh_h, Kh_h, CS%diag)
2047	25	if (CS%id_grid_Re_Kh>0) call post_data(CS%id_grid_Re_Kh, grid_Re_Kh, CS%diag)
2048	25	if (CS%id_Kh_q>0) call post_data(CS%id_Kh_q, Kh_q, CS%diag)
2049	25	if (CS%use_GME) then ! post barotropic tension and strain
2050	0	if (CS%id_GME_coeff_h > 0) call post_data(CS%id_GME_coeff_h, GME_coeff_h, CS%diag)
2051	0	if (CS%id_GME_coeff_q > 0) call post_data(CS%id_GME_coeff_q, GME_coeff_q, CS%diag)
2052	0	if (CS%id_FrictWork_GME>0) call post_data(CS%id_FrictWork_GME, FrictWork_GME, CS%diag)
2053	0	if (CS%id_dudx_bt > 0) call post_data(CS%id_dudx_bt, dudx_bt, CS%diag)
2054	0	if (CS%id_dvdy_bt > 0) call post_data(CS%id_dvdy_bt, dvdy_bt, CS%diag)
2055	0	if (CS%id_dudy_bt > 0) call post_data(CS%id_dudy_bt, dudy_bt, CS%diag)
2056	0	if (CS%id_dvdx_bt > 0) call post_data(CS%id_dvdx_bt, dvdx_bt, CS%diag)
2057		endif
2058	25	if (CS%EY24_EBT_BS) then
2059	0	if (CS%id_visc_limit_h>0) call post_data(CS%id_visc_limit_h, visc_limit_h, CS%diag)
2060	0	if (CS%id_visc_limit_q>0) call post_data(CS%id_visc_limit_q, visc_limit_q, CS%diag)
2061	0	if (CS%id_visc_limit_h_frac>0) call post_data(CS%id_visc_limit_h_frac, visc_limit_h_frac, CS%diag)
2062	0	if (CS%id_visc_limit_q_frac>0) call post_data(CS%id_visc_limit_q_frac, visc_limit_q_frac, CS%diag)
2063	0	if (CS%id_visc_limit_h_flag>0) call post_data(CS%id_visc_limit_h_flag, visc_limit_h_flag, CS%diag)
2064	0	if (CS%id_visc_limit_q_flag>0) call post_data(CS%id_visc_limit_q_flag, visc_limit_q_flag, CS%diag)
2065	0	if (CS%id_BS_coeff_h>0) call post_data(CS%id_BS_coeff_h, BS_coeff_h, CS%diag)
2066	0	if (CS%id_BS_coeff_q>0) call post_data(CS%id_BS_coeff_q, BS_coeff_q, CS%diag)
2067		endif
2068
2069	25	if (CS%debug) then
2070	0	if (CS%Laplacian) then
2071	0	call hchksum(Kh_h, "Kh_h", G%HI, haloshift=1, unscale=US%L_to_m*2US%s_to_T)
2072	0	call Bchksum(Kh_q, "Kh_q", G%HI, haloshift=0, symmetric=.true., unscale=US%L_to_m*2US%s_to_T)
2073		endif
2074	0	if (CS%biharmonic) then
2075	0	call hchksum(Ah_h, "Ah_h", G%HI, haloshift=1, unscale=US%L_to_m*4US%s_to_T)
2076	0	call Bchksum(Ah_q, "Ah_q", G%HI, haloshift=0, symmetric=.true., unscale=US%L_to_m*4US%s_to_T)
2077		endif
2078		endif
2079
2080		!$omp target exit data map(delete: sh_xy_q) &
2081		!$omp if (CS%id_sh_xy_q > 0)
2082
2083	25	if (CS%id_FrictWorkIntz > 0) then
2084	0	do j=js,je
2085	0	do i=is,ie ; FrictWorkIntz(i,j,1) = FrictWork(i,j,1) ; enddo
2086	0	do k=2,nz ; do i=is,ie
2087	0	FrictWorkIntz(i,j,1) = FrictWorkIntz(i,j,1) + FrictWork(i,j,k)
2088		enddo ; enddo
2089		enddo
2090	0	call post_data(CS%id_FrictWorkIntz, FrictWorkIntz(:,:,1), CS%diag)
2091		endif
2092
2093	25	if (CS%id_FrictWorkIntz_bh > 0) then
2094	0	do j=js,je
2095	0	do i=is,ie ; FrictWorkIntz_bh(i,j,1) = FrictWork_bh(i,j,1) ; enddo
2096	0	do k=2,nz ; do i=is,ie
2097	0	FrictWorkIntz_bh(i,j,1) = FrictWorkIntz_bh(i,j,1) + FrictWork_bh(i,j,k)
2098		enddo ; enddo
2099		enddo
2100	0	call post_data(CS%id_FrictWorkIntz_bh, FrictWorkIntz_bh(:,:,1), CS%diag)
2101		endif
2102
2103	25	if (present(ADp)) then
2104		! Diagnostics of the fractional thicknesses times momentum budget terms
2105		! 3D diagnostics of hf_diffu(diffv) are commented because there is no clarity on proper remapping grid option.
2106		! The code is retained for debugging purposes in the future.
2107		!if (CS%id_hf_diffu > 0) call post_product_u(CS%id_hf_diffu, diffu, ADp%diag_hfrac_u, G, nz, CS%diag)
2108		!if (CS%id_hf_diffv > 0) call post_product_v(CS%id_hf_diffv, diffv, ADp%diag_hfrac_v, G, nz, CS%diag)
2109
2110		! Diagnostics for thickness-weighted vertically averaged momentum budget terms
2111	24	if (CS%id_hf_diffu_2d > 0) call post_product_sum_u(CS%id_hf_diffu_2d, diffu, ADp%diag_hfrac_u, G, nz, CS%diag)
2112	24	if (CS%id_hf_diffv_2d > 0) call post_product_sum_v(CS%id_hf_diffv_2d, diffv, ADp%diag_hfrac_v, G, nz, CS%diag)
2113
2114		! Diagnostics for the vertical sum of layer thickness x momentum budget terms
2115	24	if (CS%id_intz_diffu_2d > 0) call post_product_sum_u(CS%id_intz_diffu_2d, diffu, ADp%diag_hu, G, nz, CS%diag)
2116	24	if (CS%id_intz_diffv_2d > 0) call post_product_sum_v(CS%id_intz_diffv_2d, diffv, ADp%diag_hv, G, nz, CS%diag)
2117
2118		! Diagnostics for thickness x momentum budget terms
2119	24	if (CS%id_h_diffu > 0) call post_product_u(CS%id_h_diffu, diffu, ADp%diag_hu, G, nz, CS%diag)
2120	24	if (CS%id_h_diffv > 0) call post_product_v(CS%id_h_diffv, diffv, ADp%diag_hv, G, nz, CS%diag)
2121
2122		! Diagnostics for momentum budget terms multiplied by visc_rem_[uv],
2123	24	if (CS%id_diffu_visc_rem > 0) call post_product_u(CS%id_diffu_visc_rem, diffu, ADp%visc_rem_u, G, nz, CS%diag)
2124	24	if (CS%id_diffv_visc_rem > 0) call post_product_v(CS%id_diffv_visc_rem, diffv, ADp%visc_rem_v, G, nz, CS%diag)
2125		endif
2126
2127	25	if (CS%use_ZB2020) then
2128		call ZB2020_lateral_stress(u, v, h, diffu, diffv, G, GV, CS%ZB2020, &
2129	0	CS%dx2h, CS%dy2h, CS%dx2q, CS%dy2q)
2130		endif
2131
2132	50	end subroutine horizontal_viscosity
2133
2134		!> Calculates the magnitude of the vorticity and divergence gradients, and the
2135		!! Laplacian of vorticity, that are used within horizontal_viscosity by the Leith,
2136		!! modified Leith, Leith+E, and QG Leith viscosity schemes. The caller must only
2137		!! invoke this routine when CS%Leith_Kh, CS%Leith_Ah, or CS%use_Leithy is true.
2138	0	subroutine hor_visc_Leith_grad(G, GV, US, CS, VarMix, nkblock, kstart, kmax, &
2139		is, ie, js, je, is_Kh, ie_Kh, js_Kh, je_Kh, Ieq, Jeq, &
2140	0	h, dz, slope_x, slope_y, dudx, dvdy, vort_xy, vort_xy_smooth, &
2141	0	grad_vort_mag_h, grad_vort_mag_h_2d, grad_div_mag_h, &
2142	0	grad_vort_mag_q, grad_vort_mag_q_2d, grad_div_mag_q, &
2143	0	vert_vort_mag_smooth, Del2vort_q)
2144		type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure.
2145		type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure.
2146		type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
2147		type(hor_visc_CS), intent(in) :: CS !< Horizontal viscosity control structure
2148		type(VarMix_CS), intent(inout) :: VarMix !< Variable mixing control structure
2149		integer, intent(in) :: nkblock !< The k-block size used to size the following arrays [nondim]
2150		integer, intent(in) :: kstart !< The first absolute k-layer of the current k-block
2151		integer, intent(in) :: kmax !< The number of active k-layers in the current k-block
2152		integer, intent(in) :: is !< Start i-loop index for the h-point viscosities
2153		integer, intent(in) :: ie !< End i-loop index for the h-point viscosities
2154		integer, intent(in) :: js !< Start j-loop index for the h-point viscosities
2155		integer, intent(in) :: je !< End j-loop index for the h-point viscosities
2156		integer, intent(in) :: is_Kh !< Start i-loop index for the thickness point viscosities
2157		integer, intent(in) :: ie_Kh !< End i-loop index for the thickness point viscosities
2158		integer, intent(in) :: js_Kh !< Start j-loop index for the thickness point viscosities
2159		integer, intent(in) :: je_Kh !< End j-loop index for the thickness point viscosities
2160		integer, intent(in) :: Ieq !< The last i-index at q-points
2161		integer, intent(in) :: Jeq !< The last j-index at q-points
2162		real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), &
2163		intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2].
2164		real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), &
2165		intent(in) :: dz !< Height change across layers [Z ~> m]
2166		real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), &
2167		intent(inout) :: slope_x !< Isopycnal slope in i-direction [Z L-1 ~> nondim]
2168		real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), &
2169		intent(inout) :: slope_y !< Isopycnal slope in j-direction [Z L-1 ~> nondim]
2170		real, dimension(SZI_(G),SZJ_(G),nkblock), &
2171		intent(in) :: dudx !< x-derivative of the horizontal tension [T-1 ~> s-1]
2172		real, dimension(SZI_(G),SZJ_(G),nkblock), &
2173		intent(in) :: dvdy !< y-derivative of the horizontal tension [T-1 ~> s-1]
2174		real, dimension(SZIB_(G),SZJB_(G),nkblock), &
2175		intent(in) :: vort_xy !< Vertical vorticity (dv/dx - du/dy) including
2176		!! metric terms [T-1 ~> s-1]
2177		real, dimension(SZIB_(G),SZJB_(G),nkblock), &
2178		intent(in) :: vort_xy_smooth !< Vertical vorticity including metric
2179		!! terms, smoothed [T-1 ~> s-1]
2180		real, dimension(SZI_(G),SZJ_(G),nkblock), &
2181		intent(out) :: grad_vort_mag_h !< Magnitude of vorticity gradient at
2182		!! h-points [L-1 T-1 ~> m-1 s-1]
2183		real, dimension(SZI_(G),SZJ_(G),nkblock), &
2184		intent(out) :: grad_vort_mag_h_2d !< Magnitude of 2d vorticity gradient
2185		!! at h-points [L-1 T-1 ~> m-1 s-1]
2186		real, dimension(SZI_(G),SZJ_(G),nkblock), &
2187		intent(out) :: grad_div_mag_h !< Magnitude of divergence gradient at
2188		!! h-points [L-1 T-1 ~> m-1 s-1]
2189		real, dimension(SZIB_(G),SZJB_(G),nkblock), &
2190		intent(out) :: grad_vort_mag_q !< Magnitude of vorticity gradient at
2191		!! q-points [L-1 T-1 ~> m-1 s-1]
2192		real, dimension(SZIB_(G),SZJB_(G),nkblock), &
2193		intent(out) :: grad_vort_mag_q_2d !< Magnitude of 2d vorticity gradient
2194		!! at q-points [L-1 T-1 ~> m-1 s-1]
2195		real, dimension(SZIB_(G),SZJB_(G),nkblock), &
2196		intent(out) :: grad_div_mag_q !< Magnitude of divergence gradient at
2197		!! q-points [L-1 T-1 ~> m-1 s-1]
2198		real, dimension(SZIB_(G),SZJB_(G),nkblock), &
2199		intent(out) :: vert_vort_mag_smooth !< Magnitude of gradient of smoothed
2200		!! vertical vorticity (h or q) [L-1 T-1 ~> m-1 s-1]
2201		real, dimension(SZIB_(G),SZJB_(G),nkblock), &
2202		intent(out) :: Del2vort_q !< Laplacian of vorticity at q-points
2203		!! [L-2 T-1 ~> m-2 s-1]
2204		! Local variables
2205		real, dimension(SZI_(G),SZJB_(G),nkblock) :: &
2206	0	vort_xy_dx, & ! x-derivative of vertical vorticity (d/dx(dv/dx - du/dy)) [L-1 T-1 ~> m-1 s-1]
2207	0	vort_xy_dx_smooth, & ! x-derivative of smoothed vertical vorticity [L-1 T-1 ~> m-1 s-1]
2208	0	div_xx_dy ! y-derivative of horizontal divergence (d/dy(du/dx + dv/dy)) [L-1 T-1 ~> m-1 s-1]
2209		real, dimension(SZIB_(G),SZJ_(G),nkblock) :: &
2210	0	vort_xy_dy, & ! y-derivative of vertical vorticity (d/dy(dv/dx - du/dy)) [L-1 T-1 ~> m-1 s-1]
2211	0	vort_xy_dy_smooth, & ! y-derivative of smoothed vertical vorticity [L-1 T-1 ~> m-1 s-1]
2212	0	div_xx_dx ! x-derivative of horizontal divergence (d/dx(du/dx + dv/dy)) [L-1 T-1 ~> m-1 s-1]
2213		real, dimension(SZI_(G),SZJ_(G),nkblock) :: &
2214	0	div_xx ! Estimate of horizontal divergence at h-points [T-1 ~> s-1]
2215		real :: DY_dxBu ! Ratio of meridional over zonal grid spacing at vertices [nondim]
2216		real :: DX_dyBu ! Ratio of zonal over meridional grid spacing at vertices [nondim]
2217		integer :: i, j, k, kk
2218
2219		! Vorticity gradient
2220	0	do concurrent (kk=1:kmax, J=js-2:je_Kh, i=is_Kh-1:ie_Kh+1) DO_LOCALITY(local(DY_dxBu))
2221	0	DY_dxBu = G%dyBu(I,J) * G%IdxBu(I,J)
2222	0	vort_xy_dx(i,J,kk) = DY_dxBu * ((vort_xy(I,J,kk) * G%IdyCu(I,j)) - (vort_xy(I-1,J,kk) * G%IdyCu(I-1,j)))
2223		enddo
2224
2225	0	do concurrent (kk=1:kmax, j=js_Kh-1:je_Kh+1, I=is-2:ie_Kh) DO_LOCALITY(local(DX_dyBu))
2226	0	DX_dyBu = G%dxBu(I,J) * G%IdyBu(I,J)
2227	0	vort_xy_dy(I,j,kk) = DX_dyBu * ((vort_xy(I,J,kk) * G%IdxCv(i,J)) - (vort_xy(I,J-1,kk) * G%IdxCv(i,J-1)))
2228		enddo
2229
2230	0	if (CS%use_Leithy) then
2231		! Gradient of smoothed vorticity
2232	0	do concurrent (kk=1:kmax, J=js_Kh-1:je_Kh, i=is_Kh:ie_Kh) DO_LOCALITY(local(DY_dxBu))
2233	0	DY_dxBu = G%dyBu(I,J) * G%IdxBu(I,J)
2234		vort_xy_dx_smooth(i,J,kk) = DY_dxBu * &
2235	0	((vort_xy_smooth(I,J,kk) * G%IdyCu(I,j)) - (vort_xy_smooth(I-1,J,kk) * G%IdyCu(I-1,j)))
2236		enddo
2237
2238	0	do concurrent (kk=1:kmax, j=js_Kh:je_Kh, I=is_Kh-1:ie_Kh) DO_LOCALITY(local(DX_dyBu))
2239	0	DX_dyBu = G%dxBu(I,J) * G%IdyBu(I,J)
2240		vort_xy_dy_smooth(I,j,kk) = DX_dyBu * &
2241	0	((vort_xy_smooth(I,J,kk) * G%IdxCv(i,J)) - (vort_xy_smooth(I,J-1,kk) * G%IdxCv(i,J-1)))
2242		enddo
2243		endif ! If Leithy
2244
2245		! Laplacian of vorticity
2246		! if (CS%Leith_Ah .or. CS%use_Leithy) then
2247	0	do concurrent (kk=1:kmax, J=js_Kh-1:je_Kh, I=is_Kh-1:ie_Kh) DO_LOCALITY(local(DY_dxBu, DX_dyBu))
2248	0	DY_dxBu = G%dyBu(I,J) * G%IdxBu(I,J)
2249	0	DX_dyBu = G%dxBu(I,J) * G%IdyBu(I,J)
2250
2251		Del2vort_q(I,J,kk) = DY_dxBu * ((vort_xy_dx(i+1,J,kk) * G%IdyCv(i+1,J)) - (vort_xy_dx(i,J,kk) * G%IdyCv(i,J))) + &
2252	0	DX_dyBu * ((vort_xy_dy(I,j+1,kk) * G%IdyCu(I,j+1)) - (vort_xy_dy(I,j,kk) * G%IdyCu(I,j)))
2253		enddo
2254		! endif
2255
2256	0	if (CS%modified_Leith) then
2257
2258		! Divergence
2259	0	do concurrent (kk=1:kmax, j=js_Kh-1:je_Kh+1, i=is_Kh-1:ie_Kh+1)
2260	0	div_xx(i,j,kk) = dudx(i,j,kk) + dvdy(i,j,kk)
2261		enddo
2262
2263		! Divergence gradient
2264	0	do concurrent (kk=1:kmax, j=js-1:je+1, I=is_Kh-1:ie_Kh)
2265	0	div_xx_dx(I,j,kk) = G%IdxCu(I,j)*(div_xx(i+1,j,kk) - div_xx(i,j,kk))
2266		enddo
2267	0	do concurrent (kk=1:kmax, J=js_Kh-1:je_Kh, i=is-1:ie+1)
2268	0	div_xx_dy(i,J,kk) = G%IdyCv(i,J)*(div_xx(i,j+1,kk) - div_xx(i,j,kk))
2269		enddo
2270
2271		! Magnitude of divergence gradient
2272	0	do concurrent (kk=1:kmax, j=js_Kh:je_Kh, i=is_Kh:ie_Kh)
2273		grad_div_mag_h(i,j,kk) = sqrt(((0.5(div_xx_dx(I,j,kk) + div_xx_dx(I-1,j,kk)))*2) + &
2274	0	((0.5(div_xx_dy(i,J,kk) + div_xx_dy(i,J-1,kk)))*2))
2275		enddo
2276	0	do concurrent (kk=1:kmax, J=js-1:Jeq, I=is-1:Ieq)
2277		grad_div_mag_q(I,J,kk) = sqrt(((0.5(div_xx_dx(I,j,kk) + div_xx_dx(I,j+1,kk)))*2) + &
2278	0	((0.5(div_xx_dy(i,J,kk) + div_xx_dy(i+1,J,kk)))*2))
2279		enddo
2280
2281		else
2282
2283	0	do concurrent (kk=1:kmax, j=js-1:je+1, I=is_Kh-1:ie_Kh)
2284	0	div_xx_dx(I,j,kk) = 0.0
2285		enddo
2286	0	do concurrent (kk=1:kmax, J=js_Kh-1:je_Kh, i=is-1:ie+1)
2287	0	div_xx_dy(i,J,kk) = 0.0
2288		enddo
2289	0	do concurrent (kk=1:kmax, j=js_Kh:je_Kh, i=is_Kh:ie_Kh)
2290	0	grad_div_mag_h(i,j,kk) = 0.0
2291		enddo
2292	0	do concurrent (kk=1:kmax, J=js-1:Jeq, I=is-1:Ieq)
2293	0	grad_div_mag_q(I,J,kk) = 0.0
2294		enddo
2295
2296		endif ! CS%modified_Leith
2297
2298		! Add in beta for the Leith viscosity
2299	0	if (CS%use_beta_in_Leith) then
2300	0	do concurrent (kk=1:kmax, J=js-2:Jeq+1, i=is-1:ie+1)
2301	0	vort_xy_dx(i,J,kk) = vort_xy_dx(i,J,kk) + 0.5 * ( G%dF_dx(i,j) + G%dF_dx(i,j+1))
2302		enddo
2303	0	do concurrent (kk=1:kmax, j=js-1:je+1, I=is-2:Ieq+1)
2304	0	vort_xy_dy(I,j,kk) = vort_xy_dy(I,j,kk) + 0.5 * ( G%dF_dy(i,j) + G%dF_dy(i+1,j))
2305		enddo
2306		endif ! CS%use_beta_in_Leith
2307
2308	0	if (CS%use_QG_Leith_visc) then
2309
2310	0	do concurrent (kk=1:kmax, j=js_Kh:je_Kh, i=is_Kh:ie_Kh)
2311		grad_vort_mag_h_2d(i,j,kk) = SQRT(((0.5(vort_xy_dx(i,J,kk) + vort_xy_dx(i,J-1,kk)))*2) + &
2312	0	((0.5(vort_xy_dy(I,j,kk) + vort_xy_dy(I-1,j,kk)))*2) )
2313		enddo
2314	0	do concurrent (kk=1:kmax, J=js-1:Jeq, I=is-1:Ieq)
2315		grad_vort_mag_q_2d(I,J,kk) = SQRT(((0.5(vort_xy_dx(i,J,kk) + vort_xy_dx(i+1,J,kk)))*2) + &
2316	0	((0.5(vort_xy_dy(I,j,kk) + vort_xy_dy(I,j+1,kk)))*2) )
2317		enddo
2318
2319		! This accumulates terms, some of which are in VarMix.
2320	0	do kk=1,kmax
2321	0	k = kstart + kk - 1
2322		call calc_QG_Leith_viscosity(VarMix, G, GV, US, h, dz, k, div_xx_dx(:,:,kk), div_xx_dy(:,:,kk), &
2323	0	slope_x, slope_y, vort_xy_dx(:,:,kk), vort_xy_dy(:,:,kk))
2324		enddo
2325
2326		endif
2327
2328	0	do concurrent (kk=1:kmax, j=js_Kh:je_Kh, i=is_Kh:ie_Kh)
2329		grad_vort_mag_h(i,j,kk) = SQRT(((0.5(vort_xy_dx(i,J,kk) + vort_xy_dx(i,J-1,kk)))*2) + &
2330	0	((0.5(vort_xy_dy(I,j,kk) + vort_xy_dy(I-1,j,kk)))*2) )
2331		enddo
2332	0	do concurrent (kk=1:kmax, J=js-1:Jeq, I=is-1:Ieq)
2333		grad_vort_mag_q(I,J,kk) = SQRT(((0.5(vort_xy_dx(i,J,kk) + vort_xy_dx(i+1,J,kk)))*2) + &
2334	0	((0.5(vort_xy_dy(I,j,kk) + vort_xy_dy(I,j+1,kk)))*2) )
2335		enddo
2336
2337	0	if (CS%use_Leithy) then
2338	0	do concurrent (kk=1:kmax, j=js_Kh:je_Kh, i=is_Kh:ie_Kh)
2339		vert_vort_mag_smooth(i,j,kk) = SQRT(((0.5*(vort_xy_dx_smooth(i,J,kk) + &
2340		vort_xy_dx_smooth(i,J-1,kk)))**2) + &
2341		((0.5*(vort_xy_dy_smooth(I,j,kk) + &
2342	0	vort_xy_dy_smooth(I-1,j,kk)))**2) )
2343		enddo
2344		endif ! Leithy
2345
2346	0	end subroutine hor_visc_Leith_grad
2347
2348		!> Adds the MEKE-based (EY24_EBT_BS) backscatter contribution to the diagonal term of
2349		!! the stress tensor at h-points. The caller must only invoke this routine when
2350		!! CS%EY24_EBT_BS is true.
2351	0	subroutine hor_visc_backscatter_h(G, CS, MEKE, VarMix, use_kh_struct, nkblock, kstart, kmax, &
2352	0	Isq, Ieq, Jsq, Jeq, visc_limit_h_flag, sh_xx, str_xx, BS_coeff_h)
2353		type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure.
2354		type(hor_visc_CS), intent(in) :: CS !< Horizontal viscosity control structure
2355		type(MEKE_type), intent(in) :: MEKE !< MEKE fields related to Mesoscale Eddy Kinetic Energy.
2356		type(VarMix_CS), intent(in) :: VarMix !< Variable mixing control structure
2357		logical, intent(in) :: use_kh_struct !< If true, shape the backscatter coefficient
2358		!! with VarMix%BS_struct
2359		integer, intent(in) :: nkblock !< The k-block size used to size the following arrays [nondim]
2360		integer, intent(in) :: kstart !< The first absolute k-layer of the current k-block
2361		integer, intent(in) :: kmax !< The number of active k-layers in the current k-block
2362		integer, intent(in) :: Isq !< Start i-loop index for the stress tensor at h-points
2363		integer, intent(in) :: Ieq !< End i-loop index for the stress tensor at h-points
2364		integer, intent(in) :: Jsq !< Start j-loop index for the stress tensor at h-points
2365		integer, intent(in) :: Jeq !< End j-loop index for the stress tensor at h-points
2366		real, dimension(SZI_(G),SZJ_(G),SZK_(G)), &
2367		intent(in) :: visc_limit_h_flag !< determines whether backscatter is shut off [nondim]
2368		real, dimension(SZI_(G),SZJ_(G),nkblock), &
2369		intent(in) :: sh_xx !< horizontal tension (du/dx - dv/dy) including
2370		!! metric terms [T-1 ~> s-1]
2371		real, dimension(SZI_(G),SZJ_(G),nkblock), &
2372		intent(inout) :: str_xx !< The diagonal term in the stress tensor
2373		!! [H L2 T-2 ~> m3 s-2 or kg s-2]
2374		real, dimension(SZI_(G),SZJ_(G),SZK_(G)), &
2375		intent(inout) :: BS_coeff_h !< A diagnostic array of the backscatter
2376		!! coefficient [L2 T-1 ~> m2 s-1]
2377		! Local variables
2378		real, dimension(SZI_(G),SZJ_(G),nkblock) :: &
2379	0	Kh_BS, & ! Laplacian antiviscosity [L2 T-1 ~> m2 s-1]
2380	0	str_xx_BS ! The diagonal term in the stress tensor due to backscatter [H L2 T-2 ~> m3 s-2 or kg s-2]
2381		integer :: i, j, k, kk
2382
2383	0	do kk=1,kmax ; do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1
2384	0	k = kstart + kk - 1
2385	0	if (visc_limit_h_flag(i,j,k) > 0) then
2386	0	Kh_BS(i,j,kk) = 0.
2387		else
2388	0	if (use_kh_struct) then
2389	0	Kh_BS(i,j,kk) = MEKE%Ku(i,j) * VarMix%BS_struct(i,j,k)
2390		else
2391	0	Kh_BS(i,j,kk) = MEKE%Ku(i,j)
2392		endif
2393		endif
2394		enddo ; enddo ; enddo
2395
2396	0	do concurrent (kk=1:kmax, j=Jsq:Jeq+1, i=Isq:Ieq+1)
2397	0	str_xx_BS(i,j,kk) = -Kh_BS(i,j,kk) * sh_xx(i,j,kk)
2398		enddo
2399
2400	0	if (CS%id_BS_coeff_h>0) then
2401	0	do concurrent (kk=1:kmax, j=Jsq:Jeq+1, i=Isq:Ieq+1) DO_LOCALITY(local(k))
2402	0	k = kstart + kk - 1
2403	0	BS_coeff_h(i,j,k) = Kh_BS(i,j,kk)
2404		enddo
2405		endif
2406
2407	0	do concurrent (kk=1:kmax, j=Jsq:Jeq+1, i=Isq:Ieq+1)
2408	0	str_xx(i,j,kk) = str_xx(i,j,kk) + str_xx_BS(i,j,kk)
2409		enddo
2410
2411	0	end subroutine hor_visc_backscatter_h
2412
2413		!> Adds the MEKE-based (EY24_EBT_BS) backscatter contribution to the cross term of
2414		!! the stress tensor at q-points. The caller must only invoke this routine when
2415		!! CS%EY24_EBT_BS is true.
2416	0	subroutine hor_visc_backscatter_q(G, GV, CS, MEKE, VarMix, use_kh_struct, nkblock, kstart, kmax, &
2417	0	is, js, Ieq, Jeq, visc_limit_q_flag, sh_xy, str_xy, BS_coeff_q)
2418		type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure.
2419		type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure.
2420		type(hor_visc_CS), intent(in) :: CS !< Horizontal viscosity control structure
2421		type(MEKE_type), intent(in) :: MEKE !< MEKE fields related to Mesoscale Eddy Kinetic Energy.
2422		type(VarMix_CS), intent(in) :: VarMix !< Variable mixing control structure
2423		logical, intent(in) :: use_kh_struct !< If true, shape the backscatter coefficient
2424		!! with VarMix%BS_struct
2425		integer, intent(in) :: nkblock !< The k-block size used to size the following arrays [nondim]
2426		integer, intent(in) :: kstart !< The first absolute k-layer of the current k-block
2427		integer, intent(in) :: kmax !< The number of active k-layers in the current k-block
2428		integer, intent(in) :: is !< Start i-loop index for the q-point stress tensor
2429		integer, intent(in) :: js !< Start j-loop index for the q-point stress tensor
2430		integer, intent(in) :: Ieq !< End i-loop index for the q-point stress tensor
2431		integer, intent(in) :: Jeq !< End j-loop index for the q-point stress tensor
2432		real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)), &
2433		intent(in) :: visc_limit_q_flag !< determines whether backscatter is shut off [nondim]
2434		real, dimension(SZIB_(G),SZJB_(G),nkblock), &
2435		intent(in) :: sh_xy !< horizontal shearing strain (du/dy + dv/dx) including
2436		!! metric terms [T-1 ~> s-1]
2437		real, dimension(SZIB_(G),SZJB_(G),nkblock), &
2438		intent(inout) :: str_xy !< The cross term in the stress tensor
2439		!! [H L2 T-2 ~> m3 s-2 or kg s-2]
2440		real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)), &
2441		intent(inout) :: BS_coeff_q !< A diagnostic array of the backscatter
2442		!! coefficient [L2 T-1 ~> m2 s-1]
2443		! Local variables
2444		real, dimension(SZIB_(G),SZJB_(G),nkblock) :: &
2445	0	Kh_BS, & ! Laplacian antiviscosity [L2 T-1 ~> m2 s-1]
2446	0	str_xy_BS ! The cross term in the stress tensor due to backscatter [H L2 T-2 ~> m3 s-2 or kg s-2]
2447		integer :: i, j, k, kk
2448
2449	0	do kk=1,kmax ; do J=js-1,Jeq ; do I=is-1,Ieq
2450	0	k = kstart + kk - 1
2451	0	if (visc_limit_q_flag(I,J,k) > 0) then
2452	0	Kh_BS(I,J,kk) = 0.
2453		else
2454	0	if (use_kh_struct) then
2455		Kh_BS(I,J,kk) = 0.25( ((MEKE%Ku(i,j)VarMix%BS_struct(i,j,k)) + &
2456		(MEKE%Ku(i+1,j+1)*VarMix%BS_struct(i+1,j+1,k))) + &
2457		((MEKE%Ku(i+1,j)*VarMix%BS_struct(i+1,j,k)) + &
2458	0	(MEKE%Ku(i,j+1)*VarMix%BS_struct(i,j+1,k))) )
2459		else
2460		Kh_BS(I,J,kk) = 0.25*( (MEKE%Ku(i,j) + MEKE%Ku(i+1,j+1)) + &
2461	0	(MEKE%Ku(i+1,j) + MEKE%Ku(i,j+1)) )
2462		endif
2463		endif
2464		enddo ; enddo ; enddo
2465
2466	0	do concurrent (kk=1:kmax, J=js-1:Jeq, I=is-1:Ieq)
2467	0	str_xy_BS(I,J,kk) = -Kh_BS(I,J,kk) * (sh_xy(I,J,kk))
2468		enddo
2469
2470	0	if (CS%id_BS_coeff_q>0) then
2471	0	do concurrent (kk=1:kmax, J=js-1:Jeq, I=is-1:Ieq) DO_LOCALITY(local(k))
2472	0	k = kstart + kk - 1
2473	0	BS_coeff_q(I,J,k) = Kh_BS(I,J,kk)
2474		enddo
2475		endif
2476
2477	0	do concurrent (kk=1:kmax, J=js-1:Jeq, I=is-1:Ieq)
2478	0	str_xy(I,J,kk) = str_xy(I,J,kk) + str_xy_BS(I,J,kk)
2479		enddo
2480
2481	0	end subroutine hor_visc_backscatter_q
2482
2483		!> Computes the Leith+E antisymmetric-viscosity ratio m_leithy, and updates the
2484		!! biharmonic viscosity Ah (and Ah_h) to include the Leith+E contribution, optionally
2485		!! smoothing m_leithy and Ah in the process. The caller must only invoke this
2486		!! routine when CS%use_Leithy is true.
2487	0	subroutine hor_visc_Leithy_Ah(G, GV, CS, nkblock, kstart, kmax, is_Kh, ie_Kh, js_Kh, je_Kh, inv_PI6, &
2488	0	Del2vort_q, vert_vort_mag, vert_vort_mag_smooth, vort_xy_smooth, &
2489	0	Ah, Ah_h, m_leithy)
2490		type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure.
2491		type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure.
2492		type(hor_visc_CS), intent(in) :: CS !< Horizontal viscosity control structure
2493		integer, intent(in) :: nkblock !< The k-block size used to size the following arrays [nondim]
2494		integer, intent(in) :: kstart !< The first absolute k-layer of the current k-block
2495		integer, intent(in) :: kmax !< The number of active k-layers in the current k-block
2496		integer, intent(in) :: is_Kh !< Start i-loop index for the thickness point viscosities
2497		integer, intent(in) :: ie_Kh !< End i-loop index for the thickness point viscosities
2498		integer, intent(in) :: js_Kh !< Start j-loop index for the thickness point viscosities
2499		integer, intent(in) :: je_Kh !< End j-loop index for the thickness point viscosities
2500		real, intent(in) :: inv_PI6 !< The inverse of pi to the sixth power [nondim]
2501		real, dimension(SZIB_(G),SZJB_(G),nkblock), &
2502		intent(in) :: Del2vort_q !< Laplacian of vorticity at q-points [L-2 T-1 ~> m-2 s-1]
2503		real, dimension(SZIB_(G),SZJB_(G),nkblock), &
2504		intent(in) :: vert_vort_mag !< Magnitude of the vertical vorticity
2505		!! gradient (h or q) [L-1 T-1 ~> m-1 s-1]
2506		real, dimension(SZIB_(G),SZJB_(G),nkblock), &
2507		intent(in) :: vert_vort_mag_smooth !< Magnitude of gradient of smoothed
2508		!! vertical vorticity (h or q) [L-1 T-1 ~> m-1 s-1]
2509		real, dimension(SZIB_(G),SZJB_(G),nkblock), &
2510		intent(in) :: vort_xy_smooth !< Vertical vorticity including metric
2511		!! terms, smoothed [T-1 ~> s-1]
2512		real, dimension(SZIB_(G),SZJB_(G),nkblock), &
2513		intent(inout) :: Ah !< biharmonic viscosity (h or q) [L4 T-1 ~> m4 s-1]
2514		real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), &
2515		intent(inout) :: Ah_h !< biharmonic viscosity at thickness points [L4 T-1 ~> m4 s-1]
2516		real, dimension(SZI_(G),SZJ_(G),nkblock), &
2517		intent(out) :: m_leithy !< Kh=m_leithy*Ah in Leith+E parameterization [L-2 ~> m-2]
2518		! Local variables
2519		real, dimension(SZI_(G),SZJ_(G),nkblock) :: &
2520	0	Ah_sq ! The square of the biharmonic viscosity [L8 T-2 ~> m8 s-2]
2521		real :: Del2vort_h ! Laplacian of vorticity at h-points [L-2 T-1 ~> m-2 s-1]
2522		real :: AhLth ! 2D Leith biharmonic viscosity [L4 T-1 ~> m4 s-1]
2523		real :: AhLthy ! 2D Leith+E biharmonic viscosity [L4 T-1 ~> m4 s-1]
2524		integer :: i, j, k, kk
2525
2526		! Get m_leithy
2527	0	if (CS%smooth_Ah) then
2528	0	do kk=1,kmax
2529	0	m_leithy(:,:,kk) = 0.0 ! This is here to initialize domain edge halo values.
2530		enddo
2531		endif
2532	0	do concurrent (kk=1:kmax, j=js_Kh:je_Kh, i=is_Kh:ie_Kh) DO_LOCALITY(local(Del2vort_h, AhLth))
2533		Del2vort_h = 0.25 * ((Del2vort_q(I,J,kk) + Del2vort_q(I-1,J-1,kk)) + &
2534	0	(Del2vort_q(I-1,J,kk) + Del2vort_q(I,J-1,kk)))
2535	0	AhLth = CS%Biharm6_const_xx(i,j) * inv_PI6 * abs(Del2vort_h)
2536	0	if (AhLth <= CS%Ah_bg_xx(i,j)) then
2537	0	m_leithy(i,j,kk) = 0.0
2538		else
2539	0	if ((CS%m_const_leithy(i,j)*vert_vort_mag(i,j,kk)) < abs(vort_xy_smooth(i,j,kk))) then
2540	0	m_leithy(i,j,kk) = CS%c_K * (vert_vort_mag(i,j,kk) / vort_xy_smooth(i,j,kk))**2
2541		else
2542	0	m_leithy(i,j,kk) = CS%m_leithy_max(i,j)
2543		endif
2544	0	m_leithy(i,j,kk) = G%mask2dBu(i,j) * m_leithy(i,j,kk)
2545		endif
2546		enddo
2547
2548	0	if (CS%smooth_Ah) then
2549	0	do kk=1,kmax
2550		! Smooth m_leithy. A single call smoothes twice.
2551	0	call pass_var(m_leithy(:,:,kk), G%Domain, halo=2)
2552	0	call smooth_x9_h(G, m_leithy(:,:,kk), zero_land=.true.)
2553	0	call pass_var(m_leithy(:,:,kk), G%Domain)
2554		enddo
2555		endif
2556		! Get Ah
2557	0	do concurrent (kk=1:kmax, j=js_Kh:je_Kh, i=is_Kh:ie_Kh) DO_LOCALITY(local(Del2vort_h, AhLthy))
2558		Del2vort_h = 0.25 * ((Del2vort_q(I,J,kk) + Del2vort_q(I-1,J-1,kk)) + &
2559	0	(Del2vort_q(I-1,J,kk) + Del2vort_q(I,J-1,kk)))
2560		AhLthy = CS%Biharm6_const_xx(i,j) * inv_PI6 * &
2561	0	sqrt(max(0.,Del2vort_h*2 - m_leithy(i,j,kk)vert_vort_mag_smooth(i,j,kk)**2))
2562	0	Ah(i,j,kk) = max(CS%Ah_bg_xx(i,j), AhLthy)
2563		enddo
2564	0	if (CS%smooth_Ah) then
2565		! Smooth Ah before applying upper bound. Square Ah, then smooth, then take its square root.
2566	0	do kk=1,kmax
2567	0	Ah_sq(:,:,kk) = 0.0 ! This is here to initialize domain edge halo values.
2568		enddo
2569	0	do concurrent (kk=1:kmax, j=js_Kh:je_Kh, i=is_Kh:ie_Kh)
2570	0	Ah_sq(i,j,kk) = Ah(i,j,kk)**2
2571		enddo
2572	0	do kk=1,kmax
2573	0	call pass_var(Ah_sq(:,:,kk), G%Domain, halo=2)
2574		! A single call smoothes twice.
2575	0	call smooth_x9_h(G, Ah_sq(:,:,kk), zero_land=.false.)
2576	0	call pass_var(Ah_sq(:,:,kk), G%Domain)
2577		enddo
2578	0	do concurrent (kk=1:kmax, j=js_Kh:je_Kh, i=is_Kh:ie_Kh) DO_LOCALITY(local(k))
2579	0	k = kstart + kk - 1
2580	0	Ah_h(i,j,k) = max(CS%Ah_bg_xx(i,j), sqrt(max(0., Ah_sq(i,j,kk))))
2581	0	Ah(i,j,kk) = Ah_h(i,j,k)
2582		enddo
2583		else
2584	0	do concurrent (kk=1:kmax, j=js_Kh:je_Kh, i=is_Kh:ie_Kh) DO_LOCALITY(local(k))
2585	0	k = kstart + kk - 1
2586	0	Ah_h(i,j,k) = Ah(i,j,kk)
2587		enddo
2588		endif
2589
2590	0	end subroutine hor_visc_Leithy_Ah
2591
2592		!> Returns the effective k-block size for horizontal_viscosity calls.
2593	25	integer function hor_visc_nkblock(CS, GV)
2594		type(hor_visc_CS), intent(in) :: CS !< Horizontal viscosity control structure
2595		type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure.
2596	25	hor_visc_nkblock = merge(GV%ke, CS%nkblock, CS%nkblock==0)
2597	25	end function hor_visc_nkblock
2598
2599		!> Calculates the barotropic tension and shearing strain fields and the GME
2600		!! efficiency and isopycnal height diffusivity fields that are used within
2601		!! horizontal_viscosity when GME (CS%use_GME) is active. The caller must
2602		!! only invoke this routine when CS%use_GME is true.
2603	0	subroutine hor_visc_GME_setup(G, GV, US, CS, h, BT, TD, nkblock, &
2604	0	dudx_bt, dvdy_bt, dvdx_bt, dudy_bt, sh_xx_bt, sh_xy_bt, &
2605	0	GME_effic_h, GME_effic_q, KH_u_GME, KH_v_GME, &
2606	0	GME_coeff_h, GME_coeff_q, str_xx_GME, str_xy_GME)
2607		type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure.
2608		type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure.
2609		type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
2610		type(hor_visc_CS), intent(inout) :: CS !< Horizontal viscosity control structure
2611		real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), &
2612		intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2].
2613		type(barotropic_CS), optional, intent(in) :: BT !< Barotropic control structure
2614		type(thickness_diffuse_CS), optional, intent(in) :: TD !< Thickness diffusion control structure
2615		integer, intent(in) :: nkblock !< The k-block size used to size the following arrays [nondim]
2616		real, dimension(SZI_(G),SZJB_(G)), &
2617		intent(out) :: dudx_bt !< x-component in the barotropic
2618		!! horizontal tension [T-1 ~> s-1]
2619		real, dimension(SZI_(G),SZJB_(G)), &
2620		intent(out) :: dvdy_bt !< y-component in the barotropic
2621		!! horizontal tension [T-1 ~> s-1]
2622		real, dimension(SZIB_(G),SZJB_(G)), &
2623		intent(out) :: dvdx_bt !< x-component in the barotropic
2624		!! shearing strain [T-1 ~> s-1]
2625		real, dimension(SZIB_(G),SZJB_(G)), &
2626		intent(out) :: dudy_bt !< y-component in the barotropic
2627		!! shearing strain [T-1 ~> s-1]
2628		real, dimension(SZI_(G),SZJ_(G)), &
2629		intent(out) :: sh_xx_bt !< Barotropic horizontal tension
2630		!! (du/dx - dv/dy) including metric terms [T-1 ~> s-1]
2631		real, dimension(SZIB_(G),SZJB_(G)), &
2632		intent(out) :: sh_xy_bt !< Barotropic horizontal shearing strain
2633		!! (du/dy + dv/dx) including metric terms [T-1 ~> s-1]
2634		real, dimension(SZI_(G),SZJ_(G)), &
2635		intent(out) :: GME_effic_h !< The filtered efficiency of the
2636		!! GME terms at h points [nondim]
2637		real, dimension(SZIB_(G),SZJB_(G)), &
2638		intent(out) :: GME_effic_q !< The filtered efficiency of the
2639		!! GME terms at q points [nondim]
2640		real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), &
2641		intent(out) :: KH_u_GME !< Isopycnal height diffusivities in
2642		!! u-columns [L2 T-1 ~> m2 s-1]
2643		real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), &
2644		intent(out) :: KH_v_GME !< Isopycnal height diffusivities in
2645		!! v-columns [L2 T-1 ~> m2 s-1]
2646		real, dimension(SZI_(G),SZJ_(G),SZK_(G)), &
2647		intent(out) :: GME_coeff_h !< GME coefficient at h-points
2648		!! [L2 T-1 ~> m2 s-1]
2649		real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)), &
2650		intent(out) :: GME_coeff_q !< GME coeff. at q-points [L2 T-1 ~> m2 s-1]
2651		real, dimension(SZI_(G),SZJ_(G),nkblock), &
2652		intent(out) :: str_xx_GME !< Smoothed diagonal term in the
2653		!! stress tensor from GME [L2 T-2 ~> m2 s-2]
2654		real, dimension(SZIB_(G),SZJB_(G),nkblock), &
2655		intent(out) :: str_xy_GME !< Smoothed cross term in the
2656		!! stress tensor from GME [L2 T-2 ~> m2 s-2]
2657		! Local variables
2658		real, dimension(SZIB_(G),SZJ_(G)) :: &
2659	0	ubtav ! zonal barotropic velocity averaged over a baroclinic time-step [L T-1 ~> m s-1]
2660		real, dimension(SZI_(G),SZJB_(G)) :: &
2661	0	vbtav ! meridional barotropic velocity averaged over a baroclinic time-step [L T-1 ~> m s-1]
2662		real, dimension(SZI_(G),SZJ_(G)) :: &
2663	0	htot ! The total thickness of all layers [H ~> m or kg m-2]
2664		real :: grad_vel_mag_bt_h ! Magnitude of the barotropic velocity gradient tensor squared at h-points [T-2 ~> s-2]
2665		real :: boundary_mask_h ! A mask that zeroes out cells with at least one land edge [nondim]
2666		real :: grad_vel_mag_bt_q ! Magnitude of the barotropic velocity gradient tensor squared at q-points [T-2 ~> s-2]
2667		real :: boundary_mask_q ! A mask that zeroes out cells with at least one land edge [nondim]
2668		real :: h_arith_q ! The arithmetic mean total thickness at q points [H ~> m or kg m-2]
2669		real :: I_GME_h0 ! The inverse of GME tapering scale [H-1 ~> m-1 or m2 kg-1]
2670		integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz
2671
2672	0	is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke
2673	0	Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB
2674
2675		! Initialize diagnostic arrays with zeros
2676	0	GME_coeff_h(:,:,:) = 0.0
2677	0	GME_coeff_q(:,:,:) = 0.0
2678	0	str_xx_GME(:,:,:) = 0.0
2679	0	str_xy_GME(:,:,:) = 0.0
2680
2681		! Get barotropic velocities and their gradients
2682	0	call barotropic_get_tav(BT, ubtav, vbtav, G, US)
2683
2684	0	call pass_vector(ubtav, vbtav, G%Domain)
2685	0	call pass_var(h, G%domain, halo=2)
2686
2687		! Calculate the barotropic horizontal tension
2688	0	do j=js-2,je+2 ; do i=is-2,ie+2
2689		dudx_bt(i,j) = CS%DY_dxT(i,j)((G%IdyCu(I,j) ubtav(I,j)) - &
2690	0	(G%IdyCu(I-1,j) * ubtav(I-1,j)))
2691		dvdy_bt(i,j) = CS%DX_dyT(i,j)((G%IdxCv(i,J) vbtav(i,J)) - &
2692	0	(G%IdxCv(i,J-1) * vbtav(i,J-1)))
2693		enddo ; enddo
2694	0	do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2
2695	0	sh_xx_bt(i,j) = dudx_bt(i,j) - dvdy_bt(i,j)
2696		enddo ; enddo
2697
2698		! Components for the barotropic shearing strain
2699	0	do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2
2700		dvdx_bt(I,J) = CS%DY_dxBu(I,J)((vbtav(i+1,J)G%IdyCv(i+1,J)) &
2701	0	- (vbtav(i,J)*G%IdyCv(i,J)))
2702		dudy_bt(I,J) = CS%DX_dyBu(I,J)((ubtav(I,j+1)G%IdxCu(I,j+1)) &
2703	0	- (ubtav(I,j)*G%IdxCu(I,j)))
2704		enddo ; enddo
2705
2706	0	if (CS%no_slip) then
2707	0	do J=js-2,je+1 ; do I=is-2,ie+1
2708	0	sh_xy_bt(I,J) = (2.0-G%mask2dBu(I,J)) * ( dvdx_bt(I,J) + dudy_bt(I,J) )
2709		enddo ; enddo
2710		else
2711	0	do J=js-2,je+1 ; do I=is-2,ie+1
2712	0	sh_xy_bt(I,J) = G%mask2dBu(I,J) * ( dvdx_bt(I,J) + dudy_bt(I,J) )
2713		enddo ; enddo
2714		endif
2715
2716	0	do j=js-2,je+2 ; do i=is-2,ie+2
2717	0	htot(i,j) = 0.0
2718		enddo ; enddo
2719	0	do k=1,nz ; do j=js-2,je+2 ; do i=is-2,ie+2
2720	0	htot(i,j) = htot(i,j) + h(i,j,k)
2721		enddo ; enddo ; enddo
2722
2723	0	I_GME_h0 = 1.0 / CS%GME_h0
2724	0	do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2
2725	0	boundary_mask_h = (G%mask2dCu(I,j) * G%mask2dCu(I-1,j)) * (G%mask2dCv(i,J) * G%mask2dCv(i,J-1))
2726		grad_vel_mag_bt_h = G%mask2dT(I,J) * boundary_mask_h * (dudx_bt(i,j)2 + dvdy_bt(i,j)2 + &
2727		(0.25((dvdx_bt(I,J)+dvdx_bt(I-1,J-1)) + (dvdx_bt(I,J-1)+dvdx_bt(I-1,J))))*2 + &
2728	0	(0.25((dudy_bt(I,J)+dudy_bt(I-1,J-1)) + (dudy_bt(I,J-1)+dudy_bt(I-1,J))))*2)
2729		! Probably the following test could be simplified to
2730		! if (boundary_mask_h * G%mask2dT(I,J) > 0.0) then
2731	0	if (grad_vel_mag_bt_h > 0.0) then
2732	0	GME_effic_h(i,j) = CS%GME_efficiency * G%mask2dT(I,J) * (MIN(htot(i,j) * I_GME_h0, 1.0)**2)
2733		else
2734	0	GME_effic_h(i,j) = 0.0
2735		endif
2736		enddo ; enddo
2737
2738	0	do J=js-2,je+1 ; do I=is-2,ie+1
2739	0	boundary_mask_q = (G%mask2dCv(i,J) * G%mask2dCv(i+1,J)) * (G%mask2dCu(I,j) * G%mask2dCu(I,j+1))
2740		grad_vel_mag_bt_q = G%mask2dBu(I,J) * boundary_mask_q * (dvdx_bt(I,J)2 + dudy_bt(I,J)2 + &
2741		(0.25((dudx_bt(i,j)+dudx_bt(i+1,j+1)) + (dudx_bt(i,j+1)+dudx_bt(i+1,j))))*2 + &
2742	0	(0.25((dvdy_bt(i,j)+dvdy_bt(i+1,j+1)) + (dvdy_bt(i,j+1)+dvdy_bt(i+1,j))))*2)
2743		! Probably the following test could be simplified to
2744		! if (boundary_mask_q * G%mask2dBu(I,J) > 0.0) then
2745	0	if (grad_vel_mag_bt_q > 0.0) then
2746	0	h_arith_q = 0.25 * ((htot(i,j) + htot(i+1,j+1)) + (htot(i+1,j) + htot(i,j+1)))
2747	0	GME_effic_q(I,J) = CS%GME_efficiency * G%mask2dBu(I,J) * (MIN(h_arith_q * I_GME_h0, 1.0)**2)
2748		else
2749	0	GME_effic_q(I,J) = 0.0
2750		endif
2751		enddo ; enddo
2752
2753	0	call thickness_diffuse_get_KH(TD, KH_u_GME, KH_v_GME, G, GV)
2754
2755	0	call pass_vector(KH_u_GME, KH_v_GME, G%domain, To_All+Scalar_Pair)
2756
2757	0	if (CS%debug) &
2758	0	call uvchksum("GME KH[u,v]_GME", KH_u_GME, KH_v_GME, G%HI, haloshift=2, unscale=US%L_to_m*2US%s_to_T)
2759
2760	0	end subroutine hor_visc_GME_setup
2761
2762		!> Allocates space for and calculates static variables used by horizontal_viscosity.
2763		!! hor_visc_init calculates and stores the values of a number of metric functions that
2764		!! are used in horizontal_viscosity.
2765	1	subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp)
2766		type(time_type), intent(in) :: Time !< Current model time.
2767		type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure.
2768		type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure
2769		type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
2770		type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time
2771		!! parameters.
2772		type(diag_ctrl), target, intent(inout) :: diag !< Structure to regulate diagnostic output.
2773		type(hor_visc_CS), intent(inout) :: CS !< Horizontal viscosity control structure
2774		type(accel_diag_ptrs), intent(in), optional :: ADp !< Acceleration diagnostics
2775
2776		! u0v is the Laplacian sensitivities to the v velocities at u points, with u0u, v0u, and v0v defined analogously.
2777	3	real, dimension(SZIB_(G),SZJ_(G)) :: u0u, u0v ! Laplacian sensitivities at u points [L-2 ~> m-2]
2778	1	real, dimension(SZI_(G),SZJB_(G)) :: v0u, v0v ! Laplacian sensitivities at v points [L-2 ~> m-2]
2779		real :: grid_sp_h2 ! Harmonic mean of the squares of the grid [L2 ~> m2]
2780		real :: grid_sp_h3 ! Harmonic mean of the squares of the grid^(3/2) [L3 ~> m3]
2781		real :: grid_sp_q2 ! spacings at h and q points [L2 ~> m2]
2782		real :: grid_sp_q3 ! spacings at h and q points^(3/2) [L3 ~> m3]
2783		real :: min_grid_sp_h2 ! Minimum value of grid_sp_h2 [L2 ~> m2]
2784		real :: min_grid_sp_h4 ! Minimum value of grid_sp_h2**2 [L4 ~> m4]
2785		real :: Kh_Limit ! A coefficient [T-1 ~> s-1] used, along with the
2786		! grid spacing, to limit Laplacian viscosity.
2787		real :: fmax ! maximum absolute value of f at the four
2788		! vorticity points around a thickness point [T-1 ~> s-1]
2789		real :: BoundCorConst ! A constant used when using viscosity to bound the Coriolis accelerations
2790		! [T2 L-2 ~> s2 m-2]
2791		real :: Ah_Limit ! coefficient [T-1 ~> s-1] used, along with the
2792		! grid spacing, to limit biharmonic viscosity
2793		real :: Kh ! Lapacian horizontal viscosity [L2 T-1 ~> m2 s-1]
2794		real :: Ah ! biharmonic horizontal viscosity [L4 T-1 ~> m4 s-1]
2795		real :: Kh_vel_scale ! this speed [L T-1 ~> m s-1] times grid spacing gives Laplacian viscosity
2796		real :: Ah_vel_scale ! this speed [L T-1 ~> m s-1] times grid spacing cubed gives biharmonic viscosity
2797		real :: Ah_time_scale ! damping time-scale for biharmonic visc [T ~> s]
2798		real :: Smag_Lap_const ! nondimensional Laplacian Smagorinsky constant [nondim]
2799		real :: Smag_bi_const ! nondimensional biharmonic Smagorinsky constant [nondim]
2800		real :: Leith_Lap_const ! nondimensional Laplacian Leith constant [nondim]
2801		real :: Leith_bi_const ! nondimensional biharmonic Leith constant [nondim]
2802		real :: dt ! The dynamics time step [T ~> s]
2803		real :: Idt ! The inverse of dt [T-1 ~> s-1]
2804		real :: denom ! work variable; the denominator of a fraction [L-2 ~> m-2] or [L-4 ~> m-4]
2805		real :: maxvel ! largest permitted velocity components [L T-1 ~> m s-1]
2806		real :: bound_Cor_vel ! grid-scale velocity variations at which value
2807		! the quadratically varying biharmonic viscosity
2808		! balances Coriolis acceleration [L T-1 ~> m s-1]
2809		real :: Kh_sin_lat ! Amplitude of latitudinally dependent viscosity [L2 T-1 ~> m2 s-1]
2810		real :: Kh_pwr_of_sine ! Power used to raise sin(lat) when using Kh_sin_lat [nondim]
2811		logical :: bound_Cor_def ! parameter setting of BOUND_CORIOLIS
2812		logical :: split ! If true, use the split time stepping scheme.
2813		! If false and USE_GME = True, issue a FATAL error.
2814		logical :: use_MEKE ! If true, the MEKE parameterization is in use.
2815		logical :: enable_bugs ! If true, the defaults for recently added bug-fix flags are set to
2816		! recreate the bugs, or if false bugs are only used if actively selected.
2817		real :: backscatter_Ro_c ! Coefficient in Rossby number function for backscatter [nondim]
2818		integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags
2819		character(len=200) :: inputdir, filename ! Input file names and paths
2820		character(len=80) :: Kh_var ! Input variable names
2821		real :: deg2rad ! Converts degrees to radians [radians degree-1]
2822		real :: slat_fn ! sin(lat)**Kh_pwr_of_sine [nondim]
2823		real :: aniso_grid_dir(2) ! Vector (n1,n2) for anisotropic direction [nondim]
2824		integer :: aniso_mode ! Selects the mode for setting the anisotropic direction
2825		integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz
2826		integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB
2827		integer :: i, j
2828		#ifdef __NVCOMPILER_OPENMP_GPU
2829		integer, parameter :: default_nkblock = 0
2830		#else
2831		integer, parameter :: default_nkblock = 1
2832		#endif
2833		! This include declares and sets the variable "version".
2834		# include "version_variable.h"
2835		character(len=40) :: mdl = "MOM_hor_visc" ! module name
2836	1	is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke
2837	1	Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB
2838	1	isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed
2839	1	IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB
2840
2841		! init control structure
2842	1	call ZB2020_init(Time, G, GV, US, param_file, diag, CS%ZB2020, CS%use_ZB2020)
2843
2844	1	CS%initialized = .true.
2845
2846	1	CS%diag => diag
2847		! Read parameters and write them to the model log.
2848	1	call log_version(param_file, mdl, version, "")
2849
2850		call get_param(param_file, mdl, "HORVISC_NKBLOCK", CS%nkblock, &
2851		"The k-direction block size used in horizontal viscosity calculations. "//&
2852		"The default 0 setting dynamically uses the full vertical column.", &
2853	1	default=default_nkblock, layoutParam=.true.)
2854	1	if (CS%nkblock < 0) call MOM_error(FATAL, "HORVISC_NKBLOCK must be >= 0.")
2855
2856		call get_param(param_file, mdl, "USE_CIRCULATION_IN_HORVISC", CS%use_circulation, &
2857		"Use circulation theorem to compute vorticity in horvisc module (for ZB20 or Leith)", &
2858	1	default=.False.)
2859
2860		! All parameters are read in all cases to enable parameter spelling checks.
2861		call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, &
2862		"This sets the default value for the various _ANSWER_DATE parameters.", &
2863	1	default=99991231)
2864
2865		! Determine whether HOR_VISC_ANSWER_DATE is used, and avoid logging it if it is not used.
2866		call get_param(param_file, mdl, "USE_MEKE", use_MEKE, &
2867	1	default=.false., do_not_log=.true.)
2868	1	backscatter_Ro_c = 0.0
2869	1	if (use_MEKE) call get_param(param_file, mdl, "MEKE_BACKSCAT_RO_C", backscatter_Ro_c, &
2870		"The coefficient in the Rossby number function for scaling the biharmonic "//&
2871		"frictional energy source. Setting to non-zero enables the Rossby number function.", &
2872	1	units="nondim", default=0.0, do_not_log=.true.)
2873
2874		call get_param(param_file, mdl, "HOR_VISC_ANSWER_DATE", CS%answer_date, &
2875		"The vintage of the order of arithmetic and expressions in the horizontal "//&
2876		"viscosity calculations. Values between 20190102 and 20241201 recover the "//&
2877		"answers from the end of 2018, while higher values use updated and more robust "//&
2878		"forms of the same expressions.", &
2879	1	default=default_answer_date, do_not_log=(.not.GV%Boussinesq).or.(backscatter_Ro_c==0.0))
2880	1	if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20241201)
2881
2882	1	call get_param(param_file, mdl, "DEBUG", CS%debug, default=.false.)
2883		call get_param(param_file, mdl, "USE_CONT_THICKNESS", CS%use_cont_thick, &
2884		"If true, use thickness at velocity points from continuity solver. This option "//&
2885	1	"currently only works with split mode.", default=.false.)
2886		call get_param(param_file, mdl, "USE_CONT_THICKNESS_BUG", CS%use_cont_thick_bug, &
2887		"If true, retain an answer-changing halo update bug when "//&
2888		"USE_CONT_THICKNESS=True. This is not recommended.", &
2889	1	default=.false., do_not_log=.not.CS%use_cont_thick)
2890
2891		call get_param(param_file, mdl, "LAPLACIAN", CS%Laplacian, &
2892		"If true, use a Laplacian horizontal viscosity.", &
2893	1	default=.false.)
2894
2895		call get_param(param_file, mdl, "KH", Kh, &
2896		"The background Laplacian horizontal viscosity.", &
2897		units="m2 s-1", default=0.0, scale=US%m_to_L*2US%T_to_s, &
2898	1	do_not_log=.not.CS%Laplacian)
2899		call get_param(param_file, mdl, "KH_BG_MIN", CS%Kh_bg_min, &
2900		"The minimum value allowed for Laplacian horizontal viscosity, KH.", &
2901		units="m2 s-1", default=0.0, scale=US%m_to_L*2US%T_to_s, &
2902	1	do_not_log=.not.CS%Laplacian)
2903		call get_param(param_file, mdl, "KH_VEL_SCALE", Kh_vel_scale, &
2904		"The velocity scale which is multiplied by the grid "//&
2905		"spacing to calculate the Laplacian viscosity. "//&
2906		"The final viscosity is the largest of this scaled "//&
2907		"viscosity, the Smagorinsky and Leith viscosities, and KH.", &
2908		units="m s-1", default=0.0, scale=US%m_s_to_L_T, &
2909	1	do_not_log=.not.CS%Laplacian)
2910		call get_param(param_file, mdl, "KH_SIN_LAT", Kh_sin_lat, &
2911		"The amplitude of a latitudinally-dependent background "//&
2912		"viscosity of the form KH_SIN_LAT(SIN(LAT)*KH_PWR_OF_SINE).", &
2913		units="m2 s-1", default=0.0, scale=US%m_to_L*2US%T_to_s, &
2914	1	do_not_log=.not.CS%Laplacian)
2915		call get_param(param_file, mdl, "KH_PWR_OF_SINE", Kh_pwr_of_sine, &
2916		"The power used to raise SIN(LAT) when using a latitudinally "//&
2917		"dependent background viscosity.", &
2918		units="nondim", default=4.0, &
2919	1	do_not_log=.not.(CS%Laplacian .and. (Kh_sin_lat>0.)) )
2920		call get_param(param_file, mdl, "SMAGORINSKY_KH", CS%Smagorinsky_Kh, &
2921		"If true, use a Smagorinsky nonlinear eddy viscosity.", &
2922	1	default=.false., do_not_log=.not.CS%Laplacian)
2923	1	if (.not.CS%Laplacian) CS%Smagorinsky_Kh = .false.
2924		call get_param(param_file, mdl, "SMAG_LAP_CONST", Smag_Lap_const, &
2925		"The nondimensional Laplacian Smagorinsky constant, "//&
2926		"often 0.15.", units="nondim", default=0.0, &
2927	1	fail_if_missing=CS%Smagorinsky_Kh, do_not_log=.not.CS%Smagorinsky_Kh)
2928		call get_param(param_file, mdl, "LEITH_KH", CS%Leith_Kh, &
2929		"If true, use a Leith nonlinear eddy viscosity.", &
2930	1	default=.false., do_not_log=.not.CS%Laplacian)
2931	1	if (.not.CS%Laplacian) CS%Leith_Kh = .false.
2932		call get_param(param_file, mdl, "LEITH_LAP_CONST", Leith_Lap_const, &
2933		"The nondimensional Laplacian Leith constant, "//&
2934		"often set to 1.0", units="nondim", default=0.0, &
2935	1	fail_if_missing=CS%Leith_Kh, do_not_log=.not.CS%Leith_Kh)
2936		call get_param(param_file, mdl, "RES_SCALE_MEKE_VISC", CS%res_scale_MEKE, &
2937		"If true, the viscosity contribution from MEKE is scaled by "//&
2938		"the resolution function.", default=.false., &
2939	1	do_not_log=.not.(CS%Laplacian.and.use_MEKE))
2940	1	if (.not.(CS%Laplacian.and.use_MEKE)) CS%res_scale_MEKE = .false.
2941
2942		call get_param(param_file, mdl, "BOUND_KH", CS%bound_Kh, &
2943		"If true, the Laplacian coefficient is locally limited "//&
2944	1	"to be stable.", default=.true., do_not_log=.not.CS%Laplacian)
2945		call get_param(param_file, mdl, "EY24_EBT_BS", CS%EY24_EBT_BS, &
2946		"If true, use the backscatter scheme (EBT mode with kill switch) "//&
2947		"developed by Yankovsky et al. (2024). ", &
2948	1	default=.false., do_not_log=.not.CS%Laplacian)
2949	1	if (.not.CS%Laplacian) CS%bound_Kh = .false.
2950	1	if (.not.(CS%Laplacian.and.use_MEKE)) CS%EY24_EBT_BS = .false.
2951		call get_param(param_file, mdl, "ANISOTROPIC_VISCOSITY", CS%anisotropic, &
2952		"If true, allow anistropic viscosity in the Laplacian "//&
2953		"horizontal viscosity.", default=.false., &
2954	1	do_not_log=.not.CS%Laplacian)
2955	1	if (.not.CS%Laplacian) CS%anisotropic = .false. ! This replicates the prior code, but is it intended?
2956		call get_param(param_file, mdl, "ADD_LES_VISCOSITY", CS%add_LES_viscosity, &
2957		"If true, adds the viscosity from Smagorinsky and Leith to the "//&
2958		"background viscosity instead of taking the maximum.", default=.false., &
2959	1	do_not_log=.not.CS%Laplacian)
2960
2961		call get_param(param_file, mdl, "KH_ANISO", CS%Kh_aniso, &
2962		"The background Laplacian anisotropic horizontal viscosity.", &
2963		units="m2 s-1", default=0.0, scale=US%m_to_L*2US%T_to_s, &
2964	1	do_not_log=.not.CS%anisotropic)
2965		call get_param(param_file, mdl, "ANISOTROPIC_MODE", aniso_mode, &
2966		"Selects the mode for setting the direction of anisotropy.\n"//&
2967		"\t 0 - Points along the grid i-direction.\n"//&
2968		"\t 1 - Points towards East.\n"//&
2969		"\t 2 - Points along the flow direction, U/\|U\|.", &
2970	1	default=0, do_not_log=.not.CS%anisotropic)
2971	1	if (aniso_mode == 0) then
2972		call get_param(param_file, mdl, "ANISO_GRID_DIR", aniso_grid_dir, &
2973		"The vector pointing in the direction of anisotropy for horizontal viscosity. "//&
2974		"n1,n2 are the i,j components relative to the grid.", &
2975	1	units="nondim", fail_if_missing=CS%anisotropic, do_not_log=.not.CS%anisotropic)
2976	0	elseif (aniso_mode == 1) then
2977		call get_param(param_file, mdl, "ANISO_GRID_DIR", aniso_grid_dir, &
2978		"The vector pointing in the direction of anisotropy for horizontal viscosity. "//&
2979		"n1,n2 are the i,j components relative to the spherical coordinates.", &
2980	0	units="nondim", fail_if_missing=CS%anisotropic, do_not_log=.not.CS%anisotropic)
2981		else
2982		call get_param(param_file, mdl, "ANISO_GRID_DIR", aniso_grid_dir, &
2983		"The vector pointing in the direction of anisotropy for horizontal viscosity.", &
2984	0	units="nondim", fail_if_missing=.false., do_not_log=.true.)
2985		endif
2986
2987		call get_param(param_file, mdl, "BIHARMONIC", CS%biharmonic, &
2988		"If true, use a biharmonic horizontal viscosity. "//&
2989		"BIHARMONIC may be used with LAPLACIAN.", &
2990	1	default=.true.)
2991		call get_param(param_file, mdl, "AH", Ah, &
2992		"The background biharmonic horizontal viscosity.", &
2993		units="m4 s-1", default=0.0, scale=US%m_to_L*4US%T_to_s, &
2994	1	do_not_log=.not.CS%biharmonic)
2995		call get_param(param_file, mdl, "AH_VEL_SCALE", Ah_vel_scale, &
2996		"The velocity scale which is multiplied by the cube of "//&
2997		"the grid spacing to calculate the biharmonic viscosity. "//&
2998		"The final viscosity is the largest of this scaled "//&
2999		"viscosity, the Smagorinsky and Leith viscosities, and AH.", &
3000	1	units="m s-1", default=0.0, scale=US%m_s_to_L_T, do_not_log=.not.CS%biharmonic)
3001		call get_param(param_file, mdl, "AH_TIME_SCALE", Ah_time_scale, &
3002		"A time scale whose inverse is multiplied by the fourth "//&
3003		"power of the grid spacing to calculate biharmonic viscosity. "//&
3004		"The final viscosity is the largest of all viscosity "//&
3005		"formulations in use. 0.0 means that it's not used.", &
3006	1	units="s", default=0.0, scale=US%s_to_T, do_not_log=.not.CS%biharmonic)
3007		call get_param(param_file, mdl, "SMAGORINSKY_AH", CS%Smagorinsky_Ah, &
3008		"If true, use a biharmonic Smagorinsky nonlinear eddy "//&
3009	1	"viscosity.", default=.false., do_not_log=.not.CS%biharmonic)
3010	1	if (.not.CS%biharmonic) CS%Smagorinsky_Ah = .false.
3011		call get_param(param_file, mdl, "LEITH_AH", CS%Leith_Ah, &
3012		"If true, use a biharmonic Leith nonlinear eddy "//&
3013	1	"viscosity.", default=.false., do_not_log=.not.CS%biharmonic)
3014	1	if (.not.CS%biharmonic) CS%Leith_Ah = .false.
3015		call get_param(param_file, mdl, "USE_LEITHY", CS%use_Leithy, &
3016		"If true, use a biharmonic Leith nonlinear eddy "//&
3017		"viscosity together with a harmonic backscatter.", &
3018	1	default=.false.)
3019		call get_param(param_file, mdl, "BOUND_AH", CS%bound_Ah, &
3020		"If true, the biharmonic coefficient is locally limited "//&
3021	1	"to be stable.", default=.true., do_not_log=.not.CS%biharmonic)
3022	1	if (.not.CS%biharmonic) CS%bound_Ah = .false.
3023		call get_param(param_file, mdl, "RE_AH", CS%Re_Ah, &
3024		"If nonzero, the biharmonic coefficient is scaled "//&
3025		"so that the biharmonic Reynolds number is equal to this.", &
3026	1	units="nondim", default=0.0, do_not_log=.not.CS%biharmonic)
3027
3028		call get_param(param_file, mdl, "BACKSCATTER_UNDERBOUND", CS%backscatter_underbound, &
3029		"If true, the bounds on the biharmonic viscosity are allowed to "//&
3030		"increase where the Laplacian viscosity is negative (due to backscatter "//&
3031		"parameterizations) beyond the largest timestep-dependent stable values of "//&
3032		"biharmonic viscosity when no Laplacian viscosity is applied. The default "//&
3033		"is true for historical reasons, but this option probably should not be used "//&
3034		"because it can contribute to numerical instabilities.", &
3035	1	default=.false., do_not_log=.not.((CS%bound_Kh).and.(CS%bound_Ah)))
3036
3037		call get_param(param_file, mdl, "SMAG_BI_CONST",Smag_bi_const, &
3038		"The nondimensional biharmonic Smagorinsky constant, "//&
3039		"typically 0.015 - 0.06.", units="nondim", default=0.0, &
3040	1	fail_if_missing=CS%Smagorinsky_Ah, do_not_log=.not.CS%Smagorinsky_Ah)
3041
3042		call get_param(param_file, mdl, "USE_BETA_IN_LEITH", CS%use_beta_in_Leith, &
3043		"If true, include the beta term in the Leith nonlinear eddy viscosity.", &
3044	1	default=CS%Leith_Kh, do_not_log=.not.(CS%Leith_Kh .or. CS%Leith_Ah) )
3045		call get_param(param_file, mdl, "MODIFIED_LEITH", CS%modified_Leith, &
3046		"If true, add a term to Leith viscosity which is "//&
3047		"proportional to the gradient of divergence.", &
3048	1	default=.false., do_not_log=.not.(CS%Leith_Kh .or. CS%Leith_Ah) )
3049		call get_param(param_file, mdl, "USE_QG_LEITH_VISC", CS%use_QG_Leith_visc, &
3050		"If true, use QG Leith nonlinear eddy viscosity.", &
3051	1	default=.false., do_not_log=.not.(CS%Leith_Kh .or. CS%Leith_Ah) )
3052		! if (CS%use_QG_Leith_visc) then
3053		! call MOM_error(FATAL, "USE_QG_LEITH_VISC=True activates code that is a work-in-progress and "//&
3054		! "should not be used until a number of bugs are fixed. Specifically it does not "//&
3055		! "reproduce across PE count or layout, and may use arrays that have not been properly "//&
3056		! "set or allocated. See github.com/mom-ocean/MOM6/issues/1590 for a discussion.")
3057		! endif
3058	1	if (CS%use_QG_Leith_visc .and. .not. (CS%Leith_Kh .or. CS%Leith_Ah) ) then
3059		call MOM_error(FATAL, "MOM_hor_visc.F90, hor_visc_init: "//&
3060	0	"LEITH_KH or LEITH_AH must be True when USE_QG_LEITH_VISC=True.")
3061		endif
3062
3063	1	call get_param(param_file, mdl, "BOUND_CORIOLIS", bound_Cor_def, default=.false.)
3064		call get_param(param_file, mdl, "BOUND_CORIOLIS_BIHARM", CS%bound_Coriolis, &
3065		"If true use a viscosity that increases with the square "//&
3066		"of the velocity shears, so that the resulting viscous "//&
3067		"drag is of comparable magnitude to the Coriolis terms "//&
3068		"when the velocity differences between adjacent grid "//&
3069		"points is 0.5*BOUND_CORIOLIS_VEL. The default is the "//&
3070		"value of BOUND_CORIOLIS (or false).", default=bound_Cor_def, &
3071	1	do_not_log=.not.CS%Smagorinsky_Ah)
3072	1	if (.not.CS%Smagorinsky_Ah) CS%bound_Coriolis = .false.
3073		call get_param(param_file, mdl, "MAXVEL", maxvel, &
3074	1	units="m s-1", default=3.0e8, scale=US%m_s_to_L_T)
3075		call get_param(param_file, mdl, "BOUND_CORIOLIS_VEL", bound_Cor_vel, &
3076		"The velocity scale at which BOUND_CORIOLIS_BIHARM causes "//&
3077		"the biharmonic drag to have comparable magnitude to the "//&
3078		"Coriolis acceleration. The default is set by MAXVEL.", &
3079		units="m s-1", default=maxvel*US%L_T_to_m_s, scale=US%m_s_to_L_T, &
3080	1	do_not_log=.not.(CS%Smagorinsky_Ah .and. CS%bound_Coriolis))
3081		call get_param(param_file, mdl, "LEITH_BI_CONST", Leith_bi_const, &
3082		"The nondimensional biharmonic Leith constant, "//&
3083		"typical values are thus far undetermined.", units="nondim", default=0.0, &
3084		fail_if_missing=(CS%Leith_Ah .or. CS%use_Leithy), &
3085	1	do_not_log=.not.(CS%Leith_Ah .or. CS%use_Leithy))
3086		call get_param(param_file, mdl, "USE_LAND_MASK_FOR_HVISC", CS%use_land_mask, &
3087		"If true, use the land mask for the computation of thicknesses "//&
3088		"at velocity locations. This eliminates the dependence on arbitrary "//&
3089	1	"values over land or outside of the domain.", default=.true.)
3090		call get_param(param_file, mdl, "HORVISC_BOUND_COEF", CS%bound_coef, &
3091		"The nondimensional coefficient of the ratio of the "//&
3092		"viscosity bounds to the theoretical maximum for "//&
3093		"stability without considering other terms.", units="nondim", &
3094	1	default=0.8, do_not_log=.not.(CS%bound_Ah .or. CS%bound_Kh))
3095		call get_param(param_file, mdl, "KILL_SWITCH_COEF", CS%KS_coef, &
3096		"A nondimensional coefficient on the biharmonic viscosity that "// &
3097		"sets the kill switch for backscatter. Default is 1.0.", units="nondim", &
3098	1	default=1.0, do_not_log=.not.(CS%EY24_EBT_BS))
3099		call get_param(param_file, mdl, "NOSLIP", CS%no_slip, &
3100		"If true, no slip boundary conditions are used; otherwise "//&
3101		"free slip boundary conditions are assumed. The "//&
3102		"implementation of the free slip BCs on a C-grid is much "//&
3103		"cleaner than the no slip BCs. The use of free slip BCs "//&
3104		"is strongly encouraged, and no slip BCs are not used with "//&
3105	1	"the biharmonic viscosity.", default=.false.)
3106		call get_param(param_file, mdl, "USE_KH_BG_2D", CS%use_Kh_bg_2d, &
3107		"If true, read a file containing 2-d background harmonic "//&
3108		"viscosities. The final viscosity is the maximum of the other "//&
3109	1	"terms and this background value.", default=.false., do_not_log=.not.CS%Laplacian)
3110	1	if (.not.CS%Laplacian) CS%use_Kh_bg_2d = .false.
3111		call get_param(param_file, mdl, "KH_BG_2D_BUG", CS%Kh_bg_2d_bug, &
3112		"If true, retain an answer-changing horizontal indexing bug in setting "//&
3113		"the corner-point viscosities when USE_KH_BG_2D=True. This is "//&
3114	1	"not recommended.", default=.false., do_not_log=.not.CS%use_Kh_bg_2d)
3115		call get_param(param_file, mdl, "ENABLE_BUGS_BY_DEFAULT", enable_bugs, &
3116	1	default=.true., do_not_log=.true.) ! This is logged from MOM.F90.
3117		call get_param(param_file, mdl, "FRICTWORK_BUG", CS%FrictWork_bug, &
3118		"If true, retain an answer-changing bug in calculating the FrictWork, "//&
3119		"which cancels the h in thickness flux and the h at velocity point. This is "//&
3120	1	"not recommended.", default=.false.)
3121		call get_param(param_file, mdl, "OBC_SPECIFIED_STRAIN_BUG", CS%OBC_strain_bug, &
3122		"If true, recover a bug that specified shear strain option at open boundaries "//&
3123	1	"cannot be applied.", default=.true.)
3124		call get_param(param_file, mdl, "USE_GME", CS%use_GME, &
3125		"If true, use the GM+E backscatter scheme in association \n"//&
3126	1	"with the Gent and McWilliams parameterization.", default=.false.)
3127		call get_param(param_file, mdl, "SPLIT", split, &
3128	1	"Use the split time stepping if true.", default=.true., do_not_log=.true.)
3129	1	if (CS%use_Leithy) then
3130	0	if (.not.(CS%biharmonic .and. CS%Laplacian)) then
3131		call MOM_error(FATAL, "MOM_hor_visc.F90, hor_visc_init: "//&
3132	0	"LAPLACIAN and BIHARMONIC must both be True when USE_LEITHY=True.")
3133		endif
3134		endif
3135		call get_param(param_file, mdl, "LEITHY_CK", CS%c_K, &
3136		"Fraction of biharmonic dissipation that gets backscattered, "//&
3137	1	"in Leith+E.", units="nondim", default=1.0, do_not_log=.not.CS%use_Leithy)
3138		call get_param(param_file, mdl, "SMOOTH_AH", CS%smooth_Ah, &
3139		"If true, Ah and m_leithy are smoothed within Leith+E. This requires "//&
3140		"lots of blocking communications, which can be expensive", &
3141	1	default=.true., do_not_log=.not.CS%use_Leithy)
3142
3143	1	if (CS%use_GME .and. .not.split) call MOM_error(FATAL,"ERROR: Currently, USE_GME = True "// &
3144	0	"cannot be used with SPLIT=False.")
3145
3146	1	if (CS%use_GME) then
3147		call get_param(param_file, mdl, "GME_NUM_SMOOTHINGS", CS%num_smooth_gme, &
3148		"Number of smoothing passes for the GME fluxes.", &
3149	0	default=1)
3150		call get_param(param_file, mdl, "GME_H0", CS%GME_h0, &
3151		"The strength of GME tapers quadratically to zero when the bathymetric "//&
3152		"depth is shallower than GME_H0.", &
3153	0	units="m", scale=GV%m_to_H, default=1000.0)
3154		call get_param(param_file, mdl, "GME_EFFICIENCY", CS%GME_efficiency, &
3155		"The nondimensional prefactor multiplying the GME coefficient.", &
3156	0	units="nondim", default=1.0)
3157		call get_param(param_file, mdl, "GME_LIMITER", CS%GME_limiter, &
3158		"The absolute maximum value the GME coefficient is allowed to take.", &
3159	0	units="m2 s-1", scale=US%m_to_L*2US%T_to_s, default=1.0e7)
3160		endif
3161
3162	1	if (CS%Laplacian .or. CS%biharmonic) then
3163		call get_param(param_file, mdl, "DT", dt, &
3164		"The (baroclinic) dynamics time step.", units="s", scale=US%s_to_T, &
3165	1	fail_if_missing=.true.)
3166	1	Idt = 1.0 / dt
3167		endif
3168		call get_param(param_file, mdl, "KILL_SWITCH_TIMESCALE", CS%KS_timescale, &
3169		"A timescale for computing the CFL limit for viscosity "// &
3170		"that determines when backscatter is shut off. Default is DT.", &
3171	1	default= dt , units="s", scale=US%s_to_T, do_not_log=.not.(CS%EY24_EBT_BS))
3172
3173	1	if (CS%no_slip .and. CS%biharmonic) &
3174		call MOM_error(FATAL,"ERROR: NOSLIP and BIHARMONIC cannot be defined "// &
3175	0	"at the same time in MOM.")
3176	1	if (.not.(CS%Laplacian .or. CS%biharmonic)) then
3177		! Only issue inviscid warning if not in single column mode (usually 2x2 domain)
3178	0	if ( max(G%domain%niglobal, G%domain%njglobal)>2 ) call MOM_error(WARNING, &
3179		"hor_visc_init: It is usually a very bad idea not to use either "//&
3180	0	"LAPLACIAN or BIHARMONIC viscosity.")
3181	0	return ! We are not using either Laplacian or Bi-harmonic lateral viscosity
3182		endif
3183
3184		!$omp target update to(CS)
3185
3186	1	deg2rad = atan(1.0) / 45.
3187	8773	ALLOC_(CS%dx2h(isd:ied,jsd:jed)) ; CS%dx2h(:,:) = 0.0
3188	8773	ALLOC_(CS%dy2h(isd:ied,jsd:jed)) ; CS%dy2h(:,:) = 0.0
3189	8971	ALLOC_(CS%dx2q(IsdB:IedB,JsdB:JedB)) ; CS%dx2q(:,:) = 0.0
3190	8971	ALLOC_(CS%dy2q(IsdB:IedB,JsdB:JedB)) ; CS%dy2q(:,:) = 0.0
3191	8773	ALLOC_(CS%dx_dyT(isd:ied,jsd:jed)) ; CS%dx_dyT(:,:) = 0.0
3192	8773	ALLOC_(CS%dy_dxT(isd:ied,jsd:jed)) ; CS%dy_dxT(:,:) = 0.0
3193	8971	ALLOC_(CS%dx_dyBu(IsdB:IedB,JsdB:JedB)) ; CS%dx_dyBu(:,:) = 0.0
3194	8971	ALLOC_(CS%dy_dxBu(IsdB:IedB,JsdB:JedB)) ; CS%dy_dxBu(:,:) = 0.0
3195		!$omp target enter data map(alloc: CS%dx2h, CS%dy2h, CS%dx2q, CS%dy2q)
3196		!$omp target enter data map(alloc: CS%dx_dyT, CS%dy_dxT, CS%dx_dyBu, CS%dy_dxBu)
3197
3198	1	if (CS%Laplacian) then
3199	8773	ALLOC_(CS%grid_sp_h2(isd:ied,jsd:jed)) ; CS%grid_sp_h2(:,:) = 0.0
3200	8773	ALLOC_(CS%Kh_bg_xx(isd:ied,jsd:jed)) ; CS%Kh_bg_xx(:,:) = 0.0
3201	8971	ALLOC_(CS%Kh_bg_xy(IsdB:IedB,JsdB:JedB)) ; CS%Kh_bg_xy(:,:) = 0.0
3202	1	if (CS%bound_Kh .or. CS%EY24_EBT_BS) then
3203	8773	allocate(CS%Kh_Max_xx(Isd:Ied,Jsd:Jed), source=0.0)
3204	8971	allocate(CS%Kh_Max_xy(IsdB:IedB,JsdB:JedB), source=0.0)
3205		endif
3206	1	if (CS%Smagorinsky_Kh .or. CS%EY24_EBT_BS) then
3207	0	allocate(CS%Laplac2_const_xx(isd:ied,jsd:jed), source=0.0)
3208	0	allocate(CS%Laplac2_const_xy(IsdB:IedB,JsdB:JedB), source=0.0)
3209		endif
3210	1	if (CS%Leith_Kh) then
3211	0	allocate(CS%Laplac3_const_xx(isd:ied,jsd:jed), source=0.0)
3212	0	allocate(CS%Laplac3_const_xy(IsdB:IedB,JsdB:JedB), source=0.0)
3213		endif
3214		endif
3215	8773	ALLOC_(CS%reduction_xx(isd:ied,jsd:jed)) ; CS%reduction_xx(:,:) = 0.0
3216	8971	ALLOC_(CS%reduction_xy(IsdB:IedB,JsdB:JedB)) ; CS%reduction_xy(:,:) = 0.0
3217
3218	1	CS%dynamic_aniso = .false.
3219	1	if (CS%anisotropic) then
3220	0	allocate(CS%n1n2_h(isd:ied,jsd:jed), source=0.0)
3221	0	allocate(CS%n1n1_m_n2n2_h(isd:ied,jsd:jed), source=0.0)
3222	0	allocate(CS%n1n2_q(IsdB:IedB,JsdB:JedB), source=0.0)
3223	0	allocate(CS%n1n1_m_n2n2_q(IsdB:IedB,JsdB:JedB), source=0.0)
3224	0	select case (aniso_mode)
3225		case (0)
3226	0	call align_aniso_tensor_to_grid(CS, aniso_grid_dir(1), aniso_grid_dir(2))
3227		case (1)
3228		! call align_aniso_tensor_to_grid(CS, aniso_grid_dir(1), aniso_grid_dir(2))
3229		case (2)
3230	0	CS%dynamic_aniso = .true.
3231		case default
3232		call MOM_error(FATAL, "MOM_hor_visc: "//&
3233	0	"Runtime parameter ANISOTROPIC_MODE is out of range.")
3234		end select
3235		endif
3236
3237		call get_param(param_file, mdl, "KH_BG_2D_FILENAME", filename, &
3238		'The filename containing a 2d map of "Kh".', &
3239	1	default='KH_background_2d.nc', do_not_log=.not.CS%use_Kh_bg_2d)
3240		call get_param(param_file, mdl, "KH_BG_2D_VARNAME", Kh_var, &
3241		'The name in the input file of the horizontal viscosity variable.', &
3242	1	default='Kh', do_not_log=.not.CS%use_Kh_bg_2d)
3243
3244	1	if (CS%use_Kh_bg_2d) then
3245	0	call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".")
3246	0	inputdir = slasher(inputdir)
3247	0	allocate(CS%Kh_bg_2d(isd:ied,jsd:jed), source=0.0)
3248		call MOM_read_data(trim(inputdir)//trim(filename), Kh_var, CS%Kh_bg_2d, &
3249	0	G%domain, timelevel=1, scale=US%m_to_L*2US%T_to_s)
3250	0	call pass_var(CS%Kh_bg_2d, G%domain)
3251		endif
3252	1	if (CS%biharmonic) then
3253	8841	ALLOC_(CS%Idx2dyCu(IsdB:IedB,jsd:jed)) ; CS%Idx2dyCu(:,:) = 0.0
3254	8902	ALLOC_(CS%Idx2dyCv(isd:ied,JsdB:JedB)) ; CS%Idx2dyCv(:,:) = 0.0
3255	8841	ALLOC_(CS%Idxdy2u(IsdB:IedB,jsd:jed)) ; CS%Idxdy2u(:,:) = 0.0
3256	8902	ALLOC_(CS%Idxdy2v(isd:ied,JsdB:JedB)) ; CS%Idxdy2v(:,:) = 0.0
3257	8773	ALLOC_(CS%Ah_bg_xx(isd:ied,jsd:jed)) ; CS%Ah_bg_xx(:,:) = 0.0
3258	8971	ALLOC_(CS%Ah_bg_xy(IsdB:IedB,JsdB:JedB)) ; CS%Ah_bg_xy(:,:) = 0.0
3259	8773	ALLOC_(CS%grid_sp_h3(isd:ied,jsd:jed)) ; CS%grid_sp_h3(:,:) = 0.0
3260	1	if (CS%bound_Ah) then
3261	8773	allocate(CS%Ah_Max_xx(isd:ied,jsd:jed), source=0.0)
3262	8971	allocate(CS%Ah_Max_xy(IsdB:IedB,JsdB:JedB), source=0.0)
3263		endif
3264	1	if (CS%EY24_EBT_BS) then
3265	0	allocate(CS%Ah_Max_xx_KS(isd:ied,jsd:jed), source=0.0)
3266	0	allocate(CS%Ah_Max_xy_KS(IsdB:IedB,JsdB:JedB), source=0.0)
3267		endif
3268	1	if (CS%Smagorinsky_Ah) then
3269	8773	allocate(CS%Biharm_const_xx(isd:ied,jsd:jed), source=0.0)
3270	8971	allocate(CS%Biharm_const_xy(IsdB:IedB,JsdB:JedB), source=0.0)
3271	1	if (CS%bound_Coriolis) then
3272	8773	allocate(CS%Biharm_const2_xx(isd:ied,jsd:jed), source=0.0)
3273	8971	allocate(CS%Biharm_const2_xy(IsdB:IedB,JsdB:JedB), source=0.0)
3274		endif
3275		endif
3276	1	if ((CS%Leith_Ah) .or. (CS%use_Leithy)) then
3277	0	allocate(CS%biharm6_const_xx(isd:ied,jsd:jed), source=0.0)
3278	0	allocate(CS%biharm6_const_xy(IsdB:IedB,JsdB:JedB), source=0.0)
3279		endif
3280	1	if (CS%use_Leithy) then
3281	0	allocate(CS%m_const_leithy(isd:ied,jsd:jed), source=0.0)
3282	0	allocate(CS%m_leithy_max(isd:ied,jsd:jed), source=0.0)
3283		endif
3284	1	if (CS%Re_Ah > 0.0) then
3285	0	allocate(CS%Re_Ah_const_xx(isd:ied,jsd:jed), source=0.0)
3286	0	allocate(CS%Re_Ah_const_xy(IsdB:IedB,JsdB:JedB), source=0.0)
3287		endif
3288		endif
3289
3290	124	do concurrent (J=js-2:Jeq+1, I=is-2:Ieq+1)
3291	7873	CS%dx2q(I,J) = G%dxBu(I,J)G%dxBu(I,J) ; CS%dy2q(I,J) = G%dyBu(I,J)G%dyBu(I,J)
3292		enddo
3293
3294	1	if (((CS%Leith_Kh) .or. (CS%Leith_Ah) .or. (CS%use_Leithy)) .and. &
3295		((G%isc-G%isd < 3) .or. (G%isc-G%isd < 3))) call MOM_error(FATAL, &
3296	0	"The minimum halo size is 3 when a Leith viscosity is being used.")
3297	1	if (CS%use_Leithy) then
3298	0	do concurrent (J=js-3:Jeq+2, I=is-3:Ieq+2)
3299	0	CS%DX_dyBu(I,J) = G%dxBu(I,J)G%IdyBu(I,J) ; CS%DY_dxBu(I,J) = G%dyBu(I,J)G%IdxBu(I,J)
3300		enddo
3301	1	elseif ((CS%Leith_Kh) .or. (CS%Leith_Ah)) then
3302	0	do concurrent (J=Jsq-2:Jeq+2, I=Isq-2:Ieq+2)
3303	0	CS%DX_dyBu(I,J) = G%dxBu(I,J)G%IdyBu(I,J) ; CS%DY_dxBu(I,J) = G%dyBu(I,J)G%IdxBu(I,J)
3304		enddo
3305		else
3306	124	do concurrent (J=js-2:Jeq+1, I=is-2:Ieq+1)
3307	7873	CS%DX_dyBu(I,J) = G%dxBu(I,J)G%IdyBu(I,J) ; CS%DY_dxBu(I,J) = G%dyBu(I,J)G%IdxBu(I,J)
3308		enddo
3309		endif
3310
3311	125	do concurrent (j=js-2:Jeq+2, i=is-2:Ieq+2)
3312	7936	CS%dx2h(i,j) = G%dxT(i,j)G%dxT(i,j) ; CS%dy2h(i,j) = G%dyT(i,j)G%dyT(i,j)
3313	8061	CS%DX_dyT(i,j) = G%dxT(i,j)G%IdyT(i,j) ; CS%DY_dxT(i,j) = G%dyT(i,j)G%IdxT(i,j)
3314		enddo
3315
3316		! TODO: Remove this after every instance has been moved to GPU
3317		!$omp target update from(CS%dx2q, CS%dy2q, CS%dx_dyBu, CS%dy_dxBu)
3318		!$omp target update from(CS%dx2h, CS%dy2h, CS%dx_dyT, CS%dy_dxT)
3319
3320	7627	do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1
3321	7564	CS%reduction_xx(i,j) = 1.0
3322	7564	if ((G%dy_Cu(I,j) > 0.0) .and. (G%dy_Cu(I,j) < G%dyCu(I,j)) .and. &
3323		(G%dy_Cu(I,j) < G%dyCu(I,j) * CS%reduction_xx(i,j))) &
3324	0	CS%reduction_xx(i,j) = G%dy_Cu(I,j) / (G%dyCu(I,j))
3325	7564	if ((G%dy_Cu(I-1,j) > 0.0) .and. (G%dy_Cu(I-1,j) < G%dyCu(I-1,j)) .and. &
3326		(G%dy_Cu(I-1,j) < G%dyCu(I-1,j) * CS%reduction_xx(i,j))) &
3327	0	CS%reduction_xx(i,j) = G%dy_Cu(I-1,j) / (G%dyCu(I-1,j))
3328	7564	if ((G%dx_Cv(i,J) > 0.0) .and. (G%dx_Cv(i,J) < G%dxCv(i,J)) .and. &
3329		(G%dx_Cv(i,J) < G%dxCv(i,J) * CS%reduction_xx(i,j))) &
3330	0	CS%reduction_xx(i,j) = G%dx_Cv(i,J) / (G%dxCv(i,J))
3331	7564	if ((G%dx_Cv(i,J-1) > 0.0) .and. (G%dx_Cv(i,J-1) < G%dxCv(i,J-1)) .and. &
3332		(G%dx_Cv(i,J-1) < G%dxCv(i,J-1) * CS%reduction_xx(i,j))) &
3333	62	CS%reduction_xx(i,j) = G%dx_Cv(i,J-1) / (G%dxCv(i,J-1))
3334		enddo ; enddo
3335
3336	7443	do J=js-1,Jeq ; do I=is-1,Ieq
3337	7381	CS%reduction_xy(I,J) = 1.0
3338	7381	if ((G%dy_Cu(I,j) > 0.0) .and. (G%dy_Cu(I,j) < G%dyCu(I,j)) .and. &
3339		(G%dy_Cu(I,j) < G%dyCu(I,j) * CS%reduction_xy(I,J))) &
3340	0	CS%reduction_xy(I,J) = G%dy_Cu(I,j) / (G%dyCu(I,j))
3341	7381	if ((G%dy_Cu(I,j+1) > 0.0) .and. (G%dy_Cu(I,j+1) < G%dyCu(I,j+1)) .and. &
3342		(G%dy_Cu(I,j+1) < G%dyCu(I,j+1) * CS%reduction_xy(I,J))) &
3343	0	CS%reduction_xy(I,J) = G%dy_Cu(I,j+1) / (G%dyCu(I,j+1))
3344	7381	if ((G%dx_Cv(i,J) > 0.0) .and. (G%dx_Cv(i,J) < G%dxCv(i,J)) .and. &
3345		(G%dx_Cv(i,J) < G%dxCv(i,J) * CS%reduction_xy(I,J))) &
3346	0	CS%reduction_xy(I,J) = G%dx_Cv(i,J) / (G%dxCv(i,J))
3347	7381	if ((G%dx_Cv(i+1,J) > 0.0) .and. (G%dx_Cv(i+1,J) < G%dxCv(i+1,J)) .and. &
3348		(G%dx_Cv(i+1,J) < G%dxCv(i+1,J) * CS%reduction_xy(I,J))) &
3349	61	CS%reduction_xy(I,J) = G%dx_Cv(i+1,J) / (G%dxCv(i+1,J))
3350		enddo ; enddo
3351	1	if (CS%Laplacian) then
3352		! The 0.3 below was 0.4 in MOM1.10. The change in hq requires
3353		! this to be less than 1/3, rather than 1/2 as before.
3354	1	if (CS%bound_Kh .or. CS%bound_Ah) Kh_Limit = 0.3 / (dt*4.0)
3355		! Calculate and store the background viscosity at h-points
3356
3357	1	min_grid_sp_h2 = huge(1.)
3358	7627	do j=js-1,Jeq+1 ; do i=is-1,Ieq+1
3359		! Static factors in the Smagorinsky and Leith schemes
3360	7564	grid_sp_h2 = (2.0CS%dx2h(i,j)CS%dy2h(i,j)) / (CS%dx2h(i,j) + CS%dy2h(i,j))
3361	7564	CS%grid_sp_h2(i,j) = grid_sp_h2
3362	7564	grid_sp_h3 = grid_sp_h2*sqrt(grid_sp_h2)
3363	7564	if (CS%Smagorinsky_Kh) CS%Laplac2_const_xx(i,j) = Smag_Lap_const * grid_sp_h2
3364	7564	if (CS%Leith_Kh) CS%Laplac3_const_xx(i,j) = Leith_Lap_const * grid_sp_h3
3365		! Maximum of constant background and MICOM viscosity
3366	7564	CS%Kh_bg_xx(i,j) = MAX(Kh, Kh_vel_scale * sqrt(grid_sp_h2))
3367		! Use the larger of the above and values read from a file
3368	7564	if (CS%use_Kh_bg_2d) CS%Kh_bg_xx(i,j) = MAX(CS%Kh_bg_2d(i,j), CS%Kh_bg_xx(i,j))
3369		! Use the larger of the above and a function of sin(latitude)
3370	7564	if (Kh_sin_lat>0.) then
3371	0	slat_fn = abs( sin( deg2rad * G%geoLatT(i,j) ) ) ** Kh_pwr_of_sine
3372	0	CS%Kh_bg_xx(i,j) = MAX(Kh_sin_lat * slat_fn, CS%Kh_bg_xx(i,j))
3373		endif
3374	7626	min_grid_sp_h2 = min(grid_sp_h2, min_grid_sp_h2)
3375		enddo ; enddo
3376	1	call min_across_PEs(min_grid_sp_h2)
3377
3378		! Calculate and store the background viscosity at q-points
3379	7443	do J=js-1,Jeq ; do I=is-1,Ieq
3380		! Static factors in the Smagorinsky and Leith schemes
3381	7381	grid_sp_q2 = (2.0CS%dx2q(I,J)CS%dy2q(I,J)) / (CS%dx2q(I,J) + CS%dy2q(I,J))
3382	7381	grid_sp_q3 = grid_sp_q2*sqrt(grid_sp_q2)
3383	7381	if (CS%Smagorinsky_Kh) CS%Laplac2_const_xy(I,J) = Smag_Lap_const * grid_sp_q2
3384	7381	if (CS%Leith_Kh) CS%Laplac3_const_xy(I,J) = Leith_Lap_const * grid_sp_q3
3385		! Maximum of constant background and MICOM viscosity
3386	7381	CS%Kh_bg_xy(I,J) = MAX(Kh, Kh_vel_scale * sqrt(grid_sp_q2))
3387		! Use the larger of the above and values read from a file
3388	7381	if (CS%use_Kh_bg_2d) then
3389	0	if (CS%Kh_bg_2d_bug) then
3390		! This option is unambiguously wrong but is needed to recover old answers
3391	0	CS%Kh_bg_xy(I,J) = MAX(CS%Kh_bg_2d(i,j), CS%Kh_bg_xy(I,J))
3392		else
3393		CS%Kh_bg_xy(I,J) = MAX(CS%Kh_bg_xy(I,J), &
3394		0.25*((CS%Kh_bg_2d(i,j) + CS%Kh_bg_2d(i+1,j+1)) + &
3395	0	(CS%Kh_bg_2d(i+1,j) + CS%Kh_bg_2d(i,j+1))) )
3396		endif
3397		endif
3398
3399		! Use the larger of the above and a function of sin(latitude)
3400	7442	if (Kh_sin_lat>0.) then
3401	0	slat_fn = abs( sin( deg2rad * G%geoLatBu(I,J) ) ) ** Kh_pwr_of_sine
3402	0	CS%Kh_bg_xy(I,J) = MAX(Kh_sin_lat * slat_fn, CS%Kh_bg_xy(I,J))
3403		endif
3404		enddo ; enddo
3405		endif
3406	1	if (CS%biharmonic) then
3407	7689	do j=js-1,Jeq+1 ; do I=is-2,Ieq+1
3408	7626	CS%Idx2dyCu(I,j) = (G%IdxCu(I,j)G%IdxCu(I,j)) G%IdyCu(I,j)
3409	7688	CS%Idxdy2u(I,j) = G%IdxCu(I,j) * (G%IdyCu(I,j)*G%IdyCu(I,j))
3410		enddo ; enddo
3411	7750	do J=js-2,Jeq+1 ; do i=is-1,Ieq+1
3412	7686	CS%Idx2dyCv(i,J) = (G%IdxCv(i,J)G%IdxCv(i,J)) G%IdyCv(i,J)
3413	7749	CS%Idxdy2v(i,J) = G%IdxCv(i,J) * (G%IdyCv(i,J)*G%IdyCv(i,J))
3414		enddo ; enddo
3415	8971	CS%Ah_bg_xy(:,:) = 0.0
3416		! The 0.3 below was 0.4 in HIM 1.10. The change in hq requires
3417		! this to be less than 1/3, rather than 1/2 as before.
3418	1	if (CS%bound_Ah) Ah_Limit = 0.3 / (dt*64.0)
3419	1	if (CS%Smagorinsky_Ah .and. CS%bound_Coriolis) &
3420	1	BoundCorConst = 1.0 / (5.0(bound_Cor_velbound_Cor_vel))
3421
3422	1	min_grid_sp_h4 = huge(1.)
3423	7627	do j=js-1,Jeq+1 ; do i=is-1,Ieq+1
3424	7564	grid_sp_h2 = (2.0CS%dx2h(i,j)CS%dy2h(i,j)) / (CS%dx2h(i,j)+CS%dy2h(i,j))
3425	7564	grid_sp_h3 = grid_sp_h2*sqrt(grid_sp_h2)
3426	7564	CS%grid_sp_h3(i,j) = grid_sp_h3
3427	7564	if (CS%Smagorinsky_Ah) then
3428	7564	CS%Biharm_const_xx(i,j) = Smag_bi_const * (grid_sp_h2 * grid_sp_h2)
3429	7564	if (CS%bound_Coriolis) then
3430		fmax = MAX(abs(G%CoriolisBu(I-1,J-1)), abs(G%CoriolisBu(I,J-1)), &
3431	7564	abs(G%CoriolisBu(I-1,J)), abs(G%CoriolisBu(I,J)))
3432		CS%Biharm_const2_xx(i,j) = (grid_sp_h2 * grid_sp_h2 * grid_sp_h2) * &
3433	7564	(fmax * BoundCorConst)
3434		endif
3435		endif
3436	7564	if (CS%Leith_Ah) then
3437	0	CS%biharm6_const_xx(i,j) = Leith_bi_const * (grid_sp_h3 * grid_sp_h3)
3438		endif
3439	7564	if (CS%use_Leithy) then
3440	0	CS%biharm6_const_xx(i,j) = Leith_bi_const * max(G%dxT(i,j),G%dyT(i,j))**6
3441	0	CS%m_const_leithy(i,j) = 0.5 * sqrt(CS%c_K) * max(G%dxT(i,j),G%dyT(i,j))
3442	0	CS%m_leithy_max(i,j) = 4. / max(G%dxT(i,j),G%dyT(i,j))**2
3443		endif
3444	7564	CS%Ah_bg_xx(i,j) = MAX(Ah, Ah_vel_scale * grid_sp_h2 * sqrt(grid_sp_h2))
3445	7564	if (CS%Re_Ah > 0.0) CS%Re_Ah_const_xx(i,j) = grid_sp_h3 / CS%Re_Ah
3446	7564	if (Ah_time_scale > 0.) CS%Ah_bg_xx(i,j) = &
3447	0	MAX(CS%Ah_bg_xx(i,j), (grid_sp_h2 * grid_sp_h2) / Ah_time_scale)
3448	7626	min_grid_sp_h4 = min(grid_sp_h2**2, min_grid_sp_h4)
3449		enddo ; enddo
3450	1	call min_across_PEs(min_grid_sp_h4)
3451
3452	7443	do J=js-1,Jeq ; do I=is-1,Ieq
3453	7381	grid_sp_q2 = (2.0CS%dx2q(I,J)CS%dy2q(I,J)) / (CS%dx2q(I,J)+CS%dy2q(I,J))
3454	7381	grid_sp_q3 = grid_sp_q2*sqrt(grid_sp_q2)
3455	7381	if (CS%Smagorinsky_Ah) then
3456	7381	CS%Biharm_const_xy(I,J) = Smag_bi_const * (grid_sp_q2 * grid_sp_q2)
3457	7381	if (CS%bound_Coriolis) then
3458		CS%Biharm_const2_xy(I,J) = (grid_sp_q2 * grid_sp_q2 * grid_sp_q2) * &
3459	7381	(abs(G%CoriolisBu(I,J)) * BoundCorConst)
3460		endif
3461		endif
3462	7381	if ((CS%Leith_Ah) .or. (CS%use_Leithy))then
3463	0	CS%biharm6_const_xy(I,J) = Leith_bi_const * (grid_sp_q3 * grid_sp_q3)
3464		endif
3465	7381	CS%Ah_bg_xy(I,J) = MAX(Ah, Ah_vel_scale * grid_sp_q2 * sqrt(grid_sp_q2))
3466	7381	if (CS%Re_Ah > 0.0) CS%Re_Ah_const_xy(i,j) = grid_sp_q3 / CS%Re_Ah
3467	7381	if (Ah_time_scale > 0.) CS%Ah_bg_xy(i,j) = &
3468	61	MAX(CS%Ah_bg_xy(i,j), (grid_sp_q2 * grid_sp_q2) / Ah_time_scale)
3469		enddo ; enddo
3470		endif
3471		! The Laplacian bounds should avoid overshoots when CS%bound_coef < 1.
3472	1	if (CS%Laplacian .and. CS%bound_Kh) then
3473	7627	do j=js-1,Jeq+1 ; do i=is-1,Ieq+1
3474		denom = max( &
3475		(CS%dy2h(i,j) * CS%DY_dxT(i,j) * (G%IdyCu(I,j) + G%IdyCu(I-1,j)) * &
3476		max(G%IdyCu(I,j)G%IareaCu(I,j), G%IdyCu(I-1,j)G%IareaCu(I-1,j)) ), &
3477		(CS%dx2h(i,j) * CS%DX_dyT(i,j) * (G%IdxCv(i,J) + G%IdxCv(i,J-1)) * &
3478	7564	max(G%IdxCv(i,J)G%IareaCv(i,J), G%IdxCv(i,J-1)G%IareaCv(i,J-1)) ) )
3479	7564	CS%Kh_Max_xx(i,j) = 0.0
3480	7564	if (denom > 0.0) &
3481	5112	CS%Kh_Max_xx(i,j) = CS%bound_coef * 0.25 * Idt / denom
3482		enddo ; enddo
3483	7443	do J=js-1,Jeq ; do I=is-1,Ieq
3484		denom = max( &
3485		(CS%dx2q(I,J) * CS%DX_dyBu(I,J) * (G%IdxCu(I,j+1) + G%IdxCu(I,j)) * &
3486		max(G%IdxCu(I,j)G%IareaCu(I,j), G%IdxCu(I,j+1)G%IareaCu(I,j+1)) ), &
3487		(CS%dy2q(I,J) * CS%DY_dxBu(I,J) * (G%IdyCv(i+1,J) + G%IdyCv(i,J)) * &
3488	7381	max(G%IdyCv(i,J)G%IareaCv(i,J), G%IdyCv(i+1,J)G%IareaCv(i+1,J)) ) )
3489	7381	CS%Kh_Max_xy(I,J) = 0.0
3490	7381	if (denom > 0.0) &
3491	5210	CS%Kh_Max_xy(I,J) = CS%bound_coef * 0.25 * Idt / denom
3492		enddo ; enddo
3493	1	if (CS%debug) then
3494	0	call hchksum(CS%Kh_Max_xx, "Kh_Max_xx", G%HI, haloshift=0, unscale=US%L_to_m*2US%s_to_T)
3495	0	call Bchksum(CS%Kh_Max_xy, "Kh_Max_xy", G%HI, haloshift=0, unscale=US%L_to_m*2US%s_to_T)
3496		endif
3497		endif
3498		! The biharmonic bounds should avoid overshoots when CS%bound_coef < 0.5, but
3499		! empirically work for CS%bound_coef <~ 1.0
3500	1	if (CS%biharmonic .and. CS%bound_Ah) then
3501	7689	do j=js-1,Jeq+1 ; do I=is-2,Ieq+1
3502		u0u(I,j) = ((CS%Idxdy2u(I,j)((CS%dy2h(i+1,j)CS%DY_dxT(i+1,j)*(G%IdyCu(I+1,j) + G%IdyCu(I,j))) + &
3503		(CS%dy2h(i,j) * CS%DY_dxT(i,j) * (G%IdyCu(I,j) + G%IdyCu(I-1,j))) )) + &
3504		(CS%Idx2dyCu(I,j)((CS%dx2q(I,J) CS%DX_dyBu(I,J) * (G%IdxCu(I,j+1) + G%IdxCu(I,j))) + &
3505	7626	(CS%dx2q(I,J-1)CS%DX_dyBu(I,J-1)(G%IdxCu(I,j) + G%IdxCu(I,j-1))) )) )
3506		u0v(I,j) = ((CS%Idxdy2u(I,j)((CS%dy2h(i+1,j)CS%DX_dyT(i+1,j)*(G%IdxCv(i+1,J) + G%IdxCv(i+1,J-1))) + &
3507		(CS%dy2h(i,j) * CS%DX_dyT(i,j) * (G%IdxCv(i,J) + G%IdxCv(i,J-1))) )) + &
3508		(CS%Idx2dyCu(I,j)((CS%dx2q(I,J) CS%DY_dxBu(I,J) * (G%IdyCv(i+1,J) + G%IdyCv(i,J))) + &
3509	7688	(CS%dx2q(I,J-1)CS%DY_dxBu(I,J-1)(G%IdyCv(i+1,J-1) + G%IdyCv(i,J-1))) )) )
3510		enddo ; enddo
3511	7750	do J=js-2,Jeq+1 ; do i=is-1,Ieq+1
3512		v0u(i,J) = ((CS%Idxdy2v(i,J)((CS%dy2q(I,J) CS%DX_dyBu(I,J) * (G%IdxCu(I,j+1) + G%IdxCu(I,j))) + &
3513		(CS%dy2q(I-1,J)CS%DX_dyBu(I-1,J)(G%IdxCu(I-1,j+1) + G%IdxCu(I-1,j))) )) + &
3514		(CS%Idx2dyCv(i,J)((CS%dx2h(i,j+1)CS%DY_dxT(i,j+1)*(G%IdyCu(I,j+1) + G%IdyCu(I-1,j+1))) + &
3515	7686	(CS%dx2h(i,j) * CS%DY_dxT(i,j) * (G%IdyCu(I,j) + G%IdyCu(I-1,j))) ) ))
3516		v0v(i,J) = ((CS%Idxdy2v(i,J)((CS%dy2q(I,J) CS%DY_dxBu(I,J) * (G%IdyCv(i+1,J) + G%IdyCv(i,J))) + &
3517		(CS%dy2q(I-1,J)CS%DY_dxBu(I-1,J)(G%IdyCv(i,J) + G%IdyCv(i-1,J))) )) + &
3518		(CS%Idx2dyCv(i,J)((CS%dx2h(i,j+1)CS%DX_dyT(i,j+1)*(G%IdxCv(i,J+1) + G%IdxCv(i,J))) + &
3519	7749	(CS%dx2h(i,j) * CS%DX_dyT(i,j) * (G%IdxCv(i,J) + G%IdxCv(i,J-1))) )) )
3520		enddo ; enddo
3521	7627	do j=js-1,Jeq+1 ; do i=is-1,Ieq+1
3522		denom = max( &
3523		(CS%dy2h(i,j) * &
3524		((CS%DY_dxT(i,j)((G%IdyCu(I,j)u0u(I,j)) + (G%IdyCu(I-1,j)*u0u(I-1,j)))) + &
3525		(CS%DX_dyT(i,j)((G%IdxCv(i,J)v0u(i,J)) + (G%IdxCv(i,J-1)v0u(i,J-1))))) &
3526		max(G%IdyCu(I,j)G%IareaCu(I,j), G%IdyCu(I-1,j)G%IareaCu(I-1,j)) ), &
3527		(CS%dx2h(i,j) * &
3528		((CS%DY_dxT(i,j)((G%IdyCu(I,j)u0v(I,j)) + (G%IdyCu(I-1,j)*u0v(I-1,j)))) + &
3529		(CS%DX_dyT(i,j)((G%IdxCv(i,J)v0v(i,J)) + (G%IdxCv(i,J-1)v0v(i,J-1))))) &
3530	7564	max(G%IdxCv(i,J)G%IareaCv(i,J), G%IdxCv(i,J-1)G%IareaCv(i,J-1)) ) )
3531	7564	CS%Ah_Max_xx(I,J) = 0.0
3532	7626	if (denom > 0.0) then
3533	5050	CS%Ah_Max_xx(I,J) = CS%bound_coef * 0.5 * Idt / denom
3534	5050	if (CS%EY24_EBT_BS) then
3535	0	CS%Ah_Max_xx_KS(i,j) = CS%bound_coef * 0.5 / (CS%KS_timescale * denom)
3536		endif
3537		endif
3538
3539		enddo ; enddo
3540	7443	do J=js-1,Jeq ; do I=is-1,Ieq
3541		denom = max( &
3542		(CS%dx2q(I,J) * &
3543		((CS%DX_dyBu(I,J)((u0u(I,j+1)G%IdxCu(I,j+1)) + (u0u(I,j)*G%IdxCu(I,j)))) + &
3544		(CS%DY_dxBu(I,J)((v0u(i+1,J)G%IdyCv(i+1,J)) + (v0u(i,J)G%IdyCv(i,J))))) &
3545		max(G%IdxCu(I,j)G%IareaCu(I,j), G%IdxCu(I,j+1)G%IareaCu(I,j+1)) ), &
3546		(CS%dy2q(I,J) * &
3547		((CS%DX_dyBu(I,J)((u0v(I,j+1)G%IdxCu(I,j+1)) + (u0v(I,j)*G%IdxCu(I,j)))) + &
3548		(CS%DY_dxBu(I,J)((v0v(i+1,J)G%IdyCv(i+1,J)) + (v0v(i,J)G%IdyCv(i,J))))) &
3549	7381	max(G%IdyCv(i,J)G%IareaCv(i,J), G%IdyCv(i+1,J)G%IareaCv(i+1,J)) ) )
3550	7381	CS%Ah_Max_xy(I,J) = 0.0
3551	7442	if (denom > 0.0) then
3552	5149	CS%Ah_Max_xy(I,J) = CS%bound_coef * 0.5 * Idt / denom
3553	5149	if (CS%EY24_EBT_BS) then
3554	0	CS%Ah_Max_xy_KS(i,j) = CS%bound_coef * 0.5 / (CS%KS_timescale * denom)
3555		endif
3556		endif
3557
3558		enddo ; enddo
3559	1	if (CS%debug) then
3560	0	call hchksum(CS%Ah_Max_xx, "Ah_Max_xx", G%HI, haloshift=0, unscale=US%L_to_m*4US%s_to_T)
3561	0	call Bchksum(CS%Ah_Max_xy, "Ah_Max_xy", G%HI, haloshift=0, unscale=US%L_to_m*4US%s_to_T)
3562		endif
3563		endif
3564		! Register fields for output from this module.
3565		CS%id_normstress = register_diag_field('ocean_model', 'NoSt', diag%axesTL, Time, &
3566	1	'Normal Stress', 's-1', conversion=US%s_to_T)
3567		CS%id_shearstress = register_diag_field('ocean_model', 'ShSt', diag%axesBL, Time, &
3568	1	'Shear Stress', 's-1', conversion=US%s_to_T)
3569		CS%id_diffu = register_diag_field('ocean_model', 'diffu', diag%axesCuL, Time, &
3570	1	'Zonal Acceleration from Horizontal Viscosity', 'm s-2', conversion=US%L_T2_to_m_s2)
3571		CS%id_diffv = register_diag_field('ocean_model', 'diffv', diag%axesCvL, Time, &
3572	1	'Meridional Acceleration from Horizontal Viscosity', 'm s-2', conversion=US%L_T2_to_m_s2)
3573
3574		!CS%id_hf_diffu = register_diag_field('ocean_model', 'hf_diffu', diag%axesCuL, Time, &
3575		! 'Fractional Thickness-weighted Zonal Acceleration from Horizontal Viscosity', &
3576		! 'm s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2)
3577		!if ((CS%id_hf_diffu > 0) .and. (present(ADp))) then
3578		! call safe_alloc_alloc(CS%hf_diffu,G%IsdB,G%IedB,G%jsd,G%jed,GV%ke)
3579		! call safe_alloc_ptr(ADp%diag_hfrac_u,G%IsdB,G%IedB,G%jsd,G%jed,GV%ke)
3580		!endif
3581
3582		!CS%id_hf_diffv = register_diag_field('ocean_model', 'hf_diffv', diag%axesCvL, Time, &
3583		! 'Fractional Thickness-weighted Meridional Acceleration from Horizontal Viscosity', &
3584		! 'm s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2)
3585		!if ((CS%id_hf_diffv > 0) .and. (present(ADp))) then
3586		! call safe_alloc_alloc(CS%hf_diffv,G%isd,G%ied,G%JsdB,G%JedB,GV%ke)
3587		! call safe_alloc_ptr(ADp%diag_hfrac_v,G%isd,G%ied,G%JsdB,G%JedB,GV%ke)
3588		!endif
3589
3590		CS%id_hf_diffu_2d = register_diag_field('ocean_model', 'hf_diffu_2d', diag%axesCu1, Time, &
3591		'Depth-sum Fractional Thickness-weighted Zonal Acceleration from Horizontal Viscosity', &
3592	1	'm s-2', conversion=US%L_T2_to_m_s2)
3593	1	if ((CS%id_hf_diffu_2d > 0) .and. (present(ADp))) then
3594	0	call safe_alloc_ptr(ADp%diag_hfrac_u,G%IsdB,G%IedB,G%jsd,G%jed,GV%ke)
3595		endif
3596
3597		CS%id_hf_diffv_2d = register_diag_field('ocean_model', 'hf_diffv_2d', diag%axesCv1, Time, &
3598		'Depth-sum Fractional Thickness-weighted Meridional Acceleration from Horizontal Viscosity', &
3599	1	'm s-2', conversion=US%L_T2_to_m_s2)
3600	1	if ((CS%id_hf_diffv_2d > 0) .and. (present(ADp))) then
3601	0	call safe_alloc_ptr(ADp%diag_hfrac_v,G%isd,G%ied,G%JsdB,G%JedB,GV%ke)
3602		endif
3603
3604		CS%id_h_diffu = register_diag_field('ocean_model', 'h_diffu', diag%axesCuL, Time, &
3605		'Thickness Multiplied Zonal Acceleration from Horizontal Viscosity', &
3606	1	'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2)
3607	1	if ((CS%id_h_diffu > 0) .and. (present(ADp))) then
3608	0	call safe_alloc_ptr(ADp%diag_hu,G%IsdB,G%IedB,G%jsd,G%jed,GV%ke)
3609		endif
3610
3611		CS%id_h_diffv = register_diag_field('ocean_model', 'h_diffv', diag%axesCvL, Time, &
3612		'Thickness Multiplied Meridional Acceleration from Horizontal Viscosity', &
3613	1	'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2)
3614	1	if ((CS%id_h_diffv > 0) .and. (present(ADp))) then
3615	0	call safe_alloc_ptr(ADp%diag_hv,G%isd,G%ied,G%JsdB,G%JedB,GV%ke)
3616		endif
3617
3618		CS%id_intz_diffu_2d = register_diag_field('ocean_model', 'intz_diffu_2d', diag%axesCu1, Time, &
3619		'Depth-integral of Zonal Acceleration from Horizontal Viscosity', &
3620	1	'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2)
3621	1	if ((CS%id_intz_diffu_2d > 0) .and. (present(ADp))) then
3622	0	call safe_alloc_ptr(ADp%diag_hu,G%IsdB,G%IedB,G%jsd,G%jed,GV%ke)
3623		endif
3624
3625		CS%id_intz_diffv_2d = register_diag_field('ocean_model', 'intz_diffv_2d', diag%axesCv1, Time, &
3626		'Depth-integral of Meridional Acceleration from Horizontal Viscosity', &
3627	1	'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2)
3628	1	if ((CS%id_intz_diffv_2d > 0) .and. (present(ADp))) then
3629	0	call safe_alloc_ptr(ADp%diag_hv,G%isd,G%ied,G%JsdB,G%JedB,GV%ke)
3630		endif
3631
3632		CS%id_diffu_visc_rem = register_diag_field('ocean_model', 'diffu_visc_rem', diag%axesCuL, Time, &
3633		'Zonal Acceleration from Horizontal Viscosity multiplied by viscous remnant', &
3634	1	'm s-2', conversion=US%L_T2_to_m_s2)
3635	1	if ((CS%id_diffu_visc_rem > 0) .and. (present(ADp))) then
3636	0	call safe_alloc_ptr(ADp%visc_rem_u,G%IsdB,G%IedB,G%jsd,G%jed,GV%ke)
3637		endif
3638
3639		CS%id_diffv_visc_rem = register_diag_field('ocean_model', 'diffv_visc_rem', diag%axesCvL, Time, &
3640		'Meridional Acceleration from Horizontal Viscosity multiplied by viscous remnant', &
3641	1	'm s-2', conversion=US%L_T2_to_m_s2)
3642	1	if ((CS%id_diffv_visc_rem > 0) .and. (present(ADp))) then
3643	0	call safe_alloc_ptr(ADp%visc_rem_v,G%isd,G%ied,G%JsdB,G%JedB,GV%ke)
3644		endif
3645
3646	1	if (CS%biharmonic) then
3647		CS%id_Ah_h = register_diag_field('ocean_model', 'Ahh', diag%axesTL, Time, &
3648		'Biharmonic Horizontal Viscosity at h Points', 'm4 s-1', conversion=US%L_to_m*4US%s_to_T, &
3649		cmor_field_name='difmxybo', &
3650		cmor_long_name='Ocean lateral biharmonic viscosity', &
3651	1	cmor_standard_name='ocean_momentum_xy_biharmonic_diffusivity')
3652		CS%id_Ah_q = register_diag_field('ocean_model', 'Ahq', diag%axesBL, Time, &
3653	1	'Biharmonic Horizontal Viscosity at q Points', 'm4 s-1', conversion=US%L_to_m*4US%s_to_T)
3654		CS%id_grid_Re_Ah = register_diag_field('ocean_model', 'grid_Re_Ah', diag%axesTL, Time, &
3655	1	'Grid Reynolds number for the Biharmonic horizontal viscosity at h points', 'nondim')
3656	1	if (CS%EY24_EBT_BS) then
3657		CS%id_visc_limit_h_flag = register_diag_field('ocean_model', 'visc_limit_h_flag', diag%axesTL, Time, &
3658	0	'Locations where the biharmonic viscosity reached the better_bound limiter at h points', 'nondim')
3659		CS%id_visc_limit_q_flag = register_diag_field('ocean_model', 'visc_limit_q_flag', diag%axesBL, Time, &
3660	0	'Locations where the biharmonic viscosity reached the better_bound limiter at q points', 'nondim')
3661		CS%id_visc_limit_h = register_diag_field('ocean_model', 'visc_limit_h', diag%axesTL, Time, &
3662	0	'Value of the biharmonic viscosity limiter at h points', 'nondim')
3663		CS%id_visc_limit_q = register_diag_field('ocean_model', 'visc_limit_q', diag%axesBL, Time, &
3664	0	'Value of the biharmonic viscosity limiter at q points', 'nondim')
3665		CS%id_visc_limit_h_frac = register_diag_field('ocean_model', 'visc_limit_h_frac', diag%axesTL, Time, &
3666	0	'Value of the biharmonic viscosity limiter at h points', 'nondim')
3667		CS%id_visc_limit_q_frac = register_diag_field('ocean_model', 'visc_limit_q_frac', diag%axesBL, Time, &
3668	0	'Value of the biharmonic viscosity limiter at q points', 'nondim')
3669		endif
3670
3671	1	if (CS%id_grid_Re_Ah > 0) &
3672		! Compute the smallest biharmonic viscosity capable of modifying the
3673		! velocity at floating point precision.
3674	0	CS%min_grid_Ah = spacing(1.) * min_grid_sp_h4 * Idt
3675		endif
3676	1	if (CS%Laplacian) then
3677		CS%id_Kh_h = register_diag_field('ocean_model', 'Khh', diag%axesTL, Time, &
3678		'Laplacian Horizontal Viscosity at h Points', 'm2 s-1', conversion=US%L_to_m*2US%s_to_T, &
3679		cmor_field_name='difmxylo', &
3680		cmor_long_name='Ocean lateral Laplacian viscosity', &
3681	1	cmor_standard_name='ocean_momentum_xy_laplacian_diffusivity')
3682		CS%id_Kh_q = register_diag_field('ocean_model', 'Khq', diag%axesBL, Time, &
3683	1	'Laplacian Horizontal Viscosity at q Points', 'm2 s-1', conversion=US%L_to_m*2US%s_to_T)
3684		CS%id_grid_Re_Kh = register_diag_field('ocean_model', 'grid_Re_Kh', diag%axesTL, Time, &
3685	1	'Grid Reynolds number for the Laplacian horizontal viscosity at h points', 'nondim')
3686		CS%id_vort_xy_q = register_diag_field('ocean_model', 'vort_xy_q', diag%axesBL, Time, &
3687	1	'Vertical vorticity at q Points', 's-1', conversion=US%s_to_T)
3688		CS%id_div_xx_h = register_diag_field('ocean_model', 'div_xx_h', diag%axesTL, Time, &
3689	1	'Horizontal divergence at h Points', 's-1', conversion=US%s_to_T)
3690		CS%id_sh_xy_q = register_diag_field('ocean_model', 'sh_xy_q', diag%axesBL, Time, &
3691	1	'Shearing strain at q Points', 's-1', conversion=US%s_to_T)
3692		CS%id_sh_xx_h = register_diag_field('ocean_model', 'sh_xx_h', diag%axesTL, Time, &
3693	1	'Horizontal tension at h Points', 's-1', conversion=US%s_to_T)
3694
3695	1	if (CS%id_grid_Re_Kh > 0) &
3696		! Compute a smallest Laplacian viscosity capable of modifying the
3697		! velocity at floating point precision.
3698	0	CS%min_grid_Kh = spacing(1.) * min_grid_sp_h2 * Idt
3699		endif
3700	1	if (CS%use_GME) then
3701		CS%id_dudx_bt = register_diag_field('ocean_model', 'dudx_bt', diag%axesT1, Time, &
3702		'Zonal component of the barotropic shearing strain at h points', 's-1', &
3703	0	conversion=US%s_to_T)
3704		CS%id_dudy_bt = register_diag_field('ocean_model', 'dudy_bt', diag%axesB1, Time, &
3705		'Zonal component of the barotropic shearing strain at q points', 's-1', &
3706	0	conversion=US%s_to_T)
3707		CS%id_dvdy_bt = register_diag_field('ocean_model', 'dvdy_bt', diag%axesT1, Time, &
3708		'Meridional component of the barotropic shearing strain at h points', 's-1', &
3709	0	conversion=US%s_to_T)
3710		CS%id_dvdx_bt = register_diag_field('ocean_model', 'dvdx_bt', diag%axesB1, Time, &
3711		'Meridional component of the barotropic shearing strain at q points', 's-1', &
3712	0	conversion=US%s_to_T)
3713		CS%id_GME_coeff_h = register_diag_field('ocean_model', 'GME_coeff_h', diag%axesTL, Time, &
3714	0	'GME coefficient at h Points', 'm2 s-1', conversion=US%L_to_m*2US%s_to_T)
3715		CS%id_GME_coeff_q = register_diag_field('ocean_model', 'GME_coeff_q', diag%axesBL, Time, &
3716	0	'GME coefficient at q Points', 'm2 s-1', conversion=US%L_to_m*2US%s_to_T)
3717		CS%id_FrictWork_GME = register_diag_field('ocean_model','FrictWork_GME',diag%axesTL,Time,&
3718		'Integral work done by lateral friction terms in GME (excluding diffusion of energy)', &
3719	0	'W m-2', conversion=US%RZ3_T3_to_W_m2US%L_to_Z*2)
3720		endif
3721
3722	1	if (CS%EY24_EBT_BS) then
3723		CS%id_BS_coeff_h = register_diag_field('ocean_model', 'BS_coeff_h', diag%axesTL, Time, &
3724	0	'Backscatter coefficient at h points', units='m2 s-1', conversion=US%L_to_m*2US%s_to_T)
3725		CS%id_BS_coeff_q = register_diag_field('ocean_model', 'BS_coeff_q', diag%axesBL, Time, &
3726	0	'Backscatter coefficient at q points', units='m2 s-1', conversion=US%L_to_m*2US%s_to_T)
3727		endif
3728
3729		CS%id_FrictWork = register_diag_field('ocean_model','FrictWork',diag%axesTL,Time,&
3730		'Integral work done by lateral friction terms. If GME is turned on, this '//&
3731		'includes the GME contribution.', &
3732	1	'W m-2', conversion=US%RZ3_T3_to_W_m2US%L_to_Z*2)
3733		CS%id_FrictWorkIntz = register_diag_field('ocean_model','FrictWorkIntz',diag%axesT1,Time, &
3734		'Depth integrated work done by lateral friction', &
3735		'W m-2', conversion=US%RZ3_T3_to_W_m2US%L_to_Z*2, &
3736		cmor_field_name='dispkexyfo', &
3737		cmor_long_name='Depth integrated ocean kinetic energy dissipation due to lateral friction',&
3738	1	cmor_standard_name='ocean_kinetic_energy_dissipation_per_unit_area_due_to_xy_friction')
3739		CS%id_FrictWork_bh = register_diag_field('ocean_model','FrictWork_bh',diag%axesTL,Time,&
3740		'Integral work done by the biharmonic lateral friction terms.', &
3741	1	'W m-2', conversion=US%RZ3_T3_to_W_m2US%L_to_Z*2)
3742		CS%id_FrictWorkIntz_bh = register_diag_field('ocean_model','FrictWorkIntz_bh',diag%axesT1,Time,&
3743		'Depth integrated work done by the biharmonic lateral friction', &
3744	1	'W m-2', conversion=US%RZ3_T3_to_W_m2US%L_to_Z*2)
3745
3746
3747		! TODO: Position these after their respective loops (and run loops on device)
3748		!$omp target enter data map(to: CS%Idxdy2u, CS%Idxdy2v) if (CS%biharmonic)
3749		!$omp target enter data map(to: CS%Idx2dyCu, CS%Idx2dyCv) if (CS%biharmonic)
3750
3751		!$omp target enter data map(to: CS%Kh_bg_xx, CS%Kh_bg_xy) if (CS%Laplacian)
3752		!$omp target enter data map(to: CS%Kh_max_xx) if (CS%Laplacian)
3753		!$omp target enter data map(to: CS%Kh_max_xy) &
3754		!$omp if (CS%Laplacian .and. CS%bound_Kh)
3755		!$omp target enter data map(to: CS%Laplac2_const_xx) if (CS%Laplacian)
3756		!$omp target enter data map(to: CS%Laplac3_const_xx) if (CS%Laplacian)
3757		!$omp target enter data map(to: CS%Laplac2_const_xy) if (CS%Smagorinsky_Kh)
3758
3759		!$omp target enter data map(to: CS%Ah_bg_xx, CS%Ah_bg_xy) if (CS%biharmonic)
3760		!$omp target enter data map(to: CS%reduction_xx, CS%reduction_xy)
3761		!$omp target enter data map(to: CS%Biharm_const_xx, CS%Biharm_const2_xx) &
3762		!$omp if (CS%Smagorinsky_Ah .or. CS%Leith_Ah .or. CS%use_Leithy)
3763		!$omp target enter data map(to: CS%Biharm_const_xy) &
3764		!$omp if (CS%Smagorinsky_Ah .or. CS%Leith_Ah)
3765		!$omp target enter data map(to: CS%Biharm_const2_xy) &
3766		!$omp if (CS%bound_Coriolis .and. (CS%Smagorinsky_Ah .or. CS%Leith_Ah))
3767		!$omp target enter data map(to: CS%Ah_max_xx) if (CS%bound_Ah)
3768		!$omp target enter data map(to: CS%Ah_max_xy) if (CS%bound_Ah)
3769
3770		end subroutine hor_visc_init
3771
3772		!> hor_visc_vel_stencil returns the horizontal viscosity input velocity stencil size
3773	24	function hor_visc_vel_stencil(CS) result(stencil)
3774		type(hor_visc_CS), intent(in) :: CS !< Control structure for horizontal viscosity
3775		integer :: stencil !< The horizontal viscosity velocity stencil size with the current settings.
3776
3777	24	stencil = 2
3778
3779	24	if ((CS%Leith_Kh) .or. (CS%Leith_Ah) .or. (CS%use_Leithy)) then
3780	0	stencil = 3
3781		endif
3782	24	end function hor_visc_vel_stencil
3783
3784		!> Calculates factors in the anisotropic orientation tensor to be align with the grid.
3785		!! With n1=1 and n2=0, this recovers the approach of Large et al, 2001.
3786	0	subroutine align_aniso_tensor_to_grid(CS, n1, n2)
3787		type(hor_visc_CS), intent(inout) :: CS !< Control structure for horizontal viscosity
3788		real, intent(in) :: n1 !< i-component of direction vector [nondim]
3789		real, intent(in) :: n2 !< j-component of direction vector [nondim]
3790		! Local variables
3791		real :: recip_n2_norm ! The inverse of the squared magnitude of n1 and n2 [nondim]
3792		! For normalizing n=(n1,n2) in case arguments are not a unit vector
3793	0	recip_n2_norm = (n12) + (n22)
3794	0	if (recip_n2_norm > 0.) recip_n2_norm = 1. / recip_n2_norm
3795	0	CS%n1n2_h(:,:) = 2. * ( n1 * n2 ) * recip_n2_norm
3796	0	CS%n1n2_q(:,:) = 2. * ( n1 * n2 ) * recip_n2_norm
3797	0	CS%n1n1_m_n2n2_h(:,:) = ( (n1 * n1) - (n2 * n2) ) * recip_n2_norm
3798	0	CS%n1n1_m_n2n2_q(:,:) = ( (n1 * n1) - (n2 * n2) ) * recip_n2_norm
3799	0	end subroutine align_aniso_tensor_to_grid
3800
3801		!> Apply a 1-1-4-1-1 Laplacian filter one time on GME diffusive flux to reduce any
3802		!! horizontal two-grid-point noise
3803	0	subroutine smooth_GME(CS, G, GME_flux_h, GME_flux_q)
3804		type(hor_visc_CS), intent(in) :: CS !< Control structure
3805		type(ocean_grid_type), intent(in) :: G !< Ocean grid
3806		real, dimension(SZI_(G),SZJ_(G)), optional, intent(inout) :: GME_flux_h!< GME diffusive flux
3807		!! at h points [L2 T-2 ~> m2 s-2]
3808		real, dimension(SZIB_(G),SZJB_(G)), optional, intent(inout) :: GME_flux_q!< GME diffusive flux
3809		!! at q points [L2 T-2 ~> m2 s-2]
3810		! local variables
3811	0	real, dimension(SZI_(G),SZJ_(G)) :: GME_flux_h_original ! The previous value of GME_flux_h [L2 T-2 ~> m2 s-2]
3812	0	real, dimension(SZIB_(G),SZJB_(G)) :: GME_flux_q_original ! The previous value of GME_flux_q [L2 T-2 ~> m2 s-2]
3813		real :: wc, ww, we, wn, ws ! averaging weights for smoothing [nondim]
3814		integer :: i, j, s, halosz
3815		integer :: xh, xq ! The number of valid extra halo points for h and q points.
3816		integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq
3817
3818	0	is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec
3819	0	Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB
3820	0	xh = 0 ; xq = 0
3821
3822	0	do s=1,CS%num_smooth_gme
3823	0	if (present(GME_flux_h)) then
3824	0	if (xh < 0) then
3825		! Update halos if needed, but avoid doing so more often than is needed.
3826	0	halosz = min(G%isc-G%isd, G%jsc-G%jsd, 2+CS%num_smooth_gme-s)
3827	0	call pass_var(GME_flux_h, G%Domain, halo=halosz)
3828	0	xh = halosz - 2
3829		endif
3830	0	GME_flux_h_original(:,:) = GME_flux_h(:,:)
3831		! apply smoothing on GME
3832	0	do j=Jsq-xh,Jeq+1+xh ; do i=Isq-xh,Ieq+1+xh
3833		! skip land points
3834	0	if (G%mask2dT(i,j)==0.) cycle
3835		! compute weights
3836	0	ww = 0.125 * G%mask2dT(i-1,j)
3837	0	we = 0.125 * G%mask2dT(i+1,j)
3838	0	ws = 0.125 * G%mask2dT(i,j-1)
3839	0	wn = 0.125 * G%mask2dT(i,j+1)
3840	0	wc = 1.0 - ((ww+we)+(wn+ws))
3841		GME_flux_h(i,j) = wc * GME_flux_h_original(i,j) &
3842		+ ((ww * GME_flux_h_original(i-1,j) + we * GME_flux_h_original(i+1,j)) &
3843	0	+ (ws * GME_flux_h_original(i,j-1) + wn * GME_flux_h_original(i,j+1)))
3844		enddo ; enddo
3845	0	xh = xh - 1
3846		endif
3847	0	if (present(GME_flux_q)) then
3848	0	if (xq < 0) then
3849		! Update halos if needed, but avoid doing so more often than is needed.
3850	0	halosz = min(G%isc-G%isd, G%jsc-G%jsd, 2+CS%num_smooth_gme-s)
3851	0	call pass_var(GME_flux_q, G%Domain, position=CORNER, complete=.true., halo=halosz)
3852	0	xq = halosz - 2
3853		endif
3854	0	GME_flux_q_original(:,:) = GME_flux_q(:,:)
3855		! apply smoothing on GME
3856	0	do J=js-1-xq,je+xq ; do I=is-1-xq,ie+xq
3857		! skip land points
3858	0	if (G%mask2dBu(I,J)==0.) cycle
3859		! compute weights
3860	0	ww = 0.125 * G%mask2dBu(I-1,J)
3861	0	we = 0.125 * G%mask2dBu(I+1,J)
3862	0	ws = 0.125 * G%mask2dBu(I,J-1)
3863	0	wn = 0.125 * G%mask2dBu(I,J+1)
3864	0	wc = 1.0 - ((ww+we)+(wn+ws))
3865		GME_flux_q(I,J) = wc * GME_flux_q_original(I,J) &
3866		+ ((ww * GME_flux_q_original(I-1,J) + we * GME_flux_q_original(I+1,J)) &
3867	0	+ (ws * GME_flux_q_original(I,J-1) + wn * GME_flux_q_original(I,J+1)))
3868		enddo ; enddo
3869	0	xq = xq - 1
3870		endif
3871		enddo ! s-loop
3872	0	end subroutine smooth_GME
3873
3874		!> Apply a 9-point smoothing filter twice to a field staggered at a thickness point to reduce
3875		!! horizontal two-grid-point noise.
3876		!! Note that this subroutine does not conserve mass, so don't use it in situations where you
3877		!! need conservation. Also note that it assumes that the input field has valid values in the
3878		!! first two halo points upon entry.
3879	0	subroutine smooth_x9_h(G, field_h, zero_land)
3880		type(ocean_grid_type), intent(in) :: G !< Ocean grid
3881		real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: field_h !< h-point field to be smoothed [arbitrary]
3882		logical, optional, intent(in) :: zero_land !< If present and false, return the average
3883		!! of the surrounding ocean points when
3884		!! smoothing, otherwise use a value of 0 for
3885		!! land points and include them in the averages.
3886
3887		! Local variables
3888	0	real :: fh_prev(SZI_(G),SZJ_(G)) ! The value of the h-point field at the previous iteration [arbitrary]
3889		real :: Iwts ! The inverse of the sum of the weights [nondim]
3890		logical :: zero_land_val ! The value of the zero_land optional argument or .true. if it is absent.
3891		integer :: i, j, s, is, ie, js, je
3892
3893	0	is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec
3894
3895	0	zero_land_val = .true. ; if (present(zero_land)) zero_land_val = zero_land
3896
3897	0	do s=1,0,-1
3898	0	fh_prev(:,:) = field_h(:,:)
3899		! apply smoothing on field_h using rotationally symmetric expressions.
3900	0	do j=js-s,je+s ; do i=is-s,ie+s ; if (G%mask2dT(i,j) > 0.0) then
3901	0	Iwts = 0.0625
3902	0	if (.not. zero_land_val) &
3903		Iwts = 1.0 / ( (4.0*G%mask2dT(i,j) + &
3904		( 2.0*((G%mask2dT(i-1,j) + G%mask2dT(i+1,j)) + &
3905		(G%mask2dT(i,j-1) + G%mask2dT(i,j+1))) + &
3906		((G%mask2dT(i-1,j-1) + G%mask2dT(i+1,j+1)) + &
3907	0	(G%mask2dT(i-1,j+1) + G%mask2dT(i+1,j-1))) ) ) + 1.0e-16 )
3908		field_h(i,j) = Iwts * ( 4.0G%mask2dT(i,j) fh_prev(i,j) &
3909		+ (2.0((G%mask2dT(i-1,j) fh_prev(i-1,j) + G%mask2dT(i+1,j) * fh_prev(i+1,j)) + &
3910		(G%mask2dT(i,j-1) * fh_prev(i,j-1) + G%mask2dT(i,j+1) * fh_prev(i,j+1))) &
3911		+ ((G%mask2dT(i-1,j-1) * fh_prev(i-1,j-1) + G%mask2dT(i+1,j+1) * fh_prev(i+1,j+1)) + &
3912	0	(G%mask2dT(i-1,j+1) * fh_prev(i-1,j+1) + G%mask2dT(i+1,j-1) * fh_prev(i-1,j-1))) ))
3913		endif ; enddo ; enddo
3914		enddo
3915
3916	0	end subroutine smooth_x9_h
3917
3918		!> Apply a 9-point smoothing filter twice to a pair of velocity components to reduce
3919		!! horizontal two-grid-point noise.
3920		!! Note that this subroutine does not conserve angular momentum, so don't use it
3921		!! in situations where you need conservation. Also note that it assumes that the
3922		!! input fields have valid values in the first two halo points upon entry.
3923	0	subroutine smooth_x9_uv(G, field_u, field_v, zero_land)
3924		type(ocean_grid_type), intent(in) :: G !< Ocean grid
3925		real, dimension(SZIB_(G),SZJ_(G)), intent(inout) :: field_u !< u-point field to be smoothed [arbitrary]
3926		real, dimension(SZI_(G),SZJB_(G)), intent(inout) :: field_v !< v-point field to be smoothed [arbitrary]
3927		logical, optional, intent(in) :: zero_land !< If present and false, return the average
3928		!! of the surrounding ocean points when
3929		!! smoothing, otherwise use a value of 0 for
3930		!! land points and include them in the averages.
3931
3932		! Local variables.
3933	0	real :: fu_prev(SZIB_(G),SZJ_(G)) ! The value of the u-point field at the previous iteration [arbitrary]
3934	0	real :: fv_prev(SZI_(G),SZJB_(G)) ! The value of the v-point field at the previous iteration [arbitrary]
3935		real :: Iwts ! The inverse of the sum of the weights [nondim]
3936		logical :: zero_land_val ! The value of the zero_land optional argument or .true. if it is absent.
3937		integer :: i, j, s, is, ie, js, je, Isq, Ieq, Jsq, Jeq
3938
3939	0	is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec
3940	0	Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB
3941
3942	0	zero_land_val = .true. ; if (present(zero_land)) zero_land_val = zero_land
3943
3944	0	do s=1,0,-1
3945	0	fu_prev(:,:) = field_u(:,:)
3946		! apply smoothing on field_u using the original non-rotationally symmetric expressions.
3947	0	do j=js-s,je+s ; do I=Isq-s,Ieq+s ; if (G%mask2dCu(I,j) > 0.0) then
3948	0	Iwts = 0.0625
3949	0	if (.not. zero_land_val) &
3950		Iwts = 1.0 / ( (4.0*G%mask2dCu(I,j) + &
3951		( 2.0*((G%mask2dCu(I-1,j) + G%mask2dCu(I+1,j)) + &
3952		(G%mask2dCu(I,j-1) + G%mask2dCu(I,j+1))) + &
3953		((G%mask2dCu(I-1,j-1) + G%mask2dCu(I+1,j+1)) + &
3954	0	(G%mask2dCu(I-1,j+1) + G%mask2dCu(I+1,j-1))) ) ) + 1.0e-16 )
3955		field_u(I,j) = Iwts * ( 4.0G%mask2dCu(I,j) fu_prev(I,j) &
3956		+ (2.0((G%mask2dCu(I-1,j) fu_prev(I-1,j) + G%mask2dCu(I+1,j) * fu_prev(I+1,j)) + &
3957		(G%mask2dCu(I,j-1) * fu_prev(I,j-1) + G%mask2dCu(I,j+1) * fu_prev(I,j+1))) &
3958		+ ((G%mask2dCu(I-1,j-1) * fu_prev(I-1,j-1) + G%mask2dCu(I+1,j+1) * fu_prev(I+1,j+1)) + &
3959	0	(G%mask2dCu(I-1,j+1) * fu_prev(I-1,j+1) + G%mask2dCu(I+1,j-1) * fu_prev(I-1,j-1))) ))
3960		endif ; enddo ; enddo
3961
3962	0	fv_prev(:,:) = field_v(:,:)
3963		! apply smoothing on field_v using the original non-rotationally symmetric expressions.
3964	0	do J=Jsq-s,Jeq+s ; do i=is-s,ie+s ; if (G%mask2dCv(i,J) > 0.0) then
3965	0	Iwts = 0.0625
3966	0	if (.not. zero_land_val) &
3967		Iwts = 1.0 / ( (4.0*G%mask2dCv(i,J) + &
3968		( 2.0*((G%mask2dCv(i-1,J) + G%mask2dCv(i+1,J)) + &
3969		(G%mask2dCv(i,J-1) + G%mask2dCv(i,J+1))) + &
3970		((G%mask2dCv(i-1,J-1) + G%mask2dCv(i+1,J+1)) + &
3971	0	(G%mask2dCv(i-1,J+1) + G%mask2dCv(i+1,J-1))) ) ) + 1.0e-16 )
3972		field_v(i,J) = Iwts * ( 4.0G%mask2dCv(i,J) fv_prev(i,J) &
3973		+ (2.0((G%mask2dCv(i-1,J) fv_prev(i-1,J) + G%mask2dCv(i+1,J) * fv_prev(i+1,J)) + &
3974		(G%mask2dCv(i,J-1) * fv_prev(i,J-1) + G%mask2dCv(i,J+1) * fv_prev(i,J+1))) &
3975		+ ((G%mask2dCv(i-1,J-1) * fv_prev(i-1,J-1) + G%mask2dCv(i+1,J+1) * fv_prev(i+1,J+1)) + &
3976	0	(G%mask2dCv(i-1,J+1) * fv_prev(i-1,J+1) + G%mask2dCv(i+1,J-1) * fv_prev(i-1,J-1))) ))
3977		endif ; enddo ; enddo
3978		enddo
3979
3980	0	end subroutine smooth_x9_uv
3981
3982		!> Deallocates any variables allocated in hor_visc_init.
3983	1	subroutine hor_visc_end(CS)
3984		type(hor_visc_CS), intent(inout) :: CS !< Horizontal viscosity control structure
3985
3986		!$omp target exit data map(delete: CS%DX_dyT, CS%DY_dxT)
3987		!$omp target exit data map(delete: CS%Dx_dyBu, CS%DY_dxBu)
3988
3989		!$omp target exit data map(delete: CS%Idxdy2u, CS%Idxdy2v) if (CS%biharmonic)
3990		!$omp target exit data map(delete: CS%Idx2dyCu, CS%Idx2dyCv) if (CS%biharmonic)
3991		!$omp target exit data map(delete: CS%dx2q, CS%dy2q)
3992		!$omp target exit data map(delete: CS%dx2h, CS%dy2h)
3993
3994		!$omp target exit data map(delete: CS%Kh_bg_xx, CS%Kh_bg_xy) if (CS%Laplacian)
3995		!$omp target exit data map(delete: CS%Kh_Max_xx) if (CS%Laplacian)
3996		!$omp target exit data map(delete: CS%Kh_max_xy) &
3997		!$omp if (CS%Laplacian .and. CS%bound_Kh)
3998		!$omp target exit data map(delete: CS%Laplac2_const_xx) if (CS%Laplacian)
3999		!$omp target exit data map(delete: CS%Laplac3_const_xx) if (CS%Laplacian)
4000		!$omp target exit data map(delete: CS%Laplac2_const_xy) if (CS%Smagorinsky_Kh)
4001
4002		!$omp target exit data map(delete: CS%Ah_bg_xx, CS%Ah_bg_xy) if (CS%biharmonic)
4003		!$omp target exit data map(delete: CS%reduction_xx, CS%reduction_xy)
4004		!$omp target exit data map(delete: CS%Biharm_const_xx, CS%Biharm_const2_xx) &
4005		!$omp if (CS%Smagorinsky_Ah .or. CS%Leith_Ah .or. CS%use_Leithy)
4006		!$omp target exit data map(delete: CS%Biharm_const_xy) &
4007		!$omp if (CS%Smagorinsky_Ah .or. CS%Leith_Ah)
4008		!$omp target exit data map(delete: CS%Biharm_const2_xy) &
4009		!$omp if (CS%bound_Coriolis .and. (CS%Smagorinsky_Ah .or. CS%Leith_Ah))
4010		!$omp target exit data map(delete: CS%Ah_max_xx) if (CS%bound_Ah)
4011		!$omp target exit data map(delete: CS%Ah_max_xy) if (CS%bound_Ah)
4012
4013	1	if (CS%Laplacian .or. CS%biharmonic) then
4014	1	DEALLOC_(CS%dx2h) ; DEALLOC_(CS%dx2q) ; DEALLOC_(CS%dy2h) ; DEALLOC_(CS%dy2q)
4015	1	DEALLOC_(CS%dx_dyT) ; DEALLOC_(CS%dy_dxT) ; DEALLOC_(CS%dx_dyBu) ; DEALLOC_(CS%dy_dxBu)
4016	1	DEALLOC_(CS%reduction_xx) ; DEALLOC_(CS%reduction_xy)
4017		endif
4018	1	if (CS%Laplacian) then
4019	1	DEALLOC_(CS%Kh_bg_xx) ; DEALLOC_(CS%Kh_bg_xy)
4020	1	DEALLOC_(CS%grid_sp_h2)
4021	1	if (allocated(CS%Kh_bg_2d)) deallocate(CS%Kh_bg_2d)
4022
4023	1	if (allocated(CS%Kh_Max_xx)) deallocate(CS%Kh_Max_xx)
4024	1	if (allocated(CS%Kh_Max_xy)) deallocate(CS%Kh_Max_xy)
4025	1	if (allocated(CS%Laplac2_const_xx)) deallocate(CS%Laplac2_const_xx)
4026	1	if (allocated(CS%Laplac2_const_xy)) deallocate(CS%Laplac2_const_xy)
4027	1	if (allocated(CS%Laplac3_const_xx)) deallocate(CS%Laplac3_const_xx)
4028	1	if (allocated(CS%Laplac3_const_xy)) deallocate(CS%Laplac3_const_xy)
4029		endif
4030	1	if (CS%biharmonic) then
4031	1	DEALLOC_(CS%grid_sp_h3)
4032	1	DEALLOC_(CS%Idx2dyCu) ; DEALLOC_(CS%Idx2dyCv)
4033	1	DEALLOC_(CS%Idxdy2u) ; DEALLOC_(CS%Idxdy2v)
4034	1	DEALLOC_(CS%Ah_bg_xx) ; DEALLOC_(CS%Ah_bg_xy)
4035
4036	1	if (allocated(CS%Ah_Max_xx)) deallocate(CS%Ah_Max_xx)
4037	1	if (allocated(CS%Ah_Max_xy)) deallocate(CS%Ah_Max_xy)
4038	1	if (allocated(CS%Ah_Max_xx_KS)) deallocate(CS%Ah_Max_xx_KS)
4039	1	if (allocated(CS%Ah_Max_xy_KS)) deallocate(CS%Ah_Max_xy_KS)
4040	1	if (allocated(CS%Biharm_const_xx)) deallocate(CS%Biharm_const_xx)
4041	1	if (allocated(CS%Biharm_const_xy)) deallocate(CS%Biharm_const_xy)
4042	1	if (allocated(CS%Biharm_const2_xx)) deallocate(CS%Biharm_const2_xx)
4043	1	if (allocated(CS%Biharm_const2_xy)) deallocate(CS%Biharm_const2_xy)
4044	1	if (allocated(CS%Biharm6_const_xx)) deallocate(CS%Biharm6_const_xx)
4045	1	if (allocated(CS%Biharm6_const_xy)) deallocate(CS%Biharm6_const_xy)
4046	1	if (allocated(CS%m_const_leithy)) deallocate(CS%m_const_leithy)
4047	1	if (allocated(CS%m_leithy_max)) deallocate(CS%m_leithy_max)
4048	1	if (allocated(CS%Re_Ah_const_xx)) deallocate(CS%Re_Ah_const_xx)
4049	1	if (allocated(CS%Re_Ah_const_xy)) deallocate(CS%Re_Ah_const_xy)
4050		endif
4051
4052	1	if (allocated(CS%n1n2_h)) deallocate(CS%n1n2_h)
4053	1	if (allocated(CS%n1n2_q)) deallocate(CS%n1n2_q)
4054	1	if (allocated(CS%n1n1_m_n2n2_h)) deallocate(CS%n1n1_m_n2n2_h)
4055	1	if (allocated(CS%n1n1_m_n2n2_q)) deallocate(CS%n1n1_m_n2n2_q)
4056
4057	1	if (CS%use_ZB2020) then
4058	0	call ZB2020_end(CS%ZB2020)
4059		endif
4060
4061	1	end subroutine hor_visc_end
4062		!> \namespace mom_hor_visc
4063		!!
4064		!! \section section_horizontal_viscosity Horizontal viscosity in MOM
4065		!!
4066		!! This module contains the subroutine horizontal_viscosity that calculates the
4067		!! effects of horizontal viscosity, including parameterizations of the value of
4068		!! the viscosity itself. Subroutine horizontal_viscosity calculates the acceleration due to
4069		!! some combination of a biharmonic viscosity and a Laplacian viscosity. Either or
4070		!! both may use a coefficient that depends on the shear and strain of the flow.
4071		!! All metric terms are retained. The Laplacian is calculated as the divergence of
4072		!! a stress tensor, using the form suggested by \cite Smagorinsky1993. The biharmonic
4073		!! is calculated by twice applying the divergence of the stress tensor that is
4074		!! used to calculate the Laplacian, but without the dependence on thickness in the
4075		!! first pass. This form permits a variable viscosity, and indicates no
4076		!! acceleration for either resting fluid or solid body rotation.
4077		!!
4078		!! The form of the viscous accelerations is discussed extensively in \cite griffies2000,
4079		!! and the implementation here follows that discussion closely.
4080		!! We use the notation of \cite Smith2003 with the exception that the
4081		!! isotropic viscosity is \f$\kappa_h\f$.
4082		!!
4083		!! In general, the horizontal stress tensor can be written as
4084		!! \f[
4085		!! {\bf \sigma} =
4086		!! \begin{pmatrix}
4087		!! \frac{1}{2} \left( \sigma_D + \sigma_T \right) & \frac{1}{2} \sigma_S \\\\
4088		!! \frac{1}{2} \sigma_S & \frac{1}{2} \left( \sigma_D - \sigma_T \right)
4089		!! \end{pmatrix}
4090		!! \f]
4091		!! where \f$\sigma_D\f$, \f$\sigma_T\f$ and \f$\sigma_S\f$ are stresses associated with
4092		!! invariant factors in the strain-rate tensor. For a Newtonian fluid, the stress
4093		!! tensor is usually linearly related to the strain-rate tensor. The horizontal
4094		!! strain-rate tensor is
4095		!! \f[
4096		!! \dot{\bf e} =
4097		!! \begin{pmatrix}
4098		!! \frac{1}{2} \left( \dot{e}_D + \dot{e}_T \right) & \frac{1}{2} \dot{e}_S \\\\
4099		!! \frac{1}{2} \dot{e}_S & \frac{1}{2} \left( \dot{e}_D - \dot{e}_T \right)
4100		!! \end{pmatrix}
4101		!! \f]
4102		!! where \f$\dot{e}_D = \partial_x u + \partial_y v\f$ is the horizontal divergence,
4103		!! \f$\dot{e}_T = \partial_x u - \partial_y v\f$ is the horizontal tension, and
4104		!! \f$\dot{e}_S = \partial_y u + \partial_x v\f$ is the horizontal shear strain.
4105		!!
4106		!! The trace of the stress tensor, \f$tr(\bf \sigma) = \sigma_D\f$, is usually
4107		!! absorbed into the pressure and only the deviatoric stress tensor considered.
4108		!! From here on, we drop \f$\sigma_D\f$. The trace of the strain tensor, \f$tr(\bf e) =
4109		!! \dot{e}_D\f$ is non-zero for horizontally divergent flow but only enters the
4110		!! stress tensor through \f$\sigma_D\f$ and so we will drop \f$\sigma_D\f$ from
4111		!! calculations of the strain tensor in the code. Therefore the horizontal stress
4112		!! tensor can be considered to be
4113		!! \f[
4114		!! {\bf \sigma} =
4115		!! \begin{pmatrix}
4116		!! \frac{1}{2} \sigma_T & \frac{1}{2} \sigma_S \\\\
4117		!! \frac{1}{2} \sigma_S & - \frac{1}{2} \sigma_T
4118		!! \end{pmatrix}
4119		!! .\f]
4120		!!
4121		!! The stresses above are linearly related to the strain through a viscosity
4122		!! coefficient, \f$\kappa_h\f$:
4123		!! \f{eqnarray*}{
4124		!! \sigma_T & = & 2 \kappa_h \dot{e}_T \\\\
4125		!! \sigma_S & = & 2 \kappa_h \dot{e}_S
4126		!! .
4127		!! \f}
4128		!!
4129		!! The viscosity \f$\kappa_h\f$ may either be a constant or variable. For example,
4130		!! \f$\kappa_h\f$ may vary with the shear, as proposed by \cite Smagorinsky1993.
4131		!!
4132		!! The accelerations resulting form the divergence of the stress tensor are
4133		!! \f{eqnarray*}{
4134		!! \hat{\bf x} \cdot \left( \nabla \cdot {\bf \sigma} \right)
4135		!! & = &
4136		!! \partial_x \left( \frac{1}{2} \sigma_T \right)
4137		!! + \partial_y \left( \frac{1}{2} \sigma_S \right)
4138		!! \\\\
4139		!! & = &
4140		!! \partial_x \left( \kappa_h \dot{e}_T \right)
4141		!! + \partial_y \left( \kappa_h \dot{e}_S \right)
4142		!! \\\\
4143		!! \hat{\bf y} \cdot \left( \nabla \cdot {\bf \sigma} \right)
4144		!! & = &
4145		!! \partial_x \left( \frac{1}{2} \sigma_S \right)
4146		!! + \partial_y \left( - \frac{1}{2} \sigma_T \right)
4147		!! \\\\
4148		!! & = &
4149		!! \partial_x \left( \kappa_h \dot{e}_S \right)
4150		!! + \partial_y \left( - \kappa_h \dot{e}_T \right)
4151		!! .
4152		!! \f}
4153		!!
4154		!! The form of the Laplacian viscosity in general coordinates is:
4155		!! \f{eqnarray*}{
4156		!! \hat{\bf x} \cdot \left( \nabla \cdot \sigma \right)
4157		!! & = &
4158		!! \frac{1}{h} \left[ \partial_x \left( \kappa_h h \dot{e}_T \right)
4159		!! + \partial_y \left( \kappa_h h \dot{e}_S \right) \right]
4160		!! \\\\
4161		!! \hat{\bf y} \cdot \left( \nabla \cdot \sigma \right)
4162		!! & = &
4163		!! \frac{1}{h} \left[ \partial_x \left( \kappa_h h \dot{e}_S \right)
4164		!! - \partial_y \left( \kappa_h h \dot{e}_T \right) \right]
4165		!! .
4166		!! \f}
4167		!!
4168		!! \subsection section_laplacian_viscosity_coefficient Laplacian viscosity coefficient
4169		!!
4170		!! The horizontal viscosity coefficient, \f$\kappa_h\f$, can have multiple components.
4171		!! The isotropic components are:
4172		!! - A uniform background component, \f$\kappa_{bg}\f$.
4173		!! - A constant but spatially variable 2D map, \f$\kappa_{2d}(x,y)\f$.
4174		!! - A ''MICOM'' viscosity, \f$U_\nu \Delta(x,y)\f$, which uses a constant
4175		!! velocity scale, \f$U_\nu\f$ and a measure of the grid-spacing \f$\Delta(x,y)^2 =
4176		!! \frac{2 \Delta x^2 \Delta y^2}{\Delta x^2 + \Delta y^2}\f$.
4177		!! - A function of
4178		!! latitude, \f$\kappa_{\phi}(x,y) = \kappa_{\pi/2} \|\sin(\phi)\|^n\f$.
4179		!! - A dynamic Smagorinsky viscosity, \f$\kappa_{Sm}(x,y,t) = C_{Sm} \Delta^2 \sqrt{\dot{e}_T^2 + \dot{e}_S^2}\f$.
4180		!! - A dynamic Leith viscosity, \f$\kappa_{Lth}(x,y,t) =
4181		!! C_{Lth} \Delta^3 \sqrt{\|\nabla \zeta\|^2 + \|\nabla \dot{e}_D\|^2}\f$.
4182		!!
4183		!! A maximum stable viscosity, \f$\kappa_{max}(x,y)\f$ is calculated based on the
4184		!! grid-spacing and time-step and used to clip calculated viscosities.
4185		!!
4186		!! The static components of \f$\kappa_h\f$ are first combined as follows:
4187		!! \f[
4188		!! \kappa_{static} = \min \left[ \max\left(
4189		!! \kappa_{bg},
4190		!! U_\nu \Delta(x,y),
4191		!! \kappa_{2d}(x,y),
4192		!! \kappa_\phi(x,y)
4193		!! \right)
4194		!! , \kappa_{max}(x,y) \right]
4195		!! \f]
4196		!! and stored in the module control structure as variables <code>Kh_bg_xx</code> and
4197		!! <code>Kh_bg_xy</code> for the tension (h-points) and shear (q-points) components
4198		!! respectively.
4199		!!
4200		!! The full viscosity includes the dynamic components as follows:
4201		!! \f[
4202		!! \kappa_h(x,y,t) = r(\Delta,L_d)
4203		!! \max \left( \kappa_{static}, \kappa_{Sm}, \kappa_{Lth} \right)
4204		!! \f]
4205		!! where \f$r(\Delta,L_d)\f$ is a resolution function.
4206		!!
4207		!! The dynamic Smagorinsky and Leith viscosity schemes are exclusive with each
4208		!! other.
4209		!!
4210		!! \subsection section_viscous_boundary_conditions Viscous boundary conditions
4211		!!
4212		!! Free slip boundary conditions have been coded, although no slip boundary
4213		!! conditions can be used with the Laplacian viscosity based on the 2D land-sea
4214		!! mask. For a western boundary, for example, the boundary conditions with the
4215		!! biharmonic operator would be written as:
4216		!! \f[
4217		!! \partial_x v = 0 ; \partial_x^3 v = 0 ; u = 0 ; \partial_x^2 u = 0 ,
4218		!! \f]
4219		!! while for a Laplacian operator, they are simply
4220		!! \f[
4221		!! \partial_x v = 0 ; u = 0 .
4222		!! \f]
4223		!! These boundary conditions are largely dictated by the use of an Arakawa
4224		!! C-grid and by the varying layer thickness.
4225		!!
4226		!! \subsection section_anisotropic_viscosity Anisotropic viscosity
4227		!!
4228		!! \cite Large2001 proposed enhancing viscosity in a particular direction and the
4229		!! approach was generalized in \cite Smith2003. We use the second form of their
4230		!! two coefficient anisotropic viscosity (section 4.3). We also replace their
4231		!! \f$A^\prime\f$ and $D$ such that \f$2A^\prime = 2 \kappa_h + D\f$ and
4232		!! \f$\kappa_a = D\f$ so that \f$\kappa_h\f$ can be considered the isotropic
4233		!! viscosity and \f$\kappa_a=D\f$ can be consider the anisotropic viscosity. The
4234		!! direction of anisotropy is defined by a unit vector \f$\hat{\bf
4235		!! n}=(n_1,n_2)\f$.
4236		!!
4237		!! The contributions to the stress tensor are
4238		!! \f[
4239		!! \begin{pmatrix}
4240		!! \sigma_T \\\\ \sigma_S
4241		!! \end{pmatrix}
4242		!! =
4243		!! \left[
4244		!! \begin{pmatrix}
4245		!! 2 \kappa_h + \kappa_a & 0 \\\\
4246		!! 0 & 2 \kappa_h
4247		!! \end{pmatrix}
4248		!! + 2 \kappa_a n_1 n_2
4249		!! \begin{pmatrix}
4250		!! - 2 n_1 n_2 & n_1^2 - n_2^2 \\\\
4251		!! n_1^2 - n_2^2 & 2 n_1 n_2
4252		!! \end{pmatrix}
4253		!! \right]
4254		!! \begin{pmatrix}
4255		!! \dot{e}_T \\\\ \dot{e}_S
4256		!! \end{pmatrix}
4257		!! \f]
4258		!! Dissipation of kinetic energy requires \f$\kappa_h \geq 0\f$ and \f$2 \kappa_h + \kappa_a \geq 0\f$.
4259		!! Note that when anisotropy is aligned with the x-direction, \f$n_1 = \pm 1\f$, then
4260		!! \f$n_2 = 0\f$ and the cross terms vanish. The accelerations in this aligned limit
4261		!! with constant coefficients become
4262		!! \f{eqnarray*}{
4263		!! \hat{\bf x} \cdot \nabla \cdot {\bf \sigma}
4264		!! & = &
4265		!! \partial_x \left( \left( \kappa_h + \frac{1}{2} \kappa_a \right) \dot{e}_T \right)
4266		!! + \partial_y \left( \kappa_h \dot{e}_S \right)
4267		!! \\\\
4268		!! & = &
4269		!! \left( \kappa_h + \kappa_a \right) \partial_{xx} u
4270		!! + \kappa_h \partial_{yy} u
4271		!! - \frac{1}{2} \kappa_a \partial_x \left( \partial_x u + \partial_y v \right)
4272		!! \\\\
4273		!! \hat{\bf y} \cdot \nabla \cdot {\bf \sigma}
4274		!! & = &
4275		!! \partial_x \left( \kappa_h \dot{e}_S \right)
4276		!! - \partial_y \left( \left( \kappa_h + \frac{1}{2} \kappa_a \right) \dot{e}_T \right)
4277		!! \\\\
4278		!! & = &
4279		!! \kappa_h \partial_{xx} v
4280		!! + \left( \kappa_h + \kappa_a \right) \partial_{yy} v
4281		!! - \frac{1}{2} \kappa_a \partial_y \left( \partial_x u + \partial_y v \right)
4282		!! \f}
4283		!! which has contributions akin to a negative divergence damping (a divergence
4284		!! enhancement?) but which is weaker than the enhanced tension terms by half.
4285		!!
4286		!! \subsection section_viscous_discretization Discretization
4287		!!
4288		!! The horizontal tension, \f$\dot{e}_T\f$, is stored in variable <code>sh_xx</code> and
4289		!! discretized as
4290		!! \f[
4291		!! \dot{e}_T
4292		!! = \frac{\Delta y}{\Delta x} \delta_i \left( \frac{1}{\Delta y} u \right)
4293		!! - \frac{\Delta x}{\Delta y} \delta_j \left( \frac{1}{\Delta x} v \right)
4294		!! .
4295		!! \f]
4296		!! The horizontal divergent strain, \f$\dot{e}_D\f$, is stored in variable
4297		!! <code>div_xx</code> and discretized as
4298		!! \f[
4299		!! \dot{e}_D
4300		!! = \frac{1}{h A} \left( \delta_i \left( \overline{h}^i \Delta y \, u \right)
4301		!! + \delta_j \left( \overline{h}^j\Delta x \, v \right) \right)
4302		!! .
4303		!! \f]
4304		!! Note that for expediency this is the exact discretization used in the
4305		!! continuity equation.
4306		!!
4307		!! The horizontal shear strain, \f$\dot{e}_S\f$, is stored in variable <code>sh_xy</code>
4308		!! and discretized as
4309		!! \f[
4310		!! \dot{e}_S = v_x + u_y
4311		!! \f]
4312		!! where
4313		!! \f{align*}{
4314		!! v_x &= \frac{\Delta y}{\Delta x} \delta_i \left( \frac{1}{\Delta y} v \right) \\\\
4315		!! u_y &= \frac{\Delta x}{\Delta y} \delta_j \left( \frac{1}{\Delta x} u \right)
4316		!! \f}
4317		!! which are calculated separately so that no-slip or free-slip boundary
4318		!! conditions can be applied to \f$v_x\f$ and \f$u_y\f$ where appropriate.
4319		!!
4320		!! The tendency for the x-component of the divergence of stress is stored in
4321		!! variable <code>diffu</code> and discretized as
4322		!! \f[
4323		!! \hat{\bf x} \cdot \left( \nabla \cdot {\bf \sigma} \right) =
4324		!! \frac{1}{A \overline{h}^i} \left(
4325		!! \frac{1}{\Delta y} \delta_i \left( h \Delta y^2 \kappa_h \dot{e}_T \right) +
4326		!! \frac{1}{\Delta x} \delta_j \left( \tilde{h}^{ij} \Delta x^2 \kappa_h \dot{e}_S \right)
4327		!! \right)
4328		!! .
4329		!! \f]
4330		!!
4331		!! The tendency for the y-component of the divergence of stress is stored in
4332		!! variable <code>diffv</code> and discretized as
4333		!! \f[
4334		!! \hat{\bf y} \cdot \left( \nabla \cdot {\bf \sigma} \right) =
4335		!! \frac{1}{A \overline{h}^j} \left(
4336		!! \frac{1}{\Delta y} \delta_i \left( \tilde{h}^{ij} \Delta y^2 A_M \dot{e}_S \right)
4337		!! - \frac{1}{\Delta x} \delta_j \left( h \Delta x^2 A_M \dot{e}_T \right)
4338		!! \right)
4339		!! .
4340		!! \f]
4341		!!
4342		!! \subsection section_viscous_refs References
4343		!!
4344		!! Griffies, S.M., and Hallberg, R.W., 2000: Biharmonic friction with a
4345		!! Smagorinsky-like viscosity for use in large-scale eddy-permitting ocean models.
4346		!! Monthly Weather Review, 128(8), 2935-2946.
4347		!! https://doi.org/10.1175/1520-0493(2000)128%3C2935:BFWASL%3E2.0.CO;2
4348		!!
4349		!! Large, W.G., Danabasoglu, G., McWilliams, J.C., Gent, P.R. and Bryan, F.O.,
4350		!! 2001: Equatorial circulation of a global ocean climate model with
4351		!! anisotropic horizontal viscosity.
4352		!! Journal of Physical Oceanography, 31(2), pp.518-536.
4353		!! https://doi.org/10.1175/1520-0485(2001)031%3C0518:ECOAGO%3E2.0.CO;2
4354		!!
4355		!! Smagorinsky, J., 1993: Some historical remarks on the use of nonlinear
4356		!! viscosities. Large eddy simulation of complex engineering and geophysical
4357		!! flows, 1, 69-106.
4358		!!
4359		!! Smith, R.D., and McWilliams, J.C., 2003: Anisotropic horizontal viscosity for
4360		!! ocean models. Ocean Modelling, 5(2), 129-156.
4361		!! https://doi.org/10.1016/S1463-5003(02)00016-1
4362	0	end module MOM_hor_visc