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_r10984_HPC-13_IRRMANN_DYN_optimization/src/OCE/LBC – NEMO

Context Navigation

source: NEMO/branches/2019/dev_r10984_HPC-13_IRRMANN_DYN_optimization/src/OCE/LBC/mpp_lnk_generic.h90 @ 11609

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

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

Download in other formats: