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 utils/tools_dev_r12970_AGRIF_CMEMS/DOMAINcfg/src – NEMO

Context Navigation

source: utils/tools_dev_r12970_AGRIF_CMEMS/DOMAINcfg/src/mpp_lnk_generic.h90 @ 13056

Last change on this file since 13056 was 13056, checked in by rblod, 4 years ago
ticket #2129 : cleaning domcfg
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	SELECT CASE ( nbondi )
157	CASE ( -1 )
158	CALL mppsend( 2, zt3we(1,1,1,1,1,1), imigr, noea, ml_req1 )
159	CALL mpprecv( 1, zt3ew(1,1,1,1,1,1), imigr, noea )
160	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
161	CASE ( 0 )
162	CALL mppsend( 1, zt3ew(1,1,1,1,1,1), imigr, nowe, ml_req1 )
163	CALL mppsend( 2, zt3we(1,1,1,1,1,1), imigr, noea, ml_req2 )
164	CALL mpprecv( 1, zt3ew(1,1,1,1,1,2), imigr, noea )
165	CALL mpprecv( 2, zt3we(1,1,1,1,1,2), imigr, nowe )
166	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
167	IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
168	CASE ( 1 )
169	CALL mppsend( 1, zt3ew(1,1,1,1,1,1), imigr, nowe, ml_req1 )
170	CALL mpprecv( 2, zt3we(1,1,1,1,1,1), imigr, nowe )
171	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err )
172	END SELECT
173	!
174	! ! Write Dirichlet lateral conditions
175	iihom = nlci-nn_hls
176	!
177	SELECT CASE ( nbondi )
178	CASE ( -1 )
179	DO jf = 1, ipf
180	DO jl = 1, ipl
181	DO jk = 1, ipk
182	DO jh = 1, nn_hls
183	ARRAY_IN(iihom+jh,:,jk,jl,jf) = zt3ew(:,jh,jk,jl,jf,1)
184	END DO
185	END DO
186	END DO
187	END DO
188	CASE ( 0 )
189	DO jf = 1, ipf
190	DO jl = 1, ipl
191	DO jk = 1, ipk
192	DO jh = 1, nn_hls
193	ARRAY_IN(jh ,:,jk,jl,jf) = zt3we(:,jh,jk,jl,jf,2)
194	ARRAY_IN(iihom+jh,:,jk,jl,jf) = zt3ew(:,jh,jk,jl,jf,2)
195	END DO
196	END DO
197	END DO
198	END DO
199	CASE ( 1 )
200	DO jf = 1, ipf
201	DO jl = 1, ipl
202	DO jk = 1, ipk
203	DO jh = 1, nn_hls
204	ARRAY_IN(jh ,:,jk,jl,jf) = zt3we(:,jh,jk,jl,jf,1)
205	END DO
206	END DO
207	END DO
208	END DO
209	END SELECT
210	!
211	IF( nbondi /= 2 ) DEALLOCATE( zt3ew, zt3we )
212	!
213	! ------------------------------- !
214	! 3. north fold treatment !
215	! ------------------------------- !
216	! do it before south directions so concerned processes can do it without waiting for the comm with the sourthern neighbor
217	IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN
218	!
219	SELECT CASE ( jpni )
220	CASE ( 1 ) ; CALL lbc_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) ) ! only 1 northern proc, no mpp
221	CASE DEFAULT ; CALL mpp_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) ) ! for all northern procs.
222	END SELECT
223	!
224	ENDIF
225	!
226	! ------------------------------- !
227	! 4. North and south directions !
228	! ------------------------------- !
229	! always closed : we play only with the neigbours
230	!
231	IF( ABS(nbondj) == 1 ) ALLOCATE( zt3ns(jpi,nn_hls,ipk,ipl,ipf,1), zt3sn(jpi,nn_hls,ipk,ipl,ipf,1) )
232	IF( nbondj == 0 ) ALLOCATE( zt3ns(jpi,nn_hls,ipk,ipl,ipf,2), zt3sn(jpi,nn_hls,ipk,ipl,ipf,2) )
233	!
234	SELECT CASE ( nbondj )
235	CASE ( -1 )
236	ijhom = nlcj-nrecj
237	DO jf = 1, ipf
238	DO jl = 1, ipl
239	DO jk = 1, ipk
240	DO jh = 1, nn_hls
241	zt3sn(:,jh,jk,jl,jf,1) = ARRAY_IN(:,ijhom +jh,jk,jl,jf)
242	END DO
243	END DO
244	END DO
245	END DO
246	CASE ( 0 )
247	ijhom = nlcj-nrecj
248	DO jf = 1, ipf
249	DO jl = 1, ipl
250	DO jk = 1, ipk
251	DO jh = 1, nn_hls
252	zt3sn(:,jh,jk,jl,jf,1) = ARRAY_IN(:,ijhom +jh,jk,jl,jf)
253	zt3ns(:,jh,jk,jl,jf,1) = ARRAY_IN(:,nn_hls+jh,jk,jl,jf)
254	END DO
255	END DO
256	END DO
257	END DO
258	CASE ( 1 )
259	ijhom = nlcj-nrecj
260	DO jf = 1, ipf
261	DO jl = 1, ipl
262	DO jk = 1, ipk
263	DO jh = 1, nn_hls
264	zt3ns(:,jh,jk,jl,jf,1) = ARRAY_IN(:,nn_hls+jh,jk,jl,jf)
265	END DO
266	END DO
267	END DO
268	END DO
269	END SELECT
270	!
271	! ! Migrations
272	imigr = nn_hls * jpi * ipk * ipl * ipf
273	!
274	SELECT CASE ( nbondj )
275	CASE ( -1 )
276	CALL mppsend( 4, zt3sn(1,1,1,1,1,1), imigr, nono, ml_req1 )
277	CALL mpprecv( 3, zt3ns(1,1,1,1,1,1), imigr, nono )
278	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err )
279	CASE ( 0 )
280	CALL mppsend( 3, zt3ns(1,1,1,1,1,1), imigr, noso, ml_req1 )
281	CALL mppsend( 4, zt3sn(1,1,1,1,1,1), imigr, nono, ml_req2 )
282	CALL mpprecv( 3, zt3ns(1,1,1,1,1,2), imigr, nono )
283	CALL mpprecv( 4, zt3sn(1,1,1,1,1,2), imigr, noso )
284	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err )
285	IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err )
286	CASE ( 1 )
287	CALL mppsend( 3, zt3ns(1,1,1,1,1,1), imigr, noso, ml_req1 )
288	CALL mpprecv( 4, zt3sn(1,1,1,1,1,1), imigr, noso )
289	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err )
290	END SELECT
291	!
292	ijhom = nlcj-nn_hls
293	!
294	SELECT CASE ( nbondj )
295	CASE ( -1 )
296	DO jf = 1, ipf
297	DO jl = 1, ipl
298	DO jk = 1, ipk
299	DO jh = 1, nn_hls
300	ARRAY_IN(:,ijhom+jh,jk,jl,jf) = zt3ns(:,jh,jk,jl,jf,1)
301	END DO
302	END DO
303	END DO
304	END DO
305	CASE ( 0 )
306	DO jf = 1, ipf
307	DO jl = 1, ipl
308	DO jk = 1, ipk
309	DO jh = 1, nn_hls
310	ARRAY_IN(:, jh,jk,jl,jf) = zt3sn(:,jh,jk,jl,jf,2)
311	ARRAY_IN(:,ijhom+jh,jk,jl,jf) = zt3ns(:,jh,jk,jl,jf,2)
312	END DO
313	END DO
314	END DO
315	END DO
316	CASE ( 1 )
317	DO jf = 1, ipf
318	DO jl = 1, ipl
319	DO jk = 1, ipk
320	DO jh = 1, nn_hls
321	ARRAY_IN(:,jh,jk,jl,jf) = zt3sn(:,jh,jk,jl,jf,1)
322	END DO
323	END DO
324	END DO
325	END DO
326	END SELECT
327	!
328	IF( nbondj /= 2 ) DEALLOCATE( zt3ns, zt3sn )
329	!
330	END SUBROUTINE ROUTINE_LNK
331
332	#undef ARRAY_TYPE
333	#undef NAT_IN
334	#undef SGN_IN
335	#undef ARRAY_IN
336	#undef K_SIZE
337	#undef L_SIZE
338	#undef F_SIZE
339	#undef OPT_K

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

Download in other formats:

Original Format