MOM_barotropic.F90

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!> Barotropic solver
7
8use mom_checksums, only : chksum0
9use mom_coms, only : any_across_pes
10use mom_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, clock_routine
11use mom_debugging, only : hchksum, uvchksum, bchksum
14use mom_domains, only : min_across_pes, clone_mom_domain, deallocate_mom_domain
15use mom_domains, only : to_all, scalar_pair, agrid, corner, mom_domain_type
16use mom_domains, only : create_group_pass, do_group_pass, group_pass_type
17use mom_domains, only : start_group_pass, complete_group_pass, pass_var, pass_vector
18use mom_error_handler, only : mom_error, mom_mesg, fatal, warning, is_root_pe
19use mom_file_parser, only : get_param, log_param, log_version, param_file_type
21use mom_grid, only : ocean_grid_type
24use mom_io, only : vardesc, var_desc, mom_read_data, slasher, north_face, east_face
26use mom_open_boundary, only : obc_direction_e, obc_direction_w
27use mom_open_boundary, only : obc_direction_n, obc_direction_s, obc_segment_type
28use mom_restart, only : register_restart_field, register_restart_pair
29use mom_restart, only : query_initialized, mom_restart_cs
31use mom_self_attr_load, only : sal_cs
33use mom_time_manager, only : time_type, real_to_time, get_date, operator(+), operator(-)
39
40implicit none ; private
41
42#include <MOM_memory.h>
43#ifdef STATIC_MEMORY_
44# ifndef BTHALO_
45# define BTHALO_ 0
46# endif
47# define WHALOI_ MAX(BTHALO_-NIHALO_,0)
48# define WHALOJ_ MAX(BTHALO_-NJHALO_,0)
49# define NIMEMW_ 1-WHALOI_:NIMEM_+WHALOI_
50# define NJMEMW_ 1-WHALOJ_:NJMEM_+WHALOJ_
51# define NIMEMBW_ -WHALOI_:NIMEM_+WHALOI_
52# define NJMEMBW_ -WHALOJ_:NJMEM_+WHALOJ_
53# define SZIW_(G) NIMEMW_
54# define SZJW_(G) NJMEMW_
55# define SZIBW_(G) NIMEMBW_
56# define SZJBW_(G) NJMEMBW_
57#else
58# define NIMEMW_ :
59# define NJMEMW_ :
60# define NIMEMBW_ :
61# define NJMEMBW_ :
62# define SZIW_(G) G%isdw:G%iedw
63# define SZJW_(G) G%jsdw:G%jedw
64# define SZIBW_(G) G%isdw-1:G%iedw
65# define SZJBW_(G) G%jsdw-1:G%jedw
66#endif
67
70
71! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional
72! consistency testing. These are noted in comments with units like Z, H, L, and T, along with
73! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units
74! vary with the Boussinesq approximation, the Boussinesq variant is given first.
75
76!> The barotropic stepping open boundary condition type
77type, private :: bt_obc_type
78 real, allocatable :: cg_u(:,:) !< The external wave speed at u-points [L T-1 ~> m s-1].
79 real, allocatable :: cg_v(:,:) !< The external wave speed at u-points [L T-1 ~> m s-1].
80 real, allocatable :: dz_u(:,:) !< The total vertical column extent at the u-points [Z ~> m].
81 real, allocatable :: dz_v(:,:) !< The total vertical column extent at the v-points [Z ~> m].
82 real, allocatable :: uhbt(:,:) !< The zonal barotropic thickness fluxes specified
83 !! for open boundary conditions (if any) [H L2 T-1 ~> m3 s-1 or kg s-1].
84 real, allocatable :: vhbt(:,:) !< The meridional barotropic thickness fluxes specified
85 !! for open boundary conditions (if any) [H L2 T-1 ~> m3 s-1 or kg s-1].
86 real, allocatable :: ubt_outer(:,:) !< The zonal velocities just outside the domain,
87 !! as set by the open boundary conditions [L T-1 ~> m s-1].
88 real, allocatable :: vbt_outer(:,:) !< The meridional velocities just outside the domain,
89 !! as set by the open boundary conditions [L T-1 ~> m s-1].
90 real, allocatable :: ssh_outer_u(:,:) !< The surface height outside of the domain
91 !! at a u-point with an open boundary condition [Z ~> m].
92 real, allocatable :: ssh_outer_v(:,:) !< The surface height outside of the domain
93 !! at a v-point with an open boundary condition [Z ~> m].
94 integer, allocatable :: u_obc_type(:,:) !< An integer encoding the type and direction of u-point OBCs
95 integer, allocatable :: v_obc_type(:,:) !< An integer encoding the type and direction of v-point OBCs
96 logical :: u_obcs_on_pe !< True if this PE has an open boundary at any u-points.
97 logical :: v_obcs_on_pe !< True if this PE has an open boundary at any v-points.
98 !>@{ Index ranges on the local PE for the open boundary conditions in various directions
99 integer :: is_u_w_obc, ie_u_w_obc, js_u_w_obc, je_u_w_obc
100 integer :: is_u_e_obc, ie_u_e_obc, js_u_e_obc, je_u_e_obc
101 integer :: is_v_s_obc, ie_v_s_obc, js_v_s_obc, je_v_s_obc
102 integer :: is_v_n_obc, ie_v_n_obc, js_v_n_obc, je_v_n_obc
103 !>@}
104
105 type(group_pass_type) :: pass_uv !< Structure for group halo pass of vectors
106 type(group_pass_type) :: scalar_pass !< Structure for group halo pass of scalars
107end type bt_obc_type
108
109integer, parameter :: specified_obc = 1 !< An integer used to encode a specified OBC point
110integer, parameter :: flather_obc = 2 !< An integer used to encode a Flather OBC point
111integer, parameter :: gradient_obc = 4 !< An integer used to encode a gradient OBC point
112
113!> The barotropic stepping control structure
114type, public :: barotropic_cs ; private
115 real allocable_, dimension(NIMEMB_PTR_,NJMEM_,NKMEM_) :: frhatu
116 !< The fraction of the total column thickness interpolated to u grid points in each layer [nondim].
117 real allocable_, dimension(NIMEM_,NJMEMB_PTR_,NKMEM_) :: frhatv
118 !< The fraction of the total column thickness interpolated to v grid points in each layer [nondim].
119 real allocable_, dimension(NIMEMB_PTR_,NJMEM_) :: idatu
120 !< Inverse of the total thickness at u grid points [H-1 ~> m-1 or m2 kg-1].
121 real, allocatable, dimension(:,:) :: lin_drag_u
122 !< A spatially varying linear drag coefficient acting on the zonal barotropic flow
123 !! [H T-1 ~> m s-1 or kg m-2 s-1].
124 real, allocatable, dimension(:,:) :: ubt_ic
125 !< The barotropic solvers estimate of the zonal velocity that will be the initial
126 !! condition for the next call to btstep [L T-1 ~> m s-1].
127 real allocable_, dimension(NIMEMB_PTR_,NJMEM_) :: ubtav
128 !< The barotropic zonal velocity averaged over the baroclinic time step [L T-1 ~> m s-1].
129 real allocable_, dimension(NIMEM_,NJMEMB_PTR_) :: idatv
130 !< Inverse of the basin depth at v grid points [Z-1 ~> m-1].
131 real, allocatable, dimension(:,:) :: lin_drag_v
132 !< A spatially varying linear drag coefficient acting on the zonal barotropic flow
133 !! [H T-1 ~> m s-1 or kg m-2 s-1].
134 real, allocatable, dimension(:,:) :: vbt_ic
135 !< The barotropic solvers estimate of the zonal velocity that will be the initial
136 !! condition for the next call to btstep [L T-1 ~> m s-1].
137 real allocable_, dimension(NIMEM_,NJMEMB_PTR_) :: vbtav
138 !< The barotropic meridional velocity averaged over the baroclinic time step [L T-1 ~> m s-1].
139 real allocable_, dimension(NIMEM_,NJMEM_) :: eta_cor
140 !< The difference between the free surface height from the barotropic calculation and the sum
141 !! of the layer thicknesses. This difference is imposed as a forcing term in the barotropic
142 !! calculation over a baroclinic timestep [H ~> m or kg m-2].
143 real, allocatable, dimension(:,:) :: eta_cor_bound
144 !< A limit on the rate at which eta_cor can be applied while avoiding instability
145 !! [H T-1 ~> m s-1 or kg m-2 s-1]. This is only used if CS%bound_BT_corr is true.
146 real allocable_, dimension(NIMEMW_,NJMEMW_) :: &
147 ua_polarity, & !< Test vector components for checking grid polarity [nondim]
148 va_polarity, & !< Test vector components for checking grid polarity [nondim]
149 bathyt !< A copy of bathyT (ocean bottom depth) with wide halos [Z ~> m]
150 real allocable_, dimension(NIMEMW_,NJMEMW_) :: iareat
151 !< This is a copy of G%IareaT with wide halos, but will
152 !! still utilize the macro IareaT when referenced, [L-2 ~> m-2].
153 real allocable_, dimension(NIMEMBW_,NJMEMW_) :: &
154 dy_cu, & !< A copy of G%dy_Cu with wide halos [L ~> m].
155 idxcu, & !< A copy of G%IdxCu with wide halos [L-1 ~> m-1].
156 obcmask_u !< An array to multiplicatively mask out changes at OBC points, 0 or 1 [nondim]
157 real allocable_, dimension(NIMEMW_,NJMEMBW_) :: &
158 dx_cv, & !< A copy of G%dx_Cv with wide halos [L ~> m].
159 idycv, & !< A copy of G%IdyCv with wide halos [L-1 ~> m-1].
160 obcmask_v !< An array to multiplicatively mask out changes at OBC points, 0 or 1 [nondim]
161 real, allocatable, dimension(:,:) :: &
162 d_u_cor, & !< A simply averaged depth at u points recast as a thickness [H ~> m or kg m-2]
163 d_v_cor, & !< A simply averaged depth at v points recast as a thickness [H ~> m or kg m-2]
164 q_d !< f / D at PV points [T-1 H-1 ~> s-1 m-1 or m2 s-1 kg-1]
165 real, allocatable, dimension(:,:,:) :: &
166 q_wt !< The area weights for the thicknesses around a corner point to be used when
167 !! calculating PV for use in the Coriolis term, taking OBCs into account [L2 ~> m2].
168 !! The order of the 4 values at a point is the order in which the neighboring
169 !! tracer points occur in memory, i.e. SW, SE, NW then NE.
170 real, allocatable :: frhatu1(:,:,:) !< Predictor step values of frhatu stored for diagnostics [nondim]
171 real, allocatable :: frhatv1(:,:,:) !< Predictor step values of frhatv stored for diagnostics [nondim]
172 real, allocatable :: iareat_obcmask(:,:) !< If non-zero, work on given points [L-2 ~> m-2].
173
174 type(bt_obc_type) :: bt_obc !< A structure with all of this modules fields
175 !! for applying open boundary conditions.
176
177 real :: dtbt !< The barotropic time step [T ~> s].
178 real :: dtbt_fraction !< The fraction of the maximum time-step that
179 !! should used [nondim]. The default is 0.98.
180 real :: dtbt_max !< The maximum stable barotropic time step [T ~> s].
181 real :: dt_bt_filter !< The time-scale over which the barotropic mode solutions are
182 !! filtered [T ~> s] if positive, or as a fraction of DT if
183 !! negative [nondim]. This can never be taken to be longer than 2*dt.
184 !! Set this to 0 to apply no filtering.
185 integer :: nstep_last = 0 !< The number of barotropic timesteps per baroclinic
186 !! time step the last time btstep was called.
187 real :: bebt !< A nondimensional number, from 0 to 1, that
188 !! determines the gravity wave time stepping scheme [nondim].
189 !! 0.0 gives a forward-backward scheme, while 1.0
190 !! give backward Euler. In practice, bebt should be
191 !! of order 0.2 or greater.
192 real :: rho_bt_lin !< A density that is used to convert total water column thicknesses
193 !! into mass in non-Boussinesq mode with linearized options in the
194 !! barotropic solver or when estimating the stable barotropic timestep
195 !! without access to the full baroclinic model state [R ~> kg m-3]
196 logical :: split !< If true, use the split time stepping scheme.
197 logical :: bound_bt_corr !< If true, the magnitude of the fake mass source
198 !! in the barotropic equation that drives the two
199 !! estimates of the free surface height toward each
200 !! other is bounded to avoid driving corrective
201 !! velocities that exceed MAXCFL_BT_CONT.
202 logical :: gradual_bt_ics !< If true, adjust the initial conditions for the
203 !! barotropic solver to the values from the layered
204 !! solution over a whole timestep instead of
205 !! instantly. This is a decent approximation to the
206 !! inclusion of sum(u dh_dt) while also correcting
207 !! for truncation errors.
208 logical :: sadourny !< If true, the Coriolis terms are discretized
209 !! with Sadourny's energy conserving scheme,
210 !! otherwise the Arakawa & Hsu scheme is used. If
211 !! the deformation radius is not resolved Sadourny's
212 !! scheme should probably be used.
213 logical :: integral_bt_cont !< If true, use the time-integrated velocity over the barotropic steps
214 !! to determine the integrated transports used to update the continuity
215 !! equation. Otherwise the transports are the sum of the transports
216 !! based on a series of instantaneous velocities and the BT_CONT_TYPE
217 !! for transports. This is only valid if a BT_CONT_TYPE is used.
218 logical :: bt_adjust_src_for_filter !< If true, increases the rate at which BT mass sources are
219 !! applied so that they are all used up before the steps within the
220 !! filtering period start. This avoids the mass sink driving the SSH
221 !! below the bottom during the period of filtering.
222 logical :: bt_limit_integral_transport !< If true, limit the time-integrated transports by the
223 !! initial volume accounting for sinks of mass.
224 logical :: integral_obcs !< This is true if integral_bt_cont is true and there are open boundary
225 !! conditions being applied somewhere in the global domain.
226 logical :: nonlinear_continuity !< If true, the barotropic continuity equation
227 !! uses the full ocean thickness for transport.
228 integer :: nonlin_cont_update_period !< The number of barotropic time steps
229 !! between updates to the face area, or 0 only to
230 !! update at the start of a call to btstep. The
231 !! default is 1.
232 logical :: bt_project_velocity !< If true, step the barotropic velocity first
233 !! and project out the velocity tendency by 1+BEBT
234 !! when calculating the transport. The default
235 !! (false) is to use a predictor continuity step to
236 !! find the pressure field, and then do a corrector
237 !! continuity step using a weighted average of the
238 !! old and new velocities, with weights of (1-BEBT) and BEBT.
239 logical :: nonlin_stress !< If true, use the full depth of the ocean at the start of the
240 !! barotropic step when calculating the surface stress contribution to
241 !! the barotropic accelerations. Otherwise use the depth based on bathyT.
242 real :: bt_coriolis_scale !< A factor by which the barotropic Coriolis acceleration anomaly
243 !! terms are scaled [nondim].
244 integer :: answer_date !< The vintage of the expressions in the barotropic solver.
245 !! Values below 20190101 recover the answers from the end of 2018,
246 !! while higher values use more efficient or general expressions.
247
248 logical :: dynamic_psurf !< If true, add a dynamic pressure due to a viscous
249 !! ice shelf, for instance.
250 real :: dmin_dyn_psurf !< The minimum total thickness to use in limiting the size
251 !! of the dynamic surface pressure for stability [H ~> m or kg m-2].
252 real :: ice_strength_length !< The length scale at which the damping rate
253 !! due to the ice strength should be the same as if
254 !! a Laplacian were applied [L ~> m].
255 real :: const_dyn_psurf !< The constant that scales the dynamic surface
256 !! pressure [nondim]. Stable values are < ~1.0.
257 !! The default is 0.9.
258 logical :: calculate_sal !< If true, calculate self-attraction and loading.
259 logical :: tidal_sal_bug !< If true, the tidal self-attraction and loading anomaly in the
260 !! barotropic solver has the wrong sign, replicating a long-standing
261 !! bug.
262 real :: g_extra !< A nondimensional factor by which gtot is enhanced [nondim].
263 integer :: hvel_scheme !< An integer indicating how the thicknesses at
264 !! velocity points are calculated. Valid values are
265 !! given by the parameters defined below:
266 !! HARMONIC, ARITHMETIC, HYBRID, and FROM_BT_CONT
267 logical :: strong_drag !< If true, use a stronger estimate of the retarding
268 !! effects of strong bottom drag.
269 logical :: rescale_strong_drag !< If true, reduce the barotropic contribution to the layer
270 !! accelerations to account for the difference between the forces that
271 !! can be counteracted by the stronger drag with BT_STRONG_DRAG and the
272 !! average of the layer viscous remnants after a baroclinic timestep.
273 logical :: linear_wave_drag !< If true, apply a linear drag to the barotropic
274 !! velocities, using rates set by lin_drag_u & _v
275 !! divided by the depth of the ocean.
276 logical :: linearized_bt_pv !< If true, the PV and interface thicknesses used
277 !! in the barotropic Coriolis calculation is time
278 !! invariant and linearized.
279 logical :: use_filter !< If true, use streaming band-pass filter to detect the
280 !! instantaneous tidal signals in the simulation.
281 logical :: linear_freq_drag !< If true, apply a linear frequency-dependent drag to the tidal
282 !! velocities. The streaming band-pass filter must be turned on.
283 logical :: use_wide_halos !< If true, use wide halos and march in during the
284 !! barotropic time stepping for efficiency.
285 integer :: min_stencil !< The minimum stencil width to use with the wide halo iterations.
286 !! A nonzero value may reflect the distribution of OBC faces or it
287 !! may be useful for debugging purposes.
288 logical :: clip_velocity !< If true, limit any velocity components that are
289 !! are large enough for a CFL number to exceed
290 !! CFL_trunc. This should only be used as a
291 !! desperate debugging measure.
292 logical :: debug !< If true, write verbose checksums for debugging purposes.
293 logical :: debug_bt !< If true, write verbose checksums from within the barotropic
294 !! time-stepping loop for debugging purposes.
295 logical :: debug_wide_halos !< If true, write the checksums on the full wide halos. Otherwise
296 !! only the output for the final computational domain is written.
297 real :: vel_underflow !< Velocity components smaller than vel_underflow
298 !! are set to 0 [L T-1 ~> m s-1].
299 real :: maxvel !< Velocity components greater than maxvel are
300 !! truncated to maxvel [L T-1 ~> m s-1].
301 real :: cfl_trunc !< If clip_velocity is true, velocity components will
302 !! be truncated when they are large enough that the
303 !! corresponding CFL number exceeds this value [nondim].
304 real :: maxcfl_bt_cont !< The maximum permitted CFL number associated with the
305 !! barotropic accelerations from the summed velocities
306 !! times the time-derivatives of thicknesses [nondim]. The
307 !! default is 0.1, and there will probably be real
308 !! problems if this were set close to 1.
309 logical :: bt_cont_bounds !< If true, use the BT_cont_type variables to set limits
310 !! on the magnitude of the corrective mass fluxes.
311 logical :: visc_rem_u_uh0 !< If true, use the viscous remnants when estimating
312 !! the barotropic velocities that were used to
313 !! calculate uh0 and vh0. False is probably the
314 !! better choice.
315 logical :: adjust_bt_cont !< If true, adjust the curve fit to the BT_cont type
316 !! that is used by the barotropic solver to match the
317 !! transport about which the flow is being linearized.
318 logical :: use_old_coriolis_bracket_bug !< If True, use an order of operations
319 !! that is not bitwise rotationally symmetric in the
320 !! meridional Coriolis term of the barotropic solver.
321 logical :: tidal_sal_flather !< Apply adjustment to external gravity wave speed
322 !! consistent with tidal self-attraction and loading
323 !! used within the barotropic solver
324 logical :: wt_uv_bug = .true. !< If true, recover a bug that wt_[uv] that is not normalized.
325 logical :: exterior_obc_bug = .true. !< If true, recover a bug with boundary conditions
326 !! inside the domain.
327 logical :: interior_obc_pv !< If true, use only interior ocean points at OBCs to specify the PV
328 !! used in the barotropic Coriolis anomalies. Otherwise the
329 !! calculation relies on bathymetry and eta being projected outward
330 !! across OBCs. Unfortunately, this option does change answers near
331 !! convex (peninsula-type) pairs of OBC segments.
332 type(time_type), pointer :: time => null() !< A pointer to the ocean models clock.
333 type(diag_ctrl), pointer :: diag => null() !< A structure that is used to regulate
334 !! the timing of diagnostic output.
335 type(mom_domain_type), pointer :: bt_domain => null() !< Barotropic MOM domain
336 type(hor_index_type), pointer :: debug_bt_hi => null() !< debugging copy of horizontal index_type
337 type(sal_cs), pointer :: sal_csp => null() !< Control structure for SAL
338 type(harmonic_analysis_cs), pointer :: ha_csp => null() !< Control structure for harmonic analysis
339 type(filter_cs) :: filt_cs_u, & !< Control structures for the streaming band-pass filter of ubt
340 filt_cs_v !< Control structures for the streaming band-pass filter of vbt
341 type(wave_drag_cs) :: drag_cs !< Control structures for the frequency-dependent drag
342 logical :: module_is_initialized = .false. !< If true, module has been initialized
343
344 integer :: isdw !< The lower i-memory limit for the wide halo arrays.
345 integer :: iedw !< The upper i-memory limit for the wide halo arrays.
346 integer :: jsdw !< The lower j-memory limit for the wide halo arrays.
347 integer :: jedw !< The upper j-memory limit for the wide halo arrays.
348
349 type(group_pass_type) :: pass_q_dcor !< Handle for a group halo pass
350 type(group_pass_type) :: pass_gtot !< Handle for a group halo pass
351 type(group_pass_type) :: pass_tmp_uv !< Handle for a group halo pass
352 type(group_pass_type) :: pass_eta_bt_rem !< Handle for a group halo pass
353 type(group_pass_type) :: pass_force_hbt0_cor_ref !< Handle for a group halo pass
354 type(group_pass_type) :: pass_dat_uv !< Handle for a group halo pass
355 type(group_pass_type) :: pass_eta_ubt !< Handle for a group halo pass
356 type(group_pass_type) :: pass_etaav !< Handle for a group halo pass
357 type(group_pass_type) :: pass_ubt_cor !< Handle for a group halo pass
358 type(group_pass_type) :: pass_ubta_uhbta !< Handle for a group halo pass
359 type(group_pass_type) :: pass_e_anom !< Handle for a group halo pass
360 type(group_pass_type) :: pass_spv_avg !< Handle for a group halo pass
361
362 !>@{ Diagnostic IDs
363 integer :: id_pfu_bt = -1, id_pfv_bt = -1, id_coru_bt = -1, id_corv_bt = -1
364 integer :: id_ldu_bt = -1, id_ldv_bt = -1, id_eta_cor = -1
365 integer :: id_ubtforce = -1, id_vbtforce = -1, id_uaccel = -1, id_vaccel = -1
366 integer :: id_visc_rem_u = -1, id_visc_rem_v = -1, id_bt_rem_u = -1, id_bt_rem_v = -1
367 integer :: id_ubt = -1, id_vbt = -1, id_eta_bt = -1, id_ubtav = -1, id_vbtav = -1
368 integer :: id_ubt_st = -1, id_vbt_st = -1, id_eta_st = -1
369 integer :: id_ubtdt = -1, id_vbtdt = -1
370 integer :: id_ubt_hifreq = -1, id_vbt_hifreq = -1, id_eta_hifreq = -1
371 integer :: id_uhbt_hifreq = -1, id_vhbt_hifreq = -1, id_eta_pred_hifreq = -1
372 integer :: id_etapf_hifreq = -1, id_etapf_anom = -1
373 integer :: id_gtotn = -1, id_gtots = -1, id_gtote = -1, id_gtotw = -1
374 integer :: id_uhbt = -1, id_frhatu = -1, id_vhbt = -1, id_frhatv = -1
375 integer :: id_frhatu1 = -1, id_frhatv1 = -1
376
377 integer :: id_btc_fa_u_ee = -1, id_btc_fa_u_e0 = -1, id_btc_fa_u_w0 = -1, id_btc_fa_u_ww = -1
378 integer :: id_btc_ubt_ee = -1, id_btc_ubt_ww = -1
379 integer :: id_btc_fa_v_nn = -1, id_btc_fa_v_n0 = -1, id_btc_fa_v_s0 = -1, id_btc_fa_v_ss = -1
380 integer :: id_btc_vbt_nn = -1, id_btc_vbt_ss = -1
381 integer :: id_btc_fa_u_rat0 = -1, id_btc_fa_v_rat0 = -1, id_btc_fa_h_rat0 = -1
382 integer :: id_uhbt0 = -1, id_vhbt0 = -1
383 integer :: id_ssh_u_obc = -1, id_ssh_v_obc = -1, id_ubt_obc = -1, id_vbt_obc = -1
384 !>@}
385
386end type barotropic_cs
387
388!> A description of the functional dependence of transport at a u-point
389type, private :: local_bt_cont_u_type
390 real :: fa_u_ee !< The effective open face area for zonal barotropic transport
391 !! drawing from locations far to the east [H L ~> m2 or kg m-1].
392 real :: fa_u_e0 !< The effective open face area for zonal barotropic transport
393 !! drawing from nearby to the east [H L ~> m2 or kg m-1].
394 real :: fa_u_w0 !< The effective open face area for zonal barotropic transport
395 !! drawing from nearby to the west [H L ~> m2 or kg m-1].
396 real :: fa_u_ww !< The effective open face area for zonal barotropic transport
397 !! drawing from locations far to the west [H L ~> m2 or kg m-1].
398 real :: ubt_ww !< uBT_WW is the barotropic velocity [L T-1 ~> m s-1], or with INTEGRAL_BT_CONTINUITY
399 !! the time-integrated barotropic velocity [L ~> m], beyond which the marginal
400 !! open face area is FA_u_WW. uBT_WW must be non-negative.
401 real :: ubt_ee !< uBT_EE is a barotropic velocity [L T-1 ~> m s-1], or with INTEGRAL_BT_CONTINUITY
402 !! the time-integrated barotropic velocity [L ~> m], beyond which the marginal
403 !! open face area is FA_u_EE. uBT_EE must be non-positive.
404 real :: uh_crvw !< The curvature of face area with velocity for flow from the west [H T2 L-1 ~> s2 or kg s2 m-3]
405 !! or [H L-1 ~> nondim or kg m-3] with INTEGRAL_BT_CONTINUITY.
406 real :: uh_crve !< The curvature of face area with velocity for flow from the east [H T2 L-1 ~> s2 or kg s2 m-3]
407 !! or [H L-1 ~> nondim or kg m-3] with INTEGRAL_BT_CONTINUITY.
408 real :: uh_ww !< The zonal transport when ubt=ubt_WW [H L2 T-1 ~> m3 s-1 or kg s-1], or the equivalent
409 !! time-integrated transport with INTEGRAL_BT_CONTINUITY [H L2 ~> m3 or kg].
410 real :: uh_ee !< The zonal transport when ubt=ubt_EE [H L2 T-1 ~> m3 s-1 or kg s-1], or the equivalent
411 !! time-integrated transport with INTEGRAL_BT_CONTINUITY [H L2 ~> m3 or kg].
413
414!> A description of the functional dependence of transport at a v-point
415type, private :: local_bt_cont_v_type
416 real :: fa_v_nn !< The effective open face area for meridional barotropic transport
417 !! drawing from locations far to the north [H L ~> m2 or kg m-1].
418 real :: fa_v_n0 !< The effective open face area for meridional barotropic transport
419 !! drawing from nearby to the north [H L ~> m2 or kg m-1].
420 real :: fa_v_s0 !< The effective open face area for meridional barotropic transport
421 !! drawing from nearby to the south [H L ~> m2 or kg m-1].
422 real :: fa_v_ss !< The effective open face area for meridional barotropic transport
423 !! drawing from locations far to the south [H L ~> m2 or kg m-1].
424 real :: vbt_ss !< vBT_SS is the barotropic velocity [L T-1 ~> m s-1], or with INTEGRAL_BT_CONTINUITY
425 !! the time-integrated barotropic velocity [L ~> m], beyond which the marginal
426 !! open face area is FA_v_SS. vBT_SS must be non-negative.
427 real :: vbt_nn !< vBT_NN is the barotropic velocity [L T-1 ~> m s-1], or with INTEGRAL_BT_CONTINUITY
428 !! the time-integrated barotropic velocity [L ~> m], beyond which the marginal
429 !! open face area is FA_v_NN. vBT_NN must be non-positive.
430 real :: vh_crvs !< The curvature of face area with velocity for flow from the south [H T2 L-1 ~> s2 or kg s2 m-3]
431 !! or [H L-1 ~> nondim or kg m-3] with INTEGRAL_BT_CONTINUITY.
432 real :: vh_crvn !< The curvature of face area with velocity for flow from the north [H T2 L-1 ~> s2 or kg s2 m-3]
433 !! or [H L-1 ~> nondim or kg m-3] with INTEGRAL_BT_CONTINUITY.
434 real :: vh_ss !< The meridional transport when vbt=vbt_SS [H L2 T-1 ~> m3 s-1 or kg s-1], or the equivalent
435 !! time-integrated transport with INTEGRAL_BT_CONTINUITY [H L2 ~> m3 or kg].
436 real :: vh_nn !< The meridional transport when vbt=vbt_NN [H L2 T-1 ~> m3 s-1 or kg s-1], or the equivalent
437 !! time-integrated transport with INTEGRAL_BT_CONTINUITY [H L2 ~> m3 or kg].
439
440!> A container for passing around active tracer point memory limits
441type, private :: memory_size_type
442 !>@{ Currently active memory limits
443 integer :: isdw, iedw, jsdw, jedw ! The memory limits of the wide halo arrays.
444 !>@}
445end type memory_size_type
446
447!>@{ CPU time clock IDs
448integer :: id_clock_sync=-1, id_clock_calc=-1
449integer :: id_clock_calc_pre=-1, id_clock_calc_post=-1
450integer :: id_clock_pass_step=-1, id_clock_pass_pre=-1, id_clock_pass_post=-1
451!>@}
452
453!>@{ Enumeration values for various schemes
454integer, parameter :: harmonic = 1
455integer, parameter :: arithmetic = 2
456integer, parameter :: hybrid = 3
457integer, parameter :: from_bt_cont = 4
458integer, parameter :: hybrid_bt_cont = 5
459character*(20), parameter :: hybrid_string = "HYBRID"
460character*(20), parameter :: harmonic_string = "HARMONIC"
461character*(20), parameter :: arithmetic_string = "ARITHMETIC"
462character*(20), parameter :: bt_cont_string = "FROM_BT_CONT"
463!>@}
464
465!> A negligible parameter which avoids division by zero, but is too small to
466!! modify physical values [nondim].
467real, parameter :: subroundoff = 1e-30
468
469contains
470
471!> This subroutine time steps the barotropic equations explicitly.
472!! For gravity waves, anything between a forwards-backwards scheme
473!! and a simulated backwards Euler scheme is used, with bebt between
474!! 0.0 and 1.0 determining the scheme. In practice, bebt must be of
475!! order 0.2 or greater. A forwards-backwards treatment of the
476!! Coriolis terms is always used.
477subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, &
478 eta_PF_in, U_Cor, V_Cor, accel_layer_u, accel_layer_v, &
479 eta_out, uhbtav, vhbtav, G, GV, US, CS, &
480 visc_rem_u, visc_rem_v, SpV_avg, ADp, OBC, BT_cont, eta_PF_start, &
481 taux_bot, tauy_bot, uh0, vh0, u_uh0, v_vh0, etaav)
482 type(ocean_grid_type), intent(inout) :: g !< The ocean's grid structure.
483 type(verticalgrid_type), intent(in) :: gv !< The ocean's vertical grid structure.
484 type(unit_scale_type), intent(in) :: us !< A dimensional unit scaling type
485 real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: u_in !< The initial (3-D) zonal
486 !! velocity [L T-1 ~> m s-1].
487 real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: v_in !< The initial (3-D) meridional
488 !! velocity [L T-1 ~> m s-1].
489 real, dimension(SZI_(G),SZJ_(G)), intent(in) :: eta_in !< The initial barotropic free surface height
490 !! anomaly or column mass anomaly [H ~> m or kg m-2].
491 real, intent(in) :: dt !< The time increment to integrate over [T ~> s].
492 real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: bc_accel_u !< The zonal baroclinic accelerations,
493 !! [L T-2 ~> m s-2].
494 real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: bc_accel_v !< The meridional baroclinic accelerations,
495 !! [L T-2 ~> m s-2].
496 type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces
497 real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: pbce !< The baroclinic pressure anomaly in each layer
498 !! due to free surface height anomalies
499 !! [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2].
500 real, dimension(SZI_(G),SZJ_(G)), intent(in) :: eta_pf_in !< The 2-D eta field (either SSH anomaly or
501 !! column mass anomaly) that was used to calculate the input
502 !! pressure gradient accelerations (or its final value if
503 !! eta_PF_start is provided [H ~> m or kg m-2].
504 !! Note: eta_in, pbce, and eta_PF_in must have up-to-date
505 !! values in the first point of their halos.
506 real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: u_cor !< The (3-D) zonal velocities used to
507 !! calculate the Coriolis terms in bc_accel_u [L T-1 ~> m s-1].
508 real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: v_cor !< The (3-D) meridional velocities used to
509 !! calculate the Coriolis terms in bc_accel_u [L T-1 ~> m s-1].
510 real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(out) :: accel_layer_u !< The zonal acceleration of each layer due
511 !! to the barotropic calculation [L T-2 ~> m s-2].
512 real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(out) :: accel_layer_v !< The meridional acceleration of each layer
513 !! due to the barotropic calculation [L T-2 ~> m s-2].
514 real, dimension(SZI_(G),SZJ_(G)), intent(out) :: eta_out !< The final barotropic free surface
515 !! height anomaly or column mass anomaly [H ~> m or kg m-2].
516 real, dimension(SZIB_(G),SZJ_(G)), intent(out) :: uhbtav !< the barotropic zonal volume or mass
517 !! fluxes averaged through the barotropic steps
518 !! [H L2 T-1 ~> m3 s-1 or kg s-1].
519 real, dimension(SZI_(G),SZJB_(G)), intent(out) :: vhbtav !< the barotropic meridional volume or mass
520 !! fluxes averaged through the barotropic steps
521 !! [H L2 T-1 ~> m3 s-1 or kg s-1].
522 type(barotropic_cs), intent(inout) :: cs !< Barotropic control structure
523 real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: visc_rem_u !< Both the fraction of the momentum
524 !! originally in a layer that remains after a time-step of
525 !! viscosity, and the fraction of a time-step's worth of a
526 !! barotropic acceleration that a layer experiences after
527 !! viscosity is applied, in the zonal direction [nondim].
528 !! Visc_rem_u is between 0 (at the bottom) and 1 (far above).
529 real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: visc_rem_v !< Ditto for meridional direction [nondim].
530 real, dimension(SZI_(G),SZJ_(G)), intent(in) :: spv_avg !< The column average specific volume, used
531 !! in non-Boussinesq OBC calculations [R-1 ~> m3 kg-1]
532 type(accel_diag_ptrs), pointer :: adp !< Acceleration diagnostic pointers
533 type(ocean_obc_type), pointer :: obc !< The open boundary condition structure.
534 type(bt_cont_type), pointer :: bt_cont !< A structure with elements that describe
535 !! the effective open face areas as a function of barotropic
536 !! flow.
537 real, dimension(:,:), pointer :: eta_pf_start !< The eta field consistent with the pressure
538 !! gradient at the start of the barotropic stepping
539 !! [H ~> m or kg m-2].
540 real, dimension(:,:), pointer :: taux_bot !< The zonal bottom frictional stress from
541 !! ocean to the seafloor [R L Z T-2 ~> Pa].
542 real, dimension(:,:), pointer :: tauy_bot !< The meridional bottom frictional stress
543 !! from ocean to the seafloor [R L Z T-2 ~> Pa].
544 real, dimension(:,:,:), pointer :: uh0 !< The zonal layer transports at reference
545 !! velocities [H L2 T-1 ~> m3 s-1 or kg s-1].
546 real, dimension(:,:,:), pointer :: u_uh0 !< The velocities used to calculate
547 !! uh0 [L T-1 ~> m s-1]
548 real, dimension(:,:,:), pointer :: vh0 !< The zonal layer transports at reference
549 !! velocities [H L2 T-1 ~> m3 s-1 or kg s-1].
550 real, dimension(:,:,:), pointer :: v_vh0 !< The velocities used to calculate
551 !! vh0 [L T-1 ~> m s-1]
552 real, dimension(SZI_(G),SZJ_(G)), optional, intent(out) :: etaav !< The free surface height or column mass
553 !! averaged over the barotropic integration [H ~> m or kg m-2].
554
555 ! Local variables
556 real :: ubt_cor(szib_(g),szj_(g)) ! The barotropic velocities that had been
557 real :: vbt_cor(szi_(g),szjb_(g)) ! used to calculate the input Coriolis
558 ! terms [L T-1 ~> m s-1].
559 real :: wt_u(szib_(g),szj_(g),szk_(gv)) ! wt_u and wt_v are the
560 real :: wt_v(szi_(g),szjb_(g),szk_(gv)) ! normalized weights to
561 ! be used in calculating barotropic velocities, possibly with
562 ! sums less than one due to viscous losses [nondim]
563 real :: iwt_u_tot(szib_(g),szj_(g)) ! Iwt_u_tot and Iwt_v_tot are the
564 real :: iwt_v_tot(szi_(g),szjb_(g)) ! inverses of wt_u and wt_v vertical integrals,
565 ! used to normalize wt_u and wt_v [nondim]
566 real, dimension(SZIB_(G),SZJ_(G)) :: &
567 av_rem_u, & ! The weighted average of visc_rem_u [nondim]
568 tmp_u, & ! A temporary array at u points [L T-2 ~> m s-2] or [nondim]
569 ubt_st, & ! The zonal barotropic velocity at the start of timestep [L T-1 ~> m s-1].
570 ubt_wtd, & ! A weighted sum used to find the filtered final ubt [L T-1 ~> m s-1].
571 pfu_avg, & ! The average zonal barotropic pressure gradient force [L T-2 ~> m s-2].
572 coru_avg, & ! The average zonal barotropic Coriolis acceleration [L T-2 ~> m s-2].
573 ldu_avg, & ! The average zonal barotropic linear wave drag acceleration [L T-2 ~> m s-2].
574 ubt_dt ! The zonal barotropic velocity tendency [L T-2 ~> m s-2].
575 real, dimension(SZI_(G),SZJB_(G)) :: &
576 av_rem_v, & ! The weighted average of visc_rem_v [nondim]
577 tmp_v, & ! A temporary array at v points [L T-2 ~> m s-2] or [nondim]
578 vbt_st, & ! The meridional barotropic velocity at the start of timestep [L T-1 ~> m s-1].
579 vbt_wtd, & ! A weighted sum used to find the filtered final vbt [L T-1 ~> m s-1].
580 pfv_avg, & ! The average meridional barotropic pressure gradient force [L T-2 ~> m s-2].
581 corv_avg, & ! The average meridional barotropic Coriolis acceleration [L T-2 ~> m s-2].
582 ldv_avg, & ! The average meridional barotropic linear wave drag acceleration [L T-2 ~> m s-2].
583 vbt_dt ! The meridional barotropic velocity tendency [L T-2 ~> m s-2].
584 real, dimension(SZI_(G),SZJ_(G)) :: &
585 tmp_h, & ! A temporary array at h points [nondim]
586 e_anom ! The anomaly in the sea surface height or column mass
587 ! averaged between the beginning and end of the time step,
588 ! relative to eta_PF, with SAL effects included [H ~> m or kg m-2].
589
590 ! These are always allocated with symmetric memory and wide halos.
591 real :: q(szibw_(cs),szjbw_(cs)) ! A pseudo potential vorticity [T-1 H-1 ~> s-1 m-1 or m2 s-1 kg-1]
592 real, dimension(SZIBW_(CS),SZJW_(CS)) :: &
593 ubt, & ! The zonal barotropic velocity [L T-1 ~> m s-1].
594 bt_rem_u, & ! The fraction of the barotropic zonal velocity that remains
595 ! after a time step, the remainder being lost to bottom drag [nondim].
596 ! bt_rem_u is between 0 and 1.
597 bt_force_u, & ! The vertical average of all of the u-accelerations that are
598 ! not explicitly included in the barotropic equation [L T-2 ~> m s-2].
599 u_accel_bt, & ! The difference between the zonal acceleration from the
600 ! barotropic calculation and BT_force_u [L T-2 ~> m s-2].
601 uhbt, & ! The zonal barotropic thickness fluxes [H L2 T-1 ~> m3 s-1 or kg s-1].
602 uhbt0, & ! The difference between the sum of the layer zonal thickness
603 ! fluxes and the barotropic thickness flux using the same
604 ! velocity [H L2 T-1 ~> m3 s-1 or kg s-1].
605 cor_ref_u, & ! The zonal barotropic Coriolis acceleration due
606 ! to the reference velocities [L T-2 ~> m s-2].
607 rayleigh_u, & ! A Rayleigh drag timescale operating at u-points for drag parameterizations
608 ! that introduced directly into the barotropic solver rather than coming in via
609 ! the visc_rem_u arrays from the layered equations [T-1 ~> s-1].
610 ! This is nonzero mostly for a barotropic tidal body drag.
611 dcor_u, & ! An averaged total thickness at u points [H ~> m or kg m-2].
612 datu ! Basin depth at u-velocity grid points times the y-grid
613 ! spacing [H L ~> m2 or kg m-1].
614 real, dimension(SZIW_(CS),SZJBW_(CS)) :: &
615 vbt, & ! The meridional barotropic velocity [L T-1 ~> m s-1].
616 bt_rem_v, & ! The fraction of the barotropic meridional velocity that
617 ! remains after a time step, the rest being lost to bottom
618 ! drag [nondim]. bt_rem_v is between 0 and 1.
619 bt_force_v, & ! The vertical average of all of the v-accelerations that are
620 ! not explicitly included in the barotropic equation [L T-2 ~> m s-2].
621 v_accel_bt, & ! The difference between the meridional acceleration from the
622 ! barotropic calculation and BT_force_v [L T-2 ~> m s-2].
623 vhbt, & ! The meridional barotropic thickness fluxes [H L2 T-1 ~> m3 s-1 or kg s-1].
624 vhbt0, & ! The difference between the sum of the layer meridional
625 ! thickness fluxes and the barotropic thickness flux using
626 ! the same velocities [H L2 T-1 ~> m3 s-1 or kg s-1].
627 cor_ref_v, & ! The meridional barotropic Coriolis acceleration due
628 ! to the reference velocities [L T-2 ~> m s-2].
629 rayleigh_v, & ! A Rayleigh drag timescale operating at v-points for drag parameterizations
630 ! that introduced directly into the barotropic solver rather than coming
631 ! in via the visc_rem_v arrays from the layered equations [T-1 ~> s-1].
632 ! This is nonzero mostly for a barotropic tidal body drag.
633 dcor_v, & ! An averaged total thickness at v points [H ~> m or kg m-2].
634 datv ! Basin depth at v-velocity grid points times the x-grid
635 ! spacing [H L ~> m2 or kg m-1].
636 real, dimension(4,SZIBW_(CS),SZJW_(CS)) :: &
637 f_4_u !< The terms giving the contribution to the Coriolis acceleration at a zonal
638 !! velocity point from the neighboring meridional velocity anomalies [T-1 ~> s-1].
639 !! These are the products of thicknesses at v points and appropriately staggered
640 !! averaged pseudo potential vorticities, but with sufficiently smooth topography
641 !! they are approximately f / 4. The 4 values on the innermost loop are for
642 !! v-velocities to the southwest, southeast, northwest and northeast.
643 real, dimension(4,SZIW_(CS),SZJBW_(CS)) :: &
644 f_4_v !< The terms giving the contribution to the Coriolis acceleration at a meridional
645 !! velocity point from the neighboring meridional velocity anomalies [T-1 ~> s-1].
646 !! These are the products of thicknesses at u points and appropriately staggered
647 !! averaged pseudo potential vorticities, but with sufficiently smooth topography
648 !! they are approximately f / 4. The 4 values on the innermost loop are for
649 !! u-velocities to the southwest, southeast, northwest and northeast.
650 real, dimension(:,:,:), pointer :: ufilt, vfilt
651 ! Filtered velocities from the output of streaming filters [L T-1 ~> m s-1]
652 real, dimension(SZIB_(G),SZJ_(G)) :: drag_u
653 ! The zonal acceleration due to frequency-dependent drag [L T-2 ~> m s-2]
654 real, dimension(SZI_(G),SZJB_(G)) :: drag_v
655 ! The meridional acceleration due to frequency-dependent drag [L T-2 ~> m s-2]
656 real, target, dimension(SZIW_(CS),SZJW_(CS)) :: &
657 eta ! The barotropic free surface height anomaly or column mass [H ~> m or kg m-2]
658 real, dimension(SZIW_(CS),SZJW_(CS)) :: &
659 eta_sum, & ! eta summed across the timesteps [H ~> m or kg m-2].
660 eta_wtd, & ! A weighted estimate used to calculate eta_out [H ~> m or kg m-2].
661 eta_ic, & ! A local copy of the initial 2-D eta field (eta_in) [H ~> m or kg m-2]
662 eta_pf, & ! A local copy of the 2-D eta field (either SSH anomaly or
663 ! column mass anomaly) that was used to calculate the input
664 ! pressure gradient accelerations [H ~> m or kg m-2].
665 eta_pf_1, & ! The initial value of eta_PF, when interp_eta_PF is
666 ! true [H ~> m or kg m-2].
667 d_eta_pf, & ! The change in eta_PF over the barotropic time stepping when
668 ! interp_eta_PF is true [H ~> m or kg m-2].
669 gtot_e, & ! gtot_X is the effective total reduced gravity used to relate
670 gtot_w, & ! free surface height deviations to pressure forces (including
671 gtot_n, & ! GFS and baroclinic contributions) in the barotropic momentum
672 gtot_s, & ! equations half a grid-point in the X-direction (X is N, S, E, or W)
673 ! from the thickness point [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2].
674 ! (See Hallberg, J Comp Phys 1997 for a discussion.)
675 eta_src, & ! The source of eta per barotropic timestep [H ~> m or kg m-2].
676 spv_col_avg, & ! The column average specific volume [R-1 ~> m3 kg-1]
677 dyn_coef_eta ! The coefficient relating the changes in eta to the
678 ! dynamic surface pressure under rigid ice
679 ! [L2 T-2 H-1 ~> m s-2 or m4 s-2 kg-1].
680 type(local_bt_cont_u_type), dimension(SZIBW_(CS),SZJW_(CS)) :: &
681 btcl_u ! A repackaged version of the u-point information in BT_cont.
682 type(local_bt_cont_v_type), dimension(SZIW_(CS),SZJBW_(CS)) :: &
683 btcl_v ! A repackaged version of the v-point information in BT_cont.
684 ! End of wide-sized variables.
685
686 real :: visc_rem ! A work variable that may equal visc_rem_[uv] [nondim]
687 real :: dtbt ! The barotropic time step [T ~> s].
688 real :: idt ! The inverse of dt [T-1 ~> s-1].
689 real :: det_de ! The partial derivative due to self-attraction and loading
690 ! of the reference geopotential with the sea surface height [nondim].
691 ! This is typically ~0.09 or less.
692 real :: dgeo_de ! The constant of proportionality between geopotential and sea surface height
693 ! [nondim]. It is of order 1, but for stability this may be made larger than
694 ! the physical problem would suggest.
695 real :: dgeo_de_obc ! The value of dgeo_de to be used with Flather open boundary conditions [nondim].
696 real :: instep ! The inverse of the number of barotropic time steps to take [nondim].
697 integer :: nstep ! The number of barotropic time steps to take.
698 real :: htot_avg ! The average total thickness of the tracer columns adjacent to a
699 ! velocity point [H ~> m or kg m-2]
700 logical :: use_bt_cont, find_etaav
701 logical :: integral_bt_cont ! If true, update the barotropic continuity equation directly
702 ! from the initial condition using the time-integrated barotropic velocity.
703 logical :: ice_is_rigid, nonblock_setup, interp_eta_pf
704 logical :: add_uh0
705
706 real :: dyn_coef_max ! The maximum stable value of dyn_coef_eta
707 ! [L2 T-2 H-1 ~> m s-2 or m4 s-2 kg-1].
708 real :: ice_strength = 0.0 ! The effective strength of the ice [L2 Z-1 T-2 ~> m s-2].
709 real :: h_to_z ! A local unit conversion factor used with rigid ice [Z H-1 ~> nondim or m3 kg-1]
710 real :: idt_max2 ! The squared inverse of the local maximum stable
711 ! barotropic time step [T-2 ~> s-2].
712 real :: h_min_dyn ! The minimum depth to use in limiting the size of the
713 ! dynamic surface pressure for stability [H ~> m or kg m-2].
714 real :: h_eff_dx2 ! The effective total thickness divided by the grid spacing
715 ! squared [H L-2 ~> m-1 or kg m-4].
716 real :: u_max_cor, v_max_cor ! The maximum corrective velocities [L T-1 ~> m s-1].
717 real :: uint_cor, vint_cor ! The maximum time-integrated corrective velocities [L ~> m].
718 real :: htot ! The total thickness [H ~> m or kg m-2].
719 real :: eta_cor_max ! The maximum fluid that can be added as a correction to eta [H ~> m or kg m-2].
720 real :: accel_underflow ! An acceleration that is so small it should be zeroed out [L T-2 ~> m s-2].
721 real :: h_a_neglect ! A cell volume or mass that is so small it is usually lost
722 ! in roundoff and can be neglected [H L2 ~> m3 or kg].
723
724 real, allocatable :: wt_vel(:) ! The raw or relative weights of each of the barotropic timesteps
725 ! in determining the average velocities [nondim]
726 real, allocatable :: wt_eta(:) ! The raw or relative weights of each of the barotropic timesteps
727 ! in determining the average eta [nondim]
728 real, allocatable :: wt_accel(:) ! The raw or relative weights of each of the barotropic timesteps
729 ! in determining the average accelerations [nondim]
730 real, allocatable :: wt_trans(:) ! The raw or relative weights of each of the barotropic timesteps
731 ! in determining the average transports [nondim]
732 real, allocatable :: wt_accel2(:) ! A potentially un-normalized copy of wt_accel [nondim]
733 real :: sum_wt_vel ! The sum of the raw weights used to find average velocities [nondim]
734 real :: sum_wt_eta ! The sum of the raw weights used to find average eta [nondim]
735 real :: sum_wt_accel ! The sum of the raw weights used to find average accelerations [nondim]
736 real :: sum_wt_trans ! The sum of the raw weights used to find average transports [nondim]
737 real :: i_sum_wt_vel ! The inverse of the sum of the raw weights used to find average velocities [nondim]
738 real :: i_sum_wt_eta ! The inverse of the sum of the raw weights used to find eta [nondim]
739 real :: i_sum_wt_accel ! The inverse of the sum of the raw weights used to find average accelerations [nondim]
740 real :: i_sum_wt_trans ! The inverse of the sum of the raw weights used to find average transports [nondim]
741 real :: dt_filt ! The half-width of the barotropic filter [T ~> s].
742 integer :: nfilter
743
744 logical :: apply_obcs, apply_obc_flather
745 type(memory_size_type) :: ms
746 character(len=200) :: mesg
747 integer :: stencil ! The stencil size of the algorithm, often 1 or 2.
748 integer :: isvf, ievf, jsvf, jevf, num_cycles
749 integer :: i, j, k, n
750 integer :: is, ie, js, je, nz, isq, ieq, jsq, jeq
751 integer :: isd, ied, jsd, jed, isdb, iedb, jsdb, jedb
752
753 if (.not.cs%module_is_initialized) call mom_error(fatal, &
754 "btstep: Module MOM_barotropic must be initialized before it is used.")
755
756 if (.not.cs%split) return
757 is = g%isc ; ie = g%iec ; js = g%jsc ; je = g%jec ; nz = gv%ke
758 isq = g%IscB ; ieq = g%IecB ; jsq = g%JscB ; jeq = g%JecB
759 isd = g%isd ; ied = g%ied ; jsd = g%jsd ; jed = g%jed
760 isdb = g%IsdB ; iedb = g%IedB ; jsdb = g%JsdB ; jedb = g%JedB
761 ms%isdw = cs%isdw ; ms%iedw = cs%iedw ; ms%jsdw = cs%jsdw ; ms%jedw = cs%jedw
762 h_a_neglect = gv%H_subroundoff * (1.0 * us%m_to_L**2)
763
764 idt = 1.0 / dt
765 accel_underflow = cs%vel_underflow * idt
766
767 use_bt_cont = associated(bt_cont)
768 integral_bt_cont = use_bt_cont .and. cs%integral_BT_cont
769
770 interp_eta_pf = associated(eta_pf_start)
771
772 ! Figure out the fullest arrays that could be updated.
773 stencil = max(1, cs%min_stencil)
774 if ((.not.use_bt_cont) .and. cs%Nonlinear_continuity .and. &
775 (cs%Nonlin_cont_update_period > 0)) stencil = max(2, cs%min_stencil)
776
777 find_etaav = present(etaav)
778
779 add_uh0 = associated(uh0)
780 if (add_uh0 .and. .not.(associated(vh0) .and. associated(u_uh0) .and. &
781 associated(v_vh0))) call mom_error(fatal, &
782 "btstep: vh0, u_uh0, and v_vh0 must be associated if uh0 is used.")
783
784 ! This can be changed to try to optimize the performance.
785 nonblock_setup = g%nonblocking_updates
786
787 if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre)
788
789 apply_obc_flather = .false.
790 apply_obcs = .false.
791 if (associated(obc)) then
792 apply_obc_flather = open_boundary_query(obc, apply_flather_obc=.true.)
793 apply_obcs = open_boundary_query(obc, apply_specified_obc=.true.) .or. &
794 apply_obc_flather .or. open_boundary_query(obc, apply_open_obc=.true.)
795 endif
796
797 num_cycles = 1
798 if (cs%use_wide_halos) &
799 num_cycles = min((is-cs%isdw) / stencil, (js-cs%jsdw) / stencil)
800 isvf = is - (num_cycles-1)*stencil ; ievf = ie + (num_cycles-1)*stencil
801 jsvf = js - (num_cycles-1)*stencil ; jevf = je + (num_cycles-1)*stencil
802
803 nstep = ceiling(dt/cs%dtbt - 0.0001)
804 if (is_root_pe() .and. ((nstep /= cs%nstep_last) .or. cs%debug)) then
805 write(mesg,'("btstep is using a dynamic barotropic timestep of ", ES12.6, &
806 & " seconds, max ", ES12.6, ".")') (us%T_to_s*dt/nstep), us%T_to_s*cs%dtbt_max
807 call mom_mesg(mesg, 3)
808 endif
809 cs%nstep_last = nstep
810
811 ! Set the actual barotropic time step.
812 instep = 1.0 / real(nstep)
813 dtbt = dt * instep
814
815 !--- begin setup for group halo update
816 if (id_clock_pass_pre > 0) call cpu_clock_begin(id_clock_pass_pre)
817 if (.not. cs%linearized_BT_PV) then
818 call create_group_pass(cs%pass_q_DCor, q, cs%BT_Domain, to_all, position=corner)
819 call create_group_pass(cs%pass_q_DCor, dcor_u, dcor_v, cs%BT_Domain, &
820 to_all+scalar_pair)
821 endif
822 if ((isq > is-1) .or. (jsq > js-1)) &
823 call create_group_pass(cs%pass_tmp_uv, tmp_u, tmp_v, g%Domain)
824 call create_group_pass(cs%pass_gtot, gtot_e, gtot_n, cs%BT_Domain, &
825 to_all+scalar_pair, agrid)
826 call create_group_pass(cs%pass_gtot, gtot_w, gtot_s, cs%BT_Domain, &
827 to_all+scalar_pair, agrid)
828
829 if (cs%dynamic_psurf) &
830 call create_group_pass(cs%pass_eta_bt_rem, dyn_coef_eta, cs%BT_Domain)
831 if (interp_eta_pf) then
832 call create_group_pass(cs%pass_eta_bt_rem, eta_pf_1, cs%BT_Domain)
833 call create_group_pass(cs%pass_eta_bt_rem, d_eta_pf, cs%BT_Domain)
834 else
835 call create_group_pass(cs%pass_eta_bt_rem, eta_pf, cs%BT_Domain)
836 endif
837 if (integral_bt_cont) &
838 call create_group_pass(cs%pass_eta_bt_rem, eta_ic, cs%BT_Domain)
839 call create_group_pass(cs%pass_eta_bt_rem, eta_src, cs%BT_Domain)
840
841 call create_group_pass(cs%pass_eta_bt_rem, bt_rem_u, bt_rem_v, &
842 cs%BT_Domain, to_all+scalar_pair)
843 if (cs%linear_wave_drag) &
844 call create_group_pass(cs%pass_eta_bt_rem, rayleigh_u, rayleigh_v, &
845 cs%BT_Domain, to_all+scalar_pair)
846
847 ! The following halo update is not needed without wide halos. RWH
848 if (((g%isd > cs%isdw) .or. (g%jsd > cs%jsdw)) .or. (isq <= is-1) .or. (jsq <= js-1)) &
849 call create_group_pass(cs%pass_force_hbt0_Cor_ref, bt_force_u, bt_force_v, cs%BT_Domain)
850 if (add_uh0) call create_group_pass(cs%pass_force_hbt0_Cor_ref, uhbt0, vhbt0, cs%BT_Domain)
851 call create_group_pass(cs%pass_force_hbt0_Cor_ref, cor_ref_u, cor_ref_v, cs%BT_Domain)
852 if (.not. use_bt_cont) then
853 call create_group_pass(cs%pass_Dat_uv, datu, datv, cs%BT_Domain, to_all+scalar_pair)
854 endif
855 if (apply_obc_flather .and. .not.gv%Boussinesq) &
856 call create_group_pass(cs%pass_SpV_avg, spv_col_avg, cs%BT_domain)
857
858 call create_group_pass(cs%pass_ubt_Cor, ubt_cor, vbt_cor, g%Domain)
859 ! These passes occur at the end of the routine, as data is being readied to
860 ! share with the main part of the MOM6 code.
861 if (find_etaav) then
862 call create_group_pass(cs%pass_etaav, etaav, g%Domain)
863 endif
864 call create_group_pass(cs%pass_e_anom, e_anom, g%Domain)
865 call create_group_pass(cs%pass_ubta_uhbta, cs%ubtav, cs%vbtav, g%Domain)
866 call create_group_pass(cs%pass_ubta_uhbta, uhbtav, vhbtav, g%Domain)
867
868 if (id_clock_pass_pre > 0) call cpu_clock_end(id_clock_pass_pre)
869!--- end setup for group halo update
870
871! Calculate the constant coefficients for the Coriolis force terms in the
872! barotropic momentum equations. This has to be done quite early to start
873! the halo update that needs to be completed before the next calculations.
874 if (cs%linearized_BT_PV) then
875 !$OMP parallel do default(shared)
876 do j=jsvf-2,jevf+1 ; do i=isvf-2,ievf+1
877 q(i,j) = cs%q_D(i,j)
878 enddo ; enddo
879 !$OMP parallel do default(shared)
880 do j=jsvf-1,jevf+1 ; do i=isvf-2,ievf+1
881 dcor_u(i,j) = cs%D_u_Cor(i,j)
882 enddo ; enddo
883 !$OMP parallel do default(shared)
884 do j=jsvf-2,jevf+1 ; do i=isvf-1,ievf+1
885 dcor_v(i,j) = cs%D_v_Cor(i,j)
886 enddo ; enddo
887 else
888 q(:,:) = 0.0 ; dcor_u(:,:) = 0.0 ; dcor_v(:,:) = 0.0
889 if (gv%Boussinesq) then
890 !$OMP parallel do default(shared)
891 do j=js,je ; do i=is-1,ie
892 dcor_u(i,j) = 0.5 * (max(gv%Z_to_H*g%bathyT(i+1,j) + eta_in(i+1,j), 0.0) + &
893 max(gv%Z_to_H*g%bathyT(i,j) + eta_in(i,j), 0.0) )
894 enddo ; enddo
895 if (cs%interior_OBC_PV .and. cs%BT_OBC%u_OBCs_on_PE) then
896 !$OMP parallel do default(shared)
897 do j = max(js,cs%BT_OBC%js_u_W_obc), min(je,cs%BT_OBC%je_u_W_obc)
898 do i = max(is-1,cs%BT_OBC%Is_u_W_obc), min(ie,cs%BT_OBC%Ie_u_W_obc)
899 if (cs%BT_OBC%u_OBC_type(i,j) < 0) & ! Western boundary condition
900 dcor_u(i,j) = max(gv%Z_to_H*g%bathyT(i+1,j) + eta_in(i+1,j), 0.0)
901 enddo
902 enddo
903 !$OMP parallel do default(shared)
904 do j = max(js,cs%BT_OBC%js_u_E_obc), min(je,cs%BT_OBC%je_u_E_obc)
905 do i = max(is-1,cs%BT_OBC%Is_u_E_obc), min(ie,cs%BT_OBC%Ie_u_E_obc)
906 if (cs%BT_OBC%u_OBC_type(i,j) > 0) & ! Eastern boundary condition
907 dcor_u(i,j) = max(gv%Z_to_H*g%bathyT(i,j) + eta_in(i,j), 0.0)
908 enddo
909 enddo
910 endif
911
912 !$OMP parallel do default(shared)
913 do j=js-1,je ; do i=is,ie
914 dcor_v(i,j) = 0.5 * (max(gv%Z_to_H*g%bathyT(i,j+1) + eta_in(i+1,j), 0.0) + &
915 max(gv%Z_to_H*g%bathyT(i,j) + eta_in(i,j), 0.0) )
916 enddo ; enddo
917 if (cs%interior_OBC_PV .and. cs%BT_OBC%v_OBCs_on_PE) then
918 !$OMP parallel do default(shared)
919 do j = max(js,cs%BT_OBC%js_v_S_obc), min(je,cs%BT_OBC%je_v_S_obc)
920 do i = max(is-1,cs%BT_OBC%Is_v_S_obc), min(ie,cs%BT_OBC%Ie_v_S_obc)
921 if (cs%BT_OBC%v_OBC_type(i,j) < 0) & ! Southern boundary condition
922 dcor_v(i,j) = max(gv%Z_to_H*g%bathyT(i,j+1) + eta_in(i,j+1), 0.0)
923 enddo
924 enddo
925 !$OMP parallel do default(shared)
926 do j = max(js,cs%BT_OBC%js_v_N_obc), min(je,cs%BT_OBC%je_v_N_obc)
927 do i = max(is-1,cs%BT_OBC%Is_v_N_obc), min(ie,cs%BT_OBC%Ie_v_N_obc)
928 if (cs%BT_OBC%v_OBC_type(i,j) > 0) & ! Northern boundary condition
929 dcor_v(i,j) = max(gv%Z_to_H*g%bathyT(i,j) + eta_in(i,j), 0.0)
930 enddo
931 enddo
932 endif
933 !$OMP parallel do default(shared)
934 do j=js-1,je ; do i=is-1,ie
935 q(i,j) = 0.25 * (cs%BT_Coriolis_scale * g%CoriolisBu(i,j)) * &
936 ((cs%q_wt(1,i,j) + cs%q_wt(4,i,j)) + (cs%q_wt(2,i,j) + cs%q_wt(3,i,j))) / &
937 (max(((cs%q_wt(1,i,j) * max(gv%Z_to_H*g%bathyT(i,j) + eta_in(i,j), 0.0)) + &
938 (cs%q_wt(4,i,j) * max(gv%Z_to_H*g%bathyT(i+1,j+1) + eta_in(i+1,j+1), 0.0))) + &
939 ((cs%q_wt(2,i,j) * max(gv%Z_to_H*g%bathyT(i+1,j) + eta_in(i+1,j), 0.0)) + &
940 (cs%q_wt(3,i,j) * max(gv%Z_to_H*g%bathyT(i,j+1) + eta_in(i,j+1), 0.0))), h_a_neglect) )
941 enddo ; enddo
942 else ! Non-Boussinesq
943 !$OMP parallel do default(shared)
944 do j=js,je ; do i=is-1,ie
945 dcor_u(i,j) = 0.5 * (eta_in(i+1,j) + eta_in(i,j))
946 enddo ; enddo
947 if (cs%interior_OBC_PV .and. cs%BT_OBC%u_OBCs_on_PE) then
948 !$OMP parallel do default(shared)
949 do j = max(js,cs%BT_OBC%js_u_W_obc), min(je,cs%BT_OBC%je_u_W_obc)
950 do i = max(is-1,cs%BT_OBC%Is_u_W_obc), min(ie,cs%BT_OBC%Ie_u_W_obc)
951 if (cs%BT_OBC%u_OBC_type(i,j) < 0) dcor_u(i,j) = eta_in(i+1,j) ! Western boundary condition
952 enddo
953 enddo
954 !$OMP parallel do default(shared)
955 do j = max(js,cs%BT_OBC%js_u_E_obc), min(je,cs%BT_OBC%je_u_E_obc)
956 do i = max(is-1,cs%BT_OBC%Is_u_E_obc), min(ie,cs%BT_OBC%Ie_u_E_obc)
957 if (cs%BT_OBC%u_OBC_type(i,j) > 0) dcor_u(i,j) = eta_in(i,j) ! Eastern boundary condition
958 enddo
959 enddo
960 endif
961
962 !$OMP parallel do default(shared)
963 do j=js-1,je ; do i=is,ie
964 dcor_v(i,j) = 0.5 * (eta_in(i,j+1) + eta_in(i,j))
965 enddo ; enddo
966 if (cs%interior_OBC_PV .and. cs%BT_OBC%v_OBCs_on_PE) then
967 !$OMP parallel do default(shared)
968 do j = max(js,cs%BT_OBC%js_v_S_obc), min(je,cs%BT_OBC%je_v_S_obc)
969 do i = max(is-1,cs%BT_OBC%Is_v_S_obc), min(ie,cs%BT_OBC%Ie_v_S_obc)
970 if (cs%BT_OBC%v_OBC_type(i,j) < 0) dcor_v(i,j) = eta_in(i,j+1) ! Southern boundary condition
971 enddo
972 enddo
973 !$OMP parallel do default(shared)
974 do j = max(js,cs%BT_OBC%js_v_N_obc), min(je,cs%BT_OBC%je_v_N_obc)
975 do i = max(is-1,cs%BT_OBC%Is_v_N_obc), min(ie,cs%BT_OBC%Ie_v_N_obc)
976 if (cs%BT_OBC%v_OBC_type(i,j) > 0) dcor_v(i,j) = eta_in(i,j) ! Northern boundary condition
977 enddo
978 enddo
979 endif
980
981 !$OMP parallel do default(shared)
982 do j=js-1,je ; do i=is-1,ie
983 q(i,j) = 0.25 * (cs%BT_Coriolis_scale * g%CoriolisBu(i,j)) * &
984 ((cs%q_wt(1,i,j) + cs%q_wt(4,i,j)) + (cs%q_wt(2,i,j) + cs%q_wt(3,i,j))) / &
985 (max(((cs%q_wt(1,i,j) * eta_in(i,j)) + (cs%q_wt(4,i,j) * eta_in(i+1,j+1))) + &
986 ((cs%q_wt(2,i,j) * eta_in(i+1,j)) + (cs%q_wt(3,i,j) * eta_in(i,j+1))), h_a_neglect) )
987 enddo ; enddo
988 endif
989
990 ! With very wide halos, q and D need to be calculated on the available data
991 ! domain and then updated onto the full computational domain.
992 ! These calculations can be done almost immediately, but the halo updates
993 ! must be done before the [abcd]mer and [abcd]zon are calculated.
994 if (id_clock_calc_pre > 0) call cpu_clock_end(id_clock_calc_pre)
995 if (nonblock_setup) then
996 call start_group_pass(cs%pass_q_DCor, cs%BT_Domain, clock=id_clock_pass_pre)
997 else
998 call do_group_pass(cs%pass_q_DCor, cs%BT_Domain, clock=id_clock_pass_pre)
999 endif
1000 if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre)
1001 endif
1002
1003 ! Zero out various wide-halo arrays.
1004 !$OMP parallel do default(shared)
1005 do j=cs%jsdw,cs%jedw ; do i=cs%isdw,cs%iedw
1006 gtot_e(i,j) = 0.0 ; gtot_w(i,j) = 0.0
1007 gtot_n(i,j) = 0.0 ; gtot_s(i,j) = 0.0
1008 eta(i,j) = 0.0
1009 eta_pf(i,j) = 0.0
1010 if (interp_eta_pf) then
1011 eta_pf_1(i,j) = 0.0 ; d_eta_pf(i,j) = 0.0
1012 endif
1013 if (integral_bt_cont) then
1014 eta_ic(i,j) = 0.0
1015 endif
1016 if (cs%dynamic_psurf) dyn_coef_eta(i,j) = 0.0
1017 enddo ; enddo
1018 ! The halo regions of various arrays need to be initialized to
1019 ! non-NaNs in case the neighboring domains are not part of the ocean.
1020 ! Otherwise a halo update later on fills in the correct values.
1021 !$OMP parallel do default(shared)
1022 do j=cs%jsdw,cs%jedw ; do i=cs%isdw-1,cs%iedw
1023 cor_ref_u(i,j) = 0.0 ; bt_force_u(i,j) = 0.0 ; ubt(i,j) = 0.0
1024 datu(i,j) = 0.0 ; bt_rem_u(i,j) = 0.0 ; uhbt0(i,j) = 0.0
1025 enddo ; enddo
1026 !$OMP parallel do default(shared)
1027 do j=cs%jsdw-1,cs%jedw ; do i=cs%isdw,cs%iedw
1028 cor_ref_v(i,j) = 0.0 ; bt_force_v(i,j) = 0.0 ; vbt(i,j) = 0.0
1029 datv(i,j) = 0.0 ; bt_rem_v(i,j) = 0.0 ; vhbt0(i,j) = 0.0
1030 enddo ; enddo
1031
1032 if (apply_obcs) then
1033 spv_col_avg(:,:) = 0.0
1034 if (apply_obc_flather .and. .not.gv%Boussinesq) then
1035 ! Copy the column average specific volumes into a wide halo array
1036 !$OMP parallel do default(shared)
1037 do j=js,je ; do i=is,ie
1038 spv_col_avg(i,j) = spv_avg(i,j)
1039 enddo ; enddo
1040 if (nonblock_setup) then
1041 call start_group_pass(cs%pass_SpV_avg, cs%BT_domain)
1042 else
1043 call do_group_pass(cs%pass_SpV_avg, cs%BT_domain)
1044 endif
1045 endif
1046 endif
1047
1048 if (cs%linear_wave_drag) then
1049 !$OMP parallel do default(shared)
1050 do j=cs%jsdw,cs%jedw ; do i=cs%isdw-1,cs%iedw
1051 rayleigh_u(i,j) = 0.0
1052 enddo ; enddo
1053 !$OMP parallel do default(shared)
1054 do j=cs%jsdw-1,cs%jedw ; do i=cs%isdw,cs%iedw
1055 rayleigh_v(i,j) = 0.0
1056 enddo ; enddo
1057 endif
1058
1059 ! Copy input arrays into their wide-halo counterparts.
1060 if (interp_eta_pf) then
1061 !$OMP parallel do default(shared)
1062 do j=g%jsd,g%jed ; do i=g%isd,g%ied ! Was "do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1" but doing so breaks OBC. Not sure why?
1063 eta(i,j) = eta_in(i,j)
1064 eta_pf_1(i,j) = eta_pf_start(i,j)
1065 d_eta_pf(i,j) = eta_pf_in(i,j) - eta_pf_start(i,j)
1066 enddo ; enddo
1067 else
1068 !$OMP parallel do default(shared)
1069 do j=g%jsd,g%jed ; do i=g%isd,g%ied !: Was "do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1" but doing so breaks OBC. Not sure why?
1070 eta(i,j) = eta_in(i,j)
1071 eta_pf(i,j) = eta_pf_in(i,j)
1072 enddo ; enddo
1073 endif
1074 if (integral_bt_cont) then
1075 !$OMP parallel do default(shared)
1076 do j=g%jsd,g%jed ; do i=g%isd,g%ied
1077 eta_ic(i,j) = eta_in(i,j)
1078 enddo ; enddo
1079 endif
1080
1081 !$OMP parallel do default(shared) private(visc_rem)
1082 do k=1,nz ; do j=js,je ; do i=is-1,ie
1083 ! rem needs to be greater than visc_rem_u and 1-Instep/visc_rem_u.
1084 ! The 0.5 below is just for safety.
1085 ! NOTE: subroundoff is a negligible value used to prevent division by zero.
1086 ! When 1-0.5*Instep/visc_rem exceeds visc_rem, the subroundoff is too small
1087 ! to modify the significand. When visc_rem is small, the max() operators
1088 ! select visc_rem or 0. So subroundoff cannot impact the final value.
1089 visc_rem = min(visc_rem_u(i,j,k), 1.)
1090 visc_rem = max(visc_rem, 1. - 0.5 * instep / (visc_rem + subroundoff))
1091 visc_rem = max(visc_rem, 0.)
1092 wt_u(i,j,k) = cs%frhatu(i,j,k) * visc_rem
1093 enddo ; enddo ; enddo
1094 !$OMP parallel do default(shared) private(visc_rem)
1095 do k=1,nz ; do j=js-1,je ; do i=is,ie
1096 ! As above, rem must be greater than visc_rem_v and 1-Instep/visc_rem_v.
1097 visc_rem = min(visc_rem_v(i,j,k), 1.)
1098 visc_rem = max(visc_rem, 1. - 0.5 * instep / (visc_rem + subroundoff))
1099 visc_rem = max(visc_rem, 0.)
1100 wt_v(i,j,k) = cs%frhatv(i,j,k) * visc_rem
1101 enddo ; enddo ; enddo
1102
1103 if (.not. cs%wt_uv_bug) then
1104 do j=js,je ; do i=is-1,ie ; iwt_u_tot(i,j) = wt_u(i,j,1) ; enddo ; enddo
1105 do k=2,nz ; do j=js,je ; do i=is-1,ie
1106 iwt_u_tot(i,j) = iwt_u_tot(i,j) + wt_u(i,j,k)
1107 enddo ; enddo ; enddo
1108 do j=js,je ; do i=is-1,ie
1109 if (abs(iwt_u_tot(i,j)) > 0.0 ) iwt_u_tot(i,j) = g%mask2dCu(i,j) / iwt_u_tot(i,j)
1110 enddo ; enddo
1111 do k=1,nz ; do j=js,je ; do i=is-1,ie
1112 wt_u(i,j,k) = wt_u(i,j,k) * iwt_u_tot(i,j)
1113 enddo ; enddo ; enddo
1114
1115 do j=js-1,je ; do i=is,ie ; iwt_v_tot(i,j) = wt_v(i,j,1) ; enddo ; enddo
1116 do k=2,nz ; do j=js-1,je ; do i=is,ie
1117 iwt_v_tot(i,j) = iwt_v_tot(i,j) + wt_v(i,j,k)
1118 enddo ; enddo ; enddo
1119 do j=js-1,je ; do i=is,ie
1120 if (abs(iwt_v_tot(i,j)) > 0.0 ) iwt_v_tot(i,j) = g%mask2dCv(i,j) / iwt_v_tot(i,j)
1121 enddo ; enddo
1122 do k=1,nz ; do j=js-1,je ; do i=is,ie
1123 wt_v(i,j,k) = wt_v(i,j,k) * iwt_v_tot(i,j)
1124 enddo ; enddo ; enddo
1125 endif
1126
1127 ! Use u_Cor and v_Cor as the reference values for the Coriolis terms,
1128 ! including the viscous remnant.
1129 !$OMP parallel do default(shared)
1130 do j=js-1,je+1 ; do i=is-1,ie ; ubt_cor(i,j) = 0.0 ; enddo ; enddo
1131 !$OMP parallel do default(shared)
1132 do j=js-1,je ; do i=is-1,ie+1 ; vbt_cor(i,j) = 0.0 ; enddo ; enddo
1133 !$OMP parallel do default(shared)
1134 do j=js,je ; do k=1,nz ; do i=is-1,ie
1135 ubt_cor(i,j) = ubt_cor(i,j) + wt_u(i,j,k) * u_cor(i,j,k)
1136 enddo ; enddo ; enddo
1137 !$OMP parallel do default(shared)
1138 do j=js-1,je ; do k=1,nz ; do i=is,ie
1139 vbt_cor(i,j) = vbt_cor(i,j) + wt_v(i,j,k) * v_cor(i,j,k)
1140 enddo ; enddo ; enddo
1141
1142 ! The gtot arrays are the effective layer-weighted reduced gravities for
1143 ! accelerations across the various faces, with names for the relative
1144 ! locations of the faces to the pressure point. They will have their halos
1145 ! updated later on.
1146 !$OMP parallel do default(shared)
1147 do j=js,je
1148 do k=1,nz ; do i=is-1,ie
1149 gtot_e(i,j) = gtot_e(i,j) + pbce(i,j,k) * wt_u(i,j,k)
1150 gtot_w(i+1,j) = gtot_w(i+1,j) + pbce(i+1,j,k) * wt_u(i,j,k)
1151 enddo ; enddo
1152 enddo
1153 !$OMP parallel do default(shared)
1154 do j=js-1,je
1155 do k=1,nz ; do i=is,ie
1156 gtot_n(i,j) = gtot_n(i,j) + pbce(i,j,k) * wt_v(i,j,k)
1157 gtot_s(i,j+1) = gtot_s(i,j+1) + pbce(i,j+1,k) * wt_v(i,j,k)
1158 enddo ; enddo
1159 enddo
1160
1161 if (cs%BT_OBC%u_OBCs_on_PE) then
1162 do j=js,je ; do i=is-1,ie
1163 if (cs%BT_OBC%u_OBC_type(i,j) > 0) & ! Eastern boundary condition
1164 gtot_w(i+1,j) = gtot_w(i,j) ! Perhaps this should be gtot_E(i,j)?
1165 if (cs%BT_OBC%u_OBC_type(i,j) < 0) & ! Western boundary condition
1166 gtot_e(i,j) = gtot_e(i+1,j) ! Perhaps this should be gtot_W(i+1,j)?
1167 enddo ; enddo
1168 endif
1169 if (cs%BT_OBC%v_OBCs_on_PE) then
1170 do j=js-1,je ; do i=is,ie
1171 if (cs%BT_OBC%v_OBC_type(i,j) > 0) & ! Northern boundary condition
1172 gtot_s(i,j+1) = gtot_s(i,j) !### Should this be gtot_N(i,j) to use wt_v at the same point?
1173 if (cs%BT_OBC%v_OBC_type(i,j) < 0) & ! Southern boundary condition
1174 gtot_n(i,j) = gtot_n(i,j+1) ! Perhaps this should be gtot_S(i,j+1)?
1175 enddo ; enddo
1176 endif
1177
1178 if (cs%calculate_SAL) then
1179 call scalar_sal_sensitivity(cs%SAL_CSp, det_de)
1180 if (cs%tidal_sal_bug) then
1181 dgeo_de = 1.0 + det_de + cs%G_extra
1182 else
1183 dgeo_de = (1.0 - det_de) + cs%G_extra
1184 endif
1185 else
1186 dgeo_de = 1.0 + cs%G_extra
1187 endif
1188
1189 if (nonblock_setup .and. .not.cs%linearized_BT_PV) then
1190 if (id_clock_calc_pre > 0) call cpu_clock_end(id_clock_calc_pre)
1191 call complete_group_pass(cs%pass_q_DCor, cs%BT_Domain, clock=id_clock_pass_pre)
1192 if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre)
1193 endif
1194
1195 ! Calculate the open areas at the velocity points.
1196 ! The halo updates are needed before Datu is first used, either in set_up_BT_OBC or ubt_Cor.
1197 if (integral_bt_cont) then
1198 call set_local_bt_cont_types(bt_cont, btcl_u, btcl_v, g, us, ms, cs%BT_Domain, 1+ievf-ie, dt_baroclinic=dt)
1199 elseif (use_bt_cont) then
1200 call set_local_bt_cont_types(bt_cont, btcl_u, btcl_v, g, us, ms, cs%BT_Domain, 1+ievf-ie)
1201 else
1202 if (cs%Nonlinear_continuity) then
1203 call find_face_areas(datu, datv, g, gv, us, cs, ms, 1, eta)
1204 else
1205 call find_face_areas(datu, datv, g, gv, us, cs, ms, 1)
1206 endif
1207 endif
1208
1209 ! Set up fields related to the open boundary conditions. These calls include halo updates that
1210 ! must occur on all PEs when there are open boundary conditions anywhere.
1211 if (apply_obcs) then
1212 if (nonblock_setup .and. apply_obc_flather .and. .not.gv%Boussinesq) &
1213 call complete_group_pass(cs%pass_SpV_avg, cs%BT_domain)
1214
1215 dgeo_de_obc = 1.0 ; if (cs%tidal_SAL_Flather) dgeo_de_obc = dgeo_de
1216 call set_up_bt_obc(obc, eta, spv_col_avg, cs%BT_OBC, cs%BT_Domain, g, gv, us, cs, ms, ievf-ie, &
1217 use_bt_cont, integral_bt_cont, dt, datu, datv, btcl_u, btcl_v, dgeo_de_obc)
1218 endif
1219
1220 ! Determine the difference between the sum of the layer fluxes and the
1221 ! barotropic fluxes found from the same input velocities.
1222 if (add_uh0) then
1223 !$OMP parallel do default(shared)
1224 do j=js,je ; do i=is-1,ie ; uhbt(i,j) = 0.0 ; ubt(i,j) = 0.0 ; enddo ; enddo
1225 !$OMP parallel do default(shared)
1226 do j=js-1,je ; do i=is,ie ; vhbt(i,j) = 0.0 ; vbt(i,j) = 0.0 ; enddo ; enddo
1227 if (cs%visc_rem_u_uh0) then
1228 !$OMP parallel do default(shared)
1229 do j=js,je ; do k=1,nz ; do i=is-1,ie
1230 uhbt(i,j) = uhbt(i,j) + uh0(i,j,k)
1231 ubt(i,j) = ubt(i,j) + wt_u(i,j,k) * u_uh0(i,j,k)
1232 enddo ; enddo ; enddo
1233 !$OMP parallel do default(shared)
1234 do j=js-1,je ; do k=1,nz ; do i=is,ie
1235 vhbt(i,j) = vhbt(i,j) + vh0(i,j,k)
1236 vbt(i,j) = vbt(i,j) + wt_v(i,j,k) * v_vh0(i,j,k)
1237 enddo ; enddo ; enddo
1238 else
1239 !$OMP parallel do default(shared)
1240 do j=js,je ; do k=1,nz ; do i=is-1,ie
1241 uhbt(i,j) = uhbt(i,j) + uh0(i,j,k)
1242 ubt(i,j) = ubt(i,j) + cs%frhatu(i,j,k) * u_uh0(i,j,k)
1243 enddo ; enddo ; enddo
1244 !$OMP parallel do default(shared)
1245 do j=js-1,je ; do k=1,nz ; do i=is,ie
1246 vhbt(i,j) = vhbt(i,j) + vh0(i,j,k)
1247 vbt(i,j) = vbt(i,j) + cs%frhatv(i,j,k) * v_vh0(i,j,k)
1248 enddo ; enddo ; enddo
1249 endif
1250 if ((use_bt_cont .or. integral_bt_cont) .and. cs%adjust_BT_cont) then
1251 ! Use the additional input transports to broaden the fits
1252 ! over which the bt_cont_type applies.
1253
1254 ! Fill in the halo data for ubt, vbt, uhbt, and vhbt.
1255 if (id_clock_calc_pre > 0) call cpu_clock_end(id_clock_calc_pre)
1256 if (id_clock_pass_pre > 0) call cpu_clock_begin(id_clock_pass_pre)
1257 call pass_vector(ubt, vbt, cs%BT_Domain, complete=.false., halo=1+ievf-ie)
1258 call pass_vector(uhbt, vhbt, cs%BT_Domain, complete=.true., halo=1+ievf-ie)
1259 if (id_clock_pass_pre > 0) call cpu_clock_end(id_clock_pass_pre)
1260 if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre)
1261
1262 if (integral_bt_cont) then
1263 call adjust_local_bt_cont_types(ubt, uhbt, vbt, vhbt, btcl_u, btcl_v, &
1264 g, us, ms, 1+ievf-ie, dt_baroclinic=dt)
1265 else
1266 call adjust_local_bt_cont_types(ubt, uhbt, vbt, vhbt, btcl_u, btcl_v, &
1267 g, us, ms, 1+ievf-ie)
1268 endif
1269 endif
1270 if (integral_bt_cont) then
1271 !$OMP parallel do default(shared)
1272 do j=js,je ; do i=is-1,ie
1273 uhbt0(i,j) = uhbt(i,j) - find_uhbt(dt*ubt(i,j), btcl_u(i,j)) * idt
1274 enddo ; enddo
1275 !$OMP parallel do default(shared)
1276 do j=js-1,je ; do i=is,ie
1277 vhbt0(i,j) = vhbt(i,j) - find_vhbt(dt*vbt(i,j), btcl_v(i,j)) * idt
1278 enddo ; enddo
1279 elseif (use_bt_cont) then
1280 !$OMP parallel do default(shared)
1281 do j=js,je ; do i=is-1,ie
1282 uhbt0(i,j) = uhbt(i,j) - find_uhbt(ubt(i,j), btcl_u(i,j))
1283 enddo ; enddo
1284 !$OMP parallel do default(shared)
1285 do j=js-1,je ; do i=is,ie
1286 vhbt0(i,j) = vhbt(i,j) - find_vhbt(vbt(i,j), btcl_v(i,j))
1287 enddo ; enddo
1288 else
1289 !$OMP parallel do default(shared)
1290 do j=js,je ; do i=is-1,ie
1291 uhbt0(i,j) = uhbt(i,j) - datu(i,j)*ubt(i,j)
1292 enddo ; enddo
1293 !$OMP parallel do default(shared)
1294 do j=js-1,je ; do i=is,ie
1295 vhbt0(i,j) = vhbt(i,j) - datv(i,j)*vbt(i,j)
1296 enddo ; enddo
1297 endif
1298 if (cs%BT_OBC%u_OBCs_on_PE) then ! Zero out the reference transport at OBC points
1299 !$OMP parallel do default(shared)
1300 do j=js,je ; do i=is-1,ie ; if (cs%BT_OBC%u_OBC_type(i,j) /= 0) then
1301 uhbt0(i,j) = 0.0
1302 endif ; enddo ; enddo
1303 endif
1304 if (cs%BT_OBC%v_OBCs_on_PE) then !Zero out the reference transport at OBC points
1305 !$OMP parallel do default(shared)
1306 do j=js-1,je ; do i=is,ie ; if (cs%BT_OBC%v_OBC_type(i,j) /= 0) then
1307 vhbt0(i,j) = 0.0
1308 endif ; enddo ; enddo
1309 endif
1310 endif
1311
1312! Calculate the initial barotropic velocities from the layer's velocities.
1313 call btstep_ubt_from_layer(u_in, v_in, wt_u, wt_v, ubt, vbt, g, gv, cs)
1314
1315 uhbt(:,:) = 0.0 ; vhbt(:,:) = 0.0
1316 u_accel_bt(:,:) = 0.0 ; v_accel_bt(:,:) = 0.0
1317
1318 if (apply_obcs .or. (cs%id_ubtdt > 0)) then
1319 do j=js,je ; do i=is-1,ie ; ubt_st(i,j) = ubt(i,j) ; enddo ; enddo
1320 endif
1321 if (apply_obcs .or. (cs%id_vbtdt > 0)) then
1322 do j=js-1,je ; do i=is,ie ; vbt_st(i,j) = vbt(i,j) ; enddo ; enddo
1323 endif
1324
1325! Here the vertical average accelerations due to the Coriolis, advective,
1326! pressure gradient and horizontal viscous terms in the layer momentum
1327! equations are calculated. These will be used to determine the difference
1328! between the accelerations due to the average of the layer equations and the
1329! barotropic calculation.
1330
1331 !$OMP parallel do default(shared)
1332 do j=js,je ; do i=is-1,ie ; if (g%OBCmaskCu(i,j) > 0.0) then
1333 if (cs%nonlin_stress) then
1334 if (gv%Boussinesq) then
1335 htot_avg = 0.5*(max(cs%bathyT(i,j)*gv%Z_to_H + eta(i,j), 0.0) + &
1336 max(cs%bathyT(i+1,j)*gv%Z_to_H + eta(i+1,j), 0.0))
1337 else
1338 htot_avg = 0.5*(eta(i,j) + eta(i+1,j))
1339 endif
1340 if (htot_avg*cs%dy_Cu(i,j) <= 0.0) then
1341 cs%IDatu(i,j) = 0.0
1342 elseif (integral_bt_cont) then
1343 cs%IDatu(i,j) = cs%dy_Cu(i,j) / (max(find_duhbt_du(ubt(i,j)*dt, btcl_u(i,j)), &
1344 cs%dy_Cu(i,j)*htot_avg) )
1345 elseif (use_bt_cont) then ! Reconsider the max and whether there should be some scaling.
1346 cs%IDatu(i,j) = cs%dy_Cu(i,j) / (max(find_duhbt_du(ubt(i,j), btcl_u(i,j)), &
1347 cs%dy_Cu(i,j)*htot_avg) )
1348 else
1349 cs%IDatu(i,j) = 1.0 / htot_avg
1350 endif
1351 endif
1352
1353 bt_force_u(i,j) = forces%taux(i,j) * gv%RZ_to_H * cs%IDatu(i,j)*visc_rem_u(i,j,1)
1354 else
1355 bt_force_u(i,j) = 0.0
1356 endif ; enddo ; enddo
1357 !$OMP parallel do default(shared)
1358 do j=js-1,je ; do i=is,ie ; if (g%OBCmaskCv(i,j) > 0.0) then
1359 if (cs%nonlin_stress) then
1360 if (gv%Boussinesq) then
1361 htot_avg = 0.5*(max(cs%bathyT(i,j)*gv%Z_to_H + eta(i,j), 0.0) + &
1362 max(cs%bathyT(i,j+1)*gv%Z_to_H + eta(i,j+1), 0.0))
1363 else
1364 htot_avg = 0.5*(eta(i,j) + eta(i,j+1))
1365 endif
1366 if (htot_avg*cs%dx_Cv(i,j) <= 0.0) then
1367 cs%IDatv(i,j) = 0.0
1368 elseif (integral_bt_cont) then
1369 cs%IDatv(i,j) = cs%dx_Cv(i,j) / (max(find_dvhbt_dv(vbt(i,j)*dt, btcl_v(i,j)), &
1370 cs%dx_Cv(i,j)*htot_avg) )
1371 elseif (use_bt_cont) then ! Reconsider the max and whether there should be some scaling.
1372 cs%IDatv(i,j) = cs%dx_Cv(i,j) / (max(find_dvhbt_dv(vbt(i,j), btcl_v(i,j)), &
1373 cs%dx_Cv(i,j)*htot_avg) )
1374 else
1375 cs%IDatv(i,j) = 1.0 / htot_avg
1376 endif
1377 endif
1378
1379 bt_force_v(i,j) = forces%tauy(i,j) * gv%RZ_to_H * cs%IDatv(i,j)*visc_rem_v(i,j,1)
1380 else
1381 bt_force_v(i,j) = 0.0
1382 endif ; enddo ; enddo
1383 if (associated(taux_bot) .and. associated(tauy_bot)) then
1384 !$OMP parallel do default(shared)
1385 do j=js,je ; do i=is-1,ie ; if (g%mask2dCu(i,j) > 0.0) then
1386 bt_force_u(i,j) = bt_force_u(i,j) - taux_bot(i,j) * gv%RZ_to_H * cs%IDatu(i,j)
1387 endif ; enddo ; enddo
1388 !$OMP parallel do default(shared)
1389 do j=js-1,je ; do i=is,ie ; if (g%mask2dCv(i,j) > 0.0) then
1390 bt_force_v(i,j) = bt_force_v(i,j) - tauy_bot(i,j) * gv%RZ_to_H * cs%IDatv(i,j)
1391 endif ; enddo ; enddo
1392 endif
1393
1394 ! bc_accel_u & bc_accel_v are only available on the potentially
1395 ! non-symmetric computational domain.
1396 !$OMP parallel do default(shared)
1397 do j=js,je ; do k=1,nz ; do i=isq,ieq
1398 bt_force_u(i,j) = bt_force_u(i,j) + wt_u(i,j,k) * bc_accel_u(i,j,k)
1399 enddo ; enddo ; enddo
1400 !$OMP parallel do default(shared)
1401 do j=jsq,jeq ; do k=1,nz ; do i=is,ie
1402 bt_force_v(i,j) = bt_force_v(i,j) + wt_v(i,j,k) * bc_accel_v(i,j,k)
1403 enddo ; enddo ; enddo
1404
1405 if (cs%gradual_BT_ICs) then
1406 !$OMP parallel do default(shared)
1407 do j=js,je ; do i=is-1,ie
1408 bt_force_u(i,j) = bt_force_u(i,j) + (ubt(i,j) - cs%ubt_IC(i,j)) * idt
1409 ubt(i,j) = cs%ubt_IC(i,j)
1410 if (abs(ubt(i,j)) < cs%vel_underflow) ubt(i,j) = 0.0
1411 enddo ; enddo
1412 !$OMP parallel do default(shared)
1413 do j=js-1,je ; do i=is,ie
1414 bt_force_v(i,j) = bt_force_v(i,j) + (vbt(i,j) - cs%vbt_IC(i,j)) * idt
1415 vbt(i,j) = cs%vbt_IC(i,j)
1416 if (abs(vbt(i,j)) < cs%vel_underflow) vbt(i,j) = 0.0
1417 enddo ; enddo
1418 endif
1419
1420 ! Compute instantaneous tidal velocities and apply frequency-dependent drag.
1421 ! Note that the filtered velocities are only updated during the current predictor step,
1422 ! and are calculated using the barotropic velocity from the previous correction step.
1423 if (cs%use_filter) then
1424 call filt_accum(ubt(g%IsdB:g%IedB,g%jsd:g%jed), ufilt, cs%Time, us, cs%Filt_CS_u)
1425 call filt_accum(vbt(g%isd:g%ied,g%JsdB:g%JedB), vfilt, cs%Time, us, cs%Filt_CS_v)
1426 endif
1427
1428 if (cs%use_filter .and. cs%linear_freq_drag) then
1429 call wave_drag_calc(ufilt, vfilt, drag_u, drag_v, g, cs%Drag_CS)
1430 !$OMP do
1431 do j=js,je ; do i=is-1,ie
1432 htot = 0.5 * (eta(i,j) + eta(i+1,j))
1433 if (gv%Boussinesq) &
1434 htot = htot + 0.5*gv%Z_to_H * (cs%bathyT(i,j) + cs%bathyT(i+1,j))
1435 if (htot > 0.0) then
1436 drag_u(i,j) = drag_u(i,j) / htot
1437 bt_force_u(i,j) = bt_force_u(i,j) - drag_u(i,j)
1438 else
1439 drag_u(i,j) = 0.0
1440 endif
1441 enddo ; enddo
1442 !$OMP do
1443 do j=js-1,je ; do i=is,ie
1444 htot = 0.5 * (eta(i,j) + eta(i,j+1))
1445 if (gv%Boussinesq) &
1446 htot = htot + 0.5*gv%Z_to_H * (cs%bathyT(i,j) + cs%bathyT(i,j+1))
1447 if (htot > 0.0) then
1448 drag_v(i,j) = drag_v(i,j) / htot
1449 bt_force_v(i,j) = bt_force_v(i,j) - drag_v(i,j)
1450 else
1451 drag_v(i,j) = 0.0
1452 endif
1453 enddo ; enddo
1454 endif
1455
1456 ! Mask out the forcing at OBC points
1457 if (cs%BT_OBC%u_OBCs_on_PE) then
1458 !$OMP do
1459 do j=js,je ; do i=is-1,ie
1460 bt_force_u(i,j) = cs%OBCmask_u(i,j) * bt_force_u(i,j)
1461 enddo ; enddo
1462 endif
1463 if (cs%BT_OBC%v_OBCs_on_PE) then
1464 !$OMP do
1465 do j=js-1,je ; do i=is,ie
1466 bt_force_v(i,j) = cs%OBCmask_v(i,j) * bt_force_v(i,j)
1467 enddo ; enddo
1468 endif
1469
1470 if ((isq > is-1) .or. (jsq > js-1)) then
1471 ! Non-symmetric memory is being used, so the edge values need to be
1472 ! filled in with a halo update of a non-symmetric array.
1473 if (id_clock_calc_pre > 0) call cpu_clock_end(id_clock_calc_pre)
1474 if (id_clock_pass_pre > 0) call cpu_clock_begin(id_clock_pass_pre)
1475 tmp_u(:,:) = 0.0 ; tmp_v(:,:) = 0.0
1476 do j=js,je ; do i=isq,ieq ; tmp_u(i,j) = bt_force_u(i,j) ; enddo ; enddo
1477 do j=jsq,jeq ; do i=is,ie ; tmp_v(i,j) = bt_force_v(i,j) ; enddo ; enddo
1478 if (nonblock_setup) then
1479 call start_group_pass(cs%pass_tmp_uv, g%Domain)
1480 else
1481 call do_group_pass(cs%pass_tmp_uv, g%Domain)
1482 do j=jsd,jed ; do i=isdb,iedb ; bt_force_u(i,j) = tmp_u(i,j) ; enddo ; enddo
1483 do j=jsdb,jedb ; do i=isd,ied ; bt_force_v(i,j) = tmp_v(i,j) ; enddo ; enddo
1484 endif
1485 if (id_clock_pass_pre > 0) call cpu_clock_end(id_clock_pass_pre)
1486 if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre)
1487 endif
1488
1489 if (nonblock_setup) then
1490 if (id_clock_calc_pre > 0) call cpu_clock_end(id_clock_calc_pre)
1491 if (id_clock_pass_pre > 0) call cpu_clock_begin(id_clock_pass_pre)
1492 call start_group_pass(cs%pass_gtot, cs%BT_Domain)
1493 call start_group_pass(cs%pass_ubt_Cor, g%Domain)
1494 if (id_clock_pass_pre > 0) call cpu_clock_end(id_clock_pass_pre)
1495 if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre)
1496 endif
1497
1498 ! Determine the weighted Coriolis parameters for the neighboring velocities.
1499 call btstep_find_cor(q, dcor_u, dcor_v, f_4_u, f_4_v, isvf, ievf, jsvf, jevf, cs)
1500
1501! Complete the previously initiated message passing.
1502 if (id_clock_calc_pre > 0) call cpu_clock_end(id_clock_calc_pre)
1503 if (id_clock_pass_pre > 0) call cpu_clock_begin(id_clock_pass_pre)
1504 if (nonblock_setup) then
1505 if ((isq > is-1) .or. (jsq > js-1)) then
1506 call complete_group_pass(cs%pass_tmp_uv, g%Domain)
1507 do j=jsd,jed ; do i=isdb,iedb ; bt_force_u(i,j) = tmp_u(i,j) ; enddo ; enddo
1508 do j=jsdb,jedb ; do i=isd,ied ; bt_force_v(i,j) = tmp_v(i,j) ; enddo ; enddo
1509 endif
1510 call complete_group_pass(cs%pass_gtot, cs%BT_Domain)
1511 call complete_group_pass(cs%pass_ubt_Cor, g%Domain)
1512 else
1513 call do_group_pass(cs%pass_gtot, cs%BT_Domain)
1514 call do_group_pass(cs%pass_ubt_Cor, g%Domain)
1515 endif
1516 ! The various elements of gtot are positive definite but directional, so use
1517 ! the polarity arrays to sort out when the directions have shifted.
1518 do j=jsvf-1,jevf+1 ; do i=isvf-1,ievf+1
1519 if (cs%ua_polarity(i,j) < 0.0) call swap(gtot_e(i,j), gtot_w(i,j))
1520 if (cs%va_polarity(i,j) < 0.0) call swap(gtot_n(i,j), gtot_s(i,j))
1521 enddo ; enddo
1522
1523 !$OMP parallel do default(shared)
1524 do j=js,je ; do i=is-1,ie
1525 cor_ref_u(i,j) = &
1526 (((f_4_u(4,i,j) * vbt_cor(i+1,j)) + (f_4_u(1,i,j) * vbt_cor(i ,j-1))) + &
1527 ((f_4_u(3,i,j) * vbt_cor(i ,j)) + (f_4_u(2,i,j) * vbt_cor(i+1,j-1))))
1528 enddo ; enddo
1529 !$OMP parallel do default(shared)
1530 do j=js-1,je ; do i=is,ie
1531 cor_ref_v(i,j) = -1.0 * &
1532 (((f_4_v(1,i,j) * ubt_cor(i-1,j)) + (f_4_v(4,i,j) * ubt_cor(i ,j+1))) + &
1533 ((f_4_v(2,i,j) * ubt_cor(i ,j)) + (f_4_v(3,i,j) * ubt_cor(i-1,j+1))))
1534 enddo ; enddo
1535
1536 ! Now start new halo updates.
1537 if (nonblock_setup) then
1538 if (.not.use_bt_cont) &
1539 call start_group_pass(cs%pass_Dat_uv, cs%BT_Domain)
1540
1541 ! The following halo update is not needed without wide halos. RWH
1542 call start_group_pass(cs%pass_force_hbt0_Cor_ref, cs%BT_Domain)
1543 endif
1544 if (id_clock_pass_pre > 0) call cpu_clock_end(id_clock_pass_pre)
1545 if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre)
1546 !$OMP parallel default(shared) private(u_max_cor,uint_cor,v_max_cor,vint_cor,eta_cor_max,Htot)
1547 !$OMP do
1548 do j=js-1,je+1 ; do i=is-1,ie ; av_rem_u(i,j) = 0.0 ; enddo ; enddo
1549 !$OMP do
1550 do j=js-1,je ; do i=is-1,ie+1 ; av_rem_v(i,j) = 0.0 ; enddo ; enddo
1551 !$OMP do
1552 do j=js,je ; do k=1,nz ; do i=is-1,ie
1553 av_rem_u(i,j) = av_rem_u(i,j) + cs%frhatu(i,j,k) * visc_rem_u(i,j,k)
1554 enddo ; enddo ; enddo
1555 !$OMP do
1556 do j=js-1,je ; do k=1,nz ; do i=is,ie
1557 av_rem_v(i,j) = av_rem_v(i,j) + cs%frhatv(i,j,k) * visc_rem_v(i,j,k)
1558 enddo ; enddo ; enddo
1559 if (cs%strong_drag) then
1560 !$OMP do
1561 do j=js,je ; do i=is-1,ie
1562 bt_rem_u(i,j) = g%mask2dCu(i,j) * &
1563 ((nstep * av_rem_u(i,j)) / (1.0 + (nstep-1)*av_rem_u(i,j)))
1564 enddo ; enddo
1565 !$OMP do
1566 do j=js-1,je ; do i=is,ie
1567 bt_rem_v(i,j) = g%mask2dCv(i,j) * &
1568 ((nstep * av_rem_v(i,j)) / (1.0 + (nstep-1)*av_rem_v(i,j)))
1569 enddo ; enddo
1570 else
1571 !$OMP do
1572 do j=js,je ; do i=is-1,ie
1573 bt_rem_u(i,j) = 0.0
1574 if (g%mask2dCu(i,j) * av_rem_u(i,j) > 0.0) &
1575 bt_rem_u(i,j) = g%mask2dCu(i,j) * (av_rem_u(i,j)**instep)
1576 enddo ; enddo
1577 !$OMP do
1578 do j=js-1,je ; do i=is,ie
1579 bt_rem_v(i,j) = 0.0
1580 if (g%mask2dCv(i,j) * av_rem_v(i,j) > 0.0) &
1581 bt_rem_v(i,j) = g%mask2dCv(i,j) * (av_rem_v(i,j)**instep)
1582 enddo ; enddo
1583 endif
1584 if (cs%linear_wave_drag) then
1585 !$OMP do
1586 do j=js,je ; do i=is-1,ie ; if (g%mask2dCu(i,j) * cs%lin_drag_u(i,j) > 0.0) then
1587 htot = 0.5 * (eta(i,j) + eta(i+1,j))
1588 if (gv%Boussinesq) &
1589 htot = htot + 0.5*gv%Z_to_H * (cs%bathyT(i,j) + cs%bathyT(i+1,j))
1590 ! If Htot==0., linear wave drag is not used and Rayleigh_u = 0.0 (from initialization)
1591 ! and bt_rem_u is unmodified.
1592 if (htot > 0.0) then
1593 bt_rem_u(i,j) = bt_rem_u(i,j) * (htot / (htot + cs%lin_drag_u(i,j) * dtbt))
1594 rayleigh_u(i,j) = cs%lin_drag_u(i,j) / htot
1595 endif
1596 endif ; enddo ; enddo
1597 !$OMP do
1598 do j=js-1,je ; do i=is,ie ; if (g%mask2dCv(i,j) * cs%lin_drag_v(i,j) > 0.0) then
1599 htot = 0.5 * (eta(i,j) + eta(i,j+1))
1600 if (gv%Boussinesq) &
1601 htot = htot + 0.5*gv%Z_to_H * (cs%bathyT(i,j) + cs%bathyT(i,j+1))
1602 ! If Htot==0., linear wave drag is not used and Rayleigh_v = 0.0 (from initialization)
1603 ! and bt_rem_v is unmodified.
1604 if (htot > 0.0) then
1605 bt_rem_v(i,j) = bt_rem_v(i,j) * (htot / (htot + cs%lin_drag_v(i,j) * dtbt))
1606 rayleigh_v(i,j) = cs%lin_drag_v(i,j) / htot
1607 endif
1608 endif ; enddo ; enddo
1609 endif
1610
1611 ! Avoid changing the velocities at OBC points due to non-OBC calculations.
1612 if (cs%BT_OBC%u_OBCs_on_PE) then
1613 !$OMP do
1614 do j=js,je ; do i=is-1,ie ; if (cs%BT_OBC%u_OBC_type(i,j) /= 0) then
1615 bt_rem_u(i,j) = 1.0
1616 endif ; enddo ; enddo
1617 endif
1618 if (cs%BT_OBC%v_OBCs_on_PE) then
1619 !$OMP do
1620 do j=js-1,je ; do i=is,ie ; if (cs%BT_OBC%v_OBC_type(i,j) /= 0) then
1621 bt_rem_v(i,j) = 1.0
1622 endif ; enddo ; enddo
1623 endif
1624
1625 ! Set the mass source, after first initializing the halos to 0.
1626 !$OMP do
1627 do j=jsvf-1,jevf+1 ; do i=isvf-1,ievf+1 ; eta_src(i,j) = 0.0 ; enddo ; enddo
1628 if (cs%bound_BT_corr) then ; if ((use_bt_cont.or.integral_bt_cont) .and. cs%BT_cont_bounds) then
1629 do j=js,je ; do i=is,ie ; if (g%mask2dT(i,j) > 0.0) then
1630 if (cs%eta_cor(i,j) > 0.0) then
1631 ! Limit the source (outward) correction to be a fraction the mass that
1632 ! can be transported out of the cell by velocities with a CFL number of CFL_cor.
1633 if (integral_bt_cont) then
1634 uint_cor = g%dxT(i,j) * cs%maxCFL_BT_cont
1635 vint_cor = g%dyT(i,j) * cs%maxCFL_BT_cont
1636 eta_cor_max = (cs%IareaT(i,j) * &
1637 (((find_uhbt(uint_cor, btcl_u(i,j)) + dt*uhbt0(i,j)) - &
1638 (find_uhbt(-uint_cor, btcl_u(i-1,j)) + dt*uhbt0(i-1,j))) + &
1639 ((find_vhbt(vint_cor, btcl_v(i,j)) + dt*vhbt0(i,j)) - &
1640 (find_vhbt(-vint_cor, btcl_v(i,j-1)) + dt*vhbt0(i,j-1))) ))
1641 else ! (use_BT_Cont) then
1642 u_max_cor = g%dxT(i,j) * (cs%maxCFL_BT_cont*idt)
1643 v_max_cor = g%dyT(i,j) * (cs%maxCFL_BT_cont*idt)
1644 eta_cor_max = dt * (cs%IareaT(i,j) * &
1645 (((find_uhbt(u_max_cor, btcl_u(i,j)) + uhbt0(i,j)) - &
1646 (find_uhbt(-u_max_cor, btcl_u(i-1,j)) + uhbt0(i-1,j))) + &
1647 ((find_vhbt(v_max_cor, btcl_v(i,j)) + vhbt0(i,j)) - &
1648 (find_vhbt(-v_max_cor, btcl_v(i,j-1)) + vhbt0(i,j-1))) ))
1649 endif
1650 cs%eta_cor(i,j) = min(cs%eta_cor(i,j), max(0.0, eta_cor_max))
1651 else
1652 ! Limit the sink (inward) correction to the amount of mass that is already inside the cell.
1653 htot = eta(i,j)
1654 if (gv%Boussinesq) htot = cs%bathyT(i,j)*gv%Z_to_H + eta(i,j)
1655
1656 cs%eta_cor(i,j) = max(cs%eta_cor(i,j), -max(0.0,htot))
1657 endif
1658 endif ; enddo ; enddo
1659 else ; do j=js,je ; do i=is,ie
1660 if (abs(cs%eta_cor(i,j)) > dt*cs%eta_cor_bound(i,j)) &
1661 cs%eta_cor(i,j) = sign(dt*cs%eta_cor_bound(i,j), cs%eta_cor(i,j))
1662 enddo ; enddo ; endif ; endif
1663 !$OMP do
1664 do j=js,je ; do i=is,ie
1665 eta_src(i,j) = g%mask2dT(i,j) * (instep * cs%eta_cor(i,j))
1666 enddo ; enddo
1667 !$OMP end parallel
1668
1669 if (cs%dynamic_psurf) then
1670 ice_is_rigid = (associated(forces%rigidity_ice_u) .and. &
1671 associated(forces%rigidity_ice_v))
1672 h_min_dyn = cs%Dmin_dyn_psurf
1673 if (ice_is_rigid .and. use_bt_cont) &
1674 call bt_cont_to_face_areas(bt_cont, datu, datv, g, us, ms, halo=0)
1675 if (ice_is_rigid) then
1676 if (gv%Boussinesq) then
1677 h_to_z = gv%H_to_Z
1678 else
1679 h_to_z = gv%H_to_RZ / cs%Rho_BT_lin
1680 endif
1681 !$OMP parallel do default(shared) private(Idt_max2,H_eff_dx2,dyn_coef_max,ice_strength)
1682 do j=js,je ; do i=is,ie
1683 ! First determine the maximum stable value for dyn_coef_eta.
1684
1685 ! This estimate of the maximum stable time step is pretty accurate for
1686 ! gravity waves, but it is a conservative estimate since it ignores the
1687 ! stabilizing effect of the bottom drag.
1688 idt_max2 = 0.5 * (dgeo_de * (1.0 + 2.0*cs%bebt)) * (g%IareaT(i,j) * &
1689 (((gtot_e(i,j) * (datu(i,j)*g%IdxCu(i,j))) + &
1690 (gtot_w(i,j) * (datu(i-1,j)*g%IdxCu(i-1,j)))) + &
1691 ((gtot_n(i,j) * (datv(i,j)*g%IdyCv(i,j))) + &
1692 (gtot_s(i,j) * (datv(i,j-1)*g%IdyCv(i,j-1))))) + &
1693 ((g%Coriolis2Bu(i,j) + g%Coriolis2Bu(i-1,j-1)) + &
1694 (g%Coriolis2Bu(i-1,j) + g%Coriolis2Bu(i,j-1))) * cs%BT_Coriolis_scale**2 )
1695 h_eff_dx2 = max(h_min_dyn * ((g%IdxT(i,j)**2) + (g%IdyT(i,j)**2)), &
1696 g%IareaT(i,j) * &
1697 (((datu(i,j)*g%IdxCu(i,j)) + (datu(i-1,j)*g%IdxCu(i-1,j))) + &
1698 ((datv(i,j)*g%IdyCv(i,j)) + (datv(i,j-1)*g%IdyCv(i,j-1))) ) )
1699 dyn_coef_max = cs%const_dyn_psurf * max(0.0, 1.0 - dtbt**2 * idt_max2) / &
1700 (dtbt**2 * h_eff_dx2)
1701
1702 ! ice_strength has units of [L2 Z-1 T-2 ~> m s-2]. rigidity_ice_[uv] has units of [L4 Z-1 T-1 ~> m3 s-1].
1703 ice_strength = ((forces%rigidity_ice_u(i,j) + forces%rigidity_ice_u(i-1,j)) + &
1704 (forces%rigidity_ice_v(i,j) + forces%rigidity_ice_v(i,j-1))) / &
1705 (cs%ice_strength_length**2 * dtbt)
1706
1707 ! Units of dyn_coef: [L2 T-2 H-1 ~> m s-2 or m4 s-2 kg-1]
1708 dyn_coef_eta(i,j) = min(dyn_coef_max, ice_strength * h_to_z)
1709 enddo ; enddo ; endif
1710 endif
1711
1712 if (id_clock_calc_pre > 0) call cpu_clock_end(id_clock_calc_pre)
1713 if (id_clock_pass_pre > 0) call cpu_clock_begin(id_clock_pass_pre)
1714 if (nonblock_setup) then
1715 call start_group_pass(cs%pass_eta_bt_rem, cs%BT_Domain)
1716 ! The following halo update is not needed without wide halos. RWH
1717 else
1718 call do_group_pass(cs%pass_eta_bt_rem, cs%BT_Domain)
1719 if (.not.use_bt_cont) &
1720 call do_group_pass(cs%pass_Dat_uv, cs%BT_Domain)
1721 call do_group_pass(cs%pass_force_hbt0_Cor_ref, cs%BT_Domain)
1722 endif
1723 if (id_clock_pass_pre > 0) call cpu_clock_end(id_clock_pass_pre)
1724 if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre)
1725
1726 ! Complete all of the outstanding halo updates.
1727 if (nonblock_setup) then
1728 if (id_clock_calc_pre > 0) call cpu_clock_end(id_clock_calc_pre)
1729 if (id_clock_pass_pre > 0) call cpu_clock_begin(id_clock_pass_pre)
1730
1731 if (.not.use_bt_cont) call complete_group_pass(cs%pass_Dat_uv, cs%BT_Domain)
1732 call complete_group_pass(cs%pass_force_hbt0_Cor_ref, cs%BT_Domain)
1733 call complete_group_pass(cs%pass_eta_bt_rem, cs%BT_Domain)
1734
1735 if (id_clock_pass_pre > 0) call cpu_clock_end(id_clock_pass_pre)
1736 if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre)
1737 endif
1738
1739 if (cs%debug) then
1740 call uvchksum("BT [uv]hbt", uhbt, vhbt, cs%debug_BT_HI, haloshift=0, &
1741 unscale=us%s_to_T*us%L_to_m**2*gv%H_to_m)
1742 call uvchksum("BT Initial [uv]bt", ubt, vbt, cs%debug_BT_HI, haloshift=0, unscale=us%L_T_to_m_s)
1743 call hchksum(eta, "BT Initial eta", cs%debug_BT_HI, haloshift=0, unscale=gv%H_to_MKS)
1744 call uvchksum("BT BT_force_[uv]", bt_force_u, bt_force_v, &
1745 cs%debug_BT_HI, haloshift=0, unscale=us%L_T2_to_m_s2)
1746 if (interp_eta_pf) then
1747 call hchksum(eta_pf_1, "BT eta_PF_1", cs%debug_BT_HI, haloshift=0, unscale=gv%H_to_MKS)
1748 call hchksum(d_eta_pf, "BT d_eta_PF", cs%debug_BT_HI, haloshift=0, unscale=gv%H_to_MKS)
1749 else
1750 call hchksum(eta_pf, "BT eta_PF", cs%debug_BT_HI, haloshift=0, unscale=gv%H_to_MKS)
1751 call hchksum(eta_pf_in, "BT eta_PF_in", g%HI, haloshift=0, unscale=gv%H_to_MKS)
1752 endif
1753 if (cs%linearized_BT_PV) then
1754 call bchksum(cs%q_D, "BT PV (q_D)", cs%debug_BT_HI, haloshift=0, symmetric=.true., unscale=us%s_to_T/gv%H_to_MKS)
1755 else
1756 call bchksum(q, "BT PV (q)", cs%debug_BT_HI, haloshift=0, symmetric=.true., unscale=us%s_to_T/gv%H_to_MKS)
1757 endif
1758 call uvchksum("BT DCor_[uv]", dcor_u, dcor_v, g%HI, haloshift=0, &
1759 symmetric=.true., omit_corners=.true., scalar_pair=.true., unscale=gv%H_to_MKS)
1760 call uvchksum("BT Cor_ref_[uv]", cor_ref_u, cor_ref_v, cs%debug_BT_HI, haloshift=0, unscale=us%L_T2_to_m_s2)
1761 call uvchksum("BT [uv]hbt0", uhbt0, vhbt0, cs%debug_BT_HI, haloshift=0, &
1762 unscale=us%L_to_m**2*us%s_to_T*gv%H_to_m)
1763 if (.not. use_bt_cont) then
1764 call uvchksum("BT Dat[uv]", datu, datv, cs%debug_BT_HI, haloshift=1, unscale=us%L_to_m*gv%H_to_m)
1765 endif
1766 call uvchksum("BT wt_[uv]", wt_u, wt_v, g%HI, haloshift=0, &
1767 symmetric=.true., omit_corners=.true., scalar_pair=.true.)
1768 call uvchksum("BT frhat[uv]", cs%frhatu, cs%frhatv, g%HI, haloshift=0, &
1769 symmetric=.true., omit_corners=.true., scalar_pair=.true.)
1770 call uvchksum("BT visc_rem_[uv]", visc_rem_u, visc_rem_v, g%HI, haloshift=0, &
1771 symmetric=.true., omit_corners=.true., scalar_pair=.true.)
1772 call uvchksum("BT bc_accel_[uv]", bc_accel_u, bc_accel_v, g%HI, haloshift=0, unscale=us%L_T2_to_m_s2)
1773 call uvchksum("BT IDat[uv]", cs%IDatu, cs%IDatv, g%HI, haloshift=0, &
1774 unscale=gv%m_to_H, scalar_pair=.true.)
1775 call uvchksum("BT visc_rem_[uv]", visc_rem_u, visc_rem_v, g%HI, &
1776 haloshift=1, scalar_pair=.true.)
1777
1778 if (apply_obcs) then
1779 call uvchksum("BT_OBC%[uv]bt_outer", cs%BT_OBC%ubt_outer, cs%BT_OBC%vbt_outer, cs%debug_BT_HI, &
1780 symmetric=.true., omit_corners=.true., unscale=us%L_T_to_m_s)
1781 if (allocated(cs%BT_OBC%SSH_outer_u) .and. allocated(cs%BT_OBC%SSH_outer_v)) &
1782 call uvchksum("BT_OBC%SSH_outer[uv]", cs%BT_OBC%SSH_outer_u, cs%BT_OBC%SSH_outer_v, cs%debug_BT_HI, &
1783 symmetric=.true., omit_corners=.true., unscale=us%Z_to_m, scalar_pair=.true.)
1784 if (allocated(cs%BT_OBC%Cg_u) .and. allocated(cs%BT_OBC%Cg_v)) &
1785 call uvchksum("BT_OBC%Cg_[uv]", cs%BT_OBC%Cg_u, cs%BT_OBC%Cg_v, cs%debug_BT_HI, &
1786 symmetric=.true., omit_corners=.true., unscale=us%L_T_to_m_s, scalar_pair=.true.)
1787 if (allocated(cs%BT_OBC%dZ_u) .and. allocated(cs%BT_OBC%dZ_v)) &
1788 call uvchksum("BT_OBC%dZ_[uv]", cs%BT_OBC%dZ_u, cs%BT_OBC%dZ_v, cs%debug_BT_HI, &
1789 symmetric=.true., omit_corners=.true., unscale=us%Z_to_m, scalar_pair=.true.)
1790 endif
1791 endif
1792
1793 if (query_averaging_enabled(cs%diag)) then
1794 if (cs%id_eta_st > 0) call post_data(cs%id_eta_st, eta(isd:ied,jsd:jed), cs%diag)
1795 if (cs%id_ubt_st > 0) call post_data(cs%id_ubt_st, ubt(isdb:iedb,jsd:jed), cs%diag)
1796 if (cs%id_vbt_st > 0) call post_data(cs%id_vbt_st, vbt(isd:ied,jsdb:jedb), cs%diag)
1797 endif
1798
1799 if (id_clock_calc_pre > 0) call cpu_clock_end(id_clock_calc_pre)
1800 if (id_clock_calc > 0) call cpu_clock_begin(id_clock_calc)
1801
1802 if (cs%dt_bt_filter >= 0.0) then
1803 dt_filt = 0.5 * max(0.0, min(cs%dt_bt_filter, 2.0*dt))
1804 else
1805 dt_filt = 0.5 * max(0.0, dt * min(-cs%dt_bt_filter, 2.0))
1806 endif
1807 nfilter = ceiling(dt_filt / dtbt)
1808
1809 if ( nstep+nfilter<=0 ) call mom_error(fatal, &
1810 "btstep: number of barotropic step (nstep+nfilter) is 0")
1811 if ( cs%bt_limit_integral_transport .and. nstep-nfilter<=0 ) call mom_error(fatal, &
1812 "btstep: barotropic filter steps too large (nstep-nfilter) is 0")
1813
1814 ! Set up the normalized weights for the filtered velocity.
1815 sum_wt_vel = 0.0 ; sum_wt_eta = 0.0 ; sum_wt_accel = 0.0 ; sum_wt_trans = 0.0
1816 allocate(wt_vel(nstep+nfilter)) ; allocate(wt_eta(nstep+nfilter))
1817 allocate(wt_trans(nstep+nfilter+1)) ; allocate(wt_accel(nstep+nfilter+1))
1818 allocate(wt_accel2(nstep+nfilter+1))
1819 do n=1,nstep+nfilter
1820 ! Modify this to use a different filter...
1821
1822 ! This is a filter that ramps down linearly over a time dt_filt.
1823 if ( (n==nstep) .or. (dt_filt - abs(n-nstep)*dtbt >= 0.0)) then
1824 wt_vel(n) = 1.0 ; wt_eta(n) = 1.0
1825 elseif (dtbt + dt_filt - abs(n-nstep)*dtbt > 0.0) then
1826 wt_vel(n) = 1.0 + (dt_filt / dtbt) - abs(n-nstep) ; wt_eta(n) = wt_vel(n)
1827 else
1828 wt_vel(n) = 0.0 ; wt_eta(n) = 0.0
1829 endif
1830 ! This is a simple stepfunction filter.
1831 ! if (n < nstep-nfilter) then ; wt_vel(n) = 0.0 ; else ; wt_vel(n) = 1.0 ; endif
1832 ! wt_eta(n) = wt_vel(n)
1833
1834 ! The rest should not be changed.
1835 sum_wt_vel = sum_wt_vel + wt_vel(n) ; sum_wt_eta = sum_wt_eta + wt_eta(n)
1836 enddo
1837 wt_trans(nstep+nfilter+1) = 0.0 ; wt_accel(nstep+nfilter+1) = 0.0
1838 do n=nstep+nfilter,1,-1
1839 wt_trans(n) = wt_trans(n+1) + wt_eta(n)
1840 wt_accel(n) = wt_accel(n+1) + wt_vel(n)
1841 sum_wt_accel = sum_wt_accel + wt_accel(n) ; sum_wt_trans = sum_wt_trans + wt_trans(n)
1842 enddo
1843 ! Normalize the weights.
1844 i_sum_wt_vel = 1.0 / sum_wt_vel ; i_sum_wt_accel = 1.0 / sum_wt_accel
1845 i_sum_wt_eta = 1.0 / sum_wt_eta ; i_sum_wt_trans = 1.0 / sum_wt_trans
1846 do n=1,nstep+nfilter
1847 wt_vel(n) = wt_vel(n) * i_sum_wt_vel
1848 if (cs%answer_date < 20190101) then
1849 wt_accel2(n) = wt_accel(n)
1850 ! wt_trans(n) = wt_trans(n) * I_sum_wt_trans
1851 else
1852 wt_accel2(n) = wt_accel(n) * i_sum_wt_accel
1853 wt_trans(n) = wt_trans(n) * i_sum_wt_trans
1854 endif
1855 wt_accel(n) = wt_accel(n) * i_sum_wt_accel
1856 wt_eta(n) = wt_eta(n) * i_sum_wt_eta
1857 enddo
1858 if (cs%answer_date < 20190101) then
1859 ! Recalculate the sum of the weights even that they may have been renormalized already.
1860 sum_wt_vel = 0.0 ; sum_wt_eta = 0.0 ; sum_wt_trans = 0.0 ; sum_wt_accel = 0.0
1861 do n=1,nstep+nfilter
1862 sum_wt_vel = sum_wt_vel + wt_vel(n)
1863 sum_wt_eta = sum_wt_eta + wt_eta(n)
1864 sum_wt_accel = sum_wt_accel + wt_accel2(n)
1865 sum_wt_trans = sum_wt_trans + wt_trans(n)
1866 enddo
1867 i_sum_wt_vel = 1.0 / sum_wt_vel ; i_sum_wt_eta = 1.0 / sum_wt_eta
1868 i_sum_wt_accel = 1.0 / sum_wt_accel ; i_sum_wt_trans = 1.0 / sum_wt_trans
1869 else
1870 i_sum_wt_vel = 1.0 ; i_sum_wt_eta = 1.0 ; i_sum_wt_accel = 1.0 ; i_sum_wt_trans = 1.0
1871 endif
1872
1873 ! March the barotropic solver through all of its time steps.
1874 call btstep_timeloop(eta, ubt, vbt, uhbt0, datu, btcl_u, vhbt0, datv, btcl_v, eta_ic, &
1875 eta_pf_1, d_eta_pf, eta_src, dyn_coef_eta, uhbtav, vhbtav, u_accel_bt, v_accel_bt, &
1876 f_4_u, f_4_v, bt_rem_u, bt_rem_v, &
1877 bt_force_u, bt_force_v, cor_ref_u, cor_ref_v, rayleigh_u, rayleigh_v, &
1878 eta_pf, gtot_e, gtot_w, gtot_n, gtot_s, spv_col_avg, dgeo_de, &
1879 eta_sum, eta_wtd, ubt_wtd, vbt_wtd, coru_avg, pfu_avg, ldu_avg, corv_avg, pfv_avg, &
1880 ldv_avg, use_bt_cont, interp_eta_pf, find_etaav, dt, dtbt, nstep, nfilter, &
1881 wt_vel, wt_eta, wt_accel, wt_trans, wt_accel2, adp, cs%BT_OBC, cs, g, ms, gv, us)
1882
1883 if (id_clock_calc > 0) call cpu_clock_end(id_clock_calc)
1884 if (id_clock_calc_post > 0) call cpu_clock_begin(id_clock_calc_post)
1885
1886 if (find_etaav) then ; do j=js,je ; do i=is,ie
1887 etaav(i,j) = eta_sum(i,j) * i_sum_wt_accel
1888 enddo ; enddo ; endif
1889 do j=js-1,je+1 ; do i=is-1,ie+1 ; e_anom(i,j) = 0.0 ; enddo ; enddo
1890 if (interp_eta_pf) then
1891 do j=js,je ; do i=is,ie
1892 e_anom(i,j) = dgeo_de * (0.5 * (eta(i,j) + eta_in(i,j)) - &
1893 (eta_pf_1(i,j) + 0.5*d_eta_pf(i,j)))
1894 enddo ; enddo
1895 else
1896 do j=js,je ; do i=is,ie
1897 e_anom(i,j) = dgeo_de * (0.5 * (eta(i,j) + eta_in(i,j)) - eta_pf(i,j))
1898 enddo ; enddo
1899 endif
1900 if (apply_obcs) then
1901 ! This block of code may be unnecessary because e_anom is only used for accelerations that
1902 ! are then recalculated at OBC points.
1903 if (cs%BT_OBC%u_OBCs_on_PE) then ! copy back the value for u-points on the boundary.
1904 !GOMP parallel do default(shared)
1905 do j=js,je ; do i=is-1,ie
1906 if (cs%BT_OBC%u_OBC_type(i,j) > 0) e_anom(i+1,j) = e_anom(i,j) ! OBC_DIRECTION_E
1907 if (cs%BT_OBC%u_OBC_type(i,j) < 0) e_anom(i,j) = e_anom(i+1,j) ! OBC_DIRECTION_W
1908 enddo ; enddo
1909 endif
1910
1911 if (cs%BT_OBC%v_OBCs_on_PE) then ! copy back the value for v-points on the boundary.
1912 !GOMP parallel do default(shared)
1913 do j=js-1,je ; do i=is,ie
1914 if (cs%BT_OBC%v_OBC_type(i,j) > 0) e_anom(i,j+1) = e_anom(i,j) ! OBC_DIRECTION_N
1915 if (cs%BT_OBC%v_OBC_type(i,j) < 0) e_anom(i,j) = e_anom(i,j+1) ! OBC_DIRECTION_S
1916 enddo ; enddo
1917 endif
1918 endif
1919
1920 ! Note that it is possible that eta_out and eta_in are the same array.
1921 do j=js,je ; do i=is,ie
1922 eta_out(i,j) = eta_wtd(i,j) * i_sum_wt_eta
1923 enddo ; enddo
1924
1925 ! Accumulator is updated at the end of every baroclinic time step.
1926 ! Harmonic analysis will not be performed of a field that is not registered.
1927 if (associated(cs%HA_CSp) .and. find_etaav) then
1928 call ha_accum('ubt', ubt, cs%Time, g, cs%HA_CSp)
1929 call ha_accum('vbt', vbt, cs%Time, g, cs%HA_CSp)
1930 endif
1931
1932 if (id_clock_calc_post > 0) call cpu_clock_end(id_clock_calc_post)
1933 if (id_clock_pass_post > 0) call cpu_clock_begin(id_clock_pass_post)
1934 if (g%nonblocking_updates) then
1935 call start_group_pass(cs%pass_e_anom, g%Domain)
1936 else
1937 if (find_etaav) call do_group_pass(cs%pass_etaav, g%Domain)
1938 call do_group_pass(cs%pass_e_anom, g%Domain)
1939 endif
1940 if (id_clock_pass_post > 0) call cpu_clock_end(id_clock_pass_post)
1941 if (id_clock_calc_post > 0) call cpu_clock_begin(id_clock_calc_post)
1942
1943 ! Find or store the weighted time-mean velocities and transports.
1944 if (cs%answer_date < 20190101) then
1945 do j=js,je ; do i=is-1,ie
1946 cs%ubtav(i,j) = cs%ubtav(i,j) * i_sum_wt_trans
1947 uhbtav(i,j) = uhbtav(i,j) * i_sum_wt_trans
1948 ubt_wtd(i,j) = ubt_wtd(i,j) * i_sum_wt_vel
1949 enddo ; enddo
1950
1951 do j=js-1,je ; do i=is,ie
1952 cs%vbtav(i,j) = cs%vbtav(i,j) * i_sum_wt_trans
1953 vhbtav(i,j) = vhbtav(i,j) * i_sum_wt_trans
1954 vbt_wtd(i,j) = vbt_wtd(i,j) * i_sum_wt_vel
1955 enddo ; enddo
1956 endif
1957
1958 if (cs%use_filter .and. cs%linear_freq_drag) then ! Apply frequency-dependent drag
1959 !$OMP do
1960 do j=js,je ; do i=is-1,ie
1961 u_accel_bt(i,j) = u_accel_bt(i,j) - drag_u(i,j)
1962 enddo ; enddo
1963 !$OMP do
1964 do j=js-1,je ; do i=is,ie
1965 v_accel_bt(i,j) = v_accel_bt(i,j) - drag_v(i,j)
1966 enddo ; enddo
1967
1968 if ((cs%id_LDu_bt > 0) .or. (associated(adp%bt_lwd_u))) then ; do j=js,je ; do i=is-1,ie
1969 ldu_avg(i,j) = ldu_avg(i,j) - drag_u(i,j)
1970 enddo ; enddo ; endif
1971 if ((cs%id_LDv_bt > 0) .or. (associated(adp%bt_lwd_v))) then ; do j=js-1,je ; do i=is,ie
1972 ldv_avg(i,j) = ldv_avg(i,j) - drag_v(i,j)
1973 enddo ; enddo ; endif
1974 endif
1975
1976 if (id_clock_calc_post > 0) call cpu_clock_end(id_clock_calc_post)
1977 if (id_clock_pass_post > 0) call cpu_clock_begin(id_clock_pass_post)
1978 if (g%nonblocking_updates) then
1979 call complete_group_pass(cs%pass_e_anom, g%Domain)
1980 if (find_etaav) call start_group_pass(cs%pass_etaav, g%Domain)
1981 call start_group_pass(cs%pass_ubta_uhbta, g%DoMain)
1982 else
1983 call do_group_pass(cs%pass_ubta_uhbta, g%Domain)
1984 endif
1985 if (id_clock_pass_post > 0) call cpu_clock_end(id_clock_pass_post)
1986 if (id_clock_calc_post > 0) call cpu_clock_begin(id_clock_calc_post)
1987
1988 if (cs%strong_drag .and. cs%rescale_strong_drag) then
1989 do j=js,je ; do i=is-1,ie
1990 if (g%mask2dCu(i,j) * av_rem_u(i,j) > 0.0) &
1991 u_accel_bt(i,j) = u_accel_bt(i,j) * min(bt_rem_u(i,j)**nstep / av_rem_u(i,j), 1.0)
1992 enddo ; enddo
1993 do j=js-1,je ; do i=is,ie
1994 if (g%mask2dCv(i,j) * av_rem_v(i,j) > 0.0) &
1995 v_accel_bt(i,j) = v_accel_bt(i,j) * min(bt_rem_v(i,j)**nstep / av_rem_v(i,j), 1.0)
1996 enddo ; enddo
1997 endif
1998
1999 ! Now calculate each layer's accelerations.
2000 call btstep_layer_accel(dt, u_accel_bt, v_accel_bt, pbce, gtot_e, gtot_w, gtot_n, gtot_s, &
2001 e_anom, g, gv, cs, accel_layer_u, accel_layer_v)
2002
2003 if (apply_obcs) then
2004 ! Correct the accelerations at OBC velocity points, but only in the
2005 ! symmetric-memory computational domain, not in the wide halo regions.
2006 if (cs%BT_OBC%u_OBCs_on_PE) then ; do j=js,je ; do i=is-1,ie
2007 if (cs%BT_OBC%u_OBC_type(i,j) /= 0) then
2008 u_accel_bt(i,j) = (ubt_wtd(i,j) - ubt_st(i,j)) / dt
2009 do k=1,nz ; accel_layer_u(i,j,k) = u_accel_bt(i,j) ; enddo
2010 endif
2011 enddo ; enddo ; endif
2012 if (cs%BT_OBC%v_OBCs_on_PE) then ; do j=js-1,je ; do i=is,ie
2013 if (cs%BT_OBC%v_OBC_type(i,j) /= 0) then
2014 v_accel_bt(i,j) = (vbt_wtd(i,j) - vbt_st(i,j)) / dt
2015 do k=1,nz ; accel_layer_v(i,j,k) = v_accel_bt(i,j) ; enddo
2016 endif
2017 enddo ; enddo ; endif
2018 endif
2019
2020 if (id_clock_calc_post > 0) call cpu_clock_end(id_clock_calc_post)
2021
2022 ! Calculate diagnostic quantities.
2023 if (query_averaging_enabled(cs%diag)) then
2024
2025 if (cs%gradual_BT_ICs) then
2026 do j=js,je ; do i=is-1,ie ; cs%ubt_IC(i,j) = ubt_wtd(i,j) ; enddo ; enddo
2027 do j=js-1,je ; do i=is,ie ; cs%vbt_IC(i,j) = vbt_wtd(i,j) ; enddo ; enddo
2028 endif
2029
2030 ! Calculate various time-averaged barotropic diagnostics.
2031 if (cs%answer_date >= 20190101) then
2032 if (cs%id_PFu_bt > 0) call post_data(cs%id_PFu_bt, pfu_avg, cs%diag)
2033 if (cs%id_PFv_bt > 0) call post_data(cs%id_PFv_bt, pfv_avg, cs%diag)
2034 if (cs%id_Coru_bt > 0) call post_data(cs%id_Coru_bt, coru_avg, cs%diag)
2035 if (cs%id_Corv_bt > 0) call post_data(cs%id_Corv_bt, corv_avg, cs%diag)
2036 if (cs%id_LDu_bt > 0) call post_data(cs%id_LDu_bt, ldu_avg, cs%diag)
2037 if (cs%id_LDv_bt > 0) call post_data(cs%id_LDv_bt, ldv_avg, cs%diag)
2038 else ! if (CS%answer_date < 20190101) then
2039 if (cs%id_PFu_bt > 0) then
2040 do j=js,je ; do i=is-1,ie
2041 pfu_avg(i,j) = pfu_avg(i,j) * i_sum_wt_accel
2042 enddo ; enddo
2043 call post_data(cs%id_PFu_bt, pfu_avg, cs%diag)
2044 endif
2045 if (cs%id_PFv_bt > 0) then
2046 do j=js-1,je ; do i=is,ie
2047 pfv_avg(i,j) = pfv_avg(i,j) * i_sum_wt_accel
2048 enddo ; enddo
2049 call post_data(cs%id_PFv_bt, pfv_avg, cs%diag)
2050 endif
2051 if (cs%id_Coru_bt > 0) then
2052 do j=js,je ; do i=is-1,ie
2053 coru_avg(i,j) = coru_avg(i,j) * i_sum_wt_accel
2054 enddo ; enddo
2055 call post_data(cs%id_Coru_bt, coru_avg, cs%diag)
2056 endif
2057 if (cs%id_Corv_bt > 0) then
2058 do j=js-1,je ; do i=is,ie
2059 corv_avg(i,j) = corv_avg(i,j) * i_sum_wt_accel
2060 enddo ; enddo
2061 call post_data(cs%id_Corv_bt, corv_avg, cs%diag)
2062 endif
2063 endif
2064
2065 ! Diagnostics for time tendency
2066 if (cs%id_ubtdt > 0) then
2067 do j=js,je ; do i=is-1,ie
2068 ubt_dt(i,j) = (ubt_wtd(i,j) - ubt_st(i,j))*idt
2069 enddo ; enddo
2070 call post_data(cs%id_ubtdt, ubt_dt(isdb:iedb,jsd:jed), cs%diag)
2071 endif
2072 if (cs%id_vbtdt > 0) then
2073 do j=js-1,je ; do i=is,ie
2074 vbt_dt(i,j) = (vbt_wtd(i,j) - vbt_st(i,j))*idt
2075 enddo ; enddo
2076 call post_data(cs%id_vbtdt, vbt_dt(isd:ied,jsdb:jedb), cs%diag)
2077 endif
2078
2079 ! Copy decomposed barotropic accelerations to ADp
2080 if (associated(adp%bt_pgf_u)) then
2081 ! Note that CS%IdxCu is 0 at OBC points, so ADp%bt_pgf_u is zeroed out there.
2082 do k=1,nz ; do j=js,je ; do i=is-1,ie
2083 adp%bt_pgf_u(i,j,k) = pfu_avg(i,j) - &
2084 (((pbce(i+1,j,k) - gtot_w(i+1,j)) * e_anom(i+1,j)) - &
2085 ((pbce(i,j,k) - gtot_e(i,j)) * e_anom(i,j))) * cs%IdxCu(i,j)
2086 enddo ; enddo ; enddo
2087 endif
2088 if (associated(adp%bt_pgf_v)) then
2089 ! Note that CS%IdyCv is 0 at OBC points, so ADp%bt_pgf_v is zeroed out there.
2090 do k=1,nz ; do j=js-1,je ; do i=is,ie
2091 adp%bt_pgf_v(i,j,k) = pfv_avg(i,j) - &
2092 (((pbce(i,j+1,k) - gtot_s(i,j+1)) * e_anom(i,j+1)) - &
2093 ((pbce(i,j,k) - gtot_n(i,j)) * e_anom(i,j))) * cs%IdyCv(i,j)
2094 enddo ; enddo ; enddo
2095 endif
2096
2097 if (associated(adp%bt_cor_u)) then ; do j=js,je ; do i=is-1,ie
2098 adp%bt_cor_u(i,j) = coru_avg(i,j)
2099 enddo ; enddo ; endif
2100 if (associated(adp%bt_cor_v)) then ; do j=js-1,je ; do i=is,ie
2101 adp%bt_cor_v(i,j) = corv_avg(i,j)
2102 enddo ; enddo ; endif
2103
2104 if (associated(adp%bt_lwd_u)) then ; do j=js,je ; do i=is-1,ie
2105 adp%bt_lwd_u(i,j) = ldu_avg(i,j)
2106 enddo ; enddo ; endif
2107 if (associated(adp%bt_lwd_v)) then ; do j=js-1,je ; do i=is,ie
2108 adp%bt_lwd_v(i,j) = ldv_avg(i,j)
2109 enddo ; enddo ; endif
2110
2111 if (cs%id_ubtforce > 0) call post_data(cs%id_ubtforce, bt_force_u(isdb:iedb,jsd:jed), cs%diag)
2112 if (cs%id_vbtforce > 0) call post_data(cs%id_vbtforce, bt_force_v(isd:ied,jsdb:jedb), cs%diag)
2113 if (cs%id_uaccel > 0) call post_data(cs%id_uaccel, u_accel_bt(isdb:iedb,jsd:jed), cs%diag)
2114 if (cs%id_vaccel > 0) call post_data(cs%id_vaccel, v_accel_bt(isd:ied,jsdb:jedb), cs%diag)
2115
2116 if (cs%id_eta_cor > 0) call post_data(cs%id_eta_cor, cs%eta_cor, cs%diag)
2117 if (cs%id_eta_bt > 0) call post_data(cs%id_eta_bt, eta_out, cs%diag) ! - G%Z_ref?
2118 if (cs%id_gtotn > 0) call post_data(cs%id_gtotn, gtot_n(isd:ied,jsd:jed), cs%diag)
2119 if (cs%id_gtots > 0) call post_data(cs%id_gtots, gtot_s(isd:ied,jsd:jed), cs%diag)
2120 if (cs%id_gtote > 0) call post_data(cs%id_gtote, gtot_e(isd:ied,jsd:jed), cs%diag)
2121 if (cs%id_gtotw > 0) call post_data(cs%id_gtotw, gtot_w(isd:ied,jsd:jed), cs%diag)
2122 if (cs%id_ubt > 0) call post_data(cs%id_ubt, ubt_wtd(isdb:iedb,jsd:jed), cs%diag)
2123 if (cs%id_vbt > 0) call post_data(cs%id_vbt, vbt_wtd(isd:ied,jsdb:jedb), cs%diag)
2124 if (cs%id_ubtav > 0) call post_data(cs%id_ubtav, cs%ubtav, cs%diag)
2125 if (cs%id_vbtav > 0) call post_data(cs%id_vbtav, cs%vbtav, cs%diag)
2126 if (cs%id_visc_rem_u > 0) call post_data(cs%id_visc_rem_u, visc_rem_u, cs%diag)
2127 if (cs%id_visc_rem_v > 0) call post_data(cs%id_visc_rem_v, visc_rem_v, cs%diag)
2128
2129 if (cs%id_frhatu > 0) call post_data(cs%id_frhatu, cs%frhatu, cs%diag)
2130 if (cs%id_uhbt > 0) call post_data(cs%id_uhbt, uhbtav, cs%diag)
2131 if (cs%id_frhatv > 0) call post_data(cs%id_frhatv, cs%frhatv, cs%diag)
2132 if (cs%id_vhbt > 0) call post_data(cs%id_vhbt, vhbtav, cs%diag)
2133 if (cs%id_uhbt0 > 0) call post_data(cs%id_uhbt0, uhbt0(isdb:iedb,jsd:jed), cs%diag)
2134 if (cs%id_vhbt0 > 0) call post_data(cs%id_vhbt0, vhbt0(isd:ied,jsdb:jedb), cs%diag)
2135
2136 if (cs%id_frhatu1 > 0) call post_data(cs%id_frhatu1, cs%frhatu1, cs%diag)
2137 if (cs%id_frhatv1 > 0) call post_data(cs%id_frhatv1, cs%frhatv1, cs%diag)
2138
2139 if (cs%id_bt_rem_u > 0) call post_data(cs%id_bt_rem_u, bt_rem_u(isdb:iedb,jsd:jed), cs%diag)
2140 if (cs%id_bt_rem_v > 0) call post_data(cs%id_bt_rem_v, bt_rem_v(isd:ied,jsdb:jedb), cs%diag)
2141 if (cs%id_etaPF_anom > 0) call post_data(cs%id_etaPF_anom, e_anom(isd:ied,jsd:jed), cs%diag)
2142
2143 if (use_bt_cont) then
2144 if (cs%id_BTC_FA_u_EE > 0) call post_data(cs%id_BTC_FA_u_EE, bt_cont%FA_u_EE, cs%diag)
2145 if (cs%id_BTC_FA_u_E0 > 0) call post_data(cs%id_BTC_FA_u_E0, bt_cont%FA_u_E0, cs%diag)
2146 if (cs%id_BTC_FA_u_W0 > 0) call post_data(cs%id_BTC_FA_u_W0, bt_cont%FA_u_W0, cs%diag)
2147 if (cs%id_BTC_FA_u_WW > 0) call post_data(cs%id_BTC_FA_u_WW, bt_cont%FA_u_WW, cs%diag)
2148 if (cs%id_BTC_uBT_EE > 0) call post_data(cs%id_BTC_uBT_EE, bt_cont%uBT_EE, cs%diag)
2149 if (cs%id_BTC_uBT_WW > 0) call post_data(cs%id_BTC_uBT_WW, bt_cont%uBT_WW, cs%diag)
2150 if (cs%id_BTC_FA_u_rat0 > 0) then
2151 tmp_u(:,:) = 0.0
2152 do j=js,je ; do i=is-1,ie
2153 if ((g%mask2dCu(i,j) > 0.0) .and. (bt_cont%FA_u_W0(i,j) > 0.0)) then
2154 tmp_u(i,j) = (bt_cont%FA_u_E0(i,j)/ bt_cont%FA_u_W0(i,j))
2155 else
2156 tmp_u(i,j) = 1.0
2157 endif
2158 enddo ; enddo
2159 call post_data(cs%id_BTC_FA_u_rat0, tmp_u, cs%diag)
2160 endif
2161 if (cs%id_BTC_FA_v_NN > 0) call post_data(cs%id_BTC_FA_v_NN, bt_cont%FA_v_NN, cs%diag)
2162 if (cs%id_BTC_FA_v_N0 > 0) call post_data(cs%id_BTC_FA_v_N0, bt_cont%FA_v_N0, cs%diag)
2163 if (cs%id_BTC_FA_v_S0 > 0) call post_data(cs%id_BTC_FA_v_S0, bt_cont%FA_v_S0, cs%diag)
2164 if (cs%id_BTC_FA_v_SS > 0) call post_data(cs%id_BTC_FA_v_SS, bt_cont%FA_v_SS, cs%diag)
2165 if (cs%id_BTC_vBT_NN > 0) call post_data(cs%id_BTC_vBT_NN, bt_cont%vBT_NN, cs%diag)
2166 if (cs%id_BTC_vBT_SS > 0) call post_data(cs%id_BTC_vBT_SS, bt_cont%vBT_SS, cs%diag)
2167 if (cs%id_BTC_FA_v_rat0 > 0) then
2168 tmp_v(:,:) = 0.0
2169 do j=js-1,je ; do i=is,ie
2170 if ((g%mask2dCv(i,j) > 0.0) .and. (bt_cont%FA_v_S0(i,j) > 0.0)) then
2171 tmp_v(i,j) = (bt_cont%FA_v_N0(i,j)/ bt_cont%FA_v_S0(i,j))
2172 else
2173 tmp_v(i,j) = 1.0
2174 endif
2175 enddo ; enddo
2176 call post_data(cs%id_BTC_FA_v_rat0, tmp_v, cs%diag)
2177 endif
2178 if (cs%id_BTC_FA_h_rat0 > 0) then
2179 tmp_h(:,:) = 0.0
2180 do j=js,je ; do i=is,ie
2181 tmp_h(i,j) = 1.0
2182 if ((g%mask2dCu(i,j) > 0.0) .and. (bt_cont%FA_u_W0(i,j) > 0.0) .and. (bt_cont%FA_u_E0(i,j) > 0.0)) then
2183 if (bt_cont%FA_u_W0(i,j) > bt_cont%FA_u_E0(i,j)) then
2184 tmp_h(i,j) = max(tmp_h(i,j), (bt_cont%FA_u_W0(i,j)/ bt_cont%FA_u_E0(i,j)))
2185 else
2186 tmp_h(i,j) = max(tmp_h(i,j), (bt_cont%FA_u_E0(i,j)/ bt_cont%FA_u_W0(i,j)))
2187 endif
2188 endif
2189 if ((g%mask2dCu(i-1,j) > 0.0) .and. (bt_cont%FA_u_W0(i-1,j) > 0.0) .and. (bt_cont%FA_u_E0(i-1,j) > 0.0)) then
2190 if (bt_cont%FA_u_W0(i-1,j) > bt_cont%FA_u_E0(i-1,j)) then
2191 tmp_h(i,j) = max(tmp_h(i,j), (bt_cont%FA_u_W0(i-1,j)/ bt_cont%FA_u_E0(i-1,j)))
2192 else
2193 tmp_h(i,j) = max(tmp_h(i,j), (bt_cont%FA_u_E0(i-1,j)/ bt_cont%FA_u_W0(i-1,j)))
2194 endif
2195 endif
2196 if ((g%mask2dCv(i,j) > 0.0) .and. (bt_cont%FA_v_S0(i,j) > 0.0) .and. (bt_cont%FA_v_N0(i,j) > 0.0)) then
2197 if (bt_cont%FA_v_S0(i,j) > bt_cont%FA_v_N0(i,j)) then
2198 tmp_h(i,j) = max(tmp_h(i,j), (bt_cont%FA_v_S0(i,j)/ bt_cont%FA_v_N0(i,j)))
2199 else
2200 tmp_h(i,j) = max(tmp_h(i,j), (bt_cont%FA_v_N0(i,j)/ bt_cont%FA_v_S0(i,j)))
2201 endif
2202 endif
2203 if ((g%mask2dCv(i,j-1) > 0.0) .and. (bt_cont%FA_v_S0(i,j-1) > 0.0) .and. (bt_cont%FA_v_N0(i,j-1) > 0.0)) then
2204 if (bt_cont%FA_v_S0(i,j-1) > bt_cont%FA_v_N0(i,j-1)) then
2205 tmp_h(i,j) = max(tmp_h(i,j), (bt_cont%FA_v_S0(i,j-1)/ bt_cont%FA_v_N0(i,j-1)))
2206 else
2207 tmp_h(i,j) = max(tmp_h(i,j), (bt_cont%FA_v_N0(i,j-1)/ bt_cont%FA_v_S0(i,j-1)))
2208 endif
2209 endif
2210 enddo ; enddo
2211 call post_data(cs%id_BTC_FA_h_rat0, tmp_h, cs%diag)
2212 endif
2213 endif
2214
2215 if (cs%id_SSH_u_OBC > 0) call post_data(cs%id_SSH_u_OBC, cs%BT_OBC%SSH_outer_u(isdb:iedb,jsd:jed), cs%diag)
2216 if (cs%id_SSH_v_OBC > 0) call post_data(cs%id_SSH_v_OBC, cs%BT_OBC%SSH_outer_v(isd:ied,jsdb:jedb), cs%diag)
2217 if (cs%id_ubt_OBC > 0) call post_data(cs%id_ubt_OBC, cs%BT_OBC%ubt_outer(isdb:iedb,jsd:jed), cs%diag)
2218 if (cs%id_vbt_OBC > 0) call post_data(cs%id_vbt_OBC, cs%BT_OBC%vbt_outer(isd:ied,jsdb:jedb), cs%diag)
2219 else
2220 if (cs%id_frhatu1 > 0) cs%frhatu1(:,:,:) = cs%frhatu(:,:,:)
2221 if (cs%id_frhatv1 > 0) cs%frhatv1(:,:,:) = cs%frhatv(:,:,:)
2222 endif
2223
2224 if (associated(adp%diag_hfrac_u)) then
2225 do k=1,nz ; do j=js,je ; do i=is-1,ie
2226 adp%diag_hfrac_u(i,j,k) = cs%frhatu(i,j,k)
2227 enddo ; enddo ; enddo
2228 endif
2229 if (associated(adp%diag_hfrac_v)) then
2230 do k=1,nz ; do j=js-1,je ; do i=is,ie
2231 adp%diag_hfrac_v(i,j,k) = cs%frhatv(i,j,k)
2232 enddo ; enddo ; enddo
2233 endif
2234
2235 if (use_bt_cont .and. associated(adp%diag_hu)) then
2236 do k=1,nz ; do j=js,je ; do i=is-1,ie
2237 adp%diag_hu(i,j,k) = bt_cont%h_u(i,j,k)
2238 enddo ; enddo ; enddo
2239 endif
2240 if (use_bt_cont .and. associated(adp%diag_hv)) then
2241 do k=1,nz ; do j=js-1,je ; do i=is,ie
2242 adp%diag_hv(i,j,k) = bt_cont%h_v(i,j,k)
2243 enddo ; enddo ; enddo
2244 endif
2245 if (associated(adp%visc_rem_u)) then
2246 do k=1,nz ; do j=js,je ; do i=is-1,ie
2247 adp%visc_rem_u(i,j,k) = visc_rem_u(i,j,k)
2248 enddo ; enddo ; enddo
2249 endif
2250 if (associated(adp%visc_rem_v)) then
2251 do k=1,nz ; do j=js-1,je ; do i=is,ie
2252 adp%visc_rem_v(i,j,k) = visc_rem_v(i,j,k)
2253 enddo ; enddo ; enddo
2254 endif
2255
2256 if (g%nonblocking_updates) then
2257 if (find_etaav) call complete_group_pass(cs%pass_etaav, g%Domain)
2258 call complete_group_pass(cs%pass_ubta_uhbta, g%Domain)
2259 endif
2260
2261 deallocate(wt_vel, wt_eta, wt_trans, wt_accel, wt_accel2)
2262
2263end subroutine btstep
2264
2265!> Update the barotropic solver through multiple time steps.
2266subroutine btstep_timeloop(eta, ubt, vbt, uhbt0, Datu, BTCL_u, vhbt0, Datv, BTCL_v, eta_IC, &
2267 eta_PF_1, d_eta_PF, eta_src, dyn_coef_eta, uhbtav, vhbtav, u_accel_bt, v_accel_bt, &
2268 f_4_u, f_4_v, bt_rem_u, bt_rem_v, &
2269 BT_force_u, BT_force_v, Cor_ref_u, Cor_ref_v, Rayleigh_u, Rayleigh_v, &
2270 eta_PF, gtot_E, gtot_W, gtot_N, gtot_S, SpV_col_avg, dgeo_de, &
2271 eta_sum, eta_wtd, ubt_wtd, vbt_wtd, Coru_avg, PFu_avg, LDu_avg, Corv_avg, PFv_avg, &
2272 LDv_avg, use_BT_cont, interp_eta_PF, find_etaav, dt, dtbt, nstep, nfilter, &
2273 wt_vel, wt_eta, wt_accel, wt_trans, wt_accel2, ADp, BT_OBC, CS, G, MS, GV, US)
2274
2275 type(barotropic_cs), intent(inout) :: CS !< Barotropic control structure
2276 type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure (inout to allow for halo updates)
2277 type(memory_size_type), intent(in) :: MS !< A type that describes the memory sizes of
2278 !! the argument arrays.
2279 real, dimension(SZIW_(CS),SZJW_(CS)), target, intent(inout) :: &
2280 eta !< The barotropic free surface height anomaly or total column mass [H ~> m or kg m-2]
2281 real, dimension(SZIBW_(CS),SZJW_(CS)), intent(inout) :: &
2282 ubt !< The zonal barotropic velocity [L T-1 ~> m s-1]
2283 real, dimension(SZIW_(CS),SZJBW_(CS)), intent(inout) :: &
2284 vbt !< The meridional barotropic velocity [L T-1 ~> m s-1]
2285 real, dimension(SZIBW_(CS),SZJW_(CS)), intent(in) :: &
2286 uhbt0 !< The difference between the sum of the layer zonal thickness flux and the
2287 !! barotropic thickness flux using the same velocity [H L2 T-1 ~> m3 s-1 or kg s-1]
2288 real, dimension(SZIBW_(CS),SZJW_(CS)), intent(inout) :: &
2289 Datu !< Basin depth at u-velocity grid points times the y-grid spacing [H L ~> m2 or kg m-1]
2290 type(local_bt_cont_u_type), dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: &
2291 BTCL_u !< Structure of information used for a dynamic estimate of the face areas at u-points.
2292 real, dimension(SZIW_(CS),SZJBW_(CS)), intent(in) :: &
2293 vhbt0 !< The difference between the sum of the layer meridional thickness flux and the
2294 !! barotropic thickness flux using the same velocity [H L2 T-1 ~> m3 s-1 or kg s-1]
2295 real, dimension(SZIW_(CS),SZJBW_(CS)), intent(inout) :: &
2296 Datv !< Basin depth at v-velocity grid points times the x-grid spacing [H L ~> m2 or kg m-1]
2297 type(local_bt_cont_v_type), dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: &
2298 BTCL_v !< Structure of information used for a dynamic estimate of the face areas at v-points
2299 real, dimension(SZIW_(CS),SZJW_(CS)), intent(in) :: &
2300 eta_IC !< A local copy of the initial 2-D eta field (eta_in) [H ~> m or kg m-2]
2301 real, dimension(SZIW_(CS),SZJW_(CS)), intent(in) :: &
2302 eta_PF_1 !< The initial value of eta_PF, when interp_eta_PF is true [H ~> m or kg m-2]
2303 real, dimension(SZIW_(CS),SZJW_(CS)), intent(in) :: &
2304 d_eta_PF !< The change in eta_PF over the barotropic time stepping when
2305 !! interp_eta_PF is true [H ~> m or kg m-2]
2306 real, dimension(SZIW_(CS),SZJW_(CS)), intent(in) :: &
2307 eta_src !< The source of eta per barotropic timestep [H ~> m or kg m-2]
2308 real, dimension(SZIW_(CS),SZJW_(CS)), intent(in) :: &
2309 dyn_coef_eta !< The coefficient relating the changes in eta to the dynamic surface pressure
2310 !! under rigid ice [L2 T-2 H-1 ~> m s-2 or m4 s-2 kg-1].
2311 real, dimension(SZIB_(G),SZJ_(G)), intent(out) :: &
2312 uhbtav !< the barotropic zonal volume or mass fluxes averaged through the barotropic
2313 !! steps [H L2 T-1 ~> m3 s-1 or kg s-1].
2314 real, dimension(SZI_(G),SZJB_(G)), intent(out) :: &
2315 vhbtav !< the barotropic meridional volume or mass fluxes averaged through the barotropic
2316 !! steps [H L2 T-1 ~> m3 s-1 or kg s-1].
2317 real, dimension(SZIBW_(CS),SZJW_(CS)), intent(inout) :: &
2318 u_accel_bt !! The difference between the zonal acceleration from the
2319 !< barotropic calculation and BT_force_v [L T-2 ~> m s-2].
2320 real, dimension(SZIW_(CS),SZJBW_(CS)), intent(inout) :: &
2321 v_accel_bt !< The difference between the meridional acceleration from the
2322 !! barotropic calculation and BT_force_v [L T-2 ~> m s-2].
2323 real, dimension(4,SZIBW_(CS),SZJW_(CS)), intent(inout) :: &
2324 f_4_u !< The terms giving the contribution to the Coriolis acceleration at a zonal
2325 !! velocity point from the neighboring meridional velocity anomalies [T-1 ~> s-1].
2326 !! These are the products of thicknesses at v points and appropriately staggered
2327 !! averaged pseudo potential vorticities, but with sufficiently smooth topography
2328 !! they are approximately f / 4. The 4 values on the innermost loop are for
2329 !! v-velocities to the southwest, southeast, northwest and northeast.
2330 real, dimension(4,SZIW_(CS),SZJBW_(CS)), intent(in) :: &
2331 f_4_v !< The terms giving the contribution to the Coriolis acceleration at a meridional
2332 !! velocity point from the neighboring meridional velocity anomalies [T-1 ~> s-1].
2333 !! These are the products of thicknesses at u points and appropriately staggered
2334 !! averaged pseudo potential vorticities, but with sufficiently smooth topography
2335 !! they are approximately f / 4. The 4 values on the innermost loop are for
2336 !! u-velocities to the southwest, southeast, northwest and northeast.
2337 real, dimension(SZIBW_(CS),SZJW_(CS)), intent(in) :: &
2338 bt_rem_u !< The fraction of the barotropic zonal velocity that remains after a time step,
2339 !! the rest being lost to bottom drag [nondim]. bt_rem_v is between 0 and 1.
2340 real, dimension(SZIW_(CS),SZJBW_(CS)), intent(in) :: &
2341 bt_rem_v !< The fraction of the barotropic meridional velocity that remains after a time step,
2342 !! the rest being lost to bottom drag [nondim]. bt_rem_v is between 0 and 1.
2343 real, dimension(SZIBW_(CS),SZJW_(CS)), intent(in) :: &
2344 BT_force_u !< The vertical average of all of the v-accelerations that are
2345 !! not explicitly included in the barotropic equation [L T-2 ~> m s-2]
2346 real, dimension(SZIW_(CS),SZJBW_(CS)), intent(in) :: &
2347 BT_force_v !< The vertical average of all of the v-accelerations that are
2348 !! not explicitly included in the barotropic equation [L T-2 ~> m s-2]
2349 real, dimension(SZIBW_(CS),SZJW_(CS)), intent(in) :: &
2350 Cor_ref_u !< The meridional barotropic Coriolis acceleration due
2351 !! to the reference velocities [L T-2 ~> m s-2].
2352 real, dimension(SZIW_(CS),SZJBW_(CS)), intent(in) :: &
2353 Cor_ref_v !< The meridional barotropic Coriolis acceleration due
2354 !! to the reference velocities [L T-2 ~> m s-2].
2355 real, dimension(SZIBW_(CS),SZJW_(CS)), intent(in) :: &
2356 Rayleigh_u !< A Rayleigh drag timescale operating at u-points for drag parameterizations
2357 !! that introduced directly into the barotropic solver rather than coming
2358 !! in via the visc_rem_u arrays from the layered equations [T-1 ~> s-1]
2359 real, dimension(SZIW_(CS),SZJBW_(CS)), intent(in) :: &
2360 Rayleigh_v !< A Rayleigh drag timescale operating at v-points for drag parameterizations
2361 !! that introduced directly into the barotropic solver rather than coming
2362 !! in via the visc_rem_v arrays from the layered equations [T-1 ~> s-1]
2363 real, dimension(SZIW_(CS),SZJW_(CS)), intent(inout) :: &
2364 eta_PF !< The 2-D eta field (either SSH anomaly or column mass) that was used to
2365 !! calculate the input pressure gradient accelerations [H ~> m or kg m-2]
2366 real, dimension(SZIW_(CS),SZJW_(CS)), intent(in) :: &
2367 gtot_E !< The effective total reduced gravity used to relate free surface height
2368 !! deviations to pressure forces (including GFS and baroclinic contributions)
2369 !! in the barotropic momentum equations half a grid-point to the east of a
2370 !! thickness point [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2].
2371 real, dimension(SZIW_(CS),SZJW_(CS)), intent(in) :: &
2372 gtot_W !< The effective total reduced gravity used to relate free surface height
2373 !! deviations to pressure forces (including GFS and baroclinic contributions)
2374 !! in the barotropic momentum equations half a grid-point to the west of a
2375 !! thickness point [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2]
2376 !! (See Hallberg, J Comp Phys 1997 for a discussion of gtot_E and gtot_W.)
2377 real, dimension(SZIW_(CS),SZJW_(CS)), intent(in) :: &
2378 gtot_N !< The effective total reduced gravity used to relate free surface height
2379 !! deviations to pressure forces (including GFS and baroclinic contributions)
2380 !! in the barotropic momentum equations half a grid-point to the north of a
2381 !! thickness point [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2]
2382 real, dimension(SZIW_(CS),SZJW_(CS)), intent(in) :: &
2383 gtot_S !< The effective total reduced gravity used to relate free surface height
2384 !! deviations to pressure forces (including GFS and baroclinic contributions)
2385 !! in the barotropic momentum equations half a grid-point to the south of a
2386 !! thickness point [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2]
2387 !! (See Hallberg, J Comp Phys 1997 for a discussion of gtot_E and gtot_W.)
2388 real, dimension(SZIW_(MS),SZJW_(MS)), intent(in) :: &
2389 SpV_col_avg !< The column average specific volume [R-1 ~> m3 kg-1]
2390 real, intent(in) :: dgeo_de !< The constant of proportionality between geopotential and
2391 !! sea surface height [nondim]. It is of order 1, but for stability this
2392 !! may be made larger than the physical problem would suggest.
2393 real, dimension(SZIW_(CS),SZJW_(CS)), intent(out) :: &
2394 eta_sum !< eta summed across the timesteps [H ~> m or kg m-2]
2395 real, dimension(SZIW_(CS),SZJW_(CS)), intent(out) :: &
2396 eta_wtd !< A weighted estimate used to calculate eta_out [H ~> m or kg m-2]
2397 real, dimension(SZIB_(G),SZJ_(G)), intent(out) :: &
2398 ubt_wtd !< A weighted sum used to find the filtered final ubt [L T-1 ~> m s-1]
2399 real, dimension(SZI_(G),SZJB_(G)), intent(out) :: &
2400 vbt_wtd !< A weighted sum used to find the filtered final vbt [L T-1 ~> m s-1]
2401 real, dimension(SZIB_(G),SZJ_(G)), intent(out) :: &
2402 Coru_avg !< The average zonal barotropic Coriolis acceleration [L T-2 ~> m s-2]
2403 real, dimension(SZIB_(G),SZJ_(G)), intent(out) :: &
2404 PFu_avg !< The average zonal barotropic pressure gradient force [L T-2 ~> m s-2]
2405 real, dimension(SZIB_(G),SZJ_(G)), intent(out) :: &
2406 LDu_avg !< The average zonal barotropic linear wave drag acceleration [L T-2 ~> m s-2]
2407 real, dimension(SZI_(G),SZJB_(G)), intent(out) :: &
2408 Corv_avg !< The average meridional barotropic Coriolis acceleration [L T-2 ~> m s-2]
2409 real, dimension(SZI_(G),SZJB_(G)), intent(out) :: &
2410 PFv_avg !< The average meridional barotropic pressure gradient force [L T-2 ~> m s-2]
2411 real, dimension(SZI_(G),SZJB_(G)), intent(out) :: &
2412 LDv_avg !< The average meridional barotropic linear wave drag acceleration [L T-2 ~> m s-2]
2413 logical, intent(in) :: use_BT_cont !< If true, use the information in the bt_cont_types to
2414 !! calculate the mass transports
2415 logical, intent(in) :: interp_eta_PF !< If true, interpolate the reference value of eta used
2416 !! to calculate the pressure force with time.
2417 logical, intent(in) :: find_etaav !< If true, diagnose the time mean value of eta
2418 real, intent(in) :: dt !< The time increment to integrate over [T ~> s]
2419 real, intent(in) :: dtbt !< The barotropic time step [T ~> s]
2420 integer, intent(in) :: nstep !< The number of barotropic time steps to take to cover the specified time interval
2421 integer, intent(in) :: nfilter !< The number of extra barotropic steps to take to allow for time filtering
2422 real, dimension(nstep+nfilter), intent(in) :: &
2423 wt_vel !< The raw or relative weights of each of the barotropic timesteps
2424 !! in determining the average velocities [nondim]
2425 real, dimension(nstep+nfilter), intent(in) :: &
2426 wt_eta !< The raw or relative weights of each of the barotropic timesteps
2427 !! in determining the average eta [nondim]
2428 real, dimension(nstep+nfilter+1), intent(in) :: &
2429 wt_accel !< The raw or relative weights of each of the barotropic timesteps
2430 !! in determining the average accelerations [nondim]
2431 real, dimension(nstep+nfilter+1), intent(in) :: &
2432 wt_trans !< The raw or relative weights of each of the barotropic timesteps
2433 !! in determining the average transports [nondim]
2434 real, dimension(nstep+nfilter+1), intent(in) :: &
2435 wt_accel2 !< Potentially un-normalized relative weights of each of the
2436 !! barotropic timesteps in determining the average accelerations [nondim]
2437 type(accel_diag_ptrs), pointer :: ADp !< Acceleration diagnostic pointers
2438 type(bt_obc_type), intent(in) :: BT_OBC !< A structure with the private barotropic arrays
2439 !! related to the open boundary conditions,
2440 !! with time evolving data stored via set_up_BT_OBC
2441 type(verticalgrid_type), intent(in) :: GV !< The ocean's vertical grid structure
2442 type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
2443
2444 ! Local variables
2445 real, dimension(SZIBW_(CS),SZJW_(CS)) :: &
2446 uhbt, & ! The zonal barotropic thickness fluxes [H L2 T-1 ~> m3 s-1 or kg s-1]
2447 ubt_prev, & ! The starting value of ubt in a barotropic step [L T-1 ~> m s-1]
2448 ubt_trans, & ! The latest value of ubt used for a transport [L T-1 ~> m s-1]
2449 PFu, & ! The zonal pressure force acceleration [L T-2 ~> m s-2]
2450 Cor_u, & ! The zonal Coriolis acceleration [L T-2 ~> m s-2]
2451 ubt_int, & ! The running time integral of ubt over the time steps [L ~> m]
2452 uhbt_int, & ! The running time integral of uhbt over the time steps [H L2 ~> m3 or kg]
2453 ubt_int_prev, & ! Previous value of time-integrated velocity stored for OBCs [L ~> m]
2454 uhbt_int_prev ! Previous value of time-integrated transport stored for integral_BT_cont [H L2 ~> m3 or kg]
2455 real, dimension(SZIW_(CS),SZJBW_(CS)) :: &
2456 vhbt, & ! The meridional barotropic thickness fluxes [H L2 T-1 ~> m3 s-1 or kg s-1]
2457 vbt_prev, & ! The starting value of vbt in a barotropic step [L T-1 ~> m s-1]
2458 vbt_trans, & ! The latest value of vbt used for a transport [L T-1 ~> m s-1]
2459 PFv, & ! The meridional pressure force acceleration [L T-2 ~> m s-2]
2460 Cor_v, & ! The meridional Coriolis acceleration [L T-2 ~> m s-2]
2461 vbt_int, & ! The running time integral of vbt over the time steps [L ~> m]
2462 vhbt_int, & ! The running time integral of vhbt over the time steps [H L2 ~> m3 or kg]
2463 vbt_int_prev, & ! Previous value of time-integrated velocity stored for OBCs [L ~> m]
2464 vhbt_int_prev ! Previous value of time-integrated transport stored for integral_BT_cont [H L2 ~> m3 or kg]
2465 real, target, dimension(SZIW_(CS),SZJW_(CS)) :: &
2466 eta_pred ! A predictor value of eta [H ~> m or kg m-2] like eta
2467 real, dimension(SZIW_(CS),SZJW_(CS)) :: &
2468 p_surf_dyn, & !< A dynamic surface pressure under rigid ice [L2 T-2 ~> m2 s-2]
2469 cfl_ltd_vol !< The volume available after removing sinks used to limit uhbt_int and vhbt_int [H L2 ~> m3 or kg]
2470 real, dimension(SZI_(G),SZJ_(G)) :: &
2471 eta_anom_PF ! The eta anomalies used to find the pressure force anomalies [H ~> m or kg m-2]
2472 real :: wt_end ! The weighting of the final value of eta_PF [nondim]
2473 real :: Instep ! The inverse of the number of barotropic time steps to take [nondim]
2474 real :: trans_wt1, trans_wt2 ! The weights used to compute ubt_trans and vbt_trans [nondim]
2475 real :: Idtbt ! The inverse of the barotropic time step [T-1 ~> s-1]
2476 type(time_type) :: &
2477 time_bt_start, & ! The starting time of the barotropic steps.
2478 time_step_end, & ! The end time of a barotropic step.
2479 time_end_in ! The end time for diagnostics when this routine started.
2480 real :: dtbt_diag ! The nominal barotropic time step used in hifreq diagnostics [T ~> s]
2481 ! dtbt_diag = dt/(nstep+nfilter)
2482 real :: time_int_in ! The diagnostics' time interval when this routine started [s]
2483 real :: be_proj ! The fractional amount by which velocities are projected
2484 ! when project_velocity is true [nondim]. For now be_proj is set
2485 ! to equal bebt, as they have similar roles and meanings.
2486 real :: eta_cor_multiplier ! Increases the rate of applying CS%eta_cor so that the mass
2487 ! source is all used up by the beginning of the filtering [nondim]
2488 real :: eta_acc ! Change due to divergence of mass transport [H ~> m or kg m-2]
2489 logical :: do_hifreq_output ! If true, output occurs every barotropic step.
2490 logical :: do_ave ! If true, diagnostics are enabled on this step.
2491 logical :: evolving_face_areas
2492 logical :: v_first ! If true, update the v-velocity first with the present loop iteration
2493 logical :: integral_BT_cont ! If true, update the barotropic continuity equation directly
2494 ! from the initial condition using the time-integrated barotropic velocity.
2495 character(len=200) :: mesg
2496 integer :: isv, iev, jsv, jev ! The valid array size at the end of a step.
2497 integer :: isvf, ievf, jsvf, jevf ! The fullest range of array indices that could be used.
2498 integer :: num_cycles ! The number of timesteps before a halo update is needed.
2499 integer :: stencil ! The stencil size of the algorithm, often 1 or 2.
2500 integer :: err_count ! A counter to limit the volume of error messages written to stdout.
2501 integer :: i, j, n, is, ie, js, je
2502 integer :: debug_halo ! The halo size to use for debugging checksums
2503 integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB
2504
2505 is = g%isc ; ie = g%iec ; js = g%jsc ; je = g%jec
2506 isd = g%isd ; ied = g%ied ; jsd = g%jsd ; jed = g%jed
2507 isdb = g%IsdB ; iedb = g%IedB ; jsdb = g%JsdB ; jedb = g%JedB
2508 err_count = 0
2509
2510 ! Figure out the fullest arrays that could be updated.
2511 stencil = max(1, cs%min_stencil)
2512 if ((.not.use_bt_cont) .and. cs%Nonlinear_continuity .and. (cs%Nonlin_cont_update_period > 0)) &
2513 stencil = max(2, cs%min_stencil)
2514
2515 num_cycles = 1
2516 if (cs%use_wide_halos) &
2517 num_cycles = min((is-cs%isdw) / stencil, (js-cs%jsdw) / stencil)
2518 isvf = is - (num_cycles-1)*stencil ; ievf = ie + (num_cycles-1)*stencil
2519 jsvf = js - (num_cycles-1)*stencil ; jevf = je + (num_cycles-1)*stencil
2520
2521 integral_bt_cont = use_bt_cont .and. cs%integral_BT_cont
2522 evolving_face_areas = (.not.use_bt_cont) .and. cs%Nonlinear_continuity .and. &
2523 (cs%Nonlin_cont_update_period > 0)
2524 instep = 1.0 / real(nstep)
2525 idtbt = 1.0 / dtbt
2526
2527 !--- setup the weight when computing vbt_trans and ubt_trans
2528 if (cs%BT_project_velocity) then
2529 be_proj = cs%bebt
2530 trans_wt1 = (1.0 + be_proj) ; trans_wt2 = -be_proj
2531 else
2532 trans_wt1 = cs%bebt ; trans_wt2 = (1.0-cs%bebt)
2533 endif
2534
2535 ! Manage diagnostics
2536 do_ave = query_averaging_enabled(cs%diag) .and. &
2537 ((cs%id_PFu_bt > 0) .or. (cs%id_Coru_bt > 0) .or. (cs%id_LDu_bt > 0) .or. &
2538 (cs%id_PFv_bt > 0) .or. (cs%id_Corv_bt > 0) .or. (cs%id_LDv_bt > 0) .or. &
2539 associated(adp%bt_pgf_u) .or. associated(adp%bt_cor_u) .or. associated(adp%bt_lwd_u) .or. &
2540 associated(adp%bt_pgf_v) .or. associated(adp%bt_cor_v) .or. associated(adp%bt_lwd_v))
2541
2542 do_hifreq_output = .false.
2543 if ((cs%id_ubt_hifreq > 0) .or. (cs%id_vbt_hifreq > 0) .or. &
2544 (cs%id_eta_hifreq > 0) .or. (cs%id_eta_pred_hifreq > 0) .or. (cs%id_etaPF_hifreq > 0) .or. &
2545 (cs%id_uhbt_hifreq > 0) .or. (cs%id_vhbt_hifreq > 0)) &
2546 do_hifreq_output = query_averaging_enabled(cs%diag, time_int_in, time_end_in)
2547 if (do_hifreq_output) then
2548 time_bt_start = time_end_in - real_to_time(dt, unscale=us%T_to_s)
2549 dtbt_diag = dt/(nstep+nfilter) ! Note that this is not dtbt.
2550 endif
2551
2552 ! Zero out the arrays for various time-averaged quantities.
2553 if (find_etaav) then
2554 !$OMP do
2555 do j=jsvf-1,jevf+1 ; do i=isvf-1,ievf+1
2556 eta_sum(i,j) = 0.0 ; eta_wtd(i,j) = 0.0
2557 enddo ; enddo
2558 else
2559 !$OMP do
2560 do j=jsvf-1,jevf+1 ; do i=isvf-1,ievf+1
2561 eta_wtd(i,j) = 0.0
2562 enddo ; enddo
2563 endif
2564 !$OMP do
2565 do j=js,je ; do i=is-1,ie
2566 cs%ubtav(i,j) = 0.0 ; uhbtav(i,j) = 0.0
2567 pfu_avg(i,j) = 0.0 ; coru_avg(i,j) = 0.0
2568 ldu_avg(i,j) = 0.0 ; ubt_wtd(i,j) = 0.0
2569 enddo ; enddo
2570 !$OMP do
2571 do j=jsvf-1,jevf+1 ; do i=isvf-1,ievf
2572 ubt_trans(i,j) = 0.0
2573 enddo ; enddo
2574 !$OMP do
2575 do j=js-1,je ; do i=is,ie
2576 cs%vbtav(i,j) = 0.0 ; vhbtav(i,j) = 0.0
2577 pfv_avg(i,j) = 0.0 ; corv_avg(i,j) = 0.0
2578 ldv_avg(i,j) = 0.0 ; vbt_wtd(i,j) = 0.0
2579 enddo ; enddo
2580 !$OMP do
2581 do j=jsvf-1,jevf ; do i=isvf-1,ievf+1
2582 vbt_trans(i,j) = 0.0
2583 enddo ; enddo
2584 if (integral_bt_cont) then
2585 ubt_int(:,:) = 0.0 ; uhbt_int(:,:) = 0.0
2586 vbt_int(:,:) = 0.0 ; vhbt_int(:,:) = 0.0
2587 endif
2588
2589 p_surf_dyn(:,:) = 0.0
2590 cfl_ltd_vol(:,:) = huge( gv%Z_to_H )
2591 if (cs%bt_limit_integral_transport) then
2592 ! Issue warnings if there are unphysical values of the initial sea surface height or total water column mass.
2593 if (gv%Boussinesq) then
2594 do j=js,je ; do i=is,ie
2595 if ((eta_ic(i,j) < -gv%Z_to_H*g%bathyT(i,j)) .and. (g%mask2dT(i,j) > 0.0)) then
2596 write(mesg,'(ES24.16," vs. ",ES24.16, " at ", ES12.4, ES12.4, i7, i7)') gv%H_to_m*eta(i,j), &
2597 -us%Z_to_m*g%bathyT(i,j), g%geoLonT(i,j), g%geoLatT(i,j), i + g%HI%idg_offset, j + g%HI%jdg_offset
2598 call mom_error(fatal, "btstep: eta_IC starts below bathyT: "//trim(mesg), all_print=.true.)
2599 endif
2600 enddo ; enddo
2601 else
2602 do j=js,je ; do i=is,ie
2603 if ((eta_ic(i,j) < 0.0) .and. (g%mask2dT(i,j) > 0.0)) then
2604 write(mesg,'(" at ", ES12.4, ES12.4, i7, i7)') &
2605 g%geoLonT(i,j), g%geoLatT(i,j), i + g%HI%idg_offset, j + g%HI%jdg_offset
2606 call mom_error(fatal, "btstep: negative eta_IC at start of a non-Boussinesq barotropic solver "//&
2607 trim(mesg), all_print=.true.)
2608 endif
2609 enddo ; enddo
2610 endif
2611 endif
2612
2613 ! Set up the group pass used for halo updates within the barotropic time stepping loops.
2614 call create_group_pass(cs%pass_eta_ubt, eta, cs%BT_Domain)
2615 call create_group_pass(cs%pass_eta_ubt, ubt, vbt, cs%BT_Domain)
2616 if (integral_bt_cont) then
2617 call create_group_pass(cs%pass_eta_ubt, ubt_int, vbt_int, cs%BT_Domain)
2618 ! This is only needed with integral_BT_cont, OBCs and multiple barotropic steps between halo updates.
2619 if (cs%integral_OBCs) &
2620 call create_group_pass(cs%pass_eta_ubt, uhbt_int, vhbt_int, cs%BT_Domain)
2621 endif
2622
2623 ! The following loop contains all of the time steps.
2624 isv = is ; iev = ie ; jsv = js ; jev = je
2625 do n=1,nstep+nfilter
2626 if (cs%clip_velocity) call truncate_velocities(ubt, vbt, dt, g, cs, isv, iev, jsv, jev)
2627
2628 ! Update the range of valid points, either by doing a halo update or by marching inward.
2629 if ((iev - stencil < ie) .or. (jev - stencil < je)) then
2630 if (id_clock_calc > 0) call cpu_clock_end(id_clock_calc)
2631 call do_group_pass(cs%pass_eta_ubt, cs%BT_Domain, clock=id_clock_pass_step)
2632 isv = isvf ; iev = ievf ; jsv = jsvf ; jev = jevf
2633 if (id_clock_calc > 0) call cpu_clock_begin(id_clock_calc)
2634 else
2635 isv = isv+stencil ; iev = iev-stencil
2636 jsv = jsv+stencil ; jev = jev-stencil
2637 endif
2638
2639 ! Store the previous velocities for time-filtered transports and OBCs.
2640 do j=jsv,jev ; do i=isv-2,iev+1
2641 ubt_prev(i,j) = ubt(i,j)
2642 enddo ; enddo
2643 do j=jsv-2,jev+1 ; do i=isv,iev
2644 vbt_prev(i,j) = vbt(i,j)
2645 enddo ; enddo
2646
2647 if (integral_bt_cont) then
2648 !$OMP parallel do default(shared)
2649 do j=jsv-1,jev+1 ; do i=isv-2,iev+1
2650 uhbt_int_prev(i,j) = uhbt_int(i,j)
2651 enddo ; enddo
2652 !$OMP parallel do default(shared)
2653 do j=jsv-2,jev+1 ; do i=isv-1,iev+1
2654 vhbt_int_prev(i,j) = vhbt_int(i,j)
2655 enddo ; enddo
2656 endif
2657
2658 ! Do a predictor step update of eta
2659 if (evolving_face_areas) then
2660 if ((n>1) .and. (mod(n-1,cs%Nonlin_cont_update_period) == 0)) &
2661 call find_face_areas(datu, datv, g, gv, us, cs, ms, 1+iev-ie, eta)
2662 endif
2663
2664 if (cs%dynamic_psurf .or. (.not.cs%BT_project_velocity)) then
2665 ! Estimate the change in the free surface height.
2666 call btloop_eta_predictor(n, dtbt, ubt, vbt, eta, ubt_int, vbt_int, uhbt, vhbt, uhbt0, vhbt0, &
2667 uhbt_int, vhbt_int, btcl_u, btcl_v, datu, datv, eta_ic, eta_src, eta_pred, &
2668 isv, iev, jsv, jev, integral_bt_cont, use_bt_cont, g, us, cs)
2669 endif
2670
2671 if (interp_eta_pf) then
2672 ! Interpolate the effective surface pressure in time
2673 wt_end = n*instep ! This could be (n-0.5)*Instep.
2674 !$OMP parallel do default(shared)
2675 do j=jsv-1,jev+1 ; do i=isv-1,iev+1
2676 eta_pf(i,j) = eta_pf_1(i,j) + wt_end*d_eta_pf(i,j)
2677 enddo ; enddo
2678 endif
2679
2680 v_first = (mod(n+g%first_direction,2)==1)
2681
2682 ! Determine the pressure force accelerations due to the updated eta anomalies.
2683 if (cs%BT_project_velocity) then
2684 call btloop_find_pf(pfu, pfv, isv, iev, jsv, jev, eta, eta_pf, &
2685 gtot_n, gtot_s, gtot_e, gtot_w, dgeo_de, find_etaav, &
2686 wt_accel2(n), eta_sum, v_first, g, us, cs)
2687 else
2688 call btloop_find_pf(pfu, pfv, isv, iev, jsv, jev, eta_pred, eta_pf, &
2689 gtot_n, gtot_s, gtot_e, gtot_w, dgeo_de, find_etaav, &
2690 wt_accel2(n), eta_sum, v_first, g, us, cs)
2691 endif
2692
2693 ! Use the change in eta to determine an additional divergence damping due to the ice strength.
2694 if (cs%dynamic_psurf) then
2695 call btloop_add_dyn_pf(pfu, pfv, eta_pred, eta, dyn_coef_eta, p_surf_dyn, &
2696 isv, iev, jsv, jev, v_first, g, us, cs)
2697 endif
2698
2699 if (v_first) then
2700 ! On odd-steps, update v first.
2701 call btloop_update_v(dtbt, ubt, vbt, v_accel_bt, cor_v, pfv, isv-1, iev+1, jsv-1, jev, &
2702 f_4_v, bt_rem_v, bt_force_v, cor_ref_v, rayleigh_v, &
2703 wt_accel(n), g, us, cs)
2704
2705 ! Now update the zonal velocity.
2706 call btloop_update_u(dtbt, ubt, vbt, u_accel_bt, cor_u, pfu, isv-1, iev, jsv, jev, &
2707 f_4_u, bt_rem_u, bt_force_u, cor_ref_u, rayleigh_u, &
2708 wt_accel(n), g, us, cs)
2709
2710 else
2711 ! On even steps, update u first.
2712 call btloop_update_u(dtbt, ubt, vbt, u_accel_bt, cor_u, pfu, isv-1, iev, jsv-1, jev+1, &
2713 f_4_u, bt_rem_u, bt_force_u, cor_ref_u, rayleigh_u, &
2714 wt_accel(n), g, us, cs)
2715 ! Now update the meridional velocity.
2716 call btloop_update_v(dtbt, ubt, vbt, v_accel_bt, cor_v, pfv, isv, iev, jsv-1, jev, &
2717 f_4_v, bt_rem_v, bt_force_v, cor_ref_v, rayleigh_v, &
2718 wt_accel(n), g, us, cs, cor_bracket_bug=cs%use_old_coriolis_bracket_bug)
2719 endif
2720
2721 ! Determine the transports based on the updated velocities when no OBCs are applied
2722 if (integral_bt_cont) then
2723 if (cs%bt_limit_integral_transport) then
2724 ! Calculate the volume that could be used for divergent transport to use for a limter. This applies to
2725 ! uhbt_int and vhbt_int at each BT step. It does not allow for temporary flooding during the BT cycling.
2726 ! Only the sink is accounted for: if diverent motion occurs at the beginning of the BT cycling but the volume
2727 ! was due only to a +ve source being applied gradually, then the instantaneous eta could drop below the bottom.
2728 if (gv%Boussinesq) then
2729 do j=jsv,jev ; do i=isv,iev
2730 cfl_ltd_vol(i,j) = ( cs%maxCFL_BT_cont * g%areaT(i,j) ) * &
2731 max( 0., ( gv%Z_to_H*g%bathyT(i,j) + eta_ic(i,j) ) + nstep * min( 0., eta_src(i,j) ) )
2732 enddo ; enddo
2733 else
2734 do j=jsv,jev ; do i=isv,iev
2735 cfl_ltd_vol(i,j) = ( cs%maxCFL_BT_cont * g%areaT(i,j) ) * &
2736 max( 0., eta_ic(i,j) + nstep * min( 0., eta_src(i,j) ) )
2737 enddo ; enddo
2738 endif
2739 endif
2740 !$OMP do schedule(static)
2741 do j=jsv,jev ; do i=isv-1,iev
2742 ubt_trans(i,j) = trans_wt1*ubt(i,j) + trans_wt2*ubt_prev(i,j)
2743 ubt_int_prev(i,j) = ubt_int(i,j) ! Store the previous integrated velocity so it can be reset by at OBC points
2744 ubt_int(i,j) = ubt_int(i,j) + dtbt * ubt_trans(i,j)
2745 uhbt_int(i,j) = find_uhbt(ubt_int(i,j), btcl_u(i,j)) + n*dtbt*uhbt0(i,j)
2746 uhbt_int(i,j) = max( -cfl_ltd_vol(i+1,j), min( uhbt_int(i,j), cfl_ltd_vol(i,j) ) )
2747 ! Estimate the mass flux within a single timestep to take the filtered average.
2748 uhbt(i,j) = (uhbt_int(i,j) - uhbt_int_prev(i,j)) * idtbt
2749 enddo ; enddo
2750 !$OMP end do nowait
2751 !$OMP do schedule(static)
2752 do j=jsv-1,jev ; do i=isv,iev
2753 vbt_trans(i,j) = trans_wt1*vbt(i,j) + trans_wt2*vbt_prev(i,j)
2754 vbt_int_prev(i,j) = vbt_int(i,j) ! Store the previous integrated velocity so it can be reset by at OBC points
2755 vbt_int(i,j) = vbt_int(i,j) + dtbt * vbt_trans(i,j)
2756 vhbt_int(i,j) = find_vhbt(vbt_int(i,j), btcl_v(i,j)) + n*dtbt*vhbt0(i,j)
2757 vhbt_int(i,j) = max( -cfl_ltd_vol(i,j+1), min( vhbt_int(i,j), cfl_ltd_vol(i,j) ) )
2758 ! Estimate the mass flux within a single timestep to take the filtered average.
2759 vhbt(i,j) = (vhbt_int(i,j) - vhbt_int_prev(i,j)) * idtbt
2760 enddo ; enddo
2761 elseif (use_bt_cont) then
2762 !$OMP do schedule(static)
2763 do j=jsv,jev ; do i=isv-1,iev
2764 ubt_trans(i,j) = trans_wt1*ubt(i,j) + trans_wt2*ubt_prev(i,j)
2765 uhbt(i,j) = find_uhbt(ubt_trans(i,j), btcl_u(i,j)) + uhbt0(i,j)
2766 enddo ; enddo
2767 !$OMP end do nowait
2768 !$OMP do schedule(static)
2769 do j=jsv-1,jev ; do i=isv,iev
2770 vbt_trans(i,j) = trans_wt1*vbt(i,j) + trans_wt2*vbt_prev(i,j)
2771 vhbt(i,j) = find_vhbt(vbt_trans(i,j), btcl_v(i,j)) + vhbt0(i,j)
2772 enddo ; enddo
2773 else
2774 !$OMP do schedule(static)
2775 do j=jsv,jev ; do i=isv-1,iev
2776 ubt_trans(i,j) = trans_wt1*ubt(i,j) + trans_wt2*ubt_prev(i,j)
2777 uhbt(i,j) = datu(i,j)*ubt_trans(i,j) + uhbt0(i,j)
2778 enddo ; enddo
2779 !$OMP end do nowait
2780 !$OMP do schedule(static)
2781 do j=jsv-1,jev ; do i=isv,iev
2782 vbt_trans(i,j) = trans_wt1*vbt(i,j) + trans_wt2*vbt_prev(i,j)
2783 vhbt(i,j) = datv(i,j)*vbt_trans(i,j) + vhbt0(i,j)
2784 enddo ; enddo
2785 endif
2786
2787 ! This might need to be moved outside of the OMP do loop directives.
2788 if (cs%debug_bt) then
2789 write(mesg,'("BT vel update ",I0)') n
2790 debug_halo = 0 ; if (cs%debug_wide_halos) debug_halo = iev - ie
2791 call uvchksum(trim(mesg)//" PF[uv]", pfu, pfv, cs%debug_BT_HI, haloshift=debug_halo, &
2792 symmetric=.true., unscale=us%L_T_to_m_s*us%s_to_T)
2793 call uvchksum(trim(mesg)//" Cor_[uv]", cor_u, cor_v, cs%debug_BT_HI, haloshift=debug_halo, &
2794 symmetric=.true., unscale=us%L_T_to_m_s*us%s_to_T)
2795 call uvchksum(trim(mesg)//" BT_force_[uv]", bt_force_u, bt_force_v, cs%debug_BT_HI, haloshift=debug_halo, &
2796 symmetric=.true., unscale=us%L_T_to_m_s*us%s_to_T)
2797 call uvchksum(trim(mesg)//" BT_rem_[uv]", bt_rem_u, bt_rem_v, cs%debug_BT_HI, haloshift=debug_halo, &
2798 symmetric=.true., scalar_pair=.true.)
2799 call uvchksum(trim(mesg)//" [uv]bt", ubt, vbt, cs%debug_BT_HI, haloshift=debug_halo, &
2800 symmetric=.true., unscale=us%L_T_to_m_s)
2801 call uvchksum(trim(mesg)//" [uv]bt_trans", ubt_trans, vbt_trans, cs%debug_BT_HI, haloshift=debug_halo, &
2802 symmetric=.true., unscale=us%L_T_to_m_s)
2803 call uvchksum(trim(mesg)//" [uv]hbt", uhbt, vhbt, cs%debug_BT_HI, haloshift=debug_halo, &
2804 symmetric=.true., unscale=us%s_to_T*us%L_to_m**2*gv%H_to_m)
2805 if (integral_bt_cont) &
2806 call uvchksum(trim(mesg)//" [uv]hbt_int", uhbt_int, vhbt_int, cs%debug_BT_HI, haloshift=debug_halo, &
2807 symmetric=.true., unscale=us%L_to_m**2*gv%H_to_m)
2808 endif
2809
2810 ! Apply open boundary condition considerations to revise the updated velocities and transports.
2811 if (cs%BT_OBC%u_OBCs_on_PE) then
2812 !$OMP single
2813 call apply_u_velocity_obcs(ubt, uhbt, ubt_trans, eta, spv_col_avg, ubt_prev, bt_obc, &
2814 g, ms, gv, us, cs, iev-ie, dtbt, cs%bebt, use_bt_cont, integral_bt_cont, n*dtbt, &
2815 datu, btcl_u, uhbt0, ubt_int, ubt_int_prev, uhbt_int, uhbt_int_prev)
2816 !$OMP end single
2817 endif
2818
2819 if (cs%BT_OBC%v_OBCs_on_PE) then
2820 !$OMP single
2821 call apply_v_velocity_obcs(vbt, vhbt, vbt_trans, eta, spv_col_avg, vbt_prev, bt_obc, &
2822 g, ms, gv, us, cs, iev-ie, dtbt, cs%bebt, use_bt_cont, integral_bt_cont, n*dtbt, &
2823 datv, btcl_v, vhbt0, vbt_int, vbt_int_prev, vhbt_int, vhbt_int_prev)
2824 !$OMP end single
2825 endif
2826
2827 ! Contribute to the running sums of the transports and velocities.
2828 !$OMP do
2829 do j=js,je ; do i=is-1,ie
2830 cs%ubtav(i,j) = cs%ubtav(i,j) + wt_trans(n) * ubt_trans(i,j)
2831 uhbtav(i,j) = uhbtav(i,j) + wt_trans(n) * uhbt(i,j)
2832 ubt_wtd(i,j) = ubt_wtd(i,j) + wt_vel(n) * ubt(i,j)
2833 enddo ; enddo
2834 !$OMP end do nowait
2835 !$OMP do
2836 do j=js-1,je ; do i=is,ie
2837 cs%vbtav(i,j) = cs%vbtav(i,j) + wt_trans(n) * vbt_trans(i,j)
2838 vhbtav(i,j) = vhbtav(i,j) + wt_trans(n) * vhbt(i,j)
2839 vbt_wtd(i,j) = vbt_wtd(i,j) + wt_vel(n) * vbt(i,j)
2840 enddo ; enddo
2841 !$OMP end do nowait
2842
2843 if (cs%debug_bt) then
2844 call uvchksum("BT [uv]hbt just after OBC", uhbt, vhbt, cs%debug_BT_HI, haloshift=debug_halo, &
2845 symmetric=.true., unscale=us%s_to_T*us%L_to_m**2*gv%H_to_m)
2846 if (integral_bt_cont) &
2847 call uvchksum("BT [uv]hbt_int just after OBC", uhbt_int, vhbt_int, cs%debug_BT_HI, &
2848 haloshift=debug_halo, symmetric=.true., unscale=us%L_to_m**2*gv%H_to_m)
2849 endif
2850
2851 ! Update eta in a corrector step using the barotropic continuity equation.
2852 if (integral_bt_cont) then
2853 eta_cor_multiplier = n
2854 if ( cs%bt_adjust_src_for_filter ) then
2855 if ( nstep > nfilter ) then
2856 eta_cor_multiplier = min(nstep - nfilter, n) * nstep / real(nstep - nfilter)
2857 else
2858 eta_cor_multiplier = nstep
2859 endif
2860 endif
2861 !$OMP do
2862 do j=jsv,jev ; do i=isv,iev
2863 eta(i,j) = (eta_ic(i,j) + eta_cor_multiplier*eta_src(i,j)) + cs%IareaT_OBCmask(i,j) * &
2864 ((uhbt_int(i-1,j) - uhbt_int(i,j)) + (vhbt_int(i,j-1) - vhbt_int(i,j)))
2865 ! eta_acc contains the magnitude of the largest term in the above expression which
2866 ! will be used to estimate a bound for round off when comparing to the bottom depth
2867 eta_acc = abs( cs%IareaT_OBCmask(i,j) * &
2868 ((uhbt_int(i-1,j) - uhbt_int(i,j)) + (vhbt_int(i,j-1) - vhbt_int(i,j))) )
2869 eta_acc = max( eta_acc, abs( eta_cor_multiplier*eta_src(i,j) ), abs( eta_ic(i,j) ) )
2870 ! These blocks correct the sitution when the sea-surface drops below the seafloor by a
2871 ! tiny amount that could be attributable to floating-point round-off.
2872 if (gv%Boussinesq) then
2873 if ( g%mask2dT(i,j) * ( eta(i,j) + gv%Z_to_H*g%bathyT(i,j) ) > &
2874 -g%mask2dT(i,j) * eta_acc * epsilon(eta_acc) * 2. ) &
2875 eta(i,j) = max( eta(i,j), -gv%Z_to_H*g%bathyT(i,j) )
2876 else
2877 if (g%mask2dT(i,j) * eta(i,j) < 0.0) then
2878 if (abs(eta(i,j)) < 2.*epsilon(eta_acc) * eta_acc) eta(i,j) = 0.0
2879 endif
2880 endif
2881 eta_wtd(i,j) = eta_wtd(i,j) + eta(i,j) * wt_eta(n)
2882 enddo ; enddo
2883 else
2884 !$OMP do
2885 do j=jsv,jev ; do i=isv,iev
2886 eta(i,j) = (eta(i,j) + eta_src(i,j)) + (dtbt * cs%IareaT_OBCmask(i,j)) * &
2887 ((uhbt(i-1,j) - uhbt(i,j)) + (vhbt(i,j-1) - vhbt(i,j)))
2888 eta_wtd(i,j) = eta_wtd(i,j) + eta(i,j) * wt_eta(n)
2889 enddo ; enddo
2890 endif
2891
2892 if (cs%debug_bt) then
2893 write(mesg,'("BT step ",I0)') n
2894 call uvchksum(trim(mesg)//" [uv]bt", ubt, vbt, cs%debug_BT_HI, haloshift=debug_halo, &
2895 symmetric=.true., unscale=us%L_T_to_m_s)
2896 call hchksum(eta, trim(mesg)//" eta", cs%debug_BT_HI, haloshift=debug_halo, unscale=gv%H_to_MKS)
2897 endif
2898
2899 ! Issue warnings if there are unphysical values of the sea surface height or total water column mass.
2900 if (gv%Boussinesq) then
2901 do j=js,je ; do i=is,ie
2902 if ((eta(i,j) < -gv%Z_to_H*g%bathyT(i,j)) .and. (g%mask2dT(i,j) > 0.0)) then
2903 write(mesg,'(ES24.16," vs. ",ES24.16, " at ", ES12.4, ES12.4, i7, i7)') gv%H_to_m*eta(i,j), &
2904 -us%Z_to_m*g%bathyT(i,j), g%geoLonT(i,j), g%geoLatT(i,j), i + g%HI%idg_offset, j + g%HI%jdg_offset
2905 if (cs%bt_limit_integral_transport) &
2906 call mom_error(fatal, "btstep: eta has dropped below bathyT: "//trim(mesg))
2907 if (err_count < 2) &
2908 call mom_error(warning, "btstep: eta has dropped below bathyT: "//trim(mesg), all_print=.true.)
2909 err_count = err_count + 1
2910 endif
2911 enddo ; enddo
2912 else
2913 do j=js,je ; do i=is,ie
2914 if ((eta(i,j) < 0.0) .and. (g%mask2dT(i,j) > 0.0)) then
2915 write(mesg,'(" at ", ES12.4, ES12.4, i7, i7)') &
2916 g%geoLonT(i,j), g%geoLatT(i,j), i + g%HI%idg_offset, j + g%HI%jdg_offset
2917 if (cs%bt_limit_integral_transport) &
2918 call mom_error(fatal, "btstep: negative eta in a non-Boussinesq barotropic solver "//trim(mesg))
2919 if (err_count < 2) &
2920 call mom_error(warning, "btstep: negative eta in a non-Boussinesq barotropic solver "//&
2921 trim(mesg), all_print=.true.)
2922 err_count = err_count + 1
2923 endif
2924 enddo ; enddo
2925 endif
2926
2927 ! Accumulate some diagnostics of time-averaged barotropic accelerations.
2928 if (do_ave) then
2929 if ((cs%id_PFu_bt > 0) .or. associated(adp%bt_pgf_u)) then
2930 !$OMP do
2931 do j=js,je ; do i=is-1,ie
2932 pfu_avg(i,j) = pfu_avg(i,j) + wt_accel2(n) * pfu(i,j)
2933 enddo ; enddo
2934 !$OMP end do nowait
2935 endif
2936 if ((cs%id_PFv_bt > 0) .or. associated(adp%bt_pgf_v)) then
2937 !$OMP do
2938 do j=js-1,je ; do i=is,ie
2939 pfv_avg(i,j) = pfv_avg(i,j) + wt_accel2(n) * pfv(i,j)
2940 enddo ; enddo
2941 !$OMP end do nowait
2942 endif
2943 if ((cs%id_Coru_bt > 0) .or. associated(adp%bt_cor_u)) then
2944 !$OMP do
2945 do j=js,je ; do i=is-1,ie
2946 coru_avg(i,j) = coru_avg(i,j) + wt_accel2(n) * cor_u(i,j)
2947 enddo ; enddo
2948 !$OMP end do nowait
2949 endif
2950 if ((cs%id_Corv_bt > 0) .or. associated(adp%bt_cor_v)) then
2951 !$OMP do
2952 do j=js-1,je ; do i=is,ie
2953 corv_avg(i,j) = corv_avg(i,j) + wt_accel2(n) * cor_v(i,j)
2954 enddo ; enddo
2955 !$OMP end do nowait
2956 endif
2957
2958 if (cs%linear_wave_drag) then
2959 if ((cs%id_LDu_bt > 0) .or. (associated(adp%bt_lwd_u))) then
2960 !$OMP do
2961 do j=js,je ; do i=is-1,ie
2962 ldu_avg(i,j) = ldu_avg(i,j) - wt_accel2(n) * (ubt(i,j) * rayleigh_u(i,j))
2963 enddo ; enddo
2964 !$OMP end do nowait
2965 endif
2966 if ((cs%id_LDv_bt > 0) .or. (associated(adp%bt_lwd_v))) then
2967 !$OMP do
2968 do j=js-1,je ; do i=is,ie
2969 ldv_avg(i,j) = ldv_avg(i,j) - wt_accel2(n) * (vbt(i,j) * rayleigh_v(i,j))
2970 enddo ; enddo
2971 !$OMP end do nowait
2972 endif
2973 endif
2974 endif
2975
2976 if (do_hifreq_output) then
2977 ! Note that this compresses the time so that all of the timesteps, including those in the
2978 ! extra timesteps for filtering, fit within dt.
2979 time_step_end = time_bt_start + real_to_time(n*dtbt_diag, unscale=us%T_to_s)
2980 call enable_averages(dtbt, time_step_end, cs%diag)
2981 if (cs%id_ubt_hifreq > 0) call post_data(cs%id_ubt_hifreq, ubt(isdb:iedb,jsd:jed), cs%diag)
2982 if (cs%id_vbt_hifreq > 0) call post_data(cs%id_vbt_hifreq, vbt(isd:ied,jsdb:jedb), cs%diag)
2983 if (cs%id_eta_hifreq > 0) call post_data(cs%id_eta_hifreq, eta(isd:ied,jsd:jed), cs%diag)
2984 if (cs%id_etaPF_hifreq > 0) then
2985 if (cs%BT_project_velocity) then
2986 do j=js,je ; do i=is,ie
2987 eta_anom_pf(i,j) = eta(i,j) - eta_pf(i,j)
2988 enddo ; enddo
2989 else
2990 do j=js,je ; do i=is,ie
2991 eta_anom_pf(i,j) = eta_pred(i,j) - eta_pf(i,j)
2992 enddo ; enddo
2993 endif
2994 call post_data(cs%id_etaPF_hifreq, eta_anom_pf(isd:ied,jsd:jed), cs%diag)
2995 endif
2996 if (cs%id_uhbt_hifreq > 0) call post_data(cs%id_uhbt_hifreq, uhbt(isdb:iedb,jsd:jed), cs%diag)
2997 if (cs%id_vhbt_hifreq > 0) call post_data(cs%id_vhbt_hifreq, vhbt(isd:ied,jsdb:jedb), cs%diag)
2998 if (cs%BT_project_velocity) then
2999 ! This diagnostic is redundant in this case and should probably be omitted.
3000 if (cs%id_eta_pred_hifreq > 0) call post_data(cs%id_eta_pred_hifreq, eta(isd:ied,jsd:jed), cs%diag)
3001 else
3002 if (cs%id_eta_pred_hifreq > 0) call post_data(cs%id_eta_pred_hifreq, eta_pred(isd:ied,jsd:jed), cs%diag)
3003 endif
3004 endif
3005 enddo ! end of do n=1,ntimestep
3006
3007 ! Reset the time information in the diag type.
3008 if (do_hifreq_output) call enable_averaging(time_int_in, time_end_in, cs%diag)
3009
3010end subroutine btstep_timeloop
3011
3012
3013!> Find the Coriolis force terms _zon and _mer.
3014subroutine btstep_find_cor(q, DCor_u, DCor_v, f_4_u, f_4_v, isvf, ievf, jsvf, jevf, CS)
3015 type(barotropic_cs), intent(inout) :: CS !< Barotropic control structure
3016 real, intent(in) :: q(SZIBW_(CS),SZJBW_(CS)) !< A pseudo potential vorticity [T-1 Z-1 ~> s-1 m-1]
3017 !! or [T-1 H-1 ~> s-1 m-1 or m2 s-1 kg-1]
3018 real, dimension(SZIBW_(CS),SZJW_(CS)), intent(in) :: &
3019 DCor_u !< An averaged depth or total thickness at u points [Z ~> m] or [H ~> m or kg m-2].
3020 real, dimension(SZIW_(CS),SZJBW_(CS)), intent(in) :: &
3021 DCor_v !< An averaged depth or total thickness at v points [Z ~> m] or [H ~> m or kg m-2].
3022 real, dimension(4,SZIBW_(CS),SZJW_(CS)), intent(inout) :: &
3023 f_4_u !< The terms giving the contribution to the Coriolis acceleration at a zonal
3024 !! velocity point from the neighboring meridional velocity anomalies [T-1 ~> s-1].
3025 !! These are the products of thicknesses at v points and appropriately staggered
3026 !! averaged pseudo potential vorticities, but with sufficiently smooth topography
3027 !! they are approximately f / 4. The 4 values on the innermost loop are for
3028 !! v-velocities to the southwest, southeast, northwest and northeast.
3029 real, dimension(4,SZIW_(CS),SZJBW_(CS)), intent(inout) :: &
3030 f_4_v !< The terms giving the contribution to the Coriolis acceleration at a meridional
3031 !! velocity point from the neighboring meridional velocity anomalies [T-1 ~> s-1].
3032 !! These are the products of thicknesses at u points and appropriately staggered
3033 !! averaged pseudo potential vorticities, but with sufficiently smooth topography
3034 !! they are approximately f / 4. The 4 values on the innermost loop are for
3035 !! u-velocities to the southwest, southeast, northwest and northeast.
3036 integer, intent(in) :: isvf !< The starting i-index of the largest valid range for tracer points
3037 integer, intent(in) :: ievf !< The ending i-index of the largest valid range for tracer points
3038 integer, intent(in) :: jsvf !< The starting j-index of the largest valid range for tracer points
3039 integer, intent(in) :: jevf !< The ending j-index of the largest valid range for tracer points
3040
3041 ! real :: C1_3 ! One third [nondim]
3042 integer :: i, j
3043
3044 if (cs%Sadourny) then
3045 !$OMP parallel do default(shared)
3046 do j=jsvf-1,jevf ; do i=isvf-1,ievf+1
3047 f_4_v(1,i,j) = cs%OBCmask_v(i,j) * dcor_u(i-1,j) * q(i-1,j)
3048 f_4_v(2,i,j) = cs%OBCmask_v(i,j) * dcor_u(i,j) * q(i,j)
3049 f_4_v(4,i,j) = cs%OBCmask_v(i,j) * dcor_u(i,j+1) * q(i,j)
3050 f_4_v(3,i,j) = cs%OBCmask_v(i,j) * dcor_u(i-1,j+1) * q(i-1,j)
3051 enddo ; enddo
3052 !$OMP parallel do default(shared)
3053 do j=jsvf-1,jevf+1 ; do i=isvf-1,ievf
3054 f_4_u(4,i,j) = cs%OBCmask_u(i,j) * dcor_v(i+1,j) * q(i,j)
3055 f_4_u(3,i,j) = cs%OBCmask_u(i,j) * dcor_v(i,j) * q(i,j)
3056 f_4_u(1,i,j) = cs%OBCmask_u(i,j) * dcor_v(i,j-1) * q(i,j-1)
3057 f_4_u(2,i,j) = cs%OBCmask_u(i,j) * dcor_v(i+1,j-1) * q(i,j-1)
3058 enddo ; enddo
3059 else !### if (CS%answer_date < 20250601) then ! Uncomment this later.
3060 !$OMP parallel do default(shared)
3061 do j=jsvf-1,jevf ; do i=isvf-1,ievf+1
3062 f_4_v(1,i,j) = cs%OBCmask_v(i,j) * dcor_u(i-1,j) * ((q(i,j) + q(i-1,j-1)) + q(i-1,j)) / 3.0
3063 f_4_v(2,i,j) = cs%OBCmask_v(i,j) * dcor_u(i,j) * (q(i,j) + (q(i-1,j) + q(i,j-1))) / 3.0
3064 f_4_v(4,i,j) = cs%OBCmask_v(i,j) * dcor_u(i,j+1) * (q(i,j) + (q(i-1,j) + q(i,j+1))) / 3.0
3065 f_4_v(3,i,j) = cs%OBCmask_v(i,j) * dcor_u(i-1,j+1) * ((q(i,j) + q(i-1,j+1)) + q(i-1,j)) / 3.0
3066 enddo ; enddo
3067 !$OMP parallel do default(shared)
3068 do j=jsvf-1,jevf+1 ; do i=isvf-1,ievf
3069 f_4_u(4,i,j) = cs%OBCmask_u(i,j) * dcor_v(i+1,j) * (q(i,j) + (q(i+1,j) + q(i,j-1))) / 3.0
3070 f_4_u(3,i,j) = cs%OBCmask_u(i,j) * dcor_v(i,j) * (q(i,j) + (q(i-1,j) + q(i,j-1))) / 3.0
3071 f_4_u(1,i,j) = cs%OBCmask_u(i,j) * dcor_v(i,j-1) * ((q(i,j) + q(i-1,j-1)) + q(i,j-1)) / 3.0
3072 f_4_u(2,i,j) = cs%OBCmask_u(i,j) * dcor_v(i+1,j-1) * ((q(i,j) + q(i+1,j-1)) + q(i,j-1)) / 3.0
3073 enddo ; enddo
3074 ! else
3075 ! C1_3 = 1.0 / 3.0
3076 ! !$OMP parallel do default(shared)
3077 ! do J=jsvf-1,jevf ; do i=isvf-1,ievf+1
3078 ! f_4_v(1,i,J) = CS%OBCmask_v(i,J) * DCor_u(I-1,j) * ((q(I,J) + q(I-1,J-1)) + q(I-1,J)) * C1_3
3079 ! f_4_v(2,i,J) = CS%OBCmask_v(i,J) * DCor_u(I,j) * (q(I,J) + (q(I-1,J) + q(I,J-1))) * C1_3
3080 ! f_4_v(4,i,J) = CS%OBCmask_v(i,J) * DCor_u(I,j+1) * (q(I,J) + (q(I-1,J) + q(I,J+1))) * C1_3
3081 ! f_4_v(3,i,J) = CS%OBCmask_v(i,J) * DCor_u(I-1,j+1) * ((q(I,J) + q(I-1,J+1)) + q(I-1,J)) * C1_3
3082 ! enddo ; enddo
3083 ! !$OMP parallel do default(shared)
3084 ! do j=jsvf-1,jevf+1 ; do I=isvf-1,ievf
3085 ! f_4_u(4,I,j) = CS%OBCmask_u(I,j) * DCor_v(i+1,J) * (q(I,J) + (q(I+1,J) + q(I,J-1))) * C1_3
3086 ! f_4_u(3,I,j) = CS%OBCmask_u(I,j) * DCor_v(i,J) * (q(I,J) + (q(I-1,J) + q(I,J-1))) * C1_3
3087 ! f_4_u(1,I,j) = CS%OBCmask_u(I,j) * DCor_v(i,J-1) * ((q(I,J) + q(I-1,J-1)) + q(I,J-1)) * C1_3
3088 ! f_4_u(2,I,j) = CS%OBCmask_u(I,j) * DCor_v(i+1,J-1) * ((q(I,J) + q(I+1,J-1)) + q(I,J-1)) * C1_3
3089 ! enddo ; enddo
3090 endif
3091
3092end subroutine btstep_find_cor
3093
3094!> Do a CFL-based truncation of any excessively large batotropic velocities.
3095!! This should only be used as desperate debugging measure.
3096subroutine truncate_velocities(ubt, vbt, dt, G, CS, isv, iev, jsv, jev)
3097 type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure.
3098 type(barotropic_cs), intent(inout) :: CS !< Barotropic control structure
3099 real, intent(inout) :: ubt(SZIBW_(CS),SZJW_(CS)) !< The zonal barotropic velocity [L T-1 ~> m s-1]
3100 real, intent(inout) :: vbt(SZIW_(CS),SZJBW_(CS)) !< The meridional barotropic velocity [L T-1 ~> m s-1]
3101 real, intent(in) :: dt !< The time increment to integrate over [T ~> s].
3102 integer, intent(in) :: isv !< The starting valid tracer array i-index that is being worked on
3103 integer, intent(in) :: iev !< The ending valid tracer array i-index that is being worked on
3104 integer, intent(in) :: jsv !< The starting valid tracer array j-index that is being worked on
3105 integer, intent(in) :: jev !< The ending valid tracer array j-index being that is worked on
3106
3107 integer :: i, j
3108
3109 if (cs%clip_velocity) then
3110 do j=jsv,jev ; do i=isv-1,iev
3111 if ((ubt(i,j) * (dt * g%dy_Cu(i,j))) * g%IareaT(i+1,j) < -cs%CFL_trunc) then
3112 ! Add some error reporting later.
3113 ubt(i,j) = (-0.95*cs%CFL_trunc) * (g%areaT(i+1,j) / (dt * g%dy_Cu(i,j)))
3114 elseif ((ubt(i,j) * (dt * g%dy_Cu(i,j))) * g%IareaT(i,j) > cs%CFL_trunc) then
3115 ! Add some error reporting later.
3116 ubt(i,j) = (0.95*cs%CFL_trunc) * (g%areaT(i,j) / (dt * g%dy_Cu(i,j)))
3117 endif
3118 enddo ; enddo
3119 do j=jsv-1,jev ; do i=isv,iev
3120 if ((vbt(i,j) * (dt * g%dx_Cv(i,j))) * g%IareaT(i,j+1) < -cs%CFL_trunc) then
3121 ! Add some error reporting later.
3122 vbt(i,j) = (-0.9*cs%CFL_trunc) * (g%areaT(i,j+1) / (dt * g%dx_Cv(i,j)))
3123 elseif ((vbt(i,j) * (dt * g%dx_Cv(i,j))) * g%IareaT(i,j) > cs%CFL_trunc) then
3124 ! Add some error reporting later.
3125 vbt(i,j) = (0.9*cs%CFL_trunc) * (g%areaT(i,j) / (dt * g%dx_Cv(i,j)))
3126 endif
3127 enddo ; enddo
3128 endif
3129
3130end subroutine truncate_velocities
3131
3132
3133!> A routine to set eta_pred and the running time integral of uhbt and vhbt.
3134subroutine btloop_eta_predictor(n, dtbt, ubt, vbt, eta, ubt_int, vbt_int, uhbt, vhbt, uhbt0, vhbt0, &
3135 uhbt_int, vhbt_int, BTCL_u, BTCL_v, Datu, Datv, &
3136 eta_IC, eta_src, eta_pred, isv, iev, jsv, jev, &
3137 integral_BT_cont, use_BT_cont, G, US, CS)
3138 type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure
3139 type(barotropic_cs), intent(in) :: CS !< Barotropic control structure
3140 integer, intent(in) :: n !< The current step in loop of timesteps
3141 real, intent(in) :: dtbt !< The barotropic time step [T ~> s]
3142 real, dimension(SZIBW_(CS),SZJW_(CS)), intent(in) :: &
3143 ubt !< The zonal barotropic velocity [L T-1 ~> m s-1].
3144 real, dimension(SZIW_(CS),SZJBW_(CS)), intent(in) :: &
3145 vbt !< The zonal barotropic velocity [L T-1 ~> m s-1].
3146 real, target, dimension(SZIW_(CS),SZJW_(CS)), intent(in) :: &
3147 eta !< The barotropic free surface height anomaly or column mass [H ~> m or kg m-2]
3148 real, dimension(SZIBW_(CS),SZJW_(CS)), intent(in) :: &
3149 ubt_int !< The running time integral of ubt over the time steps [L ~> m].
3150 real, dimension(SZIW_(CS),SZJBW_(CS)), intent(in) :: &
3151 vbt_int !< The running time integral of vbt over the time steps [L ~> m].
3152 real, dimension(SZIBW_(CS),SZJW_(CS)), intent(in) :: &
3153 uhbt0 !< The difference between the sum of the layer zonal thickness
3154 !! fluxes and the barotropic thickness flux using the same
3155 !! velocity [H L2 T-1 ~> m3 s-1 or kg s-1].
3156 real, dimension(SZIW_(CS),SZJBW_(CS)), intent(in) :: &
3157 vhbt0 !< The difference between the sum of the layer meridional
3158 !! thickness fluxes and the barotropic thickness flux using
3159 !! the same velocities [H L2 T-1 ~> m3 s-1 or kg s-1].
3160 type(local_bt_cont_u_type), dimension(SZIBW_(CS),SZJW_(CS)), intent(in) :: &
3161 BTCL_u !< A repackaged version of the u-point information in BT_cont.
3162 type(local_bt_cont_v_type), dimension(SZIW_(CS),SZJBW_(CS)), intent(in) :: &
3163 BTCL_v !< A repackaged version of the v-point information in BT_cont.
3164 real, dimension(SZIBW_(CS),SZJW_(CS)), intent(in) :: &
3165 Datu !< Basin depth at u-velocity grid points times the y-grid
3166 !! spacing [H L ~> m2 or kg m-1].
3167 real, dimension(SZIW_(CS),SZJBW_(CS)), intent(in) :: &
3168 Datv !< Basin depth at v-velocity grid points times the x-grid
3169 !! spacing [H L ~> m2 or kg m-1].
3170 real, dimension(SZIW_(CS),SZJW_(CS)), intent(in) :: &
3171 eta_IC !< A local copy of the initial 2-D eta field (eta_in) [H ~> m or kg m-2]
3172 real, dimension(SZIW_(CS),SZJW_(CS)), intent(in) :: &
3173 eta_src !< The source of eta per barotropic timestep [H ~> m or kg m-2].
3174 real, dimension(SZIBW_(CS),SZJW_(CS)), intent(inout) :: &
3175 uhbt !< The zonal barotropic thickness fluxes [H L2 T-1 ~> m3 s-1 or kg s-1].
3176 real, dimension(SZIW_(CS),SZJBW_(CS)), intent(inout) :: &
3177 vhbt !< The meridional barotropic thickness fluxes [H L2 T-1 ~> m3 s-1 or kg s-1].
3178 real, dimension(SZIBW_(CS),SZJW_(CS)), intent(inout) :: &
3179 uhbt_int !< The running time integral of uhbt over the time steps [H L2 ~> m3 or kg].
3180 real, dimension(SZIW_(CS),SZJBW_(CS)), intent(inout) :: &
3181 vhbt_int !< The running time integral of vhbt over the time steps [H L2 ~> m3 or kg].
3182 real, target, dimension(SZIW_(CS),SZJW_(CS)), intent(inout) :: &
3183 eta_pred !< A predictor value of eta [H ~> m or kg m-2] like eta.
3184 integer, intent(in) :: isv !< The starting i-index of eta_pred to calculate
3185 integer, intent(in) :: iev !< The ending i-index of eta_pred to calculate
3186 integer, intent(in) :: jsv !< The starting j-index of eta_pred to calculate
3187 integer, intent(in) :: jev !< The ending j-index of eta_pred to calculate
3188 logical, intent(in) :: integral_BT_cont !< If true, update the barotropic continuity equation directly
3189 !! from the initial condition using the time-integrated barotropic velocity.
3190 logical, intent(in) :: use_BT_cont !< If true, use the information in the BT_cont_type to determine
3191 !! barotropic transports as a function of the barotropic velocities.
3192 type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
3193
3194 integer :: i, j
3195
3196 !$OMP parallel default(shared)
3197 if (integral_bt_cont) then
3198 !$OMP do
3199 do j=jsv-1,jev+1 ; do i=isv-2,iev+1
3200 uhbt_int(i,j) = find_uhbt(ubt_int(i,j) + dtbt*ubt(i,j), btcl_u(i,j)) + n*dtbt*uhbt0(i,j)
3201 enddo ; enddo
3202 !$OMP end do nowait
3203 !$OMP do
3204 do j=jsv-2,jev+1 ; do i=isv-1,iev+1
3205 vhbt_int(i,j) = find_vhbt(vbt_int(i,j) + dtbt*vbt(i,j), btcl_v(i,j)) + n*dtbt*vhbt0(i,j)
3206 enddo ; enddo
3207 !$OMP do
3208 do j=jsv-1,jev+1 ; do i=isv-1,iev+1
3209 eta_pred(i,j) = (eta_ic(i,j) + n*eta_src(i,j)) + cs%IareaT_OBCmask(i,j) * &
3210 ((uhbt_int(i-1,j) - uhbt_int(i,j)) + (vhbt_int(i,j-1) - vhbt_int(i,j)))
3211 enddo ; enddo
3212 elseif (use_bt_cont) then
3213 !$OMP do
3214 do j=jsv-1,jev+1 ; do i=isv-2,iev+1
3215 uhbt(i,j) = find_uhbt(ubt(i,j), btcl_u(i,j)) + uhbt0(i,j)
3216 enddo ; enddo
3217 !$OMP do
3218 do j=jsv-2,jev+1 ; do i=isv-1,iev+1
3219 vhbt(i,j) = find_vhbt(vbt(i,j), btcl_v(i,j)) + vhbt0(i,j)
3220 enddo ; enddo
3221 !$OMP do
3222 do j=jsv-1,jev+1 ; do i=isv-1,iev+1
3223 eta_pred(i,j) = (eta(i,j) + eta_src(i,j)) + (dtbt * cs%IareaT_OBCmask(i,j)) * &
3224 ((uhbt(i-1,j) - uhbt(i,j)) + (vhbt(i,j-1) - vhbt(i,j)))
3225 enddo ; enddo
3226 else
3227 !$OMP do
3228 do j=jsv-1,jev+1 ; do i=isv-1,iev+1
3229 eta_pred(i,j) = (eta(i,j) + eta_src(i,j)) + (dtbt * cs%IareaT_OBCmask(i,j)) * &
3230 (((datu(i-1,j)*ubt(i-1,j) + uhbt0(i-1,j)) - &
3231 (datu(i,j)*ubt(i,j) + uhbt0(i,j))) + &
3232 ((datv(i,j-1)*vbt(i,j-1) + vhbt0(i,j-1)) - &
3233 (datv(i,j)*vbt(i,j) + vhbt0(i,j))))
3234 enddo ; enddo
3235 endif
3236 !$OMP end parallel
3237
3238end subroutine btloop_eta_predictor
3239
3240subroutine btloop_find_pf(PFu, PFv, isv, iev, jsv, jev, eta_PF_BT, eta_PF, &
3241 gtot_N, gtot_S, gtot_E, gtot_W, dgeo_de, find_etaav, &
3242 wt_accel2_n, eta_sum, v_first, G, US, CS)
3243 type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure.
3244 type(barotropic_cs), intent(inout) :: CS !< Barotropic control structure
3245 real, dimension(SZIBW_(CS),SZJW_(CS)), intent(inout) :: &
3246 PFu !< The anomalous zonal pressure force acceleration [L T-2 ~> m s-2].
3247 real, dimension(SZIW_(CS),SZJBW_(CS)), intent(inout) :: &
3248 PFv !< The meridional pressure force acceleration [L T-2 ~> m s-2].
3249 integer, intent(in) :: isv !< The starting i-index of eta being set in ths loop
3250 integer, intent(in) :: iev !< The ending i-index of eta_pred being set in ths loop
3251 integer, intent(in) :: jsv !< The starting j-index of eta_pred being set in ths loop
3252 integer, intent(in) :: jev !< The ending j-index of eta_pred being set in ths loop
3253 real, dimension(SZIW_(CS),SZJW_(CS)), intent(in) :: &
3254 eta_PF_BT !< The eta array (either the SSH anomaly or column mass) that
3255 !! determines the barotropic pressure force [H ~> m or kg m-2]
3256 real, dimension(SZIW_(CS),SZJW_(CS)), intent(in) :: &
3257 eta_PF !< The input 2-D eta field (either SSH anomaly or column mass)
3258 !! that was used to calculate the input pressure gradient
3259 !! accelerations [H ~> m or kg m-2].
3260 real, dimension(SZIW_(CS),SZJW_(CS)), intent(in) :: &
3261 gtot_N !< The effective total reduced gravity used to relate free surface height
3262 !! deviations to pressure forces (including GFS and baroclinic contributions)
3263 !! in the barotropic momentum equations half a grid-point to the north of a
3264 !! thickness point [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2].
3265 real, dimension(SZIW_(CS),SZJW_(CS)), intent(in) :: &
3266 gtot_S !< The effective total reduced gravity used to relate free surface height
3267 !! deviations to pressure forces (including GFS and baroclinic contributions)
3268 !! in the barotropic momentum equations half a grid-point to the south of a
3269 !! thickness point [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2].
3270 !! (See Hallberg, J Comp Phys 1997 for a discussion of gtot_E and gtot_W.)
3271 real, dimension(SZIW_(CS),SZJW_(CS)), intent(in) :: &
3272 gtot_E !< The effective total reduced gravity used to relate free surface height
3273 !! deviations to pressure forces (including GFS and baroclinic contributions)
3274 !! in the barotropic momentum equations half a grid-point to the east of a
3275 !! thickness point [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2].
3276 real, dimension(SZIW_(CS),SZJW_(CS)), intent(in) :: &
3277 gtot_W !< The effective total reduced gravity used to relate free surface height
3278 !! deviations to pressure forces (including GFS and baroclinic contributions)
3279 !! in the barotropic momentum equations half a grid-point to the west of a
3280 !! thickness point [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2].
3281 !! (See Hallberg, J Comp Phys 1997 for a discussion of gtot_E and gtot_W.)
3282 real, intent(in) :: dgeo_de !< The constant of proportionality between geopotential and
3283 !! sea surface height [nondim]. It is of order 1, but for stability this
3284 !! may be made larger than the physical problem would suggest.
3285 logical, intent(in) :: find_etaav !< If true, diagnose the time mean value of eta
3286 real, intent(in) :: wt_accel2_n !< The weighting value of wt_accel2 at step n.
3287 real, dimension(SZIW_(CS),SZJW_(CS)), intent(inout) :: &
3288 eta_sum !< A weighted running sum of eta summed across the timesteps [H ~> m or kg m-2]
3289 logical, intent(in) :: v_first !< If true, update the v-velocity first with the present loop iteration
3290 type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
3291
3292 ! Local variables
3293 integer :: i, j, js_u, je_u, is_v, ie_v
3294
3295 ! Ensure that the extra points used for the temporally staggered Coriolis terms are updated.
3296 if (v_first) then
3297 is_v = isv-1 ; ie_v = iev+1 ; js_u = jsv ; je_u = jev
3298 else
3299 is_v = isv ; ie_v = iev ; js_u = jsv-1 ; je_u = jev+1
3300 endif
3301
3302 !$OMP do schedule(static)
3303 do j=js_u,je_u ; do i=isv-1,iev
3304 pfu(i,j) = (((eta_pf_bt(i,j)-eta_pf(i,j))*gtot_e(i,j)) - &
3305 ((eta_pf_bt(i+1,j)-eta_pf(i+1,j))*gtot_w(i+1,j))) * &
3306 dgeo_de * cs%IdxCu(i,j)
3307 enddo ; enddo
3308 !$OMP end do nowait
3309
3310 !$OMP do schedule(static)
3311 do j=jsv-1,jev ; do i=is_v,ie_v
3312 pfv(i,j) = (((eta_pf_bt(i,j)-eta_pf(i,j))*gtot_n(i,j)) - &
3313 ((eta_pf_bt(i,j+1)-eta_pf(i,j+1))*gtot_s(i,j+1))) * &
3314 dgeo_de * cs%IdyCv(i,j)
3315 enddo ; enddo
3316 !$OMP end do nowait
3317
3318 if (find_etaav .and. (abs(wt_accel2_n) > 0.0)) then
3319 !$OMP do
3320 do j=g%jsc,g%jec ; do i=g%isc,g%iec
3321 eta_sum(i,j) = eta_sum(i,j) + wt_accel2_n * eta_pf_bt(i,j)
3322 enddo ; enddo
3323 !$OMP end do nowait
3324 endif
3325
3326end subroutine btloop_find_pf
3327
3328!> This routine adds a dynamic pressure force based on the temporal changes in the predicted value
3329!! of eta, perhaps as an effective divergence damping to emulate the rigidity of an ice-sheet.
3330subroutine btloop_add_dyn_pf(PFu, PFv, eta_pred, eta, dyn_coef_eta, p_surf_dyn, &
3331 isv, iev, jsv, jev, v_first, G, US, CS)
3332 type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure.
3333 type(barotropic_cs), intent(inout) :: CS !< Barotropic control structure
3334 real, dimension(SZIBW_(CS),SZJW_(CS)), intent(inout) :: &
3335 PFu !< The anomalous zonal pressure force acceleration [L T-2 ~> m s-2].
3336 real, dimension(SZIW_(CS),SZJBW_(CS)), intent(inout) :: &
3337 PFv !< The meridional pressure force acceleration [L T-2 ~> m s-2].
3338 real, dimension(SZIW_(CS),SZJW_(CS)), intent(in) :: &
3339 eta_pred !< The updated eta field (either SSH anomaly or column mass anomaly) that is
3340 !! used to estimate the divergence that is to be damped [H ~> m or kg m-2].
3341 real, dimension(SZIW_(CS),SZJW_(CS)), intent(in) :: &
3342 eta !< The previous eta field (either SSH anomaly or column mass) that is
3343 !! used to estimate the divergence that is to be damped [H ~> m or kg m-2].
3344 real, dimension(SZIW_(CS),SZJW_(CS)), intent(in) :: &
3345 dyn_coef_eta !< The coefficient relating the changes in eta to the dynamic surface pressure
3346 !! under rigid ice [L2 T-2 H-1 ~> m s-2 or m4 s-2 kg-1].
3347 real, dimension(SZIW_(CS),SZJW_(CS)), intent(inout) :: &
3348 p_surf_dyn !< A dynamic surface pressure under rigid ice [L2 T-2 ~> m2 s-2].
3349 integer, intent(in) :: isv !< The starting i-index of eta being set in ths loop
3350 integer, intent(in) :: iev !< The ending i-index of eta_pred being set in ths loop
3351 integer, intent(in) :: jsv !< The starting j-index of eta_pred being set in ths loop
3352 integer, intent(in) :: jev !< The ending j-index of eta_pred being set in ths loop
3353 logical, intent(in) :: v_first !< If true, update the v-velocity first with the present loop iteration
3354 type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
3355
3356 ! Local variables
3357 integer :: i, j, js_u, je_u, is_v, ie_v
3358
3359 ! Ensure that the extra points used for the temporally staggered Coriolis terms are updated.
3360 if (v_first) then
3361 is_v = isv-1 ; ie_v = iev+1 ; js_u = jsv ; je_u = jev
3362 else
3363 is_v = isv ; ie_v = iev ; js_u = jsv-1 ; je_u = jev+1
3364 endif
3365
3366 ! Use the change in eta to estimate the flow divergence and dynamic pressure.
3367 !$OMP do
3368 do j=jsv-1,jev+1 ; do i=isv-1,iev+1
3369 p_surf_dyn(i,j) = dyn_coef_eta(i,j) * (eta_pred(i,j) - eta(i,j))
3370 enddo ; enddo
3371
3372 !$OMP do schedule(static)
3373 do j=js_u,je_u ; do i=isv-1,iev
3374 pfu(i,j) = pfu(i,j) + (p_surf_dyn(i,j) - p_surf_dyn(i+1,j)) * cs%IdxCu(i,j)
3375 enddo ; enddo
3376 !$OMP end do nowait
3377 !$OMP do schedule(static)
3378 do j=jsv-1,jev ; do i=is_v,ie_v
3379 pfv(i,j) = pfv(i,j) + (p_surf_dyn(i,j) - p_surf_dyn(i,j+1)) * cs%IdyCv(i,j)
3380 enddo ; enddo
3381 !$OMP end do nowait
3382
3383end subroutine btloop_add_dyn_pf
3384
3385!> Update meridional velocity.
3386subroutine btloop_update_v(dtbt, ubt, vbt, v_accel_bt, &
3387 Cor_v, PFv, is_v, ie_v, Js_v, Je_v, f_4_v, &
3388 bt_rem_v, BT_force_v, Cor_ref_v, Rayleigh_v, &
3389 wt_accel_n, G, US, CS, Cor_bracket_bug)
3390 type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure.
3391 type(barotropic_cs), intent(inout) :: CS !< Barotropic control structure
3392 real, dimension(SZIBW_(CS),SZJW_(CS)), intent(in) :: &
3393 ubt !< The zonal barotropic velocity [L T-1 ~> m s-1].
3394 real, dimension(SZIW_(CS),SZJBW_(CS)), intent(inout) :: &
3395 vbt !< The meridional barotropic velocity [L T-1 ~> m s-1].
3396 real, dimension(SZIW_(CS),SZJBW_(CS)), intent(inout) :: &
3397 v_accel_bt !< The difference between the meridional acceleration from the
3398 !! barotropic calculation and BT_force_v [L T-2 ~> m s-2].
3399 real, dimension(SZIW_(CS),SZJBW_(CS)), intent(inout) :: &
3400 Cor_v !< The meridional Coriolis acceleration [L T-2 ~> m s-2]
3401 real, dimension(SZIW_(CS),SZJBW_(CS)), intent(in) :: &
3402 PFv !< The meridional pressure force acceleration [L T-2 ~> m s-2].
3403 real, dimension(4,SZIW_(CS),SZJBW_(CS)), intent(in) :: &
3404 f_4_v !< The terms giving the contribution to the Coriolis acceleration at a meridional
3405 !! velocity point from the neighboring meridional velocity anomalies [T-1 ~> s-1].
3406 !! These are the products of thicknesses at u points and appropriately staggered
3407 !! averaged pseudo potential vorticities, but with sufficiently smooth topography
3408 !! they are approximately f / 4. The 4 values on the innermost loop are for
3409 !! u-velocities to the southwest, southeast, northwest and northeast.
3410 integer, intent(in) :: is_v !< The starting i-index of the range of v-point values to calculate
3411 integer, intent(in) :: ie_v !< The ending i-index of the range of v-point values to calculate
3412 integer, intent(in) :: Js_v !< The starting j-index of the range of v-point values to calculate
3413 integer, intent(in) :: Je_v !< The ending j-index of the range of v-point values to calculate
3414 real, dimension(SZIW_(CS),SZJBW_(CS)), intent(in) :: &
3415 bt_rem_v !< The fraction of the barotropic meridional velocity that
3416 !! remains after a time step, the rest being lost to bottom
3417 !! drag [nondim]. bt_rem_v is between 0 and 1.
3418 real, dimension(SZIW_(CS),SZJBW_(CS)), intent(in) :: &
3419 BT_force_v !< The vertical average of all of the v-accelerations that are
3420 !! not explicitly included in the barotropic equation [L T-2 ~> m s-2].
3421 real, dimension(SZIW_(CS),SZJBW_(CS)), intent(in) :: &
3422 Cor_ref_v !< The meridional barotropic Coriolis acceleration due
3423 !! to the reference velocities [L T-2 ~> m s-2].
3424 real, dimension(SZIW_(CS),SZJBW_(CS)), intent(in) :: &
3425 Rayleigh_v !< A Rayleigh drag timescale operating at v-points for drag parameterizations
3426 !! that introduced directly into the barotropic solver rather than coming
3427 !! in via the visc_rem_v arrays from the layered equations [T-1 ~> s-1]
3428 real, intent(in) :: wt_accel_n !< The raw or relative weights of each of the barotropic timesteps
3429 !! in determining the average accelerations [nondim]
3430 real, intent(in) :: dtbt !< The barotropic time step [T ~> s].
3431 type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
3432 logical, optional, intent(in) :: Cor_bracket_bug !< If present and true, use an order of operations that is
3433 !! not bitwise rotationally symmetric in the meridional Coriolis term
3434
3435 ! Local variables
3436 logical :: use_bracket_bug
3437 integer :: i, j
3438
3439 use_bracket_bug = .false. ; if (present(cor_bracket_bug)) use_bracket_bug = cor_bracket_bug
3440
3441 ! The bracket bug only applies if v is second, use ioff to check.
3442 if (use_bracket_bug) then
3443 !$OMP do schedule(static)
3444 do j=js_v,je_v ; do i=is_v,ie_v
3445 cor_v(i,j) = -1.0*(((f_4_v(1,i,j) * ubt(i-1,j)) + (f_4_v(2,i,j) * ubt(i,j))) + &
3446 ((f_4_v(4,i,j) * ubt(i,j+1)) + (f_4_v(3,i,j) * ubt(i-1,j+1)))) - cor_ref_v(i,j)
3447 enddo ; enddo
3448 !$OMP end do nowait
3449 else
3450 !$OMP do schedule(static)
3451 do j=js_v,je_v ; do i=is_v,ie_v
3452 cor_v(i,j) = -1.0*(((f_4_v(1,i,j) * ubt(i-1,j)) + (f_4_v(4,i,j) * ubt(i,j+1))) + &
3453 ((f_4_v(2,i,j) * ubt(i,j)) + (f_4_v(3,i,j) * ubt(i-1,j+1)))) - cor_ref_v(i,j)
3454 enddo ; enddo
3455 !$OMP end do nowait
3456 endif
3457
3458 !$OMP do schedule(static)
3459 ! This updates the v-velocity, except at OBC points.
3460 do j=js_v,je_v ; do i=is_v,ie_v
3461 vbt(i,j) = bt_rem_v(i,j) * (vbt(i,j) + &
3462 dtbt * ((bt_force_v(i,j) + cor_v(i,j)) + pfv(i,j)))
3463 if (abs(vbt(i,j)) < cs%vel_underflow) vbt(i,j) = 0.0
3464 enddo ; enddo
3465 !$OMP end do nowait
3466
3467 if (cs%linear_wave_drag) then
3468 !$OMP do schedule(static)
3469 do j=js_v,je_v ; do i=is_v,ie_v
3470 v_accel_bt(i,j) = v_accel_bt(i,j) + wt_accel_n * &
3471 ((cor_v(i,j) + pfv(i,j)) - vbt(i,j)*rayleigh_v(i,j))
3472 enddo ; enddo
3473 else
3474 !$OMP do schedule(static)
3475 do j=js_v,je_v ; do i=is_v,ie_v
3476 v_accel_bt(i,j) = v_accel_bt(i,j) + wt_accel_n * (cor_v(i,j) + pfv(i,j))
3477 enddo ; enddo
3478 endif
3479
3480end subroutine btloop_update_v
3481
3482!> Update zonal velocity.
3483subroutine btloop_update_u(dtbt, ubt, vbt, u_accel_bt, &
3484 Cor_u, PFu, Is_u, Ie_u, js_u, je_u, f_4_u, &
3485 bt_rem_u, BT_force_u, Cor_ref_u, Rayleigh_u, &
3486 wt_accel_n, G, US, CS)
3487 type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure.
3488 type(barotropic_cs), intent(inout) :: CS !< Barotropic control structure
3489 real, intent(in) :: dtbt !< The barotropic time step [T ~> s].
3490 real, dimension(SZIBW_(CS),SZJW_(CS)), intent(inout) :: &
3491 ubt !< The zonal barotropic velocity [L T-1 ~> m s-1].
3492 real, dimension(SZIW_(CS),SZJBW_(CS)), intent(in) :: &
3493 vbt !< The meridional barotropic velocity [L T-1 ~> m s-1].
3494 real, dimension(SZIBW_(CS),SZJW_(CS)), intent(inout) :: &
3495 u_accel_bt !! The difference between the zonal acceleration from the
3496 !< barotropic calculation and BT_force_v [L T-2 ~> m s-2].
3497 real, dimension(SZIBW_(CS),SZJW_(CS)), intent(inout) :: &
3498 Cor_u !< The anomalous zonal Coriolis acceleration [L T-2 ~> m s-2]
3499 real, dimension(SZIBW_(CS),SZJW_(CS)), intent(in) :: &
3500 PFu !< The anomalous zonal pressure force acceleration [L T-2 ~> m s-2].
3501 integer, intent(in) :: Is_u !< The starting i-index of the range of u-point values to calculate
3502 integer, intent(in) :: Ie_u !< The ending i-index of the range of u-point values to calculate
3503 integer, intent(in) :: js_u !< The starting j-index of the range of u-point values to calculate
3504 integer, intent(in) :: je_u !< The ending j-index of the range of u-point values to calculate
3505 real, dimension(4,SZIBW_(CS),SZJW_(CS)), intent(in) :: &
3506 f_4_u !< The terms giving the contribution to the Coriolis acceleration at a zonal
3507 !! velocity point from the neighboring meridional velocity anomalies [T-1 ~> s-1].
3508 !! These are the products of thicknesses at v points and appropriately staggered
3509 !! averaged pseudo potential vorticities, but with sufficiently smooth topography
3510 !! they are approximately f / 4. The 4 values on the innermost loop are for
3511 !! v-velocities to the southwest, southeast, northwest and northeast.
3512 real, dimension(SZIBW_(CS),SZJW_(CS)), intent(in) :: &
3513 bt_rem_u !< The fraction of the barotropic meridional velocity that
3514 !! remains after a time step, the rest being lost to bottom
3515 !! drag [nondim]. bt_rem_v is between 0 and 1.
3516 real, dimension(SZIBW_(CS),SZJW_(CS)), intent(in) :: &
3517 BT_force_u !< The vertical average of all of the v-accelerations that are
3518 !! not explicitly included in the barotropic equation [L T-2 ~> m s-2].
3519 real, dimension(SZIBW_(CS),SZJW_(CS)), intent(in) :: &
3520 Cor_ref_u !< The meridional barotropic Coriolis acceleration due
3521 !! to the reference velocities [L T-2 ~> m s-2].
3522 real, dimension(SZIBW_(CS),SZJW_(CS)), intent(in) :: &
3523 Rayleigh_u !< A Rayleigh drag timescale operating at u-points for drag parameterizations
3524 !! that introduced directly into the barotropic solver rather than coming
3525 !! in via the visc_rem_u arrays from the layered equations [T-1 ~> s-1].
3526 real, intent(in) :: wt_accel_n !< The raw or relative weights of each of the barotropic timesteps
3527 !! in determining the average accelerations [nondim]
3528 type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
3529
3530 ! Local variables
3531 integer :: i, j
3532
3533 !$OMP do schedule(static)
3534 do j=js_u,je_u ; do i=is_u,ie_u
3535 cor_u(i,j) = (((f_4_u(4,i,j) * vbt(i+1,j)) + (f_4_u(1,i,j) * vbt(i,j-1))) + &
3536 ((f_4_u(3,i,j) * vbt(i,j)) + (f_4_u(2,i,j) * vbt(i+1,j-1)))) - &
3537 cor_ref_u(i,j)
3538
3539 ubt(i,j) = bt_rem_u(i,j) * (ubt(i,j) + &
3540 dtbt * ((bt_force_u(i,j) + cor_u(i,j)) + pfu(i,j)))
3541 if (abs(ubt(i,j)) < cs%vel_underflow) ubt(i,j) = 0.0
3542 enddo ; enddo
3543 !$OMP end do nowait
3544
3545 if (cs%linear_wave_drag) then
3546 !$OMP do schedule(static)
3547 do j=js_u,je_u ; do i=is_u,ie_u
3548 u_accel_bt(i,j) = u_accel_bt(i,j) + wt_accel_n * &
3549 ((cor_u(i,j) + pfu(i,j)) - ubt(i,j)*rayleigh_u(i,j))
3550 enddo ; enddo
3551 !$OMP end do nowait
3552 else
3553 !$OMP do schedule(static)
3554 do j=js_u,je_u ; do i=is_u,ie_u
3555 u_accel_bt(i,j) = u_accel_bt(i,j) + wt_accel_n * (cor_u(i,j) + pfu(i,j))
3556 enddo ; enddo
3557 !$OMP end do nowait
3558 endif
3559
3560end subroutine btloop_update_u
3561
3562
3563!> Calculate the zonal and meridional velocity from the 3-D velocity.
3564subroutine btstep_ubt_from_layer(U_in, V_in, wt_u, wt_v, ubt, vbt, G, GV, CS)
3565 type(verticalgrid_type), intent(in) :: GV !< The ocean's vertical grid structure.
3566 type(barotropic_cs), intent(inout) :: CS !< Barotropic control structure
3567 type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure.
3568 real, intent(in) :: U_in(SZIB_(G),SZJ_(G),SZK_(GV)) !< The initial (3-D) zonal velocity [L T-1 ~> m s-1]
3569 real, intent(in) :: V_in(SZI_(G),SZJB_(G),SZK_(GV)) !< The initial (3-D) meridional velocity [L T-1 ~> m s-1]
3570 real, intent(in) :: wt_u(SZIB_(G),SZJ_(G),SZK_(GV)) !< The normalized weights to be used in calculating
3571 !! zonal barotropic velocities, possibly with sums
3572 !! less than one due to viscous losses [nondim]
3573 real, intent(in) :: wt_v(SZI_(G),SZJB_(G),SZK_(GV)) !< The normalized weights to be used in calculating
3574 !! meridional barotropic velocities, possibly with
3575 !! sums less than one due to viscous losses [nondim]
3576 real, intent(out) :: ubt(SZIBW_(CS),SZJW_(CS)) !< The zonal barotropic velocity [L T-1 ~> m s-1]
3577 real, intent(out) :: vbt(SZIW_(CS),SZJBW_(CS)) !< The meridional barotropic velocity [L T-1 ~> m s-1]
3578
3579 ! Local variables
3580 integer :: i, j, k, is, ie, js, je, nz
3581
3582 is = g%isc ; ie = g%iec ; js = g%jsc ; je = g%jec ; nz = gv%ke
3583
3584 ubt(:,:) = 0.0 ; vbt(:,:) = 0.0
3585
3586 !$OMP parallel do default(shared)
3587 do j=js,je ; do k=1,nz ; do i=is-1,ie
3588 ubt(i,j) = ubt(i,j) + wt_u(i,j,k) * u_in(i,j,k)
3589 enddo ; enddo ; enddo
3590 !$OMP parallel do default(shared)
3591 do j=js-1,je ; do k=1,nz ; do i=is,ie
3592 vbt(i,j) = vbt(i,j) + wt_v(i,j,k) * v_in(i,j,k)
3593 enddo ; enddo ; enddo
3594
3595 !$OMP parallel do default(shared)
3596 do j=js,je ; do i=is-1,ie
3597 if (abs(ubt(i,j)) < cs%vel_underflow) ubt(i,j) = 0.0
3598 enddo ; enddo
3599 !$OMP parallel do default(shared)
3600 do j=js-1,je ; do i=is,ie
3601 if (abs(vbt(i,j)) < cs%vel_underflow) vbt(i,j) = 0.0
3602 enddo ; enddo
3603
3604end subroutine btstep_ubt_from_layer
3605
3606
3607!> Calculate the zonal and meridional acceleration of each layer due to the barotropic calculation.
3608subroutine btstep_layer_accel(dt, u_accel_bt, v_accel_bt, pbce, gtot_E, gtot_W, gtot_N, gtot_S, &
3609 e_anom, G, GV, CS, accel_layer_u, accel_layer_v)
3610 type(barotropic_cs), intent(inout) :: CS !< Barotropic control structure
3611 type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure.
3612 type(verticalgrid_type), intent(in) :: GV !< The ocean's vertical grid structure.
3613 real, intent(in) :: dt !< The time increment to integrate over [T ~> s].
3614 real, dimension(SZIBW_(CS),SZJW_(CS)), intent(in) :: &
3615 u_accel_bt !< The difference between the zonal acceleration from the
3616 !! barotropic calculation and BT_force_u [L T-2 ~> m s-2].
3617 real, dimension(SZIW_(CS),SZJBW_(CS)), intent(in) :: &
3618 v_accel_bt !< The difference between the meridional acceleration from the
3619 !! barotropic calculation and BT_force_v [L T-2 ~> m s-2].
3620 real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: pbce !< The baroclinic pressure anomaly in each layer
3621 !! due to free surface height anomalies
3622 !! [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2].
3623 real, dimension(SZIW_(CS),SZJW_(CS)), intent(in) :: &
3624 gtot_E !< The effective total reduced gravity used to relate free surface height
3625 !! deviations to pressure forces (including GFS and baroclinic contributions)
3626 !! in the barotropic momentum equations half a grid-point to the east of a
3627 !! thickness point [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2].
3628 real, dimension(SZIW_(CS),SZJW_(CS)), intent(in) :: &
3629 gtot_W !< The effective total reduced gravity used to relate free surface height
3630 !! deviations to pressure forces (including GFS and baroclinic contributions)
3631 !! in the barotropic momentum equations half a grid-point to the west of a
3632 !! thickness point [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2].
3633 real, dimension(SZIW_(CS),SZJW_(CS)), intent(in) :: &
3634 gtot_N !< The effective total reduced gravity used to relate free surface height
3635 !! deviations to pressure forces (including GFS and baroclinic contributions)
3636 !! in the barotropic momentum equations half a grid-point to the north of a
3637 !! thickness point [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2].
3638 real, dimension(SZIW_(CS),SZJW_(CS)), intent(in) :: &
3639 gtot_S !< The effective total reduced gravity used to relate free surface height
3640 !! deviations to pressure forces (including GFS and baroclinic contributions)
3641 !! in the barotropic momentum equations half a grid-point to the south of a
3642 !! thickness point [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2].
3643 !! (See Hallberg, J Comp Phys 1997 for a discussion of gtot_E, etc.)
3644 real, dimension(SZI_(G),SZJ_(G)), intent(in) :: &
3645 e_anom !< The anomaly in the sea surface height or column mass
3646 !! averaged between the beginning and end of the time step,
3647 !! relative to eta_PF, with SAL effects included [H ~> m or kg m-2].
3648 real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(out) :: accel_layer_u !< The zonal acceleration of each layer due
3649 !! to the barotropic calculation [L T-2 ~> m s-2].
3650 real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(out) :: accel_layer_v !< The meridional acceleration of each layer
3651 !! due to the barotropic calculation [L T-2 ~> m s-2].
3652
3653 ! Local variables
3654 real :: accel_underflow ! An acceleration that is so small it should be zeroed out [L T-2 ~> m s-2].
3655 real :: Idt ! The inverse of dt [T-1 ~> s-1].
3656 integer :: i, j, k, is, ie, js, je, nz
3657
3658 is = g%isc ; ie = g%iec ; js = g%jsc ; je = g%jec ; nz = gv%ke
3659
3660 idt = 1.0 / dt
3661 accel_underflow = cs%vel_underflow * idt
3662
3663 ! Now calculate each layer's accelerations.
3664 !$OMP parallel do default(shared)
3665 do k=1,nz
3666 do j=js,je ; do i=is-1,ie
3667 accel_layer_u(i,j,k) = (u_accel_bt(i,j) - &
3668 (((pbce(i+1,j,k) - gtot_w(i+1,j)) * e_anom(i+1,j)) - &
3669 ((pbce(i,j,k) - gtot_e(i,j)) * e_anom(i,j))) * cs%IdxCu(i,j) )
3670 if (abs(accel_layer_u(i,j,k)) < accel_underflow) accel_layer_u(i,j,k) = 0.0
3671 enddo ; enddo
3672 do j=js-1,je ; do i=is,ie
3673 accel_layer_v(i,j,k) = (v_accel_bt(i,j) - &
3674 (((pbce(i,j+1,k) - gtot_s(i,j+1)) * e_anom(i,j+1)) - &
3675 ((pbce(i,j,k) - gtot_n(i,j)) * e_anom(i,j))) * cs%IdyCv(i,j) )
3676 if (abs(accel_layer_v(i,j,k)) < accel_underflow) accel_layer_v(i,j,k) = 0.0
3677 enddo ; enddo
3678 enddo
3679
3680end subroutine btstep_layer_accel
3681
3682!> This subroutine automatically determines an optimal value for dtbt based on some state of the ocean. Either pbce or
3683!! gtot_est is required to calculate gravitational acceleration. Column thickness can be estimated using BT_cont, eta,
3684!! and SSH_add (default=0), with priority given in that order. The subroutine sets CS%dtbt_max and CS%dtbt.
3685subroutine set_dtbt(G, GV, US, CS, pbce, gtot_est, BT_cont, eta, SSH_add, Time)
3686 type(ocean_grid_type), intent(inout) :: g !< The ocean's grid structure.
3687 type(verticalgrid_type), intent(in) :: gv !< The ocean's vertical grid structure.
3688 type(unit_scale_type), intent(in) :: us !< A dimensional unit scaling type
3689 type(barotropic_cs), intent(inout) :: cs !< Barotropic control structure
3690 real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), &
3691 optional, intent(in) :: pbce !< The baroclinic pressure anomaly in each layer due to free
3692 !! surface height anomalies [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2].
3693 real, optional, intent(in) :: gtot_est !< An estimate of the total gravitational acceleration
3694 !! [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2].
3695 type(bt_cont_type), optional, pointer :: bt_cont !< A structure with elements that describe the effective open
3696 !! face areas as a function of barotropic flow.
3697 real, dimension(SZI_(G),SZJ_(G)), &
3698 optional, intent(in) :: eta !< The barotropic free surface height anomaly or column mass
3699 !! anomaly [H ~> m or kg m-2].
3700 real, optional, intent(in) :: ssh_add !< An additional contribution to SSH to provide a margin of
3701 !! error when calculating the external wave speed [Z ~> m].
3702 type(time_type), optional, intent(in) :: time !< Model time at the beginning of the baroclinic time step.
3703
3704 ! Local variables
3705 real, dimension(SZI_(G),SZJ_(G)) :: &
3706 gtot_e, & ! gtot_X is the effective total reduced gravity used to relate
3707 gtot_w, & ! free surface height deviations to pressure forces (including
3708 gtot_n, & ! GFS and baroclinic contributions) in the barotropic momentum
3709 gtot_s ! equations half a grid-point in the X-direction (X is N, S, E, or W)
3710 ! from the thickness point [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2].
3711 ! (See Hallberg, J Comp Phys 1997 for a discussion.)
3712 real, dimension(SZIBS_(G),SZJ_(G)) :: &
3713 datu ! Basin depth at u-velocity grid points times the y-grid
3714 ! spacing [H L ~> m2 or kg m-1].
3715 real, dimension(SZI_(G),SZJBS_(G)) :: &
3716 datv ! Basin depth at v-velocity grid points times the x-grid
3717 ! spacing [H L ~> m2 or kg m-1].
3718 real :: det_de ! The partial derivative due to self-attraction and loading
3719 ! of the reference geopotential with the sea surface height [nondim].
3720 ! This is typically ~0.09 or less.
3721 real :: dgeo_de ! The constant of proportionality between geopotential and
3722 ! sea surface height [nondim]. It is a nondimensional number of
3723 ! order 1. For stability, this may be made larger
3724 ! than physical problem would suggest.
3725 real :: add_ssh ! An additional contribution to SSH to provide a margin of error
3726 ! when calculating the external wave speed [Z ~> m].
3727 real :: min_max_dt2 ! The square of the minimum value of the largest stable barotropic
3728 ! timesteps [T2 ~> s2]
3729 real :: dtbt_max ! The maximum barotropic timestep [T ~> s]
3730 real :: idt_max2 ! The squared inverse of the local maximum stable
3731 ! barotropic time step [T-2 ~> s-2].
3732 logical :: use_bt_cont
3733 type(memory_size_type) :: ms
3734 character(len=200) :: mesg
3735 integer :: yr, mon, day, hr, minute, sec
3736 integer :: i, j, k, is, ie, js, je, nz
3737
3738 if (.not.cs%module_is_initialized) call mom_error(fatal, &
3739 "set_dtbt: Module MOM_barotropic must be initialized before it is used.")
3740
3741 if (.not.cs%split) return
3742 is = g%isc ; ie = g%iec ; js = g%jsc ; je = g%jec ; nz = gv%ke
3743 ms%isdw = g%isd ; ms%iedw = g%ied ; ms%jsdw = g%jsd ; ms%jedw = g%jed
3744
3745
3746 if (.not.(present(pbce) .or. present(gtot_est))) call mom_error(fatal, &
3747 "set_dtbt: Either pbce or gtot_est must be present.")
3748
3749 add_ssh = 0.0 ; if (present(ssh_add)) add_ssh = ssh_add
3750
3751 use_bt_cont = .false.
3752 if (present(bt_cont)) use_bt_cont = (associated(bt_cont))
3753
3754 if (use_bt_cont) then
3755 call bt_cont_to_face_areas(bt_cont, datu, datv, g, us, ms, halo=0)
3756 elseif (cs%Nonlinear_continuity .and. present(eta)) then
3757 call find_face_areas(datu, datv, g, gv, us, cs, ms, 0, eta=eta)
3758 else
3759 call find_face_areas(datu, datv, g, gv, us, cs, ms, 0, add_max=add_ssh)
3760 endif
3761
3762 det_de = 0.0
3763 if (cs%calculate_SAL) call scalar_sal_sensitivity(cs%SAL_CSp, det_de)
3764 if (cs%tidal_sal_bug) then
3765 dgeo_de = 1.0 + max(0.0, det_de + cs%G_extra)
3766 else
3767 dgeo_de = 1.0 + max(0.0, cs%G_extra - det_de)
3768 endif
3769 if (present(pbce)) then
3770 do j=js,je ; do i=is,ie
3771 gtot_e(i,j) = 0.0 ; gtot_w(i,j) = 0.0
3772 gtot_n(i,j) = 0.0 ; gtot_s(i,j) = 0.0
3773 enddo ; enddo
3774 do k=1,nz ; do j=js,je ; do i=is,ie
3775 gtot_e(i,j) = gtot_e(i,j) + pbce(i,j,k) * cs%frhatu(i,j,k)
3776 gtot_w(i,j) = gtot_w(i,j) + pbce(i,j,k) * cs%frhatu(i-1,j,k)
3777 gtot_n(i,j) = gtot_n(i,j) + pbce(i,j,k) * cs%frhatv(i,j,k)
3778 gtot_s(i,j) = gtot_s(i,j) + pbce(i,j,k) * cs%frhatv(i,j-1,k)
3779 enddo ; enddo ; enddo
3780 else
3781 do j=js,je ; do i=is,ie
3782 gtot_e(i,j) = gtot_est ; gtot_w(i,j) = gtot_est
3783 gtot_n(i,j) = gtot_est ; gtot_s(i,j) = gtot_est
3784 enddo ; enddo
3785 endif
3786
3787 min_max_dt2 = 1.0e38*us%s_to_T**2 ! A huge value for the permissible timestep squared.
3788 do j=js,je ; do i=is,ie
3789 ! This is pretty accurate for gravity waves, but it is a conservative
3790 ! estimate since it ignores the stabilizing effect of the bottom drag.
3791 idt_max2 = 0.5 * (1.0 + 2.0*cs%bebt) * (g%IareaT(i,j) * &
3792 (((gtot_e(i,j)*datu(i,j)*g%IdxCu(i,j)) + (gtot_w(i,j)*datu(i-1,j)*g%IdxCu(i-1,j))) + &
3793 ((gtot_n(i,j)*datv(i,j)*g%IdyCv(i,j)) + (gtot_s(i,j)*datv(i,j-1)*g%IdyCv(i,j-1)))) + &
3794 ((g%Coriolis2Bu(i,j) + g%Coriolis2Bu(i-1,j-1)) + &
3795 (g%Coriolis2Bu(i-1,j) + g%Coriolis2Bu(i,j-1))) * cs%BT_Coriolis_scale**2 )
3796 if (idt_max2 * min_max_dt2 > 1.0) min_max_dt2 = 1.0 / idt_max2
3797 enddo ; enddo
3798 dtbt_max = sqrt(min_max_dt2 / dgeo_de)
3799 if (id_clock_sync > 0) call cpu_clock_begin(id_clock_sync)
3800 call min_across_pes(dtbt_max)
3801 if (id_clock_sync > 0) call cpu_clock_end(id_clock_sync)
3802
3803 cs%dtbt = cs%dtbt_fraction * dtbt_max
3804 cs%dtbt_max = dtbt_max
3805
3806 if (is_root_pe() .and. present(time)) then
3807 call get_date(time, yr, mon, day, hr, minute, sec)
3808 write(mesg, '("DTBT reset by set_dtbt at ",i4.4,"-",i2.2,"-",i2.2," ",i2.2,":",i2.2,":",i2.2, &
3809 & ", dtbt = ",ES12.6," s, dtbt_max = ",ES12.6," s")') &
3810 yr, mon, day, hr, minute, sec, (us%T_to_s*cs%dtbt), (us%T_to_s*dtbt_max)
3811 call mom_mesg(mesg, 3)
3812 endif
3813
3814 if (cs%debug) then
3815 call chksum0(cs%dtbt, "End set_dtbt dtbt", unscale=us%T_to_s)
3816 call chksum0(cs%dtbt_max, "End set_dtbt dtbt_max", unscale=us%T_to_s)
3817 endif
3818
3819end subroutine set_dtbt
3820
3821! The following 5 subroutines apply the open boundary conditions.
3822
3823!> This subroutine applies the open boundary conditions on barotropic zonal
3824!! velocities and mass transports, as developed by Mehmet Ilicak.
3825subroutine apply_u_velocity_obcs(ubt, uhbt, ubt_trans, eta, SpV_avg, ubt_old, BT_OBC, G, MS, &
3826 GV, US, CS, halo, dtbt, bebt, use_BT_cont, integral_BT_cont, dt_elapsed, &
3827 Datu, BTCL_u, uhbt0, ubt_int, ubt_int_prev, uhbt_int, uhbt_int_prev)
3828 type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure.
3829 type(memory_size_type), intent(in) :: MS !< A type that describes the memory sizes of
3830 !! the argument arrays.
3831 real, dimension(SZIBW_(MS),SZJW_(MS)), intent(inout) :: ubt !< the zonal barotropic velocity [L T-1 ~> m s-1].
3832 real, dimension(SZIBW_(MS),SZJW_(MS)), intent(inout) :: uhbt !< the zonal barotropic transport
3833 !! [H L2 T-1 ~> m3 s-1 or kg s-1].
3834 real, dimension(SZIBW_(MS),SZJW_(MS)), intent(inout) :: ubt_trans !< The zonal barotropic velocity used in
3835 !! transport [L T-1 ~> m s-1].
3836 real, dimension(SZIW_(MS),SZJW_(MS)), intent(in) :: eta !< The barotropic free surface height anomaly or
3837 !! column mass anomaly [H ~> m or kg m-2].
3838 real, dimension(SZIW_(MS),SZJW_(MS)), intent(in) :: SpV_avg !< The column average specific volume [R-1 ~> m3 kg-1]
3839 real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: ubt_old !< The starting value of ubt in a barotropic
3840 !! step [L T-1 ~> m s-1].
3841 type(bt_obc_type), intent(in) :: BT_OBC !< A structure with the private barotropic arrays
3842 !! related to the open boundary conditions,
3843 !! set by set_up_BT_OBC.
3844 type(verticalgrid_type), intent(in) :: GV !< The ocean's vertical grid structure.
3845 type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
3846 type(barotropic_cs), intent(in) :: CS !< Barotropic control structure
3847 integer, intent(in) :: halo !< The extra halo size to use here.
3848 real, intent(in) :: dtbt !< The time step [T ~> s].
3849 real, intent(in) :: bebt !< The fractional weighting of the future velocity
3850 !! in determining the transport [nondim]
3851 logical, intent(in) :: use_BT_cont !< If true, use the BT_cont_types to calculate
3852 !! transports.
3853 logical, intent(in) :: integral_BT_cont !< If true, update the barotropic continuity
3854 !! equation directly from the initial condition
3855 !! using the time-integrated barotropic velocity.
3856 real, intent(in) :: dt_elapsed !< The amount of time in the barotropic stepping
3857 !! that will have elapsed [T ~> s].
3858 real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: Datu !< A fixed estimate of the face areas at u points
3859 !! [H L ~> m2 or kg m-1].
3860 type(local_bt_cont_u_type), dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: BTCL_u !< Structure of information used
3861 !! for a dynamic estimate of the face areas at
3862 !! u-points.
3863 real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: uhbt0 !< A correction to the zonal transport so that
3864 !! the barotropic functions agree with the sum
3865 !! of the layer transports
3866 !! [H L2 T-1 ~> m3 s-1 or kg s-1].
3867 real, dimension(SZIBW_(MS),SZJW_(MS)), intent(inout) :: ubt_int !< The time-integrated zonal barotropic
3868 !! velocity after this update [L T-1 ~> m s-1]
3869 real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: ubt_int_prev !< The time-integrated zonal barotropic
3870 !! velocity before this update [L T-1 ~> m s-1]
3871 real, dimension(SZIBW_(MS),SZJW_(MS)), intent(inout) :: uhbt_int !< The time-integrated zonal barotropic transport
3872 !! after this update [H L2 T-1 ~> m3 s-1 or kg s-1]
3873 real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: uhbt_int_prev !< The time-integrated zonal barotropic
3874 !! transport before this update
3875 !! [H L2 T-1 ~> m3 s-1 or kg s-1]
3876
3877 ! Local variables
3878 real :: vel_prev ! The previous velocity [L T-1 ~> m s-1].
3879 real :: cfl ! The CFL number at the point in question [nondim]
3880 real :: u_inlet ! The zonal inflow velocity [L T-1 ~> m s-1]
3881 real :: uhbt_int_new ! The updated time-integrated zonal transport [H L2 ~> m3]
3882 real :: ssh_in ! The inflow sea surface height [Z ~> m]
3883 real :: ssh_1 ! The sea surface height in the interior cell adjacent to the an OBC face [Z ~> m]
3884 real :: ssh_2 ! The sea surface height in the next cell inward from the OBC face [Z ~> m]
3885 real :: Idtbt ! The inverse of the barotropic time step [T-1 ~> s-1]
3886 integer :: i, j, Is_u, Ie_u, js, je
3887
3888 if (.not.bt_obc%u_OBCs_on_PE) return
3889
3890 idtbt = 1.0 / dtbt
3891
3892 ! Work on Eastern OBC points
3893 is_u = max((g%isc-1)-halo, bt_obc%Is_u_E_obc) ; ie_u = min(g%iec+halo, bt_obc%Ie_u_E_obc)
3894 js = max(g%jsc-halo, bt_obc%js_u_E_obc) ; je = min(g%jec+halo, bt_obc%je_u_E_obc)
3895 do j=js,je ; do i=is_u,ie_u ; if (bt_obc%u_OBC_type(i,j) > 0) then
3896 if (bt_obc%u_OBC_type(i,j) == specified_obc) then ! Eastern specified OBC
3897 uhbt(i,j) = bt_obc%uhbt(i,j)
3898 ubt(i,j) = bt_obc%ubt_outer(i,j)
3899 ubt_trans(i,j) = ubt(i,j)
3900 if (integral_bt_cont) then
3901 uhbt_int(i,j) = uhbt_int_prev(i,j) + dtbt * uhbt(i,j)
3902 ubt_int(i,j) = ubt_int_prev(i,j) + dtbt * ubt_trans(i,j)
3903 endif
3904 elseif (bt_obc%u_OBC_type(i,j) == flather_obc) then ! Eastern Flather OBC
3905 cfl = dtbt * bt_obc%Cg_u(i,j) * g%IdxCu(i,j) ! CFL
3906 u_inlet = cfl*ubt_old(i-1,j) + (1.0-cfl)*ubt_old(i,j) ! Valid for cfl<1
3907 if (i <= ms%isdw) then
3908 ! Do not apply an Eastern Flather OBC at the western halo points on a PE, as doing so would
3909 ! create a segmentation fault and this velocity will not propagate through to the next iteration.
3910 ssh_in = bt_obc%SSH_outer_u(i,j)
3911 elseif (gv%Boussinesq) then
3912 ssh_in = gv%H_to_Z*(eta(i,j) + (0.5-cfl)*(eta(i,j)-eta(i-1,j))) ! internal
3913 else
3914 ssh_1 = gv%H_to_RZ * eta(i,j) * spv_avg(i,j) - (cs%bathyT(i,j) + g%Z_ref)
3915 ssh_2 = gv%H_to_RZ * eta(i-1,j) * spv_avg(i-1,j) - (cs%bathyT(i-1,j) + g%Z_ref)
3916 ssh_in = ssh_1 + (0.5-cfl)*(ssh_1-ssh_2) ! internal
3917 endif
3918 if (bt_obc%dZ_u(i,j) > 0.0) then
3919 vel_prev = ubt(i,j)
3920 ubt(i,j) = 0.5*((u_inlet + bt_obc%ubt_outer(i,j)) + &
3921 (bt_obc%Cg_u(i,j)/bt_obc%dZ_u(i,j)) * (ssh_in-bt_obc%SSH_outer_u(i,j)))
3922 ubt_trans(i,j) = (1.0-bebt)*vel_prev + bebt*ubt(i,j)
3923 else ! This point is now dry.
3924 ubt(i,j) = 0.0
3925 ubt_trans(i,j) = 0.0
3926 endif
3927 elseif (bt_obc%u_OBC_type(i,j) == gradient_obc) then ! Eastern gradient OBC
3928 ubt(i,j) = ubt(i-1,j)
3929 ubt_trans(i,j) = ubt(i,j)
3930 endif
3931
3932 ! Reset transports and related time-inetegrated velocities with non-specified OBCs
3933 if (bt_obc%u_OBC_type(i,j) > specified_obc) then ! Eastern Flather or gradient OBC
3934 if (integral_bt_cont) then
3935 ubt_int(i,j) = ubt_int_prev(i,j) + dtbt * ubt_trans(i,j)
3936 uhbt_int_new = find_uhbt(ubt_int(i,j), btcl_u(i,j)) + dt_elapsed*uhbt0(i,j)
3937 uhbt(i,j) = (uhbt_int_new - uhbt_int_prev(i,j)) * idtbt
3938 uhbt_int(i,j) = uhbt_int_prev(i,j) + dtbt * uhbt(i,j)
3939 ! The line above is equivalent to: uhbt_int(I,j) = uhbt_int_new
3940 elseif (use_bt_cont) then
3941 uhbt(i,j) = find_uhbt(ubt_trans(i,j), btcl_u(i,j)) + uhbt0(i,j)
3942 else
3943 uhbt(i,j) = datu(i,j)*ubt_trans(i,j) + uhbt0(i,j)
3944 endif
3945 endif
3946
3947 endif ; enddo ; enddo
3948
3949 ! Work on Western OBC points
3950 is_u = max((g%isc-1)-halo, bt_obc%Is_u_W_obc) ; ie_u = min(g%iec+halo, bt_obc%Ie_u_W_obc)
3951 js = max(g%jsc-halo, bt_obc%js_u_W_obc) ; je = min(g%jec+halo, bt_obc%je_u_W_obc)
3952 do j=js,je ; do i=is_u,ie_u ; if (bt_obc%u_OBC_type(i,j) < 0) then
3953 if (bt_obc%u_OBC_type(i,j) == -specified_obc) then ! Western specified OBC
3954 uhbt(i,j) = bt_obc%uhbt(i,j)
3955 ubt(i,j) = bt_obc%ubt_outer(i,j)
3956 ubt_trans(i,j) = ubt(i,j)
3957 if (integral_bt_cont) then
3958 uhbt_int(i,j) = uhbt_int_prev(i,j) + dtbt * uhbt(i,j)
3959 ubt_int(i,j) = ubt_int_prev(i,j) + dtbt * ubt_trans(i,j)
3960 endif
3961 elseif (bt_obc%u_OBC_type(i,j) == -flather_obc) then ! Western Flather OBC
3962 cfl = dtbt * bt_obc%Cg_u(i,j) * g%IdxCu(i,j) ! CFL
3963 u_inlet = cfl*ubt_old(i+1,j) + (1.0-cfl)*ubt_old(i,j) ! Valid for cfl<1
3964 if (i >= ms%iedw-1) then
3965 ! Do not apply a Western Flather OBC at the eastern halo points on a PE, as doing so would
3966 ! create a segmentation fault and this velocity will not propagate through to the next iteration.
3967 ssh_in = bt_obc%SSH_outer_u(i,j)
3968 elseif (gv%Boussinesq) then
3969 ssh_in = gv%H_to_Z*(eta(i+1,j) + (0.5-cfl)*(eta(i+1,j)-eta(i+2,j))) ! internal
3970 else
3971 ssh_1 = gv%H_to_RZ * eta(i+1,j) * spv_avg(i+1,j) - (cs%bathyT(i+1,j) + g%Z_ref)
3972 ssh_2 = gv%H_to_RZ * eta(i+2,j) * spv_avg(i+2,j) - (cs%bathyT(i+2,j) + g%Z_ref)
3973 ssh_in = ssh_1 + (0.5-cfl)*(ssh_1-ssh_2) ! internal
3974 endif
3975
3976 if (bt_obc%dZ_u(i,j) > 0.0) then
3977 vel_prev = ubt(i,j)
3978 ubt(i,j) = 0.5*((u_inlet + bt_obc%ubt_outer(i,j)) + &
3979 (bt_obc%Cg_u(i,j)/bt_obc%dZ_u(i,j)) * (bt_obc%SSH_outer_u(i,j)-ssh_in))
3980 ubt_trans(i,j) = (1.0-bebt)*vel_prev + bebt*ubt(i,j)
3981 else ! This point is now dry.
3982 ubt(i,j) = 0.0
3983 ubt_trans(i,j) = 0.0
3984 endif
3985 elseif (bt_obc%u_OBC_type(i,j) == -gradient_obc) then ! Western gradient OBC
3986 ubt(i,j) = ubt(i+1,j)
3987 ubt_trans(i,j) = ubt(i,j)
3988 endif
3989
3990 ! Reset transports and related time-inetegrated velocities with non-specified OBCs
3991 if (bt_obc%u_OBC_type(i,j) < -specified_obc) then ! Western Flather or gradient OBC
3992 if (integral_bt_cont) then
3993 ubt_int(i,j) = ubt_int_prev(i,j) + dtbt * ubt_trans(i,j)
3994 uhbt_int_new = find_uhbt(ubt_int(i,j), btcl_u(i,j)) + dt_elapsed*uhbt0(i,j)
3995 uhbt(i,j) = (uhbt_int_new - uhbt_int_prev(i,j)) * idtbt
3996 uhbt_int(i,j) = uhbt_int_prev(i,j) + dtbt * uhbt(i,j)
3997 ! The line above is equivalent to: uhbt_int(I,j) = uhbt_int_new
3998 elseif (use_bt_cont) then
3999 uhbt(i,j) = find_uhbt(ubt_trans(i,j), btcl_u(i,j)) + uhbt0(i,j)
4000 else
4001 uhbt(i,j) = datu(i,j)*ubt_trans(i,j) + uhbt0(i,j)
4002 endif
4003 endif
4004
4005 endif ; enddo ; enddo
4006
4007end subroutine apply_u_velocity_obcs
4008
4009!> This subroutine applies the open boundary conditions on barotropic meridional
4010!! velocities and mass transports, as developed by Mehmet Ilicak.
4011subroutine apply_v_velocity_obcs(vbt, vhbt, vbt_trans, eta, SpV_avg, vbt_old, BT_OBC, &
4012 G, MS, GV, US, CS, halo, dtbt, bebt, use_BT_cont, integral_BT_cont, dt_elapsed, &
4013 Datv, BTCL_v, vhbt0, vbt_int, vbt_int_prev, vhbt_int, vhbt_int_prev)
4014 type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure.
4015 type(memory_size_type), intent(in) :: MS !< A type that describes the memory sizes of
4016 !! the argument arrays.
4017 real, dimension(SZIW_(MS),SZJBW_(MS)), intent(inout) :: vbt !< The meridional barotropic velocity
4018 !! [L T-1 ~> m s-1].
4019 real, dimension(SZIW_(MS),SZJBW_(MS)), intent(inout) :: vhbt !< the meridional barotropic transport
4020 !! [H L2 T-1 ~> m3 s-1 or kg s-1].
4021 real, dimension(SZIW_(MS),SZJBW_(MS)), intent(inout) :: vbt_trans !< the meridional BT velocity used in
4022 !! transports [L T-1 ~> m s-1].
4023 real, dimension(SZIW_(MS),SZJW_(MS)), intent(in) :: eta !< The barotropic free surface height anomaly or
4024 !! column mass anomaly [H ~> m or kg m-2].
4025 real, dimension(SZIW_(MS),SZJW_(MS)), intent(in) :: SpV_avg !< The column average specific volume [R-1 ~> m3 kg-1]
4026 real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: vbt_old !< The starting value of vbt in a barotropic
4027 !! step [L T-1 ~> m s-1].
4028 type(bt_obc_type), intent(in) :: BT_OBC !< A structure with the private barotropic arrays
4029 !! related to the open boundary conditions,
4030 !! set by set_up_BT_OBC.
4031 type(verticalgrid_type), intent(in) :: GV !< The ocean's vertical grid structure.
4032 type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
4033 type(barotropic_cs), intent(in) :: CS !< Barotropic control structure
4034 integer, intent(in) :: halo !< The extra halo size to use here.
4035 real, intent(in) :: dtbt !< The time step [T ~> s].
4036 real, intent(in) :: bebt !< The fractional weighting of the future velocity
4037 !! in determining the transport [nondim]
4038 logical, intent(in) :: use_BT_cont !< If true, use the BT_cont_types to calculate
4039 !! transports.
4040 logical, intent(in) :: integral_BT_cont !< If true, update the barotropic continuity
4041 !! equation directly from the initial condition
4042 !! using the time-integrated barotropic velocity.
4043 real, intent(in) :: dt_elapsed !< The amount of time in the barotropic stepping
4044 !! that will have elapsed [T ~> s].
4045 real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: Datv !< A fixed estimate of the face areas at v points
4046 !! [H L ~> m2 or kg m-1].
4047 type(local_bt_cont_v_type), dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: BTCL_v !< Structure of information used
4048 !! for a dynamic estimate of the face areas at
4049 !! v-points.
4050 real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: vhbt0 !< A correction to the meridional transport so that
4051 !! the barotropic functions agree with the sum
4052 !! of the layer transports
4053 !! [H L2 T-1 ~> m3 s-1 or kg s-1].
4054 real, dimension(SZIW_(MS),SZJBW_(MS)), intent(inout) :: vbt_int !< The time-integrated meridional barotropic
4055 !! velocity after this update [L T-1 ~> m s-1].
4056 real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: vbt_int_prev !< The time-integrated meridional barotropic
4057 !! velocity before this update [L T-1 ~> m s-1].
4058 real, dimension(SZIW_(MS),SZJBW_(MS)), intent(inout) :: vhbt_int !< The time-integrated meridional barotropic
4059 !! transport after this update
4060 !! [H L2 T-1 ~> m3 s-1 or kg s-1]
4061 real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: vhbt_int_prev !< The time-integrated meridional barotropic
4062 !! transport before this update
4063 !! [H L2 T-1 ~> m3 s-1 or kg s-1]
4064
4065 ! Local variables
4066 real :: vel_prev ! The previous velocity [L T-1 ~> m s-1].
4067 real :: cfl ! The CFL number at the point in question [nondim]
4068 real :: v_inlet ! The meridional inflow velocity [L T-1 ~> m s-1]
4069 real :: vhbt_int_new ! The updated time-integrated meridional transport [H L2 ~> m3]
4070 real :: ssh_in ! The inflow sea surface height [Z ~> m]
4071 real :: ssh_1 ! The sea surface height in the interior cell adjacent to the an OBC face [Z ~> m]
4072 real :: ssh_2 ! The sea surface height in the next cell inward from the OBC face [Z ~> m]
4073 real :: Idtbt ! The inverse of the barotropic time step [T-1 ~> s-1]
4074 integer :: i, j, is, ie, Js_v, Je_v
4075
4076 if (.not.bt_obc%v_OBCs_on_PE) return
4077
4078 idtbt = 1.0 / dtbt
4079
4080 ! This routine uses separate blocks of code and loops for Northern and southern open boundary
4081 ! condition points, despite this leading to some code duplication, because the OBCs almost always
4082 ! occur at the edge of the domain, and in parallel appliations, most PEs will only have one or
4083 ! the other.
4084
4085
4086 ! Work on Northern OBC points
4087 is = max(g%isc-halo, bt_obc%is_v_N_obc) ; ie = min(g%iec+halo, bt_obc%ie_v_N_obc)
4088 js_v = max((g%jsc-1)-halo, bt_obc%Js_v_N_obc) ; je_v = min(g%jec+halo, bt_obc%Je_v_N_obc)
4089 do j=js_v,je_v ; do i=is,ie ; if (bt_obc%v_OBC_type(i,j) > 0) then
4090 if (bt_obc%v_OBC_type(i,j) == specified_obc) then ! Northern specified OBC
4091 vhbt(i,j) = bt_obc%vhbt(i,j)
4092 vbt(i,j) = bt_obc%vbt_outer(i,j)
4093 vbt_trans(i,j) = vbt(i,j)
4094 if (integral_bt_cont) then
4095 vbt_int(i,j) = vbt_int_prev(i,j) + dtbt * vbt(i,j)
4096 vhbt_int(i,j) = vhbt_int_prev(i,j) + dtbt * vhbt(i,j)
4097 endif
4098 elseif (bt_obc%v_OBC_type(i,j) == flather_obc) then ! Northern Flather OBC
4099 cfl = dtbt * bt_obc%Cg_v(i,j) * g%IdyCv(i,j) ! CFL
4100 v_inlet = cfl*vbt_old(i,j-1) + (1.0-cfl)*vbt_old(i,j) ! Valid for cfl<1
4101 if (j <= ms%jsdw) then
4102 ! Do not apply a Northern Flather OBC at the southern halo points on a PE, as doing so would
4103 ! create a segmentation fault and this velocity will not propagate through to the next iteration.
4104 ssh_in = bt_obc%SSH_outer_v(i,j)
4105 elseif (gv%Boussinesq) then
4106 ssh_in = gv%H_to_Z*(eta(i,j) + (0.5-cfl)*(eta(i,j)-eta(i,j-1))) ! internal
4107 else
4108 ssh_1 = gv%H_to_RZ * eta(i,j) * spv_avg(i,j) - (cs%bathyT(i,j) + g%Z_ref)
4109 ssh_2 = gv%H_to_RZ * eta(i,j-1) * spv_avg(i,j-1) - (cs%bathyT(i,j-1) + g%Z_ref)
4110 ssh_in = ssh_1 + (0.5-cfl)*(ssh_1-ssh_2) ! internal
4111 endif
4112
4113 if (bt_obc%dZ_v(i,j) > 0.0) then
4114 vel_prev = vbt(i,j)
4115 vbt(i,j) = 0.5*((v_inlet + bt_obc%vbt_outer(i,j)) + &
4116 (bt_obc%Cg_v(i,j)/bt_obc%dZ_v(i,j)) * (ssh_in-bt_obc%SSH_outer_v(i,j)))
4117 vbt_trans(i,j) = (1.0-bebt)*vel_prev + bebt*vbt(i,j)
4118 else ! This point is now dry
4119 vbt(i,j) = 0.0
4120 vbt_trans(i,j) = 0.0
4121 endif
4122 elseif (bt_obc%v_OBC_type(i,j) == gradient_obc) then ! Northern gradient OBC
4123 vbt(i,j) = vbt(i,j-1)
4124 vbt_trans(i,j) = vbt(i,j)
4125 endif
4126
4127 ! Reset transports and related time-inetegrated velocities with non-specified OBCs
4128 if (bt_obc%v_OBC_type(i,j) > specified_obc) then ! Northern Flather or gradient OBC
4129 if (integral_bt_cont) then
4130 vbt_int(i,j) = vbt_int_prev(i,j) + dtbt * vbt_trans(i,j)
4131 vhbt_int_new = find_vhbt(vbt_int(i,j), btcl_v(i,j)) + dt_elapsed*vhbt0(i,j)
4132 vhbt(i,j) = (vhbt_int_new - vhbt_int_prev(i,j)) * idtbt
4133 vhbt_int(i,j) = vhbt_int_prev(i,j) + dtbt * vhbt(i,j)
4134 ! The line above is equivalent to: vhbt_int(i,J) = vhbt_int_new
4135 elseif (use_bt_cont) then
4136 vhbt(i,j) = find_vhbt(vbt_trans(i,j), btcl_v(i,j)) + vhbt0(i,j)
4137 else
4138 vhbt(i,j) = vbt_trans(i,j)*datv(i,j) + vhbt0(i,j)
4139 endif
4140 endif
4141
4142 endif ; enddo ; enddo
4143
4144 ! Work on Southern OBC points
4145 is = max(g%isc-halo, bt_obc%is_v_S_obc) ; ie = min(g%iec+halo, bt_obc%ie_v_S_obc)
4146 js_v = max((g%jsc-1)-halo, bt_obc%Js_v_S_obc) ; je_v = min(g%jec+halo, bt_obc%Je_v_S_obc)
4147 do j=js_v,je_v ; do i=is,ie ; if (bt_obc%v_OBC_type(i,j) < 0) then
4148 if (bt_obc%v_OBC_type(i,j) == -specified_obc) then ! Southern specified OBC
4149 vhbt(i,j) = bt_obc%vhbt(i,j)
4150 vbt(i,j) = bt_obc%vbt_outer(i,j)
4151 vbt_trans(i,j) = vbt(i,j)
4152 if (integral_bt_cont) then
4153 vbt_int(i,j) = vbt_int_prev(i,j) + dtbt * vbt(i,j)
4154 vhbt_int(i,j) = vhbt_int_prev(i,j) + dtbt * vhbt(i,j)
4155 endif
4156 elseif (bt_obc%v_OBC_type(i,j) == -flather_obc) then ! Southern Flather OBC
4157 cfl = dtbt * bt_obc%Cg_v(i,j) * g%IdyCv(i,j) ! CFL
4158 v_inlet = cfl*vbt_old(i,j+1) + (1.0-cfl)*vbt_old(i,j) ! Valid for cfl <1
4159 if (j >= ms%jedw-1) then
4160 ! Do not apply a Southern Flather OBC at the northern halo points on a PE, as doing so would
4161 ! create a segmentation fault and this velocity will not propagate through to the next iteration.
4162 ssh_in = bt_obc%SSH_outer_v(i,j)
4163 elseif (gv%Boussinesq) then
4164 ssh_in = gv%H_to_Z*(eta(i,j+1) + (0.5-cfl)*(eta(i,j+1)-eta(i,j+2))) ! internal
4165 else
4166 ssh_1 = gv%H_to_RZ * eta(i,j+1) * spv_avg(i,j+1) - (cs%bathyT(i,j+1) + g%Z_ref)
4167 ssh_2 = gv%H_to_RZ * eta(i,j+2) * spv_avg(i,j+2) - (cs%bathyT(i,j+2) + g%Z_ref)
4168 ssh_in = ssh_1 + (0.5-cfl)*(ssh_1-ssh_2) ! internal
4169 endif
4170
4171 if (bt_obc%dZ_v(i,j) > 0.0) then
4172 vel_prev = vbt(i,j)
4173 vbt(i,j) = 0.5*((v_inlet + bt_obc%vbt_outer(i,j)) + &
4174 (bt_obc%Cg_v(i,j)/bt_obc%dZ_v(i,j)) * (bt_obc%SSH_outer_v(i,j)-ssh_in))
4175 vbt_trans(i,j) = (1.0-bebt)*vel_prev + bebt*vbt(i,j)
4176 else ! This point is now dry
4177 vbt(i,j) = 0.0
4178 vbt_trans(i,j) = 0.0
4179 endif
4180 elseif (bt_obc%v_OBC_type(i,j) == -gradient_obc) then ! Southern gradient OBC
4181 vbt(i,j) = vbt(i,j+1)
4182 vbt_trans(i,j) = vbt(i,j)
4183 endif
4184
4185 ! Reset transports and related time-inetegrated velocities with non-specified OBCs
4186 if (bt_obc%v_OBC_type(i,j) < -specified_obc) then ! Southern Flather or gradient OBC
4187 if (integral_bt_cont) then
4188 vbt_int(i,j) = vbt_int_prev(i,j) + dtbt * vbt_trans(i,j)
4189 vhbt_int_new = find_vhbt(vbt_int(i,j), btcl_v(i,j)) + dt_elapsed*vhbt0(i,j)
4190 vhbt(i,j) = (vhbt_int_new - vhbt_int_prev(i,j)) * idtbt
4191 vhbt_int(i,j) = vhbt_int_prev(i,j) + dtbt * vhbt(i,j)
4192 ! The line above is equivalent to: vhbt_int(i,J) = vhbt_int_new
4193 elseif (use_bt_cont) then
4194 vhbt(i,j) = find_vhbt(vbt_trans(i,j), btcl_v(i,j)) + vhbt0(i,j)
4195 else
4196 vhbt(i,j) = vbt_trans(i,j)*datv(i,j) + vhbt0(i,j)
4197 endif
4198 endif
4199
4200 endif ; enddo ; enddo
4201
4202end subroutine apply_v_velocity_obcs
4203
4204!> This subroutine sets up the time-invariant control information about the open boundary
4205!! conditions on the full wide halo domain used by the barotropic solver.
4206subroutine initialize_bt_obc(OBC, BT_OBC, G, CS)
4207 type(ocean_obc_type), target, intent(inout) :: OBC !< An associated pointer to an OBC type.
4208 type(bt_obc_type), intent(inout) :: BT_OBC !< A structure with the private barotropic arrays
4209 !! related to the open boundary conditions,
4210 !! set by set_up_BT_OBC.
4211 type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure.
4212 type(barotropic_cs), intent(inout) :: CS !< Barotropic control structure
4213
4214 ! Local variables
4215 real, dimension(SZIBW_(CS),SZJW_(CS)) :: &
4216 u_OBC ! A set of integers encoding the nature of the u-point open boundary conditions,
4217 ! converted to real numbers to work with the MOM6 halo update code [nondim]
4218 real, dimension(SZIW_(CS),SZJBW_(CS)) :: &
4219 v_OBC ! A set of integers encoding the nature of the v-point open boundary conditions,
4220 ! converted to real numbers to work with the MOM6 halo update code [nondim]
4221 integer :: OBC_type ! The integer encoding the type of OBC being used at a point [nondim]
4222 logical :: reversed_OBCs ! True of there any OBCs in the opposite halo on this PE, e.g. points
4223 ! with a southern OBC in a northern halo.
4224 logical :: any_reversed_OBCs
4225 integer :: i, j, isdw, iedw, jsdw, jedw
4226 integer :: l_seg, Flather_OBC_in_halo
4227
4228 isdw = cs%isdw ; iedw = cs%iedw ; jsdw = cs%jsdw ; jedw = cs%jedw
4229
4230 u_obc(:,:) = 0.0
4231 v_obc(:,:) = 0.0
4232
4233 do j=g%jsc,g%jec ; do i=g%isc-1,g%iec
4234
4235 obc_type = 0
4236 if (obc%segnum_u(i,j) /= 0) then
4237 l_seg = abs(obc%segnum_u(i,j))
4238 if (obc%segment(l_seg)%gradient) obc_type = gradient_obc
4239 if (obc%segment(l_seg)%Flather) obc_type = flather_obc
4240 if (obc%segment(l_seg)%specified) obc_type = specified_obc
4241 u_obc(i,j) = sign(obc_type, obc%segnum_u(i,j))
4242 endif
4243 enddo ; enddo
4244
4245 do j=g%jsc-1,g%jec ; do i=g%isc,g%iec
4246 obc_type = 0
4247 if (obc%segnum_v(i,j) /= 0) then
4248 l_seg = abs(obc%segnum_v(i,j))
4249 if (obc%segment(l_seg)%gradient) obc_type = gradient_obc
4250 if (obc%segment(l_seg)%Flather) obc_type = flather_obc
4251 if (obc%segment(l_seg)%specified) obc_type = specified_obc
4252 v_obc(i,j) = sign(obc_type, obc%segnum_v(i,j))
4253 endif
4254 enddo ; enddo
4255
4256 call pass_vector(u_obc, v_obc, cs%BT_Domain)
4257
4258 allocate(bt_obc%u_OBC_type(isdw-1:iedw,jsdw:jedw), source=0)
4259 allocate(bt_obc%v_OBC_type(isdw:iedw,jsdw-1:jedw), source=0)
4260
4261 ! Determine the maximum and minimum index range for various directions of OBC points on this PE
4262 ! by first setting these one point outside of the wrong side of the domain.
4263 bt_obc%Is_u_W_obc = iedw + 1 ; bt_obc%Ie_u_W_obc = isdw - 2
4264 bt_obc%js_u_W_obc = jedw + 1 ; bt_obc%je_u_W_obc = jsdw - 1
4265 bt_obc%Is_u_E_obc = iedw + 1 ; bt_obc%Ie_u_E_obc = isdw - 2
4266 bt_obc%js_u_E_obc = jedw + 1 ; bt_obc%je_u_E_obc = jsdw - 1
4267 bt_obc%is_v_S_obc = iedw + 1 ; bt_obc%ie_v_S_obc = isdw - 1
4268 bt_obc%Js_v_S_obc = jedw + 1 ; bt_obc%Je_v_S_obc = jsdw - 2
4269 bt_obc%is_v_N_obc = iedw + 1 ; bt_obc%ie_v_N_obc = isdw - 1
4270 bt_obc%Js_v_N_obc = jedw + 1 ; bt_obc%Je_v_N_obc = jsdw - 2
4271
4272 flather_obc_in_halo = 0
4273 do j=jsdw,jedw ; do i=isdw-1,iedw
4274 bt_obc%u_OBC_type(i,j) = nint(u_obc(i,j))
4275 if (bt_obc%u_OBC_type(i,j) < 0) then ! This point has OBC_DIRECTION_W.
4276 if ((bt_obc%u_OBC_type(i,j) == -flather_obc) .and. (i >= iedw-1)) then
4277 ! There is no need to specify the OBC at this point, but the stencil might need to be increased.
4278 flather_obc_in_halo = 1
4279 else
4280 bt_obc%Is_u_W_obc = min(i, bt_obc%Is_u_W_obc) ; bt_obc%Ie_u_W_obc = max(i, bt_obc%Ie_u_W_obc)
4281 bt_obc%js_u_W_obc = min(j, bt_obc%js_u_W_obc) ; bt_obc%je_u_W_obc = max(j, bt_obc%je_u_W_obc)
4282 endif
4283 endif
4284 if (bt_obc%u_OBC_type(i,j) > 0) then ! This point has OBC_DIRECTION_E.
4285 if ((bt_obc%u_OBC_type(i,j) == flather_obc) .and. (i <= isdw)) then
4286 ! There is no need to specify the OBC at this point, but the stencil might need to be increased.
4287 flather_obc_in_halo = 1
4288 else
4289 bt_obc%Is_u_E_obc = min(i, bt_obc%Is_u_E_obc) ; bt_obc%Ie_u_E_obc = max(i, bt_obc%Ie_u_E_obc)
4290 bt_obc%js_u_E_obc = min(j, bt_obc%js_u_E_obc) ; bt_obc%je_u_E_obc = max(j, bt_obc%je_u_E_obc)
4291 endif
4292 endif
4293 enddo ; enddo
4294
4295 do j=jsdw-1,jedw ; do i=isdw,iedw
4296 bt_obc%v_OBC_type(i,j) = nint(v_obc(i,j))
4297 if (bt_obc%v_OBC_type(i,j) < 0) then ! This point has OBC_DIRECTION_S.
4298 if ((bt_obc%v_OBC_type(i,j) == -flather_obc) .and. (j >= jedw-1)) then
4299 ! There is no need to specify the OBC at this point, but the stencil might need to be increased.
4300 flather_obc_in_halo = 1
4301 else
4302 bt_obc%is_v_S_obc = min(i, bt_obc%is_v_S_obc) ; bt_obc%ie_v_S_obc = max(i, bt_obc%ie_v_S_obc)
4303 bt_obc%Js_v_S_obc = min(j, bt_obc%Js_v_S_obc) ; bt_obc%Je_v_S_obc = max(j, bt_obc%Je_v_S_obc)
4304 endif
4305 endif
4306 if (bt_obc%v_OBC_type(i,j) > 0) then ! This point has OBC_DIRECTION_N.
4307 if ((bt_obc%v_OBC_type(i,j) == flather_obc) .and. (j <= jsdw)) then
4308 ! There is no need to specify the OBC at this point, but the stencil might need to be increased.
4309 flather_obc_in_halo = 1
4310 else
4311 bt_obc%is_v_N_obc = min(i, bt_obc%is_v_N_obc) ; bt_obc%ie_v_N_obc = max(i, bt_obc%ie_v_N_obc)
4312 bt_obc%Js_v_N_obc = min(j, bt_obc%Js_v_N_obc) ; bt_obc%Je_v_N_obc = max(j, bt_obc%Je_v_N_obc)
4313 endif
4314 endif
4315 enddo ; enddo
4316
4317 bt_obc%u_OBCs_on_PE = ((bt_obc%Is_u_E_obc <= iedw) .or. (bt_obc%Is_u_W_obc <= iedw))
4318 bt_obc%v_OBCs_on_PE = ((bt_obc%is_v_N_obc <= iedw) .or. (bt_obc%is_v_S_obc <= iedw))
4319
4320
4321 ! Determine whether there are any OBCs in the opposite halo on any processors in the domain, e.g.,
4322 ! points with OBC_DIRECTION_S in a northern halo.
4323 reversed_obcs = (bt_obc%u_OBCs_on_PE .and. ((bt_obc%Is_u_E_obc <= g%isc-1) .or. (bt_obc%Ie_u_W_obc >= g%iec))) .or. &
4324 (bt_obc%v_OBCs_on_PE .and. ((bt_obc%Js_v_N_obc <= g%jsc-1) .or. (bt_obc%Je_v_S_obc >= g%jec)))
4325 any_reversed_obcs = any_across_pes(reversed_obcs)
4326 if (any_reversed_obcs) call mom_mesg("OBCs in an opposite halo require the use of a wider stencil.", 5)
4327 if (any_reversed_obcs) cs%min_stencil = max(cs%min_stencil, 2)
4328
4329 ! Allocate time-varying arrays that will be used for open boundary conditions.
4330
4331 ! This pair is used with either Flather or specified OBCs.
4332 allocate(bt_obc%ubt_outer(isdw-1:iedw,jsdw:jedw), source=0.0)
4333 allocate(bt_obc%vbt_outer(isdw:iedw,jsdw-1:jedw), source=0.0)
4334 call create_group_pass(bt_obc%pass_uv, bt_obc%ubt_outer, bt_obc%vbt_outer, cs%BT_Domain)
4335
4336 ! This pair is only used with specified OBCs.
4337 allocate(bt_obc%uhbt(isdw-1:iedw,jsdw:jedw), source=0.0)
4338 allocate(bt_obc%vhbt(isdw:iedw,jsdw-1:jedw), source=0.0)
4339 call create_group_pass(bt_obc%pass_uv, bt_obc%uhbt, bt_obc%vhbt, cs%BT_Domain)
4340
4341 if (obc%Flather_u_BCs_exist_globally .or. obc%Flather_v_BCs_exist_globally) then
4342 ! These 3 pairs are only used with Flather OBCs.
4343 allocate(bt_obc%Cg_u(isdw-1:iedw,jsdw:jedw), source=0.0)
4344 allocate(bt_obc%dZ_u(isdw-1:iedw,jsdw:jedw), source=0.0)
4345 allocate(bt_obc%SSH_outer_u(isdw-1:iedw,jsdw:jedw), source=0.0)
4346
4347 allocate(bt_obc%Cg_v(isdw:iedw,jsdw-1:jedw), source=0.0)
4348 allocate(bt_obc%dZ_v(isdw:iedw,jsdw-1:jedw), source=0.0)
4349 allocate(bt_obc%SSH_outer_v(isdw:iedw,jsdw-1:jedw), source=0.0)
4350
4351 call create_group_pass(bt_obc%scalar_pass, bt_obc%SSH_outer_u, bt_obc%SSH_outer_v, cs%BT_Domain, to_all+scalar_pair)
4352 call create_group_pass(bt_obc%scalar_pass, bt_obc%dZ_u, bt_obc%dZ_v, cs%BT_Domain, to_all+scalar_pair)
4353 call create_group_pass(bt_obc%scalar_pass, bt_obc%Cg_u, bt_obc%Cg_v, cs%BT_Domain, to_all+scalar_pair)
4354 endif
4355
4356end subroutine initialize_bt_obc
4357
4358!> This subroutine sets up the time-varying fields in the private structure used to apply the open
4359!! boundary conditions, as developed by Mehmet Ilicak.
4360subroutine set_up_bt_obc(OBC, eta, SpV_avg, BT_OBC, BT_Domain, G, GV, US, CS, MS, halo, use_BT_cont, &
4361 integral_BT_cont, dt_baroclinic, Datu, Datv, BTCL_u, BTCL_v, dgeo_de)
4362 type(ocean_obc_type), target, intent(inout) :: OBC !< An associated pointer to an OBC type.
4363 type(memory_size_type), intent(in) :: MS !< A type that describes the memory sizes of the
4364 !! argument arrays.
4365 real, dimension(SZIW_(MS),SZJW_(MS)), intent(in) :: eta !< The barotropic free surface height anomaly or
4366 !! column mass anomaly [H ~> m or kg m-2].
4367 real, dimension(SZIW_(MS),SZJW_(MS)), intent(in) :: SpV_avg !< The column average specific volume [R-1 ~> m3 kg-1]
4368 type(bt_obc_type), intent(inout) :: BT_OBC !< A structure with the private barotropic arrays
4369 !! related to the open boundary conditions,
4370 !! set by set_up_BT_OBC.
4371 type(mom_domain_type), intent(inout) :: BT_Domain !< MOM_domain_type associated with wide arrays
4372 type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure.
4373 type(verticalgrid_type), intent(in) :: GV !< The ocean's vertical grid structure.
4374 type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
4375 type(barotropic_cs), intent(inout) :: CS !< Barotropic control structure
4376 integer, intent(in) :: halo !< The extra halo size to use here.
4377 logical, intent(in) :: use_BT_cont !< If true, use the BT_cont_types to calculate
4378 !! transports.
4379 logical, intent(in) :: integral_BT_cont !< If true, update the barotropic continuity
4380 !! equation directly from the initial condition
4381 !! using the time-integrated barotropic velocity.
4382 real, intent(in) :: dt_baroclinic !< The baroclinic timestep for this cycle of
4383 !! updates to the barotropic solver [T ~> s]
4384 real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: Datu !< A fixed estimate of the face areas at u points
4385 !! [H L ~> m2 or kg m-1].
4386 real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: Datv !< A fixed estimate of the face areas at v points
4387 !! [H L ~> m2 or kg m-1].
4388 type(local_bt_cont_u_type), dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: BTCL_u !< Structure of information used
4389 !! for a dynamic estimate of the face areas at
4390 !! u-points.
4391 type(local_bt_cont_v_type), dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: BTCL_v !< Structure of information used
4392 !! for a dynamic estimate of the face areas at
4393 !! v-points.
4394 real, intent(in) :: dgeo_de !< The constant of proportionality between
4395 !! geopotential and sea surface height [nondim].
4396 ! Local variables
4397 real :: I_dt ! The inverse of the time interval of this call [T-1 ~> s-1].
4398 integer :: i, j, k, is, ie, js, je, n, nz
4399 integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB
4400 integer :: isdw, iedw, jsdw, jedw
4401 type(obc_segment_type), pointer :: segment !< Open boundary segment
4402
4403 is = g%isc-halo ; ie = g%iec+halo ; js = g%jsc-halo ; je = g%jec+halo
4404 isd = g%isd ; ied = g%ied ; jsd = g%jsd ; jed = g%jed ; nz = gv%ke
4405 isdb = g%IsdB ; iedb = g%IedB ; jsdb = g%JsdB ; jedb = g%JedB
4406 isdw = ms%isdw ; iedw = ms%iedw ; jsdw = ms%jsdw ; jedw = ms%jedw
4407
4408 i_dt = 1.0 / dt_baroclinic
4409
4410 if (bt_obc%u_OBCs_on_PE) then
4411 if (obc%specified_u_BCs_exist_globally) then
4412 do n = 1, obc%number_of_segments
4413 segment => obc%segment(n)
4414 if (segment%is_E_or_W .and. segment%specified) then
4415 do j=segment%HI%jsd,segment%HI%jed ; do i=segment%HI%IsdB,segment%HI%IedB
4416 bt_obc%uhbt(i,j) = 0.
4417 enddo ; enddo
4418 do k=1,nz ; do j=segment%HI%jsd,segment%HI%jed ; do i=segment%HI%IsdB,segment%HI%IedB
4419 bt_obc%uhbt(i,j) = bt_obc%uhbt(i,j) + segment%normal_trans(i,j,k)
4420 enddo ; enddo ; enddo
4421 endif
4422 enddo
4423 endif
4424 do j=js,je ; do i=is-1,ie ; if (bt_obc%u_OBC_type(i,j) /= 0) then
4425 if (abs(bt_obc%u_OBC_type(i,j)) == specified_obc) then ! Eastern or western specified OBC
4426 if (integral_bt_cont) then
4427 bt_obc%ubt_outer(i,j) = uhbt_to_ubt(bt_obc%uhbt(i,j)*dt_baroclinic, btcl_u(i,j)) * i_dt
4428 elseif (use_bt_cont) then
4429 bt_obc%ubt_outer(i,j) = uhbt_to_ubt(bt_obc%uhbt(i,j), btcl_u(i,j))
4430 else
4431 if (datu(i,j) > 0.0) bt_obc%ubt_outer(i,j) = bt_obc%uhbt(i,j) / datu(i,j)
4432 endif
4433 elseif (bt_obc%u_OBC_type(i,j) == flather_obc) then ! Eastern Flather OBC
4434 if (gv%Boussinesq) then
4435 bt_obc%dZ_u(i,j) = cs%bathyT(i,j) + gv%H_to_Z*eta(i,j)
4436 else
4437 bt_obc%dZ_u(i,j) = gv%H_to_RZ * eta(i,j) * spv_avg(i,j)
4438 endif
4439 bt_obc%Cg_u(i,j) = sqrt(dgeo_de * gv%g_prime(1) * bt_obc%dZ_u(i,j))
4440 elseif (bt_obc%u_OBC_type(i,j) == -flather_obc) then ! Western Flather OBC
4441 if (gv%Boussinesq) then
4442 bt_obc%dZ_u(i,j) = cs%bathyT(i+1,j) + gv%H_to_Z*eta(i+1,j)
4443 else
4444 bt_obc%dZ_u(i,j) = gv%H_to_RZ * eta(i+1,j) * spv_avg(i+1,j)
4445 endif
4446 bt_obc%Cg_u(i,j) = sqrt(dgeo_de * gv%g_prime(1) * bt_obc%dZ_u(i,j))
4447 endif
4448 endif ; enddo ; enddo
4449
4450 if (obc%Flather_u_BCs_exist_globally) then
4451 do n = 1, obc%number_of_segments
4452 segment => obc%segment(n)
4453 if (segment%is_E_or_W .and. segment%Flather) then
4454 do j=segment%HI%jsd,segment%HI%jed ; do i=segment%HI%IsdB,segment%HI%IedB
4455 bt_obc%ubt_outer(i,j) = segment%normal_vel_bt(i,j)
4456 bt_obc%SSH_outer_u(i,j) = segment%SSH(i,j) + g%Z_ref
4457 enddo ; enddo
4458 endif
4459 enddo
4460 endif
4461 endif
4462
4463 if (bt_obc%v_OBCs_on_PE) then
4464 if (obc%specified_v_BCs_exist_globally) then
4465 do n = 1, obc%number_of_segments
4466 segment => obc%segment(n)
4467 if (segment%is_N_or_S .and. segment%specified) then
4468 do j=segment%HI%JsdB,segment%HI%JedB ; do i=segment%HI%isd,segment%HI%ied
4469 bt_obc%vhbt(i,j) = 0.
4470 enddo ; enddo
4471 do k=1,nz ; do j=segment%HI%JsdB,segment%HI%JedB ; do i=segment%HI%isd,segment%HI%ied
4472 bt_obc%vhbt(i,j) = bt_obc%vhbt(i,j) + segment%normal_trans(i,j,k)
4473 enddo ; enddo ; enddo
4474 endif
4475 enddo
4476 endif
4477 do j=js-1,je ; do i=is,ie ; if (bt_obc%v_OBC_type(i,j) /= 0) then
4478 if (abs(bt_obc%v_OBC_type(i,j)) == specified_obc) then ! Northern or southern specified OBC
4479 if (integral_bt_cont) then
4480 bt_obc%vbt_outer(i,j) = vhbt_to_vbt(bt_obc%vhbt(i,j)*dt_baroclinic, btcl_v(i,j)) * i_dt
4481 elseif (use_bt_cont) then
4482 bt_obc%vbt_outer(i,j) = vhbt_to_vbt(bt_obc%vhbt(i,j), btcl_v(i,j))
4483 else
4484 if (datv(i,j) > 0.0) bt_obc%vbt_outer(i,j) = bt_obc%vhbt(i,j) / datv(i,j)
4485 endif
4486 elseif (bt_obc%v_OBC_type(i,j) == flather_obc) then ! Northern Flather OBC
4487 if (gv%Boussinesq) then
4488 bt_obc%dZ_v(i,j) = cs%bathyT(i,j) + gv%H_to_Z*eta(i,j)
4489 else
4490 bt_obc%dZ_v(i,j) = gv%H_to_RZ * eta(i,j) * spv_avg(i,j)
4491 endif
4492 bt_obc%Cg_v(i,j) = sqrt(dgeo_de * gv%g_prime(1) * bt_obc%dZ_v(i,j))
4493 elseif (bt_obc%v_OBC_type(i,j) == -flather_obc) then ! Southern Flather OBC
4494 if (gv%Boussinesq) then
4495 bt_obc%dZ_v(i,j) = cs%bathyT(i,j+1) + gv%H_to_Z*eta(i,j+1)
4496 else
4497 bt_obc%dZ_v(i,j) = gv%H_to_RZ * eta(i,j+1) * spv_avg(i,j+1)
4498 endif
4499 bt_obc%Cg_v(i,j) = sqrt(dgeo_de * gv%g_prime(1) * bt_obc%dZ_v(i,j))
4500 endif
4501 endif ; enddo ; enddo
4502 if (obc%Flather_v_BCs_exist_globally) then
4503 do n = 1, obc%number_of_segments
4504 segment => obc%segment(n)
4505 if (segment%is_N_or_S .and. segment%Flather) then
4506 do j=segment%HI%JsdB,segment%HI%JedB ; do i=segment%HI%isd,segment%HI%ied
4507 bt_obc%vbt_outer(i,j) = segment%normal_vel_bt(i,j)
4508 bt_obc%SSH_outer_v(i,j) = segment%SSH(i,j) + g%Z_ref
4509 enddo ; enddo
4510 endif
4511 enddo
4512 endif
4513 endif
4514
4515 call do_group_pass(bt_obc%pass_uv, bt_domain)
4516 if (obc%Flather_u_BCs_exist_globally .or. obc%Flather_v_BCs_exist_globally) &
4517 call do_group_pass(bt_obc%scalar_pass, bt_domain)
4518
4519end subroutine set_up_bt_obc
4520
4521!> Clean up the BT_OBC memory.
4522subroutine destroy_bt_obc(BT_OBC)
4523 type(bt_obc_type), intent(inout) :: BT_OBC !< A structure with the private barotropic arrays
4524 !! related to the open boundary conditions,
4525 !! set by set_up_BT_OBC.
4526
4527 if (allocated(bt_obc%u_OBC_type)) deallocate(bt_obc%u_OBC_type)
4528 if (allocated(bt_obc%v_OBC_type)) deallocate(bt_obc%v_OBC_type)
4529
4530 if (allocated(bt_obc%Cg_u)) deallocate(bt_obc%Cg_u)
4531 if (allocated(bt_obc%dZ_u)) deallocate(bt_obc%dZ_u)
4532 if (allocated(bt_obc%uhbt)) deallocate(bt_obc%uhbt)
4533 if (allocated(bt_obc%ubt_outer)) deallocate(bt_obc%ubt_outer)
4534 if (allocated(bt_obc%SSH_outer_u)) deallocate(bt_obc%SSH_outer_u)
4535
4536 if (allocated(bt_obc%Cg_v)) deallocate(bt_obc%Cg_v)
4537 if (allocated(bt_obc%dZ_v)) deallocate(bt_obc%dZ_v)
4538 if (allocated(bt_obc%vhbt)) deallocate(bt_obc%vhbt)
4539 if (allocated(bt_obc%vbt_outer)) deallocate(bt_obc%vbt_outer)
4540 if (allocated(bt_obc%SSH_outer_v)) deallocate(bt_obc%SSH_outer_v)
4541
4542end subroutine destroy_bt_obc
4543
4544!> btcalc determines the fraction of the total water column in each
4545!! layer at velocity points.
4546subroutine btcalc(h, G, GV, CS, h_u, h_v, may_use_default, OBC)
4547 type(ocean_grid_type), intent(inout) :: g !< The ocean's grid structure.
4548 type(verticalgrid_type), intent(in) :: gv !< The ocean's vertical grid structure.
4549 real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), &
4550 intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2].
4551 type(barotropic_cs), intent(inout) :: cs !< Barotropic control structure
4552 real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), &
4553 optional, intent(in) :: h_u !< The specified effective thicknesses at u-points,
4554 !! perhaps scaled down to account for viscosity and
4555 !! fractional open areas [H ~> m or kg m-2]. These
4556 !! are used here as non-normalized weights for each
4557 !! layer that are converted the normalized weights
4558 !! for determining the barotropic accelerations.
4559 real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), &
4560 optional, intent(in) :: h_v !< The specified effective thicknesses at v-points,
4561 !! perhaps scaled down to account for viscosity and
4562 !! fractional open areas [H ~> m or kg m-2]. These
4563 !! are used here as non-normalized weights for each
4564 !! layer that are converted the normalized weights
4565 !! for determining the barotropic accelerations.
4566 logical, optional, intent(in) :: may_use_default !< An optional logical argument
4567 !! to indicate that the default velocity point
4568 !! thicknesses may be used for this particular
4569 !! calculation, even though the setting of
4570 !! CS%hvel_scheme would usually require that h_u
4571 !! and h_v be passed in.
4572 type(ocean_obc_type), optional, pointer :: obc !< Open boundary control structure.
4573
4574 ! Local variables
4575 real :: hatu(szib_(g),szk_(gv)) ! The layer thicknesses interpolated to u points [H ~> m or kg m-2]
4576 real :: hatv(szi_(g),szk_(gv)) ! The layer thicknesses interpolated to v points [H ~> m or kg m-2]
4577 real :: hatutot(szib_(g)) ! The sum of the layer thicknesses interpolated to u points [H ~> m or kg m-2].
4578 real :: hatvtot(szi_(g)) ! The sum of the layer thicknesses interpolated to v points [H ~> m or kg m-2].
4579 real :: ihatutot(szib_(g)) ! Ihatutot is the inverse of hatutot [H-1 ~> m-1 or m2 kg-1].
4580 real :: ihatvtot(szi_(g)) ! Ihatvtot is the inverse of hatvtot [H-1 ~> m-1 or m2 kg-1].
4581 real :: h_arith ! The arithmetic mean thickness [H ~> m or kg m-2].
4582 real :: h_harm ! The harmonic mean thicknesses [H ~> m or kg m-2].
4583 real :: h_neglect ! A thickness that is so small it is usually lost
4584 ! in roundoff and can be neglected [H ~> m or kg m-2].
4585 real :: wt_arith ! The weight for the arithmetic mean thickness [nondim].
4586 ! The harmonic mean uses a weight of (1 - wt_arith).
4587 real :: e_u(szib_(g),szk_(gv)+1) ! The interface heights at u-velocity points [H ~> m or kg m-2]
4588 real :: e_v(szi_(g),szk_(gv)+1) ! The interface heights at v-velocity points [H ~> m or kg m-2]
4589 real :: d_shallow_u(szi_(g)) ! The height of the shallower of the adjacent bathymetric depths
4590 ! around a u-point (positive upward) [H ~> m or kg m-2]
4591 real :: d_shallow_v(szib_(g))! The height of the shallower of the adjacent bathymetric depths
4592 ! around a v-point (positive upward) [H ~> m or kg m-2]
4593 real :: z_to_h ! A local conversion factor [H Z-1 ~> nondim or kg m-3]
4594
4595 logical :: use_default, test_dflt
4596 integer :: is, ie, js, je, isq, ieq, jsq, jeq, nz, i, j, k
4597
4598 if (.not.cs%module_is_initialized) call mom_error(fatal, &
4599 "btcalc: Module MOM_barotropic must be initialized before it is used.")
4600
4601 if (.not.cs%split) return
4602
4603 use_default = .false.
4604 test_dflt = .false. ; if (present(may_use_default)) test_dflt = may_use_default
4605
4606 if (test_dflt) then
4607 if (.not.((present(h_u) .and. present(h_v)) .or. &
4608 (cs%hvel_scheme == harmonic) .or. (cs%hvel_scheme == hybrid) .or.&
4609 (cs%hvel_scheme == arithmetic))) use_default = .true.
4610 else
4611 if (.not.((present(h_u) .and. present(h_v)) .or. &
4612 (cs%hvel_scheme == harmonic) .or. (cs%hvel_scheme == hybrid) .or.&
4613 (cs%hvel_scheme == arithmetic))) call mom_error(fatal, &
4614 "btcalc: Inconsistent settings of optional arguments and hvel_scheme.")
4615 endif
4616
4617 is = g%isc ; ie = g%iec ; js = g%jsc ; je = g%jec ; nz = gv%ke
4618 isq = g%IscB ; ieq = g%IecB ; jsq = g%JscB ; jeq = g%JecB
4619 h_neglect = gv%H_subroundoff
4620
4621
4622 !$OMP parallel do default(none) shared(is,ie,js,je,nz,h_u,CS,h_neglect,h,use_default,G,GV) &
4623 !$OMP private(hatu,hatutot,Ihatutot,e_u,D_shallow_u,h_arith,h_harm,wt_arith,Z_to_H)
4624 do j=js,je
4625 do i=is-1,ie ; hatutot(i) = 0.0 ; enddo
4626
4627 if (present(h_u)) then
4628 do k=1,nz ; do i=is-1,ie
4629 hatu(i,k) = h_u(i,j,k)
4630 hatutot(i) = hatutot(i) + hatu(i,k)
4631 enddo ; enddo
4632 elseif (cs%hvel_scheme == arithmetic) then
4633 do k=1,nz ; do i=is-1,ie
4634 hatu(i,k) = 0.5 * (h(i+1,j,k) + h(i,j,k))
4635 hatutot(i) = hatutot(i) + hatu(i,k)
4636 enddo ; enddo
4637 elseif (cs%hvel_scheme == hybrid .or. use_default) then
4638 z_to_h = gv%Z_to_H ; if (.not.gv%Boussinesq) z_to_h = gv%RZ_to_H * cs%Rho_BT_lin
4639 do i=is-1,ie
4640 e_u(i,nz+1) = -0.5 * z_to_h * (g%bathyT(i+1,j) + g%bathyT(i,j))
4641 d_shallow_u(i) = -z_to_h * min(g%bathyT(i+1,j), g%bathyT(i,j))
4642 enddo
4643 do k=nz,1,-1 ; do i=is-1,ie
4644 e_u(i,k) = e_u(i,k+1) + 0.5 * (h(i+1,j,k) + h(i,j,k))
4645 h_arith = 0.5 * (h(i+1,j,k) + h(i,j,k))
4646 if (e_u(i,k+1) >= d_shallow_u(i)) then
4647 hatu(i,k) = h_arith
4648 else
4649 h_harm = (h(i+1,j,k) * h(i,j,k)) / (h_arith + h_neglect)
4650 if (e_u(i,k) <= d_shallow_u(i)) then
4651 hatu(i,k) = h_harm
4652 else
4653 wt_arith = (e_u(i,k) - d_shallow_u(i)) / (h_arith + h_neglect)
4654 hatu(i,k) = wt_arith*h_arith + (1.0-wt_arith)*h_harm
4655 endif
4656 endif
4657 hatutot(i) = hatutot(i) + hatu(i,k)
4658 enddo ; enddo
4659 elseif (cs%hvel_scheme == harmonic) then
4660 ! Interpolates thicknesses onto u grid points with the
4661 ! second order accurate estimate h = 2*(h+ * h-)/(h+ + h-).
4662 do k=1,nz ; do i=is-1,ie
4663 hatu(i,k) = 2.0*(h(i+1,j,k) * h(i,j,k)) / &
4664 ((h(i+1,j,k) + h(i,j,k)) + h_neglect)
4665 hatutot(i) = hatutot(i) + hatu(i,k)
4666 enddo ; enddo
4667 endif
4668
4669 if (cs%BT_OBC%u_OBCs_on_PE) then
4670 ! Reset velocity point thicknesses and their sums at OBC points
4671 if ((j >= cs%BT_OBC%js_u_E_obc) .and. (j <= cs%BT_OBC%je_u_E_obc)) then
4672 do i = max(is-1,cs%BT_OBC%Is_u_E_obc), min(ie,cs%BT_OBC%Ie_u_E_obc)
4673 if (cs%BT_OBC%u_OBC_type(i,j) > 0) then ! Eastern boundary condition
4674 hatutot(i) = 0.0
4675 do k=1,nz
4676 hatu(i,k) = h(i,j,k)
4677 hatutot(i) = hatutot(i) + hatu(i,k)
4678 enddo
4679 endif
4680 enddo
4681 endif
4682 if ((j >= cs%BT_OBC%js_u_W_obc) .and. (j <= cs%BT_OBC%je_u_W_obc)) then
4683 do i = max(is-1,cs%BT_OBC%Is_u_W_obc), min(ie,cs%BT_OBC%Ie_u_W_obc)
4684 if (cs%BT_OBC%u_OBC_type(i,j) < 0) then ! Western boundary condition
4685 hatutot(i) = 0.0
4686 do k=1,nz
4687 hatu(i,k) = h(i+1,j,k)
4688 hatutot(i) = hatutot(i) + hatu(i,k)
4689 enddo
4690 endif
4691 enddo
4692 endif
4693 endif
4694
4695 ! Determine the fractional thickness of each layer at the velocity points.
4696 do i=is-1,ie ; ihatutot(i) = g%mask2dCu(i,j) / (hatutot(i) + h_neglect) ; enddo
4697 do k=1,nz ; do i=is-1,ie
4698 cs%frhatu(i,j,k) = hatu(i,k) * ihatutot(i)
4699 enddo ; enddo
4700 enddo
4701
4702 !$OMP parallel do default(none) shared(is,ie,js,je,nz,CS,G,GV,h_v,h_neglect,h,use_default) &
4703 !$OMP private(hatv,hatvtot,Ihatvtot,e_v,D_shallow_v,h_arith,h_harm,wt_arith,Z_to_H)
4704 do j=js-1,je
4705 do i=is,ie ; hatvtot(i) = 0.0 ; enddo
4706 if (present(h_v)) then
4707 do k=1,nz ; do i=is,ie
4708 hatv(i,k) = h_v(i,j,k)
4709 hatvtot(i) = hatvtot(i) + hatv(i,k)
4710 enddo ; enddo
4711 elseif (cs%hvel_scheme == arithmetic) then
4712 do k=1,nz ; do i=is,ie
4713 hatv(i,k) = 0.5 * (h(i,j+1,k) + h(i,j,k))
4714 hatvtot(i) = hatvtot(i) + hatv(i,k)
4715 enddo ; enddo
4716 elseif (cs%hvel_scheme == hybrid .or. use_default) then
4717 z_to_h = gv%Z_to_H ; if (.not.gv%Boussinesq) z_to_h = gv%RZ_to_H * cs%Rho_BT_lin
4718 do i=is,ie
4719 e_v(i,nz+1) = -0.5 * z_to_h * (g%bathyT(i,j+1) + g%bathyT(i,j))
4720 d_shallow_v(i) = -z_to_h * min(g%bathyT(i,j+1), g%bathyT(i,j))
4721 enddo
4722 do k=nz,1,-1 ; do i=is,ie
4723 e_v(i,k) = e_v(i,k+1) + 0.5 * (h(i,j+1,k) + h(i,j,k))
4724 h_arith = 0.5 * (h(i,j+1,k) + h(i,j,k))
4725 if (e_v(i,k+1) >= d_shallow_v(i)) then
4726 hatv(i,k) = h_arith
4727 else
4728 h_harm = (h(i,j+1,k) * h(i,j,k)) / (h_arith + h_neglect)
4729 if (e_v(i,k) <= d_shallow_v(i)) then
4730 hatv(i,k) = h_harm
4731 else
4732 wt_arith = (e_v(i,k) - d_shallow_v(i)) / (h_arith + h_neglect)
4733 hatv(i,k) = wt_arith*h_arith + (1.0-wt_arith)*h_harm
4734 endif
4735 endif
4736 hatvtot(i) = hatvtot(i) + hatv(i,k)
4737 enddo ; enddo
4738 elseif (cs%hvel_scheme == harmonic) then
4739 do k=1,nz ; do i=is,ie
4740 hatv(i,k) = 2.0*(h(i,j+1,k) * h(i,j,k)) / &
4741 ((h(i,j+1,k) + h(i,j,k)) + h_neglect)
4742 hatvtot(i) = hatvtot(i) + hatv(i,k)
4743 enddo ; enddo
4744 endif
4745
4746 if (cs%BT_OBC%v_OBCs_on_PE) then
4747 ! Reset v-velocity point thicknesses and their sums at OBC points
4748 if ((j >= cs%BT_OBC%Js_v_N_obc) .and. (j <= cs%BT_OBC%Je_v_N_obc)) then
4749 do i = max(is,cs%BT_OBC%is_v_N_obc), min(ie,cs%BT_OBC%ie_v_N_obc)
4750 if (cs%BT_OBC%v_OBC_type(i,j) > 0) then ! Northern boundary condition
4751 hatvtot(i) = 0.0
4752 do k=1,nz
4753 hatv(i,k) = h(i,j,k)
4754 hatvtot(i) = hatvtot(i) + hatv(i,k)
4755 enddo
4756 endif
4757 enddo
4758 endif
4759 if ((j >= cs%BT_OBC%Js_v_S_obc) .and. (j <= cs%BT_OBC%Je_v_S_obc)) then
4760 do i = max(is,cs%BT_OBC%is_v_S_obc), min(ie,cs%BT_OBC%ie_v_S_obc)
4761 if (cs%BT_OBC%v_OBC_type(i,j) < 0) then ! Southern boundary condition
4762 hatvtot(i) = 0.0
4763 do k=1,nz
4764 hatv(i,k) = h(i,j+1,k)
4765 hatvtot(i) = hatvtot(i) + hatv(i,k)
4766 enddo
4767 endif
4768 enddo
4769 endif
4770 endif
4771
4772 ! Determine the fractional thickness of each layer at the velocity points.
4773 do i=is,ie ; ihatvtot(i) = g%mask2dCv(i,j) / (hatvtot(i) + h_neglect) ; enddo
4774 do k=1,nz ; do i=is,ie
4775 cs%frhatv(i,j,k) = hatv(i,k) * ihatvtot(i)
4776 enddo ; enddo
4777 enddo
4778
4779 if (cs%debug) then
4780 call uvchksum("btcalc frhat[uv]", cs%frhatu, cs%frhatv, g%HI, &
4781 haloshift=0, symmetric=.true., omit_corners=.true., &
4782 scalar_pair=.true.)
4783 if (present(h_u) .and. present(h_v)) &
4784 call uvchksum("btcalc h_[uv]", h_u, h_v, g%HI, haloshift=0, &
4785 symmetric=.true., omit_corners=.true., unscale=gv%H_to_MKS, &
4786 scalar_pair=.true.)
4787 call hchksum(h, "btcalc h", g%HI, haloshift=1, unscale=gv%H_to_MKS)
4788 endif
4789
4790end subroutine btcalc
4791
4792!> The function find_uhbt determines the zonal transport for a given velocity, or with
4793!! INTEGRAL_BT_CONT=True it determines the time-integrated zonal transport for a given
4794!! time-integrated velocity.
4795function find_uhbt(u, BTC) result(uhbt)
4796 real, intent(in) :: u !< The local zonal velocity [L T-1 ~> m s-1] or time integrated velocity [L ~> m]
4797 type(local_bt_cont_u_type), intent(in) :: btc !< A structure containing various fields that
4798 !! allow the barotropic transports to be calculated consistently
4799 !! with the layers' continuity equations. The dimensions of some
4800 !! of the elements in this type vary depending on INTEGRAL_BT_CONT.
4801
4802 real :: uhbt !< The zonal barotropic transport [L2 H T-1 ~> m3 s-1] or time integrated transport [L2 H ~> m3]
4803
4804 if (u == 0.0) then
4805 uhbt = 0.0
4806 elseif (u < btc%uBT_EE) then
4807 uhbt = (u - btc%uBT_EE) * btc%FA_u_EE + btc%uh_EE
4808 elseif (u < 0.0) then
4809 uhbt = u * (btc%FA_u_E0 + btc%uh_crvE * u**2)
4810 elseif (u <= btc%uBT_WW) then
4811 uhbt = u * (btc%FA_u_W0 + btc%uh_crvW * u**2)
4812 else ! (u > BTC%uBT_WW)
4813 uhbt = (u - btc%uBT_WW) * btc%FA_u_WW + btc%uh_WW
4814 endif
4815
4816end function find_uhbt
4817
4818!> The function find_duhbt_du determines the marginal zonal face area for a given velocity, or
4819!! with INTEGRAL_BT_CONT=True for a given time-integrated velocity.
4820function find_duhbt_du(u, BTC) result(duhbt_du)
4821 real, intent(in) :: u !< The local zonal velocity [L T-1 ~> m s-1] or time integrated velocity [L ~> m]
4822 type(local_bt_cont_u_type), intent(in) :: btc !< A structure containing various fields that
4823 !! allow the barotropic transports to be calculated consistently
4824 !! with the layers' continuity equations. The dimensions of some
4825 !! of the elements in this type vary depending on INTEGRAL_BT_CONT.
4826 real :: duhbt_du !< The zonal barotropic face area [L H ~> m2 or kg m-1]
4827
4828 if (u == 0.0) then
4829 duhbt_du = 0.5*(btc%FA_u_E0 + btc%FA_u_W0) ! Note the potential discontinuity here.
4830 elseif (u < btc%uBT_EE) then
4831 duhbt_du = btc%FA_u_EE
4832 elseif (u < 0.0) then
4833 duhbt_du = (btc%FA_u_E0 + 3.0*btc%uh_crvE * u**2)
4834 elseif (u <= btc%uBT_WW) then
4835 duhbt_du = (btc%FA_u_W0 + 3.0*btc%uh_crvW * u**2)
4836 else ! (u > BTC%uBT_WW)
4837 duhbt_du = btc%FA_u_WW
4838 endif
4839
4840end function find_duhbt_du
4841
4842!> This function inverts the transport function to determine the barotopic
4843!! velocity that is consistent with a given transport, or if INTEGRAL_BT_CONT=True
4844!! this finds the time-integrated velocity that is consistent with a time-integrated transport.
4845function uhbt_to_ubt(uhbt, BTC) result(ubt)
4846 real, intent(in) :: uhbt !< The barotropic zonal transport that should be inverted for,
4847 !! [H L2 T-1 ~> m3 s-1 or kg s-1] or the time-integrated
4848 !! transport [H L2 ~> m3 or kg].
4849 type(local_bt_cont_u_type), intent(in) :: btc !< A structure containing various fields that allow the
4850 !! barotropic transports to be calculated consistently with the
4851 !! layers' continuity equations. The dimensions of some
4852 !! of the elements in this type vary depending on INTEGRAL_BT_CONT.
4853 real :: ubt !< The result - The velocity that gives uhbt transport [L T-1 ~> m s-1]
4854 !! or the time-integrated velocity [L ~> m].
4855
4856 ! Local variables
4857 real :: ubt_min, ubt_max ! Bounding values of vbt [L T-1 ~> m s-1] or [L ~> m]
4858 real :: uhbt_err ! The transport error [H L2 T-1 ~> m3 s-1 or kg s-1] or [H L2 ~> m3 or kg].
4859 real :: derr_du ! The change in transport error with vbt, i.e. the face area [H L ~> m2 or kg m-1].
4860 real :: uherr_min, uherr_max ! The bounding values of the transport error [H L2 T-1 ~> m3 s-1 or kg s-1]
4861 ! or [H L2 ~> m3 or kg].
4862 real, parameter :: tol = 1.0e-10 ! A fractional match tolerance [nondim]
4863 real, parameter :: vs1 = 1.25 ! Nondimensional parameters used in limiting
4864 real, parameter :: vs2 = 2.0 ! the velocity, starting at vs1, with the
4865 ! maximum increase of vs2, both [nondim].
4866 integer :: itt, max_itt = 20
4867
4868 ! Find the value of ubt that gives uhbt.
4869 if (uhbt == 0.0) then
4870 ubt = 0.0
4871 elseif (uhbt < btc%uh_EE) then
4872 ubt = btc%uBT_EE + (uhbt - btc%uh_EE) / btc%FA_u_EE
4873 elseif (uhbt < 0.0) then
4874 ! Iterate to convergence with Newton's method (when bounded) and the
4875 ! false position method otherwise. ubt will be negative.
4876 ubt_min = btc%uBT_EE ; uherr_min = btc%uh_EE - uhbt
4877 ubt_max = 0.0 ; uherr_max = -uhbt
4878 ! Use a false-position method first guess.
4879 ubt = btc%uBT_EE * (uhbt / btc%uh_EE)
4880 do itt = 1, max_itt
4881 uhbt_err = ubt * (btc%FA_u_E0 + btc%uh_crvE * ubt**2) - uhbt
4882
4883 if (abs(uhbt_err) < tol*abs(uhbt)) exit
4884 if (uhbt_err > 0.0) then ; ubt_max = ubt ; uherr_max = uhbt_err ; endif
4885 if (uhbt_err < 0.0) then ; ubt_min = ubt ; uherr_min = uhbt_err ; endif
4886
4887 derr_du = btc%FA_u_E0 + 3.0 * btc%uh_crvE * ubt**2
4888 if ((uhbt_err >= derr_du*(ubt - ubt_min)) .or. &
4889 (-uhbt_err >= derr_du*(ubt_max - ubt)) .or. (derr_du <= 0.0)) then
4890 ! Use a false-position method guess.
4891 ubt = ubt_max + (ubt_min-ubt_max) * (uherr_max / (uherr_max-uherr_min))
4892 else ! Use Newton's method.
4893 ubt = ubt - uhbt_err / derr_du
4894 if (abs(uhbt_err) < (0.01*tol)*abs(ubt_min*derr_du)) exit
4895 endif
4896 enddo
4897 elseif (uhbt <= btc%uh_WW) then
4898 ! Iterate to convergence with Newton's method. ubt will be positive.
4899 ubt_min = 0.0 ; uherr_min = -uhbt
4900 ubt_max = btc%uBT_WW ; uherr_max = btc%uh_WW - uhbt
4901 ! Use a false-position method first guess.
4902 ubt = btc%uBT_WW * (uhbt / btc%uh_WW)
4903 do itt = 1, max_itt
4904 uhbt_err = ubt * (btc%FA_u_W0 + btc%uh_crvW * ubt**2) - uhbt
4905
4906 if (abs(uhbt_err) < tol*abs(uhbt)) exit
4907 if (uhbt_err > 0.0) then ; ubt_max = ubt ; uherr_max = uhbt_err ; endif
4908 if (uhbt_err < 0.0) then ; ubt_min = ubt ; uherr_min = uhbt_err ; endif
4909
4910 derr_du = btc%FA_u_W0 + 3.0 * btc%uh_crvW * ubt**2
4911 if ((uhbt_err >= derr_du*(ubt - ubt_min)) .or. &
4912 (-uhbt_err >= derr_du*(ubt_max - ubt)) .or. (derr_du <= 0.0)) then
4913 ! Use a false-position method guess.
4914 ubt = ubt_min + (ubt_max-ubt_min) * (-uherr_min / (uherr_max-uherr_min))
4915 else ! Use Newton's method.
4916 ubt = ubt - uhbt_err / derr_du
4917 if (abs(uhbt_err) < (0.01*tol)*(ubt_max*derr_du)) exit
4918 endif
4919 enddo
4920 else ! (uhbt > BTC%uh_WW)
4921 ubt = btc%uBT_WW + (uhbt - btc%uh_WW) / btc%FA_u_WW
4922 endif
4923
4924end function uhbt_to_ubt
4925
4926!> The function find_vhbt determines the meridional transport for a given velocity, or with
4927!! INTEGRAL_BT_CONT=True it determines the time-integrated meridional transport for a given
4928!! time-integrated velocity.
4929function find_vhbt(v, BTC) result(vhbt)
4930 real, intent(in) :: v !< The local meridional velocity [L T-1 ~> m s-1] or time integrated velocity [L ~> m]
4931 type(local_bt_cont_v_type), intent(in) :: btc !< A structure containing various fields that
4932 !! allow the barotropic transports to be calculated consistently
4933 !! with the layers' continuity equations. The dimensions of some
4934 !! of the elements in this type vary depending on INTEGRAL_BT_CONT.
4935 real :: vhbt !< The meridional barotropic transport [L2 H T-1 ~> m3 s-1] or time integrated transport [L2 H ~> m3]
4936
4937 if (v == 0.0) then
4938 vhbt = 0.0
4939 elseif (v < btc%vBT_NN) then
4940 vhbt = (v - btc%vBT_NN) * btc%FA_v_NN + btc%vh_NN
4941 elseif (v < 0.0) then
4942 vhbt = v * (btc%FA_v_N0 + btc%vh_crvN * v**2)
4943 elseif (v <= btc%vBT_SS) then
4944 vhbt = v * (btc%FA_v_S0 + btc%vh_crvS * v**2)
4945 else ! (v > BTC%vBT_SS)
4946 vhbt = (v - btc%vBT_SS) * btc%FA_v_SS + btc%vh_SS
4947 endif
4948
4949end function find_vhbt
4950
4951!> The function find_dvhbt_dv determines the marginal meridional face area for a given velocity, or
4952!! with INTEGRAL_BT_CONT=True for a given time-integrated velocity.
4953function find_dvhbt_dv(v, BTC) result(dvhbt_dv)
4954 real, intent(in) :: v !< The local meridional velocity [L T-1 ~> m s-1] or time integrated velocity [L ~> m]
4955 type(local_bt_cont_v_type), intent(in) :: btc !< A structure containing various fields that
4956 !! allow the barotropic transports to be calculated consistently
4957 !! with the layers' continuity equations. The dimensions of some
4958 !! of the elements in this type vary depending on INTEGRAL_BT_CONT.
4959 real :: dvhbt_dv !< The meridional barotropic face area [L H ~> m2 or kg m-1]
4960
4961 if (v == 0.0) then
4962 dvhbt_dv = 0.5*(btc%FA_v_N0 + btc%FA_v_S0) ! Note the potential discontinuity here.
4963 elseif (v < btc%vBT_NN) then
4964 dvhbt_dv = btc%FA_v_NN
4965 elseif (v < 0.0) then
4966 dvhbt_dv = btc%FA_v_N0 + 3.0*btc%vh_crvN * v**2
4967 elseif (v <= btc%vBT_SS) then
4968 dvhbt_dv = btc%FA_v_S0 + 3.0*btc%vh_crvS * v**2
4969 else ! (v > BTC%vBT_SS)
4970 dvhbt_dv = btc%FA_v_SS
4971 endif
4972
4973end function find_dvhbt_dv
4974
4975!> This function inverts the transport function to determine the barotopic
4976!! velocity that is consistent with a given transport, or if INTEGRAL_BT_CONT=True
4977!! this finds the time-integrated velocity that is consistent with a time-integrated transport.
4978function vhbt_to_vbt(vhbt, BTC) result(vbt)
4979 real, intent(in) :: vhbt !< The barotropic meridional transport that should be
4980 !! inverted for [H L2 T-1 ~> m3 s-1 or kg s-1] or the
4981 !! time-integrated transport [H L2 ~> m3 or kg].
4982 type(local_bt_cont_v_type), intent(in) :: btc !< A structure containing various fields that allow the
4983 !! barotropic transports to be calculated consistently
4984 !! with the layers' continuity equations. The dimensions of some
4985 !! of the elements in this type vary depending on INTEGRAL_BT_CONT.
4986 real :: vbt !< The result - The velocity that gives vhbt transport [L T-1 ~> m s-1]
4987 !! or the time-integrated velocity [L ~> m].
4988
4989 ! Local variables
4990 real :: vbt_min, vbt_max ! Bounding values of vbt [L T-1 ~> m s-1] or [L ~> m]
4991 real :: vhbt_err ! The transport error [H L2 T-1 ~> m3 s-1 or kg s-1] or [H L2 ~> m3 or kg].
4992 real :: derr_dv ! The change in transport error with vbt, i.e. the face area [H L ~> m2 or kg m-1].
4993 real :: vherr_min, vherr_max ! The bounding values of the transport error [H L2 T-1 ~> m3 s-1 or kg s-1]
4994 ! or [H L2 ~> m3 or kg].
4995 real, parameter :: tol = 1.0e-10 ! A fractional match tolerance [nondim]
4996 real, parameter :: vs1 = 1.25 ! Nondimensional parameters used in limiting
4997 real, parameter :: vs2 = 2.0 ! the velocity, starting at vs1, with the
4998 ! maximum increase of vs2, both [nondim].
4999 integer :: itt, max_itt = 20
5000
5001 ! Find the value of vbt that gives vhbt.
5002 if (vhbt == 0.0) then
5003 vbt = 0.0
5004 elseif (vhbt < btc%vh_NN) then
5005 vbt = btc%vBT_NN + (vhbt - btc%vh_NN) / btc%FA_v_NN
5006 elseif (vhbt < 0.0) then
5007 ! Iterate to convergence with Newton's method (when bounded) and the
5008 ! false position method otherwise. vbt will be negative.
5009 vbt_min = btc%vBT_NN ; vherr_min = btc%vh_NN - vhbt
5010 vbt_max = 0.0 ; vherr_max = -vhbt
5011 ! Use a false-position method first guess.
5012 vbt = btc%vBT_NN * (vhbt / btc%vh_NN)
5013 do itt = 1, max_itt
5014 vhbt_err = vbt * (btc%FA_v_N0 + btc%vh_crvN * vbt**2) - vhbt
5015
5016 if (abs(vhbt_err) < tol*abs(vhbt)) exit
5017 if (vhbt_err > 0.0) then ; vbt_max = vbt ; vherr_max = vhbt_err ; endif
5018 if (vhbt_err < 0.0) then ; vbt_min = vbt ; vherr_min = vhbt_err ; endif
5019
5020 derr_dv = btc%FA_v_N0 + 3.0 * btc%vh_crvN * vbt**2
5021 if ((vhbt_err >= derr_dv*(vbt - vbt_min)) .or. &
5022 (-vhbt_err >= derr_dv*(vbt_max - vbt)) .or. (derr_dv <= 0.0)) then
5023 ! Use a false-position method guess.
5024 vbt = vbt_max + (vbt_min-vbt_max) * (vherr_max / (vherr_max-vherr_min))
5025 else ! Use Newton's method.
5026 vbt = vbt - vhbt_err / derr_dv
5027 if (abs(vhbt_err) < (0.01*tol)*abs(derr_dv*vbt_min)) exit
5028 endif
5029 enddo
5030 elseif (vhbt <= btc%vh_SS) then
5031 ! Iterate to convergence with Newton's method. vbt will be positive.
5032 vbt_min = 0.0 ; vherr_min = -vhbt
5033 vbt_max = btc%vBT_SS ; vherr_max = btc%vh_SS - vhbt
5034 ! Use a false-position method first guess.
5035 vbt = btc%vBT_SS * (vhbt / btc%vh_SS)
5036 do itt = 1, max_itt
5037 vhbt_err = vbt * (btc%FA_v_S0 + btc%vh_crvS * vbt**2) - vhbt
5038
5039 if (abs(vhbt_err) < tol*abs(vhbt)) exit
5040 if (vhbt_err > 0.0) then ; vbt_max = vbt ; vherr_max = vhbt_err ; endif
5041 if (vhbt_err < 0.0) then ; vbt_min = vbt ; vherr_min = vhbt_err ; endif
5042
5043 derr_dv = btc%FA_v_S0 + 3.0 * btc%vh_crvS * vbt**2
5044 if ((vhbt_err >= derr_dv*(vbt - vbt_min)) .or. &
5045 (-vhbt_err >= derr_dv*(vbt_max - vbt)) .or. (derr_dv <= 0.0)) then
5046 ! Use a false-position method guess.
5047 vbt = vbt_min + (vbt_max-vbt_min) * (-vherr_min / (vherr_max-vherr_min))
5048 else ! Use Newton's method.
5049 vbt = vbt - vhbt_err / derr_dv
5050 if (abs(vhbt_err) < (0.01*tol)*(vbt_max*derr_dv)) exit
5051 endif
5052 enddo
5053 else ! (vhbt > BTC%vh_SS)
5054 vbt = btc%vBT_SS + (vhbt - btc%vh_SS) / btc%FA_v_SS
5055 endif
5056
5057end function vhbt_to_vbt
5058
5059!> This subroutine sets up reordered versions of the BT_cont type in the
5060!! local_BT_cont types, which have wide halos properly filled in.
5061subroutine set_local_bt_cont_types(BT_cont, BTCL_u, BTCL_v, G, US, MS, BT_Domain, halo, dt_baroclinic)
5062 type(bt_cont_type), intent(inout) :: BT_cont !< The BT_cont_type input to the barotropic solver
5063 type(memory_size_type), intent(in) :: MS !< A type that describes the memory sizes of
5064 !! the argument arrays
5065 type(local_bt_cont_u_type), dimension(SZIBW_(MS),SZJW_(MS)), &
5066 intent(out) :: BTCL_u !< A structure with the u information from BT_cont
5067 type(local_bt_cont_v_type), dimension(SZIW_(MS),SZJBW_(MS)), &
5068 intent(out) :: BTCL_v !< A structure with the v information from BT_cont
5069 type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure
5070 type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
5071 type(mom_domain_type), intent(inout) :: BT_Domain !< The domain to use for updating the halos
5072 !! of wide arrays
5073 integer, intent(in) :: halo !< The extra halo size to use here
5074 real, optional, intent(in) :: dt_baroclinic !< The baroclinic time step [T ~> s], which
5075 !! is provided if INTEGRAL_BT_CONTINUITY is true.
5076
5077 ! Local variables
5078 real, dimension(SZIBW_(MS),SZJW_(MS)) :: &
5079 u_polarity, & ! An array used to test for halo update polarity [nondim]
5080 uBT_EE, uBT_WW, & ! Zonal velocities at which the form of the fit changes [L T-1 ~> m s-1]
5081 FA_u_EE, FA_u_E0, FA_u_W0, FA_u_WW ! Zonal face areas [H L ~> m2 or kg m-1]
5082 real, dimension(SZIW_(MS),SZJBW_(MS)) :: &
5083 v_polarity, & ! An array used to test for halo update polarity [nondim]
5084 vBT_NN, vBT_SS, & ! Meridional velocities at which the form of the fit changes [L T-1 ~> m s-1]
5085 FA_v_NN, FA_v_N0, FA_v_S0, FA_v_SS ! Meridional face areas [H L ~> m2 or kg m-1]
5086 real :: dt ! The baroclinic timestep [T ~> s] or 1.0 [nondim]
5087 real, parameter :: C1_3 = 1.0/3.0 ! [nondim]
5088 integer :: i, j, is, ie, js, je, hs
5089
5090 is = g%isc ; ie = g%iec ; js = g%jsc ; je = g%jec
5091 hs = max(halo,0)
5092 dt = 1.0 ; if (present(dt_baroclinic)) dt = dt_baroclinic
5093
5094 ! Copy the BT_cont arrays into symmetric, potentially wide haloed arrays.
5095 !$OMP parallel default(shared)
5096 !$OMP do
5097 do j=js-hs,je+hs ; do i=is-hs-1,ie+hs
5098 u_polarity(i,j) = 1.0
5099 ubt_ee(i,j) = 0.0 ; ubt_ww(i,j) = 0.0
5100 fa_u_ee(i,j) = 0.0 ; fa_u_e0(i,j) = 0.0 ; fa_u_w0(i,j) = 0.0 ; fa_u_ww(i,j) = 0.0
5101 enddo ; enddo
5102 !$OMP do
5103 do j=js-hs-1,je+hs ; do i=is-hs,ie+hs
5104 v_polarity(i,j) = 1.0
5105 vbt_nn(i,j) = 0.0 ; vbt_ss(i,j) = 0.0
5106 fa_v_nn(i,j) = 0.0 ; fa_v_n0(i,j) = 0.0 ; fa_v_s0(i,j) = 0.0 ; fa_v_ss(i,j) = 0.0
5107 enddo ; enddo
5108 !$OMP do
5109 do j=js,je ; do i=is-1,ie
5110 ubt_ee(i,j) = bt_cont%uBT_EE(i,j) ; ubt_ww(i,j) = bt_cont%uBT_WW(i,j)
5111 fa_u_ee(i,j) = bt_cont%FA_u_EE(i,j) ; fa_u_e0(i,j) = bt_cont%FA_u_E0(i,j)
5112 fa_u_w0(i,j) = bt_cont%FA_u_W0(i,j) ; fa_u_ww(i,j) = bt_cont%FA_u_WW(i,j)
5113 enddo ; enddo
5114 !$OMP do
5115 do j=js-1,je ; do i=is,ie
5116 vbt_nn(i,j) = bt_cont%vBT_NN(i,j) ; vbt_ss(i,j) = bt_cont%vBT_SS(i,j)
5117 fa_v_nn(i,j) = bt_cont%FA_v_NN(i,j) ; fa_v_n0(i,j) = bt_cont%FA_v_N0(i,j)
5118 fa_v_s0(i,j) = bt_cont%FA_v_S0(i,j) ; fa_v_ss(i,j) = bt_cont%FA_v_SS(i,j)
5119 enddo ; enddo
5120 !$OMP end parallel
5121
5122 if (id_clock_calc_pre > 0) call cpu_clock_end(id_clock_calc_pre)
5123 if (id_clock_pass_pre > 0) call cpu_clock_begin(id_clock_pass_pre)
5124!--- begin setup for group halo update
5125 call create_group_pass(bt_cont%pass_polarity_BT, u_polarity, v_polarity, bt_domain)
5126 call create_group_pass(bt_cont%pass_polarity_BT, ubt_ee, vbt_nn, bt_domain)
5127 call create_group_pass(bt_cont%pass_polarity_BT, ubt_ww, vbt_ss, bt_domain)
5128
5129 call create_group_pass(bt_cont%pass_FA_uv, fa_u_ee, fa_v_nn, bt_domain, to_all+scalar_pair)
5130 call create_group_pass(bt_cont%pass_FA_uv, fa_u_e0, fa_v_n0, bt_domain, to_all+scalar_pair)
5131 call create_group_pass(bt_cont%pass_FA_uv, fa_u_w0, fa_v_s0, bt_domain, to_all+scalar_pair)
5132 call create_group_pass(bt_cont%pass_FA_uv, fa_u_ww, fa_v_ss, bt_domain, to_all+scalar_pair)
5133!--- end setup for group halo update
5134 ! Do halo updates on BT_cont.
5135 call do_group_pass(bt_cont%pass_polarity_BT, bt_domain)
5136 call do_group_pass(bt_cont%pass_FA_uv, bt_domain)
5137 if (id_clock_pass_pre > 0) call cpu_clock_end(id_clock_pass_pre)
5138 if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre)
5139
5140 !$OMP parallel default(shared)
5141 !$OMP do
5142 do j=js-hs,je+hs ; do i=is-hs-1,ie+hs
5143 btcl_u(i,j)%FA_u_EE = fa_u_ee(i,j) ; btcl_u(i,j)%FA_u_E0 = fa_u_e0(i,j)
5144 btcl_u(i,j)%FA_u_W0 = fa_u_w0(i,j) ; btcl_u(i,j)%FA_u_WW = fa_u_ww(i,j)
5145 btcl_u(i,j)%uBT_EE = dt*ubt_ee(i,j) ; btcl_u(i,j)%uBT_WW = dt*ubt_ww(i,j)
5146 ! Check for reversed polarity in the tripolar halo regions.
5147 if (u_polarity(i,j) < 0.0) then
5148 call swap(btcl_u(i,j)%FA_u_EE, btcl_u(i,j)%FA_u_WW)
5149 call swap(btcl_u(i,j)%FA_u_E0, btcl_u(i,j)%FA_u_W0)
5150 call swap(btcl_u(i,j)%uBT_EE, btcl_u(i,j)%uBT_WW)
5151 endif
5152
5153 btcl_u(i,j)%uh_EE = btcl_u(i,j)%uBT_EE * &
5154 (c1_3 * (2.0*btcl_u(i,j)%FA_u_E0 + btcl_u(i,j)%FA_u_EE))
5155 btcl_u(i,j)%uh_WW = btcl_u(i,j)%uBT_WW * &
5156 (c1_3 * (2.0*btcl_u(i,j)%FA_u_W0 + btcl_u(i,j)%FA_u_WW))
5157
5158 btcl_u(i,j)%uh_crvE = 0.0 ; btcl_u(i,j)%uh_crvW = 0.0
5159 if (abs(btcl_u(i,j)%uBT_WW) > 0.0) btcl_u(i,j)%uh_crvW = &
5160 (c1_3 * (btcl_u(i,j)%FA_u_WW - btcl_u(i,j)%FA_u_W0)) / btcl_u(i,j)%uBT_WW**2
5161 if (abs(btcl_u(i,j)%uBT_EE) > 0.0) btcl_u(i,j)%uh_crvE = &
5162 (c1_3 * (btcl_u(i,j)%FA_u_EE - btcl_u(i,j)%FA_u_E0)) / btcl_u(i,j)%uBT_EE**2
5163 enddo ; enddo
5164 !$OMP do
5165 do j=js-hs-1,je+hs ; do i=is-hs,ie+hs
5166 btcl_v(i,j)%FA_v_NN = fa_v_nn(i,j) ; btcl_v(i,j)%FA_v_N0 = fa_v_n0(i,j)
5167 btcl_v(i,j)%FA_v_S0 = fa_v_s0(i,j) ; btcl_v(i,j)%FA_v_SS = fa_v_ss(i,j)
5168 btcl_v(i,j)%vBT_NN = dt*vbt_nn(i,j) ; btcl_v(i,j)%vBT_SS = dt*vbt_ss(i,j)
5169 ! Check for reversed polarity in the tripolar halo regions.
5170 if (v_polarity(i,j) < 0.0) then
5171 call swap(btcl_v(i,j)%FA_v_NN, btcl_v(i,j)%FA_v_SS)
5172 call swap(btcl_v(i,j)%FA_v_N0, btcl_v(i,j)%FA_v_S0)
5173 call swap(btcl_v(i,j)%vBT_NN, btcl_v(i,j)%vBT_SS)
5174 endif
5175
5176 btcl_v(i,j)%vh_NN = btcl_v(i,j)%vBT_NN * &
5177 (c1_3 * (2.0*btcl_v(i,j)%FA_v_N0 + btcl_v(i,j)%FA_v_NN))
5178 btcl_v(i,j)%vh_SS = btcl_v(i,j)%vBT_SS * &
5179 (c1_3 * (2.0*btcl_v(i,j)%FA_v_S0 + btcl_v(i,j)%FA_v_SS))
5180
5181 btcl_v(i,j)%vh_crvN = 0.0 ; btcl_v(i,j)%vh_crvS = 0.0
5182 if (abs(btcl_v(i,j)%vBT_SS) > 0.0) btcl_v(i,j)%vh_crvS = &
5183 (c1_3 * (btcl_v(i,j)%FA_v_SS - btcl_v(i,j)%FA_v_S0)) / btcl_v(i,j)%vBT_SS**2
5184 if (abs(btcl_v(i,j)%vBT_NN) > 0.0) btcl_v(i,j)%vh_crvN = &
5185 (c1_3 * (btcl_v(i,j)%FA_v_NN - btcl_v(i,j)%FA_v_N0)) / btcl_v(i,j)%vBT_NN**2
5186 enddo ; enddo
5187 !$OMP end parallel
5188end subroutine set_local_bt_cont_types
5189
5190
5191!> Adjust_local_BT_cont_types expands the range of velocities with a cubic curve
5192!! translating velocities into transports to match the initial values of velocities and
5193!! summed transports when the velocities are larger than the first guesses of the cubic
5194!! transition velocities used to set up the local_BT_cont types.
5195subroutine adjust_local_bt_cont_types(ubt, uhbt, vbt, vhbt, BTCL_u, BTCL_v, &
5196 G, US, MS, halo, dt_baroclinic)
5197 type(memory_size_type), intent(in) :: MS !< A type that describes the memory sizes of the argument arrays.
5198 real, dimension(SZIBW_(MS),SZJW_(MS)), &
5199 intent(in) :: ubt !< The linearization zonal barotropic velocity [L T-1 ~> m s-1].
5200 real, dimension(SZIBW_(MS),SZJW_(MS)), &
5201 intent(in) :: uhbt !< The linearization zonal barotropic transport
5202 !! [H L2 T-1 ~> m3 s-1 or kg s-1].
5203 real, dimension(SZIW_(MS),SZJBW_(MS)), &
5204 intent(in) :: vbt !< The linearization meridional barotropic velocity [L T-1 ~> m s-1].
5205 real, dimension(SZIW_(MS),SZJBW_(MS)), &
5206 intent(in) :: vhbt !< The linearization meridional barotropic transport
5207 !! [H L2 T-1 ~> m3 s-1 or kg s-1].
5208 type(local_bt_cont_u_type), dimension(SZIBW_(MS),SZJW_(MS)), &
5209 intent(out) :: BTCL_u !< A structure with the u information from BT_cont.
5210 type(local_bt_cont_v_type), dimension(SZIW_(MS),SZJBW_(MS)), &
5211 intent(out) :: BTCL_v !< A structure with the v information from BT_cont.
5212 type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure.
5213 type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
5214 integer, intent(in) :: halo !< The extra halo size to use here.
5215 real, optional, intent(in) :: dt_baroclinic !< The baroclinic time step [T ~> s], which is
5216 !! provided if INTEGRAL_BT_CONTINUITY is true.
5217
5218 ! Local variables
5219 real :: dt ! The baroclinic timestep [T ~> s] or 1.0 [nondim]
5220 real, parameter :: C1_3 = 1.0/3.0 ! [nondim]
5221 integer :: i, j, is, ie, js, je, hs
5222
5223 is = g%isc ; ie = g%iec ; js = g%jsc ; je = g%jec
5224 hs = max(halo,0)
5225 dt = 1.0 ; if (present(dt_baroclinic)) dt = dt_baroclinic
5226
5227 !$OMP parallel do default(shared)
5228 do j=js-hs,je+hs ; do i=is-hs-1,ie+hs
5229 if ((dt*ubt(i,j) > btcl_u(i,j)%uBT_WW) .and. (dt*uhbt(i,j) > btcl_u(i,j)%uh_WW)) then
5230 ! Expand the cubic fit to use this new point. ubt is negative.
5231 btcl_u(i,j)%ubt_WW = dt * ubt(i,j)
5232 if (3.0*uhbt(i,j) < 2.0*ubt(i,j) * btcl_u(i,j)%FA_u_W0) then
5233 ! No further bounding is needed.
5234 btcl_u(i,j)%uh_crvW = (uhbt(i,j) - ubt(i,j) * btcl_u(i,j)%FA_u_W0) / (dt**2 * ubt(i,j)**3)
5235 else ! This should not happen often!
5236 btcl_u(i,j)%FA_u_W0 = 1.5*uhbt(i,j) / ubt(i,j)
5237 btcl_u(i,j)%uh_crvW = -0.5*uhbt(i,j) / (dt**2 * ubt(i,j)**3)
5238 endif
5239 btcl_u(i,j)%uh_WW = dt * uhbt(i,j)
5240 ! I don't know whether this is helpful.
5241! BTCL_u(I,j)%FA_u_WW = min(BTCL_u(I,j)%FA_u_WW, uhbt(I,j) / ubt(I,j))
5242 elseif ((dt*ubt(i,j) < btcl_u(i,j)%uBT_EE) .and. (dt*uhbt(i,j) < btcl_u(i,j)%uh_EE)) then
5243 ! Expand the cubic fit to use this new point. ubt is negative.
5244 btcl_u(i,j)%ubt_EE = dt * ubt(i,j)
5245 if (3.0*uhbt(i,j) < 2.0*ubt(i,j) * btcl_u(i,j)%FA_u_E0) then
5246 ! No further bounding is needed.
5247 btcl_u(i,j)%uh_crvE = (uhbt(i,j) - ubt(i,j) * btcl_u(i,j)%FA_u_E0) / (dt**2 * ubt(i,j)**3)
5248 else ! This should not happen often!
5249 btcl_u(i,j)%FA_u_E0 = 1.5*uhbt(i,j) / ubt(i,j)
5250 btcl_u(i,j)%uh_crvE = -0.5*uhbt(i,j) / (dt**2 * ubt(i,j)**3)
5251 endif
5252 btcl_u(i,j)%uh_EE = dt * uhbt(i,j)
5253 ! I don't know whether this is helpful.
5254! BTCL_u(I,j)%FA_u_EE = min(BTCL_u(I,j)%FA_u_EE, uhbt(I,j) / ubt(I,j))
5255 endif
5256 enddo ; enddo
5257 !$OMP parallel do default(shared)
5258 do j=js-hs-1,je+hs ; do i=is-hs,ie+hs
5259 if ((dt*vbt(i,j) > btcl_v(i,j)%vBT_SS) .and. (dt*vhbt(i,j) > btcl_v(i,j)%vh_SS)) then
5260 ! Expand the cubic fit to use this new point. vbt is negative.
5261 btcl_v(i,j)%vbt_SS = dt * vbt(i,j)
5262 if (3.0*vhbt(i,j) < 2.0*vbt(i,j) * btcl_v(i,j)%FA_v_S0) then
5263 ! No further bounding is needed.
5264 btcl_v(i,j)%vh_crvS = (vhbt(i,j) - vbt(i,j) * btcl_v(i,j)%FA_v_S0) / (dt**2 * vbt(i,j)**3)
5265 else ! This should not happen often!
5266 btcl_v(i,j)%FA_v_S0 = 1.5*vhbt(i,j) / (vbt(i,j))
5267 btcl_v(i,j)%vh_crvS = -0.5*vhbt(i,j) / (dt**2 * vbt(i,j)**3)
5268 endif
5269 btcl_v(i,j)%vh_SS = dt * vhbt(i,j)
5270 ! I don't know whether this is helpful.
5271! BTCL_v(i,J)%FA_v_SS = min(BTCL_v(i,J)%FA_v_SS, vhbt(i,J) / vbt(i,J))
5272 elseif ((dt*vbt(i,j) < btcl_v(i,j)%vBT_NN) .and. (dt*vhbt(i,j) < btcl_v(i,j)%vh_NN)) then
5273 ! Expand the cubic fit to use this new point. vbt is negative.
5274 btcl_v(i,j)%vbt_NN = dt * vbt(i,j)
5275 if (3.0*vhbt(i,j) < 2.0*vbt(i,j) * btcl_v(i,j)%FA_v_N0) then
5276 ! No further bounding is needed.
5277 btcl_v(i,j)%vh_crvN = (vhbt(i,j) - vbt(i,j) * btcl_v(i,j)%FA_v_N0) / (dt**2 * vbt(i,j)**3)
5278 else ! This should not happen often!
5279 btcl_v(i,j)%FA_v_N0 = 1.5*vhbt(i,j) / (vbt(i,j))
5280 btcl_v(i,j)%vh_crvN = -0.5*vhbt(i,j) / (dt**2 * vbt(i,j)**3)
5281 endif
5282 btcl_v(i,j)%vh_NN = dt * vhbt(i,j)
5283 ! I don't know whether this is helpful.
5284! BTCL_v(i,J)%FA_v_NN = min(BTCL_v(i,J)%FA_v_NN, vhbt(i,J) / vbt(i,J))
5285 endif
5286 enddo ; enddo
5287
5288end subroutine adjust_local_bt_cont_types
5289
5290!> This subroutine uses the BT_cont_type to find the maximum face
5291!! areas, which can then be used for finding wave speeds, etc.
5292subroutine bt_cont_to_face_areas(BT_cont, Datu, Datv, G, US, MS, halo)
5293 type(bt_cont_type), intent(inout) :: BT_cont !< The BT_cont_type input to the
5294 !! barotropic solver.
5295 type(memory_size_type), intent(in) :: MS !< A type that describes the memory
5296 !! sizes of the argument arrays.
5297 real, dimension(MS%isdw-1:MS%iedw,MS%jsdw:MS%jedw), &
5298 intent(out) :: Datu !< The effective zonal face area [H L ~> m2 or kg m-1].
5299 real, dimension(MS%isdw:MS%iedw,MS%jsdw-1:MS%jedw), &
5300 intent(out) :: Datv !< The effective meridional face area [H L ~> m2 or kg m-1].
5301 type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure.
5302 type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
5303 integer, optional, intent(in) :: halo !< The extra halo size to use here.
5304
5305 ! Local variables
5306 integer :: i, j, is, ie, js, je, hs
5307 is = g%isc ; ie = g%iec ; js = g%jsc ; je = g%jec
5308 hs = 1 ; if (present(halo)) hs = max(halo,0)
5309
5310 do j=js-hs,je+hs ; do i=is-1-hs,ie+hs
5311 datu(i,j) = max(bt_cont%FA_u_EE(i,j), bt_cont%FA_u_E0(i,j), &
5312 bt_cont%FA_u_W0(i,j), bt_cont%FA_u_WW(i,j))
5313 enddo ; enddo
5314 do j=js-1-hs,je+hs ; do i=is-hs,ie+hs
5315 datv(i,j) = max(bt_cont%FA_v_NN(i,j), bt_cont%FA_v_N0(i,j), &
5316 bt_cont%FA_v_S0(i,j), bt_cont%FA_v_SS(i,j))
5317 enddo ; enddo
5318
5319end subroutine bt_cont_to_face_areas
5320
5321!> Swap the values of two real variables
5322subroutine swap(a, b)
5323 real, intent(inout) :: a !< The first variable to be swapped [arbitrary units]
5324 real, intent(inout) :: b !< The second variable to be swapped [arbitrary units]
5325 real :: tmp ! A temporary variable [arbitrary units]
5326 tmp = a ; a = b ; b = tmp
5327end subroutine swap
5328
5329!> This subroutine determines the open face areas of cells for calculating
5330!! the barotropic transport.
5331subroutine find_face_areas(Datu, Datv, G, GV, US, CS, MS, halo, eta, add_max)
5332 type(memory_size_type), intent(in) :: MS !< A type that describes the memory sizes of the argument arrays.
5333 real, dimension(MS%isdw-1:MS%iedw,MS%jsdw:MS%jedw), &
5334 intent(out) :: Datu !< The open zonal face area [H L ~> m2 or kg m-1].
5335 real, dimension(MS%isdw:MS%iedw,MS%jsdw-1:MS%jedw), &
5336 intent(out) :: Datv !< The open meridional face area [H L ~> m2 or kg m-1].
5337 type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure.
5338 type(verticalgrid_type), intent(in) :: GV !< The ocean's vertical grid structure.
5339 type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
5340 type(barotropic_cs), intent(in) :: CS !< Barotropic control structure
5341 integer, intent(in) :: halo !< The halo size to use, default = 1.
5342 real, dimension(MS%isdw:MS%iedw,MS%jsdw:MS%jedw), &
5343 optional, intent(in) :: eta !< The barotropic free surface height anomaly
5344 !! or column mass anomaly [H ~> m or kg m-2].
5345 real, optional, intent(in) :: add_max !< A value to add to the maximum depth (used
5346 !! to overestimate the external wave speed) [Z ~> m].
5347
5348 ! Local variables
5349 real :: H1, H2 ! Temporary total thicknesses [H ~> m or kg m-2].
5350 real :: Z_to_H ! A local conversion factor [H Z-1 ~> nondim or kg m-3]
5351 integer :: i, j, is, ie, js, je, hs
5352 is = g%isc ; ie = g%iec ; js = g%jsc ; je = g%jec
5353 hs = max(halo,0)
5354
5355 !$OMP parallel default(shared) private(H1,H2,Z_to_H)
5356 if (present(eta)) then
5357 ! The use of harmonic mean thicknesses ensure positive definiteness.
5358 if (gv%Boussinesq) then
5359 !$OMP do
5360 do j=js-hs,je+hs ; do i=is-1-hs,ie+hs
5361 h1 = cs%bathyT(i,j)*gv%Z_to_H + eta(i,j) ; h2 = cs%bathyT(i+1,j)*gv%Z_to_H + eta(i+1,j)
5362 datu(i,j) = 0.0 ; if ((h1 > 0.0) .and. (h2 > 0.0)) &
5363 datu(i,j) = cs%dy_Cu(i,j) * (2.0 * h1 * h2) / (h1 + h2)
5364 ! Datu(I,j) = CS%dy_Cu(I,j) * 0.5 * (H1 + H2)
5365 enddo ; enddo
5366 !$OMP do
5367 do j=js-1-hs,je+hs ; do i=is-hs,ie+hs
5368 h1 = cs%bathyT(i,j)*gv%Z_to_H + eta(i,j) ; h2 = cs%bathyT(i,j+1)*gv%Z_to_H + eta(i,j+1)
5369 datv(i,j) = 0.0 ; if ((h1 > 0.0) .and. (h2 > 0.0)) &
5370 datv(i,j) = cs%dx_Cv(i,j) * (2.0 * h1 * h2) / (h1 + h2)
5371 ! Datv(i,J) = CS%dy_v(i,J) * 0.5 * (H1 + H2)
5372 enddo ; enddo
5373 else
5374 !$OMP do
5375 do j=js-hs,je+hs ; do i=is-1-hs,ie+hs
5376 datu(i,j) = 0.0 ; if ((eta(i,j) > 0.0) .and. (eta(i+1,j) > 0.0)) &
5377 datu(i,j) = cs%dy_Cu(i,j) * (2.0 * eta(i,j) * eta(i+1,j)) / &
5378 (eta(i,j) + eta(i+1,j))
5379 ! Datu(I,j) = CS%dy_Cu(I,j) * 0.5 * (eta(i,j) + eta(i+1,j))
5380 enddo ; enddo
5381 !$OMP do
5382 do j=js-1-hs,je+hs ; do i=is-hs,ie+hs
5383 datv(i,j) = 0.0 ; if ((eta(i,j) > 0.0) .and. (eta(i,j+1) > 0.0)) &
5384 datv(i,j) = cs%dx_Cv(i,j) * (2.0 * eta(i,j) * eta(i,j+1)) / &
5385 (eta(i,j) + eta(i,j+1))
5386 ! Datv(i,J) = CS%dy_v(i,J) * 0.5 * (eta(i,j) + eta(i,j+1))
5387 enddo ; enddo
5388 endif
5389 elseif (present(add_max)) then
5390 z_to_h = gv%Z_to_H ; if (.not.gv%Boussinesq) z_to_h = gv%RZ_to_H * cs%Rho_BT_lin
5391
5392 !$OMP do
5393 do j=js-hs,je+hs ; do i=is-1-hs,ie+hs
5394 h1 = max((g%meanSL(i+1,j) + add_max) + g%bathyT(i+1,j), 0.0)
5395 h2 = max((g%meanSL(i,j) + add_max) + g%bathyT(i,j), 0.0)
5396 datu(i,j) = cs%dy_Cu(i,j) * z_to_h * max(h1, h2)
5397 enddo ; enddo
5398 !$OMP do
5399 do j=js-1-hs,je+hs ; do i=is-hs,ie+hs
5400 h1 = max((g%meanSL(i,j+1) + add_max) + g%bathyT(i,j+1), 0.0)
5401 h2 = max((g%meanSL(i,j) + add_max) + g%bathyT(i,j), 0.0)
5402 datv(i,j) = cs%dx_Cv(i,j) * z_to_h * max(h1, h2)
5403 enddo ; enddo
5404 else
5405 z_to_h = gv%Z_to_H ; if (.not.gv%Boussinesq) z_to_h = gv%RZ_to_H * cs%Rho_BT_lin
5406
5407 !$OMP do
5408 do j=js-hs,je+hs ; do i=is-1-hs,ie+hs
5409 h1 = max(g%meanSL(i,j) + g%bathyT(i,j), 0.0) * z_to_h
5410 h2 = max(g%meanSL(i+1,j) + g%bathyT(i+1,j), 0.0) * z_to_h
5411 datu(i,j) = 0.0
5412 if ((h1 > 0.0) .and. (h2 > 0.0)) &
5413 datu(i,j) = cs%dy_Cu(i,j) * (2.0 * h1 * h2) / (h1 + h2)
5414 enddo ; enddo
5415 !$OMP do
5416 do j=js-1-hs,je+hs ; do i=is-hs,ie+hs
5417 h1 = max(g%meanSL(i,j) + g%bathyT(i,j), 0.0) * z_to_h
5418 h2 = max(g%meanSL(i,j+1) + g%bathyT(i,j+1), 0.0) * z_to_h
5419 datv(i,j) = 0.0
5420 if ((h1 > 0.0) .and. (h2 > 0.0)) &
5421 datv(i,j) = cs%dx_Cv(i,j) * (2.0 * h1 * h2) / (h1 + h2)
5422 enddo ; enddo
5423 endif
5424 !$OMP end parallel
5425
5426end subroutine find_face_areas
5427
5428!> bt_mass_source determines the appropriately limited mass source for
5429!! the barotropic solver, along with a corrective fictitious mass source that
5430!! will drive the barotropic estimate of the free surface height toward the
5431!! baroclinic estimate.
5432subroutine bt_mass_source(h, eta, set_cor, G, GV, CS)
5433 type(ocean_grid_type), intent(in) :: g !< The ocean's grid structure.
5434 type(verticalgrid_type), intent(in) :: gv !< The ocean's vertical grid structure.
5435 real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2].
5436 real, dimension(SZI_(G),SZJ_(G)), intent(in) :: eta !< The free surface height that is to be
5437 !! corrected [H ~> m or kg m-2].
5438 logical, intent(in) :: set_cor !< A flag to indicate whether to set the corrective
5439 !! fluxes (and update the slowly varying part of eta_cor)
5440 !! (.true.) or whether to incrementally update the
5441 !! corrective fluxes.
5442 type(barotropic_cs), intent(inout) :: cs !< Barotropic control structure
5443
5444 ! Local variables
5445 real :: h_tot(szi_(g)) ! The sum of the layer thicknesses [H ~> m or kg m-2].
5446 real :: eta_h(szi_(g)) ! The free surface height determined from
5447 ! the sum of the layer thicknesses [H ~> m or kg m-2].
5448 real :: d_eta ! The difference between estimates of the total
5449 ! thicknesses [H ~> m or kg m-2].
5450 integer :: is, ie, js, je, nz, i, j, k
5451
5452 if (.not.cs%module_is_initialized) call mom_error(fatal, "bt_mass_source: "// &
5453 "Module MOM_barotropic must be initialized before it is used.")
5454
5455 if (.not.cs%split) return
5456
5457 is = g%isc ; ie = g%iec ; js = g%jsc ; je = g%jec ; nz = gv%ke
5458
5459 !$OMP parallel do default(shared) private(eta_h,h_tot,d_eta)
5460 do j=js,je
5461 do i=is,ie ; h_tot(i) = h(i,j,1) ; enddo
5462 if (gv%Boussinesq) then
5463 do i=is,ie ; eta_h(i) = h(i,j,1) - g%bathyT(i,j)*gv%Z_to_H ; enddo
5464 else
5465 do i=is,ie ; eta_h(i) = h(i,j,1) ; enddo
5466 endif
5467 do k=2,nz ; do i=is,ie
5468 eta_h(i) = eta_h(i) + h(i,j,k)
5469 h_tot(i) = h_tot(i) + h(i,j,k)
5470 enddo ; enddo
5471
5472 if (set_cor) then
5473 do i=is,ie
5474 d_eta = eta_h(i) - eta(i,j)
5475 cs%eta_cor(i,j) = d_eta
5476 enddo
5477 else
5478 do i=is,ie
5479 d_eta = eta_h(i) - eta(i,j)
5480 cs%eta_cor(i,j) = cs%eta_cor(i,j) + d_eta
5481 enddo
5482 endif
5483 enddo
5484
5485end subroutine bt_mass_source
5486
5487!> barotropic_init initializes a number of time-invariant fields used in the
5488!! barotropic calculation and initializes any barotropic fields that have not
5489!! already been initialized.
5490subroutine barotropic_init(u, v, h, Time, G, GV, US, param_file, diag, CS, &
5491 restart_CS, calc_dtbt, BT_cont, OBC, SAL_CSp, HA_CSp)
5492 type(ocean_grid_type), intent(inout) :: g !< The ocean's grid structure.
5493 type(verticalgrid_type), intent(in) :: gv !< The ocean's vertical grid structure.
5494 type(unit_scale_type), intent(in) :: us !< A dimensional unit scaling type
5495 real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), &
5496 intent(in) :: u !< The zonal velocity [L T-1 ~> m s-1].
5497 real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), &
5498 intent(in) :: v !< The meridional velocity [L T-1 ~> m s-1].
5499 real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), &
5500 intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2].
5501 type(time_type), target, intent(in) :: time !< The current model time.
5502 type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters.
5503 type(diag_ctrl), target, intent(inout) :: diag !< A structure that is used to regulate diagnostic
5504 !! output.
5505 type(barotropic_cs), intent(inout) :: cs !< Barotropic control structure
5506 type(mom_restart_cs), intent(in) :: restart_cs !< MOM restart control structure
5507 logical, intent(out) :: calc_dtbt !< If true, the barotropic time step must
5508 !! be recalculated before stepping.
5509 type(bt_cont_type), pointer :: bt_cont !< A structure with elements that describe the
5510 !! effective open face areas as a function of
5511 !! barotropic flow.
5512 type(ocean_obc_type), pointer :: obc !< The open boundary condition structure.
5513 type(sal_cs), target, optional :: sal_csp !< A pointer to the control structure of the
5514 !! SAL module.
5515 type(harmonic_analysis_cs), target, optional :: ha_csp !< A pointer to the control structure of the
5516 !! harmonic analysis module
5517
5518 ! This include declares and sets the variable "version".
5519# include "version_variable.h"
5520 ! Local variables
5521 character(len=40) :: mdl = "MOM_barotropic" ! This module's name.
5522 real :: datu(szibs_(g),szj_(g)) ! Zonal open face area [H L ~> m2 or kg m-1].
5523 real :: datv(szi_(g),szjbs_(g)) ! Meridional open face area [H L ~> m2 or kg m-1].
5524 real :: gtot_estimate ! Summed GV%g_prime [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2], to give an
5525 ! upper-bound estimate for pbce.
5526 real :: ssh_extra ! An estimate of how much higher SSH might get, for use
5527 ! in calculating the safe external wave speed [Z ~> m].
5528 real :: dtbt_input ! The input value of DTBT, [nondim] if negative or [s] if positive.
5529 real :: dtbt_restart ! A temporary copy of CS%dtbt read from a restart file [T ~> s]
5530 real :: wave_drag_scale ! A scaling factor for the barotropic linear wave drag
5531 ! piston velocities [nondim].
5532 character(len=200) :: inputdir ! The directory in which to find input files.
5533 character(len=200) :: wave_drag_file ! The file from which to read the wave
5534 ! drag piston velocity.
5535 character(len=80) :: wave_drag_var ! The wave drag piston velocity variable
5536 ! name in wave_drag_file.
5537 character(len=80) :: wave_drag_u ! The wave drag piston velocity variable
5538 ! name in wave_drag_file.
5539 character(len=80) :: wave_drag_v ! The wave drag piston velocity variable
5540 ! name in wave_drag_file.
5541 real :: htot ! Total column thickness used when BT_NONLIN_STRESS is false [Z ~> m].
5542 real :: z_to_h ! A local unit conversion factor [H Z-1 ~> nondim or kg m-3]
5543 real :: h_to_z ! A local unit conversion factor [Z H-1 ~> nondim or m3 kg-1]
5544 real :: det_de ! The partial derivative due to self-attraction and loading of the reference
5545 ! geopotential with the sea surface height when scalar SAL are enabled [nondim].
5546 ! This is typically ~0.09 or less.
5547 real :: h_a_neglect ! A cell volume or mass that is so small it is usually lost
5548 ! in roundoff and can be neglected [H L2 ~> m3 or kg]
5549 real, allocatable :: lin_drag_h(:,:) ! A spatially varying linear drag coefficient at tracer points
5550 ! that acts on the barotropic flow [H T-1 ~> m s-1 or kg m-2 s-1].
5551
5552 type(memory_size_type) :: ms
5553 type(group_pass_type) :: pass_static_data, pass_q_d_cor
5554 type(group_pass_type) :: pass_bt_hbt_btav, pass_a_polarity
5555 integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags.
5556 logical :: use_bt_cont_type
5557 logical :: mask_coastal_pressure_force ! If true, apply masks to some stored inverse grid spacings
5558 ! so that diagnosed barotropic pressure gradient forces are zero at
5559 ! land, coastal or OBC points.
5560 logical :: use_tides
5561 logical :: obc_projection_bug
5562 logical :: enable_bugs ! If true, the defaults for recently added bug-fix flags are set to
5563 ! recreate the bugs, or if false bugs are only used if actively selected.
5564 logical :: visc_rem_bug ! Stores the value of runtime paramter VISC_REM_BUG.
5565 logical :: dtbt_restart_bug ! Stores the value of runtime parameter DTBT_RESTART_BUG.
5566 character(len=48) :: thickness_units, flux_units
5567 character*(40) :: hvel_str
5568 integer :: is, ie, js, je, isq, ieq, jsq, jeq, nz
5569 integer :: isd, ied, jsd, jed, isdb, iedb, jsdb, jedb
5570 integer :: isdw, iedw, jsdw, jedw
5571 integer :: i, j, k
5572 integer :: wd_halos(2), bt_halo_sz
5573 isd = g%isd ; ied = g%ied ; jsd = g%jsd ; jed = g%jed
5574 isdb = g%IsdB ; iedb = g%IedB ; jsdb = g%JsdB ; jedb = g%JedB
5575 is = g%isc ; ie = g%iec ; js = g%jsc ; je = g%jec ; nz = gv%ke
5576 isq = g%IscB ; ieq = g%IecB ; jsq = g%JscB ; jeq = g%JecB
5577 ms%isdw = g%isd ; ms%iedw = g%ied ; ms%jsdw = g%jsd ; ms%jedw = g%jed
5578
5579 if (cs%module_is_initialized) then
5580 call mom_error(warning, "barotropic_init called with a control structure "// &
5581 "that has already been initialized.")
5582 return
5583 endif
5584 cs%module_is_initialized = .true.
5585
5586 cs%diag => diag ; cs%Time => time
5587 if (present(sal_csp)) then
5588 cs%SAL_CSp => sal_csp
5589 endif
5590
5591 ! Read all relevant parameters and write them to the model log.
5592 call get_param(param_file, mdl, "SPLIT", cs%split, default=.true., do_not_log=.true.)
5593 call log_version(param_file, mdl, version, "", log_to_all=.true., layout=cs%split, &
5594 debugging=cs%split, all_default=.not.cs%split)
5595 call get_param(param_file, mdl, "SPLIT", cs%split, &
5596 "Use the split time stepping if true.", default=.true.)
5597 if (.not.cs%split) return
5598
5599 call get_param(param_file, mdl, "USE_BT_CONT_TYPE", use_bt_cont_type, &
5600 "If true, use a structure with elements that describe "//&
5601 "effective face areas from the summed continuity solver "//&
5602 "as a function the barotropic flow in coupling between "//&
5603 "the barotropic and baroclinic flow. This is only used "//&
5604 "if SPLIT is true.", default=.true.)
5605 call get_param(param_file, mdl, "INTEGRAL_BT_CONTINUITY", cs%integral_bt_cont, &
5606 "If true, use the time-integrated velocity over the barotropic steps "//&
5607 "to determine the integrated transports used to update the continuity "//&
5608 "equation. Otherwise the transports are the sum of the transports based on "//&
5609 "a series of instantaneous velocities and the BT_CONT_TYPE for transports. "//&
5610 "This is only valid if USE_BT_CONT_TYPE = True.", &
5611 default=.false., do_not_log=.not.use_bt_cont_type)
5612 call get_param(param_file, mdl, "BOUND_BT_CORRECTION", cs%bound_BT_corr, &
5613 "If true, the corrective pseudo mass-fluxes into the "//&
5614 "barotropic solver are limited to values that require "//&
5615 "less than maxCFL_BT_cont to be accommodated.",default=.false.)
5616 call get_param(param_file, mdl, "BT_CONT_CORR_BOUNDS", cs%BT_cont_bounds, &
5617 "If true, and BOUND_BT_CORRECTION is true, use the "//&
5618 "BT_cont_type variables to set limits determined by "//&
5619 "MAXCFL_BT_CONT on the CFL number of the velocities "//&
5620 "that are likely to be driven by the corrective mass fluxes.", &
5621 default=.true., do_not_log=.not.cs%bound_BT_corr)
5622 call get_param(param_file, mdl, "ADJUST_BT_CONT", cs%adjust_BT_cont, &
5623 "If true, adjust the curve fit to the BT_cont type "//&
5624 "that is used by the barotropic solver to match the "//&
5625 "transport about which the flow is being linearized.", &
5626 default=.false., do_not_log=.not.use_bt_cont_type)
5627 call get_param(param_file, mdl, "GRADUAL_BT_ICS", cs%gradual_BT_ICs, &
5628 "If true, adjust the initial conditions for the "//&
5629 "barotropic solver to the values from the layered "//&
5630 "solution over a whole timestep instead of instantly. "//&
5631 "This is a decent approximation to the inclusion of "//&
5632 "sum(u dh_dt) while also correcting for truncation errors.", &
5633 default=.false.)
5634 call get_param(param_file, mdl, "BT_ADJUST_SRC_FOR_FILTER", cs%bt_adjust_src_for_filter, &
5635 "If true, increases the rate at which BT mass sources are applied so "//&
5636 "that they are all used up before the filtering period starts. "//&
5637 "This option is only valid if INTEGRAL_BT_CONTINUITY = True.", &
5638 default=.false., do_not_log=.not.cs%integral_bt_cont)
5639 call get_param(param_file, mdl, "BT_LIMIT_INTEGRAL_TRANSPORT", cs%bt_limit_integral_transport, &
5640 "If true, limit the time-integrated transports by the initial volume "//&
5641 "accounting for sinks of mass. The limiter uses MAXCFL_BT_CONT. "//&
5642 "This option is only valid if INTEGRAL_BT_CONTINUITY = True.", &
5643 default=.false., do_not_log=.not.cs%integral_bt_cont)
5644 call get_param(param_file, mdl, "BT_USE_VISC_REM_U_UH0", cs%visc_rem_u_uh0, &
5645 "If true, use the viscous remnants when estimating the "//&
5646 "barotropic velocities that were used to calculate uh0 "//&
5647 "and vh0. False is probably the better choice.", default=.false.)
5648 call get_param(param_file, mdl, "BT_USE_WIDE_HALOS", cs%use_wide_halos, &
5649 "If true, use wide halos and march in during the "//&
5650 "barotropic time stepping for efficiency.", default=.true., &
5651 layoutparam=.true.)
5652 call get_param(param_file, mdl, "BTHALO", bt_halo_sz, &
5653 "The minimum halo size for the barotropic solver.", default=0, &
5654 layoutparam=.true.)
5655 call get_param(param_file, mdl, "BT_WIDE_HALO_MIN_STENCIL", cs%min_stencil, &
5656 "The minimum stencil width to use with the wide halo iterations. "//&
5657 "A nonzero value may be useful for debugging purposes, but at the "//&
5658 "cost of reducing the efficiency gain from BT_USE_WIDE_HALOS.", &
5659 default=0, layoutparam=.true., do_not_log=.not.cs%use_wide_halos)
5660#ifdef STATIC_MEMORY_
5661 if ((bt_halo_sz > 0) .and. (bt_halo_sz /= bthalo_)) call mom_error(fatal, &
5662 "barotropic_init: Run-time values of BTHALO must agree with the "//&
5663 "macro BTHALO_ with STATIC_MEMORY_.")
5664 wd_halos(1) = whaloi_+nihalo_ ; wd_halos(2) = whaloj_+njhalo_
5665#else
5666 wd_halos(1) = bt_halo_sz ; wd_halos(2) = bt_halo_sz
5667#endif
5668 call get_param(param_file, mdl, "NONLINEAR_BT_CONTINUITY", cs%Nonlinear_continuity, &
5669 "If true, use nonlinear transports in the barotropic "//&
5670 "continuity equation. This does not apply if "//&
5671 "USE_BT_CONT_TYPE is true.", default=.false., do_not_log=use_bt_cont_type)
5672 call get_param(param_file, mdl, "NONLIN_BT_CONT_UPDATE_PERIOD", cs%Nonlin_cont_update_period, &
5673 "If NONLINEAR_BT_CONTINUITY is true, this is the number "//&
5674 "of barotropic time steps between updates to the face "//&
5675 "areas, or 0 to update only before the barotropic stepping.", &
5676 default=1, do_not_log=.not.cs%Nonlinear_continuity)
5677
5678 call get_param(param_file, mdl, "BT_PROJECT_VELOCITY", cs%BT_project_velocity,&
5679 "If true, step the barotropic velocity first and project "//&
5680 "out the velocity tendency by 1+BEBT when calculating the "//&
5681 "transport. The default (false) is to use a predictor "//&
5682 "continuity step to find the pressure field, and then "//&
5683 "to do a corrector continuity step using a weighted "//&
5684 "average of the old and new velocities, with weights "//&
5685 "of (1-BEBT) and BEBT.", default=.false.)
5686 call get_param(param_file, mdl, "BT_NONLIN_STRESS", cs%nonlin_stress, &
5687 "If true, use the full depth of the ocean at the start of the barotropic "//&
5688 "step when calculating the surface stress contribution to the barotropic "//&
5689 "acclerations. Otherwise use the depth based on bathyT.", default=.false.)
5690 call get_param(param_file, mdl, "BT_RHO_LINEARIZED", cs%Rho_BT_lin, &
5691 "A density that is used to convert total water column thicknesses into mass "//&
5692 "in non-Boussinesq mode with linearized options in the barotropic solver or "//&
5693 "when estimating the stable barotropic timestep without access to the full "//&
5694 "baroclinic model state.", &
5695 units="kg m-3", default=gv%Rho0*us%R_to_kg_m3, scale=us%kg_m3_to_R, &
5696 do_not_log=gv%Boussinesq)
5697
5698 call get_param(param_file, mdl, "DYNAMIC_SURFACE_PRESSURE", cs%dynamic_psurf, &
5699 "If true, add a dynamic pressure due to a viscous ice "//&
5700 "shelf, for instance.", default=.false.)
5701 call get_param(param_file, mdl, "ICE_LENGTH_DYN_PSURF", cs%ice_strength_length, &
5702 "The length scale at which the Rayleigh damping rate due "//&
5703 "to the ice strength should be the same as if a Laplacian "//&
5704 "were applied, if DYNAMIC_SURFACE_PRESSURE is true.", &
5705 units="m", default=1.0e4, scale=us%m_to_L, do_not_log=.not.cs%dynamic_psurf)
5706 call get_param(param_file, mdl, "DEPTH_MIN_DYN_PSURF", cs%Dmin_dyn_psurf, &
5707 "The minimum depth to use in limiting the size of the "//&
5708 "dynamic surface pressure for stability, if "//&
5709 "DYNAMIC_SURFACE_PRESSURE is true..", &
5710 units="m", default=1.0e-6, scale=gv%m_to_H, do_not_log=.not.cs%dynamic_psurf)
5711 call get_param(param_file, mdl, "CONST_DYN_PSURF", cs%const_dyn_psurf, &
5712 "The constant that scales the dynamic surface pressure, "//&
5713 "if DYNAMIC_SURFACE_PRESSURE is true. Stable values "//&
5714 "are < ~1.0.", units="nondim", default=0.9, do_not_log=.not.cs%dynamic_psurf)
5715
5716 call get_param(param_file, mdl, "BT_CORIOLIS_SCALE", cs%BT_Coriolis_scale, &
5717 "A factor by which the barotropic Coriolis anomaly terms are scaled.", &
5718 units="nondim", default=1.0)
5719 call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, &
5720 "This sets the default value for the various _ANSWER_DATE parameters.", &
5721 default=99991231)
5722 call get_param(param_file, mdl, "BAROTROPIC_ANSWER_DATE", cs%answer_date, &
5723 "The vintage of the expressions in the barotropic solver. "//&
5724 "Values below 20190101 recover the answers from the end of 2018, "//&
5725 "while higher values use more efficient or general expressions.", &
5726 default=default_answer_date, do_not_log=.not.gv%Boussinesq)
5727 if (.not.gv%Boussinesq) cs%answer_date = max(cs%answer_date, 20230701)
5728
5729 call get_param(param_file, mdl, "ENABLE_BUGS_BY_DEFAULT", enable_bugs, &
5730 default=.true., do_not_log=.true.) ! This is logged from MOM.F90.
5731 call get_param(param_file, mdl, "VISC_REM_BUG", visc_rem_bug, default=.false., do_not_log=.true.)
5732 call get_param(param_file, mdl, "VISC_REM_BT_WEIGHT_BUG", cs%wt_uv_bug, &
5733 "If true, recover a bug in barotropic solver that uses an unnormalized weight "//&
5734 "function for vertical averages of baroclinic velocity and forcing. Default "//&
5735 "of this flag is set by VISC_REM_BUG.", default=visc_rem_bug)
5736 call get_param(param_file, mdl, "EXTERIOR_OBC_BUG", cs%exterior_OBC_bug, &
5737 "If true, recover a bug in barotropic solver and other routines when "//&
5738 "boundary contitions interior to the domain are used.", &
5739 default=enable_bugs, do_not_log=.true.)
5740 call get_param(param_file, mdl, "OBC_PROJECTION_BUG", obc_projection_bug, &
5741 "If false, use only interior ocean points at OBCs to specify several "//&
5742 "calculations at OBC points, and it avoids applying a land mask at the bay-like "//&
5743 "intersection of orthogonal OBC segments. Otherwise the calculation of terms "//&
5744 "like the potential vorticity used in the barotropic solver relies on bathymetry "//&
5745 "or other fields being projected outward across OBCs. This option changes "//&
5746 "answers for some configurations that use OBCs.", &
5747 default=enable_bugs, do_not_log=.true.)
5748 cs%interior_OBC_PV = .not.obc_projection_bug
5749 call get_param(param_file, mdl, "TIDES", use_tides, &
5750 "If true, apply tidal momentum forcing.", default=.false.)
5751 if (use_tides .and. present(ha_csp)) cs%HA_CSp => ha_csp
5752 call get_param(param_file, mdl, "CALCULATE_SAL", cs%calculate_SAL, &
5753 "If true, calculate self-attraction and loading.", default=use_tides)
5754 det_de = 0.0
5755 if (cs%calculate_SAL .and. associated(cs%SAL_CSp)) &
5756 call scalar_sal_sensitivity(cs%SAL_CSp, det_de)
5757 call get_param(param_file, mdl, "BAROTROPIC_TIDAL_SAL_BUG", cs%tidal_sal_bug, &
5758 "If true, the tidal self-attraction and loading anomaly in the barotropic "//&
5759 "solver has the wrong sign, replicating a long-standing bug with a scalar "//&
5760 "self-attraction and loading term or the SAL term from a previous simulation.", &
5761 default=.false., do_not_log=(det_de==0.0))
5762 call get_param(param_file, mdl, "TIDAL_SAL_FLATHER", cs%tidal_sal_flather, &
5763 "If true, then apply adjustments to the external gravity "//&
5764 "wave speed used with the Flather OBC routine consistent "//&
5765 "with the barotropic solver. This applies to cases with "//&
5766 "tidal forcing using the scalar self-attraction approximation. "//&
5767 "The default is currently False in order to retain previous answers "//&
5768 "but should be set to True for new experiments", default=.false.)
5769
5770 call get_param(param_file, mdl, "SADOURNY", cs%Sadourny, &
5771 "If true, the Coriolis terms are discretized with the "//&
5772 "Sadourny (1975) energy conserving scheme, otherwise "//&
5773 "the Arakawa & Hsu scheme is used. If the internal "//&
5774 "deformation radius is not resolved, the Sadourny scheme "//&
5775 "should probably be used.", default=.true.)
5776
5777 call get_param(param_file, mdl, "BT_THICK_SCHEME", hvel_str, &
5778 "A string describing the scheme that is used to set the "//&
5779 "open face areas used for barotropic transport and the "//&
5780 "relative weights of the accelerations. Valid values are:\n"//&
5781 "\t ARITHMETIC - arithmetic mean layer thicknesses \n"//&
5782 "\t HARMONIC - harmonic mean layer thicknesses \n"//&
5783 "\t HYBRID (the default) - use arithmetic means for \n"//&
5784 "\t layers above the shallowest bottom, the harmonic \n"//&
5785 "\t mean for layers below, and a weighted average for \n"//&
5786 "\t layers that straddle that depth \n"//&
5787 "\t FROM_BT_CONT - use the average thicknesses kept \n"//&
5788 "\t in the h_u and h_v fields of the BT_cont_type", &
5789 default=bt_cont_string)
5790 select case (hvel_str)
5791 case (hybrid_string) ; cs%hvel_scheme = hybrid
5792 case (harmonic_string) ; cs%hvel_scheme = harmonic
5793 case (arithmetic_string) ; cs%hvel_scheme = arithmetic
5794 case (bt_cont_string) ; cs%hvel_scheme = from_bt_cont
5795 case default
5796 call mom_mesg('barotropic_init: BT_THICK_SCHEME ="'//trim(hvel_str)//'"', 0)
5797 call mom_error(fatal, "barotropic_init: Unrecognized setting "// &
5798 "#define BT_THICK_SCHEME "//trim(hvel_str)//" found in input file.")
5799 end select
5800 if ((cs%hvel_scheme == from_bt_cont) .and. .not.use_bt_cont_type) &
5801 call mom_error(fatal, "barotropic_init: BT_THICK_SCHEME FROM_BT_CONT "//&
5802 "can only be used if USE_BT_CONT_TYPE is defined.")
5803
5804 call get_param(param_file, mdl, "BT_STRONG_DRAG", cs%strong_drag, &
5805 "If true, use a stronger estimate of the retarding "//&
5806 "effects of strong bottom drag, by making it implicit "//&
5807 "with the barotropic time-step instead of implicit with "//&
5808 "the baroclinic time-step and dividing by the number of "//&
5809 "barotropic steps.", default=.false.)
5810 call get_param(param_file, mdl, "RESCALE_STRONG_DRAG", cs%rescale_strong_drag, &
5811 "If true, reduce the barotropic contribution to the layer accelerations "//&
5812 "to account for the difference between the forces that can be counteracted "//&
5813 "by the stronger drag with BT_STRONG_DRAG and the average of the layer "//&
5814 "viscous remnants after a baroclinic timestep.", &
5815 default=.false., do_not_log=.not.cs%strong_drag)
5816 call get_param(param_file, mdl, "BT_LINEAR_WAVE_DRAG", cs%linear_wave_drag, &
5817 "If true, apply a linear drag to the barotropic velocities, "//&
5818 "using rates set by lin_drag_u & _v divided by the depth of "//&
5819 "the ocean. This was introduced to facilitate tide modeling.", &
5820 default=.false.)
5821 call get_param(param_file, mdl, "BT_LINEAR_FREQ_DRAG", cs%linear_freq_drag, &
5822 "If true, apply frequency-dependent drag to the tidal velocities. "//&
5823 "The streaming band-pass filter must be turned on.", default=.false.)
5824 call get_param(param_file, mdl, "BT_WAVE_DRAG_FILE", wave_drag_file, &
5825 "The name of the file with the barotropic linear wave drag "//&
5826 "piston velocities.", default="", &
5827 do_not_log=(.not.cs%linear_wave_drag) .and. (.not.cs%linear_freq_drag))
5828 call get_param(param_file, mdl, "BT_WAVE_DRAG_VAR", wave_drag_var, &
5829 "The name of the variable in BT_WAVE_DRAG_FILE with the "//&
5830 "barotropic linear wave drag piston velocities at h points. "//&
5831 "It will not be used if both BT_WAVE_DRAG_U and BT_WAVE_DRAG_V are defined.", &
5832 default="rH", do_not_log=.not.cs%linear_wave_drag)
5833 call get_param(param_file, mdl, "BT_WAVE_DRAG_U", wave_drag_u, &
5834 "The name of the variable in BT_WAVE_DRAG_FILE with the "//&
5835 "barotropic linear wave drag piston velocities at u points.", &
5836 default="", do_not_log=.not.cs%linear_wave_drag)
5837 call get_param(param_file, mdl, "BT_WAVE_DRAG_V", wave_drag_v, &
5838 "The name of the variable in BT_WAVE_DRAG_FILE with the "//&
5839 "barotropic linear wave drag piston velocities at v points.", &
5840 default="", do_not_log=.not.cs%linear_wave_drag)
5841 call get_param(param_file, mdl, "BT_WAVE_DRAG_SCALE", wave_drag_scale, &
5842 "A scaling factor for the barotropic linear wave drag "//&
5843 "piston velocities.", default=1.0, units="nondim", &
5844 do_not_log=.not.cs%linear_wave_drag)
5845
5846 call get_param(param_file, mdl, "CLIP_BT_VELOCITY", cs%clip_velocity, &
5847 "If true, limit any velocity components that exceed "//&
5848 "CFL_TRUNCATE. This should only be used as a desperate "//&
5849 "debugging measure.", default=.false.)
5850 call get_param(param_file, mdl, "CFL_TRUNCATE", cs%CFL_trunc, &
5851 "The value of the CFL number that will cause velocity "//&
5852 "components to be truncated; instability can occur past 0.5.", &
5853 units="nondim", default=0.5, do_not_log=.not.cs%clip_velocity)
5854 call get_param(param_file, mdl, "MAXVEL", cs%maxvel, &
5855 "The maximum velocity allowed before the velocity "//&
5856 "components are truncated.", units="m s-1", default=3.0e8, scale=us%m_s_to_L_T, &
5857 do_not_log=.not.cs%clip_velocity)
5858 call get_param(param_file, mdl, "MAXCFL_BT_CONT", cs%maxCFL_BT_cont, &
5859 "The maximum permitted CFL number associated with the "//&
5860 "barotropic accelerations from the summed velocities "//&
5861 "times the time-derivatives of thicknesses.", units="nondim", &
5862 default=0.25)
5863 call get_param(param_file, mdl, "VEL_UNDERFLOW", cs%vel_underflow, &
5864 "A negligibly small velocity magnitude below which velocity "//&
5865 "components are set to 0. A reasonable value might be "//&
5866 "1e-30 m/s, which is less than an Angstrom divided by "//&
5867 "the age of the universe.", units="m s-1", default=0.0, scale=us%m_s_to_L_T)
5868
5869 call get_param(param_file, mdl, "DT_BT_FILTER", cs%dt_bt_filter, &
5870 "A time-scale over which the barotropic mode solutions "//&
5871 "are filtered, in seconds if positive, or as a fraction "//&
5872 "of DT if negative. When used this can never be taken to "//&
5873 "be longer than 2*dt. Set this to 0 to apply no filtering.", &
5874 units="sec or nondim", default=-0.25)
5875 if (cs%dt_bt_filter > 0.0) cs%dt_bt_filter = us%s_to_T*cs%dt_bt_filter
5876 call get_param(param_file, mdl, "G_BT_EXTRA", cs%G_extra, &
5877 "A nondimensional factor by which gtot is enhanced.", &
5878 units="nondim", default=0.0)
5879 call get_param(param_file, mdl, "SSH_EXTRA", ssh_extra, &
5880 "An estimate of how much higher SSH might get, for use "//&
5881 "in calculating the safe external wave speed. The "//&
5882 "default is the minimum of 10 m or 5% of MAXIMUM_DEPTH.", &
5883 units="m", default=min(10.0,0.05*g%max_depth*us%Z_to_m), scale=us%m_to_Z)
5884
5885 call get_param(param_file, mdl, "DEBUG", cs%debug, &
5886 "If true, write out verbose debugging data.", &
5887 default=.false., debuggingparam=.true.)
5888 call get_param(param_file, mdl, "DEBUG_BT", cs%debug_bt, &
5889 "If true, write out verbose debugging data within the "//&
5890 "barotropic time-stepping loop. The data volume can be "//&
5891 "quite large if this is true.", default=cs%debug, &
5892 debuggingparam=.true.)
5893 call get_param(param_file, mdl, "DEBUG_BT_WIDE_HALOS", cs%debug_wide_halos, &
5894 "If true, write the checksums on the full wide halos. Otherwise only the "//&
5895 "output for the final computational domain is written. This can be valuable "//&
5896 "for debugging certain cases where the stencil used in the wide halo "//&
5897 "iterations depends on which opoen boundary conditions are in the halos.", &
5898 default=.true., do_not_log=.not.(cs%debug_bt.and.cs%use_wide_halos), debuggingparam=.true.)
5899
5900 call get_param(param_file, mdl, "LINEARIZED_BT_CORIOLIS", cs%linearized_BT_PV, &
5901 "If true use the bottom depth instead of the total water column thickness "//&
5902 "in the barotropic Coriolis term calculations.", default=.true.)
5903 call get_param(param_file, mdl, "BEBT", cs%bebt, &
5904 "BEBT determines whether the barotropic time stepping "//&
5905 "uses the forward-backward time-stepping scheme or a "//&
5906 "backward Euler scheme. BEBT is valid in the range from "//&
5907 "0 (for a forward-backward treatment of nonrotating "//&
5908 "gravity waves) to 1 (for a backward Euler treatment). "//&
5909 "In practice, BEBT must be greater than about 0.05.", &
5910 units="nondim", default=0.1)
5911 ! Note that dtbt_input is not rescaled because it has different units for
5912 ! positive [s] and negative [nondim] values.
5913 call get_param(param_file, mdl, "DTBT", dtbt_input, &
5914 "The barotropic time step, in s. DTBT is only used with "//&
5915 "the split explicit time stepping. To set the time step "//&
5916 "automatically based the maximum stable value use 0, or "//&
5917 "a negative value gives the fraction of the stable value. "//&
5918 "Setting DTBT to 0 is the same as setting it to -0.98. "//&
5919 "The value of DTBT that will actually be used is an "//&
5920 "integer fraction of DT, rounding down.", &
5921 units="s or nondim", default=-0.98)
5922 call get_param(param_file, mdl, "DTBT_RESTART_BUG", dtbt_restart_bug, &
5923 "If true, recover a bug where the barotropic timestep DTBT read from a restart "//&
5924 "file is immediately overridden by a recalculation on the first dynamics step.", &
5925 default=enable_bugs, do_not_log=(dtbt_input>0.0))
5926 call get_param(param_file, mdl, "BT_USE_OLD_CORIOLIS_BRACKET_BUG", cs%use_old_coriolis_bracket_bug, &
5927 "If True, use an order of operations that is not bitwise "//&
5928 "rotationally symmetric in the meridional Coriolis term of "//&
5929 "the barotropic solver.", default=.false.)
5930 call get_param(param_file, mdl, "MASK_COASTAL_PRESSURE_FORCE", mask_coastal_pressure_force, &
5931 "If true, use the land masks to zero out the diagnosed barotropic pressure "//&
5932 "gradient accelerations at coastal or land points. This changes diagnostics "//&
5933 "and improves the reproducibility of certain debugging checksums, but it "//&
5934 "does not alter the solutions themselves.", default=.false.)
5935 !### Change the default for MASK_COASTAL_PRESSURE_FORCE to true?
5936
5937 ! Initialize a version of the MOM domain that is specific to the barotropic solver.
5938 call clone_mom_domain(g%Domain, cs%BT_Domain, min_halo=wd_halos, symmetric=.true.)
5939#ifdef STATIC_MEMORY_
5940 if (wd_halos(1) /= whaloi_+nihalo_) call mom_error(fatal, "barotropic_init: "//&
5941 "Barotropic x-halo sizes are incorrectly resized with STATIC_MEMORY_.")
5942 if (wd_halos(2) /= whaloj_+njhalo_) call mom_error(fatal, "barotropic_init: "//&
5943 "Barotropic y-halo sizes are incorrectly resized with STATIC_MEMORY_.")
5944#else
5945 if (bt_halo_sz > 0) then
5946 if (wd_halos(1) > bt_halo_sz) &
5947 call mom_mesg("barotropic_init: barotropic x-halo size increased.", 3)
5948 if (wd_halos(2) > bt_halo_sz) &
5949 call mom_mesg("barotropic_init: barotropic y-halo size increased.", 3)
5950 endif
5951#endif
5952 call log_param(param_file, mdl, "!BT x-halo", wd_halos(1), &
5953 "The barotropic x-halo size that is actually used.", &
5954 layoutparam=.true.)
5955 call log_param(param_file, mdl, "!BT y-halo", wd_halos(2), &
5956 "The barotropic y-halo size that is actually used.", &
5957 layoutparam=.true.)
5958
5959 cs%isdw = g%isc-wd_halos(1) ; cs%iedw = g%iec+wd_halos(1)
5960 cs%jsdw = g%jsc-wd_halos(2) ; cs%jedw = g%jec+wd_halos(2)
5961 isdw = cs%isdw ; iedw = cs%iedw ; jsdw = cs%jsdw ; jedw = cs%jedw
5962
5963 alloc_(cs%frhatu(isdb:iedb,jsd:jed,nz)) ; alloc_(cs%frhatv(isd:ied,jsdb:jedb,nz))
5964 alloc_(cs%eta_cor(isd:ied,jsd:jed))
5965 if (cs%bound_BT_corr) &
5966 allocate(cs%eta_cor_bound(isd:ied,jsd:jed), source=0.0)
5967 alloc_(cs%IDatu(isdb:iedb,jsd:jed)) ; alloc_(cs%IDatv(isd:ied,jsdb:jedb))
5968
5969 alloc_(cs%ua_polarity(isdw:iedw,jsdw:jedw))
5970 alloc_(cs%va_polarity(isdw:iedw,jsdw:jedw))
5971
5972 cs%frhatu(:,:,:) = 0.0 ; cs%frhatv(:,:,:) = 0.0
5973 cs%eta_cor(:,:) = 0.0
5974 cs%IDatu(:,:) = 0.0 ; cs%IDatv(:,:) = 0.0
5975
5976 cs%ua_polarity(:,:) = 1.0 ; cs%va_polarity(:,:) = 1.0
5977 call create_group_pass(pass_a_polarity, cs%ua_polarity, cs%va_polarity, cs%BT_domain, to_all, agrid)
5978 call do_group_pass(pass_a_polarity, cs%BT_domain)
5979
5980 if (use_bt_cont_type) &
5981 call alloc_bt_cont_type(bt_cont, g, gv, (cs%hvel_scheme == from_bt_cont))
5982
5983 if (cs%debug) then ! Make a local copy of loop ranges for chksum calls
5984 allocate(cs%debug_BT_HI)
5985 cs%debug_BT_HI%isc = g%isc
5986 cs%debug_BT_HI%iec = g%iec
5987 cs%debug_BT_HI%jsc = g%jsc
5988 cs%debug_BT_HI%jec = g%jec
5989 cs%debug_BT_HI%IscB = g%isc-1
5990 cs%debug_BT_HI%IecB = g%iec
5991 cs%debug_BT_HI%JscB = g%jsc-1
5992 cs%debug_BT_HI%JecB = g%jec
5993 cs%debug_BT_HI%isd = cs%isdw
5994 cs%debug_BT_HI%ied = cs%iedw
5995 cs%debug_BT_HI%jsd = cs%jsdw
5996 cs%debug_BT_HI%jed = cs%jedw
5997 cs%debug_BT_HI%IsdB = cs%isdw-1
5998 cs%debug_BT_HI%IedB = cs%iedw
5999 cs%debug_BT_HI%JsdB = cs%jsdw-1
6000 cs%debug_BT_HI%JedB = cs%jedw
6001 cs%debug_BT_HI%turns = g%HI%turns
6002 endif
6003
6004 ! IareaT, IdxCu, and IdyCv need to be allocated with wide halos.
6005 alloc_(cs%IareaT(cs%isdw:cs%iedw,cs%jsdw:cs%jedw)) ; cs%IareaT(:,:) = 0.0
6006 alloc_(cs%bathyT(cs%isdw:cs%iedw,cs%jsdw:cs%jedw)) ; cs%bathyT(:,:) = 0.0
6007 alloc_(cs%IdxCu(cs%isdw-1:cs%iedw,cs%jsdw:cs%jedw)) ; cs%IdxCu(:,:) = 0.0
6008 alloc_(cs%IdyCv(cs%isdw:cs%iedw,cs%jsdw-1:cs%jedw)) ; cs%IdyCv(:,:) = 0.0
6009 alloc_(cs%dy_Cu(cs%isdw-1:cs%iedw,cs%jsdw:cs%jedw)) ; cs%dy_Cu(:,:) = 0.0
6010 alloc_(cs%dx_Cv(cs%isdw:cs%iedw,cs%jsdw-1:cs%jedw)) ; cs%dx_Cv(:,:) = 0.0
6011 allocate(cs%IareaT_OBCmask(isdw:iedw,jsdw:jedw), source=0.0)
6012 alloc_(cs%OBCmask_u(cs%isdw-1:cs%iedw,cs%jsdw:cs%jedw)) ; cs%OBCmask_u(:,:) = 0.0
6013 alloc_(cs%OBCmask_v(cs%isdw:cs%iedw,cs%jsdw-1:cs%jedw)) ; cs%OBCmask_v(:,:) = 0.0
6014 do j=g%jsd,g%jed ; do i=g%isd,g%ied
6015 cs%IareaT(i,j) = g%IareaT(i,j)
6016 cs%bathyT(i,j) = g%bathyT(i,j)
6017 cs%IareaT_OBCmask(i,j) = cs%IareaT(i,j)
6018 enddo ; enddo
6019
6020 ! Note: G%IdxCu & G%IdyCv may be valid for a smaller extent than CS%IdxCu & CS%IdyCv, even without
6021 ! wide halos.
6022 do j=g%jsd,g%jed ; do i=g%IsdB,g%IedB
6023 cs%IdxCu(i,j) = g%IdxCu(i,j) ; cs%dy_Cu(i,j) = g%dy_Cu(i,j)
6024 cs%OBCmask_u(i,j) = g%OBCmaskCu(i,j)
6025 enddo ; enddo
6026 do j=g%JsdB,g%JedB ; do i=g%isd,g%ied
6027 cs%IdyCv(i,j) = g%IdyCv(i,j) ; cs%dx_Cv(i,j) = g%dx_Cv(i,j)
6028 cs%OBCmask_v(i,j) = g%OBCmaskCv(i,j)
6029 enddo ; enddo
6030
6031 ! This sets pressure force diagnostics on land, at coastlines and at OBC points to zero.
6032 if (mask_coastal_pressure_force) then
6033 do j=g%jsd,g%jed ; do i=g%IsdB,g%IedB
6034 cs%IdxCu(i,j) = g%IdxCu_OBCmask(i,j)
6035 enddo ; enddo
6036 do j=g%JsdB,g%JedB ; do i=g%isd,g%ied
6037 cs%IdyCv(i,j) = g%IdyCv_OBCmask(i,j)
6038 enddo ; enddo
6039 endif
6040
6041 if (associated(obc)) then
6042 ! Set up information about the location and nature of the open boundary condition points.
6043 call initialize_bt_obc(obc, cs%BT_OBC, g, cs)
6044
6045 ! Update IareaT_OBCmask so that nothing changes outside of the OBC (problem for interior OBCs only)
6046 if (.not.cs%exterior_OBC_bug) then
6047 if (cs%BT_OBC%u_OBCs_on_PE) then
6048 do j=jsd,jed ; do i=isd,ied
6049 if (cs%BT_OBC%u_OBC_type(i-1,j) > 0) cs%IareaT_OBCmask(i,j) = 0.0 ! OBC_DIRECTION_E
6050 if (cs%BT_OBC%u_OBC_type(i,j) < 0) cs%IareaT_OBCmask(i,j) = 0.0 ! OBC_DIRECTION_W
6051 enddo ; enddo
6052 endif
6053 if (cs%BT_OBC%v_OBCs_on_PE) then
6054 do j=jsd,jed ; do i=isd,ied
6055 if (cs%BT_OBC%v_OBC_type(i,j-1) > 0) cs%IareaT_OBCmask(i,j) = 0.0 ! OBC_DIRECTION_N
6056 if (cs%BT_OBC%v_OBC_type(i,j) < 0) cs%IareaT_OBCmask(i,j) = 0.0 ! OBC_DIRECTION_S
6057 enddo ; enddo
6058 endif
6059 endif
6060
6061 ! Set masks to avoid changing velocities at OBC points.
6062 if (cs%BT_OBC%u_OBCs_on_PE) then
6063 do j=g%jsd,g%jed ; do i=g%IsdB,g%IedB ; if (cs%BT_OBC%u_OBC_type(i,j) /= 0) then
6064 cs%OBCmask_u(i,j) = 0.0 ; cs%IdxCu(i,j) = 0.0
6065 endif ; enddo ; enddo
6066 endif
6067 if (cs%BT_OBC%v_OBCs_on_PE) then
6068 do j=g%JsdB,g%JedB ; do i=g%isd,g%ied ; if (cs%BT_OBC%v_OBC_type(i,j) /= 0) then
6069 cs%OBCmask_v(i,j) = 0.0 ; cs%IdyCv(i,j) = 0.0
6070 endif ; enddo ; enddo
6071 endif
6072
6073 cs%integral_OBCs = cs%integral_BT_cont .and. open_boundary_query(obc, apply_open_obc=.true.)
6074 else ! There are no OBC points anywhere.
6075 cs%BT_OBC%u_OBCs_on_PE = .false.
6076 cs%BT_OBC%v_OBCs_on_PE = .false.
6077 cs%integral_OBCs = .false.
6078 endif
6079
6080 call create_group_pass(pass_static_data, cs%IareaT, cs%BT_domain, to_all)
6081 call create_group_pass(pass_static_data, cs%bathyT, cs%BT_domain, to_all)
6082 call create_group_pass(pass_static_data, cs%IareaT_OBCmask, cs%BT_domain, to_all)
6083 call create_group_pass(pass_static_data, cs%IdxCu, cs%IdyCv, cs%BT_domain, to_all+scalar_pair)
6084 call create_group_pass(pass_static_data, cs%dy_Cu, cs%dx_Cv, cs%BT_domain, to_all+scalar_pair)
6085 call create_group_pass(pass_static_data, cs%OBCmask_u, cs%OBCmask_v, cs%BT_domain, to_all+scalar_pair)
6086 call do_group_pass(pass_static_data, cs%BT_domain)
6087
6088 ! Determine the weights to use for the thicknesses when calculating PV for use in the Coriolis terms
6089 allocate(cs%q_wt(4,cs%isdw-1:cs%iedw,cs%jsdw-1:cs%jedw), source=0.0)
6090 do j=js-1,je ; do i=is-1,ie
6091 if (g%mask2dT(i,j) + g%mask2dT(i,j+1) + g%mask2dT(i+1,j) + g%mask2dT(i+1,j+1) > 0.) then
6092 cs%q_wt(1,i,j) = g%areaT(i,j) ; cs%q_wt(2,i,j) = g%areaT(i+1,j)
6093 cs%q_wt(3,i,j) = g%areaT(i,j+1) ; cs%q_wt(4,i,j) = g%areaT(i+1,j+1)
6094 else
6095 cs%q_wt(1:4,i,j) = 0.0
6096 endif
6097 enddo ; enddo
6098
6099 if (cs%interior_OBC_PV .and. (cs%BT_OBC%u_OBCs_on_PE .or. cs%BT_OBC%v_OBCs_on_PE)) then
6100 ! Reset the potential vorticity at OBC vertices as a masked weighted average.
6101 do j=js-1,je ; do i=is-1,ie
6102 if ((g%mask2dT(i,j) + g%mask2dT(i,j+1) + g%mask2dT(i+1,j) + g%mask2dT(i+1,j+1) > 0.) .and. &
6103 ((abs(cs%BT_OBC%u_OBC_type(i,j)) > 0) .or. (abs(cs%BT_OBC%u_OBC_type(i,j+1)) > 0) .or. &
6104 (abs(cs%BT_OBC%v_OBC_type(i,j)) > 0) .or. (abs(cs%BT_OBC%v_OBC_type(i+1,j)) > 0)) ) then
6105 ! This is an OBC vertex, so use an area weighted masked average and avoid external values.
6106 cs%q_wt(1,i,j) = g%mask2dT(i,j) * g%areaT(i,j)
6107 cs%q_wt(2,i,j) = g%mask2dT(i+1,j) * g%areaT(i+1,j)
6108 cs%q_wt(3,i,j) = g%mask2dT(i,j+1) * g%areaT(i,j+1)
6109 cs%q_wt(4,i,j) = g%mask2dT(i+1,j+1) * g%areaT(i+1,j+1)
6110
6111 ! The following block is the equivalent of shifting weights inward across OBC points. With
6112 ! two OBCs in a line, it gives weights of about 1/2 and 1/2 to the interior points. At a
6113 ! peninsula-like corner between two OBCs it gives weights of about 3/8, 1/4 and 3/8 for the
6114 ! 3 interior points. At a bay-liek corner there is only one interior point with a weight of 1.
6115 ! The masking above zeros out the weights for exterior points.
6116 if (cs%BT_OBC%u_OBC_type(i,j) > 0) then ! Eastern OBC in the u-point to the south
6117 cs%q_wt(1,i,j) = cs%q_wt(1,i,j) + 0.5*g%mask2dT(i,j)*g%areaT(i,j) ! already CS%q_wt(2,I,J) = 0.0
6118 elseif (cs%BT_OBC%u_OBC_type(i,j) < 0) then ! Western OBC in the u-point to the south
6119 cs%q_wt(2,i,j) = cs%q_wt(2,i,j) + 0.5*g%mask2dT(i+1,j)*g%areaT(i+1,j) ! already CS%q_wt(1,I,J) = 0.0
6120 endif
6121 if (cs%BT_OBC%u_OBC_type(i,j+1) > 0) then ! Eastern OBC in the u-point to the north
6122 cs%q_wt(3,i,j) = cs%q_wt(3,i,j) + 0.5*g%mask2dT(i,j+1)*g%areaT(i,j+1) ! already CS%q_wt(4,I,J) = 0.0
6123 elseif (cs%BT_OBC%u_OBC_type(i,j+1) < 0) then ! Western OBC in the u-point to the north
6124 cs%q_wt(4,i,j) = cs%q_wt(4,i,j) + 0.5*g%mask2dT(i+1,j+1)*g%areaT(i+1,j+1) ! already CS%q_wt(3,I,J) = 0.0
6125 endif
6126 if (cs%BT_OBC%v_OBC_type(i,j) > 0) then ! Northern OBC in the v-point to the west
6127 cs%q_wt(1,i,j) = cs%q_wt(1,i,j) + 0.5*g%mask2dT(i,j)*g%areaT(i,j) ! already CS%q_wt(3,I,J) = 0.0
6128 elseif (cs%BT_OBC%v_OBC_type(i,j) < 0) then ! Southern OBC in the v-point to the west
6129 cs%q_wt(3,i,j) = cs%q_wt(3,i,j) + 0.5*g%mask2dT(i,j+1)*g%areaT(i,j+1) ! already CS%q_wt(1,I,J) = 0.0
6130 endif
6131 if (cs%BT_OBC%v_OBC_type(i+1,j) > 0) then ! Northern OBC in the v-point to the west
6132 cs%q_wt(2,i,j) = cs%q_wt(2,i,j) + 0.5*g%mask2dT(i+1,j)*g%areaT(i+1,j) ! already CS%q_wt(4,I,J) = 0.0
6133 elseif (cs%BT_OBC%v_OBC_type(i+1,j) < 0) then ! Southern OBC in the v-point to the west
6134 cs%q_wt(4,i,j) = cs%q_wt(4,i,j) + 0.5*g%mask2dT(i+1,j+1)*g%areaT(i+1,j+1) ! already CS%q_wt(2,I,J) = 0.0
6135 endif
6136 endif
6137 enddo ; enddo
6138 endif
6139
6140 if (cs%linearized_BT_PV) then
6141 allocate(cs%q_D(cs%isdw-1:cs%iedw,cs%jsdw-1:cs%jedw), source=0.0)
6142 allocate(cs%D_u_Cor(cs%isdw-1:cs%iedw,cs%jsdw:cs%jedw), source=0.0)
6143 allocate(cs%D_v_Cor(cs%isdw:cs%iedw,cs%jsdw-1:cs%jedw), source=0.0)
6144
6145 z_to_h = gv%Z_to_H ; if (.not.gv%Boussinesq) z_to_h = gv%RZ_to_H * cs%Rho_BT_lin
6146
6147 do j=js,je ; do i=is-1,ie
6148 cs%D_u_Cor(i,j) = 0.5 * ( max(g%meanSL(i+1,j) + g%bathyT(i+1,j), 0.0) &
6149 + max(g%meanSL(i,j) + g%bathyT(i,j), 0.0) ) * z_to_h
6150 enddo ; enddo
6151 if (cs%interior_OBC_PV .and. cs%BT_OBC%u_OBCs_on_PE) then ; do j=js,je ; do i=is-1,ie
6152 if (cs%BT_OBC%u_OBC_type(i,j) < 0) & ! Western boundary condition
6153 cs%D_u_Cor(i,j) = max(g%meanSL(i+1,j) + g%bathyT(i+1,j), 0.0) * z_to_h
6154 if (cs%BT_OBC%u_OBC_type(i,j) > 0) & ! Eastern boundary condition
6155 cs%D_u_Cor(i,j) = max(g%meanSL(i,j) + g%bathyT(i,j), 0.0) * z_to_h
6156 enddo ; enddo ; endif
6157
6158 do j=js-1,je ; do i=is,ie
6159 cs%D_v_Cor(i,j) = 0.5 * ( max(g%meanSL(i,j+1) + g%bathyT(i,j+1), 0.0) &
6160 + max(g%meanSL(i,j) + g%bathyT(i,j), 0.0) ) * z_to_h
6161 enddo ; enddo
6162 if (cs%interior_OBC_PV .and. cs%BT_OBC%v_OBCs_on_PE) then ; do j=js-1,je ; do i=is,ie
6163 if (cs%BT_OBC%v_OBC_type(i,j) < 0) & ! Southern boundary condition
6164 cs%D_v_Cor(i,j) = max(g%meanSL(i,j+1) + g%bathyT(i,j+1), 0.0) * z_to_h
6165 if (cs%BT_OBC%v_OBC_type(i,j) > 0) & ! Northern boundary condition
6166 cs%D_v_Cor(i,j) = max(g%meanSL(i,j) + g%bathyT(i,j), 0.0) * z_to_h
6167 enddo ; enddo ; endif
6168
6169 h_a_neglect = gv%H_subroundoff * 1.0 * us%m_to_L**2
6170 do j=js-1,je ; do i=is-1,ie
6171 if ((cs%q_wt(1,i,j) + cs%q_wt(4,i,j)) + (cs%q_wt(2,i,j) + cs%q_wt(3,i,j)) > 0.) then
6172 cs%q_D(i,j) = 0.25 * (cs%BT_Coriolis_scale * g%CoriolisBu(i,j)) * &
6173 ((cs%q_wt(1,i,j) + cs%q_wt(4,i,j)) + (cs%q_wt(2,i,j) + cs%q_wt(3,i,j))) / &
6174 max(z_to_h * (((cs%q_wt(1,i,j) * max(g%meanSL(i,j) + g%bathyT(i,j), 0.0)) + &
6175 (cs%q_wt(4,i,j) * max(g%meanSL(i+1,j+1) + g%bathyT(i+1,j+1), 0.0))) + &
6176 ((cs%q_wt(2,i,j) * max(g%meanSL(i+1,j) + g%bathyT(i+1,j), 0.0)) + &
6177 (cs%q_wt(3,i,j) * max(g%meanSL(i,j+1) + g%bathyT(i,j+1), 0.0)))), &
6178 h_a_neglect)
6179 else ! All four h points are masked out so q_D(I,J) is meaningless
6180 cs%q_D(i,j) = 0.
6181 endif
6182 enddo ; enddo
6183
6184 ! With very wide halos, q and D need to be calculated on the available data
6185 ! domain and then updated onto the full computational domain.
6186 call create_group_pass(pass_q_d_cor, cs%q_D, cs%BT_Domain, to_all, position=corner)
6187 call create_group_pass(pass_q_d_cor, cs%D_u_Cor, cs%D_v_Cor, cs%BT_Domain, &
6188 to_all+scalar_pair)
6189 call do_group_pass(pass_q_d_cor, cs%BT_Domain)
6190 endif
6191
6192 if (cs%linear_wave_drag) then
6193 allocate(cs%lin_drag_u(isdb:iedb,jsd:jed), source=0.0)
6194 allocate(cs%lin_drag_v(isd:ied,jsdb:jedb), source=0.0)
6195
6196 if (len_trim(wave_drag_file) > 0) then
6197 inputdir = "." ; call get_param(param_file, mdl, "INPUTDIR", inputdir)
6198 wave_drag_file = trim(slasher(inputdir))//trim(wave_drag_file)
6199 call log_param(param_file, mdl, "INPUTDIR/BT_WAVE_DRAG_FILE", wave_drag_file)
6200
6201 if (len_trim(wave_drag_u) > 0 .and. len_trim(wave_drag_v) > 0) then
6202 call mom_read_data(wave_drag_file, wave_drag_u, cs%lin_drag_u, g%Domain, &
6203 position=east_face, scale=wave_drag_scale*gv%m_to_H*us%T_to_s)
6204 call mom_read_data(wave_drag_file, wave_drag_v, cs%lin_drag_v, g%Domain, &
6205 position=north_face, scale=wave_drag_scale*gv%m_to_H*us%T_to_s)
6206 call pass_vector(cs%lin_drag_u, cs%lin_drag_v, g%domain, direction=to_all+scalar_pair)
6207 else
6208 allocate(lin_drag_h(isd:ied,jsd:jed), source=0.0)
6209
6210 call mom_read_data(wave_drag_file, wave_drag_var, lin_drag_h, g%Domain, scale=gv%m_to_H*us%T_to_s)
6211 call pass_var(lin_drag_h, g%Domain)
6212 do j=js,je ; do i=is-1,ie
6213 cs%lin_drag_u(i,j) = wave_drag_scale * 0.5 * (lin_drag_h(i,j) + lin_drag_h(i+1,j))
6214 enddo ; enddo
6215 do j=js-1,je ; do i=is,ie
6216 cs%lin_drag_v(i,j) = wave_drag_scale * 0.5 * (lin_drag_h(i,j) + lin_drag_h(i,j+1))
6217 enddo ; enddo
6218 deallocate(lin_drag_h)
6219 endif ! len_trim(wave_drag_u) > 0 .and. len_trim(wave_drag_v) > 0
6220 endif ! len_trim(wave_drag_file) > 0
6221 endif ! CS%linear_wave_drag
6222
6223 ! Initialize streaming band-pass filters and frequency-dependent drag
6224 if (cs%use_filter) then
6225 call filt_init(param_file, us, cs%Filt_CS_u, restart_cs)
6226 call filt_init(param_file, us, cs%Filt_CS_v, restart_cs)
6227 endif
6228
6229 if (cs%use_filter .and. cs%linear_freq_drag) then
6230 if (.not.cs%linear_wave_drag .and. len_trim(wave_drag_file) > 0) then
6231 inputdir = "." ; call get_param(param_file, mdl, "INPUTDIR", inputdir)
6232 wave_drag_file = trim(slasher(inputdir))//trim(wave_drag_file)
6233 call log_param(param_file, mdl, "INPUTDIR/BT_WAVE_DRAG_FILE", wave_drag_file)
6234 endif
6235 call wave_drag_init(param_file, wave_drag_file, g, gv, us, cs%Drag_CS)
6236 endif
6237
6238 cs%dtbt_fraction = 0.98 ; if (dtbt_input < 0.0) cs%dtbt_fraction = -dtbt_input
6239
6240 dtbt_restart = -1.0
6241 if (query_initialized(cs%dtbt, "DTBT", restart_cs)) then
6242 dtbt_restart = cs%dtbt
6243 endif
6244
6245 ! Estimate the maximum stable barotropic time step.
6246 gtot_estimate = 0.0
6247 if (gv%Boussinesq) then
6248 do k=1,gv%ke ; gtot_estimate = gtot_estimate + gv%H_to_Z*gv%g_prime(k) ; enddo
6249 else
6250 h_to_z = gv%H_to_RZ / cs%Rho_BT_lin
6251 do k=1,gv%ke ; gtot_estimate = gtot_estimate + h_to_z*gv%g_prime(k) ; enddo
6252 endif
6253
6254 ! CS%dtbt calculated here by set_dtbt is only used when dtbt is not reset during the run, i.e. DTBT_RESET_PERIOD<0.
6255 call set_dtbt(g, gv, us, cs, gtot_est=gtot_estimate, ssh_add=ssh_extra, time=time)
6256
6257 if (dtbt_input > 0.0) then
6258 cs%dtbt = us%s_to_T * dtbt_input
6259 elseif (dtbt_restart > 0.0) then
6260 cs%dtbt = dtbt_restart
6261 endif
6262
6263 calc_dtbt = ((dtbt_restart <= 0.0) .or. (dtbt_restart_bug .and. (dtbt_input <= 0.0)))
6264
6265 call log_param(param_file, mdl, "DTBT as used", cs%dtbt, units="s", unscale=us%T_to_s)
6266 call log_param(param_file, mdl, "estimated maximum DTBT", cs%dtbt_max, units="s", unscale=us%T_to_s)
6267
6268 ! ubtav and vbtav, and perhaps ubt_IC and vbt_IC, are allocated and
6269 ! initialized in register_barotropic_restarts.
6270
6271 if (gv%Boussinesq) then
6272 thickness_units = "m" ; flux_units = "m3 s-1"
6273 else
6274 thickness_units = "kg m-2" ; flux_units = "kg s-1"
6275 endif
6276
6277 cs%id_PFu_bt = register_diag_field('ocean_model', 'PFuBT', diag%axesCu1, time, &
6278 'Zonal Anomalous Barotropic Pressure Force Acceleration', 'm s-2', conversion=us%L_T2_to_m_s2)
6279 cs%id_PFv_bt = register_diag_field('ocean_model', 'PFvBT', diag%axesCv1, time, &
6280 'Meridional Anomalous Barotropic Pressure Force Acceleration', 'm s-2', conversion=us%L_T2_to_m_s2)
6281 cs%id_etaPF_anom = register_diag_field('ocean_model', 'etaPF_anom', diag%axesT1, time, &
6282 'Eta anomalies used for pressure forces averaged over a baroclinic timestep', &
6283 thickness_units, conversion=gv%H_to_MKS)
6284 if (cs%linear_wave_drag .or. (cs%use_filter .and. cs%linear_freq_drag)) then
6285 cs%id_LDu_bt = register_diag_field('ocean_model', 'WaveDraguBT', diag%axesCu1, time, &
6286 'Zonal Barotropic Linear Wave Drag Acceleration', 'm s-2', conversion=us%L_T2_to_m_s2)
6287 cs%id_LDv_bt = register_diag_field('ocean_model', 'WaveDragvBT', diag%axesCv1, time, &
6288 'Meridional Barotropic Linear Wave Drag Acceleration', 'm s-2', conversion=us%L_T2_to_m_s2)
6289 endif
6290 cs%id_Coru_bt = register_diag_field('ocean_model', 'CoruBT', diag%axesCu1, time, &
6291 'Zonal Barotropic Coriolis Acceleration', 'm s-2', conversion=us%L_T2_to_m_s2)
6292 cs%id_Corv_bt = register_diag_field('ocean_model', 'CorvBT', diag%axesCv1, time, &
6293 'Meridional Barotropic Coriolis Acceleration', 'm s-2', conversion=us%L_T2_to_m_s2)
6294 cs%id_uaccel = register_diag_field('ocean_model', 'u_accel_bt', diag%axesCu1, time, &
6295 'Barotropic zonal acceleration', 'm s-2', conversion=us%L_T2_to_m_s2)
6296 cs%id_vaccel = register_diag_field('ocean_model', 'v_accel_bt', diag%axesCv1, time, &
6297 'Barotropic meridional acceleration', 'm s-2', conversion=us%L_T2_to_m_s2)
6298 cs%id_ubtforce = register_diag_field('ocean_model', 'ubtforce', diag%axesCu1, time, &
6299 'Barotropic zonal acceleration from baroclinic terms', 'm s-2', conversion=us%L_T2_to_m_s2)
6300 cs%id_vbtforce = register_diag_field('ocean_model', 'vbtforce', diag%axesCv1, time, &
6301 'Barotropic meridional acceleration from baroclinic terms', 'm s-2', conversion=us%L_T2_to_m_s2)
6302 cs%id_ubtdt = register_diag_field('ocean_model', 'ubt_dt', diag%axesCu1, time, &
6303 'Barotropic zonal acceleration', 'm s-2', conversion=us%L_T2_to_m_s2)
6304 cs%id_vbtdt = register_diag_field('ocean_model', 'vbt_dt', diag%axesCv1, time, &
6305 'Barotropic meridional acceleration', 'm s-2', conversion=us%L_T2_to_m_s2)
6306
6307 cs%id_eta_bt = register_diag_field('ocean_model', 'eta_bt', diag%axesT1, time, &
6308 'Barotropic end SSH', thickness_units, conversion=gv%H_to_MKS)
6309 cs%id_ubt = register_diag_field('ocean_model', 'ubt', diag%axesCu1, time, &
6310 'Barotropic end zonal velocity', 'm s-1', conversion=us%L_T_to_m_s)
6311 cs%id_vbt = register_diag_field('ocean_model', 'vbt', diag%axesCv1, time, &
6312 'Barotropic end meridional velocity', 'm s-1', conversion=us%L_T_to_m_s)
6313 cs%id_eta_st = register_diag_field('ocean_model', 'eta_st', diag%axesT1, time, &
6314 'Barotropic start SSH', thickness_units, conversion=gv%H_to_MKS)
6315 cs%id_ubt_st = register_diag_field('ocean_model', 'ubt_st', diag%axesCu1, time, &
6316 'Barotropic start zonal velocity', 'm s-1', conversion=us%L_T_to_m_s)
6317 cs%id_vbt_st = register_diag_field('ocean_model', 'vbt_st', diag%axesCv1, time, &
6318 'Barotropic start meridional velocity', 'm s-1', conversion=us%L_T_to_m_s)
6319 cs%id_ubtav = register_diag_field('ocean_model', 'ubtav', diag%axesCu1, time, &
6320 'Barotropic time-average zonal velocity', 'm s-1', conversion=us%L_T_to_m_s)
6321 cs%id_vbtav = register_diag_field('ocean_model', 'vbtav', diag%axesCv1, time, &
6322 'Barotropic time-average meridional velocity', 'm s-1', conversion=us%L_T_to_m_s)
6323 cs%id_eta_cor = register_diag_field('ocean_model', 'eta_cor', diag%axesT1, time, &
6324 'Corrective mass or volume flux within a timestep', thickness_units, conversion=gv%H_to_MKS)
6325 cs%id_visc_rem_u = register_diag_field('ocean_model', 'visc_rem_u', diag%axesCuL, time, &
6326 'Viscous remnant at u', 'nondim')
6327 cs%id_visc_rem_v = register_diag_field('ocean_model', 'visc_rem_v', diag%axesCvL, time, &
6328 'Viscous remnant at v', 'nondim')
6329 cs%id_bt_rem_u = register_diag_field('ocean_model', 'bt_rem_u', diag%axesCu1, time, &
6330 'Barotropic viscous remnant per barotropic step at u', 'nondim')
6331 cs%id_bt_rem_v = register_diag_field('ocean_model', 'bt_rem_v', diag%axesCv1, time, &
6332 'Barotropic viscous remnant per barotropic step at v', 'nondim')
6333 cs%id_gtotn = register_diag_field('ocean_model', 'gtot_n', diag%axesT1, time, &
6334 'gtot to North', 'm s-2', conversion=gv%m_to_H*(us%L_T_to_m_s**2))
6335 cs%id_gtots = register_diag_field('ocean_model', 'gtot_s', diag%axesT1, time, &
6336 'gtot to South', 'm s-2', conversion=gv%m_to_H*(us%L_T_to_m_s**2))
6337 cs%id_gtote = register_diag_field('ocean_model', 'gtot_e', diag%axesT1, time, &
6338 'gtot to East', 'm s-2', conversion=gv%m_to_H*(us%L_T_to_m_s**2))
6339 cs%id_gtotw = register_diag_field('ocean_model', 'gtot_w', diag%axesT1, time, &
6340 'gtot to West', 'm s-2', conversion=gv%m_to_H*(us%L_T_to_m_s**2))
6341 cs%id_eta_hifreq = register_diag_field('ocean_model', 'eta_hifreq', diag%axesT1, time, &
6342 'High Frequency Barotropic SSH', thickness_units, conversion=gv%H_to_MKS)
6343 cs%id_ubt_hifreq = register_diag_field('ocean_model', 'ubt_hifreq', diag%axesCu1, time, &
6344 'High Frequency Barotropic zonal velocity', 'm s-1', conversion=us%L_T_to_m_s)
6345 cs%id_vbt_hifreq = register_diag_field('ocean_model', 'vbt_hifreq', diag%axesCv1, time, &
6346 'High Frequency Barotropic meridional velocity', 'm s-1', conversion=us%L_T_to_m_s)
6347 ! if (.not.CS%BT_project_velocity) & ! The following diagnostic is redundant with BT_project_velocity.
6348 cs%id_eta_pred_hifreq = register_diag_field('ocean_model', 'eta_pred_hifreq', diag%axesT1, time, &
6349 'High Frequency Predictor Barotropic SSH', thickness_units, conversion=gv%H_to_MKS)
6350 cs%id_etaPF_hifreq = register_diag_field('ocean_model', 'etaPF_hifreq', diag%axesT1, time, &
6351 'High Frequency Barotropic SSH anomalies used for pressure forces', thickness_units, conversion=gv%H_to_MKS)
6352 cs%id_uhbt_hifreq = register_diag_field('ocean_model', 'uhbt_hifreq', diag%axesCu1, time, &
6353 'High Frequency Barotropic zonal transport', &
6354 'm3 s-1', conversion=gv%H_to_m*us%L_to_m*us%L_T_to_m_s)
6355 cs%id_vhbt_hifreq = register_diag_field('ocean_model', 'vhbt_hifreq', diag%axesCv1, time, &
6356 'High Frequency Barotropic meridional transport', &
6357 'm3 s-1', conversion=gv%H_to_m*us%L_to_m*us%L_T_to_m_s)
6358 cs%id_frhatu = register_diag_field('ocean_model', 'frhatu', diag%axesCuL, time, &
6359 'Fractional thickness of layers in u-columns', 'nondim')
6360 cs%id_frhatv = register_diag_field('ocean_model', 'frhatv', diag%axesCvL, time, &
6361 'Fractional thickness of layers in v-columns', 'nondim')
6362 cs%id_frhatu1 = register_diag_field('ocean_model', 'frhatu1', diag%axesCuL, time, &
6363 'Predictor Fractional thickness of layers in u-columns', 'nondim')
6364 cs%id_frhatv1 = register_diag_field('ocean_model', 'frhatv1', diag%axesCvL, time, &
6365 'Predictor Fractional thickness of layers in v-columns', 'nondim')
6366 cs%id_uhbt = register_diag_field('ocean_model', 'uhbt', diag%axesCu1, time, &
6367 'Barotropic zonal transport averaged over a baroclinic step', &
6368 'm3 s-1', conversion=gv%H_to_m*us%L_to_m*us%L_T_to_m_s)
6369 cs%id_vhbt = register_diag_field('ocean_model', 'vhbt', diag%axesCv1, time, &
6370 'Barotropic meridional transport averaged over a baroclinic step', &
6371 'm3 s-1', conversion=gv%H_to_m*us%L_to_m*us%L_T_to_m_s)
6372
6373 if (use_bt_cont_type) then
6374 cs%id_BTC_FA_u_EE = register_diag_field('ocean_model', 'BTC_FA_u_EE', diag%axesCu1, time, &
6375 'BTCont type far east face area', 'm2', conversion=us%L_to_m*gv%H_to_m)
6376 cs%id_BTC_FA_u_E0 = register_diag_field('ocean_model', 'BTC_FA_u_E0', diag%axesCu1, time, &
6377 'BTCont type near east face area', 'm2', conversion=us%L_to_m*gv%H_to_m)
6378 cs%id_BTC_FA_u_WW = register_diag_field('ocean_model', 'BTC_FA_u_WW', diag%axesCu1, time, &
6379 'BTCont type far west face area', 'm2', conversion=us%L_to_m*gv%H_to_m)
6380 cs%id_BTC_FA_u_W0 = register_diag_field('ocean_model', 'BTC_FA_u_W0', diag%axesCu1, time, &
6381 'BTCont type near west face area', 'm2', conversion=us%L_to_m*gv%H_to_m)
6382 cs%id_BTC_ubt_EE = register_diag_field('ocean_model', 'BTC_ubt_EE', diag%axesCu1, time, &
6383 'BTCont type far east velocity', 'm s-1', conversion=us%L_T_to_m_s)
6384 cs%id_BTC_ubt_WW = register_diag_field('ocean_model', 'BTC_ubt_WW', diag%axesCu1, time, &
6385 'BTCont type far west velocity', 'm s-1', conversion=us%L_T_to_m_s)
6386 ! This is a specialized diagnostic that is not being made widely available (yet).
6387 ! CS%id_BTC_FA_u_rat0 = register_diag_field('ocean_model', 'BTC_FA_u_rat0', diag%axesCu1, Time, &
6388 ! 'BTCont type ratio of near east and west face areas', 'nondim')
6389 cs%id_BTC_FA_v_NN = register_diag_field('ocean_model', 'BTC_FA_v_NN', diag%axesCv1, time, &
6390 'BTCont type far north face area', 'm2', conversion=us%L_to_m*gv%H_to_m)
6391 cs%id_BTC_FA_v_N0 = register_diag_field('ocean_model', 'BTC_FA_v_N0', diag%axesCv1, time, &
6392 'BTCont type near north face area', 'm2', conversion=us%L_to_m*gv%H_to_m)
6393 cs%id_BTC_FA_v_SS = register_diag_field('ocean_model', 'BTC_FA_v_SS', diag%axesCv1, time, &
6394 'BTCont type far south face area', 'm2', conversion=us%L_to_m*gv%H_to_m)
6395 cs%id_BTC_FA_v_S0 = register_diag_field('ocean_model', 'BTC_FA_v_S0', diag%axesCv1, time, &
6396 'BTCont type near south face area', 'm2', conversion=us%L_to_m*gv%H_to_m)
6397 cs%id_BTC_vbt_NN = register_diag_field('ocean_model', 'BTC_vbt_NN', diag%axesCv1, time, &
6398 'BTCont type far north velocity', 'm s-1', conversion=us%L_T_to_m_s)
6399 cs%id_BTC_vbt_SS = register_diag_field('ocean_model', 'BTC_vbt_SS', diag%axesCv1, time, &
6400 'BTCont type far south velocity', 'm s-1', conversion=us%L_T_to_m_s)
6401 ! This is a specialized diagnostic that is not being made widely available (yet).
6402 ! CS%id_BTC_FA_v_rat0 = register_diag_field('ocean_model', 'BTC_FA_v_rat0', diag%axesCv1, Time, &
6403 ! 'BTCont type ratio of near north and south face areas', 'nondim')
6404 ! CS%id_BTC_FA_h_rat0 = register_diag_field('ocean_model', 'BTC_FA_h_rat0', diag%axesT1, Time, &
6405 ! 'BTCont type maximum ratios of near face areas around cells', 'nondim')
6406 endif
6407 cs%id_uhbt0 = register_diag_field('ocean_model', 'uhbt0', diag%axesCu1, time, &
6408 'Barotropic zonal transport difference', 'm3 s-1', conversion=gv%H_to_m*us%L_to_m**2*us%s_to_T)
6409 cs%id_vhbt0 = register_diag_field('ocean_model', 'vhbt0', diag%axesCv1, time, &
6410 'Barotropic meridional transport difference', 'm3 s-1', conversion=gv%H_to_m*us%L_to_m**2*us%s_to_T)
6411 if (associated(obc)) then
6412 if (obc%Flather_u_BCs_exist_globally .or. obc%Flather_v_BCs_exist_globally) then
6413 cs%id_SSH_u_OBC = register_diag_field('ocean_model', 'SSH_u_OBC', diag%axesCu1, time, &
6414 'Outer sea surface height at u OBC points', 'm', conversion=us%Z_to_m)
6415 cs%id_SSH_v_OBC = register_diag_field('ocean_model', 'SSH_v_OBC', diag%axesCv1, time, &
6416 'Outer sea surface height at v OBC points', 'm', conversion=us%Z_to_m)
6417 cs%id_ubt_OBC = register_diag_field('ocean_model', 'ubt_OBC', diag%axesCu1, time, &
6418 'Outer u velocity at OBC points', 'm', conversion=us%L_T_to_m_s)
6419 cs%id_vbt_OBC = register_diag_field('ocean_model', 'vbt_OBC', diag%axesCv1, time, &
6420 'Outer v velocity at OBC points', 'm', conversion=us%L_T_to_m_s)
6421 endif
6422 endif
6423
6424 if (cs%id_frhatu1 > 0) allocate(cs%frhatu1(isdb:iedb,jsd:jed,nz), source=0.)
6425 if (cs%id_frhatv1 > 0) allocate(cs%frhatv1(isd:ied,jsdb:jedb,nz), source=0.)
6426
6427 if (.NOT.query_initialized(cs%ubtav, "ubtav", restart_cs) .or. &
6428 .NOT.query_initialized(cs%vbtav, "vbtav", restart_cs)) then
6429 call btcalc(h, g, gv, cs, may_use_default=.true.)
6430 cs%ubtav(:,:) = 0.0 ; cs%vbtav(:,:) = 0.0
6431 do k=1,nz ; do j=js,je ; do i=is-1,ie
6432 cs%ubtav(i,j) = cs%ubtav(i,j) + cs%frhatu(i,j,k) * u(i,j,k)
6433 enddo ; enddo ; enddo
6434 do k=1,nz ; do j=js-1,je ; do i=is,ie
6435 cs%vbtav(i,j) = cs%vbtav(i,j) + cs%frhatv(i,j,k) * v(i,j,k)
6436 enddo ; enddo ; enddo
6437 endif
6438
6439 if (cs%gradual_BT_ICs) then
6440 if (.NOT.query_initialized(cs%ubt_IC, "ubt_IC", restart_cs) .or. &
6441 .NOT.query_initialized(cs%vbt_IC, "vbt_IC", restart_cs)) then
6442 do j=js,je ; do i=is-1,ie ; cs%ubt_IC(i,j) = cs%ubtav(i,j) ; enddo ; enddo
6443 do j=js-1,je ; do i=is,ie ; cs%vbt_IC(i,j) = cs%vbtav(i,j) ; enddo ; enddo
6444 endif
6445 endif
6446 ! Calculate other constants which are used for btstep.
6447
6448 if (.not.cs%nonlin_stress) then
6449 z_to_h = gv%Z_to_H ; if (.not.gv%Boussinesq) z_to_h = gv%RZ_to_H * cs%Rho_BT_lin
6450 do j=js,je ; do i=is-1,ie
6451 htot = max(g%meanSL(i+1,j) + g%bathyT(i+1,j), 0.0) + max(g%meanSL(i,j) + g%bathyT(i,j), 0.0)
6452 if (g%OBCmaskCu(i,j) * htot > 0.) then
6453 cs%IDatu(i,j) = g%OBCmaskCu(i,j) * 2.0 / (z_to_h * htot)
6454 else ! Both neighboring H points are masked out or this is an OBC face so IDatu(I,j) is unused
6455 cs%IDatu(i,j) = 0.
6456 endif
6457 enddo ; enddo
6458 do j=js-1,je ; do i=is,ie
6459 htot = max(g%meanSL(i,j+1) + g%bathyT(i,j+1), 0.0) + max(g%meanSL(i,j) + g%bathyT(i,j), 0.0)
6460 if (g%OBCmaskCv(i,j) * htot > 0.) then
6461 cs%IDatv(i,j) = g%OBCmaskCv(i,j) * 2.0 / (z_to_h * htot)
6462 else ! Both neighboring H points are masked out or this is an OBC face so IDatv(i,J) is unused
6463 cs%IDatv(i,j) = 0.
6464 endif
6465 enddo ; enddo
6466 endif
6467
6468 call find_face_areas(datu, datv, g, gv, us, cs, ms, 1)
6469 if ((cs%bound_BT_corr) .and. .not.(use_bt_cont_type .and. cs%BT_cont_bounds)) then
6470 ! This is not used in most test cases. Were it ever to become more widely used, consider
6471 ! replacing maxvel with min(G%dxT(i,j),G%dyT(i,j)) * (CS%maxCFL_BT_cont*Idt) .
6472 do j=js,je ; do i=is,ie
6473 cs%eta_cor_bound(i,j) = g%IareaT(i,j) * 0.1 * cs%maxvel * &
6474 ((datu(i-1,j) + datu(i,j)) + (datv(i,j) + datv(i,j-1)))
6475 enddo ; enddo
6476 endif
6477
6478 if (cs%gradual_BT_ICs) &
6479 call create_group_pass(pass_bt_hbt_btav, cs%ubt_IC, cs%vbt_IC, g%Domain)
6480 call create_group_pass(pass_bt_hbt_btav, cs%ubtav, cs%vbtav, g%Domain)
6481 call do_group_pass(pass_bt_hbt_btav, g%Domain)
6482
6483 ! id_clock_pass = cpu_clock_id('(Ocean BT halo updates)', grain=CLOCK_ROUTINE)
6484 id_clock_calc_pre = cpu_clock_id('(Ocean BT pre-calcs only)', grain=clock_routine)
6485 id_clock_pass_pre = cpu_clock_id('(Ocean BT pre-step halo updates)', grain=clock_routine)
6486 id_clock_calc = cpu_clock_id('(Ocean BT stepping calcs only)', grain=clock_routine)
6487 id_clock_pass_step = cpu_clock_id('(Ocean BT stepping halo updates)', grain=clock_routine)
6488 id_clock_calc_post = cpu_clock_id('(Ocean BT post-calcs only)', grain=clock_routine)
6489 id_clock_pass_post = cpu_clock_id('(Ocean BT post-step halo updates)', grain=clock_routine)
6490 if (dtbt_input <= 0.0) &
6491 id_clock_sync = cpu_clock_id('(Ocean BT global synch)', grain=clock_routine)
6492
6493end subroutine barotropic_init
6494
6495!> Copies ubtav and vbtav from private type into arrays
6496subroutine barotropic_get_tav(CS, ubtav, vbtav, G, US)
6497 type(barotropic_cs), intent(in) :: cs !< Barotropic control structure
6498 type(ocean_grid_type), intent(in) :: g !< Grid structure
6499 real, dimension(SZIB_(G),SZJ_(G)), intent(inout) :: ubtav !< Zonal barotropic velocity averaged
6500 !! over a baroclinic timestep [L T-1 ~> m s-1]
6501 real, dimension(SZI_(G),SZJB_(G)), intent(inout) :: vbtav !< Meridional barotropic velocity averaged
6502 !! over a baroclinic timestep [L T-1 ~> m s-1]
6503 type(unit_scale_type), intent(in) :: us !< A dimensional unit scaling type
6504 ! Local variables
6505 integer :: i, j
6506
6507 do j=g%jsc,g%jec ; do i=g%isc-1,g%iec
6508 ubtav(i,j) = cs%ubtav(i,j)
6509 enddo ; enddo
6510
6511 do j=g%jsc-1,g%jec ; do i=g%isc,g%iec
6512 vbtav(i,j) = cs%vbtav(i,j)
6513 enddo ; enddo
6514
6515end subroutine barotropic_get_tav
6516
6517
6518!> Clean up the barotropic control structure.
6519subroutine barotropic_end(CS)
6520 type(barotropic_cs), intent(inout) :: cs !< Control structure to clear out.
6521
6522 call destroy_bt_obc(cs%BT_OBC)
6523
6524 ! Allocated in barotropic_init, called in timestep initialization
6525 dealloc_(cs%ua_polarity) ; dealloc_(cs%va_polarity)
6526 dealloc_(cs%IDatu) ; dealloc_(cs%IDatv)
6527 if (allocated(cs%eta_cor_bound)) deallocate(cs%eta_cor_bound)
6528 dealloc_(cs%eta_cor)
6529 dealloc_(cs%bathyT) ; dealloc_(cs%IareaT)
6530 dealloc_(cs%frhatu) ; dealloc_(cs%frhatv)
6531 dealloc_(cs%OBCmask_u) ; dealloc_(cs%OBCmask_v)
6532 dealloc_(cs%IdxCu) ; dealloc_(cs%IdyCv)
6533 dealloc_(cs%dy_Cu) ; dealloc_(cs%dx_Cv)
6534
6535 if (allocated(cs%frhatu1)) deallocate(cs%frhatu1)
6536 if (allocated(cs%frhatv1)) deallocate(cs%frhatv1)
6537 if (allocated(cs%IareaT_OBCmask)) deallocate(cs%IareaT_OBCmask)
6538
6539 if (allocated(cs%q_D)) deallocate(cs%q_D)
6540 if (allocated(cs%D_u_Cor)) deallocate(cs%D_u_Cor)
6541 if (allocated(cs%D_v_Cor)) deallocate(cs%D_v_Cor)
6542 if (allocated(cs%ubt_IC)) deallocate(cs%ubt_IC)
6543 if (allocated(cs%vbt_IC)) deallocate(cs%vbt_IC)
6544 if (allocated(cs%lin_drag_u)) deallocate(cs%lin_drag_u)
6545 if (allocated(cs%lin_drag_v)) deallocate(cs%lin_drag_v)
6546
6547 if (associated(cs%debug_BT_HI)) deallocate(cs%debug_BT_HI)
6548 call deallocate_mom_domain(cs%BT_domain)
6549
6550 ! Allocated in restart registration, prior to timestep initialization
6551 dealloc_(cs%ubtav) ; dealloc_(cs%vbtav)
6552end subroutine barotropic_end
6553
6554!> This subroutine is used to register any fields from MOM_barotropic.F90
6555!! that should be written to or read from the restart file.
6556subroutine register_barotropic_restarts(HI, GV, US, param_file, CS, restart_CS)
6557 type(hor_index_type), intent(in) :: hi !< A horizontal index type structure.
6558 type(verticalgrid_type), intent(in) :: gv !< The ocean's vertical grid structure.
6559 type(unit_scale_type), intent(in) :: us !< A dimensional unit scaling type
6560 type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters.
6561 type(barotropic_cs), intent(inout) :: cs !< Barotropic control structure
6562 type(mom_restart_cs), intent(inout) :: restart_cs !< MOM restart control structure
6563
6564 ! Local variables
6565 type(vardesc) :: vd(3)
6566 character(len=40) :: mdl = "MOM_barotropic" ! This module's name.
6567 integer :: n_filters !< Number of streaming band-pass filters to be used in the simulation.
6568 integer :: isd, ied, jsd, jed, isdb, iedb, jsdb, jedb
6569
6570 isd = hi%isd ; ied = hi%ied ; jsd = hi%jsd ; jed = hi%jed
6571 isdb = hi%IsdB ; iedb = hi%IedB ; jsdb = hi%JsdB ; jedb = hi%JedB
6572
6573 call get_param(param_file, mdl, "GRADUAL_BT_ICS", cs%gradual_BT_ICs, &
6574 "If true, adjust the initial conditions for the "//&
6575 "barotropic solver to the values from the layered "//&
6576 "solution over a whole timestep instead of instantly. "//&
6577 "This is a decent approximation to the inclusion of "//&
6578 "sum(u dh_dt) while also correcting for truncation errors.", &
6579 default=.false., do_not_log=.true.)
6580
6581 alloc_(cs%ubtav(isdb:iedb,jsd:jed)) ; cs%ubtav(:,:) = 0.0
6582 alloc_(cs%vbtav(isd:ied,jsdb:jedb)) ; cs%vbtav(:,:) = 0.0
6583 if (cs%gradual_BT_ICs) then
6584 allocate(cs%ubt_IC(isdb:iedb,jsd:jed), source=0.0)
6585 allocate(cs%vbt_IC(isd:ied,jsdb:jedb), source=0.0)
6586 endif
6587
6588 vd(2) = var_desc("ubtav","m s-1","Time mean barotropic zonal velocity", &
6589 hor_grid='u', z_grid='1')
6590 vd(3) = var_desc("vbtav","m s-1","Time mean barotropic meridional velocity",&
6591 hor_grid='v', z_grid='1')
6592 call register_restart_pair(cs%ubtav, cs%vbtav, vd(2), vd(3), .false., restart_cs, &
6593 conversion=us%L_T_to_m_s)
6594
6595 if (cs%gradual_BT_ICs) then
6596 vd(2) = var_desc("ubt_IC", "m s-1", &
6597 longname="Next initial condition for the barotropic zonal velocity", &
6598 hor_grid='u', z_grid='1')
6599 vd(3) = var_desc("vbt_IC", "m s-1", &
6600 longname="Next initial condition for the barotropic meridional velocity",&
6601 hor_grid='v', z_grid='1')
6602 call register_restart_pair(cs%ubt_IC, cs%vbt_IC, vd(2), vd(3), .false., restart_cs, &
6603 conversion=us%L_T_to_m_s)
6604 endif
6605
6606 call register_restart_field(cs%dtbt, "DTBT", .false., restart_cs, &
6607 longname="Barotropic timestep", units="seconds", conversion=us%T_to_s)
6608
6609 ! Register streaming band-pass filters
6610 call get_param(param_file, mdl, "USE_FILTER", cs%use_filter, &
6611 "If true, use streaming band-pass filters to detect the "//&
6612 "instantaneous tidal signals in the simulation.", default=.false.)
6613 call get_param(param_file, mdl, "N_FILTERS", n_filters, &
6614 "Number of streaming band-pass filters to be used in the simulation.", &
6615 default=0, do_not_log=.not.cs%use_filter)
6616 if (n_filters<=0) cs%use_filter = .false.
6617 if (cs%use_filter) then
6618 call filt_register(n_filters, 'ubt', 'u', hi, cs%Filt_CS_u, restart_cs)
6619 call filt_register(n_filters, 'vbt', 'v', hi, cs%Filt_CS_v, restart_cs)
6620 endif
6621
6622end subroutine register_barotropic_restarts
6623
6624
6625!> \namespace mom_barotropic
6626!!
6627!! By Robert Hallberg, April 1994 - January 2007
6628!!
6629!! This program contains the subroutines that time steps the
6630!! linearized barotropic equations. btstep is used to actually
6631!! time step the barotropic equations, and contains most of the
6632!! substance of this module.
6633!!
6634!! btstep uses a forwards-backwards based scheme to time step
6635!! the barotropic equations, returning the layers' accelerations due
6636!! to the barotropic changes in the ocean state, the final free
6637!! surface height (or column mass), and the volume (or mass) fluxes
6638!! summed through the layers and averaged over the baroclinic time
6639!! step. As input, btstep takes the initial 3-D velocities, the
6640!! initial free surface height, the 3-D accelerations of the layers,
6641!! and the external forcing. Everything in btstep is cast in terms
6642!! of anomalies, so if everything is in balance, there is explicitly
6643!! no acceleration due to btstep.
6644!!
6645!! The spatial discretization of the continuity equation is second
6646!! order accurate. A flux conservative form is used to guarantee
6647!! global conservation of volume. The spatial discretization of the
6648!! momentum equation is second order accurate. The Coriolis force
6649!! is written in a form which does not contribute to the energy
6650!! tendency and which conserves linearized potential vorticity, f/D.
6651!! These terms are exactly removed from the baroclinic momentum
6652!! equations, so the linearization of vorticity advection will not
6653!! degrade the overall solution.
6654!!
6655!! btcalc calculates the fractional thickness of each layer at the
6656!! velocity points, for later use in calculating the barotropic
6657!! velocities and the averaged accelerations. Harmonic mean
6658!! thicknesses (i.e. 2*h_L*h_R/(h_L + h_R)) are used to avoid overly
6659!! strong weighting of overly thin layers. This may later be relaxed
6660!! to use thicknesses determined from the continuity equations.
6661!!
6662!! bt_mass_source determines the real mass sources for the
6663!! barotropic solver, along with the corrective pseudo-fluxes that
6664!! keep the barotropic and baroclinic estimates of the free surface
6665!! height close to each other. Given the layer thicknesses and the
6666!! free surface height that correspond to each other, it calculates
6667!! a corrective mass source that is added to the barotropic continuity*
6668!! equation, and optionally adjusts a slowly varying correction rate.
6669!! Newer algorithmic changes have deemphasized the need for this, but
6670!! it is still here to add net water sources to the barotropic solver.*
6671!!
6672!! barotropic_init allocates and initializes any barotropic arrays
6673!! that have not been read from a restart file, reads parameters from
6674!! the inputfile, and sets up diagnostic fields.
6675!!
6676!! barotropic_end deallocates anything allocated in barotropic_init
6677!! or register_barotropic_restarts.
6678!!
6679!! register_barotropic_restarts is used to indicate any fields that
6680!! are private to the barotropic solver that need to be included in
6681!! the restart files, and to ensure that they are read.
6682
6683end module mom_barotropic