Changeset 14363 for NEMO/branches/2021/dev_r14312_MPI_Interface/src/OCE/LBC/lbc_lnk_pt2pt_generic.h90
- Timestamp:
- 2021-02-01T08:34:52+01:00 (3 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2021/dev_r14312_MPI_Interface/src/OCE/LBC/lbc_lnk_pt2pt_generic.h90
r14349 r14363 1 1 2 SUBROUTINE lbc_lnk_pt2pt_/**/PRECISION( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, lsend, lrecv )2 SUBROUTINE lbc_lnk_pt2pt_/**/PRECISION( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, khls, lsend, lrecv ) 3 3 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine 4 4 TYPE(PTR_4d_/**/PRECISION), DIMENSION(:), INTENT(inout) :: ptab ! pointer of arrays on which apply the b.c. … … 8 8 INTEGER , OPTIONAL, INTENT(in ) :: kfillmode ! filling method for halo over land (default = constant) 9 9 REAL(PRECISION), OPTIONAL, INTENT(in ) :: pfillval ! background value (used at closed boundaries) 10 INTEGER , OPTIONAL, INTENT(in ) :: khls ! halo size, default = nn_hls 10 11 LOGICAL, DIMENSION(4),OPTIONAL, INTENT(in ) :: lsend, lrecv ! communication with other 4 proc 11 12 ! 12 INTEGER :: ji, jj, jk, jl, jf, jn! dummy loop indices13 INTEGER :: ipk, ipl, ipf! dimension of the input array13 INTEGER :: ji, jj, jk, jl, jf, jn ! dummy loop indices 14 INTEGER :: ipi, ipj, ipk, ipl, ipf ! dimension of the input array 14 15 INTEGER :: ip0i, ip1i, im0i, im1i 15 16 INTEGER :: ip0j, ip1j, im0j, im1j 16 17 INTEGER :: ishti, ishtj, ishti2, ishtj2 17 18 INTEGER :: ifill_nfd, icomm, ierr 18 INTEGER :: i dxs, idxr19 INTEGER, DIMENSION(4) :: isizei, isht si, ishtri, ishtpi20 INTEGER, DIMENSION(4) :: isizej, isht sj, ishtrj, ishtpj21 INTEGER, DIMENSION(4) :: ifill, iszall, isht s, ishtr19 INTEGER :: ihls, idxs, idxr 20 INTEGER, DIMENSION(4) :: isizei, ishtSi, ishtRi, ishtPi 21 INTEGER, DIMENSION(4) :: isizej, ishtSj, ishtRj, ishtPj 22 INTEGER, DIMENSION(4) :: ifill, iszall, ishtS, ishtR 22 23 INTEGER, DIMENSION(4) :: ireq ! mpi_request id 23 24 REAL(PRECISION) :: zland … … 31 32 ! ----------------------------------------- ! 32 33 ! 34 ipi = SIZE(ptab(1)%pt4d,1) 35 ipj = SIZE(ptab(1)%pt4d,2) 33 36 ipk = SIZE(ptab(1)%pt4d,3) 34 37 ipl = SIZE(ptab(1)%pt4d,4) … … 38 41 ! 39 42 ! take care of optional parameters 43 ! 44 ihls = nn_hls ! default definition 45 IF( PRESENT( khls ) ) ihls = khls 46 IF( ihls > n_hlsmax ) THEN 47 WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with khls > n_hlsmax : ', khls, '>', n_hlsmax 48 CALL ctl_stop( 'STOP', ctmp1 ) 49 ENDIF 50 IF( ipi /= Ni_0+2*ihls ) THEN 51 WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with an input array which does not match ihls along i: ', ipi, ihls, Ni_0 52 CALL ctl_stop( 'STOP', ctmp1 ) 53 ENDIF 54 IF( ipj /= Nj_0+2*ihls ) THEN 55 WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with an input array which does not match ihls along j:', ipj, ihls , Nj_0 56 CALL ctl_stop( 'STOP', ctmp1 ) 57 ENDIF 40 58 ! 41 59 zland = 0._wp ! land filling value: zero by default … … 46 64 llsend(1:4) = lsend(1:4) ; llrecv(1:4) = lrecv(1:4) 47 65 ELSE IF( PRESENT(lsend) .OR. PRESENT(lrecv) ) THEN 48 WRITE(ctmp1,*) ' Routine ', cdname, 'is calling lbc_lnk with only one of the two arguments lsend or lrecv'66 WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with only one of the two arguments lsend or lrecv' 49 67 CALL ctl_stop( 'STOP', ctmp1 ) 50 68 ELSE ! default neighbours 51 llsend( 1:4) = mpinei(1:4) >= 052 llrecv(:) = llsend(:)69 llsend(:) = mpiSnei(ihls,1:4) >= 0 70 llrecv(:) = mpiRnei(ihls,1:4) >= 0 53 71 END IF 54 72 ! … … 72 90 ! or used for periodocity (p). The localization is defined as "the bottom left corner - 1" in i and j directions. 73 91 ! This is a shift that will be applied later in the do loops to pick-up the appropriate part of the array 74 ! ! ________________________ 75 ip0i = 0 ! im0j = inner |__|__|__________|__|__| 76 ip1i = nn_hls ! im1j = inner - halo |__|__|__________|__|__| 77 im1i = Nie0-nn_hls ! | | | | | | 78 im0i = Nie0 ! | | | | | | 79 ip0j = 0 ! | | | | | | 80 ip1j = nn_hls ! |__|__|__________|__|__| 81 im1j = Nje0-nn_hls ! ip1j = halo |__|__|__________|__|__| 82 im0j = Nje0 ! ip0j = 0 |__|__|__________|__|__| 83 ! ! ip0i ip1i im1i im0i 84 ! 85 ! sides: west east south north 86 isizei(1:4) = (/ nn_hls, nn_hls, jpi, jpi /) ! i- count 87 isizej(1:4) = (/ jpj, jpj, nn_hls, nn_hls /) ! j- count 88 ishtsi(1:4) = (/ ip1i, im1i, ip0i, ip0i /) ! i- shift send data 89 ishtsj(1:4) = (/ ip0j, ip0j, ip1j, im1j /) ! j- shift send data 90 ishtri(1:4) = (/ ip0i, im0i, ip0i, ip0i /) ! i- shift received data location 91 ishtrj(1:4) = (/ ip0j, ip0j, ip0j, im0j /) ! j- shift received data location 92 ishtpi(1:4) = (/ im1i, ip1i, ip0i, ip0i /) ! i- shift data used for periodicity 93 ishtpj(1:4) = (/ ip0j, ip0j, im1j, ip1j /) ! j- shift data used for periodicity 92 ! 93 ! all definitions bellow do not refer to N[ij][se]0 so we can use it with any local value of ihls 94 ! ! ________________________ 95 ip0i = 0 ! im0j = inner |__|__|__________|__|__| 96 ip1i = ihls ! im1j = inner - halo |__|__|__________|__|__| 97 im1i = ipi-2*ihls ! | | | | | | 98 im0i = ipi - ihls ! | | | | | | 99 ip0j = 0 ! | | | | | | 100 ip1j = ihls ! |__|__|__________|__|__| 101 im1j = ipj-2*ihls ! ip1j = halo |__|__|__________|__|__| 102 im0j = ipj - ihls ! ip0j = 0 |__|__|__________|__|__| 103 ! ! ip0i ip1i im1i im0i 104 ! 105 ! sides: west east south north 106 isizei(1:4) = (/ ihls, ihls, ipi, ipi /) ! i- count 107 isizej(1:4) = (/ ipj, ipj, ihls, ihls /) ! j- count 108 ishtSi(1:4) = (/ ip1i, im1i, ip0i, ip0i /) ! i- shift send data 109 ishtSj(1:4) = (/ ip0j, ip0j, ip1j, im1j /) ! j- shift send data 110 ishtRi(1:4) = (/ ip0i, im0i, ip0i, ip0i /) ! i- shift received data location 111 ishtRj(1:4) = (/ ip0j, ip0j, ip0j, im0j /) ! j- shift received data location 112 ishtPi(1:4) = (/ im1i, ip1i, ip0i, ip0i /) ! i- shift data used for periodicity 113 ishtPj(1:4) = (/ ip0j, ip0j, im1j, ip1j /) ! j- shift data used for periodicity 94 114 ! 95 115 ! -------------------------------- ! … … 99 119 ireq(:) = MPI_REQUEST_NULL 100 120 iszall(:) = isizei(:) * isizej(:) * ipk * ipl * ipf 101 isht s(1) = 0121 ishtS(1) = 0 102 122 DO jn = 2,4 103 isht s(jn) = ishts(jn-1) + iszall(jn-1) * COUNT( (/llsend(jn-1)/) ) ! with _alltoallv: in units of sendtype104 END DO 105 isht r(1) = 0123 ishtS(jn) = ishtS(jn-1) + iszall(jn-1) * COUNT( (/llsend(jn-1)/) ) ! with _alltoallv: in units of sendtype 124 END DO 125 ishtR(1) = 0 106 126 DO jn = 2,4 107 isht r(jn) = ishtr(jn-1) + iszall(jn-1) * COUNT( (/llrecv(jn-1)/) ) ! with _alltoallv: in units of sendtype127 ishtR(jn) = ishtR(jn-1) + iszall(jn-1) * COUNT( (/llrecv(jn-1)/) ) ! with _alltoallv: in units of sendtype 108 128 END DO 109 129 … … 119 139 DO jn = 1, 2 120 140 IF( llsend(jn) ) THEN 121 ishti = isht si(jn)122 ishtj = isht sj(jn)141 ishti = ishtSi(jn) 142 ishtj = ishtSj(jn) 123 143 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) 124 144 zsnd(idxs) = ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) … … 134 154 ! non-blocking send of the western/eastern side using local temporary arrays 135 155 jn = jpwe 136 IF( llsend(jn) ) CALL MPI_ISEND( zsnd(isht s(jn)+1), iszall(jn), MPI_TYPE, mpinei(jn), 1, icomm, ireq(jn), ierr )156 IF( llsend(jn) ) CALL MPI_ISEND( zsnd(ishtS(jn)+1), iszall(jn), MPI_TYPE, mpiSnei(ihls,jn), 1, icomm, ireq(jn), ierr ) 137 157 jn = jpea 138 IF( llsend(jn) ) CALL MPI_ISEND( zsnd(isht s(jn)+1), iszall(jn), MPI_TYPE, mpinei(jn), 2, icomm, ireq(jn), ierr )158 IF( llsend(jn) ) CALL MPI_ISEND( zsnd(ishtS(jn)+1), iszall(jn), MPI_TYPE, mpiSnei(ihls,jn), 2, icomm, ireq(jn), ierr ) 139 159 ! blocking receive of the western/eastern halo in local temporary arrays 140 160 jn = jpwe 141 IF( llrecv(jn) ) CALL MPI_RECV( zrcv(isht r(jn)+1), iszall(jn), MPI_TYPE, mpinei(jn), 2, icomm, MPI_STATUS_IGNORE, ierr )161 IF( llrecv(jn) ) CALL MPI_RECV( zrcv(ishtR(jn)+1), iszall(jn), MPI_TYPE, mpiRnei(ihls,jn), 2, icomm, MPI_STATUS_IGNORE, ierr ) 142 162 jn = jpea 143 IF( llrecv(jn) ) CALL MPI_RECV( zrcv(isht r(jn)+1), iszall(jn), MPI_TYPE, mpinei(jn), 1, icomm, MPI_STATUS_IGNORE, ierr )163 IF( llrecv(jn) ) CALL MPI_RECV( zrcv(ishtR(jn)+1), iszall(jn), MPI_TYPE, mpiRnei(ihls,jn), 1, icomm, MPI_STATUS_IGNORE, ierr ) 144 164 ! 145 165 IF( ln_timing ) CALL tic_tac(.FALSE.) … … 152 172 idxr = 1 153 173 DO jn = 1, 2 154 ishti = isht ri(jn)155 ishtj = isht rj(jn)174 ishti = ishtRi(jn) 175 ishtj = ishtRj(jn) 156 176 SELECT CASE ( ifill(jn) ) 157 177 CASE ( jpfillnothing ) ! no filling … … 162 182 END DO ; END DO ; END DO ; END DO ; END DO 163 183 CASE ( jpfillperio ) ! use periodicity 164 ishti2 = isht pi(jn)165 ishtj2 = isht pj(jn)184 ishti2 = ishtPi(jn) 185 ishtj2 = ishtPj(jn) 166 186 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) 167 187 ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl) 168 188 END DO ; END DO ; END DO ; END DO ; END DO 169 189 CASE ( jpfillcopy ) ! filling with inner domain values 170 ishti2 = isht si(jn)171 ishtj2 = isht sj(jn)190 ishti2 = ishtSi(jn) 191 ishtj2 = ishtSj(jn) 172 192 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) 173 193 ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl) … … 187 207 ! 188 208 IF( ll_IdoNFold ) THEN 189 IF( jpni == 1 ) THEN ; CALL lbc_nfd( ptab, cd_nat, psgn , i pf ) ! self NFold190 ELSE ; CALL mpp_nfd( ptab, cd_nat, psgn, ifill_nfd, zland, i pf ) ! mpi NFold209 IF( jpni == 1 ) THEN ; CALL lbc_nfd( ptab, cd_nat, psgn , ihls, ipf ) ! self NFold 210 ELSE ; CALL mpp_nfd( ptab, cd_nat, psgn, ifill_nfd, zland, ihls, ipf ) ! mpi NFold 191 211 ENDIF 192 212 ENDIF … … 198 218 DO jn = 3, 4 199 219 IF( llsend(jn) ) THEN 200 ishti = isht si(jn)201 ishtj = isht sj(jn)220 ishti = ishtSi(jn) 221 ishtj = ishtSj(jn) 202 222 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) 203 223 zsnd(idxs) = ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) … … 212 232 ! non-blocking send of the western/eastern side using local temporary arrays 213 233 jn = jpso 214 IF( llsend(jn) ) CALL MPI_ISEND( zsnd(isht s(jn)+1), iszall(jn), MPI_TYPE, mpinei(jn), 3, icomm, ireq(jn), ierr )234 IF( llsend(jn) ) CALL MPI_ISEND( zsnd(ishtS(jn)+1), iszall(jn), MPI_TYPE, mpiSnei(ihls,jn), 3, icomm, ireq(jn), ierr ) 215 235 jn = jpno 216 IF( llsend(jn) ) CALL MPI_ISEND( zsnd(isht s(jn)+1), iszall(jn), MPI_TYPE, mpinei(jn), 4, icomm, ireq(jn), ierr )236 IF( llsend(jn) ) CALL MPI_ISEND( zsnd(ishtS(jn)+1), iszall(jn), MPI_TYPE, mpiSnei(ihls,jn), 4, icomm, ireq(jn), ierr ) 217 237 ! blocking receive of the western/eastern halo in local temporary arrays 218 238 jn = jpso 219 IF( llrecv(jn) ) CALL MPI_RECV( zrcv(isht r(jn)+1), iszall(jn), MPI_TYPE, mpinei(jn), 4, icomm, MPI_STATUS_IGNORE, ierr )239 IF( llrecv(jn) ) CALL MPI_RECV( zrcv(ishtR(jn)+1), iszall(jn), MPI_TYPE, mpiRnei(ihls,jn), 4, icomm, MPI_STATUS_IGNORE, ierr ) 220 240 jn = jpno 221 IF( llrecv(jn) ) CALL MPI_RECV( zrcv(isht r(jn)+1), iszall(jn), MPI_TYPE, mpinei(jn), 3, icomm, MPI_STATUS_IGNORE, ierr )241 IF( llrecv(jn) ) CALL MPI_RECV( zrcv(ishtR(jn)+1), iszall(jn), MPI_TYPE, mpiRnei(ihls,jn), 3, icomm, MPI_STATUS_IGNORE, ierr ) 222 242 ! 223 243 IF( ln_timing ) CALL tic_tac(.FALSE.) … … 229 249 ! 230 250 DO jn = 3, 4 231 ishti = isht ri(jn)232 ishtj = isht rj(jn)251 ishti = ishtRi(jn) 252 ishtj = ishtRj(jn) 233 253 SELECT CASE ( ifill(jn) ) 234 254 CASE ( jpfillnothing ) ! no filling … … 239 259 END DO ; END DO ; END DO ; END DO ; END DO 240 260 CASE ( jpfillperio ) ! use periodicity 241 ishti2 = isht pi(jn)242 ishtj2 = isht pj(jn)261 ishti2 = ishtPi(jn) 262 ishtj2 = ishtPj(jn) 243 263 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) 244 264 ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl) 245 265 END DO ; END DO ; END DO ; END DO ; END DO 246 266 CASE ( jpfillcopy ) ! filling with inner domain values 247 ishti2 = isht si(jn)248 ishtj2 = isht sj(jn)267 ishti2 = ishtSi(jn) 268 ishtj2 = ishtSj(jn) 249 269 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) 250 270 ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl)
Note: See TracChangeset
for help on using the changeset viewer.
