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