| 1 | |
|---|
| 2 | SUBROUTINE lbc_lnk_neicoll_/**/PRECISION( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, khls, lsend, lrecv, ld4only ) |
|---|
| 3 | CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine |
|---|
| 4 | TYPE(PTR_4d_/**/PRECISION), DIMENSION(:), INTENT(inout) :: ptab ! pointer of arrays on which apply the b.c. |
|---|
| 5 | CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: cd_nat ! nature of array grid-points |
|---|
| 6 | REAL(PRECISION), DIMENSION(:), INTENT(in ) :: psgn ! sign used across the north fold boundary |
|---|
| 7 | INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays |
|---|
| 8 | INTEGER , OPTIONAL, INTENT(in ) :: kfillmode ! filling method for halo over land (default = constant) |
|---|
| 9 | REAL(PRECISION), OPTIONAL, INTENT(in ) :: pfillval ! background value (used at closed boundaries) |
|---|
| 10 | INTEGER , OPTIONAL, INTENT(in ) :: khls ! halo size, default = nn_hls |
|---|
| 11 | LOGICAL, DIMENSION(4),OPTIONAL, INTENT(in ) :: lsend, lrecv ! communication with other 4 proc |
|---|
| 12 | LOGICAL, OPTIONAL, INTENT(in ) :: ld4only ! if .T., do only 4-neighbour comm (ignore corners) |
|---|
| 13 | ! |
|---|
| 14 | INTEGER :: ji, jj, jk , jl, jf, jn ! dummy loop indices |
|---|
| 15 | INTEGER :: ipi, ipj, ipk, ipl, ipf ! dimension of the input array |
|---|
| 16 | INTEGER :: ip0i, ip1i, im0i, im1i |
|---|
| 17 | INTEGER :: ip0j, ip1j, im0j, im1j |
|---|
| 18 | INTEGER :: ishti, ishtj, ishti2, ishtj2 |
|---|
| 19 | INTEGER :: iszS, iszR |
|---|
| 20 | INTEGER :: ierr |
|---|
| 21 | INTEGER :: ihls, idx |
|---|
| 22 | INTEGER :: impi_nc |
|---|
| 23 | INTEGER :: ifill_nfd |
|---|
| 24 | INTEGER, DIMENSION(4) :: iwewe, issnn |
|---|
| 25 | INTEGER, DIMENSION(8) :: isizei, ishtSi, ishtRi, ishtPi |
|---|
| 26 | INTEGER, DIMENSION(8) :: isizej, ishtSj, ishtRj, ishtPj |
|---|
| 27 | INTEGER, DIMENSION(8) :: ifill, iszall |
|---|
| 28 | INTEGER, DIMENSION(8) :: jnf |
|---|
| 29 | INTEGER, DIMENSION(:), ALLOCATABLE :: iScnt, iRcnt ! number of elements to be sent/received |
|---|
| 30 | INTEGER, DIMENSION(:), ALLOCATABLE :: iSdpl, iRdpl ! displacement in halos arrays |
|---|
| 31 | LOGICAL, DIMENSION(8) :: llsend, llrecv |
|---|
| 32 | REAL(PRECISION) :: zland |
|---|
| 33 | LOGICAL :: ll4only ! default: 8 neighbourgs |
|---|
| 34 | LOGICAL :: ll_IdoNFold |
|---|
| 35 | !!---------------------------------------------------------------------- |
|---|
| 36 | ! |
|---|
| 37 | ! ----------------------------------------- ! |
|---|
| 38 | ! 1. local variables initialization ! |
|---|
| 39 | ! ----------------------------------------- ! |
|---|
| 40 | ! |
|---|
| 41 | ipi = SIZE(ptab(1)%pt4d,1) |
|---|
| 42 | ipj = SIZE(ptab(1)%pt4d,2) |
|---|
| 43 | ipk = SIZE(ptab(1)%pt4d,3) |
|---|
| 44 | ipl = SIZE(ptab(1)%pt4d,4) |
|---|
| 45 | ipf = kfld |
|---|
| 46 | ! |
|---|
| 47 | IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ipk, ipl, ipf, ld_lbc = .TRUE. ) |
|---|
| 48 | ! |
|---|
| 49 | ! take care of optional parameters |
|---|
| 50 | ! |
|---|
| 51 | ihls = nn_hls ! default definition |
|---|
| 52 | IF( PRESENT( khls ) ) ihls = khls |
|---|
| 53 | IF( ihls > n_hlsmax ) THEN |
|---|
| 54 | WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with khls > n_hlsmax : ', khls, '>', n_hlsmax |
|---|
| 55 | CALL ctl_stop( 'STOP', ctmp1 ) |
|---|
| 56 | ENDIF |
|---|
| 57 | IF( ipi /= Ni_0+2*ihls ) THEN |
|---|
| 58 | WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with an input array which does not match ihls along i: ', ipi, ihls, Ni_0 |
|---|
| 59 | CALL ctl_stop( 'STOP', ctmp1 ) |
|---|
| 60 | ENDIF |
|---|
| 61 | IF( ipj /= Nj_0+2*ihls ) THEN |
|---|
| 62 | WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with an input array which does not match ihls along j:', ipj, ihls , Nj_0 |
|---|
| 63 | CALL ctl_stop( 'STOP', ctmp1 ) |
|---|
| 64 | ENDIF |
|---|
| 65 | ! |
|---|
| 66 | ll4only = .FALSE. ! default definition |
|---|
| 67 | IF( PRESENT(ld4only) ) ll4only = ld4only |
|---|
| 68 | ! |
|---|
| 69 | impi_nc = mpi_nc_com8(ihls) ! default |
|---|
| 70 | IF( ll4only ) impi_nc = mpi_nc_com4(ihls) |
|---|
| 71 | ! |
|---|
| 72 | zland = 0._wp ! land filling value: zero by default |
|---|
| 73 | IF( PRESENT( pfillval ) ) zland = pfillval ! set land value |
|---|
| 74 | ! |
|---|
| 75 | ! define llsend and llrecv: logicals which say if mpi-neibourgs for send or receive exist or not. |
|---|
| 76 | IF ( PRESENT(lsend) .AND. PRESENT(lrecv) ) THEN ! localy defined neighbourgs |
|---|
| 77 | CALL ctl_stop( 'STOP', 'mpp_nc_generic+BDY not yet implemented') |
|---|
| 78 | !!$ ---> llsend(:) = lsend(:) ; llrecv(:) = lrecv(:) ??? |
|---|
| 79 | ELSE IF( PRESENT(lsend) .OR. PRESENT(lrecv) ) THEN |
|---|
| 80 | WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with only one of the two arguments lsend or lrecv' |
|---|
| 81 | CALL ctl_stop( 'STOP', ctmp1 ) |
|---|
| 82 | ELSE ! default neighbours |
|---|
| 83 | llsend(:) = mpiSnei(ihls,:) >= 0 |
|---|
| 84 | IF( ll4only ) llsend(5:8) = .FALSE. ! exclude corners |
|---|
| 85 | llrecv(:) = mpiRnei(ihls,:) >= 0 |
|---|
| 86 | IF( ll4only ) llrecv(5:8) = .FALSE. ! exclude corners |
|---|
| 87 | ENDIF |
|---|
| 88 | ! |
|---|
| 89 | ! define ifill: which method should be used to fill each parts (sides+corners) of the halos |
|---|
| 90 | ! default definition |
|---|
| 91 | DO jn = 1, 8 |
|---|
| 92 | IF( llrecv(jn) ) THEN ; ifill(jn) = jpfillmpi ! with an mpi communication |
|---|
| 93 | ELSEIF( l_SelfPerio(jn) ) THEN ; ifill(jn) = jpfillperio ! with self-periodicity |
|---|
| 94 | ELSEIF( PRESENT(kfillmode) ) THEN ; ifill(jn) = kfillmode ! localy defined |
|---|
| 95 | ELSE ; ifill(jn) = jpfillcst ! constant value (zland) |
|---|
| 96 | ENDIF |
|---|
| 97 | END DO |
|---|
| 98 | ! take care of "indirect self-periodicity" for the corners |
|---|
| 99 | DO jn = 5, 8 |
|---|
| 100 | IF(.NOT.l_SelfPerio(jn) .AND. l_SelfPerio(jpwe)) ifill(jn) = jpfillnothing ! no bi-perio but ew-perio: do corners later |
|---|
| 101 | IF(.NOT.l_SelfPerio(jn) .AND. l_SelfPerio(jpso)) ifill(jn) = jpfillnothing ! no bi-perio but ns-perio: do corners later |
|---|
| 102 | END DO |
|---|
| 103 | ! north fold treatment |
|---|
| 104 | ll_IdoNFold = l_IdoNFold .AND. ifill(jpno) /= jpfillnothing |
|---|
| 105 | IF( ll_IdoNFold ) THEN |
|---|
| 106 | ifill_nfd = ifill(jpno) ! if we are here, this means llrecv(jpno) = .false. and l_SelfPerio(jpno) = .false. |
|---|
| 107 | ifill( (/jpno/) ) = jpfillnothing ! we do north fold -> do nothing for northern halo |
|---|
| 108 | ENDIF |
|---|
| 109 | |
|---|
| 110 | ! We first define the localization and size of the parts of the array that will be sent (s), received (r) |
|---|
| 111 | ! or used for periodocity (p). The localization is defined as "the bottom left corner - 1" in i and j directions. |
|---|
| 112 | ! This is a shift that will be applied later in the do loops to pick-up the appropriate part of the array |
|---|
| 113 | ! |
|---|
| 114 | ! all definitions bellow do not refer to N[ij][se]0 so we can use it with any local value of ihls |
|---|
| 115 | ! ! ________________________ |
|---|
| 116 | ip0i = 0 ! im0j = inner |__|________________|__| |
|---|
| 117 | ip1i = ihls ! im1j = inner - halo | |__|__________|__| | |
|---|
| 118 | im1i = ipi-2*ihls ! | | | | | | |
|---|
| 119 | im0i = ipi - ihls ! | | | | | | |
|---|
| 120 | ip0j = 0 ! | | | | | | |
|---|
| 121 | ip1j = ihls ! | |__|__________|__| | |
|---|
| 122 | im1j = ipj-2*ihls ! ip1j = halo |__|__|__________|__|__| |
|---|
| 123 | im0j = ipj - ihls ! ip0j = 0 |__|________________|__| |
|---|
| 124 | ! ! ip0i ip1i im1i im0i |
|---|
| 125 | ! |
|---|
| 126 | iwewe(:) = (/ jpwe,jpea,jpwe,jpea /) ; issnn(:) = (/ jpso,jpso,jpno,jpno /) |
|---|
| 127 | ! sides: west east south north ; corners: so-we, so-ea, no-we, no-ea |
|---|
| 128 | isizei(1:4) = (/ ihls, ihls, Ni_0, Ni_0 /) ; isizei(5:8) = ihls ! i- count |
|---|
| 129 | isizej(1:4) = (/ Nj_0, Nj_0, ihls, ihls /) ; isizej(5:8) = ihls ! j- count |
|---|
| 130 | ishtSi(1:4) = (/ ip1i, im1i, ip1i, ip1i /) ; ishtSi(5:8) = ishtSi( iwewe ) ! i- shift send data |
|---|
| 131 | ishtSj(1:4) = (/ ip1j, ip1j, ip1j, im1j /) ; ishtSj(5:8) = ishtSj( issnn ) ! j- shift send data |
|---|
| 132 | ishtRi(1:4) = (/ ip0i, im0i, ip1i, ip1i /) ; ishtRi(5:8) = ishtRi( iwewe ) ! i- shift received data location |
|---|
| 133 | ishtRj(1:4) = (/ ip1j, ip1j, ip0j, im0j /) ; ishtRj(5:8) = ishtRj( issnn ) ! j- shift received data location |
|---|
| 134 | ishtPi(1:4) = (/ im1i, ip1i, ip1i, ip1i /) ; ishtPi(5:8) = ishtPi( iwewe ) ! i- shift data used for periodicity |
|---|
| 135 | ishtPj(1:4) = (/ ip1j, ip1j, im1j, ip1j /) ; ishtPj(5:8) = ishtPj( issnn ) ! j- shift data used for periodicity |
|---|
| 136 | ! |
|---|
| 137 | ! -------------------------------- ! |
|---|
| 138 | ! 2. Prepare MPI exchanges ! |
|---|
| 139 | ! -------------------------------- ! |
|---|
| 140 | ! |
|---|
| 141 | ! Allocate local temporary arrays to be sent/received. |
|---|
| 142 | iszS = COUNT( llsend ) |
|---|
| 143 | iszR = COUNT( llrecv ) |
|---|
| 144 | ALLOCATE( iScnt(iszS), iRcnt(iszR), iSdpl(iszS), iRdpl(iszR) ) ! ok if iszS = 0 or iszR = 0 |
|---|
| 145 | iszall(:) = isizei(:) * isizej(:) * ipk * ipl * ipf |
|---|
| 146 | iScnt(:) = PACK( iszall, mask = llsend ) ! ok if mask = .false. |
|---|
| 147 | iRcnt(:) = PACK( iszall, mask = llrecv ) |
|---|
| 148 | iSdpl(1) = 0 |
|---|
| 149 | DO jn = 2,iszS |
|---|
| 150 | iSdpl(jn) = iSdpl(jn-1) + iScnt(jn-1) ! with _alltoallv: in units of sendtype |
|---|
| 151 | END DO |
|---|
| 152 | iRdpl(1) = 0 |
|---|
| 153 | DO jn = 2,iszR |
|---|
| 154 | iRdpl(jn) = iRdpl(jn-1) + iRcnt(jn-1) ! with _alltoallv: in units of sendtype |
|---|
| 155 | END DO |
|---|
| 156 | |
|---|
| 157 | ! Allocate buffer arrays to be sent/received if needed |
|---|
| 158 | iszS = SUM(iszall, mask = llsend) ! send buffer size |
|---|
| 159 | IF( ALLOCATED(BUFFSND) ) THEN |
|---|
| 160 | IF( SIZE(BUFFSND) < iszS ) DEALLOCATE(BUFFSND) ! send buffer is too small |
|---|
| 161 | ENDIF |
|---|
| 162 | IF( .NOT. ALLOCATED(BUFFSND) ) ALLOCATE( BUFFSND(iszS) ) |
|---|
| 163 | iszR = SUM(iszall, mask = llrecv) ! recv buffer size |
|---|
| 164 | IF( ALLOCATED(BUFFRCV) ) THEN |
|---|
| 165 | IF( SIZE(BUFFRCV) < iszR ) DEALLOCATE(BUFFRCV) ! recv buffer is too small |
|---|
| 166 | ENDIF |
|---|
| 167 | IF( .NOT. ALLOCATED(BUFFRCV) ) ALLOCATE( BUFFRCV(iszR) ) |
|---|
| 168 | |
|---|
| 169 | ! fill sending buffer with ptab(jf)%pt4d |
|---|
| 170 | idx = 1 |
|---|
| 171 | DO jn = 1, 8 |
|---|
| 172 | IF( llsend(jn) ) THEN |
|---|
| 173 | ishti = ishtSi(jn) |
|---|
| 174 | ishtj = ishtSj(jn) |
|---|
| 175 | DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) |
|---|
| 176 | BUFFSND(idx) = ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) |
|---|
| 177 | idx = idx + 1 |
|---|
| 178 | END DO ; END DO ; END DO ; END DO ; END DO |
|---|
| 179 | ENDIF |
|---|
| 180 | END DO |
|---|
| 181 | ! |
|---|
| 182 | ! ------------------------------------------------ ! |
|---|
| 183 | ! 3. Do all MPI exchanges in 1 unique call ! |
|---|
| 184 | ! ------------------------------------------------ ! |
|---|
| 185 | ! |
|---|
| 186 | IF( ln_timing ) CALL tic_tac(.TRUE.) |
|---|
| 187 | CALL mpi_neighbor_alltoallv (BUFFSND, iScnt, iSdpl, MPI_TYPE, BUFFRCV, iRcnt, iRdpl, MPI_TYPE, impi_nc, ierr) |
|---|
| 188 | IF( ln_timing ) CALL tic_tac(.FALSE.) |
|---|
| 189 | ! |
|---|
| 190 | ! ------------------------- ! |
|---|
| 191 | ! 4. Fill all halos ! |
|---|
| 192 | ! ------------------------- ! |
|---|
| 193 | ! |
|---|
| 194 | idx = 1 |
|---|
| 195 | ! MPI3 bug fix when domain decomposition has 2 columns/rows |
|---|
| 196 | IF (jpni .eq. 2) THEN |
|---|
| 197 | IF (jpnj .eq. 2) THEN |
|---|
| 198 | jnf(1:8) = (/ 2, 1, 4, 3, 8, 7, 6, 5 /) |
|---|
| 199 | ELSE |
|---|
| 200 | jnf(1:8) = (/ 2, 1, 3, 4, 6, 5, 8, 7 /) |
|---|
| 201 | ENDIF |
|---|
| 202 | ELSE |
|---|
| 203 | IF (jpnj .eq. 2) THEN |
|---|
| 204 | jnf(1:8) = (/ 1, 2, 4, 3, 7, 8, 5, 6 /) |
|---|
| 205 | ELSE |
|---|
| 206 | jnf(1:8) = (/ 1, 2, 3, 4, 5, 6, 7, 8 /) |
|---|
| 207 | ENDIF |
|---|
| 208 | ENDIF |
|---|
| 209 | |
|---|
| 210 | DO jn = 1, 8 |
|---|
| 211 | ishti = ishtRi(jnf(jn)) |
|---|
| 212 | ishtj = ishtRj(jnf(jn)) |
|---|
| 213 | SELECT CASE ( ifill(jnf(jn)) ) |
|---|
| 214 | CASE ( jpfillnothing ) ! no filling |
|---|
| 215 | CASE ( jpfillmpi ) ! fill with data received by MPI |
|---|
| 216 | DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jnf(jn)) ; DO ji = 1,isizei(jnf(jn)) |
|---|
| 217 | ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = BUFFRCV(idx) |
|---|
| 218 | idx = idx + 1 |
|---|
| 219 | END DO ; END DO ; END DO ; END DO ; END DO |
|---|
| 220 | CASE ( jpfillperio ) ! use periodicity |
|---|
| 221 | ishti2 = ishtPi(jnf(jn)) |
|---|
| 222 | ishtj2 = ishtPj(jnf(jn)) |
|---|
| 223 | DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jnf(jn)) ; DO ji = 1,isizei(jnf(jn)) |
|---|
| 224 | ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl) |
|---|
| 225 | END DO ; END DO ; END DO ; END DO ; END DO |
|---|
| 226 | CASE ( jpfillcopy ) ! filling with inner domain values |
|---|
| 227 | ishti2 = ishtSi(jnf(jn)) |
|---|
| 228 | ishtj2 = ishtSj(jnf(jn)) |
|---|
| 229 | DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jnf(jn)) ; DO ji = 1,isizei(jnf(jn)) |
|---|
| 230 | ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl) |
|---|
| 231 | END DO ; END DO ; END DO ; END DO ; END DO |
|---|
| 232 | CASE ( jpfillcst ) ! filling with constant value |
|---|
| 233 | DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jnf(jn)) ; DO ji = 1,isizei(jnf(jn)) |
|---|
| 234 | ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = zland |
|---|
| 235 | END DO ; END DO ; END DO ; END DO ; END DO |
|---|
| 236 | END SELECT |
|---|
| 237 | END DO |
|---|
| 238 | |
|---|
| 239 | DEALLOCATE( iScnt, iRcnt, iSdpl, iRdpl ) |
|---|
| 240 | IF( iszS > jpi*jpj ) DEALLOCATE(BUFFSND) ! blocking Send -> can directly deallocate |
|---|
| 241 | IF( iszR > jpi*jpj ) DEALLOCATE(BUFFRCV) ! blocking Recv -> can directly deallocate |
|---|
| 242 | |
|---|
| 243 | ! potential "indirect self-periodicity" for the corners |
|---|
| 244 | DO jn = 5, 8 |
|---|
| 245 | IF( .NOT. l_SelfPerio(jn) .AND. l_SelfPerio(jpwe) ) THEN ! no bi-perio but ew-perio: corners indirect definition |
|---|
| 246 | ishti = ishtRi(jn) |
|---|
| 247 | ishtj = ishtRj(jn) |
|---|
| 248 | ishti2 = ishtPi(jn) ! use i- shift periodicity |
|---|
| 249 | ishtj2 = ishtRj(jn) ! use j- shift recv location: use ew-perio -> ok as filling of the south and north halos now done |
|---|
| 250 | DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) |
|---|
| 251 | ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl) |
|---|
| 252 | END DO ; END DO ; END DO ; END DO ; END DO |
|---|
| 253 | ENDIF |
|---|
| 254 | IF( .NOT. l_SelfPerio(jn) .AND. l_SelfPerio(jpso) ) THEN ! no bi-perio but ns-perio: corners indirect definition |
|---|
| 255 | ishti = ishtRi(jn) |
|---|
| 256 | ishtj = ishtRj(jn) |
|---|
| 257 | ishti2 = ishtRi(jn) ! use i- shift recv location: use ns-perio -> ok as filling of the west and east halos now done |
|---|
| 258 | ishtj2 = ishtPj(jn) ! use j- shift periodicity |
|---|
| 259 | DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) |
|---|
| 260 | ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl) |
|---|
| 261 | END DO ; END DO ; END DO ; END DO ; END DO |
|---|
| 262 | ENDIF |
|---|
| 263 | END DO |
|---|
| 264 | ! |
|---|
| 265 | ! ------------------------------- ! |
|---|
| 266 | ! 5. north fold treatment ! |
|---|
| 267 | ! ------------------------------- ! |
|---|
| 268 | ! |
|---|
| 269 | IF( ll_IdoNFold ) THEN |
|---|
| 270 | IF( jpni == 1 ) THEN ; CALL lbc_nfd( ptab, cd_nat, psgn , ihls, ipf ) ! self NFold |
|---|
| 271 | ELSE ; CALL mpp_nfd( ptab, cd_nat, psgn, ifill_nfd, zland, ihls, ipf ) ! mpi NFold |
|---|
| 272 | ENDIF |
|---|
| 273 | ENDIF |
|---|
| 274 | ! |
|---|
| 275 | END SUBROUTINE lbc_lnk_neicoll_/**/PRECISION |
|---|
| 276 | |
|---|
