00001
00002
00003
00004
00005 module ice_boundary
00006
00007
00008
00009
00010
00011
00012
00013
00014
00015
00016
00017
00018
00019
00020
00021
00022
00023 use ice_kinds_mod
00024 use ice_communicate, only: my_task, mpiR4, mpiR8, mpitagHalo
00025 use ice_constants, only: field_type_scalar, &
00026 field_type_vector, field_type_angle, &
00027 field_loc_center, field_loc_NEcorner, &
00028 field_loc_Nface, field_loc_Eface
00029 use ice_global_reductions, only: global_maxval
00030 use ice_exit
00031
00032 use ice_blocks, only: nx_block, ny_block, nghost, &
00033 nblocks_tot, ice_blocksNorth, &
00034 ice_blocksSouth, ice_blocksEast, ice_blocksWest, &
00035 ice_blocksEast2, ice_blocksWest2, &
00036 ice_blocksNorthEast, ice_blocksNorthWest, &
00037 ice_blocksEastNorthEast, ice_blocksWestNorthWest, &
00038 ice_blocksSouthEast, ice_blocksSouthWest, &
00039 ice_blocksGetNbrID, get_block_parameter
00040 use ice_distribution, only: distrb, &
00041 ice_distributionGetBlockLoc, ice_distributionGet
00042
00043 implicit none
00044 private
00045 save
00046
00047 include 'mpif.h'
00048
00049
00050
00051 type, public :: ice_halo
00052 integer (int_kind) ::
00053 communicator,
00054 numMsgSend,
00055 numMsgRecv,
00056 numLocalCopies,
00057 tripoleRows
00058
00059 logical (log_kind) ::
00060 tripoleTFlag
00061
00062 integer (int_kind), dimension(:), pointer ::
00063 recvTask,
00064 sendTask,
00065 sizeSend,
00066 sizeRecv
00067
00068 integer (int_kind), dimension(:,:), pointer ::
00069 srcLocalAddr,
00070 dstLocalAddr
00071
00072 integer (int_kind), dimension(:,:,:), pointer ::
00073 sendAddr,
00074 recvAddr
00075
00076 end type
00077
00078
00079
00080 public :: ice_HaloCreate, &
00081 ice_HaloUpdate, &
00082 ice_HaloUpdate_stress, &
00083 ice_HaloExtrapolate
00084
00085 interface ice_HaloUpdate
00086 module procedure ice_HaloUpdate2DR8, &
00087 ice_HaloUpdate2DR4, &
00088 ice_HaloUpdate2DI4, &
00089 ice_HaloUpdate3DR8, &
00090 ice_HaloUpdate3DR4, &
00091 ice_HaloUpdate3DI4, &
00092 ice_HaloUpdate4DR8, &
00093 ice_HaloUpdate4DR4, &
00094 ice_HaloUpdate4DI4
00095 end interface
00096
00097 interface ice_HaloExtrapolate
00098 module procedure ice_HaloExtrapolate2DR8
00099
00100
00101 end interface
00102
00103
00104
00105
00106
00107
00108
00109
00110
00111
00112
00113 integer (int_kind) ::
00114 bufSizeSend,
00115 bufSizeRecv
00116
00117 integer (int_kind), dimension(:,:), allocatable ::
00118 bufSendI4,
00119 bufRecvI4
00120
00121 real (real_kind), dimension(:,:), allocatable ::
00122 bufSendR4,
00123 bufRecvR4
00124
00125 real (dbl_kind), dimension(:,:), allocatable ::
00126 bufSendR8,
00127 bufRecvR8
00128
00129
00130
00131
00132
00133
00134
00135 integer (int_kind), dimension(:,:), allocatable ::
00136 bufTripoleI4
00137
00138 real (real_kind), dimension(:,:), allocatable ::
00139 bufTripoleR4
00140
00141 real (dbl_kind), dimension(:,:), allocatable ::
00142 bufTripoleR8
00143
00144
00145
00146
00147 contains
00148
00149
00150
00151
00152
00153
00154 function ice_HaloCreate(dist, nsBoundaryType, ewBoundaryType, &
00155 nxGlobal) result(halo)
00156
00157
00158
00159
00160
00161
00162
00163
00164
00165
00166
00167 type (distrb), intent(in) ::
00168 dist
00169
00170 character (*), intent(in) ::
00171 nsBoundaryType,
00172 ewBoundaryType
00173
00174 integer (int_kind), intent(in) ::
00175 nxGlobal
00176
00177
00178
00179 type (ice_halo) ::
00180 halo
00181
00182
00183
00184
00185
00186
00187
00188
00189
00190 integer (int_kind) ::
00191 i,j,k,l,n,m,
00192 istat,
00193 numProcs,
00194 communicator,
00195 iblock,
00196 eastBlock, westBlock,
00197 northBlock, southBlock,
00198 neBlock, nwBlock,
00199 seBlock, swBlock,
00200 srcProc, dstProc,
00201 srcLocalID, dstLocalID,
00202 maxTmp,
00203 blockSizeX,
00204 blockSizeY,
00205 maxSizeSend, maxSizeRecv,
00206 numMsgSend, numMsgRecv,
00207 eastMsgSize, westMsgSize,
00208 northMsgSize, southMsgSize,
00209 tripoleMsgSize,
00210 tripoleMsgSizeOut,
00211 tripoleRows,
00212 cornerMsgSize, msgSize
00213
00214 integer (int_kind), dimension(:), allocatable ::
00215 sendCount, recvCount
00216
00217 logical (log_kind) ::
00218 resize,
00219 tripoleFlag,
00220 tripoleBlock,
00221 tripoleTFlag
00222
00223
00224
00225
00226
00227
00228
00229
00230 call ice_distributionGet(dist, &
00231 nprocs = numProcs, &
00232 communicator = communicator)
00233
00234 if (my_task >= numProcs) return
00235
00236 halo%communicator = communicator
00237
00238 blockSizeX = nx_block - 2*nghost
00239 blockSizeY = ny_block - 2*nghost
00240 eastMsgSize = nghost*blockSizeY
00241 westMsgSize = nghost*blockSizeY
00242 southMsgSize = nghost*blockSizeX
00243 northMsgSize = nghost*blockSizeX
00244 cornerMsgSize = nghost*nghost
00245 tripoleRows = nghost+1
00246
00247 if (nsBoundaryType == 'tripole' .or. nsBoundaryType == 'tripoleT') then
00248 tripoleFlag = .true.
00249 tripoleTFlag = (nsBoundaryType == 'tripoleT')
00250 if (tripoleTflag) tripoleRows = tripoleRows+1
00251
00252
00253
00254 if (.not. allocated(bufTripoleR8)) then
00255 allocate (bufTripoleI4(nxGlobal, tripoleRows), &
00256 bufTripoleR4(nxGlobal, tripoleRows), &
00257 bufTripoleR8(nxGlobal, tripoleRows), &
00258 stat=istat)
00259
00260 if (istat > 0) then
00261 call abort_ice( &
00262 'ice_HaloCreate: error allocating tripole buffers')
00263 return
00264 endif
00265 endif
00266
00267 else
00268 tripoleFlag = .false.
00269 tripoleTFlag = .false.
00270 endif
00271 halo%tripoleTFlag = tripoleTFlag
00272 halo%tripoleRows = tripoleRows
00273 tripoleMsgSize = tripoleRows*blockSizeX
00274 tripoleMsgSizeOut = tripoleRows*nx_block
00275
00276
00277
00278
00279
00280
00281
00282
00283
00284 allocate (sendCount(numProcs), recvCount(numProcs), stat=istat)
00285
00286 if (istat > 0) then
00287 call abort_ice( &
00288 'ice_HaloCreate: error allocating count arrays')
00289 return
00290 endif
00291
00292 sendCount = 0
00293 recvCount = 0
00294
00295 msgCountLoop: do iblock=1,nblocks_tot
00296
00297 call ice_distributionGetBlockLoc(dist, iblock, srcProc, &
00298 srcLocalID)
00299
00300
00301
00302
00303 northBlock = ice_blocksGetNbrID(iblock, ice_blocksNorth, &
00304 ewBoundaryType, nsBoundaryType)
00305 if (northBlock > 0) then
00306 tripoleBlock = .false.
00307 msgSize = northMsgSize
00308 call ice_distributionGetBlockLoc(dist, northBlock, dstProc, &
00309 dstLocalID)
00310 else if (northBlock < 0) then
00311 tripoleBlock = .true.
00312 msgSize = tripoleMsgSize
00313 call ice_distributionGetBlockLoc(dist, abs(northBlock), &
00314 dstProc, dstLocalID)
00315 else
00316 tripoleBlock = .false.
00317 msgSize = northMsgSize
00318 dstProc = 0
00319 dstLocalID = 0
00320 endif
00321
00322 call ice_HaloIncrementMsgCount(sendCount, recvCount, &
00323 srcProc, dstProc, msgSize)
00324
00325
00326
00327
00328 if (tripoleBlock) then
00329
00330 call ice_HaloIncrementMsgCount(sendCount, recvCount, &
00331 srcProc, srcProc, &
00332 tripoleMsgSizeOut)
00333
00334
00335 if (dstProc /= srcProc) then
00336 call ice_HaloIncrementMsgCount(sendCount, recvCount, &
00337 srcProc, srcProc, &
00338 msgSize)
00339 endif
00340 endif
00341
00342
00343
00344 southBlock = ice_blocksGetNbrID(iblock, ice_blocksSouth, &
00345 ewBoundaryType, nsBoundaryType)
00346
00347 if (southBlock > 0) then
00348 call ice_distributionGetBlockLoc(dist, southBlock, dstProc, &
00349 dstLocalID)
00350 else
00351 dstProc = 0
00352 dstLocalID = 0
00353 endif
00354
00355 call ice_HaloIncrementMsgCount(sendCount, recvCount, &
00356 srcProc, dstProc, southMsgSize)
00357
00358
00359
00360 eastBlock = ice_blocksGetNbrID(iblock, ice_blocksEast, &
00361 ewBoundaryType, nsBoundaryType)
00362
00363 if (eastBlock > 0) then
00364 call ice_distributionGetBlockLoc(dist, eastBlock, dstProc, &
00365 dstLocalID)
00366 else
00367 dstProc = 0
00368 dstLocalID = 0
00369 endif
00370
00371 call ice_HaloIncrementMsgCount(sendCount, recvCount, &
00372 srcProc, dstProc, eastMsgSize)
00373
00374
00375
00376
00377
00378 if (tripoleBlock .and. dstProc /= srcProc) then
00379 call ice_HaloIncrementMsgCount(sendCount, recvCount, &
00380 srcProc, dstProc, tripoleMsgSize)
00381 endif
00382
00383
00384
00385 westBlock = ice_blocksGetNbrID(iblock, ice_blocksWest, &
00386 ewBoundaryType, nsBoundaryType)
00387
00388 if (westBlock > 0) then
00389 call ice_distributionGetBlockLoc(dist, westBlock, dstProc, &
00390 dstLocalID)
00391 else
00392 dstProc = 0
00393 dstLocalID = 0
00394 endif
00395
00396 call ice_HaloIncrementMsgCount(sendCount, recvCount, &
00397 srcProc, dstProc, westMsgSize)
00398
00399
00400
00401
00402
00403 if (tripoleBlock .and. dstProc /= srcProc) then
00404 call ice_HaloIncrementMsgCount(sendCount, recvCount, &
00405 srcProc, dstProc, tripoleMsgSize)
00406 endif
00407
00408
00409
00410 neBlock = ice_blocksGetNbrID(iblock, ice_blocksNorthEast, &
00411 ewBoundaryType, nsBoundaryType)
00412
00413 if (neBlock > 0) then
00414 msgSize = cornerMsgSize
00415
00416 call ice_distributionGetBlockLoc(dist, neBlock, dstProc, &
00417 dstLocalID)
00418
00419 else if (neBlock < 0) then
00420 msgSize = tripoleMsgSize
00421
00422 call ice_distributionGetBlockLoc(dist, abs(neBlock), dstProc, &
00423 dstLocalID)
00424 else
00425 dstProc = 0
00426 dstLocalID = 0
00427 endif
00428
00429 call ice_HaloIncrementMsgCount(sendCount, recvCount, &
00430 srcProc, dstProc, msgSize)
00431
00432
00433
00434 nwBlock = ice_blocksGetNbrID(iblock, ice_blocksNorthWest, &
00435 ewBoundaryType, nsBoundaryType)
00436
00437 if (nwBlock > 0) then
00438 msgSize = cornerMsgSize
00439
00440 call ice_distributionGetBlockLoc(dist, nwBlock, dstProc, &
00441 dstLocalID)
00442
00443 else if (nwBlock < 0) then
00444 msgSize = tripoleMsgSize
00445
00446 call ice_distributionGetBlockLoc(dist, abs(nwBlock), dstProc, &
00447 dstLocalID)
00448
00449 else
00450 dstProc = 0
00451 dstLocalID = 0
00452 endif
00453
00454 call ice_HaloIncrementMsgCount(sendCount, recvCount, &
00455 srcProc, dstProc, msgSize)
00456
00457
00458
00459 seBlock = ice_blocksGetNbrID(iblock, ice_blocksSouthEast, &
00460 ewBoundaryType, nsBoundaryType)
00461
00462 if (seBlock > 0) then
00463 call ice_distributionGetBlockLoc(dist, seBlock, dstProc, &
00464 dstLocalID)
00465 else
00466 dstProc = 0
00467 dstLocalID = 0
00468 endif
00469
00470 call ice_HaloIncrementMsgCount(sendCount, recvCount, &
00471 srcProc, dstProc, cornerMsgSize)
00472
00473
00474
00475 swBlock = ice_blocksGetNbrID(iblock, ice_blocksSouthWest, &
00476 ewBoundaryType, nsBoundaryType)
00477
00478 if (swBlock > 0) then
00479 call ice_distributionGetBlockLoc(dist, swBlock, dstProc, &
00480 dstLocalID)
00481 else
00482 dstProc = 0
00483 dstLocalID = 0
00484 endif
00485
00486 call ice_HaloIncrementMsgCount(sendCount, recvCount, &
00487 srcProc, dstProc, cornerMsgSize)
00488
00489
00490
00491
00492
00493 if (tripoleBlock .and. &
00494 mod(nxGlobal,blockSizeX) /= 0) then
00495
00496
00497
00498 eastBlock = ice_blocksGetNbrID(iBlock, ice_blocksEast2, &
00499 ewBoundaryType, nsBoundaryType)
00500
00501 if (eastBlock > 0) then
00502 call ice_distributionGetBlockLoc(dist, eastBlock, dstProc, &
00503 dstLocalID)
00504 else
00505 dstProc = 0
00506 dstLocalID = 0
00507 endif
00508
00509 if (dstProc /= srcProc) then
00510 call ice_HaloIncrementMsgCount(sendCount, recvCount, &
00511 srcProc, dstProc, tripoleMsgSize)
00512 endif
00513
00514
00515
00516 neBlock = ice_blocksGetNbrID(iBlock, ice_blocksEastNorthEast, &
00517 ewBoundaryType, nsBoundaryType)
00518
00519 if (neBlock < 0) then
00520 msgSize = tripoleMsgSize
00521
00522 call ice_distributionGetBlockLoc(dist, abs(neBlock), dstProc, &
00523 dstLocalID)
00524 else
00525 dstProc = 0
00526 dstLocalID = 0
00527 endif
00528
00529 if (dstProc /= srcProc) then
00530 call ice_HaloIncrementMsgCount(sendCount, recvCount, &
00531 srcProc, dstProc, msgSize)
00532 endif
00533
00534
00535
00536 westBlock = ice_blocksGetNbrID(iBlock, ice_blocksWest2, &
00537 ewBoundaryType, nsBoundaryType)
00538
00539 if (westBlock > 0) then
00540 call ice_distributionGetBlockLoc(dist, westBlock, dstProc, &
00541 dstLocalID)
00542 else
00543 dstProc = 0
00544 dstLocalID = 0
00545 endif
00546
00547 if (dstProc /= srcProc) then
00548 call ice_HaloIncrementMsgCount(sendCount, recvCount, &
00549 srcProc, dstProc, tripoleMsgSize)
00550 endif
00551
00552
00553
00554 nwBlock = ice_blocksGetNbrID(iBlock, ice_blocksWestNorthWest, &
00555 ewBoundaryType, nsBoundaryType)
00556
00557 if (nwBlock < 0) then
00558 msgSize = tripoleMsgSize
00559
00560 call ice_distributionGetBlockLoc(dist, abs(nwBlock), dstProc, &
00561 dstLocalID)
00562 else
00563 dstProc = 0
00564 dstLocalID = 0
00565 endif
00566
00567 if (dstProc /= srcProc) then
00568 call ice_HaloIncrementMsgCount(sendCount, recvCount, &
00569 srcProc, dstProc, msgSize)
00570 endif
00571
00572 endif
00573
00574 end do msgCountLoop
00575
00576
00577
00578
00579
00580
00581
00582
00583 halo%numLocalCopies = recvCount(my_task+1)
00584
00585 sendCount(my_task+1) = 0
00586 recvCount(my_task+1) = 0
00587
00588
00589
00590
00591
00592
00593
00594 numMsgSend = count(sendCount /= 0)
00595 numMsgRecv = count(recvCount /= 0)
00596 halo%numMsgSend = numMsgSend
00597 halo%numMsgRecv = numMsgRecv
00598
00599
00600
00601
00602
00603
00604
00605
00606
00607 maxTmp = maxval(sendCount)
00608 maxSizeSend = global_maxval(maxTmp, dist)
00609 maxTmp = maxval(recvCount)
00610 maxSizeRecv = global_maxval(maxTmp, dist)
00611
00612 if (.not. allocated(bufSendR8)) then
00613
00614 bufSizeSend = maxSizeSend
00615 bufSizeRecv = maxSizeRecv
00616
00617 allocate(bufSendI4(bufSizeSend, numMsgSend), &
00618 bufRecvI4(bufSizeRecv, numMsgRecv), &
00619 bufSendR4(bufSizeSend, numMsgSend), &
00620 bufRecvR4(bufSizeRecv, numMsgRecv), &
00621 bufSendR8(bufSizeSend, numMsgSend), &
00622 bufRecvR8(bufSizeRecv, numMsgRecv), stat=istat)
00623
00624 if (istat > 0) then
00625 call abort_ice( &
00626 'ice_HaloCreate: error allocating 2d buffers')
00627 return
00628 endif
00629
00630 else
00631
00632 resize = .false.
00633
00634 if (maxSizeSend > bufSizeSend) then
00635 resize = .true.
00636 bufSizeSend = maxSizeSend
00637 endif
00638 if (maxSizeRecv > bufSizeRecv) then
00639 resize = .true.
00640 bufSizeRecv = maxSizeRecv
00641 endif
00642
00643 if (numMsgSend > size(bufSendR8,dim=2)) resize = .true.
00644 if (numMsgRecv > size(bufRecvR8,dim=2)) resize = .true.
00645
00646 if (resize) then
00647 deallocate(bufSendI4, bufRecvI4, bufSendR4, &
00648 bufRecvR4, bufSendR8, bufRecvR8, stat=istat)
00649
00650 if (istat > 0) then
00651 call abort_ice( &
00652 'ice_HaloCreate: error deallocating 2d buffers')
00653 return
00654 endif
00655
00656 allocate(bufSendI4(bufSizeSend, numMsgSend), &
00657 bufRecvI4(bufSizeRecv, numMsgRecv), &
00658 bufSendR4(bufSizeSend, numMsgSend), &
00659 bufRecvR4(bufSizeRecv, numMsgRecv), &
00660 bufSendR8(bufSizeSend, numMsgSend), &
00661 bufRecvR8(bufSizeRecv, numMsgRecv), stat=istat)
00662
00663 if (istat > 0) then
00664 call abort_ice( &
00665 'ice_HaloCreate: error reallocating 2d buffers')
00666 return
00667 endif
00668
00669 endif
00670
00671 endif
00672
00673
00674
00675
00676
00677
00678
00679 allocate(halo%sendTask(numMsgSend), &
00680 halo%recvTask(numMsgRecv), &
00681 halo%sizeSend(numMsgSend), &
00682 halo%sizeRecv(numMsgRecv), &
00683 halo%sendAddr(3,bufSizeSend,numMsgSend), &
00684 halo%recvAddr(3,bufSizeRecv,numMsgRecv), &
00685 halo%srcLocalAddr(3,halo%numLocalCopies), &
00686 halo%dstLocalAddr(3,halo%numLocalCopies), &
00687 stat = istat)
00688
00689 if (istat > 0) then
00690 call abort_ice( &
00691 'ice_HaloCreate: error allocating halo message info arrays')
00692 return
00693 endif
00694
00695 halo%sendTask = 0
00696 halo%recvTask = 0
00697 halo%sizeSend = 0
00698 halo%sizeRecv = 0
00699 halo%sendAddr = 0
00700 halo%recvAddr = 0
00701 halo%srcLocalAddr = 0
00702 halo%dstLocalAddr = 0
00703
00704 deallocate(sendCount, recvCount, stat=istat)
00705
00706 if (istat > 0) then
00707 call abort_ice( &
00708 'ice_HaloCreate: error deallocating count arrays')
00709 return
00710 endif
00711
00712
00713
00714
00715
00716
00717
00718
00719
00720
00721 halo%numMsgSend = 0
00722 halo%numMsgRecv = 0
00723 halo%numLocalCopies = 0
00724
00725 msgConfigLoop: do iblock=1,nblocks_tot
00726
00727 call ice_distributionGetBlockLoc(dist, iblock, srcProc, &
00728 srcLocalID)
00729
00730
00731
00732
00733 northBlock = ice_blocksGetNbrID(iblock, ice_blocksNorth, &
00734 ewBoundaryType, nsBoundaryType)
00735
00736 if (northBlock > 0) then
00737 tripoleBlock = .false.
00738 call ice_distributionGetBlockLoc(dist, northBlock, dstProc, &
00739 dstLocalID)
00740 else if (northBlock < 0) then
00741 tripoleBlock = .true.
00742 call ice_distributionGetBlockLoc(dist, abs(northBlock), &
00743 dstProc, dstLocalID)
00744 else
00745 tripoleBlock = .false.
00746 dstProc = 0
00747 dstLocalID = 0
00748 endif
00749
00750 call ice_HaloMsgCreate(halo, iblock, srcProc, srcLocalID, &
00751 northBlock, dstProc, dstLocalID, &
00752 'north')
00753
00754
00755
00756
00757 if (tripoleBlock) then
00758
00759 call ice_HaloMsgCreate(halo,-iblock, srcProc, srcLocalID, &
00760 iblock, srcProc, srcLocalID, &
00761 'north')
00762
00763
00764 if (dstProc /= srcProc) then
00765 call ice_HaloMsgCreate(halo, iblock, srcProc, srcLocalID, &
00766 -iblock, srcProc, srcLocalID, &
00767 'north')
00768
00769 endif
00770 endif
00771
00772
00773
00774 southBlock = ice_blocksGetNbrID(iblock, ice_blocksSouth, &
00775 ewBoundaryType, nsBoundaryType)
00776
00777 if (southBlock > 0) then
00778 call ice_distributionGetBlockLoc(dist, southBlock, dstProc, &
00779 dstLocalID)
00780
00781 else
00782 dstProc = 0
00783 dstLocalID = 0
00784 endif
00785
00786 call ice_HaloMsgCreate(halo, iblock, srcProc, srcLocalID, &
00787 southBlock, dstProc, dstLocalID, &
00788 'south')
00789
00790
00791
00792 eastBlock = ice_blocksGetNbrID(iblock, ice_blocksEast, &
00793 ewBoundaryType, nsBoundaryType)
00794
00795 if (eastBlock > 0) then
00796 call ice_distributionGetBlockLoc(dist, eastBlock, dstProc, &
00797 dstLocalID)
00798
00799 else
00800 dstProc = 0
00801 dstLocalID = 0
00802 endif
00803
00804 call ice_HaloMsgCreate(halo, iblock, srcProc, srcLocalID, &
00805 eastBlock, dstProc, dstLocalID, &
00806 'east')
00807
00808
00809
00810
00811
00812 if (tripoleBlock .and. dstProc /= srcProc) then
00813 call ice_HaloMsgCreate(halo, iblock, srcProc, srcLocalID, &
00814 -eastBlock, dstProc, dstLocalID, &
00815 'north')
00816
00817 endif
00818
00819
00820
00821 westBlock = ice_blocksGetNbrID(iblock, ice_blocksWest, &
00822 ewBoundaryType, nsBoundaryType)
00823
00824 if (westBlock > 0) then
00825 call ice_distributionGetBlockLoc(dist, westBlock, dstProc, &
00826 dstLocalID)
00827
00828 else
00829 dstProc = 0
00830 dstLocalID = 0
00831 endif
00832
00833 call ice_HaloMsgCreate(halo, iblock, srcProc, srcLocalID, &
00834 westBlock, dstProc, dstLocalID, &
00835 'west')
00836
00837
00838
00839
00840
00841
00842 if (tripoleBlock .and. dstProc /= srcProc) then
00843 call ice_HaloMsgCreate(halo, iblock, srcProc, srcLocalID, &
00844 -westBlock, dstProc, dstLocalID, &
00845 'north')
00846
00847 endif
00848
00849
00850
00851 neBlock = ice_blocksGetNbrID(iblock, ice_blocksNorthEast, &
00852 ewBoundaryType, nsBoundaryType)
00853
00854 if (neBlock /= 0) then
00855 call ice_distributionGetBlockLoc(dist, abs(neBlock), dstProc, &
00856 dstLocalID)
00857
00858 else
00859 dstProc = 0
00860 dstLocalID = 0
00861 endif
00862
00863 call ice_HaloMsgCreate(halo, iblock, srcProc, srcLocalID, &
00864 neBlock, dstProc, dstLocalID, &
00865 'northeast')
00866
00867
00868
00869 nwBlock = ice_blocksGetNbrID(iblock, ice_blocksNorthWest, &
00870 ewBoundaryType, nsBoundaryType)
00871
00872 if (nwBlock /= 0) then
00873 call ice_distributionGetBlockLoc(dist, abs(nwBlock), dstProc, &
00874 dstLocalID)
00875
00876 else
00877 dstProc = 0
00878 dstLocalID = 0
00879 endif
00880
00881 call ice_HaloMsgCreate(halo, iblock, srcProc, srcLocalID, &
00882 nwBlock, dstProc, dstLocalID, &
00883 'northwest')
00884
00885
00886
00887 seBlock = ice_blocksGetNbrID(iblock, ice_blocksSouthEast, &
00888 ewBoundaryType, nsBoundaryType)
00889
00890 if (seBlock > 0) then
00891 call ice_distributionGetBlockLoc(dist, seBlock, dstProc, &
00892 dstLocalID)
00893
00894 else
00895 dstProc = 0
00896 dstLocalID = 0
00897 endif
00898
00899 call ice_HaloMsgCreate(halo, iblock, srcProc, srcLocalID, &
00900 seBlock, dstProc, dstLocalID, &
00901 'southeast')
00902
00903
00904
00905 swBlock = ice_blocksGetNbrID(iblock, ice_blocksSouthWest, &
00906 ewBoundaryType, nsBoundaryType)
00907
00908 if (swBlock > 0) then
00909 call ice_distributionGetBlockLoc(dist, swBlock, dstProc, &
00910 dstLocalID)
00911
00912 else
00913 dstProc = 0
00914 dstLocalID = 0
00915 endif
00916
00917 call ice_HaloMsgCreate(halo, iblock, srcProc, srcLocalID, &
00918 swBlock, dstProc, dstLocalID, &
00919 'southwest')
00920
00921
00922
00923
00924
00925 if (tripoleBlock .and. &
00926 mod(nxGlobal,blockSizeX) /= 0) then
00927
00928
00929
00930 eastBlock = ice_blocksGetNbrID(iBlock, ice_blocksEast2, &
00931 ewBoundaryType, nsBoundaryType)
00932
00933 if (eastBlock > 0) then
00934 call ice_distributionGetBlockLoc(dist, eastBlock, dstProc, &
00935 dstLocalID)
00936
00937 else
00938 dstProc = 0
00939 dstLocalID = 0
00940 endif
00941
00942 if (dstProc /= srcProc) then
00943 call ice_HaloMsgCreate(halo, iblock, srcProc, srcLocalID, &
00944 -eastBlock, dstProc, dstLocalID, &
00945 'north')
00946
00947 endif
00948
00949
00950
00951 neBlock = ice_blocksGetNbrID(iBlock, ice_blocksEastNorthEast, &
00952 ewBoundaryType, nsBoundaryType)
00953
00954 if (neBlock < 0) then
00955 msgSize = tripoleMsgSize
00956
00957 call ice_distributionGetBlockLoc(dist, abs(neBlock), dstProc, &
00958 dstLocalID)
00959
00960 else
00961 dstProc = 0
00962 dstLocalID = 0
00963 endif
00964
00965 if (dstProc /= srcProc) then
00966 call ice_HaloMsgCreate(halo, iblock, srcProc, srcLocalID, &
00967 neBlock, dstProc, dstLocalID, &
00968 'north')
00969 endif
00970
00971
00972
00973 westBlock = ice_blocksGetNbrID(iBlock, ice_blocksWest2, &
00974 ewBoundaryType, nsBoundaryType)
00975
00976 if (westBlock > 0) then
00977 call ice_distributionGetBlockLoc(dist, westBlock, dstProc, &
00978 dstLocalID)
00979
00980 else
00981 dstProc = 0
00982 dstLocalID = 0
00983 endif
00984
00985 if (dstProc /= srcProc) then
00986 call ice_HaloMsgCreate(halo, iblock, srcProc, srcLocalID, &
00987 -westBlock, dstProc, dstLocalID, &
00988 'north')
00989
00990 endif
00991
00992
00993
00994 nwBlock = ice_blocksGetNbrID(iBlock, ice_blocksWestNorthWest, &
00995 ewBoundaryType, nsBoundaryType)
00996
00997 if (nwBlock < 0) then
00998 msgSize = tripoleMsgSize
00999
01000 call ice_distributionGetBlockLoc(dist, abs(nwBlock), dstProc, &
01001 dstLocalID)
01002
01003 else
01004 dstProc = 0
01005 dstLocalID = 0
01006 endif
01007
01008 if (dstProc /= srcProc) then
01009 call ice_HaloMsgCreate(halo, iblock, srcProc, srcLocalID, &
01010 nwBlock, dstProc, dstLocalID, &
01011 'north')
01012
01013 endif
01014
01015 endif
01016
01017 end do msgConfigLoop
01018
01019
01020
01021
01022 end function ice_HaloCreate
01023
01024
01025
01026
01027
01028
01029 subroutine ice_HaloUpdate2DR8(array, halo, &
01030 fieldLoc, fieldKind, &
01031 fillValue)
01032
01033
01034
01035
01036
01037
01038
01039
01040
01041
01042
01043
01044
01045
01046 type (ice_halo), intent(in) ::
01047 halo
01048
01049
01050 integer (int_kind), intent(in) ::
01051 fieldKind,
01052 fieldLoc
01053
01054
01055 real (dbl_kind), intent(in), optional ::
01056 fillValue
01057
01058
01059
01060
01061
01062
01063 real (dbl_kind), dimension(:,:,:), intent(inout) ::
01064 array
01065
01066
01067
01068
01069
01070
01071
01072
01073
01074
01075
01076
01077 integer (int_kind) ::
01078 i,j,n,nmsg,
01079 ierr,
01080 nxGlobal,
01081 iSrc,jSrc,
01082 iDst,jDst,
01083 srcBlock,
01084 dstBlock,
01085 ioffset, joffset,
01086 isign
01087
01088 integer (int_kind), dimension(:), allocatable ::
01089 sndRequest,
01090 rcvRequest
01091
01092 integer (int_kind), dimension(:,:), allocatable ::
01093 sndStatus,
01094 rcvStatus
01095
01096 real (dbl_kind) ::
01097 fill,
01098 x1,x2,xavg
01099
01100 integer (int_kind) :: len
01101
01102
01103
01104
01105
01106
01107
01108 if (present(fillValue)) then
01109 fill = fillValue
01110 else
01111 fill = 0.0_dbl_kind
01112 endif
01113
01114 nxGlobal = 0
01115 if (allocated(bufTripoleR8)) then
01116 nxGlobal = size(bufTripoleR8,dim=1)
01117 bufTripoleR8 = fill
01118 endif
01119
01120
01121
01122
01123
01124
01125
01126 allocate(sndRequest(halo%numMsgSend), &
01127 rcvRequest(halo%numMsgRecv), &
01128 sndStatus(MPI_STATUS_SIZE,halo%numMsgSend), &
01129 rcvStatus(MPI_STATUS_SIZE,halo%numMsgRecv), stat=ierr)
01130
01131 if (ierr > 0) then
01132 call abort_ice( &
01133 'ice_HaloUpdate2DR8: error allocating req,status arrays')
01134 return
01135 endif
01136
01137
01138
01139
01140
01141
01142
01143 do nmsg=1,halo%numMsgRecv
01144
01145 len = halo%SizeRecv(nmsg)
01146 call MPI_IRECV(bufRecvR8(1:len,nmsg), len, mpiR8, &
01147 halo%recvTask(nmsg), &
01148 mpitagHalo + halo%recvTask(nmsg), &
01149 halo%communicator, rcvRequest(nmsg), ierr)
01150 end do
01151
01152
01153
01154
01155
01156
01157
01158 do nmsg=1,halo%numMsgSend
01159
01160 do n=1,halo%sizeSend(nmsg)
01161 iSrc = halo%sendAddr(1,n,nmsg)
01162 jSrc = halo%sendAddr(2,n,nmsg)
01163 srcBlock = halo%sendAddr(3,n,nmsg)
01164
01165 bufSendR8(n,nmsg) = array(iSrc,jSrc,srcBlock)
01166 end do
01167 do n=halo%sizeSend(nmsg)+1,bufSizeSend
01168 bufSendR8(n,nmsg) = fill
01169 end do
01170
01171 len = halo%SizeSend(nmsg)
01172 call MPI_ISEND(bufSendR8(1:len,nmsg), len, mpiR8, &
01173 halo%sendTask(nmsg), &
01174 mpitagHalo + my_task, &
01175 halo%communicator, sndRequest(nmsg), ierr)
01176 end do
01177
01178
01179
01180
01181
01182
01183
01184
01185
01186
01187
01188 do nmsg=1,halo%numLocalCopies
01189 iSrc = halo%srcLocalAddr(1,nmsg)
01190 jSrc = halo%srcLocalAddr(2,nmsg)
01191 srcBlock = halo%srcLocalAddr(3,nmsg)
01192 iDst = halo%dstLocalAddr(1,nmsg)
01193 jDst = halo%dstLocalAddr(2,nmsg)
01194 dstBlock = halo%dstLocalAddr(3,nmsg)
01195
01196 if (srcBlock > 0) then
01197 if (dstBlock > 0) then
01198 array(iDst,jDst,dstBlock) = &
01199 array(iSrc,jSrc,srcBlock)
01200 else if (dstBlock < 0) then
01201 bufTripoleR8(iDst,jDst) = &
01202 array(iSrc,jSrc,srcBlock)
01203 endif
01204 else if (srcBlock == 0) then
01205 array(iDst,jDst,dstBlock) = fill
01206 endif
01207 end do
01208
01209
01210
01211
01212
01213
01214
01215
01216 call MPI_WAITALL(halo%numMsgRecv, rcvRequest, rcvStatus, ierr)
01217
01218 do nmsg=1,halo%numMsgRecv
01219 do n=1,halo%sizeRecv(nmsg)
01220 iDst = halo%recvAddr(1,n,nmsg)
01221 jDst = halo%recvAddr(2,n,nmsg)
01222 dstBlock = halo%recvAddr(3,n,nmsg)
01223
01224 if (dstBlock > 0) then
01225 array(iDst,jDst,dstBlock) = bufRecvR8(n,nmsg)
01226 else if (dstBlock < 0) then
01227 bufTripoleR8(iDst,jDst) = bufRecvR8(n,nmsg)
01228 endif
01229 end do
01230 end do
01231
01232
01233
01234
01235
01236
01237
01238
01239
01240 if (nxGlobal > 0) then
01241
01242 select case (fieldKind)
01243 case (field_type_scalar)
01244 isign = 1
01245 case (field_type_vector)
01246 isign = -1
01247 case (field_type_angle)
01248 isign = -1
01249 case default
01250 call abort_ice( &
01251 'ice_HaloUpdate2DR8: Unknown field kind')
01252 end select
01253
01254 if (halo%tripoleTFlag) then
01255
01256 select case (fieldLoc)
01257 case (field_loc_center)
01258
01259 ioffset = -1
01260 joffset = 0
01261
01262
01263
01264
01265 do i = 2,nxGlobal/2
01266 iDst = nxGlobal - i + 2
01267 x1 = bufTripoleR8(i ,halo%tripoleRows)
01268 x2 = bufTripoleR8(iDst,halo%tripoleRows)
01269 xavg = 0.5_dbl_kind*(x1 + isign*x2)
01270 bufTripoleR8(i ,halo%tripoleRows) = xavg
01271 bufTripoleR8(iDst,halo%tripoleRows) = isign*xavg
01272 end do
01273
01274 case (field_loc_NEcorner)
01275
01276 ioffset = 0
01277 joffset = 1
01278
01279 case (field_loc_Eface)
01280
01281 ioffset = 0
01282 joffset = 0
01283
01284
01285
01286
01287 do i = 1,nxGlobal/2
01288 iDst = nxGlobal + 1 - i
01289 x1 = bufTripoleR8(i ,halo%tripoleRows)
01290 x2 = bufTripoleR8(iDst,halo%tripoleRows)
01291 xavg = 0.5_dbl_kind*(x1 + isign*x2)
01292 bufTripoleR8(i ,halo%tripoleRows) = xavg
01293 bufTripoleR8(iDst,halo%tripoleRows) = isign*xavg
01294 end do
01295
01296 case (field_loc_Nface)
01297
01298 ioffset = -1
01299 joffset = 1
01300
01301 case default
01302 call abort_ice( &
01303 'ice_HaloUpdate2DR8: Unknown field location')
01304 end select
01305
01306 else
01307
01308 select case (fieldLoc)
01309 case (field_loc_center)
01310
01311 ioffset = 0
01312 joffset = 0
01313
01314 case (field_loc_NEcorner)
01315
01316 ioffset = 1
01317 joffset = 1
01318
01319
01320
01321
01322 do i = 1,nxGlobal/2 - 1
01323 iDst = nxGlobal - i
01324 x1 = bufTripoleR8(i ,halo%tripoleRows)
01325 x2 = bufTripoleR8(iDst,halo%tripoleRows)
01326 xavg = 0.5_dbl_kind*(x1 + isign*x2)
01327 bufTripoleR8(i ,halo%tripoleRows) = xavg
01328 bufTripoleR8(iDst,halo%tripoleRows) = isign*xavg
01329 end do
01330
01331 case (field_loc_Eface)
01332
01333 ioffset = 1
01334 joffset = 0
01335
01336 case (field_loc_Nface)
01337
01338 ioffset = 0
01339 joffset = 1
01340
01341
01342
01343
01344 do i = 1,nxGlobal/2
01345 iDst = nxGlobal + 1 - i
01346 x1 = bufTripoleR8(i ,halo%tripoleRows)
01347 x2 = bufTripoleR8(iDst,halo%tripoleRows)
01348 xavg = 0.5_dbl_kind*(x1 + isign*x2)
01349 bufTripoleR8(i ,halo%tripoleRows) = xavg
01350 bufTripoleR8(iDst,halo%tripoleRows) = isign*xavg
01351 end do
01352
01353 case default
01354 call abort_ice( &
01355 'ice_HaloUpdate2DR8: Unknown field location')
01356 end select
01357
01358 endif
01359
01360
01361
01362
01363
01364
01365
01366 do nmsg=1,halo%numLocalCopies
01367 srcBlock = halo%srcLocalAddr(3,nmsg)
01368
01369 if (srcBlock < 0) then
01370
01371 iSrc = halo%srcLocalAddr(1,nmsg)
01372 jSrc = halo%srcLocalAddr(2,nmsg)
01373
01374 iDst = halo%dstLocalAddr(1,nmsg)
01375 jDst = halo%dstLocalAddr(2,nmsg)
01376 dstBlock = halo%dstLocalAddr(3,nmsg)
01377
01378
01379 iSrc = iSrc - ioffset
01380 jSrc = jSrc - joffset
01381 if (iSrc == 0) iSrc = nxGlobal
01382 if (iSrc > nxGlobal) iSrc = iSrc - nxGlobal
01383
01384
01385
01386
01387
01388
01389
01390 if (jSrc <= halo%tripoleRows .and. jSrc>0 .and. jDst>0) then
01391 array(iDst,jDst,dstBlock) = isign*bufTripoleR8(iSrc,jSrc)
01392 endif
01393
01394 endif
01395 end do
01396
01397 endif
01398
01399
01400
01401
01402
01403
01404
01405 call MPI_WAITALL(halo%numMsgSend, sndRequest, sndStatus, ierr)
01406
01407 deallocate(sndRequest, rcvRequest, sndStatus, rcvStatus, stat=ierr)
01408
01409 if (ierr > 0) then
01410 call abort_ice( &
01411 'ice_HaloUpdate2DR8: error deallocating req,status arrays')
01412 return
01413 endif
01414
01415
01416
01417
01418 end subroutine ice_HaloUpdate2DR8
01419
01420
01421
01422
01423
01424
01425 subroutine ice_HaloUpdate_stress(array1, array2, halo, &
01426 fieldLoc, fieldKind, &
01427 fillValue)
01428
01429
01430
01431
01432
01433
01434
01435
01436
01437
01438
01439
01440 type (ice_halo), intent(in) ::
01441 halo
01442
01443
01444 integer (int_kind), intent(in) ::
01445 fieldKind,
01446 fieldLoc
01447
01448
01449 real (dbl_kind), intent(in), optional ::
01450 fillValue
01451
01452
01453
01454
01455
01456
01457 real (dbl_kind), dimension(:,:,:), intent(inout) ::
01458 array1 ,
01459
01460 array2
01461
01462
01463
01464
01465
01466
01467
01468
01469
01470
01471
01472
01473 integer (int_kind) ::
01474 i,j,n,nmsg,
01475 ierr,
01476 nxGlobal,
01477 iSrc,jSrc,
01478 iDst,jDst,
01479 srcBlock,
01480 dstBlock,
01481 ioffset, joffset,
01482 isign
01483
01484 integer (int_kind), dimension(:), allocatable ::
01485 sndRequest,
01486 rcvRequest
01487
01488 integer (int_kind), dimension(:,:), allocatable ::
01489 sndStatus,
01490 rcvStatus
01491
01492 real (dbl_kind) ::
01493 fill,
01494 x1,x2,xavg
01495
01496 integer (int_kind) :: len
01497
01498
01499
01500
01501
01502
01503
01504 if (present(fillValue)) then
01505 fill = fillValue
01506 else
01507 fill = 0.0_dbl_kind
01508 endif
01509
01510 nxGlobal = 0
01511 if (allocated(bufTripoleR8)) then
01512 nxGlobal = size(bufTripoleR8,dim=1)
01513 bufTripoleR8 = fill
01514 endif
01515
01516
01517
01518
01519
01520
01521
01522 allocate(sndRequest(halo%numMsgSend), &
01523 rcvRequest(halo%numMsgRecv), &
01524 sndStatus(MPI_STATUS_SIZE,halo%numMsgSend), &
01525 rcvStatus(MPI_STATUS_SIZE,halo%numMsgRecv), stat=ierr)
01526
01527 if (ierr > 0) then
01528 call abort_ice( &
01529 'ice_HaloUpdate_stress: error allocating req,status arrays')
01530 return
01531 endif
01532
01533
01534
01535
01536
01537
01538
01539 do nmsg=1,halo%numMsgRecv
01540
01541 len = halo%SizeRecv(nmsg)
01542 call MPI_IRECV(bufRecvR8(1:len,nmsg), len, mpiR8, &
01543 halo%recvTask(nmsg), &
01544 mpitagHalo + halo%recvTask(nmsg), &
01545 halo%communicator, rcvRequest(nmsg), ierr)
01546 end do
01547
01548
01549
01550
01551
01552
01553
01554 do nmsg=1,halo%numMsgSend
01555
01556 do n=1,halo%sizeSend(nmsg)
01557 iSrc = halo%sendAddr(1,n,nmsg)
01558 jSrc = halo%sendAddr(2,n,nmsg)
01559 srcBlock = halo%sendAddr(3,n,nmsg)
01560
01561 bufSendR8(n,nmsg) = array2(iSrc,jSrc,srcBlock)
01562 end do
01563 do n=halo%sizeSend(nmsg)+1,bufSizeSend
01564 bufSendR8(n,nmsg) = fill
01565 end do
01566
01567 len = halo%SizeSend(nmsg)
01568 call MPI_ISEND(bufSendR8(1:len,nmsg), len, mpiR8, &
01569 halo%sendTask(nmsg), &
01570 mpitagHalo + my_task, &
01571 halo%communicator, sndRequest(nmsg), ierr)
01572 end do
01573
01574
01575
01576
01577
01578
01579
01580
01581
01582
01583
01584 do nmsg=1,halo%numLocalCopies
01585 iSrc = halo%srcLocalAddr(1,nmsg)
01586 jSrc = halo%srcLocalAddr(2,nmsg)
01587 srcBlock = halo%srcLocalAddr(3,nmsg)
01588 iDst = halo%dstLocalAddr(1,nmsg)
01589 jDst = halo%dstLocalAddr(2,nmsg)
01590 dstBlock = halo%dstLocalAddr(3,nmsg)
01591
01592 if (srcBlock > 0) then
01593 if (dstBlock < 0) then
01594 bufTripoleR8(iDst,jDst) = &
01595 array2(iSrc,jSrc,srcBlock)
01596 endif
01597 else if (srcBlock == 0) then
01598 array1(iDst,jDst,dstBlock) = fill
01599 endif
01600 end do
01601
01602
01603
01604
01605
01606
01607
01608
01609 call MPI_WAITALL(halo%numMsgRecv, rcvRequest, rcvStatus, ierr)
01610
01611 do nmsg=1,halo%numMsgRecv
01612 do n=1,halo%sizeRecv(nmsg)
01613 iDst = halo%recvAddr(1,n,nmsg)
01614 jDst = halo%recvAddr(2,n,nmsg)
01615 dstBlock = halo%recvAddr(3,n,nmsg)
01616
01617 if (dstBlock < 0) then
01618 bufTripoleR8(iDst,jDst) = bufRecvR8(n,nmsg)
01619 endif
01620 end do
01621 end do
01622
01623
01624
01625
01626
01627
01628
01629
01630
01631 if (nxGlobal > 0) then
01632
01633 select case (fieldKind)
01634 case (field_type_scalar)
01635 isign = 1
01636 case (field_type_vector)
01637 isign = -1
01638 case (field_type_angle)
01639 isign = -1
01640 case default
01641 call abort_ice( &
01642 'ice_HaloUpdate_stress: Unknown field kind')
01643 end select
01644
01645 select case (fieldLoc)
01646 case (field_loc_center)
01647
01648 ioffset = 0
01649 joffset = 0
01650
01651 case (field_loc_NEcorner)
01652
01653 ioffset = 1
01654 joffset = 1
01655
01656 case (field_loc_Eface)
01657
01658 ioffset = 1
01659 joffset = 0
01660
01661 case (field_loc_Nface)
01662
01663 ioffset = 0
01664 joffset = 1
01665
01666 case default
01667 call abort_ice( &
01668 'ice_HaloUpdate_stress: Unknown field location')
01669 end select
01670
01671
01672
01673
01674
01675
01676
01677 do nmsg=1,halo%numLocalCopies
01678 srcBlock = halo%srcLocalAddr(3,nmsg)
01679
01680 if (srcBlock < 0) then
01681
01682 iSrc = halo%srcLocalAddr(1,nmsg)
01683 jSrc = halo%srcLocalAddr(2,nmsg)
01684
01685 iDst = halo%dstLocalAddr(1,nmsg)
01686 jDst = halo%dstLocalAddr(2,nmsg)
01687 dstBlock = halo%dstLocalAddr(3,nmsg)
01688
01689
01690 iSrc = iSrc - ioffset
01691 jSrc = jSrc - joffset
01692 if (iSrc == 0) iSrc = nxGlobal
01693
01694
01695
01696
01697
01698
01699 if (jSrc <= nghost+1) then
01700 array1(iDst,jDst,dstBlock) = isign*bufTripoleR8(iSrc,jSrc)
01701 endif
01702
01703 endif
01704 end do
01705
01706 endif
01707
01708
01709
01710
01711
01712
01713
01714 call MPI_WAITALL(halo%numMsgSend, sndRequest, sndStatus, ierr)
01715
01716 deallocate(sndRequest, rcvRequest, sndStatus, rcvStatus, stat=ierr)
01717
01718 if (ierr > 0) then
01719 call abort_ice( &
01720 'ice_HaloUpdate_stress: error deallocating req,status arrays')
01721 return
01722 endif
01723
01724
01725
01726 end subroutine ice_HaloUpdate_stress
01727
01728
01729
01730
01731
01732
01733 subroutine ice_HaloUpdate2DR4(array, halo, &
01734 fieldLoc, fieldKind, &
01735 fillValue)
01736
01737
01738
01739
01740
01741
01742
01743
01744
01745
01746
01747
01748
01749
01750 type (ice_halo), intent(in) ::
01751 halo
01752
01753
01754 integer (int_kind), intent(in) ::
01755 fieldKind,
01756 fieldLoc
01757
01758
01759 real (real_kind), intent(in), optional ::
01760 fillValue
01761
01762
01763
01764
01765
01766
01767 real (real_kind), dimension(:,:,:), intent(inout) ::
01768 array
01769
01770
01771
01772
01773
01774
01775
01776
01777
01778
01779
01780
01781 integer (int_kind) ::
01782 i,j,n,nmsg,
01783 ierr,
01784 nxGlobal,
01785 iSrc,jSrc,
01786 iDst,jDst,
01787 srcBlock,
01788 dstBlock,
01789 ioffset, joffset,
01790 isign
01791
01792 integer (int_kind), dimension(:), allocatable ::
01793 sndRequest,
01794 rcvRequest
01795
01796 integer (int_kind), dimension(:,:), allocatable ::
01797 sndStatus,
01798 rcvStatus
01799
01800 real (real_kind) ::
01801 fill,
01802 x1,x2,xavg
01803
01804 integer (int_kind) :: len
01805
01806
01807
01808
01809
01810
01811
01812 if (present(fillValue)) then
01813 fill = fillValue
01814 else
01815 fill = 0.0_real_kind
01816 endif
01817
01818 nxGlobal = 0
01819 if (allocated(bufTripoleR4)) then
01820 nxGlobal = size(bufTripoleR4,dim=1)
01821 bufTripoleR4 = fill
01822 endif
01823
01824
01825
01826
01827
01828
01829
01830 allocate(sndRequest(halo%numMsgSend), &
01831 rcvRequest(halo%numMsgRecv), &
01832 sndStatus(MPI_STATUS_SIZE,halo%numMsgSend), &
01833 rcvStatus(MPI_STATUS_SIZE,halo%numMsgRecv), stat=ierr)
01834
01835 if (ierr > 0) then
01836 call abort_ice( &
01837 'ice_HaloUpdate2DR4: error allocating req,status arrays')
01838 return
01839 endif
01840
01841
01842
01843
01844
01845
01846
01847 do nmsg=1,halo%numMsgRecv
01848
01849 len = halo%SizeRecv(nmsg)
01850 call MPI_IRECV(bufRecvR4(1:len,nmsg), len, mpiR4, &
01851 halo%recvTask(nmsg), &
01852 mpitagHalo + halo%recvTask(nmsg), &
01853 halo%communicator, rcvRequest(nmsg), ierr)
01854 end do
01855
01856
01857
01858
01859
01860
01861
01862 do nmsg=1,halo%numMsgSend
01863
01864 do n=1,halo%sizeSend(nmsg)
01865 iSrc = halo%sendAddr(1,n,nmsg)
01866 jSrc = halo%sendAddr(2,n,nmsg)
01867 srcBlock = halo%sendAddr(3,n,nmsg)
01868
01869 bufSendR4(n,nmsg) = array(iSrc,jSrc,srcBlock)
01870 end do
01871 do n=halo%sizeSend(nmsg)+1,bufSizeSend
01872 bufSendR4(n,nmsg) = fill
01873 end do
01874
01875 len = halo%SizeSend(nmsg)
01876 call MPI_ISEND(bufSendR4(1:len,nmsg), len, mpiR4, &
01877 halo%sendTask(nmsg), &
01878 mpitagHalo + my_task, &
01879 halo%communicator, sndRequest(nmsg), ierr)
01880 end do
01881
01882
01883
01884
01885
01886
01887
01888
01889
01890
01891
01892 do nmsg=1,halo%numLocalCopies
01893 iSrc = halo%srcLocalAddr(1,nmsg)
01894 jSrc = halo%srcLocalAddr(2,nmsg)
01895 srcBlock = halo%srcLocalAddr(3,nmsg)
01896 iDst = halo%dstLocalAddr(1,nmsg)
01897 jDst = halo%dstLocalAddr(2,nmsg)
01898 dstBlock = halo%dstLocalAddr(3,nmsg)
01899
01900 if (srcBlock > 0) then
01901 if (dstBlock > 0) then
01902 array(iDst,jDst,dstBlock) = &
01903 array(iSrc,jSrc,srcBlock)
01904 else if (dstBlock < 0) then
01905 bufTripoleR4(iDst,jDst) = &
01906 array(iSrc,jSrc,srcBlock)
01907 endif
01908 else if (srcBlock == 0) then
01909 array(iDst,jDst,dstBlock) = fill
01910 endif
01911 end do
01912
01913
01914
01915
01916
01917
01918
01919
01920 call MPI_WAITALL(halo%numMsgRecv, rcvRequest, rcvStatus, ierr)
01921
01922 do nmsg=1,halo%numMsgRecv
01923 do n=1,halo%sizeRecv(nmsg)
01924 iDst = halo%recvAddr(1,n,nmsg)
01925 jDst = halo%recvAddr(2,n,nmsg)
01926 dstBlock = halo%recvAddr(3,n,nmsg)
01927
01928 if (dstBlock > 0) then
01929 array(iDst,jDst,dstBlock) = bufRecvR4(n,nmsg)
01930 else if (dstBlock < 0) then
01931 bufTripoleR4(iDst,jDst) = bufRecvR4(n,nmsg)
01932 endif
01933 end do
01934 end do
01935
01936
01937
01938
01939
01940
01941
01942
01943
01944 if (nxGlobal > 0) then
01945
01946 select case (fieldKind)
01947 case (field_type_scalar)
01948 isign = 1
01949 case (field_type_vector)
01950 isign = -1
01951 case (field_type_angle)
01952 isign = -1
01953 case default
01954 call abort_ice( &
01955 'ice_HaloUpdate2DR4: Unknown field kind')
01956 end select
01957
01958 if (halo%tripoleTFlag) then
01959
01960 select case (fieldLoc)
01961 case (field_loc_center)
01962
01963 ioffset = -1
01964 joffset = 0
01965
01966
01967
01968
01969 do i = 2,nxGlobal/2
01970 iDst = nxGlobal - i + 2
01971 x1 = bufTripoleR4(i ,halo%tripoleRows)
01972 x2 = bufTripoleR4(iDst,halo%tripoleRows)
01973 xavg = 0.5_real_kind*(x1 + isign*x2)
01974 bufTripoleR4(i ,halo%tripoleRows) = xavg
01975 bufTripoleR4(iDst,halo%tripoleRows) = isign*xavg
01976 end do
01977
01978 case (field_loc_NEcorner)
01979
01980 ioffset = 0
01981 joffset = 1
01982
01983 case (field_loc_Eface)
01984
01985 ioffset = 0
01986 joffset = 0
01987
01988
01989
01990
01991 do i = 1,nxGlobal/2
01992 iDst = nxGlobal + 1 - i
01993 x1 = bufTripoleR4(i ,halo%tripoleRows)
01994 x2 = bufTripoleR4(iDst,halo%tripoleRows)
01995 xavg = 0.5_real_kind*(x1 + isign*x2)
01996 bufTripoleR4(i ,halo%tripoleRows) = xavg
01997 bufTripoleR4(iDst,halo%tripoleRows) = isign*xavg
01998 end do
01999
02000 case (field_loc_Nface)
02001
02002 ioffset = -1
02003 joffset = 1
02004
02005 case default
02006 call abort_ice( &
02007 'ice_HaloUpdate2DR4: Unknown field location')
02008 end select
02009
02010 else
02011
02012 select case (fieldLoc)
02013 case (field_loc_center)
02014
02015 ioffset = 0
02016 joffset = 0
02017
02018 case (field_loc_NEcorner)
02019
02020 ioffset = 1
02021 joffset = 1
02022
02023
02024
02025
02026 do i = 1,nxGlobal/2 - 1
02027 iDst = nxGlobal - i
02028 x1 = bufTripoleR4(i ,halo%tripoleRows)
02029 x2 = bufTripoleR4(iDst,halo%tripoleRows)
02030 xavg = 0.5_real_kind*(x1 + isign*x2)
02031 bufTripoleR4(i ,halo%tripoleRows) = xavg
02032 bufTripoleR4(iDst,halo%tripoleRows) = isign*xavg
02033 end do
02034
02035 case (field_loc_Eface)
02036
02037 ioffset = 1
02038 joffset = 0
02039
02040 case (field_loc_Nface)
02041
02042 ioffset = 0
02043 joffset = 1
02044
02045
02046
02047
02048 do i = 1,nxGlobal/2
02049 iDst = nxGlobal + 1 - i
02050 x1 = bufTripoleR4(i ,halo%tripoleRows)
02051 x2 = bufTripoleR4(iDst,halo%tripoleRows)
02052 xavg = 0.5_real_kind*(x1 + isign*x2)
02053 bufTripoleR4(i ,halo%tripoleRows) = xavg
02054 bufTripoleR4(iDst,halo%tripoleRows) = isign*xavg
02055 end do
02056
02057 case default
02058 call abort_ice( &
02059 'ice_HaloUpdate2DR4: Unknown field location')
02060 end select
02061
02062 endif
02063
02064
02065
02066
02067
02068
02069
02070 do nmsg=1,halo%numLocalCopies
02071 srcBlock = halo%srcLocalAddr(3,nmsg)
02072
02073 if (srcBlock < 0) then
02074
02075 iSrc = halo%srcLocalAddr(1,nmsg)
02076 jSrc = halo%srcLocalAddr(2,nmsg)
02077
02078 iDst = halo%dstLocalAddr(1,nmsg)
02079 jDst = halo%dstLocalAddr(2,nmsg)
02080 dstBlock = halo%dstLocalAddr(3,nmsg)
02081
02082
02083 iSrc = iSrc - ioffset
02084 jSrc = jSrc - joffset
02085 if (iSrc == 0) iSrc = nxGlobal
02086 if (iSrc > nxGlobal) iSrc = iSrc - nxGlobal
02087
02088
02089
02090
02091
02092
02093
02094 if (jSrc <= halo%tripoleRows .and. jSrc>0 .and. jDst>0) then
02095 array(iDst,jDst,dstBlock) = isign*bufTripoleR4(iSrc,jSrc)
02096 endif
02097
02098 endif
02099 end do
02100
02101 endif
02102
02103
02104
02105
02106
02107
02108
02109 call MPI_WAITALL(halo%numMsgSend, sndRequest, sndStatus, ierr)
02110
02111 deallocate(sndRequest, rcvRequest, sndStatus, rcvStatus, stat=ierr)
02112
02113 if (ierr > 0) then
02114 call abort_ice( &
02115 'ice_HaloUpdate2DR4: error deallocating req,status arrays')
02116 return
02117 endif
02118
02119
02120
02121
02122 end subroutine ice_HaloUpdate2DR4
02123
02124
02125
02126
02127
02128
02129 subroutine ice_HaloUpdate2DI4(array, halo, &
02130 fieldLoc, fieldKind, &
02131 fillValue)
02132
02133
02134
02135
02136
02137
02138
02139
02140
02141
02142
02143
02144
02145
02146 type (ice_halo), intent(in) ::
02147 halo
02148
02149
02150 integer (int_kind), intent(in) ::
02151 fieldKind,
02152 fieldLoc
02153
02154
02155 integer (int_kind), intent(in), optional ::
02156 fillValue
02157
02158
02159
02160
02161
02162
02163 integer (int_kind), dimension(:,:,:), intent(inout) ::
02164 array
02165
02166
02167
02168
02169
02170
02171
02172
02173
02174
02175
02176
02177 integer (int_kind) ::
02178 i,j,n,nmsg,
02179 ierr,
02180 nxGlobal,
02181 iSrc,jSrc,
02182 iDst,jDst,
02183 srcBlock,
02184 dstBlock,
02185 ioffset, joffset,
02186 isign
02187
02188 integer (int_kind), dimension(:), allocatable ::
02189 sndRequest,
02190 rcvRequest
02191
02192 integer (int_kind), dimension(:,:), allocatable ::
02193 sndStatus,
02194 rcvStatus
02195
02196 integer (int_kind) ::
02197 fill,
02198 x1,x2,xavg
02199
02200 integer (int_kind) :: len
02201
02202
02203
02204
02205
02206
02207
02208 if (present(fillValue)) then
02209 fill = fillValue
02210 else
02211 fill = 0_int_kind
02212 endif
02213
02214 nxGlobal = 0
02215 if (allocated(bufTripoleI4)) then
02216 nxGlobal = size(bufTripoleI4,dim=1)
02217 bufTripoleI4 = fill
02218 endif
02219
02220
02221
02222
02223
02224
02225
02226 allocate(sndRequest(halo%numMsgSend), &
02227 rcvRequest(halo%numMsgRecv), &
02228 sndStatus(MPI_STATUS_SIZE,halo%numMsgSend), &
02229 rcvStatus(MPI_STATUS_SIZE,halo%numMsgRecv), stat=ierr)
02230
02231 if (ierr > 0) then
02232 call abort_ice( &
02233 'ice_HaloUpdate2DI4: error allocating req,status arrays')
02234 return
02235 endif
02236
02237
02238
02239
02240
02241
02242
02243 do nmsg=1,halo%numMsgRecv
02244
02245 len = halo%SizeRecv(nmsg)
02246 call MPI_IRECV(bufRecvI4(1:len,nmsg), len, MPI_INTEGER, &
02247 halo%recvTask(nmsg), &
02248 mpitagHalo + halo%recvTask(nmsg), &
02249 halo%communicator, rcvRequest(nmsg), ierr)
02250 end do
02251
02252
02253
02254
02255
02256
02257
02258 do nmsg=1,halo%numMsgSend
02259
02260 do n=1,halo%sizeSend(nmsg)
02261 iSrc = halo%sendAddr(1,n,nmsg)
02262 jSrc = halo%sendAddr(2,n,nmsg)
02263 srcBlock = halo%sendAddr(3,n,nmsg)
02264
02265 bufSendI4(n,nmsg) = array(iSrc,jSrc,srcBlock)
02266 end do
02267 do n=halo%sizeSend(nmsg)+1,bufSizeSend
02268 bufSendI4(n,nmsg) = fill
02269 end do
02270
02271 len = halo%SizeSend(nmsg)
02272 call MPI_ISEND(bufSendI4(1:len,nmsg), len, MPI_INTEGER, &
02273 halo%sendTask(nmsg), &
02274 mpitagHalo + my_task, &
02275 halo%communicator, sndRequest(nmsg), ierr)
02276 end do
02277
02278
02279
02280
02281
02282
02283
02284
02285
02286
02287
02288 do nmsg=1,halo%numLocalCopies
02289 iSrc = halo%srcLocalAddr(1,nmsg)
02290 jSrc = halo%srcLocalAddr(2,nmsg)
02291 srcBlock = halo%srcLocalAddr(3,nmsg)
02292 iDst = halo%dstLocalAddr(1,nmsg)
02293 jDst = halo%dstLocalAddr(2,nmsg)
02294 dstBlock = halo%dstLocalAddr(3,nmsg)
02295
02296 if (srcBlock > 0) then
02297 if (dstBlock > 0) then
02298 array(iDst,jDst,dstBlock) = &
02299 array(iSrc,jSrc,srcBlock)
02300 else if (dstBlock < 0) then
02301 bufTripoleI4(iDst,jDst) = &
02302 array(iSrc,jSrc,srcBlock)
02303 endif
02304 else if (srcBlock == 0) then
02305 array(iDst,jDst,dstBlock) = fill
02306 endif
02307 end do
02308
02309
02310
02311
02312
02313
02314
02315
02316 call MPI_WAITALL(halo%numMsgRecv, rcvRequest, rcvStatus, ierr)
02317
02318 do nmsg=1,halo%numMsgRecv
02319 do n=1,halo%sizeRecv(nmsg)
02320 iDst = halo%recvAddr(1,n,nmsg)
02321 jDst = halo%recvAddr(2,n,nmsg)
02322 dstBlock = halo%recvAddr(3,n,nmsg)
02323
02324 if (dstBlock > 0) then
02325 array(iDst,jDst,dstBlock) = bufRecvI4(n,nmsg)
02326 else if (dstBlock < 0) then
02327 bufTripoleI4(iDst,jDst) = bufRecvI4(n,nmsg)
02328 endif
02329 end do
02330 end do
02331
02332
02333
02334
02335
02336
02337
02338
02339
02340 if (nxGlobal > 0) then
02341
02342 select case (fieldKind)
02343 case (field_type_scalar)
02344 isign = 1
02345 case (field_type_vector)
02346 isign = -1
02347 case (field_type_angle)
02348 isign = -1
02349 case default
02350 call abort_ice( &
02351 'ice_HaloUpdate2DI4: Unknown field kind')
02352 end select
02353
02354 if (halo%tripoleTFlag) then
02355
02356 select case (fieldLoc)
02357 case (field_loc_center)
02358
02359 ioffset = -1
02360 joffset = 0
02361
02362
02363
02364
02365 do i = 2,nxGlobal/2
02366 iDst = nxGlobal - i + 2
02367 x1 = bufTripoleI4(i ,halo%tripoleRows)
02368 x2 = bufTripoleI4(iDst,halo%tripoleRows)
02369 xavg = nint(0.5_dbl_kind*(x1 + isign*x2))
02370 bufTripoleI4(i ,halo%tripoleRows) = xavg
02371 bufTripoleI4(iDst,halo%tripoleRows) = isign*xavg
02372 end do
02373
02374 case (field_loc_NEcorner)
02375
02376 ioffset = 0
02377 joffset = 1
02378
02379 case (field_loc_Eface)
02380
02381 ioffset = 0
02382 joffset = 0
02383
02384
02385
02386
02387 do i = 1,nxGlobal/2
02388 iDst = nxGlobal + 1 - i
02389 x1 = bufTripoleI4(i ,halo%tripoleRows)
02390 x2 = bufTripoleI4(iDst,halo%tripoleRows)
02391 xavg = nint(0.5_dbl_kind*(x1 + isign*x2))
02392 bufTripoleI4(i ,halo%tripoleRows) = xavg
02393 bufTripoleI4(iDst,halo%tripoleRows) = isign*xavg
02394 end do
02395
02396 case (field_loc_Nface)
02397
02398 ioffset = -1
02399 joffset = 1
02400
02401 case default
02402 call abort_ice( &
02403 'ice_HaloUpdate2DI4: Unknown field location')
02404 end select
02405
02406 else
02407
02408 select case (fieldLoc)
02409 case (field_loc_center)
02410
02411 ioffset = 0
02412 joffset = 0
02413
02414 case (field_loc_NEcorner)
02415
02416 ioffset = 1
02417 joffset = 1
02418
02419
02420
02421
02422 do i = 1,nxGlobal/2 - 1
02423 iDst = nxGlobal - i
02424 x1 = bufTripoleI4(i ,halo%tripoleRows)
02425 x2 = bufTripoleI4(iDst,halo%tripoleRows)
02426 xavg = nint(0.5_dbl_kind*(x1 + isign*x2))
02427 bufTripoleI4(i ,halo%tripoleRows) = xavg
02428 bufTripoleI4(iDst,halo%tripoleRows) = isign*xavg
02429 end do
02430
02431 case (field_loc_Eface)
02432
02433 ioffset = 1
02434 joffset = 0
02435
02436 case (field_loc_Nface)
02437
02438 ioffset = 0
02439 joffset = 1
02440
02441
02442
02443
02444 do i = 1,nxGlobal/2
02445 iDst = nxGlobal + 1 - i
02446 x1 = bufTripoleI4(i ,halo%tripoleRows)
02447 x2 = bufTripoleI4(iDst,halo%tripoleRows)
02448 xavg = nint(0.5_dbl_kind*(x1 + isign*x2))
02449 bufTripoleI4(i ,halo%tripoleRows) = xavg
02450 bufTripoleI4(iDst,halo%tripoleRows) = isign*xavg
02451 end do
02452
02453 case default
02454 call abort_ice( &
02455 'ice_HaloUpdate2DI4: Unknown field location')
02456 end select
02457
02458 endif
02459
02460
02461
02462
02463
02464
02465
02466 do nmsg=1,halo%numLocalCopies
02467 srcBlock = halo%srcLocalAddr(3,nmsg)
02468
02469 if (srcBlock < 0) then
02470
02471 iSrc = halo%srcLocalAddr(1,nmsg)
02472 jSrc = halo%srcLocalAddr(2,nmsg)
02473
02474 iDst = halo%dstLocalAddr(1,nmsg)
02475 jDst = halo%dstLocalAddr(2,nmsg)
02476 dstBlock = halo%dstLocalAddr(3,nmsg)
02477
02478
02479 iSrc = iSrc - ioffset
02480 jSrc = jSrc - joffset
02481 if (iSrc == 0) iSrc = nxGlobal
02482 if (iSrc > nxGlobal) iSrc = iSrc - nxGlobal
02483
02484
02485
02486
02487
02488
02489
02490 if (jSrc <= halo%tripoleRows .and. jSrc>0 .and. jDst>0) then
02491 array(iDst,jDst,dstBlock) = isign*bufTripoleI4(iSrc,jSrc)
02492 endif
02493
02494 endif
02495 end do
02496
02497 endif
02498
02499
02500
02501
02502
02503
02504
02505 call MPI_WAITALL(halo%numMsgSend, sndRequest, sndStatus, ierr)
02506
02507 deallocate(sndRequest, rcvRequest, sndStatus, rcvStatus, stat=ierr)
02508
02509 if (ierr > 0) then
02510 call abort_ice( &
02511 'ice_HaloUpdate2DI4: error deallocating req,status arrays')
02512 return
02513 endif
02514
02515
02516
02517
02518 end subroutine ice_HaloUpdate2DI4
02519
02520
02521
02522
02523
02524
02525 subroutine ice_HaloUpdate3DR8(array, halo, &
02526 fieldLoc, fieldKind, &
02527 fillValue)
02528
02529
02530
02531
02532
02533
02534
02535
02536
02537
02538
02539
02540
02541
02542 type (ice_halo), intent(in) ::
02543 halo
02544
02545
02546 integer (int_kind), intent(in) ::
02547 fieldKind,
02548 fieldLoc
02549
02550
02551 real (dbl_kind), intent(in), optional ::
02552 fillValue
02553
02554
02555
02556
02557
02558
02559 real (dbl_kind), dimension(:,:,:,:), intent(inout) ::
02560 array
02561
02562
02563
02564
02565
02566
02567
02568
02569
02570
02571
02572
02573 integer (int_kind) ::
02574 i,j,k,n,nmsg,
02575 ierr,
02576 nxGlobal,
02577 nz,
02578 iSrc,jSrc,
02579 iDst,jDst,
02580 srcBlock,
02581 dstBlock,
02582 ioffset, joffset,
02583 isign
02584
02585 integer (int_kind), dimension(:), allocatable ::
02586 sndRequest,
02587 rcvRequest
02588
02589 integer (int_kind), dimension(:,:), allocatable ::
02590 sndStatus,
02591 rcvStatus
02592
02593 real (dbl_kind) ::
02594 fill,
02595 x1,x2,xavg
02596
02597 real (dbl_kind), dimension(:,:), allocatable ::
02598 bufSend, bufRecv
02599
02600 real (dbl_kind), dimension(:,:,:), allocatable ::
02601 bufTripole
02602
02603 integer (int_kind) :: len
02604
02605
02606
02607
02608
02609
02610
02611 if (present(fillValue)) then
02612 fill = fillValue
02613 else
02614 fill = 0.0_dbl_kind
02615 endif
02616
02617 nxGlobal = 0
02618 if (allocated(bufTripoleR8)) nxGlobal = size(bufTripoleR8,dim=1)
02619
02620
02621
02622
02623
02624
02625
02626 allocate(sndRequest(halo%numMsgSend), &
02627 rcvRequest(halo%numMsgRecv), &
02628 sndStatus(MPI_STATUS_SIZE,halo%numMsgSend), &
02629 rcvStatus(MPI_STATUS_SIZE,halo%numMsgRecv), stat=ierr)
02630
02631 if (ierr > 0) then
02632 call abort_ice( &
02633 'ice_HaloUpdate3DR8: error allocating req,status arrays')
02634 return
02635 endif
02636
02637
02638
02639
02640
02641
02642
02643 nz = size(array, dim=3)
02644
02645 allocate(bufSend(bufSizeSend*nz, halo%numMsgSend), &
02646 bufRecv(bufSizeRecv*nz, halo%numMsgRecv), &
02647 bufTripole(nxGlobal, halo%tripoleRows, nz), &
02648 stat=ierr)
02649
02650 if (ierr > 0) then
02651 call abort_ice( &
02652 'ice_HaloUpdate3DR8: error allocating buffers')
02653 return
02654 endif
02655
02656 bufTripole = fill
02657
02658
02659
02660
02661
02662
02663
02664 do nmsg=1,halo%numMsgRecv
02665
02666 len = halo%SizeRecv(nmsg)*nz
02667 call MPI_IRECV(bufRecv(1:len,nmsg), len, mpiR8, &
02668 halo%recvTask(nmsg), &
02669 mpitagHalo + halo%recvTask(nmsg), &
02670 halo%communicator, rcvRequest(nmsg), ierr)
02671 end do
02672
02673
02674
02675
02676
02677
02678
02679 do nmsg=1,halo%numMsgSend
02680
02681 i=0
02682 do n=1,halo%sizeSend(nmsg)
02683 iSrc = halo%sendAddr(1,n,nmsg)
02684 jSrc = halo%sendAddr(2,n,nmsg)
02685 srcBlock = halo%sendAddr(3,n,nmsg)
02686
02687 do k=1,nz
02688 i = i + 1
02689 bufSend(i,nmsg) = array(iSrc,jSrc,k,srcBlock)
02690 end do
02691 end do
02692 do n=i+1,bufSizeSend*nz
02693 bufSend(n,nmsg) = fill
02694 end do
02695
02696 len = halo%SizeSend(nmsg)*nz
02697 call MPI_ISEND(bufSend(1:len,nmsg), len, mpiR8, &
02698 halo%sendTask(nmsg), &
02699 mpitagHalo + my_task, &
02700 halo%communicator, sndRequest(nmsg), ierr)
02701 end do
02702
02703
02704
02705
02706
02707
02708
02709
02710
02711
02712
02713 do nmsg=1,halo%numLocalCopies
02714 iSrc = halo%srcLocalAddr(1,nmsg)
02715 jSrc = halo%srcLocalAddr(2,nmsg)
02716 srcBlock = halo%srcLocalAddr(3,nmsg)
02717 iDst = halo%dstLocalAddr(1,nmsg)
02718 jDst = halo%dstLocalAddr(2,nmsg)
02719 dstBlock = halo%dstLocalAddr(3,nmsg)
02720
02721 if (srcBlock > 0) then
02722 if (dstBlock > 0) then
02723 do k=1,nz
02724 array(iDst,jDst,k,dstBlock) = &
02725 array(iSrc,jSrc,k,srcBlock)
02726 end do
02727 else if (dstBlock < 0) then
02728 do k=1,nz
02729 bufTripole(iDst,jDst,k) = &
02730 array(iSrc,jSrc,k,srcBlock)
02731 end do
02732 endif
02733 else if (srcBlock == 0) then
02734 do k=1,nz
02735 array(iDst,jDst,k,dstBlock) = fill
02736 end do
02737 endif
02738 end do
02739
02740
02741
02742
02743
02744
02745
02746
02747 call MPI_WAITALL(halo%numMsgRecv, rcvRequest, rcvStatus, ierr)
02748
02749 do nmsg=1,halo%numMsgRecv
02750 i = 0
02751 do n=1,halo%sizeRecv(nmsg)
02752 iDst = halo%recvAddr(1,n,nmsg)
02753 jDst = halo%recvAddr(2,n,nmsg)
02754 dstBlock = halo%recvAddr(3,n,nmsg)
02755
02756 if (dstBlock > 0) then
02757 do k=1,nz
02758 i = i + 1
02759 array(iDst,jDst,k,dstBlock) = bufRecv(i,nmsg)
02760 end do
02761 else if (dstBlock < 0) then
02762 do k=1,nz
02763 i = i + 1
02764 bufTripole(iDst,jDst,k) = bufRecv(i,nmsg)
02765 end do
02766 endif
02767 end do
02768 end do
02769
02770
02771
02772
02773
02774
02775
02776
02777
02778 if (nxGlobal > 0) then
02779
02780 select case (fieldKind)
02781 case (field_type_scalar)
02782 isign = 1
02783 case (field_type_vector)
02784 isign = -1
02785 case (field_type_angle)
02786 isign = -1
02787 case default
02788 call abort_ice( &
02789 'ice_HaloUpdate3DR8: Unknown field kind')
02790 end select
02791
02792 if (halo%tripoleTFlag) then
02793
02794 select case (fieldLoc)
02795 case (field_loc_center)
02796
02797 ioffset = -1
02798 joffset = 0
02799
02800
02801
02802
02803 do k=1,nz
02804 do i = 2,nxGlobal/2
02805 iDst = nxGlobal - i + 2
02806 x1 = bufTripole(i ,halo%tripoleRows,k)
02807 x2 = bufTripole(iDst,halo%tripoleRows,k)
02808 xavg = 0.5_dbl_kind*(x1 + isign*x2)
02809 bufTripole(i ,halo%tripoleRows,k) = xavg
02810 bufTripole(iDst,halo%tripoleRows,k) = isign*xavg
02811 end do
02812 end do
02813
02814 case (field_loc_NEcorner)
02815
02816 ioffset = 0
02817 joffset = 1
02818
02819 case (field_loc_Eface)
02820
02821 ioffset = 0
02822 joffset = 0
02823
02824
02825
02826
02827 do k=1,nz
02828 do i = 1,nxGlobal/2
02829 iDst = nxGlobal + 1 - i
02830 x1 = bufTripole(i ,halo%tripoleRows,k)
02831 x2 = bufTripole(iDst,halo%tripoleRows,k)
02832 xavg = 0.5_dbl_kind*(x1 + isign*x2)
02833 bufTripole(i ,halo%tripoleRows,k) = xavg
02834 bufTripole(iDst,halo%tripoleRows,k) = isign*xavg
02835 end do
02836 end do
02837
02838 case (field_loc_Nface)
02839
02840 ioffset = -1
02841 joffset = 1
02842
02843 case default
02844 call abort_ice( &
02845 'ice_HaloUpdate3DR8: Unknown field location')
02846 end select
02847
02848 else
02849
02850 select case (fieldLoc)
02851 case (field_loc_center)
02852
02853 ioffset = 0
02854 joffset = 0
02855
02856 case (field_loc_NEcorner)
02857
02858 ioffset = 1
02859 joffset = 1
02860
02861
02862
02863
02864 do k=1,nz
02865 do i = 1,nxGlobal/2 - 1
02866 iDst = nxGlobal - i
02867 x1 = bufTripole(i ,halo%tripoleRows,k)
02868 x2 = bufTripole(iDst,halo%tripoleRows,k)
02869 xavg = 0.5_dbl_kind*(x1 + isign*x2)
02870 bufTripole(i ,halo%tripoleRows,k) = xavg
02871 bufTripole(iDst,halo%tripoleRows,k) = isign*xavg
02872 end do
02873 end do
02874
02875 case (field_loc_Eface)
02876
02877 ioffset = 1
02878 joffset = 0
02879
02880 case (field_loc_Nface)
02881
02882 ioffset = 0
02883 joffset = 1
02884
02885
02886
02887
02888 do k=1,nz
02889 do i = 1,nxGlobal/2
02890 iDst = nxGlobal + 1 - i
02891 x1 = bufTripole(i ,halo%tripoleRows,k)
02892 x2 = bufTripole(iDst,halo%tripoleRows,k)
02893 xavg = 0.5_dbl_kind*(x1 + isign*x2)
02894 bufTripole(i ,halo%tripoleRows,k) = xavg
02895 bufTripole(iDst,halo%tripoleRows,k) = isign*xavg
02896 end do
02897 end do
02898
02899 case default
02900 call abort_ice( &
02901 'ice_HaloUpdate3DR8: Unknown field location')
02902 end select
02903
02904 endif
02905
02906
02907
02908
02909
02910
02911
02912 do nmsg=1,halo%numLocalCopies
02913 srcBlock = halo%srcLocalAddr(3,nmsg)
02914
02915 if (srcBlock < 0) then
02916
02917 iSrc = halo%srcLocalAddr(1,nmsg)
02918 jSrc = halo%srcLocalAddr(2,nmsg)
02919
02920 iDst = halo%dstLocalAddr(1,nmsg)
02921 jDst = halo%dstLocalAddr(2,nmsg)
02922 dstBlock = halo%dstLocalAddr(3,nmsg)
02923
02924
02925 iSrc = iSrc - ioffset
02926 jSrc = jSrc - joffset
02927 if (iSrc == 0) iSrc = nxGlobal
02928 if (iSrc > nxGlobal) iSrc = iSrc - nxGlobal
02929
02930
02931
02932
02933
02934
02935
02936 if (jSrc <= halo%tripoleRows .and. jSrc>0 .and. jDst>0) then
02937 do k=1,nz
02938 array(iDst,jDst,k,dstBlock) = isign* &
02939 bufTripole(iSrc,jSrc,k)
02940 end do
02941 endif
02942
02943 endif
02944 end do
02945
02946 endif
02947
02948
02949
02950
02951
02952
02953
02954 call MPI_WAITALL(halo%numMsgSend, sndRequest, sndStatus, ierr)
02955
02956 deallocate(sndRequest, rcvRequest, sndStatus, rcvStatus, stat=ierr)
02957
02958 if (ierr > 0) then
02959 call abort_ice( &
02960 'ice_HaloUpdate3DR8: error deallocating req,status arrays')
02961 return
02962 endif
02963
02964 deallocate(bufSend, bufRecv, bufTripole, stat=ierr)
02965
02966 if (ierr > 0) then
02967 call abort_ice( &
02968 'ice_HaloUpdate3DR8: error deallocating 3d buffers')
02969 return
02970 endif
02971
02972
02973
02974
02975 end subroutine ice_HaloUpdate3DR8
02976
02977
02978
02979
02980
02981
02982 subroutine ice_HaloUpdate3DR4(array, halo, &
02983 fieldLoc, fieldKind, &
02984 fillValue)
02985
02986
02987
02988
02989
02990
02991
02992
02993
02994
02995
02996
02997
02998
02999 type (ice_halo), intent(in) ::
03000 halo
03001
03002
03003 integer (int_kind), intent(in) ::
03004 fieldKind,
03005 fieldLoc
03006
03007
03008 real (real_kind), intent(in), optional ::
03009 fillValue
03010
03011
03012
03013
03014
03015
03016 real (real_kind), dimension(:,:,:,:), intent(inout) ::
03017 array
03018
03019
03020
03021
03022
03023
03024
03025
03026
03027
03028
03029
03030 integer (int_kind) ::
03031 i,j,k,n,nmsg,
03032 ierr,
03033 nxGlobal,
03034 nz,
03035 iSrc,jSrc,
03036 iDst,jDst,
03037 srcBlock,
03038 dstBlock,
03039 ioffset, joffset,
03040 isign
03041
03042 integer (int_kind), dimension(:), allocatable ::
03043 sndRequest,
03044 rcvRequest
03045
03046 integer (int_kind), dimension(:,:), allocatable ::
03047 sndStatus,
03048 rcvStatus
03049
03050 real (real_kind) ::
03051 fill,
03052 x1,x2,xavg
03053
03054 real (real_kind), dimension(:,:), allocatable ::
03055 bufSend, bufRecv
03056
03057 real (real_kind), dimension(:,:,:), allocatable ::
03058 bufTripole
03059
03060 integer (int_kind) :: len
03061
03062
03063
03064
03065
03066
03067
03068 if (present(fillValue)) then
03069 fill = fillValue
03070 else
03071 fill = 0.0_real_kind
03072 endif
03073
03074 nxGlobal = 0
03075 if (allocated(bufTripoleR4)) nxGlobal = size(bufTripoleR4,dim=1)
03076
03077
03078
03079
03080
03081
03082
03083 allocate(sndRequest(halo%numMsgSend), &
03084 rcvRequest(halo%numMsgRecv), &
03085 sndStatus(MPI_STATUS_SIZE,halo%numMsgSend), &
03086 rcvStatus(MPI_STATUS_SIZE,halo%numMsgRecv), stat=ierr)
03087
03088 if (ierr > 0) then
03089 call abort_ice( &
03090 'ice_HaloUpdate3DR4: error allocating req,status arrays')
03091 return
03092 endif
03093
03094
03095
03096
03097
03098
03099
03100 nz = size(array, dim=3)
03101
03102 allocate(bufSend(bufSizeSend*nz, halo%numMsgSend), &
03103 bufRecv(bufSizeRecv*nz, halo%numMsgRecv), &
03104 bufTripole(nxGlobal, halo%tripoleRows, nz), &
03105 stat=ierr)
03106
03107 if (ierr > 0) then
03108 call abort_ice( &
03109 'ice_HaloUpdate3DR4: error allocating buffers')
03110 return
03111 endif
03112
03113 bufTripole = fill
03114
03115
03116
03117
03118
03119
03120
03121 do nmsg=1,halo%numMsgRecv
03122
03123 len = halo%SizeRecv(nmsg)*nz
03124 call MPI_IRECV(bufRecv(1:len,nmsg), len, mpiR4, &
03125 halo%recvTask(nmsg), &
03126 mpitagHalo + halo%recvTask(nmsg), &
03127 halo%communicator, rcvRequest(nmsg), ierr)
03128 end do
03129
03130
03131
03132
03133
03134
03135
03136 do nmsg=1,halo%numMsgSend
03137
03138 i=0
03139 do n=1,halo%sizeSend(nmsg)
03140 iSrc = halo%sendAddr(1,n,nmsg)
03141 jSrc = halo%sendAddr(2,n,nmsg)
03142 srcBlock = halo%sendAddr(3,n,nmsg)
03143
03144 do k=1,nz
03145 i = i + 1
03146 bufSend(i,nmsg) = array(iSrc,jSrc,k,srcBlock)
03147 end do
03148 end do
03149 do n=i+1,bufSizeSend*nz
03150 bufSend(n,nmsg) = fill
03151 end do
03152
03153 len = halo%SizeSend(nmsg)*nz
03154 call MPI_ISEND(bufSend(1:len,nmsg), len, mpiR4, &
03155 halo%sendTask(nmsg), &
03156 mpitagHalo + my_task, &
03157 halo%communicator, sndRequest(nmsg), ierr)
03158 end do
03159
03160
03161
03162
03163
03164
03165
03166
03167
03168
03169
03170 do nmsg=1,halo%numLocalCopies
03171 iSrc = halo%srcLocalAddr(1,nmsg)
03172 jSrc = halo%srcLocalAddr(2,nmsg)
03173 srcBlock = halo%srcLocalAddr(3,nmsg)
03174 iDst = halo%dstLocalAddr(1,nmsg)
03175 jDst = halo%dstLocalAddr(2,nmsg)
03176 dstBlock = halo%dstLocalAddr(3,nmsg)
03177
03178 if (srcBlock > 0) then
03179 if (dstBlock > 0) then
03180 do k=1,nz
03181 array(iDst,jDst,k,dstBlock) = &
03182 array(iSrc,jSrc,k,srcBlock)
03183 end do
03184 else if (dstBlock < 0) then
03185 do k=1,nz
03186 bufTripole(iDst,jDst,k) = &
03187 array(iSrc,jSrc,k,srcBlock)
03188 end do
03189 endif
03190 else if (srcBlock == 0) then
03191 do k=1,nz
03192 array(iDst,jDst,k,dstBlock) = fill
03193 end do
03194 endif
03195 end do
03196
03197
03198
03199
03200
03201
03202
03203
03204 call MPI_WAITALL(halo%numMsgRecv, rcvRequest, rcvStatus, ierr)
03205
03206 do nmsg=1,halo%numMsgRecv
03207 i = 0
03208 do n=1,halo%sizeRecv(nmsg)
03209 iDst = halo%recvAddr(1,n,nmsg)
03210 jDst = halo%recvAddr(2,n,nmsg)
03211 dstBlock = halo%recvAddr(3,n,nmsg)
03212
03213 if (dstBlock > 0) then
03214 do k=1,nz
03215 i = i + 1
03216 array(iDst,jDst,k,dstBlock) = bufRecv(i,nmsg)
03217 end do
03218 else if (dstBlock < 0) then
03219 do k=1,nz
03220 i = i + 1
03221 bufTripole(iDst,jDst,k) = bufRecv(i,nmsg)
03222 end do
03223 endif
03224 end do
03225 end do
03226
03227
03228
03229
03230
03231
03232
03233
03234
03235 if (nxGlobal > 0) then
03236
03237 select case (fieldKind)
03238 case (field_type_scalar)
03239 isign = 1
03240 case (field_type_vector)
03241 isign = -1
03242 case (field_type_angle)
03243 isign = -1
03244 case default
03245 call abort_ice( &
03246 'ice_HaloUpdate3DR4: Unknown field kind')
03247 end select
03248
03249 if (halo%tripoleTFlag) then
03250
03251 select case (fieldLoc)
03252 case (field_loc_center)
03253
03254 ioffset = -1
03255 joffset = 0
03256
03257
03258
03259
03260 do k=1,nz
03261 do i = 2,nxGlobal/2
03262 iDst = nxGlobal - i + 2
03263 x1 = bufTripole(i ,halo%tripoleRows,k)
03264 x2 = bufTripole(iDst,halo%tripoleRows,k)
03265 xavg = 0.5_real_kind*(x1 + isign*x2)
03266 bufTripole(i ,halo%tripoleRows,k) = xavg
03267 bufTripole(iDst,halo%tripoleRows,k) = isign*xavg
03268 end do
03269 end do
03270
03271 case (field_loc_NEcorner)
03272
03273 ioffset = 0
03274 joffset = 1
03275
03276 case (field_loc_Eface)
03277
03278 ioffset = 0
03279 joffset = 0
03280
03281
03282
03283
03284 do k=1,nz
03285 do i = 1,nxGlobal/2
03286 iDst = nxGlobal + 1 - i
03287 x1 = bufTripole(i ,halo%tripoleRows,k)
03288 x2 = bufTripole(iDst,halo%tripoleRows,k)
03289 xavg = 0.5_real_kind*(x1 + isign*x2)
03290 bufTripole(i ,halo%tripoleRows,k) = xavg
03291 bufTripole(iDst,halo%tripoleRows,k) = isign*xavg
03292 end do
03293 end do
03294
03295 case (field_loc_Nface)
03296
03297 ioffset = -1
03298 joffset = 1
03299
03300 case default
03301 call abort_ice( &
03302 'ice_HaloUpdate3DR4: Unknown field location')
03303 end select
03304
03305 else
03306
03307 select case (fieldLoc)
03308 case (field_loc_center)
03309
03310 ioffset = 0
03311 joffset = 0
03312
03313 case (field_loc_NEcorner)
03314
03315 ioffset = 1
03316 joffset = 1
03317
03318
03319
03320
03321 do k=1,nz
03322 do i = 1,nxGlobal/2 - 1
03323 iDst = nxGlobal - i
03324 x1 = bufTripole(i ,halo%tripoleRows,k)
03325 x2 = bufTripole(iDst,halo%tripoleRows,k)
03326 xavg = 0.5_real_kind*(x1 + isign*x2)
03327 bufTripole(i ,halo%tripoleRows,k) = xavg
03328 bufTripole(iDst,halo%tripoleRows,k) = isign*xavg
03329 end do
03330 end do
03331
03332 case (field_loc_Eface)
03333
03334 ioffset = 1
03335 joffset = 0
03336
03337 case (field_loc_Nface)
03338
03339 ioffset = 0
03340 joffset = 1
03341
03342
03343
03344
03345 do k=1,nz
03346 do i = 1,nxGlobal/2
03347 iDst = nxGlobal + 1 - i
03348 x1 = bufTripole(i ,halo%tripoleRows,k)
03349 x2 = bufTripole(iDst,halo%tripoleRows,k)
03350 xavg = 0.5_real_kind*(x1 + isign*x2)
03351 bufTripole(i ,halo%tripoleRows,k) = xavg
03352 bufTripole(iDst,halo%tripoleRows,k) = isign*xavg
03353 end do
03354 end do
03355
03356 case default
03357 call abort_ice( &
03358 'ice_HaloUpdate3DR4: Unknown field location')
03359 end select
03360
03361 endif
03362
03363
03364
03365
03366
03367
03368
03369 do nmsg=1,halo%numLocalCopies
03370 srcBlock = halo%srcLocalAddr(3,nmsg)
03371
03372 if (srcBlock < 0) then
03373
03374 iSrc = halo%srcLocalAddr(1,nmsg)
03375 jSrc = halo%srcLocalAddr(2,nmsg)
03376
03377 iDst = halo%dstLocalAddr(1,nmsg)
03378 jDst = halo%dstLocalAddr(2,nmsg)
03379 dstBlock = halo%dstLocalAddr(3,nmsg)
03380
03381
03382 iSrc = iSrc - ioffset
03383 jSrc = jSrc - joffset
03384 if (iSrc == 0) iSrc = nxGlobal
03385 if (iSrc > nxGlobal) iSrc = iSrc - nxGlobal
03386
03387
03388
03389
03390
03391
03392
03393 if (jSrc <= halo%tripoleRows .and. jSrc>0 .and. jDst>0) then
03394 do k=1,nz
03395 array(iDst,jDst,k,dstBlock) = isign* &
03396 bufTripole(iSrc,jSrc,k)
03397 end do
03398 endif
03399
03400 endif
03401 end do
03402
03403 endif
03404
03405
03406
03407
03408
03409
03410
03411 call MPI_WAITALL(halo%numMsgSend, sndRequest, sndStatus, ierr)
03412
03413 deallocate(sndRequest, rcvRequest, sndStatus, rcvStatus, stat=ierr)
03414
03415 if (ierr > 0) then
03416 call abort_ice( &
03417 'ice_HaloUpdate3DR4: error deallocating req,status arrays')
03418 return
03419 endif
03420
03421 deallocate(bufSend, bufRecv, bufTripole, stat=ierr)
03422
03423 if (ierr > 0) then
03424 call abort_ice( &
03425 'ice_HaloUpdate3DR4: error deallocating 3d buffers')
03426 return
03427 endif
03428
03429
03430
03431
03432 end subroutine ice_HaloUpdate3DR4
03433
03434
03435
03436
03437
03438
03439 subroutine ice_HaloUpdate3DI4(array, halo, &
03440 fieldLoc, fieldKind, &
03441 fillValue)
03442
03443
03444
03445
03446
03447
03448
03449
03450
03451
03452
03453
03454
03455
03456 type (ice_halo), intent(in) ::
03457 halo
03458
03459
03460 integer (int_kind), intent(in) ::
03461 fieldKind,
03462 fieldLoc
03463
03464
03465 integer (int_kind), intent(in), optional ::
03466 fillValue
03467
03468
03469
03470
03471
03472
03473 integer (int_kind), dimension(:,:,:,:), intent(inout) ::
03474 array
03475
03476
03477
03478
03479
03480
03481
03482
03483
03484
03485
03486
03487 integer (int_kind) ::
03488 i,j,k,n,nmsg,
03489 ierr,
03490 nxGlobal,
03491 nz,
03492 iSrc,jSrc,
03493 iDst,jDst,
03494 srcBlock,
03495 dstBlock,
03496 ioffset, joffset,
03497 isign
03498
03499 integer (int_kind), dimension(:), allocatable ::
03500 sndRequest,
03501 rcvRequest
03502
03503 integer (int_kind), dimension(:,:), allocatable ::
03504 sndStatus,
03505 rcvStatus
03506
03507 integer (int_kind) ::
03508 fill,
03509 x1,x2,xavg
03510
03511 integer (int_kind), dimension(:,:), allocatable ::
03512 bufSend, bufRecv
03513
03514 integer (int_kind), dimension(:,:,:), allocatable ::
03515 bufTripole
03516
03517 integer (int_kind) :: len
03518
03519
03520
03521
03522
03523
03524
03525 if (present(fillValue)) then
03526 fill = fillValue
03527 else
03528 fill = 0_int_kind
03529 endif
03530
03531 nxGlobal = 0
03532 if (allocated(bufTripoleI4)) nxGlobal = size(bufTripoleI4,dim=1)
03533
03534
03535
03536
03537
03538
03539
03540 allocate(sndRequest(halo%numMsgSend), &
03541 rcvRequest(halo%numMsgRecv), &
03542 sndStatus(MPI_STATUS_SIZE,halo%numMsgSend), &
03543 rcvStatus(MPI_STATUS_SIZE,halo%numMsgRecv), stat=ierr)
03544
03545 if (ierr > 0) then
03546 call abort_ice( &
03547 'ice_HaloUpdate3DI4: error allocating req,status arrays')
03548 return
03549 endif
03550
03551
03552
03553
03554
03555
03556
03557 nz = size(array, dim=3)
03558
03559 allocate(bufSend(bufSizeSend*nz, halo%numMsgSend), &
03560 bufRecv(bufSizeRecv*nz, halo%numMsgRecv), &
03561 bufTripole(nxGlobal, halo%tripoleRows, nz), &
03562 stat=ierr)
03563
03564 if (ierr > 0) then
03565 call abort_ice( &
03566 'ice_HaloUpdate3DI4: error allocating buffers')
03567 return
03568 endif
03569
03570 bufTripole = fill
03571
03572
03573
03574
03575
03576
03577
03578 do nmsg=1,halo%numMsgRecv
03579
03580 len = halo%SizeRecv(nmsg)*nz
03581 call MPI_IRECV(bufRecv(1:len,nmsg), len, MPI_INTEGER, &
03582 halo%recvTask(nmsg), &
03583 mpitagHalo + halo%recvTask(nmsg), &
03584 halo%communicator, rcvRequest(nmsg), ierr)
03585 end do
03586
03587
03588
03589
03590
03591
03592
03593 do nmsg=1,halo%numMsgSend
03594
03595 i=0
03596 do n=1,halo%sizeSend(nmsg)
03597 iSrc = halo%sendAddr(1,n,nmsg)
03598 jSrc = halo%sendAddr(2,n,nmsg)
03599 srcBlock = halo%sendAddr(3,n,nmsg)
03600
03601 do k=1,nz
03602 i = i + 1
03603 bufSend(i,nmsg) = array(iSrc,jSrc,k,srcBlock)
03604 end do
03605 end do
03606 do n=i+1,bufSizeSend*nz
03607 bufSend(n,nmsg) = fill
03608 end do
03609
03610 len = halo%SizeSend(nmsg)*nz
03611 call MPI_ISEND(bufSend(1:len,nmsg), len, MPI_INTEGER, &
03612 halo%sendTask(nmsg), &
03613 mpitagHalo + my_task, &
03614 halo%communicator, sndRequest(nmsg), ierr)
03615 end do
03616
03617
03618
03619
03620
03621
03622
03623
03624
03625
03626
03627 do nmsg=1,halo%numLocalCopies
03628 iSrc = halo%srcLocalAddr(1,nmsg)
03629 jSrc = halo%srcLocalAddr(2,nmsg)
03630 srcBlock = halo%srcLocalAddr(3,nmsg)
03631 iDst = halo%dstLocalAddr(1,nmsg)
03632 jDst = halo%dstLocalAddr(2,nmsg)
03633 dstBlock = halo%dstLocalAddr(3,nmsg)
03634
03635 if (srcBlock > 0) then
03636 if (dstBlock > 0) then
03637 do k=1,nz
03638 array(iDst,jDst,k,dstBlock) = &
03639 array(iSrc,jSrc,k,srcBlock)
03640 end do
03641 else if (dstBlock < 0) then
03642 do k=1,nz
03643 bufTripole(iDst,jDst,k) = &
03644 array(iSrc,jSrc,k,srcBlock)
03645 end do
03646 endif
03647 else if (srcBlock == 0) then
03648 do k=1,nz
03649 array(iDst,jDst,k,dstBlock) = fill
03650 end do
03651 endif
03652 end do
03653
03654
03655
03656
03657
03658
03659
03660
03661 call MPI_WAITALL(halo%numMsgRecv, rcvRequest, rcvStatus, ierr)
03662
03663 do nmsg=1,halo%numMsgRecv
03664 i = 0
03665 do n=1,halo%sizeRecv(nmsg)
03666 iDst = halo%recvAddr(1,n,nmsg)
03667 jDst = halo%recvAddr(2,n,nmsg)
03668 dstBlock = halo%recvAddr(3,n,nmsg)
03669
03670 if (dstBlock > 0) then
03671 do k=1,nz
03672 i = i + 1
03673 array(iDst,jDst,k,dstBlock) = bufRecv(i,nmsg)
03674 end do
03675 else if (dstBlock < 0) then
03676 do k=1,nz
03677 i = i + 1
03678 bufTripole(iDst,jDst,k) = bufRecv(i,nmsg)
03679 end do
03680 endif
03681 end do
03682 end do
03683
03684
03685
03686
03687
03688
03689
03690
03691
03692 if (nxGlobal > 0) then
03693
03694 select case (fieldKind)
03695 case (field_type_scalar)
03696 isign = 1
03697 case (field_type_vector)
03698 isign = -1
03699 case (field_type_angle)
03700 isign = -1
03701 case default
03702 call abort_ice( &
03703 'ice_HaloUpdate3DI4: Unknown field kind')
03704 end select
03705
03706 if (halo%tripoleTFlag) then
03707
03708 select case (fieldLoc)
03709 case (field_loc_center)
03710
03711 ioffset = -1
03712 joffset = 0
03713
03714
03715
03716
03717 do k=1,nz
03718 do i = 2,nxGlobal/2
03719 iDst = nxGlobal - i + 2
03720 x1 = bufTripole(i ,halo%tripoleRows,k)
03721 x2 = bufTripole(iDst,halo%tripoleRows,k)
03722 xavg = nint(0.5_dbl_kind*(x1 + isign*x2))
03723 bufTripole(i ,halo%tripoleRows,k) = xavg
03724 bufTripole(iDst,halo%tripoleRows,k) = isign*xavg
03725 end do
03726 end do
03727
03728 case (field_loc_NEcorner)
03729
03730 ioffset = 0
03731 joffset = 1
03732
03733 case (field_loc_Eface)
03734
03735 ioffset = 0
03736 joffset = 0
03737
03738
03739
03740
03741 do k=1,nz
03742 do i = 1,nxGlobal/2
03743 iDst = nxGlobal + 1 - i
03744 x1 = bufTripole(i ,halo%tripoleRows,k)
03745 x2 = bufTripole(iDst,halo%tripoleRows,k)
03746 xavg = nint(0.5_dbl_kind*(x1 + isign*x2))
03747 bufTripole(i ,halo%tripoleRows,k) = xavg
03748 bufTripole(iDst,halo%tripoleRows,k) = isign*xavg
03749 end do
03750 end do
03751
03752 case (field_loc_Nface)
03753
03754 ioffset = -1
03755 joffset = 1
03756
03757 case default
03758 call abort_ice( &
03759 'ice_HaloUpdate3DI4: Unknown field location')
03760 end select
03761
03762 else
03763
03764 select case (fieldLoc)
03765 case (field_loc_center)
03766
03767 ioffset = 0
03768 joffset = 0
03769
03770 case (field_loc_NEcorner)
03771
03772 ioffset = 1
03773 joffset = 1
03774
03775
03776
03777
03778 do k=1,nz
03779 do i = 1,nxGlobal/2 - 1
03780 iDst = nxGlobal - i
03781 x1 = bufTripole(i ,halo%tripoleRows,k)
03782 x2 = bufTripole(iDst,halo%tripoleRows,k)
03783 xavg = nint(0.5_dbl_kind*(x1 + isign*x2))
03784 bufTripole(i ,halo%tripoleRows,k) = xavg
03785 bufTripole(iDst,halo%tripoleRows,k) = isign*xavg
03786 end do
03787 end do
03788
03789 case (field_loc_Eface)
03790
03791 ioffset = 1
03792 joffset = 0
03793
03794 case (field_loc_Nface)
03795
03796 ioffset = 0
03797 joffset = 1
03798
03799
03800
03801
03802 do k=1,nz
03803 do i = 1,nxGlobal/2
03804 iDst = nxGlobal + 1 - i
03805 x1 = bufTripole(i ,halo%tripoleRows,k)
03806 x2 = bufTripole(iDst,halo%tripoleRows,k)
03807 xavg = nint(0.5_dbl_kind*(x1 + isign*x2))
03808 bufTripole(i ,halo%tripoleRows,k) = xavg
03809 bufTripole(iDst,halo%tripoleRows,k) = isign*xavg
03810 end do
03811 end do
03812
03813 case default
03814 call abort_ice( &
03815 'ice_HaloUpdate3DI4: Unknown field location')
03816 end select
03817
03818 endif
03819
03820
03821
03822
03823
03824
03825
03826 do nmsg=1,halo%numLocalCopies
03827 srcBlock = halo%srcLocalAddr(3,nmsg)
03828
03829 if (srcBlock < 0) then
03830
03831 iSrc = halo%srcLocalAddr(1,nmsg)
03832 jSrc = halo%srcLocalAddr(2,nmsg)
03833
03834 iDst = halo%dstLocalAddr(1,nmsg)
03835 jDst = halo%dstLocalAddr(2,nmsg)
03836 dstBlock = halo%dstLocalAddr(3,nmsg)
03837
03838
03839 iSrc = iSrc - ioffset
03840 jSrc = jSrc - joffset
03841 if (iSrc == 0) iSrc = nxGlobal
03842 if (iSrc > nxGlobal) iSrc = iSrc - nxGlobal
03843
03844
03845
03846
03847
03848
03849
03850 if (jSrc <= halo%tripoleRows .and. jSrc>0 .and. jDst>0) then
03851 do k=1,nz
03852 array(iDst,jDst,k,dstBlock) = isign* &
03853 bufTripole(iSrc,jSrc,k)
03854 end do
03855 endif
03856
03857 endif
03858 end do
03859
03860 endif
03861
03862
03863
03864
03865
03866
03867
03868 call MPI_WAITALL(halo%numMsgSend, sndRequest, sndStatus, ierr)
03869
03870 deallocate(sndRequest, rcvRequest, sndStatus, rcvStatus, stat=ierr)
03871
03872 if (ierr > 0) then
03873 call abort_ice( &
03874 'ice_HaloUpdate3DI4: error deallocating req,status arrays')
03875 return
03876 endif
03877
03878 deallocate(bufSend, bufRecv, bufTripole, stat=ierr)
03879
03880 if (ierr > 0) then
03881 call abort_ice( &
03882 'ice_HaloUpdate3DI4: error deallocating 3d buffers')
03883 return
03884 endif
03885
03886
03887
03888
03889 end subroutine ice_HaloUpdate3DI4
03890
03891
03892
03893
03894
03895
03896 subroutine ice_HaloUpdate4DR8(array, halo, &
03897 fieldLoc, fieldKind, &
03898 fillValue)
03899
03900
03901
03902
03903
03904
03905
03906
03907
03908
03909
03910
03911
03912
03913 type (ice_halo), intent(in) ::
03914 halo
03915
03916
03917 integer (int_kind), intent(in) ::
03918 fieldKind,
03919 fieldLoc
03920
03921
03922 real (dbl_kind), intent(in), optional ::
03923 fillValue
03924
03925
03926
03927
03928
03929
03930 real (dbl_kind), dimension(:,:,:,:,:), intent(inout) ::
03931 array
03932
03933
03934
03935
03936
03937
03938
03939
03940
03941
03942
03943
03944 integer (int_kind) ::
03945 i,j,k,l,n,nmsg,
03946 ierr,
03947 nxGlobal,
03948 nz, nt,
03949 iSrc,jSrc,
03950 iDst,jDst,
03951 srcBlock,
03952 dstBlock,
03953 ioffset, joffset,
03954 isign
03955
03956 integer (int_kind), dimension(:), allocatable ::
03957 sndRequest,
03958 rcvRequest
03959
03960 integer (int_kind), dimension(:,:), allocatable ::
03961 sndStatus,
03962 rcvStatus
03963
03964 real (dbl_kind) ::
03965 fill,
03966 x1,x2,xavg
03967
03968 real (dbl_kind), dimension(:,:), allocatable ::
03969 bufSend, bufRecv
03970
03971 real (dbl_kind), dimension(:,:,:,:), allocatable ::
03972 bufTripole
03973
03974 integer (int_kind) :: len
03975
03976
03977
03978
03979
03980
03981
03982 if (present(fillValue)) then
03983 fill = fillValue
03984 else
03985 fill = 0.0_dbl_kind
03986 endif
03987
03988 nxGlobal = 0
03989 if (allocated(bufTripoleR8)) nxGlobal = size(bufTripoleR8,dim=1)
03990
03991
03992
03993
03994
03995
03996
03997 allocate(sndRequest(halo%numMsgSend), &
03998 rcvRequest(halo%numMsgRecv), &
03999 sndStatus(MPI_STATUS_SIZE,halo%numMsgSend), &
04000 rcvStatus(MPI_STATUS_SIZE,halo%numMsgRecv), stat=ierr)
04001
04002 if (ierr > 0) then
04003 call abort_ice( &
04004 'ice_HaloUpdate4DR8: error allocating req,status arrays')
04005 return
04006 endif
04007
04008
04009
04010
04011
04012
04013
04014 nz = size(array, dim=3)
04015 nt = size(array, dim=4)
04016
04017 allocate(bufSend(bufSizeSend*nz*nt, halo%numMsgSend), &
04018 bufRecv(bufSizeRecv*nz*nt, halo%numMsgRecv), &
04019 bufTripole(nxGlobal, halo%tripoleRows, nz, nt), &
04020 stat=ierr)
04021
04022 if (ierr > 0) then
04023 call abort_ice( &
04024 'ice_HaloUpdate4DR8: error allocating buffers')
04025 return
04026 endif
04027
04028 bufTripole = fill
04029
04030
04031
04032
04033
04034
04035
04036 do nmsg=1,halo%numMsgRecv
04037
04038 len = halo%SizeRecv(nmsg)*nz*nt
04039 call MPI_IRECV(bufRecv(1:len,nmsg), len, mpiR8, &
04040 halo%recvTask(nmsg), &
04041 mpitagHalo + halo%recvTask(nmsg), &
04042 halo%communicator, rcvRequest(nmsg), ierr)
04043 end do
04044
04045
04046
04047
04048
04049
04050
04051 do nmsg=1,halo%numMsgSend
04052
04053 i=0
04054 do n=1,halo%sizeSend(nmsg)
04055 iSrc = halo%sendAddr(1,n,nmsg)
04056 jSrc = halo%sendAddr(2,n,nmsg)
04057 srcBlock = halo%sendAddr(3,n,nmsg)
04058
04059 do l=1,nt
04060 do k=1,nz
04061 i = i + 1
04062 bufSend(i,nmsg) = array(iSrc,jSrc,k,l,srcBlock)
04063 end do
04064 end do
04065 end do
04066
04067 do n=i+1,bufSizeSend*nz*nt
04068 bufSend(n,nmsg) = fill
04069 end do
04070
04071 len = halo%SizeSend(nmsg)*nz*nt
04072 call MPI_ISEND(bufSend(1:len,nmsg), len, mpiR8, &
04073 halo%sendTask(nmsg), &
04074 mpitagHalo + my_task, &
04075 halo%communicator, sndRequest(nmsg), ierr)
04076 end do
04077
04078
04079
04080
04081
04082
04083
04084
04085
04086
04087
04088 do nmsg=1,halo%numLocalCopies
04089 iSrc = halo%srcLocalAddr(1,nmsg)
04090 jSrc = halo%srcLocalAddr(2,nmsg)
04091 srcBlock = halo%srcLocalAddr(3,nmsg)
04092 iDst = halo%dstLocalAddr(1,nmsg)
04093 jDst = halo%dstLocalAddr(2,nmsg)
04094 dstBlock = halo%dstLocalAddr(3,nmsg)
04095
04096 if (srcBlock > 0) then
04097 if (dstBlock > 0) then
04098 do l=1,nt
04099 do k=1,nz
04100 array(iDst,jDst,k,l,dstBlock) = &
04101 array(iSrc,jSrc,k,l,srcBlock)
04102 end do
04103 end do
04104 else if (dstBlock < 0) then
04105 do l=1,nt
04106 do k=1,nz
04107 bufTripole(iDst,jDst,k,l) = &
04108 array(iSrc,jSrc,k,l,srcBlock)
04109 end do
04110 end do
04111 endif
04112 else if (srcBlock == 0) then
04113 do l=1,nt
04114 do k=1,nz
04115 array(iDst,jDst,k,l,dstBlock) = fill
04116 end do
04117 end do
04118 endif
04119 end do
04120
04121
04122
04123
04124
04125
04126
04127
04128 call MPI_WAITALL(halo%numMsgRecv, rcvRequest, rcvStatus, ierr)
04129
04130 do nmsg=1,halo%numMsgRecv
04131 i = 0
04132 do n=1,halo%sizeRecv(nmsg)
04133 iDst = halo%recvAddr(1,n,nmsg)
04134 jDst = halo%recvAddr(2,n,nmsg)
04135 dstBlock = halo%recvAddr(3,n,nmsg)
04136
04137 if (dstBlock > 0) then
04138 do l=1,nt
04139 do k=1,nz
04140 i = i + 1
04141 array(iDst,jDst,k,l,dstBlock) = bufRecv(i,nmsg)
04142 end do
04143 end do
04144 else if (dstBlock < 0) then
04145 do l=1,nt
04146 do k=1,nz
04147 i = i + 1
04148 bufTripole(iDst,jDst,k,l) = bufRecv(i,nmsg)
04149 end do
04150 end do
04151 endif
04152 end do
04153 end do
04154
04155
04156
04157
04158
04159
04160
04161
04162
04163 if (nxGlobal > 0) then
04164
04165 select case (fieldKind)
04166 case (field_type_scalar)
04167 isign = 1
04168 case (field_type_vector)
04169 isign = -1
04170 case (field_type_angle)
04171 isign = -1
04172 case default
04173 call abort_ice( &
04174 'ice_HaloUpdate4DR8: Unknown field kind')
04175 end select
04176
04177 if (halo%tripoleTFlag) then
04178
04179 select case (fieldLoc)
04180 case (field_loc_center)
04181
04182 ioffset = -1
04183 joffset = 0
04184
04185
04186
04187
04188 do l=1,nt
04189 do k=1,nz
04190 do i = 2,nxGlobal/2
04191 iDst = nxGlobal - i + 2
04192 x1 = bufTripole(i ,halo%tripoleRows,k,l)
04193 x2 = bufTripole(iDst,halo%tripoleRows,k,l)
04194 xavg = 0.5_dbl_kind*(x1 + isign*x2)
04195 bufTripole(i ,halo%tripoleRows,k,l) = xavg
04196 bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg
04197 end do
04198 end do
04199 end do
04200
04201 case (field_loc_NEcorner)
04202
04203 ioffset = 0
04204 joffset = 1
04205
04206 case (field_loc_Eface)
04207
04208 ioffset = 0
04209 joffset = 0
04210
04211
04212
04213
04214 do l=1,nt
04215 do k=1,nz
04216 do i = 1,nxGlobal/2
04217 iDst = nxGlobal + 1 - i
04218 x1 = bufTripole(i ,halo%tripoleRows,k,l)
04219 x2 = bufTripole(iDst,halo%tripoleRows,k,l)
04220 xavg = 0.5_dbl_kind*(x1 + isign*x2)
04221 bufTripole(i ,halo%tripoleRows,k,l) = xavg
04222 bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg
04223 end do
04224 end do
04225 end do
04226
04227 case (field_loc_Nface)
04228
04229 ioffset = -1
04230 joffset = 1
04231
04232 case default
04233 call abort_ice( &
04234 'ice_HaloUpdate4DR8: Unknown field location')
04235 end select
04236
04237 else
04238
04239 select case (fieldLoc)
04240 case (field_loc_center)
04241
04242 ioffset = 0
04243 joffset = 0
04244
04245 case (field_loc_NEcorner)
04246
04247 ioffset = 1
04248 joffset = 1
04249
04250
04251
04252
04253 do l=1,nt
04254 do k=1,nz
04255 do i = 1,nxGlobal/2 - 1
04256 iDst = nxGlobal - i
04257 x1 = bufTripole(i ,halo%tripoleRows,k,l)
04258 x2 = bufTripole(iDst,halo%tripoleRows,k,l)
04259 xavg = 0.5_dbl_kind*(x1 + isign*x2)
04260 bufTripole(i ,halo%tripoleRows,k,l) = xavg
04261 bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg
04262 end do
04263 end do
04264 end do
04265
04266 case (field_loc_Eface)
04267
04268 ioffset = 1
04269 joffset = 0
04270
04271 case (field_loc_Nface)
04272
04273 ioffset = 0
04274 joffset = 1
04275
04276
04277
04278
04279 do l=1,nt
04280 do k=1,nz
04281 do i = 1,nxGlobal/2
04282 iDst = nxGlobal + 1 - i
04283 x1 = bufTripole(i ,halo%tripoleRows,k,l)
04284 x2 = bufTripole(iDst,halo%tripoleRows,k,l)
04285 xavg = 0.5_dbl_kind*(x1 + isign*x2)
04286 bufTripole(i ,halo%tripoleRows,k,l) = xavg
04287 bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg
04288 end do
04289 end do
04290 end do
04291
04292 case default
04293 call abort_ice( &
04294 'ice_HaloUpdate4DR8: Unknown field location')
04295 end select
04296
04297 endif
04298
04299
04300
04301
04302
04303
04304
04305 do nmsg=1,halo%numLocalCopies
04306 srcBlock = halo%srcLocalAddr(3,nmsg)
04307
04308 if (srcBlock < 0) then
04309
04310 iSrc = halo%srcLocalAddr(1,nmsg)
04311 jSrc = halo%srcLocalAddr(2,nmsg)
04312
04313 iDst = halo%dstLocalAddr(1,nmsg)
04314 jDst = halo%dstLocalAddr(2,nmsg)
04315 dstBlock = halo%dstLocalAddr(3,nmsg)
04316
04317
04318 iSrc = iSrc - ioffset
04319 jSrc = jSrc - joffset
04320 if (iSrc == 0) iSrc = nxGlobal
04321 if (iSrc > nxGlobal) iSrc = iSrc - nxGlobal
04322
04323
04324
04325
04326
04327
04328
04329 if (jSrc <= halo%tripoleRows .and. jSrc>0 .and. jDst>0) then
04330 do l=1,nt
04331 do k=1,nz
04332 array(iDst,jDst,k,l,dstBlock) = isign* &
04333 bufTripole(iSrc,jSrc,k,l)
04334 end do
04335 end do
04336 endif
04337
04338 endif
04339 end do
04340
04341 endif
04342
04343
04344
04345
04346
04347
04348
04349 call MPI_WAITALL(halo%numMsgSend, sndRequest, sndStatus, ierr)
04350
04351 deallocate(sndRequest, rcvRequest, sndStatus, rcvStatus, stat=ierr)
04352
04353 if (ierr > 0) then
04354 call abort_ice( &
04355 'ice_HaloUpdate4DR8: error deallocating req,status arrays')
04356 return
04357 endif
04358
04359 deallocate(bufSend, bufRecv, bufTripole, stat=ierr)
04360
04361 if (ierr > 0) then
04362 call abort_ice( &
04363 'ice_HaloUpdate4DR8: error deallocating 4d buffers')
04364 return
04365 endif
04366
04367
04368
04369
04370 end subroutine ice_HaloUpdate4DR8
04371
04372
04373
04374
04375
04376
04377 subroutine ice_HaloUpdate4DR4(array, halo, &
04378 fieldLoc, fieldKind, &
04379 fillValue)
04380
04381
04382
04383
04384
04385
04386
04387
04388
04389
04390
04391
04392
04393
04394 type (ice_halo), intent(in) ::
04395 halo
04396
04397
04398 integer (int_kind), intent(in) ::
04399 fieldKind,
04400 fieldLoc
04401
04402
04403 real (real_kind), intent(in), optional ::
04404 fillValue
04405
04406
04407
04408
04409
04410
04411 real (real_kind), dimension(:,:,:,:,:), intent(inout) ::
04412 array
04413
04414
04415
04416
04417
04418
04419
04420
04421
04422
04423
04424
04425 integer (int_kind) ::
04426 i,j,k,l,n,nmsg,
04427 ierr,
04428 nxGlobal,
04429 nz, nt,
04430 iSrc,jSrc,
04431 iDst,jDst,
04432 srcBlock,
04433 dstBlock,
04434 ioffset, joffset,
04435 isign
04436
04437 integer (int_kind), dimension(:), allocatable ::
04438 sndRequest,
04439 rcvRequest
04440
04441 integer (int_kind), dimension(:,:), allocatable ::
04442 sndStatus,
04443 rcvStatus
04444
04445 real (real_kind) ::
04446 fill,
04447 x1,x2,xavg
04448
04449 real (real_kind), dimension(:,:), allocatable ::
04450 bufSend, bufRecv
04451
04452 real (real_kind), dimension(:,:,:,:), allocatable ::
04453 bufTripole
04454
04455 integer (int_kind) :: len
04456
04457
04458
04459
04460
04461
04462
04463 if (present(fillValue)) then
04464 fill = fillValue
04465 else
04466 fill = 0.0_real_kind
04467 endif
04468
04469 nxGlobal = 0
04470 if (allocated(bufTripoleR4)) nxGlobal = size(bufTripoleR4,dim=1)
04471
04472
04473
04474
04475
04476
04477
04478 allocate(sndRequest(halo%numMsgSend), &
04479 rcvRequest(halo%numMsgRecv), &
04480 sndStatus(MPI_STATUS_SIZE,halo%numMsgSend), &
04481 rcvStatus(MPI_STATUS_SIZE,halo%numMsgRecv), stat=ierr)
04482
04483 if (ierr > 0) then
04484 call abort_ice( &
04485 'ice_HaloUpdate4DR4: error allocating req,status arrays')
04486 return
04487 endif
04488
04489
04490
04491
04492
04493
04494
04495 nz = size(array, dim=3)
04496 nt = size(array, dim=4)
04497
04498 allocate(bufSend(bufSizeSend*nz*nt, halo%numMsgSend), &
04499 bufRecv(bufSizeRecv*nz*nt, halo%numMsgRecv), &
04500 bufTripole(nxGlobal, halo%tripoleRows, nz, nt), &
04501 stat=ierr)
04502
04503 if (ierr > 0) then
04504 call abort_ice( &
04505 'ice_HaloUpdate4DR4: error allocating buffers')
04506 return
04507 endif
04508
04509 bufTripole = fill
04510
04511
04512
04513
04514
04515
04516
04517 do nmsg=1,halo%numMsgRecv
04518
04519 len = halo%SizeRecv(nmsg)*nz*nt
04520 call MPI_IRECV(bufRecv(1:len,nmsg), len, mpiR4, &
04521 halo%recvTask(nmsg), &
04522 mpitagHalo + halo%recvTask(nmsg), &
04523 halo%communicator, rcvRequest(nmsg), ierr)
04524 end do
04525
04526
04527
04528
04529
04530
04531
04532 do nmsg=1,halo%numMsgSend
04533
04534 i=0
04535 do n=1,halo%sizeSend(nmsg)
04536 iSrc = halo%sendAddr(1,n,nmsg)
04537 jSrc = halo%sendAddr(2,n,nmsg)
04538 srcBlock = halo%sendAddr(3,n,nmsg)
04539
04540 do l=1,nt
04541 do k=1,nz
04542 i = i + 1
04543 bufSend(i,nmsg) = array(iSrc,jSrc,k,l,srcBlock)
04544 end do
04545 end do
04546 end do
04547
04548 do n=i+1,bufSizeSend*nz*nt
04549 bufSend(n,nmsg) = fill
04550 end do
04551
04552 len = halo%SizeSend(nmsg)*nz*nt
04553 call MPI_ISEND(bufSend(1:len,nmsg), len, mpiR4, &
04554 halo%sendTask(nmsg), &
04555 mpitagHalo + my_task, &
04556 halo%communicator, sndRequest(nmsg), ierr)
04557 end do
04558
04559
04560
04561
04562
04563
04564
04565
04566
04567
04568
04569 do nmsg=1,halo%numLocalCopies
04570 iSrc = halo%srcLocalAddr(1,nmsg)
04571 jSrc = halo%srcLocalAddr(2,nmsg)
04572 srcBlock = halo%srcLocalAddr(3,nmsg)
04573 iDst = halo%dstLocalAddr(1,nmsg)
04574 jDst = halo%dstLocalAddr(2,nmsg)
04575 dstBlock = halo%dstLocalAddr(3,nmsg)
04576
04577 if (srcBlock > 0) then
04578 if (dstBlock > 0) then
04579 do l=1,nt
04580 do k=1,nz
04581 array(iDst,jDst,k,l,dstBlock) = &
04582 array(iSrc,jSrc,k,l,srcBlock)
04583 end do
04584 end do
04585 else if (dstBlock < 0) then
04586 do l=1,nt
04587 do k=1,nz
04588 bufTripole(iDst,jDst,k,l) = &
04589 array(iSrc,jSrc,k,l,srcBlock)
04590 end do
04591 end do
04592 endif
04593 else if (srcBlock == 0) then
04594 do l=1,nt
04595 do k=1,nz
04596 array(iDst,jDst,k,l,dstBlock) = fill
04597 end do
04598 end do
04599 endif
04600 end do
04601
04602
04603
04604
04605
04606
04607
04608
04609 call MPI_WAITALL(halo%numMsgRecv, rcvRequest, rcvStatus, ierr)
04610
04611 do nmsg=1,halo%numMsgRecv
04612 i = 0
04613 do n=1,halo%sizeRecv(nmsg)
04614 iDst = halo%recvAddr(1,n,nmsg)
04615 jDst = halo%recvAddr(2,n,nmsg)
04616 dstBlock = halo%recvAddr(3,n,nmsg)
04617
04618 if (dstBlock > 0) then
04619 do l=1,nt
04620 do k=1,nz
04621 i = i + 1
04622 array(iDst,jDst,k,l,dstBlock) = bufRecv(i,nmsg)
04623 end do
04624 end do
04625 else if (dstBlock < 0) then
04626 do l=1,nt
04627 do k=1,nz
04628 i = i + 1
04629 bufTripole(iDst,jDst,k,l) = bufRecv(i,nmsg)
04630 end do
04631 end do
04632 endif
04633 end do
04634 end do
04635
04636
04637
04638
04639
04640
04641
04642
04643
04644 if (nxGlobal > 0) then
04645
04646 select case (fieldKind)
04647 case (field_type_scalar)
04648 isign = 1
04649 case (field_type_vector)
04650 isign = -1
04651 case (field_type_angle)
04652 isign = -1
04653 case default
04654 call abort_ice( &
04655 'ice_HaloUpdate4DR4: Unknown field kind')
04656 end select
04657
04658 if (halo%tripoleTFlag) then
04659
04660 select case (fieldLoc)
04661 case (field_loc_center)
04662
04663 ioffset = -1
04664 joffset = 0
04665
04666
04667
04668
04669 do l=1,nt
04670 do k=1,nz
04671 do i = 2,nxGlobal/2
04672 iDst = nxGlobal - i + 2
04673 x1 = bufTripole(i ,halo%tripoleRows,k,l)
04674 x2 = bufTripole(iDst,halo%tripoleRows,k,l)
04675 xavg = 0.5_real_kind*(x1 + isign*x2)
04676 bufTripole(i ,halo%tripoleRows,k,l) = xavg
04677 bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg
04678 end do
04679 end do
04680 end do
04681
04682 case (field_loc_NEcorner)
04683
04684 ioffset = 0
04685 joffset = 1
04686
04687 case (field_loc_Eface)
04688
04689 ioffset = 0
04690 joffset = 0
04691
04692
04693
04694
04695 do l=1,nt
04696 do k=1,nz
04697 do i = 1,nxGlobal/2
04698 iDst = nxGlobal + 1 - i
04699 x1 = bufTripole(i ,halo%tripoleRows,k,l)
04700 x2 = bufTripole(iDst,halo%tripoleRows,k,l)
04701 xavg = 0.5_real_kind*(x1 + isign*x2)
04702 bufTripole(i ,halo%tripoleRows,k,l) = xavg
04703 bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg
04704 end do
04705 end do
04706 end do
04707
04708 case (field_loc_Nface)
04709
04710 ioffset = -1
04711 joffset = 1
04712
04713 case default
04714 call abort_ice( &
04715 'ice_HaloUpdate4DR4: Unknown field location')
04716 end select
04717
04718 else
04719
04720 select case (fieldLoc)
04721 case (field_loc_center)
04722
04723 ioffset = 0
04724 joffset = 0
04725
04726 case (field_loc_NEcorner)
04727
04728 ioffset = 1
04729 joffset = 1
04730
04731
04732
04733
04734 do l=1,nt
04735 do k=1,nz
04736 do i = 1,nxGlobal/2 - 1
04737 iDst = nxGlobal - i
04738 x1 = bufTripole(i ,halo%tripoleRows,k,l)
04739 x2 = bufTripole(iDst,halo%tripoleRows,k,l)
04740 xavg = 0.5_real_kind*(x1 + isign*x2)
04741 bufTripole(i ,halo%tripoleRows,k,l) = xavg
04742 bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg
04743 end do
04744 end do
04745 end do
04746
04747 case (field_loc_Eface)
04748
04749 ioffset = 1
04750 joffset = 0
04751
04752 case (field_loc_Nface)
04753
04754 ioffset = 0
04755 joffset = 1
04756
04757
04758
04759
04760 do l=1,nt
04761 do k=1,nz
04762 do i = 1,nxGlobal/2
04763 iDst = nxGlobal + 1 - i
04764 x1 = bufTripole(i ,halo%tripoleRows,k,l)
04765 x2 = bufTripole(iDst,halo%tripoleRows,k,l)
04766 xavg = 0.5_real_kind*(x1 + isign*x2)
04767 bufTripole(i ,halo%tripoleRows,k,l) = xavg
04768 bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg
04769 end do
04770 end do
04771 end do
04772
04773 case default
04774 call abort_ice( &
04775 'ice_HaloUpdate4DR4: Unknown field location')
04776 end select
04777
04778 endif
04779
04780
04781
04782
04783
04784
04785
04786 do nmsg=1,halo%numLocalCopies
04787 srcBlock = halo%srcLocalAddr(3,nmsg)
04788
04789 if (srcBlock < 0) then
04790
04791 iSrc = halo%srcLocalAddr(1,nmsg)
04792 jSrc = halo%srcLocalAddr(2,nmsg)
04793
04794 iDst = halo%dstLocalAddr(1,nmsg)
04795 jDst = halo%dstLocalAddr(2,nmsg)
04796 dstBlock = halo%dstLocalAddr(3,nmsg)
04797
04798
04799 iSrc = iSrc - ioffset
04800 jSrc = jSrc - joffset
04801 if (iSrc == 0) iSrc = nxGlobal
04802 if (iSrc > nxGlobal) iSrc = iSrc - nxGlobal
04803
04804
04805
04806
04807
04808
04809
04810 if (jSrc <= halo%tripoleRows .and. jSrc>0 .and. jDst>0) then
04811 do l=1,nt
04812 do k=1,nz
04813 array(iDst,jDst,k,l,dstBlock) = isign* &
04814 bufTripole(iSrc,jSrc,k,l)
04815 end do
04816 end do
04817 endif
04818
04819 endif
04820 end do
04821
04822 endif
04823
04824
04825
04826
04827
04828
04829
04830 call MPI_WAITALL(halo%numMsgSend, sndRequest, sndStatus, ierr)
04831
04832 deallocate(sndRequest, rcvRequest, sndStatus, rcvStatus, stat=ierr)
04833
04834 if (ierr > 0) then
04835 call abort_ice( &
04836 'ice_HaloUpdate4DR4: error deallocating req,status arrays')
04837 return
04838 endif
04839
04840 deallocate(bufSend, bufRecv, bufTripole, stat=ierr)
04841
04842 if (ierr > 0) then
04843 call abort_ice( &
04844 'ice_HaloUpdate4DR4: error deallocating 4d buffers')
04845 return
04846 endif
04847
04848
04849
04850
04851 end subroutine ice_HaloUpdate4DR4
04852
04853
04854
04855
04856
04857
04858 subroutine ice_HaloUpdate4DI4(array, halo, &
04859 fieldLoc, fieldKind, &
04860 fillValue)
04861
04862
04863
04864
04865
04866
04867
04868
04869
04870
04871
04872
04873
04874
04875 type (ice_halo), intent(in) ::
04876 halo
04877
04878
04879 integer (int_kind), intent(in) ::
04880 fieldKind,
04881 fieldLoc
04882
04883
04884 integer (int_kind), intent(in), optional ::
04885 fillValue
04886
04887
04888
04889
04890
04891
04892 integer (int_kind), dimension(:,:,:,:,:), intent(inout) ::
04893 array
04894
04895
04896
04897
04898
04899
04900
04901
04902
04903
04904
04905
04906 integer (int_kind) ::
04907 i,j,k,l,n,nmsg,
04908 ierr,
04909 nxGlobal,
04910 nz, nt,
04911 iSrc,jSrc,
04912 iDst,jDst,
04913 srcBlock,
04914 dstBlock,
04915 ioffset, joffset,
04916 isign
04917
04918 integer (int_kind), dimension(:), allocatable ::
04919 sndRequest,
04920 rcvRequest
04921
04922 integer (int_kind), dimension(:,:), allocatable ::
04923 sndStatus,
04924 rcvStatus
04925
04926 integer (int_kind) ::
04927 fill,
04928 x1,x2,xavg
04929
04930 integer (int_kind), dimension(:,:), allocatable ::
04931 bufSend, bufRecv
04932
04933 integer (int_kind), dimension(:,:,:,:), allocatable ::
04934 bufTripole
04935
04936 integer (int_kind) :: len
04937
04938
04939
04940
04941
04942
04943
04944 if (present(fillValue)) then
04945 fill = fillValue
04946 else
04947 fill = 0_int_kind
04948 endif
04949
04950 nxGlobal = 0
04951 if (allocated(bufTripoleI4)) nxGlobal = size(bufTripoleI4,dim=1)
04952
04953
04954
04955
04956
04957
04958
04959 allocate(sndRequest(halo%numMsgSend), &
04960 rcvRequest(halo%numMsgRecv), &
04961 sndStatus(MPI_STATUS_SIZE,halo%numMsgSend), &
04962 rcvStatus(MPI_STATUS_SIZE,halo%numMsgRecv), stat=ierr)
04963
04964 if (ierr > 0) then
04965 call abort_ice( &
04966 'ice_HaloUpdate4DI4: error allocating req,status arrays')
04967 return
04968 endif
04969
04970
04971
04972
04973
04974
04975
04976 nz = size(array, dim=3)
04977 nt = size(array, dim=4)
04978
04979 allocate(bufSend(bufSizeSend*nz*nt, halo%numMsgSend), &
04980 bufRecv(bufSizeRecv*nz*nt, halo%numMsgRecv), &
04981 bufTripole(nxGlobal, halo%tripoleRows, nz, nt), &
04982 stat=ierr)
04983
04984 if (ierr > 0) then
04985 call abort_ice( &
04986 'ice_HaloUpdate4DI4: error allocating buffers')
04987 return
04988 endif
04989
04990 bufTripole = fill
04991
04992
04993
04994
04995
04996
04997
04998 do nmsg=1,halo%numMsgRecv
04999
05000 len = halo%SizeRecv(nmsg)*nz*nt
05001 call MPI_IRECV(bufRecv(1:len,nmsg), len, MPI_INTEGER, &
05002 halo%recvTask(nmsg), &
05003 mpitagHalo + halo%recvTask(nmsg), &
05004 halo%communicator, rcvRequest(nmsg), ierr)
05005 end do
05006
05007
05008
05009
05010
05011
05012
05013 do nmsg=1,halo%numMsgSend
05014
05015 i=0
05016 do n=1,halo%sizeSend(nmsg)
05017 iSrc = halo%sendAddr(1,n,nmsg)
05018 jSrc = halo%sendAddr(2,n,nmsg)
05019 srcBlock = halo%sendAddr(3,n,nmsg)
05020
05021 do l=1,nt
05022 do k=1,nz
05023 i = i + 1
05024 bufSend(i,nmsg) = array(iSrc,jSrc,k,l,srcBlock)
05025 end do
05026 end do
05027 end do
05028
05029 do n=i+1,bufSizeSend*nz*nt
05030 bufSend(n,nmsg) = fill
05031 end do
05032
05033 len = halo%SizeSend(nmsg)*nz*nt
05034 call MPI_ISEND(bufSend(1:len,nmsg), len, MPI_INTEGER, &
05035 halo%sendTask(nmsg), &
05036 mpitagHalo + my_task, &
05037 halo%communicator, sndRequest(nmsg), ierr)
05038 end do
05039
05040
05041
05042
05043
05044
05045
05046
05047
05048
05049
05050 do nmsg=1,halo%numLocalCopies
05051 iSrc = halo%srcLocalAddr(1,nmsg)
05052 jSrc = halo%srcLocalAddr(2,nmsg)
05053 srcBlock = halo%srcLocalAddr(3,nmsg)
05054 iDst = halo%dstLocalAddr(1,nmsg)
05055 jDst = halo%dstLocalAddr(2,nmsg)
05056 dstBlock = halo%dstLocalAddr(3,nmsg)
05057
05058 if (srcBlock > 0) then
05059 if (dstBlock > 0) then
05060 do l=1,nt
05061 do k=1,nz
05062 array(iDst,jDst,k,l,dstBlock) = &
05063 array(iSrc,jSrc,k,l,srcBlock)
05064 end do
05065 end do
05066 else if (dstBlock < 0) then
05067 do l=1,nt
05068 do k=1,nz
05069 bufTripole(iDst,jDst,k,l) = &
05070 array(iSrc,jSrc,k,l,srcBlock)
05071 end do
05072 end do
05073 endif
05074 else if (srcBlock == 0) then
05075 do l=1,nt
05076 do k=1,nz
05077 array(iDst,jDst,k,l,dstBlock) = fill
05078 end do
05079 end do
05080 endif
05081 end do
05082
05083
05084
05085
05086
05087
05088
05089
05090 call MPI_WAITALL(halo%numMsgRecv, rcvRequest, rcvStatus, ierr)
05091
05092 do nmsg=1,halo%numMsgRecv
05093 i = 0
05094 do n=1,halo%sizeRecv(nmsg)
05095 iDst = halo%recvAddr(1,n,nmsg)
05096 jDst = halo%recvAddr(2,n,nmsg)
05097 dstBlock = halo%recvAddr(3,n,nmsg)
05098
05099 if (dstBlock > 0) then
05100 do l=1,nt
05101 do k=1,nz
05102 i = i + 1
05103 array(iDst,jDst,k,l,dstBlock) = bufRecv(i,nmsg)
05104 end do
05105 end do
05106 else if (dstBlock < 0) then
05107 do l=1,nt
05108 do k=1,nz
05109 i = i + 1
05110 bufTripole(iDst,jDst,k,l) = bufRecv(i,nmsg)
05111 end do
05112 end do
05113 endif
05114 end do
05115 end do
05116
05117
05118
05119
05120
05121
05122
05123
05124
05125 if (nxGlobal > 0) then
05126
05127 select case (fieldKind)
05128 case (field_type_scalar)
05129 isign = 1
05130 case (field_type_vector)
05131 isign = -1
05132 case (field_type_angle)
05133 isign = -1
05134 case default
05135 call abort_ice( &
05136 'ice_HaloUpdate4DI4: Unknown field kind')
05137 end select
05138
05139 if (halo%tripoleTFlag) then
05140
05141 select case (fieldLoc)
05142 case (field_loc_center)
05143
05144 ioffset = -1
05145 joffset = 0
05146
05147
05148
05149
05150 do l=1,nt
05151 do k=1,nz
05152 do i = 2,nxGlobal/2
05153 iDst = nxGlobal - i + 2
05154 x1 = bufTripole(i ,halo%tripoleRows,k,l)
05155 x2 = bufTripole(iDst,halo%tripoleRows,k,l)
05156 xavg = nint(0.5_dbl_kind*(x1 + isign*x2))
05157 bufTripole(i ,halo%tripoleRows,k,l) = xavg
05158 bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg
05159 end do
05160 end do
05161 end do
05162
05163 case (field_loc_NEcorner)
05164
05165 ioffset = 0
05166 joffset = 1
05167
05168 case (field_loc_Eface)
05169
05170 ioffset = 0
05171 joffset = 0
05172
05173
05174
05175
05176 do l=1,nt
05177 do k=1,nz
05178 do i = 1,nxGlobal/2
05179 iDst = nxGlobal + 1 - i
05180 x1 = bufTripole(i ,halo%tripoleRows,k,l)
05181 x2 = bufTripole(iDst,halo%tripoleRows,k,l)
05182 xavg = nint(0.5_dbl_kind*(x1 + isign*x2))
05183 bufTripole(i ,halo%tripoleRows,k,l) = xavg
05184 bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg
05185 end do
05186 end do
05187 end do
05188
05189 case (field_loc_Nface)
05190
05191 ioffset = -1
05192 joffset = 1
05193
05194 case default
05195 call abort_ice( &
05196 'ice_HaloUpdate4DI4: Unknown field location')
05197 end select
05198
05199 else
05200
05201 select case (fieldLoc)
05202 case (field_loc_center)
05203
05204 ioffset = 0
05205 joffset = 0
05206
05207 case (field_loc_NEcorner)
05208
05209 ioffset = 1
05210 joffset = 1
05211
05212
05213
05214
05215 do l=1,nt
05216 do k=1,nz
05217 do i = 1,nxGlobal/2 - 1
05218 iDst = nxGlobal - i
05219 x1 = bufTripole(i ,halo%tripoleRows,k,l)
05220 x2 = bufTripole(iDst,halo%tripoleRows,k,l)
05221 xavg = nint(0.5_dbl_kind*(x1 + isign*x2))
05222 bufTripole(i ,halo%tripoleRows,k,l) = xavg
05223 bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg
05224 end do
05225 end do
05226 end do
05227
05228 case (field_loc_Eface)
05229
05230 ioffset = 1
05231 joffset = 0
05232
05233 case (field_loc_Nface)
05234
05235 ioffset = 0
05236 joffset = 1
05237
05238
05239
05240
05241 do l=1,nt
05242 do k=1,nz
05243 do i = 1,nxGlobal/2
05244 iDst = nxGlobal + 1 - i
05245 x1 = bufTripole(i ,halo%tripoleRows,k,l)
05246 x2 = bufTripole(iDst,halo%tripoleRows,k,l)
05247 xavg = nint(0.5_dbl_kind*(x1 + isign*x2))
05248 bufTripole(i ,halo%tripoleRows,k,l) = xavg
05249 bufTripole(iDst,halo%tripoleRows,k,l) = isign*xavg
05250 end do
05251 end do
05252 end do
05253
05254 case default
05255 call abort_ice( &
05256 'ice_HaloUpdate4DI4: Unknown field location')
05257 end select
05258
05259 endif
05260
05261
05262
05263
05264
05265
05266
05267 do nmsg=1,halo%numLocalCopies
05268 srcBlock = halo%srcLocalAddr(3,nmsg)
05269
05270 if (srcBlock < 0) then
05271
05272 iSrc = halo%srcLocalAddr(1,nmsg)
05273 jSrc = halo%srcLocalAddr(2,nmsg)
05274
05275 iDst = halo%dstLocalAddr(1,nmsg)
05276 jDst = halo%dstLocalAddr(2,nmsg)
05277 dstBlock = halo%dstLocalAddr(3,nmsg)
05278
05279
05280 iSrc = iSrc - ioffset
05281 jSrc = jSrc - joffset
05282 if (iSrc == 0) iSrc = nxGlobal
05283 if (iSrc > nxGlobal) iSrc = iSrc - nxGlobal
05284
05285
05286
05287
05288
05289
05290
05291 if (jSrc <= halo%tripoleRows .and. jSrc>0 .and. jDst>0) then
05292 do l=1,nt
05293 do k=1,nz
05294 array(iDst,jDst,k,l,dstBlock) = isign* &
05295 bufTripole(iSrc,jSrc,k,l)
05296 end do
05297 end do
05298 endif
05299
05300 endif
05301 end do
05302
05303 endif
05304
05305
05306
05307
05308
05309
05310
05311 call MPI_WAITALL(halo%numMsgSend, sndRequest, sndStatus, ierr)
05312
05313 deallocate(sndRequest, rcvRequest, sndStatus, rcvStatus, stat=ierr)
05314
05315 if (ierr > 0) then
05316 call abort_ice( &
05317 'ice_HaloUpdate4DI4: error deallocating req,status arrays')
05318 return
05319 endif
05320
05321 deallocate(bufSend, bufRecv, bufTripole, stat=ierr)
05322
05323 if (ierr > 0) then
05324 call abort_ice( &
05325 'ice_HaloUpdate4DI4: error deallocating 4d buffers')
05326 return
05327 endif
05328
05329
05330
05331
05332 end subroutine ice_HaloUpdate4DI4
05333
05334
05335
05336
05337
05338
05339 subroutine ice_HaloIncrementMsgCount(sndCounter, rcvCounter, &
05340 srcProc, dstProc, msgSize)
05341
05342
05343
05344
05345
05346
05347
05348
05349
05350
05351
05352
05353 integer (int_kind), intent(in) ::
05354 srcProc,
05355 dstProc,
05356 msgSize
05357
05358
05359
05360 integer (int_kind), dimension(:), intent(inout) ::
05361 sndCounter,
05362 rcvCounter
05363
05364
05365
05366
05367
05368
05369
05370
05371
05372
05373
05374 if (srcProc < 0 .or. dstProc < 0 .or. &
05375 srcProc > size(sndCounter) .or. &
05376 dstProc > size(rcvCounter)) then
05377 call abort_ice( &
05378 'ice_HaloIncrementMsgCount: invalid processor number')
05379 return
05380 endif
05381
05382
05383
05384
05385
05386
05387
05388
05389 if (dstProc == 0) return
05390
05391
05392
05393
05394
05395
05396
05397
05398 if (srcProc == my_task + 1) sndCounter(dstProc) = &
05399 sndCounter(dstProc) + msgSize
05400
05401
05402
05403
05404
05405
05406
05407
05408 if (dstProc == my_task + 1) then
05409
05410 if (srcProc > 0) then
05411
05412
05413
05414 rcvCounter(srcProc) = rcvCounter(srcProc) + msgSize
05415
05416 else
05417
05418
05419
05420 rcvCounter(dstProc) = rcvCounter(dstProc) + msgSize
05421
05422 endif
05423 endif
05424
05425
05426
05427 end subroutine ice_HaloIncrementMsgCount
05428
05429
05430
05431
05432
05433
05434 subroutine ice_HaloMsgCreate(halo, srcBlock, srcProc, srcLocalID, &
05435 dstBlock, dstProc, dstLocalID, &
05436 direction)
05437
05438
05439
05440
05441
05442
05443
05444
05445
05446
05447 integer (int_kind), intent(in) ::
05448 srcBlock, dstBlock,
05449 srcProc, dstProc,
05450 srcLocalID, dstLocalID
05451
05452 character (*), intent(in) ::
05453 direction
05454
05455
05456
05457
05458
05459 type (ice_halo), intent(inout) ::
05460 halo
05461
05462
05463
05464
05465
05466
05467
05468
05469
05470
05471
05472 integer (int_kind) ::
05473 msgIndx,
05474 blockIndx,
05475 bufSize,
05476 ibSrc, ieSrc, jbSrc, jeSrc,
05477 ibDst, ieDst, jbDst, jeDst,
05478 nxGlobal,
05479 i,j,n
05480
05481 integer (int_kind), dimension(:), pointer ::
05482 iGlobal
05483
05484
05485
05486
05487
05488
05489
05490 if (allocated(bufTripoleR8)) nxGlobal = size(bufTripoleR8,dim=1)
05491
05492
05493
05494
05495
05496
05497
05498
05499 if (dstProc == 0) return
05500
05501
05502
05503
05504
05505
05506
05507 if (srcProc == my_task+1 .or. dstProc == my_task+1) then
05508
05509 if (srcBlock >= 0 .and. dstBlock >= 0) then
05510 call get_block_parameter(srcBlock, &
05511 ilo=ibSrc, ihi=ieSrc, &
05512 jlo=jbSrc, jhi=jeSrc)
05513 else
05514 call get_block_parameter(abs(srcBlock), &
05515 ilo=ibSrc, ihi=ieSrc, &
05516 jlo=jbSrc, jhi=jeSrc, &
05517 i_glob=iGlobal)
05518
05519 endif
05520
05521 if (dstBlock /= 0) then
05522 call get_block_parameter(abs(dstBlock), &
05523 ilo=ibDst, ihi=ieDst, &
05524 jlo=jbDst, jhi=jeDst)
05525 endif
05526
05527 endif
05528
05529
05530
05531
05532
05533
05534
05535 if (srcProc == my_task+1 .and. &
05536 dstProc == my_task+1) then
05537
05538
05539
05540 msgIndx = halo%numLocalCopies
05541
05542 if (msgIndx > size(halo%srcLocalAddr,dim=2) .or. &
05543 msgIndx > size(halo%dstLocalAddr,dim=2)) then
05544 call abort_ice( &
05545 'ice_HaloMsgCreate: msg count > array size')
05546 return
05547 endif
05548
05549 select case (direction)
05550 case ('east')
05551
05552
05553
05554
05555 do j=1,jeSrc-jbSrc+1
05556 do i=1,nghost
05557
05558 msgIndx = msgIndx + 1
05559
05560 halo%srcLocalAddr(1,msgIndx) = ieSrc - nghost + i
05561 halo%srcLocalAddr(2,msgIndx) = jbSrc + j - 1
05562 halo%srcLocalAddr(3,msgIndx) = srcLocalID
05563
05564 halo%dstLocalAddr(1,msgIndx) = i
05565 halo%dstLocalAddr(2,msgIndx) = jbDst + j - 1
05566 halo%dstLocalAddr(3,msgIndx) = dstLocalID
05567
05568 end do
05569 end do
05570
05571 case ('west')
05572
05573
05574
05575
05576 do j=1,jeSrc-jbSrc+1
05577 do i=1,nghost
05578
05579 msgIndx = msgIndx + 1
05580
05581 halo%srcLocalAddr(1,msgIndx) = ibSrc + i - 1
05582 halo%srcLocalAddr(2,msgIndx) = jbSrc + j - 1
05583 halo%srcLocalAddr(3,msgIndx) = srcLocalID
05584
05585 halo%dstLocalAddr(1,msgIndx) = ieDst + i
05586 halo%dstLocalAddr(2,msgIndx) = jbDst + j - 1
05587 halo%dstLocalAddr(3,msgIndx) = dstLocalID
05588
05589 end do
05590 end do
05591
05592 case ('north')
05593
05594
05595
05596
05597 if (srcBlock > 0 .and. dstBlock > 0) then
05598
05599 do j=1,nghost
05600 do i=1,ieSrc-ibSrc+1
05601
05602 msgIndx = msgIndx + 1
05603
05604 halo%srcLocalAddr(1,msgIndx) = ibSrc + i - 1
05605 halo%srcLocalAddr(2,msgIndx) = jeSrc - nghost + j
05606 halo%srcLocalAddr(3,msgIndx) = srcLocalID
05607
05608 halo%dstLocalAddr(1,msgIndx) = ibDst + i - 1
05609 halo%dstLocalAddr(2,msgIndx) = j
05610 halo%dstLocalAddr(3,msgIndx) = dstLocalID
05611
05612 end do
05613 end do
05614
05615 else if (srcBlock > 0 .and. dstBlock < 0) then
05616
05617
05618
05619
05620
05621
05622
05623
05624
05625 if (jeSrc - jbSrc + 1 < halo%tripoleRows) then
05626 call abort_ice( &
05627 'ice_HaloMsgCreate: not enough points in block for tripole')
05628 return
05629 endif
05630
05631 do j=1,halo%tripoleRows
05632 do i=1,ieSrc-ibSrc+1
05633
05634 msgIndx = msgIndx + 1
05635
05636 halo%srcLocalAddr(1,msgIndx) = ibSrc + i - 1
05637 halo%srcLocalAddr(2,msgIndx) = jeSrc-halo%tripoleRows+j
05638 halo%srcLocalAddr(3,msgIndx) = srcLocalID
05639
05640 halo%dstLocalAddr(1,msgIndx) = iGlobal(ibSrc + i - 1)
05641 halo%dstLocalAddr(2,msgIndx) = j
05642 halo%dstLocalAddr(3,msgIndx) = -dstLocalID
05643
05644 end do
05645 end do
05646
05647 else if (srcBlock < 0 .and. dstBlock > 0) then
05648
05649
05650
05651
05652
05653 do j=1,halo%tripoleRows
05654 do i=1,ieSrc+nghost
05655
05656 msgIndx = msgIndx + 1
05657
05658 halo%srcLocalAddr(1,msgIndx) = nxGlobal - iGlobal(i) + 1
05659 halo%srcLocalAddr(2,msgIndx) = nghost + 3 - j
05660 halo%srcLocalAddr(3,msgIndx) = -srcLocalID
05661
05662 halo%dstLocalAddr(1,msgIndx) = i
05663 if (j.gt.nghost+1) then
05664 halo%dstLocalAddr(2,msgIndx) = -1
05665 else
05666 halo%dstLocalAddr(2,msgIndx) = jeSrc + j - 1
05667 endif
05668 halo%dstLocalAddr(3,msgIndx) = dstLocalID
05669
05670 end do
05671 end do
05672
05673 endif
05674
05675 case ('south')
05676
05677
05678
05679
05680 do j=1,nghost
05681 do i=1,ieSrc-ibSrc+1
05682
05683 msgIndx = msgIndx + 1
05684
05685 halo%srcLocalAddr(1,msgIndx) = ibSrc + i - 1
05686 halo%srcLocalAddr(2,msgIndx) = jbSrc + j - 1
05687 halo%srcLocalAddr(3,msgIndx) = srcLocalID
05688
05689 halo%dstLocalAddr(1,msgIndx) = ibDst + i - 1
05690 halo%dstLocalAddr(2,msgIndx) = jeDst + j
05691 halo%dstLocalAddr(3,msgIndx) = dstLocalID
05692
05693 end do
05694 end do
05695
05696 case ('northeast')
05697
05698
05699
05700
05701 if (dstBlock > 0) then
05702
05703 do j=1,nghost
05704 do i=1,nghost
05705
05706 msgIndx = msgIndx + 1
05707
05708 halo%srcLocalAddr(1,msgIndx) = ieSrc - nghost + i
05709 halo%srcLocalAddr(2,msgIndx) = jeSrc - nghost + j
05710 halo%srcLocalAddr(3,msgIndx) = srcLocalID
05711
05712 halo%dstLocalAddr(1,msgIndx) = i
05713 halo%dstLocalAddr(2,msgIndx) = j
05714 halo%dstLocalAddr(3,msgIndx) = dstLocalID
05715
05716 end do
05717 end do
05718
05719 else
05720
05721
05722
05723
05724 endif
05725
05726 case ('northwest')
05727
05728
05729
05730
05731 if (dstBlock > 0) then
05732
05733 do j=1,nghost
05734 do i=1,nghost
05735
05736 msgIndx = msgIndx + 1
05737
05738 halo%srcLocalAddr(1,msgIndx) = ibSrc + i - 1
05739 halo%srcLocalAddr(2,msgIndx) = jeSrc - nghost + j
05740 halo%srcLocalAddr(3,msgIndx) = srcLocalID
05741
05742 halo%dstLocalAddr(1,msgIndx) = ieDst + i
05743 halo%dstLocalAddr(2,msgIndx) = j
05744 halo%dstLocalAddr(3,msgIndx) = dstLocalID
05745
05746 end do
05747 end do
05748
05749 else
05750
05751
05752
05753
05754 endif
05755
05756 case ('southeast')
05757
05758
05759
05760
05761 do j=1,nghost
05762 do i=1,nghost
05763
05764 msgIndx = msgIndx + 1
05765
05766 halo%srcLocalAddr(1,msgIndx) = ieSrc - nghost + i
05767 halo%srcLocalAddr(2,msgIndx) = jbSrc + j - 1
05768 halo%srcLocalAddr(3,msgIndx) = srcLocalID
05769
05770 halo%dstLocalAddr(1,msgIndx) = i
05771 halo%dstLocalAddr(2,msgIndx) = jeDst + j
05772 halo%dstLocalAddr(3,msgIndx) = dstLocalID
05773
05774 end do
05775 end do
05776
05777 case ('southwest')
05778
05779
05780
05781
05782 do j=1,nghost
05783 do i=1,nghost
05784
05785 msgIndx = msgIndx + 1
05786
05787 halo%srcLocalAddr(1,msgIndx) = ibSrc + i - 1
05788 halo%srcLocalAddr(2,msgIndx) = jbSrc + j - 1
05789 halo%srcLocalAddr(3,msgIndx) = srcLocalID
05790
05791 halo%dstLocalAddr(1,msgIndx) = ieDst + i
05792 halo%dstLocalAddr(2,msgIndx) = jeDst + j
05793 halo%dstLocalAddr(3,msgIndx) = dstLocalID
05794
05795 end do
05796 end do
05797
05798 case default
05799
05800 call abort_ice( &
05801 'ice_HaloMsgCreate: unknown direction local copy')
05802 return
05803
05804 end select
05805
05806 halo%numLocalCopies = msgIndx
05807
05808 if (msgIndx > size(halo%srcLocalAddr,dim=2) .or. &
05809 msgIndx > size(halo%dstLocalAddr,dim=2)) then
05810 call abort_ice( &
05811 'ice_HaloMsgCreate: msg count > array size')
05812 return
05813 endif
05814
05815
05816
05817
05818
05819
05820
05821
05822 else if (srcProc == 0 .and. dstProc == my_task+1) then
05823
05824 msgIndx = halo%numLocalCopies
05825
05826 if (msgIndx > size(halo%srcLocalAddr,dim=2) .or. &
05827 msgIndx > size(halo%dstLocalAddr,dim=2)) then
05828 call abort_ice( &
05829 'ice_HaloMsgCreate: msg count > array size')
05830 return
05831 endif
05832
05833
05834
05835 select case (direction)
05836 case ('east')
05837
05838
05839
05840
05841 do j=1,jeSrc-jbSrc+1
05842 do i=1,nghost
05843
05844 msgIndx = msgIndx + 1
05845
05846 halo%srcLocalAddr(1,msgIndx) = 0
05847 halo%srcLocalAddr(2,msgIndx) = 0
05848 halo%srcLocalAddr(3,msgIndx) = 0
05849
05850 halo%dstLocalAddr(1,msgIndx) = i
05851 halo%dstLocalAddr(2,msgIndx) = jbDst + j - 1
05852 halo%dstLocalAddr(3,msgIndx) = dstLocalID
05853
05854 end do
05855 end do
05856
05857 case ('west')
05858
05859
05860
05861
05862 do j=1,jeSrc-jbSrc+1
05863 do i=1,nghost
05864
05865 msgIndx = msgIndx + 1
05866
05867 halo%srcLocalAddr(1,msgIndx) = 0
05868 halo%srcLocalAddr(2,msgIndx) = 0
05869 halo%srcLocalAddr(3,msgIndx) = 0
05870
05871 halo%dstLocalAddr(1,msgIndx) = ieDst + i
05872 halo%dstLocalAddr(2,msgIndx) = jbDst + j - 1
05873 halo%dstLocalAddr(3,msgIndx) = dstLocalID
05874
05875 end do
05876 end do
05877
05878 case ('north')
05879
05880
05881
05882
05883 if (dstBlock > 0) then
05884
05885 do j=1,nghost
05886 do i=1,ieSrc-ibSrc+1
05887
05888 msgIndx = msgIndx + 1
05889
05890 halo%srcLocalAddr(1,msgIndx) = 0
05891 halo%srcLocalAddr(2,msgIndx) = 0
05892 halo%srcLocalAddr(3,msgIndx) = 0
05893
05894 halo%dstLocalAddr(1,msgIndx) = ibDst + i - 1
05895 halo%dstLocalAddr(2,msgIndx) = j
05896 halo%dstLocalAddr(3,msgIndx) = dstLocalID
05897
05898 end do
05899 end do
05900
05901 endif
05902
05903 case ('south')
05904
05905
05906
05907
05908 do j=1,nghost
05909 do i=1,ieSrc-ibSrc+1
05910
05911 msgIndx = msgIndx + 1
05912
05913 halo%srcLocalAddr(1,msgIndx) = 0
05914 halo%srcLocalAddr(2,msgIndx) = 0
05915 halo%srcLocalAddr(3,msgIndx) = 0
05916
05917 halo%dstLocalAddr(1,msgIndx) = ibDst + i - 1
05918 halo%dstLocalAddr(2,msgIndx) = jeDst + j
05919 halo%dstLocalAddr(3,msgIndx) = dstLocalID
05920
05921 end do
05922 end do
05923
05924 case ('northeast')
05925
05926
05927
05928
05929 if (dstBlock > 0) then
05930
05931 do j=1,nghost
05932 do i=1,nghost
05933
05934 msgIndx = msgIndx + 1
05935
05936 halo%srcLocalAddr(1,msgIndx) = 0
05937 halo%srcLocalAddr(2,msgIndx) = 0
05938 halo%srcLocalAddr(3,msgIndx) = 0
05939
05940 halo%dstLocalAddr(1,msgIndx) = i
05941 halo%dstLocalAddr(2,msgIndx) = j
05942 halo%dstLocalAddr(3,msgIndx) = dstLocalID
05943
05944 end do
05945 end do
05946
05947 endif
05948
05949 case ('northwest')
05950
05951
05952
05953
05954 if (dstBlock > 0) then
05955
05956 do j=1,nghost
05957 do i=1,nghost
05958
05959 msgIndx = msgIndx + 1
05960
05961 halo%srcLocalAddr(1,msgIndx) = 0
05962 halo%srcLocalAddr(2,msgIndx) = 0
05963 halo%srcLocalAddr(3,msgIndx) = 0
05964
05965 halo%dstLocalAddr(1,msgIndx) = ieDst + i
05966 halo%dstLocalAddr(2,msgIndx) = j
05967 halo%dstLocalAddr(3,msgIndx) = dstLocalID
05968
05969 end do
05970 end do
05971
05972 endif
05973
05974 case ('southeast')
05975
05976
05977
05978
05979 do j=1,nghost
05980 do i=1,nghost
05981
05982 msgIndx = msgIndx + 1
05983
05984 halo%srcLocalAddr(1,msgIndx) = 0
05985 halo%srcLocalAddr(2,msgIndx) = 0
05986 halo%srcLocalAddr(3,msgIndx) = 0
05987
05988 halo%dstLocalAddr(1,msgIndx) = i
05989 halo%dstLocalAddr(2,msgIndx) = jeDst + j
05990 halo%dstLocalAddr(3,msgIndx) = dstLocalID
05991
05992 end do
05993 end do
05994
05995 case ('southwest')
05996
05997
05998
05999
06000 do j=1,nghost
06001 do i=1,nghost
06002
06003 msgIndx = msgIndx + 1
06004
06005 halo%srcLocalAddr(1,msgIndx) = 0
06006 halo%srcLocalAddr(2,msgIndx) = 0
06007 halo%srcLocalAddr(3,msgIndx) = 0
06008
06009 halo%dstLocalAddr(1,msgIndx) = ieDst + i
06010 halo%dstLocalAddr(2,msgIndx) = jeDst + j
06011 halo%dstLocalAddr(3,msgIndx) = dstLocalID
06012
06013 end do
06014 end do
06015
06016 case default
06017
06018 call abort_ice( &
06019 'ice_HaloMsgCreate: unknown direction local copy')
06020 return
06021
06022 end select
06023
06024 halo%numLocalCopies = msgIndx
06025
06026 if (msgIndx > size(halo%srcLocalAddr,dim=2) .or. &
06027 msgIndx > size(halo%dstLocalAddr,dim=2)) then
06028 call abort_ice( &
06029 'ice_HaloMsgCreate: msg count > array size')
06030 return
06031 endif
06032
06033
06034
06035
06036
06037
06038
06039 else if (srcProc == my_task+1 .and. &
06040 dstProc /= my_task+1 .and. dstProc > 0) then
06041
06042
06043
06044
06045
06046 msgIndx = 0
06047
06048 srchSend: do n=1,halo%numMsgSend
06049 if (halo%sendTask(n) == dstProc - 1) then
06050 msgIndx = n
06051 bufSize = halo%sizeSend(n)
06052 exit srchSend
06053 endif
06054 end do srchSend
06055
06056 if (msgIndx == 0) then
06057 msgIndx = halo%numMsgSend + 1
06058 halo%numMsgSend = msgIndx
06059 halo%sendTask(msgIndx) = dstProc - 1
06060 bufSize = 0
06061 endif
06062
06063
06064
06065 select case (direction)
06066 case ('east')
06067
06068
06069
06070
06071 do j=1,jeSrc-jbSrc+1
06072 do i=1,nghost
06073
06074 bufSize = bufSize + 1
06075
06076 halo%sendAddr(1,bufSize,msgIndx) = ieSrc - nghost + i
06077 halo%sendAddr(2,bufSize,msgIndx) = jbSrc + j - 1
06078 halo%sendAddr(3,bufSize,msgIndx) = srcLocalID
06079
06080 end do
06081 end do
06082
06083 halo%sizeSend(msgIndx) = bufSize
06084
06085 case ('west')
06086
06087
06088
06089
06090 do j=1,jeSrc-jbSrc+1
06091 do i=1,nghost
06092
06093 bufSize = bufSize + 1
06094
06095 halo%sendAddr(1,bufSize,msgIndx) = ibSrc + i - 1
06096 halo%sendAddr(2,bufSize,msgIndx) = jbSrc + j - 1
06097 halo%sendAddr(3,bufSize,msgIndx) = srcLocalID
06098
06099 end do
06100 end do
06101
06102 halo%sizeSend(msgIndx) = bufSize
06103
06104 case ('north')
06105
06106 if (dstBlock > 0) then
06107
06108
06109
06110
06111 do j=1,nghost
06112 do i=1,ieSrc-ibSrc+1
06113
06114 bufSize = bufSize + 1
06115
06116 halo%sendAddr(1,bufSize,msgIndx) = ibSrc + i - 1
06117 halo%sendAddr(2,bufSize,msgIndx) = jeSrc-nghost+j
06118 halo%sendAddr(3,bufSize,msgIndx) = srcLocalID
06119
06120 end do
06121 end do
06122
06123 halo%sizeSend(msgIndx) = bufSize
06124
06125 else
06126
06127
06128
06129 do j=1,halo%tripoleRows
06130 do i=1,ieSrc-ibSrc+1
06131
06132 bufSize = bufSize + 1
06133
06134 halo%sendAddr(1,bufSize,msgIndx)=ibSrc + i - 1
06135 halo%sendAddr(2,bufSize,msgIndx)=jeSrc-halo%tripoleRows+j
06136 halo%sendAddr(3,bufSize,msgIndx)=srcLocalID
06137
06138 end do
06139 end do
06140
06141 halo%sizeSend(msgIndx) = bufSize
06142
06143 endif
06144
06145 case ('south')
06146
06147
06148
06149
06150 do j=1,nghost
06151 do i=1,ieSrc-ibSrc+1
06152
06153 bufSize = bufSize + 1
06154
06155 halo%sendAddr(1,bufSize,msgIndx) = ibSrc + i - 1
06156 halo%sendAddr(2,bufSize,msgIndx) = jbSrc + j - 1
06157 halo%sendAddr(3,bufSize,msgIndx) = srcLocalID
06158
06159 end do
06160 end do
06161
06162 halo%sizeSend(msgIndx) = bufSize
06163
06164 case ('northeast')
06165
06166
06167 if (dstBlock > 0) then
06168
06169
06170
06171
06172
06173 do j=1,nghost
06174 do i=1,nghost
06175
06176 bufSize = bufSize + 1
06177
06178 halo%sendAddr(1,bufSize,msgIndx) = ieSrc-nghost+i
06179 halo%sendAddr(2,bufSize,msgIndx) = jeSrc-nghost+j
06180 halo%sendAddr(3,bufSize,msgIndx) = srcLocalID
06181
06182 end do
06183 end do
06184
06185 halo%sizeSend(msgIndx) = bufSize
06186
06187 else
06188
06189
06190
06191 do j=1,halo%tripoleRows
06192 do i=1,ieSrc-ibSrc+1
06193
06194 bufSize = bufSize + 1
06195
06196 halo%sendAddr(1,bufSize,msgIndx)=ibSrc + i - 1
06197 halo%sendAddr(2,bufSize,msgIndx)=jeSrc-halo%tripoleRows+j
06198 halo%sendAddr(3,bufSize,msgIndx)=srcLocalID
06199
06200 end do
06201 end do
06202
06203 halo%sizeSend(msgIndx) = bufSize
06204
06205 endif
06206
06207 case ('northwest')
06208
06209 if (dstBlock > 0) then
06210
06211
06212
06213
06214
06215 do j=1,nghost
06216 do i=1,nghost
06217
06218 bufSize = bufSize + 1
06219
06220 halo%sendAddr(1,bufSize,msgIndx) = ibSrc + i - 1
06221 halo%sendAddr(2,bufSize,msgIndx) = jeSrc-nghost+j
06222 halo%sendAddr(3,bufSize,msgIndx) = srcLocalID
06223
06224 end do
06225 end do
06226
06227 halo%sizeSend(msgIndx) = bufSize
06228
06229 else
06230
06231
06232
06233 do j=1,halo%tripoleRows
06234 do i=1,ieSrc-ibSrc+1
06235
06236 bufSize = bufSize + 1
06237
06238 halo%sendAddr(1,bufSize,msgIndx)=ibSrc + i - 1
06239 halo%sendAddr(2,bufSize,msgIndx)=jeSrc-halo%tripoleRows+j
06240 halo%sendAddr(3,bufSize,msgIndx)=srcLocalID
06241
06242 end do
06243 end do
06244
06245 halo%sizeSend(msgIndx) = bufSize
06246
06247 endif
06248
06249 case ('southeast')
06250
06251
06252
06253
06254 do j=1,nghost
06255 do i=1,nghost
06256
06257 bufSize = bufSize + 1
06258
06259 halo%sendAddr(1,bufSize,msgIndx) = ieSrc - nghost + i
06260 halo%sendAddr(2,bufSize,msgIndx) = jbSrc + j - 1
06261 halo%sendAddr(3,bufSize,msgIndx) = srcLocalID
06262
06263 end do
06264 end do
06265
06266 halo%sizeSend(msgIndx) = bufSize
06267
06268 case ('southwest')
06269
06270
06271
06272
06273 do j=1,nghost
06274 do i=1,nghost
06275
06276 bufSize = bufSize + 1
06277
06278 halo%sendAddr(1,bufSize,msgIndx) = ibSrc + i - 1
06279 halo%sendAddr(2,bufSize,msgIndx) = jbSrc + j - 1
06280 halo%sendAddr(3,bufSize,msgIndx) = srcLocalID
06281
06282 end do
06283 end do
06284
06285 halo%sizeSend(msgIndx) = bufSize
06286
06287 case default
06288
06289
06290
06291 end select
06292
06293
06294
06295
06296
06297
06298
06299 else if (dstProc == my_task+1 .and. &
06300 srcProc /= my_task+1 .and. srcProc > 0) then
06301
06302
06303
06304
06305
06306 msgIndx = 0
06307
06308 srchRecv: do n=1,halo%numMsgRecv
06309 if (halo%recvTask(n) == srcProc - 1) then
06310 msgIndx = n
06311 bufSize = halo%sizeRecv(n)
06312 exit srchRecv
06313 endif
06314 end do srchRecv
06315
06316 if (msgIndx == 0) then
06317 msgIndx = halo%numMsgRecv + 1
06318 halo%numMsgRecv = msgIndx
06319 halo%recvTask(msgIndx) = srcProc - 1
06320 bufSize = 0
06321 endif
06322
06323
06324
06325 select case (direction)
06326 case ('east')
06327
06328
06329
06330
06331 do j=1,jeSrc-jbSrc+1
06332 do i=1,nghost
06333
06334 bufSize = bufSize + 1
06335
06336 halo%recvAddr(1,bufSize,msgIndx) = i
06337 halo%recvAddr(2,bufSize,msgIndx) = jbDst + j - 1
06338 halo%recvAddr(3,bufSize,msgIndx) = dstLocalID
06339
06340 end do
06341 end do
06342
06343 halo%sizeRecv(msgIndx) = bufSize
06344
06345 case ('west')
06346
06347
06348
06349
06350 do j=1,jeSrc-jbSrc+1
06351 do i=1,nghost
06352
06353 bufSize = bufSize + 1
06354
06355 halo%recvAddr(1,bufSize,msgIndx) = ieDst + i
06356 halo%recvAddr(2,bufSize,msgIndx) = jbDst + j - 1
06357 halo%recvAddr(3,bufSize,msgIndx) = dstLocalID
06358
06359 end do
06360 end do
06361
06362 halo%sizeRecv(msgIndx) = bufSize
06363
06364 case ('north')
06365
06366 if (dstBlock > 0) then
06367
06368
06369
06370
06371 do j=1,nghost
06372 do i=1,ieDst-ibDst+1
06373
06374 bufSize = bufSize + 1
06375
06376 halo%recvAddr(1,bufSize,msgIndx) = ibDst + i - 1
06377 halo%recvAddr(2,bufSize,msgIndx) = j
06378 halo%recvAddr(3,bufSize,msgIndx) = dstLocalID
06379
06380 end do
06381 end do
06382
06383 halo%sizeRecv(msgIndx) = bufSize
06384
06385 else
06386
06387
06388
06389 do j=1,halo%tripoleRows
06390 do i=1,ieSrc-ibSrc+1
06391
06392 bufSize = bufSize + 1
06393
06394 halo%recvAddr(1,bufSize,msgIndx) = iGlobal(ibSrc + i - 1)
06395 halo%recvAddr(2,bufSize,msgIndx) = j
06396 halo%recvAddr(3,bufSize,msgIndx) = -dstLocalID
06397
06398 end do
06399 end do
06400
06401 halo%sizeRecv(msgIndx) = bufSize
06402
06403 endif
06404
06405 case ('south')
06406
06407
06408
06409
06410 do j=1,nghost
06411 do i=1,ieSrc-ibSrc+1
06412
06413 bufSize = bufSize + 1
06414
06415 halo%recvAddr(1,bufSize,msgIndx) = ibDst + i - 1
06416 halo%recvAddr(2,bufSize,msgIndx) = jeDst + j
06417 halo%recvAddr(3,bufSize,msgIndx) = dstLocalID
06418
06419 end do
06420 end do
06421
06422 halo%sizeRecv(msgIndx) = bufSize
06423
06424 case ('northeast')
06425
06426 if (dstBlock > 0) then
06427
06428
06429
06430
06431
06432 do j=1,nghost
06433 do i=1,nghost
06434
06435 bufSize = bufSize + 1
06436
06437 halo%recvAddr(1,bufSize,msgIndx) = i
06438 halo%recvAddr(2,bufSize,msgIndx) = j
06439 halo%recvAddr(3,bufSize,msgIndx) = dstLocalID
06440
06441 end do
06442 end do
06443
06444 halo%sizeRecv(msgIndx) = bufSize
06445
06446 else
06447
06448
06449
06450 do j=1,halo%tripoleRows
06451 do i=1,ieSrc-ibSrc+1
06452
06453 bufSize = bufSize + 1
06454
06455 halo%recvAddr(1,bufSize,msgIndx) = iGlobal(ibSrc + i - 1)
06456 halo%recvAddr(2,bufSize,msgIndx) = j
06457 halo%recvAddr(3,bufSize,msgIndx) = -dstLocalID
06458
06459 end do
06460 end do
06461
06462 halo%sizeRecv(msgIndx) = bufSize
06463
06464 endif
06465
06466 case ('northwest')
06467
06468 if (dstBlock > 0) then
06469
06470
06471
06472
06473
06474 do j=1,nghost
06475 do i=1,nghost
06476
06477 bufSize = bufSize + 1
06478
06479 halo%recvAddr(1,bufSize,msgIndx) = ieDst + i
06480 halo%recvAddr(2,bufSize,msgIndx) = j
06481 halo%recvAddr(3,bufSize,msgIndx) = dstLocalID
06482
06483 end do
06484 end do
06485
06486 halo%sizeRecv(msgIndx) = bufSize
06487
06488 else
06489
06490
06491
06492 do j=1,halo%tripoleRows
06493 do i=1,ieSrc-ibSrc+1
06494
06495 bufSize = bufSize + 1
06496
06497 halo%recvAddr(1,bufSize,msgIndx) = iGlobal(ibSrc + i - 1)
06498 halo%recvAddr(2,bufSize,msgIndx) = j
06499 halo%recvAddr(3,bufSize,msgIndx) = -dstLocalID
06500
06501 end do
06502 end do
06503
06504 halo%sizeRecv(msgIndx) = bufSize
06505
06506 endif
06507
06508 case ('southeast')
06509
06510
06511
06512
06513 do j=1,nghost
06514 do i=1,nghost
06515
06516 bufSize = bufSize + 1
06517
06518 halo%recvAddr(1,bufSize,msgIndx) = i
06519 halo%recvAddr(2,bufSize,msgIndx) = jeDst + j
06520 halo%recvAddr(3,bufSize,msgIndx) = dstLocalID
06521
06522 end do
06523 end do
06524
06525 halo%sizeRecv(msgIndx) = bufSize
06526
06527 case ('southwest')
06528
06529
06530
06531
06532 do j=1,nghost
06533 do i=1,nghost
06534
06535 bufSize = bufSize + 1
06536
06537 halo%recvAddr(1,bufSize,msgIndx) = ieDst + i
06538 halo%recvAddr(2,bufSize,msgIndx) = jeDst + j
06539 halo%recvAddr(3,bufSize,msgIndx) = dstLocalID
06540
06541 end do
06542 end do
06543
06544 halo%sizeRecv(msgIndx) = bufSize
06545
06546 case default
06547
06548
06549
06550 end select
06551
06552
06553
06554
06555
06556
06557
06558
06559 endif
06560
06561
06562
06563
06564 end subroutine ice_HaloMsgCreate
06565
06566
06567
06568
06569
06570
06571 subroutine ice_HaloExtrapolate2DR8(ARRAY,dist,ew_bndy_type,ns_bndy_type)
06572
06573
06574
06575
06576
06577
06578
06579
06580
06581
06582
06583
06584
06585
06586
06587
06588
06589
06590 use ice_blocks
06591 use ice_constants
06592 use ice_distribution
06593
06594
06595
06596 character (char_len) ::
06597 ew_bndy_type,
06598 ns_bndy_type
06599
06600 type (distrb), intent(in) ::
06601 dist
06602
06603
06604
06605 real (dbl_kind), dimension(:,:,:), intent(inout) ::
06606 ARRAY
06607
06608
06609
06610
06611
06612
06613
06614
06615
06616 integer (int_kind) ::
06617 i,j,iblk,
06618 numBlocks,
06619 blockID,
06620 ibc,
06621 npad
06622
06623 type (block) ::
06624 this_block
06625
06626
06627
06628
06629
06630
06631
06632 call ice_distributionGet(dist, &
06633 numLocalBlocks = numBlocks)
06634
06635 do iblk = 1, numBlocks
06636 call ice_distributionGetBlockID(dist, iblk, blockID)
06637 this_block = get_block(blockID, blockID)
06638
06639 if (this_block%iblock == 1) then
06640 if (trim(ew_bndy_type) /= 'cyclic') then
06641 do j = 1, ny_block
06642 ARRAY(1,j,iblk) = c2*ARRAY(2,j,iblk) - ARRAY(3,j,iblk)
06643 enddo
06644 endif
06645
06646 elseif (this_block%iblock == nblocks_x) then
06647 if (trim(ew_bndy_type) /= 'cyclic') then
06648
06649 ibc = nx_block
06650 do i = nx_block, 1, - 1
06651 if (this_block%i_glob(i) == 0) ibc = ibc - 1
06652 enddo
06653 do j = 1, ny_block
06654 ARRAY(ibc,j,iblk) = c2*ARRAY(ibc-1,j,iblk) - ARRAY(ibc-2,j,iblk)
06655 enddo
06656 endif
06657 endif
06658
06659 if (this_block%jblock == 1) then
06660 if (trim(ns_bndy_type) /= 'cyclic') then
06661 do i = 1, nx_block
06662 ARRAY(i,1,iblk) = c2*ARRAY(i,2,iblk) - ARRAY(i,3,iblk)
06663 enddo
06664 endif
06665
06666 elseif (this_block%jblock == nblocks_y) then
06667 if (trim(ns_bndy_type) /= 'cyclic' .and. &
06668 trim(ns_bndy_type) /= 'tripole' .and. &
06669 trim(ns_bndy_type) /= 'tripoleT' ) then
06670
06671 ibc = ny_block
06672 do j = ny_block, 1, - 1
06673 if (this_block%j_glob(j) == 0) ibc = ibc - 1
06674 enddo
06675 do i = 1, nx_block
06676 ARRAY(i,ibc,iblk) = c2*ARRAY(i,ibc-1,iblk) - ARRAY(i,ibc-2,iblk)
06677 enddo
06678 endif
06679 endif
06680
06681 enddo
06682
06683
06684
06685 end subroutine ice_HaloExtrapolate2DR8
06686
06687
06688
06689 end module ice_boundary
06690
06691