- Timestamp:
- 2020-09-14T17:40:34+02:00 (4 years ago)
- Location:
- NEMO/branches/2019/dev_r11351_fldread_with_XIOS
- Files:
-
- 2 edited
-
. (modified) (1 prop)
-
src/OCE/LBC/mpp_nfd_generic.h90 (modified) (7 diffs)
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2019/dev_r11351_fldread_with_XIOS
- Property svn:externals
-
old new 3 3 ^/utils/build/mk@HEAD mk 4 4 ^/utils/tools@HEAD tools 5 ^/vendors/AGRIF/dev @HEADext/AGRIF5 ^/vendors/AGRIF/dev_r12970_AGRIF_CMEMS ext/AGRIF 6 6 ^/vendors/FCM@HEAD ext/FCM 7 7 ^/vendors/IOIPSL@HEAD ext/IOIPSL 8 9 # SETTE 10 ^/utils/CI/sette@13382 sette
-
- Property svn:externals
-
NEMO/branches/2019/dev_r11351_fldread_with_XIOS/src/OCE/LBC/mpp_nfd_generic.h90
r10440 r13463 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 ! Two lines update (slower but necessary to avoid different values ion identical grid points 98 IF ( l_full_nf_update .OR. & ! if coupling fields 99 ( ncom_stp == nit000 .AND. .NOT. ln_rstart ) ) & ! at first time step, if not restart 100 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) ) 101 152 102 153 ! Index of modifying lines in input 154 ij1 = 0 103 155 DO jf = 1, ipf ! Loop over the number of arrays to be processed 104 156 ! 105 157 SELECT CASE ( npolj ) 106 !107 158 CASE ( 3, 4 ) ! * North fold T-point pivot 108 !109 159 SELECT CASE ( NAT_IN(jf) ) 110 ! 111 CASE ( 'T' , 'W' ,'U' ) ! T-, U-, W-point 112 jj_s(jf,1) = nlcj - 2 ; jj_s(jf,2) = nlcj - 1 113 CASE ( 'V' , 'F' ) ! V-, F-point 114 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 115 162 END SELECT 116 ! 117 CASE ( 5, 6 ) ! * North fold F-point pivot 163 CASE ( 5, 6 ) ! * North fold F-point pivot 118 164 SELECT CASE ( NAT_IN(jf) ) 119 ! 120 CASE ( 'T' , 'W' ,'U' ) ! T-, U-, W-point 121 jj_s(jf,1) = nlcj - 1 122 ipj_s(jf) = 1 ! need only one line anyway 123 CASE ( 'V' , 'F' ) ! V-, F-point 124 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 125 167 END SELECT 126 !127 168 END SELECT 128 ! 129 ENDDO 130 ! 131 ipf_j = sum (ipj_s(:)) ! Total number of lines to be exchanged 132 ! 133 ALLOCATE( znorthloc(jpimax,ipf_j,ipk,ipl,1) ) 134 ! 135 js = 0 136 DO jf = 1, ipf ! Loop over the number of arrays to be processed 169 ! 137 170 DO jj = 1, ipj_s(jf) 138 js = js + 1 139 DO jl = 1, ipl 140 DO jk = 1, ipk 141 znorthloc(1:jpi,js,jk,jl,1) = ARRAY_IN(1:jpi,jj_s(jf,jj),jk,jl,jf) 142 END DO 143 END DO 171 ij1 = ij1 + 1 172 jj_b(jj,jf) = ij1 173 jj_s(jj,jf) = jpj - 2*nn_hls + jj - i012 144 174 END DO 175 ! 145 176 END DO 146 177 ! 147 ibuffsize = jpimax * ipf_j * ipk * ipl 148 ! 149 ALLOCATE( zfoldwk(jpimax,ipf_j,ipk,ipl,1) ) 150 ALLOCATE( ztabr(jpimax*jpmaxngh,ipj,ipk,ipl,ipf) ) 151 ! when some processors of the north fold are suppressed, 152 ! values of ztab* arrays corresponding to these suppressed domain won't be defined 153 ! and we need a default definition to 0. 154 ! a better test should be: a testing if "suppressed land-processors" belongs to the north-pole folding 155 IF ( jpni*jpnj /= jpnij ) ztabr(:,:,:,:,:) = 0._wp 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 156 193 ! 157 194 ! start waiting time measurement 158 195 IF( ln_timing ) CALL tic_tac(.TRUE.) 159 196 ! 197 ! send the data as soon as possible 160 198 DO jr = 1, nsndto 161 IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 162 CALL mppsend( 5, znorthloc, ibuffsize, nfipproc(isendto(jr),jpnj), ml_req_nf(jr) ) 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) ) 163 202 ENDIF 164 203 END DO 165 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 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 ! 166 285 DO jr = 1,nsndto 167 iproc = nfipproc(isendto(jr),jpnj) 168 IF(iproc /= -1) THEN 169 iilb = nimppt(iproc+1) 170 ilci = nlcit (iproc+1) 171 ildi = nldit (iproc+1) 172 ilei = nleit (iproc+1) 173 IF( iilb == 1 ) ildi = 1 ! e-w boundary already done -> force to take 1st column 174 IF( iilb + ilci - 1 == jpiglo ) ilei = ilci ! e-w boundary already done -> force to take last column 175 iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj) 176 ENDIF 286 iproc = nfproc(isendto(jr)) 177 287 IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN 178 CALL mpprecv(5, zfoldwk, ibuffsize, iproc) 179 js = 0 180 DO jf = 1, ipf ; DO jj = 1, ipj_s(jf) 181 js = js + 1 182 DO jl = 1, ipl 183 DO jk = 1, ipk 184 DO ji = ildi, ilei 185 ztabr(iilb+ji,jj,jk,jl,jf) = zfoldwk(ji,js,jk,jl,1) 186 END DO 187 END DO 188 END DO 189 END DO; END DO 190 ELSE IF( iproc == narea-1 ) THEN 191 DO jf = 1, ipf ; DO jj = 1, ipj_s(jf) 192 DO jl = 1, ipl 193 DO jk = 1, ipk 194 DO ji = ildi, ilei 195 ztabr(iilb+ji,jj,jk,jl,jf) = ARRAY_IN(ji,jj_s(jf,jj),jk,jl,jf) 196 END DO 197 END DO 198 END DO 199 END DO; END DO 288 CALL mpi_wait( ml_req_nf(jr), ml_stat, ml_err ) ! put the wait at the very end just before the deallocate 200 289 ENDIF 201 290 END DO 202 IF( l_isend ) THEN 203 DO jr = 1,nsndto 204 IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 205 CALL mpi_wait( ml_req_nf(jr), ml_stat, ml_err ) 206 ENDIF 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) 313 END DO 207 314 END DO 208 ENDIF 209 ! 210 IF( ln_timing ) CALL tic_tac(.FALSE.) 211 ! 212 ! North fold boundary condition 213 ! 214 DO jf = 1, ipf 215 CALL lbc_nfd_nogather(ARRAY_IN(:,:,:,:,jf), ztabr(:,1:ipj_s(jf),:,:,jf), cd_nat LBC_ARG, psgn LBC_ARG ) 216 END DO 217 ! 218 DEALLOCATE( zfoldwk ) 219 DEALLOCATE( ztabr ) 220 DEALLOCATE( jj_s ) 221 DEALLOCATE( ipj_s ) 222 ELSE !== ???? ==! 223 ! 224 ipj = 4 ! 2nd dimension of message transfers (last j-lines) 225 ! 226 ALLOCATE( znorthloc(jpimax,ipj,ipk,ipl,ipf) ) 227 ! 228 DO jf = 1, ipf ! put in znorthloc the last ipj j-lines of ptab 229 DO jl = 1, ipl 230 DO jk = 1, ipk 231 DO jj = nlcj - ipj +1, nlcj 232 ij = jj - nlcj + ipj 233 znorthloc(1:jpi,ij,jk,jl,jf) = ARRAY_IN(1:jpi,jj,jk,jl,jf) 234 END DO 235 END DO 236 END DO 237 END DO 238 ! 239 ibuffsize = jpimax * ipj * ipk * ipl * ipf 240 ! 241 ALLOCATE( ztab (jpiglo,ipj,ipk,ipl,ipf ) ) 242 ALLOCATE( znorthgloio(jpimax,ipj,ipk,ipl,ipf,jpni) ) 243 ! 244 ! when some processors of the north fold are suppressed, 245 ! values of ztab* arrays corresponding to these suppressed domain won't be defined 246 ! and we need a default definition to 0. 247 ! a better test should be: a testing if "suppressed land-processors" belongs to the north-pole folding 248 IF ( jpni*jpnj /= jpnij ) ztab(:,:,:,:,:) = 0._wp 315 END DO ; END DO ; END DO 249 316 ! 250 317 ! start waiting time measurement 251 318 IF( ln_timing ) CALL tic_tac(.TRUE.) 252 CALL MPI_ALLGATHER( znorthloc , ibuffsize, MPI_DOUBLE_PRECISION, & 253 & znorthgloio, ibuffsize, MPI_DOUBLE_PRECISION, ncomm_north, ierr )254 ! 319 #if defined key_mpp_mpi 320 CALL MPI_ALLGATHER( znorthloc, ibuffsize, MPI_TYPE, znorthglo, ibuffsize, MPI_TYPE, ncomm_north, ierr ) 321 #endif 255 322 ! stop waiting time measurement 256 323 IF( ln_timing ) CALL tic_tac(.FALSE.) 257 ! 258 DO jr = 1, ndim_rank_north ! recover the global north array 259 iproc = nrank_north(jr) + 1 260 iilb = nimppt(iproc) 261 ilci = nlcit (iproc) 262 ildi = nldit (iproc) 263 ilei = nleit (iproc) 264 IF( iilb == 1 ) ildi = 1 ! e-w boundary already done -> force to take 1st column 265 IF( iilb + ilci - 1 == jpiglo ) ilei = ilci ! e-w boundary already done -> force to take last column 266 DO jf = 1, ipf 267 DO jl = 1, ipl 268 DO jk = 1, ipk 324 DEALLOCATE( znorthloc ) 325 ALLOCATE( ztabglo(jpiglo,ipj2,ipk,ipl,ipf) ) 326 ! 327 ! need to fill only the first ipj lines of ztabglo as lbc_nfd don't use the last nn_hls lines 328 ijnr = 0 329 DO jr = 1, jpni ! recover the global north array 330 iproc = nfproc(jr) 331 impp = nfimpp(jr) 332 ipi = nfjpi( jr) - 2 * nn_hls ! corresponds to Ni_0 but for subdomain iproc 333 IF( iproc == -1 ) THEN ! No neighbour (land proc that was suppressed) 334 ! 335 SELECT CASE ( kfillmode ) 336 CASE ( jpfillnothing ) ! no filling 337 CASE ( jpfillcopy ) ! filling with inner domain values 338 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk 269 339 DO jj = 1, ipj 270 DO ji = ildi, ilei 271 ztab(ji+iilb-1,jj,jk,jl,jf) = znorthgloio(ji,jj,jk,jl,jf,jr) 340 ij2 = jpj - ipj2 + jj ! the first ipj lines of the last ipj2 lines 341 DO ji = 1, ipi 342 ii1 = impp + nn_hls + ji - 1 ! corresponds to mig(nn_hls + ji) but for subdomain iproc 343 ztabglo(ii1,jj,jk,jl,jf) = ARRAY_IN(Nis0,ij2,jk,jl,jf) ! chose to take the 1st iner domain point 272 344 END DO 273 345 END DO 346 END DO ; END DO ; END DO 347 CASE ( jpfillcst ) ! filling with constant value 348 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk 349 DO jj = 1, ipj 350 DO ji = 1, ipi 351 ii1 = impp + nn_hls + ji - 1 ! corresponds to mig(nn_hls + ji) but for subdomain iproc 352 ztabglo(ii1,jj,jk,jl,jf) = pfillval 353 END DO 354 END DO 355 END DO ; END DO ; END DO 356 END SELECT 357 ! 358 ELSE 359 ijnr = ijnr + 1 360 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk 361 DO jj = 1, ipj 362 DO ji = 1, ipi 363 ii1 = impp + nn_hls + ji - 1 ! corresponds to mig(nn_hls + ji) but for subdomain iproc 364 ztabglo(ii1,jj,jk,jl,jf) = znorthglo(ji,jj,jk,jl,jf,ijnr) 365 END DO 274 366 END DO 367 END DO ; END DO ; END DO 368 ENDIF 369 ! 370 END DO ! jpni 371 DEALLOCATE( znorthglo ) 372 ! 373 DO jf = 1, ipf 374 CALL lbc_nfd( ztabglo(:,:,:,:,jf), cd_nat LBC_ARG, psgn LBC_ARG ) ! North fold boundary condition 375 DO jl = 1, ipl ; DO jk = 1, ipk ! e-w periodicity 376 DO jj = 1, nn_hls + 1 377 ij1 = ipj2 - (nn_hls + 1) + jj ! need only the last nn_hls + 1 lines until ipj2 378 ztabglo( 1:nn_hls,ij1,jk,jl,jf) = ztabglo(jpiglo-2*nn_hls+1:jpiglo-nn_hls,ij1,jk,jl,jf) 379 ztabglo(jpiglo-nn_hls+1:jpiglo,ij1,jk,jl,jf) = ztabglo( nn_hls+1: 2*nn_hls,ij1,jk,jl,jf) 380 END DO 381 END DO ; END DO 382 END DO 383 ! 384 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ! Scatter back to ARRAY_IN 385 DO jj = 1, nn_hls + 1 386 ij1 = jpj - (nn_hls + 1) + jj ! last nn_hls + 1 lines until jpj 387 ij2 = ipj2 - (nn_hls + 1) + jj ! last nn_hls + 1 lines until ipj2 388 DO ji= 1, jpi 389 ii2 = mig(ji) 390 ARRAY_IN(ji,ij1,jk,jl,jf) = ztabglo(ii2,ij2,jk,jl,jf) 275 391 END DO 276 392 END DO 277 END DO 278 DO jf = 1, ipf 279 CALL lbc_nfd( ztab(:,:,:,:,jf), cd_nat LBC_ARG, psgn LBC_ARG ) ! North fold boundary condition 280 END DO 281 ! 282 DO jf = 1, ipf 283 DO jl = 1, ipl 284 DO jk = 1, ipk 285 DO jj = nlcj-ipj+1, nlcj ! Scatter back to ARRAY_IN 286 ij = jj - nlcj + ipj 287 DO ji= 1, nlci 288 ARRAY_IN(ji,jj,jk,jl,jf) = ztab(ji+nimpp-1,ij,jk,jl,jf) 289 END DO 290 END DO 291 END DO 292 END DO 293 END DO 294 ! 295 ! 296 DEALLOCATE( ztab ) 297 DEALLOCATE( znorthgloio ) 298 ENDIF 299 ! 300 DEALLOCATE( znorthloc ) 393 END DO ; END DO ; END DO 394 ! 395 DEALLOCATE( ztabglo ) 396 ! 397 ENDIF ! l_north_nogather 301 398 ! 302 399 END SUBROUTINE ROUTINE_NFD 303 400 401 #undef PRECISION 402 #undef MPI_TYPE 403 #undef SENDROUTINE 404 #undef RECVROUTINE 304 405 #undef ARRAY_TYPE 305 406 #undef NAT_IN … … 310 411 #undef F_SIZE 311 412 #undef LBC_ARG 413 #undef HUGEVAL
Note: See TracChangeset
for help on using the changeset viewer.
