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/2019/dev_r11514_HPC-02_single-core-extrahalo/src/OCE/LBC – NEMO

Context Navigation

source: NEMO/branches/2019/dev_r11514_HPC-02_single-core-extrahalo/src/OCE/LBC/mpp_lnk_generic.h90 @ 11719

Last change on this file since 11719 was 11719, checked in by francesca, 5 years ago
add extra halo support- ticket #2009
Property svn:keywords set to `Id` Property svn:mime-type set to `text/x-fortran`
File size: 20.9 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	# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D) , INTENT(inout) :: ptab(f)
8	# define ARRAY_IN(i,j,k,l,f) ptab(f)%pt2d(i,j)
9	# define K_SIZE(ptab) 1
10	# define L_SIZE(ptab) 1
11	# endif
12	# if defined DIM_3d
13	# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D) , INTENT(inout) :: ptab(f)
14	# define ARRAY_IN(i,j,k,l,f) ptab(f)%pt3d(i,j,k)
15	# define K_SIZE(ptab) SIZE(ptab(1)%pt3d,3)
16	# define L_SIZE(ptab) 1
17	# endif
18	# if defined DIM_4d
19	# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D) , INTENT(inout) :: ptab(f)
20	# define ARRAY_IN(i,j,k,l,f) ptab(f)%pt4d(i,j,k,l)
21	# define K_SIZE(ptab) SIZE(ptab(1)%pt4d,3)
22	# define L_SIZE(ptab) SIZE(ptab(1)%pt4d,4)
23	# endif
24	#else
25	# define ARRAY_TYPE(i,j,k,l,f) REAL(wp) , INTENT(inout) :: ARRAY_IN(i,j,k,l,f)
26	# define NAT_IN(k) cd_nat
27	# define SGN_IN(k) psgn
28	# define F_SIZE(ptab) 1
29	# define OPT_K(k)
30	# if defined DIM_2d
31	# define ARRAY_IN(i,j,k,l,f) ptab(i,j)
32	# define K_SIZE(ptab) 1
33	# define L_SIZE(ptab) 1
34	# endif
35	# if defined DIM_3d
36	# define ARRAY_IN(i,j,k,l,f) ptab(i,j,k)
37	# define K_SIZE(ptab) SIZE(ptab,3)
38	# define L_SIZE(ptab) 1
39	# endif
40	# if defined DIM_4d
41	# define ARRAY_IN(i,j,k,l,f) ptab(i,j,k,l)
42	# define K_SIZE(ptab) SIZE(ptab,3)
43	# define L_SIZE(ptab) SIZE(ptab,4)
44	# endif
45	#endif
46
47	#if defined MULTI
48	SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, lsend, lrecv )
49	INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays
50	#else
51	SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn , kfillmode, pfillval, lsend, lrecv )
52	#endif
53	ARRAY_TYPE(1-nn_hls+1:,1-nn_hls+1:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied
54	CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine
55	CHARACTER(len=1) , INTENT(in ) :: NAT_IN(:) ! nature of array grid-points
56	REAL(wp) , INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary
57	INTEGER , OPTIONAL, INTENT(in ) :: kfillmode ! filling method for halo over land (default = constant)
58	REAL(wp), OPTIONAL, INTENT(in ) :: pfillval ! background value (used at closed boundaries)
59	LOGICAL, DIMENSION(4),OPTIONAL, INTENT(in ) :: lsend, lrecv ! communication with other 4 proc
60	!
61	INTEGER :: ji, jj, jk, jl, jf ! dummy loop indices
62	INTEGER :: ipi, ipj, ipk, ipl, ipf ! dimension of the input array
63	INTEGER :: isize, ishift, ishift2 ! local integers
64	INTEGER :: ireq_we, ireq_ea, ireq_so, ireq_no ! mpi_request id
65	INTEGER :: ierr
66	INTEGER :: ifill_we, ifill_ea, ifill_so, ifill_no
67	REAL(wp) :: zland
68	INTEGER , DIMENSION(MPI_STATUS_SIZE) :: istat ! for mpi_isend
69	REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zsnd_we, zrcv_we, zsnd_ea, zrcv_ea ! east -west & west - east halos
70	REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zsnd_so, zrcv_so, zsnd_no, zrcv_no ! north-south & south-north halos
71	LOGICAL :: llsend_we, llsend_ea, llsend_no, llsend_so ! communication send
72	LOGICAL :: llrecv_we, llrecv_ea, llrecv_no, llrecv_so ! communication receive
73	LOGICAL :: lldo_nfd ! do north pole folding
74	!!----------------------------------------------------------------------
75	!
76	! ----------------------------------------- !
77	! 0. local variables initialization !
78	! ----------------------------------------- !
79	!
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
102	lldo_nfd = npolj /= 0 ! keep for compatibility, should be defined in mppini
103
104	zland = 0._wp ! land filling value: zero by default
105	IF( PRESENT( pfillval ) ) zland = pfillval ! set land value
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 defined PRINT_CAUTION
133	!
134	! ================================================================================== !
135	! CAUTION: semi-column notation is often impossible because of the cpp preprocessing !
136	! ================================================================================== !
137	!
138	#endif
139	!
140	! -------------------------------------------------- !
141	! 1. Do east and west MPI exchange if needed !
142	! -------------------------------------------------- !
143	!
144
145	! Must exchange the whole column (from 1 to jpj) to get the corners if we have no south/north neighbourg
146	isize = nn_hls * ( jpj + nn_hls - 1 ) * ipk * ipl * ipf
147	!
148	! Allocate local temporary arrays to be sent/received. Fill arrays to be sent
149	IF( llsend_we ) ALLOCATE( zsnd_we(nn_hls,1-nn_hls+1:jpj,ipk,ipl,ipf) )
150	IF( llsend_ea ) ALLOCATE( zsnd_ea(nn_hls,1-nn_hls+1:jpj,ipk,ipl,ipf) )
151	IF( llrecv_we ) ALLOCATE( zrcv_we(nn_hls,1-nn_hls+1:jpj,ipk,ipl,ipf) )
152	IF( llrecv_ea ) ALLOCATE( zrcv_ea(nn_hls,1-nn_hls+1:jpj,ipk,ipl,ipf) )
153	!
154	IF( llsend_we ) THEN ! copy western side of the inner mpi domain in local temporary array to be sent by MPI
155	ishift = 1
156	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1-nn_hls+1, jpj ; DO ji = 1, nn_hls
157	zsnd_we(ji,jj,jk,jl,jf) = ARRAY_IN(ishift+ji,jj,jk,jl,jf) ! nn_hls + 1 -> 2*nn_hls
158	END DO ; END DO ; END DO ; END DO ; END DO
159	ENDIF
160	!
161	IF( llsend_ea ) THEN ! copy eastern side of the inner mpi domain in local temporary array to be sent by MPI
162	ishift = jpi - 2 * nn_hls
163	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1-nn_hls+1, jpj ; DO ji = 1, nn_hls
164	zsnd_ea(ji,jj,jk,jl,jf) = ARRAY_IN(ishift+ji,jj,jk,jl,jf) ! jpi - 2*nn_hls + 1 -> jpi - nn_hls
165	END DO ; END DO ; END DO ; END DO ; END DO
166	ENDIF
167	!
168	IF( ln_timing ) CALL tic_tac(.TRUE.)
169	!
170	! non-blocking send of the western/eastern side using local temporary arrays
171	IF( llsend_we ) CALL mppsend( 1, zsnd_we(1,1-nn_hls+1,1,1,1), isize, nowe, ireq_we )
172	IF( llsend_ea ) CALL mppsend( 2, zsnd_ea(1,1-nn_hls+1,1,1,1), isize, noea, ireq_ea )
173	! blocking receive of the western/eastern halo in local temporary arrays
174	IF( llrecv_we ) CALL mpprecv( 2, zrcv_we(1,1-nn_hls+1,1,1,1), isize, nowe )
175	IF( llrecv_ea ) CALL mpprecv( 1, zrcv_ea(1,1-nn_hls+1,1,1,1), isize, noea )
176	!
177	IF( ln_timing ) CALL tic_tac(.FALSE.)
178	!
179	!
180	! ----------------------------------- !
181	! 2. Fill east and west halos !
182	! ----------------------------------- !
183	!
184	! 2.1 fill weastern halo
185	! ----------------------
186	! ishift = 0 ! fill halo from ji = 1 to nn_hls
187	SELECT CASE ( ifill_we )
188	CASE ( jpfillnothing ) ! no filling
189	CASE ( jpfillmpi ) ! use data received by MPI
190	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1-nn_hls+1, jpj ; DO ji = 1, nn_hls
191	ARRAY_IN(ji-nn_hls+1,jj,jk,jl,jf) = zrcv_we(ji,jj,jk,jl,jf) ! 1 -> nn_hls
192	END DO; END DO ; END DO ; END DO ; END DO
193	CASE ( jpfillperio ) ! use east-weast periodicity
194	ishift2 = jpi - 2 * nn_hls
195	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1-nn_hls+1, jpj ; DO ji = 1, nn_hls
196	ARRAY_IN(ji-nn_hls+1,jj,jk,jl,jf) = ARRAY_IN(ishift2+ji,jj,jk,jl,jf)
197	END DO; END DO ; END DO ; END DO ; END DO
198	CASE ( jpfillcopy ) ! filling with inner domain values
199	DO jf = 1, ipf ! number of arrays to be treated
200	IF( .NOT. NAT_IN(jf) == 'F' ) THEN ! do nothing for F point
201	DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1-nn_hls+1, jpj ; DO ji = 1, nn_hls
202	ARRAY_IN(ji-nn_hls+1,jj,jk,jl,jf) = ARRAY_IN(1+ji,jj,jk,jl,jf)
203	END DO ; END DO ; END DO ; END DO
204	ENDIF
205	END DO
206	CASE ( jpfillcst ) ! filling with constant value
207	DO jf = 1, ipf ! number of arrays to be treated
208	IF( .NOT. NAT_IN(jf) == 'F' ) THEN ! do nothing for F point
209	DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1-nn_hls+1, jpj ; DO ji = 1, nn_hls
210	ARRAY_IN(ji-nn_hls+1,jj,jk,jl,jf) = zland
211	END DO; END DO ; END DO ; END DO
212	ENDIF
213	END DO
214	END SELECT
215	!
216	! 2.2 fill eastern halo
217	! ---------------------
218	ishift = jpi - nn_hls ! fill halo from ji = jpi-nn_hls+1 to jpi
219	SELECT CASE ( ifill_ea )
220	CASE ( jpfillnothing ) ! no filling
221	CASE ( jpfillmpi ) ! use data received by MPI
222	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1-nn_hls+1, jpj ; DO ji = 1, nn_hls
223	ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zrcv_ea(ji,jj,jk,jl,jf) ! jpi - nn_hls + 1 -> jpi
224	END DO ; END DO ; END DO ; END DO ; END DO
225	CASE ( jpfillperio ) ! use east-weast periodicity
226	ishift2 = 1
227	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1-nn_hls+1, jpj ; DO ji = 1, nn_hls
228	ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ishift2+ji,jj,jk,jl,jf)
229	END DO ; END DO ; END DO ; END DO ; END DO
230	CASE ( jpfillcopy ) ! filling with inner domain values
231	ishift2 = jpi - 2*nn_hls
232	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1-nn_hls+1, jpj ; DO ji = 1, nn_hls
233	ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ishift2+ji,jj,jk,jl,jf)
234	END DO ; END DO ; END DO ; END DO ; END DO
235	CASE ( jpfillcst ) ! filling with constant value
236	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1-nn_hls+1, jpj ; DO ji = 1, nn_hls
237	ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zland
238	END DO; END DO ; END DO ; END DO ; END DO
239	END SELECT
240	!
241	! ------------------------------- !
242	! 3. north fold treatment !
243	! ------------------------------- !
244	!
245	! do it before south directions so concerned processes can do it without waiting for the comm with the sourthern neighbor
246	!
247	IF( lldo_nfd .AND. ifill_no /= jpfillnothing ) THEN
248	!
249	SELECT CASE ( jpni )
250	CASE ( 1 ) ; CALL lbc_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) ) ! only 1 northern proc, no mpp
251	CASE DEFAULT ; CALL mpp_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) ) ! for all northern procs.
252	END SELECT
253	!
254	ifill_no = jpfillnothing ! force to do nothing for the northern halo as we just done the north pole folding
255	!
256	ENDIF
257	!
258	! ---------------------------------------------------- !
259	! 4. Do north and south MPI exchange if needed !
260	! ---------------------------------------------------- !
261	!
262	IF( llsend_so ) ALLOCATE( zsnd_so(1-nn_hls+1:jpi,nn_hls,ipk,ipl,ipf) )
263	IF( llsend_no ) ALLOCATE( zsnd_no(1-nn_hls+1:jpi,nn_hls,ipk,ipl,ipf) )
264	IF( llrecv_so ) ALLOCATE( zrcv_so(1-nn_hls+1:jpi,nn_hls,ipk,ipl,ipf) )
265	IF( llrecv_no ) ALLOCATE( zrcv_no(1-nn_hls+1:jpi,nn_hls,ipk,ipl,ipf) )
266	!
267	isize = ( jpi + nn_hls - 1 ) * nn_hls * ipk * ipl * ipf
268
269	! allocate local temporary arrays to be sent/received. Fill arrays to be sent
270	IF( llsend_so ) THEN ! copy sourhern side of the inner mpi domain in local temporary array to be sent by MPI
271	ishift = 1
272	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1-nn_hls+1, jpi
273	zsnd_so(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift+jj,jk,jl,jf) ! nn_hls+1 -> 2*nn_hls
274	END DO ; END DO ; END DO ; END DO ; END DO
275	ENDIF
276	!
277	IF( llsend_no ) THEN ! copy eastern side of the inner mpi domain in local temporary array to be sent by MPI
278	ishift = jpj - 2 * nn_hls
279	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1-nn_hls+1, jpi
280	zsnd_no(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift+jj,jk,jl,jf) ! jpj-2*nn_hls+1 -> jpj-nn_hls
281	END DO ; END DO ; END DO ; END DO ; END DO
282	ENDIF
283	!
284	IF( ln_timing ) CALL tic_tac(.TRUE.)
285	!
286	! non-blocking send of the southern/northern side
287	IF( llsend_so ) CALL mppsend( 3, zsnd_so(1-nn_hls+1,1,1,1,1), isize, noso, ireq_so )
288	IF( llsend_no ) CALL mppsend( 4, zsnd_no(1-nn_hls+1,1,1,1,1), isize, nono, ireq_no )
289	! blocking receive of the southern/northern halo
290	IF( llrecv_so ) CALL mpprecv( 4, zrcv_so(1-nn_hls+1,1,1,1,1), isize, noso )
291	IF( llrecv_no ) CALL mpprecv( 3, zrcv_no(1-nn_hls+1,1,1,1,1), isize, nono )
292	!
293	IF( ln_timing ) CALL tic_tac(.FALSE.)
294	!
295	! ------------------------------------- !
296	! 5. Fill south and north halos !
297	! ------------------------------------- !
298	!
299	! 5.1 fill southern halo
300	! ----------------------
301	! ishift = 0 ! fill halo from jj = 1 to nn_hls
302	SELECT CASE ( ifill_so )
303	CASE ( jpfillnothing ) ! no filling
304	CASE ( jpfillmpi ) ! use data received by MPI
305	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1-nn_hls+1, jpi
306	ARRAY_IN(ji,jj-nn_hls+1,jk,jl,jf) = zrcv_so(ji,jj,jk,jl,jf) ! 1 -> nn_hls
307	END DO; END DO ; END DO ; END DO ; END DO
308	CASE ( jpfillperio ) ! use north-south periodicity
309	ishift2 = jpj - 2 * nn_hls
310	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1-nn_hls+1, jpi
311	ARRAY_IN(ji,jj-nn_hls+1,jk,jl,jf) = ARRAY_IN(ji,ishift2+jj,jk,jl,jf)
312	END DO; END DO ; END DO ; END DO ; END DO
313	CASE ( jpfillcopy ) ! filling with inner domain values
314	DO jf = 1, ipf ! number of arrays to be treated
315	IF( .NOT. NAT_IN(jf) == 'F' ) THEN ! do nothing for F point
316	DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1-nn_hls+1, jpi
317	ARRAY_IN(ji,jj-nn_hls+1,jk,jl,jf) = ARRAY_IN(ji,1+jj,jk,jl,jf)
318	END DO ; END DO ; END DO ; END DO
319	ENDIF
320	END DO
321	CASE ( jpfillcst ) ! filling with constant value
322	DO jf = 1, ipf ! number of arrays to be treated
323	IF( .NOT. NAT_IN(jf) == 'F' ) THEN ! do nothing for F point
324	DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1-nn_hls+1, jpi
325	ARRAY_IN(ji,jj-nn_hls+1,jk,jl,jf) = zland
326	END DO; END DO ; END DO ; END DO
327	ENDIF
328	END DO
329	END SELECT
330	!
331	! 5.2 fill northern halo
332	! ----------------------
333	ishift = jpj - nn_hls ! fill halo from jj = jpj-nn_hls+1 to jpj
334	SELECT CASE ( ifill_no )
335	CASE ( jpfillnothing ) ! no filling
336	CASE ( jpfillmpi ) ! use data received by MPI
337	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1-nn_hls+1, jpi
338	ARRAY_IN(ji,ishift+jj,jk,jl,jf) = zrcv_no(ji,jj,jk,jl,jf) ! jpj-nn_hls+1 -> jpj
339	END DO ; END DO ; END DO ; END DO ; END DO
340	CASE ( jpfillperio ) ! use north-south periodicity
341	ishift2 = 1
342	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1-nn_hls+1, jpi
343	ARRAY_IN(ji,ishift+jj,jk,jl,jf) = ARRAY_IN(ji,ishift2+jj,jk,jl,jf)
344	END DO; END DO ; END DO ; END DO ; END DO
345	CASE ( jpfillcopy ) ! filling with inner domain values
346	ishift2 = jpj - 2*nn_hls
347	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1-nn_hls+1, jpi
348	ARRAY_IN(ji,ishift+jj,jk,jl,jf) = ARRAY_IN(ji,ishift2+jj,jk,jl,jf)
349	END DO; END DO ; END DO ; END DO ; END DO
350	CASE ( jpfillcst ) ! filling with constant value
351	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1-nn_hls+1, jpi
352	ARRAY_IN(ji,ishift+jj,jk,jl,jf) = zland
353	END DO; END DO ; END DO ; END DO ; END DO
354	END SELECT
355	!
356	! -------------------------------------------- !
357	! 6. deallocate local temporary arrays !
358	! -------------------------------------------- !
359	!
360	IF( llsend_we ) THEN
361	CALL mpi_wait(ireq_we, istat, ierr )
362	DEALLOCATE( zsnd_we )
363	ENDIF
364	IF( llsend_ea ) THEN
365	CALL mpi_wait(ireq_ea, istat, ierr )
366	DEALLOCATE( zsnd_ea )
367	ENDIF
368	IF( llsend_so ) THEN
369	CALL mpi_wait(ireq_so, istat, ierr )
370	DEALLOCATE( zsnd_so )
371	ENDIF
372	IF( llsend_no ) THEN
373	CALL mpi_wait(ireq_no, istat, ierr )
374	DEALLOCATE( zsnd_no )
375	ENDIF
376	!
377	IF( llrecv_we ) DEALLOCATE( zrcv_we )
378	IF( llrecv_ea ) DEALLOCATE( zrcv_ea )
379	IF( llrecv_so ) DEALLOCATE( zrcv_so )
380	IF( llrecv_no ) DEALLOCATE( zrcv_no )
381	!
382	END SUBROUTINE ROUTINE_LNK
383
384	#undef ARRAY_TYPE
385	#undef NAT_IN
386	#undef SGN_IN
387	#undef ARRAY_IN
388	#undef K_SIZE
389	#undef L_SIZE
390	#undef F_SIZE
391	#undef OPT_K

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

Download in other formats: