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

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

Download in other formats:

Original Format