Changeset 14623 for utils/tools/DOMAINcfg/src/mpp_nfd_generic.h90
- Timestamp:
- 2021-03-21T19:40:22+01:00 (3 years ago)
- File:
-
- 1 edited
-
utils/tools/DOMAINcfg/src/mpp_nfd_generic.h90 (modified) (7 diffs)
Legend:
- Unmodified
- Added
- Removed
-
utils/tools/DOMAINcfg/src/mpp_nfd_generic.h90
r13204 r14623 5 5 # define LBC_ARG (jf) 6 6 # if defined DIM_2d 7 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D) , INTENT(inout) :: ptab(f) 7 # if defined SINGLE_PRECISION 8 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_sp) , INTENT(inout) :: ptab(f) 9 # else 10 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_dp) , INTENT(inout) :: ptab(f) 11 # endif 8 12 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt2d(i,j) 9 13 # define K_SIZE(ptab) 1 … … 11 15 # endif 12 16 # if defined DIM_3d 13 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D) , INTENT(inout) :: ptab(f) 17 # if defined SINGLE_PRECISION 18 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_sp) , INTENT(inout) :: ptab(f) 19 # else 20 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_dp) , INTENT(inout) :: ptab(f) 21 # endif 14 22 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt3d(i,j,k) 15 23 # define K_SIZE(ptab) SIZE(ptab(1)%pt3d,3) … … 17 25 # endif 18 26 # if defined DIM_4d 19 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D) , INTENT(inout) :: ptab(f) 27 # if defined SINGLE_PRECISION 28 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_sp) , INTENT(inout) :: ptab(f) 29 # else 30 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_dp) , INTENT(inout) :: ptab(f) 31 # endif 20 32 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt4d(i,j,k,l) 21 33 # define K_SIZE(ptab) SIZE(ptab(1)%pt4d,3) … … 24 36 #else 25 37 ! !== IN: ptab is an array ==! 26 # define ARRAY_TYPE(i,j,k,l,f) REAL(wp) , INTENT(inout) :: ARRAY_IN(i,j,k,l,f) 38 # if defined SINGLE_PRECISION 39 # define ARRAY_TYPE(i,j,k,l,f) REAL(sp) , INTENT(inout) :: ARRAY_IN(i,j,k,l,f) 40 # else 41 # define ARRAY_TYPE(i,j,k,l,f) REAL(dp) , INTENT(inout) :: ARRAY_IN(i,j,k,l,f) 42 # endif 27 43 # define NAT_IN(k) cd_nat 28 44 # define SGN_IN(k) psgn … … 46 62 #endif 47 63 48 SUBROUTINE ROUTINE_NFD( ptab, cd_nat, psgn, kfld ) 64 # if defined SINGLE_PRECISION 65 # define PRECISION sp 66 # define SENDROUTINE mppsend_sp 67 # define RECVROUTINE mpprecv_sp 68 # define MPI_TYPE MPI_REAL 69 # define HUGEVAL(x) HUGE(x/**/_sp) 70 # else 71 # define PRECISION dp 72 # define SENDROUTINE mppsend_dp 73 # define RECVROUTINE mpprecv_dp 74 # define MPI_TYPE MPI_DOUBLE_PRECISION 75 # define HUGEVAL(x) HUGE(x/**/_dp) 76 # endif 77 78 SUBROUTINE ROUTINE_NFD( ptab, cd_nat, psgn, kfillmode, pfillval, kfld ) 49 79 !!---------------------------------------------------------------------- 50 80 ARRAY_TYPE(:,:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied 51 81 CHARACTER(len=1) , INTENT(in ) :: NAT_IN(:) ! nature of array grid-points 52 82 REAL(wp) , INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary 83 INTEGER , INTENT(in ) :: kfillmode ! filling method for halo over land 84 REAL(wp) , INTENT(in ) :: pfillval ! background value (used at closed boundaries) 53 85 INTEGER, OPTIONAL, INTENT(in ) :: kfld ! number of pt3d arrays 54 86 ! 87 LOGICAL :: ll_add_line 55 88 INTEGER :: ji, jj, jk, jl, jh, jf, jr ! dummy loop indices 56 INTEGER :: ipi, ipj, ip k, ipl, ipf! dimension of the input array89 INTEGER :: ipi, ipj, ipj2, ipk, ipl, ipf ! dimension of the input array 57 90 INTEGER :: imigr, iihom, ijhom ! local integers 58 INTEGER :: ierr, ibuffsize, ilci, ildi, ilei, iilb 59 INTEGER :: ij, iproc 91 INTEGER :: ierr, ibuffsize, iis0, iie0, impp 92 INTEGER :: ii1, ii2, ij1, ij2 93 INTEGER :: ipimax, i0max 94 INTEGER :: ij, iproc, ipni, ijnr 60 95 INTEGER, DIMENSION (jpmaxngh) :: ml_req_nf ! for mpi_isend when avoiding mpi_allgather 61 96 INTEGER :: ml_err ! for mpi_isend when avoiding mpi_allgather 62 97 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for mpi_isend when avoiding mpi_allgather 63 98 ! ! Workspace for message transfers avoiding mpi_allgather 64 INTEGER :: ip f_j! sum of lines for all multi fields65 INTEGER :: js ! counter66 INTEGER , DIMENSION(:,:),ALLOCATABLE :: jj_s ! position of sent lines67 INTEGER , DIMENSION(:), ALLOCATABLE :: ipj_s ! number of sentlines68 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: ztabl69 REAL( wp), DIMENSION(:,:,:,:,:) , ALLOCATABLE :: ztab, ztabr70 REAL( wp), DIMENSION(:,:,:,:,:) , ALLOCATABLE :: znorthloc, zfoldwk71 REAL( wp), DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: znorthgloio99 INTEGER :: ipj_b ! sum of lines for all multi fields 100 INTEGER :: i012 ! 0, 1 or 2 101 INTEGER , DIMENSION(:,:) , ALLOCATABLE :: jj_s ! position of sent lines 102 INTEGER , DIMENSION(:,:) , ALLOCATABLE :: jj_b ! position of buffer lines 103 INTEGER , DIMENSION(:) , ALLOCATABLE :: ipj_s ! number of sent lines 104 REAL(PRECISION), DIMENSION(:,:,:,:) , ALLOCATABLE :: ztabb, ztabr, ztabw ! buffer, receive and work arrays 105 REAL(PRECISION), DIMENSION(:,:,:,:,:) , ALLOCATABLE :: ztabglo, znorthloc 106 REAL(PRECISION), DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: znorthglo 72 107 !!---------------------------------------------------------------------- 73 108 ! … … 76 111 ipf = F_SIZE(ptab) ! 5th - use in "multi" case (array of pointers) 77 112 ! 78 IF( l_north_nogather ) THEN !== ????==!113 IF( l_north_nogather ) THEN !== no allgather exchanges ==! 79 114 80 ALLOCATE(ipj_s(ipf)) 81 82 ipj = 2 ! Max 2nd dimension of message transfers (last two j-line only) 83 ipj_s(:) = 1 ! Real 2nd dimension of message transfers (depending on perf requirement) 84 ! by default, only one line is exchanged 85 86 ALLOCATE( jj_s(ipf,2) ) 87 88 ! re-define number of exchanged lines : 89 ! must be two during the first two time steps 90 ! to correct possible incoherent values on North fold lines from restart 91 115 ! --- define number of exchanged lines --- 116 ! 117 ! In theory we should exchange only nn_hls lines. 118 ! 119 ! However, some other points are duplicated in the north pole folding: 120 ! - jperio=[34], grid=T : half of the last line (jpiglo/2+2:jpiglo-nn_hls) 121 ! - jperio=[34], grid=U : half of the last line (jpiglo/2+1:jpiglo-nn_hls) 122 ! - jperio=[34], grid=V : all the last line nn_hls+1 and (nn_hls+2:jpiglo-nn_hls) 123 ! - jperio=[34], grid=F : all the last line (nn_hls+1:jpiglo-nn_hls) 124 ! - jperio=[56], grid=T : 2 points of the last line (jpiglo/2+1 and jpglo-nn_hls) 125 ! - jperio=[56], grid=U : no points are duplicated 126 ! - jperio=[56], grid=V : half of the last line (jpiglo/2+1:jpiglo-nn_hls) 127 ! - jperio=[56], grid=F : half of the last line (jpiglo/2+1:jpiglo-nn_hls-1) 128 ! The order of the calculations may differ for these duplicated points (as, for example jj+1 becomes jj-1) 129 ! This explain why these duplicated points may have different values even if they are at the exact same location. 130 ! In consequence, we may want to force the folding on these points by setting l_full_nf_update = .TRUE. 131 ! This is slightly slower but necessary to avoid different values on identical grid points!! 132 ! 92 133 !!!!!!!!! temporary switch off this optimisation ==> force TRUE !!!!!!!! 93 134 !!!!!!!!! needed to get the same results without agrif and with agrif and no zoom !!!!!!!! 94 135 !!!!!!!!! I don't know why we must do that... !!!!!!!! 95 136 l_full_nf_update = .TRUE. 96 97 ipj_s(:) = 2 137 ! also force it if not restart during the first 2 steps (leap frog?) 138 ll_add_line = l_full_nf_update .OR. ( ncom_stp <= nit000+1 .AND. .NOT. ln_rstart ) 139 140 ALLOCATE(ipj_s(ipf)) ! how many lines do we exchange? 141 IF( ll_add_line ) THEN 142 DO jf = 1, ipf ! Loop over the number of arrays to be processed 143 ipj_s(jf) = nn_hls + COUNT( (/ npolj == 3 .OR. npolj == 4 .OR. NAT_IN(jf) == 'V' .OR. NAT_IN(jf) == 'F' /) ) 144 END DO 145 ELSE 146 ipj_s(:) = nn_hls 147 ENDIF 148 149 ipj = MAXVAL(ipj_s(:)) ! Max 2nd dimension of message transfers 150 ipj_b = SUM( ipj_s(:)) ! Total number of lines to be exchanged 151 ALLOCATE( jj_s(ipj, ipf), jj_b(ipj, ipf) ) 98 152 99 153 ! Index of modifying lines in input 154 ij1 = 0 100 155 DO jf = 1, ipf ! Loop over the number of arrays to be processed 101 156 ! 102 157 SELECT CASE ( npolj ) 103 !104 158 CASE ( 3, 4 ) ! * North fold T-point pivot 105 !106 159 SELECT CASE ( NAT_IN(jf) ) 107 ! 108 CASE ( 'T' , 'W' ,'U' ) ! T-, U-, W-point 109 jj_s(jf,1) = nlcj - 2 ; jj_s(jf,2) = nlcj - 1 110 CASE ( 'V' , 'F' ) ! V-, F-point 111 jj_s(jf,1) = nlcj - 3 ; jj_s(jf,2) = nlcj - 2 160 CASE ( 'T', 'W', 'U' ) ; i012 = 1 ! T-, U-, W-point 161 CASE ( 'V', 'F' ) ; i012 = 2 ! V-, F-point 112 162 END SELECT 113 ! 114 CASE ( 5, 6 ) ! * North fold F-point pivot 163 CASE ( 5, 6 ) ! * North fold F-point pivot 115 164 SELECT CASE ( NAT_IN(jf) ) 116 ! 117 CASE ( 'T' , 'W' ,'U' ) ! T-, U-, W-point 118 jj_s(jf,1) = nlcj - 1 119 ipj_s(jf) = 1 ! need only one line anyway 120 CASE ( 'V' , 'F' ) ! V-, F-point 121 jj_s(jf,1) = nlcj - 2 ; jj_s(jf,2) = nlcj - 1 165 CASE ( 'T', 'W', 'U' ) ; i012 = 0 ! T-, U-, W-point 166 CASE ( 'V', 'F' ) ; i012 = 1 ! V-, F-point 122 167 END SELECT 123 !124 168 END SELECT 125 ! 126 ENDDO 127 ! 128 ipf_j = sum (ipj_s(:)) ! Total number of lines to be exchanged 129 ! 130 ALLOCATE( znorthloc(jpimax,ipf_j,ipk,ipl,1) ) 131 ! 132 js = 0 133 DO jf = 1, ipf ! Loop over the number of arrays to be processed 169 ! 134 170 DO jj = 1, ipj_s(jf) 135 js = js + 1 136 DO jl = 1, ipl 137 DO jk = 1, ipk 138 znorthloc(1:jpi,js,jk,jl,1) = ARRAY_IN(1:jpi,jj_s(jf,jj),jk,jl,jf) 171 ij1 = ij1 + 1 172 jj_b(jj,jf) = ij1 173 jj_s(jj,jf) = jpj - 2*nn_hls + jj - i012 174 END DO 175 ! 176 END DO 177 ! 178 ALLOCATE( ztabb(jpimax,ipj_b,ipk,ipl) ) ! store all the data to be sent in a buffer array 179 ibuffsize = jpimax * ipj_b * ipk * ipl 180 ! 181 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk 182 DO jj = 1, ipj_s(jf) 183 ij1 = jj_b(jj,jf) 184 ij2 = jj_s(jj,jf) 185 DO ji = 1, jpi 186 ztabb(ji,ij1,jk,jl) = ARRAY_IN(ji,ij2,jk,jl,jf) 187 END DO 188 DO ji = jpi+1, jpimax 189 ztabb(ji,ij1,jk,jl) = HUGEVAL(0.) ! avoid sending uninitialized values (make sure we don't use it) 190 END DO 191 END DO 192 END DO ; END DO ; END DO 193 ! 194 ! start waiting time measurement 195 IF( ln_timing ) CALL tic_tac(.TRUE.) 196 ! 197 ! send the data as soon as possible 198 DO jr = 1, nsndto 199 iproc = nfproc(isendto(jr)) 200 IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN 201 CALL SENDROUTINE( 5, ztabb, ibuffsize, iproc, ml_req_nf(jr) ) 202 ENDIF 203 END DO 204 ! 205 ipimax = jpimax * jpmaxngh 206 ALLOCATE( ztabw(jpimax,ipj_b,ipk,ipl), ztabr(ipimax,ipj_b,ipk,ipl) ) 207 ! 208 DO jr = 1, nsndto 209 ! 210 ipni = isendto(jr) 211 iproc = nfproc(ipni) 212 ipi = nfjpi (ipni) 213 ! 214 IF( ipni == 1 ) THEN ; iis0 = 1 ! domain left side: as e-w comm already done -> from 1st column 215 ELSE ; iis0 = 1 + nn_hls ! default: -> from inner domain 216 ENDIF 217 IF( ipni == jpni ) THEN ; iie0 = ipi ! domain right side: as e-w comm already done -> until last column 218 ELSE ; iie0 = ipi - nn_hls ! default: -> until inner domain 219 ENDIF 220 impp = nfimpp(ipni) - nfimpp(isendto(1)) 221 ! 222 IF( iproc == -1 ) THEN ! No neighbour (land proc that was suppressed) 223 ! 224 SELECT CASE ( kfillmode ) 225 CASE ( jpfillnothing ) ! no filling 226 CASE ( jpfillcopy ) ! filling with inner domain values 227 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk 228 DO jj = 1, ipj_s(jf) 229 ij1 = jj_b(jj,jf) 230 ij2 = jj_s(jj,jf) 231 DO ji = iis0, iie0 232 ztabr(impp+ji,ij1,jk,jl) = ARRAY_IN(Nis0,ij2,jk,jl,jf) ! chose to take the 1st iner domain point 233 END DO 234 END DO 235 END DO ; END DO ; END DO 236 CASE ( jpfillcst ) ! filling with constant value 237 DO jl = 1, ipl ; DO jk = 1, ipk 238 DO jj = 1, ipj_b 239 DO ji = iis0, iie0 240 ztabr(impp+ji,jj,jk,jl) = pfillval 241 END DO 242 END DO 243 END DO ; END DO 244 END SELECT 245 ! 246 ELSE IF( iproc == narea-1 ) THEN ! get data from myself! 247 ! 248 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk 249 DO jj = 1, ipj_s(jf) 250 ij1 = jj_b(jj,jf) 251 ij2 = jj_s(jj,jf) 252 DO ji = iis0, iie0 253 ztabr(impp+ji,ij1,jk,jl) = ARRAY_IN(ji,ij2,jk,jl,jf) 254 END DO 139 255 END DO 256 END DO ; END DO ; END DO 257 ! 258 ELSE ! get data from a neighbour trough communication 259 ! 260 CALL RECVROUTINE(5, ztabw, ibuffsize, iproc) 261 DO jl = 1, ipl ; DO jk = 1, ipk 262 DO jj = 1, ipj_b 263 DO ji = iis0, iie0 264 ztabr(impp+ji,jj,jk,jl) = ztabw(ji,jj,jk,jl) 265 END DO 266 END DO 267 END DO ; END DO 268 269 ENDIF 270 ! 271 END DO ! nsndto 272 ! 273 IF( ln_timing ) CALL tic_tac(.FALSE.) 274 ! 275 ! North fold boundary condition 276 ! 277 DO jf = 1, ipf 278 ij1 = jj_b( 1 ,jf) 279 ij2 = jj_b(ipj_s(jf),jf) 280 CALL lbc_nfd_nogather( ARRAY_IN(:,:,:,:,jf), ztabr(:,ij1:ij2,:,:), cd_nat LBC_ARG, psgn LBC_ARG ) 281 END DO 282 ! 283 DEALLOCATE( ztabr, ztabw, jj_s, jj_b, ipj_s ) 284 ! 285 DO jr = 1,nsndto 286 iproc = nfproc(isendto(jr)) 287 IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN 288 CALL mpi_wait( ml_req_nf(jr), ml_stat, ml_err ) ! put the wait at the very end just before the deallocate 289 ENDIF 290 END DO 291 DEALLOCATE( ztabb ) 292 ! 293 ELSE !== allgather exchanges ==! 294 ! 295 ! how many lines do we exchange at max? -> ipj (no further optimizations in this case...) 296 ipj = nn_hls + 2 297 ! how many lines do we need at max? -> ipj2 (no further optimizations in this case...) 298 ipj2 = 2 * nn_hls + 2 299 ! 300 i0max = jpimax - 2 * nn_hls 301 ibuffsize = i0max * ipj * ipk * ipl * ipf 302 ALLOCATE( znorthloc(i0max,ipj,ipk,ipl,ipf), znorthglo(i0max,ipj,ipk,ipl,ipf,ndim_rank_north) ) 303 ! 304 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ! put in znorthloc ipj j-lines of ptab 305 DO jj = 1, ipj 306 ij2 = jpj - ipj2 + jj ! the first ipj lines of the last ipj2 lines 307 DO ji = 1, Ni_0 308 ii2 = Nis0 - 1 + ji ! inner domain: Nis0 to Nie0 309 znorthloc(ji,jj,jk,jl,jf) = ARRAY_IN(ii2,ij2,jk,jl,jf) 310 END DO 311 DO ji = Ni_0+1, i0max 312 znorthloc(ji,jj,jk,jl,jf) = HUGEVAL(0.) ! avoid sending uninitialized values (make sure we don't use it) 140 313 END DO 141 314 END DO 142 END DO 143 ! 144 ibuffsize = jpimax * ipf_j * ipk * ipl 145 ! 146 ALLOCATE( zfoldwk(jpimax,ipf_j,ipk,ipl,1) ) 147 ALLOCATE( ztabr(jpimax*jpmaxngh,ipj,ipk,ipl,ipf) ) 148 ! when some processors of the north fold are suppressed, 149 ! values of ztab* arrays corresponding to these suppressed domain won't be defined 150 ! and we need a default definition to 0. 151 ! a better test should be: a testing if "suppressed land-processors" belongs to the north-pole folding 152 IF ( jpni*jpnj /= jpnij ) ztabr(:,:,:,:,:) = 0._wp 153 ! 154 DO jr = 1, nsndto 155 IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 156 CALL mppsend( 5, znorthloc, ibuffsize, nfipproc(isendto(jr),jpnj), ml_req_nf(jr) ) 157 ENDIF 158 END DO 159 ! 160 DO jr = 1,nsndto 161 iproc = nfipproc(isendto(jr),jpnj) 162 IF(iproc /= -1) THEN 163 iilb = nimppt(iproc+1) 164 ilci = nlcit (iproc+1) 165 ildi = nldit (iproc+1) 166 ilei = nleit (iproc+1) 167 IF( iilb == 1 ) ildi = 1 ! e-w boundary already done -> force to take 1st column 168 IF( iilb + ilci - 1 == jpiglo ) ilei = ilci ! e-w boundary already done -> force to take last column 169 iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj) 170 ENDIF 171 IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN 172 CALL mpprecv(5, zfoldwk, ibuffsize, iproc) 173 js = 0 174 DO jf = 1, ipf ; DO jj = 1, ipj_s(jf) 175 js = js + 1 176 DO jl = 1, ipl 177 DO jk = 1, ipk 178 DO ji = ildi, ilei 179 ztabr(iilb+ji,jj,jk,jl,jf) = zfoldwk(ji,js,jk,jl,1) 315 END DO ; END DO ; END DO 316 ! 317 ! start waiting time measurement 318 IF( ln_timing ) CALL tic_tac(.TRUE.) 319 CALL MPI_ALLGATHER( znorthloc, ibuffsize, MPI_TYPE, znorthglo, ibuffsize, MPI_TYPE, ncomm_north, ierr ) 320 ! stop waiting time measurement 321 IF( ln_timing ) CALL tic_tac(.FALSE.) 322 DEALLOCATE( znorthloc ) 323 ALLOCATE( ztabglo(jpiglo,ipj2,ipk,ipl,ipf) ) 324 ! 325 ! need to fill only the first ipj lines of ztabglo as lbc_nfd don't use the last nn_hls lines 326 ijnr = 0 327 DO jr = 1, jpni ! recover the global north array 328 iproc = nfproc(jr) 329 impp = nfimpp(jr) 330 ipi = nfjpi( jr) - 2 * nn_hls ! corresponds to Ni_0 but for subdomain iproc 331 IF( iproc == -1 ) THEN ! No neighbour (land proc that was suppressed) 332 ! 333 SELECT CASE ( kfillmode ) 334 CASE ( jpfillnothing ) ! no filling 335 CASE ( jpfillcopy ) ! filling with inner domain values 336 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk 337 DO jj = 1, ipj 338 ij2 = jpj - ipj2 + jj ! the first ipj lines of the last ipj2 lines 339 DO ji = 1, ipi 340 ii1 = impp + nn_hls + ji - 1 ! corresponds to mig(nn_hls + ji) but for subdomain iproc 341 ztabglo(ii1,jj,jk,jl,jf) = ARRAY_IN(Nis0,ij2,jk,jl,jf) ! chose to take the 1st iner domain point 180 342 END DO 181 343 END DO 344 END DO ; END DO ; END DO 345 CASE ( jpfillcst ) ! filling with constant value 346 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk 347 DO jj = 1, ipj 348 DO ji = 1, ipi 349 ii1 = impp + nn_hls + ji - 1 ! corresponds to mig(nn_hls + ji) but for subdomain iproc 350 ztabglo(ii1,jj,jk,jl,jf) = pfillval 351 END DO 352 END DO 353 END DO ; END DO ; END DO 354 END SELECT 355 ! 356 ELSE 357 ijnr = ijnr + 1 358 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk 359 DO jj = 1, ipj 360 DO ji = 1, ipi 361 ii1 = impp + nn_hls + ji - 1 ! corresponds to mig(nn_hls + ji) but for subdomain iproc 362 ztabglo(ii1,jj,jk,jl,jf) = znorthglo(ji,jj,jk,jl,jf,ijnr) 363 END DO 182 364 END DO 183 END DO; END DO 184 ELSE IF( iproc == narea-1 ) THEN 185 DO jf = 1, ipf ; DO jj = 1, ipj_s(jf) 186 DO jl = 1, ipl 187 DO jk = 1, ipk 188 DO ji = ildi, ilei 189 ztabr(iilb+ji,jj,jk,jl,jf) = ARRAY_IN(ji,jj_s(jf,jj),jk,jl,jf) 190 END DO 191 END DO 192 END DO 193 END DO; END DO 194 ENDIF 195 END DO 196 IF( l_isend ) THEN 197 DO jr = 1,nsndto 198 IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 199 CALL mpi_wait( ml_req_nf(jr), ml_stat, ml_err ) 200 ENDIF 365 END DO ; END DO ; END DO 366 ENDIF 367 ! 368 END DO ! jpni 369 DEALLOCATE( znorthglo ) 370 ! 371 DO jf = 1, ipf 372 CALL lbc_nfd( ztabglo(:,:,:,:,jf), cd_nat LBC_ARG, psgn LBC_ARG ) ! North fold boundary condition 373 DO jl = 1, ipl ; DO jk = 1, ipk ! e-w periodicity 374 DO jj = 1, nn_hls + 1 375 ij1 = ipj2 - (nn_hls + 1) + jj ! need only the last nn_hls + 1 lines until ipj2 376 ztabglo( 1:nn_hls,ij1,jk,jl,jf) = ztabglo(jpiglo-2*nn_hls+1:jpiglo-nn_hls,ij1,jk,jl,jf) 377 ztabglo(jpiglo-nn_hls+1:jpiglo,ij1,jk,jl,jf) = ztabglo( nn_hls+1: 2*nn_hls,ij1,jk,jl,jf) 378 END DO 379 END DO ; END DO 380 END DO 381 ! 382 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ! Scatter back to ARRAY_IN 383 DO jj = 1, nn_hls + 1 384 ij1 = jpj - (nn_hls + 1) + jj ! last nn_hls + 1 lines until jpj 385 ij2 = ipj2 - (nn_hls + 1) + jj ! last nn_hls + 1 lines until ipj2 386 DO ji= 1, jpi 387 ii2 = mig(ji) 388 ARRAY_IN(ji,ij1,jk,jl,jf) = ztabglo(ii2,ij2,jk,jl,jf) 389 END DO 201 390 END DO 202 ENDIF 203 ! 204 ! North fold boundary condition 205 ! 206 DO jf = 1, ipf 207 CALL lbc_nfd_nogather(ARRAY_IN(:,:,:,:,jf), ztabr(:,1:ipj_s(jf),:,:,jf), cd_nat LBC_ARG, psgn LBC_ARG ) 208 END DO 209 ! 210 DEALLOCATE( zfoldwk ) 211 DEALLOCATE( ztabr ) 212 DEALLOCATE( jj_s ) 213 DEALLOCATE( ipj_s ) 214 ELSE !== ???? ==! 215 ! 216 ipj = 4 ! 2nd dimension of message transfers (last j-lines) 217 ! 218 ALLOCATE( znorthloc(jpimax,ipj,ipk,ipl,ipf) ) 219 ! 220 DO jf = 1, ipf ! put in znorthloc the last ipj j-lines of ptab 221 DO jl = 1, ipl 222 DO jk = 1, ipk 223 DO jj = nlcj - ipj +1, nlcj 224 ij = jj - nlcj + ipj 225 znorthloc(1:jpi,ij,jk,jl,jf) = ARRAY_IN(1:jpi,jj,jk,jl,jf) 226 END DO 227 END DO 228 END DO 229 END DO 230 ! 231 ibuffsize = jpimax * ipj * ipk * ipl * ipf 232 ! 233 ALLOCATE( ztab (jpiglo,ipj,ipk,ipl,ipf ) ) 234 ALLOCATE( znorthgloio(jpimax,ipj,ipk,ipl,ipf,jpni) ) 235 ! 236 ! when some processors of the north fold are suppressed, 237 ! values of ztab* arrays corresponding to these suppressed domain won't be defined 238 ! and we need a default definition to 0. 239 ! a better test should be: a testing if "suppressed land-processors" belongs to the north-pole folding 240 IF ( jpni*jpnj /= jpnij ) ztab(:,:,:,:,:) = 0._wp 241 ! 242 CALL MPI_ALLGATHER( znorthloc , ibuffsize, MPI_DOUBLE_PRECISION, & 243 & znorthgloio, ibuffsize, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 244 ! 245 ! 246 DO jr = 1, ndim_rank_north ! recover the global north array 247 iproc = nrank_north(jr) + 1 248 iilb = nimppt(iproc) 249 ilci = nlcit (iproc) 250 ildi = nldit (iproc) 251 ilei = nleit (iproc) 252 IF( iilb == 1 ) ildi = 1 ! e-w boundary already done -> force to take 1st column 253 IF( iilb + ilci - 1 == jpiglo ) ilei = ilci ! e-w boundary already done -> force to take last column 254 DO jf = 1, ipf 255 DO jl = 1, ipl 256 DO jk = 1, ipk 257 DO jj = 1, ipj 258 DO ji = ildi, ilei 259 ztab(ji+iilb-1,jj,jk,jl,jf) = znorthgloio(ji,jj,jk,jl,jf,jr) 260 END DO 261 END DO 262 END DO 263 END DO 264 END DO 265 END DO 266 DO jf = 1, ipf 267 CALL lbc_nfd( ztab(:,:,:,:,jf), cd_nat LBC_ARG, psgn LBC_ARG ) ! North fold boundary condition 268 END DO 269 ! 270 DO jf = 1, ipf 271 DO jl = 1, ipl 272 DO jk = 1, ipk 273 DO jj = nlcj-ipj+1, nlcj ! Scatter back to ARRAY_IN 274 ij = jj - nlcj + ipj 275 DO ji= 1, nlci 276 ARRAY_IN(ji,jj,jk,jl,jf) = ztab(ji+nimpp-1,ij,jk,jl,jf) 277 END DO 278 END DO 279 END DO 280 END DO 281 END DO 282 ! 283 ! 284 DEALLOCATE( ztab ) 285 DEALLOCATE( znorthgloio ) 286 ENDIF 287 ! 288 DEALLOCATE( znorthloc ) 391 END DO ; END DO ; END DO 392 ! 393 DEALLOCATE( ztabglo ) 394 ! 395 ENDIF ! l_north_nogather 289 396 ! 290 397 END SUBROUTINE ROUTINE_NFD 291 398 399 #undef PRECISION 400 #undef MPI_TYPE 401 #undef SENDROUTINE 402 #undef RECVROUTINE 292 403 #undef ARRAY_TYPE 293 404 #undef NAT_IN … … 298 409 #undef F_SIZE 299 410 #undef LBC_ARG 411 #undef HUGEVAL
Note: See TracChangeset
for help on using the changeset viewer.
