src/core/MOM_open_boundary.F90

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

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