| 1 | |
|---|
| 2 | SUBROUTINE mpp_nfd_/**/PRECISION( ptab, cd_nat, psgn, kfillmode, pfillval, khls, kfld ) |
|---|
| 3 | TYPE(PTR_4d_/**/PRECISION), DIMENSION(:), INTENT(inout) :: ptab ! pointer of arrays on which apply the b.c. |
|---|
| 4 | CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: cd_nat ! nature of array grid-points |
|---|
| 5 | REAL(PRECISION), DIMENSION(:), INTENT(in ) :: psgn ! sign used across the north fold boundary |
|---|
| 6 | INTEGER , INTENT(in ) :: kfillmode ! filling method for halo over land |
|---|
| 7 | REAL(PRECISION) , INTENT(in ) :: pfillval ! background value (used at closed boundaries) |
|---|
| 8 | INTEGER , INTENT(in ) :: khls ! halo size, default = nn_hls |
|---|
| 9 | INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays |
|---|
| 10 | ! |
|---|
| 11 | LOGICAL :: ll_add_line |
|---|
| 12 | INTEGER :: ji, jj, jk, jl, jf, jr, jg, jn ! dummy loop indices |
|---|
| 13 | INTEGER :: ipi, ipj, ipj2, ipk, ipl, ipf ! dimension of the input array |
|---|
| 14 | INTEGER :: ierr, ibuffsize, iis0, iie0, impp |
|---|
| 15 | INTEGER :: ii1, ii2, ij1, ij2, iis, iie, iib, iig, iin |
|---|
| 16 | INTEGER :: i0max |
|---|
| 17 | INTEGER :: ij, iproc, ipni, ijnr |
|---|
| 18 | INTEGER, DIMENSION (:), ALLOCATABLE :: ireq_s, ireq_r ! for mpi_isend when avoiding mpi_allgather |
|---|
| 19 | INTEGER :: ipjtot ! sum of lines for all multi fields |
|---|
| 20 | INTEGER :: i012 ! 0, 1 or 2 |
|---|
| 21 | INTEGER , DIMENSION(:,:) , ALLOCATABLE :: ijsnd ! j-position of sent lines for each field |
|---|
| 22 | INTEGER , DIMENSION(:,:) , ALLOCATABLE :: ijbuf ! j-position of send buffer lines for each field |
|---|
| 23 | INTEGER , DIMENSION(:,:) , ALLOCATABLE :: ijrcv ! j-position of recv buffer lines for each field |
|---|
| 24 | INTEGER , DIMENSION(:,:) , ALLOCATABLE :: ii1st, iiend |
|---|
| 25 | INTEGER , DIMENSION(:) , ALLOCATABLE :: ipjfld ! number of sent lines for each field |
|---|
| 26 | REAL(PRECISION), DIMENSION(:,:,:,:) , ALLOCATABLE :: zbufs ! buffer, receive and work arrays |
|---|
| 27 | REAL(PRECISION), DIMENSION(:,:,:,:,:) , ALLOCATABLE :: zbufr ! buffer, receive and work arrays |
|---|
| 28 | REAL(PRECISION), DIMENSION(:,:,:,:,:) , ALLOCATABLE :: znorthloc |
|---|
| 29 | REAL(PRECISION), DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: znorthglo |
|---|
| 30 | TYPE(PTR_4D_/**/PRECISION), DIMENSION(:), ALLOCATABLE :: ztabglo ! array or pointer of arrays on which apply the b.c. |
|---|
| 31 | !!---------------------------------------------------------------------- |
|---|
| 32 | ! |
|---|
| 33 | ipk = SIZE(ptab(1)%pt4d,3) |
|---|
| 34 | ipl = SIZE(ptab(1)%pt4d,4) |
|---|
| 35 | ipf = kfld |
|---|
| 36 | ! |
|---|
| 37 | IF( ln_nnogather ) THEN !== no allgather exchanges ==! |
|---|
| 38 | |
|---|
| 39 | ! --- define number of exchanged lines --- |
|---|
| 40 | ! |
|---|
| 41 | ! In theory we should exchange only nn_hls lines. |
|---|
| 42 | ! |
|---|
| 43 | ! However, some other points are duplicated in the north pole folding: |
|---|
| 44 | ! - c_NFtype='T', grid=T : half of the last line (jpiglo/2+2:jpiglo-nn_hls) |
|---|
| 45 | ! - c_NFtype='T', grid=U : half of the last line (jpiglo/2+1:jpiglo-nn_hls) |
|---|
| 46 | ! - c_NFtype='T', grid=V : all the last line nn_hls+1 and (nn_hls+2:jpiglo-nn_hls) |
|---|
| 47 | ! - c_NFtype='T', grid=F : all the last line (nn_hls+1:jpiglo-nn_hls) |
|---|
| 48 | ! - c_NFtype='F', grid=T : 2 points of the last line (jpiglo/2+1 and jpglo-nn_hls) |
|---|
| 49 | ! - c_NFtype='F', grid=U : no points are duplicated |
|---|
| 50 | ! - c_NFtype='F', grid=V : half of the last line (jpiglo/2+1:jpiglo-nn_hls) |
|---|
| 51 | ! - c_NFtype='F', grid=F : half of the last line (jpiglo/2+1:jpiglo-nn_hls-1) |
|---|
| 52 | ! The order of the calculations may differ for these duplicated points (as, for example jj+1 becomes jj-1) |
|---|
| 53 | ! This explain why these duplicated points may have different values even if they are at the exact same location. |
|---|
| 54 | ! In consequence, we may want to force the folding on these points by setting l_full_nf_update = .TRUE. |
|---|
| 55 | ! This is slightly slower but necessary to avoid different values on identical grid points!! |
|---|
| 56 | ! |
|---|
| 57 | !!!!!!!!! temporary switch off this optimisation ==> force TRUE !!!!!!!! |
|---|
| 58 | !!!!!!!!! needed to get the same results without agrif and with agrif and no zoom !!!!!!!! |
|---|
| 59 | !!!!!!!!! I don't know why we must do that... !!!!!!!! |
|---|
| 60 | l_full_nf_update = .TRUE. |
|---|
| 61 | ! also force it if not restart during the first 2 steps (leap frog?) |
|---|
| 62 | ll_add_line = l_full_nf_update .OR. ( ncom_stp <= nit000+1 .AND. .NOT. ln_rstart ) |
|---|
| 63 | |
|---|
| 64 | ALLOCATE(ipjfld(ipf)) ! how many lines do we exchange for each field? |
|---|
| 65 | IF( ll_add_line ) THEN |
|---|
| 66 | DO jf = 1, ipf ! Loop over the number of arrays to be processed |
|---|
| 67 | ipjfld(jf) = khls + COUNT( (/ c_NFtype == 'T' .OR. cd_nat(jf) == 'V' .OR. cd_nat(jf) == 'F' /) ) |
|---|
| 68 | END DO |
|---|
| 69 | ELSE |
|---|
| 70 | ipjfld(:) = khls |
|---|
| 71 | ENDIF |
|---|
| 72 | |
|---|
| 73 | ipj = MAXVAL(ipjfld(:)) ! Max 2nd dimension of message transfers |
|---|
| 74 | ipjtot = SUM( ipjfld(:)) ! Total number of lines to be exchanged |
|---|
| 75 | |
|---|
| 76 | ! Index of modifying lines in input |
|---|
| 77 | ALLOCATE( ijsnd(ipj, ipf), ijbuf(ipj, ipf), ijrcv(ipj, ipf), ii1st(ipj, ipf), iiend(ipj, ipf) ) |
|---|
| 78 | |
|---|
| 79 | ij1 = 0 |
|---|
| 80 | DO jf = 1, ipf ! Loop over the number of arrays to be processed |
|---|
| 81 | ! |
|---|
| 82 | DO jj = 1, khls ! first khls lines (starting from top) must be fully defined |
|---|
| 83 | ii1st(jj, jf) = 1 |
|---|
| 84 | iiend(jj, jf) = jpi |
|---|
| 85 | END DO |
|---|
| 86 | ! |
|---|
| 87 | ! what do we do with line khls+1 (starting from top) |
|---|
| 88 | IF( c_NFtype == 'T' ) THEN ! * North fold T-point pivot |
|---|
| 89 | SELECT CASE ( cd_nat(jf) ) |
|---|
| 90 | CASE ('T','W') ; i012 = 1 ; ii1st(khls+1, jf) = mi0(jpiglo/2+2) ; iiend(khls+1, jf) = mi1(jpiglo-khls) |
|---|
| 91 | CASE ('U' ) ; i012 = 1 ; ii1st(khls+1, jf) = mi0(jpiglo/2+1) ; iiend(khls+1, jf) = mi1(jpiglo-khls) |
|---|
| 92 | CASE ('V' ) ; i012 = 2 ; ii1st(khls+1, jf) = 1 ; iiend(khls+1, jf) = jpi |
|---|
| 93 | CASE ('F' ) ; i012 = 2 ; ii1st(khls+1, jf) = 1 ; iiend(khls+1, jf) = jpi |
|---|
| 94 | END SELECT |
|---|
| 95 | ENDIF |
|---|
| 96 | IF( c_NFtype == 'F' ) THEN ! * North fold F-point pivot |
|---|
| 97 | SELECT CASE ( cd_nat(jf) ) |
|---|
| 98 | CASE ('T','W') ; i012 = 0 ! we don't touch line khls+1 |
|---|
| 99 | CASE ('U' ) ; i012 = 0 ! we don't touch line khls+1 |
|---|
| 100 | CASE ('V' ) ; i012 = 1 ; ii1st(khls+1, jf) = mi0(jpiglo/2+1) ; iiend(khls+1, jf) = mi1(jpiglo-khls ) |
|---|
| 101 | CASE ('F' ) ; i012 = 1 ; ii1st(khls+1, jf) = mi0(jpiglo/2+1) ; iiend(khls+1, jf) = mi1(jpiglo-khls-1) |
|---|
| 102 | END SELECT |
|---|
| 103 | ENDIF |
|---|
| 104 | ! |
|---|
| 105 | DO jj = 1, ipjfld(jf) |
|---|
| 106 | ij1 = ij1 + 1 |
|---|
| 107 | ijsnd(jj,jf) = jpj - 2*khls + jj - i012 ! sent lines (from bottom of sent lines) |
|---|
| 108 | ijbuf(jj,jf) = ij1 ! gather all lines in the snd/rcv buffers |
|---|
| 109 | ijrcv(jj,jf) = jpj - jj + 1 ! recv lines (from the top -> reverse order for jj) |
|---|
| 110 | END DO |
|---|
| 111 | ! |
|---|
| 112 | END DO |
|---|
| 113 | ! |
|---|
| 114 | i0max = jpimax - 2 * khls ! we are not sending the halos |
|---|
| 115 | ALLOCATE( zbufs(i0max,ipjtot,ipk,ipl), ireq_s(nfd_nbnei) ) ! store all the data to be sent in a buffer array |
|---|
| 116 | ibuffsize = i0max * ipjtot * ipk * ipl |
|---|
| 117 | ! |
|---|
| 118 | ! fill the send buffer with all the lines |
|---|
| 119 | DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk |
|---|
| 120 | DO jj = 1, ipjfld(jf) |
|---|
| 121 | ij1 = ijbuf(jj,jf) |
|---|
| 122 | ij2 = ijsnd(jj,jf) |
|---|
| 123 | DO ji = Nis0, Nie0 ! should not use any other value |
|---|
| 124 | iib = ji - Nis0 + 1 |
|---|
| 125 | zbufs(iib,ij1,jk,jl) = ptab(jf)%pt4d(ji,ij2,jk,jl) |
|---|
| 126 | END DO |
|---|
| 127 | DO ji = Ni_0+1, i0max ! avoid sending uninitialized values (make sure we don't use it) |
|---|
| 128 | zbufs(ji,ij1,jk,jl) = HUGE(0._/**/PRECISION) ! make sure we don't use it... |
|---|
| 129 | END DO |
|---|
| 130 | END DO |
|---|
| 131 | END DO ; END DO ; END DO |
|---|
| 132 | ! |
|---|
| 133 | ! start waiting time measurement |
|---|
| 134 | IF( ln_timing ) CALL tic_tac(.TRUE.) |
|---|
| 135 | ! |
|---|
| 136 | ! send the same buffer data to all neighbourgs as soon as possible |
|---|
| 137 | DO jn = 1, nfd_nbnei |
|---|
| 138 | iproc = nfd_rknei(jn) |
|---|
| 139 | IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN |
|---|
| 140 | #if ! defined key_mpi_off |
|---|
| 141 | CALL MPI_Isend( zbufs, ibuffsize, MPI_TYPE, iproc, 5, mpi_comm_oce, ireq_s(jn), ierr ) |
|---|
| 142 | #endif |
|---|
| 143 | ELSE |
|---|
| 144 | ireq_s(jn) = MPI_REQUEST_NULL |
|---|
| 145 | ENDIF |
|---|
| 146 | END DO |
|---|
| 147 | ! |
|---|
| 148 | ALLOCATE( zbufr(i0max,ipjtot,ipk,ipl,nfd_nbnei), ireq_r(nfd_nbnei) ) |
|---|
| 149 | ! |
|---|
| 150 | DO jn = 1, nfd_nbnei |
|---|
| 151 | ! |
|---|
| 152 | iproc = nfd_rknei(jn) |
|---|
| 153 | ! |
|---|
| 154 | IF( iproc == -1 ) THEN ! No neighbour (land proc that was suppressed) |
|---|
| 155 | ! |
|---|
| 156 | ireq_r(jn) = MPI_REQUEST_NULL ! no message to be received |
|---|
| 157 | zbufr(:,:,:,:,jn) = HUGE(0._/**/PRECISION) ! default: define it and make sure we don't use it... |
|---|
| 158 | SELECT CASE ( kfillmode ) |
|---|
| 159 | CASE ( jpfillnothing ) ! no filling |
|---|
| 160 | CASE ( jpfillcopy ) ! filling with inner domain values |
|---|
| 161 | DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk |
|---|
| 162 | DO jj = 1, ipjfld(jf) |
|---|
| 163 | ij1 = ijbuf(jj,jf) |
|---|
| 164 | ij2 = ijsnd(jj,jf) ! we will use only the first value, see init_nfdcom |
|---|
| 165 | zbufr(1,ij1,jk,jl,jn) = ptab(jf)%pt4d(Nis0,ij2,jk,jl) ! chose to take the 1st inner domain point |
|---|
| 166 | END DO |
|---|
| 167 | END DO ; END DO ; END DO |
|---|
| 168 | CASE ( jpfillcst ) ! filling with constant value |
|---|
| 169 | zbufr(1,:,:,:,jn) = pfillval ! we will use only the first value, see init_nfdcom |
|---|
| 170 | END SELECT |
|---|
| 171 | ! |
|---|
| 172 | ELSE IF( iproc == narea-1 ) THEN ! get data from myself! |
|---|
| 173 | ! |
|---|
| 174 | ireq_r(jn) = MPI_REQUEST_NULL ! no message to be received |
|---|
| 175 | DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk |
|---|
| 176 | DO jj = 1, ipjfld(jf) |
|---|
| 177 | ij1 = ijbuf(jj,jf) |
|---|
| 178 | ij2 = ijsnd(jj,jf) |
|---|
| 179 | DO ji = Nis0, Nie0 ! should not use any other value |
|---|
| 180 | iib = ji - Nis0 + 1 |
|---|
| 181 | zbufr(iib,ij1,jk,jl,jn) = ptab(jf)%pt4d(ji,ij2,jk,jl) |
|---|
| 182 | END DO |
|---|
| 183 | END DO |
|---|
| 184 | END DO ; END DO ; END DO |
|---|
| 185 | ! |
|---|
| 186 | ELSE ! get data from a neighbour trough communication |
|---|
| 187 | #if ! defined key_mpi_off |
|---|
| 188 | CALL MPI_Irecv( zbufr(:,:,:,:,jn), ibuffsize, MPI_TYPE, iproc, 5, mpi_comm_oce, ireq_r(jn), ierr ) |
|---|
| 189 | #endif |
|---|
| 190 | ENDIF |
|---|
| 191 | ! |
|---|
| 192 | END DO ! nfd_nbnei |
|---|
| 193 | ! |
|---|
| 194 | CALL mpi_waitall(nfd_nbnei, ireq_r, MPI_STATUSES_IGNORE, ierr) ! wait for all Irecv |
|---|
| 195 | ! |
|---|
| 196 | IF( ln_timing ) CALL tic_tac(.FALSE.) |
|---|
| 197 | ! |
|---|
| 198 | ! North fold boundary condition |
|---|
| 199 | ! |
|---|
| 200 | DO jf = 1, ipf |
|---|
| 201 | ! |
|---|
| 202 | SELECT CASE ( cd_nat(jf) ) ! which grid number? |
|---|
| 203 | CASE ('T','W') ; iig = 1 ! T-, W-point |
|---|
| 204 | CASE ('U') ; iig = 2 ! U-point |
|---|
| 205 | CASE ('V') ; iig = 3 ! V-point |
|---|
| 206 | CASE ('F') ; iig = 4 ! F-point |
|---|
| 207 | END SELECT |
|---|
| 208 | ! |
|---|
| 209 | DO jl = 1, ipl ; DO jk = 1, ipk |
|---|
| 210 | ! |
|---|
| 211 | ! if T point with F-point pivot : must be done first |
|---|
| 212 | ! --> specific correction of 3 points near the 2 pivots (to be clean, usually masked -> so useless) |
|---|
| 213 | IF( c_NFtype == 'F' .AND. iig == 1 ) THEN |
|---|
| 214 | ij1 = jpj - khls ! j-index in the receiving array |
|---|
| 215 | ij2 = 1 ! only 1 line in the buffer |
|---|
| 216 | DO ji = mi0(khls), mi1(khls) |
|---|
| 217 | iib = nfd_jisnd(mi0( khls),iig) ! i-index in the buffer |
|---|
| 218 | iin = nfd_rksnd(mi0( khls),iig) ! neigbhour-index in the buffer |
|---|
| 219 | IF( nfd_rknei(iin) == -1 .AND. kfillmode == jpfillnothing ) CYCLE |
|---|
| 220 | ptab(jf)%pt4d(ji,ij1,jk,jl) = zbufr(iib,ij2,jk,jl,iin) ! no psgn(jf) |
|---|
| 221 | END DO |
|---|
| 222 | DO ji = mi0(jpiglo/2+1), mi1(jpiglo/2+1) |
|---|
| 223 | iib = nfd_jisnd(mi0( jpiglo/2+1),iig) ! i-index in the buffer |
|---|
| 224 | iin = nfd_rksnd(mi0( jpiglo/2+1),iig) ! neigbhour-index in the buffer |
|---|
| 225 | IF( nfd_rknei(iin) == -1 .AND. kfillmode == jpfillnothing ) CYCLE |
|---|
| 226 | ptab(jf)%pt4d(ji,ij1,jk,jl) = zbufr(iib,ij2,jk,jl,iin) ! no psgn(jf) |
|---|
| 227 | END DO |
|---|
| 228 | DO ji = mi0(jpiglo-khls), mi1(jpiglo-khls) |
|---|
| 229 | iib = nfd_jisnd(mi0(jpiglo-khls),iig) ! i-index in the buffer |
|---|
| 230 | iin = nfd_rksnd(mi0(jpiglo-khls),iig) ! neigbhour-index in the buffer |
|---|
| 231 | IF( nfd_rknei(iin) == -1 .AND. kfillmode == jpfillnothing ) CYCLE |
|---|
| 232 | ptab(jf)%pt4d(ji,ij1,jk,jl) = zbufr(iib,ij2,jk,jl,iin) ! no psgn(jf) |
|---|
| 233 | END DO |
|---|
| 234 | ENDIF |
|---|
| 235 | ! |
|---|
| 236 | ! Apply the North pole folding. |
|---|
| 237 | DO jj = 1, ipjfld(jf) ! for all lines to be exchanged for this field |
|---|
| 238 | ij1 = ijrcv(jj,jf) ! j-index in the receiving array |
|---|
| 239 | ij2 = ijbuf(jj,jf) ! j-index in the buffer |
|---|
| 240 | iis = ii1st(jj,jf) ! stating i-index in the receiving array |
|---|
| 241 | iie = iiend(jj,jf) ! ending i-index in the receiving array |
|---|
| 242 | DO ji = iis, iie |
|---|
| 243 | iib = nfd_jisnd(ji,iig) ! i-index in the buffer |
|---|
| 244 | iin = nfd_rksnd(ji,iig) ! neigbhour-index in the buffer |
|---|
| 245 | IF( nfd_rknei(iin) == -1 .AND. kfillmode == jpfillnothing ) CYCLE |
|---|
| 246 | ptab(jf)%pt4d(ji,ij1,jk,jl) = psgn(jf) * zbufr(iib,ij2,jk,jl,iin) |
|---|
| 247 | END DO |
|---|
| 248 | END DO |
|---|
| 249 | ! |
|---|
| 250 | ! re-apply periodocity when we modified the eastern side of the inner domain (and not the full line) |
|---|
| 251 | IF( c_NFtype == 'T' ) THEN ! * North fold T-point pivot |
|---|
| 252 | IF( iig <= 2 ) THEN ; iis = mi0(1) ; iie = mi1(khls) ! 'T','W','U': update west halo |
|---|
| 253 | ELSE ; iis = 1 ; iie = 0 ! 'V','F' : full line already exchanged |
|---|
| 254 | ENDIF |
|---|
| 255 | ENDIF |
|---|
| 256 | IF( c_NFtype == 'F' ) THEN ! * North fold F-point pivot |
|---|
| 257 | IF( iig <= 2 ) THEN ; iis = 1 ; iie = 0 ! 'T','W','U': nothing to do |
|---|
| 258 | ELSEIF( iig == 3 ) THEN ; iis = mi0(1) ; iie = mi1(khls) ! 'V' : update west halo |
|---|
| 259 | ELSEIF( khls > 1 ) THEN ; iis = mi0(1) ; iie = mi1(khls-1) ! 'F' and khls > 1 |
|---|
| 260 | ELSE ; iis = 1 ; iie = 0 ! 'F' and khls == 1 : nothing to do |
|---|
| 261 | ENDIF |
|---|
| 262 | ENDIF |
|---|
| 263 | jj = ipjfld(jf) ! only for the last line of this field |
|---|
| 264 | ij1 = ijrcv(jj,jf) ! j-index in the receiving array |
|---|
| 265 | ij2 = ijbuf(jj,jf) ! j-index in the buffer |
|---|
| 266 | DO ji = iis, iie |
|---|
| 267 | iib = nfd_jisnd(ji,iig) ! i-index in the buffer |
|---|
| 268 | iin = nfd_rksnd(ji,iig) ! neigbhour-index in the buffer |
|---|
| 269 | IF( nfd_rknei(iin) == -1 .AND. kfillmode == jpfillnothing ) CYCLE |
|---|
| 270 | ptab(jf)%pt4d(ji,ij1,jk,jl) = psgn(jf) * zbufr(iib,ij2,jk,jl,iin) |
|---|
| 271 | END DO |
|---|
| 272 | ! |
|---|
| 273 | END DO ; END DO ! ipl ; ipk |
|---|
| 274 | ! |
|---|
| 275 | END DO ! ipf |
|---|
| 276 | |
|---|
| 277 | ! |
|---|
| 278 | DEALLOCATE( zbufr, ireq_r, ijsnd, ijbuf, ijrcv, ii1st, iiend, ipjfld ) |
|---|
| 279 | ! |
|---|
| 280 | CALL mpi_waitall(nfd_nbnei, ireq_s, MPI_STATUSES_IGNORE, ierr) ! wait for all Isend |
|---|
| 281 | ! |
|---|
| 282 | DEALLOCATE( zbufs, ireq_s ) |
|---|
| 283 | ! |
|---|
| 284 | ELSE !== allgather exchanges ==! |
|---|
| 285 | ! |
|---|
| 286 | ! how many lines do we exchange at max? -> ipj (no further optimizations in this case...) |
|---|
| 287 | ipj = khls + 2 |
|---|
| 288 | ! how many lines do we need at max? -> ipj2 (no further optimizations in this case...) |
|---|
| 289 | ipj2 = 2 * khls + 2 |
|---|
| 290 | ! |
|---|
| 291 | i0max = jpimax - 2 * khls |
|---|
| 292 | ibuffsize = i0max * ipj * ipk * ipl * ipf |
|---|
| 293 | ALLOCATE( znorthloc(i0max,ipj,ipk,ipl,ipf), znorthglo(i0max,ipj,ipk,ipl,ipf,ndim_rank_north) ) |
|---|
| 294 | ! |
|---|
| 295 | DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ! put in znorthloc ipj j-lines of ptab |
|---|
| 296 | DO jj = 1, ipj |
|---|
| 297 | ij2 = jpj - ipj2 + jj ! the first ipj lines of the last ipj2 lines |
|---|
| 298 | DO ji = 1, Ni_0 |
|---|
| 299 | ii2 = Nis0 - 1 + ji ! inner domain: Nis0 to Nie0 |
|---|
| 300 | znorthloc(ji,jj,jk,jl,jf) = ptab(jf)%pt4d(ii2,ij2,jk,jl) |
|---|
| 301 | END DO |
|---|
| 302 | DO ji = Ni_0+1, i0max |
|---|
| 303 | znorthloc(ji,jj,jk,jl,jf) = HUGE(0._/**/PRECISION) ! avoid sending uninitialized values (make sure we don't use it) |
|---|
| 304 | END DO |
|---|
| 305 | END DO |
|---|
| 306 | END DO ; END DO ; END DO |
|---|
| 307 | ! |
|---|
| 308 | ! start waiting time measurement |
|---|
| 309 | IF( ln_timing ) CALL tic_tac(.TRUE.) |
|---|
| 310 | #if ! defined key_mpi_off |
|---|
| 311 | CALL MPI_ALLGATHER( znorthloc, ibuffsize, MPI_TYPE, znorthglo, ibuffsize, MPI_TYPE, ncomm_north, ierr ) |
|---|
| 312 | #endif |
|---|
| 313 | ! stop waiting time measurement |
|---|
| 314 | IF( ln_timing ) CALL tic_tac(.FALSE.) |
|---|
| 315 | DEALLOCATE( znorthloc ) |
|---|
| 316 | ALLOCATE( ztabglo(ipf) ) |
|---|
| 317 | DO jf = 1, ipf |
|---|
| 318 | ALLOCATE( ztabglo(jf)%pt4d(jpiglo,ipj2,ipk,ipl) ) |
|---|
| 319 | END DO |
|---|
| 320 | ! |
|---|
| 321 | ! need to fill only the first ipj lines of ztabglo as lbc_nfd don't use the last khls lines |
|---|
| 322 | ijnr = 0 |
|---|
| 323 | DO jr = 1, jpni ! recover the global north array |
|---|
| 324 | iproc = nfproc(jr) |
|---|
| 325 | impp = nfimpp(jr) |
|---|
| 326 | ipi = nfjpi( jr) - 2 * khls ! corresponds to Ni_0 but for subdomain iproc |
|---|
| 327 | IF( iproc == -1 ) THEN ! No neighbour (land proc that was suppressed) |
|---|
| 328 | ! |
|---|
| 329 | SELECT CASE ( kfillmode ) |
|---|
| 330 | CASE ( jpfillnothing ) ! no filling |
|---|
| 331 | CALL ctl_stop( 'STOP', 'mpp_nfd_generic : cannot use jpfillnothing with ln_nnogather = F') |
|---|
| 332 | CASE ( jpfillcopy ) ! filling with inner domain values |
|---|
| 333 | DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk |
|---|
| 334 | DO jj = 1, ipj |
|---|
| 335 | ij2 = jpj - ipj2 + jj ! the first ipj lines of the last ipj2 lines |
|---|
| 336 | DO ji = 1, ipi |
|---|
| 337 | ii1 = impp + khls + ji - 1 ! corresponds to mig(khls + ji) but for subdomain iproc |
|---|
| 338 | ztabglo(jf)%pt4d(ii1,jj,jk,jl) = ptab(jf)%pt4d(Nis0,ij2,jk,jl) ! chose to take the 1st inner domain point |
|---|
| 339 | END DO |
|---|
| 340 | END DO |
|---|
| 341 | END DO ; END DO ; END DO |
|---|
| 342 | CASE ( jpfillcst ) ! filling with constant value |
|---|
| 343 | DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk |
|---|
| 344 | DO jj = 1, ipj |
|---|
| 345 | DO ji = 1, ipi |
|---|
| 346 | ii1 = impp + khls + ji - 1 ! corresponds to mig(khls + ji) but for subdomain iproc |
|---|
| 347 | ztabglo(jf)%pt4d(ii1,jj,jk,jl) = pfillval |
|---|
| 348 | END DO |
|---|
| 349 | END DO |
|---|
| 350 | END DO ; END DO ; END DO |
|---|
| 351 | END SELECT |
|---|
| 352 | ! |
|---|
| 353 | ELSE |
|---|
| 354 | ijnr = ijnr + 1 |
|---|
| 355 | DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk |
|---|
| 356 | DO jj = 1, ipj |
|---|
| 357 | DO ji = 1, ipi |
|---|
| 358 | ii1 = impp + khls + ji - 1 ! corresponds to mig(khls + ji) but for subdomain iproc |
|---|
| 359 | ztabglo(jf)%pt4d(ii1,jj,jk,jl) = znorthglo(ji,jj,jk,jl,jf,ijnr) |
|---|
| 360 | END DO |
|---|
| 361 | END DO |
|---|
| 362 | END DO ; END DO ; END DO |
|---|
| 363 | ENDIF |
|---|
| 364 | ! |
|---|
| 365 | END DO ! jpni |
|---|
| 366 | DEALLOCATE( znorthglo ) |
|---|
| 367 | ! |
|---|
| 368 | DO jf = 1, ipf |
|---|
| 369 | CALL lbc_nfd( ztabglo(jf:jf), cd_nat(jf:jf), psgn(jf:jf), khls, 1 ) ! North fold boundary condition |
|---|
| 370 | DO jl = 1, ipl ; DO jk = 1, ipk ! e-w periodicity |
|---|
| 371 | DO jj = 1, khls + 1 |
|---|
| 372 | ij1 = ipj2 - (khls + 1) + jj ! need only the last khls + 1 lines until ipj2 |
|---|
| 373 | ztabglo(jf)%pt4d( 1: khls,ij1,jk,jl) = ztabglo(jf)%pt4d(jpiglo-2*khls+1:jpiglo-khls,ij1,jk,jl) |
|---|
| 374 | ztabglo(jf)%pt4d(jpiglo-khls+1:jpiglo,ij1,jk,jl) = ztabglo(jf)%pt4d( khls+1: 2*khls,ij1,jk,jl) |
|---|
| 375 | END DO |
|---|
| 376 | END DO ; END DO |
|---|
| 377 | END DO |
|---|
| 378 | ! |
|---|
| 379 | DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ! Scatter back to ARRAY_IN |
|---|
| 380 | DO jj = 1, khls + 1 |
|---|
| 381 | ij1 = jpj - (khls + 1) + jj ! last khls + 1 lines until jpj |
|---|
| 382 | ij2 = ipj2 - (khls + 1) + jj ! last khls + 1 lines until ipj2 |
|---|
| 383 | DO ji= 1, jpi |
|---|
| 384 | ii2 = mig(ji) |
|---|
| 385 | ptab(jf)%pt4d(ji,ij1,jk,jl) = ztabglo(jf)%pt4d(ii2,ij2,jk,jl) |
|---|
| 386 | END DO |
|---|
| 387 | END DO |
|---|
| 388 | END DO ; END DO ; END DO |
|---|
| 389 | ! |
|---|
| 390 | DO jf = 1, ipf |
|---|
| 391 | DEALLOCATE( ztabglo(jf)%pt4d ) |
|---|
| 392 | END DO |
|---|
| 393 | DEALLOCATE( ztabglo ) |
|---|
| 394 | ! |
|---|
| 395 | ENDIF ! ln_nnogather |
|---|
| 396 | ! |
|---|
| 397 | END SUBROUTINE mpp_nfd_/**/PRECISION |
|---|
| 398 | |
|---|
