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_lnk_generic.h90 in NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/LBC – NEMO

Context Navigation

source: NEMO/branches/2020/dev_r12377_KERNEL-06_techene_e3/src/OCE/LBC/mpp_lnk_generic.h90 @ 13228

Last change on this file since 13228 was 13228, checked in by smasson, 4 years ago
better e3: update with trunk@13227 see #2385
Property svn:keywords set to `Id` Property svn:mime-type set to `text/x-fortran`
File size: 21.5 KB

Line
1	#if defined MULTI
2	# define NAT_IN(k) cd_nat(k)
3	# define SGN_IN(k) psgn(k)
4	# define F_SIZE(ptab) kfld
5	# define OPT_K(k) ,ipf
6	# if defined DIM_2d
7	# if defined SINGLE_PRECISION
8	# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_sp) , INTENT(inout) :: ptab(f)
9	# else
10	# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_dp) , INTENT(inout) :: ptab(f)
11	# endif
12	# define ARRAY_IN(i,j,k,l,f) ptab(f)%pt2d(i,j)
13	# define K_SIZE(ptab) 1
14	# define L_SIZE(ptab) 1
15	# endif
16	# if defined DIM_3d
17	# if defined SINGLE_PRECISION
18	# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_sp) , INTENT(inout) :: ptab(f)
19	# else
20	# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_dp) , INTENT(inout) :: ptab(f)
21	# endif
22	# define ARRAY_IN(i,j,k,l,f) ptab(f)%pt3d(i,j,k)
23	# define K_SIZE(ptab) SIZE(ptab(1)%pt3d,3)
24	# define L_SIZE(ptab) 1
25	# endif
26	# if defined DIM_4d
27	# if defined SINGLE_PRECISION
28	# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_sp) , INTENT(inout) :: ptab(f)
29	# else
30	# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_dp) , INTENT(inout) :: ptab(f)
31	# endif
32	# define ARRAY_IN(i,j,k,l,f) ptab(f)%pt4d(i,j,k,l)
33	# define K_SIZE(ptab) SIZE(ptab(1)%pt4d,3)
34	# define L_SIZE(ptab) SIZE(ptab(1)%pt4d,4)
35	# endif
36	#else
37	# if defined SINGLE_PRECISION
38	# define ARRAY_TYPE(i,j,k,l,f) REAL(sp) , INTENT(inout) :: ARRAY_IN(i,j,k,l,f)
39	# else
40	# define ARRAY_TYPE(i,j,k,l,f) REAL(dp) , INTENT(inout) :: ARRAY_IN(i,j,k,l,f)
41	# endif
42	# define NAT_IN(k) cd_nat
43	# define SGN_IN(k) psgn
44	# define F_SIZE(ptab) 1
45	# define OPT_K(k)
46	# if defined DIM_2d
47	# define ARRAY_IN(i,j,k,l,f) ptab(i,j)
48	# define K_SIZE(ptab) 1
49	# define L_SIZE(ptab) 1
50	# endif
51	# if defined DIM_3d
52	# define ARRAY_IN(i,j,k,l,f) ptab(i,j,k)
53	# define K_SIZE(ptab) SIZE(ptab,3)
54	# define L_SIZE(ptab) 1
55	# endif
56	# if defined DIM_4d
57	# define ARRAY_IN(i,j,k,l,f) ptab(i,j,k,l)
58	# define K_SIZE(ptab) SIZE(ptab,3)
59	# define L_SIZE(ptab) SIZE(ptab,4)
60	# endif
61	#endif
62
63	# if defined SINGLE_PRECISION
64	# define PRECISION sp
65	# define SENDROUTINE mppsend_sp
66	# define RECVROUTINE mpprecv_sp
67	# else
68	# define PRECISION dp
69	# define SENDROUTINE mppsend_dp
70	# define RECVROUTINE mpprecv_dp
71	# endif
72
73	#if defined MULTI
74	SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, lsend, lrecv, ihlcom )
75	INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays
76	#else
77	SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn , kfillmode, pfillval, lsend, lrecv, ihlcom )
78	#endif
79	ARRAY_TYPE(:,:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied
80	CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine
81	CHARACTER(len=1) , INTENT(in ) :: NAT_IN(:) ! nature of array grid-points
82	REAL(wp) , INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary
83	INTEGER , OPTIONAL, INTENT(in ) :: kfillmode ! filling method for halo over land (default = constant)
84	REAL(wp), OPTIONAL, INTENT(in ) :: pfillval ! background value (used at closed boundaries)
85	LOGICAL, DIMENSION(4),OPTIONAL, INTENT(in ) :: lsend, lrecv ! communication with other 4 proc
86	INTEGER ,OPTIONAL, INTENT(in ) :: ihlcom ! number of ranks and rows to be communicated
87	!
88	INTEGER :: ji, jj, jk, jl, jf ! dummy loop indices
89	INTEGER :: ipi, ipj, ipk, ipl, ipf ! dimension of the input array
90	INTEGER :: isize, ishift, ishift2 ! local integers
91	INTEGER :: ireq_we, ireq_ea, ireq_so, ireq_no ! mpi_request id
92	INTEGER :: ierr
93	INTEGER :: ifill_we, ifill_ea, ifill_so, ifill_no
94	INTEGER :: ihl ! number of ranks and rows to be communicated
95	REAL(PRECISION) :: zland
96	INTEGER , DIMENSION(MPI_STATUS_SIZE) :: istat ! for mpi_isend
97	REAL(PRECISION), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zsnd_we, zrcv_we, zsnd_ea, zrcv_ea ! east -west & west - east halos
98	REAL(PRECISION), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zsnd_so, zrcv_so, zsnd_no, zrcv_no ! north-south & south-north halos
99	LOGICAL :: llsend_we, llsend_ea, llsend_no, llsend_so ! communication send
100	LOGICAL :: llrecv_we, llrecv_ea, llrecv_no, llrecv_so ! communication receive
101	LOGICAL :: lldo_nfd ! do north pole folding
102	!!----------------------------------------------------------------------
103	!
104	! ----------------------------------------- !
105	! 0. local variables initialization !
106	! ----------------------------------------- !
107	!
108	ipk = K_SIZE(ptab) ! 3rd dimension
109	ipl = L_SIZE(ptab) ! 4th -
110	ipf = F_SIZE(ptab) ! 5th - use in "multi" case (array of pointers)
111	!
112	IF( PRESENT(ihlcom) ) THEN ; ihl = ihlcom
113	ELSE ; ihl = 1
114	END IF
115	!
116	IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ipk, ipl, ipf, ld_lbc = .TRUE. )
117	!
118	IF ( PRESENT(lsend) .AND. PRESENT(lrecv) ) THEN
119	llsend_we = lsend(1) ; llsend_ea = lsend(2) ; llsend_so = lsend(3) ; llsend_no = lsend(4)
120	llrecv_we = lrecv(1) ; llrecv_ea = lrecv(2) ; llrecv_so = lrecv(3) ; llrecv_no = lrecv(4)
121	ELSE IF( PRESENT(lsend) .OR. PRESENT(lrecv) ) THEN
122	WRITE(ctmp1,*) ' E R R O R : Routine ', cdname, ' is calling lbc_lnk with only one of the two arguments lsend or lrecv'
123	WRITE(ctmp2,*) ' ========== '
124	CALL ctl_stop( ' ', ctmp1, ctmp2, ' ' )
125	ELSE ! send and receive with every neighbour
126	llsend_we = nbondi == 1 .OR. nbondi == 0 ! keep for compatibility, should be defined in mppini
127	llsend_ea = nbondi == -1 .OR. nbondi == 0 ! keep for compatibility, should be defined in mppini
128	llsend_so = nbondj == 1 .OR. nbondj == 0 ! keep for compatibility, should be defined in mppini
129	llsend_no = nbondj == -1 .OR. nbondj == 0 ! keep for compatibility, should be defined in mppini
130	llrecv_we = llsend_we ; llrecv_ea = llsend_ea ; llrecv_so = llsend_so ; llrecv_no = llsend_no
131	END IF
132
133
134	lldo_nfd = npolj /= 0 ! keep for compatibility, should be defined in mppini
135
136	zland = 0._wp ! land filling value: zero by default
137	IF( PRESENT( pfillval ) ) zland = pfillval ! set land value
138
139	! define the method we will use to fill the halos in each direction
140	IF( llrecv_we ) THEN ; ifill_we = jpfillmpi
141	ELSEIF( l_Iperio ) THEN ; ifill_we = jpfillperio
142	ELSEIF( PRESENT(kfillmode) ) THEN ; ifill_we = kfillmode
143	ELSE ; ifill_we = jpfillcst
144	END IF
145	!
146	IF( llrecv_ea ) THEN ; ifill_ea = jpfillmpi
147	ELSEIF( l_Iperio ) THEN ; ifill_ea = jpfillperio
148	ELSEIF( PRESENT(kfillmode) ) THEN ; ifill_ea = kfillmode
149	ELSE ; ifill_ea = jpfillcst
150	END IF
151	!
152	IF( llrecv_so ) THEN ; ifill_so = jpfillmpi
153	ELSEIF( l_Jperio ) THEN ; ifill_so = jpfillperio
154	ELSEIF( PRESENT(kfillmode) ) THEN ; ifill_so = kfillmode
155	ELSE ; ifill_so = jpfillcst
156	END IF
157	!
158	IF( llrecv_no ) THEN ; ifill_no = jpfillmpi
159	ELSEIF( l_Jperio ) THEN ; ifill_no = jpfillperio
160	ELSEIF( PRESENT(kfillmode) ) THEN ; ifill_no = kfillmode
161	ELSE ; ifill_no = jpfillcst
162	END IF
163	!
164	#if defined PRINT_CAUTION
165	!
166	! ================================================================================== !
167	! CAUTION: semi-column notation is often impossible because of the cpp preprocessing !
168	! ================================================================================== !
169	!
170	#endif
171	!
172	! -------------------------------------------------- !
173	! 1. Do east and west MPI exchange if needed !
174	! -------------------------------------------------- !
175	!
176	! Must exchange the whole column (from 1 to jpj) to get the corners if we have no south/north neighbourg
177	isize = ihl * jpj * ipk * ipl * ipf
178	!
179	! Allocate local temporary arrays to be sent/received. Fill arrays to be sent
180	IF( llsend_we ) ALLOCATE( zsnd_we(ihl,jpj,ipk,ipl,ipf) )
181	IF( llsend_ea ) ALLOCATE( zsnd_ea(ihl,jpj,ipk,ipl,ipf) )
182	IF( llrecv_we ) ALLOCATE( zrcv_we(ihl,jpj,ipk,ipl,ipf) )
183	IF( llrecv_ea ) ALLOCATE( zrcv_ea(ihl,jpj,ipk,ipl,ipf) )
184	!
185	IF( llsend_we ) THEN ! copy western side of the inner mpi domain in local temporary array to be sent by MPI
186	ishift = ihl
187	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl
188	zsnd_we(ji,jj,jk,jl,jf) = ARRAY_IN(ishift+ji,jj,jk,jl,jf) ! ihl + 1 -> 2*ihl
189	END DO ; END DO ; END DO ; END DO ; END DO
190	ENDIF
191	!
192	IF(llsend_ea ) THEN ! copy eastern side of the inner mpi domain in local temporary array to be sent by MPI
193	ishift = jpi - 2 * ihl
194	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl
195	zsnd_ea(ji,jj,jk,jl,jf) = ARRAY_IN(ishift+ji,jj,jk,jl,jf) ! jpi - 2*ihl + 1 -> jpi - ihl
196	END DO ; END DO ; END DO ; END DO ; END DO
197	ENDIF
198	!
199	IF( ln_timing ) CALL tic_tac(.TRUE.)
200	!
201	! non-blocking send of the western/eastern side using local temporary arrays
202	IF( llsend_we ) CALL SENDROUTINE( 1, zsnd_we(1,1,1,1,1), isize, nowe, ireq_we )
203	IF( llsend_ea ) CALL SENDROUTINE( 2, zsnd_ea(1,1,1,1,1), isize, noea, ireq_ea )
204	! blocking receive of the western/eastern halo in local temporary arrays
205	IF( llrecv_we ) CALL RECVROUTINE( 2, zrcv_we(1,1,1,1,1), isize, nowe )
206	IF( llrecv_ea ) CALL RECVROUTINE( 1, zrcv_ea(1,1,1,1,1), isize, noea )
207	!
208	IF( ln_timing ) CALL tic_tac(.FALSE.)
209	!
210	!
211	! ----------------------------------- !
212	! 2. Fill east and west halos !
213	! ----------------------------------- !
214	!
215	! 2.1 fill weastern halo
216	! ----------------------
217	! ishift = 0 ! fill halo from ji = 1 to ihl
218	SELECT CASE ( ifill_we )
219	CASE ( jpfillnothing ) ! no filling
220	CASE ( jpfillmpi ) ! use data received by MPI
221	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl
222	ARRAY_IN(ji,jj,jk,jl,jf) = zrcv_we(ji,jj,jk,jl,jf) ! 1 -> ihl
223	END DO; END DO ; END DO ; END DO ; END DO
224	CASE ( jpfillperio ) ! use east-weast periodicity
225	ishift2 = jpi - 2 * ihl
226	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl
227	ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ishift2+ji,jj,jk,jl,jf)
228	END DO; END DO ; END DO ; END DO ; END DO
229	CASE ( jpfillcopy ) ! filling with inner domain values
230	DO jf = 1, ipf ! number of arrays to be treated
231	IF( .NOT. NAT_IN(jf) == 'F' ) THEN ! do nothing for F point
232	DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl
233	ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ihl+1,jj,jk,jl,jf)
234	END DO ; END DO ; END DO ; END DO
235	ENDIF
236	END DO
237	CASE ( jpfillcst ) ! filling with constant value
238	DO jf = 1, ipf ! number of arrays to be treated
239	IF( .NOT. NAT_IN(jf) == 'F' ) THEN ! do nothing for F point
240	DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl
241	ARRAY_IN(ji,jj,jk,jl,jf) = zland
242	END DO; END DO ; END DO ; END DO
243	ENDIF
244	END DO
245	END SELECT
246	!
247	! 2.2 fill eastern halo
248	! ---------------------
249	ishift = jpi - ihl ! fill halo from ji = jpi-ihl+1 to jpi
250	SELECT CASE ( ifill_ea )
251	CASE ( jpfillnothing ) ! no filling
252	CASE ( jpfillmpi ) ! use data received by MPI
253	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl
254	ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zrcv_ea(ji,jj,jk,jl,jf) ! jpi - ihl + 1 -> jpi
255	END DO ; END DO ; END DO ; END DO ; END DO
256	CASE ( jpfillperio ) ! use east-weast periodicity
257	ishift2 = ihl
258	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl
259	ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ishift2+ji,jj,jk,jl,jf)
260	END DO ; END DO ; END DO ; END DO ; END DO
261	CASE ( jpfillcopy ) ! filling with inner domain values
262	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl
263	ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ishift,jj,jk,jl,jf)
264	END DO ; END DO ; END DO ; END DO ; END DO
265	CASE ( jpfillcst ) ! filling with constant value
266	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl
267	ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zland
268	END DO; END DO ; END DO ; END DO ; END DO
269	END SELECT
270	!
271	! ------------------------------- !
272	! 3. north fold treatment !
273	! ------------------------------- !
274	!
275	! do it before south directions so concerned processes can do it without waiting for the comm with the sourthern neighbor
276	!
277	IF( lldo_nfd .AND. ifill_no /= jpfillnothing ) THEN
278	!
279	SELECT CASE ( jpni )
280	CASE ( 1 ) ; CALL lbc_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) ) ! only 1 northern proc, no mpp
281	CASE DEFAULT ; CALL mpp_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) ) ! for all northern procs.
282	END SELECT
283	!
284	ifill_no = jpfillnothing ! force to do nothing for the northern halo as we just done the north pole folding
285	!
286	ENDIF
287	!
288	! ---------------------------------------------------- !
289	! 4. Do north and south MPI exchange if needed !
290	! ---------------------------------------------------- !
291	!
292	IF( llsend_so ) ALLOCATE( zsnd_so(jpi,ihl,ipk,ipl,ipf) )
293	IF( llsend_no ) ALLOCATE( zsnd_no(jpi,ihl,ipk,ipl,ipf) )
294	IF( llrecv_so ) ALLOCATE( zrcv_so(jpi,ihl,ipk,ipl,ipf) )
295	IF( llrecv_no ) ALLOCATE( zrcv_no(jpi,ihl,ipk,ipl,ipf) )
296	!
297	isize = jpi * ihl * ipk * ipl * ipf
298
299	! allocate local temporary arrays to be sent/received. Fill arrays to be sent
300	IF( llsend_so ) THEN ! copy sourhern side of the inner mpi domain in local temporary array to be sent by MPI
301	ishift = ihl
302	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi
303	zsnd_so(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift+jj,jk,jl,jf) ! ihl+1 -> 2*ihl
304	END DO ; END DO ; END DO ; END DO ; END DO
305	ENDIF
306	!
307	IF( llsend_no ) THEN ! copy eastern side of the inner mpi domain in local temporary array to be sent by MPI
308	ishift = jpj - 2 * ihl
309	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi
310	zsnd_no(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift+jj,jk,jl,jf) ! jpj-2*ihl+1 -> jpj-ihl
311	END DO ; END DO ; END DO ; END DO ; END DO
312	ENDIF
313	!
314	IF( ln_timing ) CALL tic_tac(.TRUE.)
315	!
316	! non-blocking send of the southern/northern side
317	IF( llsend_so ) CALL SENDROUTINE( 3, zsnd_so(1,1,1,1,1), isize, noso, ireq_so )
318	IF( llsend_no ) CALL SENDROUTINE( 4, zsnd_no(1,1,1,1,1), isize, nono, ireq_no )
319	! blocking receive of the southern/northern halo
320	IF( llrecv_so ) CALL RECVROUTINE( 4, zrcv_so(1,1,1,1,1), isize, noso )
321	IF( llrecv_no ) CALL RECVROUTINE( 3, zrcv_no(1,1,1,1,1), isize, nono )
322	!
323	IF( ln_timing ) CALL tic_tac(.FALSE.)
324	!
325	! ------------------------------------- !
326	! 5. Fill south and north halos !
327	! ------------------------------------- !
328	!
329	! 5.1 fill southern halo
330	! ----------------------
331	! ishift = 0 ! fill halo from jj = 1 to ihl
332	SELECT CASE ( ifill_so )
333	CASE ( jpfillnothing ) ! no filling
334	CASE ( jpfillmpi ) ! use data received by MPI
335	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi
336	ARRAY_IN(ji,jj,jk,jl,jf) = zrcv_so(ji,jj,jk,jl,jf) ! 1 -> ihl
337	END DO; END DO ; END DO ; END DO ; END DO
338	CASE ( jpfillperio ) ! use north-south periodicity
339	ishift2 = jpj - 2 * ihl
340	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi
341	ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift2+jj,jk,jl,jf)
342	END DO; END DO ; END DO ; END DO ; END DO
343	CASE ( jpfillcopy ) ! filling with inner domain values
344	DO jf = 1, ipf ! number of arrays to be treated
345	IF( .NOT. NAT_IN(jf) == 'F' ) THEN ! do nothing for F point
346	DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi
347	ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ihl+1,jk,jl,jf)
348	END DO ; END DO ; END DO ; END DO
349	ENDIF
350	END DO
351	CASE ( jpfillcst ) ! filling with constant value
352	DO jf = 1, ipf ! number of arrays to be treated
353	IF( .NOT. NAT_IN(jf) == 'F' ) THEN ! do nothing for F point
354	DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi
355	ARRAY_IN(ji,jj,jk,jl,jf) = zland
356	END DO; END DO ; END DO ; END DO
357	ENDIF
358	END DO
359	END SELECT
360	!
361	! 5.2 fill northern halo
362	! ----------------------
363	ishift = jpj - ihl ! fill halo from jj = jpj-ihl+1 to jpj
364	SELECT CASE ( ifill_no )
365	CASE ( jpfillnothing ) ! no filling
366	CASE ( jpfillmpi ) ! use data received by MPI
367	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi
368	ARRAY_IN(ji,ishift+jj,jk,jl,jf) = zrcv_no(ji,jj,jk,jl,jf) ! jpj-ihl+1 -> jpj
369	END DO ; END DO ; END DO ; END DO ; END DO
370	CASE ( jpfillperio ) ! use north-south periodicity
371	ishift2 = ihl
372	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi
373	ARRAY_IN(ji,ishift+jj,jk,jl,jf) = ARRAY_IN(ji,ishift2+jj,jk,jl,jf)
374	END DO; END DO ; END DO ; END DO ; END DO
375	CASE ( jpfillcopy ) ! filling with inner domain values
376	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi
377	ARRAY_IN(ji,ishift+jj,jk,jl,jf) = ARRAY_IN(ji,ishift,jk,jl,jf)
378	END DO; END DO ; END DO ; END DO ; END DO
379	CASE ( jpfillcst ) ! filling with constant value
380	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi
381	ARRAY_IN(ji,ishift+jj,jk,jl,jf) = zland
382	END DO; END DO ; END DO ; END DO ; END DO
383	END SELECT
384	!
385	! -------------------------------------------- !
386	! 6. deallocate local temporary arrays !
387	! -------------------------------------------- !
388	!
389	IF( llsend_we ) THEN
390	CALL mpi_wait(ireq_we, istat, ierr )
391	DEALLOCATE( zsnd_we )
392	ENDIF
393	IF( llsend_ea ) THEN
394	CALL mpi_wait(ireq_ea, istat, ierr )
395	DEALLOCATE( zsnd_ea )
396	ENDIF
397	IF( llsend_so ) THEN
398	CALL mpi_wait(ireq_so, istat, ierr )
399	DEALLOCATE( zsnd_so )
400	ENDIF
401	IF( llsend_no ) THEN
402	CALL mpi_wait(ireq_no, istat, ierr )
403	DEALLOCATE( zsnd_no )
404	ENDIF
405	!
406	IF( llrecv_we ) DEALLOCATE( zrcv_we )
407	IF( llrecv_ea ) DEALLOCATE( zrcv_ea )
408	IF( llrecv_so ) DEALLOCATE( zrcv_so )
409	IF( llrecv_no ) DEALLOCATE( zrcv_no )
410	!
411	END SUBROUTINE ROUTINE_LNK
412
413	#undef ARRAY_TYPE
414	#undef NAT_IN
415	#undef SGN_IN
416	#undef ARRAY_IN
417	#undef K_SIZE
418	#undef L_SIZE
419	#undef F_SIZE
420	#undef OPT_K

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

Download in other formats: