| 1 | # define NAT_IN(k) cd_nat(k) |
|---|
| 2 | # define SGN_IN(k) psgn(k) |
|---|
| 3 | # define F_SIZE(ptab) kfld |
|---|
| 4 | # define OPT_K(k) ,ipf |
|---|
| 5 | # if defined DIM_2d |
|---|
| 6 | # if defined SINGLE_PRECISION |
|---|
| 7 | # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_sp) , INTENT(inout) :: ptab(f) |
|---|
| 8 | # else |
|---|
| 9 | # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_dp) , INTENT(inout) :: ptab(f) |
|---|
| 10 | # endif |
|---|
| 11 | # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt2d(i,j) |
|---|
| 12 | # define K_SIZE(ptab) 1 |
|---|
| 13 | # define L_SIZE(ptab) 1 |
|---|
| 14 | # endif |
|---|
| 15 | # if defined DIM_3d |
|---|
| 16 | # if defined SINGLE_PRECISION |
|---|
| 17 | # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_sp) , INTENT(inout) :: ptab(f) |
|---|
| 18 | # else |
|---|
| 19 | # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_dp) , INTENT(inout) :: ptab(f) |
|---|
| 20 | # endif |
|---|
| 21 | # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt3d(i,j,k) |
|---|
| 22 | # define K_SIZE(ptab) SIZE(ptab(1)%pt3d,3) |
|---|
| 23 | # define L_SIZE(ptab) 1 |
|---|
| 24 | # endif |
|---|
| 25 | # if defined DIM_4d |
|---|
| 26 | # if defined SINGLE_PRECISION |
|---|
| 27 | # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_sp) , INTENT(inout) :: ptab(f) |
|---|
| 28 | # else |
|---|
| 29 | # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_dp) , INTENT(inout) :: ptab(f) |
|---|
| 30 | # endif |
|---|
| 31 | # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt4d(i,j,k,l) |
|---|
| 32 | # define K_SIZE(ptab) SIZE(ptab(1)%pt4d,3) |
|---|
| 33 | # define L_SIZE(ptab) SIZE(ptab(1)%pt4d,4) |
|---|
| 34 | # endif |
|---|
| 35 | # if defined SINGLE_PRECISION |
|---|
| 36 | # define PRECISION sp |
|---|
| 37 | # define MPI_TYPE MPI_REAL |
|---|
| 38 | # else |
|---|
| 39 | # define PRECISION dp |
|---|
| 40 | # define MPI_TYPE MPI_DOUBLE_PRECISION |
|---|
| 41 | # endif |
|---|
| 42 | |
|---|
| 43 | SUBROUTINE ROUTINE_NC( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, lsend, lrecv, ncsten ) |
|---|
| 44 | INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays |
|---|
| 45 | ARRAY_TYPE(:,:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied |
|---|
| 46 | CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine |
|---|
| 47 | CHARACTER(len=1) , INTENT(in ) :: NAT_IN(:) ! nature of array grid-points |
|---|
| 48 | REAL(PRECISION) , INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary |
|---|
| 49 | INTEGER , OPTIONAL, INTENT(in ) :: kfillmode ! filling method for halo over land (default = constant) |
|---|
| 50 | REAL(PRECISION), OPTIONAL, INTENT(in ) :: pfillval ! background value (used at closed boundaries) |
|---|
| 51 | LOGICAL, DIMENSION(4),OPTIONAL, INTENT(in ) :: lsend, lrecv ! communication with other 4 proc |
|---|
| 52 | LOGICAL, OPTIONAL, INTENT(in ) :: ncsten ! 5-point or 9-point stencil |
|---|
| 53 | ! |
|---|
| 54 | INTEGER :: ji, jj, jk, jl, jf, jn ! dummy loop indices |
|---|
| 55 | INTEGER :: ipk, ipl, ipf ! dimension of the input array |
|---|
| 56 | INTEGER :: ip0i, ip1i, im0i, im1i |
|---|
| 57 | INTEGER :: ip0j, ip1j, im0j, im1j |
|---|
| 58 | INTEGER :: ishti, ishtj, ishti2, ishtj2 |
|---|
| 59 | INTEGER :: iszs, iszr |
|---|
| 60 | INTEGER :: ierr |
|---|
| 61 | INTEGER :: idx |
|---|
| 62 | INTEGER :: impi_nc |
|---|
| 63 | INTEGER, DIMENSION(4) :: iwewe, issnn |
|---|
| 64 | INTEGER, DIMENSION(8) :: isizei, ishtsi, ishtri, ishtpi |
|---|
| 65 | INTEGER, DIMENSION(8) :: isizej, ishtsj, ishtrj, ishtpj |
|---|
| 66 | INTEGER, DIMENSION(8) :: ifill, iszall |
|---|
| 67 | INTEGER, DIMENSION(:), ALLOCATABLE :: icounts, icountr ! number of elements to be sent/received |
|---|
| 68 | INTEGER, DIMENSION(:), ALLOCATABLE :: idispls, idisplr ! displacement in halos arrays |
|---|
| 69 | LOGICAL, DIMENSION(8) :: llsend, llrecv |
|---|
| 70 | REAL(PRECISION) :: zland |
|---|
| 71 | REAL(PRECISION), DIMENSION(:), ALLOCATABLE :: zsnd, zrcv ! halos arrays |
|---|
| 72 | LOGICAL :: llncall ! default: 9-point stencil |
|---|
| 73 | LOGICAL :: ll_IdoNFold |
|---|
| 74 | !!---------------------------------------------------------------------- |
|---|
| 75 | #if defined PRINT_CAUTION |
|---|
| 76 | ! |
|---|
| 77 | ! ================================================================================== ! |
|---|
| 78 | ! CAUTION: semi-column notation is often impossible because of the cpp preprocessing ! |
|---|
| 79 | ! ================================================================================== ! |
|---|
| 80 | ! |
|---|
| 81 | #endif |
|---|
| 82 | ! |
|---|
| 83 | ! ----------------------------------------- ! |
|---|
| 84 | ! 1. local variables initialization ! |
|---|
| 85 | ! ----------------------------------------- ! |
|---|
| 86 | ! |
|---|
| 87 | ipk = K_SIZE(ptab) ! 3rd dimension |
|---|
| 88 | ipl = L_SIZE(ptab) ! 4th - |
|---|
| 89 | ipf = F_SIZE(ptab) ! 5th - use in "multi" case (array of pointers) |
|---|
| 90 | ! |
|---|
| 91 | IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ipk, ipl, ipf, ld_lbc = .TRUE. ) |
|---|
| 92 | ! |
|---|
| 93 | ! take care of optional parameters |
|---|
| 94 | ! |
|---|
| 95 | llncall = .TRUE. |
|---|
| 96 | IF( PRESENT(ncsten) ) llncall = ncsten |
|---|
| 97 | ! |
|---|
| 98 | impi_nc = mpi_nc_com4 |
|---|
| 99 | IF(llncall) impi_nc = mpi_nc_com8 |
|---|
| 100 | ! |
|---|
| 101 | zland = 0._wp ! land filling value: zero by default |
|---|
| 102 | IF( PRESENT( pfillval ) ) zland = pfillval ! set land value |
|---|
| 103 | ! |
|---|
| 104 | ! define llsend and llrecv: logicals which say if mpi-neibourgs for send or receive exist or not. |
|---|
| 105 | IF ( PRESENT(lsend) .AND. PRESENT(lrecv) ) THEN ! localy defined neighbourgs |
|---|
| 106 | CALL ctl_stop( 'STOP', 'mpp_nc_generic+BDY not yet implemented') |
|---|
| 107 | !!$ ---> llsend(:) = lsend(:) ; llrecv(:) = lrecv(:) ??? |
|---|
| 108 | ELSE IF( PRESENT(lsend) .OR. PRESENT(lrecv) ) THEN |
|---|
| 109 | WRITE(ctmp1,*) ' Routine ', cdname, ' is calling lbc_lnk with only one of the two arguments lsend or lrecv' |
|---|
| 110 | CALL ctl_stop( 'STOP', ctmp1 ) |
|---|
| 111 | ELSE ! default neighbours |
|---|
| 112 | llsend(:) = mpinei(:) >= 0 |
|---|
| 113 | IF( .NOT. llncall ) llsend(5:8) = .FALSE. ! exclude corners |
|---|
| 114 | llrecv(:) = llsend(:) |
|---|
| 115 | END IF |
|---|
| 116 | ! |
|---|
| 117 | ! define ifill: which method should be used to fill each parts (sides+corners) of the halos |
|---|
| 118 | ! default definition |
|---|
| 119 | DO jn = 1, 8 |
|---|
| 120 | IF( llrecv(jn) ) THEN ; ifill(jn) = jpfillmpi ! with an mpi communication |
|---|
| 121 | ELSEIF( l_SelfPerio(jn) ) THEN ; ifill(jn) = jpfillperio ! with self-periodicity |
|---|
| 122 | ELSEIF( PRESENT(kfillmode) ) THEN ; ifill(jn) = kfillmode ! localy defined |
|---|
| 123 | ELSE ; ifill(jn) = jpfillcst ! constant value (zland) |
|---|
| 124 | END IF |
|---|
| 125 | END DO |
|---|
| 126 | ! take care of "indirect self-periodicity" for the corners |
|---|
| 127 | DO jn = 5, 8 |
|---|
| 128 | IF(.NOT.l_SelfPerio(jn) .AND. l_SelfPerio(jpwe)) ifill(jn) = jpfillnothing ! no bi-perio but ew-perio: do corners later |
|---|
| 129 | IF(.NOT.l_SelfPerio(jn) .AND. l_SelfPerio(jpso)) ifill(jn) = jpfillnothing ! no bi-perio but ns-perio: do corners later |
|---|
| 130 | END DO |
|---|
| 131 | ! north fold treatment |
|---|
| 132 | ll_IdoNFold = l_IdoNFold .AND. ifill(jpno) /= jpfillnothing |
|---|
| 133 | IF( ll_IdoNFold ) ifill( (/jpno,jpnw,jpne/) ) = jpfillnothing ! we do north fold -> do nothing for northern halos |
|---|
| 134 | |
|---|
| 135 | ! ! ________________________ |
|---|
| 136 | ip0i = 0 ! im0j = inner |__|________________|__| |
|---|
| 137 | ip1i = nn_hls ! im1j = inner - halo | |__|__________|__| | |
|---|
| 138 | im1i = Nie0-nn_hls ! | | | | | | |
|---|
| 139 | im0i = Nie0 ! | | | | | | |
|---|
| 140 | ip0j = 0 ! | | | | | | |
|---|
| 141 | ip1j = nn_hls ! | |__|__________|__| | |
|---|
| 142 | im1j = Nje0-nn_hls ! ip1j = halo |__|__|__________|__|__| |
|---|
| 143 | im0j = Nje0 ! ip0j = 0 |__|________________|__| |
|---|
| 144 | ! ! ip0i ip1i im1i im0i |
|---|
| 145 | ! |
|---|
| 146 | iwewe(:) = (/ jpwe,jpea,jpwe,jpea /) ; issnn(:) = (/ jpso,jpso,jpno,jpno /) |
|---|
| 147 | ! sides: west east south north ; corners: so-we, so-ea, no-we, no-ea |
|---|
| 148 | isizei(1:4) = (/ nn_hls, nn_hls, Ni_0, Ni_0 /) ; isizei(5:8) = nn_hls ! i- count |
|---|
| 149 | isizej(1:4) = (/ Nj_0, Nj_0, nn_hls, nn_hls /) ; isizej(5:8) = nn_hls ! j- count |
|---|
| 150 | ishtsi(1:4) = (/ ip1i, im1i, ip1i, ip1i /) ; ishtsi(5:8) = ishtsi( iwewe ) ! i- shift send data |
|---|
| 151 | ishtsj(1:4) = (/ ip1j, ip1j, ip1j, im1j /) ; ishtsj(5:8) = ishtsj( issnn ) ! j- shift send data |
|---|
| 152 | ishtri(1:4) = (/ ip0i, im0i, ip1i, ip1i /) ; ishtri(5:8) = ishtri( iwewe ) ! i- shift received data location |
|---|
| 153 | ishtrj(1:4) = (/ ip1j, ip1j, ip0j, im0j /) ; ishtrj(5:8) = ishtrj( issnn ) ! j- shift received data location |
|---|
| 154 | ishtpi(1:4) = (/ im1i, ip1i, ip1i, ip1i /) ; ishtpi(5:8) = ishtpi( iwewe ) ! i- shift data used for periodicity |
|---|
| 155 | ishtpj(1:4) = (/ ip1j, ip1j, im1j, ip1j /) ; ishtpj(5:8) = ishtpj( issnn ) ! j- shift data used for periodicity |
|---|
| 156 | ! |
|---|
| 157 | ! -------------------------------- ! |
|---|
| 158 | ! 2. Prepare MPI exchanges ! |
|---|
| 159 | ! -------------------------------- ! |
|---|
| 160 | ! |
|---|
| 161 | ! Allocate local temporary arrays to be sent/received. |
|---|
| 162 | iszs = COUNT( llsend ) |
|---|
| 163 | iszr = COUNT( llrecv ) |
|---|
| 164 | ALLOCATE( icounts(iszs), icountr(iszr), idispls(iszs), idisplr(iszr) ) ! ok if iszs = 0 or iszr = 0 |
|---|
| 165 | iszall(:) = isizei(:) * isizej(:) * ipk * ipl * ipf |
|---|
| 166 | icounts(:) = PACK( iszall, mask = llsend ) ! ok if mask = .false. |
|---|
| 167 | icountr(:) = PACK( iszall, mask = llrecv ) |
|---|
| 168 | idispls(1) = 0 |
|---|
| 169 | DO jn = 2,iszs |
|---|
| 170 | idispls(jn) = idispls(jn-1) + icounts(jn-1) ! with _alltoallv: in units of sendtype |
|---|
| 171 | END DO |
|---|
| 172 | idisplr(1) = 0 |
|---|
| 173 | DO jn = 2,iszr |
|---|
| 174 | idisplr(jn) = idisplr(jn-1) + icountr(jn-1) ! with _alltoallv: in units of sendtype |
|---|
| 175 | END DO |
|---|
| 176 | |
|---|
| 177 | ALLOCATE( zsnd(SUM(icounts)), zrcv(SUM(icountr)) ) |
|---|
| 178 | |
|---|
| 179 | ! fill sending buffer with ARRAY_IN |
|---|
| 180 | idx = 1 |
|---|
| 181 | DO jn = 1, 8 |
|---|
| 182 | IF( llsend(jn) ) THEN |
|---|
| 183 | ishti = ishtsi(jn) |
|---|
| 184 | ishtj = ishtsj(jn) |
|---|
| 185 | DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) |
|---|
| 186 | zsnd(idx) = ARRAY_IN(ishti+ji,ishtj+jj,jk,jl,jf) |
|---|
| 187 | idx = idx + 1 |
|---|
| 188 | END DO ; END DO ; END DO ; END DO ; END DO |
|---|
| 189 | END IF |
|---|
| 190 | END DO |
|---|
| 191 | ! |
|---|
| 192 | ! ------------------------------------------------ ! |
|---|
| 193 | ! 3. Do all MPI exchanges in 1 unique call ! |
|---|
| 194 | ! ------------------------------------------------ ! |
|---|
| 195 | ! |
|---|
| 196 | IF( ln_timing ) CALL tic_tac(.TRUE.) |
|---|
| 197 | CALL mpi_neighbor_alltoallv (zsnd, icounts, idispls, MPI_TYPE, zrcv, icountr, idisplr, MPI_TYPE, impi_nc, ierr) |
|---|
| 198 | IF( ln_timing ) CALL tic_tac(.FALSE.) |
|---|
| 199 | ! |
|---|
| 200 | ! ------------------------- ! |
|---|
| 201 | ! 4. Fill all halos ! |
|---|
| 202 | ! ------------------------- ! |
|---|
| 203 | ! |
|---|
| 204 | idx = 1 |
|---|
| 205 | DO jn = 1, 8 |
|---|
| 206 | ishti = ishtri(jn) |
|---|
| 207 | ishtj = ishtrj(jn) |
|---|
| 208 | SELECT CASE ( ifill(jn) ) |
|---|
| 209 | CASE ( jpfillnothing ) ! no filling |
|---|
| 210 | CASE ( jpfillmpi ) ! fill with data received by MPI |
|---|
| 211 | DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) |
|---|
| 212 | ARRAY_IN(ishti+ji,ishtj+jj,jk,jl,jf) = zrcv(idx) |
|---|
| 213 | idx = idx + 1 |
|---|
| 214 | END DO ; END DO ; END DO ; END DO ; END DO |
|---|
| 215 | CASE ( jpfillperio ) ! use periodicity |
|---|
| 216 | ishti2 = ishtpi(jn) |
|---|
| 217 | ishtj2 = ishtpj(jn) |
|---|
| 218 | DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) |
|---|
| 219 | ARRAY_IN(ishti+ji,ishtj+jj,jk,jl,jf) = ARRAY_IN(ishti2+ji,ishtj2+jj,jk,jl,jf) |
|---|
| 220 | END DO ; END DO ; END DO ; END DO ; END DO |
|---|
| 221 | CASE ( jpfillcopy ) ! filling with inner domain values |
|---|
| 222 | ishti2 = ishtsi(jn) |
|---|
| 223 | ishtj2 = ishtsj(jn) |
|---|
| 224 | DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) |
|---|
| 225 | ARRAY_IN(ishti+ji,ishtj+jj,jk,jl,jf) = ARRAY_IN(ishti2+ji,ishtj2+jj,jk,jl,jf) |
|---|
| 226 | END DO ; END DO ; END DO ; END DO ; END DO |
|---|
| 227 | CASE ( jpfillcst ) ! filling with constant value |
|---|
| 228 | DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) |
|---|
| 229 | ARRAY_IN(ishti+ji,ishtj+jj,jk,jl,jf) = zland |
|---|
| 230 | END DO ; END DO ; END DO ; END DO ; END DO |
|---|
| 231 | END SELECT |
|---|
| 232 | END DO |
|---|
| 233 | |
|---|
| 234 | DEALLOCATE( icounts, icountr, idispls, idisplr, zsnd, zrcv ) |
|---|
| 235 | |
|---|
| 236 | ! potential "indirect self-periodicity" for the corners |
|---|
| 237 | DO jn = 5, 8 |
|---|
| 238 | IF( .NOT. l_SelfPerio(jn) .AND. l_SelfPerio(jpwe) ) THEN ! no bi-perio but ew-perio: corners indirect definition |
|---|
| 239 | ishti = ishtri(jn) |
|---|
| 240 | ishtj = ishtrj(jn) |
|---|
| 241 | ishti2 = ishtpi(jn) ! use i- shift periodicity |
|---|
| 242 | ishtj2 = ishtrj(jn) ! use j- shift recv location: use ew-perio -> ok as filling of the south and north halos now done |
|---|
| 243 | DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) |
|---|
| 244 | ARRAY_IN(ishti+ji,ishtj+jj,jk,jl,jf) = ARRAY_IN(ishti2+ji,ishtj2+jj,jk,jl,jf) |
|---|
| 245 | END DO ; END DO ; END DO ; END DO ; END DO |
|---|
| 246 | ENDIF |
|---|
| 247 | IF( .NOT. l_SelfPerio(jn) .AND. l_SelfPerio(jpso) ) THEN ! no bi-perio but ns-perio: corners indirect definition |
|---|
| 248 | ishti = ishtri(jn) |
|---|
| 249 | ishtj = ishtrj(jn) |
|---|
| 250 | ishti2 = ishtri(jn) ! use i- shift recv location: use ns-perio -> ok as filling of the west and east halos now done |
|---|
| 251 | ishtj2 = ishtpj(jn) ! use j- shift periodicity |
|---|
| 252 | DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) |
|---|
| 253 | ARRAY_IN(ishti+ji,ishtj+jj,jk,jl,jf) = ARRAY_IN(ishti2+ji,ishtj2+jj,jk,jl,jf) |
|---|
| 254 | END DO ; END DO ; END DO ; END DO ; END DO |
|---|
| 255 | ENDIF |
|---|
| 256 | END DO |
|---|
| 257 | ! |
|---|
| 258 | ! ------------------------------- ! |
|---|
| 259 | ! 5. north fold treatment ! |
|---|
| 260 | ! ------------------------------- ! |
|---|
| 261 | ! |
|---|
| 262 | IF( ll_IdoNFold ) THEN |
|---|
| 263 | IF( jpni == 1 ) THEN ; CALL lbc_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) ) ! self NFold |
|---|
| 264 | ELSE ; CALL mpp_nfd( ptab, NAT_IN(:), SGN_IN(:), ifill(jpno), zland OPT_K(:) ) ! mpi NFold |
|---|
| 265 | ENDIF |
|---|
| 266 | ENDIF |
|---|
| 267 | |
|---|
| 268 | END SUBROUTINE ROUTINE_NC |
|---|
| 269 | |
|---|
| 270 | #undef PRECISION |
|---|
| 271 | #undef ARRAY_TYPE |
|---|
| 272 | #undef NAT_IN |
|---|
| 273 | #undef SGN_IN |
|---|
| 274 | #undef ARRAY_IN |
|---|
| 275 | #undef K_SIZE |
|---|
| 276 | #undef L_SIZE |
|---|
| 277 | #undef F_SIZE |
|---|
| 278 | #undef OPT_K |
|---|
| 279 | #undef MPI_TYPE |
|---|
