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

Context Navigation

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

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

Note: See TracBrowser for help on using the repository browser.

Download in other formats:

Original Format