- 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/mpp_nfd_generic.h90
r14349 r14363 1 1 2 SUBROUTINE mpp_nfd_/**/PRECISION( ptab, cd_nat, psgn, kfillmode, pfillval, k fld )2 SUBROUTINE mpp_nfd_/**/PRECISION( ptab, cd_nat, psgn, kfillmode, pfillval, khls, kfld ) 3 3 TYPE(PTR_4d_/**/PRECISION), DIMENSION(:), INTENT(inout) :: ptab ! pointer of arrays on which apply the b.c. 4 4 CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: cd_nat ! nature of array grid-points … … 6 6 INTEGER , INTENT(in ) :: kfillmode ! filling method for halo over land 7 7 REAL(PRECISION) , INTENT(in ) :: pfillval ! background value (used at closed boundaries) 8 INTEGER , INTENT(in ) :: khls ! halo size, default = nn_hls 8 9 INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays 9 10 ! … … 64 65 IF( ll_add_line ) THEN 65 66 DO jf = 1, ipf ! Loop over the number of arrays to be processed 66 ipj_s(jf) = nn_hls + COUNT( (/ c_NFtype == 'T' .OR. cd_nat(jf) == 'V' .OR. cd_nat(jf) == 'F' /) )67 ipj_s(jf) = khls + COUNT( (/ c_NFtype == 'T' .OR. cd_nat(jf) == 'V' .OR. cd_nat(jf) == 'F' /) ) 67 68 END DO 68 69 ELSE 69 ipj_s(:) = nn_hls70 ipj_s(:) = khls 70 71 ENDIF 71 72 … … 94 95 ij1 = ij1 + 1 95 96 jj_b(jj,jf) = ij1 96 jj_s(jj,jf) = jpj - 2* nn_hls + jj - i01297 jj_s(jj,jf) = jpj - 2*khls + jj - i012 97 98 END DO 98 99 ! … … 137 138 ipi = nfjpi (ipni) 138 139 ! 139 IF( ipni == 1 ) THEN ; iis0 = 1 140 ELSE ; iis0 = 1 + nn_hls ! default: -> from inner domain141 ENDIF 142 IF( ipni == jpni ) THEN ; iie0 = ipi 143 ELSE ; iie0 = ipi - nn_hls ! default: -> until inner domain140 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 144 145 ENDIF 145 146 impp = nfimpp(ipni) - nfimpp(isendto(1)) … … 205 206 ij1 = jj_b( 1 ,jf) 206 207 ij2 = jj_b(ipj_s(jf),jf) 207 CALL lbc_nfd_nogather( ptab(jf)%pt4d(:,:,:,:), ztabr(:,ij1:ij2,:,:), cd_nat(jf), psgn(jf) )208 CALL lbc_nfd_nogather( ptab(jf)%pt4d(:,:,:,:), ztabr(:,ij1:ij2,:,:), cd_nat(jf), psgn(jf), khls ) 208 209 END DO 209 210 ! … … 221 222 ! 222 223 ! how many lines do we exchange at max? -> ipj (no further optimizations in this case...) 223 ipj = nn_hls + 2224 ipj = khls + 2 224 225 ! how many lines do we need at max? -> ipj2 (no further optimizations in this case...) 225 ipj2 = 2 * nn_hls + 2226 ! 227 i0max = jpimax - 2 * nn_hls226 ipj2 = 2 * khls + 2 227 ! 228 i0max = jpimax - 2 * khls 228 229 ibuffsize = i0max * ipj * ipk * ipl * ipf 229 230 ALLOCATE( znorthloc(i0max,ipj,ipk,ipl,ipf), znorthglo(i0max,ipj,ipk,ipl,ipf,ndim_rank_north) ) … … 255 256 END DO 256 257 ! 257 ! need to fill only the first ipj lines of ztabglo as lbc_nfd don't use the last nn_hls lines258 ! need to fill only the first ipj lines of ztabglo as lbc_nfd don't use the last khls lines 258 259 ijnr = 0 259 260 DO jr = 1, jpni ! recover the global north array 260 261 iproc = nfproc(jr) 261 262 impp = nfimpp(jr) 262 ipi = nfjpi( jr) - 2 * nn_hls ! corresponds to Ni_0 but for subdomain iproc263 ipi = nfjpi( jr) - 2 * khls ! corresponds to Ni_0 but for subdomain iproc 263 264 IF( iproc == -1 ) THEN ! No neighbour (land proc that was suppressed) 264 265 ! … … 270 271 ij2 = jpj - ipj2 + jj ! the first ipj lines of the last ipj2 lines 271 272 DO ji = 1, ipi 272 ii1 = impp + nn_hls + ji - 1 ! corresponds to mig(nn_hls + ji) but for subdomain iproc273 ii1 = impp + khls + ji - 1 ! corresponds to mig(khls + ji) but for subdomain iproc 273 274 ztabglo(jf)%pt4d(ii1,jj,jk,jl) = ptab(jf)%pt4d(Nis0,ij2,jk,jl) ! chose to take the 1st inner domain point 274 275 END DO … … 279 280 DO jj = 1, ipj 280 281 DO ji = 1, ipi 281 ii1 = impp + nn_hls + ji - 1 ! corresponds to mig(nn_hls + ji) but for subdomain iproc282 ii1 = impp + khls + ji - 1 ! corresponds to mig(khls + ji) but for subdomain iproc 282 283 ztabglo(jf)%pt4d(ii1,jj,jk,jl) = pfillval 283 284 END DO … … 291 292 DO jj = 1, ipj 292 293 DO ji = 1, ipi 293 ii1 = impp + nn_hls + ji - 1 ! corresponds to mig(nn_hls + ji) but for subdomain iproc294 ii1 = impp + khls + ji - 1 ! corresponds to mig(khls + ji) but for subdomain iproc 294 295 ztabglo(jf)%pt4d(ii1,jj,jk,jl) = znorthglo(ji,jj,jk,jl,jf,ijnr) 295 296 END DO … … 302 303 ! 303 304 DO jf = 1, ipf 304 CALL lbc_nfd( ztabglo(jf:jf), cd_nat(jf:jf), psgn(jf:jf), 1 ) ! North fold boundary condition305 CALL lbc_nfd( ztabglo(jf:jf), cd_nat(jf:jf), psgn(jf:jf), khls, 1 ) ! North fold boundary condition 305 306 DO jl = 1, ipl ; DO jk = 1, ipk ! e-w periodicity 306 DO jj = 1, nn_hls + 1307 ij1 = ipj2 - ( nn_hls + 1) + jj ! need only the last nn_hls + 1 lines until ipj2308 ztabglo(jf)%pt4d( 1:nn_hls,ij1,jk,jl) = ztabglo(jf)%pt4d(jpiglo-2*nn_hls+1:jpiglo-nn_hls,ij1,jk,jl)309 ztabglo(jf)%pt4d(jpiglo- nn_hls+1:jpiglo,ij1,jk,jl) = ztabglo(jf)%pt4d( nn_hls+1: 2*nn_hls,ij1,jk,jl)307 DO jj = 1, khls + 1 308 ij1 = ipj2 - (khls + 1) + jj ! need only the last khls + 1 lines until ipj2 309 ztabglo(jf)%pt4d( 1: khls,ij1,jk,jl) = ztabglo(jf)%pt4d(jpiglo-2*khls+1:jpiglo-khls,ij1,jk,jl) 310 ztabglo(jf)%pt4d(jpiglo-khls+1:jpiglo,ij1,jk,jl) = ztabglo(jf)%pt4d( khls+1: 2*khls,ij1,jk,jl) 310 311 END DO 311 312 END DO ; END DO … … 313 314 ! 314 315 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ! Scatter back to ARRAY_IN 315 DO jj = 1, nn_hls + 1316 ij1 = jpj - ( nn_hls + 1) + jj ! last nn_hls + 1 lines until jpj317 ij2 = ipj2 - ( nn_hls + 1) + jj ! last nn_hls + 1 lines until ipj2316 DO jj = 1, khls + 1 317 ij1 = jpj - (khls + 1) + jj ! last khls + 1 lines until jpj 318 ij2 = ipj2 - (khls + 1) + jj ! last khls + 1 lines until ipj2 318 319 DO ji= 1, jpi 319 320 ii2 = mig(ji)
Note: See TracChangeset
for help on using the changeset viewer.
