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) using MPI calls
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 : !
16 : !-----------------------------------------------------------------------
17 : !
18 : ! Some notes on tripole, A-H below are gridpoints at i = 1:nx_global
19 : ! where nx_global=8. The schematics below show the general layout of the center
20 : ! points on the tripole fold. More complex pictures are needed to show
21 : ! relative orientation and offsets of east, north, and northeast points
22 : ! across the fold. See also appendix E of the NEMO_manual,
23 : ! https://zenodo.org/record/6334656#.YiYirhPMLXQ. Note the NFtype=T
24 : ! is the tripole u-fold grid with T-grid=center, U-grid=east, V-grid=north,
25 : ! and F-grid=northeast points in CICE. NFtype=F is similar to tripoleT
26 : ! except for the treatment of the poles. The CICE implementation also
27 : ! averages all degenerate points, NEMO's strategy seems to be to copy
28 : ! data from one side of the tripole to the other for degenerate points.
29 : !
30 : ! tripole: u-fold, fold is on north edge of ny_global
31 : ! north and northeast points on the fold are degenerate and averaged
32 : ! A,H,D,and E are pole points
33 : !
34 : ! ny_global+2 H G F E D C B A @ny_global-1
35 : ! ny_global+1 H G F E D C B A @ny_global
36 : ! ny_global A B C D E F G H
37 : ! ny_global-1 A B C D E F G H
38 : !
39 : ! tripoleT: t-fold, fold is thru center of ny_global
40 : ! center and east points at ny_global are degenerate and averaged
41 : ! north and northeast point at ny_global are not prognostic, they are halos
42 : ! A and E are pole points
43 : !
44 : ! ny_global+2 H G F E D C B A @ny_global-2
45 : ! ny_global+1 H G F E D C B A @ny_global-1
46 : ! ny_global A BH CG DF E FD GC HB A
47 : ! ny_global-1 A B C D E F G H
48 : ! ny_global-2 A B C D E F G H
49 : !
50 : !-----------------------------------------------------------------------
51 :
52 :
53 : use mpi ! MPI Fortran module
54 : use ice_kinds_mod
55 : use ice_communicate, only: my_task, mpiR4, mpiR8, mpitagHalo
56 : use ice_constants, only: field_type_scalar, &
57 : field_type_vector, field_type_angle, & ! LCOV_EXCL_LINE
58 : field_type_unknown, field_type_noupdate, & ! LCOV_EXCL_LINE
59 : field_loc_center, field_loc_NEcorner, & ! LCOV_EXCL_LINE
60 : field_loc_Nface, field_loc_Eface, & ! LCOV_EXCL_LINE
61 : field_loc_unknown, field_loc_noupdate
62 : use ice_global_reductions, only: global_maxval
63 : use ice_exit, only: abort_ice
64 : use icepack_intfc, only: icepack_warnings_flush, icepack_warnings_aborted
65 :
66 : use ice_blocks, only: nx_block, ny_block, nghost, &
67 : nblocks_tot, ice_blocksNorth, & ! LCOV_EXCL_LINE
68 : ice_blocksSouth, ice_blocksEast, ice_blocksWest, & ! LCOV_EXCL_LINE
69 : ice_blocksEast2, ice_blocksWest2, & ! LCOV_EXCL_LINE
70 : ice_blocksNorthEast, ice_blocksNorthWest, & ! LCOV_EXCL_LINE
71 : ice_blocksEastNorthEast, ice_blocksWestNorthWest, & ! LCOV_EXCL_LINE
72 : ice_blocksSouthEast, ice_blocksSouthWest, & ! LCOV_EXCL_LINE
73 : ice_blocksGetNbrID, get_block_parameter
74 : use ice_distribution, only: distrb, &
75 : ice_distributionGetBlockLoc, ice_distributionGet
76 :
77 : implicit none
78 : private
79 :
80 : type, public :: ice_halo
81 : integer (int_kind) :: &
82 : communicator, &! communicator to use for update messages ! LCOV_EXCL_LINE
83 : numLocalBlocks, &! number of local blocks, needed for halo fill ! LCOV_EXCL_LINE
84 : numMsgSend, &! number of messages to send halo update ! LCOV_EXCL_LINE
85 : numMsgRecv, &! number of messages to recv halo update ! LCOV_EXCL_LINE
86 : numLocalCopies, &! num local copies for halo update ! LCOV_EXCL_LINE
87 : tripoleRows ! number of rows in tripole buffer
88 :
89 : logical (log_kind) :: &
90 : tripoleTFlag ! NS boundary is a tripole T-fold
91 :
92 : integer (int_kind), dimension(:), pointer :: &
93 : blockGlobalID, &! list of local block global IDs, needed for halo fill ! LCOV_EXCL_LINE
94 : recvTask, &! task from which to recv each msg ! LCOV_EXCL_LINE
95 : sendTask, &! task to which to send each msg ! LCOV_EXCL_LINE
96 : sizeSend, &! size of each sent message ! LCOV_EXCL_LINE
97 : sizeRecv, &! size of each recvd message ! LCOV_EXCL_LINE
98 : tripSend, &! send msg tripole flag, 0=non-zipper block ! LCOV_EXCL_LINE
99 : tripRecv ! recv msg tripole flag, for masked halos
100 :
101 : integer (int_kind), dimension(:,:), pointer :: &
102 : srcLocalAddr, &! src addresses for each local copy ! LCOV_EXCL_LINE
103 : dstLocalAddr ! dst addresses for each local copy
104 :
105 : integer (int_kind), dimension(:,:,:), pointer :: &
106 : sendAddr, &! src addresses for each sent message ! LCOV_EXCL_LINE
107 : recvAddr ! dst addresses for each recvd message
108 :
109 : end type
110 :
111 : public :: ice_HaloCreate, &
112 : ice_HaloMask, & ! LCOV_EXCL_LINE
113 : ice_HaloUpdate, & ! LCOV_EXCL_LINE
114 : ice_HaloUpdate_stress, & ! LCOV_EXCL_LINE
115 : ice_HaloExtrapolate, & ! LCOV_EXCL_LINE
116 : ice_HaloDestroy, & ! LCOV_EXCL_LINE
117 : primary_grid_lengths_global_ext
118 :
119 : interface ice_HaloUpdate ! generic interface
120 : module procedure ice_HaloUpdate2DR8, &
121 : ice_HaloUpdate2DR4, & ! LCOV_EXCL_LINE
122 : ice_HaloUpdate2DI4, & ! LCOV_EXCL_LINE
123 : ice_HaloUpdate2DL1, & ! LCOV_EXCL_LINE
124 : ice_HaloUpdate3DR8, & ! LCOV_EXCL_LINE
125 : ice_HaloUpdate3DR4, & ! LCOV_EXCL_LINE
126 : ice_HaloUpdate3DI4, & ! LCOV_EXCL_LINE
127 : ice_HaloUpdate4DR8, & ! LCOV_EXCL_LINE
128 : ice_HaloUpdate4DR4, & ! LCOV_EXCL_LINE
129 : ice_HaloUpdate4DI4
130 : end interface
131 :
132 : interface ice_HaloExtrapolate ! generic interface
133 : module procedure ice_HaloExtrapolate2DR8 !, &
134 : ! ice_HaloExtrapolate2DR4, & ! not yet ! LCOV_EXCL_LINE
135 : ! ice_HaloExtrapolate2DI4, & ! implemented ! LCOV_EXCL_LINE
136 : end interface
137 :
138 : !-----------------------------------------------------------------------
139 : !
140 : ! to prevent frequent allocate-deallocate for 2d halo updates, create
141 : ! a static 2d buffer to be allocated once at creation. if future
142 : ! creation needs larger buffer, resize during the creation.
143 : !
144 : !-----------------------------------------------------------------------
145 :
146 : integer (int_kind), public :: &
147 : bufSizeSend, &! max buffer size for send messages ! LCOV_EXCL_LINE
148 : bufSizeRecv ! max buffer size for recv messages
149 :
150 : integer (int_kind), dimension(:,:), allocatable, public :: &
151 : bufSendI4, &! buffer for use to send in 2D i4 halo updates ! LCOV_EXCL_LINE
152 : bufRecvI4 ! buffer for use to recv in 2D i4 halo updates
153 :
154 : real (real_kind), dimension(:,:), allocatable, public :: &
155 : bufSendR4, &! buffer for use to send in 2D r4 halo updates ! LCOV_EXCL_LINE
156 : bufRecvR4 ! buffer for use to recv in 2D r4 halo updates
157 :
158 : real (dbl_kind), dimension(:,:), allocatable, public :: &
159 : bufSendR8, &! buffer for use to send in 2D r8 halo updates ! LCOV_EXCL_LINE
160 : bufRecvR8 ! buffer for use to recv in 2D r8 halo updates
161 :
162 : !-----------------------------------------------------------------------
163 : !
164 : ! global buffers for tripole boundary
165 : !
166 : !-----------------------------------------------------------------------
167 :
168 : integer (int_kind), dimension(:,:), allocatable, public :: &
169 : bufTripoleI4
170 :
171 : real (real_kind), dimension(:,:), allocatable, public :: &
172 : bufTripoleR4
173 :
174 : real (dbl_kind), dimension(:,:), allocatable, public :: &
175 : bufTripoleR8
176 :
177 : !***********************************************************************
178 :
179 : contains
180 :
181 : !***********************************************************************
182 :
183 36 : function ice_HaloCreate(dist, nsBoundaryType, ewBoundaryType, &
184 : nxGlobal) result(halo)
185 :
186 : ! This routine creates a halo type with info necessary for
187 : ! performing a halo (ghost cell) update. This info is computed
188 : ! based on the input block distribution.
189 :
190 : type (distrb), intent(in) :: &
191 : dist ! distribution of blocks across procs
192 :
193 : character (*), intent(in) :: &
194 : nsBoundaryType, &! type of boundary to use in logical ns dir ! LCOV_EXCL_LINE
195 : ewBoundaryType ! type of boundary to use in logical ew dir
196 :
197 : integer (int_kind), intent(in) :: &
198 : nxGlobal ! global grid extent for tripole grids
199 :
200 : type (ice_halo) :: &
201 : halo ! a new halo type with info for halo updates
202 :
203 : !-----------------------------------------------------------------------
204 : !
205 : ! local variables
206 : !
207 : !-----------------------------------------------------------------------
208 :
209 : integer (int_kind) :: &
210 : istat, &! allocate status flag ! LCOV_EXCL_LINE
211 : numProcs, &! num of processors involved ! LCOV_EXCL_LINE
212 : communicator, &! communicator for message passing ! LCOV_EXCL_LINE
213 : iblock, &! block counter ! LCOV_EXCL_LINE
214 : eastBlock, westBlock, &! block id east, west neighbors ! LCOV_EXCL_LINE
215 : northBlock, southBlock, &! block id north, south neighbors ! LCOV_EXCL_LINE
216 : neBlock, nwBlock, &! block id northeast, northwest nbrs ! LCOV_EXCL_LINE
217 : seBlock, swBlock, &! block id southeast, southwest nbrs ! LCOV_EXCL_LINE
218 : srcProc, dstProc, &! source, dest processor locations ! LCOV_EXCL_LINE
219 : srcLocalID, dstLocalID, &! local block index of src,dst blocks ! LCOV_EXCL_LINE
220 : maxTmp, &! temp for global maxval ! LCOV_EXCL_LINE
221 : blockSizeX, &! size of default physical domain in X ! LCOV_EXCL_LINE
222 : blockSizeY, &! size of default physical domain in Y ! LCOV_EXCL_LINE
223 : maxSizeSend, maxSizeRecv, &! max buffer sizes ! LCOV_EXCL_LINE
224 : numMsgSend, numMsgRecv, &! number of messages for this halo ! LCOV_EXCL_LINE
225 : eastMsgSize, westMsgSize, &! nominal sizes for e-w msgs ! LCOV_EXCL_LINE
226 : northMsgSize, southMsgSize, &! nominal sizes for n-s msgs ! LCOV_EXCL_LINE
227 : tripoleMsgSize, &! size for tripole messages ! LCOV_EXCL_LINE
228 : tripoleMsgSizeOut, &! size for tripole messages ! LCOV_EXCL_LINE
229 : tripoleRows, &! number of rows in tripole buffer ! LCOV_EXCL_LINE
230 : cornerMsgSize, msgSize ! nominal size for corner msg
231 :
232 : integer (int_kind), dimension(:), allocatable :: &
233 36 : sendCount, recvCount ! count number of words to each proc
234 :
235 : logical (log_kind) :: &
236 : resize, &! flag for resizing buffers ! LCOV_EXCL_LINE
237 : tripoleBlock, &! flag for identifying north tripole blocks ! LCOV_EXCL_LINE
238 : tripoleTFlag ! flag for processing tripole buffer as T-fold
239 :
240 : character(len=*), parameter :: subname = '(ice_HaloCreate)'
241 :
242 : !-----------------------------------------------------------------------
243 : !
244 : ! Initialize some useful variables and return if this task not
245 : ! in the current distribution.
246 : !
247 : !-----------------------------------------------------------------------
248 :
249 : call ice_distributionGet(dist, &
250 : nprocs = numProcs, & ! LCOV_EXCL_LINE
251 36 : communicator = communicator)
252 :
253 36 : if (my_task >= numProcs) return
254 :
255 36 : halo%communicator = communicator
256 :
257 36 : blockSizeX = nx_block - 2*nghost
258 36 : blockSizeY = ny_block - 2*nghost
259 36 : eastMsgSize = nghost*blockSizeY
260 36 : westMsgSize = nghost*blockSizeY
261 36 : southMsgSize = nghost*blockSizeX
262 36 : northMsgSize = nghost*blockSizeX
263 36 : cornerMsgSize = nghost*nghost
264 36 : tripoleRows = nghost+1
265 :
266 : !*** store some block info to fill haloes properly
267 36 : call ice_distributionGet(dist, numLocalBlocks=halo%numLocalBlocks)
268 36 : allocate(halo%blockGlobalID(halo%numLocalBlocks))
269 36 : if (halo%numLocalBlocks > 0) then
270 36 : call ice_distributionGet(dist, blockGlobalID=halo%blockGlobalID)
271 : endif
272 :
273 36 : if (nsBoundaryType == 'tripole' .or. nsBoundaryType == 'tripoleT') then
274 0 : tripoleTFlag = (nsBoundaryType == 'tripoleT')
275 0 : if (tripoleTflag) tripoleRows = tripoleRows+1
276 :
277 : !*** allocate tripole message buffers if not already done
278 :
279 0 : if (.not. allocated(bufTripoleR8)) then
280 : allocate (bufTripoleI4(nxGlobal, tripoleRows), &
281 : bufTripoleR4(nxGlobal, tripoleRows), & ! LCOV_EXCL_LINE
282 : bufTripoleR8(nxGlobal, tripoleRows), & ! LCOV_EXCL_LINE
283 0 : stat=istat)
284 :
285 0 : if (istat > 0) then
286 0 : call abort_ice(subname//'ERROR: allocating tripole buffers')
287 0 : return
288 : endif
289 : endif
290 :
291 : else
292 36 : tripoleTFlag = .false.
293 : endif
294 36 : halo%tripoleTFlag = tripoleTFlag
295 36 : halo%tripoleRows = tripoleRows
296 36 : tripoleMsgSize = tripoleRows*blockSizeX
297 36 : tripoleMsgSizeOut = tripoleRows*nx_block
298 :
299 : !-----------------------------------------------------------------------
300 : !
301 : ! Count the number of messages to send/recv from each processor
302 : ! and number of words in each message. These quantities are
303 : ! necessary for allocating future arrays.
304 : !
305 : !-----------------------------------------------------------------------
306 :
307 36 : allocate (sendCount(numProcs), recvCount(numProcs), stat=istat)
308 :
309 36 : if (istat > 0) then
310 0 : call abort_ice(subname//'ERROR: allocating count arrays')
311 0 : return
312 : endif
313 :
314 276 : sendCount = 0
315 276 : recvCount = 0
316 :
317 1124 : msgCountLoop: do iblock=1,nblocks_tot
318 :
319 : call ice_distributionGetBlockLoc(dist, iblock, srcProc, &
320 1088 : srcLocalID)
321 :
322 : !*** find north neighbor block and add to message count
323 : !*** also set tripole block flag for later special cases
324 :
325 : northBlock = ice_blocksGetNbrID(iblock, ice_blocksNorth, &
326 1088 : ewBoundaryType, nsBoundaryType)
327 1088 : if (northBlock > 0) then
328 816 : tripoleBlock = .false.
329 816 : msgSize = northMsgSize
330 : call ice_distributionGetBlockLoc(dist, northBlock, dstProc, &
331 816 : dstLocalID)
332 272 : else if (northBlock < 0) then ! tripole north row, count block
333 0 : tripoleBlock = .true.
334 0 : msgSize = tripoleMsgSize
335 : call ice_distributionGetBlockLoc(dist, abs(northBlock), &
336 0 : dstProc, dstLocalID)
337 : else
338 272 : tripoleBlock = .false.
339 272 : msgSize = northMsgSize
340 272 : dstProc = 0
341 272 : dstLocalID = 0
342 : endif
343 :
344 : call ice_HaloIncrementMsgCount(sendCount, recvCount, &
345 1088 : srcProc, dstProc, msgSize)
346 :
347 : !*** if a tripole boundary block, also create a local
348 : !*** message into and out of tripole buffer
349 :
350 1088 : if (tripoleBlock) then
351 : !*** copy out of tripole buffer - includes halo
352 : call ice_HaloIncrementMsgCount(sendCount, recvCount, &
353 : srcProc, srcProc, & ! LCOV_EXCL_LINE
354 0 : tripoleMsgSizeOut)
355 :
356 : !*** copy in only required if dstProc not same as srcProc
357 0 : if (dstProc /= srcProc) then
358 : call ice_HaloIncrementMsgCount(sendCount, recvCount, &
359 : srcProc, srcProc, & ! LCOV_EXCL_LINE
360 0 : msgSize)
361 : endif
362 : endif
363 :
364 : !*** find south neighbor block and add to message count
365 :
366 : southBlock = ice_blocksGetNbrID(iblock, ice_blocksSouth, &
367 1088 : ewBoundaryType, nsBoundaryType)
368 :
369 1088 : if (southBlock > 0) then
370 : call ice_distributionGetBlockLoc(dist, southBlock, dstProc, &
371 816 : dstLocalID)
372 : else
373 272 : dstProc = 0
374 272 : dstLocalID = 0
375 : endif
376 :
377 : call ice_HaloIncrementMsgCount(sendCount, recvCount, &
378 1088 : srcProc, dstProc, southMsgSize)
379 :
380 : !*** find east neighbor block and add to message count
381 :
382 : eastBlock = ice_blocksGetNbrID(iblock, ice_blocksEast, &
383 1088 : ewBoundaryType, nsBoundaryType)
384 :
385 1088 : if (eastBlock > 0) then
386 : call ice_distributionGetBlockLoc(dist, eastBlock, dstProc, &
387 1088 : dstLocalID)
388 : else
389 0 : dstProc = 0
390 0 : dstLocalID = 0
391 : endif
392 :
393 : call ice_HaloIncrementMsgCount(sendCount, recvCount, &
394 1088 : srcProc, dstProc, eastMsgSize)
395 :
396 : !*** if a tripole boundary block, non-local east neighbor
397 : !*** needs a chunk of the north boundary, so add a message
398 : !*** for that
399 :
400 1088 : if (tripoleBlock .and. dstProc /= srcProc) then
401 : call ice_HaloIncrementMsgCount(sendCount, recvCount, &
402 0 : srcProc, dstProc, tripoleMsgSize)
403 : endif
404 :
405 : !*** find west neighbor block and add to message count
406 :
407 : westBlock = ice_blocksGetNbrID(iblock, ice_blocksWest, &
408 1088 : ewBoundaryType, nsBoundaryType)
409 :
410 1088 : if (westBlock > 0) then
411 : call ice_distributionGetBlockLoc(dist, westBlock, dstProc, &
412 1088 : dstLocalID)
413 : else
414 0 : dstProc = 0
415 0 : dstLocalID = 0
416 : endif
417 :
418 : call ice_HaloIncrementMsgCount(sendCount, recvCount, &
419 1088 : srcProc, dstProc, westMsgSize)
420 :
421 : !*** if a tripole boundary block, non-local west neighbor
422 : !*** needs a chunk of the north boundary, so add a message
423 : !*** for that
424 :
425 1088 : if (tripoleBlock .and. dstProc /= srcProc) then
426 : call ice_HaloIncrementMsgCount(sendCount, recvCount, &
427 0 : srcProc, dstProc, tripoleMsgSize)
428 : endif
429 :
430 : !*** find northeast neighbor block and add to message count
431 :
432 : neBlock = ice_blocksGetNbrID(iblock, ice_blocksNorthEast, &
433 1088 : ewBoundaryType, nsBoundaryType)
434 :
435 1088 : if (neBlock > 0) then
436 816 : msgSize = cornerMsgSize ! normal corner message
437 :
438 : call ice_distributionGetBlockLoc(dist, neBlock, dstProc, &
439 816 : dstLocalID)
440 :
441 272 : else if (neBlock < 0) then ! tripole north row
442 0 : msgSize = tripoleMsgSize ! tripole needs whole top row of block
443 :
444 : call ice_distributionGetBlockLoc(dist, abs(neBlock), dstProc, &
445 0 : dstLocalID)
446 : else
447 272 : dstProc = 0
448 272 : dstLocalID = 0
449 : endif
450 :
451 : call ice_HaloIncrementMsgCount(sendCount, recvCount, &
452 1088 : srcProc, dstProc, msgSize)
453 :
454 : !*** find northwest neighbor block and add to message count
455 :
456 : nwBlock = ice_blocksGetNbrID(iblock, ice_blocksNorthWest, &
457 1088 : ewBoundaryType, nsBoundaryType)
458 :
459 1088 : if (nwBlock > 0) then
460 816 : msgSize = cornerMsgSize ! normal NE corner update
461 :
462 : call ice_distributionGetBlockLoc(dist, nwBlock, dstProc, &
463 816 : dstLocalID)
464 :
465 272 : else if (nwBlock < 0) then ! tripole north row, count block
466 0 : msgSize = tripoleMsgSize ! tripole NE corner update - entire row needed
467 :
468 : call ice_distributionGetBlockLoc(dist, abs(nwBlock), dstProc, &
469 0 : dstLocalID)
470 :
471 : else
472 272 : dstProc = 0
473 272 : dstLocalID = 0
474 : endif
475 :
476 : call ice_HaloIncrementMsgCount(sendCount, recvCount, &
477 1088 : srcProc, dstProc, msgSize)
478 :
479 : !*** find southeast neighbor block and add to message count
480 :
481 : seBlock = ice_blocksGetNbrID(iblock, ice_blocksSouthEast, &
482 1088 : ewBoundaryType, nsBoundaryType)
483 :
484 1088 : if (seBlock > 0) then
485 : call ice_distributionGetBlockLoc(dist, seBlock, dstProc, &
486 816 : dstLocalID)
487 : else
488 272 : dstProc = 0
489 272 : dstLocalID = 0
490 : endif
491 :
492 : call ice_HaloIncrementMsgCount(sendCount, recvCount, &
493 1088 : srcProc, dstProc, cornerMsgSize)
494 :
495 : !*** find southwest neighbor block and add to message count
496 :
497 : swBlock = ice_blocksGetNbrID(iblock, ice_blocksSouthWest, &
498 1088 : ewBoundaryType, nsBoundaryType)
499 :
500 1088 : if (swBlock > 0) then
501 : call ice_distributionGetBlockLoc(dist, swBlock, dstProc, &
502 816 : dstLocalID)
503 : else
504 272 : dstProc = 0
505 272 : dstLocalID = 0
506 : endif
507 :
508 : call ice_HaloIncrementMsgCount(sendCount, recvCount, &
509 1088 : srcProc, dstProc, cornerMsgSize)
510 :
511 : !*** for tripole grids with padded domain, padding will
512 : !*** prevent tripole buffer from getting all the info
513 : !*** it needs - must extend footprint at top boundary
514 :
515 1088 : if (tripoleBlock .and. & !tripole
516 1124 : mod(nxGlobal,blockSizeX) /= 0) then !padding
517 :
518 : !*** find east2 neighbor block and add to message count
519 :
520 : eastBlock = ice_blocksGetNbrID(iBlock, ice_blocksEast2, &
521 0 : ewBoundaryType, nsBoundaryType)
522 :
523 0 : if (eastBlock > 0) then
524 : call ice_distributionGetBlockLoc(dist, eastBlock, dstProc, &
525 0 : dstLocalID)
526 : else
527 0 : dstProc = 0
528 0 : dstLocalID = 0
529 : endif
530 :
531 0 : if (dstProc /= srcProc) then
532 : call ice_HaloIncrementMsgCount(sendCount, recvCount, &
533 0 : srcProc, dstProc, tripoleMsgSize)
534 : endif
535 :
536 : !*** find EastNorthEast neighbor block and add to message count
537 :
538 : neBlock = ice_blocksGetNbrID(iBlock, ice_blocksEastNorthEast, &
539 0 : ewBoundaryType, nsBoundaryType)
540 :
541 0 : if (neBlock < 0) then ! tripole north row
542 0 : msgSize = tripoleMsgSize ! tripole needs whole top row of block
543 :
544 : call ice_distributionGetBlockLoc(dist, abs(neBlock), dstProc, &
545 0 : dstLocalID)
546 : else
547 0 : dstProc = 0
548 0 : dstLocalID = 0
549 : endif
550 :
551 0 : if (dstProc /= srcProc) then
552 : call ice_HaloIncrementMsgCount(sendCount, recvCount, &
553 0 : srcProc, dstProc, msgSize)
554 : endif
555 :
556 : !*** find west2 neighbor block and add to message count
557 :
558 : westBlock = ice_blocksGetNbrID(iBlock, ice_blocksWest2, &
559 0 : ewBoundaryType, nsBoundaryType)
560 :
561 0 : if (westBlock > 0) then
562 : call ice_distributionGetBlockLoc(dist, westBlock, dstProc, &
563 0 : dstLocalID)
564 : else
565 0 : dstProc = 0
566 0 : dstLocalID = 0
567 : endif
568 :
569 0 : if (dstProc /= srcProc) then
570 : call ice_HaloIncrementMsgCount(sendCount, recvCount, &
571 0 : srcProc, dstProc, tripoleMsgSize)
572 : endif
573 :
574 : !*** find WestNorthWest neighbor block and add to message count
575 :
576 : nwBlock = ice_blocksGetNbrID(iBlock, ice_blocksWestNorthWest, &
577 0 : ewBoundaryType, nsBoundaryType)
578 :
579 0 : if (nwBlock < 0) then ! tripole north row
580 0 : msgSize = tripoleMsgSize ! tripole needs whole top row of block
581 :
582 : call ice_distributionGetBlockLoc(dist, abs(nwBlock), dstProc, &
583 0 : dstLocalID)
584 : else
585 0 : dstProc = 0
586 0 : dstLocalID = 0
587 : endif
588 :
589 0 : if (dstProc /= srcProc) then
590 : call ice_HaloIncrementMsgCount(sendCount, recvCount, &
591 0 : srcProc, dstProc, msgSize)
592 : endif
593 :
594 : endif
595 :
596 : end do msgCountLoop
597 :
598 : !-----------------------------------------------------------------------
599 : !
600 : ! if messages are received from the same processor, the message is
601 : ! actually a local copy - count them and reset to zero
602 : !
603 : !-----------------------------------------------------------------------
604 :
605 36 : halo%numLocalCopies = recvCount(my_task+1)
606 :
607 36 : sendCount(my_task+1) = 0
608 36 : recvCount(my_task+1) = 0
609 :
610 : !-----------------------------------------------------------------------
611 : !
612 : ! now count the number of actual messages to be sent and received
613 : !
614 : !-----------------------------------------------------------------------
615 :
616 276 : numMsgSend = count(sendCount /= 0)
617 276 : numMsgRecv = count(recvCount /= 0)
618 36 : halo%numMsgSend = numMsgSend
619 36 : halo%numMsgRecv = numMsgRecv
620 :
621 : !-----------------------------------------------------------------------
622 : !
623 : ! allocate buffers for 2-d halo updates to save time later
624 : ! if the buffers are already allocated by previous create call,
625 : ! check to see if they need to be re-sized
626 : !
627 : !-----------------------------------------------------------------------
628 :
629 276 : maxTmp = maxval(sendCount)
630 36 : maxSizeSend = global_maxval(maxTmp, dist)
631 276 : maxTmp = maxval(recvCount)
632 36 : maxSizeRecv = global_maxval(maxTmp, dist)
633 :
634 36 : if (.not. allocated(bufSendR8)) then
635 :
636 36 : bufSizeSend = maxSizeSend
637 36 : bufSizeRecv = maxSizeRecv
638 :
639 : allocate(bufSendI4(bufSizeSend, numMsgSend), &
640 : bufRecvI4(bufSizeRecv, numMsgRecv), & ! LCOV_EXCL_LINE
641 : bufSendR4(bufSizeSend, numMsgSend), & ! LCOV_EXCL_LINE
642 : bufRecvR4(bufSizeRecv, numMsgRecv), & ! LCOV_EXCL_LINE
643 : bufSendR8(bufSizeSend, numMsgSend), & ! LCOV_EXCL_LINE
644 36 : bufRecvR8(bufSizeRecv, numMsgRecv), stat=istat)
645 :
646 36 : if (istat > 0) then
647 0 : call abort_ice(subname//'ERROR: allocating 2d buffers')
648 0 : return
649 : endif
650 :
651 : else
652 :
653 0 : resize = .false.
654 :
655 0 : if (maxSizeSend > bufSizeSend) then
656 0 : resize = .true.
657 0 : bufSizeSend = maxSizeSend
658 : endif
659 0 : if (maxSizeRecv > bufSizeRecv) then
660 0 : resize = .true.
661 0 : bufSizeRecv = maxSizeRecv
662 : endif
663 :
664 0 : if (numMsgSend > size(bufSendR8,dim=2)) resize = .true.
665 0 : if (numMsgRecv > size(bufRecvR8,dim=2)) resize = .true.
666 :
667 0 : if (resize) then
668 : deallocate(bufSendI4, bufRecvI4, bufSendR4, &
669 0 : bufRecvR4, bufSendR8, bufRecvR8, stat=istat)
670 :
671 0 : if (istat > 0) then
672 0 : call abort_ice(subname//'ERROR: deallocating 2d buffers')
673 0 : return
674 : endif
675 :
676 : allocate(bufSendI4(bufSizeSend, numMsgSend), &
677 : bufRecvI4(bufSizeRecv, numMsgRecv), & ! LCOV_EXCL_LINE
678 : bufSendR4(bufSizeSend, numMsgSend), & ! LCOV_EXCL_LINE
679 : bufRecvR4(bufSizeRecv, numMsgRecv), & ! LCOV_EXCL_LINE
680 : bufSendR8(bufSizeSend, numMsgSend), & ! LCOV_EXCL_LINE
681 0 : bufRecvR8(bufSizeRecv, numMsgRecv), stat=istat)
682 :
683 0 : if (istat > 0) then
684 0 : call abort_ice(subname//'ERROR: reallocating 2d buffers')
685 0 : return
686 : endif
687 :
688 : endif
689 :
690 : endif
691 :
692 : !-----------------------------------------------------------------------
693 : !
694 : ! allocate arrays for message information and initialize
695 : !
696 : !-----------------------------------------------------------------------
697 :
698 : allocate(halo%sendTask(numMsgSend), &
699 : halo%recvTask(numMsgRecv), & ! LCOV_EXCL_LINE
700 : halo%sizeSend(numMsgSend), & ! LCOV_EXCL_LINE
701 : halo%sizeRecv(numMsgRecv), & ! LCOV_EXCL_LINE
702 : halo%tripSend(numMsgSend), & ! LCOV_EXCL_LINE
703 : halo%tripRecv(numMsgRecv), & ! LCOV_EXCL_LINE
704 : halo%sendAddr(3,bufSizeSend,numMsgSend), & ! LCOV_EXCL_LINE
705 : halo%recvAddr(3,bufSizeRecv,numMsgRecv), & ! LCOV_EXCL_LINE
706 : halo%srcLocalAddr(3,halo%numLocalCopies), & ! LCOV_EXCL_LINE
707 : halo%dstLocalAddr(3,halo%numLocalCopies), & ! LCOV_EXCL_LINE
708 36 : stat = istat)
709 :
710 36 : if (istat > 0) then
711 0 : call abort_ice(subname//'ERROR: allocating halo message info arrays')
712 0 : return
713 : endif
714 :
715 208 : halo%sendTask = 0
716 208 : halo%recvTask = 0
717 208 : halo%sizeSend = 0
718 208 : halo%sizeRecv = 0
719 208 : halo%tripSend = 0
720 208 : halo%tripRecv = 0
721 103568 : halo%sendAddr = 0
722 103568 : halo%recvAddr = 0
723 14980 : halo%srcLocalAddr = 0
724 14980 : halo%dstLocalAddr = 0
725 :
726 36 : deallocate(sendCount, recvCount, stat=istat)
727 :
728 36 : if (istat > 0) then
729 0 : call abort_ice(subname//'ERROR: deallocating count arrays')
730 0 : return
731 : endif
732 :
733 : !-----------------------------------------------------------------------
734 : !
735 : ! repeat loop through blocks but this time, determine all the
736 : ! required message information for each message or local copy
737 : !
738 : !-----------------------------------------------------------------------
739 :
740 : !*** reset halo scalars to use as counters
741 :
742 36 : halo%numMsgSend = 0
743 36 : halo%numMsgRecv = 0
744 36 : halo%numLocalCopies = 0
745 :
746 1124 : msgConfigLoop: do iblock=1,nblocks_tot
747 :
748 : call ice_distributionGetBlockLoc(dist, iblock, srcProc, &
749 1088 : srcLocalID)
750 :
751 : !*** find north neighbor block and set msg info
752 : !*** also set tripole block flag for later special cases
753 :
754 : northBlock = ice_blocksGetNbrID(iblock, ice_blocksNorth, &
755 1088 : ewBoundaryType, nsBoundaryType)
756 :
757 1088 : if (northBlock > 0) then
758 816 : tripoleBlock = .false.
759 : call ice_distributionGetBlockLoc(dist, northBlock, dstProc, &
760 816 : dstLocalID)
761 272 : else if (northBlock < 0) then ! tripole north row, count block
762 0 : tripoleBlock = .true.
763 : call ice_distributionGetBlockLoc(dist, abs(northBlock), &
764 0 : dstProc, dstLocalID)
765 : else
766 272 : tripoleBlock = .false.
767 272 : dstProc = 0
768 272 : dstLocalID = 0
769 : endif
770 :
771 : call ice_HaloMsgCreate(halo, iblock, srcProc, srcLocalID, &
772 : northBlock, dstProc, dstLocalID, & ! LCOV_EXCL_LINE
773 1088 : 'north')
774 :
775 : !*** if a tripole boundary block, also create a local
776 : !*** message into and out of tripole buffer
777 :
778 1088 : if (tripoleBlock) then
779 : !*** copy out of tripole buffer - includes halo
780 : call ice_HaloMsgCreate(halo,-iblock, srcProc, srcLocalID, &
781 : iblock, srcProc, srcLocalID, & ! LCOV_EXCL_LINE
782 0 : 'north')
783 :
784 : !*** copy in only required if dstProc not same as srcProc
785 0 : if (dstProc /= srcProc) then
786 : call ice_HaloMsgCreate(halo, iblock, srcProc, srcLocalID, &
787 : -iblock, srcProc, srcLocalID, & ! LCOV_EXCL_LINE
788 0 : 'north')
789 :
790 : endif
791 : endif
792 :
793 : !*** find south neighbor block and add to message count
794 :
795 : southBlock = ice_blocksGetNbrID(iblock, ice_blocksSouth, &
796 1088 : ewBoundaryType, nsBoundaryType)
797 :
798 1088 : if (southBlock > 0) then
799 : call ice_distributionGetBlockLoc(dist, southBlock, dstProc, &
800 816 : dstLocalID)
801 :
802 : else
803 272 : dstProc = 0
804 272 : dstLocalID = 0
805 : endif
806 :
807 : call ice_HaloMsgCreate(halo, iblock, srcProc, srcLocalID, &
808 : southBlock, dstProc, dstLocalID, & ! LCOV_EXCL_LINE
809 1088 : 'south')
810 :
811 : !*** find east neighbor block and add to message count
812 :
813 : eastBlock = ice_blocksGetNbrID(iblock, ice_blocksEast, &
814 1088 : ewBoundaryType, nsBoundaryType)
815 :
816 1088 : if (eastBlock > 0) then
817 : call ice_distributionGetBlockLoc(dist, eastBlock, dstProc, &
818 1088 : dstLocalID)
819 :
820 : else
821 0 : dstProc = 0
822 0 : dstLocalID = 0
823 : endif
824 :
825 : call ice_HaloMsgCreate(halo, iblock, srcProc, srcLocalID, &
826 : eastBlock, dstProc, dstLocalID, & ! LCOV_EXCL_LINE
827 1088 : 'east')
828 :
829 : !*** if a tripole boundary block, non-local east neighbor
830 : !*** needs a chunk of the north boundary, so add a message
831 : !*** for that
832 :
833 1088 : if (tripoleBlock .and. dstProc /= srcProc) then
834 : call ice_HaloMsgCreate(halo, iblock, srcProc, srcLocalID, &
835 : -eastBlock, dstProc, dstLocalID, & ! LCOV_EXCL_LINE
836 0 : 'north')
837 :
838 : endif
839 :
840 : !*** find west neighbor block and add to message count
841 :
842 : westBlock = ice_blocksGetNbrID(iblock, ice_blocksWest, &
843 1088 : ewBoundaryType, nsBoundaryType)
844 :
845 1088 : if (westBlock > 0) then
846 : call ice_distributionGetBlockLoc(dist, westBlock, dstProc, &
847 1088 : dstLocalID)
848 :
849 : else
850 0 : dstProc = 0
851 0 : dstLocalID = 0
852 : endif
853 :
854 : call ice_HaloMsgCreate(halo, iblock, srcProc, srcLocalID, &
855 : westBlock, dstProc, dstLocalID, & ! LCOV_EXCL_LINE
856 1088 : 'west')
857 :
858 :
859 : !*** if a tripole boundary block, non-local west neighbor
860 : !*** needs a chunk of the north boundary, so add a message
861 : !*** for that
862 :
863 1088 : if (tripoleBlock .and. dstProc /= srcProc) then
864 : call ice_HaloMsgCreate(halo, iblock, srcProc, srcLocalID, &
865 : -westBlock, dstProc, dstLocalID, & ! LCOV_EXCL_LINE
866 0 : 'north')
867 :
868 : endif
869 :
870 : !*** find northeast neighbor block and add to message count
871 :
872 : neBlock = ice_blocksGetNbrID(iblock, ice_blocksNorthEast, &
873 1088 : ewBoundaryType, nsBoundaryType)
874 :
875 1088 : if (neBlock /= 0) then
876 : call ice_distributionGetBlockLoc(dist, abs(neBlock), dstProc, &
877 816 : dstLocalID)
878 :
879 : else
880 272 : dstProc = 0
881 272 : dstLocalID = 0
882 : endif
883 :
884 : call ice_HaloMsgCreate(halo, iblock, srcProc, srcLocalID, &
885 : neBlock, dstProc, dstLocalID, & ! LCOV_EXCL_LINE
886 1088 : 'northeast')
887 :
888 : !*** find northwest neighbor block and add to message count
889 :
890 : nwBlock = ice_blocksGetNbrID(iblock, ice_blocksNorthWest, &
891 1088 : ewBoundaryType, nsBoundaryType)
892 :
893 1088 : if (nwBlock /= 0) then
894 : call ice_distributionGetBlockLoc(dist, abs(nwBlock), dstProc, &
895 816 : dstLocalID)
896 :
897 : else
898 272 : dstProc = 0
899 272 : dstLocalID = 0
900 : endif
901 :
902 : call ice_HaloMsgCreate(halo, iblock, srcProc, srcLocalID, &
903 : nwBlock, dstProc, dstLocalID, & ! LCOV_EXCL_LINE
904 1088 : 'northwest')
905 :
906 : !*** find southeast neighbor block and add to message count
907 :
908 : seBlock = ice_blocksGetNbrID(iblock, ice_blocksSouthEast, &
909 1088 : ewBoundaryType, nsBoundaryType)
910 :
911 1088 : if (seBlock > 0) then
912 : call ice_distributionGetBlockLoc(dist, seBlock, dstProc, &
913 816 : dstLocalID)
914 :
915 : else
916 272 : dstProc = 0
917 272 : dstLocalID = 0
918 : endif
919 :
920 : call ice_HaloMsgCreate(halo, iblock, srcProc, srcLocalID, &
921 : seBlock, dstProc, dstLocalID, & ! LCOV_EXCL_LINE
922 1088 : 'southeast')
923 :
924 : !*** find southwest neighbor block and add to message count
925 :
926 : swBlock = ice_blocksGetNbrID(iblock, ice_blocksSouthWest, &
927 1088 : ewBoundaryType, nsBoundaryType)
928 :
929 1088 : if (swBlock > 0) then
930 : call ice_distributionGetBlockLoc(dist, swBlock, dstProc, &
931 816 : dstLocalID)
932 :
933 : else
934 272 : dstProc = 0
935 272 : dstLocalID = 0
936 : endif
937 :
938 : call ice_HaloMsgCreate(halo, iblock, srcProc, srcLocalID, &
939 : swBlock, dstProc, dstLocalID, & ! LCOV_EXCL_LINE
940 1088 : 'southwest')
941 :
942 : !*** for tripole grids with padded domain, padding will
943 : !*** prevent tripole buffer from getting all the info
944 : !*** it needs - must extend footprint at top boundary
945 :
946 1088 : if (tripoleBlock .and. & !tripole
947 1124 : mod(nxGlobal,blockSizeX) /= 0) then !padding
948 :
949 : !*** find east2 neighbor block and add to message count
950 :
951 : eastBlock = ice_blocksGetNbrID(iBlock, ice_blocksEast2, &
952 0 : ewBoundaryType, nsBoundaryType)
953 :
954 0 : if (eastBlock > 0) then
955 : call ice_distributionGetBlockLoc(dist, eastBlock, dstProc, &
956 0 : dstLocalID)
957 :
958 : else
959 0 : dstProc = 0
960 0 : dstLocalID = 0
961 : endif
962 :
963 0 : if (dstProc /= srcProc) then
964 : call ice_HaloMsgCreate(halo, iblock, srcProc, srcLocalID, &
965 : -eastBlock, dstProc, dstLocalID, & ! LCOV_EXCL_LINE
966 0 : 'north')
967 :
968 : endif
969 :
970 : !*** find EastNorthEast neighbor block and add to message count
971 :
972 : neBlock = ice_blocksGetNbrID(iBlock, ice_blocksEastNorthEast, &
973 0 : ewBoundaryType, nsBoundaryType)
974 :
975 0 : if (neBlock < 0) then ! tripole north row
976 0 : msgSize = tripoleMsgSize ! tripole needs whole top row of block
977 :
978 : call ice_distributionGetBlockLoc(dist, abs(neBlock), dstProc, &
979 0 : dstLocalID)
980 :
981 : else
982 0 : dstProc = 0
983 0 : dstLocalID = 0
984 : endif
985 :
986 0 : if (dstProc /= srcProc) then
987 : call ice_HaloMsgCreate(halo, iblock, srcProc, srcLocalID, &
988 : neBlock, dstProc, dstLocalID, & ! LCOV_EXCL_LINE
989 0 : 'north')
990 : endif
991 :
992 : !*** find west2 neighbor block and add to message count
993 :
994 : westBlock = ice_blocksGetNbrID(iBlock, ice_blocksWest2, &
995 0 : ewBoundaryType, nsBoundaryType)
996 :
997 0 : if (westBlock > 0) then
998 : call ice_distributionGetBlockLoc(dist, westBlock, dstProc, &
999 0 : dstLocalID)
1000 :
1001 : else
1002 0 : dstProc = 0
1003 0 : dstLocalID = 0
1004 : endif
1005 :
1006 0 : if (dstProc /= srcProc) then
1007 : call ice_HaloMsgCreate(halo, iblock, srcProc, srcLocalID, &
1008 : -westBlock, dstProc, dstLocalID, & ! LCOV_EXCL_LINE
1009 0 : 'north')
1010 :
1011 : endif
1012 :
1013 : !*** find WestNorthWest neighbor block and add to message count
1014 :
1015 : nwBlock = ice_blocksGetNbrID(iBlock, ice_blocksWestNorthWest, &
1016 0 : ewBoundaryType, nsBoundaryType)
1017 :
1018 0 : if (nwBlock < 0) then ! tripole north row
1019 0 : msgSize = tripoleMsgSize ! tripole needs whole top row of block
1020 :
1021 : call ice_distributionGetBlockLoc(dist, abs(nwBlock), dstProc, &
1022 0 : dstLocalID)
1023 :
1024 : else
1025 0 : dstProc = 0
1026 0 : dstLocalID = 0
1027 : endif
1028 :
1029 0 : if (dstProc /= srcProc) then
1030 : call ice_HaloMsgCreate(halo, iblock, srcProc, srcLocalID, &
1031 : nwBlock, dstProc, dstLocalID, & ! LCOV_EXCL_LINE
1032 0 : 'north')
1033 :
1034 : endif
1035 :
1036 : endif
1037 :
1038 : end do msgConfigLoop
1039 :
1040 : !-----------------------------------------------------------------------
1041 :
1042 72 : end function ice_HaloCreate
1043 :
1044 : !***********************************************************************
1045 :
1046 0 : subroutine ice_HaloMask(halo, basehalo, mask)
1047 :
1048 : ! This routine creates a halo type with info necessary for
1049 : ! performing a halo (ghost cell) update. This info is computed
1050 : ! based on a base halo already initialized and a mask
1051 :
1052 : use ice_domain_size, only: max_blocks
1053 :
1054 : type (ice_halo) :: &
1055 : basehalo ! basehalo to mask
1056 : integer (int_kind), intent(in) :: &
1057 : mask(nx_block,ny_block,max_blocks) ! mask of live points
1058 :
1059 : type (ice_halo) :: &
1060 : halo ! a new halo type with info for halo updates
1061 : character(len=*), parameter :: subname = '(ice_HaloMask)'
1062 :
1063 : !-----------------------------------------------------------------------
1064 : !
1065 : ! local variables
1066 : !
1067 : !-----------------------------------------------------------------------
1068 :
1069 : integer (int_kind) :: &
1070 : n,nmsg,scnt, &! counters ! LCOV_EXCL_LINE
1071 : icel,jcel,nblock, &! gridcell index ! LCOV_EXCL_LINE
1072 : istat, &! allocate status flag ! LCOV_EXCL_LINE
1073 : communicator, &! communicator for message passing ! LCOV_EXCL_LINE
1074 : numMsgSend, numMsgRecv, &! number of messages for this halo ! LCOV_EXCL_LINE
1075 : numLocalCopies, &! num local copies for halo update ! LCOV_EXCL_LINE
1076 : numLocalBlocks, &! num local blocks for halo fill ! LCOV_EXCL_LINE
1077 : tripoleRows, &! number of rows in tripole buffer ! LCOV_EXCL_LINE
1078 : lbufSizeSend, &! buffer size for send messages ! LCOV_EXCL_LINE
1079 : lbufSizeRecv ! buffer size for recv messages
1080 : logical (log_kind) :: &
1081 : tripoleTFlag, & ! flag for processing tripole buffer as T-fold ! LCOV_EXCL_LINE
1082 : tmpflag ! temporary flag for setting halomask along T-fold
1083 :
1084 : !-----------------------------------------------------------------------
1085 : !
1086 : ! allocate and initialize halo
1087 : ! always keep tripole zipper msgs
1088 : !
1089 : !-----------------------------------------------------------------------
1090 :
1091 0 : communicator = basehalo%communicator
1092 0 : tripoleRows = basehalo%tripoleRows
1093 0 : tripoleTFlag = basehalo%tripoleTFlag
1094 0 : numMsgSend = basehalo%numMsgSend
1095 0 : numMsgRecv = basehalo%numMsgRecv
1096 0 : numLocalCopies = basehalo%numLocalCopies
1097 0 : numLocalBlocks = basehalo%numLocalBlocks
1098 0 : lbufSizeSend = size(basehalo%sendAddr,dim=2)
1099 0 : lbufSizeRecv = size(basehalo%recvAddr,dim=2)
1100 :
1101 : allocate(halo%sendTask(numMsgSend), &
1102 : halo%recvTask(numMsgRecv), & ! LCOV_EXCL_LINE
1103 : halo%sizeSend(numMsgSend), & ! LCOV_EXCL_LINE
1104 : halo%sizeRecv(numMsgRecv), & ! LCOV_EXCL_LINE
1105 : halo%tripSend(numMsgSend), & ! LCOV_EXCL_LINE
1106 : halo%tripRecv(numMsgRecv), & ! LCOV_EXCL_LINE
1107 : halo%sendAddr(3,lbufSizeSend,numMsgSend), & ! LCOV_EXCL_LINE
1108 : halo%recvAddr(3,lbufSizeRecv,numMsgRecv), & ! LCOV_EXCL_LINE
1109 : halo%srcLocalAddr(3,numLocalCopies), & ! LCOV_EXCL_LINE
1110 : halo%dstLocalAddr(3,numLocalCopies), & ! LCOV_EXCL_LINE
1111 : halo%blockGlobalID(numLocalBlocks), & ! LCOV_EXCL_LINE
1112 0 : stat = istat)
1113 :
1114 0 : if (istat > 0) then
1115 0 : call abort_ice(subname//'ERROR: allocating halo message info arrays')
1116 0 : return
1117 : endif
1118 :
1119 0 : halo%communicator = communicator
1120 0 : halo%tripoleRows = tripoleRows
1121 0 : halo%tripoleTFlag = tripoleTFlag
1122 0 : halo%numLocalCopies = numLocalCopies
1123 0 : halo%numLocalBlocks = numLocalBlocks
1124 :
1125 0 : halo%srcLocalAddr = basehalo%srcLocalAddr(:,1:numLocalCopies)
1126 0 : halo%dstLocalAddr = basehalo%dstLocalAddr(:,1:numLocalCopies)
1127 :
1128 0 : halo%blockGlobalID = basehalo%blockGlobalID
1129 :
1130 0 : numMsgSend = 0
1131 0 : do nmsg=1,basehalo%numMsgSend
1132 0 : scnt = 0
1133 0 : do n=1,basehalo%sizeSend(nmsg)
1134 0 : icel = basehalo%sendAddr(1,n,nmsg)
1135 0 : jcel = basehalo%sendAddr(2,n,nmsg)
1136 0 : nblock = basehalo%sendAddr(3,n,nmsg)
1137 : ! the following line fails bounds check for mask when tripSend /= 0
1138 : ! if (mask(icel,jcel,abs(nblock)) /= 0 .or. basehalo%tripSend(nmsg) /= 0) then
1139 0 : tmpflag = .false.
1140 0 : if (basehalo%tripSend(nmsg) /= 0) then
1141 0 : tmpflag = .true.
1142 0 : elseif (mask(icel,jcel,abs(nblock)) /= 0) then
1143 0 : tmpflag = .true.
1144 : endif
1145 :
1146 0 : if (tmpflag) then
1147 0 : scnt = scnt + 1
1148 0 : if (scnt == 1) then
1149 0 : numMsgSend = numMsgSend + 1
1150 0 : halo%sendTask(numMsgSend) = basehalo%sendTask(nmsg)
1151 0 : halo%tripSend(numMsgSend) = basehalo%tripSend(nmsg)
1152 : endif
1153 0 : halo%sendAddr(1,scnt,numMsgSend) = icel
1154 0 : halo%sendAddr(2,scnt,numMsgSend) = jcel
1155 0 : halo%sendAddr(3,scnt,numMsgSend) = nblock
1156 0 : halo%sizeSend(numMsgSend) = scnt
1157 : endif
1158 : enddo
1159 : enddo
1160 0 : halo%numMsgSend = numMsgSend
1161 :
1162 0 : numMsgRecv = 0
1163 0 : do nmsg=1,basehalo%numMsgRecv
1164 0 : scnt = 0
1165 0 : do n=1,basehalo%sizeRecv(nmsg)
1166 0 : icel = basehalo%recvAddr(1,n,nmsg)
1167 0 : jcel = basehalo%recvAddr(2,n,nmsg)
1168 0 : nblock = basehalo%recvAddr(3,n,nmsg)
1169 : ! the following line fails bounds check for mask when tripRecv /= 0
1170 : ! if (mask(icel,jcel,abs(nblock)) /= 0 .or. basehalo%tripRecv(nmsg) /= 0) then
1171 0 : tmpflag = .false.
1172 0 : if (basehalo%tripRecv(nmsg) /= 0) then
1173 0 : tmpflag = .true.
1174 0 : elseif (mask(icel,jcel,abs(nblock)) /= 0) then
1175 0 : tmpflag = .true.
1176 : endif
1177 :
1178 0 : if (tmpflag) then
1179 0 : scnt = scnt + 1
1180 0 : if (scnt == 1) then
1181 0 : numMsgRecv = numMsgRecv + 1
1182 0 : halo%recvTask(numMsgRecv) = basehalo%recvTask(nmsg)
1183 0 : halo%tripRecv(numMsgRecv) = basehalo%tripRecv(nmsg)
1184 : endif
1185 0 : halo%recvAddr(1,scnt,numMsgRecv) = icel
1186 0 : halo%recvAddr(2,scnt,numMsgRecv) = jcel
1187 0 : halo%recvAddr(3,scnt,numMsgRecv) = nblock
1188 0 : halo%sizeRecv(numMsgRecv) = scnt
1189 : endif
1190 : enddo
1191 : enddo
1192 0 : halo%numMsgRecv = numMsgRecv
1193 :
1194 : !-----------------------------------------------------------------------
1195 :
1196 : end subroutine ice_HaloMask
1197 :
1198 : !***********************************************************************
1199 :
1200 2373984 : subroutine ice_HaloUpdate2DR8(array, halo, &
1201 : fieldLoc, fieldKind, & ! LCOV_EXCL_LINE
1202 : fillValue, tripoleOnly)
1203 :
1204 : ! This routine updates ghost cells for an input array and is a
1205 : ! member of a group of routines under the generic interface
1206 : ! ice\_HaloUpdate. This routine is the specific interface
1207 : ! for 2d horizontal arrays of double precision.
1208 :
1209 : type (ice_halo), intent(in) :: &
1210 : halo ! precomputed halo structure containing all
1211 : ! information needed for halo update
1212 :
1213 : integer (int_kind), intent(in) :: &
1214 : fieldKind, &! id for type of field (scalar, vector, angle) ! LCOV_EXCL_LINE
1215 : fieldLoc ! id for location on horizontal grid
1216 : ! (center, NEcorner, Nface, Eface)
1217 :
1218 : real (dbl_kind), intent(in), optional :: &
1219 : fillValue ! optional value to put in ghost cells
1220 : ! where neighbor points are unknown
1221 : ! (e.g. eliminated land blocks or
1222 : ! closed boundaries)
1223 :
1224 : logical (log_kind), intent(in), optional :: &
1225 : tripoleOnly ! optional flag to execute halo only across tripole seam.
1226 : ! this is required for a few fields where we just want to
1227 : ! ensure the tripole seam is synced up to preserve symmetry.
1228 : ! Added June, 2022 by tcraig. Only added to 2DR8 for now.
1229 :
1230 : real (dbl_kind), dimension(:,:,:), intent(inout) :: &
1231 : array ! array containing field for which halo
1232 : ! needs to be updated
1233 :
1234 : !-----------------------------------------------------------------------
1235 : !
1236 : ! local variables
1237 : !
1238 : !-----------------------------------------------------------------------
1239 :
1240 : integer (int_kind) :: &
1241 : i,j,n,nmsg, &! dummy loop indices ! LCOV_EXCL_LINE
1242 : iblk,ilo,ihi,jlo,jhi, &! block sizes for fill ! LCOV_EXCL_LINE
1243 : ierr, &! error or status flag for MPI,alloc ! LCOV_EXCL_LINE
1244 : nxGlobal, &! global domain size in x (tripole) ! LCOV_EXCL_LINE
1245 : iSrc,jSrc, &! source addresses for message ! LCOV_EXCL_LINE
1246 : iDst,jDst, &! dest addresses for message ! LCOV_EXCL_LINE
1247 : srcBlock, &! local block number for source ! LCOV_EXCL_LINE
1248 : dstBlock, &! local block number for destination ! LCOV_EXCL_LINE
1249 : ioffset, joffset, &! address shifts for tripole ! LCOV_EXCL_LINE
1250 : isign ! sign factor for tripole grids
1251 :
1252 : integer (int_kind), dimension(:), allocatable :: &
1253 : sndRequest, &! MPI request ids ! LCOV_EXCL_LINE
1254 2373984 : rcvRequest ! MPI request ids
1255 :
1256 : integer (int_kind), dimension(:,:), allocatable :: &
1257 : sndStatus, &! MPI status flags ! LCOV_EXCL_LINE
1258 2373984 : rcvStatus ! MPI status flags
1259 :
1260 : real (dbl_kind) :: &
1261 : fill, &! value to use for unknown points ! LCOV_EXCL_LINE
1262 708672 : x1,x2,xavg ! scalars for enforcing symmetry at U pts
1263 :
1264 : logical (log_kind) :: &
1265 : ltripoleOnly ! local tripoleOnly value
1266 :
1267 : integer (int_kind) :: len ! length of messages
1268 :
1269 : character(len=*), parameter :: subname = '(ice_HaloUpdate2DR8)'
1270 :
1271 : !-----------------------------------------------------------------------
1272 : !
1273 : ! abort or return on unknown or noupdate field_loc or field_type
1274 : !
1275 : !-----------------------------------------------------------------------
1276 :
1277 2373984 : if (fieldLoc == field_loc_unknown .or. &
1278 : fieldKind == field_type_unknown) then
1279 0 : call abort_ice(subname//'ERROR: use of field_loc/type_unknown not allowed')
1280 0 : return
1281 : endif
1282 :
1283 2373984 : if (fieldLoc == field_loc_noupdate .or. &
1284 : fieldKind == field_type_noupdate) then
1285 0 : return
1286 : endif
1287 :
1288 : !-----------------------------------------------------------------------
1289 : !
1290 : ! initialize error code and fill value
1291 : !
1292 : !-----------------------------------------------------------------------
1293 :
1294 2373984 : if (present(fillValue)) then
1295 612 : fill = fillValue
1296 : else
1297 2373372 : fill = 0.0_dbl_kind
1298 : endif
1299 :
1300 2373984 : if (present(tripoleOnly)) then
1301 288 : ltripoleOnly = tripoleOnly
1302 : else
1303 2373696 : ltripoleOnly = .false.
1304 : endif
1305 :
1306 2373984 : nxGlobal = 0
1307 2373984 : if (allocated(bufTripoleR8)) then
1308 0 : nxGlobal = size(bufTripoleR8,dim=1)
1309 0 : bufTripoleR8 = fill
1310 : endif
1311 :
1312 : !-----------------------------------------------------------------------
1313 : !
1314 : ! allocate request and status arrays for messages
1315 : !
1316 : !-----------------------------------------------------------------------
1317 :
1318 : allocate(sndRequest(halo%numMsgSend), &
1319 : rcvRequest(halo%numMsgRecv), & ! LCOV_EXCL_LINE
1320 : sndStatus(MPI_STATUS_SIZE,halo%numMsgSend), & ! LCOV_EXCL_LINE
1321 2373984 : rcvStatus(MPI_STATUS_SIZE,halo%numMsgRecv), stat=ierr)
1322 :
1323 2373984 : if (ierr > 0) then
1324 0 : call abort_ice(subname//'ERROR: allocating req,status arrays')
1325 0 : return
1326 : endif
1327 :
1328 : !-----------------------------------------------------------------------
1329 : !
1330 : ! post receives
1331 : !
1332 : !-----------------------------------------------------------------------
1333 :
1334 12377472 : do nmsg=1,halo%numMsgRecv
1335 :
1336 10003488 : len = halo%SizeRecv(nmsg)
1337 0 : call MPI_IRECV(bufRecvR8(1:len,nmsg), len, mpiR8, &
1338 : halo%recvTask(nmsg), & ! LCOV_EXCL_LINE
1339 : mpitagHalo + halo%recvTask(nmsg), & ! LCOV_EXCL_LINE
1340 12377472 : halo%communicator, rcvRequest(nmsg), ierr)
1341 : end do
1342 :
1343 : !-----------------------------------------------------------------------
1344 : !
1345 : ! fill send buffer and post sends
1346 : !
1347 : !-----------------------------------------------------------------------
1348 :
1349 12377472 : do nmsg=1,halo%numMsgSend
1350 :
1351 417511968 : do n=1,halo%sizeSend(nmsg)
1352 407508480 : iSrc = halo%sendAddr(1,n,nmsg)
1353 407508480 : jSrc = halo%sendAddr(2,n,nmsg)
1354 407508480 : srcBlock = halo%sendAddr(3,n,nmsg)
1355 :
1356 417511968 : bufSendR8(n,nmsg) = array(iSrc,jSrc,srcBlock)
1357 : end do
1358 434167968 : do n=halo%sizeSend(nmsg)+1,bufSizeSend
1359 434167968 : bufSendR8(n,nmsg) = fill ! fill remainder of buffer
1360 : end do
1361 :
1362 10003488 : len = halo%SizeSend(nmsg)
1363 0 : call MPI_ISEND(bufSendR8(1:len,nmsg), len, mpiR8, &
1364 : halo%sendTask(nmsg), & ! LCOV_EXCL_LINE
1365 : mpitagHalo + my_task, & ! LCOV_EXCL_LINE
1366 12377472 : halo%communicator, sndRequest(nmsg), ierr)
1367 : end do
1368 :
1369 : !-----------------------------------------------------------------------
1370 : !
1371 : ! while messages are being communicated, fill out halo region
1372 : ! needed for masked halos to ensure halo values are filled for
1373 : ! halo grid cells that are not updated
1374 : !
1375 : !-----------------------------------------------------------------------
1376 :
1377 2373984 : if (ltripoleOnly) then
1378 : ! skip fill, not needed since tripole seam always exists if running
1379 : ! on tripole grid and set tripoleOnly flag
1380 : else
1381 9102480 : do iblk = 1, halo%numLocalBlocks
1382 0 : call get_block_parameter(halo%blockGlobalID(iblk), &
1383 : ilo=ilo, ihi=ihi, & ! LCOV_EXCL_LINE
1384 6728784 : jlo=jlo, jhi=jhi)
1385 13457568 : do j = 1,nghost
1386 205946496 : array(1:nx_block, jlo-j,iblk) = fill
1387 212675280 : array(1:nx_block, jhi+j,iblk) = fill
1388 : enddo
1389 22560048 : do i = 1,nghost
1390 223824384 : array(ilo-i, 1:ny_block,iblk) = fill
1391 230553168 : array(ihi+i, 1:ny_block,iblk) = fill
1392 : enddo
1393 : enddo
1394 : endif
1395 :
1396 : !-----------------------------------------------------------------------
1397 : !
1398 : ! do local copies while waiting for messages to complete
1399 : ! if srcBlock is zero, that denotes an eliminated land block or a
1400 : ! closed boundary where ghost cell values are undefined
1401 : ! if srcBlock is less than zero, the message is a copy out of the
1402 : ! tripole buffer and will be treated later
1403 : !
1404 : !-----------------------------------------------------------------------
1405 :
1406 301073568 : do nmsg=1,halo%numLocalCopies
1407 298699584 : iSrc = halo%srcLocalAddr(1,nmsg)
1408 298699584 : jSrc = halo%srcLocalAddr(2,nmsg)
1409 298699584 : srcBlock = halo%srcLocalAddr(3,nmsg)
1410 298699584 : iDst = halo%dstLocalAddr(1,nmsg)
1411 298699584 : jDst = halo%dstLocalAddr(2,nmsg)
1412 298699584 : dstBlock = halo%dstLocalAddr(3,nmsg)
1413 :
1414 301073568 : if (ltripoleOnly) then
1415 29888 : if (srcBlock > 0) then
1416 29312 : if (dstBlock < 0) then ! tripole copy into buffer
1417 0 : bufTripoleR8(iDst,jDst) = &
1418 0 : array(iSrc,jSrc,srcBlock)
1419 : endif
1420 : endif
1421 : else
1422 298669696 : if (srcBlock > 0) then
1423 298564864 : if (dstBlock > 0) then
1424 155893760 : array(iDst,jDst,dstBlock) = &
1425 298564864 : array(iSrc,jSrc,srcBlock)
1426 0 : else if (dstBlock < 0) then ! tripole copy into buffer
1427 0 : bufTripoleR8(iDst,jDst) = &
1428 0 : array(iSrc,jSrc,srcBlock)
1429 : endif
1430 104832 : else if (srcBlock == 0) then
1431 104832 : array(iDst,jDst,dstBlock) = fill
1432 : endif
1433 : endif
1434 : end do
1435 :
1436 : !-----------------------------------------------------------------------
1437 : !
1438 : ! wait for receives to finish and then unpack the recv buffer into
1439 : ! ghost cells
1440 : !
1441 : !-----------------------------------------------------------------------
1442 :
1443 2373984 : call MPI_WAITALL(halo%numMsgRecv, rcvRequest, rcvStatus, ierr)
1444 :
1445 12377472 : do nmsg=1,halo%numMsgRecv
1446 419885952 : do n=1,halo%sizeRecv(nmsg)
1447 407508480 : iDst = halo%recvAddr(1,n,nmsg)
1448 407508480 : jDst = halo%recvAddr(2,n,nmsg)
1449 407508480 : dstBlock = halo%recvAddr(3,n,nmsg)
1450 :
1451 417511968 : if (ltripoleOnly) then
1452 80640 : if (dstBlock < 0) then !tripole
1453 0 : bufTripoleR8(iDst,jDst) = bufRecvR8(n,nmsg)
1454 : endif
1455 : else
1456 407427840 : if (dstBlock > 0) then
1457 407427840 : array(iDst,jDst,dstBlock) = bufRecvR8(n,nmsg)
1458 0 : else if (dstBlock < 0) then !tripole
1459 0 : bufTripoleR8(iDst,jDst) = bufRecvR8(n,nmsg)
1460 : endif
1461 : endif
1462 : end do
1463 : end do
1464 :
1465 : !-----------------------------------------------------------------------
1466 : !
1467 : ! take care of northern boundary in tripole case
1468 : ! bufTripole array contains the top nghost+1 rows (u-fold) or nghost+2 rows
1469 : ! (T-fold) of physical domain for entire (global) top row
1470 : !
1471 : !-----------------------------------------------------------------------
1472 :
1473 2373984 : if (nxGlobal > 0) then
1474 :
1475 0 : select case (fieldKind)
1476 : case (field_type_scalar)
1477 0 : isign = 1
1478 : case (field_type_vector)
1479 0 : isign = -1
1480 : case (field_type_angle)
1481 0 : isign = -1
1482 : case default
1483 0 : call abort_ice(subname//'ERROR: Unknown field kind')
1484 : end select
1485 :
1486 0 : if (halo%tripoleTFlag) then
1487 :
1488 0 : select case (fieldLoc)
1489 : case (field_loc_center) ! cell center location
1490 :
1491 0 : ioffset = -1
1492 0 : joffset = 0
1493 :
1494 : !*** top row is degenerate, so must enforce symmetry
1495 : !*** use average of two degenerate points for value
1496 :
1497 0 : do i = 2,nxGlobal/2
1498 0 : iDst = nxGlobal - i + 2
1499 0 : x1 = bufTripoleR8(i ,halo%tripoleRows)
1500 0 : x2 = bufTripoleR8(iDst,halo%tripoleRows)
1501 0 : xavg = 0.5_dbl_kind*(x1 + isign*x2)
1502 0 : bufTripoleR8(i ,halo%tripoleRows) = xavg
1503 0 : bufTripoleR8(iDst,halo%tripoleRows) = isign*xavg
1504 : end do
1505 :
1506 : case (field_loc_NEcorner) ! cell corner location
1507 :
1508 0 : ioffset = 0
1509 0 : joffset = 1
1510 :
1511 : case (field_loc_Eface) ! cell center location
1512 :
1513 0 : ioffset = 0
1514 0 : joffset = 0
1515 :
1516 : !*** top row is degenerate, so must enforce symmetry
1517 : !*** use average of two degenerate points for value
1518 :
1519 0 : do i = 1,nxGlobal/2
1520 0 : iDst = nxGlobal + 1 - i
1521 0 : x1 = bufTripoleR8(i ,halo%tripoleRows)
1522 0 : x2 = bufTripoleR8(iDst,halo%tripoleRows)
1523 0 : xavg = 0.5_dbl_kind*(x1 + isign*x2)
1524 0 : bufTripoleR8(i ,halo%tripoleRows) = xavg
1525 0 : bufTripoleR8(iDst,halo%tripoleRows) = isign*xavg
1526 : end do
1527 :
1528 : case (field_loc_Nface) ! cell corner (velocity) location
1529 :
1530 0 : ioffset = -1
1531 0 : joffset = 1
1532 :
1533 : case default
1534 0 : call abort_ice(subname//'ERROR: Unknown field location')
1535 : end select
1536 :
1537 : else ! tripole u-fold
1538 :
1539 0 : select case (fieldLoc)
1540 : case (field_loc_center) ! cell center location
1541 :
1542 0 : ioffset = 0
1543 0 : joffset = 0
1544 :
1545 : case (field_loc_NEcorner) ! cell corner location
1546 :
1547 0 : ioffset = 1
1548 0 : joffset = 1
1549 :
1550 : !*** top row is degenerate, so must enforce symmetry
1551 : !*** use average of two degenerate points for value
1552 :
1553 0 : do i = 1,nxGlobal/2 - 1
1554 0 : iDst = nxGlobal - i
1555 0 : x1 = bufTripoleR8(i ,halo%tripoleRows)
1556 0 : x2 = bufTripoleR8(iDst,halo%tripoleRows)
1557 0 : xavg = 0.5_dbl_kind*(x1 + isign*x2)
1558 0 : bufTripoleR8(i ,halo%tripoleRows) = xavg
1559 0 : bufTripoleR8(iDst,halo%tripoleRows) = isign*xavg
1560 : end do
1561 :
1562 : case (field_loc_Eface) ! cell center location
1563 :
1564 0 : ioffset = 1
1565 0 : joffset = 0
1566 :
1567 : case (field_loc_Nface) ! cell corner (velocity) location
1568 :
1569 0 : ioffset = 0
1570 0 : joffset = 1
1571 :
1572 : !*** top row is degenerate, so must enforce symmetry
1573 : !*** use average of two degenerate points for value
1574 :
1575 0 : do i = 1,nxGlobal/2
1576 0 : iDst = nxGlobal + 1 - i
1577 0 : x1 = bufTripoleR8(i ,halo%tripoleRows)
1578 0 : x2 = bufTripoleR8(iDst,halo%tripoleRows)
1579 0 : xavg = 0.5_dbl_kind*(x1 + isign*x2)
1580 0 : bufTripoleR8(i ,halo%tripoleRows) = xavg
1581 0 : bufTripoleR8(iDst,halo%tripoleRows) = isign*xavg
1582 : end do
1583 :
1584 : case default
1585 0 : call abort_ice(subname//'ERROR: Unknown field location')
1586 : end select
1587 :
1588 : endif
1589 :
1590 : !*** copy out of global tripole buffer into local
1591 : !*** ghost cells
1592 :
1593 : !*** look through local copies to find the copy out
1594 : !*** messages (srcBlock < 0)
1595 :
1596 0 : do nmsg=1,halo%numLocalCopies
1597 0 : srcBlock = halo%srcLocalAddr(3,nmsg)
1598 :
1599 0 : if (srcBlock < 0) then
1600 :
1601 0 : iSrc = halo%srcLocalAddr(1,nmsg) ! tripole buffer addr
1602 0 : jSrc = halo%srcLocalAddr(2,nmsg)
1603 :
1604 0 : iDst = halo%dstLocalAddr(1,nmsg) ! local block addr
1605 0 : jDst = halo%dstLocalAddr(2,nmsg)
1606 0 : dstBlock = halo%dstLocalAddr(3,nmsg)
1607 :
1608 : !*** correct for offsets
1609 0 : iSrc = iSrc - ioffset
1610 0 : jSrc = jSrc - joffset
1611 0 : if (iSrc < 1 ) iSrc = iSrc + nxGlobal
1612 0 : if (iSrc > nxGlobal) iSrc = iSrc - nxGlobal
1613 :
1614 : !*** for center and Eface on u-fold, and NE corner and Nface
1615 : !*** on T-fold, do not need to replace
1616 : !*** top row of physical domain, so jSrc should be
1617 : !*** out of range and skipped
1618 : !*** otherwise do the copy
1619 :
1620 0 : if (jSrc <= halo%tripoleRows .and. jSrc>0 .and. jDst>0) then
1621 0 : array(iDst,jDst,dstBlock) = isign*bufTripoleR8(iSrc,jSrc)
1622 : endif
1623 :
1624 : endif
1625 : end do
1626 :
1627 : endif
1628 :
1629 : !-----------------------------------------------------------------------
1630 : !
1631 : ! wait for sends to complete and deallocate arrays
1632 : !
1633 : !-----------------------------------------------------------------------
1634 :
1635 2373984 : call MPI_WAITALL(halo%numMsgSend, sndRequest, sndStatus, ierr)
1636 :
1637 2373984 : deallocate(sndRequest, rcvRequest, sndStatus, rcvStatus, stat=ierr)
1638 :
1639 2373984 : if (ierr > 0) then
1640 0 : call abort_ice(subname//'ERROR: deallocating req,status arrays')
1641 0 : return
1642 : endif
1643 :
1644 : !-----------------------------------------------------------------------
1645 :
1646 7121952 : end subroutine ice_HaloUpdate2DR8
1647 :
1648 : !***********************************************************************
1649 :
1650 0 : subroutine ice_HaloUpdate2DR4(array, halo, &
1651 : fieldLoc, fieldKind, & ! LCOV_EXCL_LINE
1652 : fillValue)
1653 :
1654 : ! This routine updates ghost cells for an input array and is a
1655 : ! member of a group of routines under the generic interface
1656 : ! ice\_HaloUpdate. This routine is the specific interface
1657 : ! for 2d horizontal arrays of single precision.
1658 :
1659 : type (ice_halo), intent(in) :: &
1660 : halo ! precomputed halo structure containing all
1661 : ! information needed for halo update
1662 :
1663 : integer (int_kind), intent(in) :: &
1664 : fieldKind, &! id for type of field (scalar, vector, angle) ! LCOV_EXCL_LINE
1665 : fieldLoc ! id for location on horizontal grid
1666 : ! (center, NEcorner, Nface, Eface)
1667 :
1668 : real (real_kind), intent(in), optional :: &
1669 : fillValue ! optional value to put in ghost cells
1670 : ! where neighbor points are unknown
1671 : ! (e.g. eliminated land blocks or
1672 : ! closed boundaries)
1673 :
1674 : real (real_kind), dimension(:,:,:), intent(inout) :: &
1675 : array ! array containing field for which halo
1676 : ! needs to be updated
1677 :
1678 : !-----------------------------------------------------------------------
1679 : !
1680 : ! local variables
1681 : !
1682 : !-----------------------------------------------------------------------
1683 :
1684 : integer (int_kind) :: &
1685 : i,j,n,nmsg, &! dummy loop indices ! LCOV_EXCL_LINE
1686 : iblk,ilo,ihi,jlo,jhi, &! block sizes for fill ! LCOV_EXCL_LINE
1687 : ierr, &! error or status flag for MPI,alloc ! LCOV_EXCL_LINE
1688 : nxGlobal, &! global domain size in x (tripole) ! LCOV_EXCL_LINE
1689 : iSrc,jSrc, &! source addresses for message ! LCOV_EXCL_LINE
1690 : iDst,jDst, &! dest addresses for message ! LCOV_EXCL_LINE
1691 : srcBlock, &! local block number for source ! LCOV_EXCL_LINE
1692 : dstBlock, &! local block number for destination ! LCOV_EXCL_LINE
1693 : ioffset, joffset, &! address shifts for tripole ! LCOV_EXCL_LINE
1694 : isign ! sign factor for tripole grids
1695 :
1696 : integer (int_kind), dimension(:), allocatable :: &
1697 : sndRequest, &! MPI request ids ! LCOV_EXCL_LINE
1698 0 : rcvRequest ! MPI request ids
1699 :
1700 : integer (int_kind), dimension(:,:), allocatable :: &
1701 : sndStatus, &! MPI status flags ! LCOV_EXCL_LINE
1702 0 : rcvStatus ! MPI status flags
1703 :
1704 : real (real_kind) :: &
1705 : fill, &! value to use for unknown points ! LCOV_EXCL_LINE
1706 0 : x1,x2,xavg ! scalars for enforcing symmetry at U pts
1707 :
1708 : integer (int_kind) :: len ! length of messages
1709 :
1710 : character(len=*), parameter :: subname = '(ice_HaloUpdate2DR4)'
1711 :
1712 : !-----------------------------------------------------------------------
1713 : !
1714 : ! abort or return on unknown or noupdate field_loc or field_type
1715 : !
1716 : !-----------------------------------------------------------------------
1717 :
1718 0 : if (fieldLoc == field_loc_unknown .or. &
1719 : fieldKind == field_type_unknown) then
1720 0 : call abort_ice(subname//'ERROR: use of field_loc/type_unknown not allowed')
1721 0 : return
1722 : endif
1723 :
1724 0 : if (fieldLoc == field_loc_noupdate .or. &
1725 : fieldKind == field_type_noupdate) then
1726 0 : return
1727 : endif
1728 :
1729 : !-----------------------------------------------------------------------
1730 : !
1731 : ! initialize error code and fill value
1732 : !
1733 : !-----------------------------------------------------------------------
1734 :
1735 0 : if (present(fillValue)) then
1736 0 : fill = fillValue
1737 : else
1738 0 : fill = 0.0_real_kind
1739 : endif
1740 :
1741 0 : nxGlobal = 0
1742 0 : if (allocated(bufTripoleR4)) then
1743 0 : nxGlobal = size(bufTripoleR4,dim=1)
1744 0 : bufTripoleR4 = fill
1745 : endif
1746 :
1747 : !-----------------------------------------------------------------------
1748 : !
1749 : ! allocate request and status arrays for messages
1750 : !
1751 : !-----------------------------------------------------------------------
1752 :
1753 : allocate(sndRequest(halo%numMsgSend), &
1754 : rcvRequest(halo%numMsgRecv), & ! LCOV_EXCL_LINE
1755 : sndStatus(MPI_STATUS_SIZE,halo%numMsgSend), & ! LCOV_EXCL_LINE
1756 0 : rcvStatus(MPI_STATUS_SIZE,halo%numMsgRecv), stat=ierr)
1757 :
1758 0 : if (ierr > 0) then
1759 0 : call abort_ice(subname//'ERROR: allocating req,status arrays')
1760 0 : return
1761 : endif
1762 :
1763 : !-----------------------------------------------------------------------
1764 : !
1765 : ! post receives
1766 : !
1767 : !-----------------------------------------------------------------------
1768 :
1769 0 : do nmsg=1,halo%numMsgRecv
1770 :
1771 0 : len = halo%SizeRecv(nmsg)
1772 0 : call MPI_IRECV(bufRecvR4(1:len,nmsg), len, mpiR4, &
1773 : halo%recvTask(nmsg), & ! LCOV_EXCL_LINE
1774 : mpitagHalo + halo%recvTask(nmsg), & ! LCOV_EXCL_LINE
1775 0 : halo%communicator, rcvRequest(nmsg), ierr)
1776 : end do
1777 :
1778 : !-----------------------------------------------------------------------
1779 : !
1780 : ! fill send buffer and post sends
1781 : !
1782 : !-----------------------------------------------------------------------
1783 :
1784 0 : do nmsg=1,halo%numMsgSend
1785 :
1786 0 : do n=1,halo%sizeSend(nmsg)
1787 0 : iSrc = halo%sendAddr(1,n,nmsg)
1788 0 : jSrc = halo%sendAddr(2,n,nmsg)
1789 0 : srcBlock = halo%sendAddr(3,n,nmsg)
1790 :
1791 0 : bufSendR4(n,nmsg) = array(iSrc,jSrc,srcBlock)
1792 : end do
1793 0 : do n=halo%sizeSend(nmsg)+1,bufSizeSend
1794 0 : bufSendR4(n,nmsg) = fill ! fill remainder of buffer
1795 : end do
1796 :
1797 0 : len = halo%SizeSend(nmsg)
1798 0 : call MPI_ISEND(bufSendR4(1:len,nmsg), len, mpiR4, &
1799 : halo%sendTask(nmsg), & ! LCOV_EXCL_LINE
1800 : mpitagHalo + my_task, & ! LCOV_EXCL_LINE
1801 0 : halo%communicator, sndRequest(nmsg), ierr)
1802 : end do
1803 :
1804 : !-----------------------------------------------------------------------
1805 : !
1806 : ! while messages are being communicated, fill out halo region
1807 : ! needed for masked halos to ensure halo values are filled for
1808 : ! halo grid cells that are not updated
1809 : !
1810 : !-----------------------------------------------------------------------
1811 :
1812 0 : do iblk = 1, halo%numLocalBlocks
1813 0 : call get_block_parameter(halo%blockGlobalID(iblk), &
1814 : ilo=ilo, ihi=ihi, & ! LCOV_EXCL_LINE
1815 0 : jlo=jlo, jhi=jhi)
1816 0 : do j = 1,nghost
1817 0 : array(1:nx_block, jlo-j,iblk) = fill
1818 0 : array(1:nx_block, jhi+j,iblk) = fill
1819 : enddo
1820 0 : do i = 1,nghost
1821 0 : array(ilo-i, 1:ny_block,iblk) = fill
1822 0 : array(ihi+i, 1:ny_block,iblk) = fill
1823 : enddo
1824 : enddo
1825 :
1826 : !-----------------------------------------------------------------------
1827 : !
1828 : ! do local copies while waiting for messages to complete
1829 : ! if srcBlock is zero, that denotes an eliminated land block or a
1830 : ! closed boundary where ghost cell values are undefined
1831 : ! if srcBlock is less than zero, the message is a copy out of the
1832 : ! tripole buffer and will be treated later
1833 : !
1834 : !-----------------------------------------------------------------------
1835 :
1836 0 : do nmsg=1,halo%numLocalCopies
1837 0 : iSrc = halo%srcLocalAddr(1,nmsg)
1838 0 : jSrc = halo%srcLocalAddr(2,nmsg)
1839 0 : srcBlock = halo%srcLocalAddr(3,nmsg)
1840 0 : iDst = halo%dstLocalAddr(1,nmsg)
1841 0 : jDst = halo%dstLocalAddr(2,nmsg)
1842 0 : dstBlock = halo%dstLocalAddr(3,nmsg)
1843 :
1844 0 : if (srcBlock > 0) then
1845 0 : if (dstBlock > 0) then
1846 0 : array(iDst,jDst,dstBlock) = &
1847 0 : array(iSrc,jSrc,srcBlock)
1848 0 : else if (dstBlock < 0) then ! tripole copy into buffer
1849 0 : bufTripoleR4(iDst,jDst) = &
1850 0 : array(iSrc,jSrc,srcBlock)
1851 : endif
1852 0 : else if (srcBlock == 0) then
1853 0 : array(iDst,jDst,dstBlock) = fill
1854 : endif
1855 : end do
1856 :
1857 : !-----------------------------------------------------------------------
1858 : !
1859 : ! wait for receives to finish and then unpack the recv buffer into
1860 : ! ghost cells
1861 : !
1862 : !-----------------------------------------------------------------------
1863 :
1864 0 : call MPI_WAITALL(halo%numMsgRecv, rcvRequest, rcvStatus, ierr)
1865 :
1866 0 : do nmsg=1,halo%numMsgRecv
1867 0 : do n=1,halo%sizeRecv(nmsg)
1868 0 : iDst = halo%recvAddr(1,n,nmsg)
1869 0 : jDst = halo%recvAddr(2,n,nmsg)
1870 0 : dstBlock = halo%recvAddr(3,n,nmsg)
1871 :
1872 0 : if (dstBlock > 0) then
1873 0 : array(iDst,jDst,dstBlock) = bufRecvR4(n,nmsg)
1874 0 : else if (dstBlock < 0) then !tripole
1875 0 : bufTripoleR4(iDst,jDst) = bufRecvR4(n,nmsg)
1876 : endif
1877 : end do
1878 : end do
1879 :
1880 : !-----------------------------------------------------------------------
1881 : !
1882 : ! take care of northern boundary in tripole case
1883 : ! bufTripole array contains the top nghost+1 rows (u-fold) or nghost+2 rows
1884 : ! (T-fold) of physical domain for entire (global) top row
1885 : !
1886 : !-----------------------------------------------------------------------
1887 :
1888 0 : if (nxGlobal > 0) then
1889 :
1890 0 : select case (fieldKind)
1891 : case (field_type_scalar)
1892 0 : isign = 1
1893 : case (field_type_vector)
1894 0 : isign = -1
1895 : case (field_type_angle)
1896 0 : isign = -1
1897 : case default
1898 0 : call abort_ice(subname//'ERROR: Unknown field kind')
1899 : end select
1900 :
1901 0 : if (halo%tripoleTFlag) then
1902 :
1903 0 : select case (fieldLoc)
1904 : case (field_loc_center) ! cell center location
1905 :
1906 0 : ioffset = -1
1907 0 : joffset = 0
1908 :
1909 : !*** top row is degenerate, so must enforce symmetry
1910 : !*** use average of two degenerate points for value
1911 :
1912 0 : do i = 2,nxGlobal/2
1913 0 : iDst = nxGlobal - i + 2
1914 0 : x1 = bufTripoleR4(i ,halo%tripoleRows)
1915 0 : x2 = bufTripoleR4(iDst,halo%tripoleRows)
1916 0 : xavg = 0.5_real_kind*(x1 + isign*x2)
1917 0 : bufTripoleR4(i ,halo%tripoleRows) = xavg
1918 0 : bufTripoleR4(iDst,halo%tripoleRows) = isign*xavg
1919 : end do
1920 :
1921 : case (field_loc_NEcorner) ! cell corner location
1922 :
1923 0 : ioffset = 0
1924 0 : joffset = 1
1925 :
1926 : case (field_loc_Eface) ! cell center location
1927 :
1928 0 : ioffset = 0
1929 0 : joffset = 0
1930 :
1931 : !*** top row is degenerate, so must enforce symmetry
1932 : !*** use average of two degenerate points for value
1933 :
1934 0 : do i = 1,nxGlobal/2
1935 0 : iDst = nxGlobal + 1 - i
1936 0 : x1 = bufTripoleR4(i ,halo%tripoleRows)
1937 0 : x2 = bufTripoleR4(iDst,halo%tripoleRows)
1938 0 : xavg = 0.5_real_kind*(x1 + isign*x2)
1939 0 : bufTripoleR4(i ,halo%tripoleRows) = xavg
1940 0 : bufTripoleR4(iDst,halo%tripoleRows) = isign*xavg
1941 : end do
1942 :
1943 : case (field_loc_Nface) ! cell corner (velocity) location
1944 :
1945 0 : ioffset = -1
1946 0 : joffset = 1
1947 :
1948 : case default
1949 0 : call abort_ice(subname//'ERROR: Unknown field location')
1950 : end select
1951 :
1952 : else ! tripole u-fold
1953 :
1954 0 : select case (fieldLoc)
1955 : case (field_loc_center) ! cell center location
1956 :
1957 0 : ioffset = 0
1958 0 : joffset = 0
1959 :
1960 : case (field_loc_NEcorner) ! cell corner location
1961 :
1962 0 : ioffset = 1
1963 0 : joffset = 1
1964 :
1965 : !*** top row is degenerate, so must enforce symmetry
1966 : !*** use average of two degenerate points for value
1967 :
1968 0 : do i = 1,nxGlobal/2 - 1
1969 0 : iDst = nxGlobal - i
1970 0 : x1 = bufTripoleR4(i ,halo%tripoleRows)
1971 0 : x2 = bufTripoleR4(iDst,halo%tripoleRows)
1972 0 : xavg = 0.5_real_kind*(x1 + isign*x2)
1973 0 : bufTripoleR4(i ,halo%tripoleRows) = xavg
1974 0 : bufTripoleR4(iDst,halo%tripoleRows) = isign*xavg
1975 : end do
1976 :
1977 : case (field_loc_Eface) ! cell center location
1978 :
1979 0 : ioffset = 1
1980 0 : joffset = 0
1981 :
1982 : case (field_loc_Nface) ! cell corner (velocity) location
1983 :
1984 0 : ioffset = 0
1985 0 : joffset = 1
1986 :
1987 : !*** top row is degenerate, so must enforce symmetry
1988 : !*** use average of two degenerate points for value
1989 :
1990 0 : do i = 1,nxGlobal/2
1991 0 : iDst = nxGlobal + 1 - i
1992 0 : x1 = bufTripoleR4(i ,halo%tripoleRows)
1993 0 : x2 = bufTripoleR4(iDst,halo%tripoleRows)
1994 0 : xavg = 0.5_real_kind*(x1 + isign*x2)
1995 0 : bufTripoleR4(i ,halo%tripoleRows) = xavg
1996 0 : bufTripoleR4(iDst,halo%tripoleRows) = isign*xavg
1997 : end do
1998 :
1999 : case default
2000 0 : call abort_ice(subname//'ERROR: Unknown field location')
2001 : end select
2002 :
2003 : endif
2004 :
2005 : !*** copy out of global tripole buffer into local
2006 : !*** ghost cells
2007 :
2008 : !*** look through local copies to find the copy out
2009 : !*** messages (srcBlock < 0)
2010 :
2011 0 : do nmsg=1,halo%numLocalCopies
2012 0 : srcBlock = halo%srcLocalAddr(3,nmsg)
2013 :
2014 0 : if (srcBlock < 0) then
2015 :
2016 0 : iSrc = halo%srcLocalAddr(1,nmsg) ! tripole buffer addr
2017 0 : jSrc = halo%srcLocalAddr(2,nmsg)
2018 :
2019 0 : iDst = halo%dstLocalAddr(1,nmsg) ! local block addr
2020 0 : jDst = halo%dstLocalAddr(2,nmsg)
2021 0 : dstBlock = halo%dstLocalAddr(3,nmsg)
2022 :
2023 : !*** correct for offsets
2024 0 : iSrc = iSrc - ioffset
2025 0 : jSrc = jSrc - joffset
2026 0 : if (iSrc < 1 ) iSrc = iSrc + nxGlobal
2027 0 : if (iSrc > nxGlobal) iSrc = iSrc - nxGlobal
2028 :
2029 : !*** for center and Eface on u-fold, and NE corner and Nface
2030 : !*** on T-fold, do not need to replace
2031 : !*** top row of physical domain, so jSrc should be
2032 : !*** out of range and skipped
2033 : !*** otherwise do the copy
2034 :
2035 0 : if (jSrc <= halo%tripoleRows .and. jSrc>0 .and. jDst>0) then
2036 0 : array(iDst,jDst,dstBlock) = isign*bufTripoleR4(iSrc,jSrc)
2037 : endif
2038 :
2039 : endif
2040 : end do
2041 :
2042 : endif
2043 :
2044 : !-----------------------------------------------------------------------
2045 : !
2046 : ! wait for sends to complete and deallocate arrays
2047 : !
2048 : !-----------------------------------------------------------------------
2049 :
2050 0 : call MPI_WAITALL(halo%numMsgSend, sndRequest, sndStatus, ierr)
2051 :
2052 0 : deallocate(sndRequest, rcvRequest, sndStatus, rcvStatus, stat=ierr)
2053 :
2054 0 : if (ierr > 0) then
2055 0 : call abort_ice(subname//'ERROR: deallocating req,status arrays')
2056 0 : return
2057 : endif
2058 :
2059 : !-----------------------------------------------------------------------
2060 :
2061 0 : end subroutine ice_HaloUpdate2DR4
2062 :
2063 : !***********************************************************************
2064 :
2065 5760 : subroutine ice_HaloUpdate2DI4(array, halo, &
2066 : fieldLoc, fieldKind, & ! LCOV_EXCL_LINE
2067 : fillValue)
2068 :
2069 : ! This routine updates ghost cells for an input array and is a
2070 : ! member of a group of routines under the generic interface
2071 : ! ice\_HaloUpdate. This routine is the specific interface
2072 : ! for 2d horizontal integer arrays.
2073 :
2074 : type (ice_halo), intent(in) :: &
2075 : halo ! precomputed halo structure containing all
2076 : ! information needed for halo update
2077 :
2078 : integer (int_kind), intent(in) :: &
2079 : fieldKind, &! id for type of field (scalar, vector, angle) ! LCOV_EXCL_LINE
2080 : fieldLoc ! id for location on horizontal grid
2081 : ! (center, NEcorner, Nface, Eface)
2082 :
2083 : integer (int_kind), intent(in), optional :: &
2084 : fillValue ! optional value to put in ghost cells
2085 : ! where neighbor points are unknown
2086 : ! (e.g. eliminated land blocks or
2087 : ! closed boundaries)
2088 :
2089 : integer (int_kind), dimension(:,:,:), intent(inout) :: &
2090 : array ! array containing field for which halo
2091 : ! needs to be updated
2092 :
2093 : !-----------------------------------------------------------------------
2094 : !
2095 : ! local variables
2096 : !
2097 : !-----------------------------------------------------------------------
2098 :
2099 : integer (int_kind) :: &
2100 : i,j,n,nmsg, &! dummy loop indices ! LCOV_EXCL_LINE
2101 : iblk,ilo,ihi,jlo,jhi, &! block sizes for fill ! LCOV_EXCL_LINE
2102 : ierr, &! error or status flag for MPI,alloc ! LCOV_EXCL_LINE
2103 : nxGlobal, &! global domain size in x (tripole) ! LCOV_EXCL_LINE
2104 : iSrc,jSrc, &! source addresses for message ! LCOV_EXCL_LINE
2105 : iDst,jDst, &! dest addresses for message ! LCOV_EXCL_LINE
2106 : srcBlock, &! local block number for source ! LCOV_EXCL_LINE
2107 : dstBlock, &! local block number for destination ! LCOV_EXCL_LINE
2108 : ioffset, joffset, &! address shifts for tripole ! LCOV_EXCL_LINE
2109 : isign ! sign factor for tripole grids
2110 :
2111 : integer (int_kind), dimension(:), allocatable :: &
2112 : sndRequest, &! MPI request ids ! LCOV_EXCL_LINE
2113 5760 : rcvRequest ! MPI request ids
2114 :
2115 : integer (int_kind), dimension(:,:), allocatable :: &
2116 : sndStatus, &! MPI status flags ! LCOV_EXCL_LINE
2117 5760 : rcvStatus ! MPI status flags
2118 :
2119 : integer (int_kind) :: &
2120 : fill, &! value to use for unknown points ! LCOV_EXCL_LINE
2121 : x1,x2,xavg ! scalars for enforcing symmetry at U pts
2122 :
2123 : integer (int_kind) :: len ! length of messages
2124 :
2125 : character(len=*), parameter :: subname = '(ice_HaloUpdate2DI4)'
2126 :
2127 : !-----------------------------------------------------------------------
2128 : !
2129 : ! abort or return on unknown or noupdate field_loc or field_type
2130 : !
2131 : !-----------------------------------------------------------------------
2132 :
2133 5760 : if (fieldLoc == field_loc_unknown .or. &
2134 : fieldKind == field_type_unknown) then
2135 0 : call abort_ice(subname//'ERROR: use of field_loc/type_unknown not allowed')
2136 0 : return
2137 : endif
2138 :
2139 5760 : if (fieldLoc == field_loc_noupdate .or. &
2140 : fieldKind == field_type_noupdate) then
2141 0 : return
2142 : endif
2143 :
2144 : !-----------------------------------------------------------------------
2145 : !
2146 : ! initialize error code and fill value
2147 : !
2148 : !-----------------------------------------------------------------------
2149 :
2150 5760 : if (present(fillValue)) then
2151 0 : fill = fillValue
2152 : else
2153 5760 : fill = 0_int_kind
2154 : endif
2155 :
2156 5760 : nxGlobal = 0
2157 5760 : if (allocated(bufTripoleI4)) then
2158 0 : nxGlobal = size(bufTripoleI4,dim=1)
2159 0 : bufTripoleI4 = fill
2160 : endif
2161 :
2162 : !-----------------------------------------------------------------------
2163 : !
2164 : ! allocate request and status arrays for messages
2165 : !
2166 : !-----------------------------------------------------------------------
2167 :
2168 : allocate(sndRequest(halo%numMsgSend), &
2169 : rcvRequest(halo%numMsgRecv), & ! LCOV_EXCL_LINE
2170 : sndStatus(MPI_STATUS_SIZE,halo%numMsgSend), & ! LCOV_EXCL_LINE
2171 5760 : rcvStatus(MPI_STATUS_SIZE,halo%numMsgRecv), stat=ierr)
2172 :
2173 5760 : if (ierr > 0) then
2174 0 : call abort_ice(subname//'ERROR: allocating req,status arrays')
2175 0 : return
2176 : endif
2177 :
2178 : !-----------------------------------------------------------------------
2179 : !
2180 : ! post receives
2181 : !
2182 : !-----------------------------------------------------------------------
2183 :
2184 32640 : do nmsg=1,halo%numMsgRecv
2185 :
2186 26880 : len = halo%SizeRecv(nmsg)
2187 0 : call MPI_IRECV(bufRecvI4(1:len,nmsg), len, MPI_INTEGER, &
2188 : halo%recvTask(nmsg), & ! LCOV_EXCL_LINE
2189 : mpitagHalo + halo%recvTask(nmsg), & ! LCOV_EXCL_LINE
2190 32640 : halo%communicator, rcvRequest(nmsg), ierr)
2191 : end do
2192 :
2193 : !-----------------------------------------------------------------------
2194 : !
2195 : ! fill send buffer and post sends
2196 : !
2197 : !-----------------------------------------------------------------------
2198 :
2199 32640 : do nmsg=1,halo%numMsgSend
2200 :
2201 1479360 : do n=1,halo%sizeSend(nmsg)
2202 1452480 : iSrc = halo%sendAddr(1,n,nmsg)
2203 1452480 : jSrc = halo%sendAddr(2,n,nmsg)
2204 1452480 : srcBlock = halo%sendAddr(3,n,nmsg)
2205 :
2206 1479360 : bufSendI4(n,nmsg) = array(iSrc,jSrc,srcBlock)
2207 : end do
2208 2164800 : do n=halo%sizeSend(nmsg)+1,bufSizeSend
2209 2164800 : bufSendI4(n,nmsg) = fill ! fill remainder of buffer
2210 : end do
2211 :
2212 26880 : len = halo%SizeSend(nmsg)
2213 0 : call MPI_ISEND(bufSendI4(1:len,nmsg), len, MPI_INTEGER, &
2214 : halo%sendTask(nmsg), & ! LCOV_EXCL_LINE
2215 : mpitagHalo + my_task, & ! LCOV_EXCL_LINE
2216 32640 : halo%communicator, sndRequest(nmsg), ierr)
2217 : end do
2218 :
2219 : !-----------------------------------------------------------------------
2220 : !
2221 : ! while messages are being communicated, fill out halo region
2222 : ! needed for masked halos to ensure halo values are filled for
2223 : ! halo grid cells that are not updated
2224 : !
2225 : !-----------------------------------------------------------------------
2226 :
2227 28680 : do iblk = 1, halo%numLocalBlocks
2228 0 : call get_block_parameter(halo%blockGlobalID(iblk), &
2229 : ilo=ilo, ihi=ihi, & ! LCOV_EXCL_LINE
2230 22920 : jlo=jlo, jhi=jhi)
2231 45840 : do j = 1,nghost
2232 492480 : array(1:nx_block, jlo-j,iblk) = fill
2233 515400 : array(1:nx_block, jhi+j,iblk) = fill
2234 : enddo
2235 74520 : do i = 1,nghost
2236 750720 : array(ilo-i, 1:ny_block,iblk) = fill
2237 773640 : array(ihi+i, 1:ny_block,iblk) = fill
2238 : enddo
2239 : enddo
2240 :
2241 : !-----------------------------------------------------------------------
2242 : !
2243 : ! do local copies while waiting for messages to complete
2244 : ! if srcBlock is zero, that denotes an eliminated land block or a
2245 : ! closed boundary where ghost cell values are undefined
2246 : ! if srcBlock is less than zero, the message is a copy out of the
2247 : ! tripole buffer and will be treated later
2248 : !
2249 : !-----------------------------------------------------------------------
2250 :
2251 621120 : do nmsg=1,halo%numLocalCopies
2252 615360 : iSrc = halo%srcLocalAddr(1,nmsg)
2253 615360 : jSrc = halo%srcLocalAddr(2,nmsg)
2254 615360 : srcBlock = halo%srcLocalAddr(3,nmsg)
2255 615360 : iDst = halo%dstLocalAddr(1,nmsg)
2256 615360 : jDst = halo%dstLocalAddr(2,nmsg)
2257 615360 : dstBlock = halo%dstLocalAddr(3,nmsg)
2258 :
2259 621120 : if (srcBlock > 0) then
2260 606720 : if (dstBlock > 0) then
2261 316800 : array(iDst,jDst,dstBlock) = &
2262 606720 : array(iSrc,jSrc,srcBlock)
2263 0 : else if (dstBlock < 0) then ! tripole copy into buffer
2264 0 : bufTripoleI4(iDst,jDst) = &
2265 0 : array(iSrc,jSrc,srcBlock)
2266 : endif
2267 8640 : else if (srcBlock == 0) then
2268 8640 : array(iDst,jDst,dstBlock) = fill
2269 : endif
2270 : end do
2271 :
2272 : !-----------------------------------------------------------------------
2273 : !
2274 : ! wait for receives to finish and then unpack the recv buffer into
2275 : ! ghost cells
2276 : !
2277 : !-----------------------------------------------------------------------
2278 :
2279 5760 : call MPI_WAITALL(halo%numMsgRecv, rcvRequest, rcvStatus, ierr)
2280 :
2281 32640 : do nmsg=1,halo%numMsgRecv
2282 1485120 : do n=1,halo%sizeRecv(nmsg)
2283 1452480 : iDst = halo%recvAddr(1,n,nmsg)
2284 1452480 : jDst = halo%recvAddr(2,n,nmsg)
2285 1452480 : dstBlock = halo%recvAddr(3,n,nmsg)
2286 :
2287 1479360 : if (dstBlock > 0) then
2288 1452480 : array(iDst,jDst,dstBlock) = bufRecvI4(n,nmsg)
2289 0 : else if (dstBlock < 0) then !tripole
2290 0 : bufTripoleI4(iDst,jDst) = bufRecvI4(n,nmsg)
2291 : endif
2292 : end do
2293 : end do
2294 :
2295 : !-----------------------------------------------------------------------
2296 : !
2297 : ! take care of northern boundary in tripole case
2298 : ! bufTripole array contains the top nghost+1 rows (u-fold) or nghost+2 rows
2299 : ! (T-fold) of physical domain for entire (global) top row
2300 : !
2301 : !-----------------------------------------------------------------------
2302 :
2303 5760 : if (nxGlobal > 0) then
2304 :
2305 0 : select case (fieldKind)
2306 : case (field_type_scalar)
2307 0 : isign = 1
2308 : case (field_type_vector)
2309 0 : isign = -1
2310 : case (field_type_angle)
2311 0 : isign = -1
2312 : case default
2313 0 : call abort_ice(subname//'ERROR: Unknown field kind')
2314 : end select
2315 :
2316 0 : if (halo%tripoleTFlag) then
2317 :
2318 0 : select case (fieldLoc)
2319 : case (field_loc_center) ! cell center location
2320 :
2321 0 : ioffset = -1
2322 0 : joffset = 0
2323 :
2324 : !*** top row is degenerate, so must enforce symmetry
2325 : !*** use average of two degenerate points for value
2326 :
2327 0 : do i = 2,nxGlobal/2
2328 0 : iDst = nxGlobal - i + 2
2329 0 : x1 = bufTripoleI4(i ,halo%tripoleRows)
2330 0 : x2 = bufTripoleI4(iDst,halo%tripoleRows)
2331 0 : xavg = nint(0.5_dbl_kind*(x1 + isign*x2))
2332 0 : bufTripoleI4(i ,halo%tripoleRows) = xavg
2333 0 : bufTripoleI4(iDst,halo%tripoleRows) = isign*xavg
2334 : end do
2335 :
2336 : case (field_loc_NEcorner) ! cell corner location
2337 :
2338 0 : ioffset = 0
2339 0 : joffset = 1
2340 :
2341 : case (field_loc_Eface) ! cell center location
2342 :
2343 0 : ioffset = 0
2344 0 : joffset = 0
2345 :
2346 : !*** top row is degenerate, so must enforce symmetry
2347 : !*** use average of two degenerate points for value
2348 :
2349 0 : do i = 1,nxGlobal/2
2350 0 : iDst = nxGlobal + 1 - i
2351 0 : x1 = bufTripoleI4(i ,halo%tripoleRows)
2352 0 : x2 = bufTripoleI4(iDst,halo%tripoleRows)
2353 0 : xavg = nint(0.5_dbl_kind*(x1 + isign*x2))
2354 0 : bufTripoleI4(i ,halo%tripoleRows) = xavg
2355 0 : bufTripoleI4(iDst,halo%tripoleRows) = isign*xavg
2356 : end do
2357 :
2358 : case (field_loc_Nface) ! cell corner (velocity) location
2359 :
2360 0 : ioffset = -1
2361 0 : joffset = 1
2362 :
2363 : case default
2364 0 : call abort_ice(subname//'ERROR: Unknown field location')
2365 : end select
2366 :
2367 : else ! tripole u-fold
2368 :
2369 0 : select case (fieldLoc)
2370 : case (field_loc_center) ! cell center location
2371 :
2372 0 : ioffset = 0
2373 0 : joffset = 0
2374 :
2375 : case (field_loc_NEcorner) ! cell corner location
2376 :
2377 0 : ioffset = 1
2378 0 : joffset = 1
2379 :
2380 : !*** top row is degenerate, so must enforce symmetry
2381 : !*** use average of two degenerate points for value
2382 :
2383 0 : do i = 1,nxGlobal/2 - 1
2384 0 : iDst = nxGlobal - i
2385 0 : x1 = bufTripoleI4(i ,halo%tripoleRows)
2386 0 : x2 = bufTripoleI4(iDst,halo%tripoleRows)
2387 0 : xavg = nint(0.5_dbl_kind*(x1 + isign*x2))
2388 0 : bufTripoleI4(i ,halo%tripoleRows) = xavg
2389 0 : bufTripoleI4(iDst,halo%tripoleRows) = isign*xavg
2390 : end do
2391 :
2392 : case (field_loc_Eface) ! cell center location
2393 :
2394 0 : ioffset = 1
2395 0 : joffset = 0
2396 :
2397 : case (field_loc_Nface) ! cell corner (velocity) location
2398 :
2399 0 : ioffset = 0
2400 0 : joffset = 1
2401 :
2402 : !*** top row is degenerate, so must enforce symmetry
2403 : !*** use average of two degenerate points for value
2404 :
2405 0 : do i = 1,nxGlobal/2
2406 0 : iDst = nxGlobal + 1 - i
2407 0 : x1 = bufTripoleI4(i ,halo%tripoleRows)
2408 0 : x2 = bufTripoleI4(iDst,halo%tripoleRows)
2409 0 : xavg = nint(0.5_dbl_kind*(x1 + isign*x2))
2410 0 : bufTripoleI4(i ,halo%tripoleRows) = xavg
2411 0 : bufTripoleI4(iDst,halo%tripoleRows) = isign*xavg
2412 : end do
2413 :
2414 : case default
2415 0 : call abort_ice(subname//'ERROR: Unknown field location')
2416 : end select
2417 :
2418 : endif
2419 :
2420 : !*** copy out of global tripole buffer into local
2421 : !*** ghost cells
2422 :
2423 : !*** look through local copies to find the copy out
2424 : !*** messages (srcBlock < 0)
2425 :
2426 0 : do nmsg=1,halo%numLocalCopies
2427 0 : srcBlock = halo%srcLocalAddr(3,nmsg)
2428 :
2429 0 : if (srcBlock < 0) then
2430 :
2431 0 : iSrc = halo%srcLocalAddr(1,nmsg) ! tripole buffer addr
2432 0 : jSrc = halo%srcLocalAddr(2,nmsg)
2433 :
2434 0 : iDst = halo%dstLocalAddr(1,nmsg) ! local block addr
2435 0 : jDst = halo%dstLocalAddr(2,nmsg)
2436 0 : dstBlock = halo%dstLocalAddr(3,nmsg)
2437 :
2438 : !*** correct for offsets
2439 0 : iSrc = iSrc - ioffset
2440 0 : jSrc = jSrc - joffset
2441 0 : if (iSrc < 1 ) iSrc = iSrc + nxGlobal
2442 0 : if (iSrc > nxGlobal) iSrc = iSrc - nxGlobal
2443 :
2444 : !*** for center and Eface on u-fold, and NE corner and Nface
2445 : !*** on T-fold, do not need to replace
2446 : !*** top row of physical domain, so jSrc should be
2447 : !*** out of range and skipped
2448 : !*** otherwise do the copy
2449 :
2450 0 : if (jSrc <= halo%tripoleRows .and. jSrc>0 .and. jDst>0) then
2451 0 : array(iDst,jDst,dstBlock) = isign*bufTripoleI4(iSrc,jSrc)
2452 : endif
2453 :
2454 : endif
2455 : end do
2456 :
2457 : endif
2458 :
2459 : !-----------------------------------------------------------------------
2460 : !
2461 : ! wait for sends to complete and deallocate arrays
2462 : !
2463 : !-----------------------------------------------------------------------
2464 :
2465 5760 : call MPI_WAITALL(halo%numMsgSend, sndRequest, sndStatus, ierr)
2466 :
2467 5760 : deallocate(sndRequest, rcvRequest, sndStatus, rcvStatus, stat=ierr)
2468 :
2469 5760 : if (ierr > 0) then
2470 0 : call abort_ice(subname//'ERROR: deallocating req,status arrays')
2471 0 : return
2472 : endif
2473 :
2474 : !-----------------------------------------------------------------------
2475 :
2476 17280 : end subroutine ice_HaloUpdate2DI4
2477 :
2478 : !***********************************************************************
2479 :
2480 5760 : subroutine ice_HaloUpdate2DL1(array, halo, &
2481 : fieldLoc, fieldKind, & ! LCOV_EXCL_LINE
2482 : fillValue)
2483 :
2484 : ! This routine updates ghost cells for an input array and is a
2485 : ! member of a group of routines under the generic interface
2486 : ! ice\_HaloUpdate. This routine is the specific interface
2487 : ! for 2d horizontal logical arrays.
2488 :
2489 : type (ice_halo), intent(in) :: &
2490 : halo ! precomputed halo structure containing all
2491 : ! information needed for halo update
2492 :
2493 : integer (int_kind), intent(in) :: &
2494 : fieldKind, &! id for type of field (scalar, vector, angle) ! LCOV_EXCL_LINE
2495 : fieldLoc ! id for location on horizontal grid
2496 : ! (center, NEcorner, Nface, Eface)
2497 :
2498 : integer (int_kind), intent(in), optional :: &
2499 : fillValue ! optional value to put in ghost cells
2500 : ! where neighbor points are unknown
2501 : ! (e.g. eliminated land blocks or
2502 : ! closed boundaries)
2503 :
2504 : logical (log_kind), dimension(:,:,:), intent(inout) :: &
2505 : array ! array containing field for which halo
2506 : ! needs to be updated
2507 :
2508 : !-----------------------------------------------------------------------
2509 : !
2510 : ! local variables
2511 : !
2512 : !-----------------------------------------------------------------------
2513 :
2514 : integer (int_kind), dimension(:,:,:), allocatable :: &
2515 5760 : iarray ! integer array for logical
2516 :
2517 : character(len=*), parameter :: subname = '(ice_HaloUpdate2DL1)'
2518 :
2519 : !-----------------------------------------------------------------------
2520 : !
2521 : ! abort or return on unknown or noupdate field_loc or field_type
2522 : !
2523 : !-----------------------------------------------------------------------
2524 :
2525 5760 : if (fieldLoc == field_loc_unknown .or. &
2526 : fieldKind == field_type_unknown) then
2527 0 : call abort_ice(subname//'ERROR: use of field_loc/type_unknown not allowed')
2528 0 : return
2529 : endif
2530 :
2531 5760 : if (fieldLoc == field_loc_noupdate .or. &
2532 : fieldKind == field_type_noupdate) then
2533 0 : return
2534 : endif
2535 :
2536 : !-----------------------------------------------------------------------
2537 : !
2538 : ! copy logical into integer array and call haloupdate on integer array
2539 : !
2540 : !-----------------------------------------------------------------------
2541 :
2542 5760 : allocate(iarray(size(array,dim=1),size(array,dim=2),size(array,dim=3)))
2543 15930240 : iarray(:,:,:) = 0
2544 15930240 : where (array) iarray = 1
2545 :
2546 : call ice_HaloUpdate(iarray, halo, &
2547 : fieldLoc, fieldKind, & ! LCOV_EXCL_LINE
2548 5760 : fillValue)
2549 :
2550 15930240 : array = .false.
2551 15930240 : where (iarray /= 0) array = .true.
2552 5760 : deallocate(iarray)
2553 :
2554 : !-----------------------------------------------------------------------
2555 :
2556 5760 : end subroutine ice_HaloUpdate2DL1
2557 :
2558 : !***********************************************************************
2559 :
2560 316908 : subroutine ice_HaloUpdate3DR8(array, halo, &
2561 : fieldLoc, fieldKind, & ! LCOV_EXCL_LINE
2562 : fillValue)
2563 :
2564 : ! This routine updates ghost cells for an input array and is a
2565 : ! member of a group of routines under the generic interface
2566 : ! ice\_HaloUpdate. This routine is the specific interface
2567 : ! for 3d horizontal arrays of double precision.
2568 :
2569 : type (ice_halo), intent(in) :: &
2570 : halo ! precomputed halo structure containing all
2571 : ! information needed for halo update
2572 :
2573 : integer (int_kind), intent(in) :: &
2574 : fieldKind, &! id for type of field (scalar, vector, angle) ! LCOV_EXCL_LINE
2575 : fieldLoc ! id for location on horizontal grid
2576 : ! (center, NEcorner, Nface, Eface)
2577 :
2578 : real (dbl_kind), intent(in), optional :: &
2579 : fillValue ! optional value to put in ghost cells
2580 : ! where neighbor points are unknown
2581 : ! (e.g. eliminated land blocks or
2582 : ! closed boundaries)
2583 :
2584 : real (dbl_kind), dimension(:,:,:,:), intent(inout) :: &
2585 : array ! array containing field for which halo
2586 : ! needs to be updated
2587 :
2588 : !-----------------------------------------------------------------------
2589 : !
2590 : ! local variables
2591 : !
2592 : !-----------------------------------------------------------------------
2593 :
2594 : integer (int_kind) :: &
2595 : i,j,k,n,nmsg, &! dummy loop indices ! LCOV_EXCL_LINE
2596 : iblk,ilo,ihi,jlo,jhi, &! block sizes for fill ! LCOV_EXCL_LINE
2597 : ierr, &! error or status flag for MPI,alloc ! LCOV_EXCL_LINE
2598 : nxGlobal, &! global domain size in x (tripole) ! LCOV_EXCL_LINE
2599 : nz, &! size of array in 3rd dimension ! LCOV_EXCL_LINE
2600 : iSrc,jSrc, &! source addresses for message ! LCOV_EXCL_LINE
2601 : iDst,jDst, &! dest addresses for message ! LCOV_EXCL_LINE
2602 : srcBlock, &! local block number for source ! LCOV_EXCL_LINE
2603 : dstBlock, &! local block number for destination ! LCOV_EXCL_LINE
2604 : ioffset, joffset, &! address shifts for tripole ! LCOV_EXCL_LINE
2605 : isign ! sign factor for tripole grids
2606 :
2607 : integer (int_kind), dimension(:), allocatable :: &
2608 : sndRequest, &! MPI request ids ! LCOV_EXCL_LINE
2609 316908 : rcvRequest ! MPI request ids
2610 :
2611 : integer (int_kind), dimension(:,:), allocatable :: &
2612 : sndStatus, &! MPI status flags ! LCOV_EXCL_LINE
2613 316908 : rcvStatus ! MPI status flags
2614 :
2615 : real (dbl_kind) :: &
2616 : fill, &! value to use for unknown points ! LCOV_EXCL_LINE
2617 21624 : x1,x2,xavg ! scalars for enforcing symmetry at U pts
2618 :
2619 : real (dbl_kind), dimension(:,:), allocatable :: &
2620 316908 : bufSend, bufRecv ! 3d send,recv buffers
2621 :
2622 : real (dbl_kind), dimension(:,:,:), allocatable :: &
2623 316908 : bufTripole ! 3d tripole buffer
2624 :
2625 : integer (int_kind) :: len ! length of message
2626 :
2627 : character(len=*), parameter :: subname = '(ice_HaloUpdate3DR8)'
2628 :
2629 : !-----------------------------------------------------------------------
2630 : !
2631 : ! abort or return on unknown or noupdate field_loc or field_type
2632 : !
2633 : !-----------------------------------------------------------------------
2634 :
2635 316908 : if (fieldLoc == field_loc_unknown .or. &
2636 : fieldKind == field_type_unknown) then
2637 0 : call abort_ice(subname//'ERROR: use of field_loc/type_unknown not allowed')
2638 0 : return
2639 : endif
2640 :
2641 316908 : if (fieldLoc == field_loc_noupdate .or. &
2642 : fieldKind == field_type_noupdate) then
2643 0 : return
2644 : endif
2645 :
2646 : !-----------------------------------------------------------------------
2647 : !
2648 : ! initialize error code and fill value
2649 : !
2650 : !-----------------------------------------------------------------------
2651 :
2652 316908 : if (present(fillValue)) then
2653 0 : fill = fillValue
2654 : else
2655 316908 : fill = 0.0_dbl_kind
2656 : endif
2657 :
2658 316908 : nxGlobal = 0
2659 316908 : if (allocated(bufTripoleR8)) nxGlobal = size(bufTripoleR8,dim=1)
2660 :
2661 : !-----------------------------------------------------------------------
2662 : !
2663 : ! allocate request and status arrays for messages
2664 : !
2665 : !-----------------------------------------------------------------------
2666 :
2667 : allocate(sndRequest(halo%numMsgSend), &
2668 : rcvRequest(halo%numMsgRecv), & ! LCOV_EXCL_LINE
2669 : sndStatus(MPI_STATUS_SIZE,halo%numMsgSend), & ! LCOV_EXCL_LINE
2670 316908 : rcvStatus(MPI_STATUS_SIZE,halo%numMsgRecv), stat=ierr)
2671 :
2672 316908 : if (ierr > 0) then
2673 0 : call abort_ice(subname//'ERROR: allocating req,status arrays')
2674 0 : return
2675 : endif
2676 :
2677 : !-----------------------------------------------------------------------
2678 : !
2679 : ! allocate 3D buffers
2680 : !
2681 : !-----------------------------------------------------------------------
2682 :
2683 316908 : nz = size(array, dim=3)
2684 :
2685 : allocate(bufSend(bufSizeSend*nz, halo%numMsgSend), &
2686 : bufRecv(bufSizeRecv*nz, halo%numMsgRecv), & ! LCOV_EXCL_LINE
2687 : bufTripole(nxGlobal, halo%tripoleRows, nz), & ! LCOV_EXCL_LINE
2688 316908 : stat=ierr)
2689 :
2690 316908 : if (ierr > 0) then
2691 0 : call abort_ice(subname//'ERROR: allocating buffers')
2692 0 : return
2693 : endif
2694 :
2695 2945088 : bufTripole = fill
2696 :
2697 : !-----------------------------------------------------------------------
2698 : !
2699 : ! post receives
2700 : !
2701 : !-----------------------------------------------------------------------
2702 :
2703 2333424 : do nmsg=1,halo%numMsgRecv
2704 :
2705 2016516 : len = halo%SizeRecv(nmsg)*nz
2706 0 : call MPI_IRECV(bufRecv(1:len,nmsg), len, mpiR8, &
2707 : halo%recvTask(nmsg), & ! LCOV_EXCL_LINE
2708 : mpitagHalo + halo%recvTask(nmsg), & ! LCOV_EXCL_LINE
2709 2333424 : halo%communicator, rcvRequest(nmsg), ierr)
2710 : end do
2711 :
2712 : !-----------------------------------------------------------------------
2713 : !
2714 : ! fill send buffer and post sends
2715 : !
2716 : !-----------------------------------------------------------------------
2717 :
2718 2333424 : do nmsg=1,halo%numMsgSend
2719 :
2720 2016516 : i=0
2721 177510756 : do n=1,halo%sizeSend(nmsg)
2722 175494240 : iSrc = halo%sendAddr(1,n,nmsg)
2723 175494240 : jSrc = halo%sendAddr(2,n,nmsg)
2724 175494240 : srcBlock = halo%sendAddr(3,n,nmsg)
2725 :
2726 589594116 : do k=1,nz
2727 412083360 : i = i + 1
2728 587577600 : bufSend(i,nmsg) = array(iSrc,jSrc,k,srcBlock)
2729 : end do
2730 : end do
2731 784253556 : do n=i+1,bufSizeSend*nz
2732 784253556 : bufSend(n,nmsg) = fill ! fill remainder of buffer
2733 : end do
2734 :
2735 2016516 : len = halo%SizeSend(nmsg)*nz
2736 0 : call MPI_ISEND(bufSend(1:len,nmsg), len, mpiR8, &
2737 : halo%sendTask(nmsg), & ! LCOV_EXCL_LINE
2738 : mpitagHalo + my_task, & ! LCOV_EXCL_LINE
2739 2333424 : halo%communicator, sndRequest(nmsg), ierr)
2740 : end do
2741 :
2742 : !-----------------------------------------------------------------------
2743 : !
2744 : ! while messages are being communicated, fill out halo region
2745 : ! needed for masked halos to ensure halo values are filled for
2746 : ! halo grid cells that are not updated
2747 : !
2748 : !-----------------------------------------------------------------------
2749 :
2750 2936385 : do iblk = 1, halo%numLocalBlocks
2751 0 : call get_block_parameter(halo%blockGlobalID(iblk), &
2752 : ilo=ilo, ihi=ihi, & ! LCOV_EXCL_LINE
2753 2619477 : jlo=jlo, jhi=jhi)
2754 5238954 : do j = 1,nghost
2755 74527677 : array(1:nx_block, jlo-j,:,iblk) = fill
2756 77147154 : array(1:nx_block, jhi+j,:,iblk) = fill
2757 : enddo
2758 8175339 : do i = 1,nghost
2759 202361877 : array(ilo-i, 1:ny_block,:,iblk) = fill
2760 204981354 : array(ihi+i, 1:ny_block,:,iblk) = fill
2761 : enddo
2762 : enddo
2763 :
2764 : !-----------------------------------------------------------------------
2765 : !
2766 : ! do local copies while waiting for messages to complete
2767 : ! if srcBlock is zero, that denotes an eliminated land block or a
2768 : ! closed boundary where ghost cell values are undefined
2769 : ! if srcBlock is less than zero, the message is a copy out of the
2770 : ! tripole buffer and will be treated later
2771 : !
2772 : !-----------------------------------------------------------------------
2773 :
2774 11632116 : do nmsg=1,halo%numLocalCopies
2775 11315208 : iSrc = halo%srcLocalAddr(1,nmsg)
2776 11315208 : jSrc = halo%srcLocalAddr(2,nmsg)
2777 11315208 : srcBlock = halo%srcLocalAddr(3,nmsg)
2778 11315208 : iDst = halo%dstLocalAddr(1,nmsg)
2779 11315208 : jDst = halo%dstLocalAddr(2,nmsg)
2780 11315208 : dstBlock = halo%dstLocalAddr(3,nmsg)
2781 :
2782 11632116 : if (srcBlock > 0) then
2783 9111792 : if (dstBlock > 0) then
2784 52850592 : do k=1,nz
2785 22836000 : array(iDst,jDst,k,dstBlock) = &
2786 52850592 : array(iSrc,jSrc,k,srcBlock)
2787 : end do
2788 0 : else if (dstBlock < 0) then ! tripole copy into buffer
2789 0 : do k=1,nz
2790 0 : bufTripole(iDst,jDst,k) = &
2791 0 : array(iSrc,jSrc,k,srcBlock)
2792 : end do
2793 : endif
2794 2203416 : else if (srcBlock == 0) then
2795 6973776 : do k=1,nz
2796 6973776 : array(iDst,jDst,k,dstBlock) = fill
2797 : end do
2798 : endif
2799 : end do
2800 :
2801 : !-----------------------------------------------------------------------
2802 : !
2803 : ! wait for receives to finish and then unpack the recv buffer into
2804 : ! ghost cells
2805 : !
2806 : !-----------------------------------------------------------------------
2807 :
2808 316908 : call MPI_WAITALL(halo%numMsgRecv, rcvRequest, rcvStatus, ierr)
2809 :
2810 2333424 : do nmsg=1,halo%numMsgRecv
2811 2016516 : i = 0
2812 177827664 : do n=1,halo%sizeRecv(nmsg)
2813 175494240 : iDst = halo%recvAddr(1,n,nmsg)
2814 175494240 : jDst = halo%recvAddr(2,n,nmsg)
2815 175494240 : dstBlock = halo%recvAddr(3,n,nmsg)
2816 :
2817 177510756 : if (dstBlock > 0) then
2818 587577600 : do k=1,nz
2819 412083360 : i = i + 1
2820 587577600 : array(iDst,jDst,k,dstBlock) = bufRecv(i,nmsg)
2821 : end do
2822 0 : else if (dstBlock < 0) then !tripole
2823 0 : do k=1,nz
2824 0 : i = i + 1
2825 0 : bufTripole(iDst,jDst,k) = bufRecv(i,nmsg)
2826 : end do
2827 : endif
2828 : end do
2829 : end do
2830 :
2831 : !-----------------------------------------------------------------------
2832 : !
2833 : ! take care of northern boundary in tripole case
2834 : ! bufTripole array contains the top nghost+1 rows (u-fold) or nghost+2 rows
2835 : ! (T-fold) of physical domain for entire (global) top row
2836 : !
2837 : !-----------------------------------------------------------------------
2838 :
2839 316908 : if (nxGlobal > 0) then
2840 :
2841 0 : select case (fieldKind)
2842 : case (field_type_scalar)
2843 0 : isign = 1
2844 : case (field_type_vector)
2845 0 : isign = -1
2846 : case (field_type_angle)
2847 0 : isign = -1
2848 : case default
2849 0 : call abort_ice(subname//'ERROR: Unknown field kind')
2850 : end select
2851 :
2852 0 : if (halo%tripoleTFlag) then
2853 :
2854 0 : select case (fieldLoc)
2855 : case (field_loc_center) ! cell center location
2856 :
2857 0 : ioffset = -1
2858 0 : joffset = 0
2859 :
2860 : !*** top row is degenerate, so must enforce symmetry
2861 : !*** use average of two degenerate points for value
2862 :
2863 0 : do k=1,nz
2864 0 : do i = 2,nxGlobal/2
2865 0 : iDst = nxGlobal - i + 2
2866 0 : x1 = bufTripole(i ,halo%tripoleRows,k)
2867 0 : x2 = bufTripole(iDst,halo%tripoleRows,k)
2868 0 : xavg = 0.5_dbl_kind*(x1 + isign*x2)
2869 0 : bufTripole(i ,halo%tripoleRows,k) = xavg
2870 0 : bufTripole(iDst,halo%tripoleRows,k) = isign*xavg
2871 : end do
2872 : end do
2873 :
2874 : case (field_loc_NEcorner) ! cell corner location
2875 :
2876 0 : ioffset = 0
2877 0 : joffset = 1
2878 :
2879 : case (field_loc_Eface) ! cell center location
2880 :
2881 0 : ioffset = 0
2882 0 : joffset = 0
2883 :
2884 : !*** top row is degenerate, so must enforce symmetry
2885 : !*** use average of two degenerate points for value
2886 :
2887 0 : do k=1,nz
2888 0 : do i = 1,nxGlobal/2
2889 0 : iDst = nxGlobal + 1 - i
2890 0 : x1 = bufTripole(i ,halo%tripoleRows,k)
2891 0 : x2 = bufTripole(iDst,halo%tripoleRows,k)
2892 0 : xavg = 0.5_dbl_kind*(x1 + isign*x2)
2893 0 : bufTripole(i ,halo%tripoleRows,k) = xavg
2894 0 : bufTripole(iDst,halo%tripoleRows,k) = isign*xavg
2895 : end do
2896 : end do
2897 :
2898 : case (field_loc_Nface) ! cell corner (velocity) location
2899 :
2900 0 : ioffset = -1
2901 0 : joffset = 1
2902 :
2903 : case default
2904 0 : call abort_ice(subname//'ERROR: Unknown field location')
2905 : end select
2906 :
2907 : else ! tripole u-fold
2908 :
2909 0 : select case (fieldLoc)
2910 : case (field_loc_center) ! cell center location
2911 :
2912 0 : ioffset = 0
2913 0 : joffset = 0
2914 :
2915 : case (field_loc_NEcorner) ! cell corner location
2916 :
2917 0 : ioffset = 1
2918 0 : joffset = 1
2919 :
2920 : !*** top row is degenerate, so must enforce symmetry
2921 : !*** use average of two degenerate points for value
2922 :
2923 0 : do k=1,nz
2924 0 : do i = 1,nxGlobal/2 - 1
2925 0 : iDst = nxGlobal - i
2926 0 : x1 = bufTripole(i ,halo%tripoleRows,k)
2927 0 : x2 = bufTripole(iDst,halo%tripoleRows,k)
2928 0 : xavg = 0.5_dbl_kind*(x1 + isign*x2)
2929 0 : bufTripole(i ,halo%tripoleRows,k) = xavg
2930 0 : bufTripole(iDst,halo%tripoleRows,k) = isign*xavg
2931 : end do
2932 : end do
2933 :
2934 : case (field_loc_Eface) ! cell center location
2935 :
2936 0 : ioffset = 1
2937 0 : joffset = 0
2938 :
2939 : case (field_loc_Nface) ! cell corner (velocity) location
2940 :
2941 0 : ioffset = 0
2942 0 : joffset = 1
2943 :
2944 : !*** top row is degenerate, so must enforce symmetry
2945 : !*** use average of two degenerate points for value
2946 :
2947 0 : do k=1,nz
2948 0 : do i = 1,nxGlobal/2
2949 0 : iDst = nxGlobal + 1 - i
2950 0 : x1 = bufTripole(i ,halo%tripoleRows,k)
2951 0 : x2 = bufTripole(iDst,halo%tripoleRows,k)
2952 0 : xavg = 0.5_dbl_kind*(x1 + isign*x2)
2953 0 : bufTripole(i ,halo%tripoleRows,k) = xavg
2954 0 : bufTripole(iDst,halo%tripoleRows,k) = isign*xavg
2955 : end do
2956 : end do
2957 :
2958 : case default
2959 0 : call abort_ice(subname//'ERROR: Unknown field location')
2960 : end select
2961 :
2962 : endif
2963 :
2964 : !*** copy out of global tripole buffer into local
2965 : !*** ghost cells
2966 :
2967 : !*** look through local copies to find the copy out
2968 : !*** messages (srcBlock < 0)
2969 :
2970 0 : do nmsg=1,halo%numLocalCopies
2971 0 : srcBlock = halo%srcLocalAddr(3,nmsg)
2972 :
2973 0 : if (srcBlock < 0) then
2974 :
2975 0 : iSrc = halo%srcLocalAddr(1,nmsg) ! tripole buffer addr
2976 0 : jSrc = halo%srcLocalAddr(2,nmsg)
2977 :
2978 0 : iDst = halo%dstLocalAddr(1,nmsg) ! local block addr
2979 0 : jDst = halo%dstLocalAddr(2,nmsg)
2980 0 : dstBlock = halo%dstLocalAddr(3,nmsg)
2981 :
2982 : !*** correct for offsets
2983 0 : iSrc = iSrc - ioffset
2984 0 : jSrc = jSrc - joffset
2985 0 : if (iSrc < 1 ) iSrc = iSrc + nxGlobal
2986 0 : if (iSrc > nxGlobal) iSrc = iSrc - nxGlobal
2987 :
2988 : !*** for center and Eface on u-fold, and NE corner and Nface
2989 : !*** on T-fold, do not need to replace
2990 : !*** top row of physical domain, so jSrc should be
2991 : !*** out of range and skipped
2992 : !*** otherwise do the copy
2993 :
2994 0 : if (jSrc <= halo%tripoleRows .and. jSrc>0 .and. jDst>0) then
2995 0 : do k=1,nz
2996 0 : array(iDst,jDst,k,dstBlock) = isign* &
2997 0 : bufTripole(iSrc,jSrc,k)
2998 : end do
2999 : endif
3000 :
3001 : endif
3002 : end do
3003 :
3004 : endif
3005 :
3006 : !-----------------------------------------------------------------------
3007 : !
3008 : ! wait for sends to complete and deallocate arrays
3009 : !
3010 : !-----------------------------------------------------------------------
3011 :
3012 316908 : call MPI_WAITALL(halo%numMsgSend, sndRequest, sndStatus, ierr)
3013 :
3014 316908 : deallocate(sndRequest, rcvRequest, sndStatus, rcvStatus, stat=ierr)
3015 :
3016 316908 : if (ierr > 0) then
3017 0 : call abort_ice(subname//'ERROR: deallocating req,status arrays')
3018 0 : return
3019 : endif
3020 :
3021 316908 : deallocate(bufSend, bufRecv, bufTripole, stat=ierr)
3022 :
3023 316908 : if (ierr > 0) then
3024 0 : call abort_ice(subname//'ERROR: deallocating 3d buffers')
3025 0 : return
3026 : endif
3027 :
3028 : !-----------------------------------------------------------------------
3029 :
3030 950724 : end subroutine ice_HaloUpdate3DR8
3031 :
3032 : !***********************************************************************
3033 :
3034 0 : subroutine ice_HaloUpdate3DR4(array, halo, &
3035 : fieldLoc, fieldKind, & ! LCOV_EXCL_LINE
3036 : fillValue)
3037 :
3038 : ! This routine updates ghost cells for an input array and is a
3039 : ! member of a group of routines under the generic interface
3040 : ! ice\_HaloUpdate. This routine is the specific interface
3041 : ! for 3d horizontal arrays of single precision.
3042 :
3043 : type (ice_halo), intent(in) :: &
3044 : halo ! precomputed halo structure containing all
3045 : ! information needed for halo update
3046 :
3047 : integer (int_kind), intent(in) :: &
3048 : fieldKind, &! id for type of field (scalar, vector, angle) ! LCOV_EXCL_LINE
3049 : fieldLoc ! id for location on horizontal grid
3050 : ! (center, NEcorner, Nface, Eface)
3051 :
3052 : real (real_kind), intent(in), optional :: &
3053 : fillValue ! optional value to put in ghost cells
3054 : ! where neighbor points are unknown
3055 : ! (e.g. eliminated land blocks or
3056 : ! closed boundaries)
3057 :
3058 : real (real_kind), dimension(:,:,:,:), intent(inout) :: &
3059 : array ! array containing field for which halo
3060 : ! needs to be updated
3061 :
3062 : !-----------------------------------------------------------------------
3063 : !
3064 : ! local variables
3065 : !
3066 : !-----------------------------------------------------------------------
3067 :
3068 : integer (int_kind) :: &
3069 : i,j,k,n,nmsg, &! dummy loop indices ! LCOV_EXCL_LINE
3070 : iblk,ilo,ihi,jlo,jhi, &! block sizes for fill ! LCOV_EXCL_LINE
3071 : ierr, &! error or status flag for MPI,alloc ! LCOV_EXCL_LINE
3072 : nxGlobal, &! global domain size in x (tripole) ! LCOV_EXCL_LINE
3073 : nz, &! size of array in 3rd dimension ! LCOV_EXCL_LINE
3074 : iSrc,jSrc, &! source addresses for message ! LCOV_EXCL_LINE
3075 : iDst,jDst, &! dest addresses for message ! LCOV_EXCL_LINE
3076 : srcBlock, &! local block number for source ! LCOV_EXCL_LINE
3077 : dstBlock, &! local block number for destination ! LCOV_EXCL_LINE
3078 : ioffset, joffset, &! address shifts for tripole ! LCOV_EXCL_LINE
3079 : isign ! sign factor for tripole grids
3080 :
3081 : integer (int_kind), dimension(:), allocatable :: &
3082 : sndRequest, &! MPI request ids ! LCOV_EXCL_LINE
3083 0 : rcvRequest ! MPI request ids
3084 :
3085 : integer (int_kind), dimension(:,:), allocatable :: &
3086 : sndStatus, &! MPI status flags ! LCOV_EXCL_LINE
3087 0 : rcvStatus ! MPI status flags
3088 :
3089 : real (real_kind) :: &
3090 : fill, &! value to use for unknown points ! LCOV_EXCL_LINE
3091 0 : x1,x2,xavg ! scalars for enforcing symmetry at U pts
3092 :
3093 : real (real_kind), dimension(:,:), allocatable :: &
3094 0 : bufSend, bufRecv ! 3d send,recv buffers
3095 :
3096 : real (real_kind), dimension(:,:,:), allocatable :: &
3097 0 : bufTripole ! 3d tripole buffer
3098 :
3099 : integer (int_kind) :: len ! length of message
3100 :
3101 : character(len=*), parameter :: subname = '(ice_HaloUpdate3DR4)'
3102 :
3103 : !-----------------------------------------------------------------------
3104 : !
3105 : ! abort or return on unknown or noupdate field_loc or field_type
3106 : !
3107 : !-----------------------------------------------------------------------
3108 :
3109 0 : if (fieldLoc == field_loc_unknown .or. &
3110 : fieldKind == field_type_unknown) then
3111 0 : call abort_ice(subname//'ERROR: use of field_loc/type_unknown not allowed')
3112 0 : return
3113 : endif
3114 :
3115 0 : if (fieldLoc == field_loc_noupdate .or. &
3116 : fieldKind == field_type_noupdate) then
3117 0 : return
3118 : endif
3119 :
3120 : !-----------------------------------------------------------------------
3121 : !
3122 : ! initialize error code and fill value
3123 : !
3124 : !-----------------------------------------------------------------------
3125 :
3126 0 : if (present(fillValue)) then
3127 0 : fill = fillValue
3128 : else
3129 0 : fill = 0.0_real_kind
3130 : endif
3131 :
3132 0 : nxGlobal = 0
3133 0 : if (allocated(bufTripoleR4)) nxGlobal = size(bufTripoleR4,dim=1)
3134 :
3135 : !-----------------------------------------------------------------------
3136 : !
3137 : ! allocate request and status arrays for messages
3138 : !
3139 : !-----------------------------------------------------------------------
3140 :
3141 : allocate(sndRequest(halo%numMsgSend), &
3142 : rcvRequest(halo%numMsgRecv), & ! LCOV_EXCL_LINE
3143 : sndStatus(MPI_STATUS_SIZE,halo%numMsgSend), & ! LCOV_EXCL_LINE
3144 0 : rcvStatus(MPI_STATUS_SIZE,halo%numMsgRecv), stat=ierr)
3145 :
3146 0 : if (ierr > 0) then
3147 0 : call abort_ice(subname//'ERROR: allocating req,status arrays')
3148 0 : return
3149 : endif
3150 :
3151 : !-----------------------------------------------------------------------
3152 : !
3153 : ! allocate 3D buffers
3154 : !
3155 : !-----------------------------------------------------------------------
3156 :
3157 0 : nz = size(array, dim=3)
3158 :
3159 : allocate(bufSend(bufSizeSend*nz, halo%numMsgSend), &
3160 : bufRecv(bufSizeRecv*nz, halo%numMsgRecv), & ! LCOV_EXCL_LINE
3161 : bufTripole(nxGlobal, halo%tripoleRows, nz), & ! LCOV_EXCL_LINE
3162 0 : stat=ierr)
3163 :
3164 0 : if (ierr > 0) then
3165 0 : call abort_ice(subname//'ERROR: allocating buffers')
3166 0 : return
3167 : endif
3168 :
3169 0 : bufTripole = fill
3170 :
3171 : !-----------------------------------------------------------------------
3172 : !
3173 : ! post receives
3174 : !
3175 : !-----------------------------------------------------------------------
3176 :
3177 0 : do nmsg=1,halo%numMsgRecv
3178 :
3179 0 : len = halo%SizeRecv(nmsg)*nz
3180 0 : call MPI_IRECV(bufRecv(1:len,nmsg), len, mpiR4, &
3181 : halo%recvTask(nmsg), & ! LCOV_EXCL_LINE
3182 : mpitagHalo + halo%recvTask(nmsg), & ! LCOV_EXCL_LINE
3183 0 : halo%communicator, rcvRequest(nmsg), ierr)
3184 : end do
3185 :
3186 : !-----------------------------------------------------------------------
3187 : !
3188 : ! fill send buffer and post sends
3189 : !
3190 : !-----------------------------------------------------------------------
3191 :
3192 0 : do nmsg=1,halo%numMsgSend
3193 :
3194 0 : i=0
3195 0 : do n=1,halo%sizeSend(nmsg)
3196 0 : iSrc = halo%sendAddr(1,n,nmsg)
3197 0 : jSrc = halo%sendAddr(2,n,nmsg)
3198 0 : srcBlock = halo%sendAddr(3,n,nmsg)
3199 :
3200 0 : do k=1,nz
3201 0 : i = i + 1
3202 0 : bufSend(i,nmsg) = array(iSrc,jSrc,k,srcBlock)
3203 : end do
3204 : end do
3205 0 : do n=i+1,bufSizeSend*nz
3206 0 : bufSend(n,nmsg) = fill ! fill remainder of buffer
3207 : end do
3208 :
3209 0 : len = halo%SizeSend(nmsg)*nz
3210 0 : call MPI_ISEND(bufSend(1:len,nmsg), len, mpiR4, &
3211 : halo%sendTask(nmsg), & ! LCOV_EXCL_LINE
3212 : mpitagHalo + my_task, & ! LCOV_EXCL_LINE
3213 0 : halo%communicator, sndRequest(nmsg), ierr)
3214 : end do
3215 :
3216 : !-----------------------------------------------------------------------
3217 : !
3218 : ! while messages are being communicated, fill out halo region
3219 : ! needed for masked halos to ensure halo values are filled for
3220 : ! halo grid cells that are not updated
3221 : !
3222 : !-----------------------------------------------------------------------
3223 :
3224 0 : do iblk = 1, halo%numLocalBlocks
3225 0 : call get_block_parameter(halo%blockGlobalID(iblk), &
3226 : ilo=ilo, ihi=ihi, & ! LCOV_EXCL_LINE
3227 0 : jlo=jlo, jhi=jhi)
3228 0 : do j = 1,nghost
3229 0 : array(1:nx_block, jlo-j,:,iblk) = fill
3230 0 : array(1:nx_block, jhi+j,:,iblk) = fill
3231 : enddo
3232 0 : do i = 1,nghost
3233 0 : array(ilo-i, 1:ny_block,:,iblk) = fill
3234 0 : array(ihi+i, 1:ny_block,:,iblk) = fill
3235 : enddo
3236 : enddo
3237 :
3238 : !-----------------------------------------------------------------------
3239 : !
3240 : ! do local copies while waiting for messages to complete
3241 : ! if srcBlock is zero, that denotes an eliminated land block or a
3242 : ! closed boundary where ghost cell values are undefined
3243 : ! if srcBlock is less than zero, the message is a copy out of the
3244 : ! tripole buffer and will be treated later
3245 : !
3246 : !-----------------------------------------------------------------------
3247 :
3248 0 : do nmsg=1,halo%numLocalCopies
3249 0 : iSrc = halo%srcLocalAddr(1,nmsg)
3250 0 : jSrc = halo%srcLocalAddr(2,nmsg)
3251 0 : srcBlock = halo%srcLocalAddr(3,nmsg)
3252 0 : iDst = halo%dstLocalAddr(1,nmsg)
3253 0 : jDst = halo%dstLocalAddr(2,nmsg)
3254 0 : dstBlock = halo%dstLocalAddr(3,nmsg)
3255 :
3256 0 : if (srcBlock > 0) then
3257 0 : if (dstBlock > 0) then
3258 0 : do k=1,nz
3259 0 : array(iDst,jDst,k,dstBlock) = &
3260 0 : array(iSrc,jSrc,k,srcBlock)
3261 : end do
3262 0 : else if (dstBlock < 0) then ! tripole copy into buffer
3263 0 : do k=1,nz
3264 0 : bufTripole(iDst,jDst,k) = &
3265 0 : array(iSrc,jSrc,k,srcBlock)
3266 : end do
3267 : endif
3268 0 : else if (srcBlock == 0) then
3269 0 : do k=1,nz
3270 0 : array(iDst,jDst,k,dstBlock) = fill
3271 : end do
3272 : endif
3273 : end do
3274 :
3275 : !-----------------------------------------------------------------------
3276 : !
3277 : ! wait for receives to finish and then unpack the recv buffer into
3278 : ! ghost cells
3279 : !
3280 : !-----------------------------------------------------------------------
3281 :
3282 0 : call MPI_WAITALL(halo%numMsgRecv, rcvRequest, rcvStatus, ierr)
3283 :
3284 0 : do nmsg=1,halo%numMsgRecv
3285 0 : i = 0
3286 0 : do n=1,halo%sizeRecv(nmsg)
3287 0 : iDst = halo%recvAddr(1,n,nmsg)
3288 0 : jDst = halo%recvAddr(2,n,nmsg)
3289 0 : dstBlock = halo%recvAddr(3,n,nmsg)
3290 :
3291 0 : if (dstBlock > 0) then
3292 0 : do k=1,nz
3293 0 : i = i + 1
3294 0 : array(iDst,jDst,k,dstBlock) = bufRecv(i,nmsg)
3295 : end do
3296 0 : else if (dstBlock < 0) then !tripole
3297 0 : do k=1,nz
3298 0 : i = i + 1
3299 0 : bufTripole(iDst,jDst,k) = bufRecv(i,nmsg)
3300 : end do
3301 : endif
3302 : end do
3303 : end do
3304 :
3305 : !-----------------------------------------------------------------------
3306 : !
3307 : ! take care of northern boundary in tripole case
3308 : ! bufTripole array contains the top nghost+1 rows (u-fold) or nghost+2 rows
3309 : ! (T-fold) of physical domain for entire (global) top row
3310 : !
3311 : !-----------------------------------------------------------------------
3312 :
3313 0 : if (nxGlobal > 0) then
3314 :
3315 0 : select case (fieldKind)
3316 : case (field_type_scalar)
3317 0 : isign = 1
3318 : case (field_type_vector)
3319 0 : isign = -1
3320 : case (field_type_angle)
3321 0 : isign = -1
3322 : case default
3323 0 : call abort_ice(subname//'ERROR: Unknown field kind')
3324 : end select
3325 :
3326 0 : if (halo%tripoleTFlag) then
3327 :
3328 0 : select case (fieldLoc)
3329 : case (field_loc_center) ! cell center location
3330 :
3331 0 : ioffset = -1
3332 0 : joffset = 0
3333 :
3334 : !*** top row is degenerate, so must enforce symmetry
3335 : !*** use average of two degenerate points for value
3336 :
3337 0 : do k=1,nz
3338 0 : do i = 2,nxGlobal/2
3339 0 : iDst = nxGlobal - i + 2
3340 0 : x1 = bufTripole(i ,halo%tripoleRows,k)
3341 0 : x2 = bufTripole(iDst,halo%tripoleRows,k)
3342 0 : xavg = 0.5_real_kind*(x1 + isign*x2)
3343 0 : bufTripole(i ,halo%tripoleRows,k) = xavg
3344 0 : bufTripole(iDst,halo%tripoleRows,k) = isign*xavg
3345 : end do
3346 : end do
3347 :
3348 : case (field_loc_NEcorner) ! cell corner location
3349 :
3350 0 : ioffset = 0
3351 0 : joffset = 1
3352 :
3353 : case (field_loc_Eface) ! cell center location
3354 :
3355 0 : ioffset = 0
3356 0 : joffset = 0
3357 :
3358 : !*** top row is degenerate, so must enforce symmetry
3359 : !*** use average of two degenerate points for value
3360 :
3361 0 : do k=1,nz
3362 0 : do i = 1,nxGlobal/2
3363 0 : iDst = nxGlobal + 1 - i
3364 0 : x1 = bufTripole(i ,halo%tripoleRows,k)
3365 0 : x2 = bufTripole(iDst,halo%tripoleRows,k)
3366 0 : xavg = 0.5_real_kind*(x1 + isign*x2)
3367 0 : bufTripole(i ,halo%tripoleRows,k) = xavg
3368 0 : bufTripole(iDst,halo%tripoleRows,k) = isign*xavg
3369 : end do
3370 : end do
3371 :
3372 : case (field_loc_Nface) ! cell corner (velocity) location
3373 :
3374 0 : ioffset = -1
3375 0 : joffset = 1
3376 :
3377 : case default
3378 0 : call abort_ice(subname//'ERROR: Unknown field location')
3379 : end select
3380 :
3381 : else ! tripole u-fold
3382 :
3383 0 : select case (fieldLoc)
3384 : case (field_loc_center) ! cell center location
3385 :
3386 0 : ioffset = 0
3387 0 : joffset = 0
3388 :
3389 : case (field_loc_NEcorner) ! cell corner location
3390 :
3391 0 : ioffset = 1
3392 0 : joffset = 1
3393 :
3394 : !*** top row is degenerate, so must enforce symmetry
3395 : !*** use average of two degenerate points for value
3396 :
3397 0 : do k=1,nz
3398 0 : do i = 1,nxGlobal/2 - 1
3399 0 : iDst = nxGlobal - i
3400 0 : x1 = bufTripole(i ,halo%tripoleRows,k)
3401 0 : x2 = bufTripole(iDst,halo%tripoleRows,k)
3402 0 : xavg = 0.5_real_kind*(x1 + isign*x2)
3403 0 : bufTripole(i ,halo%tripoleRows,k) = xavg
3404 0 : bufTripole(iDst,halo%tripoleRows,k) = isign*xavg
3405 : end do
3406 : end do
3407 :
3408 : case (field_loc_Eface) ! cell center location
3409 :
3410 0 : ioffset = 1
3411 0 : joffset = 0
3412 :
3413 : case (field_loc_Nface) ! cell corner (velocity) location
3414 :
3415 0 : ioffset = 0
3416 0 : joffset = 1
3417 :
3418 : !*** top row is degenerate, so must enforce symmetry
3419 : !*** use average of two degenerate points for value
3420 :
3421 0 : do k=1,nz
3422 0 : do i = 1,nxGlobal/2
3423 0 : iDst = nxGlobal + 1 - i
3424 0 : x1 = bufTripole(i ,halo%tripoleRows,k)
3425 0 : x2 = bufTripole(iDst,halo%tripoleRows,k)
3426 0 : xavg = 0.5_real_kind*(x1 + isign*x2)
3427 0 : bufTripole(i ,halo%tripoleRows,k) = xavg
3428 0 : bufTripole(iDst,halo%tripoleRows,k) = isign*xavg
3429 : end do
3430 : end do
3431 :
3432 : case default
3433 0 : call abort_ice(subname//'ERROR: Unknown field location')
3434 : end select
3435 :
3436 : endif
3437 :
3438 : !*** copy out of global tripole buffer into local
3439 : !*** ghost cells
3440 :
3441 : !*** look through local copies to find the copy out
3442 : !*** messages (srcBlock < 0)
3443 :
3444 0 : do nmsg=1,halo%numLocalCopies
3445 0 : srcBlock = halo%srcLocalAddr(3,nmsg)
3446 :
3447 0 : if (srcBlock < 0) then
3448 :
3449 0 : iSrc = halo%srcLocalAddr(1,nmsg) ! tripole buffer addr
3450 0 : jSrc = halo%srcLocalAddr(2,nmsg)
3451 :
3452 0 : iDst = halo%dstLocalAddr(1,nmsg) ! local block addr
3453 0 : jDst = halo%dstLocalAddr(2,nmsg)
3454 0 : dstBlock = halo%dstLocalAddr(3,nmsg)
3455 :
3456 : !*** correct for offsets
3457 0 : iSrc = iSrc - ioffset
3458 0 : jSrc = jSrc - joffset
3459 0 : if (iSrc < 1 ) iSrc = iSrc + nxGlobal
3460 0 : if (iSrc > nxGlobal) iSrc = iSrc - nxGlobal
3461 :
3462 : !*** for center and Eface on u-fold, and NE corner and Nface
3463 : !*** on T-fold, do not need to replace
3464 : !*** top row of physical domain, so jSrc should be
3465 : !*** out of range and skipped
3466 : !*** otherwise do the copy
3467 :
3468 0 : if (jSrc <= halo%tripoleRows .and. jSrc>0 .and. jDst>0) then
3469 0 : do k=1,nz
3470 0 : array(iDst,jDst,k,dstBlock) = isign* &
3471 0 : bufTripole(iSrc,jSrc,k)
3472 : end do
3473 : endif
3474 :
3475 : endif
3476 : end do
3477 :
3478 : endif
3479 :
3480 : !-----------------------------------------------------------------------
3481 : !
3482 : ! wait for sends to complete and deallocate arrays
3483 : !
3484 : !-----------------------------------------------------------------------
3485 :
3486 0 : call MPI_WAITALL(halo%numMsgSend, sndRequest, sndStatus, ierr)
3487 :
3488 0 : deallocate(sndRequest, rcvRequest, sndStatus, rcvStatus, stat=ierr)
3489 :
3490 0 : if (ierr > 0) then
3491 0 : call abort_ice(subname//'ERROR: deallocating req,status arrays')
3492 0 : return
3493 : endif
3494 :
3495 0 : deallocate(bufSend, bufRecv, bufTripole, stat=ierr)
3496 :
3497 0 : if (ierr > 0) then
3498 0 : call abort_ice(subname//'ERROR: deallocating 3d buffers')
3499 0 : return
3500 : endif
3501 :
3502 : !-----------------------------------------------------------------------
3503 :
3504 0 : end subroutine ice_HaloUpdate3DR4
3505 :
3506 : !***********************************************************************
3507 :
3508 0 : subroutine ice_HaloUpdate3DI4(array, halo, &
3509 : fieldLoc, fieldKind, & ! LCOV_EXCL_LINE
3510 : fillValue)
3511 :
3512 : ! This routine updates ghost cells for an input array and is a
3513 : ! member of a group of routines under the generic interface
3514 : ! ice\_HaloUpdate. This routine is the specific interface
3515 : ! for 3d horizontal arrays of double precision.
3516 :
3517 : type (ice_halo), intent(in) :: &
3518 : halo ! precomputed halo structure containing all
3519 : ! information needed for halo update
3520 :
3521 : integer (int_kind), intent(in) :: &
3522 : fieldKind, &! id for type of field (scalar, vector, angle) ! LCOV_EXCL_LINE
3523 : fieldLoc ! id for location on horizontal grid
3524 : ! (center, NEcorner, Nface, Eface)
3525 :
3526 : integer (int_kind), intent(in), optional :: &
3527 : fillValue ! optional value to put in ghost cells
3528 : ! where neighbor points are unknown
3529 : ! (e.g. eliminated land blocks or
3530 : ! closed boundaries)
3531 :
3532 : integer (int_kind), dimension(:,:,:,:), intent(inout) :: &
3533 : array ! array containing field for which halo
3534 : ! needs to be updated
3535 :
3536 : !-----------------------------------------------------------------------
3537 : !
3538 : ! local variables
3539 : !
3540 : !-----------------------------------------------------------------------
3541 :
3542 : integer (int_kind) :: &
3543 : i,j,k,n,nmsg, &! dummy loop indices ! LCOV_EXCL_LINE
3544 : iblk,ilo,ihi,jlo,jhi, &! block sizes for fill ! LCOV_EXCL_LINE
3545 : ierr, &! error or status flag for MPI,alloc ! LCOV_EXCL_LINE
3546 : nxGlobal, &! global domain size in x (tripole) ! LCOV_EXCL_LINE
3547 : nz, &! size of array in 3rd dimension ! LCOV_EXCL_LINE
3548 : iSrc,jSrc, &! source addresses for message ! LCOV_EXCL_LINE
3549 : iDst,jDst, &! dest addresses for message ! LCOV_EXCL_LINE
3550 : srcBlock, &! local block number for source ! LCOV_EXCL_LINE
3551 : dstBlock, &! local block number for destination ! LCOV_EXCL_LINE
3552 : ioffset, joffset, &! address shifts for tripole ! LCOV_EXCL_LINE
3553 : isign ! sign factor for tripole grids
3554 :
3555 : integer (int_kind), dimension(:), allocatable :: &
3556 : sndRequest, &! MPI request ids ! LCOV_EXCL_LINE
3557 0 : rcvRequest ! MPI request ids
3558 :
3559 : integer (int_kind), dimension(:,:), allocatable :: &
3560 : sndStatus, &! MPI status flags ! LCOV_EXCL_LINE
3561 0 : rcvStatus ! MPI status flags
3562 :
3563 : integer (int_kind) :: &
3564 : fill, &! value to use for unknown points ! LCOV_EXCL_LINE
3565 : x1,x2,xavg ! scalars for enforcing symmetry at U pts
3566 :
3567 : integer (int_kind), dimension(:,:), allocatable :: &
3568 0 : bufSend, bufRecv ! 3d send,recv buffers
3569 :
3570 : integer (int_kind), dimension(:,:,:), allocatable :: &
3571 0 : bufTripole ! 3d tripole buffer
3572 :
3573 : integer (int_kind) :: len ! length of message
3574 :
3575 : character(len=*), parameter :: subname = '(ice_HaloUpdate3DI4)'
3576 :
3577 : !-----------------------------------------------------------------------
3578 : !
3579 : ! abort or return on unknown or noupdate field_loc or field_type
3580 : !
3581 : !-----------------------------------------------------------------------
3582 :
3583 0 : if (fieldLoc == field_loc_unknown .or. &
3584 : fieldKind == field_type_unknown) then
3585 0 : call abort_ice(subname//'ERROR: use of field_loc/type_unknown not allowed')
3586 0 : return
3587 : endif
3588 :
3589 0 : if (fieldLoc == field_loc_noupdate .or. &
3590 : fieldKind == field_type_noupdate) then
3591 0 : return
3592 : endif
3593 :
3594 : !-----------------------------------------------------------------------
3595 : !
3596 : ! initialize error code and fill value
3597 : !
3598 : !-----------------------------------------------------------------------
3599 :
3600 0 : if (present(fillValue)) then
3601 0 : fill = fillValue
3602 : else
3603 0 : fill = 0_int_kind
3604 : endif
3605 :
3606 0 : nxGlobal = 0
3607 0 : if (allocated(bufTripoleI4)) nxGlobal = size(bufTripoleI4,dim=1)
3608 :
3609 : !-----------------------------------------------------------------------
3610 : !
3611 : ! allocate request and status arrays for messages
3612 : !
3613 : !-----------------------------------------------------------------------
3614 :
3615 : allocate(sndRequest(halo%numMsgSend), &
3616 : rcvRequest(halo%numMsgRecv), & ! LCOV_EXCL_LINE
3617 : sndStatus(MPI_STATUS_SIZE,halo%numMsgSend), & ! LCOV_EXCL_LINE
3618 0 : rcvStatus(MPI_STATUS_SIZE,halo%numMsgRecv), stat=ierr)
3619 :
3620 0 : if (ierr > 0) then
3621 0 : call abort_ice(subname//'ERROR: allocating req,status arrays')
3622 0 : return
3623 : endif
3624 :
3625 : !-----------------------------------------------------------------------
3626 : !
3627 : ! allocate 3D buffers
3628 : !
3629 : !-----------------------------------------------------------------------
3630 :
3631 0 : nz = size(array, dim=3)
3632 :
3633 : allocate(bufSend(bufSizeSend*nz, halo%numMsgSend), &
3634 : bufRecv(bufSizeRecv*nz, halo%numMsgRecv), & ! LCOV_EXCL_LINE
3635 : bufTripole(nxGlobal, halo%tripoleRows, nz), & ! LCOV_EXCL_LINE
3636 0 : stat=ierr)
3637 :
3638 0 : if (ierr > 0) then
3639 0 : call abort_ice(subname//'ERROR: allocating buffers')
3640 0 : return
3641 : endif
3642 :
3643 0 : bufTripole = fill
3644 :
3645 : !-----------------------------------------------------------------------
3646 : !
3647 : ! post receives
3648 : !
3649 : !-----------------------------------------------------------------------
3650 :
3651 0 : do nmsg=1,halo%numMsgRecv
3652 :
3653 0 : len = halo%SizeRecv(nmsg)*nz
3654 0 : call MPI_IRECV(bufRecv(1:len,nmsg), len, MPI_INTEGER, &
3655 : halo%recvTask(nmsg), & ! LCOV_EXCL_LINE
3656 : mpitagHalo + halo%recvTask(nmsg), & ! LCOV_EXCL_LINE
3657 0 : halo%communicator, rcvRequest(nmsg), ierr)
3658 : end do
3659 :
3660 : !-----------------------------------------------------------------------
3661 : !
3662 : ! fill send buffer and post sends
3663 : !
3664 : !-----------------------------------------------------------------------
3665 :
3666 0 : do nmsg=1,halo%numMsgSend
3667 :
3668 0 : i=0
3669 0 : do n=1,halo%sizeSend(nmsg)
3670 0 : iSrc = halo%sendAddr(1,n,nmsg)
3671 0 : jSrc = halo%sendAddr(2,n,nmsg)
3672 0 : srcBlock = halo%sendAddr(3,n,nmsg)
3673 :
3674 0 : do k=1,nz
3675 0 : i = i + 1
3676 0 : bufSend(i,nmsg) = array(iSrc,jSrc,k,srcBlock)
3677 : end do
3678 : end do
3679 0 : do n=i+1,bufSizeSend*nz
3680 0 : bufSend(n,nmsg) = fill ! fill remainder of buffer
3681 : end do
3682 :
3683 0 : len = halo%SizeSend(nmsg)*nz
3684 0 : call MPI_ISEND(bufSend(1:len,nmsg), len, MPI_INTEGER, &
3685 : halo%sendTask(nmsg), & ! LCOV_EXCL_LINE
3686 : mpitagHalo + my_task, & ! LCOV_EXCL_LINE
3687 0 : halo%communicator, sndRequest(nmsg), ierr)
3688 : end do
3689 :
3690 : !-----------------------------------------------------------------------
3691 : !
3692 : ! while messages are being communicated, fill out halo region
3693 : ! needed for masked halos to ensure halo values are filled for
3694 : ! halo grid cells that are not updated
3695 : !
3696 : !-----------------------------------------------------------------------
3697 :
3698 0 : do iblk = 1, halo%numLocalBlocks
3699 0 : call get_block_parameter(halo%blockGlobalID(iblk), &
3700 : ilo=ilo, ihi=ihi, & ! LCOV_EXCL_LINE
3701 0 : jlo=jlo, jhi=jhi)
3702 0 : do j = 1,nghost
3703 0 : array(1:nx_block, jlo-j,:,iblk) = fill
3704 0 : array(1:nx_block, jhi+j,:,iblk) = fill
3705 : enddo
3706 0 : do i = 1,nghost
3707 0 : array(ilo-i, 1:ny_block,:,iblk) = fill
3708 0 : array(ihi+i, 1:ny_block,:,iblk) = fill
3709 : enddo
3710 : enddo
3711 :
3712 : !-----------------------------------------------------------------------
3713 : !
3714 : ! do local copies while waiting for messages to complete
3715 : ! if srcBlock is zero, that denotes an eliminated land block or a
3716 : ! closed boundary where ghost cell values are undefined
3717 : ! if srcBlock is less than zero, the message is a copy out of the
3718 : ! tripole buffer and will be treated later
3719 : !
3720 : !-----------------------------------------------------------------------
3721 :
3722 0 : do nmsg=1,halo%numLocalCopies
3723 0 : iSrc = halo%srcLocalAddr(1,nmsg)
3724 0 : jSrc = halo%srcLocalAddr(2,nmsg)
3725 0 : srcBlock = halo%srcLocalAddr(3,nmsg)
3726 0 : iDst = halo%dstLocalAddr(1,nmsg)
3727 0 : jDst = halo%dstLocalAddr(2,nmsg)
3728 0 : dstBlock = halo%dstLocalAddr(3,nmsg)
3729 :
3730 0 : if (srcBlock > 0) then
3731 0 : if (dstBlock > 0) then
3732 0 : do k=1,nz
3733 0 : array(iDst,jDst,k,dstBlock) = &
3734 0 : array(iSrc,jSrc,k,srcBlock)
3735 : end do
3736 0 : else if (dstBlock < 0) then ! tripole copy into buffer
3737 0 : do k=1,nz
3738 0 : bufTripole(iDst,jDst,k) = &
3739 0 : array(iSrc,jSrc,k,srcBlock)
3740 : end do
3741 : endif
3742 0 : else if (srcBlock == 0) then
3743 0 : do k=1,nz
3744 0 : array(iDst,jDst,k,dstBlock) = fill
3745 : end do
3746 : endif
3747 : end do
3748 :
3749 : !-----------------------------------------------------------------------
3750 : !
3751 : ! wait for receives to finish and then unpack the recv buffer into
3752 : ! ghost cells
3753 : !
3754 : !-----------------------------------------------------------------------
3755 :
3756 0 : call MPI_WAITALL(halo%numMsgRecv, rcvRequest, rcvStatus, ierr)
3757 :
3758 0 : do nmsg=1,halo%numMsgRecv
3759 0 : i = 0
3760 0 : do n=1,halo%sizeRecv(nmsg)
3761 0 : iDst = halo%recvAddr(1,n,nmsg)
3762 0 : jDst = halo%recvAddr(2,n,nmsg)
3763 0 : dstBlock = halo%recvAddr(3,n,nmsg)
3764 :
3765 0 : if (dstBlock > 0) then
3766 0 : do k=1,nz
3767 0 : i = i + 1
3768 0 : array(iDst,jDst,k,dstBlock) = bufRecv(i,nmsg)
3769 : end do
3770 0 : else if (dstBlock < 0) then !tripole
3771 0 : do k=1,nz
3772 0 : i = i + 1
3773 0 : bufTripole(iDst,jDst,k) = bufRecv(i,nmsg)
3774 : end do
3775 : endif
3776 : end do
3777 : end do
3778 :
3779 : !-----------------------------------------------------------------------
3780 : !
3781 : ! take care of northern boundary in tripole case
3782 : ! bufTripole array contains the top nghost+1 rows (u-fold) or nghost+2 rows
3783 : ! (T-fold) of physical domain for entire (global) top row
3784 : !
3785 : !-----------------------------------------------------------------------
3786 :
3787 0 : if (nxGlobal > 0) then
3788 :
3789 0 : select case (fieldKind)
3790 : case (field_type_scalar)
3791 0 : isign = 1
3792 : case (field_type_vector)
3793 0 : isign = -1
3794 : case (field_type_angle)
3795 0 : isign = -1
3796 : case default
3797 0 : call abort_ice(subname//'ERROR: Unknown field kind')
3798 : end select
3799 :
3800 0 : if (halo%tripoleTFlag) then
3801 :
3802 0 : select case (fieldLoc)
3803 : case (field_loc_center) ! cell center location
3804 :
3805 0 : ioffset = -1
3806 0 : joffset = 0
3807 :
3808 : !*** top row is degenerate, so must enforce symmetry
3809 : !*** use average of two degenerate points for value
3810 :
3811 0 : do k=1,nz
3812 0 : do i = 2,nxGlobal/2
3813 0 : iDst = nxGlobal - i + 2
3814 0 : x1 = bufTripole(i ,halo%tripoleRows,k)
3815 0 : x2 = bufTripole(iDst,halo%tripoleRows,k)
3816 0 : xavg = nint(0.5_dbl_kind*(x1 + isign*x2))
3817 0 : bufTripole(i ,halo%tripoleRows,k) = xavg
3818 0 : bufTripole(iDst,halo%tripoleRows,k) = isign*xavg
3819 : end do
3820 : end do
3821 :
3822 : case (field_loc_NEcorner) ! cell corner location
3823 :
3824 0 : ioffset = 0
3825 0 : joffset = 1
3826 :
3827 : case (field_loc_Eface) ! cell center location
3828 :
3829 0 : ioffset = 0
3830 0 : joffset = 0
3831 :
3832 : !*** top row is degenerate, so must enforce symmetry
3833 : !*** use average of two degenerate points for value
3834 :
3835 0 : do k=1,nz
3836 0 : do i = 1,nxGlobal/2
3837 0 : iDst = nxGlobal + 1 - i
3838 0 : x1 = bufTripole(i ,halo%tripoleRows,k)
3839 0 : x2 = bufTripole(iDst,halo%tripoleRows,k)
3840 0 : xavg = nint(0.5_dbl_kind*(x1 + isign*x2))
3841 0 : bufTripole(i ,halo%tripoleRows,k) = xavg
3842 0 : bufTripole(iDst,halo%tripoleRows,k) = isign*xavg
3843 : end do
3844 : end do
3845 :
3846 : case (field_loc_Nface) ! cell corner (velocity) location
3847 :
3848 0 : ioffset = -1
3849 0 : joffset = 1
3850 :
3851 : case default
3852 0 : call abort_ice(subname//'ERROR: Unknown field location')
3853 : end select
3854 :
3855 : else ! tripole u-fold
3856 :
3857 0 : select case (fieldLoc)
3858 : case (field_loc_center) ! cell center location
3859 :
3860 0 : ioffset = 0
3861 0 : joffset = 0
3862 :
3863 : case (field_loc_NEcorner) ! cell corner location
3864 :
3865 0 : ioffset = 1
3866 0 : joffset = 1
3867 :
3868 : !*** top row is degenerate, so must enforce symmetry
3869 : !*** use average of two degenerate points for value
3870 :
3871 0 : do k=1,nz
3872 0 : do i = 1,nxGlobal/2 - 1
3873 0 : iDst = nxGlobal - i
3874 0 : x1 = bufTripole(i ,halo%tripoleRows,k)
3875 0 : x2 = bufTripole(iDst,halo%tripoleRows,k)
3876 0 : xavg = nint(0.5_dbl_kind*(x1 + isign*x2))
3877 0 : bufTripole(i ,halo%tripoleRows,k) = xavg
3878 0 : bufTripole(iDst,halo%tripoleRows,k) = isign*xavg
3879 : end do
3880 : end do
3881 :
3882 : case (field_loc_Eface) ! cell center location
3883 :
3884 0 : ioffset = 1
3885 0 : joffset = 0
3886 :
3887 : case (field_loc_Nface) ! cell corner (velocity) location
3888 :
3889 0 : ioffset = 0
3890 0 : joffset = 1
3891 :
3892 : !*** top row is degenerate, so must enforce symmetry
3893 : !*** use average of two degenerate points for value
3894 :
3895 0 : do k=1,nz
3896 0 : do i = 1,nxGlobal/2
3897 0 : iDst = nxGlobal + 1 - i
3898 0 : x1 = bufTripole(i ,halo%tripoleRows,k)
3899 0 : x2 = bufTripole(iDst,halo%tripoleRows,k)
3900 0 : xavg = nint(0.5_dbl_kind*(x1 + isign*x2))
3901 0 : bufTripole(i ,halo%tripoleRows,k) = xavg
3902 0 : bufTripole(iDst,halo%tripoleRows,k) = isign*xavg
3903 : end do
3904 : end do
3905 :
3906 : case default
3907 0 : call abort_ice(subname//'ERROR: Unknown field location')
3908 : end select
3909 :
3910 : endif
3911 :
3912 : !*** copy out of global tripole buffer into local
3913 : !*** ghost cells
3914 :
3915 : !*** look through local copies to find the copy out
3916 : !*** messages (srcBlock < 0)
3917 :
3918 0 : do nmsg=1,halo%numLocalCopies
3919 0 : srcBlock = halo%srcLocalAddr(3,nmsg)
3920 :
3921 0 : if (srcBlock < 0) then
3922 :
3923 0 : iSrc = halo%srcLocalAddr(1,nmsg) ! tripole buffer addr
3924 0 : jSrc = halo%srcLocalAddr(2,nmsg)
3925 :
3926 0 : iDst = halo%dstLocalAddr(1,nmsg) ! local block addr
3927 0 : jDst = halo%dstLocalAddr(2,nmsg)
3928 0 : dstBlock = halo%dstLocalAddr(3,nmsg)
3929 :
3930 : !*** correct for offsets
3931 0 : iSrc = iSrc - ioffset
3932 0 : jSrc = jSrc - joffset
3933 0 : if (iSrc < 1 ) iSrc = iSrc + nxGlobal
3934 0 : if (iSrc > nxGlobal) iSrc = iSrc - nxGlobal
3935 :
3936 : !*** for center and Eface on u-fold, and NE corner and Nface
3937 : !*** on T-fold, do not need to replace
3938 : !*** top row of physical domain, so jSrc should be
3939 : !*** out of range and skipped
3940 : !*** otherwise do the copy
3941 :
3942 0 : if (jSrc <= halo%tripoleRows .and. jSrc>0 .and. jDst>0) then
3943 0 : do k=1,nz
3944 0 : array(iDst,jDst,k,dstBlock) = isign* &
3945 0 : bufTripole(iSrc,jSrc,k)
3946 : end do
3947 : endif
3948 :
3949 : endif
3950 : end do
3951 :
3952 : endif
3953 :
3954 : !-----------------------------------------------------------------------
3955 : !
3956 : ! wait for sends to complete and deallocate arrays
3957 : !
3958 : !-----------------------------------------------------------------------
3959 :
3960 0 : call MPI_WAITALL(halo%numMsgSend, sndRequest, sndStatus, ierr)
3961 :
3962 0 : deallocate(sndRequest, rcvRequest, sndStatus, rcvStatus, stat=ierr)
3963 :
3964 0 : if (ierr > 0) then
3965 0 : call abort_ice(subname//'ERROR: deallocating req,status arrays')
3966 0 : return
3967 : endif
3968 :
3969 0 : deallocate(bufSend, bufRecv, bufTripole, stat=ierr)
3970 :
3971 0 : if (ierr > 0) then
3972 0 : call abort_ice(subname//'ERROR: deallocating 3d buffers')
3973 0 : return
3974 : endif
3975 :
3976 : !-----------------------------------------------------------------------
3977 :
3978 0 : end subroutine ice_HaloUpdate3DI4
3979 :
3980 : !***********************************************************************
3981 :
3982 34596 : subroutine ice_HaloUpdate4DR8(array, halo, &
3983 : fieldLoc, fieldKind, & ! LCOV_EXCL_LINE
3984 : fillValue)
3985 :
3986 : ! This routine updates ghost cells for an input array and is a
3987 : ! member of a group of routines under the generic interface
3988 : ! ice\_HaloUpdate. This routine is the specific interface
3989 : ! for 4d horizontal arrays of double precision.
3990 :
3991 : type (ice_halo), intent(in) :: &
3992 : halo ! precomputed halo structure containing all
3993 : ! information needed for halo update
3994 :
3995 : integer (int_kind), intent(in) :: &
3996 : fieldKind, &! id for type of field (scalar, vector, angle) ! LCOV_EXCL_LINE
3997 : fieldLoc ! id for location on horizontal grid
3998 : ! (center, NEcorner, Nface, Eface)
3999 :
4000 : real (dbl_kind), intent(in), optional :: &
4001 : fillValue ! optional value to put in ghost cells
4002 : ! where neighbor points are unknown
4003 : ! (e.g. eliminated land blocks or
4004 : ! closed boundaries)
4005 :
4006 : real (dbl_kind), dimension(:,:,:,:,:), intent(inout) :: &
4007 : array ! array containing field for which halo
4008 : ! needs to be updated
4009 :
4010 : !-----------------------------------------------------------------------
4011 : !
4012 : ! local variables
4013 : !
4014 : !-----------------------------------------------------------------------
4015 :
4016 : integer (int_kind) :: &
4017 : i,j,k,l,n,nmsg, &! dummy loop indices ! LCOV_EXCL_LINE
4018 : iblk,ilo,ihi,jlo,jhi, &! block sizes for fill ! LCOV_EXCL_LINE
4019 : ierr, &! error or status flag for MPI,alloc ! LCOV_EXCL_LINE
4020 : nxGlobal, &! global domain size in x (tripole) ! LCOV_EXCL_LINE
4021 : nz, nt, &! size of array in 3rd,4th dimensions ! LCOV_EXCL_LINE
4022 : iSrc,jSrc, &! source addresses for message ! LCOV_EXCL_LINE
4023 : iDst,jDst, &! dest addresses for message ! LCOV_EXCL_LINE
4024 : srcBlock, &! local block number for source ! LCOV_EXCL_LINE
4025 : dstBlock, &! local block number for destination ! LCOV_EXCL_LINE
4026 : ioffset, joffset, &! address shifts for tripole ! LCOV_EXCL_LINE
4027 : isign ! sign factor for tripole grids
4028 :
4029 : integer (int_kind), dimension(:), allocatable :: &
4030 : sndRequest, &! MPI request ids ! LCOV_EXCL_LINE
4031 34596 : rcvRequest ! MPI request ids
4032 :
4033 : integer (int_kind), dimension(:,:), allocatable :: &
4034 : sndStatus, &! MPI status flags ! LCOV_EXCL_LINE
4035 34596 : rcvStatus ! MPI status flags
4036 :
4037 : real (dbl_kind) :: &
4038 : fill, &! value to use for unknown points ! LCOV_EXCL_LINE
4039 8648 : x1,x2,xavg ! scalars for enforcing symmetry at U pts
4040 :
4041 : real (dbl_kind), dimension(:,:), allocatable :: &
4042 34596 : bufSend, bufRecv ! 4d send,recv buffers
4043 :
4044 : real (dbl_kind), dimension(:,:,:,:), allocatable :: &
4045 34596 : bufTripole ! 4d tripole buffer
4046 :
4047 : integer (int_kind) :: len ! length of message
4048 :
4049 : character(len=*), parameter :: subname = '(ice_HaloUpdate4DR8)'
4050 :
4051 : !-----------------------------------------------------------------------
4052 : !
4053 : ! abort or return on unknown or noupdate field_loc or field_type
4054 : !
4055 : !-----------------------------------------------------------------------
4056 :
4057 34596 : if (fieldLoc == field_loc_unknown .or. &
4058 : fieldKind == field_type_unknown) then
4059 0 : call abort_ice(subname//'ERROR: use of field_loc/type_unknown not allowed')
4060 0 : return
4061 : endif
4062 :
4063 34596 : if (fieldLoc == field_loc_noupdate .or. &
4064 : fieldKind == field_type_noupdate) then
4065 0 : return
4066 : endif
4067 :
4068 : !-----------------------------------------------------------------------
4069 : !
4070 : ! initialize error code and fill value
4071 : !
4072 : !-----------------------------------------------------------------------
4073 :
4074 34596 : if (present(fillValue)) then
4075 0 : fill = fillValue
4076 : else
4077 34596 : fill = 0.0_dbl_kind
4078 : endif
4079 :
4080 34596 : nxGlobal = 0
4081 34596 : if (allocated(bufTripoleR8)) nxGlobal = size(bufTripoleR8,dim=1)
4082 :
4083 : !-----------------------------------------------------------------------
4084 : !
4085 : ! allocate request and status arrays for messages
4086 : !
4087 : !-----------------------------------------------------------------------
4088 :
4089 : allocate(sndRequest(halo%numMsgSend), &
4090 : rcvRequest(halo%numMsgRecv), & ! LCOV_EXCL_LINE
4091 : sndStatus(MPI_STATUS_SIZE,halo%numMsgSend), & ! LCOV_EXCL_LINE
4092 34596 : rcvStatus(MPI_STATUS_SIZE,halo%numMsgRecv), stat=ierr)
4093 :
4094 34596 : if (ierr > 0) then
4095 0 : call abort_ice(subname//'ERROR: allocating req,status arrays')
4096 0 : return
4097 : endif
4098 :
4099 : !-----------------------------------------------------------------------
4100 : !
4101 : ! allocate 4D buffers
4102 : !
4103 : !-----------------------------------------------------------------------
4104 :
4105 34596 : nz = size(array, dim=3)
4106 34596 : nt = size(array, dim=4)
4107 :
4108 : allocate(bufSend(bufSizeSend*nz*nt, halo%numMsgSend), &
4109 : bufRecv(bufSizeRecv*nz*nt, halo%numMsgRecv), & ! LCOV_EXCL_LINE
4110 : bufTripole(nxGlobal, halo%tripoleRows, nz, nt), & ! LCOV_EXCL_LINE
4111 34596 : stat=ierr)
4112 :
4113 34596 : if (ierr > 0) then
4114 0 : call abort_ice(subname//'ERROR: allocating buffers')
4115 0 : return
4116 : endif
4117 :
4118 13180536 : bufTripole = fill
4119 :
4120 : !-----------------------------------------------------------------------
4121 : !
4122 : ! post receives
4123 : !
4124 : !-----------------------------------------------------------------------
4125 :
4126 196048 : do nmsg=1,halo%numMsgRecv
4127 :
4128 161452 : len = halo%SizeRecv(nmsg)*nz*nt
4129 0 : call MPI_IRECV(bufRecv(1:len,nmsg), len, mpiR8, &
4130 : halo%recvTask(nmsg), & ! LCOV_EXCL_LINE
4131 : mpitagHalo + halo%recvTask(nmsg), & ! LCOV_EXCL_LINE
4132 196048 : halo%communicator, rcvRequest(nmsg), ierr)
4133 : end do
4134 :
4135 : !-----------------------------------------------------------------------
4136 : !
4137 : ! fill send buffer and post sends
4138 : !
4139 : !-----------------------------------------------------------------------
4140 :
4141 196048 : do nmsg=1,halo%numMsgSend
4142 :
4143 161452 : i=0
4144 8886412 : do n=1,halo%sizeSend(nmsg)
4145 8724960 : iSrc = halo%sendAddr(1,n,nmsg)
4146 8724960 : jSrc = halo%sendAddr(2,n,nmsg)
4147 8724960 : srcBlock = halo%sendAddr(3,n,nmsg)
4148 :
4149 52511212 : do l=1,nt
4150 1142919360 : do k=1,nz
4151 1090569600 : i = i + 1
4152 1134194400 : bufSend(i,nmsg) = array(iSrc,jSrc,k,l,srcBlock)
4153 : end do
4154 : end do
4155 : end do
4156 :
4157 1605492652 : do n=i+1,bufSizeSend*nz*nt
4158 1605492652 : bufSend(n,nmsg) = fill ! fill remainder of buffer
4159 : end do
4160 :
4161 161452 : len = halo%SizeSend(nmsg)*nz*nt
4162 0 : call MPI_ISEND(bufSend(1:len,nmsg), len, mpiR8, &
4163 : halo%sendTask(nmsg), & ! LCOV_EXCL_LINE
4164 : mpitagHalo + my_task, & ! LCOV_EXCL_LINE
4165 196048 : halo%communicator, sndRequest(nmsg), ierr)
4166 : end do
4167 :
4168 : !-----------------------------------------------------------------------
4169 : !
4170 : ! while messages are being communicated, fill out halo region
4171 : ! needed for masked halos to ensure halo values are filled for
4172 : ! halo grid cells that are not updated
4173 : !
4174 : !-----------------------------------------------------------------------
4175 :
4176 172275 : do iblk = 1, halo%numLocalBlocks
4177 0 : call get_block_parameter(halo%blockGlobalID(iblk), &
4178 : ilo=ilo, ihi=ihi, & ! LCOV_EXCL_LINE
4179 137679 : jlo=jlo, jhi=jhi)
4180 275358 : do j = 1,nghost
4181 370557594 : array(1:nx_block, jlo-j,:,:,iblk) = fill
4182 370695273 : array(1:nx_block, jhi+j,:,:,iblk) = fill
4183 : enddo
4184 447633 : do i = 1,nghost
4185 564488154 : array(ilo-i, 1:ny_block,:,:,iblk) = fill
4186 564625833 : array(ihi+i, 1:ny_block,:,:,iblk) = fill
4187 : enddo
4188 : enddo
4189 :
4190 : !-----------------------------------------------------------------------
4191 : !
4192 : ! do local copies while waiting for messages to complete
4193 : ! if srcBlock is zero, that denotes an eliminated land block or a
4194 : ! closed boundary where ghost cell values are undefined
4195 : ! if srcBlock is less than zero, the message is a copy out of the
4196 : ! tripole buffer and will be treated later
4197 : !
4198 : !-----------------------------------------------------------------------
4199 :
4200 3730492 : do nmsg=1,halo%numLocalCopies
4201 3695896 : iSrc = halo%srcLocalAddr(1,nmsg)
4202 3695896 : jSrc = halo%srcLocalAddr(2,nmsg)
4203 3695896 : srcBlock = halo%srcLocalAddr(3,nmsg)
4204 3695896 : iDst = halo%dstLocalAddr(1,nmsg)
4205 3695896 : jDst = halo%dstLocalAddr(2,nmsg)
4206 3695896 : dstBlock = halo%dstLocalAddr(3,nmsg)
4207 :
4208 3730492 : if (srcBlock > 0) then
4209 3643984 : if (dstBlock > 0) then
4210 21863904 : do l=1,nt
4211 477343584 : do k=1,nz
4212 237811200 : array(iDst,jDst,k,l,dstBlock) = &
4213 473699600 : array(iSrc,jSrc,k,l,srcBlock)
4214 : end do
4215 : end do
4216 0 : else if (dstBlock < 0) then ! tripole copy into buffer
4217 0 : do l=1,nt
4218 0 : do k=1,nz
4219 0 : bufTripole(iDst,jDst,k,l) = &
4220 0 : array(iSrc,jSrc,k,l,srcBlock)
4221 : end do
4222 : end do
4223 : endif
4224 51912 : else if (srcBlock == 0) then
4225 311472 : do l=1,nt
4226 6800112 : do k=1,nz
4227 6748200 : array(iDst,jDst,k,l,dstBlock) = fill
4228 : end do
4229 : end do
4230 : endif
4231 : end do
4232 :
4233 : !-----------------------------------------------------------------------
4234 : !
4235 : ! wait for receives to finish and then unpack the recv buffer into
4236 : ! ghost cells
4237 : !
4238 : !-----------------------------------------------------------------------
4239 :
4240 34596 : call MPI_WAITALL(halo%numMsgRecv, rcvRequest, rcvStatus, ierr)
4241 :
4242 196048 : do nmsg=1,halo%numMsgRecv
4243 161452 : i = 0
4244 8921008 : do n=1,halo%sizeRecv(nmsg)
4245 8724960 : iDst = halo%recvAddr(1,n,nmsg)
4246 8724960 : jDst = halo%recvAddr(2,n,nmsg)
4247 8724960 : dstBlock = halo%recvAddr(3,n,nmsg)
4248 :
4249 8886412 : if (dstBlock > 0) then
4250 52349760 : do l=1,nt
4251 1142919360 : do k=1,nz
4252 1090569600 : i = i + 1
4253 1134194400 : array(iDst,jDst,k,l,dstBlock) = bufRecv(i,nmsg)
4254 : end do
4255 : end do
4256 0 : else if (dstBlock < 0) then !tripole
4257 0 : do l=1,nt
4258 0 : do k=1,nz
4259 0 : i = i + 1
4260 0 : bufTripole(iDst,jDst,k,l) = bufRecv(i,nmsg)
4261 : end do
4262 : end do
4263 : endif
4264 : end do
4265 : end do
4266 :
4267 : !-----------------------------------------------------------------------
4268 : !
4269 : ! take care of northern boundary in tripole case
4270 : ! bufTripole array contains the top nghost+1 rows (u-fold) or nghost+2 rows
4271 : ! (T-fold) of physical domain for entire (global) top row
4272 : !
4273 : !-----------------------------------------------------------------------
4274 :
4275 34596 : if (nxGlobal > 0) then
4276 :
4277 0 : select case (fieldKind)
4278 : case (field_type_scalar)
4279 0 : isign = 1
4280 : case (field_type_vector)
4281 0 : isign = -1
4282 : case (field_type_angle)
4283 0 : isign = -1
4284 : case default
4285 0 : call abort_ice(subname//'ERROR: Unknown field kind')
4286 : end select
4287 :
4288 0 : if (halo%tripoleTFlag) then
4289 :
4290 0 : select case (fieldLoc)
4291 : case (field_loc_center) ! cell center location
4292 :
4293 0 : ioffset = -1
4294 0 : joffset = 0
4295 :
4296 : !*** top row is degenerate, so must enforce symmetry
4297 : !*** use average of two degenerate points for value
4298 :
4299 0 : do l=1,nt
4300 0 : do k=1,nz
4301 0 : do i = 2,nxGlobal/2
4302 0 : iDst = nxGlobal - i + 2
4303 0 : x1 = bufTripole(i ,halo%tripoleRows,k,l)
4304 0 : x2 = bufTripole(iDst,halo%tripoleRows,k,l)
4305 0 : xavg = 0.5_dbl_kind*(x1 + isign*x2)
4306 0 : bufTripole(i ,halo%tripoleRows,k,l) = xavg
4307 0 : bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg
4308 : end do
4309 : end do
4310 : end do
4311 :
4312 : case (field_loc_NEcorner) ! cell corner location
4313 :
4314 0 : ioffset = 0
4315 0 : joffset = 1
4316 :
4317 : case (field_loc_Eface) ! cell center location
4318 :
4319 0 : ioffset = 0
4320 0 : joffset = 0
4321 :
4322 : !*** top row is degenerate, so must enforce symmetry
4323 : !*** use average of two degenerate points for value
4324 :
4325 0 : do l=1,nt
4326 0 : do k=1,nz
4327 0 : do i = 1,nxGlobal/2
4328 0 : iDst = nxGlobal + 1 - i
4329 0 : x1 = bufTripole(i ,halo%tripoleRows,k,l)
4330 0 : x2 = bufTripole(iDst,halo%tripoleRows,k,l)
4331 0 : xavg = 0.5_dbl_kind*(x1 + isign*x2)
4332 0 : bufTripole(i ,halo%tripoleRows,k,l) = xavg
4333 0 : bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg
4334 : end do
4335 : end do
4336 : end do
4337 :
4338 : case (field_loc_Nface) ! cell corner (velocity) location
4339 :
4340 0 : ioffset = -1
4341 0 : joffset = 1
4342 :
4343 : case default
4344 0 : call abort_ice(subname//'ERROR: Unknown field location')
4345 : end select
4346 :
4347 : else ! tripole u-fold
4348 :
4349 0 : select case (fieldLoc)
4350 : case (field_loc_center) ! cell center location
4351 :
4352 0 : ioffset = 0
4353 0 : joffset = 0
4354 :
4355 : case (field_loc_NEcorner) ! cell corner location
4356 :
4357 0 : ioffset = 1
4358 0 : joffset = 1
4359 :
4360 : !*** top row is degenerate, so must enforce symmetry
4361 : !*** use average of two degenerate points for value
4362 :
4363 0 : do l=1,nt
4364 0 : do k=1,nz
4365 0 : do i = 1,nxGlobal/2 - 1
4366 0 : iDst = nxGlobal - i
4367 0 : x1 = bufTripole(i ,halo%tripoleRows,k,l)
4368 0 : x2 = bufTripole(iDst,halo%tripoleRows,k,l)
4369 0 : xavg = 0.5_dbl_kind*(x1 + isign*x2)
4370 0 : bufTripole(i ,halo%tripoleRows,k,l) = xavg
4371 0 : bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg
4372 : end do
4373 : end do
4374 : end do
4375 :
4376 : case (field_loc_Eface) ! cell center location
4377 :
4378 0 : ioffset = 1
4379 0 : joffset = 0
4380 :
4381 : case (field_loc_Nface) ! cell corner (velocity) location
4382 :
4383 0 : ioffset = 0
4384 0 : joffset = 1
4385 :
4386 : !*** top row is degenerate, so must enforce symmetry
4387 : !*** use average of two degenerate points for value
4388 :
4389 0 : do l=1,nt
4390 0 : do k=1,nz
4391 0 : do i = 1,nxGlobal/2
4392 0 : iDst = nxGlobal + 1 - i
4393 0 : x1 = bufTripole(i ,halo%tripoleRows,k,l)
4394 0 : x2 = bufTripole(iDst,halo%tripoleRows,k,l)
4395 0 : xavg = 0.5_dbl_kind*(x1 + isign*x2)
4396 0 : bufTripole(i ,halo%tripoleRows,k,l) = xavg
4397 0 : bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg
4398 : end do
4399 : end do
4400 : end do
4401 :
4402 : case default
4403 0 : call abort_ice(subname//'ERROR: Unknown field location')
4404 : end select
4405 :
4406 : endif
4407 :
4408 : !*** copy out of global tripole buffer into local
4409 : !*** ghost cells
4410 :
4411 : !*** look through local copies to find the copy out
4412 : !*** messages (srcBlock < 0)
4413 :
4414 0 : do nmsg=1,halo%numLocalCopies
4415 0 : srcBlock = halo%srcLocalAddr(3,nmsg)
4416 :
4417 0 : if (srcBlock < 0) then
4418 :
4419 0 : iSrc = halo%srcLocalAddr(1,nmsg) ! tripole buffer addr
4420 0 : jSrc = halo%srcLocalAddr(2,nmsg)
4421 :
4422 0 : iDst = halo%dstLocalAddr(1,nmsg) ! local block addr
4423 0 : jDst = halo%dstLocalAddr(2,nmsg)
4424 0 : dstBlock = halo%dstLocalAddr(3,nmsg)
4425 :
4426 : !*** correct for offsets
4427 0 : iSrc = iSrc - ioffset
4428 0 : jSrc = jSrc - joffset
4429 0 : if (iSrc < 1 ) iSrc = iSrc + nxGlobal
4430 0 : if (iSrc > nxGlobal) iSrc = iSrc - nxGlobal
4431 :
4432 : !*** for center and Eface on u-fold, and NE corner and Nface
4433 : !*** on T-fold, do not need to replace
4434 : !*** top row of physical domain, so jSrc should be
4435 : !*** out of range and skipped
4436 : !*** otherwise do the copy
4437 :
4438 0 : if (jSrc <= halo%tripoleRows .and. jSrc>0 .and. jDst>0) then
4439 0 : do l=1,nt
4440 0 : do k=1,nz
4441 0 : array(iDst,jDst,k,l,dstBlock) = isign* &
4442 0 : bufTripole(iSrc,jSrc,k,l)
4443 : end do
4444 : end do
4445 : endif
4446 :
4447 : endif
4448 : end do
4449 :
4450 : endif
4451 :
4452 : !-----------------------------------------------------------------------
4453 : !
4454 : ! wait for sends to complete and deallocate arrays
4455 : !
4456 : !-----------------------------------------------------------------------
4457 :
4458 34596 : call MPI_WAITALL(halo%numMsgSend, sndRequest, sndStatus, ierr)
4459 :
4460 34596 : deallocate(sndRequest, rcvRequest, sndStatus, rcvStatus, stat=ierr)
4461 :
4462 34596 : if (ierr > 0) then
4463 0 : call abort_ice(subname//'ERROR: deallocating req,status arrays')
4464 0 : return
4465 : endif
4466 :
4467 34596 : deallocate(bufSend, bufRecv, bufTripole, stat=ierr)
4468 :
4469 34596 : if (ierr > 0) then
4470 0 : call abort_ice(subname//'ERROR: deallocating 4d buffers')
4471 0 : return
4472 : endif
4473 :
4474 : !-----------------------------------------------------------------------
4475 :
4476 103788 : end subroutine ice_HaloUpdate4DR8
4477 :
4478 : !***********************************************************************
4479 :
4480 0 : subroutine ice_HaloUpdate4DR4(array, halo, &
4481 : fieldLoc, fieldKind, & ! LCOV_EXCL_LINE
4482 : fillValue)
4483 :
4484 : ! This routine updates ghost cells for an input array and is a
4485 : ! member of a group of routines under the generic interface
4486 : ! ice\_HaloUpdate. This routine is the specific interface
4487 : ! for 4d horizontal arrays of single precision.
4488 :
4489 : type (ice_halo), intent(in) :: &
4490 : halo ! precomputed halo structure containing all
4491 : ! information needed for halo update
4492 :
4493 : integer (int_kind), intent(in) :: &
4494 : fieldKind, &! id for type of field (scalar, vector, angle) ! LCOV_EXCL_LINE
4495 : fieldLoc ! id for location on horizontal grid
4496 : ! (center, NEcorner, Nface, Eface)
4497 :
4498 : real (real_kind), intent(in), optional :: &
4499 : fillValue ! optional value to put in ghost cells
4500 : ! where neighbor points are unknown
4501 : ! (e.g. eliminated land blocks or
4502 : ! closed boundaries)
4503 :
4504 : real (real_kind), dimension(:,:,:,:,:), intent(inout) :: &
4505 : array ! array containing field for which halo
4506 : ! needs to be updated
4507 :
4508 : !-----------------------------------------------------------------------
4509 : !
4510 : ! local variables
4511 : !
4512 : !-----------------------------------------------------------------------
4513 :
4514 : integer (int_kind) :: &
4515 : i,j,k,l,n,nmsg, &! dummy loop indices ! LCOV_EXCL_LINE
4516 : iblk,ilo,ihi,jlo,jhi, &! block sizes for fill ! LCOV_EXCL_LINE
4517 : ierr, &! error or status flag for MPI,alloc ! LCOV_EXCL_LINE
4518 : nxGlobal, &! global domain size in x (tripole) ! LCOV_EXCL_LINE
4519 : nz, nt, &! size of array in 3rd,4th dimensions ! LCOV_EXCL_LINE
4520 : iSrc,jSrc, &! source addresses for message ! LCOV_EXCL_LINE
4521 : iDst,jDst, &! dest addresses for message ! LCOV_EXCL_LINE
4522 : srcBlock, &! local block number for source ! LCOV_EXCL_LINE
4523 : dstBlock, &! local block number for destination ! LCOV_EXCL_LINE
4524 : ioffset, joffset, &! address shifts for tripole ! LCOV_EXCL_LINE
4525 : isign ! sign factor for tripole grids
4526 :
4527 : integer (int_kind), dimension(:), allocatable :: &
4528 : sndRequest, &! MPI request ids ! LCOV_EXCL_LINE
4529 0 : rcvRequest ! MPI request ids
4530 :
4531 : integer (int_kind), dimension(:,:), allocatable :: &
4532 : sndStatus, &! MPI status flags ! LCOV_EXCL_LINE
4533 0 : rcvStatus ! MPI status flags
4534 :
4535 : real (real_kind) :: &
4536 : fill, &! value to use for unknown points ! LCOV_EXCL_LINE
4537 0 : x1,x2,xavg ! scalars for enforcing symmetry at U pts
4538 :
4539 : real (real_kind), dimension(:,:), allocatable :: &
4540 0 : bufSend, bufRecv ! 4d send,recv buffers
4541 :
4542 : real (real_kind), dimension(:,:,:,:), allocatable :: &
4543 0 : bufTripole ! 4d tripole buffer
4544 :
4545 : integer (int_kind) :: len ! length of message
4546 :
4547 : character(len=*), parameter :: subname = '(ice_HaloUpdate4DR4)'
4548 :
4549 : !-----------------------------------------------------------------------
4550 : !
4551 : ! abort or return on unknown or noupdate field_loc or field_type
4552 : !
4553 : !-----------------------------------------------------------------------
4554 :
4555 0 : if (fieldLoc == field_loc_unknown .or. &
4556 : fieldKind == field_type_unknown) then
4557 0 : call abort_ice(subname//'ERROR: use of field_loc/type_unknown not allowed')
4558 0 : return
4559 : endif
4560 :
4561 0 : if (fieldLoc == field_loc_noupdate .or. &
4562 : fieldKind == field_type_noupdate) then
4563 0 : return
4564 : endif
4565 :
4566 : !-----------------------------------------------------------------------
4567 : !
4568 : ! initialize error code and fill value
4569 : !
4570 : !-----------------------------------------------------------------------
4571 :
4572 0 : if (present(fillValue)) then
4573 0 : fill = fillValue
4574 : else
4575 0 : fill = 0.0_real_kind
4576 : endif
4577 :
4578 0 : nxGlobal = 0
4579 0 : if (allocated(bufTripoleR4)) nxGlobal = size(bufTripoleR4,dim=1)
4580 :
4581 : !-----------------------------------------------------------------------
4582 : !
4583 : ! allocate request and status arrays for messages
4584 : !
4585 : !-----------------------------------------------------------------------
4586 :
4587 : allocate(sndRequest(halo%numMsgSend), &
4588 : rcvRequest(halo%numMsgRecv), & ! LCOV_EXCL_LINE
4589 : sndStatus(MPI_STATUS_SIZE,halo%numMsgSend), & ! LCOV_EXCL_LINE
4590 0 : rcvStatus(MPI_STATUS_SIZE,halo%numMsgRecv), stat=ierr)
4591 :
4592 0 : if (ierr > 0) then
4593 0 : call abort_ice(subname//'ERROR: allocating req,status arrays')
4594 0 : return
4595 : endif
4596 :
4597 : !-----------------------------------------------------------------------
4598 : !
4599 : ! allocate 4D buffers
4600 : !
4601 : !-----------------------------------------------------------------------
4602 :
4603 0 : nz = size(array, dim=3)
4604 0 : nt = size(array, dim=4)
4605 :
4606 : allocate(bufSend(bufSizeSend*nz*nt, halo%numMsgSend), &
4607 : bufRecv(bufSizeRecv*nz*nt, halo%numMsgRecv), & ! LCOV_EXCL_LINE
4608 : bufTripole(nxGlobal, halo%tripoleRows, nz, nt), & ! LCOV_EXCL_LINE
4609 0 : stat=ierr)
4610 :
4611 0 : if (ierr > 0) then
4612 0 : call abort_ice(subname//'ERROR: allocating buffers')
4613 0 : return
4614 : endif
4615 :
4616 0 : bufTripole = fill
4617 :
4618 : !-----------------------------------------------------------------------
4619 : !
4620 : ! post receives
4621 : !
4622 : !-----------------------------------------------------------------------
4623 :
4624 0 : do nmsg=1,halo%numMsgRecv
4625 :
4626 0 : len = halo%SizeRecv(nmsg)*nz*nt
4627 0 : call MPI_IRECV(bufRecv(1:len,nmsg), len, mpiR4, &
4628 : halo%recvTask(nmsg), & ! LCOV_EXCL_LINE
4629 : mpitagHalo + halo%recvTask(nmsg), & ! LCOV_EXCL_LINE
4630 0 : halo%communicator, rcvRequest(nmsg), ierr)
4631 : end do
4632 :
4633 : !-----------------------------------------------------------------------
4634 : !
4635 : ! fill send buffer and post sends
4636 : !
4637 : !-----------------------------------------------------------------------
4638 :
4639 0 : do nmsg=1,halo%numMsgSend
4640 :
4641 0 : i=0
4642 0 : do n=1,halo%sizeSend(nmsg)
4643 0 : iSrc = halo%sendAddr(1,n,nmsg)
4644 0 : jSrc = halo%sendAddr(2,n,nmsg)
4645 0 : srcBlock = halo%sendAddr(3,n,nmsg)
4646 :
4647 0 : do l=1,nt
4648 0 : do k=1,nz
4649 0 : i = i + 1
4650 0 : bufSend(i,nmsg) = array(iSrc,jSrc,k,l,srcBlock)
4651 : end do
4652 : end do
4653 : end do
4654 :
4655 0 : do n=i+1,bufSizeSend*nz*nt
4656 0 : bufSend(n,nmsg) = fill ! fill remainder of buffer
4657 : end do
4658 :
4659 0 : len = halo%SizeSend(nmsg)*nz*nt
4660 0 : call MPI_ISEND(bufSend(1:len,nmsg), len, mpiR4, &
4661 : halo%sendTask(nmsg), & ! LCOV_EXCL_LINE
4662 : mpitagHalo + my_task, & ! LCOV_EXCL_LINE
4663 0 : halo%communicator, sndRequest(nmsg), ierr)
4664 : end do
4665 :
4666 : !-----------------------------------------------------------------------
4667 : !
4668 : ! while messages are being communicated, fill out halo region
4669 : ! needed for masked halos to ensure halo values are filled for
4670 : ! halo grid cells that are not updated
4671 : !
4672 : !-----------------------------------------------------------------------
4673 :
4674 0 : do iblk = 1, halo%numLocalBlocks
4675 0 : call get_block_parameter(halo%blockGlobalID(iblk), &
4676 : ilo=ilo, ihi=ihi, & ! LCOV_EXCL_LINE
4677 0 : jlo=jlo, jhi=jhi)
4678 0 : do j = 1,nghost
4679 0 : array(1:nx_block, jlo-j,:,:,iblk) = fill
4680 0 : array(1:nx_block, jhi+j,:,:,iblk) = fill
4681 : enddo
4682 0 : do i = 1,nghost
4683 0 : array(ilo-i, 1:ny_block,:,:,iblk) = fill
4684 0 : array(ihi+i, 1:ny_block,:,:,iblk) = fill
4685 : enddo
4686 : enddo
4687 :
4688 : !-----------------------------------------------------------------------
4689 : !
4690 : ! do local copies while waiting for messages to complete
4691 : ! if srcBlock is zero, that denotes an eliminated land block or a
4692 : ! closed boundary where ghost cell values are undefined
4693 : ! if srcBlock is less than zero, the message is a copy out of the
4694 : ! tripole buffer and will be treated later
4695 : !
4696 : !-----------------------------------------------------------------------
4697 :
4698 0 : do nmsg=1,halo%numLocalCopies
4699 0 : iSrc = halo%srcLocalAddr(1,nmsg)
4700 0 : jSrc = halo%srcLocalAddr(2,nmsg)
4701 0 : srcBlock = halo%srcLocalAddr(3,nmsg)
4702 0 : iDst = halo%dstLocalAddr(1,nmsg)
4703 0 : jDst = halo%dstLocalAddr(2,nmsg)
4704 0 : dstBlock = halo%dstLocalAddr(3,nmsg)
4705 :
4706 0 : if (srcBlock > 0) then
4707 0 : if (dstBlock > 0) then
4708 0 : do l=1,nt
4709 0 : do k=1,nz
4710 0 : array(iDst,jDst,k,l,dstBlock) = &
4711 0 : array(iSrc,jSrc,k,l,srcBlock)
4712 : end do
4713 : end do
4714 0 : else if (dstBlock < 0) then ! tripole copy into buffer
4715 0 : do l=1,nt
4716 0 : do k=1,nz
4717 0 : bufTripole(iDst,jDst,k,l) = &
4718 0 : array(iSrc,jSrc,k,l,srcBlock)
4719 : end do
4720 : end do
4721 : endif
4722 0 : else if (srcBlock == 0) then
4723 0 : do l=1,nt
4724 0 : do k=1,nz
4725 0 : array(iDst,jDst,k,l,dstBlock) = fill
4726 : end do
4727 : end do
4728 : endif
4729 : end do
4730 :
4731 : !-----------------------------------------------------------------------
4732 : !
4733 : ! wait for receives to finish and then unpack the recv buffer into
4734 : ! ghost cells
4735 : !
4736 : !-----------------------------------------------------------------------
4737 :
4738 0 : call MPI_WAITALL(halo%numMsgRecv, rcvRequest, rcvStatus, ierr)
4739 :
4740 0 : do nmsg=1,halo%numMsgRecv
4741 0 : i = 0
4742 0 : do n=1,halo%sizeRecv(nmsg)
4743 0 : iDst = halo%recvAddr(1,n,nmsg)
4744 0 : jDst = halo%recvAddr(2,n,nmsg)
4745 0 : dstBlock = halo%recvAddr(3,n,nmsg)
4746 :
4747 0 : if (dstBlock > 0) then
4748 0 : do l=1,nt
4749 0 : do k=1,nz
4750 0 : i = i + 1
4751 0 : array(iDst,jDst,k,l,dstBlock) = bufRecv(i,nmsg)
4752 : end do
4753 : end do
4754 0 : else if (dstBlock < 0) then !tripole
4755 0 : do l=1,nt
4756 0 : do k=1,nz
4757 0 : i = i + 1
4758 0 : bufTripole(iDst,jDst,k,l) = bufRecv(i,nmsg)
4759 : end do
4760 : end do
4761 : endif
4762 : end do
4763 : end do
4764 :
4765 : !-----------------------------------------------------------------------
4766 : !
4767 : ! take care of northern boundary in tripole case
4768 : ! bufTripole array contains the top nghost+1 rows (u-fold) or nghost+2 rows
4769 : ! (T-fold) of physical domain for entire (global) top row
4770 : !
4771 : !-----------------------------------------------------------------------
4772 :
4773 0 : if (nxGlobal > 0) then
4774 :
4775 0 : select case (fieldKind)
4776 : case (field_type_scalar)
4777 0 : isign = 1
4778 : case (field_type_vector)
4779 0 : isign = -1
4780 : case (field_type_angle)
4781 0 : isign = -1
4782 : case default
4783 0 : call abort_ice(subname//'ERROR: Unknown field kind')
4784 : end select
4785 :
4786 0 : if (halo%tripoleTFlag) then
4787 :
4788 0 : select case (fieldLoc)
4789 : case (field_loc_center) ! cell center location
4790 :
4791 0 : ioffset = -1
4792 0 : joffset = 0
4793 :
4794 : !*** top row is degenerate, so must enforce symmetry
4795 : !*** use average of two degenerate points for value
4796 :
4797 0 : do l=1,nt
4798 0 : do k=1,nz
4799 0 : do i = 2,nxGlobal/2
4800 0 : iDst = nxGlobal - i + 2
4801 0 : x1 = bufTripole(i ,halo%tripoleRows,k,l)
4802 0 : x2 = bufTripole(iDst,halo%tripoleRows,k,l)
4803 0 : xavg = 0.5_real_kind*(x1 + isign*x2)
4804 0 : bufTripole(i ,halo%tripoleRows,k,l) = xavg
4805 0 : bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg
4806 : end do
4807 : end do
4808 : end do
4809 :
4810 : case (field_loc_NEcorner) ! cell corner location
4811 :
4812 0 : ioffset = 0
4813 0 : joffset = 1
4814 :
4815 : case (field_loc_Eface) ! cell center location
4816 :
4817 0 : ioffset = 0
4818 0 : joffset = 0
4819 :
4820 : !*** top row is degenerate, so must enforce symmetry
4821 : !*** use average of two degenerate points for value
4822 :
4823 0 : do l=1,nt
4824 0 : do k=1,nz
4825 0 : do i = 1,nxGlobal/2
4826 0 : iDst = nxGlobal + 1 - i
4827 0 : x1 = bufTripole(i ,halo%tripoleRows,k,l)
4828 0 : x2 = bufTripole(iDst,halo%tripoleRows,k,l)
4829 0 : xavg = 0.5_real_kind*(x1 + isign*x2)
4830 0 : bufTripole(i ,halo%tripoleRows,k,l) = xavg
4831 0 : bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg
4832 : end do
4833 : end do
4834 : end do
4835 :
4836 : case (field_loc_Nface) ! cell corner (velocity) location
4837 :
4838 0 : ioffset = -1
4839 0 : joffset = 1
4840 :
4841 : case default
4842 0 : call abort_ice(subname//'ERROR: Unknown field location')
4843 : end select
4844 :
4845 : else ! tripole u-fold
4846 :
4847 0 : select case (fieldLoc)
4848 : case (field_loc_center) ! cell center location
4849 :
4850 0 : ioffset = 0
4851 0 : joffset = 0
4852 :
4853 : case (field_loc_NEcorner) ! cell corner location
4854 :
4855 0 : ioffset = 1
4856 0 : joffset = 1
4857 :
4858 : !*** top row is degenerate, so must enforce symmetry
4859 : !*** use average of two degenerate points for value
4860 :
4861 0 : do l=1,nt
4862 0 : do k=1,nz
4863 0 : do i = 1,nxGlobal/2 - 1
4864 0 : iDst = nxGlobal - i
4865 0 : x1 = bufTripole(i ,halo%tripoleRows,k,l)
4866 0 : x2 = bufTripole(iDst,halo%tripoleRows,k,l)
4867 0 : xavg = 0.5_real_kind*(x1 + isign*x2)
4868 0 : bufTripole(i ,halo%tripoleRows,k,l) = xavg
4869 0 : bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg
4870 : end do
4871 : end do
4872 : end do
4873 :
4874 : case (field_loc_Eface) ! cell center location
4875 :
4876 0 : ioffset = 1
4877 0 : joffset = 0
4878 :
4879 : case (field_loc_Nface) ! cell corner (velocity) location
4880 :
4881 0 : ioffset = 0
4882 0 : joffset = 1
4883 :
4884 : !*** top row is degenerate, so must enforce symmetry
4885 : !*** use average of two degenerate points for value
4886 :
4887 0 : do l=1,nt
4888 0 : do k=1,nz
4889 0 : do i = 1,nxGlobal/2
4890 0 : iDst = nxGlobal + 1 - i
4891 0 : x1 = bufTripole(i ,halo%tripoleRows,k,l)
4892 0 : x2 = bufTripole(iDst,halo%tripoleRows,k,l)
4893 0 : xavg = 0.5_real_kind*(x1 + isign*x2)
4894 0 : bufTripole(i ,halo%tripoleRows,k,l) = xavg
4895 0 : bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg
4896 : end do
4897 : end do
4898 : end do
4899 :
4900 : case default
4901 0 : call abort_ice(subname//'ERROR: Unknown field location')
4902 : end select
4903 :
4904 : endif
4905 :
4906 : !*** copy out of global tripole buffer into local
4907 : !*** ghost cells
4908 :
4909 : !*** look through local copies to find the copy out
4910 : !*** messages (srcBlock < 0)
4911 :
4912 0 : do nmsg=1,halo%numLocalCopies
4913 0 : srcBlock = halo%srcLocalAddr(3,nmsg)
4914 :
4915 0 : if (srcBlock < 0) then
4916 :
4917 0 : iSrc = halo%srcLocalAddr(1,nmsg) ! tripole buffer addr
4918 0 : jSrc = halo%srcLocalAddr(2,nmsg)
4919 :
4920 0 : iDst = halo%dstLocalAddr(1,nmsg) ! local block addr
4921 0 : jDst = halo%dstLocalAddr(2,nmsg)
4922 0 : dstBlock = halo%dstLocalAddr(3,nmsg)
4923 :
4924 : !*** correct for offsets
4925 0 : iSrc = iSrc - ioffset
4926 0 : jSrc = jSrc - joffset
4927 0 : if (iSrc < 1 ) iSrc = iSrc + nxGlobal
4928 0 : if (iSrc > nxGlobal) iSrc = iSrc - nxGlobal
4929 :
4930 : !*** for center and Eface on u-fold, and NE corner and Nface
4931 : !*** on T-fold, do not need to replace
4932 : !*** top row of physical domain, so jSrc should be
4933 : !*** out of range and skipped
4934 : !*** otherwise do the copy
4935 :
4936 0 : if (jSrc <= halo%tripoleRows .and. jSrc>0 .and. jDst>0) then
4937 0 : do l=1,nt
4938 0 : do k=1,nz
4939 0 : array(iDst,jDst,k,l,dstBlock) = isign* &
4940 0 : bufTripole(iSrc,jSrc,k,l)
4941 : end do
4942 : end do
4943 : endif
4944 :
4945 : endif
4946 : end do
4947 :
4948 : endif
4949 :
4950 : !-----------------------------------------------------------------------
4951 : !
4952 : ! wait for sends to complete and deallocate arrays
4953 : !
4954 : !-----------------------------------------------------------------------
4955 :
4956 0 : call MPI_WAITALL(halo%numMsgSend, sndRequest, sndStatus, ierr)
4957 :
4958 0 : deallocate(sndRequest, rcvRequest, sndStatus, rcvStatus, stat=ierr)
4959 :
4960 0 : if (ierr > 0) then
4961 0 : call abort_ice(subname//'ERROR: deallocating req,status arrays')
4962 0 : return
4963 : endif
4964 :
4965 0 : deallocate(bufSend, bufRecv, bufTripole, stat=ierr)
4966 :
4967 0 : if (ierr > 0) then
4968 0 : call abort_ice(subname//'ERROR: deallocating 4d buffers')
4969 0 : return
4970 : endif
4971 :
4972 : !-----------------------------------------------------------------------
4973 :
4974 0 : end subroutine ice_HaloUpdate4DR4
4975 :
4976 : !***********************************************************************
4977 :
4978 0 : subroutine ice_HaloUpdate4DI4(array, halo, &
4979 : fieldLoc, fieldKind, & ! LCOV_EXCL_LINE
4980 : fillValue)
4981 :
4982 : ! This routine updates ghost cells for an input array and is a
4983 : ! member of a group of routines under the generic interface
4984 : ! ice\_HaloUpdate. This routine is the specific interface
4985 : ! for 4d horizontal integer arrays.
4986 :
4987 : type (ice_halo), intent(in) :: &
4988 : halo ! precomputed halo structure containing all
4989 : ! information needed for halo update
4990 :
4991 : integer (int_kind), intent(in) :: &
4992 : fieldKind, &! id for type of field (scalar, vector, angle) ! LCOV_EXCL_LINE
4993 : fieldLoc ! id for location on horizontal grid
4994 : ! (center, NEcorner, Nface, Eface)
4995 :
4996 : integer (int_kind), intent(in), optional :: &
4997 : fillValue ! optional value to put in ghost cells
4998 : ! where neighbor points are unknown
4999 : ! (e.g. eliminated land blocks or
5000 : ! closed boundaries)
5001 :
5002 : integer (int_kind), dimension(:,:,:,:,:), intent(inout) :: &
5003 : array ! array containing field for which halo
5004 : ! needs to be updated
5005 :
5006 : !-----------------------------------------------------------------------
5007 : !
5008 : ! local variables
5009 : !
5010 : !-----------------------------------------------------------------------
5011 :
5012 : integer (int_kind) :: &
5013 : i,j,k,l,n,nmsg, &! dummy loop indices ! LCOV_EXCL_LINE
5014 : iblk,ilo,ihi,jlo,jhi, &! block sizes for fill ! LCOV_EXCL_LINE
5015 : ierr, &! error or status flag for MPI,alloc ! LCOV_EXCL_LINE
5016 : nxGlobal, &! global domain size in x (tripole) ! LCOV_EXCL_LINE
5017 : nz, nt, &! size of array in 3rd,4th dimensions ! LCOV_EXCL_LINE
5018 : iSrc,jSrc, &! source addresses for message ! LCOV_EXCL_LINE
5019 : iDst,jDst, &! dest addresses for message ! LCOV_EXCL_LINE
5020 : srcBlock, &! local block number for source ! LCOV_EXCL_LINE
5021 : dstBlock, &! local block number for destination ! LCOV_EXCL_LINE
5022 : ioffset, joffset, &! address shifts for tripole ! LCOV_EXCL_LINE
5023 : isign ! sign factor for tripole grids
5024 :
5025 : integer (int_kind), dimension(:), allocatable :: &
5026 : sndRequest, &! MPI request ids ! LCOV_EXCL_LINE
5027 0 : rcvRequest ! MPI request ids
5028 :
5029 : integer (int_kind), dimension(:,:), allocatable :: &
5030 : sndStatus, &! MPI status flags ! LCOV_EXCL_LINE
5031 0 : rcvStatus ! MPI status flags
5032 :
5033 : integer (int_kind) :: &
5034 : fill, &! value to use for unknown points ! LCOV_EXCL_LINE
5035 : x1,x2,xavg ! scalars for enforcing symmetry at U pts
5036 :
5037 : integer (int_kind), dimension(:,:), allocatable :: &
5038 0 : bufSend, bufRecv ! 4d send,recv buffers
5039 :
5040 : integer (int_kind), dimension(:,:,:,:), allocatable :: &
5041 0 : bufTripole ! 4d tripole buffer
5042 :
5043 : integer (int_kind) :: len ! length of messages
5044 :
5045 : character(len=*), parameter :: subname = '(ice_HaloUpdate4DI4)'
5046 :
5047 : !-----------------------------------------------------------------------
5048 : !
5049 : ! abort or return on unknown or noupdate field_loc or field_type
5050 : !
5051 : !-----------------------------------------------------------------------
5052 :
5053 0 : if (fieldLoc == field_loc_unknown .or. &
5054 : fieldKind == field_type_unknown) then
5055 0 : call abort_ice(subname//'ERROR: use of field_loc/type_unknown not allowed')
5056 0 : return
5057 : endif
5058 :
5059 0 : if (fieldLoc == field_loc_noupdate .or. &
5060 : fieldKind == field_type_noupdate) then
5061 0 : return
5062 : endif
5063 :
5064 : !-----------------------------------------------------------------------
5065 : !
5066 : ! initialize error code and fill value
5067 : !
5068 : !-----------------------------------------------------------------------
5069 :
5070 0 : if (present(fillValue)) then
5071 0 : fill = fillValue
5072 : else
5073 0 : fill = 0_int_kind
5074 : endif
5075 :
5076 0 : nxGlobal = 0
5077 0 : if (allocated(bufTripoleI4)) nxGlobal = size(bufTripoleI4,dim=1)
5078 :
5079 : !-----------------------------------------------------------------------
5080 : !
5081 : ! allocate request and status arrays for messages
5082 : !
5083 : !-----------------------------------------------------------------------
5084 :
5085 : allocate(sndRequest(halo%numMsgSend), &
5086 : rcvRequest(halo%numMsgRecv), & ! LCOV_EXCL_LINE
5087 : sndStatus(MPI_STATUS_SIZE,halo%numMsgSend), & ! LCOV_EXCL_LINE
5088 0 : rcvStatus(MPI_STATUS_SIZE,halo%numMsgRecv), stat=ierr)
5089 :
5090 0 : if (ierr > 0) then
5091 0 : call abort_ice(subname//'ERROR: allocating req,status arrays')
5092 0 : return
5093 : endif
5094 :
5095 : !-----------------------------------------------------------------------
5096 : !
5097 : ! allocate 4D buffers
5098 : !
5099 : !-----------------------------------------------------------------------
5100 :
5101 0 : nz = size(array, dim=3)
5102 0 : nt = size(array, dim=4)
5103 :
5104 : allocate(bufSend(bufSizeSend*nz*nt, halo%numMsgSend), &
5105 : bufRecv(bufSizeRecv*nz*nt, halo%numMsgRecv), & ! LCOV_EXCL_LINE
5106 : bufTripole(nxGlobal, halo%tripoleRows, nz, nt), & ! LCOV_EXCL_LINE
5107 0 : stat=ierr)
5108 :
5109 0 : if (ierr > 0) then
5110 0 : call abort_ice(subname//'ERROR: allocating buffers')
5111 0 : return
5112 : endif
5113 :
5114 0 : bufTripole = fill
5115 :
5116 : !-----------------------------------------------------------------------
5117 : !
5118 : ! post receives
5119 : !
5120 : !-----------------------------------------------------------------------
5121 :
5122 0 : do nmsg=1,halo%numMsgRecv
5123 :
5124 0 : len = halo%SizeRecv(nmsg)*nz*nt
5125 0 : call MPI_IRECV(bufRecv(1:len,nmsg), len, MPI_INTEGER, &
5126 : halo%recvTask(nmsg), & ! LCOV_EXCL_LINE
5127 : mpitagHalo + halo%recvTask(nmsg), & ! LCOV_EXCL_LINE
5128 0 : halo%communicator, rcvRequest(nmsg), ierr)
5129 : end do
5130 :
5131 : !-----------------------------------------------------------------------
5132 : !
5133 : ! fill send buffer and post sends
5134 : !
5135 : !-----------------------------------------------------------------------
5136 :
5137 0 : do nmsg=1,halo%numMsgSend
5138 :
5139 0 : i=0
5140 0 : do n=1,halo%sizeSend(nmsg)
5141 0 : iSrc = halo%sendAddr(1,n,nmsg)
5142 0 : jSrc = halo%sendAddr(2,n,nmsg)
5143 0 : srcBlock = halo%sendAddr(3,n,nmsg)
5144 :
5145 0 : do l=1,nt
5146 0 : do k=1,nz
5147 0 : i = i + 1
5148 0 : bufSend(i,nmsg) = array(iSrc,jSrc,k,l,srcBlock)
5149 : end do
5150 : end do
5151 : end do
5152 :
5153 0 : do n=i+1,bufSizeSend*nz*nt
5154 0 : bufSend(n,nmsg) = fill ! fill remainder of buffer
5155 : end do
5156 :
5157 0 : len = halo%SizeSend(nmsg)*nz*nt
5158 0 : call MPI_ISEND(bufSend(1:len,nmsg), len, MPI_INTEGER, &
5159 : halo%sendTask(nmsg), & ! LCOV_EXCL_LINE
5160 : mpitagHalo + my_task, & ! LCOV_EXCL_LINE
5161 0 : halo%communicator, sndRequest(nmsg), ierr)
5162 : end do
5163 :
5164 : !-----------------------------------------------------------------------
5165 : !
5166 : ! while messages are being communicated, fill out halo region
5167 : ! needed for masked halos to ensure halo values are filled for
5168 : ! halo grid cells that are not updated
5169 : !
5170 : !-----------------------------------------------------------------------
5171 :
5172 0 : do iblk = 1, halo%numLocalBlocks
5173 0 : call get_block_parameter(halo%blockGlobalID(iblk), &
5174 : ilo=ilo, ihi=ihi, & ! LCOV_EXCL_LINE
5175 0 : jlo=jlo, jhi=jhi)
5176 0 : do j = 1,nghost
5177 0 : array(1:nx_block, jlo-j,:,:,iblk) = fill
5178 0 : array(1:nx_block, jhi+j,:,:,iblk) = fill
5179 : enddo
5180 0 : do i = 1,nghost
5181 0 : array(ilo-i, 1:ny_block,:,:,iblk) = fill
5182 0 : array(ihi+i, 1:ny_block,:,:,iblk) = fill
5183 : enddo
5184 : enddo
5185 :
5186 : !-----------------------------------------------------------------------
5187 : !
5188 : ! do local copies while waiting for messages to complete
5189 : ! if srcBlock is zero, that denotes an eliminated land block or a
5190 : ! closed boundary where ghost cell values are undefined
5191 : ! if srcBlock is less than zero, the message is a copy out of the
5192 : ! tripole buffer and will be treated later
5193 : !
5194 : !-----------------------------------------------------------------------
5195 :
5196 0 : do nmsg=1,halo%numLocalCopies
5197 0 : iSrc = halo%srcLocalAddr(1,nmsg)
5198 0 : jSrc = halo%srcLocalAddr(2,nmsg)
5199 0 : srcBlock = halo%srcLocalAddr(3,nmsg)
5200 0 : iDst = halo%dstLocalAddr(1,nmsg)
5201 0 : jDst = halo%dstLocalAddr(2,nmsg)
5202 0 : dstBlock = halo%dstLocalAddr(3,nmsg)
5203 :
5204 0 : if (srcBlock > 0) then
5205 0 : if (dstBlock > 0) then
5206 0 : do l=1,nt
5207 0 : do k=1,nz
5208 0 : array(iDst,jDst,k,l,dstBlock) = &
5209 0 : array(iSrc,jSrc,k,l,srcBlock)
5210 : end do
5211 : end do
5212 0 : else if (dstBlock < 0) then ! tripole copy into buffer
5213 0 : do l=1,nt
5214 0 : do k=1,nz
5215 0 : bufTripole(iDst,jDst,k,l) = &
5216 0 : array(iSrc,jSrc,k,l,srcBlock)
5217 : end do
5218 : end do
5219 : endif
5220 0 : else if (srcBlock == 0) then
5221 0 : do l=1,nt
5222 0 : do k=1,nz
5223 0 : array(iDst,jDst,k,l,dstBlock) = fill
5224 : end do
5225 : end do
5226 : endif
5227 : end do
5228 :
5229 : !-----------------------------------------------------------------------
5230 : !
5231 : ! wait for receives to finish and then unpack the recv buffer into
5232 : ! ghost cells
5233 : !
5234 : !-----------------------------------------------------------------------
5235 :
5236 0 : call MPI_WAITALL(halo%numMsgRecv, rcvRequest, rcvStatus, ierr)
5237 :
5238 0 : do nmsg=1,halo%numMsgRecv
5239 0 : i = 0
5240 0 : do n=1,halo%sizeRecv(nmsg)
5241 0 : iDst = halo%recvAddr(1,n,nmsg)
5242 0 : jDst = halo%recvAddr(2,n,nmsg)
5243 0 : dstBlock = halo%recvAddr(3,n,nmsg)
5244 :
5245 0 : if (dstBlock > 0) then
5246 0 : do l=1,nt
5247 0 : do k=1,nz
5248 0 : i = i + 1
5249 0 : array(iDst,jDst,k,l,dstBlock) = bufRecv(i,nmsg)
5250 : end do
5251 : end do
5252 0 : else if (dstBlock < 0) then !tripole
5253 0 : do l=1,nt
5254 0 : do k=1,nz
5255 0 : i = i + 1
5256 0 : bufTripole(iDst,jDst,k,l) = bufRecv(i,nmsg)
5257 : end do
5258 : end do
5259 : endif
5260 : end do
5261 : end do
5262 :
5263 : !-----------------------------------------------------------------------
5264 : !
5265 : ! take care of northern boundary in tripole case
5266 : ! bufTripole array contains the top nghost+1 rows (u-fold) or nghost+2 rows
5267 : ! (T-fold) of physical domain for entire (global) top row
5268 : !
5269 : !-----------------------------------------------------------------------
5270 :
5271 0 : if (nxGlobal > 0) then
5272 :
5273 0 : select case (fieldKind)
5274 : case (field_type_scalar)
5275 0 : isign = 1
5276 : case (field_type_vector)
5277 0 : isign = -1
5278 : case (field_type_angle)
5279 0 : isign = -1
5280 : case default
5281 0 : call abort_ice(subname//'ERROR: Unknown field kind')
5282 : end select
5283 :
5284 0 : if (halo%tripoleTFlag) then
5285 :
5286 0 : select case (fieldLoc)
5287 : case (field_loc_center) ! cell center location
5288 :
5289 0 : ioffset = -1
5290 0 : joffset = 0
5291 :
5292 : !*** top row is degenerate, so must enforce symmetry
5293 : !*** use average of two degenerate points for value
5294 :
5295 0 : do l=1,nt
5296 0 : do k=1,nz
5297 0 : do i = 2,nxGlobal/2
5298 0 : iDst = nxGlobal - i + 2
5299 0 : x1 = bufTripole(i ,halo%tripoleRows,k,l)
5300 0 : x2 = bufTripole(iDst,halo%tripoleRows,k,l)
5301 0 : xavg = nint(0.5_dbl_kind*(x1 + isign*x2))
5302 0 : bufTripole(i ,halo%tripoleRows,k,l) = xavg
5303 0 : bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg
5304 : end do
5305 : end do
5306 : end do
5307 :
5308 : case (field_loc_NEcorner) ! cell corner location
5309 :
5310 0 : ioffset = 0
5311 0 : joffset = 1
5312 :
5313 : case (field_loc_Eface) ! cell center location
5314 :
5315 0 : ioffset = 0
5316 0 : joffset = 0
5317 :
5318 : !*** top row is degenerate, so must enforce symmetry
5319 : !*** use average of two degenerate points for value
5320 :
5321 0 : do l=1,nt
5322 0 : do k=1,nz
5323 0 : do i = 1,nxGlobal/2
5324 0 : iDst = nxGlobal + 1 - i
5325 0 : x1 = bufTripole(i ,halo%tripoleRows,k,l)
5326 0 : x2 = bufTripole(iDst,halo%tripoleRows,k,l)
5327 0 : xavg = nint(0.5_dbl_kind*(x1 + isign*x2))
5328 0 : bufTripole(i ,halo%tripoleRows,k,l) = xavg
5329 0 : bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg
5330 : end do
5331 : end do
5332 : end do
5333 :
5334 : case (field_loc_Nface) ! cell corner (velocity) location
5335 :
5336 0 : ioffset = -1
5337 0 : joffset = 1
5338 :
5339 : case default
5340 0 : call abort_ice(subname//'ERROR: Unknown field location')
5341 : end select
5342 :
5343 : else ! tripole u-fold
5344 :
5345 0 : select case (fieldLoc)
5346 : case (field_loc_center) ! cell center location
5347 :
5348 0 : ioffset = 0
5349 0 : joffset = 0
5350 :
5351 : case (field_loc_NEcorner) ! cell corner location
5352 :
5353 0 : ioffset = 1
5354 0 : joffset = 1
5355 :
5356 : !*** top row is degenerate, so must enforce symmetry
5357 : !*** use average of two degenerate points for value
5358 :
5359 0 : do l=1,nt
5360 0 : do k=1,nz
5361 0 : do i = 1,nxGlobal/2 - 1
5362 0 : iDst = nxGlobal - i
5363 0 : x1 = bufTripole(i ,halo%tripoleRows,k,l)
5364 0 : x2 = bufTripole(iDst,halo%tripoleRows,k,l)
5365 0 : xavg = nint(0.5_dbl_kind*(x1 + isign*x2))
5366 0 : bufTripole(i ,halo%tripoleRows,k,l) = xavg
5367 0 : bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg
5368 : end do
5369 : end do
5370 : end do
5371 :
5372 : case (field_loc_Eface) ! cell center location
5373 :
5374 0 : ioffset = 1
5375 0 : joffset = 0
5376 :
5377 : case (field_loc_Nface) ! cell corner (velocity) location
5378 :
5379 0 : ioffset = 0
5380 0 : joffset = 1
5381 :
5382 : !*** top row is degenerate, so must enforce symmetry
5383 : !*** use average of two degenerate points for value
5384 :
5385 0 : do l=1,nt
5386 0 : do k=1,nz
5387 0 : do i = 1,nxGlobal/2
5388 0 : iDst = nxGlobal + 1 - i
5389 0 : x1 = bufTripole(i ,halo%tripoleRows,k,l)
5390 0 : x2 = bufTripole(iDst,halo%tripoleRows,k,l)
5391 0 : xavg = nint(0.5_dbl_kind*(x1 + isign*x2))
5392 0 : bufTripole(i ,halo%tripoleRows,k,l) = xavg
5393 0 : bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg
5394 : end do
5395 : end do
5396 : end do
5397 :
5398 : case default
5399 0 : call abort_ice(subname//'ERROR: Unknown field location')
5400 : end select
5401 :
5402 : endif
5403 :
5404 : !*** copy out of global tripole buffer into local
5405 : !*** ghost cells
5406 :
5407 : !*** look through local copies to find the copy out
5408 : !*** messages (srcBlock < 0)
5409 :
5410 0 : do nmsg=1,halo%numLocalCopies
5411 0 : srcBlock = halo%srcLocalAddr(3,nmsg)
5412 :
5413 0 : if (srcBlock < 0) then
5414 :
5415 0 : iSrc = halo%srcLocalAddr(1,nmsg) ! tripole buffer addr
5416 0 : jSrc = halo%srcLocalAddr(2,nmsg)
5417 :
5418 0 : iDst = halo%dstLocalAddr(1,nmsg) ! local block addr
5419 0 : jDst = halo%dstLocalAddr(2,nmsg)
5420 0 : dstBlock = halo%dstLocalAddr(3,nmsg)
5421 :
5422 : !*** correct for offsets
5423 0 : iSrc = iSrc - ioffset
5424 0 : jSrc = jSrc - joffset
5425 0 : if (iSrc < 1 ) iSrc = iSrc + nxGlobal
5426 0 : if (iSrc > nxGlobal) iSrc = iSrc - nxGlobal
5427 :
5428 : !*** for center and Eface on u-fold, and NE corner and Nface
5429 : !*** on T-fold, do not need to replace
5430 : !*** top row of physical domain, so jSrc should be
5431 : !*** out of range and skipped
5432 : !*** otherwise do the copy
5433 :
5434 0 : if (jSrc <= halo%tripoleRows .and. jSrc>0 .and. jDst>0) then
5435 0 : do l=1,nt
5436 0 : do k=1,nz
5437 0 : array(iDst,jDst,k,l,dstBlock) = isign* &
5438 0 : bufTripole(iSrc,jSrc,k,l)
5439 : end do
5440 : end do
5441 : endif
5442 :
5443 : endif
5444 : end do
5445 :
5446 : endif
5447 :
5448 : !-----------------------------------------------------------------------
5449 : !
5450 : ! wait for sends to complete and deallocate arrays
5451 : !
5452 : !-----------------------------------------------------------------------
5453 :
5454 0 : call MPI_WAITALL(halo%numMsgSend, sndRequest, sndStatus, ierr)
5455 :
5456 0 : deallocate(sndRequest, rcvRequest, sndStatus, rcvStatus, stat=ierr)
5457 :
5458 0 : if (ierr > 0) then
5459 0 : call abort_ice(subname//'ERROR: deallocating req,status arrays')
5460 0 : return
5461 : endif
5462 :
5463 0 : deallocate(bufSend, bufRecv, bufTripole, stat=ierr)
5464 :
5465 0 : if (ierr > 0) then
5466 0 : call abort_ice(subname//'ERROR: deallocating 4d buffers')
5467 0 : return
5468 : endif
5469 :
5470 : !-----------------------------------------------------------------------
5471 :
5472 0 : end subroutine ice_HaloUpdate4DI4
5473 :
5474 : !***********************************************************************
5475 : ! This routine updates ghost cells for an input array using
5476 : ! a second array as needed by the stress fields.
5477 : ! This is just like 2DR8 except no averaging and only on tripole
5478 :
5479 0 : subroutine ice_HaloUpdate_stress(array1, array2, halo, &
5480 : fieldLoc, fieldKind, & ! LCOV_EXCL_LINE
5481 : fillValue)
5482 :
5483 : type (ice_halo), intent(in) :: &
5484 : halo ! precomputed halo structure containing all
5485 : ! information needed for halo update
5486 :
5487 : integer (int_kind), intent(in) :: &
5488 : fieldKind, &! id for type of field (scalar, vector, angle) ! LCOV_EXCL_LINE
5489 : fieldLoc ! id for location on horizontal grid
5490 : ! (center, NEcorner, Nface, Eface)
5491 :
5492 : real (dbl_kind), intent(in), optional :: &
5493 : fillValue ! optional value to put in ghost cells
5494 : ! where neighbor points are unknown
5495 : ! (e.g. eliminated land blocks or
5496 : ! closed boundaries)
5497 :
5498 : real (dbl_kind), dimension(:,:,:), intent(inout) :: &
5499 : array1 ,& ! array containing field for which halo ! LCOV_EXCL_LINE
5500 : ! needs to be updated
5501 : array2 ! array containing field for which halo
5502 : ! in array1 needs to be updated
5503 :
5504 : ! local variables
5505 :
5506 : integer (int_kind) :: &
5507 : n,nmsg, &! dummy loop indices ! LCOV_EXCL_LINE
5508 : ierr, &! error or status flag for MPI,alloc ! LCOV_EXCL_LINE
5509 : nxGlobal, &! global domain size in x (tripole) ! LCOV_EXCL_LINE
5510 : iSrc,jSrc, &! source addresses for message ! LCOV_EXCL_LINE
5511 : iDst,jDst, &! dest addresses for message ! LCOV_EXCL_LINE
5512 : srcBlock, &! local block number for source ! LCOV_EXCL_LINE
5513 : dstBlock, &! local block number for destination ! LCOV_EXCL_LINE
5514 : ioffset, joffset, &! address shifts for tripole ! LCOV_EXCL_LINE
5515 : isign ! sign factor for tripole grids
5516 :
5517 : integer (int_kind), dimension(:), allocatable :: &
5518 : sndRequest, &! MPI request ids ! LCOV_EXCL_LINE
5519 0 : rcvRequest ! MPI request ids
5520 :
5521 : integer (int_kind), dimension(:,:), allocatable :: &
5522 : sndStatus, &! MPI status flags ! LCOV_EXCL_LINE
5523 0 : rcvStatus ! MPI status flags
5524 :
5525 : real (dbl_kind) :: &
5526 0 : fill ! value to use for unknown points
5527 :
5528 : integer (int_kind) :: len ! length of messages
5529 :
5530 : character(len=*), parameter :: subname = '(ice_HaloUpdate_stress)'
5531 :
5532 : !-----------------------------------------------------------------------
5533 : !
5534 : ! abort or return on unknown or noupdate field_loc or field_type
5535 : !
5536 : !-----------------------------------------------------------------------
5537 :
5538 0 : if (fieldLoc == field_loc_unknown .or. &
5539 : fieldKind == field_type_unknown) then
5540 0 : call abort_ice(subname//'ERROR: use of field_loc/type_unknown not allowed')
5541 0 : return
5542 : endif
5543 :
5544 0 : if (fieldLoc == field_loc_noupdate .or. &
5545 : fieldKind == field_type_noupdate) then
5546 0 : return
5547 : endif
5548 :
5549 : !-----------------------------------------------------------------------
5550 : !
5551 : ! initialize error code and fill value
5552 : !
5553 : !-----------------------------------------------------------------------
5554 :
5555 0 : if (present(fillValue)) then
5556 0 : fill = fillValue
5557 : else
5558 0 : fill = 0.0_dbl_kind
5559 : endif
5560 :
5561 0 : nxGlobal = 0
5562 0 : if (allocated(bufTripoleR8)) then
5563 0 : nxGlobal = size(bufTripoleR8,dim=1)
5564 0 : bufTripoleR8 = fill
5565 : endif
5566 :
5567 : !-----------------------------------------------------------------------
5568 : !
5569 : ! allocate request and status arrays for messages
5570 : !
5571 : !-----------------------------------------------------------------------
5572 :
5573 : allocate(sndRequest(halo%numMsgSend), &
5574 : rcvRequest(halo%numMsgRecv), & ! LCOV_EXCL_LINE
5575 : sndStatus(MPI_STATUS_SIZE,halo%numMsgSend), & ! LCOV_EXCL_LINE
5576 0 : rcvStatus(MPI_STATUS_SIZE,halo%numMsgRecv), stat=ierr)
5577 :
5578 0 : if (ierr > 0) then
5579 0 : call abort_ice(subname//'ERROR: allocating req,status arrays')
5580 0 : return
5581 : endif
5582 :
5583 : !-----------------------------------------------------------------------
5584 : !
5585 : ! post receives
5586 : !
5587 : !-----------------------------------------------------------------------
5588 :
5589 0 : do nmsg=1,halo%numMsgRecv
5590 :
5591 0 : len = halo%SizeRecv(nmsg)
5592 0 : call MPI_IRECV(bufRecvR8(1:len,nmsg), len, mpiR8, &
5593 : halo%recvTask(nmsg), & ! LCOV_EXCL_LINE
5594 : mpitagHalo + halo%recvTask(nmsg), & ! LCOV_EXCL_LINE
5595 0 : halo%communicator, rcvRequest(nmsg), ierr)
5596 : end do
5597 :
5598 : !-----------------------------------------------------------------------
5599 : !
5600 : ! fill send buffer and post sends
5601 : !
5602 : !-----------------------------------------------------------------------
5603 :
5604 0 : do nmsg=1,halo%numMsgSend
5605 :
5606 0 : do n=1,halo%sizeSend(nmsg)
5607 0 : iSrc = halo%sendAddr(1,n,nmsg)
5608 0 : jSrc = halo%sendAddr(2,n,nmsg)
5609 0 : srcBlock = halo%sendAddr(3,n,nmsg)
5610 :
5611 0 : bufSendR8(n,nmsg) = array2(iSrc,jSrc,srcBlock)
5612 : end do
5613 0 : do n=halo%sizeSend(nmsg)+1,bufSizeSend
5614 0 : bufSendR8(n,nmsg) = fill ! fill remainder of buffer
5615 : end do
5616 :
5617 0 : len = halo%SizeSend(nmsg)
5618 0 : call MPI_ISEND(bufSendR8(1:len,nmsg), len, mpiR8, &
5619 : halo%sendTask(nmsg), & ! LCOV_EXCL_LINE
5620 : mpitagHalo + my_task, & ! LCOV_EXCL_LINE
5621 0 : halo%communicator, sndRequest(nmsg), ierr)
5622 : end do
5623 :
5624 : !-----------------------------------------------------------------------
5625 : !
5626 : ! while messages are being communicated,
5627 : ! do NOT zero the halo out, this halo update just updates
5628 : ! the tripole zipper as needed for stresses. if you zero
5629 : ! it out, all halo values will be wiped out.
5630 : !-----------------------------------------------------------------------
5631 : ! do iblk = 1, halo%numLocalBlocks
5632 : ! call get_block_parameter(halo%blockGlobalID(iblk), &
5633 : ! ilo=ilo, ihi=ihi, & ! LCOV_EXCL_LINE
5634 : ! jlo=jlo, jhi=jhi)
5635 : ! do j = 1,nghost
5636 : ! array(1:nx_block, jlo-j,iblk) = fill
5637 : ! array(1:nx_block, jhi+j,iblk) = fill
5638 : ! enddo
5639 : ! do i = 1,nghost
5640 : ! array(ilo-i, 1:ny_block,iblk) = fill
5641 : ! array(ihi+i, 1:ny_block,iblk) = fill
5642 : ! enddo
5643 : ! enddo
5644 :
5645 : !-----------------------------------------------------------------------
5646 : !
5647 : ! do local copies while waiting for messages to complete
5648 : ! if srcBlock is zero, that denotes an eliminated land block or a
5649 : ! closed boundary where ghost cell values are undefined
5650 : ! if srcBlock is less than zero, the message is a copy out of the
5651 : ! tripole buffer and will be treated later
5652 : !
5653 : !-----------------------------------------------------------------------
5654 :
5655 0 : do nmsg=1,halo%numLocalCopies
5656 0 : iSrc = halo%srcLocalAddr(1,nmsg)
5657 0 : jSrc = halo%srcLocalAddr(2,nmsg)
5658 0 : srcBlock = halo%srcLocalAddr(3,nmsg)
5659 0 : iDst = halo%dstLocalAddr(1,nmsg)
5660 0 : jDst = halo%dstLocalAddr(2,nmsg)
5661 0 : dstBlock = halo%dstLocalAddr(3,nmsg)
5662 :
5663 0 : if (srcBlock > 0) then
5664 0 : if (dstBlock < 0) then ! tripole copy into buffer
5665 0 : bufTripoleR8(iDst,jDst) = &
5666 0 : array2(iSrc,jSrc,srcBlock)
5667 : endif
5668 0 : else if (srcBlock == 0) then
5669 0 : array1(iDst,jDst,dstBlock) = fill
5670 : endif
5671 : end do
5672 :
5673 : !-----------------------------------------------------------------------
5674 : !
5675 : ! wait for receives to finish and then unpack the recv buffer into
5676 : ! ghost cells
5677 : !
5678 : !-----------------------------------------------------------------------
5679 :
5680 0 : call MPI_WAITALL(halo%numMsgRecv, rcvRequest, rcvStatus, ierr)
5681 :
5682 0 : do nmsg=1,halo%numMsgRecv
5683 0 : do n=1,halo%sizeRecv(nmsg)
5684 0 : iDst = halo%recvAddr(1,n,nmsg)
5685 0 : jDst = halo%recvAddr(2,n,nmsg)
5686 0 : dstBlock = halo%recvAddr(3,n,nmsg)
5687 :
5688 0 : if (dstBlock < 0) then !tripole
5689 0 : bufTripoleR8(iDst,jDst) = bufRecvR8(n,nmsg)
5690 : endif
5691 : end do
5692 : end do
5693 :
5694 : !-----------------------------------------------------------------------
5695 : !
5696 : ! take care of northern boundary in tripole case
5697 : ! bufTripole array contains the top haloWidth+1 rows of physical
5698 : ! domain for entire (global) top row
5699 : !
5700 : !-----------------------------------------------------------------------
5701 :
5702 0 : if (nxGlobal > 0) then
5703 :
5704 0 : select case (fieldKind)
5705 : case (field_type_scalar)
5706 0 : isign = 1
5707 : case (field_type_vector)
5708 0 : isign = -1
5709 : case (field_type_angle)
5710 0 : isign = -1
5711 : case default
5712 0 : call abort_ice(subname//'ERROR: Unknown field kind')
5713 : end select
5714 :
5715 0 : if (halo%tripoleTFlag) then
5716 :
5717 0 : select case (fieldLoc)
5718 : case (field_loc_center) ! cell center location
5719 :
5720 0 : ioffset = -1
5721 0 : joffset = 0
5722 :
5723 : case (field_loc_NEcorner) ! cell corner location
5724 :
5725 0 : ioffset = 0
5726 0 : joffset = 1
5727 :
5728 : case (field_loc_Eface) ! cell center location
5729 :
5730 0 : ioffset = 0
5731 0 : joffset = 0
5732 :
5733 : case (field_loc_Nface) ! cell corner (velocity) location
5734 :
5735 0 : ioffset = -1
5736 0 : joffset = 1
5737 :
5738 : case default
5739 0 : call abort_ice(subname//'ERROR: Unknown field location')
5740 : end select
5741 :
5742 : else ! tripole u-fold
5743 :
5744 0 : select case (fieldLoc)
5745 : case (field_loc_center) ! cell center location
5746 :
5747 0 : ioffset = 0
5748 0 : joffset = 0
5749 :
5750 : case (field_loc_NEcorner) ! cell corner location
5751 :
5752 0 : ioffset = 1
5753 0 : joffset = 1
5754 :
5755 : case (field_loc_Eface)
5756 :
5757 0 : ioffset = 1
5758 0 : joffset = 0
5759 :
5760 : case (field_loc_Nface)
5761 :
5762 0 : ioffset = 0
5763 0 : joffset = 1
5764 :
5765 : case default
5766 0 : call abort_ice(subname//'ERROR: Unknown field location')
5767 : end select
5768 :
5769 : endif
5770 :
5771 : !*** copy out of global tripole buffer into local
5772 : !*** ghost cells
5773 :
5774 : !*** look through local copies to find the copy out
5775 : !*** messages (srcBlock < 0)
5776 :
5777 0 : do nmsg=1,halo%numLocalCopies
5778 0 : srcBlock = halo%srcLocalAddr(3,nmsg)
5779 :
5780 0 : if (srcBlock < 0) then
5781 :
5782 0 : iSrc = halo%srcLocalAddr(1,nmsg) ! tripole buffer addr
5783 0 : jSrc = halo%srcLocalAddr(2,nmsg)
5784 :
5785 0 : iDst = halo%dstLocalAddr(1,nmsg) ! local block addr
5786 0 : jDst = halo%dstLocalAddr(2,nmsg)
5787 0 : dstBlock = halo%dstLocalAddr(3,nmsg)
5788 :
5789 : !*** correct for offsets
5790 0 : iSrc = iSrc - ioffset
5791 0 : jSrc = jSrc - joffset
5792 0 : if (iSrc < 1 ) iSrc = iSrc + nxGlobal
5793 0 : if (iSrc > nxGlobal) iSrc = iSrc - nxGlobal
5794 :
5795 : !*** for center and Eface, do not need to replace
5796 : !*** top row of physical domain, so jSrc should be
5797 : !*** out of range and skipped
5798 : !*** otherwise do the copy
5799 :
5800 0 : if (jSrc <= halo%tripoleRows .and. jSrc>0 .and. jDst>0) then
5801 0 : array1(iDst,jDst,dstBlock) = isign*bufTripoleR8(iSrc,jSrc)
5802 : endif
5803 :
5804 : endif
5805 : end do
5806 :
5807 : endif
5808 :
5809 : !-----------------------------------------------------------------------
5810 : !
5811 : ! wait for sends to complete and deallocate arrays
5812 : !
5813 : !-----------------------------------------------------------------------
5814 :
5815 0 : call MPI_WAITALL(halo%numMsgSend, sndRequest, sndStatus, ierr)
5816 :
5817 0 : deallocate(sndRequest, rcvRequest, sndStatus, rcvStatus, stat=ierr)
5818 :
5819 0 : if (ierr > 0) then
5820 0 : call abort_ice(subname//'ERROR: deallocating req,status arrays')
5821 0 : return
5822 : endif
5823 :
5824 : !-----------------------------------------------------------------------
5825 :
5826 0 : end subroutine ice_HaloUpdate_stress
5827 :
5828 : !***********************************************************************
5829 :
5830 8704 : subroutine ice_HaloIncrementMsgCount(sndCounter, rcvCounter, &
5831 : srcProc, dstProc, msgSize)
5832 :
5833 : ! This is a utility routine to increment the arrays for counting
5834 : ! whether messages are required. It checks the source and destination
5835 : ! task to see whether the current task needs to send, receive or
5836 : ! copy messages to fill halo regions (ghost cells).
5837 :
5838 : integer (int_kind), intent(in) :: &
5839 : srcProc, &! source processor for communication ! LCOV_EXCL_LINE
5840 : dstProc, &! destination processor for communication ! LCOV_EXCL_LINE
5841 : msgSize ! number of words for this message
5842 :
5843 : integer (int_kind), dimension(:), intent(inout) :: &
5844 : sndCounter, &! array for counting messages to be sent ! LCOV_EXCL_LINE
5845 : rcvCounter ! array for counting messages to be received
5846 :
5847 : character(len=*), parameter :: subname = '(ice_HaloIncrementMsgCount)'
5848 : !-----------------------------------------------------------------------
5849 : !
5850 : ! error check
5851 : !
5852 : !-----------------------------------------------------------------------
5853 :
5854 : if (srcProc < 0 .or. dstProc < 0 .or. &
5855 : srcProc > size(sndCounter) .or. & ! LCOV_EXCL_LINE
5856 1024 : dstProc > size(rcvCounter)) then
5857 0 : call abort_ice(subname//'ERROR: invalid processor number')
5858 0 : return
5859 : endif
5860 :
5861 : !-----------------------------------------------------------------------
5862 : !
5863 : ! if destination all land or outside closed boundary (dstProc = 0),
5864 : ! then no send is necessary, so do the rest only for dstProc /= 0
5865 : !
5866 : !-----------------------------------------------------------------------
5867 :
5868 8704 : if (dstProc == 0) return
5869 :
5870 : !-----------------------------------------------------------------------
5871 : !
5872 : ! if the current processor is the source, must send data
5873 : ! local copy if dstProc = srcProc
5874 : !
5875 : !-----------------------------------------------------------------------
5876 :
5877 7216 : if (srcProc == my_task + 1) sndCounter(dstProc) = &
5878 1232 : sndCounter(dstProc) + msgSize
5879 :
5880 : !-----------------------------------------------------------------------
5881 : !
5882 : ! if the current processor is the destination, must receive data
5883 : ! local copy if dstProc = srcProc
5884 : !
5885 : !-----------------------------------------------------------------------
5886 :
5887 7008 : if (dstProc == my_task + 1) then
5888 :
5889 1032 : if (srcProc > 0) then
5890 : !*** the source block has ocean points
5891 : !*** count as a receive from srcProc
5892 :
5893 1024 : rcvCounter(srcProc) = rcvCounter(srcProc) + msgSize
5894 :
5895 : else
5896 : !*** if the source block has been dropped, create
5897 : !*** a local copy to fill halo with a fill value
5898 :
5899 8 : rcvCounter(dstProc) = rcvCounter(dstProc) + msgSize
5900 :
5901 : endif
5902 : endif
5903 : !-----------------------------------------------------------------------
5904 :
5905 : end subroutine ice_HaloIncrementMsgCount
5906 :
5907 : !***********************************************************************
5908 :
5909 8704 : subroutine ice_HaloMsgCreate(halo, srcBlock, srcProc, srcLocalID, &
5910 : dstBlock, dstProc, dstLocalID, & ! LCOV_EXCL_LINE
5911 : direction)
5912 :
5913 : ! This is a utility routine to determine the required address and
5914 : ! message information for a particular pair of blocks.
5915 :
5916 : integer (int_kind), intent(in) :: &
5917 : srcBlock, dstBlock, & ! source,destination block id ! LCOV_EXCL_LINE
5918 : srcProc, dstProc, & ! source,destination processor location ! LCOV_EXCL_LINE
5919 : srcLocalID, dstLocalID ! source,destination local index
5920 :
5921 : character (*), intent(in) :: &
5922 : direction ! direction of neighbor block
5923 : ! (north,south,east,west,
5924 : ! and NE, NW, SE, SW)
5925 :
5926 : type (ice_halo), intent(inout) :: &
5927 : halo ! data structure containing halo info
5928 :
5929 : !-----------------------------------------------------------------------
5930 : !
5931 : ! local variables
5932 : !
5933 : !-----------------------------------------------------------------------
5934 :
5935 : integer (int_kind) :: &
5936 : msgIndx, &! message counter and index into msg array ! LCOV_EXCL_LINE
5937 : bufSize, &! size of message buffer ! LCOV_EXCL_LINE
5938 : ibSrc, ieSrc, jbSrc, jeSrc, &! phys domain info for source block ! LCOV_EXCL_LINE
5939 : ibDst, ieDst, jbDst, jeDst, &! phys domain info for dest block ! LCOV_EXCL_LINE
5940 : nxGlobal, &! size of global domain in e-w direction ! LCOV_EXCL_LINE
5941 : i,j,n ! dummy loop index
5942 :
5943 : integer (int_kind), dimension(:), pointer :: &
5944 : iGlobal ! global i index for location in tripole
5945 :
5946 : character(len=*), parameter :: subname = '(ice_HaloMsgCreate)'
5947 : !-----------------------------------------------------------------------
5948 : !
5949 : ! initialize
5950 : !
5951 : !-----------------------------------------------------------------------
5952 :
5953 0 : if (allocated(bufTripoleR8)) nxGlobal = size(bufTripoleR8,dim=1)
5954 :
5955 : !-----------------------------------------------------------------------
5956 : !
5957 : ! if destination all land or outside closed boundary (dstProc = 0),
5958 : ! then no send is necessary, so do the rest only for dstProc /= 0
5959 : !
5960 : !-----------------------------------------------------------------------
5961 :
5962 8704 : if (dstProc == 0) return
5963 :
5964 : !-----------------------------------------------------------------------
5965 : !
5966 : ! get block information if either block is local
5967 : !
5968 : !-----------------------------------------------------------------------
5969 :
5970 7008 : if (srcProc == my_task+1 .or. dstProc == my_task+1) then
5971 :
5972 1880 : if (srcBlock >= 0 .and. dstBlock >= 0) then
5973 : call get_block_parameter(srcBlock, &
5974 : ilo=ibSrc, ihi=ieSrc, & ! LCOV_EXCL_LINE
5975 1880 : jlo=jbSrc, jhi=jeSrc)
5976 : else ! tripole - need iGlobal info
5977 : call get_block_parameter(abs(srcBlock), &
5978 : ilo=ibSrc, ihi=ieSrc, & ! LCOV_EXCL_LINE
5979 : jlo=jbSrc, jhi=jeSrc, & ! LCOV_EXCL_LINE
5980 0 : i_glob=iGlobal)
5981 :
5982 : endif
5983 :
5984 1880 : if (dstBlock /= 0) then
5985 : call get_block_parameter(abs(dstBlock), &
5986 : ilo=ibDst, ihi=ieDst, & ! LCOV_EXCL_LINE
5987 1880 : jlo=jbDst, jhi=jeDst)
5988 : endif
5989 :
5990 : endif
5991 :
5992 : !-----------------------------------------------------------------------
5993 : !
5994 : ! if both blocks are local, create a local copy to fill halo
5995 : !
5996 : !-----------------------------------------------------------------------
5997 :
5998 7008 : if (srcProc == my_task+1 .and. &
5999 : dstProc == my_task+1) then
6000 :
6001 : !*** compute addresses based on direction
6002 :
6003 176 : msgIndx = halo%numLocalCopies
6004 :
6005 176 : if (msgIndx > size(halo%srcLocalAddr,dim=2) .or. &
6006 : msgIndx > size(halo%dstLocalAddr,dim=2)) then
6007 0 : call abort_ice(subname//'ERROR: msg count > array size')
6008 0 : return
6009 : endif
6010 :
6011 24 : select case (direction)
6012 : case ('east')
6013 :
6014 : !*** copy easternmost physical domain of src
6015 : !*** into westernmost halo of dst
6016 :
6017 744 : do j=1,jeSrc-jbSrc+1
6018 1416 : do i=1,nghost
6019 :
6020 696 : msgIndx = msgIndx + 1
6021 :
6022 696 : halo%srcLocalAddr(1,msgIndx) = ieSrc - nghost + i
6023 696 : halo%srcLocalAddr(2,msgIndx) = jbSrc + j - 1
6024 696 : halo%srcLocalAddr(3,msgIndx) = srcLocalID
6025 :
6026 696 : halo%dstLocalAddr(1,msgIndx) = i
6027 696 : halo%dstLocalAddr(2,msgIndx) = jbDst + j - 1
6028 1392 : halo%dstLocalAddr(3,msgIndx) = dstLocalID
6029 :
6030 : end do
6031 : end do
6032 :
6033 : case ('west')
6034 :
6035 : !*** copy westernmost physical domain of src
6036 : !*** into easternmost halo of dst
6037 :
6038 744 : do j=1,jeSrc-jbSrc+1
6039 1416 : do i=1,nghost
6040 :
6041 696 : msgIndx = msgIndx + 1
6042 :
6043 696 : halo%srcLocalAddr(1,msgIndx) = ibSrc + i - 1
6044 696 : halo%srcLocalAddr(2,msgIndx) = jbSrc + j - 1
6045 696 : halo%srcLocalAddr(3,msgIndx) = srcLocalID
6046 :
6047 696 : halo%dstLocalAddr(1,msgIndx) = ieDst + i
6048 696 : halo%dstLocalAddr(2,msgIndx) = jbDst + j - 1
6049 1392 : halo%dstLocalAddr(3,msgIndx) = dstLocalID
6050 :
6051 : end do
6052 : end do
6053 :
6054 : case ('north')
6055 :
6056 : !*** copy northern physical domain of src
6057 : !*** into southern halo of dst
6058 :
6059 40 : if (srcBlock > 0 .and. dstBlock > 0) then ! normal north boundary
6060 :
6061 80 : do j=1,nghost
6062 1192 : do i=1,ieSrc-ibSrc+1
6063 :
6064 1112 : msgIndx = msgIndx + 1
6065 :
6066 1112 : halo%srcLocalAddr(1,msgIndx) = ibSrc + i - 1
6067 1112 : halo%srcLocalAddr(2,msgIndx) = jeSrc - nghost + j
6068 1112 : halo%srcLocalAddr(3,msgIndx) = srcLocalID
6069 :
6070 1112 : halo%dstLocalAddr(1,msgIndx) = ibDst + i - 1
6071 1112 : halo%dstLocalAddr(2,msgIndx) = j
6072 1152 : halo%dstLocalAddr(3,msgIndx) = dstLocalID
6073 :
6074 : end do
6075 : end do
6076 :
6077 0 : else if (srcBlock > 0 .and. dstBlock < 0) then
6078 :
6079 : !*** tripole grid - copy info into tripole buffer
6080 : !*** copy physical domain of top halo+1 rows
6081 : !*** into global buffer at src location
6082 :
6083 : !*** perform an error check to make sure the
6084 : !*** block has enough points to perform a tripole
6085 : !*** update
6086 :
6087 0 : if (jeSrc - jbSrc + 1 < halo%tripoleRows) then
6088 0 : call abort_ice(subname//'ERROR: not enough points in block for tripole')
6089 0 : return
6090 : endif
6091 :
6092 0 : do j=1,halo%tripoleRows
6093 0 : do i=1,ieSrc-ibSrc+1
6094 :
6095 0 : msgIndx = msgIndx + 1
6096 :
6097 0 : halo%srcLocalAddr(1,msgIndx) = ibSrc + i - 1
6098 0 : halo%srcLocalAddr(2,msgIndx) = jeSrc-halo%tripoleRows+j
6099 0 : halo%srcLocalAddr(3,msgIndx) = srcLocalID
6100 :
6101 0 : halo%dstLocalAddr(1,msgIndx) = iGlobal(ibSrc + i - 1)
6102 0 : halo%dstLocalAddr(2,msgIndx) = j
6103 0 : halo%dstLocalAddr(3,msgIndx) = -dstLocalID
6104 :
6105 : end do
6106 : end do
6107 :
6108 0 : else if (srcBlock < 0 .and. dstBlock > 0) then
6109 :
6110 : !*** tripole grid - set up for copying out of
6111 : !*** tripole buffer into ghost cell domains
6112 : !*** include e-w ghost cells
6113 :
6114 0 : do j=1,halo%tripoleRows
6115 0 : do i=1,ieSrc+nghost
6116 :
6117 0 : msgIndx = msgIndx + 1
6118 :
6119 0 : halo%srcLocalAddr(1,msgIndx) = nxGlobal - iGlobal(i) + 1
6120 0 : halo%srcLocalAddr(2,msgIndx) = nghost + 3 - j
6121 0 : halo%srcLocalAddr(3,msgIndx) = -srcLocalID
6122 :
6123 0 : halo%dstLocalAddr(1,msgIndx) = i
6124 0 : if (j.gt.nghost+1) then
6125 0 : halo%dstLocalAddr(2,msgIndx) = -1 ! never used
6126 : else
6127 0 : halo%dstLocalAddr(2,msgIndx) = jeSrc + j - 1
6128 : endif
6129 0 : halo%dstLocalAddr(3,msgIndx) = dstLocalID
6130 :
6131 : end do
6132 : end do
6133 :
6134 : endif
6135 :
6136 : case ('south')
6137 :
6138 : !*** copy southern physical domain of src
6139 : !*** into northern halo of dst
6140 :
6141 120 : do j=1,nghost
6142 1192 : do i=1,ieSrc-ibSrc+1
6143 :
6144 1112 : msgIndx = msgIndx + 1
6145 :
6146 1112 : halo%srcLocalAddr(1,msgIndx) = ibSrc + i - 1
6147 1112 : halo%srcLocalAddr(2,msgIndx) = jbSrc + j - 1
6148 1112 : halo%srcLocalAddr(3,msgIndx) = srcLocalID
6149 :
6150 1112 : halo%dstLocalAddr(1,msgIndx) = ibDst + i - 1
6151 1112 : halo%dstLocalAddr(2,msgIndx) = jeDst + j
6152 1152 : halo%dstLocalAddr(3,msgIndx) = dstLocalID
6153 :
6154 : end do
6155 : end do
6156 :
6157 : case ('northeast')
6158 :
6159 : !*** normal northeast boundary - just copy NE corner
6160 : !*** of physical domain into SW halo of NE nbr block
6161 :
6162 12 : if (dstBlock > 0) then
6163 :
6164 24 : do j=1,nghost
6165 36 : do i=1,nghost
6166 :
6167 12 : msgIndx = msgIndx + 1
6168 :
6169 12 : halo%srcLocalAddr(1,msgIndx) = ieSrc - nghost + i
6170 12 : halo%srcLocalAddr(2,msgIndx) = jeSrc - nghost + j
6171 12 : halo%srcLocalAddr(3,msgIndx) = srcLocalID
6172 :
6173 12 : halo%dstLocalAddr(1,msgIndx) = i
6174 12 : halo%dstLocalAddr(2,msgIndx) = j
6175 24 : halo%dstLocalAddr(3,msgIndx) = dstLocalID
6176 :
6177 : end do
6178 : end do
6179 :
6180 : else
6181 :
6182 : !*** tripole grid - this local copy should already
6183 : !*** have taken place for the north boundary
6184 :
6185 : endif
6186 :
6187 : case ('northwest')
6188 :
6189 : !*** normal northeast boundary - just copy NW corner
6190 : !*** of physical domain into SE halo of NW nbr block
6191 :
6192 12 : if (dstBlock > 0) then
6193 :
6194 24 : do j=1,nghost
6195 36 : do i=1,nghost
6196 :
6197 12 : msgIndx = msgIndx + 1
6198 :
6199 12 : halo%srcLocalAddr(1,msgIndx) = ibSrc + i - 1
6200 12 : halo%srcLocalAddr(2,msgIndx) = jeSrc - nghost + j
6201 12 : halo%srcLocalAddr(3,msgIndx) = srcLocalID
6202 :
6203 12 : halo%dstLocalAddr(1,msgIndx) = ieDst + i
6204 12 : halo%dstLocalAddr(2,msgIndx) = j
6205 24 : halo%dstLocalAddr(3,msgIndx) = dstLocalID
6206 :
6207 : end do
6208 : end do
6209 :
6210 : else
6211 :
6212 : !*** tripole grid - this local copy should already
6213 : !*** have taken place for the north boundary
6214 :
6215 : endif
6216 :
6217 : case ('southeast')
6218 :
6219 : !*** copy southeastern corner of src physical domain
6220 : !*** into northwestern halo of dst
6221 :
6222 36 : do j=1,nghost
6223 36 : do i=1,nghost
6224 :
6225 12 : msgIndx = msgIndx + 1
6226 :
6227 12 : halo%srcLocalAddr(1,msgIndx) = ieSrc - nghost + i
6228 12 : halo%srcLocalAddr(2,msgIndx) = jbSrc + j - 1
6229 12 : halo%srcLocalAddr(3,msgIndx) = srcLocalID
6230 :
6231 12 : halo%dstLocalAddr(1,msgIndx) = i
6232 12 : halo%dstLocalAddr(2,msgIndx) = jeDst + j
6233 24 : halo%dstLocalAddr(3,msgIndx) = dstLocalID
6234 :
6235 : end do
6236 : end do
6237 :
6238 : case ('southwest')
6239 :
6240 : !*** copy southwestern corner of src physical domain
6241 : !*** into northeastern halo of dst
6242 :
6243 36 : do j=1,nghost
6244 36 : do i=1,nghost
6245 :
6246 12 : msgIndx = msgIndx + 1
6247 :
6248 12 : halo%srcLocalAddr(1,msgIndx) = ibSrc + i - 1
6249 12 : halo%srcLocalAddr(2,msgIndx) = jbSrc + j - 1
6250 12 : halo%srcLocalAddr(3,msgIndx) = srcLocalID
6251 :
6252 12 : halo%dstLocalAddr(1,msgIndx) = ieDst + i
6253 12 : halo%dstLocalAddr(2,msgIndx) = jeDst + j
6254 24 : halo%dstLocalAddr(3,msgIndx) = dstLocalID
6255 :
6256 : end do
6257 : end do
6258 :
6259 : case default
6260 :
6261 0 : call abort_ice(subname//'ERROR: unknown direction local copy')
6262 176 : return
6263 :
6264 : end select
6265 :
6266 176 : halo%numLocalCopies = msgIndx
6267 :
6268 176 : if (msgIndx > size(halo%srcLocalAddr,dim=2) .or. &
6269 : msgIndx > size(halo%dstLocalAddr,dim=2)) then
6270 0 : call abort_ice(subname//'ERROR: msg count > array size')
6271 0 : return
6272 : endif
6273 :
6274 : !-----------------------------------------------------------------------
6275 : !
6276 : ! if dest block is local and source block does not exist, create a
6277 : ! local copy to fill halo with a fill value
6278 : !
6279 : !-----------------------------------------------------------------------
6280 :
6281 6832 : else if (srcProc == 0 .and. dstProc == my_task+1) then
6282 :
6283 8 : msgIndx = halo%numLocalCopies
6284 :
6285 8 : if (msgIndx > size(halo%srcLocalAddr,dim=2) .or. &
6286 : msgIndx > size(halo%dstLocalAddr,dim=2)) then
6287 0 : call abort_ice(subname//'ERROR: msg count > array size')
6288 0 : return
6289 : endif
6290 :
6291 : !*** compute addresses based on direction
6292 :
6293 1 : select case (direction)
6294 : case ('east')
6295 :
6296 : !*** copy easternmost physical domain of src
6297 : !*** into westernmost halo of dst
6298 :
6299 31 : do j=1,jeSrc-jbSrc+1
6300 59 : do i=1,nghost
6301 :
6302 29 : msgIndx = msgIndx + 1
6303 :
6304 29 : halo%srcLocalAddr(1,msgIndx) = 0
6305 29 : halo%srcLocalAddr(2,msgIndx) = 0
6306 29 : halo%srcLocalAddr(3,msgIndx) = 0
6307 :
6308 29 : halo%dstLocalAddr(1,msgIndx) = i
6309 29 : halo%dstLocalAddr(2,msgIndx) = jbDst + j - 1
6310 58 : halo%dstLocalAddr(3,msgIndx) = dstLocalID
6311 :
6312 : end do
6313 : end do
6314 :
6315 : case ('west')
6316 :
6317 : !*** copy westernmost physical domain of src
6318 : !*** into easternmost halo of dst
6319 :
6320 31 : do j=1,jeSrc-jbSrc+1
6321 59 : do i=1,nghost
6322 :
6323 29 : msgIndx = msgIndx + 1
6324 :
6325 29 : halo%srcLocalAddr(1,msgIndx) = 0
6326 29 : halo%srcLocalAddr(2,msgIndx) = 0
6327 29 : halo%srcLocalAddr(3,msgIndx) = 0
6328 :
6329 29 : halo%dstLocalAddr(1,msgIndx) = ieDst + i
6330 29 : halo%dstLocalAddr(2,msgIndx) = jbDst + j - 1
6331 58 : halo%dstLocalAddr(3,msgIndx) = dstLocalID
6332 :
6333 : end do
6334 : end do
6335 :
6336 : case ('north')
6337 :
6338 : !*** copy northern physical domain of src
6339 : !*** into southern halo of dst
6340 :
6341 1 : if (dstBlock > 0) then ! normal north boundary
6342 :
6343 2 : do j=1,nghost
6344 7 : do i=1,ieSrc-ibSrc+1
6345 :
6346 5 : msgIndx = msgIndx + 1
6347 :
6348 5 : halo%srcLocalAddr(1,msgIndx) = 0
6349 5 : halo%srcLocalAddr(2,msgIndx) = 0
6350 5 : halo%srcLocalAddr(3,msgIndx) = 0
6351 :
6352 5 : halo%dstLocalAddr(1,msgIndx) = ibDst + i - 1
6353 5 : halo%dstLocalAddr(2,msgIndx) = j
6354 6 : halo%dstLocalAddr(3,msgIndx) = dstLocalID
6355 :
6356 : end do
6357 : end do
6358 :
6359 : endif
6360 :
6361 : case ('south')
6362 :
6363 : !*** copy southern physical domain of src
6364 : !*** into northern halo of dst
6365 :
6366 3 : do j=1,nghost
6367 7 : do i=1,ieSrc-ibSrc+1
6368 :
6369 5 : msgIndx = msgIndx + 1
6370 :
6371 5 : halo%srcLocalAddr(1,msgIndx) = 0
6372 5 : halo%srcLocalAddr(2,msgIndx) = 0
6373 5 : halo%srcLocalAddr(3,msgIndx) = 0
6374 :
6375 5 : halo%dstLocalAddr(1,msgIndx) = ibDst + i - 1
6376 5 : halo%dstLocalAddr(2,msgIndx) = jeDst + j
6377 6 : halo%dstLocalAddr(3,msgIndx) = dstLocalID
6378 :
6379 : end do
6380 : end do
6381 :
6382 : case ('northeast')
6383 :
6384 : !*** normal northeast boundary - just copy NE corner
6385 : !*** of physical domain into SW halo of NE nbr block
6386 :
6387 1 : if (dstBlock > 0) then
6388 :
6389 2 : do j=1,nghost
6390 3 : do i=1,nghost
6391 :
6392 1 : msgIndx = msgIndx + 1
6393 :
6394 1 : halo%srcLocalAddr(1,msgIndx) = 0
6395 1 : halo%srcLocalAddr(2,msgIndx) = 0
6396 1 : halo%srcLocalAddr(3,msgIndx) = 0
6397 :
6398 1 : halo%dstLocalAddr(1,msgIndx) = i
6399 1 : halo%dstLocalAddr(2,msgIndx) = j
6400 2 : halo%dstLocalAddr(3,msgIndx) = dstLocalID
6401 :
6402 : end do
6403 : end do
6404 :
6405 : endif
6406 :
6407 : case ('northwest')
6408 :
6409 : !*** normal northeast boundary - just copy NW corner
6410 : !*** of physical domain into SE halo of NW nbr block
6411 :
6412 1 : if (dstBlock > 0) then
6413 :
6414 2 : do j=1,nghost
6415 3 : do i=1,nghost
6416 :
6417 1 : msgIndx = msgIndx + 1
6418 :
6419 1 : halo%srcLocalAddr(1,msgIndx) = 0
6420 1 : halo%srcLocalAddr(2,msgIndx) = 0
6421 1 : halo%srcLocalAddr(3,msgIndx) = 0
6422 :
6423 1 : halo%dstLocalAddr(1,msgIndx) = ieDst + i
6424 1 : halo%dstLocalAddr(2,msgIndx) = j
6425 2 : halo%dstLocalAddr(3,msgIndx) = dstLocalID
6426 :
6427 : end do
6428 : end do
6429 :
6430 : endif
6431 :
6432 : case ('southeast')
6433 :
6434 : !*** copy southeastern corner of src physical domain
6435 : !*** into northwestern halo of dst
6436 :
6437 3 : do j=1,nghost
6438 3 : do i=1,nghost
6439 :
6440 1 : msgIndx = msgIndx + 1
6441 :
6442 1 : halo%srcLocalAddr(1,msgIndx) = 0
6443 1 : halo%srcLocalAddr(2,msgIndx) = 0
6444 1 : halo%srcLocalAddr(3,msgIndx) = 0
6445 :
6446 1 : halo%dstLocalAddr(1,msgIndx) = i
6447 1 : halo%dstLocalAddr(2,msgIndx) = jeDst + j
6448 2 : halo%dstLocalAddr(3,msgIndx) = dstLocalID
6449 :
6450 : end do
6451 : end do
6452 :
6453 : case ('southwest')
6454 :
6455 : !*** copy southwestern corner of src physical domain
6456 : !*** into northeastern halo of dst
6457 :
6458 3 : do j=1,nghost
6459 3 : do i=1,nghost
6460 :
6461 1 : msgIndx = msgIndx + 1
6462 :
6463 1 : halo%srcLocalAddr(1,msgIndx) = 0
6464 1 : halo%srcLocalAddr(2,msgIndx) = 0
6465 1 : halo%srcLocalAddr(3,msgIndx) = 0
6466 :
6467 1 : halo%dstLocalAddr(1,msgIndx) = ieDst + i
6468 1 : halo%dstLocalAddr(2,msgIndx) = jeDst + j
6469 2 : halo%dstLocalAddr(3,msgIndx) = dstLocalID
6470 :
6471 : end do
6472 : end do
6473 :
6474 : case default
6475 :
6476 0 : call abort_ice(subname//'ERROR: unknown direction local copy')
6477 8 : return
6478 :
6479 : end select
6480 :
6481 8 : halo%numLocalCopies = msgIndx
6482 :
6483 8 : if (msgIndx > size(halo%srcLocalAddr,dim=2) .or. &
6484 : msgIndx > size(halo%dstLocalAddr,dim=2)) then
6485 0 : call abort_ice(subname//'ERROR: msg count > array size')
6486 0 : return
6487 : endif
6488 :
6489 : !-----------------------------------------------------------------------
6490 : !
6491 : ! if source block local and dest block remote, send a message
6492 : !
6493 : !-----------------------------------------------------------------------
6494 :
6495 : else if (srcProc == my_task+1 .and. &
6496 6824 : dstProc /= my_task+1 .and. dstProc > 0) then
6497 :
6498 : !*** first check to see if a message to this processor has
6499 : !*** already been defined
6500 : !*** if not, update counters and indices
6501 :
6502 848 : msgIndx = 0
6503 :
6504 2441 : srchSend: do n=1,halo%numMsgSend
6505 2441 : if (halo%sendTask(n) == dstProc - 1) then
6506 676 : msgIndx = n
6507 676 : bufSize = halo%sizeSend(n)
6508 676 : exit srchSend
6509 : endif
6510 : end do srchSend
6511 :
6512 848 : if (msgIndx == 0) then
6513 172 : msgIndx = halo%numMsgSend + 1
6514 172 : halo%numMsgSend = msgIndx
6515 172 : halo%sendTask(msgIndx) = dstProc - 1
6516 172 : bufSize = 0
6517 : endif
6518 :
6519 : !*** now compute message info based on msg direction
6520 :
6521 134 : select case (direction)
6522 : case ('east')
6523 :
6524 : !*** send easternmost physical domain of src
6525 : !*** into westernmost halo of dst
6526 :
6527 4116 : do j=1,jeSrc-jbSrc+1
6528 8098 : do i=1,nghost
6529 :
6530 3982 : bufSize = bufSize + 1
6531 :
6532 3982 : halo%sendAddr(1,bufSize,msgIndx) = ieSrc - nghost + i
6533 3982 : halo%sendAddr(2,bufSize,msgIndx) = jbSrc + j - 1
6534 7964 : halo%sendAddr(3,bufSize,msgIndx) = srcLocalID
6535 :
6536 : end do
6537 : end do
6538 :
6539 134 : halo%sizeSend(msgIndx) = bufSize
6540 :
6541 : case ('west')
6542 :
6543 : !*** copy westernmost physical domain of src
6544 : !*** into easternmost halo of dst
6545 :
6546 4116 : do j=1,jeSrc-jbSrc+1
6547 8098 : do i=1,nghost
6548 :
6549 3982 : bufSize = bufSize + 1
6550 :
6551 3982 : halo%sendAddr(1,bufSize,msgIndx) = ibSrc + i - 1
6552 3982 : halo%sendAddr(2,bufSize,msgIndx) = jbSrc + j - 1
6553 7964 : halo%sendAddr(3,bufSize,msgIndx) = srcLocalID
6554 :
6555 : end do
6556 : end do
6557 :
6558 134 : halo%sizeSend(msgIndx) = bufSize
6559 :
6560 : case ('north')
6561 :
6562 78 : if (dstBlock > 0) then
6563 :
6564 : !*** copy northern physical domain of src
6565 : !*** into southern halo of dst
6566 :
6567 156 : do j=1,nghost
6568 1002 : do i=1,ieSrc-ibSrc+1
6569 :
6570 846 : bufSize = bufSize + 1
6571 :
6572 846 : halo%sendAddr(1,bufSize,msgIndx) = ibSrc + i - 1
6573 846 : halo%sendAddr(2,bufSize,msgIndx) = jeSrc-nghost+j
6574 924 : halo%sendAddr(3,bufSize,msgIndx) = srcLocalID
6575 :
6576 : end do
6577 : end do
6578 :
6579 78 : halo%sizeSend(msgIndx) = bufSize
6580 :
6581 : else
6582 :
6583 : !*** tripole block - send top halo%tripoleRows rows of phys domain
6584 :
6585 0 : halo%tripSend(msgIndx) = 1
6586 0 : do j=1,halo%tripoleRows
6587 0 : do i=1,ieSrc-ibSrc+1
6588 :
6589 0 : bufSize = bufSize + 1
6590 :
6591 0 : halo%sendAddr(1,bufSize,msgIndx)=ibSrc + i - 1
6592 0 : halo%sendAddr(2,bufSize,msgIndx)=jeSrc-halo%tripoleRows+j
6593 0 : halo%sendAddr(3,bufSize,msgIndx)=srcLocalID
6594 :
6595 : end do
6596 : end do
6597 :
6598 0 : halo%sizeSend(msgIndx) = bufSize
6599 :
6600 : endif
6601 :
6602 : case ('south')
6603 :
6604 : !*** copy southern physical domain of src
6605 : !*** into northern halo of dst
6606 :
6607 156 : do j=1,nghost
6608 1002 : do i=1,ieSrc-ibSrc+1
6609 :
6610 846 : bufSize = bufSize + 1
6611 :
6612 846 : halo%sendAddr(1,bufSize,msgIndx) = ibSrc + i - 1
6613 846 : halo%sendAddr(2,bufSize,msgIndx) = jbSrc + j - 1
6614 924 : halo%sendAddr(3,bufSize,msgIndx) = srcLocalID
6615 :
6616 : end do
6617 : end do
6618 :
6619 78 : halo%sizeSend(msgIndx) = bufSize
6620 :
6621 : case ('northeast')
6622 :
6623 :
6624 106 : if (dstBlock > 0) then
6625 :
6626 : !*** normal northeast corner
6627 : !*** copy northeast corner of src physical domain
6628 : !*** into southwestern halo of dst
6629 :
6630 212 : do j=1,nghost
6631 318 : do i=1,nghost
6632 :
6633 106 : bufSize = bufSize + 1
6634 :
6635 106 : halo%sendAddr(1,bufSize,msgIndx) = ieSrc-nghost+i
6636 106 : halo%sendAddr(2,bufSize,msgIndx) = jeSrc-nghost+j
6637 212 : halo%sendAddr(3,bufSize,msgIndx) = srcLocalID
6638 :
6639 : end do
6640 : end do
6641 :
6642 106 : halo%sizeSend(msgIndx) = bufSize
6643 :
6644 : else
6645 :
6646 : !*** tripole block - send top halo%tripoleRows rows of phys domain
6647 :
6648 0 : halo%tripSend(msgIndx) = 1
6649 0 : do j=1,halo%tripoleRows
6650 0 : do i=1,ieSrc-ibSrc+1
6651 :
6652 0 : bufSize = bufSize + 1
6653 :
6654 0 : halo%sendAddr(1,bufSize,msgIndx)=ibSrc + i - 1
6655 0 : halo%sendAddr(2,bufSize,msgIndx)=jeSrc-halo%tripoleRows+j
6656 0 : halo%sendAddr(3,bufSize,msgIndx)=srcLocalID
6657 :
6658 : end do
6659 : end do
6660 :
6661 0 : halo%sizeSend(msgIndx) = bufSize
6662 :
6663 : endif
6664 :
6665 : case ('northwest')
6666 :
6667 106 : if (dstBlock > 0) then
6668 :
6669 : !*** normal northwest corner
6670 : !*** copy northwest corner of src physical domain
6671 : !*** into southeastern halo of dst
6672 :
6673 212 : do j=1,nghost
6674 318 : do i=1,nghost
6675 :
6676 106 : bufSize = bufSize + 1
6677 :
6678 106 : halo%sendAddr(1,bufSize,msgIndx) = ibSrc + i - 1
6679 106 : halo%sendAddr(2,bufSize,msgIndx) = jeSrc-nghost+j
6680 212 : halo%sendAddr(3,bufSize,msgIndx) = srcLocalID
6681 :
6682 : end do
6683 : end do
6684 :
6685 106 : halo%sizeSend(msgIndx) = bufSize
6686 :
6687 : else
6688 :
6689 : !*** tripole block - send top halo%tripoleRows rows of phys domain
6690 :
6691 0 : halo%tripSend(msgIndx) = 1
6692 0 : do j=1,halo%tripoleRows
6693 0 : do i=1,ieSrc-ibSrc+1
6694 :
6695 0 : bufSize = bufSize + 1
6696 :
6697 0 : halo%sendAddr(1,bufSize,msgIndx)=ibSrc + i - 1
6698 0 : halo%sendAddr(2,bufSize,msgIndx)=jeSrc-halo%tripoleRows+j
6699 0 : halo%sendAddr(3,bufSize,msgIndx)=srcLocalID
6700 :
6701 : end do
6702 : end do
6703 :
6704 0 : halo%sizeSend(msgIndx) = bufSize
6705 :
6706 : endif
6707 :
6708 : case ('southeast')
6709 :
6710 : !*** copy southeastern corner of src physical domain
6711 : !*** into northwestern halo of dst
6712 :
6713 212 : do j=1,nghost
6714 318 : do i=1,nghost
6715 :
6716 106 : bufSize = bufSize + 1
6717 :
6718 106 : halo%sendAddr(1,bufSize,msgIndx) = ieSrc - nghost + i
6719 106 : halo%sendAddr(2,bufSize,msgIndx) = jbSrc + j - 1
6720 212 : halo%sendAddr(3,bufSize,msgIndx) = srcLocalID
6721 :
6722 : end do
6723 : end do
6724 :
6725 106 : halo%sizeSend(msgIndx) = bufSize
6726 :
6727 : case ('southwest')
6728 :
6729 : !*** copy southwestern corner of src physical domain
6730 : !*** into northeastern halo of dst
6731 :
6732 212 : do j=1,nghost
6733 318 : do i=1,nghost
6734 :
6735 106 : bufSize = bufSize + 1
6736 :
6737 106 : halo%sendAddr(1,bufSize,msgIndx) = ibSrc + i - 1
6738 106 : halo%sendAddr(2,bufSize,msgIndx) = jbSrc + j - 1
6739 212 : halo%sendAddr(3,bufSize,msgIndx) = srcLocalID
6740 :
6741 : end do
6742 : end do
6743 :
6744 954 : halo%sizeSend(msgIndx) = bufSize
6745 :
6746 : case default
6747 :
6748 : !*** already checked in previous case construct
6749 :
6750 : end select
6751 :
6752 : !-----------------------------------------------------------------------
6753 : !
6754 : ! if source block remote and dest block local, recv a message
6755 : !
6756 : !-----------------------------------------------------------------------
6757 :
6758 : else if (dstProc == my_task+1 .and. &
6759 5976 : srcProc /= my_task+1 .and. srcProc > 0) then
6760 :
6761 : !*** first check to see if a message from this processor has
6762 : !*** already been defined
6763 : !*** if not, update counters and indices
6764 :
6765 848 : msgIndx = 0
6766 :
6767 2613 : srchRecv: do n=1,halo%numMsgRecv
6768 2613 : if (halo%recvTask(n) == srcProc - 1) then
6769 676 : msgIndx = n
6770 676 : bufSize = halo%sizeRecv(n)
6771 676 : exit srchRecv
6772 : endif
6773 : end do srchRecv
6774 :
6775 848 : if (msgIndx == 0) then
6776 172 : msgIndx = halo%numMsgRecv + 1
6777 172 : halo%numMsgRecv = msgIndx
6778 172 : halo%recvTask(msgIndx) = srcProc - 1
6779 172 : bufSize = 0
6780 : endif
6781 :
6782 : !*** now compute message info based on msg direction
6783 :
6784 134 : select case (direction)
6785 : case ('east')
6786 :
6787 : !*** send easternmost physical domain of src
6788 : !*** into westernmost halo of dst
6789 :
6790 4116 : do j=1,jeSrc-jbSrc+1
6791 8098 : do i=1,nghost
6792 :
6793 3982 : bufSize = bufSize + 1
6794 :
6795 3982 : halo%recvAddr(1,bufSize,msgIndx) = i
6796 3982 : halo%recvAddr(2,bufSize,msgIndx) = jbDst + j - 1
6797 7964 : halo%recvAddr(3,bufSize,msgIndx) = dstLocalID
6798 :
6799 : end do
6800 : end do
6801 :
6802 134 : halo%sizeRecv(msgIndx) = bufSize
6803 :
6804 : case ('west')
6805 :
6806 : !*** copy westernmost physical domain of src
6807 : !*** into easternmost halo of dst
6808 :
6809 4116 : do j=1,jeSrc-jbSrc+1
6810 8098 : do i=1,nghost
6811 :
6812 3982 : bufSize = bufSize + 1
6813 :
6814 3982 : halo%recvAddr(1,bufSize,msgIndx) = ieDst + i
6815 3982 : halo%recvAddr(2,bufSize,msgIndx) = jbDst + j - 1
6816 7964 : halo%recvAddr(3,bufSize,msgIndx) = dstLocalID
6817 :
6818 : end do
6819 : end do
6820 :
6821 134 : halo%sizeRecv(msgIndx) = bufSize
6822 :
6823 : case ('north')
6824 :
6825 78 : if (dstBlock > 0) then
6826 :
6827 : !*** copy northern physical domain of src
6828 : !*** into southern halo of dst
6829 :
6830 156 : do j=1,nghost
6831 1002 : do i=1,ieDst-ibDst+1
6832 :
6833 846 : bufSize = bufSize + 1
6834 :
6835 846 : halo%recvAddr(1,bufSize,msgIndx) = ibDst + i - 1
6836 846 : halo%recvAddr(2,bufSize,msgIndx) = j
6837 924 : halo%recvAddr(3,bufSize,msgIndx) = dstLocalID
6838 :
6839 : end do
6840 : end do
6841 :
6842 78 : halo%sizeRecv(msgIndx) = bufSize
6843 :
6844 : else
6845 :
6846 : !*** tripole block - receive into tripole buffer
6847 :
6848 0 : halo%tripRecv(msgIndx) = 1
6849 0 : do j=1,halo%tripoleRows
6850 0 : do i=1,ieSrc-ibSrc+1
6851 :
6852 0 : bufSize = bufSize + 1
6853 :
6854 0 : halo%recvAddr(1,bufSize,msgIndx) = iGlobal(ibSrc + i - 1)
6855 0 : halo%recvAddr(2,bufSize,msgIndx) = j
6856 0 : halo%recvAddr(3,bufSize,msgIndx) = -dstLocalID
6857 :
6858 : end do
6859 : end do
6860 :
6861 0 : halo%sizeRecv(msgIndx) = bufSize
6862 :
6863 : endif
6864 :
6865 : case ('south')
6866 :
6867 : !*** copy southern physical domain of src
6868 : !*** into northern halo of dst
6869 :
6870 156 : do j=1,nghost
6871 1002 : do i=1,ieSrc-ibSrc+1
6872 :
6873 846 : bufSize = bufSize + 1
6874 :
6875 846 : halo%recvAddr(1,bufSize,msgIndx) = ibDst + i - 1
6876 846 : halo%recvAddr(2,bufSize,msgIndx) = jeDst + j
6877 924 : halo%recvAddr(3,bufSize,msgIndx) = dstLocalID
6878 :
6879 : end do
6880 : end do
6881 :
6882 78 : halo%sizeRecv(msgIndx) = bufSize
6883 :
6884 : case ('northeast')
6885 :
6886 106 : if (dstBlock > 0) then
6887 :
6888 : !*** normal northeast neighbor
6889 : !*** copy northeast physical domain into
6890 : !*** into southwest halo of dst
6891 :
6892 212 : do j=1,nghost
6893 318 : do i=1,nghost
6894 :
6895 106 : bufSize = bufSize + 1
6896 :
6897 106 : halo%recvAddr(1,bufSize,msgIndx) = i
6898 106 : halo%recvAddr(2,bufSize,msgIndx) = j
6899 212 : halo%recvAddr(3,bufSize,msgIndx) = dstLocalID
6900 :
6901 : end do
6902 : end do
6903 :
6904 106 : halo%sizeRecv(msgIndx) = bufSize
6905 :
6906 : else
6907 :
6908 : !*** tripole block - receive into tripole buffer
6909 :
6910 0 : halo%tripRecv(msgIndx) = 1
6911 0 : do j=1,halo%tripoleRows
6912 0 : do i=1,ieSrc-ibSrc+1
6913 :
6914 0 : bufSize = bufSize + 1
6915 :
6916 0 : halo%recvAddr(1,bufSize,msgIndx) = iGlobal(ibSrc + i - 1)
6917 0 : halo%recvAddr(2,bufSize,msgIndx) = j
6918 0 : halo%recvAddr(3,bufSize,msgIndx) = -dstLocalID
6919 :
6920 : end do
6921 : end do
6922 :
6923 0 : halo%sizeRecv(msgIndx) = bufSize
6924 :
6925 : endif
6926 :
6927 : case ('northwest')
6928 :
6929 106 : if (dstBlock > 0) then
6930 :
6931 : !*** normal northwest neighbor
6932 : !*** copy northwest physical domain into
6933 : !*** into southeast halo of dst
6934 :
6935 212 : do j=1,nghost
6936 318 : do i=1,nghost
6937 :
6938 106 : bufSize = bufSize + 1
6939 :
6940 106 : halo%recvAddr(1,bufSize,msgIndx) = ieDst + i
6941 106 : halo%recvAddr(2,bufSize,msgIndx) = j
6942 212 : halo%recvAddr(3,bufSize,msgIndx) = dstLocalID
6943 :
6944 : end do
6945 : end do
6946 :
6947 106 : halo%sizeRecv(msgIndx) = bufSize
6948 :
6949 : else
6950 :
6951 : !*** tripole block - receive into tripole buffer
6952 :
6953 0 : halo%tripRecv(msgIndx) = 1
6954 0 : do j=1,halo%tripoleRows
6955 0 : do i=1,ieSrc-ibSrc+1
6956 :
6957 0 : bufSize = bufSize + 1
6958 :
6959 0 : halo%recvAddr(1,bufSize,msgIndx) = iGlobal(ibSrc + i - 1)
6960 0 : halo%recvAddr(2,bufSize,msgIndx) = j
6961 0 : halo%recvAddr(3,bufSize,msgIndx) = -dstLocalID
6962 :
6963 : end do
6964 : end do
6965 :
6966 0 : halo%sizeRecv(msgIndx) = bufSize
6967 :
6968 : endif
6969 :
6970 : case ('southeast')
6971 :
6972 : !*** copy southeastern corner of src physical domain
6973 : !*** into northwestern halo of dst
6974 :
6975 212 : do j=1,nghost
6976 318 : do i=1,nghost
6977 :
6978 106 : bufSize = bufSize + 1
6979 :
6980 106 : halo%recvAddr(1,bufSize,msgIndx) = i
6981 106 : halo%recvAddr(2,bufSize,msgIndx) = jeDst + j
6982 212 : halo%recvAddr(3,bufSize,msgIndx) = dstLocalID
6983 :
6984 : end do
6985 : end do
6986 :
6987 106 : halo%sizeRecv(msgIndx) = bufSize
6988 :
6989 : case ('southwest')
6990 :
6991 : !*** copy southwestern corner of src physical domain
6992 : !*** into northeastern halo of dst
6993 :
6994 212 : do j=1,nghost
6995 318 : do i=1,nghost
6996 :
6997 106 : bufSize = bufSize + 1
6998 :
6999 106 : halo%recvAddr(1,bufSize,msgIndx) = ieDst + i
7000 106 : halo%recvAddr(2,bufSize,msgIndx) = jeDst + j
7001 212 : halo%recvAddr(3,bufSize,msgIndx) = dstLocalID
7002 :
7003 : end do
7004 : end do
7005 :
7006 954 : halo%sizeRecv(msgIndx) = bufSize
7007 :
7008 : case default
7009 :
7010 : !*** already checked in previous case construct
7011 :
7012 : end select
7013 :
7014 : !-----------------------------------------------------------------------
7015 : !
7016 : ! if none of the cases above, no message info required for this
7017 : ! block pair
7018 : !
7019 : !-----------------------------------------------------------------------
7020 :
7021 : endif
7022 :
7023 : !-----------------------------------------------------------------------
7024 :
7025 8704 : end subroutine ice_HaloMsgCreate
7026 :
7027 : !***********************************************************************
7028 :
7029 288 : subroutine ice_HaloExtrapolate2DR8(ARRAY,dist,ew_bndy_type,ns_bndy_type)
7030 :
7031 : ! This subroutine extrapolates ARRAY values into the first row or column
7032 : ! of ghost cells, and is intended for grid variables whose ghost cells
7033 : ! would otherwise be set using the default boundary conditions (Dirichlet
7034 : ! or Neumann).
7035 : ! Note: This routine will need to be modified for nghost > 1.
7036 : ! We assume padding occurs only on east and north edges.
7037 : !
7038 : ! This is the specific interface for double precision arrays
7039 : ! corresponding to the generic interface ice_HaloExtrapolate
7040 :
7041 : use ice_blocks, only: block, nblocks_x, nblocks_y, get_block
7042 : use ice_constants, only: c2
7043 : use ice_distribution, only: ice_distributionGetBlockID
7044 :
7045 : character (char_len) :: &
7046 : ew_bndy_type, &! type of domain bndy in each logical ! LCOV_EXCL_LINE
7047 : ns_bndy_type ! direction (ew is i, ns is j)
7048 :
7049 : type (distrb), intent(in) :: &
7050 : dist ! block distribution for array X
7051 :
7052 : real (dbl_kind), dimension(:,:,:), intent(inout) :: &
7053 : ARRAY ! array containing distributed field
7054 :
7055 : !-----------------------------------------------------------------------
7056 : !
7057 : ! local variables
7058 : !
7059 : !-----------------------------------------------------------------------
7060 :
7061 : integer (int_kind) :: &
7062 : i,j,iblk, &! dummy loop indices ! LCOV_EXCL_LINE
7063 : numBlocks, &! number of local blocks ! LCOV_EXCL_LINE
7064 : blockID, &! block location ! LCOV_EXCL_LINE
7065 : ibc ! ghost cell column or row
7066 :
7067 : type (block) :: &
7068 : this_block ! block info for current block
7069 :
7070 : character(len=*), parameter :: subname = '(ice_HaloExtrapolate2DR8)'
7071 : !-----------------------------------------------------------------------
7072 : !
7073 : ! Linear extrapolation
7074 : !
7075 : !-----------------------------------------------------------------------
7076 :
7077 : call ice_distributionGet(dist, &
7078 288 : numLocalBlocks = numBlocks)
7079 :
7080 1560 : do iblk = 1, numBlocks
7081 1272 : call ice_distributionGetBlockID(dist, iblk, blockID)
7082 1272 : this_block = get_block(blockID, blockID)
7083 :
7084 1272 : if (this_block%iblock == 1) then ! west edge
7085 192 : if (trim(ew_bndy_type) /= 'cyclic') then
7086 0 : do j = 1, ny_block
7087 0 : ARRAY(1,j,iblk) = c2*ARRAY(2,j,iblk) - ARRAY(3,j,iblk)
7088 : enddo
7089 : endif
7090 : endif
7091 :
7092 1272 : if (this_block%iblock == nblocks_x) then ! east edge
7093 192 : if (trim(ew_bndy_type) /= 'cyclic') then
7094 : ! locate ghost cell column (avoid padding)
7095 0 : ibc = nx_block
7096 0 : do i = nx_block, nghost + 1, -1
7097 0 : if (this_block%i_glob(i) == 0) ibc = ibc - 1
7098 : enddo
7099 0 : do j = 1, ny_block
7100 0 : ARRAY(ibc,j,iblk) = c2*ARRAY(ibc-1,j,iblk) - ARRAY(ibc-2,j,iblk)
7101 : enddo
7102 : endif
7103 : endif
7104 :
7105 1272 : if (this_block%jblock == 1) then ! south edge
7106 320 : if (trim(ns_bndy_type) /= 'cyclic') then
7107 6208 : do i = 1, nx_block
7108 6208 : ARRAY(i,1,iblk) = c2*ARRAY(i,2,iblk) - ARRAY(i,3,iblk)
7109 : enddo
7110 : endif
7111 : endif
7112 :
7113 2832 : if (this_block%jblock == nblocks_y) then ! north edge
7114 : if (trim(ns_bndy_type) /= 'cyclic' .and. &
7115 : trim(ns_bndy_type) /= 'tripole' .and. & ! LCOV_EXCL_LINE
7116 : trim(ns_bndy_type) /= 'tripoleT' ) then
7117 : ! locate ghost cell column (avoid padding)
7118 320 : ibc = ny_block
7119 10112 : do j = ny_block, nghost + 1, -1
7120 10112 : if (this_block%j_glob(j) == 0) ibc = ibc - 1
7121 : enddo
7122 6208 : do i = 1, nx_block
7123 6208 : ARRAY(i,ibc,iblk) = c2*ARRAY(i,ibc-1,iblk) - ARRAY(i,ibc-2,iblk)
7124 : enddo
7125 : endif
7126 : endif
7127 :
7128 : enddo ! iblk
7129 :
7130 : !-----------------------------------------------------------------------
7131 :
7132 288 : end subroutine ice_HaloExtrapolate2DR8
7133 :
7134 : !***********************************************************************
7135 :
7136 0 : subroutine ice_HaloDestroy(halo)
7137 :
7138 : ! This routine creates a halo type with info necessary for
7139 : ! performing a halo (ghost cell) update. This info is computed
7140 : ! based on the input block distribution.
7141 :
7142 : type (ice_halo) :: &
7143 : halo ! a new halo type with info for halo updates
7144 :
7145 : integer (int_kind) :: &
7146 : istat ! error or status flag for MPI,alloc
7147 :
7148 : character(len=*), parameter :: subname = '(ice_HaloDestroy)'
7149 : !-----------------------------------------------------------------------
7150 :
7151 : deallocate(halo%sendTask, &
7152 : halo%recvTask, & ! LCOV_EXCL_LINE
7153 : halo%sizeSend, & ! LCOV_EXCL_LINE
7154 : halo%sizeRecv, & ! LCOV_EXCL_LINE
7155 : halo%tripSend, & ! LCOV_EXCL_LINE
7156 : halo%tripRecv, & ! LCOV_EXCL_LINE
7157 : halo%srcLocalAddr, & ! LCOV_EXCL_LINE
7158 : halo%dstLocalAddr, & ! LCOV_EXCL_LINE
7159 : halo%sendAddr, & ! LCOV_EXCL_LINE
7160 : halo%recvAddr, & ! LCOV_EXCL_LINE
7161 0 : halo%blockGlobalID, stat=istat)
7162 :
7163 0 : if (istat > 0) then
7164 0 : call abort_ice(subname,' ERROR: deallocating')
7165 0 : return
7166 : endif
7167 : end subroutine ice_HaloDestroy
7168 :
7169 : !***********************************************************************
7170 :
7171 0 : subroutine primary_grid_lengths_global_ext( &
7172 0 : ARRAY_O, ARRAY_I, ew_boundary_type, ns_boundary_type)
7173 :
7174 : ! This subroutine adds ghost cells to global primary grid lengths array
7175 : ! ARRAY_I and outputs result to array ARRAY_O
7176 :
7177 : use ice_constants, only: c0
7178 : use ice_domain_size, only: nx_global, ny_global
7179 :
7180 : real (kind=dbl_kind), dimension(:,:), intent(in) :: &
7181 : ARRAY_I
7182 :
7183 : character (*), intent(in) :: &
7184 : ew_boundary_type, ns_boundary_type
7185 :
7186 : real (kind=dbl_kind), dimension(:,:), intent(out) :: &
7187 : ARRAY_O
7188 :
7189 : !-----------------------------------------------------------------------
7190 : !
7191 : ! local variables
7192 : !
7193 : !-----------------------------------------------------------------------
7194 :
7195 : integer (kind=int_kind) :: &
7196 : ii, io, ji, jo
7197 :
7198 : character(len=*), parameter :: &
7199 : subname = '(primary_grid_lengths_global_ext)'
7200 :
7201 : !-----------------------------------------------------------------------
7202 : !
7203 : ! add ghost cells to global primary grid lengths array
7204 : !
7205 : !-----------------------------------------------------------------------
7206 :
7207 0 : if (trim(ns_boundary_type) == 'tripole' .or. &
7208 : trim(ns_boundary_type) == 'tripoleT') then
7209 : call abort_ice(subname//' ERROR: '//ns_boundary_type &
7210 0 : //' boundary type not implemented for configuration')
7211 : endif
7212 :
7213 0 : do jo = 1,ny_global+2*nghost
7214 0 : ji = -nghost + jo
7215 :
7216 : !*** Southern ghost cells
7217 :
7218 0 : if (ji < 1) then
7219 0 : select case (trim(ns_boundary_type))
7220 : case ('cyclic')
7221 0 : ji = ji + ny_global
7222 : case ('open')
7223 0 : ji = nghost - jo + 1
7224 : case ('closed')
7225 0 : ji = 0
7226 : case default
7227 : call abort_ice( &
7228 0 : subname//' ERROR: unknown north-south boundary type')
7229 : end select
7230 : endif
7231 :
7232 : !*** Northern ghost cells
7233 :
7234 0 : if (ji > ny_global) then
7235 0 : select case (trim(ns_boundary_type))
7236 : case ('cyclic')
7237 0 : ji = ji - ny_global
7238 : case ('open')
7239 0 : ji = 2 * ny_global - ji + 1
7240 : case ('closed')
7241 0 : ji = 0
7242 : case default
7243 : call abort_ice( &
7244 0 : subname//' ERROR: unknown north-south boundary type')
7245 : end select
7246 : endif
7247 :
7248 0 : do io = 1,nx_global+2*nghost
7249 0 : ii = -nghost + io
7250 :
7251 : !*** Western ghost cells
7252 :
7253 0 : if (ii < 1) then
7254 0 : select case (trim(ew_boundary_type))
7255 : case ('cyclic')
7256 0 : ii = ii + nx_global
7257 : case ('open')
7258 0 : ii = nghost - io + 1
7259 : case ('closed')
7260 0 : ii = 0
7261 : case default
7262 : call abort_ice( &
7263 0 : subname//' ERROR: unknown east-west boundary type')
7264 : end select
7265 : endif
7266 :
7267 : !*** Eastern ghost cells
7268 :
7269 0 : if (ii > nx_global) then
7270 0 : select case (trim(ew_boundary_type))
7271 : case ('cyclic')
7272 0 : ii = ii - nx_global
7273 : case ('open')
7274 0 : ii = 2 * nx_global - ii + 1
7275 : case ('closed')
7276 0 : ii = 0
7277 : case default
7278 : call abort_ice( &
7279 0 : subname//' ERROR: unknown east-west boundary type')
7280 : end select
7281 : endif
7282 :
7283 0 : if (ii == 0 .or. ji == 0) then
7284 0 : ARRAY_O(io, jo) = c0
7285 : else
7286 0 : ARRAY_O(io, jo) = ARRAY_I(ii, ji)
7287 : endif
7288 :
7289 : enddo
7290 : enddo
7291 :
7292 : !-----------------------------------------------------------------------
7293 :
7294 0 : end subroutine primary_grid_lengths_global_ext
7295 :
7296 : !***********************************************************************
7297 :
7298 0 : end module ice_boundary
7299 :
7300 : !|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
|
