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

Context Navigation

source: NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/OCE/LBC/mpp_lnk_generic.h90 @ 13887

Last change on this file since 13887 was 10329, checked in by smasson, 5 years ago
dev_r10164_HPC09_ESIWACE_PREP_MERGE: action 3c: slight cleanning/optimisation of lbc_lnk, see #2133
Property svn:keywords set to `Id` Property svn:mime-type set to `text/x-fortran`
File size: 13.3 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, cd_mpp, pval )
49	INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays
50	#else
51	SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn , cd_mpp, pval )
52	#endif
53	ARRAY_TYPE(:,:,:,:,:) ! 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	CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only
58	REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries)
59	!
60	INTEGER :: ji, jj, jk, jl, jh, jf ! dummy loop indices
61	INTEGER :: ipi, ipj, ipk, ipl, ipf ! dimension of the input array
62	INTEGER :: imigr, iihom, ijhom ! local integers
63	INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
64	INTEGER :: ierr
65	REAL(wp) :: zland
66	INTEGER , DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend
67	REAL(wp), DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: zt3ns, zt3sn ! north-south & south-north halos
68	REAL(wp), DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: zt3ew, zt3we ! east -west & west - east halos
69	!!----------------------------------------------------------------------
70	!
71	ipk = K_SIZE(ptab) ! 3rd dimension
72	ipl = L_SIZE(ptab) ! 4th -
73	ipf = F_SIZE(ptab) ! 5th - use in "multi" case (array of pointers)
74	!
75	IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ipk, ipl, ipf, ld_lbc = .TRUE. )
76	!
77	IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value
78	ELSE ; zland = 0._wp ! zero by default
79	ENDIF
80
81	! ------------------------------- !
82	! standard boundary treatment ! ! CAUTION: semi-column notation is often impossible
83	! ------------------------------- !
84	!
85	IF( .NOT. PRESENT( cd_mpp ) ) THEN !== standard close or cyclic treatment ==!
86	!
87	DO jf = 1, ipf ! number of arrays to be treated
88	!
89	! ! East-West boundaries
90	IF( l_Iperio ) THEN !* cyclic
91	ARRAY_IN( 1 ,:,:,:,jf) = ARRAY_IN(jpim1,:,:,:,jf)
92	ARRAY_IN(jpi,:,:,:,jf) = ARRAY_IN( 2 ,:,:,:,jf)
93	ELSE !* closed
94	IF( .NOT. NAT_IN(jf) == 'F' ) ARRAY_IN( 1 :nn_hls,:,:,:,jf) = zland ! east except F-point
95	ARRAY_IN(nlci-nn_hls+1:jpi ,:,:,:,jf) = zland ! west
96	ENDIF
97	! ! North-South boundaries
98	IF( l_Jperio ) THEN !* cyclic (only with no mpp j-split)
99	ARRAY_IN(:, 1 ,:,:,jf) = ARRAY_IN(:, jpjm1,:,:,jf)
100	ARRAY_IN(:,jpj,:,:,jf) = ARRAY_IN(:, 2 ,:,:,jf)
101	ELSE !* closed
102	IF( .NOT. NAT_IN(jf) == 'F' ) ARRAY_IN(:, 1 :nn_hls,:,:,jf) = zland ! south except F-point
103	ARRAY_IN(:,nlcj-nn_hls+1:jpj ,:,:,jf) = zland ! north
104	ENDIF
105	END DO
106	!
107	ENDIF
108
109	! ------------------------------- !
110	! East and west exchange !
111	! ------------------------------- !
112	! we play with the neigbours AND the row number because of the periodicity
113	!
114	IF( ABS(nbondi) == 1 ) ALLOCATE( zt3ew(jpj,nn_hls,ipk,ipl,ipf,1), zt3we(jpj,nn_hls,ipk,ipl,ipf,1) )
115	IF( nbondi == 0 ) ALLOCATE( zt3ew(jpj,nn_hls,ipk,ipl,ipf,2), zt3we(jpj,nn_hls,ipk,ipl,ipf,2) )
116	!
117	SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions
118	CASE ( -1 )
119	iihom = nlci-nreci
120	DO jf = 1, ipf
121	DO jl = 1, ipl
122	DO jk = 1, ipk
123	DO jh = 1, nn_hls
124	zt3we(:,jh,jk,jl,jf,1) = ARRAY_IN(iihom +jh,:,jk,jl,jf)
125	END DO
126	END DO
127	END DO
128	END DO
129	CASE ( 0 )
130	iihom = nlci-nreci
131	DO jf = 1, ipf
132	DO jl = 1, ipl
133	DO jk = 1, ipk
134	DO jh = 1, nn_hls
135	zt3ew(:,jh,jk,jl,jf,1) = ARRAY_IN(nn_hls+jh,:,jk,jl,jf)
136	zt3we(:,jh,jk,jl,jf,1) = ARRAY_IN(iihom +jh,:,jk,jl,jf)
137	END DO
138	END DO
139	END DO
140	END DO
141	CASE ( 1 )
142	iihom = nlci-nreci
143	DO jf = 1, ipf
144	DO jl = 1, ipl
145	DO jk = 1, ipk
146	DO jh = 1, nn_hls
147	zt3ew(:,jh,jk,jl,jf,1) = ARRAY_IN(nn_hls+jh,:,jk,jl,jf)
148	END DO
149	END DO
150	END DO
151	END DO
152	END SELECT
153	! ! Migrations
154	imigr = nn_hls * jpj * ipk * ipl * ipf
155	!
156	IF( ln_timing ) CALL tic_tac(.TRUE.)
157	!
158	SELECT CASE ( nbondi )
159	CASE ( -1 )
160	CALL mppsend( 2, zt3we(1,1,1,1,1,1), imigr, noea, ml_req1 )
161	CALL mpprecv( 1, zt3ew(1,1,1,1,1,1), imigr, noea )
162	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
163	CASE ( 0 )
164	CALL mppsend( 1, zt3ew(1,1,1,1,1,1), imigr, nowe, ml_req1 )
165	CALL mppsend( 2, zt3we(1,1,1,1,1,1), imigr, noea, ml_req2 )
166	CALL mpprecv( 1, zt3ew(1,1,1,1,1,2), imigr, noea )
167	CALL mpprecv( 2, zt3we(1,1,1,1,1,2), imigr, nowe )
168	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
169	IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
170	CASE ( 1 )
171	CALL mppsend( 1, zt3ew(1,1,1,1,1,1), imigr, nowe, ml_req1 )
172	CALL mpprecv( 2, zt3we(1,1,1,1,1,1), imigr, nowe )
173	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err )
174	END SELECT
175	!
176	IF( ln_timing ) CALL tic_tac(.FALSE.)
177	!
178	! ! Write Dirichlet lateral conditions
179	iihom = nlci-nn_hls
180	!
181	SELECT CASE ( nbondi )
182	CASE ( -1 )
183	DO jf = 1, ipf
184	DO jl = 1, ipl
185	DO jk = 1, ipk
186	DO jh = 1, nn_hls
187	ARRAY_IN(iihom+jh,:,jk,jl,jf) = zt3ew(:,jh,jk,jl,jf,1)
188	END DO
189	END DO
190	END DO
191	END DO
192	CASE ( 0 )
193	DO jf = 1, ipf
194	DO jl = 1, ipl
195	DO jk = 1, ipk
196	DO jh = 1, nn_hls
197	ARRAY_IN(jh ,:,jk,jl,jf) = zt3we(:,jh,jk,jl,jf,2)
198	ARRAY_IN(iihom+jh,:,jk,jl,jf) = zt3ew(:,jh,jk,jl,jf,2)
199	END DO
200	END DO
201	END DO
202	END DO
203	CASE ( 1 )
204	DO jf = 1, ipf
205	DO jl = 1, ipl
206	DO jk = 1, ipk
207	DO jh = 1, nn_hls
208	ARRAY_IN(jh ,:,jk,jl,jf) = zt3we(:,jh,jk,jl,jf,1)
209	END DO
210	END DO
211	END DO
212	END DO
213	END SELECT
214	!
215	IF( nbondi /= 2 ) DEALLOCATE( zt3ew, zt3we )
216
217	! 3. North and south directions
218	! -----------------------------
219	! always closed : we play only with the neigbours
220	!
221	IF( ABS(nbondj) == 1 ) ALLOCATE( zt3ns(jpi,nn_hls,ipk,ipl,ipf,1), zt3sn(jpi,nn_hls,ipk,ipl,ipf,1) )
222	IF( nbondj == 0 ) ALLOCATE( zt3ns(jpi,nn_hls,ipk,ipl,ipf,2), zt3sn(jpi,nn_hls,ipk,ipl,ipf,2) )
223	!
224	SELECT CASE ( nbondj )
225	CASE ( -1 )
226	ijhom = nlcj-nrecj
227	DO jf = 1, ipf
228	DO jl = 1, ipl
229	DO jk = 1, ipk
230	DO jh = 1, nn_hls
231	zt3sn(:,jh,jk,jl,jf,1) = ARRAY_IN(:,ijhom +jh,jk,jl,jf)
232	END DO
233	END DO
234	END DO
235	END DO
236	CASE ( 0 )
237	ijhom = nlcj-nrecj
238	DO jf = 1, ipf
239	DO jl = 1, ipl
240	DO jk = 1, ipk
241	DO jh = 1, nn_hls
242	zt3sn(:,jh,jk,jl,jf,1) = ARRAY_IN(:,ijhom +jh,jk,jl,jf)
243	zt3ns(:,jh,jk,jl,jf,1) = ARRAY_IN(:,nn_hls+jh,jk,jl,jf)
244	END DO
245	END DO
246	END DO
247	END DO
248	CASE ( 1 )
249	ijhom = nlcj-nrecj
250	DO jf = 1, ipf
251	DO jl = 1, ipl
252	DO jk = 1, ipk
253	DO jh = 1, nn_hls
254	zt3ns(:,jh,jk,jl,jf,1) = ARRAY_IN(:,nn_hls+jh,jk,jl,jf)
255	END DO
256	END DO
257	END DO
258	END DO
259	END SELECT
260	!
261	! ! Migrations
262	imigr = nn_hls * jpi * ipk * ipl * ipf
263	!
264	IF( ln_timing ) CALL tic_tac(.TRUE.)
265	!
266	SELECT CASE ( nbondj )
267	CASE ( -1 )
268	CALL mppsend( 4, zt3sn(1,1,1,1,1,1), imigr, nono, ml_req1 )
269	CALL mpprecv( 3, zt3ns(1,1,1,1,1,1), imigr, nono )
270	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err )
271	CASE ( 0 )
272	CALL mppsend( 3, zt3ns(1,1,1,1,1,1), imigr, noso, ml_req1 )
273	CALL mppsend( 4, zt3sn(1,1,1,1,1,1), imigr, nono, ml_req2 )
274	CALL mpprecv( 3, zt3ns(1,1,1,1,1,2), imigr, nono )
275	CALL mpprecv( 4, zt3sn(1,1,1,1,1,2), imigr, noso )
276	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err )
277	IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err )
278	CASE ( 1 )
279	CALL mppsend( 3, zt3ns(1,1,1,1,1,1), imigr, noso, ml_req1 )
280	CALL mpprecv( 4, zt3sn(1,1,1,1,1,1), imigr, noso )
281	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err )
282	END SELECT
283	!
284	IF( ln_timing ) CALL tic_tac(.FALSE.)
285	! ! Write Dirichlet lateral conditions
286	ijhom = nlcj-nn_hls
287	!
288	SELECT CASE ( nbondj )
289	CASE ( -1 )
290	DO jf = 1, ipf
291	DO jl = 1, ipl
292	DO jk = 1, ipk
293	DO jh = 1, nn_hls
294	ARRAY_IN(:,ijhom+jh,jk,jl,jf) = zt3ns(:,jh,jk,jl,jf,1)
295	END DO
296	END DO
297	END DO
298	END DO
299	CASE ( 0 )
300	DO jf = 1, ipf
301	DO jl = 1, ipl
302	DO jk = 1, ipk
303	DO jh = 1, nn_hls
304	ARRAY_IN(:, jh,jk,jl,jf) = zt3sn(:,jh,jk,jl,jf,2)
305	ARRAY_IN(:,ijhom+jh,jk,jl,jf) = zt3ns(:,jh,jk,jl,jf,2)
306	END DO
307	END DO
308	END DO
309	END DO
310	CASE ( 1 )
311	DO jf = 1, ipf
312	DO jl = 1, ipl
313	DO jk = 1, ipk
314	DO jh = 1, nn_hls
315	ARRAY_IN(:,jh,jk,jl,jf) = zt3sn(:,jh,jk,jl,jf,1)
316	END DO
317	END DO
318	END DO
319	END DO
320	END SELECT
321	!
322	IF( nbondj /= 2 ) DEALLOCATE( zt3ns, zt3sn )
323
324	! 4. north fold treatment
325	! -----------------------
326	!
327	IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN
328	!
329	SELECT CASE ( jpni )
330	CASE ( 1 ) ; CALL lbc_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) ) ! only 1 northern proc, no mpp
331	CASE DEFAULT ; CALL mpp_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) ) ! for all northern procs.
332	END SELECT
333	!
334	ENDIF
335	!
336	END SUBROUTINE ROUTINE_LNK
337
338	#undef ARRAY_TYPE
339	#undef NAT_IN
340	#undef SGN_IN
341	#undef ARRAY_IN
342	#undef K_SIZE
343	#undef L_SIZE
344	#undef F_SIZE
345	#undef OPT_K

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

Download in other formats: