Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

mpp_lnk_generic.h90 @ 10948

Last change on this file since 10948 was 10888, checked in by davestorkey, 5 years ago
branches/UKMO/NEMO_4.0_mirror : clear SVN keywords
Property svn:mime-type set to `text/x-fortran`
File size: 13.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( 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	! ------------------------------- !
218	! 3. north fold treatment !
219	! ------------------------------- !
220	! do it before south directions so concerned processes can do it without waiting for the comm with the sourthern neighbor
221	IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN
222	!
223	SELECT CASE ( jpni )
224	CASE ( 1 ) ; CALL lbc_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) ) ! only 1 northern proc, no mpp
225	CASE DEFAULT ; CALL mpp_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) ) ! for all northern procs.
226	END SELECT
227	!
228	ENDIF
229	!
230	! ------------------------------- !
231	! 4. North and south directions !
232	! ------------------------------- !
233	! always closed : we play only with the neigbours
234	!
235	IF( ABS(nbondj) == 1 ) ALLOCATE( zt3ns(jpi,nn_hls,ipk,ipl,ipf,1), zt3sn(jpi,nn_hls,ipk,ipl,ipf,1) )
236	IF( nbondj == 0 ) ALLOCATE( zt3ns(jpi,nn_hls,ipk,ipl,ipf,2), zt3sn(jpi,nn_hls,ipk,ipl,ipf,2) )
237	!
238	SELECT CASE ( nbondj )
239	CASE ( -1 )
240	ijhom = nlcj-nrecj
241	DO jf = 1, ipf
242	DO jl = 1, ipl
243	DO jk = 1, ipk
244	DO jh = 1, nn_hls
245	zt3sn(:,jh,jk,jl,jf,1) = ARRAY_IN(:,ijhom +jh,jk,jl,jf)
246	END DO
247	END DO
248	END DO
249	END DO
250	CASE ( 0 )
251	ijhom = nlcj-nrecj
252	DO jf = 1, ipf
253	DO jl = 1, ipl
254	DO jk = 1, ipk
255	DO jh = 1, nn_hls
256	zt3sn(:,jh,jk,jl,jf,1) = ARRAY_IN(:,ijhom +jh,jk,jl,jf)
257	zt3ns(:,jh,jk,jl,jf,1) = ARRAY_IN(:,nn_hls+jh,jk,jl,jf)
258	END DO
259	END DO
260	END DO
261	END DO
262	CASE ( 1 )
263	ijhom = nlcj-nrecj
264	DO jf = 1, ipf
265	DO jl = 1, ipl
266	DO jk = 1, ipk
267	DO jh = 1, nn_hls
268	zt3ns(:,jh,jk,jl,jf,1) = ARRAY_IN(:,nn_hls+jh,jk,jl,jf)
269	END DO
270	END DO
271	END DO
272	END DO
273	END SELECT
274	!
275	! ! Migrations
276	imigr = nn_hls * jpi * ipk * ipl * ipf
277	!
278	IF( ln_timing ) CALL tic_tac(.TRUE.)
279	!
280	SELECT CASE ( nbondj )
281	CASE ( -1 )
282	CALL mppsend( 4, zt3sn(1,1,1,1,1,1), imigr, nono, ml_req1 )
283	CALL mpprecv( 3, zt3ns(1,1,1,1,1,1), imigr, nono )
284	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err )
285	CASE ( 0 )
286	CALL mppsend( 3, zt3ns(1,1,1,1,1,1), imigr, noso, ml_req1 )
287	CALL mppsend( 4, zt3sn(1,1,1,1,1,1), imigr, nono, ml_req2 )
288	CALL mpprecv( 3, zt3ns(1,1,1,1,1,2), imigr, nono )
289	CALL mpprecv( 4, zt3sn(1,1,1,1,1,2), imigr, noso )
290	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err )
291	IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err )
292	CASE ( 1 )
293	CALL mppsend( 3, zt3ns(1,1,1,1,1,1), imigr, noso, ml_req1 )
294	CALL mpprecv( 4, zt3sn(1,1,1,1,1,1), imigr, noso )
295	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err )
296	END SELECT
297	!
298	IF( ln_timing ) CALL tic_tac(.FALSE.)
299	! ! Write Dirichlet lateral conditions
300	ijhom = nlcj-nn_hls
301	!
302	SELECT CASE ( nbondj )
303	CASE ( -1 )
304	DO jf = 1, ipf
305	DO jl = 1, ipl
306	DO jk = 1, ipk
307	DO jh = 1, nn_hls
308	ARRAY_IN(:,ijhom+jh,jk,jl,jf) = zt3ns(:,jh,jk,jl,jf,1)
309	END DO
310	END DO
311	END DO
312	END DO
313	CASE ( 0 )
314	DO jf = 1, ipf
315	DO jl = 1, ipl
316	DO jk = 1, ipk
317	DO jh = 1, nn_hls
318	ARRAY_IN(:, jh,jk,jl,jf) = zt3sn(:,jh,jk,jl,jf,2)
319	ARRAY_IN(:,ijhom+jh,jk,jl,jf) = zt3ns(:,jh,jk,jl,jf,2)
320	END DO
321	END DO
322	END DO
323	END DO
324	CASE ( 1 )
325	DO jf = 1, ipf
326	DO jl = 1, ipl
327	DO jk = 1, ipk
328	DO jh = 1, nn_hls
329	ARRAY_IN(:,jh,jk,jl,jf) = zt3sn(:,jh,jk,jl,jf,1)
330	END DO
331	END DO
332	END DO
333	END DO
334	END SELECT
335	!
336	IF( nbondj /= 2 ) DEALLOCATE( zt3ns, zt3sn )
337	!
338	END SUBROUTINE ROUTINE_LNK
339
340	#undef ARRAY_TYPE
341	#undef NAT_IN
342	#undef SGN_IN
343	#undef ARRAY_IN
344	#undef K_SIZE
345	#undef L_SIZE
346	#undef F_SIZE
347	#undef OPT_K

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

New URL for NEMO forge! http://forge.nemo-ocean.eu

Context Navigation

source: NEMO/branches/UKMO/NEMO_4.0_GO8_package_text_diagnostics/src/OCE/LBC/mpp_lnk_generic.h90 @ 10948

Download in other formats: