Changeset 12993 for NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/LBC/mpp_nfd_generic.h90
- Timestamp:
- 2020-05-29T17:13:41+02:00 (4 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
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
Note: See TracChangeset
for help on using the changeset viewer.
