Changeset 15548 for NEMO/branches/2021/ticket2632_r14588_theta_sbcblk/src/OCE/LBC/lbc_lnk_neicoll_generic.h90
- Timestamp:
- 2021-11-28T18:59:49+01:00 (3 years ago)
- Location:
- NEMO/branches/2021/ticket2632_r14588_theta_sbcblk
- Files:
-
- 2 edited
-
. (modified) (1 prop)
-
src/OCE/LBC/lbc_lnk_neicoll_generic.h90 (modified) (8 diffs)
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2021/ticket2632_r14588_theta_sbcblk
- Property svn:externals
-
old new 9 9 10 10 # SETTE 11 ^/utils/CI/sette@14244 sette 11 ^/utils/CI/sette@HEAD sette 12
-
- Property svn:externals
-
NEMO/branches/2021/ticket2632_r14588_theta_sbcblk/src/OCE/LBC/lbc_lnk_neicoll_generic.h90
r14433 r15548 9 9 REAL(PRECISION), OPTIONAL, INTENT(in ) :: pfillval ! background value (used at closed boundaries) 10 10 INTEGER , OPTIONAL, INTENT(in ) :: khls ! halo size, default = nn_hls 11 LOGICAL, DIMENSION( 4),OPTIONAL, INTENT(in ) :: lsend, lrecv ! communication with other 4 proc11 LOGICAL, DIMENSION(8),OPTIONAL, INTENT(in ) :: lsend, lrecv ! communication with other 4 proc 12 12 LOGICAL, OPTIONAL, INTENT(in ) :: ld4only ! if .T., do only 4-neighbour comm (ignore corners) 13 13 ! … … 26 26 INTEGER, DIMENSION(8) :: isizej, ishtSj, ishtRj, ishtPj 27 27 INTEGER, DIMENSION(8) :: ifill, iszall 28 INTEGER, DIMENSION(8) :: jnf 28 29 INTEGER, DIMENSION(:), ALLOCATABLE :: iScnt, iRcnt ! number of elements to be sent/received 29 30 INTEGER, DIMENSION(:), ALLOCATABLE :: iSdpl, iRdpl ! displacement in halos arrays … … 31 32 REAL(PRECISION) :: zland 32 33 LOGICAL :: ll4only ! default: 8 neighbourgs 33 LOGICAL :: ll_IdoNFold34 34 !!---------------------------------------------------------------------- 35 35 ! … … 74 74 ! define llsend and llrecv: logicals which say if mpi-neibourgs for send or receive exist or not. 75 75 IF ( PRESENT(lsend) .AND. PRESENT(lrecv) ) THEN ! localy defined neighbourgs 76 CALL ctl_stop( 'STOP', 'mpp_nc_generic+BDY not yet implemented') 77 !!$ ---> llsend(:) = lsend(:) ; llrecv(:) = lrecv(:) ??? 76 CALL ctl_stop( 'STOP', 'mpp_nc_generic+lsend and lrecv not yet implemented') 78 77 ELSE IF( PRESENT(lsend) .OR. PRESENT(lrecv) ) THEN 79 78 WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with only one of the two arguments lsend or lrecv' … … 101 100 END DO 102 101 ! north fold treatment 103 ll_IdoNFold = l_IdoNFold .AND. ifill(jpno) /= jpfillnothing 104 IF( ll_IdoNFold ) THEN 102 IF( l_IdoNFold ) THEN 105 103 ifill_nfd = ifill(jpno) ! if we are here, this means llrecv(jpno) = .false. and l_SelfPerio(jpno) = .false. 106 104 ifill( (/jpno/) ) = jpfillnothing ! we do north fold -> do nothing for northern halo … … 145 143 iScnt(:) = PACK( iszall, mask = llsend ) ! ok if mask = .false. 146 144 iRcnt(:) = PACK( iszall, mask = llrecv ) 147 iSdpl(1) = 0145 IF( iszS > 0 ) iSdpl(1) = 0 148 146 DO jn = 2,iszS 149 147 iSdpl(jn) = iSdpl(jn-1) + iScnt(jn-1) ! with _alltoallv: in units of sendtype 150 148 END DO 151 iRdpl(1) = 0149 IF( iszR > 0 ) iRdpl(1) = 0 152 150 DO jn = 2,iszR 153 151 iRdpl(jn) = iRdpl(jn-1) + iRcnt(jn-1) ! with _alltoallv: in units of sendtype … … 192 190 ! 193 191 idx = 1 192 ! MPI3 bug fix when domain decomposition has 2 columns/rows 193 IF (jpni .eq. 2) THEN 194 IF (jpnj .eq. 2) THEN 195 jnf(1:8) = (/ 2, 1, 4, 3, 8, 7, 6, 5 /) 196 ELSE 197 jnf(1:8) = (/ 2, 1, 3, 4, 6, 5, 8, 7 /) 198 ENDIF 199 ELSE 200 IF (jpnj .eq. 2) THEN 201 jnf(1:8) = (/ 1, 2, 4, 3, 7, 8, 5, 6 /) 202 ELSE 203 jnf(1:8) = (/ 1, 2, 3, 4, 5, 6, 7, 8 /) 204 ENDIF 205 ENDIF 206 194 207 DO jn = 1, 8 195 ishti = ishtRi(jn )196 ishtj = ishtRj(jn )197 SELECT CASE ( ifill(jn ) )208 ishti = ishtRi(jnf(jn)) 209 ishtj = ishtRj(jnf(jn)) 210 SELECT CASE ( ifill(jnf(jn)) ) 198 211 CASE ( jpfillnothing ) ! no filling 199 212 CASE ( jpfillmpi ) ! fill with data received by MPI 200 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn ) ; DO ji = 1,isizei(jn)213 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jnf(jn)) ; DO ji = 1,isizei(jnf(jn)) 201 214 ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = BUFFRCV(idx) 202 215 idx = idx + 1 203 216 END DO ; END DO ; END DO ; END DO ; END DO 204 217 CASE ( jpfillperio ) ! use periodicity 205 ishti2 = ishtPi(jn )206 ishtj2 = ishtPj(jn )207 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn ) ; DO ji = 1,isizei(jn)218 ishti2 = ishtPi(jnf(jn)) 219 ishtj2 = ishtPj(jnf(jn)) 220 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jnf(jn)) ; DO ji = 1,isizei(jnf(jn)) 208 221 ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl) 209 222 END DO ; END DO ; END DO ; END DO ; END DO 210 223 CASE ( jpfillcopy ) ! filling with inner domain values 211 ishti2 = ishtSi(jn )212 ishtj2 = ishtSj(jn )213 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn ) ; DO ji = 1,isizei(jn)224 ishti2 = ishtSi(jnf(jn)) 225 ishtj2 = ishtSj(jnf(jn)) 226 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jnf(jn)) ; DO ji = 1,isizei(jnf(jn)) 214 227 ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl) 215 228 END DO ; END DO ; END DO ; END DO ; END DO 216 229 CASE ( jpfillcst ) ! filling with constant value 217 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn ) ; DO ji = 1,isizei(jn)230 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jnf(jn)) ; DO ji = 1,isizei(jnf(jn)) 218 231 ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = zland 219 232 END DO ; END DO ; END DO ; END DO ; END DO … … 251 264 ! ------------------------------- ! 252 265 ! 253 IF( l l_IdoNFold ) THEN266 IF( l_IdoNFold ) THEN 254 267 IF( jpni == 1 ) THEN ; CALL lbc_nfd( ptab, cd_nat, psgn , ihls, ipf ) ! self NFold 255 268 ELSE ; CALL mpp_nfd( ptab, cd_nat, psgn, ifill_nfd, zland, ihls, ipf ) ! mpi NFold
Note: See TracChangeset
for help on using the changeset viewer.
