MOM_open_boundary.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!> Controls where open boundary conditions are applied
7
8use mom_array_transform, only : rotate_array, rotate_array_pair
9use mom_coms, only : sum_across_pes, any_across_pes
10use mom_coms, only : set_pelist, get_pelist, pe_here, num_pes
11use mom_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, clock_routine
12use mom_debugging, only : hchksum, uvchksum, chksum
13use mom_diag_mediator, only : diag_ctrl, time_type
14use mom_domains, only : pass_var, pass_vector
15use mom_domains, only : create_group_pass, do_group_pass, group_pass_type
16use mom_domains, only : to_all, east_face, north_face, scalar_pair, cgrid_ne, corner
18use mom_error_handler, only : mom_mesg, mom_error, fatal, warning, note, is_root_pe
19use mom_file_parser, only : get_param, log_version, param_file_type, read_param
20use mom_grid, only : ocean_grid_type, hor_index_type
21use mom_interface_heights, only : thickness_to_dz
22use mom_interpolate, only : init_external_field, time_interp_external, time_interp_external_init
23use mom_interpolate, only : external_field
24use mom_io, only : slasher, field_size, file_exists, stderr, single_file
27use mom_remapping, only : remappingschemesdoc, remappingdefaultscheme, remapping_cs
29use mom_restart, only : register_restart_field, register_restart_pair
30use mom_restart, only : query_initialized, set_initialized, mom_restart_cs
33use mom_time_manager, only : set_date, time_type, time_minus_signed
34use mom_tracer_registry, only : tracer_type, tracer_registry_type, tracer_name_lookup
38
39implicit none ; private
40
41#include <MOM_memory.h>
42
82public update_obc_ramp
88public flood_fill
89public flood_fill2
90
91integer, parameter, public :: obc_none = 0 !< Indicates the use of no open boundary
92integer, parameter, public :: obc_direction_n = 100 !< Indicates the boundary is an effective northern boundary
93integer, parameter, public :: obc_direction_s = 200 !< Indicates the boundary is an effective southern boundary
94integer, parameter, public :: obc_direction_e = 300 !< Indicates the boundary is an effective eastern boundary
95integer, parameter, public :: obc_direction_w = 400 !< Indicates the boundary is an effective western boundary
96!>@{ Enumeration values for OBC relative vorticity configurations
97integer, parameter, public :: obc_vorticity_none = 0
98integer, parameter, public :: obc_vorticity_zero = 1
99integer, parameter, public :: obc_vorticity_freeslip = 2
100integer, parameter, public :: obc_vorticity_computed = 3
101integer, parameter, public :: obc_vorticity_specified = 4
102!>@}
103!>@{ Enumeration values for OBC strain configurations
104integer, parameter, public :: obc_strain_none = 0
105integer, parameter, public :: obc_strain_zero = 1
106integer, parameter, public :: obc_strain_freeslip = 2
107integer, parameter, public :: obc_strain_computed = 3
108integer, parameter, public :: obc_strain_specified = 4
109!>@}
110integer, parameter :: num_phys_fields = 13 !< Number of physical fields
111!>@{ Indices of physical field positions in segment%field array
112integer, parameter :: &
113 f_u = 1, f_v = 2, f_vx = 3, f_uy = 4, f_z = 5, f_uamp = 6, f_uphase = 7, &
114 f_vamp = 8, f_vphase = 9, f_zamp = 10, f_zphase = 11, f_t = 12, f_s = 13
115!>@}
116character(len=8), parameter :: phys_field_names(num_phys_fields) = &
117 [character(len=8) :: 'U', 'V', 'DVDX', 'DUDY', 'SSH', 'Uamp', &
118 'Uphase', 'Vamp', 'Vphase', 'SSHamp', 'SSHphase', 'TEMP', 'SALT'] !< Physical field name
119 !! strings used by input parameter
120
121!> Open boundary segment data from files (mostly).
122type, public :: obc_segment_data_type
123 type(external_field) :: handle !< handle from FMS associated with segment data on disk
124 type(external_field) :: dz_handle !< handle from FMS associated with segment thicknesses on disk
125 logical :: required = .false. !< True if this field is required
126 logical :: use_io = .false. !< True if segment data is based on file input
127 character(len=32) :: name !< A name identifier for the segment data. When there is grid
128 !! rotation, this is the name on the rotated internal grid.
129 integer :: tr_index = -1 !< If this field is a tracer, its index in registry is stored here.
130 logical :: bgc_tracer !< True if this field is a BGC tracer
131 logical :: on_face !< If true, this field is discretized on the OBC segment
132 !! (velocity-point) faces, or if false it as the vorticiy points
133 real :: scale !< A scaling factor for converting input data to
134 !! the internal units of this field. For salinity this would
135 !! be in units of [S ppt-1 ~> 1]
136 real, allocatable :: buffer_src(:,:,:) !< buffer for segment data located at cell faces and on
137 !! the original vertical grid in the internally scaled
138 !! units for the field in question, such as [L T-1 ~> m s-1]
139 !! for a velocity or [S ~> ppt] for salinity.
140 integer :: nk_src !< Number of vertical levels in the source data
141 real, allocatable :: dz_src(:,:,:) !< vertical grid cell spacing of the incoming segment
142 !! data in [Z ~> m].
143 real, allocatable :: buffer_dst(:,:,:) !< buffer src data remapped to the target vertical grid
144 !! in the internally scaled units for the field in
145 !! question, such as [L T-1 ~> m s-1] for a velocity or
146 !! [S ~> ppt] for salinity.
147 real :: value !< A constant value for the inflow concentration if not read
148 !! from file, in the internal units of a field, such as [S ~> ppt]
149 !! for salinity.
150 real :: resrv_lfac_in = 1. !< The reservoir inverse length scale factor for the inward
151 !! direction per field [nondim]. The general 1/Lscale_in is
152 !! multiplied by this factor for a specific tracer or thickness.
153 real :: resrv_lfac_out= 1. !< The reservoir inverse length scale factor for the outward
154 !! direction per field [nondim]. The general 1/Lscale_out is
155 !! multiplied by this factor for a specific tracer or thickness.
157
158!> Tracer on OBC segment data structure, for putting into a segment tracer registry.
159type, public :: obc_segment_tracer_type
160 logical :: is_initialized !< Reservoir values have been set when True
161 character(len=32) :: name !< Tracer name used for error messages
162 integer :: ntr_index = -1 !< Index of segment tracer in the global tracer registry
163 real, allocatable :: t(:,:,:) !< External tracer concentration array in rescaled
164 !! units, like [S ~> ppt] for salinity.
165 real, allocatable :: tres(:,:,:) !< Tracer reservoir array in rescaled units, like
166 !! [S ~> ppt] for salinity.
167 real :: scale !< A scaling factor for converting the units of input
168 !! data, like [S ppt-1 ~> 1] for salinity.
169 real :: resrv_lfac_in = 1.0 !< The reservoir inverse length scale factor for the
170 !! inward direction per tracer [nondim]. The general
171 !! 1/Lscale_in is multiplied by this factor for a
172 !! specific tracer or thickness. Set to -1 to force
173 !! a zero effective length scale regardless of
174 !! Tr_InvLscale_in.
175 real :: resrv_lfac_out = 1.0 !< The reservoir inverse length scale factor for the
176 !! outward direction per tracer [nondim]. The general
177 !! 1/Lscale_out is multiplied by this factor for a
178 !! specific tracer or thickness. Set to -1 to force
179 !! a zero effective length scale regardless of
180 !! Tr_InvLscale_out.
181 real :: i_lscale_in = 0.0 !< Per-tracer inverse length scale for flow into the
182 !! reservoir direction. Three regimes:
183 !! - Positive: finite length scale; I_Lscale_in =
184 !! resrv_lfac_in * Tr_InvLscale_in [L-1 ~> m-1].
185 !! - Zero: infinite length scale; reservoir is frozen
186 !! [nondim].
187 !! - Negative (-1): instant-update sentinel (zero
188 !! effective length scale) [nondim].
189 real :: i_lscale_out = 0.0 !< Per-tracer inverse length scale for flow out of the
190 !! reservoir direction. Three regimes:
191 !! - Positive: finite length scale; I_Lscale_out =
192 !! resrv_lfac_out * Tr_InvLscale_out [L-1 ~> m-1].
193 !! - Zero: infinite length scale; reservoir is frozen
194 !! [nondim].
195 !! - Negative (-1): instant-update sentinel (zero
196 !! effective length scale) [nondim].
198
199!> Thickness on OBC segment data structure, with a reservoir
200type, public :: obc_segment_thickness_type
201 logical :: is_initialized !< Reservoir values have been set when True
202 character(len=32) :: name !< Thickness name used for error messages
203 real, allocatable :: h(:,:,:) !< Layer thickness array in rescaled units, [Z ~> m].
204 real, allocatable :: h_res(:,:,:) !< Thickness reservoir array in rescaled units,
205 !! [Z ~> m].
206 real :: scale !< A scaling factor for converting the units of input
207 !! data, [Z m-1 ~> 1].
208 integer :: fd_index = -1 !< index of segment thickness in the input fields
210
211!> Registry type for tracers on segments
212type, public :: segment_tracer_registry_type
213 integer :: ntseg = 0 !< number of registered tracer segments
214 type(obc_segment_tracer_type) :: tr(max_fields_) !< array of registered tracers
215 logical :: locked = .false. !< New tracers may be registered if locked=.false.
216 !! When locked=.true.,no more tracers can be registered.
217 !! Not sure who should lock it or when...
219
220!> Open boundary segment data structure. Unless otherwise noted, 2-d and 3-d arrays are discretized
221!! at the same position as normal velocity points in the middle of the OBC segments.
222type, public :: obc_segment_type
223 logical :: flather !< If true, applies Flather + Chapman radiation of barotropic gravity waves.
224 logical :: radiation !< If true, 1D Orlanksi radiation boundary conditions are applied.
225 !! If False, a gradient condition is applied.
226 logical :: radiation_tan !< If true, 1D Orlanksi radiation boundary conditions are applied to
227 !! tangential flows.
228 logical :: radiation_grad !< If true, 1D Orlanksi radiation boundary conditions are applied to
229 !! dudv and dvdx.
230 logical :: oblique !< Oblique waves supported at radiation boundary.
231 logical :: oblique_tan !< If true, 2D radiation boundary conditions are applied to
232 !! tangential flows.
233 logical :: oblique_grad !< If true, 2D radiation boundary conditions are applied to
234 !! dudv and dvdx.
235 logical :: nudged !< Optional supplement to radiation boundary.
236 logical :: nudged_tan !< Optional supplement to nudge tangential velocity.
237 logical :: nudged_grad !< Optional supplement to nudge normal gradient of tangential velocity.
238 logical :: specified !< Boundary normal velocity fixed to external value.
239 logical :: specified_tan !< Boundary tangential velocity fixed to external value.
240 logical :: specified_grad !< Boundary gradient of tangential velocity fixed to external value.
241 logical :: open !< Boundary is open for continuity solver, and there are no other
242 !! parameterized mass fluxes at the open boundary.
243 logical :: gradient !< Zero gradient at boundary.
244 integer :: direction !< Boundary faces one of the four directions.
245 logical :: is_n_or_s !< True if the OB is facing North or South and exists on this PE.
246 logical :: is_e_or_w !< True if the OB is facing East or West and exists on this PE.
247 logical :: is_e_or_w_2 !< True if the OB is facing East or West anywhere.
248 type(obc_segment_data_type), pointer :: field(:) => null() !< OBC data
249 integer :: num_fields !< number of OBC data fields (e.g. u_normal,u_parallel and eta for Flather)
250 integer :: is_obc !< Starting local i-index of boundary segment, this may be outside of the local PE.
251 integer :: ie_obc !< Ending local i-index of boundary segment, this may be outside of the local PE.
252 integer :: js_obc !< Starting local j-index of boundary segment, this may be outside of the local PE.
253 integer :: je_obc !< Ending local j-index of boundary segment, this may be outside of the local PE.
254 real :: velocity_nudging_timescale_in !< Nudging timescale on inflow [T ~> s].
255 real :: velocity_nudging_timescale_out !< Nudging timescale on outflow [T ~> s].
256 logical :: on_pe !< true if any portion of the segment is located in this PE's data domain
257 real, allocatable :: htot(:,:) !< The total column thickness [H ~> m or kg m-2] at OBC-points.
258 real, allocatable :: dz(:,:,:) !< The layer vertical extent [Z ~> m] at OBC segment faces.
259 real, allocatable :: dztot(:,:) !< The total column vertical extent [Z ~> m] at OBC segment faces.
260 real, allocatable :: normal_vel(:,:,:) !< The layer velocity normal to the OB
261 !! segment [L T-1 ~> m s-1].
262 real, allocatable :: tangential_vel(:,:,:) !< The layer velocity tangential to the OB segment
263 !! [L T-1 ~> m s-1], discretized at the corner points.
264 real, allocatable :: tangential_grad(:,:,:) !< The gradient of the velocity tangential to the OB
265 !! segment [T-1 ~> s-1], discretized at the corner points.
266 real, allocatable :: normal_trans(:,:,:) !< The layer transport normal to the OB
267 !! segment [H L2 T-1 ~> m3 s-1].
268 real, allocatable :: normal_vel_bt(:,:) !< The barotropic velocity normal to
269 !! the OB segment [L T-1 ~> m s-1].
270 real, allocatable :: normal_trans_bt(:,:) !< The barotropic transport normal
271 !! the OB segment [H L2 T-1 ~> m3 s-1 or kg s-1].
272 real, allocatable :: tidal_vn(:,:) !< The barotropic tidal velocity normal to
273 !! the OB segment [L T-1 ~> m s-1].
274 real, allocatable :: tidal_vt(:,:) !< The barotropic tidal velocity tangential to
275 !! the OB segment [L T-1 ~> m s-1].
276 real, allocatable :: ssh(:,:) !< The sea-surface elevation along the
277 !! segment [Z ~> m].
278 real, allocatable :: tidal_elev(:,:) !< Tidal elevation at the OBC points [Z ~> m]
279 real, allocatable :: grad_normal(:,:,:) !< The gradient of the normal flow along the
280 !! segment times the grid spacing [L T-1 ~> m s-1],
281 !! with the first index being the corner-point index
282 !! along the segment, and the second index being 1 (for
283 !! values one point into the domain) or 2 (for values
284 !! along the OBC itself)
285 real, allocatable :: grad_tan(:,:,:) !< The gradient of the tangential flow along the
286 !! segment times the grid spacing [L T-1 ~> m s-1], with the
287 !! first index being the velocity/tracer point index along the
288 !! segment, and the second being 1 for the value 1.5 points
289 !! inside the domain and 2 for the value half a point
290 !! inside the domain.
291 real, allocatable :: grad_gradient(:,:,:) !< The gradient normal to the segment of the gradient
292 !! tangetial to the segment of tangential flow along the segment
293 !! times the grid spacing [T-1 ~> s-1], with the first
294 !! index being the velocity/tracer point index along the segment,
295 !! and the second being 1 for the value 2 points into the domain
296 !! and 2 for the value 1 point into the domain.
297 real, allocatable :: rx_norm_rad(:,:,:) !< The previous normal phase speed use for EW radiation
298 !! OBC, in grid points per timestep [nondim]
299 real, allocatable :: ry_norm_rad(:,:,:) !< The previous normal phase speed use for NS radiation
300 !! OBC, in grid points per timestep [nondim]
301 real, allocatable :: rx_norm_obl(:,:,:) !< The previous x-direction normalized radiation coefficient
302 !! for either EW or NS oblique OBCs [L2 T-2 ~> m2 s-2]
303 real, allocatable :: ry_norm_obl(:,:,:) !< The previous y-direction normalized radiation coefficient
304 !! for either EW or NS oblique OBCs [L2 T-2 ~> m2 s-2]
305 real, allocatable :: cff_normal(:,:,:) !< The denominator for oblique radiation of the normal
306 !! velocity [L2 T-2 ~> m2 s-2]
307 real, allocatable :: nudged_normal_vel(:,:,:) !< The layer velocity normal to the OB segment
308 !! that values should be nudged towards [L T-1 ~> m s-1].
309 real, allocatable :: nudged_tangential_vel(:,:,:) !< The layer velocity tangential to the OB segment
310 !! that values should be nudged towards [L T-1 ~> m s-1],
311 !! discretized at the corner (PV) points.
312 real, allocatable :: nudged_tangential_grad(:,:,:) !< The layer dvdx or dudy towards which nudging
313 !! can occur [T-1 ~> s-1].
314 type(obc_segment_thickness_type), pointer :: h_reg=> null()!< A pointer to the thickness for the segment.
315 type(segment_tracer_registry_type), pointer :: tr_reg=> null()!< A pointer to the tracer registry for the segment.
316 type(hor_index_type) :: hi !< Horizontal index ranges
317 real :: tr_invlscale_out !< An effective inverse length scale for restoring
318 !! the tracer concentration in a fictitious
319 !! reservoir towards interior values when flow
320 !! is exiting the domain [L-1 ~> m-1]
321 real :: tr_invlscale_in !< An effective inverse length scale for restoring
322 !! the tracer concentration towards an externally
323 !! imposed value when flow is entering [L-1 ~> m-1]
324 real :: th_invlscale_out !< An effective inverse length scale for restoring
325 !! the layer thickness in a fictitious
326 !! reservoir towards interior values when flow
327 !! is exiting the domain [L-1 ~> m-1]
328 real :: th_invlscale_in !< An effective inverse length scale for restoring
329 !! the layer thickness towards an externally
330 !! imposed value when flow is entering [L-1 ~> m-1]
331end type obc_segment_type
332
333!> Open-boundary data
334type, public :: ocean_obc_type
335 integer :: number_of_segments = 0 !< The number of open-boundary segments.
336 logical :: reverse_segment_order = .false. !< If true, store the segments internally in the reversed order.
337 integer :: ke = 0 !< The number of model layers
338 logical :: open_u_bcs_exist_globally = .false. !< True if any zonal velocity points
339 !! in the global domain use open BCs.
340 logical :: open_v_bcs_exist_globally = .false. !< True if any meridional velocity points
341 !! in the global domain use open BCs.
342 logical :: flather_u_bcs_exist_globally = .false. !< True if any zonal velocity points
343 !! in the global domain use Flather BCs.
344 logical :: flather_v_bcs_exist_globally = .false. !< True if any meridional velocity points
345 !! in the global domain use Flather BCs.
346 logical :: oblique_bcs_exist_globally = .false. !< True if any velocity points
347 !! in the global domain use oblique BCs.
348 logical :: nudged_u_bcs_exist_globally = .false. !< True if any velocity points in the
349 !! global domain use nudged BCs.
350 logical :: nudged_v_bcs_exist_globally = .false. !< True if any velocity points in the
351 !! global domain use nudged BCs.
352 logical :: specified_u_bcs_exist_globally = .false. !< True if any zonal velocity points
353 !! in the global domain use specified BCs.
354 logical :: specified_v_bcs_exist_globally = .false. !< True if any meridional velocity points
355 !! in the global domain use specified BCs.
356 logical :: radiation_bcs_exist_globally = .false. !< True if radiations BCs are in use anywhere.
357 logical :: user_bcs_set_globally = .false. !< True if any OBC_USER_CONFIG is set
358 !! for input from user directory.
359 logical :: update_obc = .false. !< Is OBC data time-dependent
360 logical :: update_obc_seg_data = .false. !< Is it the time for OBC segment data update for fields that
361 !! require less frequent update
362 logical :: any_needs_io_for_data = .false. !< Is any i/o needed for OBCs globally
363 integer :: vorticity_config !< An integer indicating OBC relative vorticity configuration
364 integer :: strain_config !< An integer indicating OBC strain configuration
365 logical :: zero_biharmonic = .false. !< If True, zeros the Laplacian of flow on open boundaries for
366 !! use in the biharmonic viscosity term.
367 logical :: brushcutter_mode = .false. !< If True, read data on supergrid.
368 logical, allocatable :: tracer_x_reservoirs_used(:) !< Dimensioned by the number of tracers, set globally,
369 !! true for those with x reservoirs (needed for restarts).
370 logical, allocatable :: tracer_y_reservoirs_used(:) !< Dimensioned by the number of tracers, set globally,
371 !! true for those with y reservoirs (needed for restarts).
372 logical :: thickness_x_reservoirs_used = .false. !< True for thichness reservoirs in x (needed for restarts).
373 logical :: thickness_y_reservoirs_used = .false. !< True for thichness reservoirs in y (needed for restarts).
374 integer :: ntr = 0 !< number of tracers
375 integer :: n_tide_constituents = 0 !< Number of tidal constituents to add to the boundary.
376 logical :: add_tide_constituents = .false. !< If true, add tidal constituents to the boundary elevation
377 !! and velocity. Will be set to true if n_tide_constituents > 0.
378 character(len=2), allocatable, dimension(:) :: tide_names !< Names of tidal constituents to add to the boundary data.
379 real, allocatable, dimension(:) :: tide_frequencies !< Angular frequencies of chosen tidal
380 !! constituents [rad T-1 ~> rad s-1].
381 real, allocatable, dimension(:) :: tide_eq_phases !< Equilibrium phases of chosen tidal constituents [rad].
382 real, allocatable, dimension(:) :: tide_fn !< Amplitude modulation of boundary tides by nodal cycle [nondim].
383 real, allocatable, dimension(:) :: tide_un !< Phase modulation of boundary tides by nodal cycle [rad].
384 logical :: add_eq_phase = .false. !< If true, add the equilibrium phase argument
385 !! to the specified boundary tidal phase.
386 logical :: add_nodal_terms = .false. !< If true, insert terms for the 18.6 year modulation when
387 !! calculating tidal boundary conditions.
388 type(time_type) :: time_ref !< Reference date (t = 0) for tidal forcing.
389 type(astro_longitudes) :: tidal_longitudes !< Lunar and solar longitudes used to calculate tidal forcing.
390 ! Properties of the segments used.
391 type(obc_segment_type), allocatable :: segment(:) !< List of segment objects.
392 ! Which segment object describes the current point.
393 integer, allocatable :: segnum_u(:,:) !< The absolute value gives the segment number of any OBCs at u-points,
394 !! while the sign indicates whether they are Eastern (> 0) or Western (< 0)
395 !! OBCs, with 0 for velocities that are not on an OBC.
396 integer, allocatable :: segnum_v(:,:) !< The absolute value gives the segment number of any OBCs at v-points,
397 !! while the sign indicates whether they are Northern (> 0) or Southern (< 0)
398 !! OBCs, with 0 for velocities that are not on an OBC.
399 ! Keep the OBC segment properties for external BGC tracers
400 type(external_tracers_segments_props), pointer :: obgc_segments_props => null() !< obgc segment properties
401 integer :: num_obgc_tracers = 0 !< The total number of obgc tracers
402
403 ! The following parameters are used in the baroclinic radiation code:
404 real :: gamma_uv !< The relative weighting for the baroclinic radiation
405 !! velocities (or speed of characteristics) at the
406 !! new time level (1) or the running mean (0) for velocities [nondim].
407 !! Valid values range from 0 to 1, with a default of 0.3.
408 real :: rx_max !< The maximum magnitude of the baroclinic radiation velocity (or speed of
409 !! characteristics) in units of grid points per timestep [nondim].
410 logical :: obc_pe !< Is there an open boundary on this tile?
411 logical :: u_obcs_on_pe !< True if there are any u-point OBCs on this PE, including in its halos.
412 logical :: v_obcs_on_pe !< True if there are any v-point OBCs on this PE, including in its halos.
413 logical :: v_n_obcs_on_pe !< True if there are any northern v-point OBCs on this PE, including in its halos.
414 logical :: v_s_obcs_on_pe !< True if there are any southern v-point OBCs on this PE, including in its halos.
415 logical :: u_e_obcs_on_pe !< True if there are any eastern u-point OBCs on this PE, including in its halos.
416 logical :: u_w_obcs_on_pe !< True if there are any western u-point OBCs on this PE, including in its halos.
417 !>@{ Index ranges on the local PE for the open boundary conditions in various directions
418 integer :: is_u_w_obc, ie_u_w_obc, js_u_w_obc, je_u_w_obc
419 integer :: is_u_e_obc, ie_u_e_obc, js_u_e_obc, je_u_e_obc
420 integer :: is_v_s_obc, ie_v_s_obc, js_v_s_obc, je_v_s_obc
421 integer :: is_v_n_obc, ie_v_n_obc, js_v_n_obc, je_v_n_obc
422 !>@}
423 type(remapping_cs), pointer :: remap_z_cs => null() !< ALE remapping control structure for
424 !! z-space data on segments
425 type(remapping_cs), pointer :: remap_h_cs => null() !< ALE remapping control structure for
426 !! thickness-based fields on segments
427 type(obc_registry_type), pointer :: obc_reg => null() !< Registry type for boundaries
428 real, allocatable :: rx_normal(:,:,:) !< Array storage for normal phase speed for EW radiation OBCs
429 !! in units of grid points per timestep [nondim]
430 real, allocatable :: ry_normal(:,:,:) !< Array storage for normal phase speed for NS radiation OBCs
431 !! in units of grid points per timestep [nondim]
432 real, allocatable :: rx_oblique_u(:,:,:) !< X-direction oblique boundary condition radiation speeds
433 !! squared at u points for restarts [L2 T-2 ~> m2 s-2]
434 real, allocatable :: ry_oblique_u(:,:,:) !< Y-direction oblique boundary condition radiation speeds
435 !! squared at u points for restarts [L2 T-2 ~> m2 s-2]
436 real, allocatable :: rx_oblique_v(:,:,:) !< X-direction oblique boundary condition radiation speeds
437 !! squared at v points for restarts [L2 T-2 ~> m2 s-2]
438 real, allocatable :: ry_oblique_v(:,:,:) !< Y-direction oblique boundary condition radiation speeds
439 !! squared at v points for restarts [L2 T-2 ~> m2 s-2]
440 real, allocatable :: cff_normal_u(:,:,:) !< Denominator for normalizing EW oblique boundary condition
441 !! radiation rates at u points for restarts [L2 T-2 ~> m2 s-2]
442 real, allocatable :: cff_normal_v(:,:,:) !< Denominator for normalizing NS oblique boundary condition
443 !! radiation rates at v points for restarts [L2 T-2 ~> m2 s-2]
444 real, allocatable :: tres_x(:,:,:,:) !< Array storage of tracer reservoirs for restarts,
445 !! in unscaled units [conc]
446 real, allocatable :: tres_y(:,:,:,:) !< Array storage of tracer reservoirs for restarts,
447 !! in unscaled units [conc]
448 real, allocatable :: h_res_x(:,:,:) !< Array storage of thickness reservoirs for restarts,
449 !! [Z ~> m]
450 real, allocatable :: h_res_y(:,:,:) !< Array storage of thickness reservoirs for restarts,
451 !! [Z ~> m]
452 logical :: use_h_res = .false. !< If true, use thickness reservoirs
453 logical :: debug !< If true, write verbose checksums for debugging purposes.
454 integer :: nk_obc_debug = 0 !< The number of layers of OBC segment data to write out
455 !! in full when DEBUG_OBCS is true.
456 real :: silly_h !< A silly value of thickness outside of the domain that can be used to test
457 !! the independence of the OBCs to this external data [Z ~> m].
458 real :: silly_u !< A silly value of velocity outside of the domain that can be used to test
459 !! the independence of the OBCs to this external data [L T-1 ~> m s-1].
460 logical :: ramp = .false. !< If True, ramp from zero to the external values for SSH.
461 logical :: ramping_is_activated = .false. !< True if the ramping has been initialized
462 real :: ramp_timescale !< If ramp is True, use this timescale for ramping [T ~> s].
463 real :: trunc_ramp_time !< If ramp is True, time after which ramp is done [T ~> s].
464 real :: ramp_value !< If ramp is True, where we are on the ramp from
465 !! zero to one [nondim].
466 type(time_type) :: ramp_start_time !< Time when model was started.
467 integer :: remap_answer_date !< The vintage of the order of arithmetic and expressions to use
468 !! for remapping. Values below 20190101 recover the remapping
469 !! answers from 2018, while higher values use more robust
470 !! forms of the same remapping expressions.
471 logical :: check_reconstruction !< Flag for remapping to run checks on reconstruction
472 logical :: check_remapping !< Flag for remapping to run internal checks
473 logical :: force_bounds_in_subcell !< Flag for remapping to hide overshoot using bounds
474 logical :: om4_remap_via_sub_cells !< If true, use the OM4 remapping algorithm
475 character(40) :: remappingscheme !< String selecting the vertical remapping scheme
476 type(group_pass_type) :: pass_oblique !< Structure for group halo pass
477 logical :: exterior_obc_bug !< If true, use incorrect form of tracers exterior to OBCs.
478 logical :: hor_index_bug !< If true, recover set of a horizontal indexing bugs in the OBC code.
479 logical :: reservoir_init_bug !< If true, set the OBC tracer reservoirs at the startup of a new
480 !! run from the interior tracer concentrations regardless of
481 !! properties that may be explicitly specified for the reservoir
482 !! concentrations.
483 logical :: ts_needed_bug !< If true, recover a bug that temperature and salinity can be ignored
484 !! even if they are registered tracers in the rest of the model.
485 logical :: ignore_dt_obc_bgc !< If true, DT_OBC_SEG_UPDATE_OBGC is ignored and all OBC segment
486 !! tracer data (T/S and BGC) is updated every tracer advection step.
487 !! If false, T/S is updated every dynamic step, which is unnecessary,
488 !! while BGC follows its own update schedule, which may not reproduce
489 !! across restarts. Once DT_OBC_SEG_UPDATE_OBGC is deprecated, only
490 !! the "true" path will be needed.
491end type ocean_obc_type
492
493!> Control structure for open boundaries that read from files.
494!! Probably lots to update here.
495type, public :: file_obc_cs ; private
496 logical :: obc_file_used = .false. !< Placeholder for now to avoid an empty type.
497end type file_obc_cs
498
499!> Type to carry something (what??) for the OBC registry.
500type, public :: obc_struct_type
501 character(len=32) :: name !< OBC name used for error messages
502end type obc_struct_type
503
504!> Type to carry basic OBC information needed for updating values.
505type, public :: obc_registry_type
506 integer :: nobc = 0 !< number of registered open boundary types.
507 type(obc_struct_type) :: ob(max_fields_) !< array of registered boundary types.
508 logical :: locked = .false. !< New OBC types may be registered if locked=.false.
509 !! When locked=.true.,no more boundaries can be registered.
510end type obc_registry_type
511
512!> Type to carry OBC information needed for setting segments for OBGC tracers
513type, private :: external_tracers_segments_props
514 type(external_tracers_segments_props), pointer :: next => null() !< pointer to the next node
515 character(len=128) :: tracer_name !< tracer name
516 character(len=128) :: tracer_src_file !< tracer source file for BC
517 character(len=128) :: tracer_src_field !< name of the field in source file to extract BC
518 real :: lfac_in !< multiplicative factor for inbound tracer reservoir length scale [nondim]
519 real :: lfac_out !< multiplicative factor for outbound tracer reservoir length scale [nondim]
521integer :: id_clock_pass !< A CPU time clock
522
523character(len=40) :: mdl = "MOM_open_boundary" !< This module's name.
524
525contains
526
527!> Enables OBC module and reads configuration parameters
528!! This routine is called from MOM_initialize_fixed which
529!! occurs before the initialization of the vertical coordinate
530!! and ALE_init. Therefore segment data are not fully initialized
531!! here. The remainder of the segment data are initialized in a
532!! later call to update_open_boundary_data
533subroutine open_boundary_config(G, US, param_file, OBC)
534 type(dyn_horgrid_type), intent(inout) :: g !< Ocean grid structure
535 type(unit_scale_type), intent(in) :: us !< A dimensional unit scaling type
536 type(param_file_type), intent(in) :: param_file !< Parameter file handle
537 type(ocean_obc_type), pointer :: obc !< Open boundary control structure
538
539 ! Local variables
540 integer :: num_of_segs ! Number of open boundary segments
541 integer :: n, n_seg ! For looping over segments
542 logical :: debug, mask_outside, reentrant_x, reentrant_y
543 character(len=15) :: segment_param_str ! The run-time parameter name for each segment
544 character(len=1024) :: segment_str ! The contents (rhs) for parameter "segment_param_str"
545 character(len=200) :: config ! A string to temporarily store a few runtime parameters
546 real :: lscale_in, lscale_out ! parameters controlling tracer values at the boundaries [L ~> m]
547 integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags.
548 logical :: enable_bugs ! If true, the defaults for recently added bug-fix flags are set to
549 ! recreate the bugs, or if false bugs are only used if actively selected.
550 logical :: debugging_tests ! If true, do additional calls resetting values to help debug the performance
551 ! of the open boundary condition code.
552 logical :: obsolete_param_set, param_set
553 logical :: zero_vorticity, freeslip_vorticity, computed_vorticity, specified_vorticity
554 logical :: zero_strain, freeslip_strain, computed_strain, specified_strain
555 ! This include declares and sets the variable "version".
556# include "version_variable.h"
557
558 call log_version(param_file, mdl, version, "Controls where open boundaries are located, "//&
559 "what kind of boundary condition to impose, and what data to apply, if any.", &
560 all_default=.false.)
561 ! Parameter OBC_NUMBER_OF_SEGMENTS is always logged.
562 call get_param(param_file, mdl, "OBC_NUMBER_OF_SEGMENTS", num_of_segs, &
563 "The number of open boundary segments.", default=0)
564 if (num_of_segs <= 0) & ! Do nothing if there is no OBC segments
565 return
566
567 allocate(obc)
568 obc%number_of_segments = num_of_segs
569 call get_param(param_file, mdl, "OBC_USER_CONFIG", config, &
570 "A string that sets how the open boundary conditions are "//&
571 " configured: \n", default="none", do_not_log=.true.)
572 call get_param(param_file, mdl, "NK", obc%ke, &
573 "The number of model layers", default=0, do_not_log=.true.)
574
575 if (config /= "none" .and. config /= "dyed_obcs") obc%user_BCs_set_globally = .true.
576
577 ! Configuration for OBC relative vorticity.
578 ! Old setup method
579 obsolete_param_set = .false.
580 zero_vorticity = .false.
581 call read_param(param_file, "OBC_ZERO_VORTICITY", zero_vorticity, set=param_set)
582 obsolete_param_set = obsolete_param_set .or. param_set
583 freeslip_vorticity = .true.
584 call read_param(param_file, "OBC_FREESLIP_VORTICITY", freeslip_vorticity, set=param_set)
585 obsolete_param_set = obsolete_param_set .or. param_set
586 computed_vorticity = .false.
587 call read_param(param_file, "OBC_COMPUTED_VORTICITY", computed_vorticity, set=param_set)
588 obsolete_param_set = obsolete_param_set .or. param_set
589 specified_vorticity = .false.
590 call read_param(param_file, "OBC_SPECIFIED_VORTICITY", specified_vorticity, set=param_set)
591 obsolete_param_set = obsolete_param_set .or. param_set
592 if (obsolete_param_set) then
593 call mom_error(warning, 'OBC_ZERO_VORTICITY, OBC_FREESLIP_VORTICITY, OBC_COMPUTED_VORTICITY'//&
594 ' and OBC_SPECIFIED_VORTICITY are obsolete, use OBC_VORTICITY_CONFIG instead.')
595 if ((zero_vorticity .and. freeslip_vorticity) .or. &
596 (zero_vorticity .and. computed_vorticity) .or. &
597 (zero_vorticity .and. specified_vorticity) .or. &
598 (freeslip_vorticity .and. computed_vorticity) .or. &
599 (freeslip_vorticity .and. specified_vorticity) .or. &
600 (computed_vorticity .and. specified_vorticity)) &
601 call mom_error(fatal, "MOM_open_boundary.F90, open_boundary_config:\n"//&
602 "Only one of OBC_ZERO_VORTICITY, OBC_FREESLIP_VORTICITY, OBC_COMPUTED_VORTICITY\n"//&
603 "and OBC_IMPORTED_VORTICITY can be True at once.")
604 ! "config" is set from OBC_XXX_VORTICITY if they are used.
605 if (zero_vorticity) then
606 config = 'zero'
607 elseif (freeslip_vorticity) then
608 config = 'freeslip'
609 elseif (computed_vorticity) then
610 config = 'computed'
611 elseif (specified_vorticity) then
612 config = 'specified'
613 else
614 config = 'none'
615 endif
616 else
617 config = 'freeslip' ! Default
618 endif
619 ! New setup method (overrides old method if specified)
620 call read_param(param_file, "OBC_VORTICITY_CONFIG", config)
621 call get_param(param_file, mdl, "OBC_VORTICITY_CONFIG", config, &
622 "Configuration for relative vorticity in momentum advection at open "//&
623 "boundaries. Options are: \n"// &
624 " \t none - No adjustment.\n"//&
625 " \t zero - Sets relative vorticity to zero.\n"//&
626 " \t freeslip - Sets the normal gradient of tangential velocity to zero.\n"//&
627 " \t computed - Computes the normal gradient of tangential velocity using\n"//&
628 " \t external values of tangential velocity.\n"//&
629 " \t specified - Uses the external values of the normal gradient of\n"//&
630 " \t tangential velocity.", default="freeslip", do_not_read=.true.)
631 select case (trim(config))
632 case ("none") ; obc%vorticity_config = obc_vorticity_none
633 case ("zero") ; obc%vorticity_config = obc_vorticity_zero
634 case ("freeslip") ; obc%vorticity_config = obc_vorticity_freeslip
635 case ("computed") ; obc%vorticity_config = obc_vorticity_computed
636 case ("specified") ; obc%vorticity_config = obc_vorticity_specified
637 case default
638 call mom_error(fatal, "MOM_open_boundary: Unrecognized OBC_VORTICITY_CONFIG: "//trim(config))
639 end select
640
641 ! Configuration for OBC strain.
642 ! Old setup method
643 obsolete_param_set = .false.
644 zero_strain = .false.
645 call read_param(param_file, "OBC_ZERO_STRAIN", zero_strain, set=param_set)
646 obsolete_param_set = obsolete_param_set .or. param_set
647 freeslip_strain = .true.
648 call read_param(param_file, "OBC_FREESLIP_STRAIN", freeslip_strain, set=param_set)
649 obsolete_param_set = obsolete_param_set .or. param_set
650 computed_strain = .false.
651 call read_param(param_file, "OBC_COMPUTED_STRAIN", computed_strain, set=param_set)
652 obsolete_param_set = obsolete_param_set .or. param_set
653 specified_strain = .false.
654 call read_param(param_file, "OBC_SPECIFIED_STRAIN", specified_strain, set=param_set)
655 obsolete_param_set = obsolete_param_set .or. param_set
656 if (obsolete_param_set) then
657 call mom_error(warning, 'OBC_ZERO_STRAIN, OBC_FREESLIP_STRAIN, OBC_COMPUTED_STRAIN'//&
658 ' and OBC_SPECIFIED_STRAIN are obsolete, use OBC_STRAIN_CONFIG instead.')
659 if ((zero_strain .and. freeslip_strain) .or. &
660 (zero_strain .and. computed_strain) .or. &
661 (zero_strain .and. specified_strain) .or. &
662 (freeslip_strain .and. computed_strain) .or. &
663 (freeslip_strain .and. specified_strain) .or. &
664 (computed_strain .and. specified_strain)) &
665 call mom_error(fatal, "MOM_open_boundary.F90, open_boundary_config: \n"//&
666 "Only one of OBC_ZERO_STRAIN, OBC_FREESLIP_STRAIN, OBC_COMPUTED_STRAIN \n"//&
667 "and OBC_IMPORTED_STRAIN can be True at once.")
668 ! "config" is set from OBC_XXX_STRAIN if they are used.
669 if (zero_strain) then
670 config = 'zero'
671 elseif (freeslip_strain) then
672 config = 'freeslip'
673 elseif (computed_strain) then
674 config = 'computed'
675 elseif (specified_strain) then
676 config = 'specified'
677 else
678 config = 'none'
679 endif
680 else
681 config = 'freeslip' ! Default
682 endif
683 ! New setup method (overrides old method if specified)
684 call read_param(param_file, "OBC_STRAIN_CONFIG", config)
685 call get_param(param_file, mdl, "OBC_STRAIN_CONFIG", config, &
686 "Configuration for strain in horizontal viscosity at open boundaries. "//&
687 "Options are: \n"// &
688 " \t none - No adjustment.\n"//&
689 " \t zero - Sets strain to zero.\n"//&
690 " \t freeslip - Sets the normal gradient of tangential velocity to zero.\n"//&
691 " \t computed - Computes the normal gradient of tangential velocity using\n"//&
692 " \t external values of tangential velocity.\n"//&
693 " \t specified - Uses the external values of the normal gradient of\n"//&
694 " \t tangential velocity.", default="freeslip", do_not_read=.true.)
695 select case (trim(config))
696 case ("none") ; obc%strain_config = obc_strain_none
697 case ("zero") ; obc%strain_config = obc_strain_zero
698 case ("freeslip") ; obc%strain_config = obc_strain_freeslip
699 case ("computed") ; obc%strain_config = obc_strain_computed
700 case ("specified") ; obc%strain_config = obc_strain_specified
701 case default
702 call mom_error(fatal, "MOM_open_boundary: Unrecognized OBC_STRAIN_CONFIG: "//trim(config))
703 end select
704
705 call get_param(param_file, mdl, "OBC_ZERO_BIHARMONIC", obc%zero_biharmonic, &
706 "If true, zeros the Laplacian of flow on open boundaries in the biharmonic "//&
707 "viscosity term.", default=.false.)
708 call get_param(param_file, mdl, "MASK_OUTSIDE_OBCS", mask_outside, &
709 "If true, set the areas outside open boundaries to be land.", &
710 default=.false.)
711 call get_param(param_file, mdl, "RAMP_OBCS", obc%ramp, &
712 "If true, ramps from zero to the external values over time, with "//&
713 "a ramping timescale given by RAMP_TIMESCALE. Ramping SSH only so far.", &
714 default=.false.)
715 call get_param(param_file, mdl, "OBC_RAMP_TIMESCALE", obc%ramp_timescale, &
716 "If RAMP_OBCS is true, this sets the ramping timescale.", &
717 units="days", default=1.0, scale=86400.0*us%s_to_T)
718 call get_param(param_file, mdl, "OBC_TIDE_N_CONSTITUENTS", obc%n_tide_constituents, &
719 "Number of tidal constituents being added to the open boundary.", &
720 default=0)
721 obc%add_tide_constituents = (obc%n_tide_constituents > 0)
722
723 call get_param(param_file, mdl, "DEBUG", debug, default=.false.)
724 call get_param(param_file, mdl, "DEBUG_OBCS", obc%debug, &
725 "If true, do additional calls to help debug the performance "//&
726 "of the open boundary condition code.", &
727 default=.false., debuggingparam=.true.)
728 if (obc%debug .and. (num_pes() > 1)) &
729 call mom_error(fatal, "DEBUG_OBCS = True is currently only supported for single PE runs.")
730 call get_param(param_file, mdl, "OBC_DEBUGGING_TESTS", debugging_tests, &
731 "If true, do additional calls resetting certain values to help verify the correctness "//&
732 "of the open boundary condition code.", &
733 default=.false., old_name="DEBUG_OBC", debuggingparam=.true.)
734 call get_param(param_file, mdl, "NK_OBC_DEBUG", obc%nk_OBC_debug, &
735 "The number of layers of OBC segment data to write out in full "//&
736 "when DEBUG_OBCS is true.", &
737 default=0, debuggingparam=.true., do_not_log=.not.obc%debug)
738 call get_param(param_file, mdl, "OBC_REVERSE_SEGMENT_ORDER", obc%reverse_segment_order, &
739 "If true, store the OBC segments internally and handle them in the reverse "//&
740 "order from that with which they are specified via external parameters to test "//&
741 "for dependencies on the order with which the OBC segments are applied.", &
742 default=.false., debuggingparam=.true., do_not_log=(obc%number_of_segments<2))
743
744 call get_param(param_file, mdl, "OBC_SILLY_THICK", obc%silly_h, &
745 "A silly value of thicknesses used outside of open boundary "//&
746 "conditions for debugging.", units="m", default=0.0, scale=us%m_to_Z, &
747 do_not_log=.not.debugging_tests, debuggingparam=.true.)
748 call get_param(param_file, mdl, "OBC_SILLY_VEL", obc%silly_u, &
749 "A silly value of velocities used outside of open boundary "//&
750 "conditions for debugging.", units="m/s", default=0.0, scale=us%m_s_to_L_T, &
751 do_not_log=.not.debugging_tests, debuggingparam=.true.)
752 call get_param(param_file, mdl, "ENABLE_BUGS_BY_DEFAULT", enable_bugs, &
753 default=.true., do_not_log=.true.) ! This is logged from MOM.F90.
754 call get_param(param_file, mdl, "EXTERIOR_OBC_BUG", obc%exterior_OBC_bug, &
755 "If true, recover a bug in barotropic solver and other routines when "//&
756 "boundary contitions interior to the domain are used.", &
757 default=enable_bugs)
758 call get_param(param_file, mdl, "OBC_HOR_INDEXING_BUG", obc%hor_index_bug, &
759 "If true, recover set of a horizontal indexing bugs in the OBC code.", &
760 default=enable_bugs)
761 call get_param(param_file, mdl, "OBC_RESERVOIR_INIT_BUG", obc%reservoir_init_bug, &
762 "If true, set the OBC tracer reservoirs at the startup of a new run from the "//&
763 "interior tracer concentrations regardless of properties that may be explicitly "//&
764 "specified for the reservoir concentrations.", default=enable_bugs, do_not_log=.true.)
765 call get_param(param_file, mdl, "OBC_TEMP_SALT_NEEDED_BUG", obc%ts_needed_bug, &
766 "If true, recover a bug that OBC temperature and salinity can be ignored "//&
767 "even if they are registered tracers in the rest of the model.", default=enable_bugs)
768 call get_param(param_file, mdl, "IGNORE_DT_OBC_SEG_UPDATE_OBGC", obc%ignore_dt_obc_bgc, &
769 "If true, DT_OBC_SEG_UPDATE_OBGC is ignored and all OBC segment tracer data "//&
770 "(T/S and BGC) is updated every tracer advection step. If false, T/S is "//&
771 "updated every dynamic step, which is unnecessary, while BGC follows its own "//&
772 "update schedule, which may not reproduce across restarts. Once "//&
773 "DT_OBC_SEG_UPDATE_OBGC is deprecated, only the 'true' path will be needed.", &
774 default=.false.)
775 call get_param(param_file, mdl, "REENTRANT_X", reentrant_x, default=.true.)
776 call get_param(param_file, mdl, "REENTRANT_Y", reentrant_y, default=.false.)
777
778 ! Allocate everything
779 allocate(obc%segment(1:obc%number_of_segments))
780 do n=1,obc%number_of_segments
781 obc%segment(n)%Flather = .false.
782 obc%segment(n)%radiation = .false.
783 obc%segment(n)%radiation_tan = .false.
784 obc%segment(n)%radiation_grad = .false.
785 obc%segment(n)%oblique = .false.
786 obc%segment(n)%oblique_tan = .false.
787 obc%segment(n)%oblique_grad = .false.
788 obc%segment(n)%nudged = .false.
789 obc%segment(n)%nudged_tan = .false.
790 obc%segment(n)%nudged_grad = .false.
791 obc%segment(n)%specified = .false.
792 obc%segment(n)%specified_tan = .false.
793 obc%segment(n)%specified_grad = .false.
794 obc%segment(n)%open = .false.
795 obc%segment(n)%gradient = .false.
796 obc%segment(n)%direction = obc_none
797 obc%segment(n)%is_N_or_S = .false.
798 obc%segment(n)%is_E_or_W = .false.
799 obc%segment(n)%is_E_or_W_2 = .false.
800 obc%segment(n)%Velocity_nudging_timescale_in = 0.0
801 obc%segment(n)%Velocity_nudging_timescale_out = 0.0
802 obc%segment(n)%num_fields = 0
803 enddo
804 allocate(obc%segnum_u(g%IsdB:g%IedB,g%jsd:g%jed), source=0)
805 allocate(obc%segnum_v(g%isd:g%ied,g%JsdB:g%JedB), source=0)
806 obc%u_OBCs_on_PE = .false.
807 obc%v_OBCs_on_PE = .false.
808
809 do n=1,obc%number_of_segments
810 n_seg = n ; if (obc%reverse_segment_order) n_seg = obc%number_of_segments + 1 - n
811 write(segment_param_str(1:15),"('OBC_SEGMENT_',i3.3)") n
812 call get_param(param_file, mdl, segment_param_str, segment_str, &
813 "Documentation needs to be dynamic?????", &
814 fail_if_missing=.true.)
815 segment_str = remove_spaces(segment_str)
816 if (segment_str(1:2) == 'I=') then
817 call setup_u_point_obc(obc, g, us, segment_str, n_seg, n, param_file, reentrant_y)
818 elseif (segment_str(1:2) == 'J=') then
819 call setup_v_point_obc(obc, g, us, segment_str, n_seg, n, param_file, reentrant_x)
820 else
821 call mom_error(fatal, "MOM_open_boundary.F90, open_boundary_config: "//&
822 "Unable to interpret "//segment_param_str//" = "//trim(segment_str))
823 endif
824 enddo
825 ! Set arrays indicating the segment number and segment direction, and also store the
826 ! range of indices within which various orientations of OBCs can be found on this PE.
827 call set_segnum_signs(obc, g)
828
829 ! Moved this earlier because time_interp_external_init needs to be called
830 ! before anything that uses time_interp_external (such as initialize_segment_data)
831 if (obc%specified_u_BCs_exist_globally .or. obc%specified_v_BCs_exist_globally .or. &
832 obc%open_u_BCs_exist_globally .or. obc%open_v_BCs_exist_globally) then
833 ! Need this for ocean_only mode boundary interpolation.
834 call time_interp_external_init()
835 endif
836 ! if (open_boundary_query(OBC, needs_ext_seg_data=.true.)) &
837 ! call initialize_segment_data(G, OBC, param_file)
838
839 if (open_boundary_query(obc, apply_open_obc=.true.)) then
840 call get_param(param_file, mdl, "OBC_RADIATION_MAX", obc%rx_max, &
841 "The maximum magnitude of the baroclinic radiation velocity (or speed of "//&
842 "characteristics), in gridpoints per timestep. This is only "//&
843 "used if one of the open boundary segments is using Orlanski.", &
844 units="nondim", default=1.0)
845 call get_param(param_file, mdl, "OBC_RAD_VEL_WT", obc%gamma_uv, &
846 "The relative weighting for the baroclinic radiation "//&
847 "velocities (or speed of characteristics) at the new "//&
848 "time level (1) or the running mean (0) for velocities. "//&
849 "Valid values range from 0 to 1. This is only used if "//&
850 "one of the open boundary segments is using Orlanski.", &
851 units="nondim", default=0.3)
852 endif
853
854 if (mask_outside) call mask_outside_obcs(g, us, param_file, obc)
855
856 lscale_in = 0.
857 lscale_out = 0.
858 if (open_boundary_query(obc, apply_open_obc=.true.)) then
859 call get_param(param_file, mdl, "OBC_TRACER_RESERVOIR_LENGTH_SCALE_OUT", lscale_out, &
860 "An effective length scale for the tracer reservoir update when the flow "//&
861 "is exiting the domain. If positive, the reservoir relaxes toward the "//&
862 "interior concentration with this length scale. If zero (default), the "//&
863 "length scale is truly zero: the reservoir is set instantly to the "//&
864 "interior concentration on outflow. If negative, the length scale is "//&
865 "effectively infinite: the reservoir is never updated on outflow.", &
866 units="m", default=0.0, scale=us%m_to_L)
867 call get_param(param_file, mdl, "OBC_TRACER_RESERVOIR_LENGTH_SCALE_IN", lscale_in, &
868 "An effective length scale for the tracer reservoir update when the flow "//&
869 "is entering the domain. If positive, the reservoir relaxes toward the "//&
870 "external OBC concentration with this length scale. If zero (default), "//&
871 "the length scale is truly zero: the reservoir is set instantly to the "//&
872 "external OBC concentration on inflow. If negative, the length scale is "//&
873 "effectively infinite: the reservoir is never updated on inflow.", &
874 units="m", default=0.0, scale=us%m_to_L)
875 endif
876
877 ! All tracers are using the same restoring length scale for now, but we may want to make this
878 ! tracer-specific in the future for example, in cases where certain tracers are poorly constrained
879 ! by data while others are well constrained - MJH.
880 ! All segments also have the same restoring length scale. Internally, each tracer has
881 ! resrv_lfac_in/out attributes to rescale the length scales. resrv_lfac_in/out is only
882 ! used by BGC tracers at the moment.
883 do n=1,obc%number_of_segments
884 if (lscale_in > 0.0) then
885 obc%segment(n)%Tr_InvLscale_in = 1.0 / lscale_in
886 elseif (lscale_in < 0.0) then
887 obc%segment(n)%Tr_InvLscale_in = 0.0
888 else ! (Lscale_in == 0.0) then
889 obc%segment(n)%Tr_InvLscale_in = -1.0 ! A nondim sentinel value
890 endif
891 if (lscale_out > 0.0) then
892 obc%segment(n)%Tr_InvLscale_out = 1.0 / lscale_out
893 elseif (lscale_out < 0.0) then
894 obc%segment(n)%Tr_InvLscale_out = 0.0
895 else ! (Lscale_out == 0.0) then
896 obc%segment(n)%Tr_InvLscale_out = -1.0 ! A nondim sentinel value
897 endif
898 enddo
899
900 lscale_in = 0.
901 lscale_out = 0.
902 if (open_boundary_query(obc, apply_open_obc=.true.)) then
903 call get_param(param_file, mdl, "OBC_THICKNESS_RESERVOIR_LENGTH_SCALE_OUT ", lscale_out, &
904 "An effective length scale for restoring the layer thickness "//&
905 "at the boundaries to externally imposed values when the flow "//&
906 "is exiting the domain.", units="m", default=0.0, scale=us%m_to_L)
907
908 call get_param(param_file, mdl, "OBC_THICKNESS_RESERVOIR_LENGTH_SCALE_IN ", lscale_in, &
909 "An effective length scale for restoring the layer thickness "//&
910 "at the boundaries to values from the interior when the flow "//&
911 "is entering the domain.", units="m", default=0.0, scale=us%m_to_L)
912 endif
913
914 do n=1,obc%number_of_segments
915 obc%segment(n)%Th_InvLscale_in = 0.0
916 if (lscale_in>0.) obc%segment(n)%Th_InvLscale_in = 1.0/lscale_in
917 obc%segment(n)%Th_InvLscale_out = 0.0
918 if (lscale_out>0.) obc%segment(n)%Th_InvLscale_out = 1.0/lscale_out
919 if (lscale_in>0. .or. lscale_out>0.) then
920 if (obc%segment(n)%is_E_or_W_2) then
921 obc%thickness_x_reservoirs_used = .true.
922 obc%use_h_res = .true.
923 else
924 obc%thickness_y_reservoirs_used = .true.
925 obc%use_h_res = .true.
926 endif
927 endif
928 enddo
929
930 call get_param(param_file, mdl, "REMAPPING_SCHEME", obc%remappingScheme, &
931 default=remappingdefaultscheme, do_not_log=.true.)
932 call get_param(param_file, mdl, "OBC_REMAPPING_SCHEME", obc%remappingScheme, &
933 "This sets the reconstruction scheme used "//&
934 "for OBC vertical remapping for all variables. "//&
935 "It can be one of the following schemes: \n"//&
936 trim(remappingschemesdoc), default=obc%remappingScheme)
937 call get_param(param_file, mdl, "FATAL_CHECK_RECONSTRUCTIONS", obc%check_reconstruction, &
938 "If true, cell-by-cell reconstructions are checked for "//&
939 "consistency and if non-monotonicity or an inconsistency is "//&
940 "detected then a FATAL error is issued.", default=.false., do_not_log=.true.)
941 call get_param(param_file, mdl, "FATAL_CHECK_REMAPPING", obc%check_remapping, &
942 "If true, the results of remapping are checked for "//&
943 "conservation and new extrema and if an inconsistency is "//&
944 "detected then a FATAL error is issued.", default=.false., do_not_log=.true.)
945 call get_param(param_file, mdl, "BRUSHCUTTER_MODE", obc%brushcutter_mode, &
946 "If true, read external OBC data on the supergrid.", &
947 default=.false.)
948 call get_param(param_file, mdl, "REMAP_BOUND_INTERMEDIATE_VALUES", obc%force_bounds_in_subcell, &
949 "If true, the values on the intermediate grid used for remapping "//&
950 "are forced to be bounded, which might not be the case due to "//&
951 "round off.", default=.false., do_not_log=.true.)
952 call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, &
953 "This sets the default value for the various _ANSWER_DATE parameters.", &
954 default=99991231)
955 call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", obc%remap_answer_date, &
956 "The vintage of the expressions and order of arithmetic to use for remapping. "//&
957 "Values below 20190101 result in the use of older, less accurate expressions "//&
958 "that were in use at the end of 2018. Higher values result in the use of more "//&
959 "robust and accurate forms of mathematically equivalent expressions.", &
960 default=default_answer_date)
961 call get_param(param_file, mdl, "REMAPPING_USE_OM4_SUBCELLS", obc%om4_remap_via_sub_cells, &
962 do_not_log=.true., default=.true.)
963
964 call get_param(param_file, mdl, "OBC_REMAPPING_USE_OM4_SUBCELLS", obc%om4_remap_via_sub_cells, &
965 "If true, use the OM4 remapping-via-subcells algorithm for neutral diffusion. "//&
966 "See REMAPPING_USE_OM4_SUBCELLS for more details. "//&
967 "We recommend setting this option to false.", default=obc%om4_remap_via_sub_cells)
968
969 ! Safety check
970 if ((obc%open_u_BCs_exist_globally .or. obc%open_v_BCs_exist_globally) .and. &
971 .not.g%symmetric ) call mom_error(fatal, &
972 "MOM_open_boundary, open_boundary_config: "//&
973 "Symmetric memory must be used when using Flather OBCs.")
974 ! Need to do this last, because it depends on time_interp_external_init having already been called
975 if (obc%add_tide_constituents) then
976 call initialize_obc_tides(obc, us, param_file)
977 ! Tide update is done within update_OBC_segment_data, so this should be true if tides are included.
978 obc%update_OBC = .true.
979 endif
980
981 if (.not.(obc%specified_u_BCs_exist_globally .or. obc%specified_v_BCs_exist_globally .or. &
982 obc%open_u_BCs_exist_globally .or. obc%open_v_BCs_exist_globally)) then
983 ! No open boundaries have been requested
984 call open_boundary_dealloc(obc)
985 endif
986
987end subroutine open_boundary_config
988
989!> Setup vertical remapping for open boundaries
990subroutine open_boundary_setup_vert(GV, US, OBC)
991 type(verticalgrid_type), intent(in) :: gv !< Container for vertical grid information
992 type(unit_scale_type), intent(in) :: us !< A dimensional unit scaling type
993 type(ocean_obc_type), pointer :: obc !< Open boundary control structure
994
995 ! Local variables
996 real :: dz_neglect, dz_neglect_edge ! Small thicknesses in vertical height units [Z ~> m]
997
998 if (associated(obc)) then
999 if (obc%number_of_segments > 0) then
1000 ! Set up vertical remapping for open boundaries. Remapping happens independently on each PE,
1001 ! so this block could be skipped for PEs without open boundary conditions that use remapping.
1002 if (gv%Boussinesq .and. (obc%remap_answer_date < 20190101)) then
1003 dz_neglect = us%m_to_Z * 1.0e-30 ; dz_neglect_edge = us%m_to_Z * 1.0e-10
1004 elseif (gv%semi_Boussinesq .and. (obc%remap_answer_date < 20190101)) then
1005 dz_neglect = gv%kg_m2_to_H*gv%H_to_Z * 1.0e-30 ; dz_neglect_edge = gv%kg_m2_to_H*gv%H_to_Z * 1.0e-10
1006 else
1007 dz_neglect = gv%dZ_subroundoff ; dz_neglect_edge = gv%dZ_subroundoff
1008 endif
1009 allocate(obc%remap_z_CS)
1010 call initialize_remapping(obc%remap_z_CS, obc%remappingScheme, boundary_extrapolation=.false., &
1011 check_reconstruction=obc%check_reconstruction, check_remapping=obc%check_remapping, &
1012 om4_remap_via_sub_cells=obc%om4_remap_via_sub_cells, &
1013 force_bounds_in_subcell=obc%force_bounds_in_subcell, answer_date=obc%remap_answer_date, &
1014 h_neglect=dz_neglect, h_neglect_edge=dz_neglect_edge)
1015 allocate(obc%remap_h_CS)
1016 call initialize_remapping(obc%remap_h_CS, obc%remappingScheme, boundary_extrapolation=.false., &
1017 check_reconstruction=obc%check_reconstruction, check_remapping=obc%check_remapping, &
1018 om4_remap_via_sub_cells=obc%om4_remap_via_sub_cells, &
1019 force_bounds_in_subcell=obc%force_bounds_in_subcell, answer_date=obc%remap_answer_date, &
1020 h_neglect=gv%H_subroundoff, h_neglect_edge=gv%H_subroundoff)
1021 endif
1022 endif
1023
1024end subroutine open_boundary_setup_vert
1025
1026!> Determine which physical fields are required for this segment based on boundary-condition type
1027!! and segment orientation. Also enable groups of physical fields required by tides or thermodynamics.
1028!! Note the tidal group could be further narrowed based on modes.
1029subroutine segment_determine_required_fields(segment, tides, temp_salt)
1030 type(obc_segment_type), intent(inout) :: segment !< OBC segment
1031 logical, optional, intent(in) :: tides !< Switch for tidal variables
1032 logical, optional, intent(in) :: temp_salt !< Switch for thermodynamic variables
1033
1034 ! Local variables
1035 logical :: use_tide ! Local switch for tidal variables
1036 logical :: use_temp ! Local switch for thermodynamic variables
1037 integer :: m
1038 integer :: F_Vn, F_Vt, F_G
1039 integer, parameter :: &
1040 tide_idx(6) = (/ f_uamp, f_uphase, f_vamp, f_vphase, f_zamp, f_zphase /), & ! Indices for tides
1041 temp_idx(2) = (/ f_t, f_s /) ! Indices for thermodynamics
1042
1043 if (.not. associated(segment%field)) &
1044 call mom_error(fatal, 'segment_determine_required_fields: segment%field is not allocated.')
1045
1046 use_tide = .false. ; if (present(tides)) use_tide = tides
1047 use_temp = .false. ; if (present(temp_salt)) use_temp = temp_salt
1048
1049 ! Normal, tangential and gradient depend on segment orientation.
1050 if (segment%is_E_or_W_2) then
1051 f_vn = f_u ; f_vt = f_v ; f_g = f_vx
1052 else
1053 f_vn = f_v ; f_vt = f_u ; f_g = f_uy
1054 endif
1055 if (segment%Flather) &
1056 segment%field(f_z)%required = .true.
1057
1058 if (segment%Flather .or. segment%nudged .or. segment%specified) &
1059 segment%field(f_vn)%required = .true.
1060
1061 if (segment%nudged_tan .or. segment%specified_tan) &
1062 segment%field(f_vt)%required = .true.
1063
1064 if (segment%nudged_grad .or. segment%specified_grad) &
1065 segment%field(f_g)%required = .true.
1066
1067 if (use_tide) then ; do m = 1, size(tide_idx)
1068 segment%field(tide_idx(m))%required = .true.
1069 enddo ; endif
1070
1071 if (use_temp) then ; do m = 1, size(temp_idx)
1072 segment%field(temp_idx(m))%required = .true.
1073 enddo ; endif
1074
1076
1077!> Find physical field index from name
1078integer function find_phys_field_index(name)
1079 character(len=*), intent(in) :: name !< Field name
1080
1081 ! Local variables
1082 integer :: i
1083
1085 do i = 1, num_phys_fields ; if (trim(name) == phys_field_names(i)) then
1087 return
1088 endif ; enddo
1089end function find_phys_field_index
1090
1091!> Set global flag OBC%any_needs_IO_for_data.
1092subroutine obc_any_io(OBC)
1093 type(ocean_obc_type), intent(inout) :: OBC !< Open boundary control structure
1094
1095 ! Local variables
1096 integer :: m, n
1097 logical :: use_IO
1098
1099 use_io = .false.
1100 do n=1,obc%number_of_segments
1101 do m=1,obc%segment(n)%num_fields
1102 if (obc%segment(n)%field(m)%use_IO) then
1103 use_io = .true.
1104 exit
1105 endif
1106 enddo
1107 if (use_io) exit
1108 enddo
1109
1110 obc%any_needs_IO_for_data = any_across_pes(use_io)
1111end subroutine obc_any_io
1112
1113!> Allocate data (buffer_src, buffer_dst and dz_src) for a field at an OBC segment.
1114subroutine allocate_segment_field_data(field, OBC, segment, US, inputdir, filename, varname, &
1115 suffix, value, turns, nz)
1116 type(obc_segment_data_type), &
1117 intent(inout) :: field !< A field of the segment
1118 type(ocean_obc_type), intent(in) :: OBC !< Open boundary control structure
1119 type(obc_segment_type), intent(inout) :: segment !< Segment to work on
1120 type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
1121 character(len=*), intent(in) :: inputdir !< The directory of input files
1122 character(len=*), intent(in) :: filename !< Input file name
1123 character(len=*), intent(in) :: varname !< Variable name in the input file
1124 character(len=*), intent(in) :: suffix !< Variable name suffix, "_segment_xxx"
1125 real, intent(in) :: value !< Unscaled specified value of the field [a]
1126 integer, intent(in) :: turns !< Number of quarter turns of the grid
1127 integer, intent(in) :: nz !< Default k-axis size in buffer_dst
1128
1129 ! Local variables
1130 character(len=256) :: full_filename, full_varname ! Full filename and varname
1131 character(len=512) :: mesg ! Error message
1132 real :: init_value_dst ! Initial value for allocated buffer_dst array [a]
1133 integer :: qturns ! The number of quarter turns in the range of 0 to 3
1134 integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB ! Aliases of segment geometry indices
1135 integer, dimension(4) :: siz, siz_check ! Four-dimensional shape of a variable in input file
1136 integer :: dim ! Loop index for siz/siz_check
1137 integer :: nk_dst ! k-axis size of buffer_dst
1138
1139 if (.not. segment%on_pe) return
1140
1141 isd = segment%HI%isd ; ied = segment%HI%ied ; isdb = segment%HI%IsdB ; iedb = segment%HI%IedB
1142 jsd = segment%HI%jsd ; jed = segment%HI%jed ; jsdb = segment%HI%JsdB ; jedb = segment%HI%JedB
1143 nk_dst = nz
1144
1145 qturns = modulo(turns, 4)
1146
1147 field%on_face = field_is_on_face(field%name, segment%is_E_or_W)
1148 ! The scale factor for tracers may also be set in register_segment_tracer, and a constant input
1149 ! value is rescaled there.
1150 field%scale = scale_factor_from_name(field%name, us, segment%tr_Reg)
1151 field%use_IO = (trim(filename) /= 'none')
1152
1153 if (field%use_IO) then
1154 full_filename = trim(inputdir) // trim(filename)
1155 full_varname = trim(varname) // trim(suffix)
1156
1157 if (.not.file_exists(full_filename)) &
1158 call mom_error(fatal," Unable to open OBC file " // trim(full_filename))
1159
1160 call field_size(full_filename, full_varname, siz, no_domain=.true.)
1161 field%nk_src = siz(3)
1162
1163 if (obc%brushcutter_mode .and. (modulo(siz(1),2) == 0 .or. modulo(siz(2),2) == 0)) then
1164 write(mesg, '("Brushcutter mode sizes ",I0," ",I0)') siz(1), siz(2)
1165 call mom_error(warning, mesg // " " // trim(full_filename) // " " // trim(full_varname))
1166 call mom_error(fatal,'segment data are not on the supergrid')
1167 endif
1168
1169 ! Allocate src array
1170 if (.not.field%on_face) then
1171 allocate(field%buffer_src(isdb:iedb, jsdb:jedb, field%nk_src), source=0.0)
1172 elseif (segment%is_E_or_W) then
1173 allocate(field%buffer_src(isdb:iedb, jsd:jed, field%nk_src), source=0.0)
1174 else
1175 allocate(field%buffer_src(isd:ied, jsdb:jedb, field%nk_src), source=0.0)
1176 endif
1177
1178 field%handle = init_external_field(trim(full_filename), trim(full_varname), &
1179 ignore_axis_atts=.true., threading=single_file)
1180
1181 if ((field%nk_src > 1) .and. (.not. field_is_tidal(field%name))) then ! nk_src is depth
1182 full_varname = 'dz_' // trim(full_varname)
1183 call field_size(full_filename, full_varname, siz_check, no_domain=.true.)
1184 do dim = 1, 4 ; if (siz(dim) /= siz_check(dim)) &
1185 call mom_error(fatal, "'dz' field size is inconsistent with "//&
1186 "its corresponding variable.")
1187 enddo
1188
1189 if (.not.field%on_face) then
1190 allocate(field%dz_src(isdb:iedb, jsdb:jedb, field%nk_src), source=0.0)
1191 elseif (segment%is_E_or_W) then
1192 allocate(field%dz_src(isdb:iedb, jsd:jed, field%nk_src), source=0.0)
1193 else
1194 allocate(field%dz_src(isd:ied, jsdb:jedb, field%nk_src), source=0.0)
1195 endif
1196 field%dz_handle = init_external_field(trim(full_filename), trim(full_varname), &
1197 ignore_axis_atts=.true., threading=single_file)
1198
1199 elseif (field_is_tidal(field%name)) then ! nk_src is constituent for tidal variables
1200 ! expect third dimension to be number of constituents in MOM_input
1201 if (obc%add_tide_constituents .and. (field%nk_src /= obc%n_tide_constituents)) &
1202 call mom_error(fatal, 'Number of constituents in input data is not '//&
1203 'the same as the number specified')
1204 nk_dst = field%nk_src
1205
1206 else ! nk_src = 1
1207 nk_dst = 1
1208
1209 endif
1210
1211 init_value_dst = 0.0
1212 else ! This data is not being read from a file.
1213 field%value = field%scale * value
1214 ! Change the sign of the specified velocities, depending on the number of quarter turns of the grid.
1215 if ( ( ((field%name == 'U') .or. (field%name == 'Uamp')) .and. &
1216 ((qturns == 1) .or. (qturns == 2)) ) .or. &
1217 ( ((field%name == 'V') .or. (field%name == 'Vamp')) .and. &
1218 ((qturns == 3) .or. (qturns == 2)) ) ) &
1219 field%value = -field%value
1220
1221 ! Check if this is a tidal field. If so, the number of expected constituents must be 1.
1222 if (field_is_tidal(field%name)) then
1223 if (obc%add_tide_constituents .and. (obc%n_tide_constituents > 1)) &
1224 call mom_error(fatal, 'Only one constituent is supported when specifying '//&
1225 'tidal boundary conditions by value rather than file.')
1226 nk_dst = 1
1227 endif
1228
1229 if (field%name == 'SSH') &
1230 nk_dst = 1
1231
1232 init_value_dst = field%value
1233 endif
1234
1235 ! Allocate buffer_dst array
1236 if (.not.field%on_face) then
1237 allocate(field%buffer_dst(isdb:iedb, jsdb:jedb, nk_dst), source=init_value_dst)
1238 elseif (segment%is_E_or_W) then
1239 allocate(field%buffer_dst(isdb:iedb, jsd:jed, nk_dst), source=init_value_dst)
1240 else
1241 allocate(field%buffer_dst(isd:ied, jsdb:jedb, nk_dst), source=init_value_dst)
1242 endif
1243end subroutine allocate_segment_field_data
1244
1245!> Get and store properties about the fields on the OBC segments and allocate space for reading
1246!! OBC data from files. In the process, it does funky stuff with the MPI processes.
1247subroutine initialize_segment_data(GV, US, OBC, PF, turns, use_temperature)
1248 type(verticalgrid_type), intent(in) :: gv !< Container for vertical grid information
1249 type(unit_scale_type), intent(in) :: us !< A dimensional unit scaling type
1250 type(ocean_obc_type), target, intent(inout) :: obc !< Open boundary control structure
1251 type(param_file_type), intent(in) :: pf !< Parameter file handle
1252 integer, intent(in) :: turns !< Number of quarter turns of the grid
1253 logical, intent(in) :: use_temperature !< If true, temperature and
1254 !! salinity used as state variables.
1255
1256 ! Local variables
1257 integer :: n, n_seg, m, num_manifest_fields, mm
1258 character(len=1024) :: segstr
1259 character(len=256) :: filename
1260 character(len=20) :: segname, suffix
1261 character(len=32) :: varname
1262 real :: value ! A value that is parsed from the segment data string [various units]
1263 character(len=32), dimension(NUM_PHYS_FIELDS) :: phys_inputs ! input physical field names
1264 integer, dimension(NUM_PHYS_FIELDS) :: phys_idx ! input physical field indices to PHYS_FIELD_NAMES
1265 character(len=32) :: bgc_input ! segment field names
1266 character(len=128) :: inputdir
1267 type(obc_segment_type), pointer :: segment => null() ! pointer to segment type list
1268 character(len=256) :: mesg ! Message for error messages.
1269 integer, dimension(:), allocatable :: saved_pelist
1270 integer :: current_pe
1271 integer, dimension(1) :: single_pelist
1272 type(external_tracers_segments_props), pointer :: obgc_segments_props_list =>null()
1273 logical :: check_ts_needed ! Check if temperature and salinity are explicitly specified.
1274 integer :: idx
1275 character(len=256) :: routine_name ! Name of this subroutine
1276
1277 if (obc%user_BCs_set_globally) return
1278
1279 routine_name = trim(mdl) // ', initialize_segment_data'
1280
1281 obc%update_OBC = .true. ! Data is time-dependent if not using user BC.
1282
1283 check_ts_needed = use_temperature .and. (.not. obc%ts_needed_bug)
1284
1285 call get_param(pf, mdl, "INPUTDIR", inputdir, default=".")
1286 inputdir = slasher(inputdir)
1287
1288 ! Try this here just for the documentation. It is repeated below.
1289 do n=1,obc%number_of_segments
1290 write(segname, "('OBC_SEGMENT_',i3.3,'_DATA')") n
1291 call get_param(pf, mdl, segname, segstr, 'OBC segment docs')
1292 enddo
1293
1294 !< temporarily disable communication in order to read segment data independently
1295
1296 allocate(saved_pelist(0:num_pes()-1))
1297 call get_pelist(saved_pelist)
1298 current_pe = pe_here()
1299 single_pelist(1) = current_pe
1300 call set_pelist(single_pelist)
1301
1302 do n=1,obc%number_of_segments
1303 n_seg = n ; if (obc%reverse_segment_order) n_seg = obc%number_of_segments + 1 - n
1304 segment => obc%segment(n_seg)
1305
1306 if (.not. segment%on_pe) cycle
1307
1308 write(segname, "('OBC_SEGMENT_',i3.3,'_DATA')") n
1309 write(suffix, "('_segment_',i3.3)") n
1310 ! needs documentation !! Yet, unsafe for now, causes grief for
1311 ! MOM_parameter_docs in circle_obcs on two processes.
1312 ! call get_param(PF, mdl, segname, segstr, 'xyz')
1313 ! Clear out any old values
1314 segstr = ''
1315 call get_param(pf, mdl, segname, segstr)
1316 if (segstr == '') then
1317 write(mesg,'("No OBC_SEGMENT_XXX_DATA string for OBC segment ",I0)') n
1318 call mom_error(fatal, mesg)
1319 endif
1320
1321 segment%num_fields = num_phys_fields + obc%num_obgc_tracers
1322 allocate(segment%field(segment%num_fields))
1323
1324 ! Initialize physical fields
1325 do m = 1, num_phys_fields
1326 segment%field(m)%name = phys_field_names(m) ! The order of physical fields is fixed.
1327 segment%field(m)%bgc_tracer = .false.
1328 segment%field(m)%required = .false.
1329 segment%field(m)%use_IO = .false.
1330 segment%field(m)%tr_index = -1
1331 enddo
1332 segment%field(f_t)%tr_index = 1 ! Temperature tracer index is hard-coded.
1333 segment%field(f_s)%tr_index = 2 ! Salinity tracer index is hard-coded.
1334
1335 call segment_determine_required_fields(segment, tides=obc%add_tide_constituents, &
1336 temp_salt=check_ts_needed)
1337
1338 ! Parse and find available physical fields
1339 call parse_segment_manifest_str(trim(segstr), num_manifest_fields, phys_inputs)
1340
1341 phys_idx(:) = -1
1342 do m = 1, num_manifest_fields
1343 idx = find_phys_field_index(rotated_field_name(trim(phys_inputs(m)), turns))
1344 if (idx == 0) then
1345 write(mesg,'("OBC segment ",I0," has an unknown input field: ",a)') n, trim(phys_inputs(m))
1346 call mom_error(fatal, trim(routine_name) // ", " // trim(mesg))
1347 endif
1348 if ((.not. segment%field(idx)%required) .and. &
1349 ((.not. (idx == f_t .or. idx == f_s)) .or. check_ts_needed)) then
1350 write(mesg,'("OBC segment ",I0," has an unnecessary field: ",a)') &
1351 n, trim(phys_inputs(m))
1352 call mom_error(warning, trim(mesg))
1353 ! Unnecessary field is allowed and allocated for now.
1354 ! Otherwise, the next line can be uncommented.
1355 ! cycle
1356 endif
1357 phys_idx(idx) = m
1358 enddo
1359
1360 ! Allocate physical fields
1361 do m = 1, num_phys_fields
1362 if (segment%field(m)%required .and. (phys_idx(m) < 0)) then
1363 write(mesg,'("OBC segment ",I0," requires field: ",a)') n, trim(segment%field(m)%name)
1364 call mom_error(fatal, trim(routine_name) // ", " // trim(mesg))
1365 endif
1366 if ((phys_idx(m) > 0)) then ! Field is found in input, even if not required
1367 call parse_segment_data_str(trim(segstr), phys_idx(m), trim(phys_inputs(phys_idx(m))), &
1368 value, filename, varname)
1369 call allocate_segment_field_data(segment%field(m), obc, segment, us, &
1370 inputdir, filename, varname, suffix, value, turns, gv%ke)
1371 endif
1372 enddo
1373
1374 ! Allocate BGC tracer fields
1375 obgc_segments_props_list => obc%obgc_segments_props ! pointer to the head node
1376 do m = num_phys_fields+1, segment%num_fields
1377 segment%field(m)%bgc_tracer = .true.
1378 ! Query the obgc segment properties by traversing the linked list
1379 call get_obgc_segments_props(obgc_segments_props_list, bgc_input, filename, varname, &
1380 segment%field(m)%resrv_lfac_in, segment%field(m)%resrv_lfac_out)
1381 ! Make sure the obgc tracer is not specified in the MOM6 param file too.
1382 do mm=1,num_manifest_fields ; if (trim(bgc_input) == trim(phys_inputs(mm))) then
1383 write(mesg,'("Input parameter for OBC segment ",I0," contains a BGC tracer: ", A)') &
1384 n, trim(bgc_input)
1385 call mom_error(fatal, trim(routine_name) // ", " // trim(mesg))
1386 endif ; enddo
1387 segment%field(m)%name = rotated_field_name(bgc_input, turns)
1388 segment%field(m)%tr_index = get_tracer_index(segment, trim(segment%field(m)%name))
1389 call allocate_segment_field_data(segment%field(m), obc, segment, us, &
1390 inputdir, filename, varname, suffix, 0.0, turns, gv%ke)
1391 enddo
1392
1393 ! write(stderr, '(A)') trim(suffix)//" segment checksum"
1394 if (obc%debug) call chksum_obc_segment_data(obc%segment(n_seg), gv, us, obc%nk_OBC_debug, n)
1395
1396 enddo ! n-loop for segments
1397
1398 call set_pelist(saved_pelist)
1399
1400 ! Determine global IO data requirement patterns.
1401 call obc_any_io(obc)
1402end subroutine initialize_segment_data
1403
1404!> Determine whether a particular field is descretized at the normal-velocity faces of an open
1405!! boundary condition segment.
1406logical function field_is_on_face(name, is_E_or_W)
1407 character(len=*), intent(in) :: name !< The OBC segment data name to interpret
1408 logical, intent(in) :: is_e_or_w !< This is true for an eastern or western open boundary condition
1409
1410 field_is_on_face = .true.
1411 if (is_e_or_w) then
1412 if ((name == 'V') .or. (name == 'Vamp') .or. (name == 'Vphase') .or. (name == 'DVDX')) &
1413 field_is_on_face = .false.
1414 else
1415 if ((name == 'U') .or. (name == 'Uamp') .or. (name == 'Uphase') .or. (name == 'DUDY')) &
1416 field_is_on_face = .false.
1417 endif
1418end function field_is_on_face
1419
1420!> Determine based on its name whether a particular field a barotropic tidal field, for which the
1421!! third dimension is the tidal constituent rather than a vertical axis
1422logical function field_is_tidal(name)
1423 character(len=*), intent(in) :: name !< The OBC segment data name to interpret
1424
1425 field_is_tidal = ((index(name, 'phase') > 0) .or. (index(name, 'amp') > 0))
1426end function field_is_tidal
1427
1428!> This subroutine sets the sign of the OBC%segnum_u and OBC%segnum_v arrays to indicate the
1429!! direction of the faces - positive for logically eastern or northern OBCs and neagative
1430!! for logically western or southern OBCs, or zero on non-OBC points. Also store information
1431!! about which orientations of OBCs ar on this PE and the range of indices within which the
1432!! various orientations of OBCs can be found on this PE.
1433subroutine set_segnum_signs(OBC, G)
1434 type(ocean_obc_type), intent(inout) :: OBC !< Open boundary control structure, perhaps on a rotated grid.
1435 type(dyn_horgrid_type), intent(in) :: G !< Ocean grid structure used by OBC
1436
1437 integer :: i, j
1438
1439 obc%u_OBCs_on_PE = .false. ; obc%v_OBCs_on_PE = .false.
1440 do j=g%jsd,g%jed ; do i=g%IsdB,g%IedB
1441 obc%segnum_u(i,j) = abs(obc%segnum_u(i,j))
1442 if (abs(obc%segnum_u(i,j)) > 0) then
1443 obc%u_OBCs_on_PE = .true.
1444 if (obc%segment(abs(obc%segnum_u(i,j)))%direction == obc_direction_w) &
1445 obc%segnum_u(i,j) = -abs(obc%segnum_u(i,j))
1446 endif
1447 enddo ; enddo
1448 do j=g%JsdB,g%JedB ; do i=g%isd,g%ied
1449 obc%segnum_v(i,j) = abs(obc%segnum_v(i,j))
1450 if (abs(obc%segnum_v(i,j)) > 0) then
1451 obc%v_OBCs_on_PE = .true.
1452 if (obc%segment(abs(obc%segnum_v(i,j)))%direction == obc_direction_s) &
1453 obc%segnum_v(i,j) = -abs(obc%segnum_v(i,j))
1454 endif
1455 enddo ; enddo
1456
1457 ! Determine the maximum and minimum index range for various directions of OBC points on this PE
1458 ! by first setting these one point outside of the wrong side of the domain.
1459 obc%Is_u_W_obc = g%IedB + 1 ; obc%Ie_u_W_obc = g%IsdB - 1
1460 obc%js_u_W_obc = g%jed + 1 ; obc%je_u_W_obc = g%jsd - 1
1461 obc%Is_u_E_obc = g%IedB + 1 ; obc%Ie_u_E_obc = g%IsdB - 1
1462 obc%js_u_E_obc = g%jed + 1 ; obc%je_u_E_obc = g%jsd - 1
1463 obc%is_v_S_obc = g%ied + 1 ; obc%ie_v_S_obc = g%isd - 1
1464 obc%Js_v_S_obc = g%JedB + 1 ; obc%Je_v_S_obc = g%JsdB - 1
1465 obc%is_v_N_obc = g%ied + 1 ; obc%ie_v_N_obc = g%isd - 1
1466 obc%Js_v_N_obc = g%JedB + 1 ; obc%Je_v_N_obc = g%JsdB - 1
1467 obc%v_N_OBCs_on_PE = .false. ; obc%v_S_OBCs_on_PE = .false.
1468 obc%u_E_OBCs_on_PE = .false. ; obc%u_W_OBCs_on_PE = .false.
1469 ! Note that the loop ranges are reduced because outward facing OBCs can not be applied at edge points.
1470 do j=g%jsd,g%jed ; do i=g%IsdB,g%IedB-1
1471 if (obc%segnum_u(i,j) < 0) then ! This point has OBC_DIRECTION_W.
1472 obc%Is_u_W_obc = min(i, obc%Is_u_W_obc) ; obc%Ie_u_W_obc = max(i, obc%Ie_u_W_obc)
1473 obc%js_u_W_obc = min(j, obc%js_u_W_obc) ; obc%je_u_W_obc = max(j, obc%je_u_W_obc)
1474 obc%u_W_OBCs_on_PE = .true.
1475 endif
1476 enddo ; enddo
1477 do j=g%jsd,g%jed ; do i=g%IsdB+1,g%IedB
1478 if (obc%segnum_u(i,j) > 0) then ! This point has OBC_DIRECTION_E.
1479 obc%Is_u_E_obc = min(i, obc%Is_u_E_obc) ; obc%Ie_u_E_obc = max(i, obc%Ie_u_E_obc)
1480 obc%js_u_E_obc = min(j, obc%js_u_E_obc) ; obc%je_u_E_obc = max(j, obc%je_u_E_obc)
1481 obc%u_E_OBCs_on_PE = .true.
1482 endif
1483 enddo ; enddo
1484 do j=g%JsdB,g%JedB-1 ; do i=g%isd,g%ied
1485 if (obc%segnum_v(i,j) < 0) then ! This point has OBC_DIRECTION_S.
1486 obc%is_v_S_obc = min(i, obc%is_v_S_obc) ; obc%ie_v_S_obc = max(i, obc%ie_v_S_obc)
1487 obc%Js_v_S_obc = min(j, obc%Js_v_S_obc) ; obc%Je_v_S_obc = max(j, obc%Je_v_S_obc)
1488 obc%v_S_OBCs_on_PE = .true.
1489 endif
1490 enddo ; enddo
1491 do j=g%JsdB+1,g%JedB ; do i=g%isd,g%ied
1492 if (obc%segnum_v(i,j) > 0) then ! This point has OBC_DIRECTION_N.
1493 obc%is_v_N_obc = min(i, obc%is_v_N_obc) ; obc%ie_v_N_obc = max(i, obc%ie_v_N_obc)
1494 obc%Js_v_N_obc = min(j, obc%Js_v_N_obc) ; obc%Je_v_N_obc = max(j, obc%Je_v_N_obc)
1495 obc%v_N_OBCs_on_PE = .true.
1496 endif
1497 enddo ; enddo
1498
1499end subroutine set_segnum_signs
1500
1501!> Return an appropriate dimensional scaling factor for input data based on an OBC segment data
1502!! name [various ~> 1], or 1 for tracers or other fields that do not match one of the specified names.
1503!! Note that calls to register_segment_tracer can come before or after calls to scale_factor_from_name.
1504
1505real function scale_factor_from_name(name, US, Tr_Reg)
1506 character(len=*), intent(in) :: name !< The OBC segment data name to interpret
1507 type(unit_scale_type), intent(in) :: us !< A dimensional unit scaling type
1508 type(segment_tracer_registry_type), pointer :: tr_reg !< pointer to tracer registry for this segment
1509
1510 integer :: m
1511
1512 select case (trim(name))
1513 case ('U') ; scale_factor_from_name = us%m_s_to_L_T
1514 case ('V') ; scale_factor_from_name = us%m_s_to_L_T
1515 case ('Uamp') ; scale_factor_from_name = us%m_s_to_L_T
1516 case ('Vamp') ; scale_factor_from_name = us%m_s_to_L_T
1517 case ('DVDX') ; scale_factor_from_name = us%T_to_s
1518 case ('DUDY') ; scale_factor_from_name = us%T_to_s
1519 case ('SSH') ; scale_factor_from_name = us%m_to_Z
1520 case ('SSHamp') ; scale_factor_from_name = us%m_to_Z
1521 case default ; scale_factor_from_name = 1.0
1522 end select
1523
1524 if (associated(tr_reg) .and. (scale_factor_from_name == 1.0)) then
1525 ! Check for name matches with previously registered tracers.
1526 do m=1,tr_reg%ntseg
1527 if (uppercase(name) == uppercase(tr_reg%Tr(m)%name)) then
1528 scale_factor_from_name = tr_reg%Tr(m)%scale
1529 exit
1530 endif
1531 enddo
1532 endif
1533
1534end function scale_factor_from_name
1535
1536!> Initize parameters and fields related to the specification of tides at open boundaries.
1537subroutine initialize_obc_tides(OBC, US, param_file)
1538 type(ocean_obc_type), intent(inout) :: OBC !< Open boundary control structure
1539 type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
1540 type(param_file_type), intent(in) :: param_file !< Parameter file handle
1541 integer, dimension(3) :: tide_ref_date !< Reference date (t = 0) for tidal forcing (year, month, day).
1542 integer, dimension(3) :: nodal_ref_date !< Date to calculate nodal modulation for (year, month, day).
1543 character(len=50) :: tide_constituent_str !< List of tidal constituents to include on boundary.
1544 type(astro_longitudes) :: nodal_longitudes !< Solar and lunar longitudes for tidal forcing
1545 type(time_type) :: nodal_time !< Model time to calculate nodal modulation for.
1546 integer :: c !< Index to tidal constituent.
1547 logical :: tides !< True if astronomical tides are also used.
1548
1549 call get_param(param_file, mdl, "OBC_TIDE_CONSTITUENTS", tide_constituent_str, &
1550 "Names of tidal constituents being added to the open boundaries.", &
1551 fail_if_missing=.true.)
1552
1553 call get_param(param_file, mdl, "TIDES", tides, &
1554 "If true, apply tidal momentum forcing.", default=.false., do_not_log=.true.)
1555
1556 call get_param(param_file, mdl, "TIDE_USE_EQ_PHASE", obc%add_eq_phase, &
1557 "If true, add the equilibrium phase argument to the specified tidal phases.", &
1558 old_name="OBC_TIDE_ADD_EQ_PHASE", default=.false., do_not_log=tides)
1559
1560 call get_param(param_file, mdl, "TIDE_ADD_NODAL", obc%add_nodal_terms, &
1561 "If true, include 18.6 year nodal modulation in the boundary tidal forcing.", &
1562 old_name="OBC_TIDE_ADD_NODAL", default=.false., do_not_log=tides)
1563
1564 call get_param(param_file, mdl, "TIDE_REF_DATE", tide_ref_date, &
1565 "Reference date to use for tidal calculations and equilibrium phase.", &
1566 old_name="OBC_TIDE_REF_DATE", defaults=(/0, 0, 0/), do_not_log=tides)
1567
1568 call get_param(param_file, mdl, "TIDE_NODAL_REF_DATE", nodal_ref_date, &
1569 "Fixed reference date to use for nodal modulation of boundary tides.", &
1570 old_name="OBC_TIDE_NODAL_REF_DATE", defaults=(/0, 0, 0/), do_not_log=tides)
1571
1572 allocate(obc%tide_names(obc%n_tide_constituents))
1573 read(tide_constituent_str, *) obc%tide_names
1574
1575 ! Set reference time (t = 0) for boundary tidal forcing.
1576 if (sum(tide_ref_date) == 0) then ! tide_ref_date defaults to 0.
1577 obc%time_ref = set_date(1, 1, 1, 0, 0, 0)
1578 else
1579 if (.not. obc%add_eq_phase) then
1580 ! If equilibrium phase argument is not added, the input phases
1581 ! should already be relative to the reference time.
1582 call mom_mesg('OBC tidal phases will *not* be corrected with equilibrium arguments.')
1583 endif
1584 obc%time_ref = set_date(tide_ref_date(1), tide_ref_date(2), tide_ref_date(3), 0, 0, 0)
1585 endif
1586
1587 ! Find relevant lunar and solar longitudes at the reference time
1588 if (obc%add_eq_phase) call astro_longitudes_init(obc%time_ref, obc%tidal_longitudes)
1589
1590 ! If the nodal correction is based on a different time, initialize that.
1591 ! Otherwise, it can use N from the time reference.
1592 if (obc%add_nodal_terms) then
1593 if (sum(nodal_ref_date) /= 0) then
1594 ! A reference date was provided for the nodal correction
1595 nodal_time = set_date(nodal_ref_date(1), nodal_ref_date(2), nodal_ref_date(3), 0, 0, 0)
1596 call astro_longitudes_init(nodal_time, nodal_longitudes)
1597 elseif (obc%add_eq_phase) then
1598 ! Astronomical longitudes were already calculated for use in equilibrium phases,
1599 ! so use nodal longitude from that.
1600 nodal_longitudes = obc%tidal_longitudes
1601 else
1602 ! Tidal reference time is a required parameter, so calculate the longitudes from that.
1603 call astro_longitudes_init(obc%time_ref, nodal_longitudes)
1604 endif
1605 endif
1606
1607 allocate(obc%tide_frequencies(obc%n_tide_constituents))
1608 allocate(obc%tide_eq_phases(obc%n_tide_constituents))
1609 allocate(obc%tide_fn(obc%n_tide_constituents))
1610 allocate(obc%tide_un(obc%n_tide_constituents))
1611
1612 do c=1,obc%n_tide_constituents
1613 ! If tidal frequency is overridden by setting TIDE_*_FREQ, use that, otherwise use the
1614 ! default realistic frequency for this constituent.
1615 call get_param(param_file, mdl, "TIDE_"//trim(obc%tide_names(c))//"_FREQ", obc%tide_frequencies(c), &
1616 "Frequency of the "//trim(obc%tide_names(c))//" tidal constituent. "//&
1617 "This is only used if TIDES and TIDE_"//trim(obc%tide_names(c))// &
1618 " are true, or if OBC_TIDE_N_CONSTITUENTS > 0 and "//trim(obc%tide_names(c))//&
1619 " is in OBC_TIDE_CONSTITUENTS.", &
1620 units="rad s-1", default=tidal_frequency(trim(obc%tide_names(c))), scale=us%T_to_s)
1621
1622 ! Find equilibrium phase if needed
1623 if (obc%add_eq_phase) then
1624 obc%tide_eq_phases(c) = eq_phase(trim(obc%tide_names(c)), obc%tidal_longitudes)
1625 else
1626 obc%tide_eq_phases(c) = 0.0
1627 endif
1628
1629 ! Find nodal corrections if needed
1630 if (obc%add_nodal_terms) then
1631 call nodal_fu(trim(obc%tide_names(c)), nodal_longitudes%N, obc%tide_fn(c), obc%tide_un(c))
1632 else
1633 obc%tide_fn(c) = 1.0
1634 obc%tide_un(c) = 0.0
1635 endif
1636 enddo
1637end subroutine initialize_obc_tides
1638
1639!> Define indices for segment and store in hor_index_type
1640!! using global segment bounds corresponding to q-points
1641subroutine setup_segment_indices(G, seg, Is_obc, Ie_obc, Js_obc, Je_obc)
1642 type(dyn_horgrid_type), intent(in) :: G !< grid type
1643 type(obc_segment_type), intent(inout) :: seg !< Open boundary segment
1644 integer, intent(in) :: Is_obc !< Q-point global i-index of start of segment
1645 integer, intent(in) :: Ie_obc !< Q-point global i-index of end of segment
1646 integer, intent(in) :: Js_obc !< Q-point global j-index of start of segment
1647 integer, intent(in) :: Je_obc !< Q-point global j-index of end of segment
1648 ! Local variables
1649 integer :: IsgB, IegB, JsgB, JegB ! Global corner point indices at the ends of the OBC segments
1650 integer :: isg, ieg, jsg, jeg
1651
1652 ! Isg, Ieg will be I*_obc in global space
1653 if (ie_obc < is_obc) then
1654 isgb = ie_obc
1655 iegb = is_obc
1656 else
1657 isgb = is_obc
1658 iegb = ie_obc
1659 endif
1660
1661 if (je_obc < js_obc) then
1662 jsgb = je_obc
1663 jegb = js_obc
1664 else
1665 jsgb = js_obc
1666 jegb = je_obc
1667 endif
1668
1669 ! NOTE: h-points are defined along the interior of the segment q-points.
1670 ! For a given segment and its start and end index pairs, [IJ][se]gB, the
1671 ! h-cell corresponding to this pair are shown in the figure below.
1672 !
1673 ! x-x----------------x-x
1674 ! | | N | |
1675 ! x-x W E x-x
1676 ! | S |
1677 ! x-x----------------x-x
1678 ! | | | |
1679 ! x-x x-x
1680 !
1681 ! For segment points on the west and south, h-point indices are incremented
1682 ! in order to move to the interior cell.
1683
1684 if (is_obc > ie_obc) then
1685 ! Northern boundary
1686 isg = isgb + 1
1687 jsg = jsgb
1688 ieg = iegb
1689 jeg = jegb
1690 endif
1691
1692 if (is_obc < ie_obc) then
1693 ! Southern boundary
1694 isg = isgb + 1
1695 jsg = jsgb + 1
1696 ieg = iegb
1697 jeg = jegb + 1
1698 endif
1699
1700 if (js_obc < je_obc) then
1701 ! Eastern boundary
1702 isg = isgb
1703 jsg = jsgb + 1
1704 ieg = iegb
1705 jeg = jegb
1706 endif
1707
1708 if (js_obc > je_obc) then
1709 ! Western boundary
1710 isg = isgb + 1
1711 jsg = jsgb + 1
1712 ieg = iegb + 1
1713 jeg = jegb
1714 endif
1715
1716 ! Global space I*_obc but sorted
1717 seg%HI%IsgB = isgb
1718 seg%HI%JegB = jegb
1719 seg%HI%IegB = iegb
1720 seg%HI%JsgB = jsgb
1721
1722 seg%HI%isg = isg
1723 seg%HI%jsg = jsg
1724 seg%HI%ieg = ieg
1725 seg%HI%jeg = jeg
1726
1727 ! Move into local index space
1728 isgb = isgb - g%idg_offset
1729 jsgb = jsgb - g%jdg_offset
1730 iegb = iegb - g%idg_offset
1731 jegb = jegb - g%jdg_offset
1732
1733 isg = isg - g%idg_offset
1734 jsg = jsg - g%jdg_offset
1735 ieg = ieg - g%idg_offset
1736 jeg = jeg - g%jdg_offset
1737
1738 ! This is the i-extent of the segment on this PE.
1739 ! The values are nonsense if the segment is not on this PE.
1740 seg%HI%IsdB = min(max(isgb, g%HI%IsdB), g%HI%IedB)
1741 seg%HI%IedB = min(max(iegb, g%HI%IsdB), g%HI%IedB)
1742 seg%HI%isd = min(max(isg, g%HI%isd), g%HI%ied)
1743 seg%HI%ied = min(max(ieg, g%HI%isd), g%HI%ied)
1744 seg%HI%IscB = min(max(isgb, g%HI%IscB), g%HI%IecB)
1745 seg%HI%IecB = min(max(iegb, g%HI%IscB), g%HI%IecB)
1746 seg%HI%isc = min(max(isg, g%HI%isc), g%HI%iec)
1747 seg%HI%iec = min(max(ieg, g%HI%isc), g%HI%iec)
1748
1749 ! This is the j-extent of the segment on this PE.
1750 ! The values are nonsense if the segment is not on this PE.
1751 seg%HI%JsdB = min(max(jsgb, g%HI%JsdB), g%HI%JedB)
1752 seg%HI%JedB = min(max(jegb, g%HI%JsdB), g%HI%JedB)
1753 seg%HI%jsd = min(max(jsg, g%HI%jsd), g%HI%jed)
1754 seg%HI%jed = min(max(jeg, g%HI%jsd), g%HI%jed)
1755 seg%HI%JscB = min(max(jsgb, g%HI%JscB), g%HI%JecB)
1756 seg%HI%JecB = min(max(jegb, g%HI%JscB), g%HI%JecB)
1757 seg%HI%jsc = min(max(jsg, g%HI%jsc), g%HI%jec)
1758 seg%HI%jec = min(max(jeg, g%HI%jsc), g%HI%jec)
1759
1760end subroutine setup_segment_indices
1761
1762!> Parse an OBC_SEGMENT_%%% string starting with "I=" and configure placement and type of OBC accordingly
1763subroutine setup_u_point_obc(OBC, G, US, segment_str, l_seg, l_seg_io, PF, reentrant_y)
1764 type(ocean_obc_type), intent(inout) :: OBC !< Open boundary control structure
1765 type(dyn_horgrid_type), intent(in) :: G !< Ocean grid structure
1766 type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
1767 character(len=*), intent(in) :: segment_str !< A string in form of "I=%,J=%:%,string"
1768 integer, intent(in) :: l_seg !< The internal segment number
1769 integer, intent(in) :: l_seg_io !< The segment number used for reading parameters
1770 type(param_file_type), intent(in) :: PF !< Parameter file handle
1771 logical, intent(in) :: reentrant_y !< is the domain reentrant in y?
1772 ! Local variables
1773 integer :: I_obc, Js_obc, Je_obc ! Position of segment in global index space
1774 integer :: j, a_loop
1775 character(len=32) :: action_str(8)
1776 character(len=128) :: segment_param_str
1777 real, allocatable, dimension(:) :: tnudge ! Nudging timescales [T ~> s]
1778 ! This returns the global indices for the segment
1779 call parse_segment_str(g%ieg, g%jeg, segment_str, i_obc, js_obc, je_obc, action_str, reentrant_y)
1780
1781 call setup_segment_indices(g, obc%segment(l_seg),i_obc,i_obc,js_obc,je_obc)
1782
1783 i_obc = i_obc - g%idg_offset ! Convert to local tile indices on this tile
1784 js_obc = js_obc - g%jdg_offset ! Convert to local tile indices on this tile
1785 je_obc = je_obc - g%jdg_offset ! Convert to local tile indices on this tile
1786
1787 if (je_obc>js_obc) then
1788 obc%segment(l_seg)%direction = obc_direction_e
1789 elseif (je_obc<js_obc) then
1790 obc%segment(l_seg)%direction = obc_direction_w
1791 j = js_obc ; js_obc = je_obc ; je_obc = j
1792 endif
1793
1794 obc%segment(l_seg)%on_pe = .false.
1795
1796 do a_loop = 1,8 ! up to 8 options available
1797 if (len_trim(action_str(a_loop)) == 0) then
1798 cycle
1799 elseif (trim(action_str(a_loop)) == 'FLATHER') then
1800 obc%segment(l_seg)%Flather = .true.
1801 obc%segment(l_seg)%open = .true.
1802 obc%Flather_u_BCs_exist_globally = .true.
1803 obc%open_u_BCs_exist_globally = .true.
1804 elseif (trim(action_str(a_loop)) == 'ORLANSKI') then
1805 obc%segment(l_seg)%radiation = .true.
1806 obc%segment(l_seg)%open = .true.
1807 obc%open_u_BCs_exist_globally = .true.
1808 obc%radiation_BCs_exist_globally = .true.
1809 elseif (trim(action_str(a_loop)) == 'ORLANSKI_TAN') then
1810 obc%segment(l_seg)%radiation = .true.
1811 obc%segment(l_seg)%radiation_tan = .true.
1812 obc%radiation_BCs_exist_globally = .true.
1813 elseif (trim(action_str(a_loop)) == 'ORLANSKI_GRAD') then
1814 obc%segment(l_seg)%radiation = .true.
1815 obc%segment(l_seg)%radiation_grad = .true.
1816 elseif (trim(action_str(a_loop)) == 'OBLIQUE') then
1817 obc%segment(l_seg)%oblique = .true.
1818 obc%segment(l_seg)%open = .true.
1819 obc%oblique_BCs_exist_globally = .true.
1820 obc%open_u_BCs_exist_globally = .true.
1821 elseif (trim(action_str(a_loop)) == 'OBLIQUE_TAN') then
1822 obc%segment(l_seg)%oblique = .true.
1823 obc%segment(l_seg)%oblique_tan = .true.
1824 obc%oblique_BCs_exist_globally = .true.
1825 elseif (trim(action_str(a_loop)) == 'OBLIQUE_GRAD') then
1826 obc%segment(l_seg)%oblique = .true.
1827 obc%segment(l_seg)%oblique_grad = .true.
1828 elseif (trim(action_str(a_loop)) == 'NUDGED') then
1829 obc%segment(l_seg)%nudged = .true.
1830 obc%nudged_u_BCs_exist_globally = .true.
1831 elseif (trim(action_str(a_loop)) == 'NUDGED_TAN') then
1832 obc%segment(l_seg)%nudged_tan = .true.
1833 obc%nudged_u_BCs_exist_globally = .true.
1834 elseif (trim(action_str(a_loop)) == 'NUDGED_GRAD') then
1835 obc%segment(l_seg)%nudged_grad = .true.
1836 elseif (trim(action_str(a_loop)) == 'GRADIENT') then
1837 obc%segment(l_seg)%gradient = .true.
1838 obc%segment(l_seg)%open = .true.
1839 obc%open_u_BCs_exist_globally = .true.
1840 elseif (trim(action_str(a_loop)) == 'SIMPLE') then
1841 obc%segment(l_seg)%specified = .true.
1842 obc%specified_u_BCs_exist_globally = .true. ! This avoids deallocation
1843 elseif (trim(action_str(a_loop)) == 'SIMPLE_TAN') then
1844 obc%segment(l_seg)%specified_tan = .true.
1845 elseif (trim(action_str(a_loop)) == 'SIMPLE_GRAD') then
1846 obc%segment(l_seg)%specified_grad = .true.
1847 else
1848 call mom_error(fatal, "MOM_open_boundary.F90, setup_u_point_obc: "//&
1849 "String '"//trim(action_str(a_loop))//"' not understood.")
1850 endif
1851 if (obc%segment(l_seg)%nudged .or. obc%segment(l_seg)%nudged_tan) then
1852 write(segment_param_str(1:43),"('OBC_SEGMENT_',i3.3,'_VELOCITY_NUDGING_TIMESCALES')") l_seg_io
1853 allocate(tnudge(2))
1854 call get_param(pf, mdl, segment_param_str(1:43), tnudge, &
1855 "Timescales in days for nudging along a segment, "//&
1856 "for inflow, then outflow. Setting both to zero should "//&
1857 "behave like SIMPLE obcs for the baroclinic velocities.", &
1858 fail_if_missing=.true., units="days", scale=86400.0*us%s_to_T)
1859 obc%segment(l_seg)%Velocity_nudging_timescale_in = tnudge(1)
1860 obc%segment(l_seg)%Velocity_nudging_timescale_out = tnudge(2)
1861 deallocate(tnudge)
1862 endif
1863
1864 enddo ! a_loop
1865
1866 obc%segment(l_seg)%is_E_or_W_2 = .true.
1867
1868 if (i_obc<=g%HI%IsdB+1 .or. i_obc>=g%HI%IedB-1) return ! Boundary is not on tile
1869 if (je_obc<=g%HI%JsdB .or. js_obc>=g%HI%JedB) return ! Segment is not on tile
1870
1871 obc%segment(l_seg)%on_pe = .true.
1872 obc%segment(l_seg)%is_E_or_W = .true.
1873
1874 do j=g%HI%jsd, g%HI%jed
1875 if (j>js_obc .and. j<=je_obc) then
1876 obc%segnum_u(i_obc,j) = l_seg
1877 if (obc%segment(l_seg)%direction == obc_direction_w) obc%segnum_u(i_obc,j) = -l_seg
1878 obc%u_OBCs_on_PE = .true.
1879 endif
1880 enddo
1881 obc%segment(l_seg)%Is_obc = i_obc
1882 obc%segment(l_seg)%Ie_obc = i_obc
1883 obc%segment(l_seg)%Js_obc = js_obc
1884 obc%segment(l_seg)%Je_obc = je_obc
1885 call allocate_obc_segment_data(obc, obc%segment(l_seg))
1886
1887 if (obc%segment(l_seg)%oblique .and. obc%segment(l_seg)%radiation) &
1888 call mom_error(fatal, "MOM_open_boundary.F90, setup_u_point_obc: \n"//&
1889 "Orlanski and Oblique OBC options cannot be used together on one segment.")
1890end subroutine setup_u_point_obc
1891
1892!> Parse an OBC_SEGMENT_%%% string starting with "J=" and configure placement and type of OBC accordingly
1893subroutine setup_v_point_obc(OBC, G, US, segment_str, l_seg, l_seg_io, PF, reentrant_x)
1894 type(ocean_obc_type), intent(inout) :: OBC !< Open boundary control structure
1895 type(dyn_horgrid_type), intent(in) :: G !< Ocean grid structure
1896 type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
1897 character(len=*), intent(in) :: segment_str !< A string in form of "J=%,I=%:%,string"
1898 integer, intent(in) :: l_seg !< The internal segment number
1899 integer, intent(in) :: l_seg_io !< The segment number used for reading parameters
1900 type(param_file_type), intent(in) :: PF !< Parameter file handle
1901 logical, intent(in) :: reentrant_x !< is the domain reentrant in x?
1902 ! Local variables
1903 integer :: J_obc, Is_obc, Ie_obc ! Position of segment in global index space
1904 integer :: i, a_loop
1905 character(len=32) :: action_str(8)
1906 character(len=128) :: segment_param_str
1907 real, allocatable, dimension(:) :: tnudge ! Nudging timescales [T ~> s]
1908
1909 ! This returns the global indices for the segment
1910 call parse_segment_str(g%ieg, g%jeg, segment_str, j_obc, is_obc, ie_obc, action_str, reentrant_x)
1911
1912 call setup_segment_indices(g, obc%segment(l_seg),is_obc,ie_obc,j_obc,j_obc)
1913
1914 j_obc = j_obc - g%jdg_offset ! Convert to local tile indices on this tile
1915 is_obc = is_obc - g%idg_offset ! Convert to local tile indices on this tile
1916 ie_obc = ie_obc - g%idg_offset ! Convert to local tile indices on this tile
1917
1918 if (ie_obc>is_obc) then
1919 obc%segment(l_seg)%direction = obc_direction_s
1920 elseif (ie_obc<is_obc) then
1921 obc%segment(l_seg)%direction = obc_direction_n
1922 i = is_obc ; is_obc = ie_obc ; ie_obc = i
1923 endif
1924
1925 obc%segment(l_seg)%on_pe = .false.
1926
1927 do a_loop = 1,8
1928 if (len_trim(action_str(a_loop)) == 0) then
1929 cycle
1930 elseif (trim(action_str(a_loop)) == 'FLATHER') then
1931 obc%segment(l_seg)%Flather = .true.
1932 obc%segment(l_seg)%open = .true.
1933 obc%Flather_v_BCs_exist_globally = .true.
1934 obc%open_v_BCs_exist_globally = .true.
1935 elseif (trim(action_str(a_loop)) == 'ORLANSKI') then
1936 obc%segment(l_seg)%radiation = .true.
1937 obc%segment(l_seg)%open = .true.
1938 obc%open_v_BCs_exist_globally = .true.
1939 obc%radiation_BCs_exist_globally = .true.
1940 elseif (trim(action_str(a_loop)) == 'ORLANSKI_TAN') then
1941 obc%segment(l_seg)%radiation = .true.
1942 obc%segment(l_seg)%radiation_tan = .true.
1943 obc%radiation_BCs_exist_globally = .true.
1944 elseif (trim(action_str(a_loop)) == 'ORLANSKI_GRAD') then
1945 obc%segment(l_seg)%radiation = .true.
1946 obc%segment(l_seg)%radiation_grad = .true.
1947 elseif (trim(action_str(a_loop)) == 'OBLIQUE') then
1948 obc%segment(l_seg)%oblique = .true.
1949 obc%segment(l_seg)%open = .true.
1950 obc%oblique_BCs_exist_globally = .true.
1951 obc%open_v_BCs_exist_globally = .true.
1952 elseif (trim(action_str(a_loop)) == 'OBLIQUE_TAN') then
1953 obc%segment(l_seg)%oblique = .true.
1954 obc%segment(l_seg)%oblique_tan = .true.
1955 obc%oblique_BCs_exist_globally = .true.
1956 elseif (trim(action_str(a_loop)) == 'OBLIQUE_GRAD') then
1957 obc%segment(l_seg)%oblique = .true.
1958 obc%segment(l_seg)%oblique_grad = .true.
1959 elseif (trim(action_str(a_loop)) == 'NUDGED') then
1960 obc%segment(l_seg)%nudged = .true.
1961 obc%nudged_v_BCs_exist_globally = .true.
1962 elseif (trim(action_str(a_loop)) == 'NUDGED_TAN') then
1963 obc%segment(l_seg)%nudged_tan = .true.
1964 obc%nudged_v_BCs_exist_globally = .true.
1965 elseif (trim(action_str(a_loop)) == 'NUDGED_GRAD') then
1966 obc%segment(l_seg)%nudged_grad = .true.
1967 elseif (trim(action_str(a_loop)) == 'GRADIENT') then
1968 obc%segment(l_seg)%gradient = .true.
1969 obc%segment(l_seg)%open = .true.
1970 obc%open_v_BCs_exist_globally = .true.
1971 elseif (trim(action_str(a_loop)) == 'SIMPLE') then
1972 obc%segment(l_seg)%specified = .true.
1973 obc%specified_v_BCs_exist_globally = .true. ! This avoids deallocation
1974 elseif (trim(action_str(a_loop)) == 'SIMPLE_TAN') then
1975 obc%segment(l_seg)%specified_tan = .true.
1976 elseif (trim(action_str(a_loop)) == 'SIMPLE_GRAD') then
1977 obc%segment(l_seg)%specified_grad = .true.
1978 else
1979 call mom_error(fatal, "MOM_open_boundary.F90, setup_v_point_obc: "//&
1980 "String '"//trim(action_str(a_loop))//"' not understood.")
1981 endif
1982 if (obc%segment(l_seg)%nudged .or. obc%segment(l_seg)%nudged_tan) then
1983 write(segment_param_str(1:43),"('OBC_SEGMENT_',i3.3,'_VELOCITY_NUDGING_TIMESCALES')") l_seg_io
1984 allocate(tnudge(2))
1985 call get_param(pf, mdl, segment_param_str(1:43), tnudge, &
1986 "Timescales in days for nudging along a segment, "//&
1987 "for inflow, then outflow. Setting both to zero should "//&
1988 "behave like SIMPLE obcs for the baroclinic velocities.", &
1989 fail_if_missing=.true., units="days", scale=86400.0*us%s_to_T)
1990 obc%segment(l_seg)%Velocity_nudging_timescale_in = tnudge(1)
1991 obc%segment(l_seg)%Velocity_nudging_timescale_out = tnudge(2)
1992 deallocate(tnudge)
1993 endif
1994
1995 enddo ! a_loop
1996
1997 if (j_obc<=g%HI%JsdB+1 .or. j_obc>=g%HI%JedB-1) return ! Boundary is not on tile
1998 if (ie_obc<=g%HI%IsdB .or. is_obc>=g%HI%IedB) return ! Segment is not on tile
1999
2000 obc%segment(l_seg)%on_pe = .true.
2001 obc%segment(l_seg)%is_N_or_S = .true.
2002
2003 do i=g%HI%isd, g%HI%ied
2004 if (i>is_obc .and. i<=ie_obc) then
2005 obc%segnum_v(i,j_obc) = l_seg
2006 if (obc%segment(l_seg)%direction == obc_direction_s) obc%segnum_v(i,j_obc) = -l_seg
2007 obc%v_OBCs_on_PE = .true.
2008 endif
2009 enddo
2010 obc%segment(l_seg)%Is_obc = is_obc
2011 obc%segment(l_seg)%Ie_obc = ie_obc
2012 obc%segment(l_seg)%Js_obc = j_obc
2013 obc%segment(l_seg)%Je_obc = j_obc
2014 call allocate_obc_segment_data(obc, obc%segment(l_seg))
2015
2016 if (obc%segment(l_seg)%oblique .and. obc%segment(l_seg)%radiation) &
2017 call mom_error(fatal, "MOM_open_boundary.F90, setup_v_point_obc: \n"//&
2018 "Orlanski and Oblique OBC options cannot be used together on one segment.")
2019
2020end subroutine setup_v_point_obc
2021
2022!> Parse an OBC_SEGMENT_%%% string
2023subroutine parse_segment_str(ni_global, nj_global, segment_str, l, m, n, action_str, reentrant)
2024 integer, intent(in) :: ni_global !< Number of h-points in zonal direction
2025 integer, intent(in) :: nj_global !< Number of h-points in meridional direction
2026 character(len=*), intent(in) :: segment_str !< A string in form of "I=l,J=m:n,string" or "J=l,I=m,n,string"
2027 integer, intent(out) :: l !< The value of I=l, if segment_str begins with I=l, or the value of J=l
2028 integer, intent(out) :: m !< The value of J=m, if segment_str begins with I=, or the value of I=m
2029 integer, intent(out) :: n !< The value of J=n, if segment_str begins with I=, or the value of I=n
2030 character(len=*), intent(out) :: action_str(:) !< The "string" part of segment_str
2031 logical, intent(in) :: reentrant !< is domain reentrant in relevant direction?
2032 ! Local variables
2033 character(len=24) :: word1, word2, m_word, n_word !< Words delineated by commas in a string in form of
2034 !! "I=%,J=%:%,string"
2035 character(len=3) :: max_words !< maximum number of OBC types per segment
2036 integer :: l_max !< Either ni_global or nj_global, depending on whether segment_str begins with "I=" or "J="
2037 integer :: mn_max !< Either nj_global or ni_global, depending on whether segment_str begins with "I=" or "J="
2038 integer :: j
2039 integer, parameter :: halo = 10
2040
2041 ! Process first word which will started with either 'I=' or 'J='
2042 word1 = extract_word(segment_str,',',1)
2043 word2 = extract_word(segment_str,',',2)
2044 if (word1(1:2)=='I=') then
2045 l_max = ni_global
2046 mn_max = nj_global
2047 if (.not. (word2(1:2)=='J=')) call mom_error(fatal, "MOM_open_boundary.F90, parse_segment_str: "//&
2048 "Second word of string '"//trim(segment_str)//"' must start with 'J='.")
2049 elseif (word1(1:2)=='J=') then ! Note that the file_parser uniformly expands "=" to " = "
2050 l_max = nj_global
2051 mn_max = ni_global
2052 if (.not. (word2(1:2)=='I=')) call mom_error(fatal, "MOM_open_boundary.F90, parse_segment_str: "//&
2053 "Second word of string '"//trim(segment_str)//"' must start with 'I='.")
2054 else
2055 call mom_error(fatal, "MOM_open_boundary.F90, parse_segment_str: "//&
2056 "String '"//segment_str//"' must start with 'I=' or 'J='.")
2057 endif
2058
2059 ! Read l
2060 l = interpret_int_expr( word1(3:24), l_max )
2061 if (l<0 .or. l>l_max) then
2062 call mom_error(fatal, "MOM_open_boundary.F90, parse_segment_str: "//&
2063 "First value from string '"//trim(segment_str)//"' is outside of the physical domain.")
2064 endif
2065
2066 ! Read m
2067 m_word = extract_word(word2(3:24),':',1)
2068 m = interpret_int_expr( m_word, mn_max )
2069 if (reentrant) then
2070 if (m<-halo .or. m>mn_max+halo) then
2071 call mom_error(fatal, "MOM_open_boundary.F90, parse_segment_str: "//&
2072 "Beginning of range in string '"//trim(segment_str)//"' is outside of the physical domain.")
2073 endif
2074 else
2075 if (m<-1 .or. m>mn_max+1) then
2076 call mom_error(fatal, "MOM_open_boundary.F90, parse_segment_str: "//&
2077 "Beginning of range in string '"//trim(segment_str)//"' is outside of the physical domain.")
2078 endif
2079 endif
2080
2081 ! Read n
2082 n_word = extract_word(word2(3:24),':',2)
2083 n = interpret_int_expr( n_word, mn_max )
2084 if (reentrant) then
2085 if (n<-halo .or. n>mn_max+halo) then
2086 call mom_error(fatal, "MOM_open_boundary.F90, parse_segment_str: "//&
2087 "End of range in string '"//trim(segment_str)//"' is outside of the physical domain.")
2088 endif
2089 else
2090 if (n<-1 .or. n>mn_max+1) then
2091 call mom_error(fatal, "MOM_open_boundary.F90, parse_segment_str: "//&
2092 "End of range in string '"//trim(segment_str)//"' is outside of the physical domain.")
2093 endif
2094 endif
2095
2096 if (abs(n-m)==0) then
2097 call mom_error(fatal, "MOM_open_boundary.F90, parse_segment_str: "//&
2098 "Range in string '"//trim(segment_str)//"' must span one cell.")
2099 endif
2100
2101 ! checking if the number of provided OBC types is less than or equal to 8
2102 if (extract_word(segment_str,',',3+size(action_str))/="") then
2103 write(max_words, '(I0)') size(action_str)
2104 call mom_error(fatal, "MOM_open_boundary.F90, parse_segment_str: "// &
2105 "Number of OBC descriptor words in '" // trim(segment_str) // "' is too large. " // &
2106 "There can be at most " // trim(max_words) // " descriptor words.")
2107 endif
2108
2109 ! Type of open boundary condition
2110 do j = 1, size(action_str)
2111 action_str(j) = extract_word(segment_str,',',2+j)
2112 enddo
2113
2114 contains
2115
2116 ! Returns integer value interpreted from string in form of %I, N or N+-%I
2117 integer function interpret_int_expr(string, imax)
2118 character(len=*), intent(in) :: string !< Integer in form or %I, N or N-%I
2119 integer, intent(in) :: imax !< Value to replace 'N' with
2120 ! Local variables
2121 integer slen
2122
2123 slen = len_trim(string)
2124 if (slen==0) call mom_error(fatal, "MOM_open_boundary.F90, parse_segment_str: "//&
2125 "Parsed string was empty!")
2126 if (len_trim(string)==1 .and. string(1:1)=='N') then
2127 interpret_int_expr = imax
2128 elseif (string(1:1)=='N') then
2129 if (string(2:2)=='+') then
2130 read(string(3:slen),*,err=911) interpret_int_expr
2131 interpret_int_expr = imax + interpret_int_expr
2132 elseif (string(2:2)=='-') then
2133 read(string(3:slen),*,err=911) interpret_int_expr
2134 interpret_int_expr = imax - interpret_int_expr
2135 endif
2136 else
2137 read(string(1:slen),*,err=911) interpret_int_expr
2138 endif
2139 return
2140 911 call mom_error(fatal, "MOM_open_boundary.F90, parse_segment_str: "//&
2141 "Problem reading value from string '"//trim(string)//"'.")
2142 end function interpret_int_expr
2143end subroutine parse_segment_str
2144
2145
2146!> Parse an OBC_SEGMENT_%%%_DATA string and determine its fields
2147subroutine parse_segment_manifest_str(segment_str, num_fields, fields)
2148 character(len=*), intent(in) :: segment_str !< A string in form of
2149 !< "VAR1=file:foo1.nc(varnam1),VAR2=file:foo2.nc(varnam2),..."
2150 integer, intent(out) :: num_fields !< The number of fields in the segment data
2151 character(len=*), dimension(NUM_PHYS_FIELDS), intent(out) :: fields
2152 !< List of fieldnames for each segment
2153
2154 ! Local variables
2155 character(len=128) :: field_spec, field
2156 integer :: i
2157
2158 num_fields = 0
2159 fields(:) = ''
2160
2161 do
2162 field_spec = extract_word(segment_str, ',', num_fields + 1)
2163 if (trim(field_spec) == '') exit
2164
2165 if (num_fields >= num_phys_fields) &
2166 call mom_error(fatal, "MOM_open_boundary.F90, parse_segment_manifest_str: " // &
2167 "too many fields in OBC segment manifest '" //trim(segment_str) // "'.")
2168
2169 field = trim(extract_word(field_spec, '=', 1))
2170
2171 ! Check for duplicate fields
2172 do i=1, num_fields
2173 if (fields(i) == trim(field)) &
2174 call mom_error(fatal, "MOM_open_boundary.F90, parse_segment_manifest_str: "//&
2175 "duplicate field '" // trim(field) // "' in '" // trim(segment_str) // "'.")
2176 enddo
2177
2178 num_fields = num_fields + 1
2179 fields(num_fields) = trim(field)
2180 enddo
2181end subroutine parse_segment_manifest_str
2182
2183
2184!> Parse an OBC_SEGMENT_%%%_DATA string
2185subroutine parse_segment_data_str(segment_str, idx, var, value, filename, fieldname)
2186 character(len=*), intent(in) :: segment_str !< A string in form of
2187 !! "VAR1=file:foo1.nc(varnam1),VAR2=file:foo2.nc(varnam2),..."
2188 integer, intent(in) :: idx !< Index of segment_str record
2189 character(len=*), intent(in) :: var !< The name of the variable for which parameters are needed
2190 character(len=*), intent(out) :: filename !< The name of the input file if using "file" method
2191 character(len=*), intent(out) :: fieldname !< The name of the variable in the input file if using
2192 !! "file" method
2193 real, optional, intent(out) :: value !< A constant value if using the "value" method in various
2194 !! units but without the internal rescaling [various units]
2195
2196 ! Local variables
2197 character(len=128) :: word1, word2, word3, method
2198 integer :: lword
2199
2200 ! Process first word which will start with the fieldname
2201 word3 = extract_word(segment_str, ',', idx)
2202 word1 = extract_word(word3, ':', 1)
2203 !if (trim(word1) == '') exit
2204 word2 = extract_word(word1, '=', 1)
2205 if (trim(word2) == trim(var)) then
2206 method = trim(extract_word(word1, '=', 2))
2207 lword = len_trim(method)
2208 if (method(lword-3:lword) == 'file') then
2209 ! raise an error id filename/fieldname not in argument list
2210 word1 = extract_word(word3, ':', 2)
2211 filename = extract_word(word1, '(', 1)
2212 fieldname = extract_word(word1, '(', 2)
2213 lword = len_trim(fieldname)
2214 fieldname = fieldname(1:lword-1) ! remove trailing parenth
2215 value = -999.
2216 elseif (method(lword-4:lword) == 'value') then
2217 filename = 'none'
2218 fieldname = 'none'
2219 word1 = extract_word(word3, ':', 2)
2220 lword = len_trim(word1)
2221 read(word1(1:lword), *, end=986, err=987) value
2222 endif
2223 endif
2224
2225 return
2226986 call mom_error(fatal,'End of record while parsing segment data specification! '//trim(segment_str))
2227987 call mom_error(fatal,'Error while parsing segment data specification! '//trim(segment_str))
2228end subroutine parse_segment_data_str
2229
2230!> Parse all the OBC_SEGMENT_%%%_DATA strings again
2231!! to see which need tracer reservoirs (all pes need to know).
2232subroutine parse_for_tracer_reservoirs(OBC, PF, use_temperature)
2233 type(ocean_obc_type), target, intent(inout) :: OBC !< Open boundary control structure
2234 type(param_file_type), intent(in) :: PF !< Parameter file handle
2235 logical, intent(in) :: use_temperature !< If true, T and S are used
2236
2237 ! Local variables
2238 integer :: n ! The segment number used to read in input data
2239 integer :: n_seg ! The internal segment number
2240 integer :: m, num_fields ! Used to loop over the fields on a segment
2241 integer :: na
2242 character(len=1024) :: segstr
2243 character(len=256) :: filename
2244 character(len=20) :: segname, suffix
2245 character(len=32) :: fieldname
2246 real :: value ! A value that is parsed from the segment data string [various units]
2247 character(len=32), dimension(NUM_PHYS_FIELDS) :: fields ! segment field names
2248 type(obc_segment_type), pointer :: segment => null() ! pointer to segment type list
2249
2250 do n=1,obc%number_of_segments
2251 n_seg = n ; if (obc%reverse_segment_order) n_seg = obc%number_of_segments + 1 - n
2252 segment => obc%segment(n_seg)
2253 write(segname, "('OBC_SEGMENT_',i3.3,'_DATA')") n
2254 write(suffix, "('_segment_',i3.3)") n
2255 ! Clear out any old values
2256 segstr = ''
2257 call get_param(pf, mdl, segname, segstr)
2258 if (segstr == '') cycle
2259
2260 call parse_segment_manifest_str(trim(segstr), num_fields, fields)
2261 if (num_fields == 0) cycle
2262
2263 ! At this point, just search for TEMP and SALT as tracers 1 and 2.
2264 do m=1,num_fields
2265 call parse_segment_data_str(trim(segstr), m, trim(fields(m)), value, filename, fieldname)
2266 if (trim(filename) /= 'none') then
2267 if (fields(m) == 'TEMP') then
2268 if (segment%is_E_or_W_2) then
2269 obc%tracer_x_reservoirs_used(1) = .true.
2270 else
2271 obc%tracer_y_reservoirs_used(1) = .true.
2272 endif
2273 endif
2274 if (fields(m) == 'SALT') then
2275 if (segment%is_E_or_W_2) then
2276 obc%tracer_x_reservoirs_used(2) = .true.
2277 else
2278 obc%tracer_y_reservoirs_used(2) = .true.
2279 endif
2280 endif
2281 endif
2282 enddo
2283 ! Alternately, set first two to true if use_temperature is true
2284 if (use_temperature) then
2285 if (segment%is_E_or_W_2) then
2286 obc%tracer_x_reservoirs_used(1) = .true.
2287 obc%tracer_x_reservoirs_used(2) = .true.
2288 else
2289 obc%tracer_y_reservoirs_used(1) = .true.
2290 obc%tracer_y_reservoirs_used(2) = .true.
2291 endif
2292 endif
2293 !Add reservoirs for external/obgc tracers
2294 !There is a diconnect in the above logic between tracer index and reservoir index.
2295 !It arbitarily assigns reservoir indexes 1&2 to tracers T&S,
2296 !So we need to start from reservoir index for non-native tracers from 3, hence na=2 below.
2297 !num_fields is the number of vars in segstr (6 of them now, U,V,SSH,TEMP,SALT,dye)
2298 !but OBC%tracer_x_reservoirs_used is allocated to size Reg%ntr, which is the total number of tracers
2299 na = 2 ! Number of native MOM6 tracers (T&S) with reservoirs
2300 do m=1,obc%num_obgc_tracers
2301 !This logic assumes all external tarcers need a reservoir
2302 !The segments for tracers are not initialized yet (that happens later in initialize_segment_data())
2303 !so we cannot query to determine if this tracer needs a reservoir.
2304 if (segment%is_E_or_W_2) then
2305 obc%tracer_x_reservoirs_used(m+na) = .true.
2306 else
2307 obc%tracer_y_reservoirs_used(m+na) = .true.
2308 endif
2309 enddo
2310 enddo
2311
2312 return
2313
2314end subroutine parse_for_tracer_reservoirs
2315
2316!> Do any necessary halo updates on OBC-related fields.
2317subroutine open_boundary_halo_update(G, OBC)
2318 type(ocean_grid_type), intent(in) :: g !< Ocean grid structure
2319 type(ocean_obc_type), pointer :: obc !< Open boundary control structure
2320
2321 ! Local variables
2322 integer :: m
2323
2324 if (.not.associated(obc)) return
2325
2326 id_clock_pass = cpu_clock_id('(Ocean OBC halo updates)', grain=clock_routine)
2327 if (obc%radiation_BCs_exist_globally) call pass_vector(obc%rx_normal, obc%ry_normal, g%Domain, &
2328 to_all+scalar_pair)
2329 if (obc%oblique_BCs_exist_globally) then
2330! call pass_vector(OBC%rx_oblique_u, OBC%ry_oblique_v, G%Domain, To_All+Scalar_Pair)
2331! call pass_vector(OBC%ry_oblique_u, OBC%rx_oblique_v, G%Domain, To_All+Scalar_Pair)
2332! call pass_vector(OBC%cff_normal_u, OBC%cff_normal_v, G%Domain, To_All+Scalar_Pair)
2333 call create_group_pass(obc%pass_oblique, obc%rx_oblique_u, obc%ry_oblique_v, g%Domain, to_all+scalar_pair)
2334 call create_group_pass(obc%pass_oblique, obc%ry_oblique_u, obc%rx_oblique_v, g%Domain, to_all+scalar_pair)
2335 call create_group_pass(obc%pass_oblique, obc%cff_normal_u, obc%cff_normal_v, g%Domain, to_all+scalar_pair)
2336 call do_group_pass(obc%pass_oblique, g%Domain)
2337 endif
2338 if (allocated(obc%tres_x) .and. allocated(obc%tres_y)) then
2339 do m=1,obc%ntr
2340 call pass_vector(obc%tres_x(:,:,:,m), obc%tres_y(:,:,:,m), g%Domain, to_all+scalar_pair)
2341 enddo
2342 elseif (allocated(obc%tres_x)) then
2343 do m=1,obc%ntr
2344 call pass_var(obc%tres_x(:,:,:,m), g%Domain, position=east_face)
2345 enddo
2346 elseif (allocated(obc%tres_y)) then
2347 do m=1,obc%ntr
2348 call pass_var(obc%tres_y(:,:,:,m), g%Domain, position=north_face)
2349 enddo
2350 endif
2351 if (allocated(obc%h_res_x) .and. allocated(obc%h_res_y)) then
2352 call pass_vector(obc%h_res_x(:,:,:), obc%h_res_y(:,:,:), g%Domain, to_all+scalar_pair)
2353 elseif (allocated(obc%h_res_x)) then
2354 call pass_var(obc%h_res_x(:,:,:), g%Domain, position=east_face)
2355 elseif (allocated(obc%h_res_y)) then
2356 call pass_var(obc%h_res_y(:,:,:), g%Domain, position=north_face)
2357 endif
2358
2359end subroutine open_boundary_halo_update
2360
2361logical function open_boundary_query(OBC, apply_open_OBC, apply_specified_OBC, apply_Flather_OBC, &
2362 apply_nudged_OBC, needs_ext_seg_data)
2363 type(ocean_obc_type), pointer :: obc !< Open boundary control structure
2364 logical, optional, intent(in) :: apply_open_obc !< Returns True if open_*_BCs_exist_globally is true
2365 logical, optional, intent(in) :: apply_specified_obc !< Returns True if specified_*_BCs_exist_globally is true
2366 logical, optional, intent(in) :: apply_flather_obc !< Returns True if Flather_*_BCs_exist_globally is true
2367 logical, optional, intent(in) :: apply_nudged_obc !< Returns True if nudged_*_BCs_exist_globally is true
2368 logical, optional, intent(in) :: needs_ext_seg_data !< Returns True if external segment data needed
2369 open_boundary_query = .false.
2370 if (.not. associated(obc)) return
2371 if (present(apply_open_obc)) open_boundary_query = obc%open_u_BCs_exist_globally .or. &
2372 obc%open_v_BCs_exist_globally
2373 if (present(apply_specified_obc)) open_boundary_query = obc%specified_u_BCs_exist_globally .or. &
2374 obc%specified_v_BCs_exist_globally
2375 if (present(apply_flather_obc)) open_boundary_query = obc%Flather_u_BCs_exist_globally .or. &
2376 obc%Flather_v_BCs_exist_globally
2377 if (present(apply_nudged_obc)) open_boundary_query = obc%nudged_u_BCs_exist_globally .or. &
2378 obc%nudged_v_BCs_exist_globally
2379 if (present(needs_ext_seg_data)) open_boundary_query = obc%any_needs_IO_for_data
2380
2381end function open_boundary_query
2382
2383!> Deallocate open boundary data
2384subroutine open_boundary_dealloc(OBC)
2385 type(ocean_obc_type), pointer :: OBC !< Open boundary control structure
2386 type(obc_segment_type), pointer :: segment => null()
2387 integer :: n
2388
2389 if (.not. associated(obc)) return
2390
2391 do n=1,obc%number_of_segments
2392 segment => obc%segment(n)
2393 call deallocate_obc_segment_data(segment)
2394 enddo
2395 if (allocated(obc%segment)) deallocate(obc%segment)
2396 if (allocated(obc%segnum_u)) deallocate(obc%segnum_u)
2397 if (allocated(obc%segnum_v)) deallocate(obc%segnum_v)
2398 if (allocated(obc%rx_normal)) deallocate(obc%rx_normal)
2399 if (allocated(obc%ry_normal)) deallocate(obc%ry_normal)
2400 if (allocated(obc%rx_oblique_u)) deallocate(obc%rx_oblique_u)
2401 if (allocated(obc%ry_oblique_u)) deallocate(obc%ry_oblique_u)
2402 if (allocated(obc%rx_oblique_v)) deallocate(obc%rx_oblique_v)
2403 if (allocated(obc%ry_oblique_v)) deallocate(obc%ry_oblique_v)
2404 if (allocated(obc%cff_normal_u)) deallocate(obc%cff_normal_u)
2405 if (allocated(obc%cff_normal_v)) deallocate(obc%cff_normal_v)
2406 if (allocated(obc%tres_x)) deallocate(obc%tres_x)
2407 if (allocated(obc%tres_y)) deallocate(obc%tres_y)
2408 if (allocated(obc%h_res_x)) deallocate(obc%h_res_x)
2409 if (allocated(obc%h_res_y)) deallocate(obc%h_res_y)
2410 if (associated(obc%remap_z_CS)) deallocate(obc%remap_z_CS)
2411 if (associated(obc%remap_h_CS)) deallocate(obc%remap_h_CS)
2412 deallocate(obc)
2413end subroutine open_boundary_dealloc
2414
2415!> Close open boundary data
2416subroutine open_boundary_end(OBC)
2417 type(ocean_obc_type), pointer :: obc !< Open boundary control structure
2418 call open_boundary_dealloc(obc)
2419end subroutine open_boundary_end
2420
2421!> Sets the slope of bathymetry normal to an open boundary to zero.
2422subroutine open_boundary_impose_normal_slope(OBC, G, depth)
2423 type(ocean_obc_type), pointer :: obc !< Open boundary control structure
2424 type(dyn_horgrid_type), intent(in) :: g !< Ocean grid structure
2425 real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: depth !< Bathymetry at h-points, in [Z ~> m] or other units
2426 ! Local variables
2427 integer :: i, j, n
2428 type(obc_segment_type), pointer :: segment => null()
2429
2430 if (.not.associated(obc)) return
2431
2432 if (.not.(obc%specified_u_BCs_exist_globally .or. obc%specified_v_BCs_exist_globally .or. &
2433 obc%open_u_BCs_exist_globally .or. obc%open_v_BCs_exist_globally)) &
2434 return
2435
2436 do n=1,obc%number_of_segments
2437 segment => obc%segment(n)
2438 if (.not. segment%on_pe) cycle
2439 if (segment%direction == obc_direction_e) then
2440 i=segment%HI%IsdB
2441 do j=segment%HI%jsd,segment%HI%jed
2442 depth(i+1,j) = depth(i,j)
2443 enddo
2444 elseif (segment%direction == obc_direction_w) then
2445 i=segment%HI%IsdB
2446 do j=segment%HI%jsd,segment%HI%jed
2447 depth(i,j) = depth(i+1,j)
2448 enddo
2449 elseif (segment%direction == obc_direction_n) then
2450 j=segment%HI%JsdB
2451 do i=segment%HI%isd,segment%HI%ied
2452 depth(i,j+1) = depth(i,j)
2453 enddo
2454 elseif (segment%direction == obc_direction_s) then
2455 j=segment%HI%JsdB
2456 do i=segment%HI%isd,segment%HI%ied
2457 depth(i,j) = depth(i,j+1)
2458 enddo
2459 endif
2460 enddo
2461
2463
2464!> Reconcile masks and open boundaries, deallocate OBC on PEs where it is not needed.
2465!! Also adjust u- and v-point cell area on specified open boundaries and mask all
2466!! points outside open boundaries.
2467subroutine open_boundary_impose_land_mask(OBC, G, areaCu, areaCv, US)
2468 type(ocean_obc_type), pointer :: obc !< Open boundary control structure
2469 type(dyn_horgrid_type), intent(inout) :: g !< Ocean grid structure
2470 type(unit_scale_type), intent(in) :: us !< A dimensional unit scaling type
2471 real, dimension(SZIB_(G),SZJ_(G)), intent(inout) :: areacu !< Area of a u-cell [L2 ~> m2]
2472 real, dimension(SZI_(G),SZJB_(G)), intent(inout) :: areacv !< Area of a u-cell [L2 ~> m2]
2473 ! Local variables
2474 integer :: i, j, n
2475 type(obc_segment_type), pointer :: segment => null()
2476 logical :: any_u, any_v
2477
2478 if (.not.associated(obc)) return
2479
2480 do n=1,obc%number_of_segments
2481 segment => obc%segment(n)
2482 if (.not. segment%on_pe) cycle
2483 if (segment%is_E_or_W) then
2484 ! Sweep along u-segments and delete the OBC for blocked points.
2485 ! Also, mask all points outside.
2486 i=segment%HI%IsdB
2487 do j=segment%HI%jsd,segment%HI%jed
2488 if (g%mask2dCu(i,j) == 0) obc%segnum_u(i,j) = 0
2489 if (segment%direction == obc_direction_w) then
2490 g%mask2dT(i,j) = 0.0
2491 else
2492 g%mask2dT(i+1,j) = 0.0
2493 endif
2494 enddo
2495 do j=segment%HI%JsdB+1,segment%HI%JedB-1
2496 if (segment%direction == obc_direction_w) then
2497 g%mask2dCv(i,j) = 0 ; g%OBCmaskCv(i,j) = 0.0 ; g%IdyCv_OBCmask(i,j) = 0.0
2498 else
2499 g%mask2dCv(i+1,j) = 0.0 ; g%OBCmaskCv(i+1,j) = 0.0 ; g%IdyCv_OBCmask(i+1,j) = 0.0
2500 endif
2501 enddo
2502 else
2503 ! Sweep along v-segments and delete the OBC for blocked points.
2504 j=segment%HI%JsdB
2505 do i=segment%HI%isd,segment%HI%ied
2506 if (g%mask2dCv(i,j) == 0) obc%segnum_v(i,j) = 0
2507 if (segment%direction == obc_direction_s) then
2508 g%mask2dT(i,j) = 0.0
2509 else
2510 g%mask2dT(i,j+1) = 0.0
2511 endif
2512 enddo
2513 do i=segment%HI%IsdB+1,segment%HI%IedB-1
2514 if (segment%direction == obc_direction_s) then
2515 g%mask2dCu(i,j) = 0.0 ; g%OBCmaskCu(i,j) = 0.0 ; g%IdxCu_OBCmask(i,j) = 0.0
2516 else
2517 g%mask2dCu(i,j+1) = 0.0 ; g%OBCmaskCu(i,j+1) = 0.0 ; g%IdxCu_OBCmask(i,j+1) = 0.0
2518 endif
2519 enddo
2520 endif
2521 enddo
2522
2523 do n=1,obc%number_of_segments
2524 segment => obc%segment(n)
2525 if (.not. (segment%on_pe .and. segment%open)) cycle
2526 ! Set the OBCmask values to help eliminate certain terms at u- or v- OBC points.
2527 ! Testing suggests this could be applied at all u- or v- OBC points without changing answers.
2528 if (segment%is_E_or_W) then
2529 i=segment%HI%IsdB
2530 do j=segment%HI%jsd,segment%HI%jed
2531 g%OBCmaskCu(i,j) = 0.0 ; g%IdxCu_OBCmask(i,j) = 0.0
2532 enddo
2533 else
2534 j=segment%HI%JsdB
2535 do i=segment%HI%isd,segment%HI%ied
2536 g%OBCmaskCv(i,j) = 0.0 ; g%IdyCv_OBCmask(i,j) = 0.0
2537 enddo
2538 endif
2539 enddo
2540
2541 do n=1,obc%number_of_segments
2542 segment => obc%segment(n)
2543 if (.not. segment%on_pe .or. .not. segment%specified) cycle
2544 if (segment%is_E_or_W) then
2545 ! Sweep along u-segments and for %specified BC points reset the u-point area which was masked out
2546 i=segment%HI%IsdB
2547 do j=segment%HI%jsd,segment%HI%jed
2548 if (segment%direction == obc_direction_e) then
2549 areacu(i,j) = g%areaT(i,j) ! Both of these are in [L2 ~> m2]
2550 else ! West
2551 areacu(i,j) = g%areaT(i+1,j) ! Both of these are in [L2 ~> m2]
2552 endif
2553 enddo
2554 else
2555 ! Sweep along v-segments and for %specified BC points reset the v-point area which was masked out
2556 j=segment%HI%JsdB
2557 do i=segment%HI%isd,segment%HI%ied
2558 if (segment%direction == obc_direction_s) then
2559 areacv(i,j) = g%areaT(i,j+1) ! Both of these are in [L2 ~> m2]
2560 else ! North
2561 areacv(i,j) = g%areaT(i,j) ! Both of these are in [L2 ~> m2]
2562 endif
2563 enddo
2564 endif
2565 enddo
2566
2567 ! G%mask2du will be open wherever bathymetry allows it.
2568 ! Bathymetry outside of the open boundary was adjusted to match
2569 ! the bathymetry inside so these points will be open unless the
2570 ! bathymetry inside the boundary was too shallow and flagged as land.
2571 any_u = .false.
2572 any_v = .false.
2573 do n=1,obc%number_of_segments
2574 segment => obc%segment(n)
2575 if (.not. segment%on_pe) cycle
2576 if (segment%is_E_or_W) then
2577 i=segment%HI%IsdB
2578 do j=segment%HI%jsd,segment%HI%jed
2579 if (obc%segnum_u(i,j) /= 0) any_u = .true.
2580 enddo
2581 else
2582 j=segment%HI%JsdB
2583 do i=segment%HI%isd,segment%HI%ied
2584 if (obc%segnum_v(i,j) /= 0) any_v = .true.
2585 enddo
2586 endif
2587 enddo
2588
2589 obc%u_OBCs_on_PE = any_u
2590 obc%v_OBCs_on_PE = any_v
2591 obc%OBC_pe = (any_u .or. any_v)
2592
2593end subroutine open_boundary_impose_land_mask
2594
2595!> Initialize the tracer reservoirs values, perhaps only if they have not been set via a restart file.
2596subroutine setup_obc_tracer_reservoirs(G, GV, OBC, restart_CS)
2597 type(ocean_grid_type), intent(in) :: g !< Ocean grid structure
2598 type(verticalgrid_type), intent(in) :: gv !< The ocean's vertical grid structure
2599 type(ocean_obc_type), target, intent(inout) :: obc !< Open boundary control structure
2600 type(mom_restart_cs), optional, intent(in) :: restart_cs !< MOM restart control structure
2601
2602 ! Local variables
2603 type(obc_segment_type), pointer :: segment => null()
2604 real :: i_scale ! The inverse of the scaling factor for the tracers.
2605 ! For salinity the units would be [ppt S-1 ~> 1]
2606 logical :: set_tres_x, set_tres_y
2607 character(len=12) :: x_var_name, y_var_name
2608 integer :: i, j, k, m, n
2609
2610 do m=1,obc%ntr
2611
2612 set_tres_x = allocated(obc%tres_x) .and. obc%tracer_x_reservoirs_used(m)
2613 set_tres_y = allocated(obc%tres_y) .and. obc%tracer_y_reservoirs_used(m)
2614
2615 if (present(restart_cs)) then
2616 ! Set the names of the reservoirs for this tracer in the restart file, and inquire whether
2617 ! they have been initialized
2618 if (modulo(g%HI%turns, 2) == 0) then
2619 write(x_var_name,'("tres_x_",I3.3)') m
2620 write(y_var_name,'("tres_y_",I3.3)') m
2621 else
2622 write(x_var_name,'("tres_y_",I3.3)') m
2623 write(y_var_name,'("tres_x_",I3.3)') m
2624 endif
2625 if (set_tres_x) set_tres_x = .not.query_initialized(obc%tres_x, x_var_name, restart_cs)
2626 if (set_tres_y) set_tres_y = .not.query_initialized(obc%tres_y, y_var_name, restart_cs)
2627 endif
2628
2629 do n=1,obc%number_of_segments
2630 segment => obc%segment(n)
2631 if (associated(segment%tr_Reg)) then ; if (allocated(segment%tr_Reg%Tr(m)%tres)) then
2632 i_scale = 1.0 ; if (segment%tr_Reg%Tr(m)%scale /= 0.0) i_scale = 1.0 / segment%tr_Reg%Tr(m)%scale
2633
2634 if (segment%is_E_or_W .and. set_tres_x) then
2635 i = segment%HI%IsdB
2636 if (segment%tr_Reg%Tr(m)%is_initialized) then
2637 do k=1,gv%ke ; do j=segment%HI%jsd,segment%HI%jed
2638 obc%tres_x(i,j,k,m) = i_scale * segment%tr_Reg%Tr(m)%tres(i,j,k)
2639 enddo ; enddo
2640 else
2641 do k=1,gv%ke ; do j=segment%HI%jsd,segment%HI%jed
2642 obc%tres_x(i,j,k,m) = i_scale * segment%tr_Reg%Tr(m)%t(i,j,k)
2643 enddo ; enddo
2644 endif
2645 elseif (segment%is_N_or_S .and. set_tres_y) then
2646 j = segment%HI%JsdB
2647 if (segment%tr_Reg%Tr(m)%is_initialized) then
2648 do k=1,gv%ke ; do i=segment%HI%isd,segment%HI%ied
2649 obc%tres_y(i,j,k,m) = i_scale * segment%tr_Reg%Tr(m)%tres(i,j,k)
2650 enddo ; enddo
2651 else
2652 do k=1,gv%ke ; do i=segment%HI%isd,segment%HI%ied
2653 obc%tres_y(i,j,k,m) = i_scale * segment%tr_Reg%Tr(m)%t(i,j,k)
2654 enddo ; enddo
2655 endif
2656 endif
2657 endif ; endif
2658 enddo
2659 enddo
2660
2661end subroutine setup_obc_tracer_reservoirs
2662
2663!> Initialize the thickness reservoirs values, perhaps only if they have not been set via a restart file.
2664subroutine setup_obc_thickness_reservoirs(G, GV, OBC, restart_CS)
2665 type(ocean_grid_type), intent(in) :: g !< Ocean grid structure
2666 type(verticalgrid_type), intent(in) :: gv !< The ocean's vertical grid structure
2667 type(ocean_obc_type), target, intent(inout) :: obc !< Open boundary control structure
2668 type(mom_restart_cs), optional, intent(in) :: restart_cs !< MOM restart control structure
2669
2670 ! Local variables
2671 type(obc_segment_type), pointer :: segment => null()
2672 real :: i_scale ! The inverse of the scaling factor for the thicknesses.
2673 ! [m Z-1 ~> 1]
2674 logical :: set_h_res_x, set_h_res_y
2675 character(len=12) :: x_var_name, y_var_name
2676 integer :: i, j, k, n
2677
2678 set_h_res_x = allocated(obc%h_res_x) .and. obc%thickness_x_reservoirs_used
2679 set_h_res_y = allocated(obc%h_res_y) .and. obc%thickness_y_reservoirs_used
2680
2681 if (present(restart_cs)) then
2682 ! Set the names of the reservoirs for the layer thickness in the restart file, and inquire
2683 ! whether they have been initialized
2684 if (modulo(g%HI%turns, 2) == 0) then
2685 write(x_var_name,'("h_res_x")')
2686 write(y_var_name,'("h_res_y")')
2687 else
2688 write(x_var_name,'("h_res_y")')
2689 write(y_var_name,'("h_res_x")')
2690 endif
2691 if (set_h_res_x) set_h_res_x = .not.query_initialized(obc%h_res_x, x_var_name, restart_cs)
2692 if (set_h_res_y) set_h_res_y = .not.query_initialized(obc%h_res_y, y_var_name, restart_cs)
2693 endif
2694
2695 do n=1,obc%number_of_segments
2696 segment => obc%segment(n)
2697 if (associated(segment%h_Reg)) then ; if (allocated(segment%h_Reg%h_res)) then
2698 i_scale = 1.0 ; if (segment%h_Reg%scale /= 0.0) i_scale = 1.0 / segment%h_Reg%scale
2699
2700 if (segment%is_E_or_W .and. set_h_res_x) then
2701 i = segment%HI%IsdB
2702 if (segment%h_Reg%is_initialized) then
2703 do k=1,gv%ke ; do j=segment%HI%jsd,segment%HI%jed
2704 obc%h_res_x(i,j,k) = i_scale * segment%h_Reg%h_res(i,j,k)
2705 enddo ; enddo
2706 else
2707 do k=1,gv%ke ; do j=segment%HI%jsd,segment%HI%jed
2708 obc%h_res_x(i,j,k) = i_scale * segment%h_Reg%h(i,j,k)
2709 enddo ; enddo
2710 endif
2711 elseif (segment%is_N_or_S .and. set_h_res_y) then
2712 j = segment%HI%JsdB
2713 if (segment%h_Reg%is_initialized) then
2714 do k=1,gv%ke ; do i=segment%HI%isd,segment%HI%ied
2715 obc%h_res_y(i,j,k) = i_scale * segment%h_Reg%h_res(i,j,k)
2716 enddo ; enddo
2717 else
2718 do k=1,gv%ke ; do i=segment%HI%isd,segment%HI%ied
2719 obc%h_res_y(i,j,k) = i_scale * segment%h_Reg%h(i,j,k)
2720 enddo ; enddo
2721 endif
2722 endif
2723 endif ; endif
2724 enddo
2725
2726end subroutine setup_obc_thickness_reservoirs
2727
2728!> Record that the tracer reservoirs have been initialized so that their values are not reset later.
2729subroutine set_initialized_obc_tracer_reservoirs(G, OBC, restart_CS)
2730 type(ocean_grid_type), intent(in) :: g !< Ocean grid structure
2731 type(ocean_obc_type), intent(in) :: obc !< Open boundary control structure
2732 type(mom_restart_cs), intent(inout) :: restart_cs !< MOM restart control structure
2733 character(len=12) :: x_var_name, y_var_name
2734 integer :: m
2735
2736 do m=1,obc%ntr
2737 ! Set the names of the reservoirs for this tracer in the restart file
2738 if (modulo(g%HI%turns, 2) == 0) then
2739 write(x_var_name,'("tres_x_",I3.3)') m
2740 write(y_var_name,'("tres_y_",I3.3)') m
2741 else
2742 write(x_var_name,'("tres_y_",I3.3)') m
2743 write(y_var_name,'("tres_x_",I3.3)') m
2744 endif
2745
2746 if (obc%tracer_x_reservoirs_used(m)) call set_initialized(obc%tres_x, x_var_name, restart_cs)
2747 if (obc%tracer_y_reservoirs_used(m)) call set_initialized(obc%tres_y, y_var_name, restart_cs)
2748 enddo
2749
2751
2752!> Copy radiation and oblique boundary condition coefficients (phase speeds and normalizing
2753!! denominator) from the global restart arrays into the per-segment arrays.
2754subroutine copy_obc_radiation_coefs(OBC)
2755 type(ocean_obc_type), pointer :: obc !< Open boundary control structure
2756
2757 ! Local variables
2758 type(obc_segment_type), pointer :: segment => null()
2759 integer :: nz, i, j, k, n, is, ie, js, je
2760
2761 if (.not. associated(obc)) return
2762 if (obc%gamma_uv >= 1.0) return
2763
2764 nz = obc%ke
2765 do n=1,obc%number_of_segments
2766 segment => obc%segment(n)
2767 if (.not. segment%on_pe) cycle
2768 if (segment%is_E_or_W) then ! EW segment
2769 i = segment%HI%IsdB ; js = segment%HI%jsd ; je = segment%HI%jed
2770 if (segment%radiation) then
2771 do k=1,nz ; do j=js,je
2772 segment%rx_norm_rad(i,j,k) = obc%rx_normal(i,j,k)
2773 enddo ; enddo
2774 endif
2775 if (segment%oblique) then
2776 do k=1,nz ; do j=js,je
2777 segment%rx_norm_obl(i,j,k) = obc%rx_oblique_u(i,j,k)
2778 segment%ry_norm_obl(i,j,k) = obc%ry_oblique_u(i,j,k)
2779 segment%cff_normal(i,j,k) = obc%cff_normal_u(i,j,k)
2780 enddo ; enddo
2781 endif
2782 elseif (segment%is_N_or_S) then ! NS segment
2783 j = segment%HI%JsdB ; is = segment%HI%isd ; ie = segment%HI%ied
2784 if (segment%radiation) then
2785 do k=1,nz ; do i=is,ie
2786 segment%ry_norm_rad(i,j,k) = obc%ry_normal(i,j,k)
2787 enddo ; enddo
2788 endif
2789 if (segment%oblique) then
2790 do k=1,nz ; do i=is,ie
2791 segment%rx_norm_obl(i,j,k) = obc%rx_oblique_v(i,j,k)
2792 segment%ry_norm_obl(i,j,k) = obc%ry_oblique_v(i,j,k)
2793 segment%cff_normal(i,j,k) = obc%cff_normal_v(i,j,k)
2794 enddo ; enddo
2795 endif
2796 endif
2797 enddo
2798
2799end subroutine copy_obc_radiation_coefs
2800
2801!> Copy restart fields OBC%tres_x/y to per-segment tracer reservoir segment%tr_Reg%Tr(m)%tres.
2802subroutine copy_obc_tracer_reservoirs(OBC)
2803 type(ocean_obc_type), pointer :: obc !< Open boundary control structure
2804
2805 ! Local variables
2806 type(obc_segment_type), pointer :: segment => null()
2807 integer :: n, m, i, j, k, is, ie, js, je, nz
2808
2809 if (.not. associated(obc)) return
2810 ! The allocated checks are needed for some user cases (e.g. "dyed_obcs"), where per-segment
2811 ! tracers are registered after global restart arrays OBC%tres_x/y are allocated (or not).
2812 if (.not. (allocated(obc%tres_x) .or. allocated(obc%tres_y))) return
2813
2814 nz = obc%ke
2815 do n=1, obc%number_of_segments
2816 segment => obc%segment(n)
2817 if (.not. (segment%on_pe .and. associated(segment%tr_Reg))) cycle
2818 if (segment%is_E_or_W .and. allocated(obc%tres_x)) then ! EW segment
2819 i = segment%HI%IsdB ; js = segment%HI%jsd ; je = segment%HI%jed
2820 do m=1, segment%tr_Reg%ntseg ; do k=1,nz ; do j=js,je
2821 segment%tr_Reg%Tr(m)%tres(i,j,k) = segment%tr_Reg%Tr(m)%scale * obc%tres_x(i,j,k,m)
2822 enddo ; enddo ; enddo
2823 elseif (segment%is_N_or_S .and. allocated(obc%tres_y)) then ! NS segment
2824 j = segment%HI%JsdB ; is = segment%HI%isd ; ie = segment%HI%ied
2825 do m=1, segment%tr_Reg%ntseg ; do k=1,nz ; do i=is,ie
2826 segment%tr_Reg%Tr(m)%tres(i,j,k) = segment%tr_Reg%Tr(m)%scale * obc%tres_y(i,j,k,m)
2827 enddo ; enddo ; enddo
2828 endif
2829 enddo ! end segment loop
2830end subroutine copy_obc_tracer_reservoirs
2831
2832!> Fill segment%h_Reg from restart fields.
2833subroutine copy_obc_thickness_reservoirs(OBC, G, GV)
2834 type(ocean_grid_type), intent(inout) :: g !< Ocean grid structure
2835 type(verticalgrid_type), intent(in) :: gv !< The ocean's vertical grid structure
2836 type(ocean_obc_type), pointer :: obc !< Open boundary control structure
2837 ! Local variables
2838 type(obc_segment_type), pointer :: segment => null()
2839 integer :: i, j, k, n
2840 logical :: sym
2841
2842 if (.not.associated(obc)) return
2843
2844 if (.not.(obc%thickness_x_reservoirs_used .or. obc%thickness_y_reservoirs_used)) &
2845 return
2846
2847 ! Now thickness reservoirs
2848 do n=1,obc%number_of_segments
2849 segment=>obc%segment(n)
2850 if (associated(segment%h_Reg)) then
2851 if (segment%is_E_or_W) then
2852 i = segment%HI%IsdB
2853 if (allocated(segment%h_Reg%h_res)) then
2854 do k=1,gv%ke
2855 do j=segment%HI%jsd,segment%HI%jed
2856 segment%h_Reg%h_res(i,j,k) = segment%h_Reg%scale * obc%h_res_x(i,j,k)
2857 enddo
2858 enddo
2859 endif
2860 else
2861 j = segment%HI%JsdB
2862 if (allocated(segment%h_Reg%h_res)) then
2863 do k=1,gv%ke
2864 do i=segment%HI%isd,segment%HI%ied
2865 segment%h_Reg%h_res(i,j,k) = segment%h_Reg%scale * obc%h_res_y(i,j,k)
2866 enddo
2867 enddo
2868 endif
2869 endif
2870 endif
2871 enddo
2872
2873 if (obc%debug) then
2874 sym = g%Domain%symmetric
2875 if (allocated(obc%h_res_x) .and. allocated(obc%h_res_y)) then
2876 call uvchksum("radiation_OBCs: OBC%h_res_[xy]", obc%h_res_x(:,:,:), obc%h_res_y(:,:,:), g%HI, &
2877 haloshift=0, symmetric=sym, scalar_pair=.true., unscale=1.0)
2878 endif
2879 endif
2880
2881end subroutine copy_obc_thickness_reservoirs
2882
2883!> Apply radiation conditions to 3D u,v at open boundaries
2884subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US, dt)
2885 type(ocean_grid_type), intent(inout) :: g !< Ocean grid structure
2886 type(verticalgrid_type), intent(in) :: gv !< The ocean's vertical grid structure
2887 type(ocean_obc_type), pointer :: obc !< Open boundary control structure
2888 real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: u_new !< On exit, new u values on open boundaries
2889 !! On entry, the old time-level u but including
2890 !! barotropic accelerations [L T-1 ~> m s-1].
2891 real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: u_old !< Original unadjusted u [L T-1 ~> m s-1]
2892 real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: v_new !< On exit, new v values on open boundaries.
2893 !! On entry, the old time-level v but including
2894 !! barotropic accelerations [L T-1 ~> m s-1].
2895 real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: v_old !< Original unadjusted v [L T-1 ~> m s-1]
2896 type(unit_scale_type), intent(in) :: us !< A dimensional unit scaling type
2897 real, intent(in) :: dt !< Appropriate timestep [T ~> s]
2898 ! Local variables
2899 real :: dhdt, dhdx, dhdy ! One-point differences in time or space [L T-1 ~> m s-1]
2900 real :: gamma_u, gamma_2 ! Fractional weightings of new values [nondim]
2901 real :: tau ! A local nudging timescale [T ~> s]
2902 real :: rx_max, ry_max ! coefficients for radiation [nondim]
2903 real :: rx_new, rx_avg ! coefficients for radiation [nondim] or [L2 T-2 ~> m2 s-2]
2904 real :: ry_new, ry_avg ! coefficients for radiation [nondim] or [L2 T-2 ~> m2 s-2]
2905 real :: cff_new, cff_avg ! denominator in oblique [L2 T-2 ~> m2 s-2]
2906 real, allocatable, dimension(:,:,:) :: &
2907 rx_tang_rad, & ! The phase speed at u-points for tangential oblique OBCs
2908 ! in units of grid points per timestep [nondim],
2909 ! discretized at the corner (PV) points.
2910 ry_tang_rad, & ! The phase speed at v-points for tangential oblique OBCs
2911 ! in units of grid points per timestep [nondim],
2912 ! discretized at the corner (PV) points.
2913 rx_tang_obl, & ! The x-coefficient for tangential oblique OBCs [L2 T-2 ~> m2 s-2],
2914 ! discretized at the corner (PV) points.
2915 ry_tang_obl, & ! The y-coefficient for tangential oblique OBCs [L2 T-2 ~> m2 s-2],
2916 ! discretized at the corner (PV) points.
2917 cff_tangential ! The denominator for tangential oblique OBCs [L2 T-2 ~> m2 s-2],
2918 ! discretized at the corner (PV) points.
2919 real :: eps ! A small velocity squared [L2 T-2 ~> m2 s-2]
2920 type(obc_segment_type), pointer :: segment => null()
2921 integer :: i, j, k, is, ie, js, je, m, nz, n
2922 integer :: is_obc, ie_obc, js_obc, je_obc
2923 logical :: sym
2924 character(len=3) :: var_num
2925
2926 is = g%isc ; ie = g%iec ; js = g%jsc ; je = g%jec ; nz = gv%ke
2927
2928 if (.not.associated(obc)) return
2929
2930 if (.not.(obc%open_u_BCs_exist_globally .or. obc%open_v_BCs_exist_globally)) &
2931 return
2932
2933 if (obc%debug) call chksum_obc_segments(obc, g, gv, us, obc%nk_OBC_debug)
2934
2935 eps = 1.0e-20*us%m_s_to_L_T**2
2936
2937 gamma_u = obc%gamma_uv
2938 rx_max = obc%rx_max ; ry_max = obc%rx_max
2939 do n=1,obc%number_of_segments
2940 segment => obc%segment(n)
2941 if (.not. segment%on_pe) cycle
2942 if (segment%oblique) call gradient_at_q_points(g, gv, segment, u_new(:,:,:), v_new(:,:,:))
2943 if (segment%direction == obc_direction_e) then
2944 i=segment%HI%IsdB
2945 if (i<g%HI%IscB) cycle
2946 do k=1,nz ; do j=segment%HI%jsd,segment%HI%jed
2947 if (segment%radiation) then
2948 dhdt = (u_old(i-1,j,k) - u_new(i-1,j,k)) !old-new
2949 dhdx = (u_new(i-1,j,k) - u_new(i-2,j,k)) !in new time backward sashay for I-1
2950 rx_new = 0.0
2951 if (dhdt*dhdx > 0.0) rx_new = min( (dhdt/dhdx), rx_max) ! outward phase speed
2952 if (gamma_u < 1.0) then
2953 rx_avg = (1.0-gamma_u)*segment%rx_norm_rad(i,j,k) + gamma_u*rx_new
2954 else
2955 rx_avg = rx_new
2956 endif
2957 segment%rx_norm_rad(i,j,k) = rx_avg
2958 ! The new boundary value is interpolated between future interior
2959 ! value, u_new(I-1) and past boundary value but with barotropic
2960 ! accelerations, u_new(I).
2961 segment%normal_vel(i,j,k) = (u_new(i,j,k) + rx_avg*u_new(i-1,j,k)) / (1.0+rx_avg)
2962 ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues
2963 ! implemented as a work-around to limitations in restart capability
2964 if (gamma_u < 1.0) then
2965 obc%rx_normal(i,j,k) = segment%rx_norm_rad(i,j,k)
2966 endif
2967 elseif (segment%oblique) then
2968 dhdt = (u_old(i-1,j,k) - u_new(i-1,j,k)) !old-new
2969 dhdx = (u_new(i-1,j,k) - u_new(i-2,j,k)) !in new time backward sashay for I-1
2970 if (dhdt*(segment%grad_normal(j,1,k) + segment%grad_normal(j-1,1,k)) > 0.0) then
2971 dhdy = segment%grad_normal(j-1,1,k)
2972 elseif (dhdt*(segment%grad_normal(j,1,k) + segment%grad_normal(j-1,1,k)) == 0.0) then
2973 dhdy = 0.0
2974 else
2975 dhdy = segment%grad_normal(j,1,k)
2976 endif
2977 if (dhdt*dhdx < 0.0) dhdt = 0.0
2978 cff_new = max((dhdx*dhdx) + (dhdy*dhdy), eps)
2979 rx_new = min(dhdt*dhdx, cff_new*rx_max)
2980 ry_new = min(cff_new,max(dhdt*dhdy,-cff_new))
2981 if (gamma_u < 1.0) then
2982 rx_avg = (1.0-gamma_u)*segment%rx_norm_obl(i,j,k) + gamma_u*rx_new
2983 ry_avg = (1.0-gamma_u)*segment%ry_norm_obl(i,j,k) + gamma_u*ry_new
2984 cff_avg = (1.0-gamma_u)*segment%cff_normal(i,j,k) + gamma_u*cff_new
2985 else
2986 rx_avg = rx_new
2987 ry_avg = ry_new
2988 cff_avg = cff_new
2989 endif
2990 segment%rx_norm_obl(i,j,k) = rx_avg
2991 segment%ry_norm_obl(i,j,k) = ry_avg
2992 segment%cff_normal(i,j,k) = cff_avg
2993 segment%normal_vel(i,j,k) = ((cff_avg*u_new(i,j,k) + rx_avg*u_new(i-1,j,k)) - &
2994 (max(ry_avg,0.0)*segment%grad_normal(j-1,2,k) + &
2995 min(ry_avg,0.0)*segment%grad_normal(j,2,k))) / &
2996 (cff_avg + rx_avg)
2997 if (gamma_u < 1.0) then
2998 ! Copy restart fields into 3-d arrays. This is an inefficient and temporary
2999 ! implementation as a work-around to limitations in restart capability
3000 obc%rx_oblique_u(i,j,k) = segment%rx_norm_obl(i,j,k)
3001 obc%ry_oblique_u(i,j,k) = segment%ry_norm_obl(i,j,k)
3002 obc%cff_normal_u(i,j,k) = segment%cff_normal(i,j,k)
3003 endif
3004 elseif (segment%gradient) then
3005 segment%normal_vel(i,j,k) = u_new(i-1,j,k)
3006 endif
3007 if ((segment%radiation .or. segment%oblique) .and. segment%nudged) then
3008 ! dhdt gets set to 0 on inflow in oblique case
3009 if (dhdt*dhdx <= 0.0) then
3010 tau = segment%Velocity_nudging_timescale_in
3011 else
3012 tau = segment%Velocity_nudging_timescale_out
3013 endif
3014 gamma_2 = dt / (tau + dt)
3015 segment%normal_vel(i,j,k) = (1.0 - gamma_2) * segment%normal_vel(i,j,k) + &
3016 gamma_2 * segment%nudged_normal_vel(i,j,k)
3017 endif
3018 enddo ; enddo
3019 if (segment%radiation_tan .or. segment%radiation_grad) then
3020 i=segment%HI%IsdB
3021 allocate(rx_tang_rad(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz))
3022 do k=1,nz
3023 if (gamma_u < 1.0) then
3024 rx_tang_rad(i,segment%HI%JsdB,k) = segment%rx_norm_rad(i,segment%HI%jsd,k)
3025 rx_tang_rad(i,segment%HI%JedB,k) = segment%rx_norm_rad(i,segment%HI%jed,k)
3026 do j=segment%HI%JsdB+1,segment%HI%JedB-1
3027 rx_tang_rad(i,j,k) = 0.5*(segment%rx_norm_rad(i,j,k) + segment%rx_norm_rad(i,j+1,k))
3028 enddo
3029 else
3030 do j=segment%HI%JsdB,segment%HI%JedB
3031 dhdt = v_old(i,j,k)-v_new(i,j,k) !old-new
3032 dhdx = v_new(i,j,k)-v_new(i-1,j,k) !in new time backward sashay for I-1
3033 rx_tang_rad(i,j,k) = 0.0
3034 if (dhdt*dhdx > 0.0) rx_tang_rad(i,j,k) = min( (dhdt/dhdx), rx_max) ! outward phase speed
3035 enddo
3036 endif
3037 enddo
3038 if (segment%radiation_tan) then
3039 do k=1,nz ; do j=segment%HI%JsdB,segment%HI%JedB
3040 rx_avg = rx_tang_rad(i,j,k)
3041 segment%tangential_vel(i,j,k) = (v_new(i,j,k) + rx_avg*v_new(i-1,j,k)) / (1.0+rx_avg)
3042 enddo ; enddo
3043 endif
3044 if (segment%nudged_tan) then
3045 do k=1,nz ; do j=segment%HI%JsdB,segment%HI%JedB
3046 ! dhdt gets set to 0 on inflow in oblique case
3047 if (rx_tang_rad(i,j,k) <= 0.0) then
3048 tau = segment%Velocity_nudging_timescale_in
3049 else
3050 tau = segment%Velocity_nudging_timescale_out
3051 endif
3052 gamma_2 = dt / (tau + dt)
3053 segment%tangential_vel(i,j,k) = (1.0 - gamma_2) * segment%tangential_vel(i,j,k) + &
3054 gamma_2 * segment%nudged_tangential_vel(i,j,k)
3055 enddo ; enddo
3056 endif
3057 if (segment%radiation_grad) then
3058 js_obc = max(segment%HI%JsdB,g%jsd+1)
3059 je_obc = min(segment%HI%JedB,g%jed-1)
3060 do k=1,nz ; do j=js_obc,je_obc
3061 rx_avg = rx_tang_rad(i,j,k)
3062 ! if (G%mask2dCu(I-1,j) > 0.0 .and. G%mask2dCu(I-1,j+1) > 0.0) then
3063 ! rx_avg = 0.5*(u_new(I-1,j,k) + u_new(I-1,j+1,k)) * dt * G%IdxBu(I-1,J)
3064 ! elseif (G%mask2dCu(I-1,j) > 0.0) then
3065 ! rx_avg = u_new(I-1,j,k) * dt * G%IdxBu(I-1,J)
3066 ! elseif (G%mask2dCu(I-1,j+1) > 0.0) then
3067 ! rx_avg = u_new(I-1,j+1,k) * dt * G%IdxBu(I-1,J)
3068 ! else
3069 ! rx_avg = 0.0
3070 ! endif
3071 segment%tangential_grad(i,j,k) = ((v_new(i,j,k) - v_new(i-1,j,k))*g%IdxBu(i-1,j) + &
3072 rx_avg*(v_new(i-1,j,k) - v_new(i-2,j,k))*g%IdxBu(i-2,j)) / (1.0+rx_avg)
3073 enddo ; enddo
3074 endif
3075 if (segment%nudged_grad) then
3076 do k=1,nz ; do j=segment%HI%JsdB,segment%HI%JedB
3077 ! dhdt gets set to 0 on inflow in oblique case
3078 if (rx_tang_rad(i,j,k) <= 0.0) then
3079 tau = segment%Velocity_nudging_timescale_in
3080 else
3081 tau = segment%Velocity_nudging_timescale_out
3082 endif
3083 gamma_2 = dt / (tau + dt)
3084 segment%tangential_grad(i,j,k) = (1.0 - gamma_2) * segment%tangential_grad(i,j,k) + &
3085 gamma_2 * segment%nudged_tangential_grad(i,j,k)
3086 enddo ; enddo
3087 endif
3088 deallocate(rx_tang_rad)
3089 endif
3090 if (segment%oblique_tan .or. segment%oblique_grad) then
3091 i=segment%HI%IsdB
3092 allocate(rx_tang_obl(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz))
3093 allocate(ry_tang_obl(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz))
3094 allocate(cff_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz))
3095 do k=1,nz
3096 if (gamma_u < 1.0) then
3097 rx_tang_obl(i,segment%HI%JsdB,k) = segment%rx_norm_obl(i,segment%HI%jsd,k)
3098 rx_tang_obl(i,segment%HI%JedB,k) = segment%rx_norm_obl(i,segment%HI%jed,k)
3099 ry_tang_obl(i,segment%HI%JsdB,k) = segment%ry_norm_obl(i,segment%HI%jsd,k)
3100 ry_tang_obl(i,segment%HI%JedB,k) = segment%ry_norm_obl(i,segment%HI%jed,k)
3101 cff_tangential(i,segment%HI%JsdB,k) = segment%cff_normal(i,segment%HI%jsd,k)
3102 cff_tangential(i,segment%HI%JedB,k) = segment%cff_normal(i,segment%HI%jed,k)
3103 do j=segment%HI%JsdB+1,segment%HI%JedB-1
3104 rx_tang_obl(i,j,k) = 0.5*(segment%rx_norm_obl(i,j,k) + segment%rx_norm_obl(i,j+1,k))
3105 ry_tang_obl(i,j,k) = 0.5*(segment%ry_norm_obl(i,j,k) + segment%ry_norm_obl(i,j+1,k))
3106 cff_tangential(i,j,k) = 0.5*(segment%cff_normal(i,j,k) + segment%cff_normal(i,j+1,k))
3107 enddo
3108 else
3109 do j=segment%HI%JsdB,segment%HI%JedB
3110 dhdt = v_old(i,j,k)-v_new(i,j,k) !old-new
3111 dhdx = v_new(i,j,k)-v_new(i-1,j,k) !in new time backward sashay for I-1
3112 if (dhdt*(segment%grad_tan(j,1,k) + segment%grad_tan(j+1,1,k)) > 0.0) then
3113 dhdy = segment%grad_tan(j,1,k)
3114 elseif (dhdt*(segment%grad_tan(j,1,k) + segment%grad_tan(j+1,1,k)) == 0.0) then
3115 dhdy = 0.0
3116 else
3117 dhdy = segment%grad_tan(j+1,1,k)
3118 endif
3119 if (dhdt*dhdx < 0.0) dhdt = 0.0
3120 cff_new = max((dhdx*dhdx) + (dhdy*dhdy), eps)
3121 rx_new = min(dhdt*dhdx, cff_new*rx_max)
3122 ry_new = min(cff_new,max(dhdt*dhdy,-cff_new))
3123 rx_tang_obl(i,j,k) = rx_new
3124 ry_tang_obl(i,j,k) = ry_new
3125 cff_tangential(i,j,k) = cff_new
3126 enddo
3127 endif
3128 enddo
3129 if (segment%oblique_tan) then
3130 do k=1,nz ; do j=segment%HI%JsdB,segment%HI%JedB
3131 rx_avg = rx_tang_obl(i,j,k)
3132 ry_avg = ry_tang_obl(i,j,k)
3133 cff_avg = cff_tangential(i,j,k)
3134 segment%tangential_vel(i,j,k) = ((cff_avg*v_new(i,j,k) + rx_avg*v_new(i-1,j,k)) - &
3135 (max(ry_avg,0.0)*segment%grad_tan(j,2,k) + &
3136 min(ry_avg,0.0)*segment%grad_tan(j+1,2,k))) / &
3137 (cff_avg + rx_avg)
3138 enddo ; enddo
3139 endif
3140 if (segment%nudged_tan) then
3141 do k=1,nz ; do j=segment%HI%JsdB,segment%HI%JedB
3142 ! dhdt gets set to 0 on inflow in oblique case
3143 if (rx_tang_obl(i,j,k) <= 0.0) then
3144 tau = segment%Velocity_nudging_timescale_in
3145 else
3146 tau = segment%Velocity_nudging_timescale_out
3147 endif
3148 gamma_2 = dt / (tau + dt)
3149 segment%tangential_vel(i,j,k) = (1.0 - gamma_2) * segment%tangential_vel(i,j,k) + &
3150 gamma_2 * segment%nudged_tangential_vel(i,j,k)
3151 enddo ; enddo
3152 endif
3153 if (segment%oblique_grad) then
3154 js_obc = max(segment%HI%JsdB,g%jsd+1)
3155 je_obc = min(segment%HI%JedB,g%jed-1)
3156 do k=1,nz ; do j=segment%HI%JsdB+1,segment%HI%JedB-1
3157 rx_avg = rx_tang_obl(i,j,k)
3158 ry_avg = ry_tang_obl(i,j,k)
3159 cff_avg = cff_tangential(i,j,k)
3160 segment%tangential_grad(i,j,k) = &
3161 ((cff_avg*(v_new(i,j,k) - v_new(i-1,j,k))*g%IdxBu(i-1,j) + &
3162 rx_avg*(v_new(i-1,j,k) - v_new(i-2,j,k))*g%IdxBu(i-2,j)) - &
3163 (max(ry_avg,0.0)*segment%grad_gradient(j,2,k) + &
3164 min(ry_avg,0.0)*segment%grad_gradient(j+1,2,k)) ) / &
3165 (cff_avg + rx_avg)
3166 enddo ; enddo
3167 endif
3168 if (segment%nudged_grad) then
3169 do k=1,nz ; do j=segment%HI%JsdB,segment%HI%JedB
3170 ! dhdt gets set to 0 on inflow in oblique case
3171 if (rx_tang_obl(i,j,k) <= 0.0) then
3172 tau = segment%Velocity_nudging_timescale_in
3173 else
3174 tau = segment%Velocity_nudging_timescale_out
3175 endif
3176 gamma_2 = dt / (tau + dt)
3177 segment%tangential_grad(i,j,k) = (1.0 - gamma_2) * segment%tangential_grad(i,j,k) + &
3178 gamma_2 * segment%nudged_tangential_grad(i,j,k)
3179 enddo ; enddo
3180 endif
3181 deallocate(rx_tang_obl)
3182 deallocate(ry_tang_obl)
3183 deallocate(cff_tangential)
3184 endif
3185 endif
3186
3187 if (segment%direction == obc_direction_w) then
3188 i=segment%HI%IsdB
3189 if (i>g%HI%IecB) cycle
3190 do k=1,nz ; do j=segment%HI%jsd,segment%HI%jed
3191 if (segment%radiation) then
3192 dhdt = (u_old(i+1,j,k) - u_new(i+1,j,k)) !old-new
3193 dhdx = (u_new(i+1,j,k) - u_new(i+2,j,k)) !in new time forward sashay for I+1
3194 rx_new = 0.0
3195 if (dhdt*dhdx > 0.0) rx_new = min( (dhdt/dhdx), rx_max)
3196 if (gamma_u < 1.0) then
3197 rx_avg = (1.0-gamma_u)*segment%rx_norm_rad(i,j,k) + gamma_u*rx_new
3198 else
3199 rx_avg = rx_new
3200 endif
3201 segment%rx_norm_rad(i,j,k) = rx_avg
3202 ! The new boundary value is interpolated between future interior
3203 ! value, u_new(I+1) and past boundary value but with barotropic
3204 ! accelerations, u_new(I).
3205 segment%normal_vel(i,j,k) = (u_new(i,j,k) + rx_avg*u_new(i+1,j,k)) / (1.0+rx_avg)
3206 if (gamma_u < 1.0) then
3207 ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues
3208 ! implemented as a work-around to limitations in restart capability
3209 obc%rx_normal(i,j,k) = segment%rx_norm_rad(i,j,k)
3210 endif
3211 elseif (segment%oblique) then
3212 dhdt = (u_old(i+1,j,k) - u_new(i+1,j,k)) !old-new
3213 dhdx = (u_new(i+1,j,k) - u_new(i+2,j,k)) !in new time forward sashay for I+1
3214 if (dhdt*(segment%grad_normal(j,1,k) + segment%grad_normal(j-1,1,k)) > 0.0) then
3215 dhdy = segment%grad_normal(j-1,1,k)
3216 elseif (dhdt*(segment%grad_normal(j,1,k) + segment%grad_normal(j-1,1,k)) == 0.0) then
3217 dhdy = 0.0
3218 else
3219 dhdy = segment%grad_normal(j,1,k)
3220 endif
3221 if (dhdt*dhdx < 0.0) dhdt = 0.0
3222
3223 cff_new = max((dhdx*dhdx) + (dhdy*dhdy), eps)
3224 rx_new = min(dhdt*dhdx, cff_new*rx_max)
3225 ry_new = min(cff_new,max(dhdt*dhdy,-cff_new))
3226 if (gamma_u < 1.0) then
3227 rx_avg = (1.0-gamma_u)*segment%rx_norm_obl(i,j,k) + gamma_u*rx_new
3228 ry_avg = (1.0-gamma_u)*segment%ry_norm_obl(i,j,k) + gamma_u*ry_new
3229 cff_avg = (1.0-gamma_u)*segment%cff_normal(i,j,k) + gamma_u*cff_new
3230 else
3231 rx_avg = rx_new
3232 ry_avg = ry_new
3233 cff_avg = cff_new
3234 endif
3235 segment%rx_norm_obl(i,j,k) = rx_avg
3236 segment%ry_norm_obl(i,j,k) = ry_avg
3237 segment%cff_normal(i,j,k) = cff_avg
3238 segment%normal_vel(i,j,k) = ((cff_avg*u_new(i,j,k) + rx_avg*u_new(i+1,j,k)) - &
3239 (max(ry_avg,0.0)*segment%grad_normal(j-1,2,k) + &
3240 min(ry_avg,0.0)*segment%grad_normal(j,2,k))) / &
3241 (cff_avg + rx_avg)
3242 if (gamma_u < 1.0) then
3243 ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues
3244 ! implemented as a work-around to limitations in restart capability
3245 obc%rx_oblique_u(i,j,k) = segment%rx_norm_obl(i,j,k)
3246 obc%ry_oblique_u(i,j,k) = segment%ry_norm_obl(i,j,k)
3247 obc%cff_normal_u(i,j,k) = segment%cff_normal(i,j,k)
3248 endif
3249 elseif (segment%gradient) then
3250 segment%normal_vel(i,j,k) = u_new(i+1,j,k)
3251 endif
3252 if ((segment%radiation .or. segment%oblique) .and. segment%nudged) then
3253 ! dhdt gets set to 0. on inflow in oblique case
3254 if (dhdt*dhdx <= 0.0) then
3255 tau = segment%Velocity_nudging_timescale_in
3256 else
3257 tau = segment%Velocity_nudging_timescale_out
3258 endif
3259 gamma_2 = dt / (tau + dt)
3260 segment%normal_vel(i,j,k) = (1.0 - gamma_2) * segment%normal_vel(i,j,k) + &
3261 gamma_2 * segment%nudged_normal_vel(i,j,k)
3262 endif
3263 enddo ; enddo
3264 if (segment%radiation_tan .or. segment%radiation_grad) then
3265 i=segment%HI%IsdB
3266 allocate(rx_tang_rad(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz))
3267 do k=1,nz
3268 if (gamma_u < 1.0) then
3269 rx_tang_rad(i,segment%HI%JsdB,k) = segment%rx_norm_rad(i,segment%HI%jsd,k)
3270 rx_tang_rad(i,segment%HI%JedB,k) = segment%rx_norm_rad(i,segment%HI%jed,k)
3271 do j=segment%HI%JsdB+1,segment%HI%JedB-1
3272 rx_tang_rad(i,j,k) = 0.5*(segment%rx_norm_rad(i,j,k) + segment%rx_norm_rad(i,j+1,k))
3273 enddo
3274 else
3275 do j=segment%HI%JsdB,segment%HI%JedB
3276 dhdt = v_old(i+1,j,k)-v_new(i+1,j,k) !old-new
3277 dhdx = v_new(i+1,j,k)-v_new(i+2,j,k) !in new time backward sashay for I-1
3278 rx_tang_rad(i,j,k) = 0.0
3279 if (dhdt*dhdx > 0.0) rx_tang_rad(i,j,k) = min( (dhdt/dhdx), rx_max) ! outward phase speed
3280 enddo
3281 endif
3282 enddo
3283 if (segment%radiation_tan) then
3284 do k=1,nz ; do j=segment%HI%JsdB,segment%HI%JedB
3285 rx_avg = rx_tang_rad(i,j,k)
3286 segment%tangential_vel(i,j,k) = (v_new(i+1,j,k) + rx_avg*v_new(i+2,j,k)) / (1.0+rx_avg)
3287 enddo ; enddo
3288 endif
3289 if (segment%nudged_tan) then
3290 do k=1,nz ; do j=segment%HI%JsdB,segment%HI%JedB
3291 ! dhdt gets set to 0 on inflow in oblique case
3292 if (rx_tang_rad(i,j,k) <= 0.0) then
3293 tau = segment%Velocity_nudging_timescale_in
3294 else
3295 tau = segment%Velocity_nudging_timescale_out
3296 endif
3297 gamma_2 = dt / (tau + dt)
3298 segment%tangential_vel(i,j,k) = (1.0 - gamma_2) * segment%tangential_vel(i,j,k) + &
3299 gamma_2 * segment%nudged_tangential_vel(i,j,k)
3300 enddo ; enddo
3301 endif
3302 if (segment%radiation_grad) then
3303 js_obc = max(segment%HI%JsdB,g%jsd+1)
3304 je_obc = min(segment%HI%JedB,g%jed-1)
3305 do k=1,nz ; do j=js_obc,je_obc
3306 rx_avg = rx_tang_rad(i,j,k)
3307 ! if (G%mask2dCu(I+1,j) > 0.0 .and. G%mask2dCu(I+1,j+1) > 0.0) then
3308 ! rx_avg = 0.5*(u_new(I+1,j,k) + u_new(I+1,j+1,k)) * dt * G%IdxBu(I+1,J)
3309 ! elseif (G%mask2dCu(I+1,j) > 0.0) then
3310 ! rx_avg = u_new(I+1,j,k) * dt * G%IdxBu(I+1,J)
3311 ! elseif (G%mask2dCu(I+1,j+1) > 0.0) then
3312 ! rx_avg = u_new(I+1,j+1,k) * dt * G%IdxBu(I+1,J)
3313 ! else
3314 ! rx_avg = 0.0
3315 ! endif
3316 segment%tangential_grad(i,j,k) = ((v_new(i+2,j,k) - v_new(i+1,j,k))*g%IdxBu(i+1,j) + &
3317 rx_avg*(v_new(i+3,j,k) - v_new(i+2,j,k))*g%IdxBu(i+2,j)) / (1.0+rx_avg)
3318 enddo ; enddo
3319 endif
3320 if (segment%nudged_grad) then
3321 do k=1,nz ; do j=segment%HI%JsdB,segment%HI%JedB
3322 ! dhdt gets set to 0 on inflow in oblique case
3323 if (rx_tang_rad(i,j,k) <= 0.0) then
3324 tau = segment%Velocity_nudging_timescale_in
3325 else
3326 tau = segment%Velocity_nudging_timescale_out
3327 endif
3328 gamma_2 = dt / (tau + dt)
3329 segment%tangential_grad(i,j,k) = (1.0 - gamma_2) * segment%tangential_grad(i,j,k) + &
3330 gamma_2 * segment%nudged_tangential_grad(i,j,k)
3331 enddo ; enddo
3332 endif
3333 deallocate(rx_tang_rad)
3334 endif
3335 if (segment%oblique_tan .or. segment%oblique_grad) then
3336 i=segment%HI%IsdB
3337 allocate(rx_tang_obl(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz))
3338 allocate(ry_tang_obl(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz))
3339 allocate(cff_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz))
3340 do k=1,nz
3341 if (gamma_u < 1.0) then
3342 rx_tang_obl(i,segment%HI%JsdB,k) = segment%rx_norm_obl(i,segment%HI%jsd,k)
3343 rx_tang_obl(i,segment%HI%JedB,k) = segment%rx_norm_obl(i,segment%HI%jed,k)
3344 ry_tang_obl(i,segment%HI%JsdB,k) = segment%ry_norm_obl(i,segment%HI%jsd,k)
3345 ry_tang_obl(i,segment%HI%JedB,k) = segment%ry_norm_obl(i,segment%HI%jed,k)
3346 cff_tangential(i,segment%HI%JsdB,k) = segment%cff_normal(i,segment%HI%jsd,k)
3347 cff_tangential(i,segment%HI%JedB,k) = segment%cff_normal(i,segment%HI%jed,k)
3348 do j=segment%HI%JsdB+1,segment%HI%JedB-1
3349 rx_tang_obl(i,j,k) = 0.5*(segment%rx_norm_obl(i,j,k) + segment%rx_norm_obl(i,j+1,k))
3350 ry_tang_obl(i,j,k) = 0.5*(segment%ry_norm_obl(i,j,k) + segment%ry_norm_obl(i,j+1,k))
3351 cff_tangential(i,j,k) = 0.5*(segment%cff_normal(i,j,k) + segment%cff_normal(i,j+1,k))
3352 enddo
3353 else
3354 do j=segment%HI%JsdB,segment%HI%JedB
3355 dhdt = v_old(i+1,j,k)-v_new(i+1,j,k) !old-new
3356 dhdx = v_new(i+1,j,k)-v_new(i+2,j,k) !in new time backward sashay for I-1
3357 if (dhdt*(segment%grad_tan(j,1,k) + segment%grad_tan(j+1,1,k)) > 0.0) then
3358 dhdy = segment%grad_tan(j,1,k)
3359 elseif (dhdt*(segment%grad_tan(j,1,k) + segment%grad_tan(j+1,1,k)) == 0.0) then
3360 dhdy = 0.0
3361 else
3362 dhdy = segment%grad_tan(j+1,1,k)
3363 endif
3364 if (dhdt*dhdx < 0.0) dhdt = 0.0
3365 cff_new = max((dhdx*dhdx) + (dhdy*dhdy), eps)
3366 rx_new = min(dhdt*dhdx, cff_new*rx_max)
3367 ry_new = min(cff_new,max(dhdt*dhdy,-cff_new))
3368 rx_tang_obl(i,j,k) = rx_new
3369 ry_tang_obl(i,j,k) = ry_new
3370 cff_tangential(i,j,k) = cff_new
3371 enddo
3372 endif
3373 enddo
3374 if (segment%oblique_tan) then
3375 do k=1,nz ; do j=segment%HI%JsdB,segment%HI%JedB
3376 rx_avg = rx_tang_obl(i,j,k)
3377 ry_avg = ry_tang_obl(i,j,k)
3378 cff_avg = cff_tangential(i,j,k)
3379 segment%tangential_vel(i,j,k) = ((cff_avg*v_new(i+1,j,k) + rx_avg*v_new(i+2,j,k)) - &
3380 (max(ry_avg,0.0)*segment%grad_tan(j,2,k) + &
3381 min(ry_avg,0.0)*segment%grad_tan(j+1,2,k))) / &
3382 (cff_avg + rx_avg)
3383 enddo ; enddo
3384 endif
3385 if (segment%nudged_tan) then
3386 do k=1,nz ; do j=segment%HI%JsdB,segment%HI%JedB
3387 ! dhdt gets set to 0 on inflow in oblique case
3388 if (rx_tang_obl(i,j,k) <= 0.0) then
3389 tau = segment%Velocity_nudging_timescale_in
3390 else
3391 tau = segment%Velocity_nudging_timescale_out
3392 endif
3393 gamma_2 = dt / (tau + dt)
3394 segment%tangential_vel(i,j,k) = (1.0 - gamma_2) * segment%tangential_vel(i,j,k) + &
3395 gamma_2 * segment%nudged_tangential_vel(i,j,k)
3396 enddo ; enddo
3397 endif
3398 if (segment%oblique_grad) then
3399 js_obc = max(segment%HI%JsdB,g%jsd+1)
3400 je_obc = min(segment%HI%JedB,g%jed-1)
3401 do k=1,nz ; do j=segment%HI%JsdB+1,segment%HI%JedB-1
3402 rx_avg = rx_tang_obl(i,j,k)
3403 ry_avg = ry_tang_obl(i,j,k)
3404 cff_avg = cff_tangential(i,j,k)
3405 segment%tangential_grad(i,j,k) = &
3406 ((cff_avg*(v_new(i+2,j,k) - v_new(i+1,j,k))*g%IdxBu(i+1,j) + &
3407 rx_avg*(v_new(i+3,j,k) - v_new(i+2,j,k))*g%IdxBu(i+2,j)) - &
3408 (max(ry_avg,0.0)*segment%grad_gradient(j,2,k) + &
3409 min(ry_avg,0.0)*segment%grad_gradient(j+1,2,k))) / &
3410 (cff_avg + rx_avg)
3411 enddo ; enddo
3412 endif
3413 if (segment%nudged_grad) then
3414 do k=1,nz ; do j=segment%HI%JsdB,segment%HI%JedB
3415 ! dhdt gets set to 0 on inflow in oblique case
3416 if (rx_tang_obl(i,j,k) <= 0.0) then
3417 tau = segment%Velocity_nudging_timescale_in
3418 else
3419 tau = segment%Velocity_nudging_timescale_out
3420 endif
3421 gamma_2 = dt / (tau + dt)
3422 segment%tangential_grad(i,j,k) = (1.0 - gamma_2) * segment%tangential_grad(i,j,k) + &
3423 gamma_2 * segment%nudged_tangential_grad(i,j,k)
3424 enddo ; enddo
3425 endif
3426 deallocate(rx_tang_obl)
3427 deallocate(ry_tang_obl)
3428 deallocate(cff_tangential)
3429 endif
3430 endif
3431
3432 if (segment%direction == obc_direction_n) then
3433 j=segment%HI%JsdB
3434 if (j<g%HI%JscB) cycle
3435 do k=1,nz ; do i=segment%HI%isd,segment%HI%ied
3436 if (segment%radiation) then
3437 dhdt = (v_old(i,j-1,k) - v_new(i,j-1,k)) !old-new
3438 dhdy = (v_new(i,j-1,k) - v_new(i,j-2,k)) !in new time backward sashay for J-1
3439 ry_new = 0.0
3440 if (dhdt*dhdy > 0.0) ry_new = min( (dhdt/dhdy), ry_max)
3441 if (gamma_u < 1.0) then
3442 ry_avg = (1.0-gamma_u)*segment%ry_norm_rad(i,j,k) + gamma_u*ry_new
3443 else
3444 ry_avg = ry_new
3445 endif
3446 segment%ry_norm_rad(i,j,k) = ry_avg
3447 ! The new boundary value is interpolated between future interior
3448 ! value, v_new(J-1) and past boundary value but with barotropic
3449 ! accelerations, v_new(J).
3450 segment%normal_vel(i,j,k) = (v_new(i,j,k) + ry_avg*v_new(i,j-1,k)) / (1.0+ry_avg)
3451 if (gamma_u < 1.0) then
3452 ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues
3453 ! implemented as a work-around to limitations in restart capability
3454 obc%ry_normal(i,j,k) = segment%ry_norm_rad(i,j,k)
3455 endif
3456 elseif (segment%oblique) then
3457 dhdt = (v_old(i,j-1,k) - v_new(i,j-1,k)) !old-new
3458 dhdy = (v_new(i,j-1,k) - v_new(i,j-2,k)) !in new time backward sashay for J-1
3459 if (dhdt*(segment%grad_normal(i,1,k) + segment%grad_normal(i-1,1,k)) > 0.0) then
3460 dhdx = segment%grad_normal(i-1,1,k)
3461 elseif (dhdt*(segment%grad_normal(i,1,k) + segment%grad_normal(i-1,1,k)) == 0.0) then
3462 dhdx = 0.0
3463 else
3464 dhdx = segment%grad_normal(i,1,k)
3465 endif
3466 if (dhdt*dhdy < 0.0) dhdt = 0.0
3467 cff_new = max((dhdx*dhdx) + (dhdy*dhdy), eps)
3468 ry_new = min(dhdt*dhdy, cff_new*ry_max)
3469 rx_new = min(cff_new,max(dhdt*dhdx,-cff_new))
3470 if (gamma_u < 1.0) then
3471 rx_avg = (1.0-gamma_u)*segment%rx_norm_obl(i,j,k) + gamma_u*rx_new
3472 ry_avg = (1.0-gamma_u)*segment%ry_norm_obl(i,j,k) + gamma_u*ry_new
3473 cff_avg = (1.0-gamma_u)*segment%cff_normal(i,j,k) + gamma_u*cff_new
3474 else
3475 rx_avg = rx_new
3476 ry_avg = ry_new
3477 cff_avg = cff_new
3478 endif
3479 segment%rx_norm_obl(i,j,k) = rx_avg
3480 segment%ry_norm_obl(i,j,k) = ry_avg
3481 segment%cff_normal(i,j,k) = cff_avg
3482 segment%normal_vel(i,j,k) = ((cff_avg*v_new(i,j,k) + ry_avg*v_new(i,j-1,k)) - &
3483 (max(rx_avg,0.0)*segment%grad_normal(i-1,2,k) +&
3484 min(rx_avg,0.0)*segment%grad_normal(i,2,k))) / &
3485 (cff_avg + ry_avg)
3486 if (gamma_u < 1.0) then
3487 ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues
3488 ! implemented as a work-around to limitations in restart capability
3489 obc%rx_oblique_v(i,j,k) = segment%rx_norm_obl(i,j,k)
3490 obc%ry_oblique_v(i,j,k) = segment%ry_norm_obl(i,j,k)
3491 obc%cff_normal_v(i,j,k) = segment%cff_normal(i,j,k)
3492 endif
3493 elseif (segment%gradient) then
3494 segment%normal_vel(i,j,k) = v_new(i,j-1,k)
3495 endif
3496 if ((segment%radiation .or. segment%oblique) .and. segment%nudged) then
3497 ! dhdt gets set to 0 on inflow in oblique case
3498 if (dhdt*dhdy <= 0.0) then
3499 tau = segment%Velocity_nudging_timescale_in
3500 else
3501 tau = segment%Velocity_nudging_timescale_out
3502 endif
3503 gamma_2 = dt / (tau + dt)
3504 segment%normal_vel(i,j,k) = (1.0 - gamma_2) * segment%normal_vel(i,j,k) + &
3505 gamma_2 * segment%nudged_normal_vel(i,j,k)
3506 endif
3507 enddo ; enddo
3508 if (segment%radiation_tan .or. segment%radiation_grad) then
3509 j=segment%HI%JsdB
3510 allocate(ry_tang_rad(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz))
3511 do k=1,nz
3512 if (gamma_u < 1.0) then
3513 ry_tang_rad(segment%HI%IsdB,j,k) = segment%ry_norm_rad(segment%HI%isd,j,k)
3514 ry_tang_rad(segment%HI%IedB,j,k) = segment%ry_norm_rad(segment%HI%ied,j,k)
3515 do i=segment%HI%IsdB+1,segment%HI%IedB-1
3516 ry_tang_rad(i,j,k) = 0.5*(segment%ry_norm_rad(i,j,k) + segment%ry_norm_rad(i+1,j,k))
3517 enddo
3518 else
3519 do i=segment%HI%IsdB,segment%HI%IedB
3520 dhdt = u_old(i,j-1,k)-u_new(i,j-1,k) !old-new
3521 dhdy = u_new(i,j-1,k)-u_new(i,j-2,k) !in new time backward sashay for I-1
3522 ry_tang_rad(i,j,k) = 0.0
3523 if (dhdt*dhdy > 0.0) ry_tang_rad(i,j,k) = min( (dhdt/dhdy), rx_max) ! outward phase speed
3524 enddo
3525 endif
3526 enddo
3527 if (segment%radiation_tan) then
3528 do k=1,nz ; do i=segment%HI%IsdB,segment%HI%IedB
3529 ry_avg = ry_tang_rad(i,j,k)
3530 segment%tangential_vel(i,j,k) = (u_new(i,j,k) + ry_avg*u_new(i,j-1,k)) / (1.0+ry_avg)
3531 enddo ; enddo
3532 endif
3533 if (segment%nudged_tan) then
3534 do k=1,nz ; do i=segment%HI%IsdB,segment%HI%IedB
3535 ! dhdt gets set to 0 on inflow in oblique case
3536 if (ry_tang_rad(i,j,k) <= 0.0) then
3537 tau = segment%Velocity_nudging_timescale_in
3538 else
3539 tau = segment%Velocity_nudging_timescale_out
3540 endif
3541 gamma_2 = dt / (tau + dt)
3542 segment%tangential_vel(i,j,k) = (1.0 - gamma_2) * segment%tangential_vel(i,j,k) + &
3543 gamma_2 * segment%nudged_tangential_vel(i,j,k)
3544 enddo ; enddo
3545 endif
3546 if (segment%radiation_grad) then
3547 is_obc = max(segment%HI%IsdB,g%isd+1)
3548 ie_obc = min(segment%HI%IedB,g%ied-1)
3549 do k=1,nz ; do i=is_obc,ie_obc
3550 ry_avg = ry_tang_rad(i,j,k)
3551 ! if (G%mask2dCv(i,J-1) > 0.0 .and. G%mask2dCv(i+1,J-1) > 0.0) then
3552 ! ry_avg = 0.5*(v_new(i,J-1,k) + v_new(i+1,J-1,k) * dt * G%IdyBu(I,J-1))
3553 ! elseif (G%mask2dCv(i,J-1) > 0.0) then
3554 ! ry_avg = v_new(i,J-1,k) * dt *G%IdyBu(I,J-1)
3555 ! elseif (G%mask2dCv(i+1,J-1) > 0.0) then
3556 ! ry_avg = v_new(i+1,J-1,k) * dt *G%IdyBu(I,J-1)
3557 ! else
3558 ! ry_avg = 0.0
3559 ! endif
3560 segment%tangential_grad(i,j,k) = ((u_new(i,j,k) - u_new(i,j-1,k))*g%IdyBu(i,j-1) + &
3561 ry_avg*(u_new(i,j-1,k) - u_new(i,j-2,k))*g%IdyBu(i,j-2)) / (1.0+ry_avg)
3562 enddo ; enddo
3563 endif
3564 if (segment%nudged_grad) then
3565 do k=1,nz ; do i=segment%HI%IsdB,segment%HI%IedB
3566 ! dhdt gets set to 0 on inflow in oblique case
3567 if (ry_tang_rad(i,j,k) <= 0.0) then
3568 tau = segment%Velocity_nudging_timescale_in
3569 else
3570 tau = segment%Velocity_nudging_timescale_out
3571 endif
3572 gamma_2 = dt / (tau + dt)
3573 segment%tangential_grad(i,j,k) = (1.0 - gamma_2) * segment%tangential_grad(i,j,k) + &
3574 gamma_2 * segment%nudged_tangential_grad(i,j,k)
3575 enddo ; enddo
3576 endif
3577 deallocate(ry_tang_rad)
3578 endif
3579 if (segment%oblique_tan .or. segment%oblique_grad) then
3580 j=segment%HI%JsdB
3581 allocate(rx_tang_obl(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz))
3582 allocate(ry_tang_obl(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz))
3583 allocate(cff_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz))
3584 do k=1,nz
3585 if (gamma_u < 1.0) then
3586 rx_tang_obl(segment%HI%IsdB,j,k) = segment%rx_norm_obl(segment%HI%isd,j,k)
3587 rx_tang_obl(segment%HI%IedB,j,k) = segment%rx_norm_obl(segment%HI%ied,j,k)
3588 ry_tang_obl(segment%HI%IsdB,j,k) = segment%ry_norm_obl(segment%HI%isd,j,k)
3589 ry_tang_obl(segment%HI%IedB,j,k) = segment%ry_norm_obl(segment%HI%ied,j,k)
3590 cff_tangential(segment%HI%IsdB,j,k) = segment%cff_normal(segment%HI%isd,j,k)
3591 cff_tangential(segment%HI%IedB,j,k) = segment%cff_normal(segment%HI%ied,j,k)
3592 do i=segment%HI%IsdB+1,segment%HI%IedB-1
3593 rx_tang_obl(i,j,k) = 0.5*(segment%rx_norm_obl(i,j,k) + segment%rx_norm_obl(i+1,j,k))
3594 ry_tang_obl(i,j,k) = 0.5*(segment%ry_norm_obl(i,j,k) + segment%ry_norm_obl(i+1,j,k))
3595 cff_tangential(i,j,k) = 0.5*(segment%cff_normal(i,j,k) + segment%cff_normal(i+1,j,k))
3596 enddo
3597 else
3598 do i=segment%HI%IsdB,segment%HI%IedB
3599 dhdt = u_old(i,j,k)-u_new(i,j,k) !old-new
3600 dhdy = u_new(i,j,k)-u_new(i,j-1,k) !in new time backward sashay for I-1
3601 if (dhdt*(segment%grad_tan(i,1,k) + segment%grad_tan(i+1,1,k)) > 0.0) then
3602 dhdx = segment%grad_tan(i,1,k)
3603 elseif (dhdt*(segment%grad_tan(i,1,k) + segment%grad_tan(i+1,1,k)) == 0.0) then
3604 dhdx = 0.0
3605 else
3606 dhdx = segment%grad_tan(i+1,1,k)
3607 endif
3608 if (dhdt*dhdy < 0.0) dhdt = 0.0
3609 cff_new = max((dhdx*dhdx) + (dhdy*dhdy), eps)
3610 ry_new = min(dhdt*dhdy, cff_new*ry_max)
3611 rx_new = min(cff_new,max(dhdt*dhdx,-cff_new))
3612 rx_tang_obl(i,j,k) = rx_new
3613 ry_tang_obl(i,j,k) = ry_new
3614 cff_tangential(i,j,k) = cff_new
3615 enddo
3616 endif
3617 enddo
3618 if (segment%oblique_tan) then
3619 do k=1,nz ; do i=segment%HI%IsdB,segment%HI%IedB
3620 rx_avg = rx_tang_obl(i,j,k)
3621 ry_avg = ry_tang_obl(i,j,k)
3622 cff_avg = cff_tangential(i,j,k)
3623 segment%tangential_vel(i,j,k) = ((cff_avg*u_new(i,j,k) + ry_avg*u_new(i,j-1,k)) - &
3624 (max(rx_avg,0.0)*segment%grad_tan(i,2,k) + &
3625 min(rx_avg,0.0)*segment%grad_tan(i+1,2,k))) / &
3626 (cff_avg + ry_avg)
3627 enddo ; enddo
3628 endif
3629 if (segment%nudged_tan) then
3630 do k=1,nz ; do i=segment%HI%IsdB,segment%HI%IedB
3631 ! dhdt gets set to 0 on inflow in oblique case
3632 if (ry_tang_obl(i,j,k) <= 0.0) then
3633 tau = segment%Velocity_nudging_timescale_in
3634 else
3635 tau = segment%Velocity_nudging_timescale_out
3636 endif
3637 gamma_2 = dt / (tau + dt)
3638 segment%tangential_vel(i,j,k) = (1.0 - gamma_2) * segment%tangential_vel(i,j,k) + &
3639 gamma_2 * segment%nudged_tangential_vel(i,j,k)
3640 enddo ; enddo
3641 endif
3642 if (segment%oblique_grad) then
3643 is_obc = max(segment%HI%IsdB,g%isd+1)
3644 ie_obc = min(segment%HI%IedB,g%ied-1)
3645 do k=1,nz ; do i=segment%HI%IsdB+1,segment%HI%IedB-1
3646 rx_avg = rx_tang_obl(i,j,k)
3647 ry_avg = ry_tang_obl(i,j,k)
3648 cff_avg = cff_tangential(i,j,k)
3649 segment%tangential_grad(i,j,k) = &
3650 ((cff_avg*(u_new(i,j,k) - u_new(i,j-1,k))*g%IdyBu(i,j-1) + &
3651 ry_avg*(u_new(i,j-1,k) - u_new(i,j-2,k))*g%IdyBu(i,j-2)) - &
3652 (max(rx_avg,0.0)*segment%grad_gradient(i,2,k) + &
3653 min(rx_avg,0.0)*segment%grad_gradient(i+1,2,k))) / &
3654 (cff_avg + ry_avg)
3655 enddo ; enddo
3656 endif
3657 if (segment%nudged_grad) then
3658 do k=1,nz ; do i=segment%HI%IsdB,segment%HI%IedB
3659 ! dhdt gets set to 0 on inflow in oblique case
3660 if (ry_tang_obl(i,j,k) <= 0.0) then
3661 tau = segment%Velocity_nudging_timescale_in
3662 else
3663 tau = segment%Velocity_nudging_timescale_out
3664 endif
3665 gamma_2 = dt / (tau + dt)
3666 segment%tangential_grad(i,j,k) = (1.0 - gamma_2) * segment%tangential_grad(i,j,k) + &
3667 gamma_2 * segment%nudged_tangential_grad(i,j,k)
3668 enddo ; enddo
3669 endif
3670 deallocate(rx_tang_obl)
3671 deallocate(ry_tang_obl)
3672 deallocate(cff_tangential)
3673 endif
3674 endif
3675
3676 if (segment%direction == obc_direction_s) then
3677 j=segment%HI%JsdB
3678 if (j>g%HI%JecB) cycle
3679 do k=1,nz ; do i=segment%HI%isd,segment%HI%ied
3680 if (segment%radiation) then
3681 dhdt = (v_old(i,j+1,k) - v_new(i,j+1,k)) !old-new
3682 dhdy = (v_new(i,j+1,k) - v_new(i,j+2,k)) !in new time backward sashay for J-1
3683 ry_new = 0.0
3684 if (dhdt*dhdy > 0.0) ry_new = min( (dhdt/dhdy), ry_max)
3685 if (gamma_u < 1.0) then
3686 ry_avg = (1.0-gamma_u)*segment%ry_norm_rad(i,j,k) + gamma_u*ry_new
3687 else
3688 ry_avg = ry_new
3689 endif
3690 segment%ry_norm_rad(i,j,k) = ry_avg
3691 ! The new boundary value is interpolated between future interior
3692 ! value, v_new(J+1) and past boundary value but with barotropic
3693 ! accelerations, v_new(J).
3694 segment%normal_vel(i,j,k) = (v_new(i,j,k) + ry_avg*v_new(i,j+1,k)) / (1.0+ry_avg)
3695 if (gamma_u < 1.0) then
3696 ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues
3697 ! implemented as a work-around to limitations in restart capability
3698 obc%ry_normal(i,j,k) = segment%ry_norm_rad(i,j,k)
3699 endif
3700 elseif (segment%oblique) then
3701 dhdt = (v_old(i,j+1,k) - v_new(i,j+1,k)) !old-new
3702 dhdy = (v_new(i,j+1,k) - v_new(i,j+2,k)) !in new time backward sashay for J-1
3703 if (dhdt*(segment%grad_normal(i,1,k) + segment%grad_normal(i-1,1,k)) > 0.0) then
3704 dhdx = segment%grad_normal(i-1,1,k)
3705 elseif (dhdt*(segment%grad_normal(i,1,k) + segment%grad_normal(i-1,1,k)) == 0.0) then
3706 dhdx = 0.0
3707 else
3708 dhdx = segment%grad_normal(i,1,k)
3709 endif
3710 if (dhdt*dhdy < 0.0) dhdt = 0.0
3711
3712 cff_new = max((dhdx*dhdx) + (dhdy*dhdy), eps)
3713 ry_new = min(dhdt*dhdy, cff_new*ry_max)
3714 rx_new = min(cff_new,max(dhdt*dhdx,-cff_new))
3715 if (gamma_u < 1.0) then
3716 rx_avg = (1.0-gamma_u)*segment%rx_norm_obl(i,j,k) + gamma_u*rx_new
3717 ry_avg = (1.0-gamma_u)*segment%ry_norm_obl(i,j,k) + gamma_u*ry_new
3718 cff_avg = (1.0-gamma_u)*segment%cff_normal(i,j,k) + gamma_u*cff_new
3719 else
3720 rx_avg = rx_new
3721 ry_avg = ry_new
3722 cff_avg = cff_new
3723 endif
3724 segment%rx_norm_obl(i,j,k) = rx_avg
3725 segment%ry_norm_obl(i,j,k) = ry_avg
3726 segment%cff_normal(i,j,k) = cff_avg
3727 segment%normal_vel(i,j,k) = ((cff_avg*v_new(i,j,k) + ry_avg*v_new(i,j+1,k)) - &
3728 (max(rx_avg,0.0)*segment%grad_normal(i-1,2,k) + &
3729 min(rx_avg,0.0)*segment%grad_normal(i,2,k))) / &
3730 (cff_avg + ry_avg)
3731 if (gamma_u < 1.0) then
3732 ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues
3733 ! implemented as a work-around to limitations in restart capability
3734 obc%rx_oblique_v(i,j,k) = segment%rx_norm_obl(i,j,k)
3735 obc%ry_oblique_v(i,j,k) = segment%ry_norm_obl(i,j,k)
3736 obc%cff_normal_v(i,j,k) = segment%cff_normal(i,j,k)
3737 endif
3738 elseif (segment%gradient) then
3739 segment%normal_vel(i,j,k) = v_new(i,j+1,k)
3740 endif
3741 if ((segment%radiation .or. segment%oblique) .and. segment%nudged) then
3742 ! dhdt gets set to 0 on inflow in oblique case
3743 if (dhdt*dhdy <= 0.0) then
3744 tau = segment%Velocity_nudging_timescale_in
3745 else
3746 tau = segment%Velocity_nudging_timescale_out
3747 endif
3748 gamma_2 = dt / (tau + dt)
3749 segment%normal_vel(i,j,k) = (1.0 - gamma_2) * segment%normal_vel(i,j,k) + &
3750 gamma_2 * segment%nudged_normal_vel(i,j,k)
3751 endif
3752 enddo ; enddo
3753 if (segment%radiation_tan .or. segment%radiation_grad) then
3754 j=segment%HI%JsdB
3755 allocate(ry_tang_rad(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz))
3756 do k=1,nz
3757 if (gamma_u < 1.0) then
3758 ry_tang_rad(segment%HI%IsdB,j,k) = segment%ry_norm_rad(segment%HI%isd,j,k)
3759 ry_tang_rad(segment%HI%IedB,j,k) = segment%ry_norm_rad(segment%HI%ied,j,k)
3760 do i=segment%HI%IsdB+1,segment%HI%IedB-1
3761 ry_tang_rad(i,j,k) = 0.5*(segment%ry_norm_rad(i,j,k) + segment%ry_norm_rad(i+1,j,k))
3762 enddo
3763 else
3764 do i=segment%HI%IsdB,segment%HI%IedB
3765 dhdt = u_old(i,j+1,k)-u_new(i,j+1,k) !old-new
3766 dhdy = u_new(i,j+1,k)-u_new(i,j+2,k) !in new time backward sashay for I-1
3767 ry_tang_rad(i,j,k) = 0.0
3768 if (dhdt*dhdy > 0.0) ry_tang_rad(i,j,k) = min( (dhdt/dhdy), rx_max) ! outward phase speed
3769 enddo
3770 endif
3771 enddo
3772 if (segment%radiation_tan) then
3773 do k=1,nz ; do i=segment%HI%IsdB,segment%HI%IedB
3774 ry_avg = ry_tang_rad(i,j,k)
3775 segment%tangential_vel(i,j,k) = (u_new(i,j+1,k) + ry_avg*u_new(i,j+2,k)) / (1.0+ry_avg)
3776 enddo ; enddo
3777 endif
3778 if (segment%nudged_tan) then
3779 do k=1,nz ; do i=segment%HI%IsdB,segment%HI%IedB
3780 ! dhdt gets set to 0 on inflow in oblique case
3781 if (ry_tang_rad(i,j,k) <= 0.0) then
3782 tau = segment%Velocity_nudging_timescale_in
3783 else
3784 tau = segment%Velocity_nudging_timescale_out
3785 endif
3786 gamma_2 = dt / (tau + dt)
3787 segment%tangential_vel(i,j,k) = (1.0 - gamma_2) * segment%tangential_vel(i,j,k) + &
3788 gamma_2 * segment%nudged_tangential_vel(i,j,k)
3789 enddo ; enddo
3790 endif
3791 if (segment%radiation_grad) then
3792 is_obc = max(segment%HI%IsdB,g%isd+1)
3793 ie_obc = min(segment%HI%IedB,g%ied-1)
3794 do k=1,nz ; do i=is_obc,ie_obc
3795 ry_avg = ry_tang_rad(i,j,k)
3796 ! if (G%mask2dCv(i,J+1) > 0.0 .and. G%mask2dCv(i+1,J+1) > 0.0) then
3797 ! ry_avg = 0.5*(v_new(i,J+1,k) + v_new(i+1,J+1,k)) * dt * G%IdyBu(I,J+1)
3798 ! elseif (G%mask2dCv(i,J+1) > 0.0) then
3799 ! ry_avg = v_new(i,J+1,k) * dt * G%IdyBu(I,J+1)
3800 ! elseif (G%mask2dCv(i+1,J+1) > 0.0) then
3801 ! ry_avg = v_new(i+1,J+1,k) * dt * G%IdyBu(I,J+1)
3802 ! else
3803 ! ry_avg = 0.0
3804 ! endif
3805 segment%tangential_grad(i,j,k) = ((u_new(i,j+2,k) - u_new(i,j+1,k))*g%IdyBu(i,j+1) + &
3806 ry_avg*(u_new(i,j+3,k) - u_new(i,j+2,k))*g%IdyBu(i,j+2)) / (1.0+ry_avg)
3807 enddo ; enddo
3808 endif
3809 if (segment%nudged_grad) then
3810 do k=1,nz ; do i=segment%HI%IsdB,segment%HI%IedB
3811 ! dhdt gets set to 0 on inflow in oblique case
3812 if (ry_tang_rad(i,j,k) <= 0.0) then
3813 tau = segment%Velocity_nudging_timescale_in
3814 else
3815 tau = segment%Velocity_nudging_timescale_out
3816 endif
3817 gamma_2 = dt / (tau + dt)
3818 segment%tangential_grad(i,j,k) = (1.0 - gamma_2) * segment%tangential_grad(i,j,k) + &
3819 gamma_2 * segment%nudged_tangential_grad(i,j,k)
3820 enddo ; enddo
3821 endif
3822 deallocate(ry_tang_rad)
3823 endif
3824 if (segment%oblique_tan .or. segment%oblique_grad) then
3825 j=segment%HI%JsdB
3826 allocate(rx_tang_obl(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz))
3827 allocate(ry_tang_obl(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz))
3828 allocate(cff_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz))
3829 do k=1,nz
3830 if (gamma_u < 1.0) then
3831 rx_tang_obl(segment%HI%IsdB,j,k) = segment%rx_norm_obl(segment%HI%isd,j,k)
3832 rx_tang_obl(segment%HI%IedB,j,k) = segment%rx_norm_obl(segment%HI%ied,j,k)
3833 ry_tang_obl(segment%HI%IsdB,j,k) = segment%ry_norm_obl(segment%HI%isd,j,k)
3834 ry_tang_obl(segment%HI%IedB,j,k) = segment%ry_norm_obl(segment%HI%ied,j,k)
3835 cff_tangential(segment%HI%IsdB,j,k) = segment%cff_normal(segment%HI%isd,j,k)
3836 cff_tangential(segment%HI%IedB,j,k) = segment%cff_normal(segment%HI%ied,j,k)
3837 do i=segment%HI%IsdB+1,segment%HI%IedB-1
3838 rx_tang_obl(i,j,k) = 0.5*(segment%rx_norm_obl(i,j,k) + segment%rx_norm_obl(i+1,j,k))
3839 ry_tang_obl(i,j,k) = 0.5*(segment%ry_norm_obl(i,j,k) + segment%ry_norm_obl(i+1,j,k))
3840 cff_tangential(i,j,k) = 0.5*(segment%cff_normal(i,j,k) + segment%cff_normal(i+1,j,k))
3841 enddo
3842 else
3843 do i=segment%HI%IsdB,segment%HI%IedB
3844 dhdt = u_old(i,j+1,k)-u_new(i,j+1,k) !old-new
3845 dhdy = u_new(i,j+1,k)-u_new(i,j+2,k) !in new time backward sashay for I-1
3846 if (dhdt*(segment%grad_tan(i,1,k) + segment%grad_tan(i+1,1,k)) > 0.0) then
3847 dhdx = segment%grad_tan(i,1,k)
3848 elseif (dhdt*(segment%grad_tan(i,1,k) + segment%grad_tan(i+1,1,k)) == 0.0) then
3849 dhdx = 0.0
3850 else
3851 dhdx = segment%grad_tan(i+1,1,k)
3852 endif
3853 if (dhdt*dhdy < 0.0) dhdt = 0.0
3854 cff_new = max((dhdx*dhdx) + (dhdy*dhdy), eps)
3855 ry_new = min(dhdt*dhdy, cff_new*ry_max)
3856 rx_new = min(cff_new,max(dhdt*dhdx,-cff_new))
3857 rx_tang_obl(i,j,k) = rx_new
3858 ry_tang_obl(i,j,k) = ry_new
3859 cff_tangential(i,j,k) = cff_new
3860 enddo
3861 endif
3862 enddo
3863 if (segment%oblique_tan) then
3864 do k=1,nz ; do i=segment%HI%IsdB,segment%HI%IedB
3865 rx_avg = rx_tang_obl(i,j,k)
3866 ry_avg = ry_tang_obl(i,j,k)
3867 cff_avg = cff_tangential(i,j,k)
3868 segment%tangential_vel(i,j,k) = ((cff_avg*u_new(i,j+1,k) + ry_avg*u_new(i,j+2,k)) - &
3869 (max(rx_avg,0.0)*segment%grad_tan(i,2,k) + &
3870 min(rx_avg,0.0)*segment%grad_tan(i+1,2,k)) ) / &
3871 (cff_avg + ry_avg)
3872 enddo ; enddo
3873 endif
3874 if (segment%nudged_tan) then
3875 do k=1,nz ; do i=segment%HI%IsdB,segment%HI%IedB
3876 ! dhdt gets set to 0 on inflow in oblique case
3877 if (ry_tang_obl(i,j,k) <= 0.0) then
3878 tau = segment%Velocity_nudging_timescale_in
3879 else
3880 tau = segment%Velocity_nudging_timescale_out
3881 endif
3882 gamma_2 = dt / (tau + dt)
3883 segment%tangential_vel(i,j,k) = (1.0 - gamma_2) * segment%tangential_vel(i,j,k) + &
3884 gamma_2 * segment%nudged_tangential_vel(i,j,k)
3885 enddo ; enddo
3886 endif
3887 if (segment%oblique_grad) then
3888 is_obc = max(segment%HI%IsdB,g%isd+1)
3889 ie_obc = min(segment%HI%IedB,g%ied-1)
3890 do k=1,nz ; do i=segment%HI%IsdB+1,segment%HI%IedB-1
3891 rx_avg = rx_tang_obl(i,j,k)
3892 ry_avg = ry_tang_obl(i,j,k)
3893 cff_avg = cff_tangential(i,j,k)
3894 segment%tangential_grad(i,j,k) = &
3895 ((cff_avg*(u_new(i,j+2,k) - u_new(i,j+1,k))*g%IdyBu(i,j+1) + &
3896 ry_avg*(u_new(i,j+3,k) - u_new(i,j+2,k))*g%IdyBu(i,j+2)) - &
3897 (max(rx_avg,0.0)*segment%grad_gradient(i,2,k) + &
3898 min(rx_avg,0.0)*segment%grad_gradient(i+1,2,k))) / &
3899 (cff_avg + ry_avg)
3900 enddo ; enddo
3901 endif
3902 if (segment%nudged_grad) then
3903 do k=1,nz ; do j=segment%HI%JsdB,segment%HI%JedB
3904 ! dhdt gets set to 0 on inflow in oblique case
3905 if (ry_tang_obl(i,j,k) <= 0.0) then
3906 tau = segment%Velocity_nudging_timescale_in
3907 else
3908 tau = segment%Velocity_nudging_timescale_out
3909 endif
3910 gamma_2 = dt / (tau + dt)
3911 segment%tangential_grad(i,j,k) = (1.0 - gamma_2) * segment%tangential_grad(i,j,k) + &
3912 gamma_2 * segment%nudged_tangential_grad(i,j,k)
3913 enddo ; enddo
3914 endif
3915 deallocate(rx_tang_obl)
3916 deallocate(ry_tang_obl)
3917 deallocate(cff_tangential)
3918 endif
3919 endif
3920 enddo
3921
3922 ! Actually update u_new, v_new
3923 call open_boundary_apply_normal_flow(obc, g, gv, u_new, v_new)
3924
3925 call pass_vector(u_new, v_new, g%Domain, clock=id_clock_pass)
3926
3927 if (obc%debug) then
3928 sym = g%Domain%symmetric
3929 if (obc%radiation_BCs_exist_globally) then
3930 call uvchksum("radiation_OBCs: OBC%r[xy]_normal", obc%rx_normal, obc%ry_normal, g%HI, &
3931 haloshift=0, symmetric=sym, scalar_pair=.true., unscale=1.0)
3932 endif
3933 if (obc%oblique_BCs_exist_globally) then
3934 call uvchksum("radiation_OBCs: OBC%r[xy]_oblique_[uv]", obc%rx_oblique_u, obc%ry_oblique_v, g%HI, &
3935 haloshift=0, symmetric=sym, scalar_pair=.true., unscale=1.0/us%L_T_to_m_s**2)
3936 call uvchksum("radiation_OBCs: OBC%r[yx]_oblique_[uv]", obc%ry_oblique_u, obc%rx_oblique_v, g%HI, &
3937 haloshift=0, symmetric=sym, scalar_pair=.true., unscale=1.0/us%L_T_to_m_s**2)
3938 call uvchksum("radiation_OBCs: OBC%cff_normal_[uv]", obc%cff_normal_u, obc%cff_normal_v, g%HI, &
3939 haloshift=0, symmetric=sym, scalar_pair=.true., unscale=1.0/us%L_T_to_m_s**2)
3940 endif
3941 if ((obc%ntr > 0) .and. allocated(obc%tres_x) .and. allocated(obc%tres_y)) then
3942 do m=1,obc%ntr
3943 write(var_num,'(I3.3)') m
3944 call uvchksum("radiation_OBCs: OBC%tres_[xy]_"//var_num, obc%tres_x(:,:,:,m), obc%tres_y(:,:,:,m), g%HI, &
3945 haloshift=0, symmetric=sym, scalar_pair=.true., unscale=1.0)
3946 enddo
3947 endif
3948 endif
3949
3950end subroutine radiation_open_bdry_conds
3951
3952!> Applies OBC values stored in segments to 3d u,v fields
3953subroutine open_boundary_apply_normal_flow(OBC, G, GV, u, v)
3954 ! Arguments
3955 type(ocean_obc_type), pointer :: obc !< Open boundary control structure
3956 type(ocean_grid_type), intent(inout) :: g !< Ocean grid structure
3957 type(verticalgrid_type), intent(in) :: gv !< The ocean's vertical grid structure
3958 real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: u !< u field to update on open
3959 !! boundaries [L T-1 ~> m s-1]
3960 real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: v !< v field to update on open
3961 !! boundaries [L T-1 ~> m s-1]
3962 ! Local variables
3963 integer :: i, j, k, n
3964 type(obc_segment_type), pointer :: segment => null()
3965
3966 if (.not.associated(obc)) return ! Bail out if OBC is not available
3967
3968 do n=1,obc%number_of_segments
3969 segment => obc%segment(n)
3970 if (.not. segment%on_pe) then
3971 cycle
3972 elseif (segment%radiation .or. segment%oblique .or. segment%gradient) then
3973 if (segment%is_E_or_W) then
3974 i=segment%HI%IsdB
3975 do k=1,gv%ke ; do j=segment%HI%jsd,segment%HI%jed
3976 u(i,j,k) = segment%normal_vel(i,j,k)
3977 enddo ; enddo
3978 elseif (segment%is_N_or_S) then
3979 j=segment%HI%JsdB
3980 do k=1,gv%ke ; do i=segment%HI%isd,segment%HI%ied
3981 v(i,j,k) = segment%normal_vel(i,j,k)
3982 enddo ; enddo
3983 endif
3984 endif
3985 enddo
3986
3988
3989!> Applies zero values to 3d u,v fields on OBC segments
3990subroutine open_boundary_zero_normal_flow(OBC, G, GV, u, v)
3991 ! Arguments
3992 type(ocean_obc_type), pointer :: obc !< Open boundary control structure
3993 type(ocean_grid_type), intent(inout) :: g !< Ocean grid structure
3994 type(verticalgrid_type), intent(in) :: gv !< The ocean's vertical grid structure
3995 real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: u !< u field to update on open boundaries [arbitrary]
3996 real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: v !< v field to update on open boundaries [arbitrary]
3997 ! Local variables
3998 integer :: i, j, k, n
3999 type(obc_segment_type), pointer :: segment => null()
4000
4001 if (.not.associated(obc)) return ! Bail out if OBC is not available
4002
4003 do n=1,obc%number_of_segments
4004 segment => obc%segment(n)
4005 if (.not. segment%on_pe) then
4006 cycle
4007 elseif (segment%is_E_or_W) then
4008 i=segment%HI%IsdB
4009 do k=1,gv%ke ; do j=segment%HI%jsd,segment%HI%jed
4010 u(i,j,k) = 0.
4011 enddo ; enddo
4012 elseif (segment%is_N_or_S) then
4013 j=segment%HI%JsdB
4014 do k=1,gv%ke ; do i=segment%HI%isd,segment%HI%ied
4015 v(i,j,k) = 0.
4016 enddo ; enddo
4017 endif
4018 enddo
4019
4020end subroutine open_boundary_zero_normal_flow
4021
4022!> Calculate the tangential gradient of the normal flow at the boundary q-points.
4023subroutine gradient_at_q_points(G, GV, segment, uvel, vvel)
4024 type(ocean_grid_type), intent(in) :: G !< Ocean grid structure
4025 type(verticalgrid_type), intent(in) :: GV !< The ocean's vertical grid structure
4026 type(obc_segment_type), intent(inout) :: segment !< OBC segment structure
4027 real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: uvel !< zonal velocity [L T-1 ~> m s-1]
4028 real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: vvel !< meridional velocity [L T-1 ~> m s-1]
4029 integer :: i,j,k
4030
4031 if (.not. segment%on_pe) return
4032
4033 if (segment%is_E_or_W) then
4034 if (segment%direction == obc_direction_e) then
4035 i=segment%HI%isdB
4036 do k=1,gv%ke
4037 do j=max(segment%HI%JsdB, g%HI%JsdB+1),min(segment%HI%JedB, g%HI%JedB-1)
4038 segment%grad_normal(j,1,k) = (uvel(i-1,j+1,k)-uvel(i-1,j,k)) * g%mask2dBu(i-1,j)
4039 segment%grad_normal(j,2,k) = (uvel(i,j+1,k)-uvel(i,j,k)) * g%mask2dBu(i,j)
4040 enddo
4041 enddo
4042 if (segment%oblique_tan) then
4043 do k=1,gv%ke
4044 do j=max(segment%HI%jsd-1, g%HI%jsd),min(segment%HI%jed+1, g%HI%jed)
4045 segment%grad_tan(j,1,k) = (vvel(i-1,j,k)-vvel(i-1,j-1,k)) * g%mask2dT(i-1,j)
4046 segment%grad_tan(j,2,k) = (vvel(i,j,k)-vvel(i,j-1,k)) * g%mask2dT(i,j)
4047 enddo
4048 enddo
4049 endif
4050 if (segment%oblique_grad) then
4051 do k=1,gv%ke
4052 do j=max(segment%HI%jsd, g%HI%jsd+1),min(segment%HI%jed, g%HI%jed-1)
4053 segment%grad_gradient(j,1,k) = (((vvel(i-1,j,k) - vvel(i-2,j,k))*g%IdxBu(i-2,j)) - &
4054 ((vvel(i-1,j-1,k) - vvel(i-2,j-1,k))*g%IdxBu(i-2,j-1))) * g%mask2dCu(i-2,j)
4055 segment%grad_gradient(j,2,k) = (((vvel(i,j,k) - vvel(i-1,j,k))*g%IdxBu(i-1,j)) - &
4056 ((vvel(i,j-1,k) - vvel(i-1,j-1,k))*g%IdxBu(i-1,j-1))) * g%mask2dCu(i-1,j)
4057 enddo
4058 enddo
4059 endif
4060 else ! western segment
4061 i=segment%HI%isdB
4062 do k=1,gv%ke
4063 do j=max(segment%HI%JsdB, g%HI%JsdB+1),min(segment%HI%JedB, g%HI%JedB-1)
4064 segment%grad_normal(j,1,k) = (uvel(i+1,j+1,k)-uvel(i+1,j,k)) * g%mask2dBu(i+1,j)
4065 segment%grad_normal(j,2,k) = (uvel(i,j+1,k)-uvel(i,j,k)) * g%mask2dBu(i,j)
4066 enddo
4067 enddo
4068 if (segment%oblique_tan) then
4069 do k=1,gv%ke
4070 do j=max(segment%HI%jsd-1, g%HI%jsd),min(segment%HI%jed+1, g%HI%jed)
4071 segment%grad_tan(j,1,k) = (vvel(i+2,j,k)-vvel(i+2,j-1,k)) * g%mask2dT(i+2,j)
4072 segment%grad_tan(j,2,k) = (vvel(i+1,j,k)-vvel(i+1,j-1,k)) * g%mask2dT(i+1,j)
4073 enddo
4074 enddo
4075 endif
4076 if (segment%oblique_grad) then
4077 do k=1,gv%ke
4078 do j=max(segment%HI%jsd, g%HI%jsd+1),min(segment%HI%jed, g%HI%jed-1)
4079 segment%grad_gradient(j,1,k) = (((vvel(i+3,j,k) - vvel(i+2,j,k))*g%IdxBu(i+2,j)) - &
4080 ((vvel(i+3,j-1,k) - vvel(i+2,j-1,k))*g%IdxBu(i+2,j-1))) * g%mask2dCu(i+2,j)
4081 segment%grad_gradient(j,2,k) = (((vvel(i+2,j,k) - vvel(i+1,j,k))*g%IdxBu(i+1,j)) - &
4082 ((vvel(i+2,j-1,k) - vvel(i+1,j-1,k))*g%IdxBu(i+1,j-1))) * g%mask2dCu(i+1,j)
4083 enddo
4084 enddo
4085 endif
4086 endif
4087 elseif (segment%is_N_or_S) then
4088 if (segment%direction == obc_direction_n) then
4089 j=segment%HI%jsdB
4090 do k=1,gv%ke
4091 do i=max(segment%HI%IsdB, g%HI%IsdB+1),min(segment%HI%IedB, g%HI%IedB-1)
4092 segment%grad_normal(i,1,k) = (vvel(i+1,j-1,k)-vvel(i,j-1,k)) * g%mask2dBu(i,j-1)
4093 segment%grad_normal(i,2,k) = (vvel(i+1,j,k)-vvel(i,j,k)) * g%mask2dBu(i,j)
4094 enddo
4095 enddo
4096 if (segment%oblique_tan) then
4097 do k=1,gv%ke
4098 do i=max(segment%HI%isd-1, g%HI%isd),min(segment%HI%ied+1, g%HI%ied)
4099 segment%grad_tan(i,1,k) = (uvel(i,j-1,k)-uvel(i-1,j-1,k)) * g%mask2dT(i,j-1)
4100 segment%grad_tan(i,2,k) = (uvel(i,j,k)-uvel(i-1,j,k)) * g%mask2dT(i,j)
4101 enddo
4102 enddo
4103 endif
4104 if (segment%oblique_grad) then
4105 do k=1,gv%ke
4106 do i=max(segment%HI%isd, g%HI%isd+1),min(segment%HI%ied, g%HI%ied-1)
4107 segment%grad_gradient(i,1,k) = (((uvel(i,j-1,k) - uvel(i,j-2,k))*g%IdyBu(i,j-2)) - &
4108 ((uvel(i-1,j-1,k) - uvel(i-1,j-2,k))*g%IdyBu(i-1,j-2))) * g%mask2dCv(i,j-2)
4109 segment%grad_gradient(i,2,k) = (((uvel(i,j,k) - uvel(i,j-1,k))*g%IdyBu(i,j-1)) - &
4110 ((uvel(i-1,j,k) - uvel(i-1,j-1,k))*g%IdyBu(i-1,j-1))) * g%mask2dCv(i,j-1)
4111 enddo
4112 enddo
4113 endif
4114 else ! south segment
4115 j=segment%HI%jsdB
4116 do k=1,gv%ke
4117 do i=max(segment%HI%IsdB, g%HI%IsdB+1),min(segment%HI%IedB, g%HI%IedB-1)
4118 segment%grad_normal(i,1,k) = (vvel(i+1,j+1,k)-vvel(i,j+1,k)) * g%mask2dBu(i,j+1)
4119 segment%grad_normal(i,2,k) = (vvel(i+1,j,k)-vvel(i,j,k)) * g%mask2dBu(i,j)
4120 enddo
4121 enddo
4122 if (segment%oblique_tan) then
4123 do k=1,gv%ke
4124 do i=max(segment%HI%isd-1, g%HI%isd),min(segment%HI%ied+1, g%HI%ied)
4125 segment%grad_tan(i,1,k) = (uvel(i,j+2,k)-uvel(i-1,j+2,k)) * g%mask2dT(i,j+2)
4126 segment%grad_tan(i,2,k) = (uvel(i,j+1,k)-uvel(i-1,j+1,k)) * g%mask2dT(i,j+1)
4127 enddo
4128 enddo
4129 endif
4130 if (segment%oblique_grad) then
4131 do k=1,gv%ke
4132 do i=max(segment%HI%isd, g%HI%isd+1),min(segment%HI%ied, g%HI%ied-1)
4133 segment%grad_gradient(i,1,k) = (((uvel(i,j+3,k) - uvel(i,j+2,k))*g%IdyBu(i,j+2)) - &
4134 ((uvel(i-1,j+3,k) - uvel(i-1,j+2,k))*g%IdyBu(i-1,j+2))) * g%mask2dCv(i,j+2)
4135 segment%grad_gradient(i,2,k) = (((uvel(i,j+2,k) - uvel(i,j+1,k))*g%IdyBu(i,j+1)) - &
4136 ((uvel(i-1,j+2,k) - uvel(i-1,j+1,k))*g%IdyBu(i-1,j+1))) * g%mask2dCv(i,j+1)
4137 enddo
4138 enddo
4139 endif
4140 endif
4141 endif
4142
4143end subroutine gradient_at_q_points
4144
4145
4146!> Return the field number on the segment for the named field, or -1 if there is no field with that name.
4147function lookup_seg_field(OBC_seg, field)
4148 type(obc_segment_type), intent(in) :: obc_seg !< OBC segment
4149 character(len=32), intent(in) :: field !< The field name
4150 integer :: lookup_seg_field
4151 ! Local variables
4152 integer :: n
4153
4154 lookup_seg_field = -1
4155 do n=1,obc_seg%num_fields
4156 if (trim(field) == obc_seg%field(n)%name) then
4158 return
4159 endif
4160 enddo
4161
4162end function lookup_seg_field
4163
4164!> Return the tracer index from its name
4165function get_tracer_index(OBC_seg,tr_name)
4166 type(obc_segment_type), pointer :: obc_seg !< OBC segment
4167 character(len=*), intent(in) :: tr_name !< The field name
4168 integer :: get_tracer_index, it
4169 get_tracer_index = -1
4170 it = 1
4171 do while(allocated(obc_seg%tr_Reg%Tr(it)%t))
4172 if (trim(obc_seg%tr_Reg%Tr(it)%name) == trim(tr_name)) then
4173 get_tracer_index = it
4174 exit
4175 endif
4176 it = it + 1
4177 enddo
4178end function get_tracer_index
4179
4180!> Allocate segment data fields
4181subroutine allocate_obc_segment_data(OBC, segment)
4182 type(ocean_obc_type), intent(in) :: OBC !< Open boundary structure
4183 type(obc_segment_type), intent(inout) :: segment !< Open boundary segment
4184 ! Local variables
4185 integer :: isd, ied, jsd, jed
4186 integer :: IsdB, IedB, JsdB, JedB
4187 integer :: IscB, IecB, JscB, JecB
4188
4189 isd = segment%HI%isd ; ied = segment%HI%ied
4190 jsd = segment%HI%jsd ; jed = segment%HI%jed
4191 isdb = segment%HI%IsdB ; iedb = segment%HI%IedB
4192 jsdb = segment%HI%JsdB ; jedb = segment%HI%JedB
4193 iscb = segment%HI%IscB ; iecb = segment%HI%IecB
4194 jscb = segment%HI%JscB ; jecb = segment%HI%JecB
4195
4196 if (.not. segment%on_pe) return
4197
4198 if (segment%is_E_or_W) then
4199 ! If these are just Flather, change update_OBC_segment_data accordingly
4200 allocate(segment%Htot(isdb:iedb,jsd:jed), source=0.0)
4201 ! Allocate dZtot with extra values at the end to avoid segmentation faults in cases where
4202 ! it is interpolated to OBC vorticity points.
4203 allocate(segment%dz(isdb:iedb,jsd-1:jed+1,obc%ke), source=0.0)
4204 allocate(segment%dZtot(isdb:iedb,jsd-1:jed+1), source=0.0)
4205 allocate(segment%SSH(isdb:iedb,jsd:jed), source=0.0)
4206 allocate(segment%tidal_elev(isdb:iedb,jsd:jed), source=0.0)
4207 if (segment%radiation) &
4208 allocate(segment%rx_norm_rad(isdb:iedb,jsd:jed,obc%ke), source=0.0)
4209 allocate(segment%normal_vel(isdb:iedb,jsd:jed,obc%ke), source=0.0)
4210 allocate(segment%normal_vel_bt(isdb:iedb,jsd:jed), source=0.0)
4211 allocate(segment%normal_trans(isdb:iedb,jsd:jed,obc%ke), source=0.0)
4212 allocate(segment%normal_trans_bt(isdb:iedb,jsd:jed), source=0.0)
4213 allocate(segment%tidal_vn(isdb:iedb,jsd:jed), source=0.0)
4214 if (segment%nudged) &
4215 allocate(segment%nudged_normal_vel(isdb:iedb,jsd:jed,obc%ke), source=0.0)
4216 if (segment%radiation_tan .or. segment%nudged_tan .or. &
4217 segment%specified_tan .or. segment%oblique_tan .or. &
4218 (obc%vorticity_config == obc_vorticity_computed) .or. &
4219 (obc%strain_config == obc_strain_computed)) then
4220 allocate(segment%tangential_vel(isdb:iedb,jsdb:jedb,obc%ke), source=0.0)
4221 allocate(segment%tidal_vt(isdb:iedb,jsdb:jedb), source=0.0)
4222 endif
4223 if (segment%nudged_tan) &
4224 allocate(segment%nudged_tangential_vel(isdb:iedb,jsdb:jedb,obc%ke), source=0.0)
4225 if (segment%nudged_grad) &
4226 allocate(segment%nudged_tangential_grad(isdb:iedb,jsdb:jedb,obc%ke), source=0.0)
4227 if (segment%radiation_grad .or. segment%oblique_grad .or. segment%specified_grad .or. &
4228 (obc%vorticity_config == obc_vorticity_specified) .or. &
4229 (obc%strain_config == obc_strain_specified)) &
4230 allocate(segment%tangential_grad(isdb:iedb,jsdb:jedb,obc%ke), source=0.0)
4231 if (segment%oblique) then
4232 allocate(segment%grad_normal(jsdb:jedb,2,obc%ke), source=0.0)
4233 allocate(segment%rx_norm_obl(isdb:iedb,jsd:jed,obc%ke), source=0.0)
4234 allocate(segment%ry_norm_obl(isdb:iedb,jsd:jed,obc%ke), source=0.0)
4235 allocate(segment%cff_normal(isdb:iedb,jsd:jed,obc%ke), source=0.0)
4236 endif
4237 if (segment%oblique_tan) &
4238 allocate(segment%grad_tan(jsd-1:jed+1,2,obc%ke), source=0.0)
4239 if (segment%oblique_grad) &
4240 allocate(segment%grad_gradient(jsd:jed,2,obc%ke), source=0.0)
4241 endif
4242
4243 if (segment%is_N_or_S) then
4244 ! If these are just Flather, change update_OBC_segment_data accordingly
4245 allocate(segment%Htot(isd:ied,jsdb:jedb), source=0.0)
4246 ! Allocate dZtot with extra values at the end to avoid segmentation faults in cases where
4247 ! it is interpolated to OBC vorticity points.
4248 allocate(segment%dz(isd-1:ied+1,jsdb:jedb,obc%ke), source=0.0)
4249 allocate(segment%dZtot(isd-1:ied+1,jsdb:jedb), source=0.0)
4250 allocate(segment%SSH(isd:ied,jsdb:jedb), source=0.0)
4251 allocate(segment%tidal_elev(isd:ied,jsdb:jedb), source=0.0)
4252 if (segment%radiation) &
4253 allocate(segment%ry_norm_rad(isd:ied,jsdb:jedb,obc%ke), source=0.0)
4254 allocate(segment%normal_vel(isd:ied,jsdb:jedb,obc%ke), source=0.0)
4255 allocate(segment%normal_vel_bt(isd:ied,jsdb:jedb), source=0.0)
4256 allocate(segment%normal_trans(isd:ied,jsdb:jedb,obc%ke), source=0.0)
4257 allocate(segment%normal_trans_bt(isd:ied,jsdb:jedb), source=0.0)
4258 allocate(segment%tidal_vn(isd:ied,jsdb:jedb), source=0.0)
4259 if (segment%nudged) &
4260 allocate(segment%nudged_normal_vel(isd:ied,jsdb:jedb,obc%ke), source=0.0)
4261 if (segment%radiation_tan .or. segment%nudged_tan .or. &
4262 segment%specified_tan .or. segment%oblique_tan .or. &
4263 (obc%vorticity_config == obc_vorticity_computed) .or. &
4264 (obc%strain_config == obc_strain_computed)) then
4265 allocate(segment%tangential_vel(isdb:iedb,jsdb:jedb,obc%ke), source=0.0)
4266 allocate(segment%tidal_vt(isdb:iedb,jsdb:jedb), source=0.0)
4267 endif
4268 if (segment%nudged_tan) &
4269 allocate(segment%nudged_tangential_vel(isdb:iedb,jsdb:jedb,obc%ke), source=0.0)
4270 if (segment%nudged_grad) &
4271 allocate(segment%nudged_tangential_grad(isdb:iedb,jsdb:jedb,obc%ke), source=0.0)
4272 if (segment%radiation_grad .or. segment%oblique_grad .or. segment%specified_grad .or. &
4273 (obc%vorticity_config == obc_vorticity_specified) .or. &
4274 (obc%strain_config == obc_strain_specified)) &
4275 allocate(segment%tangential_grad(isdb:iedb,jsdb:jedb,obc%ke), source=0.0)
4276 if (segment%oblique) then
4277 allocate(segment%grad_normal(isdb:iedb,2,obc%ke), source=0.0)
4278 allocate(segment%rx_norm_obl(isd:ied,jsdb:jedb,obc%ke), source=0.0)
4279 allocate(segment%ry_norm_obl(isd:ied,jsdb:jedb,obc%ke), source=0.0)
4280 allocate(segment%cff_normal(isd:ied,jsdb:jedb,obc%ke), source=0.0)
4281 endif
4282 if (segment%oblique_tan) &
4283 allocate(segment%grad_tan(isd-1:ied+1,2,obc%ke), source=0.0)
4284 if (segment%oblique_grad) &
4285 allocate(segment%grad_gradient(isd:ied,2,obc%ke), source=0.0)
4286 endif
4287
4288end subroutine allocate_obc_segment_data
4289
4290!> Deallocate segment data fields
4291subroutine deallocate_obc_segment_data(segment)
4292 type(obc_segment_type), intent(inout) :: segment !< Open boundary segment
4293
4294 if (.not. segment%on_pe) return
4295
4296 if (allocated(segment%Htot)) deallocate(segment%Htot)
4297 if (allocated(segment%dz)) deallocate(segment%dz)
4298 if (allocated(segment%dZtot)) deallocate(segment%dZtot)
4299 if (allocated(segment%SSH)) deallocate(segment%SSH)
4300 if (allocated(segment%tidal_elev)) deallocate(segment%tidal_elev)
4301 if (allocated(segment%rx_norm_rad)) deallocate(segment%rx_norm_rad)
4302 if (allocated(segment%ry_norm_rad)) deallocate(segment%ry_norm_rad)
4303 if (allocated(segment%rx_norm_obl)) deallocate(segment%rx_norm_obl)
4304 if (allocated(segment%ry_norm_obl)) deallocate(segment%ry_norm_obl)
4305 if (allocated(segment%cff_normal)) deallocate(segment%cff_normal)
4306 if (allocated(segment%grad_normal)) deallocate(segment%grad_normal)
4307 if (allocated(segment%grad_tan)) deallocate(segment%grad_tan)
4308 if (allocated(segment%grad_gradient)) deallocate(segment%grad_gradient)
4309 if (allocated(segment%normal_vel)) deallocate(segment%normal_vel)
4310 if (allocated(segment%normal_vel_bt)) deallocate(segment%normal_vel_bt)
4311 if (allocated(segment%normal_trans)) deallocate(segment%normal_trans)
4312 if (allocated(segment%normal_trans_bt)) deallocate(segment%normal_trans_Bt)
4313 if (allocated(segment%tidal_vn)) deallocate(segment%tidal_vn)
4314 if (allocated(segment%tidal_vt)) deallocate(segment%tidal_vt)
4315 if (allocated(segment%nudged_normal_vel)) deallocate(segment%nudged_normal_vel)
4316 if (allocated(segment%tangential_vel)) deallocate(segment%tangential_vel)
4317 if (allocated(segment%nudged_tangential_vel)) deallocate(segment%nudged_tangential_vel)
4318 if (allocated(segment%nudged_tangential_grad)) deallocate(segment%nudged_tangential_grad)
4319 if (allocated(segment%tangential_grad)) deallocate(segment%tangential_grad)
4320
4321 if (associated(segment%tr_Reg)) call segment_tracer_registry_end(segment%tr_Reg)
4322 if (associated(segment%h_Reg)) call segment_thickness_registry_end(segment%h_Reg)
4323
4324end subroutine deallocate_obc_segment_data
4325
4326!> Set tangential velocities outside of open boundaries to silly values
4327!! (used for checking the interior state is independent of values outside
4328!! of the domain).
4329subroutine open_boundary_test_extern_uv(G, GV, OBC, u, v)
4330 type(ocean_grid_type), intent(in) :: g !< Ocean grid structure
4331 type(verticalgrid_type), intent(in) :: gv !< The ocean's vertical grid structure
4332 type(ocean_obc_type), pointer :: obc !< Open boundary structure
4333 real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)),intent(inout) :: u !< Zonal velocity [L T-1 ~> m s-1]
4334 real, dimension(SZI_(G),SZJB_(G),SZK_(GV)),intent(inout) :: v !< Meridional velocity [L T-1 ~> m s-1]
4335 ! Local variables
4336 integer :: i, j, k, n
4337
4338 if (.not. associated(obc)) return
4339
4340 do n=1,obc%number_of_segments
4341 do k = 1, gv%ke
4342 if (obc%segment(n)%is_N_or_S) then
4343 j = obc%segment(n)%HI%JsdB
4344 if (obc%segment(n)%direction == obc_direction_n) then
4345 do i = obc%segment(n)%HI%IsdB, obc%segment(n)%HI%IedB
4346 u(i,j+1,k) = obc%silly_u
4347 enddo
4348 else
4349 do i = obc%segment(n)%HI%IsdB, obc%segment(n)%HI%IedB
4350 u(i,j,k) = obc%silly_u
4351 enddo
4352 endif
4353 elseif (obc%segment(n)%is_E_or_W) then
4354 i = obc%segment(n)%HI%IsdB
4355 if (obc%segment(n)%direction == obc_direction_e) then
4356 do j = obc%segment(n)%HI%JsdB, obc%segment(n)%HI%JedB
4357 v(i+1,j,k) = obc%silly_u
4358 enddo
4359 else
4360 do j = obc%segment(n)%HI%JsdB, obc%segment(n)%HI%JedB
4361 v(i,j,k) = obc%silly_u
4362 enddo
4363 endif
4364 endif
4365 enddo
4366 enddo
4367
4368end subroutine open_boundary_test_extern_uv
4369
4370!> Set thicknesses outside of open boundaries to silly values
4371!! (used for checking the interior state is independent of values outside
4372!! of the domain).
4373subroutine open_boundary_test_extern_h(G, GV, OBC, h)
4374 type(ocean_grid_type), intent(in) :: g !< Ocean grid structure
4375 type(verticalgrid_type), intent(in) :: gv !< Ocean vertical grid structure
4376 type(ocean_obc_type), pointer :: obc !< Open boundary structure
4377 real, dimension(SZI_(G),SZJ_(G), SZK_(GV)),intent(inout) :: h !< Layer thickness [H ~> m or kg m-2]
4378 ! Local variables
4379 real :: silly_h ! A silly thickness for testing [H ~> m or kg m-2]
4380 integer :: i, j, k, n
4381
4382 if (.not. associated(obc)) return
4383
4384 silly_h = gv%Z_to_H * obc%silly_h ! This rescaling is here because GV was initialized after OBC.
4385
4386 do n=1,obc%number_of_segments
4387 do k = 1, gv%ke
4388 if (obc%segment(n)%is_N_or_S) then
4389 j = obc%segment(n)%HI%JsdB
4390 if (obc%segment(n)%direction == obc_direction_n) then
4391 do i = obc%segment(n)%HI%isd, obc%segment(n)%HI%ied
4392 h(i,j+1,k) = silly_h
4393 enddo
4394 else
4395 do i = obc%segment(n)%HI%isd, obc%segment(n)%HI%ied
4396 h(i,j,k) = silly_h
4397 enddo
4398 endif
4399 elseif (obc%segment(n)%is_E_or_W) then
4400 i = obc%segment(n)%HI%IsdB
4401 if (obc%segment(n)%direction == obc_direction_e) then
4402 do j = obc%segment(n)%HI%jsd, obc%segment(n)%HI%jed
4403 h(i+1,j,k) = silly_h
4404 enddo
4405 else
4406 do j = obc%segment(n)%HI%jsd, obc%segment(n)%HI%jed
4407 h(i,j,k) = silly_h
4408 enddo
4409 endif
4410 endif
4411 enddo
4412 enddo
4413
4414end subroutine open_boundary_test_extern_h
4415
4416!> Read and remap segment data for a single field index m. This is the shared per-field subroutine
4417!! used by read_OBC_dynamics_data and read_OBC_tracer_data.
4418subroutine read_obc_field_data(G, GV, US, OBC, segment, m, Time)
4419 type(ocean_grid_type), intent(in) :: G !< Ocean grid structure
4420 type(verticalgrid_type), intent(in) :: GV !< Ocean vertical grid structure
4421 type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
4422 type(ocean_obc_type), pointer :: OBC !< Open boundary structure
4423 type(obc_segment_type), pointer :: segment !< Segment whose field is being read
4424 integer, intent(in) :: m !< Field index within segment%field
4425 type(time_type), intent(in) :: Time !< Model time
4426
4427 ! Local variables
4428 integer :: i, j
4429 integer :: IsdB, IedB, JsdB, JedB
4430 real, dimension(:,:,:), pointer :: tmp_buffer_in => null() ! Unrotated input [various units]
4431 real, dimension(:,:,:), allocatable, target :: tmp_buffer ! A buffer for input data [various units]
4432 real :: dz_stack(SZK_(GV)) ! Distance between the interfaces at corner points [Z ~> m]
4433 integer :: ni_seg, nj_seg ! number of src gridpoints along the segments
4434 integer :: ni_buf, nj_buf ! Number of filled values in tmp_buffer
4435 integer :: i_seg_offset, j_seg_offset, bug_offset
4436 real :: net_dz_src ! Total vertical extent of the incoming flow in the source field [Z ~> m]
4437 real :: net_dz_int ! Total vertical extent of the incoming flow in the model [Z ~> m]
4438 real :: scl_fac ! A scaling factor to compensate for differences in total thicknesses [nondim]
4439 integer :: turns ! Number of index quarter turns
4440 logical :: flip_buffer ! If true, the input buffer needs to be transposed
4441
4442 if (segment%field(m)%required .and. (.not. allocated(segment%field(m)%buffer_dst))) &
4443 call mom_error(fatal, 'buffer_dst not allocated')
4444
4445 if (.not. segment%field(m)%use_IO) return
4446
4447 isdb = segment%HI%IsdB ; iedb = segment%HI%IedB
4448 jsdb = segment%HI%JsdB ; jedb = segment%HI%JedB
4449
4450 ni_seg = segment%ie_obc - segment%is_obc + 1 ! Global number of q points
4451 nj_seg = segment%je_obc - segment%js_obc + 1 ! Global number of q points
4452 i_seg_offset = g%idg_offset - segment%HI%IsgB
4453 j_seg_offset = g%jdg_offset - segment%HI%JsgB
4454
4455 turns = modulo(g%HI%turns, 4)
4456
4457 ! read source data interpolated to the current model time
4458 ! NOTE: buffer is sized for vertex points, but may be used for faces
4459 if (segment%is_E_or_W) then
4460 if (obc%brushcutter_mode) then
4461 allocate(tmp_buffer(1,nj_seg*2-1,segment%field(m)%nk_src)) ! segment data is currently on supergrid
4462 else
4463 allocate(tmp_buffer(1,nj_seg,segment%field(m)%nk_src)) ! segment data is currently on native grid
4464 endif
4465 else
4466 if (obc%brushcutter_mode) then
4467 allocate(tmp_buffer(ni_seg*2-1,1,segment%field(m)%nk_src)) ! segment data is currently on supergrid
4468 else
4469 allocate(tmp_buffer(ni_seg,1,segment%field(m)%nk_src)) ! segment data is currently on native grid
4470 endif
4471 endif
4472
4473 ! TODO: Since we conditionally rotate a subset of tmp_buffer_in after
4474 ! reading the value, it is currently not possible to use the rotated
4475 ! implementation of time_interp_extern.
4476 ! For now, we must explicitly allocate and rotate this array.
4477 if (turns /= 0) then
4478 if (modulo(turns, 2) /= 0) then
4479 allocate(tmp_buffer_in(size(tmp_buffer, 2), size(tmp_buffer, 1), size(tmp_buffer, 3)))
4480 else
4481 allocate(tmp_buffer_in(size(tmp_buffer, 1), size(tmp_buffer, 2), size(tmp_buffer, 3)))
4482 endif
4483 else
4484 tmp_buffer_in => tmp_buffer
4485 endif
4486
4487 ! This is where the data values are actually read in.
4488 call time_interp_external(segment%field(m)%handle, time, tmp_buffer_in, scale=segment%field(m)%scale)
4489
4490 ! NOTE: Rotation of face-points require that we skip the final value when not in brushcutter mode.
4491 if (turns /= 0) then
4492 flip_buffer = ((turns==1) .or. (turns==3))
4493 if (obc%brushcutter_mode .or. (.not.flip_buffer)) then
4494 call rotate_array(tmp_buffer_in, turns, tmp_buffer)
4495 elseif (flip_buffer .and. segment%is_E_or_W .and. segment%field(m)%on_face) then
4496 nj_buf = size(tmp_buffer, 2) - 1
4497 call rotate_array(tmp_buffer_in(:nj_buf,:,:), turns, tmp_buffer(:,:nj_buf,:))
4498 elseif (flip_buffer .and. segment%is_N_or_S .and. segment%field(m)%on_face) then
4499 ni_buf = size(tmp_buffer, 1) - 1
4500 call rotate_array(tmp_buffer_in(:,:ni_buf,:), turns, tmp_buffer(:ni_buf,:,:))
4501 else
4502 call rotate_array(tmp_buffer_in, turns, tmp_buffer)
4503 endif
4504
4505 if (((segment%field(m)%name == 'U') .and. ((turns==1).or.(turns==2))) .or. &
4506 ((segment%field(m)%name == 'V') .and. ((turns==2).or.(turns==3))) .or. &
4507 ((segment%field(m)%name == 'Vamp') .and. ((turns==2).or.(turns==3))) .or. &
4508 ((segment%field(m)%name == 'Uamp') .and. ((turns==1).or.(turns==2))) .or. &
4509 ((segment%field(m)%name == 'DVDX') .and. ((turns==1).or.(turns==3))) .or. &
4510 ((segment%field(m)%name == 'DUDY') .and. ((turns==1).or.(turns==3))) ) then
4511 tmp_buffer(:,:,:) = -tmp_buffer(:,:,:)
4512 endif
4513 endif
4514
4515 if (obc%brushcutter_mode) then
4516 ! In brushcutter mode, the input data includes vales at both the vorticity point nodes and
4517 ! the velocity point faces of the OBC segments. The vorticity node values are at the odd
4518 ! positions in tmp_buffer, while the faces are at the even points. The bug that is being
4519 ! corrected here is the use of the odd indexed points for both the corners and the faces.
4520 bug_offset = 0 ; if (obc%hor_index_bug) bug_offset = -1
4521 if (segment%is_E_or_W) then
4522 if (.not.segment%field(m)%on_face) then
4523 segment%field(m)%buffer_src(isdb,:,:) = &
4524 tmp_buffer(1, 2*(jsdb+j_seg_offset+1)-1:2*(jedb+j_seg_offset)+1:2, :)
4525 else
4526 segment%field(m)%buffer_src(isdb,:,:) = &
4527 tmp_buffer(1, 2*(jsdb+j_seg_offset+1)+bug_offset:2*(jedb+j_seg_offset):2, :)
4528 endif
4529 else
4530 if (.not.segment%field(m)%on_face) then
4531 segment%field(m)%buffer_src(:,jsdb,:) = &
4532 tmp_buffer(2*(isdb+i_seg_offset+1)-1:2*(iedb+i_seg_offset)+1:2, 1, :)
4533 else
4534 segment%field(m)%buffer_src(:,jsdb,:) = &
4535 tmp_buffer(2*(isdb+i_seg_offset+1)+bug_offset:2*(iedb+i_seg_offset):2, 1, :)
4536 endif
4537 endif
4538 else ! Not brushcutter_mode.
4539 if (segment%is_E_or_W) then
4540 if (.not.segment%field(m)%on_face) then
4541 segment%field(m)%buffer_src(isdb,:,:) = &
4542 tmp_buffer(1,jsdb+j_seg_offset+1:jedb+j_seg_offset+1,:)
4543 else
4544 segment%field(m)%buffer_src(isdb,:,:) = &
4545 tmp_buffer(1,jsdb+j_seg_offset+1:jedb+j_seg_offset,:)
4546 endif
4547 else
4548 if (.not.segment%field(m)%on_face) then
4549 segment%field(m)%buffer_src(:,jsdb,:) = &
4550 tmp_buffer(isdb+i_seg_offset+1:iedb+i_seg_offset+1,1,:)
4551 else
4552 segment%field(m)%buffer_src(:,jsdb,:) = &
4553 tmp_buffer(isdb+i_seg_offset+1:iedb+i_seg_offset,1,:)
4554 endif
4555 endif
4556 endif
4557
4558 ! no dz for tidal variables
4559 if (segment%field(m)%nk_src <= 1) then ! This is 2-d data with no remapping.
4560 segment%field(m)%buffer_dst(:,:,1) = segment%field(m)%buffer_src(:,:,1)
4561 elseif (field_is_tidal(segment%field(m)%name)) then
4562 ! The 3rd axis for tidal variables is the tidal constituent, so there is no remapping.
4563 segment%field(m)%buffer_dst(:,:,:) = segment%field(m)%buffer_src(:,:,:)
4564 else
4565 ! Read in 3-d data that may need to be remapped onto the new grid
4566 ! This is also where the 2-d tidal data values (apart from phase and amp) are actually read in.
4567 call time_interp_external(segment%field(m)%dz_handle, time, tmp_buffer_in, scale=us%m_to_Z)
4568
4569 if (turns /= 0) then
4570 flip_buffer = ((turns==1) .or. (turns==3))
4571 if (flip_buffer .and. segment%is_E_or_W .and. segment%field(m)%on_face) then
4572 nj_buf = size(tmp_buffer, 2) - 1
4573 call rotate_array(tmp_buffer_in(:nj_buf,:,:), turns, tmp_buffer(:,:nj_buf,:))
4574 elseif (flip_buffer .and. segment%is_N_or_S .and. segment%field(m)%on_face) then
4575 ni_buf = size(tmp_buffer, 1) - 1
4576 call rotate_array(tmp_buffer_in(:,:ni_buf,:), turns, tmp_buffer(:ni_buf,:,:))
4577 else
4578 call rotate_array(tmp_buffer_in, turns, tmp_buffer)
4579 endif
4580 endif ! End of rotation
4581
4582 if (obc%brushcutter_mode) then
4583 bug_offset = 0 ; if (obc%hor_index_bug) bug_offset = -1
4584 if (segment%is_E_or_W) then
4585 if (.not.segment%field(m)%on_face) then
4586 segment%field(m)%dz_src(isdb,:,:) = &
4587 tmp_buffer(1, 2*(jsdb+j_seg_offset+1)-1:2*(jedb+j_seg_offset)+1:2, :)
4588 else
4589 segment%field(m)%dz_src(isdb,:,:) = &
4590 tmp_buffer(1, 2*(jsdb+j_seg_offset+1)+bug_offset:2*(jedb+j_seg_offset):2, :)
4591 endif
4592 else
4593 if (.not.segment%field(m)%on_face) then
4594 segment%field(m)%dz_src(:,jsdb,:) = &
4595 tmp_buffer(2*(isdb+i_seg_offset+1)-1:2*(iedb+i_seg_offset)+1:2, 1, :)
4596 else
4597 segment%field(m)%dz_src(:,jsdb,:) = &
4598 tmp_buffer(2*(isdb+i_seg_offset+1)+bug_offset:2*(iedb+i_seg_offset):2, 1, :)
4599 endif
4600 endif
4601 else ! Not brushcutter_mode.
4602 if (segment%is_E_or_W) then
4603 if (.not.segment%field(m)%on_face) then
4604 segment%field(m)%dz_src(isdb,:,:) = &
4605 tmp_buffer(1,jsdb+j_seg_offset+1:jedb+j_seg_offset+1,:)
4606 else
4607 segment%field(m)%dz_src(isdb,:,:) = &
4608 tmp_buffer(1,jsdb+j_seg_offset+1:jedb+j_seg_offset,:)
4609 endif
4610 else
4611 if (.not.segment%field(m)%on_face) then
4612 segment%field(m)%dz_src(:,jsdb,:) = &
4613 tmp_buffer(isdb+i_seg_offset+1:iedb+i_seg_offset+1,1,:)
4614 else
4615 segment%field(m)%dz_src(:,jsdb,:) = &
4616 tmp_buffer(isdb+i_seg_offset+1:iedb+i_seg_offset,1,:)
4617 endif
4618 endif
4619 endif
4620
4621 if ((.not.segment%field(m)%on_face) .and. (.not.obc%hor_index_bug)) then
4622 ! This point is at the OBC vorticity point nodes, rather than the OBC velocity point faces.
4623 call adjustsegmentetatofitbathymetry(g, gv, us, segment, m, at_node=.true.)
4624 else
4625 call adjustsegmentetatofitbathymetry(g, gv, us, segment, m, at_node=.false.)
4626 endif
4627
4628 if (segment%is_E_or_W) then
4629 i = isdb
4630 if (.not.segment%field(m)%on_face) then
4631 ! Do q points for the whole segment
4632 do j = max(jsdb, g%jsd), min(jedb, g%jed-1)
4633 ! Using the h remapping approach
4634 ! Pretty sure we need to check for source/target grid consistency here
4635 !### For a concave corner between OBC segments, there are 3 thicknesses we might
4636 ! consider using.
4637 segment%field(m)%buffer_dst(i,j,:) = 0.0 ! initialize remap destination buffer
4638 if ((g%mask2dCu(i,j) > 0.0) .or. (g%mask2dCu(i,j+1) > 0.0)) then
4639 dz_stack(:) = (1.0 / (g%mask2dCu(i,j) + g%mask2dCu(i,j+1))) * &
4640 (g%mask2dCu(i,j) * segment%dz(i,j,:) + g%mask2dCu(i,j+1) * segment%dz(i,j+1,:))
4641 call remapping_core_h(obc%remap_z_CS, &
4642 segment%field(m)%nk_src, segment%field(m)%dz_src(i,j,:), &
4643 segment%field(m)%buffer_src(i,j,:), &
4644 gv%ke, dz_stack, segment%field(m)%buffer_dst(i,j,:))
4645 endif
4646 enddo
4647 else
4648 do j = jsdb+1, jedb
4649 ! Using the h remapping approach
4650 ! Pretty sure we need to check for source/target grid consistency here
4651 segment%field(m)%buffer_dst(i,j,:) = 0.0 ! initialize remap destination buffer
4652 if (g%mask2dCu(i,j)>0.) then
4653 net_dz_src = sum( segment%field(m)%dz_src(i,j,:) )
4654 net_dz_int = sum( segment%dz(i,j,:) )
4655 scl_fac = net_dz_int / net_dz_src
4656 call remapping_core_h(obc%remap_z_CS, &
4657 segment%field(m)%nk_src, scl_fac*segment%field(m)%dz_src(i,j,:), &
4658 segment%field(m)%buffer_src(i,j,:), &
4659 gv%ke, segment%dz(i,j,:), segment%field(m)%buffer_dst(i,j,:))
4660 endif
4661 enddo
4662 endif
4663 else
4664 j = jsdb
4665 if (.not.segment%field(m)%on_face) then
4666 ! Do q points for the whole segment
4667 do i = max(isdb, g%isd), min(iedb, g%ied-1)
4668 segment%field(m)%buffer_dst(i,j,:) = 0.0 ! initialize remap destination buffer
4669 if ((g%mask2dCv(i,j) > 0.0) .or. (g%mask2dCv(i+1,j) > 0.0)) then
4670 ! Using the h remapping approach
4671 ! Pretty sure we need to check for source/target grid consistency here
4672 dz_stack(:) = (1.0 / (g%mask2dCv(i,j) + g%mask2dCv(i+1,j))) * &
4673 (g%mask2dCv(i,j) * segment%dz(i,j,:) + g%mask2dCv(i+1,j) * segment%dz(i+1,j,:))
4674 call remapping_core_h(obc%remap_z_CS, &
4675 segment%field(m)%nk_src, segment%field(m)%dz_src(i,j,:), &
4676 segment%field(m)%buffer_src(i,j,:), &
4677 gv%ke, dz_stack, segment%field(m)%buffer_dst(i,j,:))
4678 endif
4679 enddo
4680 else
4681 do i = isdb+1, iedb
4682 ! Using the h remapping approach
4683 ! Pretty sure we need to check for source/target grid consistency here
4684 segment%field(m)%buffer_dst(i,j,:) = 0.0 ! initialize remap destination buffer
4685 if (g%mask2dCv(i,j)>0.) then
4686 net_dz_src = sum( segment%field(m)%dz_src(i,j,:) )
4687 net_dz_int = sum( segment%dz(i,j,:) )
4688 scl_fac = net_dz_int / net_dz_src
4689 call remapping_core_h(obc%remap_z_CS, &
4690 segment%field(m)%nk_src, scl_fac* segment%field(m)%dz_src(i,j,:), &
4691 segment%field(m)%buffer_src(i,j,:), &
4692 gv%ke, segment%dz(i,j,:), segment%field(m)%buffer_dst(i,j,:))
4693 endif
4694 enddo
4695 endif
4696 endif
4697 endif
4698 deallocate(tmp_buffer)
4699 if (turns /= 0) deallocate(tmp_buffer_in)
4700end subroutine read_obc_field_data
4701
4702!> Read OBC segment data for the dynamical fields, with field indices
4703!! m=1..NUM_PHYS_FIELDS-2 (U, V, gradients, SSH, and tidal constituents).
4704subroutine read_obc_dynamics_data(G, GV, US, OBC, tv, h, Time)
4705 type(ocean_grid_type), intent(in) :: g !< Ocean grid structure
4706 type(verticalgrid_type), intent(in) :: gv !< Ocean vertical grid structure
4707 type(unit_scale_type), intent(in) :: us !< A dimensional unit scaling type
4708 type(ocean_obc_type), pointer :: obc !< Open boundary structure
4709 type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure
4710 real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Thickness [H ~> m or kg m-2]
4711 type(time_type), intent(in) :: time !< Model time
4712
4713 ! Local variables
4714 integer :: i, j, k, n, m
4715 type(obc_segment_type), pointer :: segment => null()
4716 real :: dz(szi_(g),szj_(g),szk_(gv)) ! Distance between the interfaces around a layer [Z ~> m]
4717
4718 if (.not. associated(obc)) return
4719 if (obc%user_BCs_set_globally) return
4720
4721 dz(:,:,:) = 0.0
4722 call thickness_to_dz(h, tv, dz, g, gv, us)
4723 call pass_var(dz, g%Domain)
4724
4725 do n=1,obc%number_of_segments
4726 segment => obc%segment(n)
4727
4728 if (.not. segment%on_pe) cycle ! continue to next segment if not in data domain
4729
4730 ! dZtot may extend one point past the end of the segment on the current PE for use at vorticity points
4731 segment%dZtot(:,:) = 0.0
4732 if (segment%is_E_or_W) then
4733 i = segment%HI%IsdB
4734 do k=1,gv%ke ; do j=max(segment%HI%jsd-1, g%jsd), min(segment%HI%jed+1, g%jed)
4735 segment%dz(i,j,k) = dz(segment%HI%isd,j,k)
4736 segment%dZtot(i,j) = segment%dZtot(i,j) + segment%dz(i,j,k)
4737 enddo ; enddo
4738 else
4739 j = segment%HI%JsdB
4740 do k=1,gv%ke ; do i=max(segment%HI%isd-1, g%isd), min(segment%HI%ied+1, g%ied)
4741 segment%dz(i,j,k) = dz(i,segment%HI%jsd,k)
4742 segment%dZtot(i,j) = segment%dZtot(i,j) + segment%dz(i,j,k)
4743 enddo ; enddo
4744 endif
4745
4746 do m=1, num_phys_fields-2
4747 call read_obc_field_data(g, gv, us, obc, segment, m, time)
4748 enddo ! end dynamical field loop
4749 enddo ! end segment loop
4750end subroutine read_obc_dynamics_data
4751
4752!> Read OBC segment data for tracer fields, with field indices
4753!! m=NUM_PHYS_FIELDS-1..segment%num_fields (T, S, and BGC tracers).
4754!! Assumes segment%dz has been populated by a prior call to read_OBC_dynamics_data at the current
4755!! time step. The optional argument include_bgc (default .true.) allows BGC fields to be read
4756!! independently.
4757subroutine read_obc_tracer_data(G, GV, US, OBC, Time, include_bgc)
4758 type(ocean_grid_type), intent(in) :: g !< Ocean grid structure
4759 type(verticalgrid_type), intent(in) :: gv !< Ocean vertical grid structure
4760 type(unit_scale_type), intent(in) :: us !< A dimensional unit scaling type
4761 type(ocean_obc_type), pointer :: obc !< Open boundary structure
4762 type(time_type), intent(in) :: time !< Model time
4763 logical, optional, intent(in) :: include_bgc !< Read BGC tracers
4764
4765 ! Local variables
4766 logical :: do_bgc ! If true, read BGC tracer fields
4767 integer :: n, m
4768 type(obc_segment_type), pointer :: segment => null()
4769
4770 if (.not. associated(obc)) return
4771 if (obc%user_BCs_set_globally) return
4772
4773 do_bgc = .true. ; if (present(include_bgc)) do_bgc = include_bgc
4774
4775 do n=1,obc%number_of_segments
4776 segment => obc%segment(n)
4777
4778 if (.not. segment%on_pe) cycle ! continue to next segment if not in data domain
4779
4780 do m=num_phys_fields-1, segment%num_fields
4781 if (.not. allocated(segment%field(m)%buffer_dst)) cycle
4782 if (segment%field(m)%bgc_tracer .and. (.not. do_bgc)) cycle
4783 call read_obc_field_data(g, gv, us, obc, segment, m, time)
4784 enddo ! end tracer field loop
4785 enddo ! end segment loop
4786end subroutine read_obc_tracer_data
4787
4788!> Update OBC segment dynamical fields: normal/tangential velocity, gradient, SSH, and
4789!! the thickness reservoir.
4790subroutine update_obc_dynamics_data(G, GV, US, OBC, h, Time)
4791 type(ocean_grid_type), intent(in) :: g !< Ocean grid structure
4792 type(verticalgrid_type), intent(in) :: gv !< Ocean vertical grid structure
4793 type(unit_scale_type), intent(in) :: us !< A dimensional unit scaling type
4794 type(ocean_obc_type), pointer :: obc !< Open boundary structure
4795 real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Thickness [H ~> m or kg m-2]
4796 type(time_type), intent(in) :: time !< Model time
4797
4798 ! Local variables
4799 type(obc_segment_type), pointer :: segment => null()
4800 integer :: c, i, j, k, n, nz
4801 integer :: isd, ied, jsd, jed, isdb, iedb, jsdb, jedb
4802 integer :: is_seg, ie_seg, js_seg, je_seg ! Orientation-agnostic loop ranges
4803 integer :: i_offset_in, j_offset_in ! Indexing offset for interior cells
4804 integer :: f_g, f_vn, f_vnamp, f_vnphase, f_vt, f_vtamp, f_vtphase ! Field indices
4805 real :: ramp_value ! If OBC%ramp is True, where we are on the ramp from 0 to 1, or 1 otherwise [nondim].
4806 real :: time_delta ! Time since tidal reference date [T ~> s]
4807 real :: tidal_amp, tidal_phase ! Tidal amplitude [Z ~> m] and phase [rad]
4808
4809 if (.not. associated(obc)) return
4810 if (obc%user_BCs_set_globally) return
4811
4812 nz = gv%ke
4813
4814 if (obc%add_tide_constituents) &
4815 time_delta = time_minus_signed(time, obc%time_ref, scale=us%s_to_T)
4816
4817 do n=1,obc%number_of_segments
4818 segment => obc%segment(n)
4819
4820 if (.not. segment%on_pe) cycle ! continue to next segment if not in data domain
4821
4822 ! Segment indices are on q points:
4823 ! | x | x | x | x | jsd/jed (if southern boundary)
4824 ! |-----------|-----------|-----------|-----------| JsdB/JedB
4825 ! IsdB isd ied IedB
4826 ! | x | x | x | x | jsd/jed (if northern boundary)
4827
4828 isd = segment%HI%isd ; ied = segment%HI%ied ; isdb = segment%HI%IsdB ; iedb = segment%HI%IedB
4829 jsd = segment%HI%jsd ; jed = segment%HI%jed ; jsdb = segment%HI%JsdB ; jedb = segment%HI%JedB
4830 i_offset_in = ied - iedb ! = 0 if East, South, North; = 1 if West
4831 j_offset_in = jed - jedb ! = 0 if North, West, East ; = 1 if South
4832
4833 if (segment%is_E_or_W) then
4834 is_seg = isdb ; ie_seg = is_seg
4835 js_seg = jsd ; je_seg = jed
4836 f_vn = f_u ; f_vnamp = f_uamp ; f_vnphase = f_uphase
4837 f_vt = f_v ; f_vtamp = f_vamp ; f_vtphase = f_vphase ; f_g = f_vx
4838 else
4839 is_seg = isd ; ie_seg = ied
4840 js_seg = jsdb ; je_seg = js_seg
4841 f_vn = f_v ; f_vnamp = f_vamp ; f_vnphase = f_vphase
4842 f_vt = f_u ; f_vtamp = f_uamp ; f_vtphase = f_uphase ; f_g = f_uy
4843 endif
4844
4845 ! Update normal velocity, transport. Split by orientation for now because of G%dyCu and G%dxCv.
4846 if (allocated(segment%field(f_vn)%buffer_dst)) then
4847 ! Update tidal normal velocity
4848 segment%tidal_vn(:,:) = 0.0
4849 if (obc%add_tide_constituents) then
4850 do c=1,obc%n_tide_constituents ; do j=js_seg,je_seg ; do i=is_seg,ie_seg
4851 tidal_amp = obc%tide_fn(c) * segment%field(f_vnamp)%buffer_dst(i,j,c)
4852 tidal_phase = (time_delta * obc%tide_frequencies(c) - segment%field(f_vnphase)%buffer_dst(i,j,c)) &
4853 + (obc%tide_eq_phases(c) + obc%tide_un(c))
4854 segment%tidal_vn(i,j) = segment%tidal_vn(i,j) + tidal_amp * cos(tidal_phase)
4855 enddo ; enddo ; enddo
4856 endif
4857
4858 segment%Htot(:,:) = 0.0
4859 segment%normal_trans_bt(:,:) = 0.0
4860 if (segment%is_E_or_W) then
4861 do k=1,nz ; do j=js_seg,je_seg ; do i=is_seg,ie_seg
4862 segment%Htot(i,j) = segment%Htot(i,j) + h(i+i_offset_in,j+j_offset_in,k)
4863 segment%normal_vel(i,j,k) = segment%field(f_vn)%buffer_dst(i,j,k) + segment%tidal_vn(i,j)
4864 segment%normal_trans(i,j,k) = &
4865 segment%normal_vel(i,j,k) * h(i+i_offset_in,j+j_offset_in,k) * g%dyCu(i,j)
4866 segment%normal_trans_bt(i,j) = segment%normal_trans_bt(i,j) + segment%normal_trans(i,j,k)
4867 enddo ; enddo ; enddo
4868 do j=js_seg,je_seg ; do i=is_seg,ie_seg
4869 segment%normal_vel_bt(i,j) = segment%normal_trans_bt(i,j) &
4870 / (max(segment%Htot(i,j), 1.e-12 * gv%m_to_H) * g%dyCu(i,j))
4871 enddo ; enddo
4872 else
4873 do k=1,nz ; do j=js_seg,je_seg ; do i=is_seg,ie_seg
4874 segment%Htot(i,j) = segment%Htot(i,j) + h(i+i_offset_in,j+j_offset_in,k)
4875 segment%normal_vel(i,j,k) = segment%field(f_vn)%buffer_dst(i,j,k) + segment%tidal_vn(i,j)
4876 segment%normal_trans(i,j,k) = &
4877 segment%normal_vel(i,j,k) * h(i+i_offset_in,j+j_offset_in,k) * g%dxCv(i,j)
4878 segment%normal_trans_bt(i,j) = segment%normal_trans_bt(i,j) + segment%normal_trans(i,j,k)
4879 enddo ; enddo ; enddo
4880 do j=js_seg,je_seg ; do i=is_seg,ie_seg
4881 segment%normal_vel_bt(i,j) = segment%normal_trans_bt(i,j) &
4882 / (max(segment%Htot(i,j), 1.e-12 * gv%m_to_H) * g%dxCv(i,j))
4883 enddo ; enddo
4884 endif
4885
4886 if (allocated(segment%nudged_normal_vel)) then
4887 do k=1,nz ; do j=js_seg,je_seg ; do i=is_seg,ie_seg
4888 segment%nudged_normal_vel(i,j,k) = segment%normal_vel(i,j,k)
4889 enddo ; enddo ; enddo
4890 endif
4891 endif
4892
4893 ! Update tangential velocity
4894 if (allocated(segment%tangential_vel) .and. allocated(segment%field(f_vt)%buffer_dst)) then
4895 ! Update tidal tangential velocity
4896 segment%tidal_vt(:,:) = 0.0
4897 if (obc%add_tide_constituents) then
4898 do c=1,obc%n_tide_constituents ; do j=jsdb,jedb ; do i=isdb,iedb
4899 tidal_amp = obc%tide_fn(c) * segment%field(f_vtamp)%buffer_dst(i,j,c)
4900 tidal_phase = (time_delta * obc%tide_frequencies(c) - segment%field(f_vtphase)%buffer_dst(i,j,c)) &
4901 + (obc%tide_eq_phases(c) + obc%tide_un(c))
4902 segment%tidal_vt(i,j) = segment%tidal_vt(i,j) + tidal_amp * cos(tidal_phase)
4903 enddo ; enddo ; enddo
4904 endif
4905
4906 do k=1,nz ; do j=jsdb,jedb ; do i=isdb,iedb
4907 segment%tangential_vel(i,j,k) = segment%field(f_vt)%buffer_dst(i,j,k) + segment%tidal_vt(i,j)
4908 enddo ; enddo ; enddo
4909
4910 if (allocated(segment%nudged_tangential_vel)) then
4911 do k=1,nz ; do j=jsdb,jedb ; do i=isdb,iedb
4912 segment%nudged_tangential_vel(i,j,k) = segment%tangential_vel(i,j,k)
4913 enddo ; enddo ; enddo
4914 endif
4915 endif
4916
4917 ! Update tangential gradient dvdx and dudy
4918 if (allocated(segment%tangential_grad) .and. allocated(segment%field(f_g)%buffer_dst)) then
4919 do k=1,nz ; do j=jsdb,jedb ; do i=isdb,iedb
4920 segment%tangential_grad(i,j,k) = segment%field(f_g)%buffer_dst(i,j,k)
4921 enddo ; enddo ; enddo
4922
4923 if (allocated(segment%nudged_tangential_grad)) then
4924 do k=1,nz ; do j=jsdb,jedb ; do i=isdb,iedb
4925 segment%nudged_tangential_grad(i,j,k) = segment%tangential_grad(i,j,k)
4926 enddo ; enddo ; enddo
4927 endif
4928 endif
4929
4930 ! Update SSH
4931 if (allocated(segment%field(f_z)%buffer_dst)) then
4932 ! Update tidal SSH
4933 segment%tidal_elev(:,:) = 0.0
4934 if (obc%add_tide_constituents) then
4935 do c=1,obc%n_tide_constituents ; do j=js_seg,je_seg ; do i=is_seg,ie_seg
4936 tidal_amp = obc%tide_fn(c) * segment%field(f_zamp)%buffer_dst(i,j,c)
4937 tidal_phase = (time_delta * obc%tide_frequencies(c) - segment%field(f_zphase)%buffer_dst(i,j,c)) &
4938 + (obc%tide_eq_phases(c) + obc%tide_un(c))
4939 segment%tidal_elev(i,j) = segment%tidal_elev(i,j) + tidal_amp * cos(tidal_phase)
4940 enddo ; enddo ; enddo
4941 endif
4942
4943 ramp_value = 1.0 ; if (obc%ramp) ramp_value = obc%ramp_value
4944 do j=js_seg,je_seg ; do i=is_seg,ie_seg
4945 segment%SSH(i,j) = ramp_value * (segment%field(f_z)%buffer_dst(i,j,1) + segment%tidal_elev(i,j))
4946 enddo ; enddo
4947 endif
4948
4949 ! Update thickness registry
4950 if (obc%thickness_x_reservoirs_used .or. obc%thickness_y_reservoirs_used) then
4951 do k=1,nz ; do j=js_seg,je_seg ; do i=is_seg,ie_seg
4952 segment%h_Reg%h(i,j,k) = h(i+i_offset_in,j+j_offset_in,k)
4953 enddo ; enddo ; enddo
4954 endif
4955 enddo ! end segment loop
4956end subroutine update_obc_dynamics_data
4957
4958!> Update the OBC segment tracer reservoir from segment%field(m)%buffer_dst for tracer field
4959!! indices m=NUM_PHYS_FIELDS-1..segment%num_fields. The optional argument include_bgc (default
4960!! true) allows BGC fields to be updated independently.
4961subroutine update_obc_tracer_data(OBC, include_bgc)
4962 type(ocean_obc_type), pointer :: obc !< Open boundary structure
4963 logical, optional, intent(in) :: include_bgc !< Update BGC tracers
4964
4965 ! Local variables
4966 logical :: do_bgc ! If true, update BGC tracer fields
4967 type(obc_segment_type), pointer :: segment => null()
4968 integer :: i, j, k, n, m, nt, nz
4969 integer :: is_seg, ie_seg, js_seg, je_seg ! Orientation-agnostic loop ranges
4970
4971 if (.not. associated(obc)) return
4972 if (obc%user_BCs_set_globally) return
4973
4974 do_bgc = .true. ; if (present(include_bgc)) do_bgc = include_bgc
4975
4976 nz = obc%ke
4977
4978 do n=1,obc%number_of_segments
4979 segment => obc%segment(n)
4980 if (.not. segment%on_pe) cycle ! continue to next segment if not in data domain
4981
4982 if (segment%is_E_or_W) then
4983 is_seg = segment%HI%IsdB ; ie_seg = is_seg
4984 js_seg = segment%HI%jsd ; je_seg = segment%HI%jed
4985 else
4986 is_seg = segment%HI%isd ; ie_seg = segment%HI%ied
4987 js_seg = segment%HI%JsdB ; je_seg = js_seg
4988 endif
4989
4990 do m=num_phys_fields-1, segment%num_fields ! F_T = NUM_PHYS_FIELDS-1 and F_S = NUM_PHYS_FIELDS
4991 if (.not. allocated(segment%field(m)%buffer_dst)) cycle
4992 if (segment%field(m)%bgc_tracer .and. (.not. do_bgc)) cycle
4993 nt = segment%field(m)%tr_index
4994 do k=1,nz ; do j=js_seg,je_seg ; do i=is_seg,ie_seg
4995 segment%tr_Reg%Tr(nt)%t(i,j,k) = segment%field(m)%buffer_dst(i,j,k)
4996 enddo ; enddo ; enddo
4997 enddo ! end tracer loop
4998 enddo ! end segment loop
4999end subroutine update_obc_tracer_data
5000
5001!> Initialize thickness and tracer reservoirs to external value.
5002subroutine initialize_obc_segment_reservoirs(GV, OBC)
5003 type(verticalgrid_type), intent(in) :: gv !< Ocean vertical grid structure
5004 type(ocean_obc_type), pointer :: obc !< Open boundary structure
5005
5006 ! Local variables
5007 type(obc_segment_type), pointer :: segment => null()
5008 integer :: isd, ied, jsd, jed, isdb, iedb, jsdb, jedb
5009 integer :: is_seg, ie_seg, js_seg, je_seg, nz
5010 integer :: n, m, nt, i, j, k
5011 character(len=256) :: msg ! Error message
5012
5013 if (.not. associated(obc)) return
5014
5015 nz = gv%ke
5016
5017 do n=1,obc%number_of_segments
5018 segment => obc%segment(n)
5019
5020 if (.not. segment%on_pe) cycle
5021
5022 isd = segment%HI%isd ; ied = segment%HI%ied ; isdb = segment%HI%IsdB ; iedb = segment%HI%IedB
5023 jsd = segment%HI%jsd ; jed = segment%HI%jed ; jsdb = segment%HI%JsdB ; jedb = segment%HI%JedB
5024
5025 if (segment%is_E_or_W) then
5026 is_seg = isdb ; ie_seg = iedb ! = is_seg
5027 js_seg = jsd ; je_seg = jed
5028 else
5029 is_seg = isd ; ie_seg = ied
5030 js_seg = jsdb ; je_seg = jedb ! = js_seg
5031 endif
5032
5033 ! Thickness
5034 ! If the thickness reservoir has not yet been initialized, then set to external value.
5035 if (obc%thickness_x_reservoirs_used .or. obc%thickness_y_reservoirs_used) then
5036 if (.not. segment%h_Reg%is_initialized) then ! h_Reg may be initialized by fill_thickness_segments
5037 do k=1,nz ; do j=js_seg,je_seg ; do i=is_seg,ie_seg
5038 segment%h_Reg%h_res(i,j,k) = segment%h_Reg%h(i,j,k)
5039 enddo ; enddo ; enddo
5040 segment%h_Reg%is_initialized = .true.
5041 endif
5042 endif
5043
5044 ! Tracers
5045 ! If the tracer reservoir has not yet been initialized, then set to external value.
5046 do m=num_phys_fields-1, segment%num_fields ! F_T = NUM_PHYS_FIELDS-1 and F_S = NUM_PHYS_FIELDS
5047 if ((.not. allocated(segment%field(m)%buffer_dst)) .or. &
5048 (segment%field(m)%bgc_tracer .and. (.not. obc%update_OBC_seg_data))) cycle
5049 nt = segment%field(m)%tr_index
5050 if (.not. segment%tr_Reg%Tr(nt)%is_initialized) then ! T/S may be initialized by fill_temp_salt_segments
5051 do k=1,nz ; do j=js_seg,je_seg ; do i=is_seg,ie_seg
5052 segment%tr_Reg%Tr(nt)%tres(i,j,k) = segment%tr_Reg%Tr(nt)%t(i,j,k)
5053 enddo ; enddo ; enddo
5054 segment%tr_Reg%Tr(nt)%is_initialized = .true.
5055 endif
5056 enddo ! end tracer field loop
5057 enddo ! end segment loop
5059
5060!> Update the OBC ramp value as a function of time.
5061!! If called with the optional argument activate=.true., record the
5062!! value of Time as the beginning of the ramp period.
5063subroutine update_obc_ramp(Time, OBC, US, activate)
5064 type(time_type), target, intent(in) :: time !< Current model time
5065 type(ocean_obc_type), intent(inout) :: obc !< Open boundary structure
5066 type(unit_scale_type), intent(in) :: us !< A dimensional unit scaling type
5067 logical, optional, intent(in) :: activate !< Specify whether to record the value of
5068 !! Time as the beginning of the ramp period
5069
5070 ! Local variables
5071 real :: deltatime ! The time since start of ramping [T ~> s]
5072 real :: wghta ! A temporary variable used to set OBC%ramp_value [nondim]
5073 character(len=12) :: msg
5074
5075 if (.not. obc%ramp) return ! This indicates the ramping is turned off
5076
5077 ! We use the optional argument to indicate this Time should be recorded as the
5078 ! beginning of the ramp-up period.
5079 if (present(activate)) then
5080 if (activate) then
5081 obc%ramp_start_time = time ! Record the current time
5082 obc%ramping_is_activated = .true.
5083 obc%trunc_ramp_time = obc%ramp_timescale ! times 3.0 for tanh
5084 endif
5085 endif
5086 if (.not.obc%ramping_is_activated) return
5087 deltatime = max(0., time_minus_signed(time, obc%ramp_start_time, scale=us%s_to_T))
5088 if (deltatime >= obc%trunc_ramp_time) then
5089 obc%ramp_value = 1.0
5090 obc%ramp = .false. ! This turns off ramping after this call
5091 else
5092 wghta = min( 1., deltatime / obc%ramp_timescale ) ! Linear profile in time
5093 !wghtA = wghtA*wghtA ! Convert linear profile to parabolic profile in time
5094 !wghtA = wghtA*wghtA*(3. - 2.*wghtA) ! Convert linear profile to cosine profile
5095 !wghtA = 1. - ( (1. - wghtA)**2 ) ! Convert linear profile to inverted parabolic profile
5096 !wghtA = tanh(wghtA) ! Convert linear profile to tanh
5097 obc%ramp_value = wghta
5098 endif
5099 write(msg(1:12),'(es12.3)') obc%ramp_value
5100 call mom_error(note, "MOM_open_boundary: update_OBC_ramp set OBC ramp to "//trim(msg))
5101end subroutine update_obc_ramp
5102
5103!> register open boundary objects for boundary updates.
5104subroutine register_obc(name, param_file, Reg)
5105 character(len=32), intent(in) :: name !< OBC name used for error messages
5106 type(param_file_type), intent(in) :: param_file !< file to parse for model parameter values
5107 type(obc_registry_type), pointer :: reg !< pointer to the tracer registry
5108 integer :: nobc
5109 character(len=256) :: mesg ! Message for error messages.
5110
5111 if (.not. associated(reg)) call obc_registry_init(param_file, reg)
5112
5113 if (reg%nobc>=max_fields_) then
5114 write(mesg, '("Increase MAX_FIELDS_ in MOM_memory.h to at least ",I0," to allow for &
5115 &all the open boundaries being registered via register_OBC.")') reg%nobc+1
5116 call mom_error(fatal,"MOM register_OBC: "//mesg)
5117 endif
5118 reg%nobc = reg%nobc + 1
5119 nobc = reg%nobc
5120
5121 reg%OB(nobc)%name = name
5122
5123 if (reg%locked) call mom_error(fatal, &
5124 "MOM register_OBC was called for OBC "//trim(reg%OB(nobc)%name)//&
5125 " with a locked OBC registry.")
5126
5127end subroutine register_obc
5128
5129!> This routine include declares and sets the variable "version".
5130subroutine obc_registry_init(param_file, Reg)
5131 type(param_file_type), intent(in) :: param_file !< open file to parse for model parameters
5132 type(obc_registry_type), pointer :: reg !< pointer to OBC registry
5133
5134 integer, save :: init_calls = 0
5135
5136# include "version_variable.h"
5137 character(len=256) :: mesg ! Message for error messages.
5138
5139 if (.not.associated(reg)) then ; allocate(reg)
5140 else ; return ; endif
5141
5142 ! Read all relevant parameters and write them to the model log.
5143! call log_version(param_file, mdl, version, "")
5144
5145 init_calls = init_calls + 1
5146 if (init_calls > 1) then
5147 write(mesg,'("OBC_registry_init called ",I0," times with different registry pointers.")') init_calls
5148 if (is_root_pe()) call mom_error(warning,"MOM_open_boundary: "//trim(mesg))
5149 endif
5150
5151end subroutine obc_registry_init
5152
5153!> Add file to OBC registry.
5154function register_file_obc(param_file, CS, US, OBC_Reg)
5155 type(param_file_type), intent(in) :: param_file !< parameter file.
5156 type(file_obc_cs), pointer :: cs !< file control structure.
5157 type(unit_scale_type), intent(in) :: us !< A dimensional unit scaling type
5158 type(obc_registry_type), pointer :: obc_reg !< OBC registry.
5159 logical :: register_file_obc
5160 character(len=32) :: casename = "OBC file" !< This case's name.
5161
5162 if (associated(cs)) then
5163 call mom_error(warning, "register_file_OBC called with an "// &
5164 "associated control structure.")
5165 return
5166 endif
5167 allocate(cs)
5168
5169 ! Register the file for boundary updates.
5170 call register_obc(casename, param_file, obc_reg)
5171 register_file_obc = .true.
5172
5173end function register_file_obc
5174
5175!> Clean up the file OBC from registry.
5176subroutine file_obc_end(CS)
5177 type(file_obc_cs), pointer :: cs !< OBC file control structure.
5178
5179 if (associated(cs)) then
5180 deallocate(cs)
5181 endif
5182end subroutine file_obc_end
5183
5184!> Initialize the segment tracer registry.
5185subroutine segment_tracer_registry_init(param_file, segment)
5186 type(param_file_type), intent(in) :: param_file !< open file to parse for model parameters
5187 type(obc_segment_type), intent(inout) :: segment !< the segment
5188
5189 integer, save :: init_calls = 0
5190
5191! This include declares and sets the variable "version".
5192# include "version_variable.h"
5193 character(len=40) :: mdl = "segment_tracer_registry_init" ! This routine's name.
5194 !character(len=256) :: mesg ! Message for error messages.
5195
5196 if (.not.associated(segment%tr_Reg)) then
5197 allocate(segment%tr_Reg)
5198 else
5199 return
5200 endif
5201
5202 init_calls = init_calls + 1
5203
5204 ! Read all relevant parameters and write them to the model log.
5205 if (init_calls == 1) call log_version(param_file, mdl, version, "")
5206
5207end subroutine segment_tracer_registry_init
5208
5209!> Initialize all the segment thickness reservoirs.
5210subroutine segment_thickness_reservoir_init(GV, US, OBC, param_file)
5211 type(param_file_type), intent(in) :: param_file !< open file to parse for model parameters
5212 type(verticalgrid_type), intent(in) :: gv !< ocean vertical grid structure
5213 type(unit_scale_type), intent(in) :: us !< Unit scaling type
5214 type(ocean_obc_type), pointer :: obc !< Open boundary structure
5215! real, optional, intent(in) :: OBC_scalar !< If present, use scalar value for segment tracer
5216! !! inflow concentration, including any rescaling to
5217! !! put the tracer concentration into its internal units,
5218! !! like [S ~> ppt] for salinity.
5219! logical, optional, intent(in) :: OBC_array !< If true, use array values for segment tracer
5220! !! inflow concentration.
5221! Local variables
5222 real :: rescale ! A multiplicatively corrected scaling factor, in units like [S ppt-1 ~> 1] for
5223 ! salinity, or other various units depending on what rescaling has occurred previously.
5224 integer :: nseg, m, isd, ied, jsd, jed, isdb, iedb, jsdb, jedb
5225 type(obc_segment_type), pointer :: segment => null() ! pointer to segment type list
5226 integer, save :: init_calls = 0
5227
5228! This include declares and sets the variable "version".
5229# include "version_variable.h"
5230 character(len=40) :: mdl = "segment_thickness_reservoir_init" ! This routine's name.
5231
5232 if (.not. associated(obc)) return
5233
5234 do nseg=1, obc%number_of_segments
5235 segment=>obc%segment(nseg)
5236 if (.not. segment%on_pe) cycle
5237
5238 if (associated(segment%h_Reg)) &
5239 call mom_error(fatal,"segment_thickness_reservoir_init: thickness array was previously allocated")
5240 allocate(segment%h_Reg)
5241
5242 isd = segment%HI%isd ; ied = segment%HI%ied
5243 jsd = segment%HI%jsd ; jed = segment%HI%jed
5244 isdb = segment%HI%IsdB ; iedb = segment%HI%IedB
5245 jsdb = segment%HI%JsdB ; jedb = segment%HI%JedB
5246
5247 segment%h_Reg%scale = us%Z_to_m
5248 do m=1,segment%num_fields
5249 if (uppercase(segment%field(m)%name) == uppercase(segment%h_Reg%name)) then
5250 if (.not. segment%field(m)%use_IO) then
5251 rescale = 1.0
5252 if ((segment%field(m)%scale /= 0.0) .and. (segment%field(m)%scale /= 1.0)) &
5253 rescale = 1.0 / segment%field(m)%scale
5254 segment%field(m)%value = rescale * segment%field(m)%value
5255 endif
5256 endif
5257 enddo
5258
5259 if (segment%is_E_or_W) then
5260 allocate(segment%h_Reg%h(isdb:iedb,jsd:jed,1:gv%ke), source=0.0)
5261 allocate(segment%h_Reg%h_res(isdb:iedb,jsd:jed,1:gv%ke), source=0.0)
5262 elseif (segment%is_N_or_S) then
5263 allocate(segment%h_Reg%h(isd:ied,jsdb:jedb,1:gv%ke), source=0.0)
5264 allocate(segment%h_Reg%h_res(isd:ied,jsdb:jedb,1:gv%ke), source=0.0)
5265 endif
5266 segment%h_Reg%is_initialized = .false.
5267
5268 init_calls = init_calls + 1
5269
5270 ! Read all relevant parameters and write them to the model log.
5271 if (init_calls == 1) call log_version(param_file, mdl, version, "")
5272 enddo
5273
5275
5276!> Register a tracer on an OBC segment, allocate its t and tres arrays, and set the
5277!! per-tracer inverse length scales (I_Lscale_in/out) that control reservoir relaxation.
5278subroutine register_segment_tracer(tr_ptr, ntr_index, param_file, GV, segment, OBC_scalar, &
5279 scale, resrv_lfac_in, resrv_lfac_out)
5280 type(verticalgrid_type), intent(in) :: gv !< ocean vertical grid structure
5281 type(tracer_type), target :: tr_ptr !< Tracer to register; must persist in the caller's
5282 !! control structure for the lifetime of the segment.
5283 integer, intent(in) :: ntr_index !< index of segment tracer in the global tracer registry
5284 type(param_file_type), intent(in) :: param_file !< file to parse for model parameter values
5285 type(obc_segment_type), intent(inout) :: segment !< current segment data structure
5286 real, optional, intent(in) :: obc_scalar !< If present, use this spatially uniform value as the
5287 !! OBC inflow concentration in the tracer's internal
5288 !! units, like [S ~> ppt] for salinity. Mutually
5289 !! exclusive with resrv_lfac_in and resrv_lfac_out.
5290 real, optional, intent(in) :: scale !< A scaling factor that should be used with any
5291 !! data that is read in to convert it to the internal
5292 !! units of this tracer, in units like [S ppt-1 ~> 1]
5293 !! for salinity.
5294 real, optional, intent(in) :: resrv_lfac_in !< Per-tracer multiplier for the inward reservoir
5295 !! relaxation length scale [nondim].
5296 real, optional, intent(in) :: resrv_lfac_out !< Per-tracer multiplier for the outward reservoir
5297 !! relaxation length scale [nondim].
5298
5299 ! Local variables
5300 real :: rescale ! A multiplicatively corrected scaling factor, in units like [S ppt-1 ~> 1] for
5301 ! salinity, or other various units depending on what rescaling has occurred previously.
5302 integer :: ntseg, m, isd, ied, jsd, jed, isdb, iedb, jsdb, jedb
5303 character(len=256) :: mesg ! Message for error messages.
5304 real :: init_value ! Initial tracer concentration in OBC-rescaled units [A ~> a]
5305
5306 if (present(obc_scalar) .and. (present(resrv_lfac_in) .or. present(resrv_lfac_out))) &
5307 call mom_error(fatal, "register_segment_tracer: OBC_scalar and resrv_lfac_in/out are "// &
5308 "mutually exclusive for tracer "//trim(tr_ptr%name))
5309
5310 call segment_tracer_registry_init(param_file, segment)
5311
5312 if (segment%tr_Reg%ntseg>=max_fields_) then
5313 write(mesg,'("Increase MAX_FIELDS_ in MOM_memory.h to at least ",I0," to allow for &
5314 &all the tracers being registered via register_segment_tracer.")') segment%tr_Reg%ntseg+1
5315 call mom_error(fatal,"MOM register_segment_tracer: "//mesg)
5316 endif
5317 segment%tr_Reg%ntseg = segment%tr_Reg%ntseg + 1
5318 ntseg = segment%tr_Reg%ntseg
5319
5320 isd = segment%HI%isd ; ied = segment%HI%ied
5321 jsd = segment%HI%jsd ; jed = segment%HI%jed
5322 isdb = segment%HI%IsdB ; iedb = segment%HI%IedB
5323 jsdb = segment%HI%JsdB ; jedb = segment%HI%JedB
5324
5325 segment%tr_Reg%Tr(ntseg)%name = tr_ptr%name
5326 segment%tr_Reg%Tr(ntseg)%ntr_index = ntr_index
5327
5328 segment%tr_Reg%Tr(ntseg)%scale = 1.0
5329 if (present(scale)) then
5330 segment%tr_Reg%Tr(ntseg)%scale = scale
5331 do m=1,segment%num_fields
5332 ! Store the scaling factor for fields with exactly matching names, and possibly
5333 ! rescale the previously stored input values. Note that calls to register_segment_tracer
5334 ! can come before or after calls to initialize_segment_data.
5335 if (uppercase(segment%field(m)%name) == uppercase(segment%tr_Reg%Tr(ntseg)%name)) then
5336 if (.not. segment%field(m)%use_IO) then
5337 rescale = scale
5338 if ((segment%field(m)%scale /= 0.0) .and. (segment%field(m)%scale /= 1.0)) &
5339 rescale = scale / segment%field(m)%scale
5340 segment%field(m)%value = rescale * segment%field(m)%value
5341 endif
5342 segment%field(m)%scale = scale
5343 endif
5344 enddo
5345 endif
5346
5347 if (segment%tr_Reg%locked) call mom_error(fatal, &
5348 "MOM register_segment_tracer was called for variable "//trim(segment%tr_Reg%Tr(ntseg)%name)//&
5349 " with a locked tracer registry.")
5350
5351 if (present(obc_scalar)) then
5352 init_value = obc_scalar
5353 segment%tr_Reg%Tr(ntseg)%is_initialized = .true.
5354 segment%tr_Reg%Tr(ntseg)%resrv_lfac_in = 0.0
5355 segment%tr_Reg%Tr(ntseg)%resrv_lfac_out = 0.0
5356 else
5357 init_value = 0.0
5358 segment%tr_Reg%Tr(ntseg)%is_initialized = .false.
5359 ! Currently, resrv_lfac_in/out are for BGC tracers only.
5360 if (present(resrv_lfac_in)) segment%tr_Reg%Tr(ntseg)%resrv_lfac_in = resrv_lfac_in
5361 if (present(resrv_lfac_out)) segment%tr_Reg%Tr(ntseg)%resrv_lfac_out = resrv_lfac_out
5362 endif
5363
5364 if (segment%is_E_or_W) then
5365 allocate(segment%tr_Reg%Tr(ntseg)%t(isdb:iedb,jsd:jed,1:gv%ke), source=init_value)
5366 allocate(segment%tr_Reg%Tr(ntseg)%tres(isdb:iedb,jsd:jed,1:gv%ke), source=init_value)
5367 elseif (segment%is_N_or_S) then
5368 allocate(segment%tr_Reg%Tr(ntseg)%t(isd:ied,jsdb:jedb,1:gv%ke), source=init_value)
5369 allocate(segment%tr_Reg%Tr(ntseg)%tres(isd:ied,jsdb:jedb,1:gv%ke), source=init_value)
5370 endif
5371
5372 ! Assign per-tracer inverse length scales from the per-tracer factor (resrv_lfac) and the
5373 ! segment-level inverse length scale (Tr_InvLscale). Three regimes for each direction:
5374 ! I_Lscale > 0 : finite relaxation length scale.
5375 ! I_Lscale = 0 : infinite length scale; reservoir does not update.
5376 ! I_Lscale = -1 : instant-update sentinel; reservoir is immediately replaced by interior or
5377 ! external values.
5378 ! For the two edge cases, resrv_lfac overrides Tr_InvLscale entirely, i.e.,
5379 ! resrv_lfac = 0 : I_Lscale = 0
5380 ! resrv_lfac = -1 : I_Lscale = -1
5381 segment%tr_Reg%Tr(ntseg)%I_Lscale_in = &
5382 segment%tr_Reg%Tr(ntseg)%resrv_lfac_in * segment%Tr_InvLscale_in
5383 if ((segment%tr_Reg%Tr(ntseg)%resrv_lfac_in == -1.0) .or. &
5384 (segment%tr_Reg%Tr(ntseg)%I_Lscale_in < 0.0)) &
5385 segment%tr_Reg%Tr(ntseg)%I_Lscale_in = -1.0
5386 segment%tr_Reg%Tr(ntseg)%I_Lscale_out = &
5387 segment%tr_Reg%Tr(ntseg)%resrv_lfac_out * segment%Tr_InvLscale_out
5388 if ((segment%tr_Reg%Tr(ntseg)%resrv_lfac_out == -1.0) .or. &
5389 (segment%tr_Reg%Tr(ntseg)%I_Lscale_out < 0.0)) &
5390 segment%tr_Reg%Tr(ntseg)%I_Lscale_out = -1.0
5391end subroutine register_segment_tracer
5392
5393!> Clean up the segment tracer registry.
5394subroutine segment_tracer_registry_end(Reg)
5395 type(segment_tracer_registry_type), pointer :: reg !< pointer to tracer registry
5396
5397 ! Local variables
5398 integer :: n
5399
5400 if (associated(reg)) then
5401 do n=1, reg%ntseg
5402 if (allocated(reg%Tr(n)%t)) deallocate(reg%Tr(n)%t)
5403 if (allocated(reg%Tr(n)%tres)) deallocate(reg%Tr(n)%tres)
5404 enddo
5405 deallocate(reg)
5406 endif
5407end subroutine segment_tracer_registry_end
5408
5409!> Clean up the segment thickness object
5410subroutine segment_thickness_registry_end(Reg)
5411 type(obc_segment_thickness_type), pointer :: Reg !< pointer to thickness reservoir
5412
5413 if (associated(reg)) then
5414 if (allocated(reg%h)) deallocate(reg%h)
5415 if (allocated(reg%h_res)) deallocate(reg%h_res)
5416 deallocate(reg)
5417 endif
5418end subroutine segment_thickness_registry_end
5419
5420!> Registers the temperature and salinity in the segment tracer registry.
5421subroutine register_temp_salt_segments(GV, US, OBC, tr_Reg, param_file)
5422 type(verticalgrid_type), intent(in) :: gv !< ocean vertical grid structure
5423 type(unit_scale_type), intent(in) :: us !< Unit scaling type
5424 type(ocean_obc_type), pointer :: obc !< Open boundary structure
5425 type(tracer_registry_type), pointer :: tr_reg !< Tracer registry
5426 type(param_file_type), intent(in) :: param_file !< file to parse for model parameter values
5427
5428 ! Local variables
5429 integer :: n, ntr_id
5430 character(len=32) :: name
5431 type(obc_segment_type), pointer :: segment => null() ! pointer to segment type list
5432 type(tracer_type), pointer :: tr_ptr => null()
5433
5434 if (.not. associated(obc)) return
5435
5436 do n=1,obc%number_of_segments
5437 segment => obc%segment(n)
5438 if (.not. segment%on_pe) cycle
5439
5440 if (associated(segment%tr_Reg)) &
5441 call mom_error(fatal,"register_temp_salt_segments: tracer array was previously allocated")
5442
5443 name = 'temp'
5444 call tracer_name_lookup(tr_reg, ntr_id, tr_ptr, name)
5445 call register_segment_tracer(tr_ptr, ntr_id, param_file, gv, segment, scale=us%degC_to_C)
5446 name = 'salt'
5447 call tracer_name_lookup(tr_reg, ntr_id, tr_ptr, name)
5448 call register_segment_tracer(tr_ptr, ntr_id, param_file, gv, segment, scale=us%ppt_to_S)
5449 enddo
5450
5451end subroutine register_temp_salt_segments
5452
5453!> Sets the OBC properties of external obgc tracers, such as their source file and field name
5454subroutine set_obgc_segments_props(OBC,tr_name,obc_src_file_name,obc_src_field_name,lfac_in,lfac_out)
5455 type(ocean_obc_type),pointer :: obc !< Open boundary structure
5456 character(len=*), intent(in) :: tr_name !< Tracer name
5457 character(len=*), intent(in) :: obc_src_file_name !< OBC source file name
5458 character(len=*), intent(in) :: obc_src_field_name !< name of the field in the source file
5459 real, intent(in) :: lfac_in !< factors for tracer reservoir inbound length scales [nondim]
5460 real, intent(in) :: lfac_out !< factors for tracer reservoir outbound length scales [nondim]
5461
5462 type(external_tracers_segments_props),pointer :: node_ptr => null() !pointer to type that keeps
5463 ! the tracer segment properties
5464 allocate(node_ptr)
5465 node_ptr%tracer_name = trim(tr_name)
5466 node_ptr%tracer_src_file = trim(obc_src_file_name)
5467 node_ptr%tracer_src_field = trim(obc_src_field_name)
5468 node_ptr%lfac_in = lfac_in
5469 node_ptr%lfac_out = lfac_out
5470 ! Reversed Linked List implementation! Make this new node to be the head of the list.
5471 node_ptr%next => obc%obgc_segments_props
5472 obc%obgc_segments_props => node_ptr
5473 obc%num_obgc_tracers = obc%num_obgc_tracers+1
5474end subroutine set_obgc_segments_props
5475
5476!> Get the OBC properties of external obgc tracers, such as their source file, field name,
5477!! reservoir length scale factors
5478subroutine get_obgc_segments_props(node, tr_name,obc_src_file_name,obc_src_field_name,lfac_in,lfac_out)
5479 type(external_tracers_segments_props),pointer :: node !< pointer to tracer segment properties
5480 character(len=*), intent(out) :: tr_name !< Tracer name
5481 character(len=*), intent(out) :: obc_src_file_name !< OBC source file name
5482 character(len=*), intent(out) :: obc_src_field_name !< name of the field in the source file
5483 real, intent(out) :: lfac_in !< multiplicative factor for inbound reservoir length scale [nondim]
5484 real, intent(out) :: lfac_out !< multiplicative factor for outbound reservoir length scale [nondim]
5485 tr_name = trim(node%tracer_name)
5486 obc_src_file_name = trim(node%tracer_src_file)
5487 obc_src_field_name = trim(node%tracer_src_field)
5488 lfac_in = node%lfac_in
5489 lfac_out = node%lfac_out
5490 node => node%next
5491end subroutine get_obgc_segments_props
5492
5493!> Registers a named tracer in the segment tracer registries for the OBC segments on which it is active.
5494subroutine register_obgc_segments(GV, OBC, tr_Reg, param_file, tr_name)
5495 type(verticalgrid_type), intent(in) :: gv !< ocean vertical grid structure
5496 type(ocean_obc_type), pointer :: obc !< Open boundary structure
5497 type(tracer_registry_type), pointer :: tr_reg !< Tracer registry
5498 type(param_file_type), intent(in) :: param_file !< file to parse for model parameter values
5499 character(len=*), intent(in) :: tr_name !< Tracer name
5500
5501 ! Local variables
5502 integer :: ntr_id
5503 integer :: n, m
5504 type(obc_segment_type), pointer :: segment => null() ! pointer to segment type list
5505 type(tracer_type), pointer :: tr_ptr => null()
5506 real :: resrv_lfac_in ! Per-tracer multiplier for the inward reservoir
5507 ! relaxation length scale [nondim].
5508 real :: resrv_lfac_out ! Per-tracer multiplier for the outward reservoir
5509 ! relaxation length scale [nondim].
5510
5511 if (.not. associated(obc)) return
5512
5513 do n=1,obc%number_of_segments
5514 segment => obc%segment(n)
5515 if (.not. segment%on_pe) cycle
5516 call tracer_name_lookup(tr_reg, ntr_id, tr_ptr, tr_name)
5517 resrv_lfac_in = 1.0
5518 resrv_lfac_out = 1.0
5519 do m=1,segment%num_fields
5520 if (lowercase(segment%field(m)%name) == lowercase(tr_name)) then
5521 resrv_lfac_in = segment%field(m)%resrv_lfac_in
5522 resrv_lfac_out = segment%field(m)%resrv_lfac_out
5523 endif
5524 enddo
5525 call register_segment_tracer(tr_ptr, ntr_id, param_file, gv, segment, &
5526 resrv_lfac_in=resrv_lfac_in, resrv_lfac_out=resrv_lfac_out)
5527 enddo
5528end subroutine register_obgc_segments
5529
5530!> Stores the interior tracer values on the segment, and in some cases also sets the tracer reservoir values.
5531subroutine fill_obgc_segments(G, GV, OBC, tr_ptr, tr_name)
5532 type(ocean_grid_type), intent(inout) :: g !< Ocean grid structure
5533 type(verticalgrid_type), intent(in) :: gv !< ocean vertical grid structure
5534 type(ocean_obc_type), pointer :: obc !< Open boundary structure
5535 real, dimension(:,:,:), pointer :: tr_ptr !< Pointer to tracer field in scaled concentration
5536 !! units, like [S ~> ppt] for salinity.
5537 character(len=*), intent(in) :: tr_name !< Tracer name
5538! Local variables
5539 integer :: isd, ied, isdb, iedb, jsd, jed, jsdb, jedb, n, nz, nt
5540 integer :: i, j, k
5541 type(obc_segment_type), pointer :: segment => null() ! pointer to segment type list
5542 real :: i_scale ! A factor that unscales the internal units of a tracer, like [ppt S-1 ~> 1] for salinity
5543
5544 if (.not. associated(obc)) return
5545 call pass_var(tr_ptr, g%Domain)
5546 nz = g%ke
5547 do n=1,obc%number_of_segments
5548 segment => obc%segment(n)
5549 if (.not. segment%on_pe) cycle
5550 nt = get_tracer_index(segment, tr_name)
5551 if (nt < 0) then
5552 call mom_error(fatal,"fill_obgc_segments: Did not find tracer "// tr_name)
5553 endif
5554 isd = segment%HI%isd ; ied = segment%HI%ied
5555 jsd = segment%HI%jsd ; jed = segment%HI%jed
5556 isdb = segment%HI%IsdB ; iedb = segment%HI%IedB
5557 jsdb = segment%HI%JsdB ; jedb = segment%HI%JedB
5558
5559 ! Fill segments with Tracer values
5560 if (segment%direction == obc_direction_w) then
5561 i = segment%HI%IsdB
5562 do k=1,nz ; do j=segment%HI%jsd,segment%HI%jed
5563 segment%tr_Reg%Tr(nt)%t(i,j,k) = tr_ptr(i+1,j,k)
5564 enddo ; enddo
5565 elseif (segment%direction == obc_direction_e) then
5566 i = segment%HI%IsdB
5567 do k=1,nz ; do j=segment%HI%jsd,segment%HI%jed
5568 segment%tr_Reg%Tr(nt)%t(i,j,k) = tr_ptr(i,j,k)
5569 enddo ; enddo
5570 elseif (segment%direction == obc_direction_s) then
5571 j = segment%HI%JsdB
5572 do k=1,nz ; do i=segment%HI%isd,segment%HI%ied
5573 segment%tr_Reg%Tr(nt)%t(i,j,k) = tr_ptr(i,j+1,k)
5574 enddo ; enddo
5575 elseif (segment%direction == obc_direction_n) then
5576 j = segment%HI%JsdB
5577 do k=1,nz ; do i=segment%HI%isd,segment%HI%ied
5578 segment%tr_Reg%Tr(nt)%t(i,j,k) = tr_ptr(i,j,k)
5579 enddo ; enddo
5580 endif
5581
5582 if (.not.segment%tr_Reg%Tr(nt)%is_initialized) &
5583 segment%tr_Reg%Tr(nt)%tres(:,:,:) = segment%tr_Reg%Tr(nt)%t(:,:,:)
5584
5585 if (obc%reservoir_init_bug) then
5586 ! OBC%tres_x and OBC%tres_y should not be set here, but in a subsequent call to setup_OBC_tracer_reservoirs.
5587 ! Note that fill_obgc_segments is not called for runs that start from a restart file.
5588 i_scale = 1.0
5589 if (segment%tr_Reg%Tr(nt)%scale /= 0.0) i_scale = 1.0 / segment%tr_Reg%Tr(nt)%scale
5590 if (segment%is_E_or_W) then
5591 if (allocated(obc%tres_x)) then
5592 i = segment%HI%IsdB
5593 do k=1,nz ; do j=segment%HI%jsd,segment%HI%jed
5594 obc%tres_x(i,j,k,nt) = i_scale * segment%tr_Reg%Tr(nt)%tres(i,j,k)
5595 enddo ; enddo
5596 endif
5597 else ! segment%is_N_or_S
5598 if (allocated(obc%tres_y)) then
5599 j = segment%HI%JsdB
5600 do k=1,nz ; do i=segment%HI%isd,segment%HI%ied
5601 obc%tres_y(i,j,k,nt) = i_scale * segment%tr_Reg%Tr(nt)%tres(i,j,k)
5602 enddo ; enddo
5603 endif
5604 endif
5605 endif
5606
5607 enddo ! End of loop over segments.
5608
5609end subroutine fill_obgc_segments
5610
5611!> Set the value of temperatures and salinities on OBC segments
5612subroutine fill_temp_salt_segments(G, GV, US, OBC, tv)
5613 type(ocean_grid_type), intent(in) :: g !< Ocean grid structure
5614 type(verticalgrid_type), intent(in) :: gv !< ocean vertical grid structure
5615 type(unit_scale_type), intent(in) :: us !< Unit scaling
5616 type(ocean_obc_type), pointer :: obc !< Open boundary structure
5617 type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure
5618
5619 integer :: isd, ied, isdb, iedb, jsd, jed, jsdb, jedb, n, nz
5620 integer :: i, j, k
5621 type(obc_segment_type), pointer :: segment => null() ! pointer to segment type list
5622
5623 if (.not. associated(obc)) return
5624 if (.not. associated(tv%T) .and. associated(tv%S)) return
5625 ! Both temperature and salinity fields
5626
5627 nz = gv%ke
5628
5629 do n=1,obc%number_of_segments
5630 segment => obc%segment(n)
5631 if (.not. segment%on_pe) cycle
5632
5633 isd = segment%HI%isd ; ied = segment%HI%ied
5634 jsd = segment%HI%jsd ; jed = segment%HI%jed
5635 isdb = segment%HI%IsdB ; iedb = segment%HI%IedB
5636 jsdb = segment%HI%JsdB ; jedb = segment%HI%JedB
5637
5638 ! Fill with T and S values
5639 if (segment%is_E_or_W) then
5640 i=segment%HI%IsdB
5641 do k=1,nz ; do j=segment%HI%jsd,segment%HI%jed
5642 if (segment%direction == obc_direction_w) then
5643 segment%tr_Reg%Tr(1)%t(i,j,k) = tv%T(i+1,j,k)
5644 segment%tr_Reg%Tr(2)%t(i,j,k) = tv%S(i+1,j,k)
5645 else
5646 segment%tr_Reg%Tr(1)%t(i,j,k) = tv%T(i,j,k)
5647 segment%tr_Reg%Tr(2)%t(i,j,k) = tv%S(i,j,k)
5648 endif
5649 enddo ; enddo
5650 else
5651 j=segment%HI%JsdB
5652 do k=1,nz ; do i=segment%HI%isd,segment%HI%ied
5653 if (segment%direction == obc_direction_s) then
5654 segment%tr_Reg%Tr(1)%t(i,j,k) = tv%T(i,j+1,k)
5655 segment%tr_Reg%Tr(2)%t(i,j,k) = tv%S(i,j+1,k)
5656 else
5657 segment%tr_Reg%Tr(1)%t(i,j,k) = tv%T(i,j,k)
5658 segment%tr_Reg%Tr(2)%t(i,j,k) = tv%S(i,j,k)
5659 endif
5660 enddo ; enddo
5661 endif
5662 if (.not.segment%tr_Reg%Tr(1)%is_initialized) &
5663 segment%tr_Reg%Tr(1)%tres(:,:,:) = segment%tr_Reg%Tr(1)%t(:,:,:)
5664 if (.not.segment%tr_Reg%Tr(2)%is_initialized) &
5665 segment%tr_Reg%Tr(2)%tres(:,:,:) = segment%tr_Reg%Tr(2)%t(:,:,:)
5666 enddo
5667
5668end subroutine fill_temp_salt_segments
5669
5670!> Set the value of temperatures and salinities on OBC segments
5671subroutine fill_thickness_segments(G, GV, US, OBC, h)
5672 type(ocean_grid_type), intent(in) :: g !< Ocean grid structure
5673 type(verticalgrid_type), intent(in) :: gv !< ocean vertical grid structure
5674 type(unit_scale_type), intent(in) :: us !< Unit scaling
5675 type(ocean_obc_type), pointer :: obc !< Open boundary structure
5676 real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]
5677
5678 integer :: isd, ied, isdb, iedb, jsd, jed, jsdb, jedb, n, nz
5679 integer :: i, j, k
5680 type(obc_segment_type), pointer :: segment => null() ! pointer to segment type list
5681
5682 if (.not. associated(obc)) return
5683 ! Both temperature and salinity fields
5684
5685 nz = gv%ke
5686
5687 do n=1, obc%number_of_segments
5688 segment => obc%segment(n)
5689 if (.not. segment%on_pe) cycle
5690
5691 isd = segment%HI%isd ; ied = segment%HI%ied
5692 jsd = segment%HI%jsd ; jed = segment%HI%jed
5693 isdb = segment%HI%IsdB ; iedb = segment%HI%IedB
5694 jsdb = segment%HI%JsdB ; jedb = segment%HI%JedB
5695
5696 ! Fill with thickness
5697 if (segment%is_E_or_W) then
5698 i=segment%HI%IsdB
5699 do k=1,nz ; do j=segment%HI%jsd,segment%HI%jed
5700 if (segment%direction == obc_direction_w) then
5701 segment%h_Reg%h(i,j,k) = h(i+1,j,k)
5702 else
5703 segment%h_Reg%h(i,j,k) = h(i,j,k)
5704 endif
5705 enddo ; enddo
5706 else
5707 j=segment%HI%JsdB
5708 do k=1,nz ; do i=segment%HI%isd,segment%HI%ied
5709 if (segment%direction == obc_direction_s) then
5710 segment%h_Reg%h(i,j,k) = h(i,j+1,k)
5711 else
5712 segment%h_Reg%h(i,j,k) = h(i,j,k)
5713 endif
5714 enddo ; enddo
5715 endif
5716 if (.not.segment%h_Reg%is_initialized) then
5717 segment%h_Reg%h_res(:,:,:) = segment%h_Reg%h(:,:,:)
5718 segment%h_Reg%is_initialized = .true.
5719 endif
5720 enddo
5721
5722end subroutine fill_thickness_segments
5723
5724!> Find the region outside of all open boundary segments and
5725!! make sure it is set to land mask. Gonna need to know global land
5726!! mask as well to get it right...
5727subroutine mask_outside_obcs(G, US, param_file, OBC)
5728 type(dyn_horgrid_type), intent(inout) :: G !< Ocean grid structure
5729 type(param_file_type), intent(in) :: param_file !< Parameter file handle
5730 type(ocean_obc_type), pointer :: OBC !< Open boundary structure
5731 type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
5732
5733 ! Local variables
5734 integer :: i, j
5735 logical :: fatal_error = .false.
5736 real :: min_depth ! The minimum depth for ocean points [Z ~> m]
5737 real :: mask_depth ! The masking depth for ocean points [Z ~> m]
5738 real :: Dmask ! The depth for masking in the same units as G%bathyT [Z ~> m].
5739 integer, parameter :: cin = 3, cout = 4, cland = -1, cedge = -2
5740 character(len=256) :: mesg ! Message for error messages.
5741 real, allocatable, dimension(:,:) :: color, color2 ! For sorting inside from outside,
5742 ! two different ways [nondim]
5743
5744 if (.not. associated(obc)) return
5745
5746 call get_param(param_file, mdl, "MINIMUM_DEPTH", min_depth, &
5747 units="m", default=0.0, scale=us%m_to_Z, do_not_log=.true.)
5748 call get_param(param_file, mdl, "MASKING_DEPTH", mask_depth, &
5749 units="m", default=-9999.0, scale=us%m_to_Z, do_not_log=.true.)
5750
5751 dmask = mask_depth
5752 if (mask_depth == -9999.0*us%m_to_Z) dmask = min_depth
5753
5754 ! The reference depth on a dyn_horgrid is 0, otherwise would need: min_depth = min_depth - G%Z_ref
5755
5756 allocate(color(g%isd:g%ied, g%jsd:g%jed), source=0.0)
5757 allocate(color2(g%isd:g%ied, g%jsd:g%jed), source=0.0)
5758
5759 ! Paint a frame around the outside.
5760 do j=g%jsd,g%jed
5761 color(g%isd,j) = cedge
5762 color(g%ied,j) = cedge
5763 color2(g%isd,j) = cedge
5764 color2(g%ied,j) = cedge
5765 enddo
5766 do i=g%isd,g%ied
5767 color(i,g%jsd) = cedge
5768 color(i,g%jed) = cedge
5769 color2(i,g%jsd) = cedge
5770 color2(i,g%jed) = cedge
5771 enddo
5772
5773 ! Set color to cland in the land. Note that this is before the land
5774 ! mask has been initialized, set mask values based on depth.
5775 do j=g%jsd,g%jed
5776 do i=g%isd,g%ied
5777 if (g%bathyT(i,j) <= min_depth) color(i,j) = cland
5778 if (g%bathyT(i,j) <= min_depth) color2(i,j) = cland
5779 enddo
5780 enddo
5781
5782 do j=g%jsd,g%jed ; do i=g%IsdB+1,g%IedB-1
5783 if (obc%segnum_u(i,j) < 0) then ! OBC_DIRECTION_W
5784 if (color(i,j) == 0.0) color(i,j) = cout
5785 if (color(i+1,j) == 0.0) color(i+1,j) = cin
5786 elseif (obc%segnum_u(i,j) > 0) then ! OBC_DIRECTION_E
5787 if (color(i,j) == 0.0) color(i,j) = cin
5788 if (color(i+1,j) == 0.0) color(i+1,j) = cout
5789 endif
5790 enddo ; enddo
5791 do j=g%JsdB+1,g%JedB-1 ; do i=g%isd,g%ied
5792 if (obc%segnum_v(i,j) < 0) then ! OBC_DIRECTION_S
5793 if (color(i,j) == 0.0) color(i,j) = cout
5794 if (color(i,j+1) == 0.0) color(i,j+1) = cin
5795 elseif (obc%segnum_v(i,j) > 0) then ! OBC_DIRECTION_N
5796 if (color(i,j) == 0.0) color(i,j) = cin
5797 if (color(i,j+1) == 0.0) color(i,j+1) = cout
5798 endif
5799 enddo ; enddo
5800
5801 do j=g%JsdB+1,g%JedB-1 ; do i=g%isd,g%ied
5802 if (obc%segnum_v(i,j) < 0) then ! OBC_DIRECTION_S
5803 if (color2(i,j) == 0.0) color2(i,j) = cout
5804 if (color2(i,j+1) == 0.0) color2(i,j+1) = cin
5805 elseif (obc%segnum_v(i,j) > 0) then ! OBC_DIRECTION_N
5806 if (color2(i,j) == 0.0) color2(i,j) = cin
5807 if (color2(i,j+1) == 0.0) color2(i,j+1) = cout
5808 endif
5809 enddo ; enddo
5810 do j=g%jsd,g%jed ; do i=g%IsdB+1,g%IedB-1
5811 if (obc%segnum_u(i,j) < 0) then ! OBC_DIRECTION_W
5812 if (color2(i,j) == 0.0) color2(i,j) = cout
5813 if (color2(i+1,j) == 0.0) color2(i+1,j) = cin
5814 elseif (obc%segnum_u(i,j) > 0) then ! OBC_DIRECTION_E
5815 if (color2(i,j) == 0.0) color2(i,j) = cin
5816 if (color2(i+1,j) == 0.0) color2(i+1,j) = cout
5817 endif
5818 enddo ; enddo
5819
5820 ! Do the flood fill until there are no more uncolored cells.
5821 call flood_fill(g, color, cin, cout, cland)
5822 call flood_fill2(g, color2, cin, cout, cland)
5823
5824 ! Use the color to set outside to min_depth on this process.
5825 do j=g%jsd,g%jed ; do i=g%isd,g%ied
5826 if (color(i,j) /= color2(i,j)) then
5827 fatal_error = .true.
5828 write(mesg,'("MOM_open_boundary: problem with OBC segments specification at ",I0,",",I0," during\n", &
5829 &"the masking of the outside grid points.")') i, j
5830 call mom_error(warning,"MOM mask_outside_OBCs: "//mesg, all_print=.true.)
5831 endif
5832 if (color(i,j) == cout) g%bathyT(i,j) = dmask
5833 enddo ; enddo
5834 if (fatal_error) call mom_error(fatal, &
5835 "MOM_open_boundary: inconsistent OBC segments.")
5836
5837 deallocate(color)
5838 deallocate(color2)
5839end subroutine mask_outside_obcs
5840
5841!> flood the cin, cout values
5842subroutine flood_fill(G, color, cin, cout, cland)
5843 type(dyn_horgrid_type), intent(inout) :: g !< Ocean grid structure
5844 real, dimension(:,:), intent(inout) :: color !< For sorting inside from outside [nondim]
5845 integer, intent(in) :: cin !< color for inside the domain
5846 integer, intent(in) :: cout !< color for outside the domain
5847 integer, intent(in) :: cland !< color for inside the land mask
5848
5849! Local variables
5850 integer :: i, j, ncount
5851
5852 ncount = 1
5853 do while (ncount > 0)
5854 ncount = 0
5855 do j=g%jsd+1,g%jed-1
5856 do i=g%isd+1,g%ied-1
5857 if (color(i,j) == 0.0 .and. color(i-1,j) > 0.0) then
5858 color(i,j) = color(i-1,j)
5859 ncount = ncount + 1
5860 endif
5861 if (color(i,j) == 0.0 .and. color(i+1,j) > 0.0) then
5862 color(i,j) = color(i+1,j)
5863 ncount = ncount + 1
5864 endif
5865 if (color(i,j) == 0.0 .and. color(i,j-1) > 0.0) then
5866 color(i,j) = color(i,j-1)
5867 ncount = ncount + 1
5868 endif
5869 if (color(i,j) == 0.0 .and. color(i,j+1) > 0.0) then
5870 color(i,j) = color(i,j+1)
5871 ncount = ncount + 1
5872 endif
5873 enddo
5874 enddo
5875 do j=g%jed-1,g%jsd+1,-1
5876 do i=g%ied-1,g%isd+1,-1
5877 if (color(i,j) == 0.0 .and. color(i-1,j) > 0.0) then
5878 color(i,j) = color(i-1,j)
5879 ncount = ncount + 1
5880 endif
5881 if (color(i,j) == 0.0 .and. color(i+1,j) > 0.0) then
5882 color(i,j) = color(i+1,j)
5883 ncount = ncount + 1
5884 endif
5885 if (color(i,j) == 0.0 .and. color(i,j-1) > 0.0) then
5886 color(i,j) = color(i,j-1)
5887 ncount = ncount + 1
5888 endif
5889 if (color(i,j) == 0.0 .and. color(i,j+1) > 0.0) then
5890 color(i,j) = color(i,j+1)
5891 ncount = ncount + 1
5892 endif
5893 enddo
5894 enddo
5895 call pass_var(color, g%Domain)
5896 call sum_across_pes(ncount)
5897 enddo
5898
5899end subroutine flood_fill
5900
5901!> flood the cin, cout values
5902subroutine flood_fill2(G, color, cin, cout, cland)
5903 type(dyn_horgrid_type), intent(inout) :: g !< Ocean grid structure
5904 real, dimension(:,:), intent(inout) :: color !< For sorting inside from outside [nondim]
5905 integer, intent(in) :: cin !< color for inside the domain
5906 integer, intent(in) :: cout !< color for outside the domain
5907 integer, intent(in) :: cland !< color for inside the land mask
5908
5909! Local variables
5910 integer :: i, j, ncount
5911
5912 ncount = 1
5913 do while (ncount > 0)
5914 ncount = 0
5915 do i=g%isd+1,g%ied-1
5916 do j=g%jsd+1,g%jed-1
5917 if (color(i,j) == 0.0 .and. color(i-1,j) > 0.0) then
5918 color(i,j) = color(i-1,j)
5919 ncount = ncount + 1
5920 endif
5921 if (color(i,j) == 0.0 .and. color(i+1,j) > 0.0) then
5922 color(i,j) = color(i+1,j)
5923 ncount = ncount + 1
5924 endif
5925 if (color(i,j) == 0.0 .and. color(i,j-1) > 0.0) then
5926 color(i,j) = color(i,j-1)
5927 ncount = ncount + 1
5928 endif
5929 if (color(i,j) == 0.0 .and. color(i,j+1) > 0.0) then
5930 color(i,j) = color(i,j+1)
5931 ncount = ncount + 1
5932 endif
5933 enddo
5934 enddo
5935 do i=g%ied-1,g%isd+1,-1
5936 do j=g%jed-1,g%jsd+1,-1
5937 if (color(i,j) == 0.0 .and. color(i-1,j) > 0.0) then
5938 color(i,j) = color(i-1,j)
5939 ncount = ncount + 1
5940 endif
5941 if (color(i,j) == 0.0 .and. color(i+1,j) > 0.0) then
5942 color(i,j) = color(i+1,j)
5943 ncount = ncount + 1
5944 endif
5945 if (color(i,j) == 0.0 .and. color(i,j-1) > 0.0) then
5946 color(i,j) = color(i,j-1)
5947 ncount = ncount + 1
5948 endif
5949 if (color(i,j) == 0.0 .and. color(i,j+1) > 0.0) then
5950 color(i,j) = color(i,j+1)
5951 ncount = ncount + 1
5952 endif
5953 enddo
5954 enddo
5955 call pass_var(color, g%Domain)
5956 call sum_across_pes(ncount)
5957 enddo
5958
5959end subroutine flood_fill2
5960
5961!> Register OBC segment data for restarts
5962subroutine open_boundary_register_restarts(HI, GV, US, OBC, Reg, param_file, restart_CS, &
5963 use_temperature)
5964 type(hor_index_type), intent(in) :: hi !< Horizontal indices
5965 type(verticalgrid_type), pointer :: gv !< Container for vertical grid information
5966 type(unit_scale_type), intent(in) :: us !< A dimensional unit scaling type
5967 type(ocean_obc_type), pointer :: obc !< OBC data structure, data intent(inout)
5968 type(tracer_registry_type), pointer :: reg !< pointer to tracer registry
5969 type(param_file_type), intent(in) :: param_file !< Parameter file handle
5970 type(mom_restart_cs), intent(inout) :: restart_cs !< MOM restart control structure
5971 logical, intent(in) :: use_temperature !< If true, T and S are used
5972 ! Local variables
5973 type(vardesc) :: vd(2)
5974 integer :: m
5975 character(len=100) :: mesg, var_name
5976
5977 if (.not. associated(obc)) &
5978 call mom_error(fatal, "open_boundary_register_restarts: Called with "//&
5979 "uninitialized OBC control structure")
5980
5981 ! ### This is a temporary work around for restarts with OBC segments.
5982 ! This implementation uses 3D arrays solely for restarts. We need
5983 ! to be able to add 2D ( x,z or y,z ) data to restarts to avoid using
5984 ! so much memory and disk space.
5985 if (obc%radiation_BCs_exist_globally) then
5986 allocate(obc%rx_normal(hi%isdB:hi%iedB,hi%jsd:hi%jed,gv%ke), source=0.0)
5987 allocate(obc%ry_normal(hi%isd:hi%ied,hi%jsdB:hi%jedB,gv%ke), source=0.0)
5988
5989 vd(1) = var_desc("rx_normal", "gridpoint timestep-1", "Normal Phase Speed for EW radiation OBCs", 'u', 'L')
5990 vd(2) = var_desc("ry_normal", "gridpoint timestep-1", "Normal Phase Speed for NS radiation OBCs", 'v', 'L')
5991 call register_restart_pair(obc%rx_normal, obc%ry_normal, vd(1), vd(2), .false., restart_cs, scalar_pair=.true.)
5992 ! The rx_normal and ry_normal arrays used with radiation OBCs are currently in units of grid
5993 ! points per timestep, but if this were to be corrected to [L T-1 ~> m s-1] or [T-1 ~> s-1] to
5994 ! permit timesteps to change between calls to the OBC code, the following would be needed instead:
5995 ! vd(1) = var_desc("rx_normal", "m s-1", "Normal Phase Speed for EW radiation OBCs", 'u', 'L')
5996 ! vd(2) = var_desc("ry_normal", "m s-1", "Normal Phase Speed for NS radiation OBCs", 'v', 'L')
5997 ! call register_restart_pair(OBC%rx_normal, OBC%ry_normal, vd(1), vd(2), .false., restart_CS, &
5998 ! conversion=US%L_T_to_m_s, scalar_pair=.true.)
5999 endif
6000
6001 if (obc%oblique_BCs_exist_globally) then
6002 allocate(obc%rx_oblique_u(hi%isdB:hi%iedB,hi%jsd:hi%jed,gv%ke), source=0.0)
6003 allocate(obc%ry_oblique_u(hi%isdB:hi%iedB,hi%jsd:hi%jed,gv%ke), source=0.0)
6004 allocate(obc%cff_normal_u(hi%IsdB:hi%IedB,hi%jsd:hi%jed,gv%ke), source=0.0)
6005 allocate(obc%rx_oblique_v(hi%isd:hi%ied,hi%jsdB:hi%jedB,gv%ke), source=0.0)
6006 allocate(obc%ry_oblique_v(hi%isd:hi%ied,hi%jsdB:hi%jedB,gv%ke), source=0.0)
6007 allocate(obc%cff_normal_v(hi%isd:hi%ied,hi%jsdB:hi%jedB,gv%ke), source=0.0)
6008
6009 vd(1) = var_desc("rx_oblique_u", "m2 s-2", "X-Direction Radiation Speed Squared for EW oblique OBCs", 'u', 'L')
6010 vd(2) = var_desc("ry_oblique_v", "m2 s-2", "Y-Direction Radiation Speed Squared for NS oblique OBCs", 'v', 'L')
6011 call register_restart_pair(obc%rx_oblique_u, obc%ry_oblique_v, vd(1), vd(2), .false., &
6012 restart_cs, conversion=us%L_T_to_m_s**2)
6013 vd(1) = var_desc("ry_oblique_u", "m2 s-2", "Y-Direction Radiation Speed Squared for EW oblique OBCs", 'u', 'L')
6014 vd(2) = var_desc("rx_oblique_v", "m2 s-2", "X-Direction Radiation Speed Squared for NS oblique OBCs", 'v', 'L')
6015 call register_restart_pair(obc%ry_oblique_u, obc%rx_oblique_v, vd(1), vd(2), .false., &
6016 restart_cs, conversion=us%L_T_to_m_s**2)
6017
6018 vd(1) = var_desc("norm_oblique_u", "m2 s-2", "Denominator for normalizing EW oblique OBC radiation rates", &
6019 'u', 'L')
6020 vd(2) = var_desc("norm_oblique_v", "m2 s-2", "Denominator for normalizing NS oblique OBC radiation rates", &
6021 'v', 'L')
6022 call register_restart_pair(obc%cff_normal_u, obc%cff_normal_v, vd(1), vd(2), .false., &
6023 restart_cs, conversion=us%L_T_to_m_s**2)
6024 endif
6025
6026 if (obc%thickness_x_reservoirs_used) then
6027 allocate(obc%h_res_x(hi%isdB:hi%iedB,hi%jsd:hi%jed,gv%ke), source=0.0)
6028 if (modulo(hi%turns, 2) /= 0) then
6029 write(var_name,'("h_res_y")')
6030 call register_restart_field(obc%h_res_x(:,:,:), var_name, .false., restart_cs, &
6031 longname="Layer thickness for NS OBCs", units="Conc", hor_grid='v')
6032 else
6033 write(var_name,'("h_res_x")')
6034 call register_restart_field(obc%h_res_x(:,:,:), var_name, .false., restart_cs, &
6035 longname="Layer thickness for EW OBCs", units="Conc", hor_grid='u')
6036 endif
6037 endif
6038 if (obc%thickness_y_reservoirs_used) then
6039 allocate(obc%h_res_y(hi%isd:hi%ied,hi%jsdB:hi%jedB,gv%ke), source=0.0)
6040 if (modulo(hi%turns, 2) /= 0) then
6041 write(var_name,'("h_res_x")')
6042 call register_restart_field(obc%h_res_y(:,:,:), var_name, .false., restart_cs, &
6043 longname="Layer thickness for EW OBCs", units="Conc", hor_grid='u')
6044 else
6045 write(var_name,'("h_res_y")')
6046 call register_restart_field(obc%h_res_y(:,:,:), var_name, .false., restart_cs, &
6047 longname="Layer thickness for NS OBCs", units="Conc", hor_grid='v')
6048 endif
6049 endif
6050
6051 if (reg%ntr == 0) return
6052 if (.not. allocated(obc%tracer_x_reservoirs_used)) then
6053 obc%ntr = reg%ntr
6054 allocate(obc%tracer_x_reservoirs_used(reg%ntr), source=.false.)
6055 allocate(obc%tracer_y_reservoirs_used(reg%ntr), source=.false.)
6056 call parse_for_tracer_reservoirs(obc, param_file, use_temperature)
6057 else
6058 ! This would be coming from user code such as DOME.
6059 if (obc%ntr /= reg%ntr) then
6060! call MOM_error(FATAL, "open_boundary_register_restarts: Inconsistent value for ntr")
6061 write(mesg,'("Inconsistent values for ntr ", I0," and ",I0,".")') obc%ntr, reg%ntr
6062 call mom_error(warning, 'open_boundary_register_restarts: '//mesg)
6063 endif
6064 endif
6065
6066 ! Still painfully inefficient, now in four dimensions.
6067 if (any(obc%tracer_x_reservoirs_used)) then
6068 allocate(obc%tres_x(hi%isdB:hi%iedB,hi%jsd:hi%jed,gv%ke,obc%ntr), source=0.0)
6069 do m=1,obc%ntr
6070 if (obc%tracer_x_reservoirs_used(m)) then
6071 if (modulo(hi%turns, 2) /= 0) then
6072 write(var_name,'("tres_y_",I3.3)') m
6073 call register_restart_field(obc%tres_x(:,:,:,m), var_name, .false., restart_cs, &
6074 longname="Tracer concentration for NS OBCs", units="Conc", hor_grid='v')
6075 else
6076 write(var_name,'("tres_x_",I3.3)') m
6077 call register_restart_field(obc%tres_x(:,:,:,m), var_name, .false., restart_cs, &
6078 longname="Tracer concentration for EW OBCs", units="Conc", hor_grid='u')
6079 endif
6080 endif
6081 enddo
6082 endif
6083 if (any(obc%tracer_y_reservoirs_used)) then
6084 allocate(obc%tres_y(hi%isd:hi%ied,hi%jsdB:hi%jedB,gv%ke,obc%ntr), source=0.0)
6085 do m=1,obc%ntr
6086 if (obc%tracer_y_reservoirs_used(m)) then
6087 if (modulo(hi%turns, 2) /= 0) then
6088 write(var_name,'("tres_x_",I3.3)') m
6089 call register_restart_field(obc%tres_y(:,:,:,m), var_name, .false., restart_cs, &
6090 longname="Tracer concentration for EW OBCs", units="Conc", hor_grid='u')
6091 else
6092 write(var_name,'("tres_y_",I3.3)') m
6093 call register_restart_field(obc%tres_y(:,:,:,m), var_name, .false., restart_cs, &
6094 longname="Tracer concentration for NS OBCs", units="Conc", hor_grid='v')
6095 endif
6096 endif
6097 enddo
6098 endif
6099
6101
6102!> Update OBC tracer reservoirs (segment%tr_Reg%Tr%tres) using a backward-Euler implicit step,
6103!! then copy the result into OBC%tres_x / OBC%tres_y for restart I/O.
6104!!
6105!! The reservoir at each boundary cell is nudged toward the adjacent interior tracer (on outflow)
6106!! or the open-ocean boundary value (on inflow), weighted by the volume flux and the per-tracer
6107!! inverse length scale I_Lscale. Three regimes, set at registration via I_Lscale_in/out:
6108!! - **Frozen** (I_Lscale = 0): tres is unchanged every timestep.
6109!! - **Finite length scale** (I_Lscale > 0): tres relaxes toward the interior or boundary value
6110!! at a rate proportional to the flux and I_Lscale.
6111!! - **Instant update** (I_Lscale = -1): tres is immediately replaced by the interior value
6112!! (outflow) or the boundary value (inflow).
6113subroutine update_segment_tracer_reservoirs(G, GV, uhr, vhr, h, OBC, Reg)
6114 type(ocean_grid_type), intent(in) :: g !< The ocean's grid structure
6115 type(verticalgrid_type), intent(in) :: gv !< Ocean vertical grid structure
6116 real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: uhr !< accumulated volume/mass flux through
6117 !! the zonal face [H L2 ~> m3 or kg]
6118 real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: vhr !< accumulated volume/mass flux through
6119 !! the meridional face [H L2 ~> m3 or kg]
6120 real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< layer thickness after advection
6121 !! [H ~> m or kg m-2]
6122 type(ocean_obc_type), pointer :: obc !< Open boundary structure
6123 type(tracer_registry_type), pointer :: reg !< pointer to tracer registry
6124
6125 ! Local variables
6126 type(obc_segment_type), pointer :: segment => null()
6127 integer :: dir ! Sign convention so that positive flux_to_res means flow toward the
6128 ! reservoir: -1 for W/S segments, +1 for E/N segments.
6129 real :: face_area ! Interior cell face area adjacent to the OBC boundary [H L ~> m2 or kg m-1].
6130 real :: flux_to_res ! Signed volume/mass flux directed toward the reservoir (positive = interior
6131 ! to reservoir), equals dir * uhr or dir * vhr [H L2 ~> m3 or kg].
6132 real :: resrv_lfac_out ! Per-tracer multiplier on segment%Tr_InvLscale_out for the outward
6133 ! direction [nondim].
6134 real :: resrv_lfac_in ! Per-tracer multiplier on segment%Tr_InvLscale_in for the inward
6135 ! direction [nondim].
6136 real :: l_out, l_in ! Nondimensional exchange weight = flux * InvLscale * resrv_lfac / face_area
6137 ! for the outflow (L_out >= 0) and inflow (L_in <= 0) directions [nondim].
6138 ! Active only in finite/infinite length-scale mode (mask_L = 1).
6139 real :: a_out, a_in ! In instant-update (zero length scale) mode: +1 on outflow (a_out) or
6140 ! -1 on inflow (a_in), selecting which boundary value is applied instantly
6141 ! to the reservoir. Both are 0 in finite/infinite length-scale mode, and
6142 ! a_out and a_in cannot be simultaneously non-zero [nondim].
6143 real :: mask_l_out, mask_l_in ! 1 in finite/infinite length-scale mode (activates L term);
6144 ! 0 in instant-update mode [nondim]. mask_L = 1 - mask_a.
6145 real :: mask_a_out, mask_a_in ! 1 in instant-update (zero length scale) mode (activates a term);
6146 ! 0 in finite/infinite length-scale mode [nondim].
6147 real :: fac1 ! Implicit-update denominator = 1 + L_out - L_in [nondim].
6148 real :: i_scale ! The inverse of the scaling factor for the tracers.
6149 ! For salinity the units would be [ppt S-1 ~> 1]
6150 integer :: i, j, k, m, n, nz, ntr_id
6151 integer :: is, ie, js, je, ii, ji
6152
6153 if (.not. associated(obc)) return
6154 if (.not. obc%OBC_pe) return
6155
6156 nz = gv%ke
6157
6158 do n=1,obc%number_of_segments
6159 segment => obc%segment(n)
6160 if (.not.(segment%on_pe .and. associated(segment%tr_Reg))) cycle
6161 ! dir switches the sign of the flow so that positive is into the reservoir
6162 if ((segment%direction == obc_direction_w) .or. (segment%direction == obc_direction_s)) then
6163 dir = -1
6164 else
6165 dir = 1
6166 endif
6167 if (segment%is_E_or_W) then
6168 i = segment%HI%IsdB ; ii = segment%HI%isd
6169 js = segment%HI%jsd ; je = segment%HI%jed
6170 do m=1,segment%tr_Reg%ntseg
6171 ntr_id = segment%tr_Reg%Tr(m)%ntr_index
6172 resrv_lfac_out = segment%tr_Reg%Tr(m)%resrv_lfac_out
6173 resrv_lfac_in = segment%tr_Reg%Tr(m)%resrv_lfac_in
6174 mask_a_in = max(0.0, -segment%tr_Reg%Tr(m)%I_Lscale_in) ; mask_l_in = 1.0 - mask_a_in
6175 mask_a_out = max(0.0, -segment%tr_Reg%Tr(m)%I_Lscale_out) ; mask_l_out = 1.0 - mask_a_out
6176 i_scale = 1.0 ; if (segment%tr_Reg%Tr(m)%scale /= 0.0) i_scale = 1.0 / segment%tr_Reg%Tr(m)%scale
6177 do k=1,nz ; do j=js,je
6178 ! Calculate weights. Both a and L are nondim. Adding them together has no meaning.
6179 ! However, since they cannot be both non-zero, adding them works like a switch.
6180 ! When InvLscale_out is 0 and outflow, only interior data is applied to reservoirs
6181 ! When InvLscale_in is 0 and inflow, only nudged data is applied to reservoirs
6182 flux_to_res = dir * uhr(i,j,k)
6183 ! I_face_area would be more efficient but it changes answers.
6184 face_area = (h(ii,j,k) + gv%H_subroundoff) * g%dyCu(i,j)
6185 a_out = mask_a_out * max(0.0, sign(1.0, flux_to_res))
6186 a_in = mask_a_in * min(0.0, sign(1.0, flux_to_res))
6187 ! Below, segment%Tr_InvLscale_out * resrv_lfac_out can be replaced by segment%I_Lscale_out,
6188 ! but it changes answers.
6189 l_out = mask_l_out * g%mask2dT(ii,j) * max(0.0, &
6190 flux_to_res * segment%Tr_InvLscale_out * resrv_lfac_out / face_area)
6191 l_in = mask_l_in * g%mask2dT(ii,j) * min(0.0, &
6192 flux_to_res * segment%Tr_InvLscale_in * resrv_lfac_in / face_area)
6193 fac1 = 1.0 + (l_out - l_in)
6194 segment%tr_Reg%Tr(m)%tres(i,j,k) = (1.0 / fac1) * &
6195 ((1.0 - a_out + a_in) * segment%tr_Reg%Tr(m)%tres(i,j,k) + &
6196 ((l_out + a_out) * reg%Tr(ntr_id)%t(ii,j,k) - &
6197 (l_in + a_in ) * segment%tr_Reg%Tr(m)%t(i,j,k)))
6198 enddo ; enddo
6199 if (allocated(obc%tres_x)) then ; do k=1,nz ; do j=js,je
6200 obc%tres_x(i,j,k,m) = i_scale * segment%tr_Reg%Tr(m)%tres(i,j,k)
6201 enddo ; enddo ; endif
6202 enddo
6203 elseif (segment%is_N_or_S) then
6204 j = segment%HI%JsdB ; ji = segment%HI%jsd
6205 is = segment%HI%isd ; ie = segment%HI%ied
6206 do m=1,segment%tr_Reg%ntseg
6207 ntr_id = segment%tr_Reg%Tr(m)%ntr_index
6208 resrv_lfac_out = segment%tr_Reg%Tr(m)%resrv_lfac_out
6209 resrv_lfac_in = segment%tr_Reg%Tr(m)%resrv_lfac_in
6210 mask_a_in = max(0.0, -segment%tr_Reg%Tr(m)%I_Lscale_in) ; mask_l_in = 1.0 - mask_a_in
6211 mask_a_out = max(0.0, -segment%tr_Reg%Tr(m)%I_Lscale_out) ; mask_l_out = 1.0 - mask_a_out
6212 i_scale = 1.0 ; if (segment%tr_Reg%Tr(m)%scale /= 0.0) i_scale = 1.0 / segment%tr_Reg%Tr(m)%scale
6213 do k=1,nz ; do i=is,ie
6214 flux_to_res = dir * vhr(i,j,k)
6215 face_area = (h(i,ji,k) + gv%H_subroundoff) * g%dxCv(i,j)
6216 a_out = mask_a_out * max(0.0, sign(1.0, flux_to_res))
6217 a_in = mask_a_in * min(0.0, sign(1.0, flux_to_res))
6218 l_out = mask_l_out * g%mask2dT(i,ji) * max(0.0, &
6219 flux_to_res * segment%Tr_InvLscale_out * resrv_lfac_out / face_area)
6220 l_in = mask_l_in * g%mask2dT(i,ji) * min(0.0, &
6221 flux_to_res * segment%Tr_InvLscale_in * resrv_lfac_in / face_area)
6222 fac1 = 1.0 + (l_out - l_in)
6223 segment%tr_Reg%Tr(m)%tres(i,j,k) = (1.0 / fac1) * &
6224 ((1.0 - a_out + a_in) * segment%tr_Reg%Tr(m)%tres(i,j,k) + &
6225 ((l_out + a_out) * reg%Tr(ntr_id)%t(i,ji,k) - &
6226 (l_in + a_in ) * segment%tr_Reg%Tr(m)%t(i,j,k)))
6227 enddo ; enddo
6228 if (allocated(obc%tres_y)) then ; do k=1,nz ; do i=is,ie
6229 obc%tres_y(i,j,k,m) = i_scale * segment%tr_Reg%Tr(m)%tres(i,j,k)
6230 enddo ; enddo ; endif
6231 enddo
6232 endif
6233 enddo
6235
6236!> Update the OBC thickness reservoirs after the thicknesses have been updated.
6237subroutine update_segment_thickness_reservoirs(G, GV, uhr, vhr, h, OBC)
6238 type(ocean_grid_type), intent(in) :: g !< The ocean's grid structure
6239 type(verticalgrid_type), intent(in) :: gv !< Ocean vertical grid structure
6240 real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: uhr !< accumulated volume/mass flux through
6241 !! the zonal face [H L2 ~> m3 or kg]
6242 real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: vhr !< accumulated volume/mass flux through
6243 !! the meridional face [H L2 ~> m3 or kg]
6244 real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< layer thickness after advection
6245 !! [H ~> m or kg m-2]
6246 type(ocean_obc_type), pointer :: obc !< Open boundary structure
6247
6248 ! Local variable
6249 type(obc_segment_type), pointer :: segment=>null()
6250 real :: u_l_in, u_l_out ! The zonal distance moved in or out of a cell, normalized by the reservoir
6251 ! length scale [nondim]
6252 real :: v_l_in, v_l_out ! The meridional distance moved in or out of a cell, normalized by the reservoir
6253 ! length scale [nondim]
6254 real :: fac1 ! The denominator of the expression for tracer updates [nondim]
6255 real :: i_scale ! The inverse of the scaling factor for the tracers.
6256 ! For salinity the units would be [ppt S-1 ~> 1]
6257 integer :: i, j, k, n, nz, fd_id
6258 integer :: ishift, idir, jshift, jdir
6259 real :: resrv_lfac_out ! The reservoir inverse length scale scaling factor for the outward
6260 ! direction per field [nondim]
6261 real :: resrv_lfac_in ! The reservoir inverse length scale scaling factor for the inward
6262 ! direction per field [nondim]
6263 real :: b_in, b_out ! The 0 and 1 switch for tracer reservoirs
6264 ! 1 if the length scale of reservoir is zero [nondim]
6265 real :: a_in, a_out ! The 0 and 1(-1) switch for reservoir source weights
6266 ! e.g. a_in is -1 only if b_in ==1 and uhr or vhr is inward
6267 ! e.g. a_out is 1 only if b_out==1 and uhr or vhr is outward
6268 ! It's clear that a_in and a_out cannot be both non-zero [nondim]
6269 nz = gv%ke
6270
6271 if (associated(obc)) then ; if (obc%OBC_pe) then ; do n=1,obc%number_of_segments
6272 segment=>obc%segment(n)
6273 if (.not. associated(segment%h_Reg)) cycle
6274 b_in = 0.0 ; if (segment%Tr_InvLscale_in < 0.0) b_in = 1.0
6275 b_out = 0.0 ; if (segment%Tr_InvLscale_out < 0.0) b_out = 1.0
6276 if (segment%is_E_or_W) then
6277 i = segment%HI%IsdB
6278 do j=segment%HI%jsd,segment%HI%jed
6279 ! ishift+I corresponds to the nearest interior tracer cell index
6280 ! idir switches the sign of the flow so that positive is into the reservoir
6281 if (segment%direction == obc_direction_w) then
6282 ishift = 1 ; idir = -1
6283 else
6284 ishift = 0 ; idir = 1
6285 endif
6286 ! Can keep this or take it out, either way
6287 if (g%mask2dT(i+ishift,j) == 0.0) cycle
6288 ! Update the reservoir thickness concentration implicitly using a Backward-Euler timestep
6289 fd_id = segment%h_Reg%fd_index
6290 if (fd_id == -1) then
6291 resrv_lfac_out = 1.0
6292 resrv_lfac_in = 1.0
6293 else
6294 resrv_lfac_out = segment%field(fd_id)%resrv_lfac_out
6295 resrv_lfac_in = segment%field(fd_id)%resrv_lfac_in
6296 endif
6297 i_scale = 1.0 ; if (segment%h_Reg%scale /= 0.0) i_scale = 1.0 / segment%h_Reg%scale
6298 if (allocated(segment%h_Reg%h_res)) then ; do k=1,nz
6299 ! Calculate weights. Both a and u_L are nondim. Adding them together has no meaning.
6300 ! However, since they cannot be both non-zero, adding them works like a switch.
6301 ! When InvLscale_out is 0 and outflow, only interior data is applied to reservoirs
6302 ! When InvLscale_in is 0 and inflow, only nudged data is applied to reservoirs
6303 a_out = b_out * max(0.0, sign(1.0, idir*uhr(i,j,k)))
6304 a_in = b_in * min(0.0, sign(1.0, idir*uhr(i,j,k)))
6305 u_l_out = max(0.0, (idir*uhr(i,j,k))*segment%Th_InvLscale_out*resrv_lfac_out / &
6306 ((h(i+ishift,j,k) + gv%H_subroundoff)*g%dyCu(i,j)))
6307 u_l_in = min(0.0, (idir*uhr(i,j,k))*segment%Th_InvLscale_in*resrv_lfac_in / &
6308 ((h(i+ishift,j,k) + gv%H_subroundoff)*g%dyCu(i,j)))
6309 fac1 = (1.0 - (a_out - a_in)) + ((u_l_out + a_out) - (u_l_in + a_in))
6310 segment%h_Reg%h_res(i,j,k) = (1.0/fac1) * &
6311 ((1.0-a_out+a_in)*segment%h_Reg%h_res(i,j,k)+ &
6312 ((u_l_out+a_out)*h(i+ishift,j,k) - &
6313 (u_l_in+a_in)*segment%h_Reg%h(i,j,k)))
6314 if (allocated(obc%h_res_x)) obc%h_res_x(i,j,k) = i_scale * segment%h_Reg%h_res(i,j,k)
6315 enddo ; endif
6316 enddo
6317 elseif (segment%is_N_or_S) then
6318 j = segment%HI%JsdB
6319 do i=segment%HI%isd,segment%HI%ied
6320 ! jshift+J corresponds to the nearest interior tracer cell index
6321 ! jdir switches the sign of the flow so that positive is into the reservoir
6322 if (segment%direction == obc_direction_s) then
6323 jshift = 1 ; jdir = -1
6324 else
6325 jshift = 0 ; jdir = 1
6326 endif
6327 ! Can keep this or take it out, either way
6328 if (g%mask2dT(i,j+jshift) == 0.0) cycle
6329 ! Update the reservoir tracer concentration implicitly using a Backward-Euler timestep
6330 fd_id = segment%h_Reg%fd_index
6331 if (fd_id == -1) then
6332 resrv_lfac_out = 1.0
6333 resrv_lfac_in = 1.0
6334 else
6335 resrv_lfac_out = segment%field(fd_id)%resrv_lfac_out
6336 resrv_lfac_in = segment%field(fd_id)%resrv_lfac_in
6337 endif
6338 i_scale = 1.0 ; if (segment%h_Reg%scale /= 0.0) i_scale = 1.0 / segment%h_Reg%scale
6339 if (allocated(segment%h_Reg%h_res)) then ; do k=1,nz
6340 a_out = b_out * max(0.0, sign(1.0, jdir*vhr(i,j,k)))
6341 a_in = b_in * min(0.0, sign(1.0, jdir*vhr(i,j,k)))
6342 v_l_out = max(0.0, (jdir*vhr(i,j,k))*segment%Th_InvLscale_out*resrv_lfac_out / &
6343 ((h(i,j+jshift,k) + gv%H_subroundoff)*g%dxCv(i,j)))
6344 v_l_in = min(0.0, (jdir*vhr(i,j,k))*segment%Th_InvLscale_in*resrv_lfac_in / &
6345 ((h(i,j+jshift,k) + gv%H_subroundoff)*g%dxCv(i,j)))
6346 fac1 = (1.0 - (a_out - a_in)) + ((v_l_out + a_out) - (v_l_in + a_in))
6347 segment%h_Reg%h_res(i,j,k) = (1.0/fac1) * &
6348 ((1.0-a_out+a_in)*segment%h_Reg%h_res(i,j,k) + &
6349 ((v_l_out+a_out)*h(i,j+jshift,k) - &
6350 (v_l_in+a_in)*segment%h_Reg%h(i,j,k)))
6351 if (allocated(obc%h_res_y)) obc%h_res_y(i,j,k) = i_scale * segment%h_Reg%h_res(i,j,k)
6352 enddo ; endif
6353 enddo
6354 endif
6355 enddo ; endif ; endif
6356
6358
6359!> Vertically remap the OBC tracer reservoirs and radiation rates that are filtered in time.
6360subroutine remap_obc_fields(G, GV, h_old, h_new, OBC, PCM_cell)
6361 type(ocean_grid_type), intent(in) :: g !< The ocean's grid structure
6362 type(verticalgrid_type), intent(in) :: gv !< Ocean vertical grid structure
6363 real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_old !< Thickness of source grid [H ~> m or kg m-2]
6364 real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_new !< Thickness of destination grid [H ~> m or kg m-2]
6365 type(ocean_obc_type), pointer :: obc !< Open boundary structure
6366 logical, dimension(SZI_(G),SZJ_(G),SZK_(GV)), &
6367 optional, intent(in) :: pcm_cell !< Use PCM remapping in cells where true
6368
6369 ! Local variables
6370 type(obc_segment_type), pointer :: segment => null() ! A pointer to the various segments, used just for shorthand.
6371
6372 real :: tr_column(gv%ke) ! A column of updated tracer concentrations in internally scaled units.
6373 ! For salinity the units would be [S ~> ppt].
6374 real :: r_norm_col(gv%ke) ! A column of updated radiation rates, in grid points per timestep [nondim]
6375 real :: rxy_col(gv%ke) ! A column of updated radiation rates for oblique OBCs [L2 T-2 ~> m2 s-2]
6376 real :: h1(gv%ke) ! A column of source grid layer thicknesses [H ~> m or kg m-2]
6377 real :: h2(gv%ke) ! A column of target grid layer thicknesses [H ~> m or kg m-2]
6378 real :: i_scale ! The inverse of the scaling factor for the tracers.
6379 ! For salinity the units would be [ppt S-1 ~> 1].
6380 logical :: pcm(gv%ke) ! If true, do PCM remapping from a cell.
6381 integer :: i, j, k, m, n, ntr, nz
6382
6383 if (.not.associated(obc)) return
6384
6385 nz = gv%ke
6386 ntr = obc%ntr
6387
6388 if (.not.present(pcm_cell)) pcm(:) = .false.
6389
6390 if (associated(obc)) then ; if (obc%OBC_pe) then ; do n=1,obc%number_of_segments
6391 segment => obc%segment(n)
6392 if (.not.(segment%on_pe .and. associated(segment%tr_Reg))) cycle
6393
6394 if (segment%is_E_or_W) then
6395 i = segment%HI%IsdB
6396 do j=segment%HI%jsd,segment%HI%jed
6397
6398 ! Store a column of the start and final grids
6399 if (segment%direction == obc_direction_w) then
6400 if (g%mask2dT(i+1,j) == 0.0) cycle
6401 h1(:) = h_old(i+1,j,:)
6402 h2(:) = h_new(i+1,j,:)
6403 if (present(pcm_cell)) then ; pcm(:) = pcm_cell(i+1,j,:) ; endif
6404 else
6405 if (g%mask2dT(i,j) == 0.0) cycle
6406 h1(:) = h_old(i,j,:)
6407 h2(:) = h_new(i,j,:)
6408 if (present(pcm_cell)) then ; pcm(:) = pcm_cell(i,j,:) ; endif
6409 endif
6410
6411 ! Vertically remap the reservoir tracer concentrations
6412 do m=1,segment%tr_Reg%ntseg
6413 i_scale = 1.0 ; if (segment%tr_Reg%Tr(m)%scale /= 0.0) i_scale = 1.0 / segment%tr_Reg%Tr(m)%scale
6414
6415 if (present(pcm_cell)) then
6416 call remapping_core_h(obc%remap_h_CS, nz, h1, segment%tr_Reg%Tr(m)%tres(i,j,:), nz, h2, tr_column, &
6417 pcm_cell=pcm)
6418 else
6419 call remapping_core_h(obc%remap_h_CS, nz, h1, segment%tr_Reg%Tr(m)%tres(i,j,:), nz, h2, tr_column)
6420 endif
6421
6422 ! Possibly underflow any very tiny tracer concentrations to 0?
6423
6424 ! Update tracer concentrations
6425 segment%tr_Reg%Tr(m)%tres(i,j,:) = tr_column(:)
6426 if (allocated(obc%tres_x)) then ; do k=1,nz
6427 obc%tres_x(i,j,k,m) = i_scale * segment%tr_Reg%Tr(m)%tres(i,j,k)
6428 enddo ; endif
6429
6430 enddo
6431
6432 ! Vertically remap the reservoir thicknesses?
6433 if (associated(segment%h_Reg)) then
6434 if (allocated(segment%h_Reg%h_res)) then
6435 i_scale = 1.0 ; if (segment%h_Reg%scale /= 0.0) i_scale = 1.0 / segment%h_Reg%scale
6436
6437 if (present(pcm_cell)) then
6438 call remapping_core_h(obc%remap_h_CS, nz, h1, segment%h_Reg%h_res(i,j,:), nz, h2, tr_column, &
6439 pcm_cell=pcm)
6440 else
6441 call remapping_core_h(obc%remap_h_CS, nz, h1, segment%h_Reg%h_res(i,j,:), nz, h2, tr_column)
6442 endif
6443
6444 ! Possibly underflow any very tiny tracer concentrations to 0?
6445
6446 ! Update tracer concentrations
6447 segment%h_Reg%h_res(i,j,:) = tr_column(:)
6448 if (allocated(obc%h_res_x)) then ; do k=1,nz
6449 obc%h_res_x(i,j,k) = i_scale * segment%h_Reg%h_res(i,j,k)
6450 enddo ; endif
6451 endif
6452 endif
6453
6454 if (segment%radiation .and. (obc%gamma_uv < 1.0)) then
6455 call remapping_core_h(obc%remap_h_CS, nz, h1, segment%rx_norm_rad(i,j,:), nz, h2, r_norm_col, &
6456 pcm_cell=pcm)
6457
6458 do k=1,nz
6459 segment%rx_norm_rad(i,j,k) = r_norm_col(k)
6460 obc%rx_normal(i,j,k) = segment%rx_norm_rad(i,j,k)
6461 enddo
6462 endif
6463
6464 if (segment%oblique .and. (obc%gamma_uv < 1.0)) then
6465 call remapping_core_h(obc%remap_h_CS, nz, h1, segment%rx_norm_obl(i,j,:), nz, h2, rxy_col, &
6466 pcm_cell=pcm)
6467 segment%rx_norm_obl(i,j,:) = rxy_col(:)
6468 call remapping_core_h(obc%remap_h_CS, nz, h1, segment%ry_norm_obl(i,j,:), nz, h2, rxy_col, &
6469 pcm_cell=pcm)
6470 segment%ry_norm_obl(i,j,:) = rxy_col(:)
6471 call remapping_core_h(obc%remap_h_CS, nz, h1, segment%cff_normal(i,j,:), nz, h2, rxy_col, &
6472 pcm_cell=pcm)
6473 segment%cff_normal(i,j,:) = rxy_col(:)
6474
6475 do k=1,nz
6476 obc%rx_oblique_u(i,j,k) = segment%rx_norm_obl(i,j,k)
6477 obc%ry_oblique_u(i,j,k) = segment%ry_norm_obl(i,j,k)
6478 obc%cff_normal_u(i,j,k) = segment%cff_normal(i,j,k)
6479 enddo
6480 endif
6481
6482 enddo
6483 elseif (segment%is_N_or_S) then
6484 j = segment%HI%JsdB
6485 do i=segment%HI%isd,segment%HI%ied
6486
6487 ! Store a column of the start and final grids
6488 if (segment%direction == obc_direction_s) then
6489 if (g%mask2dT(i,j+1) == 0.0) cycle
6490 h1(:) = h_old(i,j+1,:)
6491 h2(:) = h_new(i,j+1,:)
6492 if (present(pcm_cell)) then ; pcm(:) = pcm_cell(i,j+1,:) ; endif
6493 else
6494 if (g%mask2dT(i,j) == 0.0) cycle
6495 h1(:) = h_old(i,j,:)
6496 h2(:) = h_new(i,j,:)
6497 if (present(pcm_cell)) then ; pcm(:) = pcm_cell(i,j,:) ; endif
6498 endif
6499
6500 ! Vertically remap the reservoir tracer concentrations
6501 do m=1,segment%tr_Reg%ntseg
6502 i_scale = 1.0 ; if (segment%tr_Reg%Tr(m)%scale /= 0.0) i_scale = 1.0 / segment%tr_Reg%Tr(m)%scale
6503
6504 if (present(pcm_cell)) then
6505 call remapping_core_h(obc%remap_h_CS, nz, h1, segment%tr_Reg%Tr(m)%tres(i,j,:), nz, h2, tr_column, &
6506 pcm_cell=pcm)
6507 else
6508 call remapping_core_h(obc%remap_h_CS, nz, h1, segment%tr_Reg%Tr(m)%tres(i,j,:), nz, h2, tr_column)
6509 endif
6510
6511 ! Possibly underflow any very tiny tracer concentrations to 0?
6512
6513 ! Update tracer concentrations
6514 segment%tr_Reg%Tr(m)%tres(i,j,:) = tr_column(:)
6515 if (allocated(obc%tres_y)) then ; do k=1,nz
6516 obc%tres_y(i,j,k,m) = i_scale * segment%tr_Reg%Tr(m)%tres(i,j,k)
6517 enddo ; endif
6518
6519 enddo
6520
6521 ! Vertically remap the reservoir thicknesses?
6522 if (associated(segment%h_Reg)) then
6523 if (allocated(segment%h_Reg%h_res)) then
6524 i_scale = 1.0 ; if (segment%h_Reg%scale /= 0.0) i_scale = 1.0 / segment%h_Reg%scale
6525
6526 if (present(pcm_cell)) then
6527 call remapping_core_h(obc%remap_h_CS, nz, h1, segment%h_Reg%h_res(i,j,:), nz, h2, tr_column, &
6528 pcm_cell=pcm)
6529 else
6530 call remapping_core_h(obc%remap_h_CS, nz, h1, segment%h_Reg%h_res(i,j,:), nz, h2, tr_column)
6531 endif
6532
6533 ! Possibly underflow any very tiny tracer concentrations to 0?
6534
6535 ! Update tracer concentrations
6536 segment%h_Reg%h_res(i,j,:) = tr_column(:)
6537 if (allocated(obc%h_res_y)) then ; do k=1,nz
6538 obc%h_res_y(i,j,k) = i_scale * segment%h_Reg%h_res(i,j,k)
6539 enddo ; endif
6540 endif
6541 endif
6542
6543 if (segment%radiation .and. (obc%gamma_uv < 1.0)) then
6544 call remapping_core_h(obc%remap_h_CS, nz, h1, segment%ry_norm_rad(i,j,:), nz, h2, r_norm_col, &
6545 pcm_cell=pcm)
6546
6547 do k=1,nz
6548 segment%ry_norm_rad(i,j,k) = r_norm_col(k)
6549 obc%ry_normal(i,j,k) = segment%ry_norm_rad(i,j,k)
6550 enddo
6551 endif
6552
6553 if (segment%oblique .and. (obc%gamma_uv < 1.0)) then
6554 call remapping_core_h(obc%remap_h_CS, nz, h1, segment%rx_norm_obl(i,j,:), nz, h2, rxy_col, &
6555 pcm_cell=pcm)
6556 segment%rx_norm_obl(i,j,:) = rxy_col(:)
6557 call remapping_core_h(obc%remap_h_CS, nz, h1, segment%ry_norm_obl(i,j,:), nz, h2, rxy_col, &
6558 pcm_cell=pcm)
6559 segment%ry_norm_obl(i,j,:) = rxy_col(:)
6560 call remapping_core_h(obc%remap_h_CS, nz, h1, segment%cff_normal(i,j,:), nz, h2, rxy_col, &
6561 pcm_cell=pcm)
6562 segment%cff_normal(i,j,:) = rxy_col(:)
6563
6564 do k=1,nz
6565 obc%rx_oblique_v(i,j,k) = segment%rx_norm_obl(i,j,k)
6566 obc%ry_oblique_v(i,j,k) = segment%ry_norm_obl(i,j,k)
6567 obc%cff_normal_v(i,j,k) = segment%cff_normal(i,j,k)
6568 enddo
6569 endif
6570
6571 enddo
6572 endif
6573 enddo ; endif ; endif
6574 if (obc%radiation_BCs_exist_globally) call pass_vector(obc%rx_normal, obc%ry_normal, g%Domain, &
6575 to_all+scalar_pair)
6576 if (obc%oblique_BCs_exist_globally) then
6577 call do_group_pass(obc%pass_oblique, g%Domain)
6578 endif
6579
6580end subroutine remap_obc_fields
6581
6582
6583!> Adjust interface heights to fit the bathymetry and diagnose layer thickness.
6584!!
6585!! If the bottom most interface is below the topography then the bottom-most
6586!! layers are contracted to GV%Angstrom_Z.
6587!! If the bottom most interface is above the topography then the entire column
6588!! is dilated (expanded) to fill the void.
6589!! @remark{There is a (hard-wired) "tolerance" parameter such that the
6590!! criteria for adjustment must equal or exceed 10cm.}
6591subroutine adjustsegmentetatofitbathymetry(G, GV, US, segment, fld, at_node)
6592 type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure
6593 type(verticalgrid_type), intent(in) :: GV !< The ocean's vertical grid structure
6594 type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
6595 type(obc_segment_type), intent(inout) :: segment !< OBC segment
6596 integer, intent(in) :: fld !< field index to adjust thickness
6597 logical, intent(in) :: at_node !< True this point is at the OBC nodes rather than the faces
6598
6599 integer :: i, j, k, is, ie, js, je, nz, contractions, dilations
6600 real, allocatable, dimension(:,:,:) :: eta ! Segment source data interface heights [Z ~> m]
6601 real, allocatable, dimension(:,:) :: dz_tot ! Segment total thicknesses [Z ~> m]
6602 real :: hTolerance = 0.1 !< Tolerance to exceed adjustment criteria [Z ~> m]
6603 ! real :: dilate ! A factor by which to dilate the water column [nondim]
6604 !character(len=100) :: mesg
6605
6606 htolerance = 0.1*us%m_to_Z
6607
6608 nz = size(segment%field(fld)%dz_src,3)
6609
6610 if (segment%is_E_or_W) then
6611 is = segment%HI%IsdB ; ie = segment%HI%IedB
6612 if (at_node) then ! This point is at the OBC nodes, rather than the cell face centers.
6613 js = max(segment%Js_obc, g%jsd)
6614 je = min(segment%Je_obc, g%jed-1)
6615 else ! Segment thicknesses are defined at cell face centers.
6616 js = segment%HI%jsd ; je = segment%HI%jed
6617 endif
6618 else ! segment%is_N_or_S
6619 js = segment%HI%jsdB ; je = segment%HI%jedB
6620 if (at_node) then ! This point is at the OBC nodes, rather than the cell face centers.
6621 is = max(segment%HI%IsdB, g%isd)
6622 ie = min(segment%HI%IedB, g%ied-1)
6623 else ! Segment thicknesses are defined at cell face centers.
6624 is = segment%HI%isd ; ie = segment%HI%ied
6625 endif
6626 endif
6627 allocate(eta(is:ie,js:je,nz+1))
6628 allocate(dz_tot(is:ie,js:je), source=0.0)
6629
6630 if (at_node) then
6631 if (segment%is_E_or_W) then
6632 i = is
6633 do j=js,je
6634 dz_tot(i,j) = 0.5*(segment%dZtot(i,j) + segment%dZtot(i,j+1))
6635 enddo
6636 ! Do not extrapolate past the end of a global segment.
6637 ! ### For a concave corner between segments, perhaps we should do something more sophisticated.
6638 if (js == segment%Js_obc) dz_tot(i,js) = segment%dZtot(i,js+1)
6639 if (je == segment%Js_obc) dz_tot(i,je) = segment%dZtot(i,je)
6640 else
6641 j = js
6642 do i=is,ie
6643 dz_tot(i,j) = 0.5*(segment%dZtot(i,j) + segment%dZtot(i+1,j))
6644 enddo
6645 ! Do not extrapolate past the end of a global segment.
6646 if (is == segment%Is_obc) dz_tot(is,j) = segment%dZtot(is+1,j)
6647 if (ie == segment%Is_obc) dz_tot(ie,j) = segment%dZtot(ie,j)
6648 endif
6649 else
6650 do j=js,je ; do i=is,ie
6651 dz_tot(i,j) = segment%dZtot(i,j)
6652 enddo ; enddo
6653 endif
6654
6655 contractions = 0 ; dilations = 0
6656 do j=js,je ; do i=is,ie
6657 eta(i,j,1) = 0.0 ! segment data are assumed to be located on a static grid
6658 ! For remapping calls, the entire column will be dilated
6659 ! by a factor equal to the ratio of the sum of the geopotential referenced
6660 ! source data thicknesses, and the current model thicknesses. This could be
6661 ! an issue to be addressed, for instance if we are placing open boundaries
6662 ! under ice shelf cavities.
6663 do k=2,nz+1
6664 eta(i,j,k) = eta(i,j,k-1) - segment%field(fld)%dz_src(i,j,k-1)
6665 enddo
6666 ! The normal slope at the boundary is zero by a
6667 ! previous call to open_boundary_impose_normal_slope
6668 do k=nz+1,1,-1
6669 if (-eta(i,j,k) > dz_tot(i,j) + htolerance) then
6670 eta(i,j,k) = -dz_tot(i,j)
6671 contractions = contractions + 1
6672 endif
6673 enddo
6674
6675 do k=1,nz
6676 ! Collapse layers to thinnest possible if the thickness less than
6677 ! the thinnest possible (or negative).
6678 if (eta(i,j,k) < (eta(i,j,k+1) + gv%Angstrom_Z)) then
6679 eta(i,j,k) = eta(i,j,k+1) + gv%Angstrom_Z
6680 segment%field(fld)%dz_src(i,j,k) = gv%Angstrom_Z
6681 else
6682 segment%field(fld)%dz_src(i,j,k) = (eta(i,j,k) - eta(i,j,k+1))
6683 endif
6684 enddo
6685
6686 ! The whole column is dilated to accommodate deeper topography than
6687 ! the bathymetry would indicate.
6688 if (-eta(i,j,nz+1) < dz_tot(i,j) - htolerance) then
6689 dilations = dilations + 1
6690 ! expand bottom-most cell only
6691 eta(i,j,nz+1) = -dz_tot(i,j)
6692 segment%field(fld)%dz_src(i,j,nz) = eta(i,j,nz) - eta(i,j,nz+1)
6693 ! if (eta(i,j,1) <= eta(i,j,nz+1)) then
6694 ! do k=1,nz ; segment%field(fld)%dz_src(i,j,k) = (eta(i,j,1) + G%bathyT(i,j)) / real(nz) ; enddo
6695 ! else
6696 ! dilate = (eta(i,j,1) + G%bathyT(i,j)) / (eta(i,j,1) - eta(i,j,nz+1))
6697 ! do k=1,nz ; segment%field(fld)%dz_src(i,j,k) = segment%field(fld)%dz_src(i,j,k) * dilate ; enddo
6698 ! endif
6699 !do k=nz,2,-1 ; eta(i,j,K) = eta(i,j,K+1) + segment%field(fld)%dz_src(i,j,k) ; enddo
6700 endif
6701 enddo ; enddo
6702
6703 ! can not do communication call here since only PEs on the current segment are here
6704 ! call sum_across_PEs(contractions)
6705 ! if ((contractions > 0) .and. (is_root_pe())) then
6706 ! write(mesg,'("Thickness OBCs were contracted ",'// &
6707 ! '"to fit topography in ",I0," places.")') contractions
6708 ! call MOM_error(WARNING, 'adjustEtaToFitBathymetry: '//mesg)
6709 ! endif
6710 ! call sum_across_PEs(dilations)
6711 ! if ((dilations > 0) .and. (is_root_pe())) then
6712 ! write(mesg,'("Thickness OBCs were dilated ",'// &
6713 ! '"to fit topography in ",I0," places.")') dilations
6714 ! call MOM_error(WARNING, 'adjustEtaToFitBathymetry: '//mesg)
6715 ! endif
6716
6717 deallocate(eta, dz_tot)
6718
6720
6721!> This is more of a rotate initialization than an actual rotate
6722subroutine rotate_obc_config(OBC_in, G_in, OBC, G, turns)
6723 type(ocean_obc_type), pointer, intent(in) :: obc_in !< Input OBC
6724 type(dyn_horgrid_type), intent(in) :: g_in !< Input grid
6725 type(ocean_obc_type), pointer, intent(inout) :: obc !< Rotated OBC
6726 type(dyn_horgrid_type), intent(in) :: g !< Rotated grid
6727 integer, intent(in) :: turns !< Number of quarter turns
6728
6729 integer :: c, n, l_seg
6730
6731 if (obc_in%number_of_segments == 0) return
6732
6733 ! Scalar and logical transfer
6734 obc%number_of_segments = obc_in%number_of_segments
6735 obc%ke = obc_in%ke
6736 obc%user_BCs_set_globally = obc_in%user_BCs_set_globally
6737
6738 ! These are conditionally read and set if number_of_segments > 0
6739 obc%vorticity_config = obc_in%vorticity_config
6740 obc%strain_config = obc_in%strain_config
6741 obc%zero_biharmonic = obc_in%zero_biharmonic
6742 obc%silly_h = obc_in%silly_h
6743 obc%silly_u = obc_in%silly_u
6744 obc%reverse_segment_order = obc_in%reverse_segment_order
6745
6746 ! Segment rotation
6747 allocate(obc%segment(0:obc%number_of_segments))
6748 do l_seg=1,obc%number_of_segments
6749 call rotate_obc_segment_config(obc_in%segment(l_seg), g_in, obc%segment(l_seg), g, turns)
6750 ! Data stored in setup_[uv]_point_obc is needed for allocate_obc_segment_data
6751 call allocate_obc_segment_data(obc, obc%segment(l_seg))
6752 enddo
6753
6754 ! The horizontal segment map
6755 allocate(obc%segnum_u(g%IsdB:g%IedB,g%jsd:g%jed), source=0)
6756 allocate(obc%segnum_v(g%isd:g%ied,g%JsdB:g%JedB), source=0)
6757 call rotate_array_pair(obc_in%segnum_u, obc_in%segnum_v, turns, obc%segnum_u, obc%segnum_v)
6758 call set_segnum_signs(obc, g)
6759
6760 ! These are conditionally enabled during segment configuration
6761 if (modulo(turns,2) == 0) then
6762 obc%open_u_BCs_exist_globally = obc_in%open_u_BCs_exist_globally
6763 obc%open_v_BCs_exist_globally = obc_in%open_v_BCs_exist_globally
6764 obc%Flather_u_BCs_exist_globally = obc_in%Flather_u_BCs_exist_globally
6765 obc%Flather_v_BCs_exist_globally = obc_in%Flather_v_BCs_exist_globally
6766 obc%nudged_u_BCs_exist_globally = obc_in%nudged_u_BCs_exist_globally
6767 obc%nudged_v_BCs_exist_globally = obc_in%nudged_v_BCs_exist_globally
6768 obc%specified_u_BCs_exist_globally = obc_in%specified_u_BCs_exist_globally
6769 obc%specified_v_BCs_exist_globally = obc_in%specified_v_BCs_exist_globally
6770 else ! Swap information for u- and v- OBCs
6771 obc%open_u_BCs_exist_globally = obc_in%open_v_BCs_exist_globally
6772 obc%open_v_BCs_exist_globally = obc_in%open_u_BCs_exist_globally
6773 obc%Flather_u_BCs_exist_globally = obc_in%Flather_v_BCs_exist_globally
6774 obc%Flather_v_BCs_exist_globally = obc_in%Flather_u_BCs_exist_globally
6775 obc%nudged_u_BCs_exist_globally = obc_in%nudged_v_BCs_exist_globally
6776 obc%nudged_v_BCs_exist_globally = obc_in%nudged_u_BCs_exist_globally
6777 obc%specified_u_BCs_exist_globally = obc_in%specified_v_BCs_exist_globally
6778 obc%specified_v_BCs_exist_globally = obc_in%specified_u_BCs_exist_globally
6779 endif
6780 obc%oblique_BCs_exist_globally = obc_in%oblique_BCs_exist_globally
6781 obc%radiation_BCs_exist_globally = obc_in%radiation_BCs_exist_globally
6782
6783 ! These are set by initialize_segment_data
6784 obc%brushcutter_mode = obc_in%brushcutter_mode
6785 obc%update_OBC = obc_in%update_OBC
6786 obc%any_needs_IO_for_data = obc_in%any_needs_IO_for_data
6787
6788 obc%update_OBC_seg_data = obc_in%update_OBC_seg_data
6789 obc%ntr = obc_in%ntr
6790 if (obc%ntr > 0) then
6791 allocate(obc%tracer_x_reservoirs_used(obc%ntr), source=.false.)
6792 allocate(obc%tracer_y_reservoirs_used(obc%ntr), source=.false.)
6793 if (modulo(turns,2) == 0) then
6794 do n=1,obc%ntr
6795 obc%tracer_x_reservoirs_used(n) = obc_in%tracer_x_reservoirs_used(n)
6796 obc%tracer_y_reservoirs_used(n) = obc_in%tracer_y_reservoirs_used(n)
6797 enddo
6798 else ! Swap information for u- and v- OBCs
6799 do n=1,obc%ntr
6800 obc%tracer_x_reservoirs_used(n) = obc_in%tracer_y_reservoirs_used(n)
6801 obc%tracer_y_reservoirs_used(n) = obc_in%tracer_x_reservoirs_used(n)
6802 enddo
6803 endif
6804 endif
6805
6806 obc%gamma_uv = obc_in%gamma_uv
6807 obc%rx_max = obc_in%rx_max
6808 obc%OBC_pe = obc_in%OBC_pe
6809
6810 ! These are run-time parameters that are read in via open_boundary_config
6811 obc%debug = obc_in%debug
6812 obc%ramp = obc_in%ramp
6813 obc%ramping_is_activated = obc_in%ramping_is_activated
6814 obc%ramp_timescale = obc_in%ramp_timescale
6815 obc%trunc_ramp_time = obc_in%trunc_ramp_time
6816 obc%ramp_value = obc_in%ramp_value
6817 obc%ramp_start_time = obc_in%ramp_start_time
6818 obc%remap_answer_date = obc_in%remap_answer_date
6819 obc%check_reconstruction = obc_in%check_reconstruction
6820 obc%check_remapping = obc_in%check_remapping
6821 obc%force_bounds_in_subcell = obc_in%force_bounds_in_subcell
6822 obc%om4_remap_via_sub_cells = obc_in%om4_remap_via_sub_cells
6823 obc%remappingScheme = obc_in%remappingScheme
6824 obc%exterior_OBC_bug = obc_in%exterior_OBC_bug
6825 obc%hor_index_bug = obc_in%hor_index_bug
6826 obc%ignore_dt_obc_bgc = obc_in%ignore_dt_obc_bgc
6827 obc%n_tide_constituents = obc_in%n_tide_constituents
6828 obc%add_tide_constituents = obc_in%add_tide_constituents
6829
6830 ! These are read in via initialize_obc_tides when n_tide_constituents > 0
6831 if (obc%add_tide_constituents .and. (obc%n_tide_constituents>0)) then
6832 obc%add_eq_phase = obc_in%add_eq_phase
6833 obc%add_nodal_terms = obc_in%add_nodal_terms
6834 obc%time_ref = obc_in%time_ref
6835
6836 allocate(obc%tide_names(obc%n_tide_constituents))
6837 allocate(obc%tide_frequencies(obc%n_tide_constituents))
6838 allocate(obc%tide_eq_phases(obc%n_tide_constituents))
6839 allocate(obc%tide_fn(obc%n_tide_constituents))
6840 allocate(obc%tide_un(obc%n_tide_constituents))
6841 do c=1,obc%n_tide_constituents
6842 obc%tide_names(c) = obc_in%tide_names(c)
6843 obc%tide_frequencies(c) = obc_in%tide_frequencies(c)
6844 obc%tide_eq_phases(c) = obc_in%tide_eq_phases(c)
6845 obc%tide_fn(c) = obc_in%tide_fn(c)
6846 obc%tide_un(c) = obc_in%tide_un(c)
6847 enddo
6848
6849 if (obc%add_eq_phase .or. obc%add_nodal_terms) &
6850 obc%tidal_longitudes = obc_in%tidal_longitudes
6851 endif
6852
6853end subroutine rotate_obc_config
6854
6855!> Rotate the OBC segment configuration data from the input to model index map.
6856subroutine rotate_obc_segment_config(segment_in, G_in, segment, G, turns)
6857 type(obc_segment_type), intent(in) :: segment_in !< Input OBC segment
6858 type(dyn_horgrid_type), intent(in) :: G_in !< Input grid metric
6859 type(obc_segment_type), intent(inout) :: segment !< Rotated OBC segment
6860 type(dyn_horgrid_type), intent(in) :: G !< Rotated grid metric
6861 integer, intent(in) :: turns !< Number of quarter turns
6862
6863 ! Global segment indices
6864 integer :: Is_obc_in, Ie_obc_in, Js_obc_in, Je_obc_in ! Input domain global indices
6865 integer :: Is_obc, Ie_obc, Js_obc, Je_obc ! Rotated domain global indices
6866 integer :: qturns ! The number of quarter turns in the range of 0 to 3
6867
6868 ! NOTE: A "rotation" of the OBC segment string would allow us to use
6869 ! setup_[uv]_point_obc to set up most of this. For now, we just copy/swap
6870 ! flags and manually rotate the indices.
6871
6872 ! This is set if the segment is in the local grid
6873 segment%on_pe = segment_in%on_pe
6874
6875 qturns = modulo(turns, 4)
6876
6877 ! Transfer configuration flags
6878 segment%Flather = segment_in%Flather
6879 segment%radiation = segment_in%radiation
6880 segment%radiation_tan = segment_in%radiation_tan
6881 segment%radiation_grad = segment_in%radiation_grad
6882 segment%oblique = segment_in%oblique
6883 segment%oblique_tan = segment_in%oblique_tan
6884 segment%oblique_grad = segment_in%oblique_grad
6885 segment%nudged = segment_in%nudged
6886 segment%nudged_tan = segment_in%nudged_tan
6887 segment%nudged_grad = segment_in%nudged_grad
6888 segment%specified = segment_in%specified
6889 segment%specified_tan = segment_in%specified_tan
6890 segment%specified_grad = segment_in%specified_grad
6891 segment%open = segment_in%open
6892 segment%gradient = segment_in%gradient
6893
6894 ! These are conditionally set if nudged
6895 segment%Velocity_nudging_timescale_in = segment_in%Velocity_nudging_timescale_in
6896 segment%Velocity_nudging_timescale_out = segment_in%Velocity_nudging_timescale_out
6897
6898 ! Rotate segment indices
6899
6900 ! Reverse engineer the input [IJ][se]_obc segment indices
6901 ! NOTE: The values stored in the segment are always saved in ascending order,
6902 ! e.g. (is < ie). In order to use setup_segment_indices, we reorder the
6903 ! indices here to indicate face direction.
6904 ! Segment indices are also indexed locally, so here we convert to global indices
6905 if (segment_in%direction == obc_direction_n) then
6906 is_obc_in = segment_in%Ie_obc + g_in%idg_offset
6907 ie_obc_in = segment_in%Is_obc + g_in%idg_offset
6908 else
6909 is_obc_in = segment_in%Is_obc + g_in%idg_offset
6910 ie_obc_in = segment_in%Ie_obc + g_in%idg_offset
6911 endif
6912
6913 if (segment_in%direction == obc_direction_w) then
6914 js_obc_in = segment_in%Je_obc + g_in%jdg_offset
6915 je_obc_in = segment_in%Js_obc + g_in%jdg_offset
6916 else
6917 js_obc_in = segment_in%Js_obc + g_in%jdg_offset
6918 je_obc_in = segment_in%Je_obc + g_in%jdg_offset
6919 endif
6920
6921 ! Rotate the global indices of the segment according to the number of turns.
6922 if (qturns == 0) then
6923 is_obc = is_obc_in ; ie_obc = ie_obc_in
6924 js_obc = js_obc_in ; je_obc = je_obc_in
6925 elseif (qturns == 1) then
6926 is_obc = g_in%JegB - js_obc_in ; ie_obc = g_in%JegB - je_obc_in
6927 js_obc = is_obc_in ; je_obc = ie_obc_in
6928 elseif (qturns == 2) then
6929 is_obc = g_in%IegB - is_obc_in ; ie_obc = g_in%IegB - ie_obc_in
6930 js_obc = g_in%JegB - js_obc_in ; je_obc = g_in%JegB - je_obc_in
6931 elseif (qturns == 3) then
6932 is_obc = js_obc_in ; ie_obc = je_obc_in
6933 js_obc = g_in%IegB - is_obc_in ; je_obc = g_in%IegB - ie_obc_in
6934 endif
6935
6936 ! Orientation is based on the index ordering, and setup_segment_indices
6937 ! is based on the original order in the intput files.
6938 call setup_segment_indices(g, segment, is_obc, ie_obc, js_obc, je_obc)
6939
6940 ! Re-order [IJ][se]_obc back to ascending, and remove the global indexing offset.
6941 if (is_obc > ie_obc) then
6942 segment%Is_obc = ie_obc - g%idg_offset
6943 segment%Ie_obc = is_obc - g%idg_offset
6944 else
6945 segment%Is_obc = is_obc - g%idg_offset
6946 segment%Ie_obc = ie_obc - g%idg_offset
6947 endif
6948
6949 if (js_obc > je_obc) then
6950 segment%Js_obc = je_obc - g%jdg_offset
6951 segment%Je_obc = js_obc - g%jdg_offset
6952 else
6953 segment%Js_obc = js_obc - g%jdg_offset
6954 segment%Je_obc = je_obc - g%jdg_offset
6955 endif
6956
6957 ! Reconfigure the directional flags
6958 segment%direction = rotate_obc_segment_direction(segment_in%direction, turns)
6959
6960 segment%is_E_or_W_2 = ((segment%direction == obc_direction_e) .or. &
6961 (segment%direction == obc_direction_w))
6962 segment%is_E_or_W = segment_in%on_PE .and. segment%is_E_or_W_2
6963 segment%is_N_or_S = segment_in%on_PE .and. &
6964 ((segment%direction == obc_direction_n) .or. &
6965 (segment%direction == obc_direction_s))
6966
6967 ! These are conditionally set if Lscale_{in,out} are present
6968 segment%Tr_InvLscale_in = segment_in%Tr_InvLscale_in
6969 segment%Tr_InvLscale_out = segment_in%Tr_InvLscale_out
6970 segment%Th_InvLscale_in = segment_in%Th_InvLscale_in
6971 segment%Th_InvLscale_out = segment_in%Th_InvLscale_out
6972
6973 ! This needs to be set
6974 segment%num_fields = segment_in%num_fields
6975end subroutine rotate_obc_segment_config
6976
6977
6978!> Return the direction of an OBC segment on after rotation to the new grid. Note that
6979!! rotate_OBC_seg_direction(rotate_OBC_seg_direction(direction, turns), -turns) = direction.
6980function rotate_obc_segment_direction(direction, turns) result(rotated_dir)
6981 integer, intent(in) :: direction !< The orientation of an OBC segment on the original grid
6982 integer, intent(in) :: turns !< Number of quarter turns
6983 integer :: rotated_dir !< An integer encoding the new rotated segment direction
6984
6985 integer :: qturns ! The number of quarter turns in the range of 0 to 3
6986
6987 qturns = modulo(turns, 4)
6988
6989 if ((qturns == 0) .or. (direction == obc_none)) then
6990 rotated_dir = direction
6991 else ! Determine the segment direction on a rotated grid
6992 select case (direction)
6993 case (obc_direction_n)
6994 if (qturns == 0) rotated_dir = obc_direction_n
6995 if (qturns == 1) rotated_dir = obc_direction_w
6996 if (qturns == 2) rotated_dir = obc_direction_s
6997 if (qturns == 3) rotated_dir = obc_direction_e
6998 case (obc_direction_w)
6999 if (qturns == 0) rotated_dir = obc_direction_w
7000 if (qturns == 1) rotated_dir = obc_direction_s
7001 if (qturns == 2) rotated_dir = obc_direction_e
7002 if (qturns == 3) rotated_dir = obc_direction_n
7003 case (obc_direction_s)
7004 if (qturns == 0) rotated_dir = obc_direction_s
7005 if (qturns == 1) rotated_dir = obc_direction_e
7006 if (qturns == 2) rotated_dir = obc_direction_n
7007 if (qturns == 3) rotated_dir = obc_direction_w
7008 case (obc_direction_e)
7009 if (qturns == 0) rotated_dir = obc_direction_e
7010 if (qturns == 1) rotated_dir = obc_direction_n
7011 if (qturns == 2) rotated_dir = obc_direction_w
7012 if (qturns == 3) rotated_dir = obc_direction_s
7013 case (obc_none)
7014 rotated_dir = obc_none
7015 case default ! This should never happen.
7016 rotated_dir = direction
7017 end select
7018 endif
7019
7021
7022!> Return the that the field would have after being rotated by the given number of quarter turns
7023function rotated_field_name(input_name, turns)
7024 character(len=*), intent(in) :: input_name !< The unrotated field name
7025 integer, intent(in) :: turns !< Number of quarter turns of the grid
7026 character(len=len(input_name)) :: rotated_field_name !< The rotated field name
7027
7028 if (modulo(turns, 2) /= 0) then
7029 select case (input_name)
7030 case ('U') ; rotated_field_name = 'V'
7031 case ('Uamp') ; rotated_field_name = 'Vamp'
7032 case ('Uphase') ; rotated_field_name = 'Vphase'
7033 case ('V') ; rotated_field_name = 'U'
7034 case ('Vamp') ; rotated_field_name = 'Uamp'
7035 case ('Vphase') ; rotated_field_name = 'Uphase'
7036 case ('DVDX') ; rotated_field_name = 'DUDY'
7037 case ('DUDY') ; rotated_field_name = 'DVDX'
7038 case default ; rotated_field_name = input_name
7039 end select
7040 else
7041 rotated_field_name = input_name
7042 endif
7043
7044end function rotated_field_name
7045
7046!> Allocate an array of data for a field on a segment based on the size of a potentially rotated source array
7047subroutine allocate_rotated_seg_data(src_array, HI_in, tgt_array, segment)
7048 real, dimension(:,:,:), intent(in) :: src_array !< The segment data on the unrotated source grid
7049 type(hor_index_type), intent(in) :: HI_in !< Horizontal indices on the source grid
7050 real, dimension(:,:,:), allocatable, intent(inout) :: tgt_array !< The segment data that is being allocated
7051 type(obc_segment_type), intent(inout) :: segment !< OBC segment on the target grid
7052
7053 ! Local variables
7054 integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nk
7055 logical :: corner ! True if this field is discretized at the OBC segment nodes rather than the faces.
7056
7057 isd = segment%HI%isd ; ied = segment%HI%ied ; isdb = segment%HI%IsdB ; iedb = segment%HI%IedB
7058 jsd = segment%HI%jsd ; jed = segment%HI%jed ; jsdb = segment%HI%JsdB ; jedb = segment%HI%JedB
7059 nk = size(src_array, 3)
7060
7061 ! Determine whether the source array is allocated at a segment face or at the corners.
7062 corner = (size(src_array, 1) == abs(hi_in%IedB - hi_in%IsdB) + 1 ) .and. &
7063 (size(src_array, 2) == abs(hi_in%JedB - hi_in%JsdB) + 1 )
7064
7065 if (corner) then
7066 allocate(tgt_array(isdb:iedb,jsdb:jedb,nk), source=0.0)
7067 elseif (segment%is_E_or_W) then
7068 allocate(tgt_array(isdb:iedb,jsd:jed,nk), source=0.0)
7069 elseif (segment%is_N_or_S) then
7070 allocate(tgt_array(isd:ied,jsdb:jedb,nk), source=0.0)
7071 endif
7072end subroutine allocate_rotated_seg_data
7073
7074
7075!> Write out information about the contents of the OBC control structure
7076subroutine write_obc_info(OBC, G, GV, US)
7077 type(ocean_obc_type), pointer :: obc !< An open boundary condition control structure
7078 type(ocean_grid_type), intent(in) :: g !< Rotated grid metric
7079 type(verticalgrid_type), intent(in) :: gv !< Vertical grid
7080 type(unit_scale_type), intent(in) :: us !< Unit scaling
7081
7082 ! Local variables
7083 type(obc_segment_type), pointer :: segment => null() ! pointer to segment type list
7084 integer :: turns ! Number of index quarter turns
7085 integer :: n ! The segment number reported in output
7086 integer :: n_seg ! The internal segment number
7087 integer :: dir ! This indicates the internal logical orientation of a segment
7088 integer :: unrot_dir ! This indicates the logical orientation a segment would have had
7089 ! without grid rotation
7090 integer :: c ! Used to loop over tidal constituents
7091 character(len=1024) :: mesg
7092
7093 turns = modulo(g%HI%turns, 4)
7094
7095 write(mesg, '("OBC has ", I0, " segments.")') obc%number_of_segments
7096 call mom_mesg(mesg, verb=1)
7097 ! call MOM_error(WARNING, mesg)
7098
7099 if (modulo(turns, 2) == 0) then
7100 if (obc%open_u_BCs_exist_globally) call mom_mesg("open_u_BCs_exist_globally", verb=1)
7101 if (obc%open_v_BCs_exist_globally) call mom_mesg("open_v_BCs_exist_globally", verb=1)
7102 if (obc%Flather_u_BCs_exist_globally) call mom_mesg("Flather_u_BCs_exist_globally", verb=1)
7103 if (obc%Flather_v_BCs_exist_globally) call mom_mesg("Flather_v_BCs_exist_globally", verb=1)
7104 if (obc%nudged_u_BCs_exist_globally) call mom_mesg("nudged_u_BCs_exist_globally", verb=1)
7105 if (obc%nudged_v_BCs_exist_globally) call mom_mesg("nudged_v_BCs_exist_globally", verb=1)
7106 if (obc%specified_u_BCs_exist_globally) call mom_mesg("specified_u_BCs_exist_globally", verb=1)
7107 if (obc%specified_v_BCs_exist_globally) call mom_mesg("specified_v_BCs_exist_globally", verb=1)
7108 else ! The u- and v-directions are swapped.
7109 if (obc%open_v_BCs_exist_globally) call mom_mesg("open_u_BCs_exist_globally", verb=1)
7110 if (obc%open_u_BCs_exist_globally) call mom_mesg("open_v_BCs_exist_globally", verb=1)
7111 if (obc%Flather_v_BCs_exist_globally) call mom_mesg("Flather_u_BCs_exist_globally", verb=1)
7112 if (obc%Flather_u_BCs_exist_globally) call mom_mesg("Flather_v_BCs_exist_globally", verb=1)
7113 if (obc%nudged_v_BCs_exist_globally) call mom_mesg("nudged_u_BCs_exist_globally", verb=1)
7114 if (obc%nudged_u_BCs_exist_globally) call mom_mesg("nudged_v_BCs_exist_globally", verb=1)
7115 if (obc%specified_v_BCs_exist_globally) call mom_mesg("specified_u_BCs_exist_globally", verb=1)
7116 if (obc%specified_u_BCs_exist_globally) call mom_mesg("specified_v_BCs_exist_globally", verb=1)
7117 endif
7118
7119 if (obc%oblique_BCs_exist_globally) call mom_mesg("oblique_BCs_exist_globally", verb=1)
7120 if (obc%radiation_BCs_exist_globally) call mom_mesg("radiation_BCs_exist_globally", verb=1)
7121 if (obc%user_BCs_set_globally) call mom_mesg("user_BCs_set_globally", verb=1)
7122 if (obc%update_OBC) call mom_mesg("update_OBC", verb=1)
7123 if (obc%update_OBC_seg_data) call mom_mesg("update_OBC_seg_data", verb=1)
7124 if (obc%any_needs_IO_for_data) call mom_mesg("any_needs_IO_for_data", verb=1)
7125 if (obc%zero_biharmonic) call mom_mesg("zero_biharmonic", verb=1)
7126 if (obc%brushcutter_mode) call mom_mesg("brushcutter_mode", verb=1)
7127 if (obc%check_reconstruction) call mom_mesg("check_reconstruction", verb=1)
7128 if (obc%check_remapping) call mom_mesg("check_remapping", verb=1)
7129 if (obc%force_bounds_in_subcell) call mom_mesg("force_bounds_in_subcell", verb=1)
7130 if (obc%om4_remap_via_sub_cells) call mom_mesg("om4_remap_via_sub_cells", verb=1)
7131 if (obc%exterior_OBC_bug) call mom_mesg("exterior_OBC_bug", verb=1)
7132 if (obc%hor_index_bug) call mom_mesg("hor_index_bug", verb=1)
7133 if (obc%debug) call mom_mesg("debug", verb=1)
7134 if (obc%ramp) call mom_mesg("ramp", verb=1)
7135 if (obc%ramping_is_activated) call mom_mesg("ramping_is_activated", verb=1)
7136 write(mesg, '("n_tide_constituents ", I0)') obc%n_tide_constituents
7137 call mom_mesg(mesg, verb=1)
7138 if (obc%n_tide_constituents > 0) then
7139 do c=1,obc%n_tide_constituents
7140 write(mesg, '(" properties ", 4ES16.6)') &
7141 us%s_to_T*obc%tide_frequencies(c), obc%tide_eq_phases(c), obc%tide_fn(c), obc%tide_un(c)
7142 call mom_mesg(trim(obc%tide_names(c))//mesg, verb=1)
7143 enddo
7144 endif
7145 if (obc%ramp) then
7146 write(mesg, '("ramp_values ", 3ES16.6)') obc%ramp_timescale, obc%trunc_ramp_time, obc%ramp_value
7147 call mom_mesg(mesg, verb=1)
7148 endif
7149 write(mesg, '("gamma_uv ", ES16.6)') obc%gamma_uv
7150 call mom_mesg(mesg, verb=1)
7151 write(mesg, '("rx_max ", ES16.6)') obc%rx_max
7152 call mom_mesg(mesg, verb=1)
7153
7154 call mom_mesg("remappingScheme = "//trim(obc%remappingScheme), verb=1)
7155
7156 do n=1,obc%number_of_segments
7157 n_seg = n ; if (obc%reverse_segment_order) n_seg = obc%number_of_segments + 1 - n
7158 segment => obc%segment(n_seg)
7159 dir = segment%direction
7160
7161 unrot_dir = rotate_obc_segment_direction(dir, -turns)
7162 write(mesg, '(" Segment ", I0, " has direction ", I0)') n, unrot_dir
7163 if (unrot_dir == obc_direction_n) write(mesg, '(" Segment ", I0, " is Northern")') n
7164 if (unrot_dir == obc_direction_s) write(mesg, '(" Segment ", I0, " is Southern")') n
7165 if (unrot_dir == obc_direction_e) write(mesg, '(" Segment ", I0, " is Eastern")') n
7166 if (unrot_dir == obc_direction_w) write(mesg, '(" Segment ", I0, " is Western")') n
7167 call mom_mesg(mesg, verb=1)
7168
7169 ! write(mesg, '(" range:", 4(1x,I0))') segment%Is_obc, segment%Ie_obc, segment%Js_obc, segment%Je_obc
7170 if (modulo(turns, 2) == 0) then
7171 write(mesg, '(" size: ", I0," ",I0)') 1+abs(segment%Ie_obc-segment%Is_obc), 1+abs(segment%Je_obc-segment%Js_obc)
7172 else
7173 write(mesg, '(" size: ", I0," ",I0)') 1+abs(segment%Je_obc-segment%Js_obc), 1+abs(segment%Ie_obc-segment%Is_obc)
7174 endif
7175 call mom_mesg(mesg, verb=1)
7176
7177 if (segment%on_pe) call mom_mesg(" Segment is on PE.", verb=1)
7178
7179 if (segment%Flather) call mom_mesg(" Flather", verb=1)
7180 if (segment%radiation) call mom_mesg(" radiation", verb=1)
7181 if (segment%radiation_tan) call mom_mesg(" radiation_tan", verb=1)
7182 if (segment%radiation_grad) call mom_mesg(" radiation_grad", verb=1)
7183 if (segment%oblique) call mom_mesg(" oblique", verb=1)
7184 if (segment%oblique_tan) call mom_mesg(" oblique_tan", verb=1)
7185 if (segment%oblique_grad) call mom_mesg(" oblique_grad", verb=1)
7186 if (segment%nudged) call mom_mesg(" nudged", verb=1)
7187 if (segment%nudged_tan) call mom_mesg(" nudged_tan", verb=1)
7188 if (segment%nudged_grad) call mom_mesg(" nudged_grad", verb=1)
7189 if (segment%specified) call mom_mesg(" specified", verb=1)
7190 if (segment%specified_tan) call mom_mesg(" specified_tan", verb=1)
7191 if (segment%specified_grad) call mom_mesg(" specified_grad", verb=1)
7192 if (segment%open) call mom_mesg(" open", verb=1)
7193 if (segment%gradient) call mom_mesg(" gradient", verb=1)
7194 if (modulo(turns, 2) == 0) then
7195 if (segment%is_N_or_S) call mom_mesg(" is_N_or_S", verb=1)
7196 if (segment%is_E_or_W) call mom_mesg(" is_E_or_W", verb=1)
7197 else ! The x- and y-directions are swapped.
7198 if (segment%is_E_or_W) call mom_mesg(" is_N_or_S", verb=1)
7199 if (segment%is_N_or_S) call mom_mesg(" is_E_or_W", verb=1)
7200 endif
7201 ! if (segment%is_E_or_W_2) call MOM_mesg(" is_E_or_W_2", verb=1)
7202
7203 write(mesg, '(" Tr_InvLscale_out ", ES16.6)') segment%Tr_InvLscale_out*us%m_to_L
7204 call mom_mesg(mesg, verb=1)
7205 write(mesg, '(" Tr_InvLscale_in ", ES16.6)') segment%Tr_InvLscale_in*us%m_to_L
7206 call mom_mesg(mesg, verb=1)
7207 write(mesg, '(" Th_InvLscale_out ", ES16.6)') segment%Th_InvLscale_out*us%m_to_L
7208 call mom_mesg(mesg, verb=1)
7209 write(mesg, '(" Th_InvLscale_in ", ES16.6)') segment%Th_InvLscale_in*us%m_to_L
7210 call mom_mesg(mesg, verb=1)
7211
7212 enddo
7213
7214 call chksum_obc_segments(obc, g, gv, us, 0)
7215
7216end subroutine write_obc_info
7217
7218!> Write checksums and perhaps some or all of the values of all the allocated arrays on the OBC segments.
7219subroutine chksum_obc_segments(OBC, G, GV, US, nk)
7220 type(ocean_obc_type), intent(in) :: obc !< An open boundary condition control structure
7221 type(ocean_grid_type), intent(in) :: g !< Rotated grid metric
7222 type(verticalgrid_type), intent(in) :: gv !< Vertical grid
7223 type(unit_scale_type), intent(in) :: us !< Unit scaling
7224 integer, intent(in) :: nk !< The number of layers to print
7225
7226 ! Local variables
7227 integer :: n ! The segment number reported in output
7228 integer :: n_seg ! The internal segment number
7229
7230 do n=1,obc%number_of_segments
7231 n_seg = n ; if (obc%reverse_segment_order) n_seg = obc%number_of_segments + 1 - n
7232
7233 call chksum_obc_segment_data(obc%segment(n_seg), gv, us, nk, n)
7234 enddo
7235
7236end subroutine chksum_obc_segments
7237
7238
7239!> Write checksums and perhaps some or all of the values of all the allocated arrays on a single OBC segment.
7240subroutine chksum_obc_segment_data(segment, GV, US, nk, nseg_out)
7241 type(obc_segment_type), intent(in) :: segment !< Segment type to checksum
7242 type(verticalgrid_type), intent(in) :: GV !< Vertical grid
7243 type(unit_scale_type), intent(in) :: US !< Unit scaling
7244 integer, intent(in) :: nk !< The number of layers to print
7245 integer, intent(in) :: nseg_out !< The segment number reported in output
7246
7247 ! Local variables
7248 real :: norm ! A sign change used when rotating a normal component [nondim]
7249 real :: tang ! A sign change used when rotating a tangential component [nondim]
7250 character(len=8) :: sn, segno
7251 integer :: dir ! This indicates the internal logical orientation of a segment
7252
7253 dir = segment%direction
7254
7255 write(segno, '(I0)') nseg_out
7256 sn = '('//trim(segno)//')'
7257
7258 ! Turn each segment and write it as though it is an eastern face.
7259 norm = 0.0 ; tang = 0.0
7260 if (dir == obc_direction_e) then
7261 norm = 1.0 ; tang = 1.0
7262 elseif (dir == obc_direction_n) then
7263 norm = 1.0 ; tang = -1.0
7264 elseif (dir == obc_direction_w) then
7265 norm = -1.0 ; tang = -1.0
7266 elseif (dir == obc_direction_s) then
7267 norm = -1.0 ; tang = 1.0
7268 endif
7269
7270 if (allocated(segment%Htot)) call write_2d_array_vals("Htot"//trim(sn), segment%Htot, dir, nk, unscale=gv%H_to_mks)
7271 if (allocated(segment%dZtot)) call write_2d_array_vals("dZtot"//trim(sn), segment%dZtot, dir, nk, unscale=us%Z_to_m)
7272 if (allocated(segment%SSH)) call write_2d_array_vals("SSH"//trim(sn), segment%SSH, dir, nk, unscale=us%Z_to_m)
7273 if (allocated(segment%normal_vel)) &
7274 call write_3d_array_vals("normal_vel"//trim(sn), segment%normal_vel, dir, nk, unscale=norm*us%L_T_to_m_s)
7275 if (allocated(segment%normal_vel_bt)) &
7276 call write_2d_array_vals("normal_vel_bt"//trim(sn), segment%normal_vel_bt, dir, nk, unscale=norm*us%L_T_to_m_s)
7277 if (allocated(segment%tangential_vel)) &
7278 call write_3d_array_vals("tangential_vel"//trim(sn), segment%tangential_vel, dir, nk, unscale=tang*us%L_T_to_m_s)
7279 if (allocated(segment%tangential_grad)) &
7280 call write_3d_array_vals("tangential_grad"//trim(sn), segment%tangential_grad, dir, nk, &
7281 unscale=tang*norm*us%s_to_T)
7282 if (allocated(segment%normal_trans)) &
7283 call write_3d_array_vals("normal_trans"//trim(sn), segment%normal_trans, dir, nk, &
7284 unscale=norm*gv%H_to_mks*us%L_T_to_m_s*us%L_to_m)
7285 if (allocated(segment%grad_normal)) &
7286 call write_3d_array_vals("grad_normal"//trim(sn), segment%grad_normal, dir, nk, unscale=norm*tang*us%L_T_to_m_s)
7287 if (allocated(segment%grad_tan)) &
7288 call write_3d_array_vals("grad_tan"//trim(sn), segment%grad_tan, dir, nk, unscale=1.0*us%L_T_to_m_s)
7289 if (allocated(segment%grad_gradient)) &
7290 call write_3d_array_vals("grad_gradient"//trim(sn), segment%grad_gradient, dir, nk, unscale=norm*us%s_to_T)
7291
7292 if (allocated(segment%rx_norm_rad)) &
7293 call write_3d_array_vals("rxy_norm_rad"//trim(sn), segment%rx_norm_rad, dir, nk, unscale=1.0)
7294 if (allocated(segment%ry_norm_rad)) &
7295 call write_3d_array_vals("rxy_norm_rad"//trim(sn), segment%ry_norm_rad, dir, nk, unscale=1.0)
7296 if (segment%is_E_or_W) then
7297 if (allocated(segment%rx_norm_obl)) &
7298 call write_3d_array_vals("rx_norm_obl"//trim(sn), segment%rx_norm_obl, dir, nk, unscale=us%L_T_to_m_s**2)
7299 if (allocated(segment%ry_norm_obl)) &
7300 call write_3d_array_vals("ry_norm_obl"//trim(sn), segment%ry_norm_obl, dir, nk, unscale=us%L_T_to_m_s**2)
7301 else ! The x- and y- directions are swapped.
7302 if (allocated(segment%ry_norm_obl)) &
7303 call write_3d_array_vals("rx_norm_obl"//trim(sn), segment%ry_norm_obl, dir, nk, unscale=us%L_T_to_m_s**2)
7304 if (allocated(segment%rx_norm_obl)) &
7305 call write_3d_array_vals("ry_norm_obl"//trim(sn), segment%rx_norm_obl, dir, nk, unscale=us%L_T_to_m_s**2)
7306 endif
7307
7308 if (allocated(segment%cff_normal)) &
7309 call write_3d_array_vals("cff_normal"//trim(sn), segment%cff_normal, dir, nk, unscale=us%L_T_to_m_s**2)
7310 if (allocated(segment%nudged_normal_vel)) &
7311 call write_3d_array_vals("nudged_normal_vel"//trim(sn), segment%nudged_normal_vel, dir, nk, &
7312 unscale=norm*us%L_T_to_m_s)
7313 if (allocated(segment%nudged_tangential_vel)) &
7314 call write_3d_array_vals("nudged_tangential_vel"//trim(sn), segment%nudged_tangential_vel, dir, nk, &
7315 unscale=tang*us%L_T_to_m_s)
7316 if (allocated(segment%nudged_tangential_grad)) &
7317 call write_3d_array_vals("nudged_tangential_grad"//trim(sn), segment%nudged_tangential_grad, dir, nk, &
7318 unscale=tang*norm*us%s_to_T)
7319
7320 contains
7321
7322 !> Write out the values in a named 2-d segment data array
7323 subroutine write_2d_array_vals(name, Array, seg_dir, nkp, unscale)
7324 character(len=*), intent(in) :: name !< The name of the variable
7325 real, dimension(:,:), intent(in) :: Array !< The 2-d array to write [A ~> a]
7326 integer, intent(in) :: seg_dir !< The direction of the segment
7327 integer, intent(in) :: nkp !< Print all the values if this is greater than 0
7328 real, optional, intent(in) :: unscale !< A factor that undoes the scaling of the array [a A-1 ~> 1]
7329 ! Local variables
7330 real :: scale ! A factor that undoes the scaling of the array [a A-1 ~> 1]
7331 character(len=1024) :: mesg
7332 character(len=24) :: val
7333 integer :: i, j, n, iounit
7334
7335 scale = 1.0 ; if (present(unscale)) scale = unscale
7336 iounit = stderr
7337
7338 if (nkp > 0) then
7339 write(iounit, '(2X,A,":")') trim(name)
7340 mesg = "" ; n = 0
7341 if ((seg_dir == obc_direction_n) .or. (seg_dir == obc_direction_w)) then
7342 do j=size(array,2),1,-1 ; do i=size(array,1),1,-1
7343 write(val, '(ES16.6)') scale*array(i,j)
7344 mesg = trim(mesg)//" "//trim(val) ; n = n + 1
7345 if (n >= 12) then
7346 write(iounit, '(2X,A)') trim(mesg)
7347 mesg = "" ; n = 0
7348 endif
7349 enddo ; enddo
7350 else
7351 do j=1,size(array,2) ; do i=1,size(array,1)
7352 write(val, '(ES16.6)') scale*array(i,j)
7353 mesg = trim(mesg)//" "//trim(val) ; n = n + 1
7354 if (n >= 12) then
7355 write(iounit, '(2X,A)') trim(mesg)
7356 mesg = "" ; n = 0
7357 endif
7358 enddo ; enddo
7359 endif
7360 if (n > 0) write(iounit, '(2X,A)') trim(mesg)
7361 endif
7362
7363 if (scale == 1.0) then
7364 call chksum(array, name)
7365 else
7366 call chksum(scale*array(:,:), name)
7367 endif
7368 end subroutine write_2d_array_vals
7369
7370 !> Write out the values in a 3-d segment data array
7371 subroutine write_3d_array_vals(name, Array, seg_dir, nkp, unscale)
7372 character(len=*), intent(in) :: name !< The name of the variable
7373 real, dimension(:,:,:), intent(in) :: Array !< The 3-d array to write
7374 integer, intent(in) :: seg_dir !< The direction of the segment
7375 integer, intent(in) :: nkp !< The number of layers to print
7376 real, optional, intent(in) :: unscale !< A factor that undoes the scaling of the array [a A-1 ~> 1]
7377 ! Local variables
7378 real :: scale ! A factor that undoes the scaling of the array [a A-1 ~> 1]
7379 logical :: reverse
7380 character(len=1024) :: mesg
7381 character(len=24) :: val
7382 integer :: i, j, k, n, nk, iounit
7383
7384 scale = 1.0 ; if (present(unscale)) scale = unscale
7385 iounit = stderr
7386
7387 if (nkp > 0) then
7388 nk = min(nkp, size(array,3))
7389 write(iounit, '(2X,A,":")') trim(name)
7390 do k=1,nk
7391 mesg = "" ; n = 0
7392 if ((seg_dir == obc_direction_n) .or. (seg_dir == obc_direction_w)) then
7393 do j=size(array,2),1,-1 ; do i=size(array,1),1,-1
7394 write(val, '(ES16.6)') scale*array(i,j,k)
7395 mesg = trim(mesg)//" "//trim(val) ; n = n + 1
7396 if (n >= 12) then
7397 write(iounit, '(2X,A)') trim(mesg)
7398 mesg = "" ; n = 0
7399 endif
7400 enddo ; enddo
7401 else
7402 do j=1,size(array,2) ; do i=1,size(array,1)
7403 write(val, '(ES16.6)') scale*array(i,j,k)
7404 mesg = trim(mesg)//" "//trim(val) ; n = n + 1
7405 if (n >= 12) then
7406 write(iounit, '(2X,A)') trim(mesg)
7407 mesg = "" ; n = 0
7408 endif
7409 enddo ; enddo
7410 endif
7411 if (n > 0) write(iounit, '(2X,A)') trim(mesg)
7412 enddo
7413 endif
7414
7415 if (scale == 1.0) then
7416 call chksum(array, name)
7417 else
7418 call chksum(scale*array(:,:,:), name)
7419 endif
7420
7421 end subroutine write_3d_array_vals
7422
7423end subroutine chksum_obc_segment_data
7424
7425!> \namespace mom_open_boundary
7426!! This module implements some aspects of internal open boundary
7427!! conditions in MOM.
7428!!
7429!! A small fragment of the grid is shown below:
7430!!
7431!! j+1 x ^ x ^ x At x: q, CoriolisBu
7432!! j+1 > o > o > At ^: v, tauy
7433!! j x ^ x ^ x At >: u, taux
7434!! j > o > o > At o: h, bathyT, buoy, tr, T, S, Rml, ustar
7435!! j-1 x ^ x ^ x
7436!! i-1 i i+1 At x & ^:
7437!! i i+1 At > & o:
7438!!
7439!! The boundaries always run through q grid points (x).
7440
7441end module mom_open_boundary