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_r11351_fldread_with_XIOS/src/OCE/LBC – NEMO

Context Navigation

source: NEMO/branches/2019/dev_r11351_fldread_with_XIOS/src/OCE/LBC/mpp_lnk_generic.h90 @ 13463

Last change on this file since 13463 was 13463, checked in by andmirek, 4 years ago
Ticket #2195:update to trunk 13461
Property svn:keywords set to `Id` Property svn:mime-type set to `text/x-fortran`
File size: 20.7 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 )
75	INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays
76	#else
77	SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn , kfillmode, pfillval, lsend, lrecv )
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	!
87	INTEGER :: ji, jj, jk, jl, jf ! dummy loop indices
88	INTEGER :: ipi, ipj, ipk, ipl, ipf ! dimension of the input array
89	INTEGER :: isize, ishift, ishift2 ! local integers
90	INTEGER :: ireq_we, ireq_ea, ireq_so, ireq_no ! mpi_request id
91	INTEGER :: ierr
92	INTEGER :: ifill_we, ifill_ea, ifill_so, ifill_no
93	REAL(wp) :: zland
94	INTEGER , DIMENSION(MPI_STATUS_SIZE) :: istat ! for mpi_isend
95	REAL(PRECISION), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zsnd_we, zrcv_we, zsnd_ea, zrcv_ea ! east -west & west - east halos
96	REAL(PRECISION), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zsnd_so, zrcv_so, zsnd_no, zrcv_no ! north-south & south-north halos
97	LOGICAL :: llsend_we, llsend_ea, llsend_no, llsend_so ! communication send
98	LOGICAL :: llrecv_we, llrecv_ea, llrecv_no, llrecv_so ! communication receive
99	LOGICAL :: lldo_nfd ! do north pole folding
100	!!----------------------------------------------------------------------
101	!
102	! ----------------------------------------- !
103	! 0. local variables initialization !
104	! ----------------------------------------- !
105	!
106	ipk = K_SIZE(ptab) ! 3rd dimension
107	ipl = L_SIZE(ptab) ! 4th -
108	ipf = F_SIZE(ptab) ! 5th - use in "multi" case (array of pointers)
109	!
110	IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ipk, ipl, ipf, ld_lbc = .TRUE. )
111	!
112	IF ( PRESENT(lsend) .AND. PRESENT(lrecv) ) THEN
113	llsend_we = lsend(1) ; llsend_ea = lsend(2) ; llsend_so = lsend(3) ; llsend_no = lsend(4)
114	llrecv_we = lrecv(1) ; llrecv_ea = lrecv(2) ; llrecv_so = lrecv(3) ; llrecv_no = lrecv(4)
115	ELSE IF( PRESENT(lsend) .OR. PRESENT(lrecv) ) THEN
116	WRITE(ctmp1,*) ' E R R O R : Routine ', cdname, ' is calling lbc_lnk with only one of the two arguments lsend or lrecv'
117	WRITE(ctmp2,*) ' ========== '
118	CALL ctl_stop( ' ', ctmp1, ctmp2, ' ' )
119	ELSE ! send and receive with every neighbour
120	llsend_we = nbondi == 1 .OR. nbondi == 0 ! keep for compatibility, should be defined in mppini
121	llsend_ea = nbondi == -1 .OR. nbondi == 0 ! keep for compatibility, should be defined in mppini
122	llsend_so = nbondj == 1 .OR. nbondj == 0 ! keep for compatibility, should be defined in mppini
123	llsend_no = nbondj == -1 .OR. nbondj == 0 ! keep for compatibility, should be defined in mppini
124	llrecv_we = llsend_we ; llrecv_ea = llsend_ea ; llrecv_so = llsend_so ; llrecv_no = llsend_no
125	END IF
126
127
128	lldo_nfd = npolj /= 0 ! keep for compatibility, should be defined in mppini
129
130	zland = 0._wp ! land filling value: zero by default
131	IF( PRESENT( pfillval ) ) zland = pfillval ! set land value
132
133	! define the method we will use to fill the halos in each direction
134	IF( llrecv_we ) THEN ; ifill_we = jpfillmpi
135	ELSEIF( l_Iperio ) THEN ; ifill_we = jpfillperio
136	ELSEIF( PRESENT(kfillmode) ) THEN ; ifill_we = kfillmode
137	ELSE ; ifill_we = jpfillcst
138	END IF
139	!
140	IF( llrecv_ea ) THEN ; ifill_ea = jpfillmpi
141	ELSEIF( l_Iperio ) THEN ; ifill_ea = jpfillperio
142	ELSEIF( PRESENT(kfillmode) ) THEN ; ifill_ea = kfillmode
143	ELSE ; ifill_ea = jpfillcst
144	END IF
145	!
146	IF( llrecv_so ) THEN ; ifill_so = jpfillmpi
147	ELSEIF( l_Jperio ) THEN ; ifill_so = jpfillperio
148	ELSEIF( PRESENT(kfillmode) ) THEN ; ifill_so = kfillmode
149	ELSE ; ifill_so = jpfillcst
150	END IF
151	!
152	IF( llrecv_no ) THEN ; ifill_no = jpfillmpi
153	ELSEIF( l_Jperio ) THEN ; ifill_no = jpfillperio
154	ELSEIF( PRESENT(kfillmode) ) THEN ; ifill_no = kfillmode
155	ELSE ; ifill_no = jpfillcst
156	END IF
157	!
158	#if defined PRINT_CAUTION
159	!
160	! ================================================================================== !
161	! CAUTION: semi-column notation is often impossible because of the cpp preprocessing !
162	! ================================================================================== !
163	!
164	#endif
165	!
166	! -------------------------------------------------- !
167	! 1. Do east and west MPI exchange if needed !
168	! -------------------------------------------------- !
169	!
170	! Must exchange the whole column (from 1 to jpj) to get the corners if we have no south/north neighbourg
171	isize = nn_hls * jpj * ipk * ipl * ipf
172	!
173	! Allocate local temporary arrays to be sent/received. Fill arrays to be sent
174	IF( llsend_we ) ALLOCATE( zsnd_we(nn_hls,jpj,ipk,ipl,ipf) )
175	IF( llsend_ea ) ALLOCATE( zsnd_ea(nn_hls,jpj,ipk,ipl,ipf) )
176	IF( llrecv_we ) ALLOCATE( zrcv_we(nn_hls,jpj,ipk,ipl,ipf) )
177	IF( llrecv_ea ) ALLOCATE( zrcv_ea(nn_hls,jpj,ipk,ipl,ipf) )
178	!
179	IF( llsend_we ) THEN ! copy western side of the inner mpi domain in local temporary array to be sent by MPI
180	ishift = nn_hls
181	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls
182	zsnd_we(ji,jj,jk,jl,jf) = ARRAY_IN(ishift+ji,jj,jk,jl,jf) ! nn_hls + 1 -> 2*nn_hls
183	END DO ; END DO ; END DO ; END DO ; END DO
184	ENDIF
185	!
186	IF(llsend_ea ) THEN ! copy eastern side of the inner mpi domain in local temporary array to be sent by MPI
187	ishift = jpi - 2 * nn_hls
188	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls
189	zsnd_ea(ji,jj,jk,jl,jf) = ARRAY_IN(ishift+ji,jj,jk,jl,jf) ! jpi - 2*nn_hls + 1 -> jpi - nn_hls
190	END DO ; END DO ; END DO ; END DO ; END DO
191	ENDIF
192	!
193	IF( ln_timing ) CALL tic_tac(.TRUE.)
194	!
195	! non-blocking send of the western/eastern side using local temporary arrays
196	IF( llsend_we ) CALL SENDROUTINE( 1, zsnd_we(1,1,1,1,1), isize, nowe, ireq_we )
197	IF( llsend_ea ) CALL SENDROUTINE( 2, zsnd_ea(1,1,1,1,1), isize, noea, ireq_ea )
198	! blocking receive of the western/eastern halo in local temporary arrays
199	IF( llrecv_we ) CALL RECVROUTINE( 2, zrcv_we(1,1,1,1,1), isize, nowe )
200	IF( llrecv_ea ) CALL RECVROUTINE( 1, zrcv_ea(1,1,1,1,1), isize, noea )
201	!
202	IF( ln_timing ) CALL tic_tac(.FALSE.)
203	!
204	!
205	! ----------------------------------- !
206	! 2. Fill east and west halos !
207	! ----------------------------------- !
208	!
209	! 2.1 fill weastern halo
210	! ----------------------
211	! ishift = 0 ! fill halo from ji = 1 to nn_hls
212	SELECT CASE ( ifill_we )
213	CASE ( jpfillnothing ) ! no filling
214	CASE ( jpfillmpi ) ! use data received by MPI
215	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls
216	ARRAY_IN(ji,jj,jk,jl,jf) = zrcv_we(ji,jj,jk,jl,jf) ! 1 -> nn_hls
217	END DO ; END DO ; END DO ; END DO ; END DO
218	CASE ( jpfillperio ) ! use east-weast periodicity
219	ishift2 = jpi - 2 * nn_hls
220	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls
221	ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ishift2+ji,jj,jk,jl,jf)
222	END DO ; END DO ; END DO ; END DO ; END DO
223	CASE ( jpfillcopy ) ! filling with inner domain values
224	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls
225	ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(nn_hls+1,jj,jk,jl,jf)
226	END DO ; END DO ; END DO ; END DO ; END DO
227	CASE ( jpfillcst ) ! filling with constant value
228	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls
229	ARRAY_IN(ji,jj,jk,jl,jf) = zland
230	END DO ; END DO ; END DO ; END DO ; END DO
231	END SELECT
232	!
233	! 2.2 fill eastern halo
234	! ---------------------
235	ishift = jpi - nn_hls ! fill halo from ji = jpi-nn_hls+1 to jpi
236	SELECT CASE ( ifill_ea )
237	CASE ( jpfillnothing ) ! no filling
238	CASE ( jpfillmpi ) ! use data received by MPI
239	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls
240	ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zrcv_ea(ji,jj,jk,jl,jf) ! jpi - nn_hls + 1 -> jpi
241	END DO ; END DO ; END DO ; END DO ; END DO
242	CASE ( jpfillperio ) ! use east-weast periodicity
243	ishift2 = nn_hls
244	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls
245	ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ishift2+ji,jj,jk,jl,jf)
246	END DO ; END DO ; END DO ; END DO ; END DO
247	CASE ( jpfillcopy ) ! filling with inner domain values
248	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls
249	ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ishift,jj,jk,jl,jf)
250	END DO ; END DO ; END DO ; END DO ; END DO
251	CASE ( jpfillcst ) ! filling with constant value
252	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, nn_hls
253	ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zland
254	END DO ; END DO ; END DO ; END DO ; END DO
255	END SELECT
256	!
257	! ------------------------------- !
258	! 3. north fold treatment !
259	! ------------------------------- !
260	!
261	! do it before south directions so concerned processes can do it without waiting for the comm with the sourthern neighbor
262	!
263	IF( lldo_nfd .AND. ifill_no /= jpfillnothing ) THEN
264	!
265	SELECT CASE ( jpni )
266	CASE ( 1 ) ; CALL lbc_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) ) ! only 1 northern proc, no mpp
267	CASE DEFAULT ; CALL mpp_nfd( ptab, NAT_IN(:), SGN_IN(:), ifill_no, zland OPT_K(:) ) ! for all northern procs.
268	END SELECT
269	!
270	ifill_no = jpfillnothing ! force to do nothing for the northern halo as we just done the north pole folding
271	!
272	ENDIF
273	!
274	! ---------------------------------------------------- !
275	! 4. Do north and south MPI exchange if needed !
276	! ---------------------------------------------------- !
277	!
278	IF( llsend_so ) ALLOCATE( zsnd_so(jpi,nn_hls,ipk,ipl,ipf) )
279	IF( llsend_no ) ALLOCATE( zsnd_no(jpi,nn_hls,ipk,ipl,ipf) )
280	IF( llrecv_so ) ALLOCATE( zrcv_so(jpi,nn_hls,ipk,ipl,ipf) )
281	IF( llrecv_no ) ALLOCATE( zrcv_no(jpi,nn_hls,ipk,ipl,ipf) )
282	!
283	isize = jpi * nn_hls * ipk * ipl * ipf
284
285	! allocate local temporary arrays to be sent/received. Fill arrays to be sent
286	IF( llsend_so ) THEN ! copy sourhern side of the inner mpi domain in local temporary array to be sent by MPI
287	ishift = nn_hls
288	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi
289	zsnd_so(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift+jj,jk,jl,jf) ! nn_hls+1 -> 2*nn_hls
290	END DO ; END DO ; END DO ; END DO ; END DO
291	ENDIF
292	!
293	IF( llsend_no ) THEN ! copy eastern side of the inner mpi domain in local temporary array to be sent by MPI
294	ishift = jpj - 2 * nn_hls
295	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi
296	zsnd_no(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift+jj,jk,jl,jf) ! jpj-2*nn_hls+1 -> jpj-nn_hls
297	END DO ; END DO ; END DO ; END DO ; END DO
298	ENDIF
299	!
300	IF( ln_timing ) CALL tic_tac(.TRUE.)
301	!
302	! non-blocking send of the southern/northern side
303	IF( llsend_so ) CALL SENDROUTINE( 3, zsnd_so(1,1,1,1,1), isize, noso, ireq_so )
304	IF( llsend_no ) CALL SENDROUTINE( 4, zsnd_no(1,1,1,1,1), isize, nono, ireq_no )
305	! blocking receive of the southern/northern halo
306	IF( llrecv_so ) CALL RECVROUTINE( 4, zrcv_so(1,1,1,1,1), isize, noso )
307	IF( llrecv_no ) CALL RECVROUTINE( 3, zrcv_no(1,1,1,1,1), isize, nono )
308	!
309	IF( ln_timing ) CALL tic_tac(.FALSE.)
310	!
311	! ------------------------------------- !
312	! 5. Fill south and north halos !
313	! ------------------------------------- !
314	!
315	! 5.1 fill southern halo
316	! ----------------------
317	! ishift = 0 ! fill halo from jj = 1 to nn_hls
318	SELECT CASE ( ifill_so )
319	CASE ( jpfillnothing ) ! no filling
320	CASE ( jpfillmpi ) ! use data received by MPI
321	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi
322	ARRAY_IN(ji,jj,jk,jl,jf) = zrcv_so(ji,jj,jk,jl,jf) ! 1 -> nn_hls
323	END DO ; END DO ; END DO ; END DO ; END DO
324	CASE ( jpfillperio ) ! use north-south periodicity
325	ishift2 = jpj - 2 * nn_hls
326	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi
327	ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift2+jj,jk,jl,jf)
328	END DO ; END DO ; END DO ; END DO ; END DO
329	CASE ( jpfillcopy ) ! filling with inner domain values
330	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi
331	ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ji,nn_hls+1,jk,jl,jf)
332	END DO ; END DO ; END DO ; END DO ; END DO
333	CASE ( jpfillcst ) ! filling with constant value
334	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi
335	ARRAY_IN(ji,jj,jk,jl,jf) = zland
336	END DO ; END DO ; END DO ; END DO ; END DO
337	END SELECT
338	!
339	! 5.2 fill northern halo
340	! ----------------------
341	ishift = jpj - nn_hls ! fill halo from jj = jpj-nn_hls+1 to jpj
342	SELECT CASE ( ifill_no )
343	CASE ( jpfillnothing ) ! no filling
344	CASE ( jpfillmpi ) ! use data received by MPI
345	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi
346	ARRAY_IN(ji,ishift+jj,jk,jl,jf) = zrcv_no(ji,jj,jk,jl,jf) ! jpj-nn_hls+1 -> jpj
347	END DO ; END DO ; END DO ; END DO ; END DO
348	CASE ( jpfillperio ) ! use north-south periodicity
349	ishift2 = nn_hls
350	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi
351	ARRAY_IN(ji,ishift+jj,jk,jl,jf) = ARRAY_IN(ji,ishift2+jj,jk,jl,jf)
352	END DO ; END DO ; END DO ; END DO ; END DO
353	CASE ( jpfillcopy ) ! filling with inner domain values
354	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi
355	ARRAY_IN(ji,ishift+jj,jk,jl,jf) = ARRAY_IN(ji,ishift,jk,jl,jf)
356	END DO ; END DO ; END DO ; END DO ; END DO
357	CASE ( jpfillcst ) ! filling with constant value
358	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, nn_hls ; DO ji = 1, jpi
359	ARRAY_IN(ji,ishift+jj,jk,jl,jf) = zland
360	END DO ; END DO ; END DO ; END DO ; END DO
361	END SELECT
362	!
363	! -------------------------------------------- !
364	! 6. deallocate local temporary arrays !
365	! -------------------------------------------- !
366	!
367	IF( llsend_we ) THEN
368	CALL mpi_wait(ireq_we, istat, ierr )
369	DEALLOCATE( zsnd_we )
370	ENDIF
371	IF( llsend_ea ) THEN
372	CALL mpi_wait(ireq_ea, istat, ierr )
373	DEALLOCATE( zsnd_ea )
374	ENDIF
375	IF( llsend_so ) THEN
376	CALL mpi_wait(ireq_so, istat, ierr )
377	DEALLOCATE( zsnd_so )
378	ENDIF
379	IF( llsend_no ) THEN
380	CALL mpi_wait(ireq_no, istat, ierr )
381	DEALLOCATE( zsnd_no )
382	ENDIF
383	!
384	IF( llrecv_we ) DEALLOCATE( zrcv_we )
385	IF( llrecv_ea ) DEALLOCATE( zrcv_ea )
386	IF( llrecv_so ) DEALLOCATE( zrcv_so )
387	IF( llrecv_no ) DEALLOCATE( zrcv_no )
388	!
389	END SUBROUTINE ROUTINE_LNK
390	#undef PRECISION
391	#undef SENDROUTINE
392	#undef RECVROUTINE
393	#undef ARRAY_TYPE
394	#undef NAT_IN
395	#undef SGN_IN
396	#undef ARRAY_IN
397	#undef K_SIZE
398	#undef L_SIZE
399	#undef F_SIZE
400	#undef OPT_K

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

Download in other formats: