Changeset 10425 for NEMO/trunk/src/OCE/LBC/mpp_nfd_generic.h90
- Timestamp:
- 2018-12-19T22:54:16+01:00 (5 years ago)
- File:
-
- 1 edited
-
NEMO/trunk/src/OCE/LBC/mpp_nfd_generic.h90 (modified) (7 diffs)
Legend:
- Unmodified
- Added
- Removed
-
NEMO/trunk/src/OCE/LBC/mpp_nfd_generic.h90
r10068 r10425 56 56 INTEGER :: ipi, ipj, ipk, ipl, ipf ! dimension of the input array 57 57 INTEGER :: imigr, iihom, ijhom ! local integers 58 INTEGER :: ierr, i taille, ilci, ildi, ilei, iilb58 INTEGER :: ierr, ibuffsize, ilci, ildi, ilei, iilb 59 59 INTEGER :: ij, iproc 60 60 INTEGER, DIMENSION (jpmaxngh) :: ml_req_nf ! for mpi_isend when avoiding mpi_allgather … … 62 62 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for mpi_isend when avoiding mpi_allgather 63 63 ! ! Workspace for message transfers avoiding mpi_allgather 64 REAL(wp), DIMENSION(:,:,:,:,:) , ALLOCATABLE :: ztab, ztabl, ztabr 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 65 70 REAL(wp), DIMENSION(:,:,:,:,:) , ALLOCATABLE :: znorthloc, zfoldwk 66 71 REAL(wp), DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: znorthgloio … … 71 76 ipf = F_SIZE(ptab) ! 5th - use in "multi" case (array of pointers) 72 77 ! 73 ipj = 4 ! 2nd dimension of message transfers (last j-lines) 74 ! 75 ALLOCATE( znorthloc(jpimax,4,ipk,ipl,ipf) ) 76 ! 77 znorthloc(:,:,:,:,:) = 0._wp 78 ! 79 DO jf = 1, ipf ! put in znorthloc the last ipj j-lines of ptab 80 DO jl = 1, ipl 81 DO jk = 1, ipk 82 DO jj = nlcj - ipj +1, nlcj 83 ij = jj - nlcj + ipj 84 znorthloc(1:jpi,ij,jk,jl,jf) = ARRAY_IN(1:jpi,jj,jk,jl,jf) 78 IF( l_north_nogather ) THEN !== ???? ==! 79 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 92 !!!!!!!!! temporary switch off this optimisation ==> force TRUE !!!!!!!! 93 l_full_nf_update = .TRUE. 94 95 ! Two lines update (slower but necessary to avoid different values ion identical grid points 96 IF ( l_full_nf_update .OR. & ! if coupling fields 97 ( ncom_stp == nit000 .AND. .NOT. ln_rstart ) ) & ! at first time step, if not restart 98 ipj_s(:) = 2 99 100 ! Index of modifying lines in input 101 DO jf = 1, ipf ! Loop over the number of arrays to be processed 102 ! 103 SELECT CASE ( npolj ) 104 ! 105 CASE ( 3, 4 ) ! * North fold T-point pivot 106 ! 107 SELECT CASE ( NAT_IN(jf) ) 108 ! 109 CASE ( 'T' , 'W' ,'U' ) ! T-, U-, W-point 110 jj_s(jf,1) = nlcj - 2 ; jj_s(jf,2) = nlcj - 1 111 CASE ( 'V' , 'F' ) ! V-, F-point 112 jj_s(jf,1) = nlcj - 3 ; jj_s(jf,2) = nlcj - 2 113 END SELECT 114 ! 115 CASE ( 5, 6 ) ! * North fold F-point pivot 116 SELECT CASE ( NAT_IN(jf) ) 117 ! 118 CASE ( 'T' , 'W' ,'U' ) ! T-, U-, W-point 119 jj_s(jf,1) = nlcj - 1 120 ipj_s(jf) = 1 ! need only one line anyway 121 CASE ( 'V' , 'F' ) ! V-, F-point 122 jj_s(jf,1) = nlcj - 2 ; jj_s(jf,2) = nlcj - 1 123 END SELECT 124 ! 125 END SELECT 126 ! 127 ENDDO 128 ! 129 ipf_j = sum (ipj_s(:)) ! Total number of lines to be exchanged 130 ! 131 ALLOCATE( znorthloc(jpimax,ipf_j,ipk,ipl,1) ) 132 ! 133 js = 0 134 DO jf = 1, ipf ! Loop over the number of arrays to be processed 135 DO jj = 1, ipj_s(jf) 136 js = js + 1 137 DO jl = 1, ipl 138 DO jk = 1, ipk 139 znorthloc(1:jpi,js,jk,jl,1) = ARRAY_IN(1:jpi,jj_s(jf,jj),jk,jl,jf) 140 END DO 85 141 END DO 86 142 END DO 87 143 END DO 88 END DO 89 ! 90 ! 91 itaille = jpimax * ipj * ipk * ipl * ipf 92 ! 93 IF( l_north_nogather ) THEN !== ???? ==! 94 ALLOCATE( zfoldwk(jpimax,4,ipk,ipl,ipf) ) 95 ALLOCATE( ztabl(jpimax ,4,ipk,ipl,ipf) , ztabr(jpimax*jpmaxngh,4,ipk,ipl,ipf) ) 96 ! 144 ! 145 ibuffsize = jpimax * ipf_j * ipk * ipl 146 ! 147 ALLOCATE( zfoldwk(jpimax,ipf_j,ipk,ipl,1) ) 148 ALLOCATE( ztabr(jpimax*jpmaxngh,ipj,ipk,ipl,ipf) ) 97 149 ! when some processors of the north fold are suppressed, 98 150 ! values of ztab* arrays corresponding to these suppressed domain won't be defined 99 151 ! and we need a default definition to 0. 100 152 ! a better test should be: a testing if "suppressed land-processors" belongs to the north-pole folding 101 IF ( jpni*jpnj /= jpnij ) THEN 102 ztabr(:,:,:,:,:) = 0._wp 103 ztabl(:,:,:,:,:) = 0._wp 104 END IF 105 ! 106 DO jf = 1, ipf 107 DO jl = 1, ipl 108 DO jk = 1, ipk 109 DO jj = nlcj-ipj+1, nlcj ! First put local values into the global array 110 ij = jj - nlcj + ipj 111 DO ji = nfsloop, nfeloop 112 ztabl(ji,ij,jk,jl,jf) = ARRAY_IN(ji,jj,jk,jl,jf) 113 END DO 114 END DO 115 END DO 116 END DO 117 END DO 153 IF ( jpni*jpnj /= jpnij ) ztabr(:,:,:,:,:) = 0._wp 154 ! 155 ! start waiting time measurement 156 IF( ln_timing ) CALL tic_tac(.TRUE.) 118 157 ! 119 158 DO jr = 1, nsndto 120 159 IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 121 CALL mppsend( 5, znorthloc, itaille, nfipproc(isendto(jr),jpnj), ml_req_nf(jr) )160 CALL mppsend( 5, znorthloc, ibuffsize, nfipproc(isendto(jr),jpnj), ml_req_nf(jr) ) 122 161 ENDIF 123 162 END DO 163 ! 124 164 DO jr = 1,nsndto 125 165 iproc = nfipproc(isendto(jr),jpnj) … … 134 174 ENDIF 135 175 IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN 136 CALL mpprecv(5, zfoldwk, itaille, iproc) 137 DO jf = 1, ipf 176 CALL mpprecv(5, zfoldwk, ibuffsize, iproc) 177 js = 0 178 DO jf = 1, ipf ; DO jj = 1, ipj_s(jf) 179 js = js + 1 138 180 DO jl = 1, ipl 139 181 DO jk = 1, ipk 140 DO jj = 1, ipj 141 DO ji = ildi, ilei 142 ztabr(iilb+ji,jj,jk,jl,jf) = zfoldwk(ji,jj,jk,jl,jf) 143 END DO 182 DO ji = ildi, ilei 183 ztabr(iilb+ji,jj,jk,jl,jf) = zfoldwk(ji,js,jk,jl,1) 144 184 END DO 145 185 END DO 146 186 END DO 147 END DO 187 END DO; END DO 148 188 ELSE IF( iproc == narea-1 ) THEN 149 DO jf = 1, ipf 189 DO jf = 1, ipf ; DO jj = 1, ipj_s(jf) 150 190 DO jl = 1, ipl 151 191 DO jk = 1, ipk 152 DO jj = 1, ipj 153 DO ji = ildi, ilei 154 ztabr(iilb+ji,jj,jk,jl,jf) = ARRAY_IN(ji,nlcj-ipj+jj,jk,jl,jf) 155 END DO 192 DO ji = ildi, ilei 193 ztabr(iilb+ji,jj,jk,jl,jf) = ARRAY_IN(ji,jj_s(jf,jj),jk,jl,jf) 156 194 END DO 157 195 END DO 158 196 END DO 159 END DO 197 END DO; END DO 160 198 ENDIF 161 199 END DO … … 164 202 IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 165 203 CALL mpi_wait( ml_req_nf(jr), ml_stat, ml_err ) 166 ENDIF 204 ENDIF 167 205 END DO 168 206 ENDIF 207 ! 208 IF( ln_timing ) CALL tic_tac(.FALSE.) 209 ! 210 ! North fold boundary condition 211 ! 169 212 DO jf = 1, ipf 170 CALL lbc_nfd_nogather( ztabl(:,:,:,:,jf), ztabr(:,:,:,:,jf), cd_nat LBC_ARG, psgn LBC_ARG ) ! North fold boundary condition 171 END DO 172 DO jf = 1, ipf 213 CALL lbc_nfd_nogather(ARRAY_IN(:,:,:,:,jf), ztabr(:,1:ipj_s(jf),:,:,jf), cd_nat LBC_ARG, psgn LBC_ARG ) 214 END DO 215 ! 216 DEALLOCATE( zfoldwk ) 217 DEALLOCATE( ztabr ) 218 DEALLOCATE( jj_s ) 219 DEALLOCATE( ipj_s ) 220 ELSE !== ???? ==! 221 ! 222 ipj = 4 ! 2nd dimension of message transfers (last j-lines) 223 ! 224 ALLOCATE( znorthloc(jpimax,ipj,ipk,ipl,ipf) ) 225 ! 226 DO jf = 1, ipf ! put in znorthloc the last ipj j-lines of ptab 173 227 DO jl = 1, ipl 174 228 DO jk = 1, ipk 175 DO jj = nlcj -ipj+1, nlcj ! Scatter back to ARRAY_IN229 DO jj = nlcj - ipj +1, nlcj 176 230 ij = jj - nlcj + ipj 177 DO ji= 1, nlci 178 ARRAY_IN(ji,jj,jk,jl,jf) = ztabl(ji,ij,jk,jl,jf) 179 END DO 231 znorthloc(1:jpi,ij,jk,jl,jf) = ARRAY_IN(1:jpi,jj,jk,jl,jf) 180 232 END DO 181 233 END DO … … 183 235 END DO 184 236 ! 185 DEALLOCATE( zfoldwk ) 186 DEALLOCATE( ztabl, ztabr ) 187 ELSE !== ???? ==! 188 ALLOCATE( ztab (jpiglo,4,ipk,ipl,ipf ) ) 189 ALLOCATE( znorthgloio(jpimax,4,ipk,ipl,ipf,jpni) ) 237 ibuffsize = jpimax * ipj * ipk * ipl * ipf 238 ! 239 ALLOCATE( ztab (jpiglo,ipj,ipk,ipl,ipf ) ) 240 ALLOCATE( znorthgloio(jpimax,ipj,ipk,ipl,ipf,jpni) ) 190 241 ! 191 242 ! when some processors of the north fold are suppressed, … … 193 244 ! and we need a default definition to 0. 194 245 ! a better test should be: a testing if "suppressed land-processors" belongs to the north-pole folding 195 IF ( jpni*jpnj /= jpnij ) ztab(:,:,:,:,:)=0._wp 196 ! 197 CALL MPI_ALLGATHER( znorthloc , itaille, MPI_DOUBLE_PRECISION, & 198 & znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 246 IF ( jpni*jpnj /= jpnij ) ztab(:,:,:,:,:) = 0._wp 247 ! 248 ! start waiting time measurement 249 IF( ln_timing ) CALL tic_tac(.TRUE.) 250 CALL MPI_ALLGATHER( znorthloc , ibuffsize, MPI_DOUBLE_PRECISION, & 251 & znorthgloio, ibuffsize, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 252 ! 253 ! stop waiting time measurement 254 IF( ln_timing ) CALL tic_tac(.FALSE.) 199 255 ! 200 256 DO jr = 1, ndim_rank_north ! recover the global north array
Note: See TracChangeset
for help on using the changeset viewer.
