New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
mpp_nc_generic.h90 in NEMO/branches/2020/dev_r13898_Tiling_Cleanup_MPI3/src/OCE/LBC – NEMO

source: NEMO/branches/2020/dev_r13898_Tiling_Cleanup_MPI3/src/OCE/LBC/mpp_nc_generic.h90 @ 13923

Last change on this file since 13923 was 13923, checked in by mocavero, 4 years ago

Final merge - conflicts solved

File size: 49.3 KB
Line 
1#   define NAT_IN(k)                cd_nat(k)   
2#   define SGN_IN(k)                psgn(k)
3#   define F_SIZE(ptab)             kfld
4#   define OPT_K(k)                 ,ipf
5#   if defined DIM_2d
6#      if defined SINGLE_PRECISION
7#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_2D_sp)                , INTENT(inout) ::   ptab(f)
8#      else
9#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_2D_dp)                , INTENT(inout) ::   ptab(f)
10#      endif
11#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt2d(i,j)
12#      define K_SIZE(ptab)             1
13#      define L_SIZE(ptab)             1
14#   endif
15#   if defined DIM_3d
16#      if defined SINGLE_PRECISION
17#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_3D_sp)                , INTENT(inout) ::   ptab(f)
18#      else
19#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_3D_dp)                , INTENT(inout) ::   ptab(f)
20#      endif
21#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt3d(i,j,k)
22#      define K_SIZE(ptab)             SIZE(ptab(1)%pt3d,3)
23#      define L_SIZE(ptab)             1
24#   endif
25#   if defined DIM_4d
26#      if defined SINGLE_PRECISION
27#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_4D_sp)                , INTENT(inout) ::   ptab(f)
28#      else
29#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_4D_dp)                , INTENT(inout) ::   ptab(f)
30#      endif
31#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt4d(i,j,k,l)
32#      define K_SIZE(ptab)             SIZE(ptab(1)%pt4d,3)
33#      define L_SIZE(ptab)             SIZE(ptab(1)%pt4d,4)
34#   endif
35#   if defined SINGLE_PRECISION
36#      define PRECISION sp
37#      define MPI_TYPE MPI_REAL
38#   else
39#      define PRECISION dp
40#      define MPI_TYPE MPI_DOUBLE_PRECISION
41#   endif
42
43   SUBROUTINE ROUTINE_NC( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, lsend, lrecv, ncsten )
44      INTEGER             , INTENT(in   ) ::   kfld        ! number of pt3d arrays
45      ARRAY_TYPE(:,:,:,:,:)                                        ! array or pointer of arrays on which the boundary condition is applied
46      CHARACTER(len=*)              , INTENT(in   ) ::   cdname      ! name of the calling subroutine
47      CHARACTER(len=1)              , INTENT(in   ) ::   NAT_IN(:)   ! nature of array grid-points
48      REAL(wp)                      , INTENT(in   ) ::   SGN_IN(:)   ! sign used across the north fold boundary
49      INTEGER ,             OPTIONAL, INTENT(in   ) ::   kfillmode   ! filling method for halo over land (default = constant)
50      REAL(wp),             OPTIONAL, INTENT(in   ) ::   pfillval    ! background value (used at closed boundaries)
51      LOGICAL, DIMENSION(4),OPTIONAL, INTENT(in   ) ::   lsend, lrecv  ! communication with other 4 proc
52      LOGICAL,              OPTIONAL, INTENT(in   ) ::   ncsten      ! 5-point or 9-point stencil
53      !
54      INTEGER  ::   ji,  jj,  jk,  jl,  jf                                      ! dummy loop indices
55      INTEGER  ::   ipi, ipj, ipk, ipl, ipf                                     ! dimension of the input array
56      INTEGER  ::   ishift, ishift2, idx, icount, icount1                       ! local integers
57      INTEGER  ::   idims, idimr, isizet, isizets, isizetr, izsnd, izrcv        ! local integers
58      INTEGER  ::   ierr
59      INTEGER  ::   ifill_we, ifill_ea, ifill_so, ifill_no
60      INTEGER  ::   ifill_web, ifill_eab
61      REAL(wp) ::   zland
62      INTEGER , DIMENSION(MPI_STATUS_SIZE)                        ::   istate              ! for mpi_isend
63      REAL(PRECISION), DIMENSION(:), ALLOCATABLE                  ::   zsnd, zrcv          ! halos arrays
64      INTEGER , DIMENSION(:), ALLOCATABLE                         ::   isizes              ! number of elements to be sent
65      INTEGER , DIMENSION(:), ALLOCATABLE                         ::   isizer              ! number of elements to be received
66      INTEGER , DIMENSION(:), ALLOCATABLE                         ::   idatatys, idatatyr  ! datatype of halos arrays
67      INTEGER (KIND=MPI_ADDRESS_KIND), DIMENSION (:), ALLOCATABLE ::   idispls, idisplr    ! displacement in halos arrays
68      LOGICAL  ::   llsend_we, llsend_ea, llsend_no, llsend_so       ! communication send
69      LOGICAL  ::   llrecv_we, llrecv_ea, llrecv_no, llrecv_so       ! communication receive
70      LOGICAL  ::   lldo_nfd                                         ! do north pole folding
71      LOGICAL  ::   llncall                                          ! default: 9-point stencil
72
73      !!----------------------------------------------------------------------
74      !
75      ! ----------------------------------------- !
76      !     0. local variables initialization     !
77      ! ----------------------------------------- !
78      !
79      llncall = .TRUE.
80      ipk = K_SIZE(ptab)   ! 3rd dimension
81      ipl = L_SIZE(ptab)   ! 4th    -
82      ipf = F_SIZE(ptab)   ! 5th    -      use in "multi" case (array of pointers)
83      !
84      IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ipk, ipl, ipf, ld_lbc = .TRUE. )
85      !
86      IF     ( PRESENT(lsend) .AND. PRESENT(lrecv) ) THEN
87         llsend_we = lsend(1)   ;   llsend_ea = lsend(2)   ;   llsend_so = lsend(3)   ;   llsend_no = lsend(4)
88         llrecv_we = lrecv(1)   ;   llrecv_ea = lrecv(2)   ;   llrecv_so = lrecv(3)   ;   llrecv_no = lrecv(4)
89      ELSE IF( PRESENT(lsend) .OR.  PRESENT(lrecv) ) THEN
90         WRITE(ctmp1,*) ' E R R O R : Routine ', cdname, '  is calling lbc_lnk with only one of the two arguments lsend or lrecv'
91         WRITE(ctmp2,*) ' ========== '
92         CALL ctl_stop( ' ', ctmp1, ctmp2, ' ' )
93      ELSE   ! send and receive with every neighbour
94         llsend_we = nbondi ==  1 .OR. nbondi == 0   ! keep for compatibility, should be defined in mppini
95         llsend_ea = nbondi == -1 .OR. nbondi == 0   ! keep for compatibility, should be defined in mppini
96         llsend_so = nbondj ==  1 .OR. nbondj == 0   ! keep for compatibility, should be defined in mppini
97         llsend_no = nbondj == -1 .OR. nbondj == 0   ! keep for compatibility, should be defined in mppini
98         llrecv_we = llsend_we   ;   llrecv_ea = llsend_ea   ;   llrecv_so = llsend_so   ;   llrecv_no = llsend_no
99      END IF
100         
101      lldo_nfd = npolj /= 0                      ! keep for compatibility, should be defined in mppini
102
103      zland = 0._wp                                     ! land filling value: zero by default
104      IF( PRESENT( pfillval ) )   zland = pfillval      ! set land value
105
106
107      ! define the method we will use to fill the halos in each direction
108      IF(              llrecv_we ) THEN   ;   ifill_we = jpfillmpi
109      ELSEIF(           l_Iperio ) THEN   ;   ifill_we = jpfillperio
110      ELSEIF( PRESENT(kfillmode) ) THEN   ;   ifill_we = kfillmode
111      ELSE                                ;   ifill_we = jpfillcst
112      END IF
113      IF(               l_Iperio ) THEN   ;   ifill_web = jpfillperio
114      ELSEIF( PRESENT(kfillmode) ) THEN   ;   ifill_web = kfillmode
115      ELSE                                ;   ifill_web = jpfillcst
116      END IF
117      !
118      IF(              llrecv_ea ) THEN   ;   ifill_ea = jpfillmpi
119      ELSEIF(           l_Iperio ) THEN   ;   ifill_ea = jpfillperio
120      ELSEIF( PRESENT(kfillmode) ) THEN   ;   ifill_ea = kfillmode
121      ELSE                                ;   ifill_ea = jpfillcst
122      END IF
123      IF(               l_Iperio ) THEN   ;   ifill_eab = jpfillperio
124      ELSEIF( PRESENT(kfillmode) ) THEN   ;   ifill_eab = kfillmode
125      ELSE                                ;   ifill_eab = jpfillcst
126      END IF
127      !
128      IF(              llrecv_so ) THEN   ;   ifill_so = jpfillmpi
129      ELSEIF(           l_Jperio ) THEN   ;   ifill_so = jpfillperio
130      ELSEIF( PRESENT(kfillmode) ) THEN   ;   ifill_so = kfillmode
131      ELSE                                ;   ifill_so = jpfillcst
132      END IF
133      !
134      IF(              llrecv_no ) THEN   ;   ifill_no = jpfillmpi
135      ELSEIF(           l_Jperio ) THEN   ;   ifill_no = jpfillperio
136      ELSEIF( PRESENT(kfillmode) ) THEN   ;   ifill_no = kfillmode
137      ELSE                                ;   ifill_no = jpfillcst
138      END IF
139      !
140      IF(PRESENT(ncsten)) llncall = ncsten
141#if defined PRINT_CAUTION
142      !
143      ! ================================================================================== !
144      ! CAUTION: semi-column notation is often impossible because of the cpp preprocessing !
145      ! ================================================================================== !
146      !
147#endif
148      !
149      ! -------------------------------------------------- !
150      !     1. Do west, east, south and north MPI exchange !
151      ! -------------------------------------------------- !
152      !
153      ! Allocate local temporary arrays to be sent/received. Fill arrays to be sent
154
155      idims = 0
156      idimr = 0
157      izsnd = 0
158      izrcv = 0
159
160      IF(llsend_we) idims = idims + 1
161      IF(llsend_ea) idims = idims + 1
162      IF(llsend_so) idims = idims + 1
163      IF(llsend_no) idims = idims + 1
164
165      idimr = idims
166
167      IF(llncall) THEN
168         IF(noswr .ne. -1) idimr = idimr + 1
169         IF(noser .ne. -1) idimr = idimr + 1
170         IF(nonwr .ne. -1) idimr = idimr + 1
171         IF(noner .ne. -1) idimr = idimr + 1
172     
173         IF(nosws .ne. -1) idims = idims + 1
174         IF(noses .ne. -1) idims = idims + 1
175         IF(nonws .ne. -1) idims = idims + 1
176         IF(nones .ne. -1) idims = idims + 1
177      END IF
178
179      IF(llsend_we) izsnd = izsnd + nn_hls * (jpj - 2*nn_hls) * ipk * ipl * ipf
180      IF(llsend_ea) izsnd = izsnd + nn_hls * (jpj - 2*nn_hls) * ipk * ipl * ipf
181      IF(llsend_so) izsnd = izsnd + (jpi - 2*nn_hls) * nn_hls * ipk * ipl * ipf
182      IF(llsend_no) izsnd = izsnd + (jpi - 2*nn_hls) * nn_hls * ipk * ipl * ipf
183
184      izrcv = izsnd
185     
186      IF(llncall) THEN
187         IF(noswr .ne. -1) izrcv = izrcv + nn_hls * nn_hls * ipk * ipl * ipf
188         IF(noser .ne. -1) izrcv = izrcv + nn_hls * nn_hls * ipk * ipl * ipf
189         IF(nonwr .ne. -1) izrcv = izrcv + nn_hls * nn_hls * ipk * ipl * ipf
190         IF(noner .ne. -1) izrcv = izrcv + nn_hls * nn_hls * ipk * ipl * ipf
191
192         IF(nosws .ne. -1) izsnd = izsnd + nn_hls * nn_hls * ipk * ipl * ipf
193         IF(noses .ne. -1) izsnd = izsnd + nn_hls * nn_hls * ipk * ipl * ipf
194         IF(nonws .ne. -1) izsnd = izsnd + nn_hls * nn_hls * ipk * ipl * ipf
195         IF(nones .ne. -1) izsnd = izsnd + nn_hls * nn_hls * ipk * ipl * ipf
196      END IF
197
198      ALLOCATE(zsnd(izsnd))
199      ALLOCATE(zrcv(izrcv))
200      ALLOCATE(isizes(idims))
201      ALLOCATE(isizer(idimr))
202      ALLOCATE(idatatys(idims))
203      ALLOCATE(idatatyr(idimr))
204      ALLOCATE(idispls(idims))
205      ALLOCATE(idisplr(idimr))
206
207      zrcv(:)=-1
208      zsnd(:)=-1
209      isizes(:) = 0
210      isizer(:) = 0
211      idispls(:) = 0
212      idisplr(:) = 0
213      isizet = 0
214     
215      idx = 1
216      icount = 1
217
218      IF(llsend_we) THEN
219         DO jf = 1, ipf  ;  DO jl = 1, ipl  ;  DO jk = 1, ipk  ;  DO jj = nn_hls + 1, jpj - nn_hls  ;  DO ji = 1, nn_hls
220            zsnd(idx) = ARRAY_IN(nn_hls+ji,jj,jk,jl,jf)
221            idx = idx + 1
222         END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
223
224         isizes(icount) = nn_hls * (jpj - 2*nn_hls) * ipk * ipl * ipf
225         IF(icount .gt. 1) isizet = isizet + isizes(icount - 1)
226         idispls(icount) = jpbyt*isizet
227         icount = icount + 1
228      END IF
229
230      IF(llsend_ea) THEN
231         ishift = jpi-2*nn_hls
232
233         DO jf = 1, ipf  ;  DO jl = 1, ipl  ;  DO jk = 1, ipk  ;  DO jj = nn_hls + 1, jpj - nn_hls  ;  DO ji = 1, nn_hls
234            zsnd(idx) = ARRAY_IN(ishift+ji,jj,jk,jl,jf)
235            idx = idx + 1
236         END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
237
238         isizes(icount) = nn_hls * (jpj - 2*nn_hls) * ipk * ipl * ipf
239         IF(icount .gt. 1) isizet = isizet + isizes(icount - 1)
240         idispls(icount) = jpbyt*isizet
241         icount = icount + 1
242      END IF
243
244      IF(llsend_so) THEN
245         DO jf = 1, ipf  ;  DO jl = 1, ipl  ;  DO jk = 1, ipk  ;  DO jj = 1, nn_hls  ;  DO ji = nn_hls + 1, jpi - nn_hls
246            zsnd(idx) = ARRAY_IN(ji,nn_hls+jj,jk,jl,jf)
247            idx = idx + 1
248         END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
249
250         isizes(icount) = (jpi - 2*nn_hls) * nn_hls * ipk * ipl * ipf
251         IF(icount .gt. 1) isizet = isizet + isizes(icount - 1)
252         idispls(icount) = jpbyt*isizet
253         icount = icount + 1
254      END IF
255
256      IF(llsend_no) THEN
257         ishift = jpj-2*nn_hls
258
259         DO jf = 1, ipf  ;  DO jl = 1, ipl  ;  DO jk = 1, ipk  ;  DO jj = 1, nn_hls  ;  DO ji = nn_hls + 1, jpi - nn_hls
260            zsnd(idx) = ARRAY_IN(ji,ishift+jj,jk,jl,jf)
261            idx = idx + 1
262         END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
263
264         isizes(icount) = (jpi - 2*nn_hls) * nn_hls * ipk * ipl * ipf
265         IF(icount .gt. 1) isizet = isizet + isizes(icount - 1)
266         idispls(icount) = jpbyt*isizet
267         icount = icount + 1
268      END IF
269
270      isizer(:) = isizes(:)
271      idisplr(:) = idispls(:)
272     
273      icount1 = icount
274      isizets = isizet
275      isizetr = isizet
276
277      IF(llncall) THEN
278         IF(noswr .ne. -1) THEN
279            isizer(icount1) = nn_hls * nn_hls * ipk * ipl * ipf
280            IF(icount1 .gt. 1) isizetr = isizetr + isizer(icount1 - 1)
281            idisplr(icount1) = jpbyt*isizetr
282            icount1 = icount1 + 1
283         END IF
284         IF(noser .ne. -1) THEN
285            isizer(icount1) = nn_hls * nn_hls * ipk * ipl * ipf
286            IF(icount1 .gt. 1) isizetr = isizetr + isizer(icount1 - 1)
287            idisplr(icount1) = jpbyt*isizetr
288            icount1 = icount1 + 1
289         END IF
290         IF(nonwr .ne. -1) THEN
291            isizer(icount1) = nn_hls * nn_hls * ipk * ipl * ipf
292            IF(icount1 .gt. 1) isizetr = isizetr + isizer(icount1 - 1)
293            idisplr(icount1) = jpbyt*isizetr
294            icount1 = icount1 + 1
295         END IF
296         IF(noner .ne. -1) THEN
297            isizer(icount1) = nn_hls * nn_hls * ipk * ipl * ipf
298            IF(icount1 .gt. 1) isizetr = isizetr + isizer(icount1 - 1)
299            idisplr(icount1) = jpbyt*isizetr
300            icount1 = icount1 + 1
301         END IF
302
303         IF(nosws .ne. -1) THEN
304            DO jf = 1, ipf  ;  DO jl = 1, ipl  ;  DO jk = 1, ipk  ;  DO jj = 1, nn_hls  ;  DO ji = 1, nn_hls
305               zsnd(idx) = ARRAY_IN(nn_hls+ji,nn_hls+jj,jk,jl,jf)
306               idx = idx + 1
307            END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
308
309            isizes(icount) = nn_hls * nn_hls * ipk * ipl * ipf
310            IF(icount .gt. 1) isizets = isizets + isizes(icount - 1)
311            idispls(icount) = jpbyt*isizets
312            icount = icount + 1
313         END IF
314         IF(noses .ne. -1) THEN
315            ishift = jpi-2*nn_hls
316            DO jf = 1, ipf  ;  DO jl = 1, ipl  ;  DO jk = 1, ipk  ;  DO jj = 1, nn_hls  ;  DO ji = 1, nn_hls
317               zsnd(idx) = ARRAY_IN(ji+ishift,nn_hls+jj,jk,jl,jf)
318               idx = idx + 1
319            END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
320
321            isizes(icount) = nn_hls * nn_hls * ipk * ipl * ipf
322            IF(icount .gt. 1) isizets = isizets + isizes(icount - 1)
323            idispls(icount) = jpbyt*isizets
324            icount = icount + 1
325         END IF
326         IF(nonws .ne. -1) THEN
327            ishift = jpj-2*nn_hls
328            DO jf = 1, ipf  ;  DO jl = 1, ipl  ;  DO jk = 1, ipk  ;  DO jj = 1, nn_hls  ;  DO ji = 1, nn_hls
329               zsnd(idx) = ARRAY_IN(nn_hls+ji,jj+ishift,jk,jl,jf)
330               idx = idx + 1
331            END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
332
333            isizes(icount) = nn_hls * nn_hls * ipk * ipl * ipf
334            IF(icount .gt. 1) isizets = isizets + isizes(icount - 1)
335            idispls(icount) = jpbyt*isizets
336            icount = icount + 1
337         END IF
338         IF(nones .ne. -1) THEN
339            ishift = jpi-2*nn_hls
340            ishift2 = jpj-2*nn_hls
341            DO jf = 1, ipf  ;  DO jl = 1, ipl  ;  DO jk = 1, ipk  ;  DO jj = 1, nn_hls  ;  DO ji = 1, nn_hls
342               zsnd(idx) = ARRAY_IN(ji+ishift,jj+ishift2,jk,jl,jf)
343               idx = idx + 1
344            END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
345
346            isizes(icount) = nn_hls * nn_hls * ipk * ipl * ipf
347            IF(icount .gt. 1) isizets = isizets + isizes(icount - 1)
348            idispls(icount) = jpbyt*isizets
349            icount = icount + 1
350         END IF
351      END IF
352
353      idatatys(:) = MPI_TYPE
354      idatatyr(:) = MPI_TYPE
355
356      IF(llncall) THEN
357         IF( ln_timing ) CALL tic_tac(.TRUE.)
358         CALL mpi_neighbor_alltoallw (zsnd, isizes, idispls, idatatys, zrcv, isizer, idisplr, idatatyr, mpi_nc_all_com, ierr)
359         IF( ln_timing ) CALL tic_tac(.FALSE.)
360      ELSE
361         IF( ln_timing ) CALL tic_tac(.TRUE.)
362         CALL mpi_neighbor_alltoallw (zsnd, isizes, idispls, idatatys, zrcv, isizer, idisplr, idatatyr, mpi_nc_com, ierr)
363         IF( ln_timing ) CALL tic_tac(.FALSE.)
364      END IF
365
366      ! --------------------------------------------------- !
367      !     2. Fill east and west north and south halos     !
368      ! --------------------------------------------------- !
369      !
370      !!! Patch to solve MPI3 bug when we have only two processes columns
371      IF(jpni .eq. 2) THEN
372         ! ---------------------
373         ! 2.2 fill eastern halo
374         ! ---------------------
375         idx = 1
376         ishift = jpi - nn_hls                ! fill halo from ji = jpi-nn_hls+1 to jpi
377         SELECT CASE ( ifill_ea )
378         CASE ( jpfillnothing )               ! no filling
379         CASE ( jpfillmpi   )                 ! use data received by MPI
380            DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = nn_hls + 1, jpj - nn_hls   ;   DO ji = 1, nn_hls
381               ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zrcv(idx)   ! jpi - nn_hls + 1 -> jpi
382               idx = idx + 1
383            END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
384         CASE ( jpfillperio )                 ! use east-weast periodicity
385            ishift2 = nn_hls
386            DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, jpj   ;   DO ji = 1, nn_hls
387               ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ishift2+ji,jj,jk,jl,jf)
388            END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
389         CASE ( jpfillcopy  )                 ! filling with inner domain values
390            DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, jpj   ;   DO ji = 1, nn_hls
391               ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ishift,jj,jk,jl,jf)
392            END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
393         CASE ( jpfillcst   )                 ! filling with constant value
394            DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, jpj   ;   DO ji = 1, nn_hls
395               ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zland
396            END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
397         END SELECT
398         ! ----------------------
399         ! 2.1 fill weastern halo
400         ! ----------------------
401         SELECT CASE ( ifill_we )
402         CASE ( jpfillnothing )               ! no filling
403         CASE ( jpfillmpi   )                 ! use data received by MPI
404            DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = nn_hls + 1, jpj - nn_hls   ;   DO ji = 1, nn_hls
405               ARRAY_IN(ji,jj,jk,jl,jf) = zrcv(idx)   ! 1 -> nn_hls
406               idx = idx + 1
407            END DO;   END DO   ;   END DO   ;   END DO   ;   END DO
408         CASE ( jpfillperio )                 ! use east-weast periodicity
409            ishift2 = jpi - 2 * nn_hls
410            DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, jpj   ;   DO ji = 1, nn_hls
411               ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ishift2+ji,jj,jk,jl,jf)
412            END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
413         CASE ( jpfillcopy  )                 ! filling with inner domain values
414            DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, jpj   ;   DO ji = 1, nn_hls
415               ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(nn_hls+1,jj,jk,jl,jf)
416            END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
417         CASE ( jpfillcst   )                 ! filling with constant value
418            DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, jpj   ;   DO ji = 1, nn_hls
419               ARRAY_IN(ji,jj,jk,jl,jf) = zland
420            END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
421         END SELECT
422
423      ELSE
424
425         ! ----------------------
426         ! 2.1 fill weastern halo
427         ! ----------------------
428         idx = 1
429         SELECT CASE ( ifill_we )
430         CASE ( jpfillnothing )               ! no filling
431         CASE ( jpfillmpi   )                 ! use data received by MPI
432            DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = nn_hls + 1, jpj - nn_hls   ;   DO ji = 1, nn_hls
433               ARRAY_IN(ji,jj,jk,jl,jf) = zrcv(idx)   ! 1 -> nn_hls
434               idx = idx + 1
435            END DO;   END DO   ;   END DO   ;   END DO   ;   END DO
436         CASE ( jpfillperio )                 ! use east-weast periodicity
437            ishift2 = jpi - 2 * nn_hls
438            DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, jpj   ;   DO ji = 1, nn_hls
439               ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ishift2+ji,jj,jk,jl,jf)
440            END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
441         CASE ( jpfillcopy  )                 ! filling with inner domain values
442            DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, jpj   ;   DO ji = 1, nn_hls
443               ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(nn_hls+1,jj,jk,jl,jf)
444            END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
445         CASE ( jpfillcst   )                 ! filling with constant value
446            DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, jpj   ;   DO ji = 1, nn_hls
447               ARRAY_IN(ji,jj,jk,jl,jf) = zland
448            END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
449         END SELECT
450         ! ---------------------
451         ! 2.2 fill eastern halo
452         ! ---------------------
453         ishift = jpi - nn_hls                ! fill halo from ji = jpi-nn_hls+1 to jpi
454         SELECT CASE ( ifill_ea )
455         CASE ( jpfillnothing )               ! no filling
456         CASE ( jpfillmpi   )                 ! use data received by MPI
457            DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = nn_hls + 1, jpj - nn_hls   ;   DO ji = 1, nn_hls
458               ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zrcv(idx)   ! jpi - nn_hls + 1 -> jpi
459               idx = idx + 1
460            END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
461         CASE ( jpfillperio )                 ! use east-weast periodicity
462            ishift2 = nn_hls
463            DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, jpj   ;   DO ji = 1, nn_hls
464               ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ishift2+ji,jj,jk,jl,jf)
465            END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
466         CASE ( jpfillcopy  )                 ! filling with inner domain values
467            DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, jpj   ;   DO ji = 1, nn_hls
468               ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ishift,jj,jk,jl,jf)
469            END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
470         CASE ( jpfillcst   )                 ! filling with constant value
471            DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, jpj   ;   DO ji = 1, nn_hls
472               ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zland
473            END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
474         END SELECT
475
476      ENDIF
477
478      !!! Patch to solve MPI3 bug when we have only two processes rows
479      IF(jpnj .eq. 2) THEN
480         ! ----------------------
481         ! 2.3 fill northern halo
482         ! ----------------------
483         ishift = jpj - nn_hls                ! fill halo from jj = jpj-nn_hls+1 to jpj
484         SELECT CASE ( ifill_no )
485         CASE ( jpfillnothing )               ! no filling
486         CASE ( jpfillmpi   )                 ! use data received by MPI
487            DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;  DO ji = nn_hls + 1, jpi - nn_hls
488               ARRAY_IN(ji,ishift+jj,jk,jl,jf) = zrcv(idx)   ! jpj-nn_hls+1 -> jpj
489               idx = idx + 1
490            END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
491            IF(nonwr .eq. -1) THEN
492               ishift = jpj - nn_hls
493               SELECT CASE ( ifill_web )
494                  CASE ( jpfillperio )
495                     ishift2 = jpi - 2 * nn_hls
496                     DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1 + ishift, jpj   ;  DO ji = 1, nn_hls
497                        ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ishift2+ji,jj,jk,jl,jf)
498                     END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
499                  CASE ( jpfillcopy  )
500                     DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1 + ishift, jpj   ;  DO ji = 1, nn_hls
501                        ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(nn_hls+1,jj,jk,jl,jf)
502                     END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
503
504                  CASE ( jpfillcst   )
505                     DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1 + ishift, jpj   ;  DO ji = 1, nn_hls
506                        ARRAY_IN(ji,jj,jk,jl,jf) = zland
507                     END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
508               END SELECT
509            END IF
510            IF(noner .eq. -1) THEN
511               ishift = jpi - nn_hls
512               ishift2 = jpj - nn_hls
513               SELECT CASE ( ifill_eab )
514                  CASE ( jpfillperio )
515                     DO jf = 1, ipf  ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1 + ishift2, jpj   ;  DO ji = 1, nn_hls
516                        ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ji,jj,jk,jl,jf)
517                     END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
518
519                  CASE ( jpfillcopy  )
520                     DO jf = 1, ipf  ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1 + ishift2, jpj   ;  DO ji = 1, nn_hls
521                        ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ishift,jj,jk,jl,jf)
522                     END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
523                  CASE ( jpfillcst   )
524                     DO jf = 1, ipf  ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1 + ishift2, jpj   ;  DO ji = 1, nn_hls
525                        ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zland
526                     END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
527               END SELECT
528            END IF
529         CASE ( jpfillperio )                 ! use north-south periodicity
530            ishift2 = nn_hls
531            DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;   DO ji = 1, jpi
532               ARRAY_IN(ji,ishift+jj,jk,jl,jf) = ARRAY_IN(ji,ishift2+jj,jk,jl,jf)
533            END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
534         CASE ( jpfillcopy  )                 ! filling with inner domain values
535            DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;   DO ji = 1, jpi
536               ARRAY_IN(ji,ishift+jj,jk,jl,jf) = ARRAY_IN(ji,ishift,jk,jl,jf)
537            END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
538         CASE ( jpfillcst   )                 ! filling with constant value
539            DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;   DO ji = 1, jpi
540               ARRAY_IN(ji,ishift+jj,jk,jl,jf) = zland
541            END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
542         END SELECT
543
544         ! ----------------------
545         ! 2.4 fill southern halo
546         ! ----------------------
547         SELECT CASE ( ifill_so )
548         CASE ( jpfillnothing )               ! no filling
549         CASE ( jpfillmpi   )                 ! use data received by MPI
550            DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;   DO ji = nn_hls + 1, jpi - nn_hls
551               ARRAY_IN(ji,jj,jk,jl,jf) = zrcv(idx)   ! 1 -> nn_hls
552               idx = idx + 1
553            END DO;   END DO   ;   END DO   ;   END DO   ;   END DO
554            IF(noswr .eq. -1) THEN
555               SELECT CASE ( ifill_web )
556                  CASE ( jpfillperio )
557                     ishift2 = jpi - 2 * nn_hls
558                     DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;  DO ji = 1, nn_hls
559                        ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ishift2+ji,jj,jk,jl,jf)
560                     END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
561                  CASE ( jpfillcopy  )
562                     DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;  DO ji = 1, nn_hls
563                        ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(nn_hls+1,jj,jk,jl,jf)
564                     END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
565
566                  CASE ( jpfillcst   )
567                     DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;  DO ji = 1, nn_hls
568                        ARRAY_IN(ji,jj,jk,jl,jf) = zland
569                     END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
570               END SELECT
571            END IF
572            IF(noser .eq. -1) THEN
573               ishift = jpi - nn_hls
574               SELECT CASE ( ifill_eab )
575                  CASE ( jpfillperio )
576                     DO jf = 1, ipf  ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;  DO ji = 1, nn_hls
577                        ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ji+nn_hls,jj,jk,jl,jf)
578                     END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
579
580                  CASE ( jpfillcopy  )
581                     DO jf = 1, ipf  ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;  DO ji = 1, nn_hls
582                        ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ishift,jj,jk,jl,jf)
583                     END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
584                  CASE ( jpfillcst   )
585                     DO jf = 1, ipf  ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;  DO ji = 1, nn_hls
586                        ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zland
587                     END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
588               END SELECT
589            END IF
590         CASE ( jpfillperio )                 ! use north-south periodicity
591            ishift2 = jpj - 2 * nn_hls
592            DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;   DO ji = 1, jpi
593               ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift2+jj,jk,jl,jf)
594            END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
595         CASE ( jpfillcopy  )                 ! filling with inner domain values
596            DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;   DO ji = 1, jpi
597               ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ji,nn_hls+1,jk,jl,jf)
598            END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
599         CASE ( jpfillcst   )                 ! filling with constant value
600            DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;   DO ji = 1, jpi
601               ARRAY_IN(ji,jj,jk,jl,jf) = zland
602            END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
603         END SELECT
604      ELSE
605         ! ----------------------
606         ! 2.3 fill southern halo
607         ! ----------------------
608         SELECT CASE ( ifill_so )
609         CASE ( jpfillnothing )               ! no filling
610         CASE ( jpfillmpi   )                 ! use data received by MPI
611            DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;   DO ji = nn_hls + 1, jpi - nn_hls
612               ARRAY_IN(ji,jj,jk,jl,jf) = zrcv(idx)   ! 1 -> nn_hls
613               idx = idx + 1
614            END DO;   END DO   ;   END DO   ;   END DO   ;   END DO
615            IF(noswr .eq. -1) THEN
616               SELECT CASE ( ifill_web )
617                  CASE ( jpfillperio )
618                     ishift2 = jpi - 2 * nn_hls
619                     DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;  DO ji = 1, nn_hls
620                        ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ishift2+ji,jj,jk,jl,jf)
621                     END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
622                  CASE ( jpfillcopy  )
623                     DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;  DO ji = 1, nn_hls
624                        ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(nn_hls+1,jj,jk,jl,jf)
625                     END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
626
627                  CASE ( jpfillcst   )
628                     DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;  DO ji = 1, nn_hls
629                        ARRAY_IN(ji,jj,jk,jl,jf) = zland
630                     END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
631               END SELECT
632            END IF
633            IF(noser .eq. -1) THEN
634               ishift = jpi - nn_hls
635               SELECT CASE ( ifill_eab )
636                  CASE ( jpfillperio )
637                     DO jf = 1, ipf  ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;  DO ji = 1, nn_hls
638                        ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ji+nn_hls,jj,jk,jl,jf)
639                     END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
640
641                  CASE ( jpfillcopy  )
642                     DO jf = 1, ipf  ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;  DO ji = 1, nn_hls
643                        ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ishift,jj,jk,jl,jf)
644                     END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
645                  CASE ( jpfillcst   )
646                     DO jf = 1, ipf  ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;  DO ji = 1, nn_hls
647                        ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zland
648                     END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
649               END SELECT
650            END IF
651         CASE ( jpfillperio )                 ! use north-south periodicity
652            ishift2 = jpj - 2 * nn_hls
653            DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;   DO ji = 1, jpi
654               ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift2+jj,jk,jl,jf)
655            END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
656         CASE ( jpfillcopy  )                 ! filling with inner domain values
657            DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;   DO ji = 1, jpi
658               ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ji,nn_hls+1,jk,jl,jf)
659            END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
660         CASE ( jpfillcst   )                 ! filling with constant value
661            DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;   DO ji = 1, jpi
662               ARRAY_IN(ji,jj,jk,jl,jf) = zland
663            END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
664         END SELECT
665
666         ! ----------------------
667         ! 2.4 fill northern halo
668         ! ----------------------
669         ishift = jpj - nn_hls                ! fill halo from jj = jpj-nn_hls+1 to jpj
670         SELECT CASE ( ifill_no )
671         CASE ( jpfillnothing )               ! no filling
672         CASE ( jpfillmpi   )                 ! use data received by MPI
673            DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;  DO ji = nn_hls + 1, jpi - nn_hls
674               ARRAY_IN(ji,ishift+jj,jk,jl,jf) = zrcv(idx)   ! jpj-nn_hls+1 -> jpj
675               idx = idx + 1
676            END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
677            IF(nonwr .eq. -1) THEN
678               ishift = jpj - nn_hls
679               SELECT CASE ( ifill_web )
680                  CASE ( jpfillperio )
681                     ishift2 = jpi - 2 * nn_hls
682                     DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1 + ishift, jpj   ;  DO ji = 1, nn_hls
683                        ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ishift2+ji,jj,jk,jl,jf)
684                     END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
685                  CASE ( jpfillcopy  )
686                     DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1 + ishift, jpj   ;  DO ji = 1, nn_hls
687                        ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(nn_hls+1,jj,jk,jl,jf)
688                     END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
689
690                  CASE ( jpfillcst   )
691                     DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1 + ishift, jpj   ;  DO ji = 1, nn_hls
692                        ARRAY_IN(ji,jj,jk,jl,jf) = zland
693                     END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
694               END SELECT
695            END IF
696            IF(noner .eq. -1) THEN
697               ishift = jpi - nn_hls
698               ishift2 = jpj - nn_hls
699               SELECT CASE ( ifill_eab )
700                  CASE ( jpfillperio )
701                     DO jf = 1, ipf  ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1 + ishift2, jpj   ;  DO ji = 1, nn_hls
702                        ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ji,jj,jk,jl,jf)
703                     END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
704
705                  CASE ( jpfillcopy  )
706                     DO jf = 1, ipf  ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1 + ishift2, jpj   ;  DO ji = 1, nn_hls
707                        ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ishift,jj,jk,jl,jf)
708                     END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
709                  CASE ( jpfillcst   )
710                     DO jf = 1, ipf  ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1 + ishift2, jpj   ;  DO ji = 1, nn_hls
711                        ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zland
712                     END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
713               END SELECT
714            END IF
715         CASE ( jpfillperio )                 ! use north-south periodicity
716            ishift2 = nn_hls
717            DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;   DO ji = 1, jpi
718               ARRAY_IN(ji,ishift+jj,jk,jl,jf) = ARRAY_IN(ji,ishift2+jj,jk,jl,jf)
719            END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
720         CASE ( jpfillcopy  )                 ! filling with inner domain values
721            DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;   DO ji = 1, jpi
722               ARRAY_IN(ji,ishift+jj,jk,jl,jf) = ARRAY_IN(ji,ishift,jk,jl,jf)
723            END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
724         CASE ( jpfillcst   )                 ! filling with constant value
725            DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;   DO ji = 1, jpi
726               ARRAY_IN(ji,ishift+jj,jk,jl,jf) = zland
727            END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
728         END SELECT
729      ENDIF
730
731      IF(llncall) THEN
732
733         !!! Patch to solve MPI3 bug when we have only two processes columns
734         IF(jpni .eq. 2) THEN
735            !!! Patch to solve MPI3 bug when we have only two processes rows
736            IF(jpnj .eq. 2) THEN
737               ! ---------------------------
738               ! 2.5 fill east-nouthern halo
739               ! ---------------------------
740                 IF(noner .ne. -1) THEN
741                    ishift = jpi - nn_hls
742                    ishift2 = jpj - nn_hls
743                    DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;  DO ji = 1, nn_hls
744                       ARRAY_IN(ji+ishift,jj+ishift2,jk,jl,jf) = zrcv(idx)
745                       idx = idx + 1
746                    END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
747                 END IF
748               ! ---------------------------
749               ! 2.6 fill west-nouthern halo
750               ! ---------------------------
751                 IF(nonwr .ne. -1) THEN
752                    ishift = jpj - nn_hls
753                    DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;  DO ji = 1, nn_hls
754                       ARRAY_IN(ji,jj+ishift,jk,jl,jf) = zrcv(idx)
755                       idx = idx + 1
756                    END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
757                 END IF
758               ! ---------------------------
759               ! 2.7 fill east-southern halo
760               ! ---------------------------
761                 IF(noser .ne. -1) THEN
762                    ishift = jpi - nn_hls
763                    DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;  DO ji = 1, nn_hls
764                       ARRAY_IN(ji+ishift,jj,jk,jl,jf) = zrcv(idx)
765                       idx = idx + 1
766                    END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
767                 END IF
768               ! ---------------------------
769               ! 2.8 fill west-southern halo
770               ! ---------------------------
771                 IF(noswr .ne. -1) THEN
772                    DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;  DO ji = 1, nn_hls
773                       ARRAY_IN(ji,jj,jk,jl,jf) = zrcv(idx)
774                       idx = idx + 1
775                    END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
776                 END IF
777
778            ELSE
779               ! ---------------------------
780               ! 2.5 fill east-southern halo
781               ! ---------------------------
782                 IF(noser .ne. -1) THEN
783                    ishift = jpi - nn_hls
784                    DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;  DO ji = 1, nn_hls
785                       ARRAY_IN(ji+ishift,jj,jk,jl,jf) = zrcv(idx)
786                       idx = idx + 1
787                    END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
788                 END IF
789               ! ---------------------------
790               ! 2.6 fill west-southern halo
791               ! ---------------------------
792                 IF(noswr .ne. -1) THEN
793                    DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;  DO ji = 1, nn_hls
794                       ARRAY_IN(ji,jj,jk,jl,jf) = zrcv(idx)
795                       idx = idx + 1
796                    END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
797                 END IF
798               ! ---------------------------
799               ! 2.7 fill east-nouthern halo
800               ! ---------------------------
801                 IF(noner .ne. -1) THEN
802                    ishift = jpi - nn_hls
803                    ishift2 = jpj - nn_hls
804                    DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;  DO ji = 1, nn_hls
805                       ARRAY_IN(ji+ishift,jj+ishift2,jk,jl,jf) = zrcv(idx)
806                       idx = idx + 1
807                    END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
808                 END IF
809               ! ---------------------------
810               ! 2.8 fill west-nouthern halo
811               ! ---------------------------
812                 IF(nonwr .ne. -1) THEN
813                    ishift = jpj - nn_hls
814                    DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;  DO ji = 1, nn_hls
815                       ARRAY_IN(ji,jj+ishift,jk,jl,jf) = zrcv(idx)
816                       idx = idx + 1
817                    END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
818                 END IF
819            ENDIF
820         ELSE
821            !!! Patch to solve MPI3 bug when we have only two processes rows
822            IF(jpnj .eq. 2) THEN
823               ! ---------------------------
824               ! 2.5 fill west-nouthern halo
825               ! ---------------------------
826                 IF(nonwr .ne. -1) THEN
827                    ishift = jpj - nn_hls
828                    DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;  DO ji = 1, nn_hls
829                       ARRAY_IN(ji,jj+ishift,jk,jl,jf) = zrcv(idx)
830                       idx = idx + 1
831                    END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
832                 END IF
833               ! ---------------------------
834               ! 2.6 fill east-nouthern halo
835               ! ---------------------------
836                 IF(noner .ne. -1) THEN
837                    ishift = jpi - nn_hls
838                    ishift2 = jpj - nn_hls
839                    DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;  DO ji = 1, nn_hls
840                       ARRAY_IN(ji+ishift,jj+ishift2,jk,jl,jf) = zrcv(idx)
841                       idx = idx + 1
842                    END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
843                 END IF
844               ! ---------------------------
845               ! 2.7 fill west-southern halo
846               ! ---------------------------
847                 IF(noswr .ne. -1) THEN
848                    DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;  DO ji = 1, nn_hls
849                       ARRAY_IN(ji,jj,jk,jl,jf) = zrcv(idx)
850                       idx = idx + 1
851                    END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
852                 END IF
853               ! ---------------------------
854               ! 2.8 fill east-southern halo
855               ! ---------------------------
856                 IF(noser .ne. -1) THEN
857                    ishift = jpi - nn_hls
858                    DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;  DO ji = 1, nn_hls
859                       ARRAY_IN(ji+ishift,jj,jk,jl,jf) = zrcv(idx)
860                       idx = idx + 1
861                    END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
862                 END IF
863
864            ELSE
865               ! ---------------------------
866               ! 2.5 fill west-southern halo
867               ! ---------------------------
868                 IF(noswr .ne. -1) THEN
869                    DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;  DO ji = 1, nn_hls
870                       ARRAY_IN(ji,jj,jk,jl,jf) = zrcv(idx)
871                       idx = idx + 1
872                    END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
873                 END IF
874               ! ---------------------------
875               ! 2.6 fill east-southern halo
876               ! ---------------------------
877                 IF(noser .ne. -1) THEN
878                    ishift = jpi - nn_hls
879                    DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;  DO ji = 1, nn_hls
880                       ARRAY_IN(ji+ishift,jj,jk,jl,jf) = zrcv(idx)
881                       idx = idx + 1
882                    END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
883                 END IF
884               ! ---------------------------
885               ! 2.7 fill west-nouthern halo
886               ! ---------------------------
887                 IF(nonwr .ne. -1) THEN
888                    ishift = jpj - nn_hls
889                    DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;  DO ji = 1, nn_hls
890                       ARRAY_IN(ji,jj+ishift,jk,jl,jf) = zrcv(idx)
891                       idx = idx + 1
892                    END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
893                 END IF
894               ! ---------------------------
895               ! 2.8 fill east-nouthern halo
896               ! ---------------------------
897                 IF(noner .ne. -1) THEN
898                    ishift = jpi - nn_hls
899                    ishift2 = jpj - nn_hls
900                    DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;  DO ji = 1, nn_hls
901                       ARRAY_IN(ji+ishift,jj+ishift2,jk,jl,jf) = zrcv(idx)
902                       idx = idx + 1
903                    END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
904                 END IF
905            ENDIF
906         END IF
907      END IF
908
909
910      !
911      ! -------------------------------------------- !
912      !     3. deallocate local temporary arrays     !
913      ! -------------------------------------------- !
914      !
915      DEALLOCATE( zsnd )
916      DEALLOCATE( zrcv )
917      DEALLOCATE(isizes)
918      DEALLOCATE(isizer)
919      DEALLOCATE(idatatys)
920      DEALLOCATE(idatatyr)
921      DEALLOCATE(idispls)
922      DEALLOCATE(idisplr)
923      !
924      ! ------------------------------- !
925      !     4. north fold treatment     !
926      ! ------------------------------- !
927      !
928      IF( lldo_nfd .AND. ifill_no /= jpfillnothing ) THEN
929         !
930         SELECT CASE ( jpni )
931         CASE ( 1 )     ;   CALL lbc_nfd( ptab, NAT_IN(:), SGN_IN(:)                  OPT_K(:) )   ! only 1 northern proc, no mpp
932         CASE DEFAULT   ;   CALL mpp_nfd( ptab, NAT_IN(:), SGN_IN(:), ifill_no, zland OPT_K(:) )   ! for all northern procs.
933         END SELECT
934         !
935         ifill_no = jpfillnothing  ! force to do nothing for the northern halo as we just done the north pole folding
936         !
937      ENDIF
938
939   END SUBROUTINE ROUTINE_NC
940
941#undef PRECISION
942#undef ARRAY_TYPE
943#undef NAT_IN
944#undef SGN_IN
945#undef ARRAY_IN
946#undef K_SIZE
947#undef L_SIZE
948#undef F_SIZE
949#undef OPT_K
950#undef MPI_TYPE
Note: See TracBrowser for help on using the repository browser.