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 branches/2017/dev_r8126_ROBUST08_no_ghost/NEMOGCM/NEMO/OPA_SRC/LBC – NEMO

Context Navigation

source: branches/2017/dev_r8126_ROBUST08_no_ghost/NEMOGCM/NEMO/OPA_SRC/LBC/mpp_lnk_generic.h90 @ 8591

Last change on this file since 8591 was 8591, checked in by acc, 7 years ago
Branch 2017/dev_r8126_ROBUST08_no_ghost. Add in fixes for mono-processor operation as supplied by gm. Fully Sette-tested at this stage.
File size: 12.7 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	LOGICAL :: ll_Iperio, ll_Jperio
65	INTEGER , DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend
66	REAL(wp), DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: zt3ns, zt3sn ! north-south & south-north halos
67	REAL(wp), DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: zt3ew, zt3we ! east -west & west - east halos
68	!!----------------------------------------------------------------------
69	!
70	ipk = K_SIZE(ptab) ! 3rd dimension
71	ipl = L_SIZE(ptab) ! 4th -
72	ipf = F_SIZE(ptab) ! 5th - use in "multi" case (array of pointers)
73	!
74	ALLOCATE( zt3ns(jpi,jprecj,ipk,ipl,ipf,2), zt3sn(jpi,jprecj,ipk,ipl,ipf,2), &
75	& zt3ew(jpj,jpreci,ipk,ipl,ipf,2), zt3we(jpj,jpreci,ipk,ipl,ipf,2) )
76	!
77	ll_Iperio = nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6)
78	ll_Jperio = nbondj == 2 .AND. jperio == 7
79	!
80	IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value
81	ELSE ; zland = 0._wp ! zero by default
82	ENDIF
83
84	! ------------------------------- !
85	! standard boundary treatment ! ! CAUTION: semi-column notation is often impossible
86	! ------------------------------- !
87	!
88	IF( PRESENT( cd_mpp ) ) THEN !== halos filled with inner values ==!
89	!
90	DO jf = 1, ipf ! number of arrays to be treated
91	!
92	DO jl = 1, ipl ! CAUTION: ptab is defined only between nld and nle
93	DO jk = 1, ipk
94	DO jj = nlcj+1, jpj ! added line(s) (inner only)
95	ARRAY_IN(nldi :nlei ,jj,jk,jl,jf) = ARRAY_IN(nldi:nlei,nlej,jk,jl,jf)
96	ARRAY_IN(1 :nldi-1,jj,jk,jl,jf) = ARRAY_IN(nldi ,nlej,jk,jl,jf)
97	ARRAY_IN(nlei+1:nlci ,jj,jk,jl,jf) = ARRAY_IN( nlei,nlej,jk,jl,jf)
98	END DO
99	DO ji = nlci+1, jpi ! added column(s) (full)
100	ARRAY_IN(ji,nldj :nlej ,jk,jl,jf) = ARRAY_IN(nlei,nldj:nlej,jk,jl,jf)
101	ARRAY_IN(ji,1 :nldj-1,jk,jl,jf) = ARRAY_IN(nlei,nldj ,jk,jl,jf)
102	ARRAY_IN(ji,nlej+1:jpj ,jk,jl,jf) = ARRAY_IN(nlei, nlej,jk,jl,jf)
103	END DO
104	END DO
105	END DO
106	!
107	END DO
108	!
109	ELSE !== standard close or cyclic treatment ==!
110	!
111	DO jf = 1, ipf ! number of arrays to be treated
112	!
113	! ! East-West boundaries
114	IF( ll_Iperio ) THEN !* cyclic
115	ARRAY_IN( 1 ,:,:,:,jf) = ARRAY_IN(jpim1,:,:,:,jf)
116	ARRAY_IN(jpi,:,:,:,jf) = ARRAY_IN( 2 ,:,:,:,jf)
117	ELSE !* closed
118	IF( .NOT. NAT_IN(jf) == 'F' ) ARRAY_IN( 1 :jpreci,:,:,:,jf) = zland ! east except F-point
119	ARRAY_IN(nlci-jpreci+1:jpi ,:,:,:,jf) = zland ! west
120	ENDIF
121	! ! North-South boundaries
122	IF( ll_Jperio ) THEN !* cyclic (only with no mpp j-split)
123	ARRAY_IN(:, 1 ,:,:,jf) = ARRAY_IN(:, jpjm1,:,:,jf)
124	ARRAY_IN(:,jpj,:,:,jf) = ARRAY_IN(:, 2 ,:,:,jf)
125	ELSE !* closed
126	IF( .NOT. NAT_IN(jf) == 'F' ) ARRAY_IN(:, 1 :jprecj,:,:,jf) = zland ! south except F-point
127	ARRAY_IN(:,nlcj-jprecj+1:jpj ,:,:,jf) = zland ! north
128	ENDIF
129	END DO
130	!
131	ENDIF
132
133	! ------------------------------- !
134	! East and west exchange !
135	! ------------------------------- !
136	! we play with the neigbours AND the row number because of the periodicity
137	!
138	SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions
139	CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)
140	iihom = nlci-nreci
141	DO jf = 1, ipf
142	DO jl = 1, ipl
143	DO jk = 1, ipk
144	DO jh = 1, jpreci
145	zt3ew(:,jh,jk,jl,jf,1) = ARRAY_IN(jpreci+jh,:,jk,jl,jf)
146	zt3we(:,jh,jk,jl,jf,1) = ARRAY_IN(iihom +jh,:,jk,jl,jf)
147	END DO
148	END DO
149	END DO
150	END DO
151	END SELECT
152	!
153	! ! Migrations
154	imigr = jpreci * 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,2), 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,2), 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-jpreci
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, jpreci
183	ARRAY_IN(iihom+jh,:,jk,jl,jf) = zt3ew(:,jh,jk,jl,jf,2)
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, jpreci
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, jpreci
204	ARRAY_IN(jh ,:,jk,jl,jf) = zt3we(:,jh,jk,jl,jf,2)
205	END DO
206	END DO
207	END DO
208	END DO
209	END SELECT
210
211	! 3. North and south directions
212	! -----------------------------
213	! always closed : we play only with the neigbours
214	!
215	IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions
216	ijhom = nlcj-nrecj
217	DO jf = 1, ipf
218	DO jl = 1, ipl
219	DO jk = 1, ipk
220	DO jh = 1, jprecj
221	zt3sn(:,jh,jk,jl,jf,1) = ARRAY_IN(:,ijhom +jh,jk,jl,jf)
222	zt3ns(:,jh,jk,jl,jf,1) = ARRAY_IN(:,jprecj+jh,jk,jl,jf)
223	END DO
224	END DO
225	END DO
226	END DO
227	ENDIF
228	!
229	! ! Migrations
230	imigr = jprecj * jpi * ipk * ipl * ipf
231	!
232	SELECT CASE ( nbondj )
233	CASE ( -1 )
234	CALL mppsend( 4, zt3sn(1,1,1,1,1,1), imigr, nono, ml_req1 )
235	CALL mpprecv( 3, zt3ns(1,1,1,1,1,2), imigr, nono )
236	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err )
237	CASE ( 0 )
238	CALL mppsend( 3, zt3ns(1,1,1,1,1,1), imigr, noso, ml_req1 )
239	CALL mppsend( 4, zt3sn(1,1,1,1,1,1), imigr, nono, ml_req2 )
240	CALL mpprecv( 3, zt3ns(1,1,1,1,1,2), imigr, nono )
241	CALL mpprecv( 4, zt3sn(1,1,1,1,1,2), imigr, noso )
242	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err )
243	IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err )
244	CASE ( 1 )
245	CALL mppsend( 3, zt3ns(1,1,1,1,1,1), imigr, noso, ml_req1 )
246	CALL mpprecv( 4, zt3sn(1,1,1,1,1,2), imigr, noso )
247	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err )
248	END SELECT
249	!
250	! ! Write Dirichlet lateral conditions
251	ijhom = nlcj-jprecj
252	!
253	SELECT CASE ( nbondj )
254	CASE ( -1 )
255	DO jf = 1, ipf
256	DO jl = 1, ipl
257	DO jk = 1, ipk
258	DO jh = 1, jprecj
259	ARRAY_IN(:,ijhom+jh,jk,jl,jf) = zt3ns(:,jh,jk,jl,jf,2)
260	END DO
261	END DO
262	END DO
263	END DO
264	CASE ( 0 )
265	DO jf = 1, ipf
266	DO jl = 1, ipl
267	DO jk = 1, ipk
268	DO jh = 1, jprecj
269	ARRAY_IN(:, jh,jk,jl,jf) = zt3sn(:,jh,jk,jl,jf,2)
270	ARRAY_IN(:,ijhom+jh,jk,jl,jf) = zt3ns(:,jh,jk,jl,jf,2)
271	END DO
272	END DO
273	END DO
274	END DO
275	CASE ( 1 )
276	DO jf = 1, ipf
277	DO jl = 1, ipl
278	DO jk = 1, ipk
279	DO jh = 1, jprecj
280	ARRAY_IN(:,jh,jk,jl,jf) = zt3sn(:,jh,jk,jl,jf,2)
281	END DO
282	END DO
283	END DO
284	END DO
285	END SELECT
286
287	! 4. north fold treatment
288	! -----------------------
289	!
290	IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN
291	!
292	SELECT CASE ( jpni )
293	CASE ( 1 ) ; CALL lbc_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) ) ! only 1 northern proc, no mpp
294	CASE DEFAULT ; CALL mpp_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) ) ! for all northern procs.
295	END SELECT
296	!
297	ENDIF
298	!
299	DEALLOCATE( zt3ns, zt3sn, zt3ew, zt3we )
300	!
301	END SUBROUTINE ROUTINE_LNK
302
303	#undef ARRAY_TYPE
304	#undef NAT_IN
305	#undef SGN_IN
306	#undef ARRAY_IN
307	#undef K_SIZE
308	#undef L_SIZE
309	#undef F_SIZE
310	#undef OPT_K

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

Download in other formats:

Original Format