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_bdy_generic.h90 in branches/2017/dev_CNRS_2017/NEMOGCM/NEMO/OPA_SRC/LBC – NEMO

Context Navigation

source: branches/2017/dev_CNRS_2017/NEMOGCM/NEMO/OPA_SRC/LBC/mpp_bdy_generic.h90 @ 8882

Last change on this file since 8882 was 8882, checked in by flavoni, 6 years ago
dev_CNRS_2017 branch: merged dev_r7881_ENHANCE09_RK3 with trunk r8864
File size: 12.4 KB

Line
1	#if defined MULTI
2	# define NAT_IN(k) cd_nat(k)
3	# define SGN_IN(k) psgn(k)
4	# define IBD_IN(k) kb_bdy(k)
5	# define F_SIZE(ptab) kfld
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 IBD_IN(k) kb_bdy
29	# define F_SIZE(ptab) 1
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_BDY( ptab, cd_nat, psgn, kfld, kb_bdy )
49	INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays
50	#else
51	SUBROUTINE ROUTINE_BDY( ptab, cd_nat, psgn , kb_bdy )
52	#endif
53	!!----------------------------------------------------------------------
54	!! * routine mpp_lnk_bdy_3d *
55	!!
56	!! ** Purpose : Message passing management
57	!!
58	!! ** Method : Use mppsend and mpprecv function for passing BDY boundaries
59	!! between processors following neighboring subdomains.
60	!! domain parameters
61	!! nlci : first dimension of the local subdomain
62	!! nlcj : second dimension of the local subdomain
63	!! nbondi_bdy : mark for "east-west local boundary"
64	!! nbondj_bdy : mark for "north-south local boundary"
65	!! noea : number for local neighboring processors
66	!! nowe : number for local neighboring processors
67	!! noso : number for local neighboring processors
68	!! nono : number for local neighboring processors
69	!!
70	!! ** Action : ptab with update value at its periphery
71	!!
72	!!----------------------------------------------------------------------
73	ARRAY_TYPE(:,:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied
74	CHARACTER(len=1) , INTENT(in ) :: NAT_IN(:) ! nature of array grid-points
75	REAL(wp) , INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary
76	INTEGER , INTENT(in ) :: IBD_IN(:) ! BDY boundary set
77	!
78	INTEGER :: ji, jj, jk, jl, jh, jf ! dummy loop indices
79	INTEGER :: ipk, ipl, ipf ! 3dimension of the input array
80	INTEGER :: imigr, iihom, ijhom ! local integers
81	INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
82	REAL(wp) :: zland ! local scalar
83	INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend
84	!
85	REAL(wp), DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: zt3ns, zt3sn ! 3d for north-south & south-north
86	REAL(wp), DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: zt3ew, zt3we ! 3d for east-west & west-east
87	!!----------------------------------------------------------------------
88	!
89	ipk = K_SIZE(ptab) ! 3rd dimension
90	ipl = L_SIZE(ptab) ! 4th -
91	ipf = F_SIZE(ptab) ! 5th - use in "multi" case (array of pointers)
92	!
93	ALLOCATE( zt3ns(jpi,jprecj,ipk,ipl,ipf,2), zt3sn(jpi,jprecj,ipk,ipl,ipf,2), &
94	& zt3ew(jpj,jpreci,ipk,ipl,ipf,2), zt3we(jpj,jpreci,ipk,ipl,ipf,2) )
95
96	zland = 0._wp
97
98	! 1. standard boundary treatment
99	! ------------------------------
100	!
101	DO jf = 1, ipf ! number of arrays to be treated
102	!
103	! ! East-West boundaries
104	!
105	IF( nbondi == 2) THEN ! neither subdomain to the east nor to the west
106	! !* Cyclic
107	IF( nperio == 1 .OR. nperio == 4 .OR. nperio == 6 ) THEN
108	ARRAY_IN( 1 ,:,:,:,jf) = ARRAY_IN(jpim1,:,:,:,jf)
109	ARRAY_IN(jpi,:,:,:,jf) = ARRAY_IN( 2 ,:,:,:,jf)
110	ELSE !* Closed
111	IF( .NOT. NAT_IN(jf) == 'F' ) ARRAY_IN( 1 :jpreci,:,:,:,jf) = zland ! east except F-point
112	ARRAY_IN(nlci-jpreci+1:jpi ,:,:,:,jf) = zland ! west
113	ENDIF
114	ELSEIF(nbondi == -1) THEN ! subdomain to the east only
115	IF( .NOT. NAT_IN(jf) == 'F' ) ARRAY_IN(1:jpreci,:,:,:,jf) = zland ! south except F-point
116	!
117	ELSEIF(nbondi == 1) THEN ! subdomain to the west only
118	ARRAY_IN(nlci-jpreci+1:jpi,:,:,:,jf) = zland ! north
119	ENDIF
120	! ! North-South boundaries
121	!
122	IF (nbondj == 2 .OR. nbondj == -1) THEN !* closed
123	IF( .NOT. NAT_IN(jf) == 'F' ) ARRAY_IN(:,1:jprecj,:,:,jf) = zland ! south except F-point
124	ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN
125	ARRAY_IN(:,nlcj-jprecj+1:jpj,:,:,jf) = zland ! north
126	ENDIF
127	END DO
128
129	! 2. East and west directions exchange
130	! ------------------------------------
131	! we play with the neigbours AND the row number because of the periodicity
132	!
133	!
134	DO jf = 1, ipf
135	SELECT CASE ( nbondi_bdy(IBD_IN(jf)) ) ! Read Dirichlet lateral conditions
136	CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)
137	iihom = nlci-nreci
138	DO jl = 1, ipl
139	DO jk = 1, ipk
140	DO jh = 1, jpreci
141	zt3ew(:,jh,jk,jl,jf,1) = ARRAY_IN(jpreci+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 SELECT
147	!
148	! ! Migrations
149	!!gm imigr = jpreci * jpj * ipk * ipl * ipf
150	imigr = jpreci * jpj * ipk * ipl
151	!
152	SELECT CASE ( nbondi_bdy(IBD_IN(jf)) )
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-jpreci
172	!
173	!
174	SELECT CASE ( nbondi_bdy_b(IBD_IN(jf)) )
175	CASE ( -1 )
176	DO jl = 1, ipl
177	DO jk = 1, ipk
178	DO jh = 1, jpreci
179	ARRAY_IN(iihom+jh,:,jk,jl,jf) = zt3ew(:,jh,jk,jl,jf,2)
180	END DO
181	END DO
182	END DO
183	CASE ( 0 )
184	DO jl = 1, ipl
185	DO jk = 1, ipk
186	DO jh = 1, jpreci
187	ARRAY_IN(jh ,:,jk,jl,jf) = zt3we(:,jh,jk,jl,jf,2)
188	ARRAY_IN(iihom+jh,:,jk,jl,jf) = zt3ew(:,jh,jk,jl,jf,2)
189	END DO
190	END DO
191	END DO
192	CASE ( 1 )
193	DO jl = 1, ipl
194	DO jk = 1, ipk
195	DO jh = 1, jpreci
196	ARRAY_IN(jh ,:,jk,jl,jf) = zt3we(:,jh,jk,jl,jf,2)
197	END DO
198	END DO
199	END DO
200	END SELECT
201	!
202	END DO
203
204	! 3. North and south directions
205	! -----------------------------
206	! always closed : we play only with the neigbours
207	!
208	DO jf = 1, ipf
209	IF( nbondj_bdy(IBD_IN(jf)) /= 2 ) THEN ! Read Dirichlet lateral conditions
210	ijhom = nlcj-nrecj
211	DO jl = 1, ipl
212	DO jk = 1, ipk
213	DO jh = 1, jprecj
214	zt3sn(:,jh,jk,jl,jf,1) = ARRAY_IN(:,ijhom +jh,jk,jl,jf)
215	zt3ns(:,jh,jk,jl,jf,1) = ARRAY_IN(:,jprecj+jh,jk,jl,jf)
216	END DO
217	END DO
218	END DO
219	ENDIF
220	!
221	! ! Migrations
222	!!gm imigr = jprecj * jpi * ipk * ipl * ipf
223	imigr = jprecj * jpi * ipk * ipl
224	!
225	SELECT CASE ( nbondj_bdy(IBD_IN(jf)) )
226	CASE ( -1 )
227	CALL mppsend( 4, zt3sn(1,1,1,1,1,1), imigr, nono, ml_req1 )
228	CALL mpprecv( 3, zt3ns(1,1,1,1,1,2), imigr, nono )
229	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
230	CASE ( 0 )
231	CALL mppsend( 3, zt3ns(1,1,1,1,1,1), imigr, noso, ml_req1 )
232	CALL mppsend( 4, zt3sn(1,1,1,1,1,1), imigr, nono, ml_req2 )
233	CALL mpprecv( 3, zt3ns(1,1,1,1,1,2), imigr, nono )
234	CALL mpprecv( 4, zt3sn(1,1,1,1,1,2), imigr, noso )
235	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
236	IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
237	CASE ( 1 )
238	CALL mppsend( 3, zt3ns(1,1,1,1,1,1), imigr, noso, ml_req1 )
239	CALL mpprecv( 4, zt3sn(1,1,1,1,1,2), imigr, noso )
240	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
241	END SELECT
242	!
243	! ! Write Dirichlet lateral conditions
244	ijhom = nlcj-jprecj
245	!
246	SELECT CASE ( nbondj_bdy_b(IBD_IN(jf)) )
247	CASE ( -1 )
248	DO jl = 1, ipl
249	DO jk = 1, ipk
250	DO jh = 1, jprecj
251	ARRAY_IN(:,ijhom+jh,jk,jl,jf) = zt3ns(:,jh,jk,jl,jf,2)
252	END DO
253	END DO
254	END DO
255	CASE ( 0 )
256	DO jl = 1, ipl
257	DO jk = 1, ipk
258	DO jh = 1, jprecj
259	ARRAY_IN(:, jh,jk,jl,jf) = zt3sn(:,jh,jk,jl,jf,2)
260	ARRAY_IN(:,ijhom+jh,jk,jl,jf) = zt3ns(:,jh,jk,jl,jf,2)
261	END DO
262	END DO
263	END DO
264	CASE ( 1 )
265	DO jl = 1, ipl
266	DO jk = 1, ipk
267	DO jh = 1, jprecj
268	ARRAY_IN(:,jh,jk,jl,jf) = zt3sn(:,jh,jk,jl,jf,2)
269	END DO
270	END DO
271	END DO
272	END SELECT
273	END DO
274
275	! 4. north fold treatment
276	! -----------------------
277	!
278	IF( npolj /= 0) THEN
279	!
280	SELECT CASE ( jpni )
281	CASE ( 1 ) ; CALL lbc_nfd( ptab, NAT_IN(:), SGN_IN(:) ) ! only 1 northern proc, no mpp
282	CASE DEFAULT ; CALL mpp_nfd( ptab, NAT_IN(:), SGN_IN(:) ) ! for all northern procs.
283	END SELECT
284	!
285	ENDIF
286	!
287	DEALLOCATE( zt3ns, zt3sn, zt3ew, zt3we )
288	!
289	END SUBROUTINE ROUTINE_BDY
290
291	#undef ARRAY_TYPE
292	#undef NAT_IN
293	#undef SGN_IN
294	#undef IBD_IN
295	#undef ARRAY_IN
296	#undef K_SIZE
297	#undef L_SIZE
298	#undef F_SIZE

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

Download in other formats:

Original Format