Changeset 15267 for NEMO/trunk/src/OCE/LBC/mpp_nfd_generic.h90
- Timestamp:
- 2021-09-17T11:04:34+02:00 (3 years ago)
- File:
-
- 1 edited
-
NEMO/trunk/src/OCE/LBC/mpp_nfd_generic.h90 (modified) (7 diffs)
Legend:
- Unmodified
- Added
- Removed
-
NEMO/trunk/src/OCE/LBC/mpp_nfd_generic.h90
r14433 r15267 10 10 ! 11 11 LOGICAL :: ll_add_line 12 INTEGER :: ji, jj, jk, jl, j h, jf, jr! dummy loop indices12 INTEGER :: ji, jj, jk, jl, jf, jr, jg, jn ! dummy loop indices 13 13 INTEGER :: ipi, ipj, ipj2, ipk, ipl, ipf ! dimension of the input array 14 INTEGER :: imigr, iihom, ijhom ! local integers15 14 INTEGER :: ierr, ibuffsize, iis0, iie0, impp 16 INTEGER :: ii1, ii2, ij1, ij2 17 INTEGER :: i pimax, i0max15 INTEGER :: ii1, ii2, ij1, ij2, iis, iie, iib, iig, iin 16 INTEGER :: i0max 18 17 INTEGER :: ij, iproc, ipni, ijnr 19 INTEGER, DIMENSION (jpmaxngh) :: ml_req_nf ! for mpi_isend when avoiding mpi_allgather 20 INTEGER :: ml_err ! for mpi_isend when avoiding mpi_allgather 21 ! ! Workspace for message transfers avoiding mpi_allgather 22 INTEGER :: ipj_b ! sum of lines for all multi fields 23 INTEGER :: i012 ! 0, 1 or 2 24 INTEGER , DIMENSION(:,:) , ALLOCATABLE :: jj_s ! position of sent lines 25 INTEGER , DIMENSION(:,:) , ALLOCATABLE :: jj_b ! position of buffer lines 26 INTEGER , DIMENSION(:) , ALLOCATABLE :: ipj_s ! number of sent lines 27 REAL(PRECISION), DIMENSION(:,:,:,:) , ALLOCATABLE :: ztabb, ztabr, ztabw ! buffer, receive and work arrays 18 INTEGER, DIMENSION (:), ALLOCATABLE :: ireq_s, ireq_r ! for mpi_isend when avoiding mpi_allgather 19 INTEGER :: ipjtot ! sum of lines for all multi fields 20 INTEGER :: i012 ! 0, 1 or 2 21 INTEGER , DIMENSION(:,:) , ALLOCATABLE :: ijsnd ! j-position of sent lines for each field 22 INTEGER , DIMENSION(:,:) , ALLOCATABLE :: ijbuf ! j-position of send buffer lines for each field 23 INTEGER , DIMENSION(:,:) , ALLOCATABLE :: ijrcv ! j-position of recv buffer lines for each field 24 INTEGER , DIMENSION(:,:) , ALLOCATABLE :: ii1st, iiend 25 INTEGER , DIMENSION(:) , ALLOCATABLE :: ipjfld ! number of sent lines for each field 26 REAL(PRECISION), DIMENSION(:,:,:,:) , ALLOCATABLE :: zbufs ! buffer, receive and work arrays 27 REAL(PRECISION), DIMENSION(:,:,:,:,:) , ALLOCATABLE :: zbufr ! buffer, receive and work arrays 28 28 REAL(PRECISION), DIMENSION(:,:,:,:,:) , ALLOCATABLE :: znorthloc 29 29 REAL(PRECISION), DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: znorthglo … … 62 62 ll_add_line = l_full_nf_update .OR. ( ncom_stp <= nit000+1 .AND. .NOT. ln_rstart ) 63 63 64 ALLOCATE(ipj _s(ipf)) ! how many lines do we exchange?64 ALLOCATE(ipjfld(ipf)) ! how many lines do we exchange for each field? 65 65 IF( ll_add_line ) THEN 66 DO jf = 1, ipf 67 ipj _s(jf) = khls + COUNT( (/ c_NFtype == 'T' .OR. cd_nat(jf) == 'V' .OR. cd_nat(jf) == 'F' /) )66 DO jf = 1, ipf ! Loop over the number of arrays to be processed 67 ipjfld(jf) = khls + COUNT( (/ c_NFtype == 'T' .OR. cd_nat(jf) == 'V' .OR. cd_nat(jf) == 'F' /) ) 68 68 END DO 69 69 ELSE 70 ipj _s(:) = khls70 ipjfld(:) = khls 71 71 ENDIF 72 72 73 ipj = MAXVAL(ipj_s(:)) ! Max 2nd dimension of message transfers 74 ipj_b = SUM( ipj_s(:)) ! Total number of lines to be exchanged 75 ALLOCATE( jj_s(ipj, ipf), jj_b(ipj, ipf) ) 73 ipj = MAXVAL(ipjfld(:)) ! Max 2nd dimension of message transfers 74 ipjtot = SUM( ipjfld(:)) ! Total number of lines to be exchanged 76 75 77 76 ! Index of modifying lines in input 77 ALLOCATE( ijsnd(ipj, ipf), ijbuf(ipj, ipf), ijrcv(ipj, ipf), ii1st(ipj, ipf), iiend(ipj, ipf) ) 78 78 79 ij1 = 0 79 DO jf = 1, ipf ! Loop over the number of arrays to be processed 80 ! 80 DO jf = 1, ipf ! Loop over the number of arrays to be processed 81 ! 82 DO jj = 1, khls ! first khls lines (starting from top) must be fully defined 83 ii1st(jj, jf) = 1 84 iiend(jj, jf) = jpi 85 END DO 86 ! 87 ! what do we do with line khls+1 (starting from top) 81 88 IF( c_NFtype == 'T' ) THEN ! * North fold T-point pivot 82 89 SELECT CASE ( cd_nat(jf) ) 83 CASE ( 'T', 'W', 'U' ) ; i012 = 1 ! T-, U-, W-point 84 CASE ( 'V', 'F' ) ; i012 = 2 ! V-, F-point 90 CASE ('T','W') ; i012 = 1 ; ii1st(khls+1, jf) = mi0(jpiglo/2+2) ; iiend(khls+1, jf) = mi1(jpiglo-khls) 91 CASE ('U' ) ; i012 = 1 ; ii1st(khls+1, jf) = mi0(jpiglo/2+1) ; iiend(khls+1, jf) = mi1(jpiglo-khls) 92 CASE ('V' ) ; i012 = 2 ; ii1st(khls+1, jf) = 1 ; iiend(khls+1, jf) = jpi 93 CASE ('F' ) ; i012 = 2 ; ii1st(khls+1, jf) = 1 ; iiend(khls+1, jf) = jpi 85 94 END SELECT 86 95 ENDIF 87 96 IF( c_NFtype == 'F' ) THEN ! * North fold F-point pivot 88 97 SELECT CASE ( cd_nat(jf) ) 89 CASE ( 'T', 'W', 'U' ) ; i012 = 0 ! T-, U-, W-point 90 CASE ( 'V', 'F' ) ; i012 = 1 ! V-, F-point 98 CASE ('T','W') ; i012 = 0 ! we don't touch line khls+1 99 CASE ('U' ) ; i012 = 0 ! we don't touch line khls+1 100 CASE ('V' ) ; i012 = 1 ; ii1st(khls+1, jf) = mi0(jpiglo/2+1) ; iiend(khls+1, jf) = mi1(jpiglo-khls ) 101 CASE ('F' ) ; i012 = 1 ; ii1st(khls+1, jf) = mi0(jpiglo/2+1) ; iiend(khls+1, jf) = mi1(jpiglo-khls-1) 91 102 END SELECT 92 103 ENDIF 93 94 DO jj = 1, ipj _s(jf)104 ! 105 DO jj = 1, ipjfld(jf) 95 106 ij1 = ij1 + 1 96 jj_b(jj,jf) = ij1 97 jj_s(jj,jf) = jpj - 2*khls + jj - i012 107 ijsnd(jj,jf) = jpj - 2*khls + jj - i012 ! sent lines (from bottom of sent lines) 108 ijbuf(jj,jf) = ij1 ! gather all lines in the snd/rcv buffers 109 ijrcv(jj,jf) = jpj - jj + 1 ! recv lines (from the top -> reverse order for jj) 98 110 END DO 99 111 ! 100 112 END DO 101 113 ! 102 ALLOCATE( ztabb(jpimax,ipj_b,ipk,ipl) ) ! store all the data to be sent in a buffer array 103 ibuffsize = jpimax * ipj_b * ipk * ipl 104 ! 114 i0max = jpimax - 2 * khls ! we are not sending the halos 115 ALLOCATE( zbufs(i0max,ipjtot,ipk,ipl), ireq_s(nfd_nbnei) ) ! store all the data to be sent in a buffer array 116 ibuffsize = i0max * ipjtot * ipk * ipl 117 ! 118 ! fill the send buffer with all the lines 105 119 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk 106 DO jj = 1, ipj_s(jf) 107 ij1 = jj_b(jj,jf) 108 ij2 = jj_s(jj,jf) 109 DO ji = 1, jpi 110 ztabb(ji,ij1,jk,jl) = ptab(jf)%pt4d(ji,ij2,jk,jl) 111 END DO 112 DO ji = jpi+1, jpimax 113 ztabb(ji,ij1,jk,jl) = HUGE(0._/**/PRECISION) ! avoid sending uninitialized values (make sure we don't use it) 120 DO jj = 1, ipjfld(jf) 121 ij1 = ijbuf(jj,jf) 122 ij2 = ijsnd(jj,jf) 123 DO ji = Nis0, Nie0 ! should not use any other value 124 iib = ji - Nis0 + 1 125 zbufs(iib,ij1,jk,jl) = ptab(jf)%pt4d(ji,ij2,jk,jl) 126 END DO 127 DO ji = Ni_0+1, i0max ! avoid sending uninitialized values (make sure we don't use it) 128 zbufs(ji,ij1,jk,jl) = HUGE(0._/**/PRECISION) ! make sure we don't use it... 114 129 END DO 115 130 END DO … … 119 134 IF( ln_timing ) CALL tic_tac(.TRUE.) 120 135 ! 121 ! send the dataas soon as possible122 DO j r = 1, nsndto123 iproc = nf proc(isendto(jr))136 ! send the same buffer data to all neighbourgs as soon as possible 137 DO jn = 1, nfd_nbnei 138 iproc = nfd_rknei(jn) 124 139 IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN 125 140 #if ! defined key_mpi_off 126 CALL MPI_I SEND( ztabb, ibuffsize, MPI_TYPE, iproc, 5, mpi_comm_oce, ml_req_nf(jr), ierr )141 CALL MPI_Isend( zbufs, ibuffsize, MPI_TYPE, iproc, 5, mpi_comm_oce, ireq_s(jn), ierr ) 127 142 #endif 143 ELSE 144 ireq_s(jn) = MPI_REQUEST_NULL 128 145 ENDIF 129 146 END DO 130 147 ! 131 ipimax = jpimax * jpmaxngh 132 ALLOCATE( ztabw(jpimax,ipj_b,ipk,ipl), ztabr(ipimax,ipj_b,ipk,ipl) ) 133 ! 134 DO jr = 1, nsndto 135 ! 136 ipni = isendto(jr) 137 iproc = nfproc(ipni) 138 ipi = nfjpi (ipni) 139 ! 140 IF( ipni == 1 ) THEN ; iis0 = 1 ! domain left side: as e-w comm already done -> from 1st column 141 ELSE ; iis0 = 1 + khls ! default: -> from inner domain 142 ENDIF 143 IF( ipni == jpni ) THEN ; iie0 = ipi ! domain right side: as e-w comm already done -> until last column 144 ELSE ; iie0 = ipi - khls ! default: -> until inner domain 145 ENDIF 146 impp = nfimpp(ipni) - nfimpp(isendto(1)) 148 ALLOCATE( zbufr(i0max,ipjtot,ipk,ipl,nfd_nbnei), ireq_r(nfd_nbnei) ) 149 ! 150 DO jn = 1, nfd_nbnei 151 ! 152 iproc = nfd_rknei(jn) 147 153 ! 148 154 IF( iproc == -1 ) THEN ! No neighbour (land proc that was suppressed) 149 155 ! 156 ireq_r(jn) = MPI_REQUEST_NULL ! no message to be received 157 zbufr(:,:,:,:,jn) = HUGE(0._/**/PRECISION) ! default: define it and make sure we don't use it... 150 158 SELECT CASE ( kfillmode ) 151 CASE ( jpfillnothing ) ! no filling152 CASE ( jpfillcopy ) ! filling with inner domain values159 CASE ( jpfillnothing ) ! no filling 160 CASE ( jpfillcopy ) ! filling with inner domain values 153 161 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk 154 DO jj = 1, ipj_s(jf) 155 ij1 = jj_b(jj,jf) 156 ij2 = jj_s(jj,jf) 157 DO ji = iis0, iie0 158 ztabr(impp+ji,ij1,jk,jl) = ptab(jf)%pt4d(Nis0,ij2,jk,jl) ! chose to take the 1st iner domain point 159 END DO 162 DO jj = 1, ipjfld(jf) 163 ij1 = ijbuf(jj,jf) 164 ij2 = ijsnd(jj,jf) ! we will use only the first value, see init_nfdcom 165 zbufr(1,ij1,jk,jl,jn) = ptab(jf)%pt4d(Nis0,ij2,jk,jl) ! chose to take the 1st inner domain point 160 166 END DO 161 167 END DO ; END DO ; END DO 162 CASE ( jpfillcst ) ! filling with constant value 163 DO jl = 1, ipl ; DO jk = 1, ipk 164 DO jj = 1, ipj_b 165 DO ji = iis0, iie0 166 ztabr(impp+ji,jj,jk,jl) = pfillval 167 END DO 168 END DO 169 END DO ; END DO 168 CASE ( jpfillcst ) ! filling with constant value 169 zbufr(1,:,:,:,jn) = pfillval ! we will use only the first value, see init_nfdcom 170 170 END SELECT 171 171 ! 172 172 ELSE IF( iproc == narea-1 ) THEN ! get data from myself! 173 173 ! 174 ireq_r(jn) = MPI_REQUEST_NULL ! no message to be received 174 175 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk 175 DO jj = 1, ipj_s(jf) 176 ij1 = jj_b(jj,jf) 177 ij2 = jj_s(jj,jf) 178 DO ji = iis0, iie0 179 ztabr(impp+ji,ij1,jk,jl) = ptab(jf)%pt4d(ji,ij2,jk,jl) 176 DO jj = 1, ipjfld(jf) 177 ij1 = ijbuf(jj,jf) 178 ij2 = ijsnd(jj,jf) 179 DO ji = Nis0, Nie0 ! should not use any other value 180 iib = ji - Nis0 + 1 181 zbufr(iib,ij1,jk,jl,jn) = ptab(jf)%pt4d(ji,ij2,jk,jl) 180 182 END DO 181 183 END DO … … 183 185 ! 184 186 ELSE ! get data from a neighbour trough communication 185 !186 187 #if ! defined key_mpi_off 187 CALL MPI_ RECV( ztabw, ibuffsize, MPI_TYPE, iproc, 5, mpi_comm_oce, MPI_STATUS_IGNORE, ierr )188 CALL MPI_Irecv( zbufr(:,:,:,:,jn), ibuffsize, MPI_TYPE, iproc, 5, mpi_comm_oce, ireq_r(jn), ierr ) 188 189 #endif 189 DO jl = 1, ipl ; DO jk = 1, ipk 190 DO jj = 1, ipj_b 191 DO ji = iis0, iie0 192 ztabr(impp+ji,jj,jk,jl) = ztabw(ji,jj,jk,jl) 193 END DO 194 END DO 195 END DO ; END DO 196 197 ENDIF 198 ! 199 END DO ! nsndto 190 ENDIF 191 ! 192 END DO ! nfd_nbnei 193 ! 194 CALL mpi_waitall(nfd_nbnei, ireq_r, MPI_STATUSES_IGNORE, ierr) ! wait for all Irecv 200 195 ! 201 196 IF( ln_timing ) CALL tic_tac(.FALSE.) … … 204 199 ! 205 200 DO jf = 1, ipf 206 ij1 = jj_b( 1 ,jf) 207 ij2 = jj_b(ipj_s(jf),jf) 208 CALL lbc_nfd_nogather( ptab(jf)%pt4d(:,:,:,:), ztabr(:,ij1:ij2,:,:), cd_nat(jf), psgn(jf), khls ) 209 END DO 210 ! 211 DEALLOCATE( ztabr, ztabw, jj_s, jj_b, ipj_s ) 212 ! 213 DO jr = 1,nsndto 214 iproc = nfproc(isendto(jr)) 215 IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN 216 CALL mpi_wait( ml_req_nf(jr), MPI_STATUS_IGNORE, ml_err ) ! put the wait at the very end just before the deallocate 217 ENDIF 218 END DO 219 DEALLOCATE( ztabb ) 201 ! 202 SELECT CASE ( cd_nat(jf) ) ! which grid number? 203 CASE ('T','W') ; iig = 1 ! T-, W-point 204 CASE ('U') ; iig = 2 ! U-point 205 CASE ('V') ; iig = 3 ! V-point 206 CASE ('F') ; iig = 4 ! F-point 207 END SELECT 208 ! 209 DO jl = 1, ipl ; DO jk = 1, ipk 210 ! 211 ! if T point with F-point pivot : must be done first 212 ! --> specific correction of 3 points near the 2 pivots (to be clean, usually masked -> so useless) 213 IF( c_NFtype == 'F' .AND. iig == 1 ) THEN 214 ij1 = jpj - khls ! j-index in the receiving array 215 ij2 = 1 ! only 1 line in the buffer 216 DO ji = mi0(khls), mi1(khls) 217 iib = nfd_jisnd(mi0( khls),iig) ! i-index in the buffer 218 iin = nfd_rksnd(mi0( khls),iig) ! neigbhour-index in the buffer 219 IF( nfd_rknei(iin) == -1 .AND. kfillmode == jpfillnothing ) CYCLE 220 ptab(jf)%pt4d(ji,ij1,jk,jl) = zbufr(iib,ij2,jk,jl,iin) ! no psgn(jf) 221 END DO 222 DO ji = mi0(jpiglo/2+1), mi1(jpiglo/2+1) 223 iib = nfd_jisnd(mi0( jpiglo/2+1),iig) ! i-index in the buffer 224 iin = nfd_rksnd(mi0( jpiglo/2+1),iig) ! neigbhour-index in the buffer 225 IF( nfd_rknei(iin) == -1 .AND. kfillmode == jpfillnothing ) CYCLE 226 ptab(jf)%pt4d(ji,ij1,jk,jl) = zbufr(iib,ij2,jk,jl,iin) ! no psgn(jf) 227 END DO 228 DO ji = mi0(jpiglo-khls), mi1(jpiglo-khls) 229 iib = nfd_jisnd(mi0(jpiglo-khls),iig) ! i-index in the buffer 230 iin = nfd_rksnd(mi0(jpiglo-khls),iig) ! neigbhour-index in the buffer 231 IF( nfd_rknei(iin) == -1 .AND. kfillmode == jpfillnothing ) CYCLE 232 ptab(jf)%pt4d(ji,ij1,jk,jl) = zbufr(iib,ij2,jk,jl,iin) ! no psgn(jf) 233 END DO 234 ENDIF 235 ! 236 ! Apply the North pole folding. 237 DO jj = 1, ipjfld(jf) ! for all lines to be exchanged for this field 238 ij1 = ijrcv(jj,jf) ! j-index in the receiving array 239 ij2 = ijbuf(jj,jf) ! j-index in the buffer 240 iis = ii1st(jj,jf) ! stating i-index in the receiving array 241 iie = iiend(jj,jf) ! ending i-index in the receiving array 242 DO ji = iis, iie 243 iib = nfd_jisnd(ji,iig) ! i-index in the buffer 244 iin = nfd_rksnd(ji,iig) ! neigbhour-index in the buffer 245 IF( nfd_rknei(iin) == -1 .AND. kfillmode == jpfillnothing ) CYCLE 246 ptab(jf)%pt4d(ji,ij1,jk,jl) = psgn(jf) * zbufr(iib,ij2,jk,jl,iin) 247 END DO 248 END DO 249 ! 250 ! re-apply periodocity when we modified the eastern side of the inner domain (and not the full line) 251 IF( c_NFtype == 'T' ) THEN ! * North fold T-point pivot 252 IF( iig <= 2 ) THEN ; iis = mi0(1) ; iie = mi1(khls) ! 'T','W','U': update west halo 253 ELSE ; iis = 1 ; iie = 0 ! 'V','F' : full line already exchanged 254 ENDIF 255 ENDIF 256 IF( c_NFtype == 'F' ) THEN ! * North fold F-point pivot 257 IF( iig <= 2 ) THEN ; iis = 1 ; iie = 0 ! 'T','W','U': nothing to do 258 ELSEIF( iig == 3 ) THEN ; iis = mi0(1) ; iie = mi1(khls) ! 'V' : update west halo 259 ELSEIF( khls > 1 ) THEN ; iis = mi0(1) ; iie = mi1(khls-1) ! 'F' and khls > 1 260 ELSE ; iis = 1 ; iie = 0 ! 'F' and khls == 1 : nothing to do 261 ENDIF 262 ENDIF 263 jj = ipjfld(jf) ! only for the last line of this field 264 ij1 = ijrcv(jj,jf) ! j-index in the receiving array 265 ij2 = ijbuf(jj,jf) ! j-index in the buffer 266 DO ji = iis, iie 267 iib = nfd_jisnd(ji,iig) ! i-index in the buffer 268 iin = nfd_rksnd(ji,iig) ! neigbhour-index in the buffer 269 IF( nfd_rknei(iin) == -1 .AND. kfillmode == jpfillnothing ) CYCLE 270 ptab(jf)%pt4d(ji,ij1,jk,jl) = psgn(jf) * zbufr(iib,ij2,jk,jl,iin) 271 END DO 272 ! 273 END DO ; END DO ! ipl ; ipk 274 ! 275 END DO ! ipf 276 277 ! 278 DEALLOCATE( zbufr, ireq_r, ijsnd, ijbuf, ijrcv, ii1st, iiend, ipjfld ) 279 ! 280 CALL mpi_waitall(nfd_nbnei, ireq_s, MPI_STATUSES_IGNORE, ierr) ! wait for all Isend 281 ! 282 DEALLOCATE( zbufs, ireq_s ) 220 283 ! 221 284 ELSE !== allgather exchanges ==! … … 265 328 ! 266 329 SELECT CASE ( kfillmode ) 267 CASE ( jpfillnothing ) ! no filling 330 CASE ( jpfillnothing ) ! no filling 331 CALL ctl_stop( 'STOP', 'mpp_nfd_generic : cannot use jpfillnothing with ln_nnogather = F') 268 332 CASE ( jpfillcopy ) ! filling with inner domain values 269 333 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk … … 329 393 DEALLOCATE( ztabglo ) 330 394 ! 331 ENDIF ! l _north_nogather395 ENDIF ! ln_nnogather 332 396 ! 333 397 END SUBROUTINE mpp_nfd_/**/PRECISION
Note: See TracChangeset
for help on using the changeset viewer.
