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_r13648_ASINTER-04_laurent_bulk_ice/src/OCE/LBC – NEMO

Context Navigation

source: NEMO/branches/2020/dev_r13648_ASINTER-04_laurent_bulk_ice/src/OCE/LBC/mpp_nc_generic.h90 @ 14021

Last change on this file since 14021 was 14021, checked in by laurent, 3 years ago
Caught up with trunk rev 14020...
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 - 2nn_hls) ipk * ipl * ipf
180	IF(llsend_ea) izsnd = izsnd + nn_hls * (jpj - 2nn_hls) ipk * ipl * ipf
181	IF(llsend_so) izsnd = izsnd + (jpi - 2nn_hls) nn_hls * ipk * ipl * ipf
182	IF(llsend_no) izsnd = izsnd + (jpi - 2nn_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 - 2nn_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 - 2nn_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 - 2nn_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 - 2nn_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.

Download in other formats:

Original Format