Line data Source code
1 : !|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
2 :
3 : module ice_boundary
4 :
5 : ! This module contains data types and routines for updating halo
6 : ! regions (ghost cells)
7 : !
8 : ! 2007-07-19: Phil Jones, Yoshi Yoshida, John Dennis
9 : ! new naming conventions, optimizations during
10 : ! initialization, true multi-dimensional updates
11 : ! (rather than serial call to two-dimensional updates),
12 : ! fixes for non-existent blocks
13 : ! 2008-01-28: Elizabeth Hunke replaced old routines with new POP
14 : ! infrastructure
15 : ! 2023-03-09: Tony Craig updated the implementation to fix bug in
16 : ! tripoleT and reduce number of copies in tripole overall.
17 : ! Because all blocks are local, can fill the tripole
18 : ! buffer from "north" copies. This is not true for
19 : ! the MPI version.
20 :
21 : use ice_kinds_mod
22 : use ice_communicate, only: my_task
23 : use ice_constants, only: field_type_scalar, &
24 : field_type_vector, field_type_angle, & ! LCOV_EXCL_LINE
25 : field_type_unknown, field_type_noupdate, & ! LCOV_EXCL_LINE
26 : field_loc_center, field_loc_NEcorner, & ! LCOV_EXCL_LINE
27 : field_loc_Nface, field_loc_Eface, & ! LCOV_EXCL_LINE
28 : field_loc_unknown, field_loc_noupdate
29 : use ice_global_reductions, only: global_maxval
30 : use ice_exit, only: abort_ice
31 : use icepack_intfc, only: icepack_warnings_flush, icepack_warnings_aborted
32 :
33 : use ice_blocks, only: nx_block, ny_block, nghost, &
34 : nblocks_tot, ice_blocksNorth, & ! LCOV_EXCL_LINE
35 : ice_blocksSouth, ice_blocksEast, ice_blocksWest, & ! LCOV_EXCL_LINE
36 : ice_blocksEast2, ice_blocksWest2, & ! LCOV_EXCL_LINE
37 : ice_blocksNorthEast, ice_blocksNorthWest, & ! LCOV_EXCL_LINE
38 : ice_blocksEastNorthEast, ice_blocksWestNorthWest, & ! LCOV_EXCL_LINE
39 : ice_blocksSouthEast, ice_blocksSouthWest, & ! LCOV_EXCL_LINE
40 : ice_blocksGetNbrID, get_block_parameter
41 : use ice_distribution, only: distrb, &
42 : ice_distributionGetBlockLoc, ice_distributionGet
43 :
44 : implicit none
45 : private
46 :
47 : type, public :: ice_halo
48 : integer (int_kind) :: &
49 : communicator, &! communicator to use for update messages ! LCOV_EXCL_LINE
50 : numLocalBlocks, &! number of local blocks, needed for halo fill ! LCOV_EXCL_LINE
51 : numLocalCopies, &! num local copies for halo update ! LCOV_EXCL_LINE
52 : tripoleRows ! number of rows in tripole buffer
53 :
54 : logical (log_kind) :: &
55 : tripoleTFlag ! NS boundary is a tripole T-fold
56 :
57 : integer (int_kind), dimension(:), pointer :: &
58 : blockGlobalID ! list of local block global IDs, needed for halo fill
59 :
60 : integer (int_kind), dimension(:,:), pointer :: &
61 : srcLocalAddr, &! src addresses for each local copy ! LCOV_EXCL_LINE
62 : dstLocalAddr ! dst addresses for each local copy
63 :
64 : end type
65 :
66 : public :: ice_HaloCreate, &
67 : ice_HaloMask, & ! LCOV_EXCL_LINE
68 : ice_HaloUpdate, & ! LCOV_EXCL_LINE
69 : ice_HaloUpdate_stress, & ! LCOV_EXCL_LINE
70 : ice_HaloExtrapolate, & ! LCOV_EXCL_LINE
71 : ice_HaloDestroy, & ! LCOV_EXCL_LINE
72 : primary_grid_lengths_global_ext
73 :
74 : interface ice_HaloUpdate ! generic interface
75 : module procedure ice_HaloUpdate2DR8, &
76 : ice_HaloUpdate2DR4, & ! LCOV_EXCL_LINE
77 : ice_HaloUpdate2DI4, & ! LCOV_EXCL_LINE
78 : ice_HaloUpdate2DL1, & ! LCOV_EXCL_LINE
79 : ice_HaloUpdate3DR8, & ! LCOV_EXCL_LINE
80 : ice_HaloUpdate3DR4, & ! LCOV_EXCL_LINE
81 : ice_HaloUpdate3DI4, & ! LCOV_EXCL_LINE
82 : ice_HaloUpdate4DR8, & ! LCOV_EXCL_LINE
83 : ice_HaloUpdate4DR4, & ! LCOV_EXCL_LINE
84 : ice_HaloUpdate4DI4
85 : end interface
86 :
87 : interface ice_HaloExtrapolate ! generic interface
88 : module procedure ice_HaloExtrapolate2DR8 !, &
89 : ! ice_HaloExtrapolate2DR4, & ! not yet ! LCOV_EXCL_LINE
90 : ! ice_HaloExtrapolate2DI4, & ! implemented ! LCOV_EXCL_LINE
91 : end interface
92 :
93 : !-----------------------------------------------------------------------
94 : !
95 : ! global buffers for tripole boundary
96 : !
97 : !-----------------------------------------------------------------------
98 :
99 : integer (int_kind), dimension(:,:), allocatable :: &
100 : bufTripoleI4
101 :
102 : real (real_kind), dimension(:,:), allocatable :: &
103 : bufTripoleR4
104 :
105 : real (dbl_kind), dimension(:,:), allocatable :: &
106 : bufTripoleR8
107 :
108 : !***********************************************************************
109 :
110 : contains
111 :
112 : !***********************************************************************
113 :
114 1 : function ice_HaloCreate(dist, nsBoundaryType, ewBoundaryType, &
115 : nxGlobal) result(halo)
116 :
117 : ! This routine creates a halo type with info necessary for
118 : ! performing a halo (ghost cell) update. This info is computed
119 : ! based on the input block distribution.
120 :
121 : type (distrb), intent(in) :: &
122 : dist ! distribution of blocks across procs
123 :
124 : character (*), intent(in) :: &
125 : nsBoundaryType, &! type of boundary to use in logical ns dir ! LCOV_EXCL_LINE
126 : ewBoundaryType ! type of boundary to use in logical ew dir
127 :
128 : integer (int_kind), intent(in) :: &
129 : nxGlobal ! global grid extent for tripole grids
130 :
131 : type (ice_halo) :: &
132 : halo ! a new halo type with info for halo updates
133 :
134 : !-----------------------------------------------------------------------
135 : !
136 : ! local variables
137 : !
138 : !-----------------------------------------------------------------------
139 :
140 : integer (int_kind) :: &
141 : istat, &! allocate status flag ! LCOV_EXCL_LINE
142 : numProcs, &! num of processors involved ! LCOV_EXCL_LINE
143 : communicator, &! communicator for message passing ! LCOV_EXCL_LINE
144 : iblock, &! block counter ! LCOV_EXCL_LINE
145 : eastBlock, westBlock, &! block id east, west neighbors ! LCOV_EXCL_LINE
146 : northBlock, southBlock, &! block id north, south neighbors ! LCOV_EXCL_LINE
147 : neBlock, nwBlock, &! block id northeast, northwest nbrs ! LCOV_EXCL_LINE
148 : seBlock, swBlock, &! block id southeast, southwest nbrs ! LCOV_EXCL_LINE
149 : srcProc, dstProc, &! source, dest processor locations ! LCOV_EXCL_LINE
150 : srcLocalID, dstLocalID, &! local block index of src,dst blocks ! LCOV_EXCL_LINE
151 : blockSizeX, &! size of default physical domain in X ! LCOV_EXCL_LINE
152 : blockSizeY, &! size of default physical domain in Y ! LCOV_EXCL_LINE
153 : eastMsgSize, westMsgSize, &! nominal sizes for e-w msgs ! LCOV_EXCL_LINE
154 : northMsgSize, southMsgSize, &! nominal sizes for n-s msgs ! LCOV_EXCL_LINE
155 : tripoleRows, &! number of rows in tripole buffer ! LCOV_EXCL_LINE
156 : cornerMsgSize, msgSize ! nominal size for corner msg
157 :
158 : integer (int_kind), dimension(:), allocatable :: &
159 1 : sendCount, recvCount ! count number of words to each proc
160 :
161 : logical (log_kind) :: &
162 : tripoleBlock, &! flag for identifying north tripole blocks ! LCOV_EXCL_LINE
163 : tripoleTFlag ! flag for processing tripole buffer as T-fold
164 :
165 : character(len=*), parameter :: subname = '(ice_HaloCreate)'
166 :
167 : !-----------------------------------------------------------------------
168 : !
169 : ! Initialize some useful variables and return if this task not
170 : ! in the current distribution.
171 : !
172 : !-----------------------------------------------------------------------
173 :
174 : call ice_distributionGet(dist, &
175 : nprocs = numProcs, & ! LCOV_EXCL_LINE
176 1 : communicator = communicator)
177 :
178 1 : if (my_task >= numProcs) return
179 :
180 1 : halo%communicator = communicator
181 :
182 1 : blockSizeX = nx_block - 2*nghost
183 1 : blockSizeY = ny_block - 2*nghost
184 1 : eastMsgSize = nghost*blockSizeY
185 1 : westMsgSize = nghost*blockSizeY
186 1 : southMsgSize = nghost*blockSizeX
187 1 : cornerMsgSize = nghost*nghost
188 1 : tripoleRows = nghost+1
189 :
190 : !*** store some block info to fill haloes properly
191 1 : call ice_distributionGet(dist, numLocalBlocks=halo%numLocalBlocks)
192 1 : if (halo%numLocalBlocks > 0) then
193 1 : allocate(halo%blockGlobalID(halo%numLocalBlocks))
194 1 : call ice_distributionGet(dist, blockGlobalID=halo%blockGlobalID)
195 : endif
196 :
197 1 : if (nsBoundaryType == 'tripole' .or. nsBoundaryType == 'tripoleT') then
198 0 : tripoleTFlag = (nsBoundaryType == 'tripoleT')
199 0 : if (tripoleTflag) tripoleRows = tripoleRows+1
200 0 : northMsgSize = tripoleRows*blockSizeX
201 :
202 : !*** allocate tripole message buffers if not already done
203 :
204 0 : if (.not. allocated(bufTripoleR8)) then
205 : allocate (bufTripoleI4(nxGlobal, tripoleRows), &
206 : bufTripoleR4(nxGlobal, tripoleRows), & ! LCOV_EXCL_LINE
207 : bufTripoleR8(nxGlobal, tripoleRows), & ! LCOV_EXCL_LINE
208 0 : stat=istat)
209 :
210 0 : if (istat > 0) then
211 0 : call abort_ice(subname//'ERROR: allocating tripole buffers')
212 0 : return
213 : endif
214 : endif
215 :
216 : else
217 1 : tripoleTFlag = .false.
218 1 : northMsgSize = nghost*blockSizeX
219 : endif
220 1 : halo%tripoleTFlag = tripoleTFlag
221 1 : halo%tripoleRows = tripoleRows
222 :
223 : !-----------------------------------------------------------------------
224 : !
225 : ! Count the number of messages to send/recv from each processor
226 : ! and number of words in each message. These quantities are
227 : ! necessary for allocating future arrays.
228 : !
229 : !-----------------------------------------------------------------------
230 :
231 1 : allocate (sendCount(numProcs), recvCount(numProcs), stat=istat)
232 :
233 1 : if (istat > 0) then
234 0 : call abort_ice(subname//'ERROR: allocating count arrays')
235 0 : return
236 : endif
237 :
238 2 : sendCount = 0
239 2 : recvCount = 0
240 :
241 2 : msgCountLoop: do iblock=1,nblocks_tot
242 :
243 : call ice_distributionGetBlockLoc(dist, iblock, srcProc, &
244 1 : srcLocalID)
245 :
246 : !*** find north neighbor block and add to message count
247 : !*** also set tripole block flag for later special cases
248 :
249 : northBlock = ice_blocksGetNbrID(iblock, ice_blocksNorth, &
250 1 : ewBoundaryType, nsBoundaryType)
251 1 : if (northBlock > 0) then
252 0 : tripoleBlock = .false.
253 : call ice_distributionGetBlockLoc(dist, northBlock, dstProc, &
254 0 : dstLocalID)
255 1 : else if (northBlock < 0) then ! tripole north row, count block
256 0 : tripoleBlock = .true.
257 : call ice_distributionGetBlockLoc(dist, abs(northBlock), &
258 0 : dstProc, dstLocalID)
259 : else
260 1 : tripoleBlock = .false.
261 1 : dstProc = 0
262 1 : dstLocalID = 0
263 : endif
264 :
265 : call ice_HaloIncrementMsgCount(sendCount, recvCount, &
266 1 : srcProc, dstProc, northMsgSize)
267 :
268 : !*** if a tripole boundary block, also create a local
269 : !*** message into and out of tripole buffer
270 :
271 1 : if (tripoleBlock) then
272 : !*** copy in
273 : call ice_HaloIncrementMsgCount(sendCount, recvCount, &
274 : srcProc, srcProc, & ! LCOV_EXCL_LINE
275 0 : northMsgSize)
276 :
277 : !*** copy out of tripole buffer - includes halo
278 : call ice_HaloIncrementMsgCount(sendCount, recvCount, &
279 : srcProc, srcProc, & ! LCOV_EXCL_LINE
280 0 : (nghost+1)*nx_block)
281 : endif
282 :
283 : !*** find south neighbor block and add to message count
284 :
285 : southBlock = ice_blocksGetNbrID(iblock, ice_blocksSouth, &
286 1 : ewBoundaryType, nsBoundaryType)
287 :
288 1 : if (southBlock > 0) then
289 : call ice_distributionGetBlockLoc(dist, southBlock, dstProc, &
290 0 : dstLocalID)
291 : else
292 1 : dstProc = 0
293 1 : dstLocalID = 0
294 : endif
295 :
296 : call ice_HaloIncrementMsgCount(sendCount, recvCount, &
297 1 : srcProc, dstProc, southMsgSize)
298 :
299 : !*** find east neighbor block and add to message count
300 :
301 : eastBlock = ice_blocksGetNbrID(iblock, ice_blocksEast, &
302 1 : ewBoundaryType, nsBoundaryType)
303 :
304 1 : if (eastBlock > 0) then
305 : call ice_distributionGetBlockLoc(dist, eastBlock, dstProc, &
306 1 : dstLocalID)
307 : else
308 0 : dstProc = 0
309 0 : dstLocalID = 0
310 : endif
311 :
312 : call ice_HaloIncrementMsgCount(sendCount, recvCount, &
313 1 : srcProc, dstProc, eastMsgSize)
314 :
315 : !*** if a tripole boundary block, non-local east neighbor
316 : !*** needs a chunk of the north boundary, so add a message
317 : !*** for that
318 :
319 : !echmod if (tripoleBlock .and. dstProc /= srcProc) then
320 : ! tcx,tcraig, 3/2023, this is not needed
321 : ! if (tripoleBlock) then
322 : ! call ice_HaloIncrementMsgCount(sendCount, recvCount, &
323 : ! srcProc, dstProc, northMsgSize)
324 : ! endif
325 :
326 : !*** find west neighbor block and add to message count
327 :
328 : westBlock = ice_blocksGetNbrID(iblock, ice_blocksWest, &
329 1 : ewBoundaryType, nsBoundaryType)
330 :
331 1 : if (westBlock > 0) then
332 : call ice_distributionGetBlockLoc(dist, westBlock, dstProc, &
333 1 : dstLocalID)
334 : else
335 0 : dstProc = 0
336 0 : dstLocalID = 0
337 : endif
338 :
339 : call ice_HaloIncrementMsgCount(sendCount, recvCount, &
340 1 : srcProc, dstProc, westMsgSize)
341 :
342 : !*** if a tripole boundary block, non-local west neighbor
343 : !*** needs a chunk of the north boundary, so add a message
344 : !*** for that
345 :
346 : !echmod if (tripoleBlock .and. dstProc /= srcProc) then
347 : ! tcx,tcraig, 3/2023, this is not needed
348 : ! if (tripoleBlock) then
349 : ! call ice_HaloIncrementMsgCount(sendCount, recvCount, &
350 : ! srcProc, dstProc, northMsgSize)
351 : ! endif
352 :
353 : !*** find northeast neighbor block and add to message count
354 :
355 : neBlock = ice_blocksGetNbrID(iblock, ice_blocksNorthEast, &
356 1 : ewBoundaryType, nsBoundaryType)
357 :
358 1 : if (neBlock > 0) then
359 0 : msgSize = cornerMsgSize ! normal corner message
360 :
361 : call ice_distributionGetBlockLoc(dist, neBlock, dstProc, &
362 0 : dstLocalID)
363 :
364 : ! tcx,tcraig, 3/2023, this is not needed
365 : ! else if (neBlock < 0) then ! tripole north row
366 : ! msgSize = northMsgSize ! tripole needs whole top row of block
367 : !
368 : ! call ice_distributionGetBlockLoc(dist, abs(neBlock), dstProc, &
369 : ! dstLocalID)
370 : else
371 1 : dstProc = 0
372 1 : dstLocalID = 0
373 : endif
374 :
375 : call ice_HaloIncrementMsgCount(sendCount, recvCount, &
376 1 : srcProc, dstProc, msgSize)
377 :
378 : !*** find northwest neighbor block and add to message count
379 :
380 : nwBlock = ice_blocksGetNbrID(iblock, ice_blocksNorthWest, &
381 1 : ewBoundaryType, nsBoundaryType)
382 :
383 1 : if (nwBlock > 0) then
384 0 : msgSize = cornerMsgSize ! normal NE corner update
385 :
386 : call ice_distributionGetBlockLoc(dist, nwBlock, dstProc, &
387 0 : dstLocalID)
388 :
389 : ! tcx,tcraig, 3/2023, this is not needed
390 : ! else if (nwBlock < 0) then ! tripole north row, count block
391 : ! msgSize = northMsgSize ! tripole NE corner update - entire row needed
392 : !
393 : ! call ice_distributionGetBlockLoc(dist, abs(nwBlock), dstProc, &
394 : ! dstLocalID)
395 :
396 : else
397 1 : dstProc = 0
398 1 : dstLocalID = 0
399 : endif
400 :
401 : call ice_HaloIncrementMsgCount(sendCount, recvCount, &
402 1 : srcProc, dstProc, msgSize)
403 :
404 : !*** find southeast neighbor block and add to message count
405 :
406 : seBlock = ice_blocksGetNbrID(iblock, ice_blocksSouthEast, &
407 1 : ewBoundaryType, nsBoundaryType)
408 :
409 1 : if (seBlock > 0) then
410 : call ice_distributionGetBlockLoc(dist, seBlock, dstProc, &
411 0 : dstLocalID)
412 : else
413 1 : dstProc = 0
414 1 : dstLocalID = 0
415 : endif
416 :
417 : call ice_HaloIncrementMsgCount(sendCount, recvCount, &
418 1 : srcProc, dstProc, cornerMsgSize)
419 :
420 : !*** find southwest neighbor block and add to message count
421 :
422 : swBlock = ice_blocksGetNbrID(iblock, ice_blocksSouthWest, &
423 1 : ewBoundaryType, nsBoundaryType)
424 :
425 1 : if (swBlock > 0) then
426 : call ice_distributionGetBlockLoc(dist, swBlock, dstProc, &
427 0 : dstLocalID)
428 : else
429 1 : dstProc = 0
430 1 : dstLocalID = 0
431 : endif
432 :
433 : call ice_HaloIncrementMsgCount(sendCount, recvCount, &
434 3 : srcProc, dstProc, cornerMsgSize)
435 :
436 : end do msgCountLoop
437 :
438 : !-----------------------------------------------------------------------
439 : !
440 : ! if messages are received from the same processor, the message is
441 : ! actually a local copy - count them and reset to zero
442 : !
443 : !-----------------------------------------------------------------------
444 :
445 1 : halo%numLocalCopies = recvCount(my_task+1)
446 :
447 1 : sendCount(my_task+1) = 0
448 1 : recvCount(my_task+1) = 0
449 :
450 : !-----------------------------------------------------------------------
451 : !
452 : ! allocate arrays for message information and initialize
453 : !
454 : !-----------------------------------------------------------------------
455 :
456 : allocate(halo%srcLocalAddr(3,halo%numLocalCopies), &
457 : halo%dstLocalAddr(3,halo%numLocalCopies), & ! LCOV_EXCL_LINE
458 1 : stat = istat)
459 :
460 1 : if (istat > 0) then
461 0 : call abort_ice(subname//'ERROR: allocating halo message info arrays')
462 0 : return
463 : endif
464 :
465 929 : halo%srcLocalAddr = 0
466 929 : halo%dstLocalAddr = 0
467 :
468 1 : deallocate(sendCount, recvCount, stat=istat)
469 :
470 1 : if (istat > 0) then
471 0 : call abort_ice(subname//'ERROR: deallocating count arrays')
472 0 : return
473 : endif
474 :
475 : !-----------------------------------------------------------------------
476 : !
477 : ! repeat loop through blocks but this time, determine all the
478 : ! required message information for each message or local copy
479 : !
480 : !-----------------------------------------------------------------------
481 :
482 : !*** reset halo scalars to use as counters
483 :
484 1 : halo%numLocalCopies = 0
485 :
486 2 : msgConfigLoop: do iblock=1,nblocks_tot
487 :
488 : call ice_distributionGetBlockLoc(dist, iblock, srcProc, &
489 1 : srcLocalID)
490 :
491 : !*** find north neighbor block
492 :
493 : northBlock = ice_blocksGetNbrID(iblock, ice_blocksNorth, &
494 1 : ewBoundaryType, nsBoundaryType)
495 :
496 : !*** set tripole flag and add two copies for inserting
497 : !*** and extracting info from the tripole buffer
498 :
499 1 : if (northBlock < 0) then
500 0 : tripoleBlock = .true.
501 0 : call ice_HaloMsgCreate(halo, dist, iblock, -iblock, 'north')
502 0 : call ice_HaloMsgCreate(halo, dist, -iblock, iblock, 'north')
503 : else
504 1 : tripoleBlock = .false.
505 1 : call ice_HaloMsgCreate(halo, dist, iblock, northBlock, 'north')
506 : endif
507 :
508 : !*** find south neighbor block
509 :
510 : southBlock = ice_blocksGetNbrID(iblock, ice_blocksSouth, &
511 1 : ewBoundaryType, nsBoundaryType)
512 :
513 1 : call ice_HaloMsgCreate(halo, dist, iblock, southBlock, 'south')
514 :
515 : !*** find east neighbor block
516 :
517 : eastBlock = ice_blocksGetNbrID(iblock, ice_blocksEast, &
518 1 : ewBoundaryType, nsBoundaryType)
519 :
520 1 : call ice_HaloMsgCreate(halo, dist, iblock, eastBlock, 'east')
521 :
522 : !*** for tripole grids, send a north tripole message to
523 : !*** the east block to make sure enough information is
524 : !*** available for tripole manipulations
525 :
526 : ! tcx,tcraig, 3/2023, this is not needed
527 : ! if (tripoleBlock) then
528 : ! call ice_HaloMsgCreate(halo, dist, iblock, -eastBlock, 'north')
529 : ! endif
530 :
531 : !*** find west neighbor block
532 :
533 : westBlock = ice_blocksGetNbrID(iblock, ice_blocksWest, &
534 1 : ewBoundaryType, nsBoundaryType)
535 :
536 1 : call ice_HaloMsgCreate(halo, dist, iblock, westBlock, 'west')
537 :
538 : !*** for tripole grids, send a north tripole message to
539 : !*** the west block to make sure enough information is
540 : !*** available for tripole manipulations
541 :
542 : ! tcx,tcraig, 3/2023, this is not needed
543 : ! if (tripoleBlock) then
544 : ! call ice_HaloMsgCreate(halo, dist, iblock, -westBlock, 'north')
545 : ! endif
546 :
547 : !*** find northeast neighbor block
548 :
549 : neBlock = ice_blocksGetNbrID(iblock, ice_blocksNorthEast, &
550 1 : ewBoundaryType, nsBoundaryType)
551 :
552 1 : call ice_HaloMsgCreate(halo, dist, iblock, neBlock, 'northeast')
553 :
554 : !*** find northwest neighbor block
555 :
556 : nwBlock = ice_blocksGetNbrID(iblock, ice_blocksNorthWest, &
557 1 : ewBoundaryType, nsBoundaryType)
558 :
559 1 : call ice_HaloMsgCreate(halo, dist, iblock, nwBlock, 'northwest')
560 :
561 : !*** find southeast neighbor block
562 :
563 : seBlock = ice_blocksGetNbrID(iblock, ice_blocksSouthEast, &
564 1 : ewBoundaryType, nsBoundaryType)
565 :
566 1 : call ice_HaloMsgCreate(halo, dist, iblock, seBlock, 'southeast')
567 :
568 : !*** find southwest neighbor block
569 :
570 : swBlock = ice_blocksGetNbrID(iblock, ice_blocksSouthWest, &
571 1 : ewBoundaryType, nsBoundaryType)
572 :
573 3 : call ice_HaloMsgCreate(halo, dist, iblock, swBlock, 'southwest')
574 :
575 : end do msgConfigLoop
576 :
577 : !-----------------------------------------------------------------------
578 :
579 2 : end function ice_HaloCreate
580 :
581 : !***********************************************************************
582 :
583 0 : subroutine ice_HaloMask(halo, basehalo, mask)
584 :
585 : ! This routine creates a halo type with info necessary for
586 : ! performing a halo (ghost cell) update. This info is computed
587 : ! based on a base halo already initialized and a mask
588 :
589 : use ice_domain_size, only: max_blocks
590 :
591 : type (ice_halo) :: &
592 : basehalo ! basehalo to mask
593 : integer (int_kind), intent(in) :: &
594 : mask(nx_block,ny_block,max_blocks) ! mask of live points
595 :
596 : type (ice_halo) :: &
597 : halo ! a new halo type with info for halo updates
598 :
599 : !-----------------------------------------------------------------------
600 : !
601 : ! local variables
602 : !
603 : !-----------------------------------------------------------------------
604 :
605 : integer (int_kind) :: &
606 : istat, &! allocate status flag ! LCOV_EXCL_LINE
607 : communicator, &! communicator for message passing ! LCOV_EXCL_LINE
608 : numLocalCopies, &! num local copies for halo update ! LCOV_EXCL_LINE
609 : numLocalBlocks, &! num local blocks for halo fill ! LCOV_EXCL_LINE
610 : tripoleRows ! number of rows in tripole buffer
611 :
612 : logical (log_kind) :: &
613 : tripoleTFlag ! flag for processing tripole buffer as T-fold
614 :
615 : character(len=*), parameter :: subname = '(ice_HaloMask)'
616 :
617 : !-----------------------------------------------------------------------
618 : !
619 : ! allocate and initialize halo
620 : ! halos are not masked for local copies
621 : !
622 : !-----------------------------------------------------------------------
623 :
624 0 : communicator = basehalo%communicator
625 0 : tripoleRows = basehalo%tripoleRows
626 0 : tripoleTFlag = basehalo%tripoleTFlag
627 0 : numLocalCopies = basehalo%numLocalCopies
628 0 : numLocalBlocks = basehalo%numLocalBlocks
629 :
630 : allocate(halo%srcLocalAddr(3,numLocalCopies), &
631 : halo%dstLocalAddr(3,numLocalCopies), & ! LCOV_EXCL_LINE
632 : halo%blockGlobalID(numLocalBlocks), & ! LCOV_EXCL_LINE
633 0 : stat = istat)
634 :
635 0 : if (istat > 0) then
636 0 : call abort_ice(subname//'ERROR: allocating halo message info arrays')
637 0 : return
638 : endif
639 :
640 0 : halo%communicator = communicator
641 0 : halo%tripoleRows = tripoleRows
642 0 : halo%tripoleTFlag = tripoleTFlag
643 0 : halo%numLocalCopies = numLocalCopies
644 0 : halo%numLocalBlocks = numLocalBlocks
645 :
646 0 : halo%srcLocalAddr = basehalo%srcLocalAddr
647 0 : halo%dstLocalAddr = basehalo%dstLocalAddr
648 :
649 0 : halo%blockGlobalID = basehalo%blockGlobalID
650 :
651 : !-----------------------------------------------------------------------
652 :
653 : end subroutine ice_HaloMask
654 :
655 : !***********************************************************************
656 :
657 11832 : subroutine ice_HaloUpdate2DR8(array, halo, &
658 : fieldLoc, fieldKind, & ! LCOV_EXCL_LINE
659 : fillValue, tripoleOnly)
660 :
661 : ! This routine updates ghost cells for an input array and is a
662 : ! member of a group of routines under the generic interface
663 : ! POP\_HaloUpdate. This routine is the specific interface
664 : ! for 2d horizontal arrays of double precision.
665 :
666 : type (ice_halo), intent(in) :: &
667 : halo ! precomputed halo structure containing all
668 : ! information needed for halo update
669 :
670 : integer (int_kind), intent(in) :: &
671 : fieldKind, &! id for type of field (scalar, vector, angle) ! LCOV_EXCL_LINE
672 : fieldLoc ! id for location on horizontal grid
673 : ! (center, NEcorner, Nface, Eface)
674 :
675 : real (dbl_kind), intent(in), optional :: &
676 : fillValue ! optional value to put in ghost cells
677 : ! where neighbor points are unknown
678 : ! (e.g. eliminated land blocks or
679 : ! closed boundaries)
680 :
681 : logical (log_kind), intent(in), optional :: &
682 : tripoleOnly ! optional flag to execute halo only across tripole seam
683 :
684 : real (dbl_kind), dimension(:,:,:), intent(inout) :: &
685 : array ! array containing field for which halo
686 : ! needs to be updated
687 :
688 : !-----------------------------------------------------------------------
689 : !
690 : ! local variables
691 : !
692 : !-----------------------------------------------------------------------
693 :
694 : integer (int_kind) :: &
695 : i,j,nmsg, &! dummy loop indices ! LCOV_EXCL_LINE
696 : iblk,ilo,ihi,jlo,jhi, &! block sizes for fill ! LCOV_EXCL_LINE
697 : nxGlobal, &! global domain size in x (tripole) ! LCOV_EXCL_LINE
698 : iSrc,jSrc, &! source addresses for message ! LCOV_EXCL_LINE
699 : iDst,jDst, &! dest addresses for message ! LCOV_EXCL_LINE
700 : srcBlock, &! local block number for source ! LCOV_EXCL_LINE
701 : dstBlock, &! local block number for destination ! LCOV_EXCL_LINE
702 : ioffset, joffset, &! address shifts for tripole ! LCOV_EXCL_LINE
703 : isign ! sign factor for tripole grids
704 :
705 : real (dbl_kind) :: &
706 : fill, &! value to use for unknown points ! LCOV_EXCL_LINE
707 : x1,x2,xavg ! scalars for enforcing symmetry at U pts
708 :
709 : logical (log_kind) :: &
710 : ltripoleOnly ! local tripoleOnly value
711 :
712 : character(len=*), parameter :: subname = '(ice_HaloUpdate2DR8)'
713 :
714 : !-----------------------------------------------------------------------
715 : !
716 : ! abort or return on unknown or noupdate field_loc or field_type
717 : !
718 : !-----------------------------------------------------------------------
719 :
720 11832 : if (fieldLoc == field_loc_unknown .or. &
721 : fieldKind == field_type_unknown) then
722 0 : call abort_ice(subname//'ERROR: use of field_loc/type_unknown not allowed')
723 0 : return
724 : endif
725 :
726 11832 : if (fieldLoc == field_loc_noupdate .or. &
727 : fieldKind == field_type_noupdate) then
728 0 : return
729 : endif
730 :
731 : !-----------------------------------------------------------------------
732 : !
733 : ! initialize error code and fill value
734 : !
735 : !-----------------------------------------------------------------------
736 :
737 11832 : if (present(fillValue)) then
738 17 : fill = fillValue
739 : else
740 11815 : fill = 0.0_dbl_kind
741 : endif
742 :
743 11832 : if (present(tripoleOnly)) then
744 8 : ltripoleOnly = tripoleOnly
745 : else
746 11824 : ltripoleOnly = .false.
747 : endif
748 :
749 11832 : nxGlobal = 0
750 11832 : if (allocated(bufTripoleR8)) then
751 0 : nxGlobal = size(bufTripoleR8,dim=1)
752 0 : bufTripoleR8 = fill
753 : endif
754 :
755 : !-----------------------------------------------------------------------
756 : !
757 : ! fill out halo region
758 : ! needed for masked halos to ensure halo values are filled for
759 : ! halo grid cells that are not updated
760 : !
761 : !-----------------------------------------------------------------------
762 :
763 11832 : if (ltripoleOnly) then
764 : ! skip fill, not needed since tripole seam always exists if running
765 : ! on tripole grid and set tripoleOnly flag
766 : else
767 23648 : do iblk = 1, halo%numLocalBlocks
768 : call get_block_parameter(halo%blockGlobalID(iblk), &
769 : ilo=ilo, ihi=ihi, & ! LCOV_EXCL_LINE
770 11824 : jlo=jlo, jhi=jhi)
771 23648 : do j = 1,nghost
772 1217872 : array(1:nx_block, jlo-j,iblk) = fill
773 1229696 : array(1:nx_block, jhi+j,iblk) = fill
774 : enddo
775 47296 : do i = 1,nghost
776 1407056 : array(ilo-i, 1:ny_block,iblk) = fill
777 1418880 : array(ihi+i, 1:ny_block,iblk) = fill
778 : enddo
779 : enddo
780 : endif
781 :
782 : !-----------------------------------------------------------------------
783 : !
784 : ! do local copies while waiting for messages to complete
785 : ! if srcBlock is zero, that denotes an eliminated land block or a
786 : ! closed boundary where ghost cell values are undefined
787 : ! if srcBlock is less than zero, the message is a copy out of the
788 : ! tripole buffer and will be treated later
789 : !
790 : !-----------------------------------------------------------------------
791 :
792 2756856 : do nmsg=1,halo%numLocalCopies
793 2745024 : iSrc = halo%srcLocalAddr(1,nmsg)
794 2745024 : jSrc = halo%srcLocalAddr(2,nmsg)
795 2745024 : srcBlock = halo%srcLocalAddr(3,nmsg)
796 2745024 : iDst = halo%dstLocalAddr(1,nmsg)
797 2745024 : jDst = halo%dstLocalAddr(2,nmsg)
798 2745024 : dstBlock = halo%dstLocalAddr(3,nmsg)
799 :
800 2756856 : if (ltripoleOnly) then
801 1856 : if (srcBlock > 0) then
802 1856 : if (dstBlock < 0) then ! tripole copy into buffer
803 : bufTripoleR8(iDst,jDst) = &
804 0 : array(iSrc,jSrc,srcBlock)
805 : endif
806 : endif
807 : else
808 2743168 : if (srcBlock > 0) then
809 2743168 : if (dstBlock > 0) then
810 : array(iDst,jDst,dstBlock) = &
811 2743168 : array(iSrc,jSrc,srcBlock)
812 0 : else if (dstBlock < 0) then ! tripole copy into buffer
813 : bufTripoleR8(iDst,jDst) = &
814 0 : array(iSrc,jSrc,srcBlock)
815 : endif
816 0 : else if (srcBlock == 0) then
817 0 : array(iDst,jDst,dstBlock) = fill
818 : endif
819 : endif
820 : end do
821 :
822 : !-----------------------------------------------------------------------
823 : !
824 : ! take care of northern boundary in tripole case
825 : ! bufTripole array contains the top nghost+1 rows (u-fold) or nghost+2 rows
826 : ! (T-fold) of physical domain for entire (global) top row
827 : !
828 : !-----------------------------------------------------------------------
829 :
830 11832 : if (nxGlobal > 0) then
831 :
832 0 : select case (fieldKind)
833 : case (field_type_scalar)
834 0 : isign = 1
835 : case (field_type_vector)
836 0 : isign = -1
837 : case (field_type_angle)
838 0 : isign = -1
839 : case default
840 0 : call abort_ice(subname//'ERROR: Unknown field kind')
841 : end select
842 :
843 0 : if (halo%tripoleTFlag) then
844 :
845 0 : select case (fieldLoc)
846 : case (field_loc_center) ! cell center location
847 :
848 0 : ioffset = -1
849 0 : joffset = 0
850 :
851 : !*** top row is degenerate, so must enforce symmetry
852 : !*** use average of two degenerate points for value
853 :
854 0 : do i = 2,nxGlobal/2
855 0 : iDst = nxGlobal - i + 2
856 0 : x1 = bufTripoleR8(i ,halo%tripoleRows)
857 0 : x2 = bufTripoleR8(iDst,halo%tripoleRows)
858 0 : xavg = 0.5_dbl_kind*(x1 + isign*x2)
859 0 : bufTripoleR8(i ,halo%tripoleRows) = xavg
860 0 : bufTripoleR8(iDst,halo%tripoleRows) = isign*xavg
861 : end do
862 :
863 : case (field_loc_NEcorner) ! cell corner location
864 :
865 0 : ioffset = 0
866 0 : joffset = 1
867 :
868 : case (field_loc_Eface) ! cell center location
869 :
870 0 : ioffset = 0
871 0 : joffset = 0
872 :
873 : !*** top row is degenerate, so must enforce symmetry
874 : !*** use average of two degenerate points for value
875 :
876 0 : do i = 1,nxGlobal/2
877 0 : iDst = nxGlobal + 1 - i
878 0 : x1 = bufTripoleR8(i ,halo%tripoleRows)
879 0 : x2 = bufTripoleR8(iDst,halo%tripoleRows)
880 0 : xavg = 0.5_dbl_kind*(x1 + isign*x2)
881 0 : bufTripoleR8(i ,halo%tripoleRows) = xavg
882 0 : bufTripoleR8(iDst,halo%tripoleRows) = isign*xavg
883 : end do
884 :
885 : case (field_loc_Nface) ! cell corner (velocity) location
886 :
887 0 : ioffset = -1
888 0 : joffset = 1
889 :
890 : case default
891 0 : call abort_ice(subname//'ERROR: Unknown field location')
892 : end select
893 :
894 : else ! tripole u-fold
895 :
896 0 : select case (fieldLoc)
897 : case (field_loc_center) ! cell center location
898 :
899 0 : ioffset = 0
900 0 : joffset = 0
901 :
902 : case (field_loc_NEcorner) ! cell corner location
903 :
904 0 : ioffset = 1
905 0 : joffset = 1
906 :
907 : !*** top row is degenerate, so must enforce symmetry
908 : !*** use average of two degenerate points for value
909 :
910 0 : do i = 1,nxGlobal/2 - 1
911 0 : iDst = nxGlobal - i
912 0 : x1 = bufTripoleR8(i ,halo%tripoleRows)
913 0 : x2 = bufTripoleR8(iDst,halo%tripoleRows)
914 0 : xavg = 0.5_dbl_kind*(x1 + isign*x2)
915 0 : bufTripoleR8(i ,halo%tripoleRows) = xavg
916 0 : bufTripoleR8(iDst,halo%tripoleRows) = isign*xavg
917 : end do
918 :
919 : case (field_loc_Eface) ! cell center location
920 :
921 0 : ioffset = 1
922 0 : joffset = 0
923 :
924 : case (field_loc_Nface) ! cell corner (velocity) location
925 :
926 0 : ioffset = 0
927 0 : joffset = 1
928 :
929 : !*** top row is degenerate, so must enforce symmetry
930 : !*** use average of two degenerate points for value
931 :
932 0 : do i = 1,nxGlobal/2
933 0 : iDst = nxGlobal + 1 - i
934 0 : x1 = bufTripoleR8(i ,halo%tripoleRows)
935 0 : x2 = bufTripoleR8(iDst,halo%tripoleRows)
936 0 : xavg = 0.5_dbl_kind*(x1 + isign*x2)
937 0 : bufTripoleR8(i ,halo%tripoleRows) = xavg
938 0 : bufTripoleR8(iDst,halo%tripoleRows) = isign*xavg
939 : end do
940 :
941 : case default
942 0 : call abort_ice(subname//'ERROR: Unknown field location')
943 : end select
944 :
945 : endif
946 :
947 : !*** copy out of global tripole buffer into local
948 : !*** ghost cells
949 :
950 : !*** look through local copies to find the copy out
951 : !*** messages (srcBlock < 0)
952 :
953 0 : do nmsg=1,halo%numLocalCopies
954 0 : srcBlock = halo%srcLocalAddr(3,nmsg)
955 :
956 0 : if (srcBlock < 0) then
957 :
958 0 : iSrc = halo%srcLocalAddr(1,nmsg) ! tripole buffer addr
959 0 : jSrc = halo%srcLocalAddr(2,nmsg)
960 :
961 0 : iDst = halo%dstLocalAddr(1,nmsg) ! local block addr
962 0 : jDst = halo%dstLocalAddr(2,nmsg)
963 0 : dstBlock = halo%dstLocalAddr(3,nmsg)
964 :
965 : !*** correct for offsets
966 0 : iSrc = iSrc - ioffset
967 0 : jSrc = jSrc - joffset
968 0 : if (iSrc < 1 ) iSrc = iSrc + nxGlobal
969 0 : if (iSrc > nxGlobal) iSrc = iSrc - nxGlobal
970 :
971 : !*** for center and Eface on u-fold, and NE corner and Nface
972 : !*** on T-fold, do not need to replace
973 : !*** top row of physical domain, so jSrc should be
974 : !*** out of range and skipped
975 : !*** otherwise do the copy
976 :
977 0 : if (jSrc <= halo%tripoleRows .and. jSrc>0 .and. jDst>0) then
978 0 : array(iDst,jDst,dstBlock) = isign*bufTripoleR8(iSrc,jSrc)
979 : endif
980 :
981 : endif
982 : end do
983 :
984 : endif
985 :
986 : !-----------------------------------------------------------------------
987 :
988 : end subroutine ice_HaloUpdate2DR8
989 :
990 : !***********************************************************************
991 :
992 0 : subroutine ice_HaloUpdate2DR4(array, halo, &
993 : fieldLoc, fieldKind, & ! LCOV_EXCL_LINE
994 : fillValue)
995 :
996 : ! This routine updates ghost cells for an input array and is a
997 : ! member of a group of routines under the generic interface
998 : ! POP\_HaloUpdate. This routine is the specific interface
999 : ! for 2d horizontal arrays of single precision.
1000 :
1001 : type (ice_halo), intent(in) :: &
1002 : halo ! precomputed halo structure containing all
1003 : ! information needed for halo update
1004 :
1005 : integer (int_kind), intent(in) :: &
1006 : fieldKind, &! id for type of field (scalar, vector, angle) ! LCOV_EXCL_LINE
1007 : fieldLoc ! id for location on horizontal grid
1008 : ! (center, NEcorner, Nface, Eface)
1009 :
1010 : real (real_kind), intent(in), optional :: &
1011 : fillValue ! optional value to put in ghost cells
1012 : ! where neighbor points are unknown
1013 : ! (e.g. eliminated land blocks or
1014 : ! closed boundaries)
1015 :
1016 : real (real_kind), dimension(:,:,:), intent(inout) :: &
1017 : array ! array containing field for which halo
1018 : ! needs to be updated
1019 :
1020 : !-----------------------------------------------------------------------
1021 : !
1022 : ! local variables
1023 : !
1024 : !-----------------------------------------------------------------------
1025 :
1026 : integer (int_kind) :: &
1027 : i,j,nmsg, &! dummy loop indices ! LCOV_EXCL_LINE
1028 : iblk,ilo,ihi,jlo,jhi, &! block sizes for fill ! LCOV_EXCL_LINE
1029 : nxGlobal, &! global domain size in x (tripole) ! LCOV_EXCL_LINE
1030 : iSrc,jSrc, &! source addresses for message ! LCOV_EXCL_LINE
1031 : iDst,jDst, &! dest addresses for message ! LCOV_EXCL_LINE
1032 : srcBlock, &! local block number for source ! LCOV_EXCL_LINE
1033 : dstBlock, &! local block number for destination ! LCOV_EXCL_LINE
1034 : ioffset, joffset, &! address shifts for tripole ! LCOV_EXCL_LINE
1035 : isign ! sign factor for tripole grids
1036 :
1037 : real (real_kind) :: &
1038 : fill, &! value to use for unknown points ! LCOV_EXCL_LINE
1039 : x1,x2,xavg ! scalars for enforcing symmetry at U pts
1040 :
1041 : character(len=*), parameter :: subname = '(ice_HaloUpdate2DR4)'
1042 :
1043 : !-----------------------------------------------------------------------
1044 : !
1045 : ! abort or return on unknown or noupdate field_loc or field_type
1046 : !
1047 : !-----------------------------------------------------------------------
1048 :
1049 0 : if (fieldLoc == field_loc_unknown .or. &
1050 : fieldKind == field_type_unknown) then
1051 0 : call abort_ice(subname//'ERROR: use of field_loc/type_unknown not allowed')
1052 0 : return
1053 : endif
1054 :
1055 0 : if (fieldLoc == field_loc_noupdate .or. &
1056 : fieldKind == field_type_noupdate) then
1057 0 : return
1058 : endif
1059 :
1060 : !-----------------------------------------------------------------------
1061 : !
1062 : ! initialize error code and fill value
1063 : !
1064 : !-----------------------------------------------------------------------
1065 :
1066 0 : if (present(fillValue)) then
1067 0 : fill = fillValue
1068 : else
1069 0 : fill = 0.0_real_kind
1070 : endif
1071 :
1072 0 : nxGlobal = 0
1073 0 : if (allocated(bufTripoleR4)) then
1074 0 : nxGlobal = size(bufTripoleR4,dim=1)
1075 0 : bufTripoleR4 = fill
1076 : endif
1077 :
1078 : !-----------------------------------------------------------------------
1079 : !
1080 : ! fill out halo region
1081 : ! needed for masked halos to ensure halo values are filled for
1082 : ! halo grid cells that are not updated
1083 : !
1084 : !-----------------------------------------------------------------------
1085 :
1086 0 : do iblk = 1, halo%numLocalBlocks
1087 : call get_block_parameter(halo%blockGlobalID(iblk), &
1088 : ilo=ilo, ihi=ihi, & ! LCOV_EXCL_LINE
1089 0 : jlo=jlo, jhi=jhi)
1090 0 : do j = 1,nghost
1091 0 : array(1:nx_block, jlo-j,iblk) = fill
1092 0 : array(1:nx_block, jhi+j,iblk) = fill
1093 : enddo
1094 0 : do i = 1,nghost
1095 0 : array(ilo-i, 1:ny_block,iblk) = fill
1096 0 : array(ihi+i, 1:ny_block,iblk) = fill
1097 : enddo
1098 : enddo
1099 :
1100 : !-----------------------------------------------------------------------
1101 : !
1102 : ! do local copies while waiting for messages to complete
1103 : ! if srcBlock is zero, that denotes an eliminated land block or a
1104 : ! closed boundary where ghost cell values are undefined
1105 : ! if srcBlock is less than zero, the message is a copy out of the
1106 : ! tripole buffer and will be treated later
1107 : !
1108 : !-----------------------------------------------------------------------
1109 :
1110 0 : do nmsg=1,halo%numLocalCopies
1111 0 : iSrc = halo%srcLocalAddr(1,nmsg)
1112 0 : jSrc = halo%srcLocalAddr(2,nmsg)
1113 0 : srcBlock = halo%srcLocalAddr(3,nmsg)
1114 0 : iDst = halo%dstLocalAddr(1,nmsg)
1115 0 : jDst = halo%dstLocalAddr(2,nmsg)
1116 0 : dstBlock = halo%dstLocalAddr(3,nmsg)
1117 :
1118 0 : if (srcBlock > 0) then
1119 0 : if (dstBlock > 0) then
1120 : array(iDst,jDst,dstBlock) = &
1121 0 : array(iSrc,jSrc,srcBlock)
1122 0 : else if (dstBlock < 0) then ! tripole copy into buffer
1123 : bufTripoleR4(iDst,jDst) = &
1124 0 : array(iSrc,jSrc,srcBlock)
1125 : endif
1126 0 : else if (srcBlock == 0) then
1127 0 : array(iDst,jDst,dstBlock) = fill
1128 : endif
1129 : end do
1130 :
1131 : !-----------------------------------------------------------------------
1132 : !
1133 : ! take care of northern boundary in tripole case
1134 : ! bufTripole array contains the top nghost+1 rows (u-fold) or nghost+2 rows
1135 : ! (T-fold) of physical domain for entire (global) top row
1136 : !
1137 : !-----------------------------------------------------------------------
1138 :
1139 0 : if (nxGlobal > 0) then
1140 :
1141 0 : select case (fieldKind)
1142 : case (field_type_scalar)
1143 0 : isign = 1
1144 : case (field_type_vector)
1145 0 : isign = -1
1146 : case (field_type_angle)
1147 0 : isign = -1
1148 : case default
1149 0 : call abort_ice(subname//'ERROR: Unknown field kind')
1150 : end select
1151 :
1152 0 : if (halo%tripoleTFlag) then
1153 :
1154 0 : select case (fieldLoc)
1155 : case (field_loc_center) ! cell center location
1156 :
1157 0 : ioffset = -1
1158 0 : joffset = 0
1159 :
1160 : !*** top row is degenerate, so must enforce symmetry
1161 : !*** use average of two degenerate points for value
1162 :
1163 0 : do i = 2,nxGlobal/2
1164 0 : iDst = nxGlobal - i + 2
1165 0 : x1 = bufTripoleR4(i ,halo%tripoleRows)
1166 0 : x2 = bufTripoleR4(iDst,halo%tripoleRows)
1167 0 : xavg = 0.5_real_kind*(x1 + isign*x2)
1168 0 : bufTripoleR4(i ,halo%tripoleRows) = xavg
1169 0 : bufTripoleR4(iDst,halo%tripoleRows) = isign*xavg
1170 : end do
1171 :
1172 : case (field_loc_NEcorner) ! cell corner location
1173 :
1174 0 : ioffset = 0
1175 0 : joffset = 1
1176 :
1177 : case (field_loc_Eface) ! cell center location
1178 :
1179 0 : ioffset = 0
1180 0 : joffset = 0
1181 :
1182 : !*** top row is degenerate, so must enforce symmetry
1183 : !*** use average of two degenerate points for value
1184 :
1185 0 : do i = 1,nxGlobal/2
1186 0 : iDst = nxGlobal + 1 - i
1187 0 : x1 = bufTripoleR4(i ,halo%tripoleRows)
1188 0 : x2 = bufTripoleR4(iDst,halo%tripoleRows)
1189 0 : xavg = 0.5_real_kind*(x1 + isign*x2)
1190 0 : bufTripoleR4(i ,halo%tripoleRows) = xavg
1191 0 : bufTripoleR4(iDst,halo%tripoleRows) = isign*xavg
1192 : end do
1193 :
1194 : case (field_loc_Nface) ! cell corner (velocity) location
1195 :
1196 0 : ioffset = -1
1197 0 : joffset = 1
1198 :
1199 : case default
1200 0 : call abort_ice(subname//'ERROR: Unknown field location')
1201 : end select
1202 :
1203 : else ! tripole u-fold
1204 :
1205 0 : select case (fieldLoc)
1206 : case (field_loc_center) ! cell center location
1207 :
1208 0 : ioffset = 0
1209 0 : joffset = 0
1210 :
1211 : case (field_loc_NEcorner) ! cell corner location
1212 :
1213 0 : ioffset = 1
1214 0 : joffset = 1
1215 :
1216 : !*** top row is degenerate, so must enforce symmetry
1217 : !*** use average of two degenerate points for value
1218 :
1219 0 : do i = 1,nxGlobal/2 - 1
1220 0 : iDst = nxGlobal - i
1221 0 : x1 = bufTripoleR4(i ,halo%tripoleRows)
1222 0 : x2 = bufTripoleR4(iDst,halo%tripoleRows)
1223 0 : xavg = 0.5_real_kind*(x1 + isign*x2)
1224 0 : bufTripoleR4(i ,halo%tripoleRows) = xavg
1225 0 : bufTripoleR4(iDst,halo%tripoleRows) = isign*xavg
1226 : end do
1227 :
1228 : case (field_loc_Eface) ! cell center location
1229 :
1230 0 : ioffset = 1
1231 0 : joffset = 0
1232 :
1233 : case (field_loc_Nface) ! cell corner (velocity) location
1234 :
1235 0 : ioffset = 0
1236 0 : joffset = 1
1237 :
1238 : !*** top row is degenerate, so must enforce symmetry
1239 : !*** use average of two degenerate points for value
1240 :
1241 0 : do i = 1,nxGlobal/2
1242 0 : iDst = nxGlobal + 1 - i
1243 0 : x1 = bufTripoleR4(i ,halo%tripoleRows)
1244 0 : x2 = bufTripoleR4(iDst,halo%tripoleRows)
1245 0 : xavg = 0.5_real_kind*(x1 + isign*x2)
1246 0 : bufTripoleR4(i ,halo%tripoleRows) = xavg
1247 0 : bufTripoleR4(iDst,halo%tripoleRows) = isign*xavg
1248 : end do
1249 :
1250 : case default
1251 0 : call abort_ice(subname//'ERROR: Unknown field location')
1252 : end select
1253 :
1254 : endif
1255 :
1256 : !*** copy out of global tripole buffer into local
1257 : !*** ghost cells
1258 :
1259 : !*** look through local copies to find the copy out
1260 : !*** messages (srcBlock < 0)
1261 :
1262 0 : do nmsg=1,halo%numLocalCopies
1263 0 : srcBlock = halo%srcLocalAddr(3,nmsg)
1264 :
1265 0 : if (srcBlock < 0) then
1266 :
1267 0 : iSrc = halo%srcLocalAddr(1,nmsg) ! tripole buffer addr
1268 0 : jSrc = halo%srcLocalAddr(2,nmsg)
1269 :
1270 0 : iDst = halo%dstLocalAddr(1,nmsg) ! local block addr
1271 0 : jDst = halo%dstLocalAddr(2,nmsg)
1272 0 : dstBlock = halo%dstLocalAddr(3,nmsg)
1273 :
1274 : !*** correct for offsets
1275 0 : iSrc = iSrc - ioffset
1276 0 : jSrc = jSrc - joffset
1277 0 : if (iSrc < 1 ) iSrc = iSrc + nxGlobal
1278 0 : if (iSrc > nxGlobal) iSrc = iSrc - nxGlobal
1279 :
1280 : !*** for center and Eface on u-fold, and NE corner and Nface
1281 : !*** on T-fold, do not need to replace
1282 : !*** top row of physical domain, so jSrc should be
1283 : !*** out of range and skipped
1284 : !*** otherwise do the copy
1285 :
1286 0 : if (jSrc <= halo%tripoleRows .and. jSrc>0 .and. jDst>0) then
1287 0 : array(iDst,jDst,dstBlock) = isign*bufTripoleR4(iSrc,jSrc)
1288 : endif
1289 :
1290 : endif
1291 : end do
1292 :
1293 : endif
1294 :
1295 : !-----------------------------------------------------------------------
1296 :
1297 : end subroutine ice_HaloUpdate2DR4
1298 :
1299 : !***********************************************************************
1300 :
1301 24 : subroutine ice_HaloUpdate2DI4(array, halo, &
1302 : fieldLoc, fieldKind, & ! LCOV_EXCL_LINE
1303 : fillValue)
1304 :
1305 : ! This routine updates ghost cells for an input array and is a
1306 : ! member of a group of routines under the generic interface
1307 : ! POP\_HaloUpdate. This routine is the specific interface
1308 : ! for 2d horizontal integer arrays.
1309 :
1310 : type (ice_halo), intent(in) :: &
1311 : halo ! precomputed halo structure containing all
1312 : ! information needed for halo update
1313 :
1314 : integer (int_kind), intent(in) :: &
1315 : fieldKind, &! id for type of field (scalar, vector, angle) ! LCOV_EXCL_LINE
1316 : fieldLoc ! id for location on horizontal grid
1317 : ! (center, NEcorner, Nface, Eface)
1318 :
1319 : integer (int_kind), intent(in), optional :: &
1320 : fillValue ! optional value to put in ghost cells
1321 : ! where neighbor points are unknown
1322 : ! (e.g. eliminated land blocks or
1323 : ! closed boundaries)
1324 :
1325 : integer (int_kind), dimension(:,:,:), intent(inout) :: &
1326 : array ! array containing field for which halo
1327 : ! needs to be updated
1328 :
1329 : !-----------------------------------------------------------------------
1330 : !
1331 : ! local variables
1332 : !
1333 : !-----------------------------------------------------------------------
1334 :
1335 : integer (int_kind) :: &
1336 : i,j,nmsg, &! dummy loop indices ! LCOV_EXCL_LINE
1337 : iblk,ilo,ihi,jlo,jhi, &! block sizes for fill ! LCOV_EXCL_LINE
1338 : nxGlobal, &! global domain size in x (tripole) ! LCOV_EXCL_LINE
1339 : iSrc,jSrc, &! source addresses for message ! LCOV_EXCL_LINE
1340 : iDst,jDst, &! dest addresses for message ! LCOV_EXCL_LINE
1341 : srcBlock, &! local block number for source ! LCOV_EXCL_LINE
1342 : dstBlock, &! local block number for destination ! LCOV_EXCL_LINE
1343 : ioffset, joffset, &! address shifts for tripole ! LCOV_EXCL_LINE
1344 : isign ! sign factor for tripole grids
1345 :
1346 : integer (int_kind) :: &
1347 : fill, &! value to use for unknown points ! LCOV_EXCL_LINE
1348 : x1,x2,xavg ! scalars for enforcing symmetry at U pts
1349 :
1350 : character(len=*), parameter :: subname = '(ice_HaloUpdate2DI4)'
1351 :
1352 : !-----------------------------------------------------------------------
1353 : !
1354 : ! abort or return on unknown or noupdate field_loc or field_type
1355 : !
1356 : !-----------------------------------------------------------------------
1357 :
1358 24 : if (fieldLoc == field_loc_unknown .or. &
1359 : fieldKind == field_type_unknown) then
1360 0 : call abort_ice(subname//'ERROR: use of field_loc/type_unknown not allowed')
1361 0 : return
1362 : endif
1363 :
1364 24 : if (fieldLoc == field_loc_noupdate .or. &
1365 : fieldKind == field_type_noupdate) then
1366 0 : return
1367 : endif
1368 :
1369 : !-----------------------------------------------------------------------
1370 : !
1371 : ! initialize error code and fill value
1372 : !
1373 : !-----------------------------------------------------------------------
1374 :
1375 24 : if (present(fillValue)) then
1376 0 : fill = fillValue
1377 : else
1378 24 : fill = 0_int_kind
1379 : endif
1380 :
1381 24 : nxGlobal = 0
1382 24 : if (allocated(bufTripoleI4)) then
1383 0 : nxGlobal = size(bufTripoleI4,dim=1)
1384 0 : bufTripoleI4 = fill
1385 : endif
1386 :
1387 : !-----------------------------------------------------------------------
1388 : !
1389 : ! fill out halo region
1390 : ! needed for masked halos to ensure halo values are filled for
1391 : ! halo grid cells that are not updated
1392 : !
1393 : !-----------------------------------------------------------------------
1394 :
1395 48 : do iblk = 1, halo%numLocalBlocks
1396 : call get_block_parameter(halo%blockGlobalID(iblk), &
1397 : ilo=ilo, ihi=ihi, & ! LCOV_EXCL_LINE
1398 24 : jlo=jlo, jhi=jhi)
1399 48 : do j = 1,nghost
1400 2472 : array(1:nx_block, jlo-j,iblk) = fill
1401 2496 : array(1:nx_block, jhi+j,iblk) = fill
1402 : enddo
1403 96 : do i = 1,nghost
1404 2856 : array(ilo-i, 1:ny_block,iblk) = fill
1405 2880 : array(ihi+i, 1:ny_block,iblk) = fill
1406 : enddo
1407 : enddo
1408 :
1409 : !-----------------------------------------------------------------------
1410 : !
1411 : ! do local copies while waiting for messages to complete
1412 : ! if srcBlock is zero, that denotes an eliminated land block or a
1413 : ! closed boundary where ghost cell values are undefined
1414 : ! if srcBlock is less than zero, the message is a copy out of the
1415 : ! tripole buffer and will be treated later
1416 : !
1417 : !-----------------------------------------------------------------------
1418 :
1419 5592 : do nmsg=1,halo%numLocalCopies
1420 5568 : iSrc = halo%srcLocalAddr(1,nmsg)
1421 5568 : jSrc = halo%srcLocalAddr(2,nmsg)
1422 5568 : srcBlock = halo%srcLocalAddr(3,nmsg)
1423 5568 : iDst = halo%dstLocalAddr(1,nmsg)
1424 5568 : jDst = halo%dstLocalAddr(2,nmsg)
1425 5568 : dstBlock = halo%dstLocalAddr(3,nmsg)
1426 :
1427 5592 : if (srcBlock > 0) then
1428 5568 : if (dstBlock > 0) then
1429 : array(iDst,jDst,dstBlock) = &
1430 5568 : array(iSrc,jSrc,srcBlock)
1431 0 : else if (dstBlock < 0) then ! tripole copy into buffer
1432 : bufTripoleI4(iDst,jDst) = &
1433 0 : array(iSrc,jSrc,srcBlock)
1434 : endif
1435 0 : else if (srcBlock == 0) then
1436 0 : array(iDst,jDst,dstBlock) = fill
1437 : endif
1438 : end do
1439 :
1440 : !-----------------------------------------------------------------------
1441 : !
1442 : ! take care of northern boundary in tripole case
1443 : ! bufTripole array contains the top nghost+1 rows (u-fold) or nghost+2 rows
1444 : ! (T-fold) of physical domain for entire (global) top row
1445 : !
1446 : !-----------------------------------------------------------------------
1447 :
1448 24 : if (nxGlobal > 0) then
1449 :
1450 0 : select case (fieldKind)
1451 : case (field_type_scalar)
1452 0 : isign = 1
1453 : case (field_type_vector)
1454 0 : isign = -1
1455 : case (field_type_angle)
1456 0 : isign = -1
1457 : case default
1458 0 : call abort_ice(subname//'ERROR: Unknown field kind')
1459 : end select
1460 :
1461 0 : if (halo%tripoleTFlag) then
1462 :
1463 0 : select case (fieldLoc)
1464 : case (field_loc_center) ! cell center location
1465 :
1466 0 : ioffset = -1
1467 0 : joffset = 0
1468 :
1469 : !*** top row is degenerate, so must enforce symmetry
1470 : !*** use average of two degenerate points for value
1471 :
1472 0 : do i = 2,nxGlobal/2
1473 0 : iDst = nxGlobal - i + 2
1474 0 : x1 = bufTripoleI4(i ,halo%tripoleRows)
1475 0 : x2 = bufTripoleI4(iDst,halo%tripoleRows)
1476 0 : xavg = nint(0.5_dbl_kind*(x1 + isign*x2))
1477 0 : bufTripoleI4(i ,halo%tripoleRows) = xavg
1478 0 : bufTripoleI4(iDst,halo%tripoleRows) = isign*xavg
1479 : end do
1480 :
1481 : case (field_loc_NEcorner) ! cell corner location
1482 :
1483 0 : ioffset = 0
1484 0 : joffset = 1
1485 :
1486 : case (field_loc_Eface) ! cell center location
1487 :
1488 0 : ioffset = 0
1489 0 : joffset = 0
1490 :
1491 : !*** top row is degenerate, so must enforce symmetry
1492 : !*** use average of two degenerate points for value
1493 :
1494 0 : do i = 1,nxGlobal/2
1495 0 : iDst = nxGlobal + 1 - i
1496 0 : x1 = bufTripoleI4(i ,halo%tripoleRows)
1497 0 : x2 = bufTripoleI4(iDst,halo%tripoleRows)
1498 0 : xavg = nint(0.5_dbl_kind*(x1 + isign*x2))
1499 0 : bufTripoleI4(i ,halo%tripoleRows) = xavg
1500 0 : bufTripoleI4(iDst,halo%tripoleRows) = isign*xavg
1501 : end do
1502 :
1503 : case (field_loc_Nface) ! cell corner (velocity) location
1504 :
1505 0 : ioffset = -1
1506 0 : joffset = 1
1507 :
1508 : case default
1509 0 : call abort_ice(subname//'ERROR: Unknown field location')
1510 : end select
1511 :
1512 : else ! tripole u-fold
1513 :
1514 0 : select case (fieldLoc)
1515 : case (field_loc_center) ! cell center location
1516 :
1517 0 : ioffset = 0
1518 0 : joffset = 0
1519 :
1520 : case (field_loc_NEcorner) ! cell corner location
1521 :
1522 0 : ioffset = 1
1523 0 : joffset = 1
1524 :
1525 : !*** top row is degenerate, so must enforce symmetry
1526 : !*** use average of two degenerate points for value
1527 :
1528 0 : do i = 1,nxGlobal/2 - 1
1529 0 : iDst = nxGlobal - i
1530 0 : x1 = bufTripoleI4(i ,halo%tripoleRows)
1531 0 : x2 = bufTripoleI4(iDst,halo%tripoleRows)
1532 0 : xavg = nint(0.5_dbl_kind*(x1 + isign*x2))
1533 0 : bufTripoleI4(i ,halo%tripoleRows) = xavg
1534 0 : bufTripoleI4(iDst,halo%tripoleRows) = isign*xavg
1535 : end do
1536 :
1537 : case (field_loc_Eface) ! cell center location
1538 :
1539 0 : ioffset = 1
1540 0 : joffset = 0
1541 :
1542 : case (field_loc_Nface) ! cell corner (velocity) location
1543 :
1544 0 : ioffset = 0
1545 0 : joffset = 1
1546 :
1547 : !*** top row is degenerate, so must enforce symmetry
1548 : !*** use average of two degenerate points for value
1549 :
1550 0 : do i = 1,nxGlobal/2
1551 0 : iDst = nxGlobal + 1 - i
1552 0 : x1 = bufTripoleI4(i ,halo%tripoleRows)
1553 0 : x2 = bufTripoleI4(iDst,halo%tripoleRows)
1554 0 : xavg = nint(0.5_dbl_kind*(x1 + isign*x2))
1555 0 : bufTripoleI4(i ,halo%tripoleRows) = xavg
1556 0 : bufTripoleI4(iDst,halo%tripoleRows) = isign*xavg
1557 : end do
1558 :
1559 : case default
1560 0 : call abort_ice(subname//'ERROR: Unknown field location')
1561 : end select
1562 :
1563 : endif
1564 :
1565 : !*** copy out of global tripole buffer into local
1566 : !*** ghost cells
1567 :
1568 : !*** look through local copies to find the copy out
1569 : !*** messages (srcBlock < 0)
1570 :
1571 0 : do nmsg=1,halo%numLocalCopies
1572 0 : srcBlock = halo%srcLocalAddr(3,nmsg)
1573 :
1574 0 : if (srcBlock < 0) then
1575 :
1576 0 : iSrc = halo%srcLocalAddr(1,nmsg) ! tripole buffer addr
1577 0 : jSrc = halo%srcLocalAddr(2,nmsg)
1578 :
1579 0 : iDst = halo%dstLocalAddr(1,nmsg) ! local block addr
1580 0 : jDst = halo%dstLocalAddr(2,nmsg)
1581 0 : dstBlock = halo%dstLocalAddr(3,nmsg)
1582 :
1583 : !*** correct for offsets
1584 0 : iSrc = iSrc - ioffset
1585 0 : jSrc = jSrc - joffset
1586 0 : if (iSrc < 1 ) iSrc = iSrc + nxGlobal
1587 0 : if (iSrc > nxGlobal) iSrc = iSrc - nxGlobal
1588 :
1589 : !*** for center and Eface on u-fold, and NE corner and Nface
1590 : !*** on T-fold, do not need to replace
1591 : !*** top row of physical domain, so jSrc should be
1592 : !*** out of range and skipped
1593 : !*** otherwise do the copy
1594 :
1595 0 : if (jSrc <= halo%tripoleRows .and. jSrc>0 .and. jDst>0) then
1596 0 : array(iDst,jDst,dstBlock) = isign*bufTripoleI4(iSrc,jSrc)
1597 : endif
1598 :
1599 : endif
1600 : end do
1601 :
1602 : endif
1603 :
1604 : !-----------------------------------------------------------------------
1605 :
1606 : end subroutine ice_HaloUpdate2DI4
1607 :
1608 : !***********************************************************************
1609 :
1610 24 : subroutine ice_HaloUpdate2DL1(array, halo, &
1611 : fieldLoc, fieldKind, & ! LCOV_EXCL_LINE
1612 : fillValue)
1613 :
1614 : ! This routine updates ghost cells for an input array and is a
1615 : ! member of a group of routines under the generic interface
1616 : ! ice\_HaloUpdate. This routine is the specific interface
1617 : ! for 2d horizontal logical arrays.
1618 :
1619 : type (ice_halo), intent(in) :: &
1620 : halo ! precomputed halo structure containing all
1621 : ! information needed for halo update
1622 :
1623 : integer (int_kind), intent(in) :: &
1624 : fieldKind, &! id for type of field (scalar, vector, angle) ! LCOV_EXCL_LINE
1625 : fieldLoc ! id for location on horizontal grid
1626 : ! (center, NEcorner, Nface, Eface)
1627 :
1628 : integer (int_kind), intent(in), optional :: &
1629 : fillValue ! optional value to put in ghost cells
1630 : ! where neighbor points are unknown
1631 : ! (e.g. eliminated land blocks or
1632 : ! closed boundaries)
1633 :
1634 : logical (log_kind), dimension(:,:,:), intent(inout) :: &
1635 : array ! array containing field for which halo
1636 : ! needs to be updated
1637 :
1638 : !-----------------------------------------------------------------------
1639 : !
1640 : ! local variables
1641 : !
1642 : !-----------------------------------------------------------------------
1643 :
1644 : integer (int_kind), dimension(:,:,:), allocatable :: &
1645 24 : iarray ! integer array for logical
1646 :
1647 : character(len=*), parameter :: subname = '(ice_HaloUpdate2DL1)'
1648 :
1649 : !-----------------------------------------------------------------------
1650 : !
1651 : ! abort or return on unknown or noupdate field_loc or field_type
1652 : !
1653 : !-----------------------------------------------------------------------
1654 :
1655 24 : if (fieldLoc == field_loc_unknown .or. &
1656 : fieldKind == field_type_unknown) then
1657 0 : call abort_ice(subname//'ERROR: use of field_loc/type_unknown not allowed')
1658 0 : return
1659 : endif
1660 :
1661 24 : if (fieldLoc == field_loc_noupdate .or. &
1662 : fieldKind == field_type_noupdate) then
1663 0 : return
1664 : endif
1665 :
1666 : !-----------------------------------------------------------------------
1667 : !
1668 : ! copy logical into integer array and call haloupdate on integer array
1669 : !
1670 : !-----------------------------------------------------------------------
1671 :
1672 24 : allocate(iarray(size(array,dim=1),size(array,dim=2),size(array,dim=3)))
1673 291744 : iarray(:,:,:) = 0
1674 291744 : where (array) iarray = 1
1675 :
1676 : call ice_HaloUpdate(iarray, halo, &
1677 : fieldLoc, fieldKind, & ! LCOV_EXCL_LINE
1678 24 : fillValue)
1679 :
1680 291744 : array = .false.
1681 291744 : where (iarray /= 0) array = .true.
1682 24 : deallocate(iarray)
1683 :
1684 : !-----------------------------------------------------------------------
1685 :
1686 24 : end subroutine ice_HaloUpdate2DL1
1687 :
1688 : !***********************************************************************
1689 :
1690 363 : subroutine ice_HaloUpdate3DR8(array, halo, &
1691 : fieldLoc, fieldKind, & ! LCOV_EXCL_LINE
1692 : fillValue)
1693 :
1694 : ! This routine updates ghost cells for an input array and is a
1695 : ! member of a group of routines under the generic interface
1696 : ! POP\_HaloUpdate. This routine is the specific interface
1697 : ! for 3d horizontal arrays of double precision.
1698 :
1699 : type (ice_halo), intent(in) :: &
1700 : halo ! precomputed halo structure containing all
1701 : ! information needed for halo update
1702 :
1703 : integer (int_kind), intent(in) :: &
1704 : fieldKind, &! id for type of field (scalar, vector, angle) ! LCOV_EXCL_LINE
1705 : fieldLoc ! id for location on horizontal grid
1706 : ! (center, NEcorner, Nface, Eface)
1707 :
1708 : real (dbl_kind), intent(in), optional :: &
1709 : fillValue ! optional value to put in ghost cells
1710 : ! where neighbor points are unknown
1711 : ! (e.g. eliminated land blocks or
1712 : ! closed boundaries)
1713 :
1714 : real (dbl_kind), dimension(:,:,:,:), intent(inout) :: &
1715 : array ! array containing field for which halo
1716 : ! needs to be updated
1717 :
1718 : !-----------------------------------------------------------------------
1719 : !
1720 : ! local variables
1721 : !
1722 : !-----------------------------------------------------------------------
1723 :
1724 : integer (int_kind) :: &
1725 : i,j,k,nmsg, &! dummy loop indices ! LCOV_EXCL_LINE
1726 : iblk,ilo,ihi,jlo,jhi, &! block sizes for fill ! LCOV_EXCL_LINE
1727 : nxGlobal, &! global domain size in x (tripole) ! LCOV_EXCL_LINE
1728 : nz, &! size of array in 3rd dimension ! LCOV_EXCL_LINE
1729 : iSrc,jSrc, &! source addresses for message ! LCOV_EXCL_LINE
1730 : iDst,jDst, &! dest addresses for message ! LCOV_EXCL_LINE
1731 : srcBlock, &! local block number for source ! LCOV_EXCL_LINE
1732 : dstBlock, &! local block number for destination ! LCOV_EXCL_LINE
1733 : ioffset, joffset, &! address shifts for tripole ! LCOV_EXCL_LINE
1734 : isign ! sign factor for tripole grids
1735 :
1736 : real (dbl_kind) :: &
1737 : fill, &! value to use for unknown points ! LCOV_EXCL_LINE
1738 : x1,x2,xavg ! scalars for enforcing symmetry at U pts
1739 :
1740 : real (dbl_kind), dimension(:,:,:), allocatable :: &
1741 363 : bufTripole ! 3d tripole buffer
1742 :
1743 : character(len=*), parameter :: subname = '(ice_HaloUpdate3DR8)'
1744 :
1745 : !-----------------------------------------------------------------------
1746 : !
1747 : ! abort or return on unknown or noupdate field_loc or field_type
1748 : !
1749 : !-----------------------------------------------------------------------
1750 :
1751 363 : if (fieldLoc == field_loc_unknown .or. &
1752 : fieldKind == field_type_unknown) then
1753 0 : call abort_ice(subname//'ERROR: use of field_loc/type_unknown not allowed')
1754 0 : return
1755 : endif
1756 :
1757 363 : if (fieldLoc == field_loc_noupdate .or. &
1758 : fieldKind == field_type_noupdate) then
1759 0 : return
1760 : endif
1761 :
1762 : !-----------------------------------------------------------------------
1763 : !
1764 : ! initialize error code and fill value
1765 : !
1766 : !-----------------------------------------------------------------------
1767 :
1768 363 : if (present(fillValue)) then
1769 0 : fill = fillValue
1770 : else
1771 363 : fill = 0.0_dbl_kind
1772 : endif
1773 :
1774 363 : nz = size(array, dim=3)
1775 :
1776 363 : nxGlobal = 0
1777 363 : if (allocated(bufTripoleR8)) then
1778 0 : nxGlobal = size(bufTripoleR8,dim=1)
1779 0 : allocate(bufTripole(nxGlobal,halo%tripoleRows,nz))
1780 0 : bufTripole = fill
1781 : endif
1782 :
1783 : !-----------------------------------------------------------------------
1784 : !
1785 : ! fill out halo region
1786 : ! needed for masked halos to ensure halo values are filled for
1787 : ! halo grid cells that are not updated
1788 : !
1789 : !-----------------------------------------------------------------------
1790 :
1791 726 : do iblk = 1, halo%numLocalBlocks
1792 : call get_block_parameter(halo%blockGlobalID(iblk), &
1793 : ilo=ilo, ihi=ihi, & ! LCOV_EXCL_LINE
1794 363 : jlo=jlo, jhi=jhi)
1795 726 : do j = 1,nghost
1796 179892 : array(1:nx_block, jlo-j,:,iblk) = fill
1797 180255 : array(1:nx_block, jhi+j,:,iblk) = fill
1798 : enddo
1799 1452 : do i = 1,nghost
1800 207780 : array(ilo-i, 1:ny_block,:,iblk) = fill
1801 208143 : array(ihi+i, 1:ny_block,:,iblk) = fill
1802 : enddo
1803 : enddo
1804 :
1805 : !-----------------------------------------------------------------------
1806 : !
1807 : ! do local copies
1808 : ! if srcBlock is zero, that denotes an eliminated land block or a
1809 : ! closed boundary where ghost cell values are undefined
1810 : ! if srcBlock is less than zero, the message is a copy out of the
1811 : ! tripole buffer and will be treated later
1812 : !
1813 : !-----------------------------------------------------------------------
1814 :
1815 84579 : do nmsg=1,halo%numLocalCopies
1816 84216 : iSrc = halo%srcLocalAddr(1,nmsg)
1817 84216 : jSrc = halo%srcLocalAddr(2,nmsg)
1818 84216 : srcBlock = halo%srcLocalAddr(3,nmsg)
1819 84216 : iDst = halo%dstLocalAddr(1,nmsg)
1820 84216 : jDst = halo%dstLocalAddr(2,nmsg)
1821 84216 : dstBlock = halo%dstLocalAddr(3,nmsg)
1822 :
1823 84579 : if (srcBlock > 0) then
1824 84216 : if (dstBlock > 0) then
1825 488592 : do k=1,nz
1826 : array(iDst,jDst,k,dstBlock) = &
1827 488592 : array(iSrc,jSrc,k,srcBlock)
1828 : end do
1829 0 : else if (dstBlock < 0) then ! tripole copy into buffer
1830 0 : do k=1,nz
1831 : bufTripole(iDst,jDst,k) = &
1832 0 : array(iSrc,jSrc,k,srcBlock)
1833 : end do
1834 : endif
1835 0 : else if (srcBlock == 0) then
1836 0 : do k=1,nz
1837 0 : array(iDst,jDst,k,dstBlock) = fill
1838 : end do
1839 : endif
1840 : end do
1841 :
1842 : !-----------------------------------------------------------------------
1843 : !
1844 : ! take care of northern boundary in tripole case
1845 : ! bufTripole array contains the top nghost+1 rows (u-fold) or nghost+2 rows
1846 : ! (T-fold) of physical domain for entire (global) top row
1847 : !
1848 : !-----------------------------------------------------------------------
1849 :
1850 363 : if (nxGlobal > 0) then
1851 :
1852 0 : select case (fieldKind)
1853 : case (field_type_scalar)
1854 0 : isign = 1
1855 : case (field_type_vector)
1856 0 : isign = -1
1857 : case (field_type_angle)
1858 0 : isign = -1
1859 : case default
1860 0 : call abort_ice(subname//'ERROR: Unknown field kind')
1861 : end select
1862 :
1863 0 : if (halo%tripoleTFlag) then
1864 :
1865 0 : select case (fieldLoc)
1866 : case (field_loc_center) ! cell center location
1867 :
1868 0 : ioffset = -1
1869 0 : joffset = 0
1870 :
1871 : !*** top row is degenerate, so must enforce symmetry
1872 : !*** use average of two degenerate points for value
1873 :
1874 0 : do k=1,nz
1875 0 : do i = 2,nxGlobal/2
1876 0 : iDst = nxGlobal - i + 2
1877 0 : x1 = bufTripole(i ,halo%tripoleRows,k)
1878 0 : x2 = bufTripole(iDst,halo%tripoleRows,k)
1879 0 : xavg = 0.5_dbl_kind*(x1 + isign*x2)
1880 0 : bufTripole(i ,halo%tripoleRows,k) = xavg
1881 0 : bufTripole(iDst,halo%tripoleRows,k) = isign*xavg
1882 : end do
1883 : end do
1884 :
1885 : case (field_loc_NEcorner) ! cell corner location
1886 :
1887 0 : ioffset = 0
1888 0 : joffset = 1
1889 :
1890 : case (field_loc_Eface) ! cell center location
1891 :
1892 0 : ioffset = 0
1893 0 : joffset = 0
1894 :
1895 : !*** top row is degenerate, so must enforce symmetry
1896 : !*** use average of two degenerate points for value
1897 :
1898 0 : do k=1,nz
1899 0 : do i = 1,nxGlobal/2
1900 0 : iDst = nxGlobal + 1 - i
1901 0 : x1 = bufTripole(i ,halo%tripoleRows,k)
1902 0 : x2 = bufTripole(iDst,halo%tripoleRows,k)
1903 0 : xavg = 0.5_dbl_kind*(x1 + isign*x2)
1904 0 : bufTripole(i ,halo%tripoleRows,k) = xavg
1905 0 : bufTripole(iDst,halo%tripoleRows,k) = isign*xavg
1906 : end do
1907 : end do
1908 :
1909 : case (field_loc_Nface) ! cell corner (velocity) location
1910 :
1911 0 : ioffset = -1
1912 0 : joffset = 1
1913 :
1914 : case default
1915 0 : call abort_ice(subname//'ERROR: Unknown field location')
1916 : end select
1917 :
1918 : else ! tripole u-fold
1919 :
1920 0 : select case (fieldLoc)
1921 : case (field_loc_center) ! cell center location
1922 :
1923 0 : ioffset = 0
1924 0 : joffset = 0
1925 :
1926 : case (field_loc_NEcorner) ! cell corner location
1927 :
1928 0 : ioffset = 1
1929 0 : joffset = 1
1930 :
1931 : !*** top row is degenerate, so must enforce symmetry
1932 : !*** use average of two degenerate points for value
1933 :
1934 0 : do k=1,nz
1935 0 : do i = 1,nxGlobal/2 - 1
1936 0 : iDst = nxGlobal - i
1937 0 : x1 = bufTripole(i ,halo%tripoleRows,k)
1938 0 : x2 = bufTripole(iDst,halo%tripoleRows,k)
1939 0 : xavg = 0.5_dbl_kind*(x1 + isign*x2)
1940 0 : bufTripole(i ,halo%tripoleRows,k) = xavg
1941 0 : bufTripole(iDst,halo%tripoleRows,k) = isign*xavg
1942 : end do
1943 : end do
1944 :
1945 : case (field_loc_Eface) ! cell center location
1946 :
1947 0 : ioffset = 1
1948 0 : joffset = 0
1949 :
1950 : case (field_loc_Nface) ! cell corner (velocity) location
1951 :
1952 0 : ioffset = 0
1953 0 : joffset = 1
1954 :
1955 : !*** top row is degenerate, so must enforce symmetry
1956 : !*** use average of two degenerate points for value
1957 :
1958 0 : do k=1,nz
1959 0 : do i = 1,nxGlobal/2
1960 0 : iDst = nxGlobal + 1 - i
1961 0 : x1 = bufTripole(i ,halo%tripoleRows,k)
1962 0 : x2 = bufTripole(iDst,halo%tripoleRows,k)
1963 0 : xavg = 0.5_dbl_kind*(x1 + isign*x2)
1964 0 : bufTripole(i ,halo%tripoleRows,k) = xavg
1965 0 : bufTripole(iDst,halo%tripoleRows,k) = isign*xavg
1966 : end do
1967 : end do
1968 :
1969 : case default
1970 0 : call abort_ice(subname//'ERROR: Unknown field location')
1971 : end select
1972 :
1973 : endif
1974 :
1975 : !*** copy out of global tripole buffer into local
1976 : !*** ghost cells
1977 :
1978 : !*** look through local copies to find the copy out
1979 : !*** messages (srcBlock < 0)
1980 :
1981 0 : do nmsg=1,halo%numLocalCopies
1982 0 : srcBlock = halo%srcLocalAddr(3,nmsg)
1983 :
1984 0 : if (srcBlock < 0) then
1985 :
1986 0 : iSrc = halo%srcLocalAddr(1,nmsg) ! tripole buffer addr
1987 0 : jSrc = halo%srcLocalAddr(2,nmsg)
1988 :
1989 0 : iDst = halo%dstLocalAddr(1,nmsg) ! local block addr
1990 0 : jDst = halo%dstLocalAddr(2,nmsg)
1991 0 : dstBlock = halo%dstLocalAddr(3,nmsg)
1992 :
1993 : !*** correct for offsets
1994 0 : iSrc = iSrc - ioffset
1995 0 : jSrc = jSrc - joffset
1996 0 : if (iSrc < 1 ) iSrc = iSrc + nxGlobal
1997 0 : if (iSrc > nxGlobal) iSrc = iSrc - nxGlobal
1998 :
1999 : !*** for center and Eface on u-fold, and NE corner and Nface
2000 : !*** on T-fold, do not need to replace
2001 : !*** top row of physical domain, so jSrc should be
2002 : !*** out of range and skipped
2003 : !*** otherwise do the copy
2004 :
2005 0 : if (jSrc <= halo%tripoleRows .and. jSrc>0 .and. jDst>0) then
2006 0 : do k=1,nz
2007 : array(iDst,jDst,k,dstBlock) = isign* &
2008 0 : bufTripole(iSrc,jSrc,k)
2009 : end do
2010 : endif
2011 :
2012 : endif
2013 : end do
2014 :
2015 : endif
2016 :
2017 363 : if (allocated(bufTripole)) deallocate(bufTripole)
2018 :
2019 : !-----------------------------------------------------------------------
2020 :
2021 363 : end subroutine ice_HaloUpdate3DR8
2022 :
2023 : !***********************************************************************
2024 :
2025 0 : subroutine ice_HaloUpdate3DR4(array, halo, &
2026 : fieldLoc, fieldKind, & ! LCOV_EXCL_LINE
2027 : fillValue)
2028 :
2029 : ! This routine updates ghost cells for an input array and is a
2030 : ! member of a group of routines under the generic interface
2031 : ! POP\_HaloUpdate. This routine is the specific interface
2032 : ! for 3d horizontal arrays of single precision.
2033 :
2034 : type (ice_halo), intent(in) :: &
2035 : halo ! precomputed halo structure containing all
2036 : ! information needed for halo update
2037 :
2038 : integer (int_kind), intent(in) :: &
2039 : fieldKind, &! id for type of field (scalar, vector, angle) ! LCOV_EXCL_LINE
2040 : fieldLoc ! id for location on horizontal grid
2041 : ! (center, NEcorner, Nface, Eface)
2042 :
2043 : real (real_kind), intent(in), optional :: &
2044 : fillValue ! optional value to put in ghost cells
2045 : ! where neighbor points are unknown
2046 : ! (e.g. eliminated land blocks or
2047 : ! closed boundaries)
2048 :
2049 : real (real_kind), dimension(:,:,:,:), intent(inout) :: &
2050 : array ! array containing field for which halo
2051 : ! needs to be updated
2052 :
2053 : !-----------------------------------------------------------------------
2054 : !
2055 : ! local variables
2056 : !
2057 : !-----------------------------------------------------------------------
2058 :
2059 : integer (int_kind) :: &
2060 : i,j,k,nmsg, &! dummy loop indices ! LCOV_EXCL_LINE
2061 : iblk,ilo,ihi,jlo,jhi, &! block sizes for fill ! LCOV_EXCL_LINE
2062 : nxGlobal, &! global domain size in x (tripole) ! LCOV_EXCL_LINE
2063 : nz, &! size of array in 3rd dimension ! LCOV_EXCL_LINE
2064 : iSrc,jSrc, &! source addresses for message ! LCOV_EXCL_LINE
2065 : iDst,jDst, &! dest addresses for message ! LCOV_EXCL_LINE
2066 : srcBlock, &! local block number for source ! LCOV_EXCL_LINE
2067 : dstBlock, &! local block number for destination ! LCOV_EXCL_LINE
2068 : ioffset, joffset, &! address shifts for tripole ! LCOV_EXCL_LINE
2069 : isign ! sign factor for tripole grids
2070 :
2071 : real (real_kind) :: &
2072 : fill, &! value to use for unknown points ! LCOV_EXCL_LINE
2073 : x1,x2,xavg ! scalars for enforcing symmetry at U pts
2074 :
2075 : real (real_kind), dimension(:,:,:), allocatable :: &
2076 0 : bufTripole ! 3d tripole buffer
2077 :
2078 : character(len=*), parameter :: subname = '(ice_HaloUpdate3DR4)'
2079 :
2080 : !-----------------------------------------------------------------------
2081 : !
2082 : ! abort or return on unknown or noupdate field_loc or field_type
2083 : !
2084 : !-----------------------------------------------------------------------
2085 :
2086 0 : if (fieldLoc == field_loc_unknown .or. &
2087 : fieldKind == field_type_unknown) then
2088 0 : call abort_ice(subname//'ERROR: use of field_loc/type_unknown not allowed')
2089 0 : return
2090 : endif
2091 :
2092 0 : if (fieldLoc == field_loc_noupdate .or. &
2093 : fieldKind == field_type_noupdate) then
2094 0 : return
2095 : endif
2096 :
2097 : !-----------------------------------------------------------------------
2098 : !
2099 : ! initialize error code and fill value
2100 : !
2101 : !-----------------------------------------------------------------------
2102 :
2103 0 : if (present(fillValue)) then
2104 0 : fill = fillValue
2105 : else
2106 0 : fill = 0.0_real_kind
2107 : endif
2108 :
2109 0 : nz = size(array, dim=3)
2110 :
2111 0 : nxGlobal = 0
2112 0 : if (allocated(bufTripoleR4)) then
2113 0 : nxGlobal = size(bufTripoleR4,dim=1)
2114 0 : allocate(bufTripole(nxGlobal,halo%tripoleRows,nz))
2115 0 : bufTripole = fill
2116 : endif
2117 :
2118 : !-----------------------------------------------------------------------
2119 : !
2120 : ! fill out halo region
2121 : ! needed for masked halos to ensure halo values are filled for
2122 : ! halo grid cells that are not updated
2123 : !
2124 : !-----------------------------------------------------------------------
2125 :
2126 0 : do iblk = 1, halo%numLocalBlocks
2127 : call get_block_parameter(halo%blockGlobalID(iblk), &
2128 : ilo=ilo, ihi=ihi, & ! LCOV_EXCL_LINE
2129 0 : jlo=jlo, jhi=jhi)
2130 0 : do j = 1,nghost
2131 0 : array(1:nx_block, jlo-j,:,iblk) = fill
2132 0 : array(1:nx_block, jhi+j,:,iblk) = fill
2133 : enddo
2134 0 : do i = 1,nghost
2135 0 : array(ilo-i, 1:ny_block,:,iblk) = fill
2136 0 : array(ihi+i, 1:ny_block,:,iblk) = fill
2137 : enddo
2138 : enddo
2139 :
2140 : !-----------------------------------------------------------------------
2141 : !
2142 : ! do local copies
2143 : ! if srcBlock is zero, that denotes an eliminated land block or a
2144 : ! closed boundary where ghost cell values are undefined
2145 : ! if srcBlock is less than zero, the message is a copy out of the
2146 : ! tripole buffer and will be treated later
2147 : !
2148 : !-----------------------------------------------------------------------
2149 :
2150 0 : do nmsg=1,halo%numLocalCopies
2151 0 : iSrc = halo%srcLocalAddr(1,nmsg)
2152 0 : jSrc = halo%srcLocalAddr(2,nmsg)
2153 0 : srcBlock = halo%srcLocalAddr(3,nmsg)
2154 0 : iDst = halo%dstLocalAddr(1,nmsg)
2155 0 : jDst = halo%dstLocalAddr(2,nmsg)
2156 0 : dstBlock = halo%dstLocalAddr(3,nmsg)
2157 :
2158 0 : if (srcBlock > 0) then
2159 0 : if (dstBlock > 0) then
2160 0 : do k=1,nz
2161 : array(iDst,jDst,k,dstBlock) = &
2162 0 : array(iSrc,jSrc,k,srcBlock)
2163 : end do
2164 0 : else if (dstBlock < 0) then ! tripole copy into buffer
2165 0 : do k=1,nz
2166 : bufTripole(iDst,jDst,k) = &
2167 0 : array(iSrc,jSrc,k,srcBlock)
2168 : end do
2169 : endif
2170 0 : else if (srcBlock == 0) then
2171 0 : do k=1,nz
2172 0 : array(iDst,jDst,k,dstBlock) = fill
2173 : end do
2174 : endif
2175 : end do
2176 :
2177 : !-----------------------------------------------------------------------
2178 : !
2179 : ! take care of northern boundary in tripole case
2180 : ! bufTripole array contains the top nghost+1 rows (u-fold) or nghost+2 rows
2181 : ! (T-fold) of physical domain for entire (global) top row
2182 : !
2183 : !-----------------------------------------------------------------------
2184 :
2185 0 : if (nxGlobal > 0) then
2186 :
2187 0 : select case (fieldKind)
2188 : case (field_type_scalar)
2189 0 : isign = 1
2190 : case (field_type_vector)
2191 0 : isign = -1
2192 : case (field_type_angle)
2193 0 : isign = -1
2194 : case default
2195 0 : call abort_ice(subname//'ERROR: Unknown field kind')
2196 : end select
2197 :
2198 0 : if (halo%tripoleTFlag) then
2199 :
2200 0 : select case (fieldLoc)
2201 : case (field_loc_center) ! cell center location
2202 :
2203 0 : ioffset = -1
2204 0 : joffset = 0
2205 :
2206 : !*** top row is degenerate, so must enforce symmetry
2207 : !*** use average of two degenerate points for value
2208 :
2209 0 : do k=1,nz
2210 0 : do i = 2,nxGlobal/2
2211 0 : iDst = nxGlobal - i + 2
2212 0 : x1 = bufTripole(i ,halo%tripoleRows,k)
2213 0 : x2 = bufTripole(iDst,halo%tripoleRows,k)
2214 0 : xavg = 0.5_real_kind*(x1 + isign*x2)
2215 0 : bufTripole(i ,halo%tripoleRows,k) = xavg
2216 0 : bufTripole(iDst,halo%tripoleRows,k) = isign*xavg
2217 : end do
2218 : end do
2219 :
2220 : case (field_loc_NEcorner) ! cell corner location
2221 :
2222 0 : ioffset = 0
2223 0 : joffset = 1
2224 :
2225 : case (field_loc_Eface) ! cell center location
2226 :
2227 0 : ioffset = 0
2228 0 : joffset = 0
2229 :
2230 : !*** top row is degenerate, so must enforce symmetry
2231 : !*** use average of two degenerate points for value
2232 :
2233 0 : do k=1,nz
2234 0 : do i = 1,nxGlobal/2
2235 0 : iDst = nxGlobal + 1 - i
2236 0 : x1 = bufTripole(i ,halo%tripoleRows,k)
2237 0 : x2 = bufTripole(iDst,halo%tripoleRows,k)
2238 0 : xavg = 0.5_real_kind*(x1 + isign*x2)
2239 0 : bufTripole(i ,halo%tripoleRows,k) = xavg
2240 0 : bufTripole(iDst,halo%tripoleRows,k) = isign*xavg
2241 : end do
2242 : end do
2243 :
2244 : case (field_loc_Nface) ! cell corner (velocity) location
2245 :
2246 0 : ioffset = -1
2247 0 : joffset = 1
2248 :
2249 : case default
2250 0 : call abort_ice(subname//'ERROR: Unknown field location')
2251 : end select
2252 :
2253 : else ! tripole u-fold
2254 :
2255 0 : select case (fieldLoc)
2256 : case (field_loc_center) ! cell center location
2257 :
2258 0 : ioffset = 0
2259 0 : joffset = 0
2260 :
2261 : case (field_loc_NEcorner) ! cell corner location
2262 :
2263 0 : ioffset = 1
2264 0 : joffset = 1
2265 :
2266 : !*** top row is degenerate, so must enforce symmetry
2267 : !*** use average of two degenerate points for value
2268 :
2269 0 : do k=1,nz
2270 0 : do i = 1,nxGlobal/2 - 1
2271 0 : iDst = nxGlobal - i
2272 0 : x1 = bufTripole(i ,halo%tripoleRows,k)
2273 0 : x2 = bufTripole(iDst,halo%tripoleRows,k)
2274 0 : xavg = 0.5_real_kind*(x1 + isign*x2)
2275 0 : bufTripole(i ,halo%tripoleRows,k) = xavg
2276 0 : bufTripole(iDst,halo%tripoleRows,k) = isign*xavg
2277 : end do
2278 : end do
2279 :
2280 : case (field_loc_Eface) ! cell center location
2281 :
2282 0 : ioffset = 1
2283 0 : joffset = 0
2284 :
2285 : case (field_loc_Nface) ! cell corner (velocity) location
2286 :
2287 0 : ioffset = 0
2288 0 : joffset = 1
2289 :
2290 : !*** top row is degenerate, so must enforce symmetry
2291 : !*** use average of two degenerate points for value
2292 :
2293 0 : do k=1,nz
2294 0 : do i = 1,nxGlobal/2
2295 0 : iDst = nxGlobal + 1 - i
2296 0 : x1 = bufTripole(i ,halo%tripoleRows,k)
2297 0 : x2 = bufTripole(iDst,halo%tripoleRows,k)
2298 0 : xavg = 0.5_real_kind*(x1 + isign*x2)
2299 0 : bufTripole(i ,halo%tripoleRows,k) = xavg
2300 0 : bufTripole(iDst,halo%tripoleRows,k) = isign*xavg
2301 : end do
2302 : end do
2303 :
2304 : case default
2305 0 : call abort_ice(subname//'ERROR: Unknown field location')
2306 : end select
2307 :
2308 : endif
2309 :
2310 : !*** copy out of global tripole buffer into local
2311 : !*** ghost cells
2312 :
2313 : !*** look through local copies to find the copy out
2314 : !*** messages (srcBlock < 0)
2315 :
2316 0 : do nmsg=1,halo%numLocalCopies
2317 0 : srcBlock = halo%srcLocalAddr(3,nmsg)
2318 :
2319 0 : if (srcBlock < 0) then
2320 :
2321 0 : iSrc = halo%srcLocalAddr(1,nmsg) ! tripole buffer addr
2322 0 : jSrc = halo%srcLocalAddr(2,nmsg)
2323 :
2324 0 : iDst = halo%dstLocalAddr(1,nmsg) ! local block addr
2325 0 : jDst = halo%dstLocalAddr(2,nmsg)
2326 0 : dstBlock = halo%dstLocalAddr(3,nmsg)
2327 :
2328 : !*** correct for offsets
2329 0 : iSrc = iSrc - ioffset
2330 0 : jSrc = jSrc - joffset
2331 0 : if (iSrc < 1 ) iSrc = iSrc + nxGlobal
2332 0 : if (iSrc > nxGlobal) iSrc = iSrc - nxGlobal
2333 :
2334 : !*** for center and Eface on u-fold, and NE corner and Nface
2335 : !*** on T-fold, do not need to replace
2336 : !*** top row of physical domain, so jSrc should be
2337 : !*** out of range and skipped
2338 : !*** otherwise do the copy
2339 :
2340 0 : if (jSrc <= halo%tripoleRows .and. jSrc>0 .and. jDst>0) then
2341 0 : do k=1,nz
2342 : array(iDst,jDst,k,dstBlock) = isign* &
2343 0 : bufTripole(iSrc,jSrc,k)
2344 : end do
2345 : endif
2346 :
2347 : endif
2348 : end do
2349 :
2350 : endif
2351 :
2352 0 : if (allocated(bufTripole)) deallocate(bufTripole)
2353 :
2354 : !-----------------------------------------------------------------------
2355 :
2356 0 : end subroutine ice_HaloUpdate3DR4
2357 :
2358 : !***********************************************************************
2359 :
2360 0 : subroutine ice_HaloUpdate3DI4(array, halo, &
2361 : fieldLoc, fieldKind, & ! LCOV_EXCL_LINE
2362 : fillValue)
2363 :
2364 : ! This routine updates ghost cells for an input array and is a
2365 : ! member of a group of routines under the generic interface
2366 : ! POP\_HaloUpdate. This routine is the specific interface
2367 : ! for 3d horizontal arrays of double precision.
2368 :
2369 : type (ice_halo), intent(in) :: &
2370 : halo ! precomputed halo structure containing all
2371 : ! information needed for halo update
2372 :
2373 : integer (int_kind), intent(in) :: &
2374 : fieldKind, &! id for type of field (scalar, vector, angle) ! LCOV_EXCL_LINE
2375 : fieldLoc ! id for location on horizontal grid
2376 : ! (center, NEcorner, Nface, Eface)
2377 :
2378 : integer (int_kind), intent(in), optional :: &
2379 : fillValue ! optional value to put in ghost cells
2380 : ! where neighbor points are unknown
2381 : ! (e.g. eliminated land blocks or
2382 : ! closed boundaries)
2383 :
2384 : integer (int_kind), dimension(:,:,:,:), intent(inout) :: &
2385 : array ! array containing field for which halo
2386 : ! needs to be updated
2387 :
2388 : !-----------------------------------------------------------------------
2389 : !
2390 : ! local variables
2391 : !
2392 : !-----------------------------------------------------------------------
2393 :
2394 : integer (int_kind) :: &
2395 : i,j,k,nmsg, &! dummy loop indices ! LCOV_EXCL_LINE
2396 : iblk,ilo,ihi,jlo,jhi, &! block sizes for fill ! LCOV_EXCL_LINE
2397 : nxGlobal, &! global domain size in x (tripole) ! LCOV_EXCL_LINE
2398 : nz, &! size of array in 3rd dimension ! LCOV_EXCL_LINE
2399 : iSrc,jSrc, &! source addresses for message ! LCOV_EXCL_LINE
2400 : iDst,jDst, &! dest addresses for message ! LCOV_EXCL_LINE
2401 : srcBlock, &! local block number for source ! LCOV_EXCL_LINE
2402 : dstBlock, &! local block number for destination ! LCOV_EXCL_LINE
2403 : ioffset, joffset, &! address shifts for tripole ! LCOV_EXCL_LINE
2404 : isign ! sign factor for tripole grids
2405 :
2406 : integer (int_kind) :: &
2407 : fill, &! value to use for unknown points ! LCOV_EXCL_LINE
2408 : x1,x2,xavg ! scalars for enforcing symmetry at U pts
2409 :
2410 : integer (int_kind), dimension(:,:,:), allocatable :: &
2411 0 : bufTripole ! 3d tripole buffer
2412 :
2413 : character(len=*), parameter :: subname = '(ice_HaloUpdate3DI4)'
2414 :
2415 : !-----------------------------------------------------------------------
2416 : !
2417 : ! abort or return on unknown or noupdate field_loc or field_type
2418 : !
2419 : !-----------------------------------------------------------------------
2420 :
2421 0 : if (fieldLoc == field_loc_unknown .or. &
2422 : fieldKind == field_type_unknown) then
2423 0 : call abort_ice(subname//'ERROR: use of field_loc/type_unknown not allowed')
2424 0 : return
2425 : endif
2426 :
2427 0 : if (fieldLoc == field_loc_noupdate .or. &
2428 : fieldKind == field_type_noupdate) then
2429 0 : return
2430 : endif
2431 :
2432 : !-----------------------------------------------------------------------
2433 : !
2434 : ! initialize error code and fill value
2435 : !
2436 : !-----------------------------------------------------------------------
2437 :
2438 0 : if (present(fillValue)) then
2439 0 : fill = fillValue
2440 : else
2441 0 : fill = 0_int_kind
2442 : endif
2443 :
2444 0 : nz = size(array, dim=3)
2445 :
2446 0 : nxGlobal = 0
2447 0 : if (allocated(bufTripoleI4)) then
2448 0 : nxGlobal = size(bufTripoleI4,dim=1)
2449 0 : allocate(bufTripole(nxGlobal,halo%tripoleRows,nz))
2450 0 : bufTripole = fill
2451 : endif
2452 :
2453 : !-----------------------------------------------------------------------
2454 : !
2455 : ! fill out halo region
2456 : ! needed for masked halos to ensure halo values are filled for
2457 : ! halo grid cells that are not updated
2458 : !
2459 : !-----------------------------------------------------------------------
2460 :
2461 0 : do iblk = 1, halo%numLocalBlocks
2462 : call get_block_parameter(halo%blockGlobalID(iblk), &
2463 : ilo=ilo, ihi=ihi, & ! LCOV_EXCL_LINE
2464 0 : jlo=jlo, jhi=jhi)
2465 0 : do j = 1,nghost
2466 0 : array(1:nx_block, jlo-j,:,iblk) = fill
2467 0 : array(1:nx_block, jhi+j,:,iblk) = fill
2468 : enddo
2469 0 : do i = 1,nghost
2470 0 : array(ilo-i, 1:ny_block,:,iblk) = fill
2471 0 : array(ihi+i, 1:ny_block,:,iblk) = fill
2472 : enddo
2473 : enddo
2474 :
2475 : !-----------------------------------------------------------------------
2476 : !
2477 : ! do local copies
2478 : ! if srcBlock is zero, that denotes an eliminated land block or a
2479 : ! closed boundary where ghost cell values are undefined
2480 : ! if srcBlock is less than zero, the message is a copy out of the
2481 : ! tripole buffer and will be treated later
2482 : !
2483 : !-----------------------------------------------------------------------
2484 :
2485 0 : do nmsg=1,halo%numLocalCopies
2486 0 : iSrc = halo%srcLocalAddr(1,nmsg)
2487 0 : jSrc = halo%srcLocalAddr(2,nmsg)
2488 0 : srcBlock = halo%srcLocalAddr(3,nmsg)
2489 0 : iDst = halo%dstLocalAddr(1,nmsg)
2490 0 : jDst = halo%dstLocalAddr(2,nmsg)
2491 0 : dstBlock = halo%dstLocalAddr(3,nmsg)
2492 :
2493 0 : if (srcBlock > 0) then
2494 0 : if (dstBlock > 0) then
2495 0 : do k=1,nz
2496 : array(iDst,jDst,k,dstBlock) = &
2497 0 : array(iSrc,jSrc,k,srcBlock)
2498 : end do
2499 0 : else if (dstBlock < 0) then ! tripole copy into buffer
2500 0 : do k=1,nz
2501 : bufTripole(iDst,jDst,k) = &
2502 0 : array(iSrc,jSrc,k,srcBlock)
2503 : end do
2504 : endif
2505 0 : else if (srcBlock == 0) then
2506 0 : do k=1,nz
2507 0 : array(iDst,jDst,k,dstBlock) = fill
2508 : end do
2509 : endif
2510 : end do
2511 :
2512 : !-----------------------------------------------------------------------
2513 : !
2514 : ! take care of northern boundary in tripole case
2515 : ! bufTripole array contains the top nghost+1 rows (u-fold) or nghost+2 rows
2516 : ! (T-fold) of physical domain for entire (global) top row
2517 : !
2518 : !-----------------------------------------------------------------------
2519 :
2520 0 : if (nxGlobal > 0) then
2521 :
2522 0 : select case (fieldKind)
2523 : case (field_type_scalar)
2524 0 : isign = 1
2525 : case (field_type_vector)
2526 0 : isign = -1
2527 : case (field_type_angle)
2528 0 : isign = -1
2529 : case default
2530 0 : call abort_ice(subname//'ERROR: Unknown field kind')
2531 : end select
2532 :
2533 0 : if (halo%tripoleTFlag) then
2534 :
2535 0 : select case (fieldLoc)
2536 : case (field_loc_center) ! cell center location
2537 :
2538 0 : ioffset = -1
2539 0 : joffset = 0
2540 :
2541 : !*** top row is degenerate, so must enforce symmetry
2542 : !*** use average of two degenerate points for value
2543 :
2544 0 : do k=1,nz
2545 0 : do i = 2,nxGlobal/2
2546 0 : iDst = nxGlobal - i + 2
2547 0 : x1 = bufTripole(i ,halo%tripoleRows,k)
2548 0 : x2 = bufTripole(iDst,halo%tripoleRows,k)
2549 0 : xavg = nint(0.5_dbl_kind*(x1 + isign*x2))
2550 0 : bufTripole(i ,halo%tripoleRows,k) = xavg
2551 0 : bufTripole(iDst,halo%tripoleRows,k) = isign*xavg
2552 : end do
2553 : end do
2554 :
2555 : case (field_loc_NEcorner) ! cell corner location
2556 :
2557 0 : ioffset = 0
2558 0 : joffset = 1
2559 :
2560 : case (field_loc_Eface) ! cell center location
2561 :
2562 0 : ioffset = 0
2563 0 : joffset = 0
2564 :
2565 : !*** top row is degenerate, so must enforce symmetry
2566 : !*** use average of two degenerate points for value
2567 :
2568 0 : do k=1,nz
2569 0 : do i = 1,nxGlobal/2
2570 0 : iDst = nxGlobal + 1 - i
2571 0 : x1 = bufTripole(i ,halo%tripoleRows,k)
2572 0 : x2 = bufTripole(iDst,halo%tripoleRows,k)
2573 0 : xavg = nint(0.5_dbl_kind*(x1 + isign*x2))
2574 0 : bufTripole(i ,halo%tripoleRows,k) = xavg
2575 0 : bufTripole(iDst,halo%tripoleRows,k) = isign*xavg
2576 : end do
2577 : end do
2578 :
2579 : case (field_loc_Nface) ! cell corner (velocity) location
2580 :
2581 0 : ioffset = -1
2582 0 : joffset = 1
2583 :
2584 : case default
2585 0 : call abort_ice(subname//'ERROR: Unknown field location')
2586 : end select
2587 :
2588 : else ! tripole u-fold
2589 :
2590 0 : select case (fieldLoc)
2591 : case (field_loc_center) ! cell center location
2592 :
2593 0 : ioffset = 0
2594 0 : joffset = 0
2595 :
2596 : case (field_loc_NEcorner) ! cell corner location
2597 :
2598 0 : ioffset = 1
2599 0 : joffset = 1
2600 :
2601 : !*** top row is degenerate, so must enforce symmetry
2602 : !*** use average of two degenerate points for value
2603 :
2604 0 : do k=1,nz
2605 0 : do i = 1,nxGlobal/2 - 1
2606 0 : iDst = nxGlobal - i
2607 0 : x1 = bufTripole(i ,halo%tripoleRows,k)
2608 0 : x2 = bufTripole(iDst,halo%tripoleRows,k)
2609 0 : xavg = nint(0.5_dbl_kind*(x1 + isign*x2))
2610 0 : bufTripole(i ,halo%tripoleRows,k) = xavg
2611 0 : bufTripole(iDst,halo%tripoleRows,k) = isign*xavg
2612 : end do
2613 : end do
2614 :
2615 : case (field_loc_Eface) ! cell center location
2616 :
2617 0 : ioffset = 1
2618 0 : joffset = 0
2619 :
2620 : case (field_loc_Nface) ! cell corner (velocity) location
2621 :
2622 0 : ioffset = 0
2623 0 : joffset = 1
2624 :
2625 : !*** top row is degenerate, so must enforce symmetry
2626 : !*** use average of two degenerate points for value
2627 :
2628 0 : do k=1,nz
2629 0 : do i = 1,nxGlobal/2
2630 0 : iDst = nxGlobal + 1 - i
2631 0 : x1 = bufTripole(i ,halo%tripoleRows,k)
2632 0 : x2 = bufTripole(iDst,halo%tripoleRows,k)
2633 0 : xavg = nint(0.5_dbl_kind*(x1 + isign*x2))
2634 0 : bufTripole(i ,halo%tripoleRows,k) = xavg
2635 0 : bufTripole(iDst,halo%tripoleRows,k) = isign*xavg
2636 : end do
2637 : end do
2638 :
2639 : case default
2640 0 : call abort_ice(subname//'ERROR: Unknown field location')
2641 : end select
2642 :
2643 : endif
2644 :
2645 : !*** copy out of global tripole buffer into local
2646 : !*** ghost cells
2647 :
2648 : !*** look through local copies to find the copy out
2649 : !*** messages (srcBlock < 0)
2650 :
2651 0 : do nmsg=1,halo%numLocalCopies
2652 0 : srcBlock = halo%srcLocalAddr(3,nmsg)
2653 :
2654 0 : if (srcBlock < 0) then
2655 :
2656 0 : iSrc = halo%srcLocalAddr(1,nmsg) ! tripole buffer addr
2657 0 : jSrc = halo%srcLocalAddr(2,nmsg)
2658 :
2659 0 : iDst = halo%dstLocalAddr(1,nmsg) ! local block addr
2660 0 : jDst = halo%dstLocalAddr(2,nmsg)
2661 0 : dstBlock = halo%dstLocalAddr(3,nmsg)
2662 :
2663 : !*** correct for offsets
2664 0 : iSrc = iSrc - ioffset
2665 0 : jSrc = jSrc - joffset
2666 0 : if (iSrc < 1 ) iSrc = iSrc + nxGlobal
2667 0 : if (iSrc > nxGlobal) iSrc = iSrc - nxGlobal
2668 :
2669 : !*** for center and Eface on u-fold, and NE corner and Nface
2670 : !*** on T-fold, do not need to replace
2671 : !*** top row of physical domain, so jSrc should be
2672 : !*** out of range and skipped
2673 : !*** otherwise do the copy
2674 :
2675 0 : if (jSrc <= halo%tripoleRows .and. jSrc>0 .and. jDst>0) then
2676 0 : do k=1,nz
2677 : array(iDst,jDst,k,dstBlock) = isign* &
2678 0 : bufTripole(iSrc,jSrc,k)
2679 : end do
2680 : endif
2681 :
2682 : endif
2683 : end do
2684 :
2685 : endif
2686 :
2687 0 : if (allocated(bufTripole)) deallocate(bufTripole)
2688 :
2689 : !-----------------------------------------------------------------------
2690 :
2691 0 : end subroutine ice_HaloUpdate3DI4
2692 :
2693 : !***********************************************************************
2694 :
2695 145 : subroutine ice_HaloUpdate4DR8(array, halo, &
2696 : fieldLoc, fieldKind, & ! LCOV_EXCL_LINE
2697 : fillValue)
2698 :
2699 : ! This routine updates ghost cells for an input array and is a
2700 : ! member of a group of routines under the generic interface
2701 : ! POP\_HaloUpdate. This routine is the specific interface
2702 : ! for 4d horizontal arrays of double precision.
2703 :
2704 : type (ice_halo), intent(in) :: &
2705 : halo ! precomputed halo structure containing all
2706 : ! information needed for halo update
2707 :
2708 : integer (int_kind), intent(in) :: &
2709 : fieldKind, &! id for type of field (scalar, vector, angle) ! LCOV_EXCL_LINE
2710 : fieldLoc ! id for location on horizontal grid
2711 : ! (center, NEcorner, Nface, Eface)
2712 :
2713 : real (dbl_kind), intent(in), optional :: &
2714 : fillValue ! optional value to put in ghost cells
2715 : ! where neighbor points are unknown
2716 : ! (e.g. eliminated land blocks or
2717 : ! closed boundaries)
2718 :
2719 : real (dbl_kind), dimension(:,:,:,:,:), intent(inout) :: &
2720 : array ! array containing field for which halo
2721 : ! needs to be updated
2722 :
2723 : !-----------------------------------------------------------------------
2724 : !
2725 : ! local variables
2726 : !
2727 : !-----------------------------------------------------------------------
2728 :
2729 : integer (int_kind) :: &
2730 : i,j,k,l,nmsg, &! dummy loop indices ! LCOV_EXCL_LINE
2731 : iblk,ilo,ihi,jlo,jhi, &! block sizes for fill ! LCOV_EXCL_LINE
2732 : nxGlobal, &! global domain size in x (tripole) ! LCOV_EXCL_LINE
2733 : nz, nt, &! size of array in 3rd,4th dimensions ! LCOV_EXCL_LINE
2734 : iSrc,jSrc, &! source addresses for message ! LCOV_EXCL_LINE
2735 : iDst,jDst, &! dest addresses for message ! LCOV_EXCL_LINE
2736 : srcBlock, &! local block number for source ! LCOV_EXCL_LINE
2737 : dstBlock, &! local block number for destination ! LCOV_EXCL_LINE
2738 : ioffset, joffset, &! address shifts for tripole ! LCOV_EXCL_LINE
2739 : isign ! sign factor for tripole grids
2740 :
2741 : real (dbl_kind) :: &
2742 : fill, &! value to use for unknown points ! LCOV_EXCL_LINE
2743 : x1,x2,xavg ! scalars for enforcing symmetry at U pts
2744 :
2745 : real (dbl_kind), dimension(:,:,:,:), allocatable :: &
2746 145 : bufTripole ! 4d tripole buffer
2747 :
2748 : character(len=*), parameter :: subname = '(ice_HaloUpdate4DR8)'
2749 :
2750 : !-----------------------------------------------------------------------
2751 : !
2752 : ! abort or return on unknown or noupdate field_loc or field_type
2753 : !
2754 : !-----------------------------------------------------------------------
2755 :
2756 145 : if (fieldLoc == field_loc_unknown .or. &
2757 : fieldKind == field_type_unknown) then
2758 0 : call abort_ice(subname//'ERROR: use of field_loc/type_unknown not allowed')
2759 0 : return
2760 : endif
2761 :
2762 145 : if (fieldLoc == field_loc_noupdate .or. &
2763 : fieldKind == field_type_noupdate) then
2764 0 : return
2765 : endif
2766 :
2767 : !-----------------------------------------------------------------------
2768 : !
2769 : ! initialize error code and fill value
2770 : !
2771 : !-----------------------------------------------------------------------
2772 :
2773 145 : if (present(fillValue)) then
2774 0 : fill = fillValue
2775 : else
2776 145 : fill = 0.0_dbl_kind
2777 : endif
2778 :
2779 145 : nz = size(array, dim=3)
2780 145 : nt = size(array, dim=4)
2781 :
2782 145 : nxGlobal = 0
2783 145 : if (allocated(bufTripoleR8)) then
2784 0 : nxGlobal = size(bufTripoleR8,dim=1)
2785 0 : allocate(bufTripole(nxGlobal,halo%tripoleRows,nz,nt))
2786 0 : bufTripole = fill
2787 : endif
2788 :
2789 : !-----------------------------------------------------------------------
2790 : !
2791 : ! fill out halo region
2792 : ! needed for masked halos to ensure halo values are filled for
2793 : ! halo grid cells that are not updated
2794 : !
2795 : !-----------------------------------------------------------------------
2796 :
2797 290 : do iblk = 1, halo%numLocalBlocks
2798 : call get_block_parameter(halo%blockGlobalID(iblk), &
2799 : ilo=ilo, ihi=ihi, & ! LCOV_EXCL_LINE
2800 145 : jlo=jlo, jhi=jhi)
2801 290 : do j = 1,nghost
2802 1867230 : array(1:nx_block, jlo-j,:,:,iblk) = fill
2803 1867375 : array(1:nx_block, jhi+j,:,:,iblk) = fill
2804 : enddo
2805 580 : do i = 1,nghost
2806 2157150 : array(ilo-i, 1:ny_block,:,:,iblk) = fill
2807 2157295 : array(ihi+i, 1:ny_block,:,:,iblk) = fill
2808 : enddo
2809 : enddo
2810 :
2811 : !-----------------------------------------------------------------------
2812 : !
2813 : ! do local copies
2814 : ! if srcBlock is zero, that denotes an eliminated land block or a
2815 : ! closed boundary where ghost cell values are undefined
2816 : ! if srcBlock is less than zero, the message is a copy out of the
2817 : ! tripole buffer and will be treated later
2818 : !
2819 : !-----------------------------------------------------------------------
2820 :
2821 33785 : do nmsg=1,halo%numLocalCopies
2822 33640 : iSrc = halo%srcLocalAddr(1,nmsg)
2823 33640 : jSrc = halo%srcLocalAddr(2,nmsg)
2824 33640 : srcBlock = halo%srcLocalAddr(3,nmsg)
2825 33640 : iDst = halo%dstLocalAddr(1,nmsg)
2826 33640 : jDst = halo%dstLocalAddr(2,nmsg)
2827 33640 : dstBlock = halo%dstLocalAddr(3,nmsg)
2828 :
2829 33785 : if (srcBlock > 0) then
2830 33640 : if (dstBlock > 0) then
2831 201840 : do l=1,nt
2832 4405680 : do k=1,nz
2833 : array(iDst,jDst,k,l,dstBlock) = &
2834 4372040 : array(iSrc,jSrc,k,l,srcBlock)
2835 : end do
2836 : end do
2837 0 : else if (dstBlock < 0) then ! tripole copy into buffer
2838 0 : do l=1,nt
2839 0 : do k=1,nz
2840 : bufTripole(iDst,jDst,k,l) = &
2841 0 : array(iSrc,jSrc,k,l,srcBlock)
2842 : end do
2843 : end do
2844 : endif
2845 0 : else if (srcBlock == 0) then
2846 0 : do l=1,nt
2847 0 : do k=1,nz
2848 0 : array(iDst,jDst,k,l,dstBlock) = fill
2849 : end do
2850 : end do
2851 : endif
2852 : end do
2853 :
2854 : !-----------------------------------------------------------------------
2855 : !
2856 : ! take care of northern boundary in tripole case
2857 : ! bufTripole array contains the top nghost+1 rows (u-fold) or nghost+2 rows
2858 : ! (T-fold) of physical domain for entire (global) top row
2859 : !
2860 : !-----------------------------------------------------------------------
2861 :
2862 145 : if (nxGlobal > 0) then
2863 :
2864 0 : select case (fieldKind)
2865 : case (field_type_scalar)
2866 0 : isign = 1
2867 : case (field_type_vector)
2868 0 : isign = -1
2869 : case (field_type_angle)
2870 0 : isign = -1
2871 : case default
2872 0 : call abort_ice(subname//'ERROR: Unknown field kind')
2873 : end select
2874 :
2875 0 : if (halo%tripoleTFlag) then
2876 :
2877 0 : select case (fieldLoc)
2878 : case (field_loc_center) ! cell center location
2879 :
2880 0 : ioffset = -1
2881 0 : joffset = 0
2882 :
2883 : !*** top row is degenerate, so must enforce symmetry
2884 : !*** use average of two degenerate points for value
2885 :
2886 0 : do l=1,nt
2887 0 : do k=1,nz
2888 0 : do i = 2,nxGlobal/2
2889 0 : iDst = nxGlobal - i + 2
2890 0 : x1 = bufTripole(i ,halo%tripoleRows,k,l)
2891 0 : x2 = bufTripole(iDst,halo%tripoleRows,k,l)
2892 0 : xavg = 0.5_dbl_kind*(x1 + isign*x2)
2893 0 : bufTripole(i ,halo%tripoleRows,k,l) = xavg
2894 0 : bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg
2895 : end do
2896 : end do
2897 : end do
2898 :
2899 : case (field_loc_NEcorner) ! cell corner location
2900 :
2901 0 : ioffset = 0
2902 0 : joffset = 1
2903 :
2904 : case (field_loc_Eface) ! cell center location
2905 :
2906 0 : ioffset = 0
2907 0 : joffset = 0
2908 :
2909 : !*** top row is degenerate, so must enforce symmetry
2910 : !*** use average of two degenerate points for value
2911 :
2912 0 : do l=1,nt
2913 0 : do k=1,nz
2914 0 : do i = 1,nxGlobal/2
2915 0 : iDst = nxGlobal + 1 - i
2916 0 : x1 = bufTripole(i ,halo%tripoleRows,k,l)
2917 0 : x2 = bufTripole(iDst,halo%tripoleRows,k,l)
2918 0 : xavg = 0.5_dbl_kind*(x1 + isign*x2)
2919 0 : bufTripole(i ,halo%tripoleRows,k,l) = xavg
2920 0 : bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg
2921 : end do
2922 : end do
2923 : end do
2924 :
2925 : case (field_loc_Nface) ! cell corner (velocity) location
2926 :
2927 0 : ioffset = -1
2928 0 : joffset = 1
2929 :
2930 : case default
2931 0 : call abort_ice(subname//'ERROR: Unknown field location')
2932 : end select
2933 :
2934 : else ! tripole u-fold
2935 :
2936 0 : select case (fieldLoc)
2937 : case (field_loc_center) ! cell center location
2938 :
2939 0 : ioffset = 0
2940 0 : joffset = 0
2941 :
2942 : case (field_loc_NEcorner) ! cell corner location
2943 :
2944 0 : ioffset = 1
2945 0 : joffset = 1
2946 :
2947 : !*** top row is degenerate, so must enforce symmetry
2948 : !*** use average of two degenerate points for value
2949 :
2950 0 : do l=1,nt
2951 0 : do k=1,nz
2952 0 : do i = 1,nxGlobal/2 - 1
2953 0 : iDst = nxGlobal - i
2954 0 : x1 = bufTripole(i ,halo%tripoleRows,k,l)
2955 0 : x2 = bufTripole(iDst,halo%tripoleRows,k,l)
2956 0 : xavg = 0.5_dbl_kind*(x1 + isign*x2)
2957 0 : bufTripole(i ,halo%tripoleRows,k,l) = xavg
2958 0 : bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg
2959 : end do
2960 : end do
2961 : end do
2962 :
2963 : case (field_loc_Eface) ! cell center location
2964 :
2965 0 : ioffset = 1
2966 0 : joffset = 0
2967 :
2968 : case (field_loc_Nface) ! cell corner (velocity) location
2969 :
2970 0 : ioffset = 0
2971 0 : joffset = 1
2972 :
2973 : !*** top row is degenerate, so must enforce symmetry
2974 : !*** use average of two degenerate points for value
2975 :
2976 0 : do l=1,nt
2977 0 : do k=1,nz
2978 0 : do i = 1,nxGlobal/2
2979 0 : iDst = nxGlobal + 1 - i
2980 0 : x1 = bufTripole(i ,halo%tripoleRows,k,l)
2981 0 : x2 = bufTripole(iDst,halo%tripoleRows,k,l)
2982 0 : xavg = 0.5_dbl_kind*(x1 + isign*x2)
2983 0 : bufTripole(i ,halo%tripoleRows,k,l) = xavg
2984 0 : bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg
2985 : end do
2986 : end do
2987 : end do
2988 :
2989 : case default
2990 0 : call abort_ice(subname//'ERROR: Unknown field location')
2991 : end select
2992 :
2993 : endif
2994 :
2995 : !*** copy out of global tripole buffer into local
2996 : !*** ghost cells
2997 :
2998 : !*** look through local copies to find the copy out
2999 : !*** messages (srcBlock < 0)
3000 :
3001 0 : do nmsg=1,halo%numLocalCopies
3002 0 : srcBlock = halo%srcLocalAddr(3,nmsg)
3003 :
3004 0 : if (srcBlock < 0) then
3005 :
3006 0 : iSrc = halo%srcLocalAddr(1,nmsg) ! tripole buffer addr
3007 0 : jSrc = halo%srcLocalAddr(2,nmsg)
3008 :
3009 0 : iDst = halo%dstLocalAddr(1,nmsg) ! local block addr
3010 0 : jDst = halo%dstLocalAddr(2,nmsg)
3011 0 : dstBlock = halo%dstLocalAddr(3,nmsg)
3012 :
3013 : !*** correct for offsets
3014 0 : iSrc = iSrc - ioffset
3015 0 : jSrc = jSrc - joffset
3016 0 : if (iSrc < 1 ) iSrc = iSrc + nxGlobal
3017 0 : if (iSrc > nxGlobal) iSrc = iSrc - nxGlobal
3018 :
3019 : !*** for center and Eface on u-fold, and NE corner and Nface
3020 : !*** on T-fold, do not need to replace
3021 : !*** top row of physical domain, so jSrc should be
3022 : !*** out of range and skipped
3023 : !*** otherwise do the copy
3024 :
3025 0 : if (jSrc <= halo%tripoleRows .and. jSrc>0 .and. jDst>0) then
3026 0 : do l=1,nt
3027 0 : do k=1,nz
3028 : array(iDst,jDst,k,l,dstBlock) = isign* &
3029 0 : bufTripole(iSrc,jSrc,k,l)
3030 : end do
3031 : end do
3032 : endif
3033 :
3034 : endif
3035 : end do
3036 :
3037 : endif
3038 :
3039 145 : if (allocated(bufTripole)) deallocate(bufTripole)
3040 :
3041 : !-----------------------------------------------------------------------
3042 :
3043 145 : end subroutine ice_HaloUpdate4DR8
3044 :
3045 : !***********************************************************************
3046 :
3047 0 : subroutine ice_HaloUpdate4DR4(array, halo, &
3048 : fieldLoc, fieldKind, & ! LCOV_EXCL_LINE
3049 : fillValue)
3050 :
3051 : ! This routine updates ghost cells for an input array and is a
3052 : ! member of a group of routines under the generic interface
3053 : ! POP\_HaloUpdate. This routine is the specific interface
3054 : ! for 4d horizontal arrays of single precision.
3055 :
3056 : type (ice_halo), intent(in) :: &
3057 : halo ! precomputed halo structure containing all
3058 : ! information needed for halo update
3059 :
3060 : integer (int_kind), intent(in) :: &
3061 : fieldKind, &! id for type of field (scalar, vector, angle) ! LCOV_EXCL_LINE
3062 : fieldLoc ! id for location on horizontal grid
3063 : ! (center, NEcorner, Nface, Eface)
3064 :
3065 : real (real_kind), intent(in), optional :: &
3066 : fillValue ! optional value to put in ghost cells
3067 : ! where neighbor points are unknown
3068 : ! (e.g. eliminated land blocks or
3069 : ! closed boundaries)
3070 :
3071 : real (real_kind), dimension(:,:,:,:,:), intent(inout) :: &
3072 : array ! array containing field for which halo
3073 : ! needs to be updated
3074 :
3075 : !-----------------------------------------------------------------------
3076 : !
3077 : ! local variables
3078 : !
3079 : !-----------------------------------------------------------------------
3080 :
3081 : integer (int_kind) :: &
3082 : i,j,k,l,nmsg, &! dummy loop indices ! LCOV_EXCL_LINE
3083 : iblk,ilo,ihi,jlo,jhi, &! block sizes for fill ! LCOV_EXCL_LINE
3084 : nxGlobal, &! global domain size in x (tripole) ! LCOV_EXCL_LINE
3085 : nz, nt, &! size of array in 3rd,4th dimensions ! LCOV_EXCL_LINE
3086 : iSrc,jSrc, &! source addresses for message ! LCOV_EXCL_LINE
3087 : iDst,jDst, &! dest addresses for message ! LCOV_EXCL_LINE
3088 : srcBlock, &! local block number for source ! LCOV_EXCL_LINE
3089 : dstBlock, &! local block number for destination ! LCOV_EXCL_LINE
3090 : ioffset, joffset, &! address shifts for tripole ! LCOV_EXCL_LINE
3091 : isign ! sign factor for tripole grids
3092 :
3093 : real (real_kind) :: &
3094 : fill, &! value to use for unknown points ! LCOV_EXCL_LINE
3095 : x1,x2,xavg ! scalars for enforcing symmetry at U pts
3096 :
3097 : real (real_kind), dimension(:,:,:,:), allocatable :: &
3098 0 : bufTripole ! 4d tripole buffer
3099 :
3100 : character(len=*), parameter :: subname = '(ice_HaloUpdate4DR4)'
3101 :
3102 : !-----------------------------------------------------------------------
3103 : !
3104 : ! abort or return on unknown or noupdate field_loc or field_type
3105 : !
3106 : !-----------------------------------------------------------------------
3107 :
3108 0 : if (fieldLoc == field_loc_unknown .or. &
3109 : fieldKind == field_type_unknown) then
3110 0 : call abort_ice(subname//'ERROR: use of field_loc/type_unknown not allowed')
3111 0 : return
3112 : endif
3113 :
3114 0 : if (fieldLoc == field_loc_noupdate .or. &
3115 : fieldKind == field_type_noupdate) then
3116 0 : return
3117 : endif
3118 :
3119 : !-----------------------------------------------------------------------
3120 : !
3121 : ! initialize error code and fill value
3122 : !
3123 : !-----------------------------------------------------------------------
3124 :
3125 0 : if (present(fillValue)) then
3126 0 : fill = fillValue
3127 : else
3128 0 : fill = 0.0_real_kind
3129 : endif
3130 :
3131 0 : nz = size(array, dim=3)
3132 0 : nt = size(array, dim=4)
3133 :
3134 0 : nxGlobal = 0
3135 0 : if (allocated(bufTripoleR4)) then
3136 0 : nxGlobal = size(bufTripoleR4,dim=1)
3137 0 : allocate(bufTripole(nxGlobal,halo%tripoleRows,nz,nt))
3138 0 : bufTripole = fill
3139 : endif
3140 :
3141 : !-----------------------------------------------------------------------
3142 : !
3143 : ! fill out halo region
3144 : ! needed for masked halos to ensure halo values are filled for
3145 : ! halo grid cells that are not updated
3146 : !
3147 : !-----------------------------------------------------------------------
3148 :
3149 0 : do iblk = 1, halo%numLocalBlocks
3150 : call get_block_parameter(halo%blockGlobalID(iblk), &
3151 : ilo=ilo, ihi=ihi, & ! LCOV_EXCL_LINE
3152 0 : jlo=jlo, jhi=jhi)
3153 0 : do j = 1,nghost
3154 0 : array(1:nx_block, jlo-j,:,:,iblk) = fill
3155 0 : array(1:nx_block, jhi+j,:,:,iblk) = fill
3156 : enddo
3157 0 : do i = 1,nghost
3158 0 : array(ilo-i, 1:ny_block,:,:,iblk) = fill
3159 0 : array(ihi+i, 1:ny_block,:,:,iblk) = fill
3160 : enddo
3161 : enddo
3162 :
3163 : !-----------------------------------------------------------------------
3164 : !
3165 : ! do local copies
3166 : ! if srcBlock is zero, that denotes an eliminated land block or a
3167 : ! closed boundary where ghost cell values are undefined
3168 : ! if srcBlock is less than zero, the message is a copy out of the
3169 : ! tripole buffer and will be treated later
3170 : !
3171 : !-----------------------------------------------------------------------
3172 :
3173 0 : do nmsg=1,halo%numLocalCopies
3174 0 : iSrc = halo%srcLocalAddr(1,nmsg)
3175 0 : jSrc = halo%srcLocalAddr(2,nmsg)
3176 0 : srcBlock = halo%srcLocalAddr(3,nmsg)
3177 0 : iDst = halo%dstLocalAddr(1,nmsg)
3178 0 : jDst = halo%dstLocalAddr(2,nmsg)
3179 0 : dstBlock = halo%dstLocalAddr(3,nmsg)
3180 :
3181 0 : if (srcBlock > 0) then
3182 0 : if (dstBlock > 0) then
3183 0 : do l=1,nt
3184 0 : do k=1,nz
3185 : array(iDst,jDst,k,l,dstBlock) = &
3186 0 : array(iSrc,jSrc,k,l,srcBlock)
3187 : end do
3188 : end do
3189 0 : else if (dstBlock < 0) then ! tripole copy into buffer
3190 0 : do l=1,nt
3191 0 : do k=1,nz
3192 : bufTripole(iDst,jDst,k,l) = &
3193 0 : array(iSrc,jSrc,k,l,srcBlock)
3194 : end do
3195 : end do
3196 : endif
3197 0 : else if (srcBlock == 0) then
3198 0 : do l=1,nt
3199 0 : do k=1,nz
3200 0 : array(iDst,jDst,k,l,dstBlock) = fill
3201 : end do
3202 : end do
3203 : endif
3204 : end do
3205 :
3206 : !-----------------------------------------------------------------------
3207 : !
3208 : ! take care of northern boundary in tripole case
3209 : ! bufTripole array contains the top nghost+1 rows (u-fold) or nghost+2 rows
3210 : ! (T-fold) of physical domain for entire (global) top row
3211 : !
3212 : !-----------------------------------------------------------------------
3213 :
3214 0 : if (nxGlobal > 0) then
3215 :
3216 0 : select case (fieldKind)
3217 : case (field_type_scalar)
3218 0 : isign = 1
3219 : case (field_type_vector)
3220 0 : isign = -1
3221 : case (field_type_angle)
3222 0 : isign = -1
3223 : case default
3224 0 : call abort_ice(subname//'ERROR: Unknown field kind')
3225 : end select
3226 :
3227 0 : if (halo%tripoleTFlag) then
3228 :
3229 0 : select case (fieldLoc)
3230 : case (field_loc_center) ! cell center location
3231 :
3232 0 : ioffset = -1
3233 0 : joffset = 0
3234 :
3235 : !*** top row is degenerate, so must enforce symmetry
3236 : !*** use average of two degenerate points for value
3237 :
3238 0 : do l=1,nt
3239 0 : do k=1,nz
3240 0 : do i = 2,nxGlobal/2
3241 0 : iDst = nxGlobal - i + 2
3242 0 : x1 = bufTripole(i ,halo%tripoleRows,k,l)
3243 0 : x2 = bufTripole(iDst,halo%tripoleRows,k,l)
3244 0 : xavg = 0.5_real_kind*(x1 + isign*x2)
3245 0 : bufTripole(i ,halo%tripoleRows,k,l) = xavg
3246 0 : bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg
3247 : end do
3248 : end do
3249 : end do
3250 :
3251 : case (field_loc_NEcorner) ! cell corner location
3252 :
3253 0 : ioffset = 0
3254 0 : joffset = 1
3255 :
3256 : case (field_loc_Eface) ! cell center location
3257 :
3258 0 : ioffset = 0
3259 0 : joffset = 0
3260 :
3261 : !*** top row is degenerate, so must enforce symmetry
3262 : !*** use average of two degenerate points for value
3263 :
3264 0 : do l=1,nt
3265 0 : do k=1,nz
3266 0 : do i = 1,nxGlobal/2
3267 0 : iDst = nxGlobal + 1 - i
3268 0 : x1 = bufTripole(i ,halo%tripoleRows,k,l)
3269 0 : x2 = bufTripole(iDst,halo%tripoleRows,k,l)
3270 0 : xavg = 0.5_real_kind*(x1 + isign*x2)
3271 0 : bufTripole(i ,halo%tripoleRows,k,l) = xavg
3272 0 : bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg
3273 : end do
3274 : end do
3275 : end do
3276 :
3277 : case (field_loc_Nface) ! cell corner (velocity) location
3278 :
3279 0 : ioffset = -1
3280 0 : joffset = 1
3281 :
3282 : case default
3283 0 : call abort_ice(subname//'ERROR: Unknown field location')
3284 : end select
3285 :
3286 : else ! tripole u-fold
3287 :
3288 0 : select case (fieldLoc)
3289 : case (field_loc_center) ! cell center location
3290 :
3291 0 : ioffset = 0
3292 0 : joffset = 0
3293 :
3294 : case (field_loc_NEcorner) ! cell corner location
3295 :
3296 0 : ioffset = 1
3297 0 : joffset = 1
3298 :
3299 : !*** top row is degenerate, so must enforce symmetry
3300 : !*** use average of two degenerate points for value
3301 :
3302 0 : do l=1,nt
3303 0 : do k=1,nz
3304 0 : do i = 1,nxGlobal/2 - 1
3305 0 : iDst = nxGlobal - i
3306 0 : x1 = bufTripole(i ,halo%tripoleRows,k,l)
3307 0 : x2 = bufTripole(iDst,halo%tripoleRows,k,l)
3308 0 : xavg = 0.5_real_kind*(x1 + isign*x2)
3309 0 : bufTripole(i ,halo%tripoleRows,k,l) = xavg
3310 0 : bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg
3311 : end do
3312 : end do
3313 : end do
3314 :
3315 : case (field_loc_Eface) ! cell center location
3316 :
3317 0 : ioffset = 1
3318 0 : joffset = 0
3319 :
3320 : case (field_loc_Nface) ! cell corner (velocity) location
3321 :
3322 0 : ioffset = 0
3323 0 : joffset = 1
3324 :
3325 : !*** top row is degenerate, so must enforce symmetry
3326 : !*** use average of two degenerate points for value
3327 :
3328 0 : do l=1,nt
3329 0 : do k=1,nz
3330 0 : do i = 1,nxGlobal/2
3331 0 : iDst = nxGlobal + 1 - i
3332 0 : x1 = bufTripole(i ,halo%tripoleRows,k,l)
3333 0 : x2 = bufTripole(iDst,halo%tripoleRows,k,l)
3334 0 : xavg = 0.5_real_kind*(x1 + isign*x2)
3335 0 : bufTripole(i ,halo%tripoleRows,k,l) = xavg
3336 0 : bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg
3337 : end do
3338 : end do
3339 : end do
3340 :
3341 : case default
3342 0 : call abort_ice(subname//'ERROR: Unknown field location')
3343 : end select
3344 :
3345 : endif
3346 :
3347 : !*** copy out of global tripole buffer into local
3348 : !*** ghost cells
3349 :
3350 : !*** look through local copies to find the copy out
3351 : !*** messages (srcBlock < 0)
3352 :
3353 0 : do nmsg=1,halo%numLocalCopies
3354 0 : srcBlock = halo%srcLocalAddr(3,nmsg)
3355 :
3356 0 : if (srcBlock < 0) then
3357 :
3358 0 : iSrc = halo%srcLocalAddr(1,nmsg) ! tripole buffer addr
3359 0 : jSrc = halo%srcLocalAddr(2,nmsg)
3360 :
3361 0 : iDst = halo%dstLocalAddr(1,nmsg) ! local block addr
3362 0 : jDst = halo%dstLocalAddr(2,nmsg)
3363 0 : dstBlock = halo%dstLocalAddr(3,nmsg)
3364 :
3365 : !*** correct for offsets
3366 0 : iSrc = iSrc - ioffset
3367 0 : jSrc = jSrc - joffset
3368 0 : if (iSrc < 1 ) iSrc = iSrc + nxGlobal
3369 0 : if (iSrc > nxGlobal) iSrc = iSrc - nxGlobal
3370 :
3371 : !*** for center and Eface on u-fold, and NE corner and Nface
3372 : !*** on T-fold, do not need to replace
3373 : !*** top row of physical domain, so jSrc should be
3374 : !*** out of range and skipped
3375 : !*** otherwise do the copy
3376 :
3377 0 : if (jSrc <= halo%tripoleRows .and. jSrc>0 .and. jDst>0) then
3378 0 : do l=1,nt
3379 0 : do k=1,nz
3380 : array(iDst,jDst,k,l,dstBlock) = isign* &
3381 0 : bufTripole(iSrc,jSrc,k,l)
3382 : end do
3383 : end do
3384 : endif
3385 :
3386 : endif
3387 : end do
3388 :
3389 : endif
3390 :
3391 0 : if (allocated(bufTripole)) deallocate(bufTripole)
3392 :
3393 : !-----------------------------------------------------------------------
3394 :
3395 0 : end subroutine ice_HaloUpdate4DR4
3396 :
3397 : !***********************************************************************
3398 :
3399 0 : subroutine ice_HaloUpdate4DI4(array, halo, &
3400 : fieldLoc, fieldKind, & ! LCOV_EXCL_LINE
3401 : fillValue)
3402 :
3403 : ! This routine updates ghost cells for an input array and is a
3404 : ! member of a group of routines under the generic interface
3405 : ! POP\_HaloUpdate. This routine is the specific interface
3406 : ! for 4d horizontal integer arrays.
3407 :
3408 : type (ice_halo), intent(in) :: &
3409 : halo ! precomputed halo structure containing all
3410 : ! information needed for halo update
3411 :
3412 : integer (int_kind), intent(in) :: &
3413 : fieldKind, &! id for type of field (scalar, vector, angle) ! LCOV_EXCL_LINE
3414 : fieldLoc ! id for location on horizontal grid
3415 : ! (center, NEcorner, Nface, Eface)
3416 :
3417 : integer (int_kind), intent(in), optional :: &
3418 : fillValue ! optional value to put in ghost cells
3419 : ! where neighbor points are unknown
3420 : ! (e.g. eliminated land blocks or
3421 : ! closed boundaries)
3422 :
3423 : integer (int_kind), dimension(:,:,:,:,:), intent(inout) :: &
3424 : array ! array containing field for which halo
3425 : ! needs to be updated
3426 :
3427 : !-----------------------------------------------------------------------
3428 : !
3429 : ! local variables
3430 : !
3431 : !-----------------------------------------------------------------------
3432 :
3433 : integer (int_kind) :: &
3434 : i,j,k,l,nmsg, &! dummy loop indices ! LCOV_EXCL_LINE
3435 : iblk,ilo,ihi,jlo,jhi, &! block sizes for fill ! LCOV_EXCL_LINE
3436 : nxGlobal, &! global domain size in x (tripole) ! LCOV_EXCL_LINE
3437 : nz, nt, &! size of array in 3rd,4th dimensions ! LCOV_EXCL_LINE
3438 : iSrc,jSrc, &! source addresses for message ! LCOV_EXCL_LINE
3439 : iDst,jDst, &! dest addresses for message ! LCOV_EXCL_LINE
3440 : srcBlock, &! local block number for source ! LCOV_EXCL_LINE
3441 : dstBlock, &! local block number for destination ! LCOV_EXCL_LINE
3442 : ioffset, joffset, &! address shifts for tripole ! LCOV_EXCL_LINE
3443 : isign ! sign factor for tripole grids
3444 :
3445 : integer (int_kind) :: &
3446 : fill, &! value to use for unknown points ! LCOV_EXCL_LINE
3447 : x1,x2,xavg ! scalars for enforcing symmetry at U pts
3448 :
3449 : integer (int_kind), dimension(:,:,:,:), allocatable :: &
3450 0 : bufTripole ! 4d tripole buffer
3451 :
3452 : character(len=*), parameter :: subname = '(ice_HaloUpdate4DI4)'
3453 :
3454 : !-----------------------------------------------------------------------
3455 : !
3456 : ! abort or return on unknown or noupdate field_loc or field_type
3457 : !
3458 : !-----------------------------------------------------------------------
3459 :
3460 0 : if (fieldLoc == field_loc_unknown .or. &
3461 : fieldKind == field_type_unknown) then
3462 0 : call abort_ice(subname//'ERROR: use of field_loc/type_unknown not allowed')
3463 0 : return
3464 : endif
3465 :
3466 0 : if (fieldLoc == field_loc_noupdate .or. &
3467 : fieldKind == field_type_noupdate) then
3468 0 : return
3469 : endif
3470 :
3471 : !-----------------------------------------------------------------------
3472 : !
3473 : ! initialize error code and fill value
3474 : !
3475 : !-----------------------------------------------------------------------
3476 :
3477 0 : if (present(fillValue)) then
3478 0 : fill = fillValue
3479 : else
3480 0 : fill = 0_int_kind
3481 : endif
3482 :
3483 0 : nz = size(array, dim=3)
3484 0 : nt = size(array, dim=4)
3485 :
3486 0 : nxGlobal = 0
3487 0 : if (allocated(bufTripoleI4)) then
3488 0 : nxGlobal = size(bufTripoleI4,dim=1)
3489 0 : allocate(bufTripole(nxGlobal,halo%tripoleRows,nz,nt))
3490 0 : bufTripole = fill
3491 : endif
3492 :
3493 : !-----------------------------------------------------------------------
3494 : !
3495 : ! fill out halo region
3496 : ! needed for masked halos to ensure halo values are filled for
3497 : ! halo grid cells that are not updated
3498 : !
3499 : !-----------------------------------------------------------------------
3500 :
3501 0 : do iblk = 1, halo%numLocalBlocks
3502 : call get_block_parameter(halo%blockGlobalID(iblk), &
3503 : ilo=ilo, ihi=ihi, & ! LCOV_EXCL_LINE
3504 0 : jlo=jlo, jhi=jhi)
3505 0 : do j = 1,nghost
3506 0 : array(1:nx_block, jlo-j,:,:,iblk) = fill
3507 0 : array(1:nx_block, jhi+j,:,:,iblk) = fill
3508 : enddo
3509 0 : do i = 1,nghost
3510 0 : array(ilo-i, 1:ny_block,:,:,iblk) = fill
3511 0 : array(ihi+i, 1:ny_block,:,:,iblk) = fill
3512 : enddo
3513 : enddo
3514 :
3515 : !-----------------------------------------------------------------------
3516 : !
3517 : ! do local copies
3518 : ! if srcBlock is zero, that denotes an eliminated land block or a
3519 : ! closed boundary where ghost cell values are undefined
3520 : ! if srcBlock is less than zero, the message is a copy out of the
3521 : ! tripole buffer and will be treated later
3522 : !
3523 : !-----------------------------------------------------------------------
3524 :
3525 0 : do nmsg=1,halo%numLocalCopies
3526 0 : iSrc = halo%srcLocalAddr(1,nmsg)
3527 0 : jSrc = halo%srcLocalAddr(2,nmsg)
3528 0 : srcBlock = halo%srcLocalAddr(3,nmsg)
3529 0 : iDst = halo%dstLocalAddr(1,nmsg)
3530 0 : jDst = halo%dstLocalAddr(2,nmsg)
3531 0 : dstBlock = halo%dstLocalAddr(3,nmsg)
3532 :
3533 0 : if (srcBlock > 0) then
3534 0 : if (dstBlock > 0) then
3535 0 : do l=1,nt
3536 0 : do k=1,nz
3537 : array(iDst,jDst,k,l,dstBlock) = &
3538 0 : array(iSrc,jSrc,k,l,srcBlock)
3539 : end do
3540 : end do
3541 0 : else if (dstBlock < 0) then ! tripole copy into buffer
3542 0 : do l=1,nt
3543 0 : do k=1,nz
3544 : bufTripole(iDst,jDst,k,l) = &
3545 0 : array(iSrc,jSrc,k,l,srcBlock)
3546 : end do
3547 : end do
3548 : endif
3549 0 : else if (srcBlock == 0) then
3550 0 : do l=1,nt
3551 0 : do k=1,nz
3552 0 : array(iDst,jDst,k,l,dstBlock) = fill
3553 : end do
3554 : end do
3555 : endif
3556 : end do
3557 :
3558 : !-----------------------------------------------------------------------
3559 : !
3560 : ! take care of northern boundary in tripole case
3561 : ! bufTripole array contains the top nghost+1 rows (u-fold) or nghost+2 rows
3562 : ! (T-fold) of physical domain for entire (global) top row
3563 : !
3564 : !-----------------------------------------------------------------------
3565 :
3566 0 : if (nxGlobal > 0) then
3567 :
3568 0 : select case (fieldKind)
3569 : case (field_type_scalar)
3570 0 : isign = 1
3571 : case (field_type_vector)
3572 0 : isign = -1
3573 : case (field_type_angle)
3574 0 : isign = -1
3575 : case default
3576 0 : call abort_ice(subname//'ERROR: Unknown field kind')
3577 : end select
3578 :
3579 0 : if (halo%tripoleTFlag) then
3580 :
3581 0 : select case (fieldLoc)
3582 : case (field_loc_center) ! cell center location
3583 :
3584 0 : ioffset = -1
3585 0 : joffset = 0
3586 :
3587 : !*** top row is degenerate, so must enforce symmetry
3588 : !*** use average of two degenerate points for value
3589 :
3590 0 : do l=1,nt
3591 0 : do k=1,nz
3592 0 : do i = 2,nxGlobal/2
3593 0 : iDst = nxGlobal - i + 2
3594 0 : x1 = bufTripole(i ,halo%tripoleRows,k,l)
3595 0 : x2 = bufTripole(iDst,halo%tripoleRows,k,l)
3596 0 : xavg = nint(0.5_dbl_kind*(x1 + isign*x2))
3597 0 : bufTripole(i ,halo%tripoleRows,k,l) = xavg
3598 0 : bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg
3599 : end do
3600 : end do
3601 : end do
3602 :
3603 : case (field_loc_NEcorner) ! cell corner location
3604 :
3605 0 : ioffset = 0
3606 0 : joffset = 1
3607 :
3608 : case (field_loc_Eface) ! cell center location
3609 :
3610 0 : ioffset = 0
3611 0 : joffset = 0
3612 :
3613 : !*** top row is degenerate, so must enforce symmetry
3614 : !*** use average of two degenerate points for value
3615 :
3616 0 : do l=1,nt
3617 0 : do k=1,nz
3618 0 : do i = 1,nxGlobal/2
3619 0 : iDst = nxGlobal + 1 - i
3620 0 : x1 = bufTripole(i ,halo%tripoleRows,k,l)
3621 0 : x2 = bufTripole(iDst,halo%tripoleRows,k,l)
3622 0 : xavg = nint(0.5_dbl_kind*(x1 + isign*x2))
3623 0 : bufTripole(i ,halo%tripoleRows,k,l) = xavg
3624 0 : bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg
3625 : end do
3626 : end do
3627 : end do
3628 :
3629 : case (field_loc_Nface) ! cell corner (velocity) location
3630 :
3631 0 : ioffset = -1
3632 0 : joffset = 1
3633 :
3634 : case default
3635 0 : call abort_ice(subname//'ERROR: Unknown field location')
3636 : end select
3637 :
3638 : else ! tripole u-fold
3639 :
3640 0 : select case (fieldLoc)
3641 : case (field_loc_center) ! cell center location
3642 :
3643 0 : ioffset = 0
3644 0 : joffset = 0
3645 :
3646 : case (field_loc_NEcorner) ! cell corner location
3647 :
3648 0 : ioffset = 1
3649 0 : joffset = 1
3650 :
3651 : !*** top row is degenerate, so must enforce symmetry
3652 : !*** use average of two degenerate points for value
3653 :
3654 0 : do l=1,nt
3655 0 : do k=1,nz
3656 0 : do i = 1,nxGlobal/2 - 1
3657 0 : iDst = nxGlobal - i
3658 0 : x1 = bufTripole(i ,halo%tripoleRows,k,l)
3659 0 : x2 = bufTripole(iDst,halo%tripoleRows,k,l)
3660 0 : xavg = nint(0.5_dbl_kind*(x1 + isign*x2))
3661 0 : bufTripole(i ,halo%tripoleRows,k,l) = xavg
3662 0 : bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg
3663 : end do
3664 : end do
3665 : end do
3666 :
3667 : case (field_loc_Eface) ! cell center location
3668 :
3669 0 : ioffset = 1
3670 0 : joffset = 0
3671 :
3672 : case (field_loc_Nface) ! cell corner (velocity) location
3673 :
3674 0 : ioffset = 0
3675 0 : joffset = 1
3676 :
3677 : !*** top row is degenerate, so must enforce symmetry
3678 : !*** use average of two degenerate points for value
3679 :
3680 0 : do l=1,nt
3681 0 : do k=1,nz
3682 0 : do i = 1,nxGlobal/2
3683 0 : iDst = nxGlobal + 1 - i
3684 0 : x1 = bufTripole(i ,halo%tripoleRows,k,l)
3685 0 : x2 = bufTripole(iDst,halo%tripoleRows,k,l)
3686 0 : xavg = nint(0.5_dbl_kind*(x1 + isign*x2))
3687 0 : bufTripole(i ,halo%tripoleRows,k,l) = xavg
3688 0 : bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg
3689 : end do
3690 : end do
3691 : end do
3692 :
3693 : case default
3694 0 : call abort_ice(subname//'ERROR: Unknown field location')
3695 : end select
3696 :
3697 : endif
3698 :
3699 : !*** copy out of global tripole buffer into local
3700 : !*** ghost cells
3701 :
3702 : !*** look through local copies to find the copy out
3703 : !*** messages (srcBlock < 0)
3704 :
3705 0 : do nmsg=1,halo%numLocalCopies
3706 0 : srcBlock = halo%srcLocalAddr(3,nmsg)
3707 :
3708 0 : if (srcBlock < 0) then
3709 :
3710 0 : iSrc = halo%srcLocalAddr(1,nmsg) ! tripole buffer addr
3711 0 : jSrc = halo%srcLocalAddr(2,nmsg)
3712 :
3713 0 : iDst = halo%dstLocalAddr(1,nmsg) ! local block addr
3714 0 : jDst = halo%dstLocalAddr(2,nmsg)
3715 0 : dstBlock = halo%dstLocalAddr(3,nmsg)
3716 :
3717 : !*** correct for offsets
3718 0 : iSrc = iSrc - ioffset
3719 0 : jSrc = jSrc - joffset
3720 0 : if (iSrc < 1 ) iSrc = iSrc + nxGlobal
3721 0 : if (iSrc > nxGlobal) iSrc = iSrc - nxGlobal
3722 :
3723 : !*** for center and Eface on u-fold, and NE corner and Nface
3724 : !*** on T-fold, do not need to replace
3725 : !*** top row of physical domain, so jSrc should be
3726 : !*** out of range and skipped
3727 : !*** otherwise do the copy
3728 :
3729 0 : if (jSrc <= halo%tripoleRows .and. jSrc>0 .and. jDst>0) then
3730 0 : do l=1,nt
3731 0 : do k=1,nz
3732 : array(iDst,jDst,k,l,dstBlock) = isign* &
3733 0 : bufTripole(iSrc,jSrc,k,l)
3734 : end do
3735 : end do
3736 : endif
3737 :
3738 : endif
3739 : end do
3740 :
3741 : endif
3742 :
3743 0 : if (allocated(bufTripole)) deallocate(bufTripole)
3744 :
3745 : !-----------------------------------------------------------------------
3746 :
3747 0 : end subroutine ice_HaloUpdate4DI4
3748 :
3749 : !***********************************************************************
3750 : ! This routine updates ghost cells for an input array using
3751 : ! a second array as needed by the stress fields.
3752 : ! This is just like 2DR8 except no averaging and only on tripole
3753 :
3754 0 : subroutine ice_HaloUpdate_stress(array1, array2, halo, &
3755 : fieldLoc, fieldKind, & ! LCOV_EXCL_LINE
3756 : fillValue)
3757 :
3758 : type (ice_halo), intent(in) :: &
3759 : halo ! precomputed halo structure containing all
3760 : ! information needed for halo update
3761 :
3762 : integer (int_kind), intent(in) :: &
3763 : fieldKind, &! id for type of field (scalar, vector, angle) ! LCOV_EXCL_LINE
3764 : fieldLoc ! id for location on horizontal grid
3765 : ! (center, NEcorner, Nface, Eface)
3766 :
3767 : real (dbl_kind), intent(in), optional :: &
3768 : fillValue ! optional value to put in ghost cells
3769 : ! where neighbor points are unknown
3770 : ! (e.g. eliminated land blocks or
3771 : ! closed boundaries)
3772 :
3773 : real (dbl_kind), dimension(:,:,:), intent(inout) :: &
3774 : array1 ,& ! array containing field for which halo ! LCOV_EXCL_LINE
3775 : ! needs to be updated
3776 : array2 ! array containing field for which halo
3777 : ! in array1 needs to be updated
3778 :
3779 : ! local variables
3780 :
3781 : integer (int_kind) :: &
3782 : nmsg, &! dummy loop indices ! LCOV_EXCL_LINE
3783 : nxGlobal, &! global domain size in x (tripole) ! LCOV_EXCL_LINE
3784 : iSrc,jSrc, &! source addresses for message ! LCOV_EXCL_LINE
3785 : iDst,jDst, &! dest addresses for message ! LCOV_EXCL_LINE
3786 : srcBlock, &! local block number for source ! LCOV_EXCL_LINE
3787 : dstBlock, &! local block number for destination ! LCOV_EXCL_LINE
3788 : ioffset, joffset, &! address shifts for tripole ! LCOV_EXCL_LINE
3789 : isign ! sign factor for tripole grids
3790 :
3791 : real (dbl_kind) :: &
3792 : fill ! value to use for unknown points
3793 :
3794 : character(len=*), parameter :: subname = '(ice_HaloUpdate_stress)'
3795 :
3796 : !-----------------------------------------------------------------------
3797 : !
3798 : ! abort or return on unknown or noupdate field_loc or field_type
3799 : !
3800 : !-----------------------------------------------------------------------
3801 :
3802 0 : if (fieldLoc == field_loc_unknown .or. &
3803 : fieldKind == field_type_unknown) then
3804 0 : call abort_ice(subname//'ERROR: use of field_loc/type_unknown not allowed')
3805 0 : return
3806 : endif
3807 :
3808 0 : if (fieldLoc == field_loc_noupdate .or. &
3809 : fieldKind == field_type_noupdate) then
3810 0 : return
3811 : endif
3812 :
3813 : !-----------------------------------------------------------------------
3814 : !
3815 : ! initialize error code and fill value
3816 : !
3817 : !-----------------------------------------------------------------------
3818 :
3819 0 : if (present(fillValue)) then
3820 0 : fill = fillValue
3821 : else
3822 0 : fill = 0.0_dbl_kind
3823 : endif
3824 :
3825 0 : nxGlobal = 0
3826 0 : if (allocated(bufTripoleR8)) then
3827 0 : nxGlobal = size(bufTripoleR8,dim=1)
3828 0 : bufTripoleR8 = fill
3829 : endif
3830 :
3831 : !-----------------------------------------------------------------------
3832 : !
3833 : ! do NOT zero the halo out, this halo update just updates
3834 : ! the tripole zipper as needed for stresses. if you zero
3835 : ! it out, all halo values will be wiped out.
3836 : !-----------------------------------------------------------------------
3837 : ! do iblk = 1, halo%numLocalBlocks
3838 : ! call get_block_parameter(halo%blockGlobalID(iblk), &
3839 : ! ilo=ilo, ihi=ihi, & ! LCOV_EXCL_LINE
3840 : ! jlo=jlo, jhi=jhi)
3841 : ! do j = 1,nghost
3842 : ! array(1:nx_block, jlo-j,iblk) = fill
3843 : ! array(1:nx_block, jhi+j,iblk) = fill
3844 : ! enddo
3845 : ! do i = 1,nghost
3846 : ! array(ilo-i, 1:ny_block,iblk) = fill
3847 : ! array(ihi+i, 1:ny_block,iblk) = fill
3848 : ! enddo
3849 : ! enddo
3850 :
3851 : !-----------------------------------------------------------------------
3852 : !
3853 : ! do local copies
3854 : ! if srcBlock is zero, that denotes an eliminated land block or a
3855 : ! closed boundary where ghost cell values are undefined
3856 : ! if srcBlock is less than zero, the message is a copy out of the
3857 : ! tripole buffer and will be treated later
3858 : !
3859 : !-----------------------------------------------------------------------
3860 :
3861 0 : do nmsg=1,halo%numLocalCopies
3862 0 : iSrc = halo%srcLocalAddr(1,nmsg)
3863 0 : jSrc = halo%srcLocalAddr(2,nmsg)
3864 0 : srcBlock = halo%srcLocalAddr(3,nmsg)
3865 0 : iDst = halo%dstLocalAddr(1,nmsg)
3866 0 : jDst = halo%dstLocalAddr(2,nmsg)
3867 0 : dstBlock = halo%dstLocalAddr(3,nmsg)
3868 :
3869 0 : if (srcBlock > 0) then
3870 0 : if (dstBlock < 0) then ! tripole copy into buffer
3871 : bufTripoleR8(iDst,jDst) = &
3872 0 : array2(iSrc,jSrc,srcBlock)
3873 : endif
3874 0 : else if (srcBlock == 0) then
3875 0 : array1(iDst,jDst,dstBlock) = fill
3876 : endif
3877 : end do
3878 :
3879 : !-----------------------------------------------------------------------
3880 : !
3881 : ! take care of northern boundary in tripole case
3882 : ! bufTripole array contains the top haloWidth+1 rows of physical
3883 : ! domain for entire (global) top row
3884 : !
3885 : !-----------------------------------------------------------------------
3886 :
3887 0 : if (nxGlobal > 0) then
3888 :
3889 0 : select case (fieldKind)
3890 : case (field_type_scalar)
3891 0 : isign = 1
3892 : case (field_type_vector)
3893 0 : isign = -1
3894 : case (field_type_angle)
3895 0 : isign = -1
3896 : case default
3897 0 : call abort_ice(subname//'ERROR: Unknown field kind')
3898 : end select
3899 :
3900 0 : if (halo%tripoleTFlag) then
3901 :
3902 0 : select case (fieldLoc)
3903 : case (field_loc_center) ! cell center location
3904 :
3905 0 : ioffset = -1
3906 0 : joffset = 0
3907 :
3908 : case (field_loc_NEcorner) ! cell corner location
3909 :
3910 0 : ioffset = 0
3911 0 : joffset = 1
3912 :
3913 : case (field_loc_Eface) ! cell center location
3914 :
3915 0 : ioffset = 0
3916 0 : joffset = 0
3917 :
3918 : case (field_loc_Nface) ! cell corner (velocity) location
3919 :
3920 0 : ioffset = -1
3921 0 : joffset = 1
3922 :
3923 : case default
3924 0 : call abort_ice(subname//'ERROR: Unknown field location')
3925 : end select
3926 :
3927 : else ! tripole u-fold
3928 :
3929 0 : select case (fieldLoc)
3930 : case (field_loc_center) ! cell center location
3931 :
3932 0 : ioffset = 0
3933 0 : joffset = 0
3934 :
3935 : case (field_loc_NEcorner) ! cell corner location
3936 :
3937 0 : ioffset = 1
3938 0 : joffset = 1
3939 :
3940 : case (field_loc_Eface)
3941 :
3942 0 : ioffset = 1
3943 0 : joffset = 0
3944 :
3945 : case (field_loc_Nface)
3946 :
3947 0 : ioffset = 0
3948 0 : joffset = 1
3949 :
3950 : case default
3951 0 : call abort_ice(subname//'ERROR: Unknown field location')
3952 : end select
3953 :
3954 : endif
3955 :
3956 : !*** copy out of global tripole buffer into local
3957 : !*** ghost cells
3958 :
3959 : !*** look through local copies to find the copy out
3960 : !*** messages (srcBlock < 0)
3961 :
3962 0 : do nmsg=1,halo%numLocalCopies
3963 0 : srcBlock = halo%srcLocalAddr(3,nmsg)
3964 :
3965 0 : if (srcBlock < 0) then
3966 :
3967 0 : iSrc = halo%srcLocalAddr(1,nmsg) ! tripole buffer addr
3968 0 : jSrc = halo%srcLocalAddr(2,nmsg)
3969 :
3970 0 : iDst = halo%dstLocalAddr(1,nmsg) ! local block addr
3971 0 : jDst = halo%dstLocalAddr(2,nmsg)
3972 0 : dstBlock = halo%dstLocalAddr(3,nmsg)
3973 :
3974 : !*** correct for offsets
3975 0 : iSrc = iSrc - ioffset
3976 0 : jSrc = jSrc - joffset
3977 0 : if (iSrc < 1 ) iSrc = iSrc + nxGlobal
3978 0 : if (iSrc > nxGlobal) iSrc = iSrc - nxGlobal
3979 :
3980 : !*** for center and Eface, do not need to replace
3981 : !*** top row of physical domain, so jSrc should be
3982 : !*** out of range and skipped
3983 : !*** otherwise do the copy
3984 :
3985 0 : if (jSrc <= halo%tripoleRows .and. jSrc>0 .and. jDst>0) then
3986 0 : array1(iDst,jDst,dstBlock) = isign*bufTripoleR8(iSrc,jSrc)
3987 : endif
3988 :
3989 : endif
3990 : end do
3991 :
3992 : endif
3993 :
3994 : !-----------------------------------------------------------------------
3995 :
3996 : end subroutine ice_HaloUpdate_stress
3997 :
3998 : !***********************************************************************
3999 :
4000 8 : subroutine ice_HaloIncrementMsgCount(sndCounter, rcvCounter, &
4001 : srcProc, dstProc, msgSize)
4002 :
4003 : ! This is a utility routine to increment the arrays for counting
4004 : ! whether messages are required. It checks the source and destination
4005 : ! task to see whether the current task needs to send, receive or
4006 : ! copy messages to fill halo regions (ghost cells).
4007 :
4008 : integer (int_kind), intent(in) :: &
4009 : srcProc, &! source processor for communication ! LCOV_EXCL_LINE
4010 : dstProc, &! destination processor for communication ! LCOV_EXCL_LINE
4011 : msgSize ! number of words for this message
4012 :
4013 : integer (int_kind), dimension(:), intent(inout) :: &
4014 : sndCounter, &! array for counting messages to be sent ! LCOV_EXCL_LINE
4015 : rcvCounter ! array for counting messages to be received
4016 :
4017 : character(len=*), parameter :: subname = '(ice_HaloIncrementMsgCount)'
4018 :
4019 : !-----------------------------------------------------------------------
4020 : !
4021 : ! error check
4022 : !
4023 : !-----------------------------------------------------------------------
4024 :
4025 : if (srcProc < 0 .or. dstProc < 0 .or. &
4026 : srcProc > size(sndCounter) .or. & ! LCOV_EXCL_LINE
4027 : dstProc > size(rcvCounter)) then
4028 0 : call abort_ice(subname//'ERROR: invalid processor number')
4029 0 : return
4030 : endif
4031 :
4032 : !-----------------------------------------------------------------------
4033 : !
4034 : ! if destination all land or outside closed boundary (dstProc = 0),
4035 : ! then no send is necessary, so do the rest only for dstProc /= 0
4036 : !
4037 : !-----------------------------------------------------------------------
4038 :
4039 8 : if (dstProc == 0) return
4040 :
4041 : !-----------------------------------------------------------------------
4042 : !
4043 : ! if the current processor is the source, must send data
4044 : ! local copy if dstProc = srcProc
4045 : !
4046 : !-----------------------------------------------------------------------
4047 :
4048 2 : if (srcProc == my_task + 1) sndCounter(dstProc) = &
4049 2 : sndCounter(dstProc) + msgSize
4050 :
4051 : !-----------------------------------------------------------------------
4052 : !
4053 : ! if the current processor is the destination, must receive data
4054 : ! local copy if dstProc = srcProc
4055 : !
4056 : !-----------------------------------------------------------------------
4057 :
4058 2 : if (dstProc == my_task + 1) then
4059 :
4060 2 : if (srcProc > 0) then
4061 : !*** the source block has ocean points
4062 : !*** count as a receive from srcProc
4063 :
4064 2 : rcvCounter(srcProc) = rcvCounter(srcProc) + msgSize
4065 :
4066 : else
4067 : !*** if the source block has been dropped, create
4068 : !*** a local copy to fill halo with a fill value
4069 :
4070 0 : rcvCounter(dstProc) = rcvCounter(dstProc) + msgSize
4071 :
4072 : endif
4073 : endif
4074 : !-----------------------------------------------------------------------
4075 :
4076 : end subroutine ice_HaloIncrementMsgCount
4077 :
4078 : !***********************************************************************
4079 :
4080 8 : subroutine ice_HaloMsgCreate(halo, dist, srcBlock, dstBlock, direction)
4081 :
4082 : ! This is a utility routine to determine the required address and
4083 : ! message information for a particular pair of blocks.
4084 :
4085 : type (distrb), intent(in) :: &
4086 : dist ! distribution of blocks across procs
4087 :
4088 : integer (int_kind), intent(in) :: &
4089 : srcBlock, dstBlock ! source,destination block id
4090 :
4091 : character (*), intent(in) :: &
4092 : direction ! direction of neighbor block
4093 : ! (north,south,east,west,
4094 : ! and NE, NW, SE, SW)
4095 :
4096 : type (ice_halo), intent(inout) :: &
4097 : halo ! data structure containing halo info
4098 :
4099 : !-----------------------------------------------------------------------
4100 : !
4101 : ! local variables
4102 : !
4103 : !-----------------------------------------------------------------------
4104 :
4105 : integer (int_kind) :: &
4106 : srcProc, srcLocalID, &! source block location in distribution ! LCOV_EXCL_LINE
4107 : dstProc, dstLocalID, &! source block location in distribution ! LCOV_EXCL_LINE
4108 : msgIndx, &! message counter and index into msg array ! LCOV_EXCL_LINE
4109 : ibSrc, ieSrc, jbSrc, jeSrc, &! phys domain info for source block ! LCOV_EXCL_LINE
4110 : ibDst, ieDst, jbDst, jeDst, &! phys domain info for dest block ! LCOV_EXCL_LINE
4111 : nxGlobal, &! size of global domain in e-w direction ! LCOV_EXCL_LINE
4112 : i,j ! dummy loop index
4113 :
4114 : integer (int_kind), dimension(:), pointer :: &
4115 : iGlobal ! global i index for location in tripole
4116 :
4117 : character(len=*), parameter :: subname = '(ice_HaloMsgCreate)'
4118 :
4119 : !-----------------------------------------------------------------------
4120 : !
4121 : ! initialize
4122 : !
4123 : !-----------------------------------------------------------------------
4124 :
4125 0 : if (allocated(bufTripoleR8)) nxGlobal = size(bufTripoleR8,dim=1)
4126 :
4127 : !-----------------------------------------------------------------------
4128 : !
4129 : ! find source and destination block locations
4130 : !
4131 : !-----------------------------------------------------------------------
4132 :
4133 8 : if (srcBlock /= 0) then
4134 : call ice_DistributionGetBlockLoc(dist, abs(srcBlock), srcProc, &
4135 8 : srcLocalID)
4136 : else
4137 0 : srcProc = 0
4138 0 : srcLocalID = 0
4139 : endif
4140 :
4141 8 : if (dstBlock /= 0) then
4142 : call ice_DistributionGetBlockLoc(dist, abs(dstBlock), dstProc, &
4143 2 : dstLocalID)
4144 : else
4145 6 : dstProc = 0
4146 6 : dstLocalID = 0
4147 : endif
4148 :
4149 : !-----------------------------------------------------------------------
4150 : !
4151 : ! if destination all land or outside closed boundary (dstProc = 0),
4152 : ! then no send is necessary, so do the rest only for dstProc /= 0
4153 : !
4154 : !-----------------------------------------------------------------------
4155 :
4156 8 : if (dstProc == 0) return
4157 :
4158 : !-----------------------------------------------------------------------
4159 : !
4160 : ! get block information if either block is local
4161 : !
4162 : !-----------------------------------------------------------------------
4163 :
4164 2 : if (srcProc == my_task+1 .or. dstProc == my_task+1) then
4165 :
4166 2 : if (srcBlock >= 0 .and. dstBlock >= 0) then
4167 : call get_block_parameter(srcBlock, &
4168 : ilo=ibSrc, ihi=ieSrc, & ! LCOV_EXCL_LINE
4169 2 : jlo=jbSrc, jhi=jeSrc)
4170 : else ! tripole - need iGlobal info
4171 : call get_block_parameter(abs(srcBlock), &
4172 : ilo=ibSrc, ihi=ieSrc, & ! LCOV_EXCL_LINE
4173 : jlo=jbSrc, jhi=jeSrc, & ! LCOV_EXCL_LINE
4174 0 : i_glob=iGlobal)
4175 :
4176 : endif
4177 :
4178 2 : if (dstBlock /= 0) then
4179 : call get_block_parameter(abs(dstBlock), &
4180 : ilo=ibDst, ihi=ieDst, & ! LCOV_EXCL_LINE
4181 2 : jlo=jbDst, jhi=jeDst)
4182 : endif
4183 :
4184 : endif
4185 :
4186 : !-----------------------------------------------------------------------
4187 : !
4188 : ! if both blocks are local, create a local copy to fill halo
4189 : !
4190 : !-----------------------------------------------------------------------
4191 :
4192 2 : if (srcProc == my_task+1 .and. &
4193 : dstProc == my_task+1) then
4194 :
4195 : !*** compute addresses based on direction
4196 :
4197 1 : select case (direction)
4198 : case ('east')
4199 :
4200 : !*** copy easternmost physical domain of src
4201 : !*** into westernmost halo of dst
4202 :
4203 1 : msgIndx = halo%numLocalCopies
4204 :
4205 117 : do j=1,jeSrc-jbSrc+1
4206 233 : do i=1,nghost
4207 :
4208 116 : msgIndx = msgIndx + 1
4209 :
4210 116 : halo%srcLocalAddr(1,msgIndx) = ieSrc - nghost + i
4211 116 : halo%srcLocalAddr(2,msgIndx) = jbSrc + j - 1
4212 116 : halo%srcLocalAddr(3,msgIndx) = srcLocalID
4213 :
4214 116 : halo%dstLocalAddr(1,msgIndx) = i
4215 116 : halo%dstLocalAddr(2,msgIndx) = jbDst + j - 1
4216 232 : halo%dstLocalAddr(3,msgIndx) = dstLocalID
4217 :
4218 : end do
4219 : end do
4220 :
4221 1 : halo%numLocalCopies = msgIndx
4222 :
4223 : case ('west')
4224 :
4225 : !*** copy westernmost physical domain of src
4226 : !*** into easternmost halo of dst
4227 :
4228 1 : msgIndx = halo%numLocalCopies
4229 :
4230 117 : do j=1,jeSrc-jbSrc+1
4231 233 : do i=1,nghost
4232 :
4233 116 : msgIndx = msgIndx + 1
4234 :
4235 116 : halo%srcLocalAddr(1,msgIndx) = ibSrc + i - 1
4236 116 : halo%srcLocalAddr(2,msgIndx) = jbSrc + j - 1
4237 116 : halo%srcLocalAddr(3,msgIndx) = srcLocalID
4238 :
4239 116 : halo%dstLocalAddr(1,msgIndx) = ieDst + i
4240 116 : halo%dstLocalAddr(2,msgIndx) = jbDst + j - 1
4241 232 : halo%dstLocalAddr(3,msgIndx) = dstLocalID
4242 :
4243 : end do
4244 : end do
4245 :
4246 1 : halo%numLocalCopies = msgIndx
4247 :
4248 : case ('north')
4249 :
4250 : !*** copy northern physical domain of src
4251 : !*** into southern halo of dst
4252 :
4253 0 : if (srcBlock > 0 .and. dstBlock > 0) then ! normal north boundary
4254 :
4255 0 : msgIndx = halo%numLocalCopies
4256 :
4257 0 : do j=1,nghost
4258 0 : do i=1,ieSrc-ibSrc+1
4259 :
4260 0 : msgIndx = msgIndx + 1
4261 :
4262 0 : halo%srcLocalAddr(1,msgIndx) = ibSrc + i - 1
4263 0 : halo%srcLocalAddr(2,msgIndx) = jeSrc - nghost + j
4264 0 : halo%srcLocalAddr(3,msgIndx) = srcLocalID
4265 :
4266 0 : halo%dstLocalAddr(1,msgIndx) = ibDst + i - 1
4267 0 : halo%dstLocalAddr(2,msgIndx) = j
4268 0 : halo%dstLocalAddr(3,msgIndx) = dstLocalID
4269 :
4270 : end do
4271 : end do
4272 :
4273 0 : halo%numLocalCopies = msgIndx
4274 :
4275 0 : else if (srcBlock > 0 .and. dstBlock < 0) then
4276 :
4277 : !*** tripole grid - copy info into tripole buffer
4278 : !*** copy physical domain of top halo+1 rows
4279 : !*** into global buffer at src location
4280 :
4281 : !*** perform an error check to make sure the
4282 : !*** block has enough points to perform a tripole
4283 : !*** update
4284 :
4285 0 : if (jeSrc - jbSrc + 1 < halo%tripoleRows) then
4286 0 : call abort_ice(subname//'ERROR: not enough points in block for tripole')
4287 0 : return
4288 : endif
4289 :
4290 0 : msgIndx = halo%numLocalCopies
4291 :
4292 0 : do j=1,halo%tripoleRows
4293 0 : do i=1,ieSrc-ibSrc+1
4294 :
4295 0 : msgIndx = msgIndx + 1
4296 :
4297 0 : halo%srcLocalAddr(1,msgIndx) = ibSrc + i - 1
4298 0 : halo%srcLocalAddr(2,msgIndx) = jeSrc-halo%tripoleRows+j
4299 0 : halo%srcLocalAddr(3,msgIndx) = srcLocalID
4300 :
4301 0 : halo%dstLocalAddr(1,msgIndx) = iGlobal(ibSrc + i - 1)
4302 0 : halo%dstLocalAddr(2,msgIndx) = j
4303 0 : halo%dstLocalAddr(3,msgIndx) = -dstLocalID
4304 :
4305 : end do
4306 : end do
4307 :
4308 0 : halo%numLocalCopies = msgIndx
4309 :
4310 0 : else if (srcBlock < 0 .and. dstBlock > 0) then
4311 :
4312 : !*** tripole grid - set up for copying out of
4313 : !*** tripole buffer into ghost cell domains
4314 : !*** include e-w ghost cells
4315 :
4316 0 : msgIndx = halo%numLocalCopies
4317 :
4318 0 : do j=1,halo%tripoleRows
4319 0 : do i=1,ieSrc+nghost
4320 :
4321 0 : msgIndx = msgIndx + 1
4322 :
4323 0 : halo%srcLocalAddr(1,msgIndx) = nxGlobal - iGlobal(i) + 1
4324 0 : halo%srcLocalAddr(2,msgIndx) = nghost + 3 - j
4325 0 : halo%srcLocalAddr(3,msgIndx) = -srcLocalID
4326 :
4327 0 : halo%dstLocalAddr(1,msgIndx) = i
4328 0 : if (j.gt.nghost+1) then
4329 0 : halo%dstLocalAddr(2,msgIndx) = -1 ! never used
4330 : else
4331 0 : halo%dstLocalAddr(2,msgIndx) = jeSrc + j - 1
4332 : endif
4333 0 : halo%dstLocalAddr(3,msgIndx) = dstLocalID
4334 :
4335 : end do
4336 : end do
4337 :
4338 0 : halo%numLocalCopies = msgIndx
4339 :
4340 : endif
4341 :
4342 : case ('south')
4343 :
4344 : !*** copy southern physical domain of src
4345 : !*** into northern halo of dst
4346 :
4347 0 : msgIndx = halo%numLocalCopies
4348 :
4349 0 : do j=1,nghost
4350 0 : do i=1,ieSrc-ibSrc+1
4351 :
4352 0 : msgIndx = msgIndx + 1
4353 :
4354 0 : halo%srcLocalAddr(1,msgIndx) = ibSrc + i - 1
4355 0 : halo%srcLocalAddr(2,msgIndx) = jbSrc + j - 1
4356 0 : halo%srcLocalAddr(3,msgIndx) = srcLocalID
4357 :
4358 0 : halo%dstLocalAddr(1,msgIndx) = ibDst + i - 1
4359 0 : halo%dstLocalAddr(2,msgIndx) = jeDst + j
4360 0 : halo%dstLocalAddr(3,msgIndx) = dstLocalID
4361 :
4362 : end do
4363 : end do
4364 :
4365 0 : halo%numLocalCopies = msgIndx
4366 :
4367 : case ('northeast')
4368 :
4369 : !*** normal northeast boundary - just copy NE corner
4370 : !*** of physical domain into SW halo of NE nbr block
4371 :
4372 0 : if (dstBlock > 0) then
4373 :
4374 0 : msgIndx = halo%numLocalCopies
4375 :
4376 0 : do j=1,nghost
4377 0 : do i=1,nghost
4378 :
4379 0 : msgIndx = msgIndx + 1
4380 :
4381 0 : halo%srcLocalAddr(1,msgIndx) = ieSrc - nghost + i
4382 0 : halo%srcLocalAddr(2,msgIndx) = jeSrc - nghost + j
4383 0 : halo%srcLocalAddr(3,msgIndx) = srcLocalID
4384 :
4385 0 : halo%dstLocalAddr(1,msgIndx) = i
4386 0 : halo%dstLocalAddr(2,msgIndx) = j
4387 0 : halo%dstLocalAddr(3,msgIndx) = dstLocalID
4388 :
4389 : end do
4390 : end do
4391 :
4392 0 : halo%numLocalCopies = msgIndx
4393 :
4394 : ! tcx,tcraig, 3/2023, this is not needed
4395 : ! else
4396 : !
4397 : ! !*** tripole grid - copy entire top halo+1
4398 : ! !*** rows into global buffer at src location
4399 : !
4400 : ! msgIndx = halo%numLocalCopies
4401 : !
4402 : ! do j=1,nghost+1
4403 : ! do i=1,ieSrc-ibSrc+1
4404 : !
4405 : ! msgIndx = msgIndx + 1
4406 : !
4407 : ! halo%srcLocalAddr(1,msgIndx) = ibSrc + i - 1
4408 : ! halo%srcLocalAddr(2,msgIndx) = jeSrc-1-nghost+j
4409 : ! halo%srcLocalAddr(3,msgIndx) = srcLocalID
4410 : !
4411 : ! halo%dstLocalAddr(1,msgIndx) = iGlobal(ibSrc + i - 1)
4412 : ! halo%dstLocalAddr(2,msgIndx) = j
4413 : ! halo%dstLocalAddr(3,msgIndx) = -dstLocalID
4414 : !
4415 : ! end do
4416 : ! end do
4417 : !
4418 : ! halo%numLocalCopies = msgIndx
4419 :
4420 : endif
4421 :
4422 : case ('northwest')
4423 :
4424 : !*** normal northwest boundary - just copy NW corner
4425 : !*** of physical domain into SE halo of NW nbr block
4426 :
4427 0 : if (dstBlock > 0) then
4428 :
4429 0 : msgIndx = halo%numLocalCopies
4430 :
4431 0 : do j=1,nghost
4432 0 : do i=1,nghost
4433 :
4434 0 : msgIndx = msgIndx + 1
4435 :
4436 0 : halo%srcLocalAddr(1,msgIndx) = ibSrc + i - 1
4437 0 : halo%srcLocalAddr(2,msgIndx) = jeSrc - nghost + j
4438 0 : halo%srcLocalAddr(3,msgIndx) = srcLocalID
4439 :
4440 0 : halo%dstLocalAddr(1,msgIndx) = ieDst + i
4441 0 : halo%dstLocalAddr(2,msgIndx) = j
4442 0 : halo%dstLocalAddr(3,msgIndx) = dstLocalID
4443 :
4444 : end do
4445 : end do
4446 :
4447 0 : halo%numLocalCopies = msgIndx
4448 :
4449 : ! tcx,tcraig, 3/2023, this is not needed
4450 : ! else
4451 : !
4452 : ! !*** tripole grid - copy entire top halo+1
4453 : ! !*** rows into global buffer at src location
4454 : !
4455 : ! msgIndx = halo%numLocalCopies
4456 : !
4457 : ! do j=1,nghost+1
4458 : ! do i=1,ieSrc-ibSrc+1
4459 : !
4460 : ! msgIndx = msgIndx + 1
4461 : !
4462 : ! halo%srcLocalAddr(1,msgIndx) = ibSrc + i - 1
4463 : ! halo%srcLocalAddr(2,msgIndx) = jeSrc-1-nghost+j
4464 : ! halo%srcLocalAddr(3,msgIndx) = srcLocalID
4465 : !
4466 : ! halo%dstLocalAddr(1,msgIndx) = iGlobal(ibSrc + i - 1)
4467 : ! halo%dstLocalAddr(2,msgIndx) = j
4468 : ! halo%dstLocalAddr(3,msgIndx) = -dstLocalID
4469 : !
4470 : ! end do
4471 : ! end do
4472 : !
4473 : ! halo%numLocalCopies = msgIndx
4474 :
4475 : endif
4476 :
4477 : case ('southeast')
4478 :
4479 : !*** copy southeastern corner of src physical domain
4480 : !*** into northwestern halo of dst
4481 :
4482 0 : msgIndx = halo%numLocalCopies
4483 :
4484 0 : do j=1,nghost
4485 0 : do i=1,nghost
4486 :
4487 0 : msgIndx = msgIndx + 1
4488 :
4489 0 : halo%srcLocalAddr(1,msgIndx) = ieSrc - nghost + i
4490 0 : halo%srcLocalAddr(2,msgIndx) = jbSrc + j - 1
4491 0 : halo%srcLocalAddr(3,msgIndx) = srcLocalID
4492 :
4493 0 : halo%dstLocalAddr(1,msgIndx) = i
4494 0 : halo%dstLocalAddr(2,msgIndx) = jeDst + j
4495 0 : halo%dstLocalAddr(3,msgIndx) = dstLocalID
4496 :
4497 : end do
4498 : end do
4499 :
4500 0 : halo%numLocalCopies = msgIndx
4501 :
4502 : case ('southwest')
4503 :
4504 : !*** copy southwestern corner of src physical domain
4505 : !*** into northeastern halo of dst
4506 :
4507 0 : msgIndx = halo%numLocalCopies
4508 :
4509 0 : do j=1,nghost
4510 0 : do i=1,nghost
4511 :
4512 0 : msgIndx = msgIndx + 1
4513 :
4514 0 : halo%srcLocalAddr(1,msgIndx) = ibSrc + i - 1
4515 0 : halo%srcLocalAddr(2,msgIndx) = jbSrc + j - 1
4516 0 : halo%srcLocalAddr(3,msgIndx) = srcLocalID
4517 :
4518 0 : halo%dstLocalAddr(1,msgIndx) = ieDst + i
4519 0 : halo%dstLocalAddr(2,msgIndx) = jeDst + j
4520 0 : halo%dstLocalAddr(3,msgIndx) = dstLocalID
4521 :
4522 : end do
4523 : end do
4524 :
4525 0 : halo%numLocalCopies = msgIndx
4526 :
4527 : case default
4528 :
4529 0 : call abort_ice(subname//'ERROR: unknown direction local copy')
4530 2 : return
4531 :
4532 : end select
4533 :
4534 : !-----------------------------------------------------------------------
4535 : !
4536 : ! if dest block is local and source block does not exist, create a
4537 : ! local copy to fill halo with a fill value
4538 : !
4539 : !-----------------------------------------------------------------------
4540 :
4541 0 : else if (srcProc == 0 .and. dstProc == my_task+1) then
4542 :
4543 : !*** compute addresses based on direction
4544 :
4545 0 : select case (direction)
4546 : case ('east')
4547 :
4548 : !*** copy easternmost physical domain of src
4549 : !*** into westernmost halo of dst
4550 :
4551 0 : msgIndx = halo%numLocalCopies
4552 :
4553 0 : do j=1,jeSrc-jbSrc+1
4554 0 : do i=1,nghost
4555 :
4556 0 : msgIndx = msgIndx + 1
4557 :
4558 0 : halo%srcLocalAddr(1,msgIndx) = 0
4559 0 : halo%srcLocalAddr(2,msgIndx) = 0
4560 0 : halo%srcLocalAddr(3,msgIndx) = 0
4561 :
4562 0 : halo%dstLocalAddr(1,msgIndx) = i
4563 0 : halo%dstLocalAddr(2,msgIndx) = jbDst + j - 1
4564 0 : halo%dstLocalAddr(3,msgIndx) = dstLocalID
4565 :
4566 : end do
4567 : end do
4568 :
4569 0 : halo%numLocalCopies = msgIndx
4570 :
4571 : case ('west')
4572 :
4573 : !*** copy westernmost physical domain of src
4574 : !*** into easternmost halo of dst
4575 :
4576 0 : msgIndx = halo%numLocalCopies
4577 :
4578 0 : do j=1,jeSrc-jbSrc+1
4579 0 : do i=1,nghost
4580 :
4581 0 : msgIndx = msgIndx + 1
4582 :
4583 0 : halo%srcLocalAddr(1,msgIndx) = 0
4584 0 : halo%srcLocalAddr(2,msgIndx) = 0
4585 0 : halo%srcLocalAddr(3,msgIndx) = 0
4586 :
4587 0 : halo%dstLocalAddr(1,msgIndx) = ieDst + i
4588 0 : halo%dstLocalAddr(2,msgIndx) = jbDst + j - 1
4589 0 : halo%dstLocalAddr(3,msgIndx) = dstLocalID
4590 :
4591 : end do
4592 : end do
4593 :
4594 0 : halo%numLocalCopies = msgIndx
4595 :
4596 : case ('north')
4597 :
4598 : !*** copy northern physical domain of src
4599 : !*** into southern halo of dst
4600 :
4601 0 : if (dstBlock > 0) then ! normal north boundary
4602 :
4603 0 : msgIndx = halo%numLocalCopies
4604 :
4605 0 : do j=1,nghost
4606 0 : do i=1,ieSrc-ibSrc+1
4607 :
4608 0 : msgIndx = msgIndx + 1
4609 :
4610 0 : halo%srcLocalAddr(1,msgIndx) = 0
4611 0 : halo%srcLocalAddr(2,msgIndx) = 0
4612 0 : halo%srcLocalAddr(3,msgIndx) = 0
4613 :
4614 0 : halo%dstLocalAddr(1,msgIndx) = ibDst + i - 1
4615 0 : halo%dstLocalAddr(2,msgIndx) = j
4616 0 : halo%dstLocalAddr(3,msgIndx) = dstLocalID
4617 :
4618 : end do
4619 : end do
4620 :
4621 0 : halo%numLocalCopies = msgIndx
4622 :
4623 : endif
4624 :
4625 : case ('south')
4626 :
4627 : !*** copy southern physical domain of src
4628 : !*** into northern halo of dst
4629 :
4630 0 : msgIndx = halo%numLocalCopies
4631 :
4632 0 : do j=1,nghost
4633 0 : do i=1,ieSrc-ibSrc+1
4634 :
4635 0 : msgIndx = msgIndx + 1
4636 :
4637 0 : halo%srcLocalAddr(1,msgIndx) = 0
4638 0 : halo%srcLocalAddr(2,msgIndx) = 0
4639 0 : halo%srcLocalAddr(3,msgIndx) = 0
4640 :
4641 0 : halo%dstLocalAddr(1,msgIndx) = ibDst + i - 1
4642 0 : halo%dstLocalAddr(2,msgIndx) = jeDst + j
4643 0 : halo%dstLocalAddr(3,msgIndx) = dstLocalID
4644 :
4645 : end do
4646 : end do
4647 :
4648 0 : halo%numLocalCopies = msgIndx
4649 :
4650 : case ('northeast')
4651 :
4652 : !*** normal northeast boundary - just copy NE corner
4653 : !*** of physical domain into SW halo of NE nbr block
4654 :
4655 0 : if (dstBlock > 0) then
4656 :
4657 0 : msgIndx = halo%numLocalCopies
4658 :
4659 0 : do j=1,nghost
4660 0 : do i=1,nghost
4661 :
4662 0 : msgIndx = msgIndx + 1
4663 :
4664 0 : halo%srcLocalAddr(1,msgIndx) = 0
4665 0 : halo%srcLocalAddr(2,msgIndx) = 0
4666 0 : halo%srcLocalAddr(3,msgIndx) = 0
4667 :
4668 0 : halo%dstLocalAddr(1,msgIndx) = i
4669 0 : halo%dstLocalAddr(2,msgIndx) = j
4670 0 : halo%dstLocalAddr(3,msgIndx) = dstLocalID
4671 :
4672 : end do
4673 : end do
4674 :
4675 0 : halo%numLocalCopies = msgIndx
4676 :
4677 : endif
4678 :
4679 : case ('northwest')
4680 :
4681 : !*** normal northwest boundary - just copy NW corner
4682 : !*** of physical domain into SE halo of NW nbr block
4683 :
4684 0 : if (dstBlock > 0) then
4685 :
4686 0 : msgIndx = halo%numLocalCopies
4687 :
4688 0 : do j=1,nghost
4689 0 : do i=1,nghost
4690 :
4691 0 : msgIndx = msgIndx + 1
4692 :
4693 0 : halo%srcLocalAddr(1,msgIndx) = 0
4694 0 : halo%srcLocalAddr(2,msgIndx) = 0
4695 0 : halo%srcLocalAddr(3,msgIndx) = 0
4696 :
4697 0 : halo%dstLocalAddr(1,msgIndx) = ieDst + i
4698 0 : halo%dstLocalAddr(2,msgIndx) = j
4699 0 : halo%dstLocalAddr(3,msgIndx) = dstLocalID
4700 :
4701 : end do
4702 : end do
4703 :
4704 0 : halo%numLocalCopies = msgIndx
4705 :
4706 : endif
4707 :
4708 : case ('southeast')
4709 :
4710 : !*** copy southeastern corner of src physical domain
4711 : !*** into northwestern halo of dst
4712 :
4713 0 : msgIndx = halo%numLocalCopies
4714 :
4715 0 : do j=1,nghost
4716 0 : do i=1,nghost
4717 :
4718 0 : msgIndx = msgIndx + 1
4719 :
4720 0 : halo%srcLocalAddr(1,msgIndx) = 0
4721 0 : halo%srcLocalAddr(2,msgIndx) = 0
4722 0 : halo%srcLocalAddr(3,msgIndx) = 0
4723 :
4724 0 : halo%dstLocalAddr(1,msgIndx) = i
4725 0 : halo%dstLocalAddr(2,msgIndx) = jeDst + j
4726 0 : halo%dstLocalAddr(3,msgIndx) = dstLocalID
4727 :
4728 : end do
4729 : end do
4730 :
4731 0 : halo%numLocalCopies = msgIndx
4732 :
4733 : case ('southwest')
4734 :
4735 : !*** copy southwestern corner of src physical domain
4736 : !*** into northeastern halo of dst
4737 :
4738 0 : msgIndx = halo%numLocalCopies
4739 :
4740 0 : do j=1,nghost
4741 0 : do i=1,nghost
4742 :
4743 0 : msgIndx = msgIndx + 1
4744 :
4745 0 : halo%srcLocalAddr(1,msgIndx) = 0
4746 0 : halo%srcLocalAddr(2,msgIndx) = 0
4747 0 : halo%srcLocalAddr(3,msgIndx) = 0
4748 :
4749 0 : halo%dstLocalAddr(1,msgIndx) = ieDst + i
4750 0 : halo%dstLocalAddr(2,msgIndx) = jeDst + j
4751 0 : halo%dstLocalAddr(3,msgIndx) = dstLocalID
4752 :
4753 : end do
4754 : end do
4755 :
4756 0 : halo%numLocalCopies = msgIndx
4757 :
4758 : case default
4759 :
4760 0 : call abort_ice(subname//'ERROR: unknown direction local copy')
4761 0 : return
4762 :
4763 : end select
4764 :
4765 : !-----------------------------------------------------------------------
4766 : !
4767 : ! if none of the cases above, no message info required for this
4768 : ! block pair
4769 : !
4770 : !-----------------------------------------------------------------------
4771 :
4772 : endif
4773 :
4774 : !-----------------------------------------------------------------------
4775 :
4776 8 : end subroutine ice_HaloMsgCreate
4777 :
4778 : !***********************************************************************
4779 :
4780 8 : subroutine ice_HaloExtrapolate2DR8(ARRAY,dist,ew_bndy_type,ns_bndy_type)
4781 :
4782 : ! This subroutine extrapolates ARRAY values into the first row or column
4783 : ! of ghost cells, and is intended for grid variables whose ghost cells
4784 : ! would otherwise be set using the default boundary conditions (Dirichlet
4785 : ! or Neumann).
4786 : ! Note: This routine will need to be modified for nghost > 1.
4787 : ! We assume padding occurs only on east and north edges.
4788 : !
4789 : ! This is the specific interface for double precision arrays
4790 : ! corresponding to the generic interface ice_HaloExtrapolate
4791 :
4792 : use ice_blocks, only: block, nblocks_x, nblocks_y, get_block
4793 : use ice_constants, only: c2
4794 : use ice_distribution, only: ice_distributionGetBlockID
4795 :
4796 : character (char_len) :: &
4797 : ew_bndy_type, &! type of domain bndy in each logical ! LCOV_EXCL_LINE
4798 : ns_bndy_type ! direction (ew is i, ns is j)
4799 :
4800 : type (distrb), intent(in) :: &
4801 : dist ! block distribution for array X
4802 :
4803 : real (dbl_kind), dimension(:,:,:), intent(inout) :: &
4804 : ARRAY ! array containing distributed field
4805 :
4806 : !-----------------------------------------------------------------------
4807 : !
4808 : ! local variables
4809 : !
4810 : !-----------------------------------------------------------------------
4811 :
4812 : integer (int_kind) :: &
4813 : i,j,iblk, &! dummy loop indices ! LCOV_EXCL_LINE
4814 : numBlocks, &! number of local blocks ! LCOV_EXCL_LINE
4815 : blockID, &! block location ! LCOV_EXCL_LINE
4816 : ibc ! ghost cell column or row
4817 :
4818 : type (block) :: &
4819 : this_block ! block info for current block
4820 :
4821 : character(len=*), parameter :: subname = '(ice_HaloExtrapolate2DR8)'
4822 :
4823 : !-----------------------------------------------------------------------
4824 : !
4825 : ! Linear extrapolation
4826 : !
4827 : !-----------------------------------------------------------------------
4828 :
4829 : call ice_distributionGet(dist, &
4830 8 : numLocalBlocks = numBlocks)
4831 :
4832 16 : do iblk = 1, numBlocks
4833 8 : call ice_distributionGetBlockID(dist, iblk, blockID)
4834 8 : this_block = get_block(blockID, blockID)
4835 :
4836 8 : if (this_block%iblock == 1) then ! west edge
4837 8 : if (trim(ew_bndy_type) /= 'cyclic') then
4838 0 : do j = 1, ny_block
4839 0 : ARRAY(1,j,iblk) = c2*ARRAY(2,j,iblk) - ARRAY(3,j,iblk)
4840 : enddo
4841 : endif
4842 : endif
4843 :
4844 8 : if (this_block%iblock == nblocks_x) then ! east edge
4845 8 : if (trim(ew_bndy_type) /= 'cyclic') then
4846 : ! locate ghost cell column (avoid padding)
4847 0 : ibc = nx_block
4848 0 : do i = nx_block, nghost + 1, -1
4849 0 : if (this_block%i_glob(i) == 0) ibc = ibc - 1
4850 : enddo
4851 0 : do j = 1, ny_block
4852 0 : ARRAY(ibc,j,iblk) = c2*ARRAY(ibc-1,j,iblk) - ARRAY(ibc-2,j,iblk)
4853 : enddo
4854 : endif
4855 : endif
4856 :
4857 8 : if (this_block%jblock == 1) then ! south edge
4858 8 : if (trim(ns_bndy_type) /= 'cyclic') then
4859 824 : do i = 1, nx_block
4860 824 : ARRAY(i,1,iblk) = c2*ARRAY(i,2,iblk) - ARRAY(i,3,iblk)
4861 : enddo
4862 : endif
4863 : endif
4864 :
4865 24 : if (this_block%jblock == nblocks_y) then ! north edge
4866 : if (trim(ns_bndy_type) /= 'cyclic' .and. &
4867 : trim(ns_bndy_type) /= 'tripole' .and. & ! LCOV_EXCL_LINE
4868 : trim(ns_bndy_type) /= 'tripoleT' ) then
4869 : ! locate ghost cell column (avoid padding)
4870 8 : ibc = ny_block
4871 944 : do j = ny_block, nghost + 1, -1
4872 944 : if (this_block%j_glob(j) == 0) ibc = ibc - 1
4873 : enddo
4874 824 : do i = 1, nx_block
4875 824 : ARRAY(i,ibc,iblk) = c2*ARRAY(i,ibc-1,iblk) - ARRAY(i,ibc-2,iblk)
4876 : enddo
4877 : endif
4878 : endif
4879 :
4880 : enddo ! iblk
4881 :
4882 : !-----------------------------------------------------------------------
4883 :
4884 8 : end subroutine ice_HaloExtrapolate2DR8
4885 :
4886 : !***********************************************************************
4887 :
4888 0 : subroutine ice_HaloDestroy(halo)
4889 :
4890 : ! This routine creates a halo type with info necessary for
4891 : ! performing a halo (ghost cell) update. This info is computed
4892 : ! based on the input block distribution.
4893 :
4894 : type (ice_halo) :: &
4895 : halo ! a new halo type with info for halo updates
4896 :
4897 : integer (int_kind) :: &
4898 : istat ! error or status flag for MPI,alloc
4899 :
4900 : character(len=*), parameter :: subname = '(ice_HaloDestroy)'
4901 :
4902 : !-----------------------------------------------------------------------
4903 :
4904 : deallocate(halo%srcLocalAddr, &
4905 : halo%dstLocalAddr, & ! LCOV_EXCL_LINE
4906 0 : halo%blockGlobalID, stat=istat)
4907 :
4908 0 : if (istat > 0) then
4909 0 : call abort_ice(subname,' ERROR: deallocating')
4910 0 : return
4911 : endif
4912 :
4913 : end subroutine ice_HaloDestroy
4914 :
4915 : !***********************************************************************
4916 :
4917 0 : subroutine primary_grid_lengths_global_ext( &
4918 0 : ARRAY_O, ARRAY_I, ew_boundary_type, ns_boundary_type)
4919 :
4920 : ! This subroutine adds ghost cells to global primary grid lengths array
4921 : ! ARRAY_I and outputs result to array ARRAY_O
4922 :
4923 : use ice_constants, only: c0
4924 : use ice_domain_size, only: nx_global, ny_global
4925 :
4926 : real (kind=dbl_kind), dimension(:,:), intent(in) :: &
4927 : ARRAY_I
4928 :
4929 : character (*), intent(in) :: &
4930 : ew_boundary_type, ns_boundary_type
4931 :
4932 : real (kind=dbl_kind), dimension(:,:), intent(out) :: &
4933 : ARRAY_O
4934 :
4935 : !-----------------------------------------------------------------------
4936 : !
4937 : ! local variables
4938 : !
4939 : !-----------------------------------------------------------------------
4940 :
4941 : integer (kind=int_kind) :: &
4942 : ii, io, ji, jo
4943 :
4944 : character(len=*), parameter :: &
4945 : subname = '(primary_grid_lengths_global_ext)'
4946 :
4947 : !-----------------------------------------------------------------------
4948 : !
4949 : ! add ghost cells to global primary grid lengths array
4950 : !
4951 : !-----------------------------------------------------------------------
4952 :
4953 0 : if (trim(ns_boundary_type) == 'tripole' .or. &
4954 : trim(ns_boundary_type) == 'tripoleT') then
4955 : call abort_ice(subname//' ERROR: '//ns_boundary_type &
4956 0 : //' boundary type not implemented for configuration')
4957 : endif
4958 :
4959 0 : do jo = 1,ny_global+2*nghost
4960 0 : ji = -nghost + jo
4961 :
4962 : !*** Southern ghost cells
4963 :
4964 0 : if (ji < 1) then
4965 0 : select case (trim(ns_boundary_type))
4966 : case ('cyclic')
4967 0 : ji = ji + ny_global
4968 : case ('open')
4969 0 : ji = nghost - jo + 1
4970 : case ('closed')
4971 0 : ji = 0
4972 : case default
4973 : call abort_ice( &
4974 0 : subname//' ERROR: unknown north-south boundary type')
4975 : end select
4976 : endif
4977 :
4978 : !*** Northern ghost cells
4979 :
4980 0 : if (ji > ny_global) then
4981 0 : select case (trim(ns_boundary_type))
4982 : case ('cyclic')
4983 0 : ji = ji - ny_global
4984 : case ('open')
4985 0 : ji = 2 * ny_global - ji + 1
4986 : case ('closed')
4987 0 : ji = 0
4988 : case default
4989 : call abort_ice( &
4990 0 : subname//' ERROR: unknown north-south boundary type')
4991 : end select
4992 : endif
4993 :
4994 0 : do io = 1,nx_global+2*nghost
4995 0 : ii = -nghost + io
4996 :
4997 : !*** Western ghost cells
4998 :
4999 0 : if (ii < 1) then
5000 0 : select case (trim(ew_boundary_type))
5001 : case ('cyclic')
5002 0 : ii = ii + nx_global
5003 : case ('open')
5004 0 : ii = nghost - io + 1
5005 : case ('closed')
5006 0 : ii = 0
5007 : case default
5008 : call abort_ice( &
5009 0 : subname//' ERROR: unknown east-west boundary type')
5010 : end select
5011 : endif
5012 :
5013 : !*** Eastern ghost cells
5014 :
5015 0 : if (ii > nx_global) then
5016 0 : select case (trim(ew_boundary_type))
5017 : case ('cyclic')
5018 0 : ii = ii - nx_global
5019 : case ('open')
5020 0 : ii = 2 * nx_global - ii + 1
5021 : case ('closed')
5022 0 : ii = 0
5023 : case default
5024 : call abort_ice( &
5025 0 : subname//' ERROR: unknown east-west boundary type')
5026 : end select
5027 : endif
5028 :
5029 0 : if (ii == 0 .or. ji == 0) then
5030 0 : ARRAY_O(io, jo) = c0
5031 : else
5032 0 : ARRAY_O(io, jo) = ARRAY_I(ii, ji)
5033 : endif
5034 :
5035 : enddo
5036 : enddo
5037 :
5038 : !-----------------------------------------------------------------------
5039 :
5040 0 : end subroutine primary_grid_lengths_global_ext
5041 :
5042 : !***********************************************************************
5043 :
5044 0 : end module ice_boundary
5045 :
5046 : !|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
|
