Changeset 12993
- Timestamp:
- 2020-05-29T17:13:41+02:00 (5 years ago)
- Location:
- NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE
- Files:
-
- 5 edited
-
DOM/dom_oce.F90 (modified) (1 diff)
-
LBC/lbc_nfd_nogather_generic.h90 (modified) (14 diffs)
-
LBC/mpp_lnk_generic.h90 (modified) (1 diff)
-
LBC/mpp_nfd_generic.h90 (modified) (4 diffs)
-
LBC/mppini.F90 (modified) (4 diffs)
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/DOM/dom_oce.F90
r12978 r12993 104 104 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nis0all, njs0all !: first, last indoor index for all i-subdomain 105 105 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nie0all, nje0all !: first, last indoor index for all j-subdomain 106 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(: ,:) :: nfiimpp, nfipproc, nfijpit106 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nfimpp, nfproc, nfjpi 107 107 108 108 !!---------------------------------------------------------------------- -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/LBC/lbc_nfd_nogather_generic.h90
r12992 r12993 99 99 ijj = jpj -jj +1 100 100 DO ji = startloop, jpi 101 ijt = jpiglo - ji - nimpp - nfi impp(isendto(1),jpnj) + 4101 ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4 102 102 ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,jj,jk,jl,jf) 103 103 END DO … … 126 126 DO jl = 1, ipl; DO jk = 1, ipk 127 127 DO ji = startloop, jpi 128 ijt = jpiglo - ji - nimpp - nfi impp(isendto(1),jpnj) + 4128 ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4 129 129 jia = ji + nimpp - 1 130 130 ijta = jpiglo - jia + 2 … … 148 148 ijj = jpj -jj +1 149 149 DO ji = 1, endloop 150 iju = jpiglo - ji - nimpp - nfi impp(isendto(1),jpnj) + 3150 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 151 151 ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,jj,jk,jl,jf) 152 152 END DO … … 186 186 DO jl = 1, ipl; DO jk = 1, ipk 187 187 DO ji = startloop, endloop 188 iju = jpiglo - ji - nimpp - nfi impp(isendto(1),jpnj) + 3188 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 189 189 jia = ji + nimpp - 1 190 190 ijua = jpiglo - jia + 1 … … 210 210 ijj = jpj -jj +1 211 211 DO ji = startloop, jpi 212 ijt=jpiglo - ji - nimpp - nfi impp(isendto(1),jpnj) + 4212 ijt=jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4 213 213 ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,jj,jk,jl,jf) 214 214 END DO … … 218 218 DO jl = 1, ipl; DO jk = 1, ipk 219 219 DO ji = startloop, jpi 220 ijt=jpiglo - ji - nimpp - nfi impp(isendto(1),jpnj) + 4220 ijt=jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4 221 221 ARRAY_IN(ji,jpj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,1,jk,jl,jf) 222 222 END DO … … 241 241 ijj = jpj -jj +1 242 242 DO ji = 1, endloop 243 iju = jpiglo - ji - nimpp - nfi impp(isendto(1),jpnj) + 3243 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 244 244 ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,jj,jk,jl,jf) 245 245 END DO … … 249 249 DO jl = 1, ipl; DO jk = 1, ipk 250 250 DO ji = 1, endloop 251 iju = jpiglo - ji - nimpp - nfi impp(isendto(1),jpnj) + 3251 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 252 252 ARRAY_IN(ji,jpj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,1,jk,jl,jf) 253 253 END DO … … 290 290 ijj = jpj-jj+1 291 291 DO ji = 1, jpi 292 ijt = jpiglo - ji - nimpp - nfi impp(isendto(1),jpnj) + 3292 ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 293 293 ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,jj,jk,jl,jf) 294 294 END DO … … 306 306 ijj = jpj-jj+1 307 307 DO ji = 1, endloop 308 iju = jpiglo - ji - nimpp - nfi impp(isendto(1),jpnj) + 2308 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 2 309 309 ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,jj,jk,jl,jf) 310 310 END DO … … 328 328 ijj = jpj -jj +1 329 329 DO ji = 1, jpi 330 ijt = jpiglo - ji - nimpp - nfi impp(isendto(1),jpnj) + 3330 ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 331 331 ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,jj,jk,jl,jf) 332 332 END DO … … 345 345 DO jl = 1, ipl; DO jk = 1, ipk 346 346 DO ji = startloop, jpi 347 ijt = jpiglo - ji - nimpp - nfi impp(isendto(1),jpnj) + 3347 ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 348 348 ARRAY_IN(ji,jpj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,nn_hls+1,jk,jl,jf) 349 349 END DO … … 362 362 ijj = jpj -jj +1 363 363 DO ji = 1, endloop 364 iju = jpiglo - ji - nimpp - nfi impp(isendto(1),jpnj) + 2364 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 2 365 365 ARRAY_IN(ji,ijj ,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,jj,jk,jl,jf) 366 366 END DO … … 395 395 DO jl = 1, ipl; DO jk = 1, ipk 396 396 DO ji = startloop, endloop 397 iju = jpiglo - ji - nimpp - nfi impp(isendto(1),jpnj) + 2397 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 2 398 398 ARRAY_IN(ji,jpj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,nn_hls+1,jk,jl,jf) 399 399 END DO -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/LBC/mpp_lnk_generic.h90
r12807 r12993 238 238 ! 239 239 SELECT CASE ( jpni ) 240 CASE ( 1 ) ; CALL lbc_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) ) ! only 1 northern proc, no mpp241 CASE DEFAULT ; CALL mpp_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) ) ! for all northern procs.240 CASE ( 1 ) ; CALL lbc_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) ) ! only 1 northern proc, no mpp 241 CASE DEFAULT ; CALL mpp_nfd( ptab, NAT_IN(:), SGN_IN(:), ifill_no, zland OPT_K(:) ) ! for all northern procs. 242 242 END SELECT 243 243 ! -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/LBC/mpp_nfd_generic.h90
r12992 r12993 46 46 #endif 47 47 48 SUBROUTINE ROUTINE_NFD( ptab, cd_nat, psgn, kf ld )48 SUBROUTINE ROUTINE_NFD( ptab, cd_nat, psgn, kfillmode, pfillval, kfld ) 49 49 !!---------------------------------------------------------------------- 50 50 ARRAY_TYPE(:,:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied 51 51 CHARACTER(len=1) , INTENT(in ) :: NAT_IN(:) ! nature of array grid-points 52 52 REAL(wp) , INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary 53 INTEGER , INTENT(in ) :: kfillmode ! filling method for halo over land 54 REAL(wp) , INTENT(in ) :: pfillval ! background value (used at closed boundaries) 53 55 INTEGER, OPTIONAL, INTENT(in ) :: kfld ! number of pt3d arrays 54 56 ! 57 LOGICAL :: ll_add_line 55 58 INTEGER :: ji, jj, jk, jl, jh, jf, jr ! dummy loop indices 56 59 INTEGER :: ipi, ipk, ipl, ipf ! dimension of the input array 57 60 INTEGER :: imigr, iihom, ijhom ! local integers 58 61 INTEGER :: ierr, ibuffsize, ijpi, iis0, iie0, iilb 59 INTEGER :: ij, iproc 62 INTEGER :: ijbs, ijbe, ipimax2 63 INTEGER :: ij, iproc, ipni 60 64 INTEGER, DIMENSION (jpmaxngh) :: ml_req_nf ! for mpi_isend when avoiding mpi_allgather 61 65 INTEGER :: ml_err ! for mpi_isend when avoiding mpi_allgather 62 66 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for mpi_isend when avoiding mpi_allgather 63 67 ! ! Workspace for message transfers avoiding mpi_allgather 64 INTEGER :: ipf_j ! sum of lines for all multi fields 65 INTEGER :: js ! counter 66 INTEGER, DIMENSION(:,:), ALLOCATABLE :: jj_s ! position of sent lines 67 INTEGER, DIMENSION(:), ALLOCATABLE :: ipj_s ! number of sent lines 68 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: ztabl 69 REAL(wp), DIMENSION(:,:,:,:,:) , ALLOCATABLE :: ztab, ztabr 70 REAL(wp), DIMENSION(:,:,:,:,:) , ALLOCATABLE :: znorthloc, zfoldwk 68 INTEGER :: ipj_b ! sum of lines for all multi fields 69 INTEGER :: ijs, ijb ! j-counter for send and buffer 70 INTEGER :: i012 ! 0, 1 or 2 71 INTEGER , DIMENSION(:,:) , ALLOCATABLE :: jj_s ! position of sent lines 72 INTEGER , DIMENSION(:,:) , ALLOCATABLE :: jj_b ! position of buffer lines 73 INTEGER , DIMENSION(:) , ALLOCATABLE :: ipj_s ! number of sent lines 74 REAL(wp), DIMENSION(:,:,:,:) , ALLOCATABLE :: ztabb, ztabr, ztabw ! buffer, receive and work arrays 75 REAL(wp), DIMENSION(:,:,:,:,:) , ALLOCATABLE :: ztab, znorthloc 71 76 REAL(wp), DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: znorthgloio 72 77 !!---------------------------------------------------------------------- … … 78 83 IF( l_north_nogather ) THEN !== no allgather exchanges ==! 79 84 80 ALLOCATE(ipj_s(ipf)) 81 82 ijpj = 2 + nn_hls -1 ! Max 2nd dimension of message transfers (last two j-line only) 83 ipj_s(:) = 1 + nn_hls -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,ijpj) ) 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 85 ! --- define number of exchanged lines --- 86 ! 87 ! In theory we should exchange only nn_hls lines. 88 ! 89 ! However, some other points are duplicated in the north pole folding: 90 ! - jperio=[34], grid=T : half of the last line (jpiglo/2+2:jpiglo-nn_hls) 91 ! - jperio=[34], grid=U : half of the last line (jpiglo/2+1:jpiglo-nn_hls) 92 ! - jperio=[34], grid=V : all the last line nn_hls+1 and (nn_hls+2:jpiglo-nn_hls) 93 ! - jperio=[34], grid=F : all the last line (nn_hls+1:jpiglo-nn_hls) 94 ! - jperio=[56], grid=T : 2 points of the last line (jpiglo/2+1 and jpglo-nn_hls) 95 ! - jperio=[56], grid=U : no points are duplicated 96 ! - jperio=[56], grid=V : half of the last line (jpiglo/2+1:jpiglo-nn_hls) 97 ! - jperio=[56], grid=F : half of the last line (jpiglo/2+1:jpiglo-nn_hls-1) 98 ! The order of the calculations may differ for these duplicated points (as, for example jj+1 becomes jj-1) 99 ! This explain why these duplicated points may have different values even if they are at the exact same location. 100 ! In consequence, we may want to force the folding on these points by setting l_full_nf_update = .TRUE. 101 ! This is slightly slower but necessary to avoid different values on identical grid points!! 102 ! 92 103 !!!!!!!!! temporary switch off this optimisation ==> force TRUE !!!!!!!! 93 104 !!!!!!!!! needed to get the same results without agrif and with agrif and no zoom !!!!!!!! 94 105 !!!!!!!!! I don't know why we must do that... !!!!!!!! 95 106 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 + nn_hls -1 107 ! also force it if not restart during the first 2 steps (leap frog?) 108 ll_add_line = l_full_nf_update .OR. ( ncom_stp <= nit000+1 .AND. .NOT. ln_rstart ) 109 110 ALLOCATE(ipj_s(ipf)) ! how many lines do we exchange? 111 IF( ll_add_line ) THEN 112 DO jf = 1, ipf ! Loop over the number of arrays to be processed 113 ipj_s(jf) = nn_hls + COUNT( (/ npolj == 3 .OR. npolj == 4 .OR. NAT_IN(jf) == 'V' .OR. NAT_IN(jf) == 'F' /) ) 114 END DO 115 ELSE 116 ipj_s(:) = nn_hls 117 ENDIF 118 119 ijpj = MAXVAL(ipj_s(:)) ! Max 2nd dimension of message transfers (last two j-line only) 120 ipj_b = SUM( ipj_s(:)) ! Total number of lines to be exchanged 121 ALLOCATE( jj_s(ijpj, ipf), jj_b(ijpj, ipf) ) 101 122 102 123 ! Index of modifying lines in input 124 ijb = 0 103 125 DO jf = 1, ipf ! Loop over the number of arrays to be processed 104 126 ! 105 127 SELECT CASE ( npolj ) 106 !107 128 CASE ( 3, 4 ) ! * North fold T-point pivot 108 !109 129 SELECT CASE ( NAT_IN(jf) ) 110 ! 111 CASE ( 'T' , 'W' ,'U' ) ! T-, U-, W-point 112 DO ji = 1, nn_hls+1 113 jj_s(jf,ji) = jpj - 2*nn_hls +ji -1 114 ENDDO 115 CASE ( 'V' , 'F' ) ! V-, F-point 116 DO ji = 1, nn_hls+1 117 jj_s(jf,ji) = jpj - 2*nn_hls +ji - 2 118 ENDDO 130 CASE ( 'T', 'W', 'U' ) ; i012 = 1 ! T-, U-, W-point 131 CASE ( 'V', 'F' ) ; i012 = 2 ! V-, F-point 119 132 END SELECT 120 ! 121 CASE ( 5, 6 ) ! * North fold F-point pivot 133 CASE ( 5, 6 ) ! * North fold F-point pivot 122 134 SELECT CASE ( NAT_IN(jf) ) 123 ! 124 CASE ( 'T' , 'W' ,'U' ) ! T-, U-, W-point 125 DO ji = 1, nn_hls 126 jj_s(jf,ji) = jpj - 2*nn_hls + ji 127 ENDDO 128 ipj_s(jf) = nn_hls ! need only one line anyway 129 CASE ( 'V' , 'F' ) ! V-, F-point 130 DO ji = 1, nn_hls+1 131 jj_s(jf,ji) = jpj - 2*nn_hls +ji -1 132 ENDDO 135 CASE ( 'T', 'W', 'U' ) ; i012 = 0 ! T-, U-, W-point 136 CASE ( 'V', 'F' ) ; i012 = 1 ! V-, F-point 133 137 END SELECT 134 !135 138 END SELECT 136 ! 137 ENDDO 138 ! 139 ipf_j = sum (ipj_s(:)) ! Total number of lines to be exchanged 140 ! 141 ALLOCATE( znorthloc(jpimax,ipf_j,ipk,ipl,1) ) 142 ! 143 js = 0 144 DO jf = 1, ipf ! Loop over the number of arrays to be processed 139 ! 145 140 DO jj = 1, ipj_s(jf) 146 js = js+ 1147 DO jl = 1, ipl148 DO jk = 1, ipk149 znorthloc(1:jpi,js,jk,jl,1) = ARRAY_IN(1:jpi,jj_s(jf,jj),jk,jl,jf)150 END DO151 152 END DO153 END DO154 !155 ibuffsize = jpimax * ipf_j * ipk * ipl156 !157 ALLOCATE( zfoldwk(jpimax,ipf_j,ipk,ipl,1))158 ALLOCATE( ztabr(jpimax*jpmaxngh,ijpj,ipk,ipl,ipf) )159 ! when some processors of the north fold are suppressed,160 ! values of ztab* arrays corresponding to these suppressed domain won't be defined161 ! and we need a default definition to 0.162 ! a better test should be: a testing if "suppressed land-processors" belongs to the north-pole folding163 IF ( jpni*jpnj /= jpnij ) ztabr(:,:,:,:,:) = 0._wp141 ijb = ijb + 1 142 jj_b(jj,jf) = ijb 143 jj_s(jj,jf) = jpj - 2*nn_hls + jj - i012 144 END DO 145 ! 146 END DO 147 ! 148 ALLOCATE( ztabb(jpimax,ipj_b,ipk,ipl) ) ! store all the data to be sent in a buffer array 149 ibuffsize = jpimax * ipj_b * ipk * ipl 150 ! 151 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk 152 DO jj = 1, ipj_s(jf) 153 ijb = jj_b(jj,jf) 154 ijs = jj_s(jj,jf) 155 ztabb( 1:jpi ,ijb,jk,jl) = ARRAY_IN(1:jpi,ijs,jk,jl,jf) 156 ztabb(jpi+1:jpimax,ijb,jk,jl) = 0._wp ! needed? to avoid sending uninitialized values 157 END DO 158 END DO ; END DO ; END DO 164 159 ! 165 160 ! start waiting time measurement 166 161 IF( ln_timing ) CALL tic_tac(.TRUE.) 167 162 ! 163 ! send the data as soon as possible 168 164 DO jr = 1, nsndto 169 IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 170 CALL mppsend( 5, znorthloc, ibuffsize, nfipproc(isendto(jr),jpnj), ml_req_nf(jr) ) 171 ENDIF 172 END DO 165 iproc = nfproc(isendto(jr)) 166 IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN 167 CALL mppsend( 5, ztabb, ibuffsize, iproc, ml_req_nf(jr) ) 168 ENDIF 169 END DO 170 ! 171 ipimax2 = jpimax * jpmaxngh 172 ALLOCATE( ztabw(jpimax,ipj_b,ipk,ipl), ztabr(ipimax2,ipj_b,ipk,ipl) ) 173 ! 174 DO jr = 1, nsndto 175 ! 176 ipni = isendto(jr) 177 iproc = nfproc(ipni) 178 ijpi = nfjpi (ipni) 179 ! 180 IF( ipni == 1 ) THEN ; iis0 = 1 ! domain left side: as e-w comm already done -> from 1st column 181 ELSE ; iis0 = 1 + nn_hls ! default: -> from inner domain 182 ENDIF 183 IF( ipni == jpni ) THEN ; iie0 = ijpi ! domain right side: as e-w comm already done -> until last column 184 ELSE ; iie0 = ijpi - nn_hls ! default: -> until inner domain 185 ENDIF 186 iilb = nfimpp(ipni) - nfimpp(isendto(1)) 187 ! 188 IF( iproc == -1 ) THEN ! No neighbour (land proc that was suppressed) 189 ! 190 SELECT CASE ( kfillmode ) 191 CASE ( jpfillnothing ) ! no filling 192 CASE ( jpfillcopy ) ! filling with inner domain values 193 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk 194 DO jj = 1, ipj_s(jf) 195 ijb = jj_b(jj,jf) 196 ijs = jj_s(jj,jf) 197 DO ji = iis0, iie0 198 ztabr(iilb+ji,ijb,jk,jl) = ARRAY_IN(nn_hls+1,ijs,jk,jl,jf) ! chose to take the 1st iner domain point 199 END DO 200 END DO 201 END DO ; END DO ; END DO 202 CASE ( jpfillcst ) ! filling with constant value 203 DO jl = 1, ipl ; DO jk = 1, ipk 204 DO jj = 1, ipj_b 205 DO ji = iis0, iie0 206 ztabr(iilb+ji,jj,jk,jl) = pfillval 207 END DO 208 END DO 209 END DO ; END DO 210 END SELECT 211 ! 212 ELSE IF( iproc == narea-1 ) THEN ! get data from myself! 213 ! 214 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk 215 DO jj = 1, ipj_s(jf) 216 ijb = jj_b(jj,jf) 217 ijs = jj_s(jj,jf) 218 DO ji = iis0, iie0 219 ztabr(iilb+ji,ijb,jk,jl) = ARRAY_IN(ji,ijs,jk,jl,jf) 220 END DO 221 END DO 222 END DO ; END DO ; END DO 223 ! 224 ELSE ! get data from a neighbour trough communication 225 ! 226 CALL mpprecv(5, ztabw, ibuffsize, iproc) 227 DO jl = 1, ipl ; DO jk = 1, ipk 228 DO jj = 1, ipj_b 229 DO ji = iis0, iie0 230 ztabr(iilb+ji,jj,jk,jl) = ztabw(ji,jj,jk,jl) 231 END DO 232 END DO 233 END DO ; END DO 234 235 ENDIF 236 END DO 237 ! 238 IF( ln_timing ) CALL tic_tac(.FALSE.) 239 ! 240 ! North fold boundary condition 241 ! 242 DO jf = 1, ipf 243 ijbs = jj_b( 1 ,jf) 244 ijbe = jj_b(ipj_s(jf),jf) 245 CALL lbc_nfd_nogather( ARRAY_IN(:,:,:,:,jf), ztabr(:,ijbs:ijbe,:,:), cd_nat LBC_ARG, psgn LBC_ARG ) 246 END DO 247 ! 248 DEALLOCATE( ztabr, ztabw, jj_s, jj_b, ipj_s ) 173 249 ! 174 250 DO jr = 1,nsndto 175 iproc = nfipproc(isendto(jr),jpnj) 176 IF(iproc /= -1) THEN 177 iilb = nimppt(iproc+1) 178 ijpi = jpiall(iproc+1) 179 iis0 = nis0all(iproc+1) 180 iie0 = nie0all(iproc+1) 181 IF( iilb == 1 ) iis0 = 1 ! e-w boundary already done -> force to take 1st column 182 IF( iilb + ijpi - 1 == jpiglo ) iie0 = ijpi ! e-w boundary already done -> force to take last column 183 iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj) 184 ENDIF 251 iproc = nfproc(isendto(jr)) 185 252 IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN 186 CALL mpprecv(5, zfoldwk, ibuffsize, iproc) 187 js = 0 188 DO jf = 1, ipf ; DO jj = 1, ipj_s(jf) 189 js = js + 1 190 DO jl = 1, ipl 191 DO jk = 1, ipk 192 DO ji = iis0, iie0 193 ztabr(iilb+ji,jj,jk,jl,jf) = zfoldwk(ji,js,jk,jl,1) 194 END DO 195 END DO 196 END DO 197 END DO; END DO 198 ELSE IF( iproc == narea-1 ) THEN 199 DO jf = 1, ipf ; DO jj = 1, ipj_s(jf) 200 DO jl = 1, ipl 201 DO jk = 1, ipk 202 DO ji = iis0, iie0 203 ztabr(iilb+ji,jj,jk,jl,jf) = ARRAY_IN(ji,jj_s(jf,jj),jk,jl,jf) 204 END DO 205 END DO 206 END DO 207 END DO; END DO 208 ENDIF 209 END DO 210 DO jr = 1,nsndto 211 IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 212 CALL mpi_wait( ml_req_nf(jr), ml_stat, ml_err ) 213 ENDIF 214 END DO 215 ! 216 IF( ln_timing ) CALL tic_tac(.FALSE.) 217 ! 218 ! North fold boundary condition 219 ! 220 DO jf = 1, ipf 221 CALL lbc_nfd_nogather( ARRAY_IN(:,:,:,:,jf), ztabr(:,1:ipj_s(jf),:,:,jf), cd_nat LBC_ARG, psgn LBC_ARG ) 222 END DO 223 ! 224 DEALLOCATE( zfoldwk, ztabr, jj_s, ipj_s ) 253 CALL mpi_wait( ml_req_nf(jr), ml_stat, ml_err ) ! put the wait at the very end just before the deallocate 254 ENDIF 255 END DO 256 DEALLOCATE( ztabb ) 225 257 ! 226 258 ELSE !== allgather exchanges ==! … … 266 298 iis0 = nis0all(iproc) 267 299 iie0 = nie0all(iproc) 268 IF( iilb == 1 ) iis0 = 1 ! e-w boundary already done -> force to take 1st column269 IF( iilb + ijpi - 1 == jpiglo ) iie0 = ijpi ! e-w boundary already done -> force to take last column300 IF( iilb == 1 ) iis0 = 1 ! e-w boundary already done -> force to take all from 1st column 301 IF( iilb + ijpi - 1 == jpiglo ) iie0 = ijpi ! e-w boundary already done -> force to take all until last column 270 302 DO jf = 1, ipf 271 303 DO jl = 1, ipl … … 298 330 ! 299 331 ! 300 DEALLOCATE( ztab ) 301 DEALLOCATE( znorthgloio ) 332 DEALLOCATE( ztab, znorthgloio, znorthloc ) 302 333 ENDIF 303 !304 DEALLOCATE( znorthloc )305 334 ! 306 335 END SUBROUTINE ROUTINE_NFD -
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/LBC/mppini.F90
r12960 r12993 317 317 IF( numbot /= -1 ) CALL iom_close( numbot ) 318 318 IF( numbdy /= -1 ) CALL iom_close( numbdy ) 319 320 ALLOCATE( nfi impp(jpni,jpnj), nfipproc(jpni,jpnj), nfijpit(jpni,jpnj) ,&319 320 ALLOCATE( nfimpp(jpni ) , nfproc(jpni ) , nfjpi(jpni ) , & 321 321 & nimppt(jpnij) , ibonit(jpnij) , jpiall(jpnij) , jpjall(jpnij) , & 322 322 & njmppt(jpnij) , ibonjt(jpnij) , nis0all(jpnij) , njs0all(jpnij) , & … … 346 346 ! 347 347 CALL basic_decomposition( jpiglo, jpjglo, nn_hls, jpni, jpnj, jpimax, jpjmax, iimppt, ijmppt, ijpi, ijpj ) 348 nfi impp(:,:) = iimppt(:,:)349 nf ijpit(:,:) = ijpi(:,:)348 nfimpp(:) = iimppt(:,jpnj) 349 nfjpi (:) = ijpi(:,jpnj) 350 350 ! 351 351 IF(lwp) THEN … … 458 458 ENDIF 459 459 END DO 460 nf ipproc(:,:) = ipproc(:,:)460 nfproc(:) = ipproc(:,jpnj) 461 461 462 462 ! neighbour treatment: change ibondi, ibondj if next to a land zone … … 1260 1260 DO jn = 1, jpni 1261 1261 ! 1262 sxT = nfi impp(jn, jpnj)! sxT = 1st point (in the global domain) of the jn process1263 dxT = nfi impp(jn, jpnj) + nfijpit(jn, jpnj) - 1 ! dxT = last point (in the global domain) of the jn process1262 sxT = nfimpp(jn) ! sxT = 1st point (in the global domain) of the jn process 1263 dxT = nfimpp(jn) + nfjpi(jn) - 1 ! dxT = last point (in the global domain) of the jn process 1264 1264 ! 1265 1265 IF ( sxT < sxM .AND. sxM < dxT ) THEN
Note: See TracChangeset
for help on using the changeset viewer.
