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

Context Navigation

source: NEMO/trunk/src/OCE/LBC/mpp_lnk_generic.h90 @ 9667

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

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

Download in other formats:

Original Format