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