config_src/infra/FMS2/MOM_domain_infra.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		!> Describes the decomposed MOM domain and has routines for communications across PEs
6		module MOM_domain_infra
7
8		use MOM_coms_infra, only : PE_here, root_PE, num_PEs
9		use MOM_cpu_clock_infra, only : cpu_clock_begin, cpu_clock_end
10		use MOM_error_infra, only : MOM_error=>MOM_err, NOTE, WARNING, FATAL
11
12		use mpp_domains_mod, only : domain2D, domain1D
13		use mpp_domains_mod, only : mpp_define_io_domain, mpp_define_domains, mpp_deallocate_domain
14		use mpp_domains_mod, only : mpp_get_domain_components, mpp_get_domain_extents, mpp_get_layout
15		use mpp_domains_mod, only : mpp_get_compute_domain, mpp_get_data_domain, mpp_get_global_domain
16		use mpp_domains_mod, only : mpp_get_boundary, mpp_update_domains
17		use mpp_domains_mod, only : mpp_start_update_domains, mpp_complete_update_domains
18		use mpp_domains_mod, only : mpp_create_group_update, mpp_do_group_update
19		use mpp_domains_mod, only : mpp_reset_group_update_field, mpp_group_update_initialized
20		use mpp_domains_mod, only : mpp_start_group_update, mpp_complete_group_update
21		use mpp_domains_mod, only : mpp_compute_block_extent, mpp_compute_extent
22		use mpp_domains_mod, only : mpp_broadcast_domain, mpp_redistribute, mpp_global_field
23		use mpp_domains_mod, only : AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR, BITWISE_EXACT_SUM
24		use mpp_domains_mod, only : CYCLIC_GLOBAL_DOMAIN
25		use mpp_domains_mod, only : FOLD_NORTH_EDGE, FOLD_SOUTH_EDGE, FOLD_EAST_EDGE, FOLD_WEST_EDGE
26		use mpp_domains_mod, only : To_East => WUPDATE, To_West => EUPDATE, Omit_Corners => EDGEUPDATE
27		use mpp_domains_mod, only : To_North => SUPDATE, To_South => NUPDATE
28		use mpp_domains_mod, only : CENTER, CORNER, NORTH_FACE => NORTH, EAST_FACE => EAST
29		use fms_io_utils_mod, only : file_exists, parse_mask_table
30		use fms_affinity_mod, only : fms_affinity_init, fms_affinity_set, fms_affinity_get
31
32		! This subroutine is not in MOM6/src but may be required by legacy drivers
33		! use mpp_domains_mod, only : global_field_sum => mpp_global_sum
34
35		! The `group_pass_type` fields are never accessed, so we keep it as an FMS type
36		use mpp_domains_mod, only : group_pass_type => mpp_group_update_type
37
38		implicit none ; private
39
40		! These types are inherited from mpp, but are treated as opaque here.
41		public :: domain2D, domain1D, group_pass_type
42		! These interfaces are actually implemented or have explicit interfaces in this file.
43		public :: create_MOM_domain, clone_MOM_domain, get_domain_components, get_domain_extent
44		public :: deallocate_MOM_domain, get_global_shape, compute_block_extent, compute_extent
45		public :: pass_var, pass_vector, fill_symmetric_edges, rescale_comp_data
46		public :: pass_var_start, pass_var_complete, pass_vector_start, pass_vector_complete
47		public :: create_group_pass, do_group_pass, start_group_pass, complete_group_pass
48		public :: redistribute_array, broadcast_domain, same_domain, global_field
49		public :: get_simple_array_i_ind, get_simple_array_j_ind
50		public :: MOM_thread_affinity_set, set_MOM_thread_affinity
51		! These are encoding constant parmeters with self-explanatory names.
52		public :: To_East, To_West, To_North, To_South, To_All, Omit_Corners
53		public :: AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR
54		public :: CORNER, CENTER, NORTH_FACE, EAST_FACE
55		public :: set_domain, nullify_domain
56		! These are no longer used by MOM6 because the reproducing sum works so well, but they are
57		! still referenced by some of the non-GFDL couplers.
58		! public :: global_field_sum, BITWISE_EXACT_SUM
59
60		!> Do a halo update on an array
61		interface pass_var
62		module procedure pass_var_3d, pass_var_2d
63		end interface pass_var
64
65		!> Do a halo update on a pair of arrays representing the two components of a vector
66		interface pass_vector
67		module procedure pass_vector_3d, pass_vector_2d
68		end interface pass_vector
69
70		!> Initiate a non-blocking halo update on an array
71		interface pass_var_start
72		module procedure pass_var_start_3d, pass_var_start_2d
73		end interface pass_var_start
74
75		!> Complete a non-blocking halo update on an array
76		interface pass_var_complete
77		module procedure pass_var_complete_3d, pass_var_complete_2d
78		end interface pass_var_complete
79
80		!> Initiate a halo update on a pair of arrays representing the two components of a vector
81		interface pass_vector_start
82		module procedure pass_vector_start_3d, pass_vector_start_2d
83		end interface pass_vector_start
84
85		!> Complete a halo update on a pair of arrays representing the two components of a vector
86		interface pass_vector_complete
87		module procedure pass_vector_complete_3d, pass_vector_complete_2d
88		end interface pass_vector_complete
89
90		!> Set up a group of halo updates
91		interface create_group_pass
92		module procedure create_var_group_pass_2d
93		module procedure create_var_group_pass_3d
94		module procedure create_vector_group_pass_2d
95		module procedure create_vector_group_pass_3d
96		end interface create_group_pass
97
98		!> Do a set of halo updates that fill in the values at the duplicated edges
99		!! of a staggered symmetric memory domain
100		interface fill_symmetric_edges
101		module procedure fill_vector_symmetric_edges_2d !, fill_vector_symmetric_edges_3d
102		! module procedure fill_scalar_symmetric_edges_2d, fill_scalar_symmetric_edges_3d
103		end interface fill_symmetric_edges
104
105		!> Rescale the values of an array in its computational domain by a constant factor
106		interface rescale_comp_data
107		module procedure rescale_comp_data_4d, rescale_comp_data_3d, rescale_comp_data_2d
108		end interface rescale_comp_data
109
110		!> Pass an array from one MOM domain to another
111		interface redistribute_array
112		module procedure redistribute_array_2d, redistribute_array_3d, redistribute_array_4d
113		end interface redistribute_array
114
115		!> Copy one MOM_domain_type into another
116		interface clone_MOM_domain
117		module procedure clone_MD_to_MD, clone_MD_to_d2D
118		end interface clone_MOM_domain
119
120		!> Extract the 1-d domain components from a MOM_domain or domain2d
121		interface get_domain_components
122		module procedure get_domain_components_MD, get_domain_components_d2D
123		end interface get_domain_components
124
125		!> Returns the index ranges that have been stored in a MOM_domain_type
126		interface get_domain_extent
127		module procedure get_domain_extent_MD, get_domain_extent_d2D
128		end interface get_domain_extent
129
130
131		!> The MOM_domain_type contains information about the domain decomposition.
132		type, public :: MOM_domain_type
133		character(len=64) :: name !< The name of this domain
134		type(domain2D), pointer :: mpp_domain => NULL() !< The FMS domain with halos
135		!! on this processor, centered at h points.
136		type(domain2D), pointer :: mpp_domain_d2 => NULL() !< A coarse FMS domain with halos
137		!! on this processor, centered at h points.
138		integer :: niglobal !< The total horizontal i-domain size.
139		integer :: njglobal !< The total horizontal j-domain size.
140		integer :: nihalo !< The i-halo size in memory.
141		integer :: njhalo !< The j-halo size in memory.
142		logical :: symmetric !< True if symmetric memory is used with this domain.
143		logical :: nonblocking_updates !< If true, non-blocking halo updates are
144		!! allowed. The default is .false. (for now).
145		logical :: thin_halo_updates !< If true, optional arguments may be used to
146		!! specify the width of the halos that are
147		!! updated with each call.
148		integer :: layout(2) !< This domain's processor layout. This is
149		!! saved to enable the construction of related
150		!! new domains with different resolutions or
151		!! other properties.
152		integer :: io_layout(2) !< The IO-layout used with this domain.
153		integer :: X_FLAGS !< Flag that specifies the properties of the
154		!! domain in the i-direction in a define_domain call.
155		integer :: Y_FLAGS !< Flag that specifies the properties of the
156		!! domain in the j-direction in a define_domain call.
157		logical, pointer :: maskmap(:,:) => NULL() !< A pointer to an array indicating
158		!! which logical processors are actually used for
159		!! the ocean code. The other logical processors
160		!! would be contain only land points and are not
161		!! assigned to actual processors. This need not be
162		!! assigned if all logical processors are used.
163		integer :: turns !< Number of quarter-turns from input to this grid.
164		type(MOM_domain_type), pointer :: domain_in => NULL()
165		!< Reference to unrotated domain (if turned)
166		end type MOM_domain_type
167
168		integer, parameter :: To_All = To_East + To_West + To_North + To_South !< A flag for passing in all directions
169
170		contains
171
172		!> pass_var_3d does a halo update for a three-dimensional array.
173	55	subroutine pass_var_3d(array, MOM_dom, sideflag, complete, position, halo, &
174		clock)
175		real, dimension(:,:,:), intent(inout) :: array !< The array which is having its halos points
176		!! exchanged.
177		type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain
178		!! needed to determine where data should be
179		!! sent.
180		integer, optional, intent(in) :: sideflag !< An optional integer indicating which
181		!! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST,
182		!! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east,
183		!! sothe halos on the western side are filled. TO_ALL is the default if sideflag is omitted.
184		logical, optional, intent(in) :: complete !< An optional argument indicating whether the
185		!! halo updates should be completed before
186		!! progress resumes. Omitting complete is the
187		!! same as setting complete to .true.
188		integer, optional, intent(in) :: position !< An optional argument indicating the position.
189		!! This is CENTER by default and is often CORNER,
190		!! but could also be EAST_FACE or NORTH_FACE.
191		integer, optional, intent(in) :: halo !< The size of the halo to update - the full
192		!! halo by default.
193		integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be
194		!! started then stopped to time this routine.
195
196		integer :: dirflag
197		logical :: block_til_complete
198
199	55	if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif
200
201	55	dirflag = To_All ! 60
202	55	if (present(sideflag)) then ; if (sideflag > 0) dirflag = sideflag ; endif
203	55	block_til_complete = .true.
204	55	if (present(complete)) block_til_complete = complete
205
206	55	if (present(halo) .and. MOM_dom%thin_halo_updates) then
207		call mpp_update_domains(array, MOM_dom%mpp_domain, flags=dirflag, &
208		complete=block_til_complete, position=position, &
209	49	whalo=halo, ehalo=halo, shalo=halo, nhalo=halo)
210		else
211		call mpp_update_domains(array, MOM_dom%mpp_domain, flags=dirflag, &
212	6	complete=block_til_complete, position=position)
213		endif
214
215	55	if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif
216
217	55	end subroutine pass_var_3d
218
219		!> pass_var_2d does a halo update for a two-dimensional array.
220	106	subroutine pass_var_2d(array, MOM_dom, sideflag, complete, position, halo, inner_halo, clock)
221		real, dimension(:,:), intent(inout) :: array !< The array which is having its halos points
222		!! exchanged.
223		type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain
224		!! needed to determine where data should be sent.
225		integer, optional, intent(in) :: sideflag !< An optional integer indicating which
226		!! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST,
227		!! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east,
228		!! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted.
229		logical, optional, intent(in) :: complete !< An optional argument indicating whether the
230		!! halo updates should be completed before
231		!! progress resumes. Omitting complete is the
232		!! same as setting complete to .true.
233		integer, optional, intent(in) :: position !< An optional argument indicating the position.
234		!! This is CENTER by default and is often CORNER,
235		!! but could also be EAST_FACE or NORTH_FACE.
236		integer, optional, intent(in) :: halo !< The size of the halo to update - the full halo
237		!! by default.
238		integer, optional, intent(in) :: inner_halo !< The size of an inner halo to avoid updating,
239		!! or 0 to avoid updating symmetric memory
240		!! computational domain points. Setting this >=0
241		!! also enforces that complete=.true.
242		integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be
243		!! started then stopped to time this routine.
244
245		! Local variables
246	106	real, allocatable, dimension(:,:) :: tmp
247		integer :: pos, i_halo, j_halo
248		integer :: isc, iec, jsc, jec, isd, ied, jsd, jed, IscB, IecB, JscB, JecB
249		integer :: inner, i, j, isfw, iefw, isfe, iefe, jsfs, jefs, jsfn, jefn
250		integer :: dirflag
251		logical :: block_til_complete
252
253	106	if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif
254
255	106	dirflag = To_All ! 60
256	106	if (present(sideflag)) then ; if (sideflag > 0) dirflag = sideflag ; endif
257	106	block_til_complete = .true. ; if (present(complete)) block_til_complete = complete
258	106	pos = CENTER ; if (present(position)) pos = position
259
260	106	if (present(inner_halo)) then ; if (inner_halo >= 0) then
261		! Store the original values.
262	1	allocate(tmp(size(array,1), size(array,2)))
263	8971	tmp(:,:) = array(:,:)
264	1	block_til_complete = .true.
265		endif ; endif
266
267	106	if (present(halo) .and. MOM_dom%thin_halo_updates) then
268		call mpp_update_domains(array, MOM_dom%mpp_domain, flags=dirflag, &
269		complete=block_til_complete, position=position, &
270	87	whalo=halo, ehalo=halo, shalo=halo, nhalo=halo)
271		else
272		call mpp_update_domains(array, MOM_dom%mpp_domain, flags=dirflag, &
273	19	complete=block_til_complete, position=position)
274		endif
275
276	106	if (present(inner_halo)) then ; if (inner_halo >= 0) then
277	1	call mpp_get_compute_domain(MOM_dom%mpp_domain, isc, iec, jsc, jec)
278	1	call mpp_get_data_domain(MOM_dom%mpp_domain, isd, ied, jsd, jed)
279		! Convert to local indices for arrays starting at 1.
280	1	isc = isc - (isd-1) ; iec = iec - (isd-1) ; ied = ied - (isd-1) ; isd = 1
281	1	jsc = jsc - (jsd-1) ; jec = jec - (jsd-1) ; jed = jed - (jsd-1) ; jsd = 1
282	1	i_halo = min(inner_halo, isc-1) ; j_halo = min(inner_halo, jsc-1)
283
284		! Figure out the array index extents of the eastern, western, northern and southern regions to copy.
285	1	if (pos == CENTER) then
286	0	if (size(array,1) == ied) then
287	0	isfw = isc - i_halo ; iefw = isc ; isfe = iec ; iefe = iec + i_halo
288	0	else ; call MOM_error(FATAL, "pass_var_2d: wrong i-size for CENTER array.") ; endif
289	0	if (size(array,2) == jed) then
290	0	isfw = isc - i_halo ; iefw = isc ; isfe = iec ; iefe = iec + i_halo
291	0	else ; call MOM_error(FATAL, "pass_var_2d: wrong j-size for CENTER array.") ; endif
292	1	elseif (pos == CORNER) then
293	1	if (size(array,1) == ied) then
294	0	isfw = max(isc - (i_halo+1), 1) ; iefw = isc ; isfe = iec ; iefe = iec + i_halo
295	1	elseif (size(array,1) == ied+1) then
296	1	isfw = isc - i_halo ; iefw = isc+1 ; isfe = iec+1 ; iefe = min(iec + 1 + i_halo, ied+1)
297	0	else ; call MOM_error(FATAL, "pass_var_2d: wrong i-size for CORNER array.") ; endif
298	1	if (size(array,2) == jed) then
299	0	jsfs = max(jsc - (j_halo+1), 1) ; jefs = jsc ; jsfn = jec ; jefn = jec + j_halo
300	1	elseif (size(array,2) == jed+1) then
301	1	jsfs = jsc - j_halo ; jefs = jsc+1 ; jsfn = jec+1 ; jefn = min(jec + 1 + j_halo, jed+1)
302	0	else ; call MOM_error(FATAL, "pass_var_2d: wrong j-size for CORNER array.") ; endif
303	0	elseif (pos == NORTH_FACE) then
304	0	if (size(array,1) == ied) then
305	0	isfw = isc - i_halo ; iefw = isc ; isfe = iec ; iefe = iec + i_halo
306	0	else ; call MOM_error(FATAL, "pass_var_2d: wrong i-size for NORTH_FACE array.") ; endif
307	0	if (size(array,2) == jed) then
308	0	jsfs = max(jsc - (j_halo+1), 1) ; jefs = jsc ; jsfn = jec ; jefn = jec + j_halo
309	0	elseif (size(array,2) == jed+1) then
310	0	jsfs = jsc - j_halo ; jefs = jsc+1 ; jsfn = jec+1 ; jefn = min(jec + 1 + j_halo, jed+1)
311	0	else ; call MOM_error(FATAL, "pass_var_2d: wrong j-size for NORTH_FACE array.") ; endif
312	0	elseif (pos == EAST_FACE) then
313	0	if (size(array,1) == ied) then
314	0	isfw = max(isc - (i_halo+1), 1) ; iefw = isc ; isfe = iec ; iefe = iec + i_halo
315	0	elseif (size(array,1) == ied+1) then
316	0	isfw = isc - i_halo ; iefw = isc+1 ; isfe = iec+1 ; iefe = min(iec + 1 + i_halo, ied+1)
317	0	else ; call MOM_error(FATAL, "pass_var_2d: wrong i-size for EAST_FACE array.") ; endif
318	0	if (size(array,2) == jed) then
319	0	isfw = isc - i_halo ; iefw = isc ; isfe = iec ; iefe = iec + i_halo
320	0	else ; call MOM_error(FATAL, "pass_var_2d: wrong j-size for EAST_FACE array.") ; endif
321		else
322	0	call MOM_error(FATAL, "pass_var_2d: Unrecognized position")
323		endif
324
325		! Copy back the stored inner halo points
326	484	do j=jsfs,jefn ; do i=isfw,iefw ; array(i,j) = tmp(i,j) ; enddo ; enddo
327	415	do j=jsfs,jefn ; do i=isfe,iefe ; array(i,j) = tmp(i,j) ; enddo ; enddo
328	781	do j=jsfs,jefs ; do i=isfw,iefe ; array(i,j) = tmp(i,j) ; enddo ; enddo
329	651	do j=jsfn,jefn ; do i=isfw,iefe ; array(i,j) = tmp(i,j) ; enddo ; enddo
330
331	1	deallocate(tmp)
332		endif ; endif
333
334	106	if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif
335
336	106	end subroutine pass_var_2d
337
338		!> pass_var_start_2d starts a halo update for a two-dimensional array.
339	0	function pass_var_start_2d(array, MOM_dom, sideflag, position, complete, halo, &
340		clock)
341		real, dimension(:,:), intent(inout) :: array !< The array which is having its halos points
342		!! exchanged.
343		type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain
344		!! needed to determine where data should be
345		!! sent.
346		integer, optional, intent(in) :: sideflag !< An optional integer indicating which
347		!! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST,
348		!! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east,
349		!! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted.
350		integer, optional, intent(in) :: position !< An optional argument indicating the position.
351		!! This is CENTER by default and is often CORNER,
352		!! but could also be EAST_FACE or NORTH_FACE.
353		logical, optional, intent(in) :: complete !< An optional argument indicating whether the
354		!! halo updates should be completed before
355		!! progress resumes. Omitting complete is the
356		!! same as setting complete to .true.
357		integer, optional, intent(in) :: halo !< The size of the halo to update - the full
358		!! halo by default.
359		integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be
360		!! started then stopped to time this routine.
361		integer :: pass_var_start_2d !<The integer index for this update.
362
363		integer :: dirflag
364
365	0	if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif
366
367	0	dirflag = To_All ! 60
368	0	if (present(sideflag)) then ; if (sideflag > 0) dirflag = sideflag ; endif
369
370	0	if (present(halo) .and. MOM_dom%thin_halo_updates) then
371		pass_var_start_2d = mpp_start_update_domains(array, MOM_dom%mpp_domain, &
372		flags=dirflag, position=position, &
373	0	whalo=halo, ehalo=halo, shalo=halo, nhalo=halo)
374		else
375		pass_var_start_2d = mpp_start_update_domains(array, MOM_dom%mpp_domain, &
376	0	flags=dirflag, position=position)
377		endif
378
379	0	if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif
380
381	0	end function pass_var_start_2d
382
383		!> pass_var_start_3d starts a halo update for a three-dimensional array.
384	0	function pass_var_start_3d(array, MOM_dom, sideflag, position, complete, halo, &
385		clock)
386		real, dimension(:,:,:), intent(inout) :: array !< The array which is having its halos points
387		!! exchanged.
388		type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain
389		!! needed to determine where data should be
390		!! sent.
391		integer, optional, intent(in) :: sideflag !< An optional integer indicating which
392		!! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST,
393		!! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east,
394		!! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted.
395		integer, optional, intent(in) :: position !< An optional argument indicating the position.
396		!! This is CENTER by default and is often CORNER,
397		!! but could also be EAST_FACE or NORTH_FACE.
398		logical, optional, intent(in) :: complete !< An optional argument indicating whether the
399		!! halo updates should be completed before
400		!! progress resumes. Omitting complete is the
401		!! same as setting complete to .true.
402		integer, optional, intent(in) :: halo !< The size of the halo to update - the full
403		!! halo by default.
404		integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be
405		!! started then stopped to time this routine.
406		integer :: pass_var_start_3d !< The integer index for this update.
407
408		integer :: dirflag
409
410	0	if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif
411
412	0	dirflag = To_All ! 60
413	0	if (present(sideflag)) then ; if (sideflag > 0) dirflag = sideflag ; endif
414
415	0	if (present(halo) .and. MOM_dom%thin_halo_updates) then
416		pass_var_start_3d = mpp_start_update_domains(array, MOM_dom%mpp_domain, &
417		flags=dirflag, position=position, &
418	0	whalo=halo, ehalo=halo, shalo=halo, nhalo=halo)
419		else
420		pass_var_start_3d = mpp_start_update_domains(array, MOM_dom%mpp_domain, &
421	0	flags=dirflag, position=position)
422		endif
423
424	0	if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif
425
426	0	end function pass_var_start_3d
427
428		!> pass_var_complete_2d completes a halo update for a two-dimensional array.
429	0	subroutine pass_var_complete_2d(id_update, array, MOM_dom, sideflag, position, halo, &
430		clock)
431		integer, intent(in) :: id_update !< The integer id of this update which has
432		!! been returned from a previous call to
433		!! pass_var_start.
434		real, dimension(:,:), intent(inout) :: array !< The array which is having its halos points
435		!! exchanged.
436		type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain
437		!! needed to determine where data should be
438		!! sent.
439		integer, optional, intent(in) :: sideflag !< An optional integer indicating which
440		!! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST,
441		!! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east,
442		!! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted.
443		integer, optional, intent(in) :: position !< An optional argument indicating the position.
444		!! This is CENTER by default and is often CORNER,
445		!! but could also be EAST_FACE or NORTH_FACE.
446		integer, optional, intent(in) :: halo !< The size of the halo to update - the full
447		!! halo by default.
448		integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be
449		!! started then stopped to time this routine.
450
451		integer :: dirflag
452
453	0	if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif
454
455	0	dirflag = To_All ! 60
456	0	if (present(sideflag)) then ; if (sideflag > 0) dirflag = sideflag ; endif
457
458	0	if (present(halo) .and. MOM_dom%thin_halo_updates) then
459		call mpp_complete_update_domains(id_update, array, MOM_dom%mpp_domain, &
460		flags=dirflag, position=position, &
461	0	whalo=halo, ehalo=halo, shalo=halo, nhalo=halo)
462		else
463		call mpp_complete_update_domains(id_update, array, MOM_dom%mpp_domain, &
464	0	flags=dirflag, position=position)
465		endif
466
467	0	if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif
468
469	0	end subroutine pass_var_complete_2d
470
471		!> pass_var_complete_3d completes a halo update for a three-dimensional array.
472	0	subroutine pass_var_complete_3d(id_update, array, MOM_dom, sideflag, position, halo, &
473		clock)
474		integer, intent(in) :: id_update !< The integer id of this update which has
475		!! been returned from a previous call to
476		!! pass_var_start.
477		real, dimension(:,:,:), intent(inout) :: array !< The array which is having its halos points
478		!! exchanged.
479		type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain
480		!! needed to determine where data should be
481		!! sent.
482		integer, optional, intent(in) :: sideflag !< An optional integer indicating which
483		!! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST,
484		!! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east,
485		!! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted.
486		integer, optional, intent(in) :: position !< An optional argument indicating the position.
487		!! This is CENTER by default and is often CORNER,
488		!! but could also be EAST_FACE or NORTH_FACE.
489		integer, optional, intent(in) :: halo !< The size of the halo to update - the full
490		!! halo by default.
491		integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be
492		!! started then stopped to time this routine.
493
494		integer :: dirflag
495
496	0	if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif
497
498	0	dirflag = To_All ! 60
499	0	if (present(sideflag)) then ; if (sideflag > 0) dirflag = sideflag ; endif
500
501	0	if (present(halo) .and. MOM_dom%thin_halo_updates) then
502		call mpp_complete_update_domains(id_update, array, MOM_dom%mpp_domain, &
503		flags=dirflag, position=position, &
504	0	whalo=halo, ehalo=halo, shalo=halo, nhalo=halo)
505		else
506		call mpp_complete_update_domains(id_update, array, MOM_dom%mpp_domain, &
507	0	flags=dirflag, position=position)
508		endif
509
510	0	if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif
511
512	0	end subroutine pass_var_complete_3d
513
514		!> pass_vector_2d does a halo update for a pair of two-dimensional arrays
515		!! representing the components of a two-dimensional horizontal vector.
516	16	subroutine pass_vector_2d(u_cmpt, v_cmpt, MOM_dom, direction, stagger, complete, halo, &
517		clock)
518		real, dimension(:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector
519		!! pair which is having its halos points
520		!! exchanged.
521		real, dimension(:,:), intent(inout) :: v_cmpt !< The nominal meridional (v) component of the
522		!! vector pair which is having its halos points
523		!! exchanged.
524		type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain
525		!! needed to determine where data should be
526		!! sent.
527		integer, optional, intent(in) :: direction !< An optional integer indicating which
528		!! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST,
529		!! TO_NORTH, and TO_SOUTH, possibly plus SCALAR_PAIR if these are paired non-directional
530		!! scalars discretized at the typical vector component locations. For example, TO_EAST sends
531		!! the data to the processor to the east, so the halos on the western side are filled. TO_ALL
532		!! is the default if omitted.
533		integer, optional, intent(in) :: stagger !< An optional flag, which may be one of A_GRID,
534		!! BGRID_NE, or CGRID_NE, indicating where the two components of the vector are
535		!! discretized. Omitting stagger is the same as setting it to CGRID_NE.
536		logical, optional, intent(in) :: complete !< An optional argument indicating whether the
537		!! halo updates should be completed before progress resumes.
538		!! Omitting complete is the same as setting complete to .true.
539		integer, optional, intent(in) :: halo !< The size of the halo to update - the full
540		!! halo by default.
541		integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be
542		!! started then stopped to time this routine.
543
544		! Local variables
545		integer :: stagger_local
546		integer :: dirflag
547		logical :: block_til_complete
548
549	16	if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif
550
551	16	stagger_local = CGRID_NE ! Default value for type of grid
552	16	if (present(stagger)) stagger_local = stagger
553
554	16	dirflag = To_All ! 60
555	16	if (present(direction)) then ; if (direction > 0) dirflag = direction ; endif
556	16	block_til_complete = .true.
557	16	if (present(complete)) block_til_complete = complete
558
559	16	if (present(halo) .and. MOM_dom%thin_halo_updates) then
560		call mpp_update_domains(u_cmpt, v_cmpt, MOM_dom%mpp_domain, flags=dirflag, &
561		gridtype=stagger_local, complete = block_til_complete, &
562	0	whalo=halo, ehalo=halo, shalo=halo, nhalo=halo)
563		else
564		call mpp_update_domains(u_cmpt, v_cmpt, MOM_dom%mpp_domain, flags=dirflag, &
565	16	gridtype=stagger_local, complete = block_til_complete)
566		endif
567
568	16	if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif
569
570	16	end subroutine pass_vector_2d
571
572		!> fill_vector_symmetric_edges_2d does an usual set of halo updates that only
573		!! fill in the values at the edge of a pair of symmetric memory two-dimensional
574		!! arrays representing the components of a two-dimensional horizontal vector.
575		!! If symmetric memory is not being used, this subroutine does nothing except to
576		!! possibly turn optional cpu clocks on or off.
577	0	subroutine fill_vector_symmetric_edges_2d(u_cmpt, v_cmpt, MOM_dom, stagger, scalar, &
578		clock)
579		real, dimension(:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector
580		!! pair which is having its halos points
581		!! exchanged.
582		real, dimension(:,:), intent(inout) :: v_cmpt !< The nominal meridional (v) component of the
583		!! vector pair which is having its halos points
584		!! exchanged.
585		type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain
586		!! needed to determine where data should be
587		!! sent.
588		integer, optional, intent(in) :: stagger !< An optional flag, which may be one of A_GRID,
589		!! BGRID_NE, or CGRID_NE, indicating where the two components of the vector are
590		!! discretized. Omitting stagger is the same as setting it to CGRID_NE.
591		logical, optional, intent(in) :: scalar !< An optional argument indicating whether.
592		integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be
593		!! started then stopped to time this routine.
594
595		! Local variables
596		integer :: stagger_local
597		integer :: dirflag
598		integer :: i, j, isc, iec, jsc, jec, isd, ied, jsd, jed, IscB, IecB, JscB, JecB
599	0	real, allocatable, dimension(:) :: sbuff_x, sbuff_y, wbuff_x, wbuff_y
600		logical :: block_til_complete
601
602	0	if (.not. MOM_dom%symmetric) then
603	0	return
604		endif
605
606	0	if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif
607
608	0	stagger_local = CGRID_NE ! Default value for type of grid
609	0	if (present(stagger)) stagger_local = stagger
610
611	0	if (.not.(stagger_local == CGRID_NE .or. stagger_local == BGRID_NE)) return
612
613	0	call mpp_get_compute_domain(MOM_dom%mpp_domain, isc, iec, jsc, jec)
614	0	call mpp_get_data_domain(MOM_dom%mpp_domain, isd, ied, jsd, jed)
615
616		! Adjust isc, etc., to account for the fact that the input arrays indices all
617		! start at 1 (and are effectively on a SW grid!).
618	0	isc = isc - (isd-1) ; iec = iec - (isd-1)
619	0	jsc = jsc - (jsd-1) ; jec = jec - (jsd-1)
620	0	IscB = isc ; IecB = iec+1 ; JscB = jsc ; JecB = jec+1
621
622	0	dirflag = To_All ! 60
623	0	if (present(scalar)) then ; if (scalar) dirflag = To_All+SCALAR_PAIR ; endif
624
625	0	if (stagger_local == CGRID_NE) then
626	0	allocate(wbuff_x(jsc:jec)) ; allocate(sbuff_y(isc:iec))
627	0	wbuff_x(:) = 0.0 ; sbuff_y(:) = 0.0
628		call mpp_get_boundary(u_cmpt, v_cmpt, MOM_dom%mpp_domain, flags=dirflag, &
629		wbufferx=wbuff_x, sbuffery=sbuff_y, &
630	0	gridtype=CGRID_NE)
631	0	do i=isc,iec
632	0	v_cmpt(i,JscB) = sbuff_y(i)
633		enddo
634	0	do j=jsc,jec
635	0	u_cmpt(IscB,j) = wbuff_x(j)
636		enddo
637	0	deallocate(wbuff_x) ; deallocate(sbuff_y)
638	0	elseif (stagger_local == BGRID_NE) then
639	0	allocate(wbuff_x(JscB:JecB)) ; allocate(sbuff_x(IscB:IecB))
640	0	allocate(wbuff_y(JscB:JecB)) ; allocate(sbuff_y(IscB:IecB))
641	0	wbuff_x(:) = 0.0 ; wbuff_y(:) = 0.0 ; sbuff_x(:) = 0.0 ; sbuff_y(:) = 0.0
642		call mpp_get_boundary(u_cmpt, v_cmpt, MOM_dom%mpp_domain, flags=dirflag, &
643		wbufferx=wbuff_x, sbufferx=sbuff_x, &
644		wbuffery=wbuff_y, sbuffery=sbuff_y, &
645	0	gridtype=BGRID_NE)
646	0	do I=IscB,IecB
647	0	u_cmpt(I,JscB) = sbuff_x(I) ; v_cmpt(I,JscB) = sbuff_y(I)
648		enddo
649	0	do J=JscB,JecB
650	0	u_cmpt(IscB,J) = wbuff_x(J) ; v_cmpt(IscB,J) = wbuff_y(J)
651		enddo
652	0	deallocate(wbuff_x) ; deallocate(sbuff_x)
653	0	deallocate(wbuff_y) ; deallocate(sbuff_y)
654		endif
655
656	0	if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif
657
658	0	end subroutine fill_vector_symmetric_edges_2d
659
660		!> pass_vector_3d does a halo update for a pair of three-dimensional arrays
661		!! representing the components of a three-dimensional horizontal vector.
662	3	subroutine pass_vector_3d(u_cmpt, v_cmpt, MOM_dom, direction, stagger, complete, halo, &
663		clock)
664		real, dimension(:,:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector
665		!! pair which is having its halos points
666		!! exchanged.
667		real, dimension(:,:,:), intent(inout) :: v_cmpt !< The nominal meridional (v) component of the
668		!! vector pair which is having its halos points
669		!! exchanged.
670		type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain
671		!! needed to determine where data should be
672		!! sent.
673		integer, optional, intent(in) :: direction !< An optional integer indicating which
674		!! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST,
675		!! TO_NORTH, and TO_SOUTH, possibly plus SCALAR_PAIR if these are paired non-directional
676		!! scalars discretized at the typical vector component locations. For example, TO_EAST sends
677		!! the data to the processor to the east, so the halos on the western side are filled. TO_ALL
678		!! is the default if omitted.
679		integer, optional, intent(in) :: stagger !< An optional flag, which may be one of A_GRID,
680		!! BGRID_NE, or CGRID_NE, indicating where the two components of the vector are
681		!! discretized. Omitting stagger is the same as setting it to CGRID_NE.
682		logical, optional, intent(in) :: complete !< An optional argument indicating whether the
683		!! halo updates should be completed before progress resumes.
684		!! Omitting complete is the same as setting complete to .true.
685		integer, optional, intent(in) :: halo !< The size of the halo to update - the full
686		!! halo by default.
687		integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be
688		!! started then stopped to time this routine.
689
690		! Local variables
691		integer :: stagger_local
692		integer :: dirflag
693		logical :: block_til_complete
694
695	3	if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif
696
697	3	stagger_local = CGRID_NE ! Default value for type of grid
698	3	if (present(stagger)) stagger_local = stagger
699
700	3	dirflag = To_All ! 60
701	3	if (present(direction)) then ; if (direction > 0) dirflag = direction ; endif
702	3	block_til_complete = .true.
703	3	if (present(complete)) block_til_complete = complete
704
705	3	if (present(halo) .and. MOM_dom%thin_halo_updates) then
706		call mpp_update_domains(u_cmpt, v_cmpt, MOM_dom%mpp_domain, flags=dirflag, &
707		gridtype=stagger_local, complete = block_til_complete, &
708	2	whalo=halo, ehalo=halo, shalo=halo, nhalo=halo)
709		else
710		call mpp_update_domains(u_cmpt, v_cmpt, MOM_dom%mpp_domain, flags=dirflag, &
711	1	gridtype=stagger_local, complete = block_til_complete)
712		endif
713
714	3	if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif
715
716	3	end subroutine pass_vector_3d
717
718		!> pass_vector_start_2d starts a halo update for a pair of two-dimensional arrays
719		!! representing the components of a two-dimensional horizontal vector.
720	0	function pass_vector_start_2d(u_cmpt, v_cmpt, MOM_dom, direction, stagger, complete, halo, &
721		clock)
722		real, dimension(:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector
723		!! pair which is having its halos points
724		!! exchanged.
725		real, dimension(:,:), intent(inout) :: v_cmpt !< The nominal meridional (v) component of the
726		!! vector pair which is having its halos points
727		!! exchanged.
728		type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain
729		!! needed to determine where data should be
730		!! sent.
731		integer, optional, intent(in) :: direction !< An optional integer indicating which
732		!! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST,
733		!! TO_NORTH, and TO_SOUTH, possibly plus SCALAR_PAIR if these are paired non-directional
734		!! scalars discretized at the typical vector component locations. For example, TO_EAST sends
735		!! the data to the processor to the east, so the halos on the western side are filled. TO_ALL
736		!! is the default if omitted.
737		integer, optional, intent(in) :: stagger !< An optional flag, which may be one of A_GRID,
738		!! BGRID_NE, or CGRID_NE, indicating where the two components of the vector are
739		!! discretized. Omitting stagger is the same as setting it to CGRID_NE.
740		logical, optional, intent(in) :: complete !< An optional argument indicating whether the
741		!! halo updates should be completed before progress resumes.
742		!! Omitting complete is the same as setting complete to .true.
743		integer, optional, intent(in) :: halo !< The size of the halo to update - the full
744		!! halo by default.
745		integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be
746		!! started then stopped to time this routine.
747		integer :: pass_vector_start_2d !< The integer index for this
748		!! update.
749
750		! Local variables
751		integer :: stagger_local
752		integer :: dirflag
753
754	0	if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif
755
756	0	stagger_local = CGRID_NE ! Default value for type of grid
757	0	if (present(stagger)) stagger_local = stagger
758
759	0	dirflag = To_All ! 60
760	0	if (present(direction)) then ; if (direction > 0) dirflag = direction ; endif
761
762	0	if (present(halo) .and. MOM_dom%thin_halo_updates) then
763		pass_vector_start_2d = mpp_start_update_domains(u_cmpt, v_cmpt, &
764		MOM_dom%mpp_domain, flags=dirflag, gridtype=stagger_local, &
765	0	whalo=halo, ehalo=halo, shalo=halo, nhalo=halo)
766		else
767		pass_vector_start_2d = mpp_start_update_domains(u_cmpt, v_cmpt, &
768	0	MOM_dom%mpp_domain, flags=dirflag, gridtype=stagger_local)
769		endif
770
771	0	if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif
772
773	0	end function pass_vector_start_2d
774
775		!> pass_vector_start_3d starts a halo update for a pair of three-dimensional arrays
776		!! representing the components of a three-dimensional horizontal vector.
777	0	function pass_vector_start_3d(u_cmpt, v_cmpt, MOM_dom, direction, stagger, complete, halo, &
778		clock)
779		real, dimension(:,:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector
780		!! pair which is having its halos points
781		!! exchanged.
782		real, dimension(:,:,:), intent(inout) :: v_cmpt !< The nominal meridional (v) component of the
783		!! vector pair which is having its halos points
784		!! exchanged.
785		type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain
786		!! needed to determine where data should be
787		!! sent.
788		integer, optional, intent(in) :: direction !< An optional integer indicating which
789		!! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST,
790		!! TO_NORTH, and TO_SOUTH, possibly plus SCALAR_PAIR if these are paired non-directional
791		!! scalars discretized at the typical vector component locations. For example, TO_EAST sends
792		!! the data to the processor to the east, so the halos on the western side are filled. TO_ALL
793		!! is the default if omitted.
794		integer, optional, intent(in) :: stagger !< An optional flag, which may be one of A_GRID,
795		!! BGRID_NE, or CGRID_NE, indicating where the two components of the vector are
796		!! discretized. Omitting stagger is the same as setting it to CGRID_NE.
797		logical, optional, intent(in) :: complete !< An optional argument indicating whether the
798		!! halo updates should be completed before progress resumes.
799		!! Omitting complete is the same as setting complete to .true.
800		integer, optional, intent(in) :: halo !< The size of the halo to update - the full
801		!! halo by default.
802		integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be
803		!! started then stopped to time this routine.
804		integer :: pass_vector_start_3d !< The integer index for this
805		!! update.
806		! Local variables
807		integer :: stagger_local
808		integer :: dirflag
809
810	0	if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif
811
812	0	stagger_local = CGRID_NE ! Default value for type of grid
813	0	if (present(stagger)) stagger_local = stagger
814
815	0	dirflag = To_All ! 60
816	0	if (present(direction)) then ; if (direction > 0) dirflag = direction ; endif
817
818	0	if (present(halo) .and. MOM_dom%thin_halo_updates) then
819		pass_vector_start_3d = mpp_start_update_domains(u_cmpt, v_cmpt, &
820		MOM_dom%mpp_domain, flags=dirflag, gridtype=stagger_local, &
821	0	whalo=halo, ehalo=halo, shalo=halo, nhalo=halo)
822		else
823		pass_vector_start_3d = mpp_start_update_domains(u_cmpt, v_cmpt, &
824	0	MOM_dom%mpp_domain, flags=dirflag, gridtype=stagger_local)
825		endif
826
827	0	if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif
828
829	0	end function pass_vector_start_3d
830
831		!> pass_vector_complete_2d completes a halo update for a pair of two-dimensional arrays
832		!! representing the components of a two-dimensional horizontal vector.
833	0	subroutine pass_vector_complete_2d(id_update, u_cmpt, v_cmpt, MOM_dom, direction, stagger, halo, &
834		clock)
835		integer, intent(in) :: id_update !< The integer id of this update which has been
836		!! returned from a previous call to
837		!! pass_var_start.
838		real, dimension(:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector
839		!! pair which is having its halos points
840		!! exchanged.
841		real, dimension(:,:), intent(inout) :: v_cmpt !< The nominal meridional (v) component of the
842		!! vector pair which is having its halos points
843		!! exchanged.
844		type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain
845		!! needed to determine where data should be
846		!! sent.
847		integer, optional, intent(in) :: direction !< An optional integer indicating which
848		!! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST,
849		!! TO_NORTH, and TO_SOUTH, possibly plus SCALAR_PAIR if these are paired non-directional
850		!! scalars discretized at the typical vector component locations. For example, TO_EAST sends
851		!! the data to the processor to the east, so the halos on the western side are filled. TO_ALL
852		!! is the default if omitted.
853		integer, optional, intent(in) :: stagger !< An optional flag, which may be one of A_GRID,
854		!! BGRID_NE, or CGRID_NE, indicating where the two components of the vector are
855		!! discretized. Omitting stagger is the same as setting it to CGRID_NE.
856		integer, optional, intent(in) :: halo !< The size of the halo to update - the full
857		!! halo by default.
858		integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be
859		!! started then stopped to time this routine.
860		! Local variables
861		integer :: stagger_local
862		integer :: dirflag
863
864	0	if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif
865
866	0	stagger_local = CGRID_NE ! Default value for type of grid
867	0	if (present(stagger)) stagger_local = stagger
868
869	0	dirflag = To_All ! 60
870	0	if (present(direction)) then ; if (direction > 0) dirflag = direction ; endif
871
872	0	if (present(halo) .and. MOM_dom%thin_halo_updates) then
873		call mpp_complete_update_domains(id_update, u_cmpt, v_cmpt, &
874		MOM_dom%mpp_domain, flags=dirflag, gridtype=stagger_local, &
875	0	whalo=halo, ehalo=halo, shalo=halo, nhalo=halo)
876		else
877		call mpp_complete_update_domains(id_update, u_cmpt, v_cmpt, &
878	0	MOM_dom%mpp_domain, flags=dirflag, gridtype=stagger_local)
879		endif
880
881	0	if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif
882
883	0	end subroutine pass_vector_complete_2d
884
885		!> pass_vector_complete_3d completes a halo update for a pair of three-dimensional
886		!! arrays representing the components of a three-dimensional horizontal vector.
887	0	subroutine pass_vector_complete_3d(id_update, u_cmpt, v_cmpt, MOM_dom, direction, stagger, halo, &
888		clock)
889		integer, intent(in) :: id_update !< The integer id of this update which has been
890		!! returned from a previous call to
891		!! pass_var_start.
892		real, dimension(:,:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector
893		!! pair which is having its halos points
894		!! exchanged.
895		real, dimension(:,:,:), intent(inout) :: v_cmpt !< The nominal meridional (v) component of the
896		!! vector pair which is having its halos points
897		!! exchanged.
898		type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain
899		!! needed to determine where data should be
900		!! sent.
901		integer, optional, intent(in) :: direction !< An optional integer indicating which
902		!! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST,
903		!! TO_NORTH, and TO_SOUTH, possibly plus SCALAR_PAIR if these are paired non-directional
904		!! scalars discretized at the typical vector component locations. For example, TO_EAST sends
905		!! the data to the processor to the east, so the halos on the western side are filled. TO_ALL
906		!! is the default if omitted.
907		integer, optional, intent(in) :: stagger !< An optional flag, which may be one of A_GRID,
908		!! BGRID_NE, or CGRID_NE, indicating where the two components of the vector are
909		!! discretized. Omitting stagger is the same as setting it to CGRID_NE.
910		integer, optional, intent(in) :: halo !< The size of the halo to update - the full
911		!! halo by default.
912		integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be
913		!! started then stopped to time this routine.
914		! Local variables
915		integer :: stagger_local
916		integer :: dirflag
917
918	0	if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif
919
920	0	stagger_local = CGRID_NE ! Default value for type of grid
921	0	if (present(stagger)) stagger_local = stagger
922
923	0	dirflag = To_All ! 60
924	0	if (present(direction)) then ; if (direction > 0) dirflag = direction ; endif
925
926	0	if (present(halo) .and. MOM_dom%thin_halo_updates) then
927		call mpp_complete_update_domains(id_update, u_cmpt, v_cmpt, &
928		MOM_dom%mpp_domain, flags=dirflag, gridtype=stagger_local, &
929	0	whalo=halo, ehalo=halo, shalo=halo, nhalo=halo)
930		else
931		call mpp_complete_update_domains(id_update, u_cmpt, v_cmpt, &
932	0	MOM_dom%mpp_domain, flags=dirflag, gridtype=stagger_local)
933		endif
934
935	0	if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif
936
937	0	end subroutine pass_vector_complete_3d
938
939		!> create_var_group_pass_2d sets up a group of two-dimensional array halo updates.
940	294	subroutine create_var_group_pass_2d(group, array, MOM_dom, sideflag, position, &
941		halo, clock)
942		type(group_pass_type), intent(inout) :: group !< The data type that store information for
943		!! group update. This data will be used in
944		!! do_group_pass.
945		real, dimension(:,:), intent(inout) :: array !< The array which is having its halos points
946		!! exchanged.
947		type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain
948		!! needed to determine where data should be
949		!! sent.
950		integer, optional, intent(in) :: sideflag !< An optional integer indicating which
951		!! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST,
952		!! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east,
953		!! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted.
954		integer, optional, intent(in) :: position !< An optional argument indicating the position.
955		!! This is CENTER by default and is often CORNER,
956		!! but could also be EAST_FACE or NORTH_FACE.
957		integer, optional, intent(in) :: halo !< The size of the halo to update - the full
958		!! halo by default.
959		integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be
960		!! started then stopped to time this routine.
961		! Local variables
962		integer :: dirflag
963
964	294	if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif
965
966	294	dirflag = To_All ! 60
967	294	if (present(sideflag)) then ; if (sideflag > 0) dirflag = sideflag ; endif
968
969	294	if (mpp_group_update_initialized(group)) then
970	245	call mpp_reset_group_update_field(group,array)
971	49	elseif (present(halo) .and. MOM_dom%thin_halo_updates) then
972		call mpp_create_group_update(group, array, MOM_dom%mpp_domain, flags=dirflag, &
973		position=position, whalo=halo, ehalo=halo, &
974	1	shalo=halo, nhalo=halo)
975		else
976		call mpp_create_group_update(group, array, MOM_dom%mpp_domain, flags=dirflag, &
977	48	position=position)
978		endif
979
980	294	if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif
981
982	294	end subroutine create_var_group_pass_2d
983
984		!> create_var_group_pass_3d sets up a group of three-dimensional array halo updates.
985	234	subroutine create_var_group_pass_3d(group, array, MOM_dom, sideflag, position, halo, &
986		clock)
987		type(group_pass_type), intent(inout) :: group !< The data type that store information for
988		!! group update. This data will be used in
989		!! do_group_pass.
990		real, dimension(:,:,:), intent(inout) :: array !< The array which is having its halos points
991		!! exchanged.
992		type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain
993		!! needed to determine where data should be
994		!! sent.
995		integer, optional, intent(in) :: sideflag !< An optional integer indicating which
996		!! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST,
997		!! TO_NORTH, and TO_SOUTH. For example, TO_EAST sends the data to the processor to the east,
998		!! so the halos on the western side are filled. TO_ALL is the default if sideflag is omitted.
999		integer, optional, intent(in) :: position !< An optional argument indicating the position.
1000		!! This is CENTER by default and is often CORNER,
1001		!! but could also be EAST_FACE or NORTH_FACE.
1002		integer, optional, intent(in) :: halo !< The size of the halo to update - the full
1003		!! halo by default.
1004		integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be
1005		!! started then stopped to time this routine.
1006		! Local variables
1007		integer :: dirflag
1008
1009	234	if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif
1010
1011	234	dirflag = To_All ! 60
1012	234	if (present(sideflag)) then ; if (sideflag > 0) dirflag = sideflag ; endif
1013
1014	234	if (mpp_group_update_initialized(group)) then
1015	123	call mpp_reset_group_update_field(group,array)
1016	111	elseif (present(halo) .and. MOM_dom%thin_halo_updates) then
1017		call mpp_create_group_update(group, array, MOM_dom%mpp_domain, flags=dirflag, &
1018		position=position, whalo=halo, ehalo=halo, &
1019	101	shalo=halo, nhalo=halo)
1020		else
1021		call mpp_create_group_update(group, array, MOM_dom%mpp_domain, flags=dirflag, &
1022	10	position=position)
1023		endif
1024
1025	234	if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif
1026
1027	234	end subroutine create_var_group_pass_3d
1028
1029		!> create_vector_group_pass_2d sets up a group of two-dimensional vector halo updates.
1030	834	subroutine create_vector_group_pass_2d(group, u_cmpt, v_cmpt, MOM_dom, direction, stagger, halo, &
1031		clock)
1032		type(group_pass_type), intent(inout) :: group !< The data type that store information for
1033		!! group update. This data will be used in
1034		!! do_group_pass.
1035		real, dimension(:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector
1036		!! pair which is having its halos points
1037		!! exchanged.
1038		real, dimension(:,:), intent(inout) :: v_cmpt !< The nominal meridional (v) component of the
1039		!! vector pair which is having its halos points
1040		!! exchanged.
1041
1042		type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain
1043		!! needed to determine where data should be
1044		!! sent
1045		integer, optional, intent(in) :: direction !< An optional integer indicating which
1046		!! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST,
1047		!! TO_NORTH, and TO_SOUTH, possibly plus SCALAR_PAIR if these are paired non-directional
1048		!! scalars discretized at the typical vector component locations. For example, TO_EAST sends
1049		!! the data to the processor to the east, so the halos on the western side are filled. TO_ALL
1050		!! is the default if omitted.
1051		integer, optional, intent(in) :: stagger !< An optional flag, which may be one of A_GRID,
1052		!! BGRID_NE, or CGRID_NE, indicating where the two components of the vector are
1053		!! discretized. Omitting stagger is the same as setting it to CGRID_NE.
1054		integer, optional, intent(in) :: halo !< The size of the halo to update - the full
1055		!! halo by default.
1056		integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be
1057		!! started then stopped to time this routine.
1058		! Local variables
1059		integer :: stagger_local
1060		integer :: dirflag
1061
1062	834	if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif
1063
1064	834	stagger_local = CGRID_NE ! Default value for type of grid
1065	834	if (present(stagger)) stagger_local = stagger
1066
1067	834	dirflag = To_All ! 60
1068	834	if (present(direction)) then ; if (direction > 0) dirflag = direction ; endif
1069
1070	834	if (mpp_group_update_initialized(group)) then
1071	799	call mpp_reset_group_update_field(group,u_cmpt, v_cmpt)
1072	35	elseif (present(halo) .and. MOM_dom%thin_halo_updates) then
1073		call mpp_create_group_update(group, u_cmpt, v_cmpt, MOM_dom%mpp_domain, &
1074		flags=dirflag, gridtype=stagger_local, whalo=halo, ehalo=halo, &
1075	0	shalo=halo, nhalo=halo)
1076		else
1077		call mpp_create_group_update(group, u_cmpt, v_cmpt, MOM_dom%mpp_domain, &
1078	35	flags=dirflag, gridtype=stagger_local)
1079		endif
1080
1081	834	if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif
1082
1083	834	end subroutine create_vector_group_pass_2d
1084
1085		!> create_vector_group_pass_3d sets up a group of three-dimensional vector halo updates.
1086	196	subroutine create_vector_group_pass_3d(group, u_cmpt, v_cmpt, MOM_dom, direction, stagger, halo, &
1087		clock)
1088		type(group_pass_type), intent(inout) :: group !< The data type that store information for
1089		!! group update. This data will be used in
1090		!! do_group_pass.
1091		real, dimension(:,:,:), intent(inout) :: u_cmpt !< The nominal zonal (u) component of the vector
1092		!! pair which is having its halos points
1093		!! exchanged.
1094		real, dimension(:,:,:), intent(inout) :: v_cmpt !< The nominal meridional (v) component of the
1095		!! vector pair which is having its halos points
1096		!! exchanged.
1097
1098		type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain
1099		!! needed to determine where data should be
1100		!! sent.
1101		integer, optional, intent(in) :: direction !< An optional integer indicating which
1102		!! directions the data should be sent. It is TO_ALL or the sum of any of TO_EAST, TO_WEST,
1103		!! TO_NORTH, and TO_SOUTH, possibly plus SCALAR_PAIR if these are paired non-directional
1104		!! scalars discretized at the typical vector component locations. For example, TO_EAST sends
1105		!! the data to the processor to the east, so the halos on the western side are filled. TO_ALL
1106		!! is the default if omitted.
1107		integer, optional, intent(in) :: stagger !< An optional flag, which may be one of A_GRID,
1108		!! BGRID_NE, or CGRID_NE, indicating where the two components of the vector are
1109		!! discretized. Omitting stagger is the same as setting it to CGRID_NE.
1110		integer, optional, intent(in) :: halo !< The size of the halo to update - the full
1111		!! halo by default.
1112		integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be
1113		!! started then stopped to time this routine.
1114
1115		! Local variables
1116		integer :: stagger_local
1117		integer :: dirflag
1118
1119	196	if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif
1120
1121	196	stagger_local = CGRID_NE ! Default value for type of grid
1122	196	if (present(stagger)) stagger_local = stagger
1123
1124	196	dirflag = To_All ! 60
1125	196	if (present(direction)) then ; if (direction > 0) dirflag = direction ; endif
1126
1127	196	if (mpp_group_update_initialized(group)) then
1128	172	call mpp_reset_group_update_field(group,u_cmpt, v_cmpt)
1129	24	elseif (present(halo) .and. MOM_dom%thin_halo_updates) then
1130		call mpp_create_group_update(group, u_cmpt, v_cmpt, MOM_dom%mpp_domain, &
1131		flags=dirflag, gridtype=stagger_local, whalo=halo, ehalo=halo, &
1132	22	shalo=halo, nhalo=halo)
1133		else
1134		call mpp_create_group_update(group, u_cmpt, v_cmpt, MOM_dom%mpp_domain, &
1135	2	flags=dirflag, gridtype=stagger_local)
1136		endif
1137
1138	196	if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif
1139
1140	196	end subroutine create_vector_group_pass_3d
1141
1142		!> do_group_pass carries out a group halo update.
1143	939	subroutine do_group_pass(group, MOM_dom, clock, omp_offload)
1144		type(group_pass_type), intent(inout) :: group !< The data type that store information for
1145		!! group update. This data will be used in
1146		!! do_group_pass.
1147		type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain
1148		!! needed to determine where data should be
1149		!! sent.
1150		integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be
1151		!! started then stopped to time this routine.
1152		logical, optional, intent(in) :: omp_offload !< Whether the data to be transferred is
1153		!! offloaded to the GPU with OpenMP.
1154		real :: d_type
1155
1156	939	if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif
1157
1158	939	call mpp_do_group_update(group, MOM_dom%mpp_domain, d_type, omp_offload)
1159
1160	939	if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif
1161
1162	939	end subroutine do_group_pass
1163
1164		!> start_group_pass starts out a group halo update.
1165	0	subroutine start_group_pass(group, MOM_dom, clock)
1166		type(group_pass_type), intent(inout) :: group !< The data type that store information for
1167		!! group update. This data will be used in
1168		!! do_group_pass.
1169		type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain
1170		!! needed to determine where data should be
1171		!! sent.
1172		integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be
1173		!! started then stopped to time this routine.
1174
1175		real :: d_type
1176
1177	0	if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif
1178
1179	0	call mpp_start_group_update(group, MOM_dom%mpp_domain, d_type)
1180
1181	0	if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif
1182
1183	0	end subroutine start_group_pass
1184
1185		!> complete_group_pass completes a group halo update.
1186	0	subroutine complete_group_pass(group, MOM_dom, clock)
1187		type(group_pass_type), intent(inout) :: group !< The data type that store information for
1188		!! group update. This data will be used in
1189		!! do_group_pass.
1190		type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain
1191		!! needed to determine where data should be
1192		!! sent.
1193		integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be
1194		!! started then stopped to time this routine.
1195		real :: d_type
1196
1197	0	if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif
1198
1199	0	call mpp_complete_group_update(group, MOM_dom%mpp_domain, d_type)
1200
1201	0	if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif
1202
1203	0	end subroutine complete_group_pass
1204
1205
1206		!> Pass a 2-D array from one MOM domain to another
1207	0	subroutine redistribute_array_2d(Domain1, array1, Domain2, array2, complete)
1208		type(domain2d), &
1209		intent(in) :: Domain1 !< The MOM domain from which to extract information.
1210		real, dimension(:,:), intent(in) :: array1 !< The array from which to extract information.
1211		type(domain2d), &
1212		intent(in) :: Domain2 !< The MOM domain receiving information.
1213		real, dimension(:,:), intent(out) :: array2 !< The array receiving information.
1214		logical, optional, intent(in) :: complete !< If true, finish communication before proceeding.
1215
1216		! Local variables
1217		logical :: do_complete
1218
1219	0	do_complete=.true. ; if (PRESENT(complete)) do_complete = complete
1220
1221	0	call mpp_redistribute(Domain1, array1, Domain2, array2, do_complete)
1222
1223	0	end subroutine redistribute_array_2d
1224
1225		!> Pass a 3-D array from one MOM domain to another
1226	0	subroutine redistribute_array_3d(Domain1, array1, Domain2, array2, complete)
1227		type(domain2d), &
1228		intent(in) :: Domain1 !< The MOM domain from which to extract information.
1229		real, dimension(:,:,:), intent(in) :: array1 !< The array from which to extract information.
1230		type(domain2d), &
1231		intent(in) :: Domain2 !< The MOM domain receiving information.
1232		real, dimension(:,:,:), intent(out) :: array2 !< The array receiving information.
1233		logical, optional, intent(in) :: complete !< If true, finish communication before proceeding.
1234
1235		! Local variables
1236		logical :: do_complete
1237
1238	0	do_complete=.true. ; if (PRESENT(complete)) do_complete = complete
1239
1240	0	call mpp_redistribute(Domain1, array1, Domain2, array2, do_complete)
1241
1242	0	end subroutine redistribute_array_3d
1243
1244		!> Pass a 4-D array from one MOM domain to another
1245	0	subroutine redistribute_array_4d(Domain1, array1, Domain2, array2, complete)
1246		type(domain2d), &
1247		intent(in) :: Domain1 !< The MOM domain from which to extract information.
1248		real, dimension(:,:,:,:), intent(in) :: array1 !< The array from which to extract information.
1249		type(domain2d), &
1250		intent(in) :: Domain2 !< The MOM domain receiving information.
1251		real, dimension(:,:,:,:), intent(out) :: array2 !< The array receiving information.
1252		logical, optional, intent(in) :: complete !< If true, finish communication before proceeding.
1253
1254		! Local variables
1255		logical :: do_complete
1256
1257	0	do_complete=.true. ; if (PRESENT(complete)) do_complete = complete
1258
1259	0	call mpp_redistribute(Domain1, array1, Domain2, array2, do_complete)
1260
1261	0	end subroutine redistribute_array_4d
1262
1263
1264		!> Rescale the values of a 4-D array in its computational domain by a constant factor
1265	0	subroutine rescale_comp_data_4d(domain, array, scale, zero_zeros)
1266		type(MOM_domain_type), intent(in) :: domain !< MOM domain from which to extract information
1267		real, dimension(:,:,:,:), intent(inout) :: array !< The array which is having the data in its
1268		!! computational domain rescaled
1269		real, intent(in) :: scale !< A scaling factor by which to multiply the
1270		!! values in the computational domain of array
1271		logical, optional, intent(in) :: zero_zeros !< If present and true, convert negative zeros
1272		!! into ordinary signless zeros.
1273		logical :: unsign_zeros ! If true, convert negative zeros into ordinary signless zeros.
1274		integer :: is, ie, js, je, i, j, k, m
1275
1276	0	unsign_zeros = .false. ; if (present(zero_zeros)) unsign_zeros = zero_zeros
1277
1278	0	if ((scale == 1.0) .and. (.not.unsign_zeros)) return
1279
1280	0	call get_simple_array_i_ind(domain, size(array,1), is, ie)
1281	0	call get_simple_array_j_ind(domain, size(array,2), js, je)
1282	0	if (scale /= 1.0) &
1283	0	array(is:ie,js:je,:,:) = scale*array(is:ie,js:je,:,:)
1284
1285	0	if (unsign_zeros) then ! Convert negative zeros into zeros
1286	0	do m=1,size(array,4) ; do k=1,size(array,3) ; do j=js,je ; do i=is,ie
1287	0	if (array(i,j,k,m) == 0.0) array(i,j,k,m) = 0.0
1288		enddo ; enddo ; enddo ; enddo
1289		endif
1290
1291		end subroutine rescale_comp_data_4d
1292
1293		!> Rescale the values of a 3-D array in its computational domain by a constant factor
1294	31	subroutine rescale_comp_data_3d(domain, array, scale, zero_zeros)
1295		type(MOM_domain_type), intent(in) :: domain !< MOM domain from which to extract information
1296		real, dimension(:,:,:), intent(inout) :: array !< The array which is having the data in its
1297		!! computational domain rescaled
1298		real, intent(in) :: scale !< A scaling factor by which to multiply the
1299		!! values in the computational domain of array
1300		logical, optional, intent(in) :: zero_zeros !< If present and true, convert negative zeros
1301		!! into ordinary signless zeros.
1302		logical :: unsign_zeros ! If true, convert negative zeros into ordinary signless zeros.
1303		integer :: is, ie, js, je, i, j, k
1304
1305	31	unsign_zeros = .false. ; if (present(zero_zeros)) unsign_zeros = zero_zeros
1306
1307	31	if ((scale == 1.0) .and. (.not.unsign_zeros)) return
1308
1309	0	call get_simple_array_i_ind(domain, size(array,1), is, ie)
1310	0	call get_simple_array_j_ind(domain, size(array,2), js, je)
1311	0	if (scale /= 1.0) &
1312	0	array(is:ie,js:je,:) = scale*array(is:ie,js:je,:)
1313
1314	0	if (unsign_zeros) then ! Convert negative zeros into zeros
1315	0	do k=1,size(array,3) ; do j=js,je ; do i=is,ie
1316	0	if (array(i,j,k) == 0.0) array(i,j,k) = 0.0
1317		enddo ; enddo ; enddo
1318		endif
1319
1320		end subroutine rescale_comp_data_3d
1321
1322		!> Rescale the values of a 2-D array in its computational domain by a constant factor
1323	28	subroutine rescale_comp_data_2d(domain, array, scale, zero_zeros)
1324		type(MOM_domain_type), intent(in) :: domain !< MOM domain from which to extract information
1325		real, dimension(:,:), intent(inout) :: array !< The array which is having the data in its
1326		!! computational domain rescaled
1327		real, intent(in) :: scale !< A scaling factor by which to multiply the
1328		!! values in the computational domain of array
1329		logical, optional, intent(in) :: zero_zeros !< If present and true, convert negative zeros
1330		!! into ordinary signless zeros.
1331		logical :: unsign_zeros ! If true, convert negative zeros into ordinary signless zeros.
1332		integer :: is, ie, js, je, i, j
1333
1334	28	unsign_zeros = .false. ; if (present(zero_zeros)) unsign_zeros = zero_zeros
1335
1336	28	if ((scale == 1.0) .and. (.not.unsign_zeros)) return
1337
1338	0	call get_simple_array_i_ind(domain, size(array,1), is, ie)
1339	0	call get_simple_array_j_ind(domain, size(array,2), js, je)
1340	0	if (scale /= 1.0) &
1341	0	array(is:ie,js:je) = scale*array(is:ie,js:je)
1342
1343	0	if (unsign_zeros) then ! Convert negative zeros into zeros
1344	0	do j=js,je ; do i=is,ie
1345	0	if (array(i,j) == 0.0) array(i,j) = 0.0
1346		enddo ; enddo
1347		endif
1348
1349		end subroutine rescale_comp_data_2d
1350
1351		!> create_MOM_domain creates and initializes a MOM_domain_type variables, based on the information
1352		!! provided in arguments.
1353	1	subroutine create_MOM_domain(MOM_dom, n_global, n_halo, reentrant, tripolar_N, layout, io_layout, &
1354		domain_name, mask_table, symmetric, thin_halos, nonblocking)
1355		type(MOM_domain_type), pointer :: MOM_dom !< A pointer to the MOM_domain_type being defined here.
1356		integer, dimension(2), intent(in) :: n_global !< The number of points on the global grid in
1357		!! the i- and j-directions
1358		integer, dimension(2), intent(in) :: n_halo !< The number of halo points on each processor
1359		logical, dimension(2), intent(in) :: reentrant !< If true the grid is periodic in the i- and j- directions
1360		logical, intent(in) :: tripolar_N !< If true the grid uses northern tripolar connectivity
1361		integer, dimension(2), intent(in) :: layout !< The layout of logical PEs in the i- and j-directions.
1362		integer, dimension(2), optional, intent(in) :: io_layout !< The layout for parallel input and output.
1363		character(len=*), optional, intent(in) :: domain_name !< A name for this domain, "MOM" if missing.
1364		character(len=*), optional, intent(in) :: mask_table !< The full relative or absolute path to the mask table.
1365		logical, optional, intent(in) :: symmetric !< If present, this specifies whether this domain
1366		!! uses symmetric memory, or true if missing.
1367		logical, optional, intent(in) :: thin_halos !< If present, this specifies whether to permit the use of
1368		!! thin halo updates, or true if missing.
1369		logical, optional, intent(in) :: nonblocking !< If present, this specifies whether to permit the use of
1370		!! nonblocking halo updates, or false if missing.
1371
1372		! local variables
1373		integer, dimension(4) :: global_indices ! The lower and upper global i- and j-index bounds
1374		integer :: X_FLAGS ! A combination of integers encoding the x-direction grid connectivity.
1375		integer :: Y_FLAGS ! A combination of integers encoding the y-direction grid connectivity.
1376		integer :: xhalo_d2, yhalo_d2
1377		character(len=200) :: mesg ! A string for use in error messages
1378		logical :: mask_table_exists ! Mask_table is present and the file it points to exists
1379
1380	1	if (.not.associated(MOM_dom)) then
1381	1	allocate(MOM_dom)
1382	1	allocate(MOM_dom%mpp_domain)
1383	1	allocate(MOM_dom%mpp_domain_d2)
1384		endif
1385
1386	1	MOM_dom%name = "MOM" ; if (present(domain_name)) MOM_dom%name = trim(domain_name)
1387
1388	1	X_FLAGS = 0 ; Y_FLAGS = 0
1389	1	if (reentrant(1)) X_FLAGS = CYCLIC_GLOBAL_DOMAIN
1390	1	if (reentrant(2)) Y_FLAGS = CYCLIC_GLOBAL_DOMAIN
1391	1	if (tripolar_N) then
1392	0	Y_FLAGS = FOLD_NORTH_EDGE
1393	0	if (reentrant(2)) call MOM_error(FATAL,"MOM_domains: "// &
1394	0	"TRIPOLAR_N and REENTRANT_Y may not be used together.")
1395		endif
1396
1397	1	MOM_dom%nonblocking_updates = .false.
1398	1	if (present(nonblocking)) MOM_dom%nonblocking_updates = nonblocking
1399	1	MOM_dom%thin_halo_updates = .false.
1400	1	if (present(thin_halos)) MOM_dom%thin_halo_updates = thin_halos
1401	1	MOM_dom%symmetric = .true. ; if (present(symmetric)) MOM_dom%symmetric = symmetric
1402	1	MOM_dom%niglobal = n_global(1) ; MOM_dom%njglobal = n_global(2)
1403	1	MOM_dom%nihalo = n_halo(1) ; MOM_dom%njhalo = n_halo(2)
1404
1405		! Save the extra data for creating other domains of different resolution that overlay this domain.
1406	1	MOM_dom%X_FLAGS = X_FLAGS
1407	1	MOM_dom%Y_FLAGS = Y_FLAGS
1408	3	MOM_dom%layout(:) = layout(:)
1409
1410		! Set up the io_layout, with error handling.
1411	3	MOM_dom%io_layout(:) = (/ 1, 1 /)
1412	1	if (present(io_layout)) then
1413	1	if (io_layout(1) == 0) then
1414	0	MOM_dom%io_layout(1) = layout(1)
1415	1	elseif (io_layout(1) > 1) then
1416	0	MOM_dom%io_layout(1) = io_layout(1)
1417	0	if (modulo(layout(1), io_layout(1)) /= 0) then
1418		write(mesg,'("MOM_domains_init: The i-direction I/O-layout, IO_LAYOUT(1)=",i4, &
1419	0	&", does not evenly divide the i-direction layout, NIPROC=,",i4,".")') io_layout(1), layout(1)
1420	0	call MOM_error(FATAL, mesg)
1421		endif
1422		endif
1423
1424	1	if (io_layout(2) == 0) then
1425	0	MOM_dom%io_layout(2) = layout(2)
1426	1	elseif (io_layout(2) > 1) then
1427	0	MOM_dom%io_layout(2) = io_layout(2)
1428	0	if (modulo(layout(2), io_layout(2)) /= 0) then
1429		write(mesg,'("MOM_domains_init: The j-direction I/O-layout, IO_LAYOUT(2)=",i4, &
1430	0	&", does not evenly divide the j-direction layout, NJPROC=,",i4,".")') io_layout(2), layout(2)
1431	0	call MOM_error(FATAL, mesg)
1432		endif
1433		endif
1434		endif
1435
1436	1	if (present(mask_table)) then
1437	1	mask_table_exists = file_exists(mask_table)
1438	1	if (mask_table_exists) then
1439	0	allocate(MOM_dom%maskmap(layout(1), layout(2)))
1440	0	call parse_mask_table(mask_table, MOM_dom%maskmap, MOM_dom%name)
1441		endif
1442		else
1443	0	mask_table_exists = .false.
1444		endif
1445
1446		! Initialize as an unrotated domain
1447	1	MOM_dom%turns = 0
1448
1449	1	call clone_MD_to_d2D(MOM_dom, MOM_dom%mpp_domain)
1450
1451		!For downsampled domain, recommend a halo of 1 (or 0?) since we're not doing wide-stencil computations.
1452		!But that does not work because the downsampled field would not have the correct size to pass the checks, e.g., we get
1453		!error: downsample_diag_indices_get: peculiar size 28 in i-direction\ndoes not match one of 24 25 26 27
1454		! call clone_MD_to_d2D(MOM_dom, MOM_dom%mpp_domain_d2, halo_size=(MOM_dom%nihalo/2), coarsen=2)
1455	1	call clone_MD_to_d2D(MOM_dom, MOM_dom%mpp_domain_d2, coarsen=2)
1456	1	end subroutine create_MOM_domain
1457
1458		!> dealloc_MOM_domain deallocates memory associated with a pointer to a MOM_domain_type
1459		!! and potentially all of its contents
1460	5	subroutine deallocate_MOM_domain(MOM_domain, cursory)
1461		type(MOM_domain_type), pointer :: MOM_domain !< A pointer to the MOM_domain_type being deallocated
1462		logical, optional, intent(in) :: cursory !< If true do not deallocate fields associated
1463		!! with the underlying infrastructure
1464		logical :: invasive ! If true, deallocate fields associated with the underlying infrastructure
1465
1466	5	invasive = .true. ; if (present(cursory)) invasive = .not.cursory
1467
1468	5	if (associated(MOM_domain)) then
1469	4	if (associated(MOM_domain%mpp_domain)) then
1470	4	if (invasive) call mpp_deallocate_domain(MOM_domain%mpp_domain)
1471	4	deallocate(MOM_domain%mpp_domain)
1472		endif
1473	4	if (associated(MOM_domain%mpp_domain_d2)) then
1474	4	if (invasive) call mpp_deallocate_domain(MOM_domain%mpp_domain_d2)
1475	4	deallocate(MOM_domain%mpp_domain_d2)
1476		endif
1477	4	if (associated(MOM_domain%maskmap)) deallocate(MOM_domain%maskmap)
1478	4	deallocate(MOM_domain)
1479		endif
1480
1481	5	end subroutine deallocate_MOM_domain
1482
1483		!> MOM_thread_affinity_set returns true if the number of openMP threads have been set to a value greater than 1.
1484	0	function MOM_thread_affinity_set()
1485		! Local variables
1486		!$ integer :: ocean_nthreads ! Number of openMP threads
1487		!$ integer :: omp_get_num_threads ! An openMP function that returns the number of threads
1488		logical :: MOM_thread_affinity_set
1489
1490	0	MOM_thread_affinity_set = .false.
1491		!$ call fms_affinity_init()
1492		!$OMP PARALLEL
1493		!$OMP MASTER
1494		!$ ocean_nthreads = omp_get_num_threads()
1495		!$OMP END MASTER
1496		!$OMP END PARALLEL
1497		!$ MOM_thread_affinity_set = (ocean_nthreads > 1 )
1498	0	end function MOM_thread_affinity_set
1499
1500		!> set_MOM_thread_affinity sets the number of openMP threads to use with the ocean.
1501	0	subroutine set_MOM_thread_affinity(ocean_nthreads, ocean_hyper_thread)
1502		integer, intent(in) :: ocean_nthreads !< Number of openMP threads to use for the ocean model
1503		logical, intent(in) :: ocean_hyper_thread !< If true, use hyper threading
1504
1505		! Local variables
1506		!$ integer :: omp_get_thread_num, omp_get_num_threads !< These are the results of openMP functions
1507
1508		!$ call fms_affinity_init() ! fms_affinity_init can be safely called more than once.
1509		!$ call fms_affinity_set('OCEAN', ocean_hyper_thread, ocean_nthreads)
1510		!$ call omp_set_num_threads(ocean_nthreads)
1511		!$OMP PARALLEL
1512		!$ write(6,*) "MOM_domains_mod OMPthreading ", fms_affinity_get(), omp_get_thread_num(), omp_get_num_threads()
1513		!$ flush(6)
1514		!$OMP END PARALLEL
1515	0	end subroutine set_MOM_thread_affinity
1516
1517		!> This subroutine retrieves the 1-d domains that make up the 2d-domain in a MOM_domain
1518	2	subroutine get_domain_components_MD(MOM_dom, x_domain, y_domain)
1519		type(MOM_domain_type), intent(in) :: MOM_dom !< The MOM_domain whose contents are being extracted
1520		type(domain1D), optional, intent(inout) :: x_domain !< The 1-d logical x-domain
1521		type(domain1D), optional, intent(inout) :: y_domain !< The 1-d logical y-domain
1522
1523	2	call mpp_get_domain_components(MOM_dom%mpp_domain, x_domain, y_domain)
1524	2	end subroutine get_domain_components_MD
1525
1526		!> This subroutine retrieves the 1-d domains that make up a 2d-domain
1527	0	subroutine get_domain_components_d2D(domain, x_domain, y_domain)
1528		type(domain2D), intent(in) :: domain !< The 2D domain whose contents are being extracted
1529		type(domain1D), optional, intent(inout) :: x_domain !< The 1-d logical x-domain
1530		type(domain1D), optional, intent(inout) :: y_domain !< The 1-d logical y-domain
1531
1532	0	call mpp_get_domain_components(domain, x_domain, y_domain)
1533	0	end subroutine get_domain_components_d2D
1534
1535		!> clone_MD_to_MD copies one MOM_domain_type into another, while allowing
1536		!! some properties of the new type to differ from the original one.
1537	3	subroutine clone_MD_to_MD(MD_in, MOM_dom, min_halo, halo_size, symmetric, domain_name, &
1538		turns, refine, extra_halo, io_layout)
1539		type(MOM_domain_type), target, intent(in) :: MD_in !< An existing MOM_domain
1540		type(MOM_domain_type), pointer :: MOM_dom
1541		!< A pointer to a MOM_domain that will be
1542		!! allocated if it is unassociated, and will have data
1543		!! copied from MD_in
1544		integer, dimension(2), &
1545		optional, intent(inout) :: min_halo !< If present, this sets the
1546		!! minimum halo size for this domain in the i- and j-
1547		!! directions, and returns the actual halo size used.
1548		integer, optional, intent(in) :: halo_size !< If present, this sets the halo
1549		!! size for the domain in the i- and j-directions.
1550		!! min_halo and halo_size can not both be present.
1551		logical, optional, intent(in) :: symmetric !< If present, this specifies
1552		!! whether the new domain is symmetric, regardless of
1553		!! whether the macro SYMMETRIC_MEMORY_ is defined.
1554		character(len=*), &
1555		optional, intent(in) :: domain_name !< A name for the new domain, copied
1556		!! from MD_in if missing.
1557		integer, optional, intent(in) :: turns !< Number of quarter turns
1558		integer, optional, intent(in) :: refine !< A factor by which to enhance the grid resolution.
1559		integer, optional, intent(in) :: extra_halo !< An extra number of points in the halos
1560		!! compared with MD_in
1561		integer, optional, intent(in) :: io_layout(2)
1562		!< A user-defined IO layout to replace the domain's IO layout
1563
1564
1565		integer :: global_indices(4)
1566		logical :: mask_table_exists
1567	3	integer, dimension(:), allocatable :: exni ! The extents of the grid for each i-row of the layout.
1568		! The sum of exni must equal MOM_dom%niglobal.
1569	3	integer, dimension(:), allocatable :: exnj ! The extents of the grid for each j-row of the layout.
1570		! The sum of exni must equal MOM_dom%niglobal.
1571		integer :: qturns ! The number of quarter turns, restricted to the range of 0 to 3.
1572		integer :: i, j, nl1, nl2
1573		integer :: io_layout_in(2)
1574
1575	3	qturns = 0
1576	0	if (present(turns)) qturns = modulo(turns, 4)
1577
1578	3	if (present(io_layout)) then
1579	0	io_layout_in(:) = io_layout(:)
1580		else
1581	9	io_layout_in(:) = MD_in%io_layout(:)
1582		endif
1583
1584	3	if (.not.associated(MOM_dom)) then
1585	3	allocate(MOM_dom)
1586	3	allocate(MOM_dom%mpp_domain)
1587	3	allocate(MOM_dom%mpp_domain_d2)
1588		endif
1589
1590		! Save the extra data for creating other domains of different resolution that overlay this domain
1591	3	MOM_dom%symmetric = MD_in%symmetric
1592	3	MOM_dom%nonblocking_updates = MD_in%nonblocking_updates
1593	3	MOM_dom%thin_halo_updates = MD_in%thin_halo_updates
1594
1595	3	if (modulo(qturns, 2) /= 0) then
1596	0	MOM_dom%niglobal = MD_in%njglobal ; MOM_dom%njglobal = MD_in%niglobal
1597	0	MOM_dom%nihalo = MD_in%njhalo ; MOM_dom%njhalo = MD_in%nihalo
1598	0	call get_layout_extents(MD_in, exnj, exni)
1599
1600	0	MOM_dom%X_FLAGS = MD_in%Y_FLAGS ; MOM_dom%Y_FLAGS = MD_in%X_FLAGS
1601		! Correct the position of a tripolar grid, assuming that flags are not additive.
1602	0	if (modulo(qturns, 4) == 1) then
1603	0	if (MD_in%Y_FLAGS == FOLD_NORTH_EDGE) MOM_dom%X_FLAGS = FOLD_EAST_EDGE
1604	0	if (MD_in%Y_FLAGS == FOLD_SOUTH_EDGE) MOM_dom%X_FLAGS = FOLD_WEST_EDGE
1605	0	if (MD_in%X_FLAGS == FOLD_EAST_EDGE) MOM_dom%Y_FLAGS = FOLD_SOUTH_EDGE
1606	0	if (MD_in%X_FLAGS == FOLD_WEST_EDGE) MOM_dom%Y_FLAGS = FOLD_NORTH_EDGE
1607	0	elseif (modulo(qturns, 4) == 3) then
1608	0	if (MD_in%Y_FLAGS == FOLD_NORTH_EDGE) MOM_dom%X_FLAGS = FOLD_WEST_EDGE
1609	0	if (MD_in%Y_FLAGS == FOLD_SOUTH_EDGE) MOM_dom%X_FLAGS = FOLD_EAST_EDGE
1610	0	if (MD_in%X_FLAGS == FOLD_EAST_EDGE) MOM_dom%Y_FLAGS = FOLD_NORTH_EDGE
1611	0	if (MD_in%X_FLAGS == FOLD_WEST_EDGE) MOM_dom%Y_FLAGS = FOLD_SOUTH_EDGE
1612		endif
1613
1614	0	MOM_dom%layout(:) = MD_in%layout(2:1:-1)
1615	0	MOM_dom%io_layout(:) = io_layout_in(2:1:-1)
1616		else
1617	3	MOM_dom%niglobal = MD_in%niglobal ; MOM_dom%njglobal = MD_in%njglobal
1618	3	MOM_dom%nihalo = MD_in%nihalo ; MOM_dom%njhalo = MD_in%njhalo
1619	3	call get_layout_extents(MD_in, exni, exnj)
1620
1621	3	MOM_dom%X_FLAGS = MD_in%X_FLAGS ; MOM_dom%Y_FLAGS = MD_in%Y_FLAGS
1622		! Correct the position of a tripolar grid, assuming that flags are not additive.
1623	3	if (modulo(qturns, 4) == 2) then
1624	0	if (MD_in%Y_FLAGS == FOLD_NORTH_EDGE) MOM_dom%Y_FLAGS = FOLD_SOUTH_EDGE
1625	0	if (MD_in%Y_FLAGS == FOLD_SOUTH_EDGE) MOM_dom%Y_FLAGS = FOLD_NORTH_EDGE
1626	0	if (MD_in%X_FLAGS == FOLD_EAST_EDGE) MOM_dom%X_FLAGS = FOLD_WEST_EDGE
1627	0	if (MD_in%X_FLAGS == FOLD_WEST_EDGE) MOM_dom%X_FLAGS = FOLD_EAST_EDGE
1628		endif
1629
1630	15	MOM_dom%layout(:) = MD_in%layout(:)
1631	9	MOM_dom%io_layout(:) = io_layout_in(:)
1632		endif
1633
1634		! Ensure that the points per processor are the same on the source and destination grids.
1635	0	select case (qturns)
1636	0	case (1) ; call invert(exni)
1637	0	case (2) ; call invert(exni) ; call invert(exnj)
1638	3	case (3) ; call invert(exnj)
1639		end select
1640
1641	3	if (associated(MD_in%maskmap)) then
1642	0	mask_table_exists = .true.
1643	0	allocate(MOM_dom%maskmap(MOM_dom%layout(1), MOM_dom%layout(2)))
1644
1645	0	nl1 = MOM_dom%layout(1) ; nl2 = MOM_dom%layout(2)
1646	0	select case (qturns)
1647		case (0)
1648	0	do j=1,nl2 ; do i=1,nl1
1649	0	MOM_dom%maskmap(i,j) = MD_in%maskmap(i, j)
1650		enddo ; enddo
1651		case (1)
1652	0	do j=1,nl2 ; do i=1,nl1
1653	0	MOM_dom%maskmap(i,j) = MD_in%maskmap(j, nl1+1-i)
1654		enddo ; enddo
1655		case (2)
1656	0	do j=1,nl2 ; do i=1,nl1
1657	0	MOM_dom%maskmap(i,j) = MD_in%maskmap(nl1+1-i, nl2+1-j)
1658		enddo ; enddo
1659		case (3)
1660	0	do j=1,nl2 ; do i=1,nl1
1661	0	MOM_dom%maskmap(i,j) = MD_in%maskmap(nl2+1-j, i)
1662		enddo ; enddo
1663		end select
1664		else
1665	3	mask_table_exists = .false.
1666		endif
1667
1668		! Optionally enhance the grid resolution.
1669	3	if (present(refine)) then ; if (refine > 1) then
1670	0	MOM_dom%niglobal = refineMOM_dom%niglobal ; MOM_dom%njglobal = refineMOM_dom%njglobal
1671	0	MOM_dom%nihalo = refineMOM_dom%nihalo ; MOM_dom%njhalo = refineMOM_dom%njhalo
1672	0	do i=1,MOM_dom%layout(1) ; exni(i) = refine*exni(i) ; enddo
1673	0	do j=1,MOM_dom%layout(2) ; exnj(j) = refine*exnj(j) ; enddo
1674		endif ; endif
1675
1676		! Optionally enhance the grid resolution.
1677	3	if (present(extra_halo)) then ; if (extra_halo > 0) then
1678	0	MOM_dom%nihalo = MOM_dom%nihalo + extra_halo ; MOM_dom%njhalo = MOM_dom%njhalo + extra_halo
1679		endif ; endif
1680
1681	3	if (present(halo_size) .and. present(min_halo)) call MOM_error(FATAL, &
1682	0	"clone_MOM_domain can not have both halo_size and min_halo present.")
1683
1684	3	if (present(min_halo)) then
1685	1	MOM_dom%nihalo = max(MOM_dom%nihalo, min_halo(1))
1686	1	min_halo(1) = MOM_dom%nihalo
1687	1	MOM_dom%njhalo = max(MOM_dom%njhalo, min_halo(2))
1688	1	min_halo(2) = MOM_dom%njhalo
1689		endif
1690
1691	3	if (present(halo_size)) then
1692	0	MOM_dom%nihalo = halo_size ; MOM_dom%njhalo = halo_size
1693		endif
1694
1695	3	if (present(symmetric)) then ; MOM_dom%symmetric = symmetric ; endif
1696
1697	3	if (present(domain_name)) then
1698	0	MOM_dom%name = trim(domain_name)
1699		else
1700	3	MOM_dom%name = MD_in%name
1701		endif
1702
1703	3	MOM_dom%turns = qturns
1704	3	if (qturns /= 0) then
1705	0	MOM_dom%domain_in => MD_in
1706		endif
1707
1708	3	call clone_MD_to_d2D(MOM_dom, MOM_dom%mpp_domain, xextent=exni, yextent=exnj)
1709	3	call clone_MD_to_d2D(MOM_dom, MOM_dom%mpp_domain_d2, domain_name=MOM_dom%name, coarsen=2)
1710
1711	6	end subroutine clone_MD_to_MD
1712
1713
1714		!> clone_MD_to_d2D uses information from a MOM_domain_type to create a new
1715		!! domain2d type, while allowing some properties of the new type to differ from
1716		!! the original one.
1717	8	subroutine clone_MD_to_d2D(MD_in, mpp_domain, min_halo, halo_size, symmetric, &
1718	8	domain_name, turns, xextent, yextent, coarsen)
1719		type(MOM_domain_type), intent(in) :: MD_in !< An existing MOM_domain to be cloned
1720		type(domain2d), intent(inout) :: mpp_domain !< The new mpp_domain to be set up
1721		integer, dimension(2), &
1722		optional, intent(inout) :: min_halo !< If present, this sets the
1723		!! minimum halo size for this domain in the i- and j-
1724		!! directions, and returns the actual halo size used.
1725		integer, optional, intent(in) :: halo_size !< If present, this sets the halo
1726		!! size for the domain in the i- and j-directions.
1727		!! min_halo and halo_size can not both be present.
1728		logical, optional, intent(in) :: symmetric !< If present, this specifies
1729		!! whether the new domain is symmetric, regardless of
1730		!! whether the macro SYMMETRIC_MEMORY_ is defined or
1731		!! whether MD_in is symmetric.
1732		character(len=*), &
1733		optional, intent(in) :: domain_name !< A name for the new domain, "MOM"
1734		!! if missing.
1735		integer, optional, intent(in) :: turns !< Number of quarter turns - not implemented here.
1736		integer, optional, intent(in) :: coarsen !< A factor by which to coarsen this grid.
1737		!! The default of 1 is for no coarsening.
1738		integer, dimension(:), optional, intent(in) :: xextent !< The number of grid points in the
1739		!! tracer computational domain for division of the x-layout.
1740		integer, dimension(:), optional, intent(in) :: yextent !< The number of grid points in the
1741		!! tracer computational domain for division of the y-layout.
1742
1743		integer :: global_indices(4)
1744		integer :: nihalo, njhalo
1745		logical :: symmetric_dom, do_coarsen
1746		character(len=64) :: dom_name
1747
1748	8	if (present(turns)) &
1749	0	call MOM_error(FATAL, "Rotation not supported for MOM_domain to domain2d")
1750
1751	8	if (present(halo_size) .and. present(min_halo)) call MOM_error(FATAL, &
1752	0	"clone_MOM_domain can not have both halo_size and min_halo present.")
1753
1754	8	do_coarsen = .false. ; if (present(coarsen)) then ; do_coarsen = (coarsen > 1) ; endif
1755
1756	8	nihalo = MD_in%nihalo ; njhalo = MD_in%njhalo
1757	8	if (do_coarsen) then
1758	4	nihalo = int(MD_in%nihalo / coarsen) ; njhalo = int(MD_in%njhalo / coarsen)
1759		endif
1760
1761	8	if (present(min_halo)) then
1762	0	nihalo = max(nihalo, min_halo(1))
1763	0	njhalo = max(njhalo, min_halo(2))
1764	0	min_halo(1) = nihalo ; min_halo(2) = njhalo
1765		endif
1766	8	if (present(halo_size)) then
1767	0	nihalo = halo_size ; njhalo = halo_size
1768		endif
1769
1770	8	symmetric_dom = MD_in%symmetric
1771	8	if (present(symmetric)) then ; symmetric_dom = symmetric ; endif
1772
1773	8	dom_name = MD_in%name
1774	8	if (do_coarsen) dom_name = trim(MD_in%name)//"c"
1775	8	if (present(domain_name)) dom_name = trim(domain_name)
1776
1777	40	global_indices(1:4) = (/ 1, MD_in%niglobal, 1, MD_in%njglobal /)
1778	8	if (do_coarsen) then
1779	20	global_indices(1:4) = (/ 1, (MD_in%niglobal/coarsen), 1, (MD_in%njglobal/coarsen) /)
1780		endif
1781
1782	8	if (associated(MD_in%maskmap)) then
1783		call mpp_define_domains( global_indices, MD_in%layout, mpp_domain, &
1784		xflags=MD_in%X_FLAGS, yflags=MD_in%Y_FLAGS, xhalo=nihalo, yhalo=njhalo, &
1785		xextent=xextent, yextent=yextent, symmetry=symmetric_dom, name=dom_name, &
1786	0	maskmap=MD_in%maskmap )
1787		else
1788		call mpp_define_domains( global_indices, MD_in%layout, mpp_domain, &
1789		xflags=MD_in%X_FLAGS, yflags=MD_in%Y_FLAGS, xhalo=nihalo, yhalo=njhalo, &
1790	8	symmetry=symmetric_dom, xextent=xextent, yextent=yextent, name=dom_name)
1791		endif
1792
1793	8	if ((MD_in%io_layout(1) + MD_in%io_layout(2) > 0) .and. &
1794		(MD_in%layout(1)*MD_in%layout(2) > 1)) then
1795	0	call mpp_define_io_domain(mpp_domain, MD_in%io_layout)
1796		else
1797	8	call mpp_define_io_domain(mpp_domain, (/ 1, 1 /) )
1798		endif
1799
1800	8	end subroutine clone_MD_to_d2D
1801
1802		!> Returns the index ranges that have been stored in a MOM_domain_type
1803	3	subroutine get_domain_extent_MD(Domain, isc, iec, jsc, jec, isd, ied, jsd, jed, &
1804		isg, ieg, jsg, jeg, idg_offset, jdg_offset, &
1805		symmetric, local_indexing, index_offset, coarsen)
1806		type(MOM_domain_type), &
1807		intent(in) :: Domain !< The MOM domain from which to extract information
1808		integer, intent(out) :: isc !< The start i-index of the computational domain
1809		integer, intent(out) :: iec !< The end i-index of the computational domain
1810		integer, intent(out) :: jsc !< The start j-index of the computational domain
1811		integer, intent(out) :: jec !< The end j-index of the computational domain
1812		integer, intent(out) :: isd !< The start i-index of the data domain
1813		integer, intent(out) :: ied !< The end i-index of the data domain
1814		integer, intent(out) :: jsd !< The start j-index of the data domain
1815		integer, intent(out) :: jed !< The end j-index of the data domain
1816		integer, optional, intent(out) :: isg !< The start i-index of the global domain
1817		integer, optional, intent(out) :: ieg !< The end i-index of the global domain
1818		integer, optional, intent(out) :: jsg !< The start j-index of the global domain
1819		integer, optional, intent(out) :: jeg !< The end j-index of the global domain
1820		integer, optional, intent(out) :: idg_offset !< The offset between the corresponding global and
1821		!! data i-index spaces.
1822		integer, optional, intent(out) :: jdg_offset !< The offset between the corresponding global and
1823		!! data j-index spaces.
1824		logical, optional, intent(out) :: symmetric !< True if symmetric memory is used.
1825		logical, optional, intent(in) :: local_indexing !< If true, local tracer array indices start at 1,
1826		!! as in most MOM6 code. The default is true.
1827		integer, optional, intent(in) :: index_offset !< A fixed additional offset to all indices. This
1828		!! can be useful for some types of debugging with
1829		!! dynamic memory allocation. The default is 0.
1830		integer, optional, intent(in) :: coarsen !< A factor by which the grid is coarsened.
1831		!! The default is 1, for no coarsening.
1832
1833		! Local variables
1834		integer :: isg_, ieg_, jsg_, jeg_
1835		integer :: ind_off, idg_off, jdg_off, coarsen_lev
1836		logical :: local
1837
1838	3	local = .true. ; if (present(local_indexing)) local = local_indexing
1839	3	ind_off = 0 ; if (present(index_offset)) ind_off = index_offset
1840
1841	3	coarsen_lev = 1 ; if (present(coarsen)) coarsen_lev = coarsen
1842
1843	3	if (coarsen_lev == 1) then
1844	2	call mpp_get_compute_domain(Domain%mpp_domain, isc, iec, jsc, jec)
1845	2	call mpp_get_data_domain(Domain%mpp_domain, isd, ied, jsd, jed)
1846	2	call mpp_get_global_domain(Domain%mpp_domain, isg_, ieg_, jsg_, jeg_)
1847	1	elseif (coarsen_lev == 2) then
1848	1	if (.not.associated(Domain%mpp_domain_d2)) call MOM_error(FATAL, &
1849	0	"get_domain_extent called with coarsen=2, but Domain%mpp_domain_d2 is not associated.")
1850	1	call mpp_get_compute_domain(Domain%mpp_domain_d2, isc, iec, jsc, jec)
1851	1	call mpp_get_data_domain(Domain%mpp_domain_d2, isd, ied, jsd, jed)
1852	1	call mpp_get_global_domain(Domain%mpp_domain_d2, isg_, ieg_, jsg_, jeg_)
1853		else
1854	0	call MOM_error(FATAL, "get_domain_extent called with an unsupported level of coarsening.")
1855		endif
1856
1857	3	if (local) then
1858		! This code institutes the MOM convention that local array indices start at 1.
1859	3	idg_off = isd - 1 ; jdg_off = jsd - 1
1860	3	isc = isc - isd + 1 ; iec = iec - isd + 1 ; jsc = jsc - jsd + 1 ; jec = jec - jsd + 1
1861	3	ied = ied - isd + 1 ; jed = jed - jsd + 1
1862	3	isd = 1 ; jsd = 1
1863		else
1864	0	idg_off = 0 ; jdg_off = 0
1865		endif
1866	3	if (ind_off /= 0) then
1867	0	idg_off = idg_off + ind_off ; jdg_off = jdg_off + ind_off
1868	0	isc = isc + ind_off ; iec = iec + ind_off
1869	0	jsc = jsc + ind_off ; jec = jec + ind_off
1870	0	isd = isd + ind_off ; ied = ied + ind_off
1871	0	jsd = jsd + ind_off ; jed = jed + ind_off
1872		endif
1873	3	if (present(isg)) isg = isg_
1874	3	if (present(ieg)) ieg = ieg_
1875	3	if (present(jsg)) jsg = jsg_
1876	3	if (present(jeg)) jeg = jeg_
1877	3	if (present(idg_offset)) idg_offset = idg_off
1878	3	if (present(jdg_offset)) jdg_offset = jdg_off
1879	3	if (present(symmetric)) symmetric = Domain%symmetric
1880
1881	3	end subroutine get_domain_extent_MD
1882
1883		!> Returns the index ranges that have been stored in a domain2D type
1884	0	subroutine get_domain_extent_d2D(Domain, isc, iec, jsc, jec, isd, ied, jsd, jed)
1885		type(domain2d), intent(in) :: Domain !< The MOM domain from which to extract information
1886		integer, intent(out) :: isc !< The start i-index of the computational domain
1887		integer, intent(out) :: iec !< The end i-index of the computational domain
1888		integer, intent(out) :: jsc !< The start j-index of the computational domain
1889		integer, intent(out) :: jec !< The end j-index of the computational domain
1890		integer, optional, intent(out) :: isd !< The start i-index of the data domain
1891		integer, optional, intent(out) :: ied !< The end i-index of the data domain
1892		integer, optional, intent(out) :: jsd !< The start j-index of the data domain
1893		integer, optional, intent(out) :: jed !< The end j-index of the data domain
1894
1895		! Local variables
1896		integer :: isd_, ied_, jsd_, jed_, jsg_, jeg_, isg_, ieg_
1897
1898	0	call mpp_get_compute_domain(Domain, isc, iec, jsc, jec)
1899	0	call mpp_get_data_domain(Domain, isd_, ied_, jsd_, jed_)
1900
1901	0	if (present(isd)) isd = isd_
1902	0	if (present(ied)) ied = ied_
1903	0	if (present(jsd)) jsd = jsd_
1904	0	if (present(jed)) jed = jed_
1905
1906	0	end subroutine get_domain_extent_d2D
1907
1908		!> Return the (potentially symmetric) computational domain i-bounds for an array
1909		!! passed without index specifications (i.e. indices start at 1) based on an array size.
1910	0	subroutine get_simple_array_i_ind(domain, size, is, ie, symmetric)
1911		type(MOM_domain_type), intent(in) :: domain !< MOM domain from which to extract information
1912		integer, intent(in) :: size !< The i-array size
1913		integer, intent(out) :: is !< The computational domain starting i-index.
1914		integer, intent(out) :: ie !< The computational domain ending i-index.
1915		logical, optional, intent(in) :: symmetric !< If present, indicates whether symmetric sizes
1916		!! can be considered.
1917		! Local variables
1918		logical :: sym
1919		character(len=120) :: mesg, mesg2
1920		integer :: isc, iec, jsc, jec, isd, ied, jsd, jed
1921
1922	0	call mpp_get_compute_domain(Domain%mpp_domain, isc, iec, jsc, jec)
1923	0	call mpp_get_data_domain(Domain%mpp_domain, isd, ied, jsd, jed)
1924
1925	0	isc = isc-isd+1 ; iec = iec-isd+1 ; ied = ied-isd+1 ; isd = 1
1926	0	sym = Domain%symmetric ; if (present(symmetric)) sym = symmetric
1927
1928	0	if (size == ied) then ; is = isc ; ie = iec
1929	0	elseif (size == 1+iec-isc) then ; is = 1 ; ie = size
1930	0	elseif (sym .and. (size == 1+ied)) then ; is = isc ; ie = iec+1
1931	0	elseif (sym .and. (size == 2+iec-isc)) then ; is = 1 ; ie = size+1
1932		else
1933	0	write(mesg,'("Unrecognized size ", i6, "in call to get_simple_array_i_ind. \")') size
1934	0	if (sym) then
1935	0	write(mesg2,'("Valid sizes are : ", 2i7)') ied, 1+iec-isc
1936		else
1937	0	write(mesg2,'("Valid sizes are : ", 4i7)') ied, 1+iec-isc, 1+ied, 2+iec-isc
1938		endif
1939	0	call MOM_error(FATAL, trim(mesg)//trim(mesg2))
1940		endif
1941
1942	0	end subroutine get_simple_array_i_ind
1943
1944
1945		!> Return the (potentially symmetric) computational domain j-bounds for an array
1946		!! passed without index specifications (i.e. indices start at 1) based on an array size.
1947	0	subroutine get_simple_array_j_ind(domain, size, js, je, symmetric)
1948		type(MOM_domain_type), intent(in) :: domain !< MOM domain from which to extract information
1949		integer, intent(in) :: size !< The j-array size
1950		integer, intent(out) :: js !< The computational domain starting j-index.
1951		integer, intent(out) :: je !< The computational domain ending j-index.
1952		logical, optional, intent(in) :: symmetric !< If present, indicates whether symmetric sizes
1953		!! can be considered.
1954		! Local variables
1955		logical :: sym
1956		character(len=120) :: mesg, mesg2
1957		integer :: isc, iec, jsc, jec, isd, ied, jsd, jed
1958
1959	0	call mpp_get_compute_domain(Domain%mpp_domain, isc, iec, jsc, jec)
1960	0	call mpp_get_data_domain(Domain%mpp_domain, isd, ied, jsd, jed)
1961
1962	0	jsc = jsc-jsd+1 ; jec = jec-jsd+1 ; jed = jed-jsd+1 ; jsd = 1
1963	0	sym = Domain%symmetric ; if (present(symmetric)) sym = symmetric
1964
1965	0	if (size == jed) then ; js = jsc ; je = jec
1966	0	elseif (size == 1+jec-jsc) then ; js = 1 ; je = size
1967	0	elseif (sym .and. (size == 1+jed)) then ; js = jsc ; je = jec+1
1968	0	elseif (sym .and. (size == 2+jec-jsc)) then ; js = 1 ; je = size+1
1969		else
1970	0	write(mesg,'("Unrecognized size ", i6, "in call to get_simple_array_j_ind. \")') size
1971	0	if (sym) then
1972	0	write(mesg2,'("Valid sizes are : ", 2i7)') jed, 1+jec-jsc
1973		else
1974	0	write(mesg2,'("Valid sizes are : ", 4i7)') jed, 1+jec-jsc, 1+jed, 2+jec-jsc
1975		endif
1976	0	call MOM_error(FATAL, trim(mesg)//trim(mesg2))
1977		endif
1978
1979	0	end subroutine get_simple_array_j_ind
1980
1981		!> Invert the contents of a 1-d array
1982	0	subroutine invert(array)
1983		integer, dimension(:), intent(inout) :: array !< The 1-d array to invert
1984		integer :: i, ni, swap
1985	0	ni = size(array)
1986	0	do i=1,ni
1987	0	swap = array(i)
1988	0	array(i) = array(ni+1-i)
1989	0	array(ni+1-i) = swap
1990		enddo
1991	0	end subroutine invert
1992
1993		!> Returns the global shape of h-point arrays
1994	2	subroutine get_global_shape(domain, niglobal, njglobal)
1995		type(MOM_domain_type), intent(in) :: domain !< MOM domain from which to extract information
1996		integer, intent(out) :: niglobal !< i-index global size of h-point arrays
1997		integer, intent(out) :: njglobal !< j-index global size of h-point arrays
1998
1999	2	niglobal = domain%niglobal
2000	2	njglobal = domain%njglobal
2001	2	end subroutine get_global_shape
2002
2003		!> Get the array ranges in one dimension for the divisions of a global index space (alternative to compute_extent)
2004	2	subroutine compute_block_extent(isg, ieg, ndivs, ibegin, iend)
2005		integer, intent(in) :: isg !< The starting index of the global index space
2006		integer, intent(in) :: ieg !< The ending index of the global index space
2007		integer, intent(in) :: ndivs !< The number of divisions
2008		integer, dimension(:), intent(out) :: ibegin !< The starting index of each division
2009		integer, dimension(:), intent(out) :: iend !< The ending index of each division
2010
2011	2	call mpp_compute_block_extent(isg, ieg, ndivs, ibegin, iend)
2012	2	end subroutine compute_block_extent
2013
2014		!> Get the array ranges in one dimension for the divisions of a global index space
2015	0	subroutine compute_extent(isg, ieg, ndivs, ibegin, iend)
2016		integer, intent(in) :: isg !< The starting index of the global index space
2017		integer, intent(in) :: ieg !< The ending index of the global index space
2018		integer, intent(in) :: ndivs !< The number of divisions
2019		integer, dimension(:), intent(out) :: ibegin !< The starting index of each division
2020		integer, dimension(:), intent(out) :: iend !< The ending index of each division
2021
2022	0	call mpp_compute_extent(isg, ieg, ndivs, ibegin, iend)
2023	0	end subroutine compute_extent
2024
2025		!> Broadcast a 2-d domain from the root PE to the other PEs
2026	0	subroutine broadcast_domain(domain)
2027		type(domain2d), intent(inout) :: domain !< The domain2d type that will be shared across PEs.
2028
2029	0	call mpp_broadcast_domain(domain)
2030	0	end subroutine broadcast_domain
2031
2032		!> Broadcast an entire 2-d array from the root processor to all others.
2033	0	subroutine global_field(domain, local, global)
2034		type(domain2d), intent(inout) :: domain !< The domain2d type that describes the decomposition
2035		real, dimension(:,:), intent(in) :: local !< The portion of the array on the local PE
2036		real, dimension(:,:), intent(out) :: global !< The whole global array
2037
2038	0	call mpp_global_field(domain, local, global)
2039	0	end subroutine global_field
2040
2041		!> same_domain returns true if two domains use the same list of PEs and layouts and have the same
2042		!! size computational domains, and false if the domains do not conform with each other.
2043		!! Different halo sizes or indexing conventions do not alter the results.
2044	0	logical function same_domain(domain_a, domain_b)
2045		type(domain2D), intent(in) :: domain_a !< The first domain in the comparison
2046		type(domain2D), intent(in) :: domain_b !< The second domain in the comparison
2047
2048		! Local variables
2049		integer :: isc_a, iec_a, jsc_a, jec_a, isc_b, iec_b, jsc_b, jec_b
2050		integer :: layout_a(2), layout_b(2)
2051
2052		! This routine currently does a few checks for consistent domains; more could be added.
2053	0	call mpp_get_layout(domain_a, layout_a)
2054	0	call mpp_get_layout(domain_b, layout_b)
2055
2056	0	call get_domain_extent(domain_a, isc_a, iec_a, jsc_a, jec_a)
2057	0	call get_domain_extent(domain_b, isc_b, iec_b, jsc_b, jec_b)
2058
2059		same_domain = (layout_a(1) == layout_b(1)) .and. (layout_a(2) == layout_b(2)) .and. &
2060	0	(iec_a - isc_a == iec_b - isc_b) .and. (jec_a - jsc_a == jec_b - jsc_b)
2061
2062	0	end function same_domain
2063
2064		!> Returns arrays of the i- and j- sizes of the h-point computational domains for each
2065		!! element of the grid layout. Any input values in the extent arrays are discarded, so
2066		!! they are effectively intent out despite their declared intent of inout.
2067	3	subroutine get_layout_extents(Domain, extent_i, extent_j)
2068		type(MOM_domain_type), intent(in) :: domain !< MOM domain from which to extract information
2069		integer, dimension(:), allocatable, intent(inout) :: extent_i !< The number of points in the
2070		!! i-direction in each i-row of the layout
2071		integer, dimension(:), allocatable, intent(inout) :: extent_j !< The number of points in the
2072		!! j-direction in each j-row of the layout
2073
2074	3	if (allocated(extent_i)) deallocate(extent_i)
2075	3	if (allocated(extent_j)) deallocate(extent_j)
2076	6	allocate(extent_i(domain%layout(1))) ; extent_i(:) = 0
2077	6	allocate(extent_j(domain%layout(2))) ; extent_j(:) = 0
2078	3	call mpp_get_domain_extents(domain%mpp_domain, extent_i, extent_j)
2079	3	end subroutine get_layout_extents
2080
2081		!> Set the associated domain for internal FMS I/O operations.
2082	0	subroutine set_domain(Domain)
2083		type(MOM_domain_type), intent(in) :: Domain
2084		!< MOM domain to be designated as the internal FMS I/O domain
2085
2086		! FMS2 does not have domain-based internal FMS I/O operations, so this
2087		! function does nothing.
2088	0	end subroutine set_domain
2089
2090	0	subroutine nullify_domain
2091		! No internal FMS I/O domain can be assigned, so this function does nothing.
2092	0	end subroutine nullify_domain
2093
2094	0	end module MOM_domain_infra