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 NEMO/branches/2019/dev_r10984_HPC-13_IRRMANN_BDY_optimization/src/OCE/LBC – NEMO

Context Navigation

source: NEMO/branches/2019/dev_r10984_HPC-13_IRRMANN_BDY_optimization/src/OCE/LBC/mpp_bdy_generic.h90 @ 11067

Last change on this file since 11067 was 11067, checked in by girrmann, 5 years ago
dev_r10984_HPC-13 : new implementation of lbc_bdy_lnk in prevision of step 2, regroup communications, see #2285
Property svn:keywords set to `Id` Property svn:mime-type set to `text/x-fortran`
File size: 12.6 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	!! * routine mpp_lnk_bdy *
48	!!
49	!! ** Purpose : Message passing management
50	!!
51	!! ** Method : Use mppsend and mpprecv function for passing BDY boundaries
52	!! between processors following neighboring subdomains.
53	!! domain parameters
54	!! nlci : first dimension of the local subdomain
55	!! nlcj : second dimension of the local subdomain
56	!! noea : number for local neighboring processors
57	!! nowe : number for local neighboring processors
58	!! noso : number for local neighboring processors
59	!! nono : number for local neighboring processors
60	!!
61	!! ** Action : ptab with update value at its periphery
62	!!
63	!!----------------------------------------------------------------------
64	#if defined MULTI
65	SUBROUTINE ROUTINE_BDY( cdname, lsend, lrecv, ptab, cd_nat, psgn, kfld )
66	INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays
67	#else
68	SUBROUTINE ROUTINE_BDY( cdname, lsend, lrecv, ptab, cd_nat, psgn )
69	#endif
70	CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine
71	ARRAY_TYPE(:,:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied
72	CHARACTER(len=1) , INTENT(in ) :: NAT_IN(:) ! nature of array grid-points
73	REAL(wp) , INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary
74	LOGICAL, DIMENSION(4) , INTENT(in ) :: lsend, lrecv ! communication with other 4 proc
75	!
76	INTEGER :: ji, jj, jk, jl, jh, jf ! dummy loop indices
77	INTEGER :: ipk, ipl, ipf ! 3dimension of the input array
78	INTEGER :: imigr, iihom, ijhom ! local integers
79	INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
80	INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend
81	LOGICAL :: llsend_we, llsend_ea, llsend_no, llsend_so ! communication send
82	LOGICAL :: llrecv_we, llrecv_ea, llrecv_no, llrecv_so ! communication receive
83	!
84	REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zsend_no, zsend_so ! 3d for north-south & south-north send
85	REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zsend_ea, zsend_we ! 3d for east-west & west-east send
86	REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zrecv_no, zrecv_so ! 3d for north-south & south-north receive
87	REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zrecv_ea, zrecv_we ! 3d for east-west & west-east receive
88	!!----------------------------------------------------------------------
89	!
90	ipk = K_SIZE(ptab) ! 3rd dimension
91	ipl = L_SIZE(ptab) ! 4th -
92	ipf = F_SIZE(ptab) ! 5th - use in "multi" case (array of pointers)
93	llsend_we = lsend(1); llsend_ea = lsend(2); llsend_so = lsend(3); llsend_no = lsend(4);
94	llrecv_we = lrecv(1); llrecv_ea = lrecv(2); llrecv_so = lrecv(3); llrecv_no = lrecv(4);
95	!
96	IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ipk, ipl, ipf, ld_lbc = .TRUE. )
97
98
99	! 1. standard boundary treatment
100	! ------------------------------
101	! Bdy treatment does not update land points
102	DO jf = 1, ipf ! number of arrays to be treated
103	IF( nbondi == 2 ) THEN ! neither subdomain to the east nor to the west
104	! !* Cyclic East-West boundaries
105	IF( l_Iperio ) THEN
106	ARRAY_IN( 1 ,:,:,:,jf) = ARRAY_IN(jpim1,:,:,:,jf)
107	ARRAY_IN(jpi,:,:,:,jf) = ARRAY_IN( 2 ,:,:,:,jf)
108	END IF
109	END IF
110	IF( nbondj == 2) THEN ! neither subdomain to the north nor to the south
111	! !* Cyclic North-South boundaries
112	IF( l_Jperio ) THEN
113	ARRAY_IN(:, 1 ,:,:,jf) = ARRAY_IN(:,jpjm1,:,:,jf)
114	ARRAY_IN(:,jpj,:,:,jf) = ARRAY_IN(:, 2 ,:,:,jf)
115	END IF
116	END IF
117	END DO
118
119
120	! 2. East and west directions exchange
121	! ------------------------------------
122	! we play with the neigbours AND the row number because of the periodicity
123	!
124	IF( llsend_we ) ALLOCATE( zsend_we(jpj,nn_hls,ipk,ipl,ipf) )
125	IF( llsend_ea ) ALLOCATE( zsend_ea(jpj,nn_hls,ipk,ipl,ipf) )
126	IF( llrecv_we ) ALLOCATE( zrecv_we(jpj,nn_hls,ipk,ipl,ipf) )
127	IF( llrecv_ea ) ALLOCATE( zrecv_ea(jpj,nn_hls,ipk,ipl,ipf) )
128	!
129	! Load arrays to the east and to the west to be sent
130	IF( llsend_we ) THEN ! Read Dirichlet lateral conditions
131	DO jf = 1, ipf
132	DO jl = 1, ipl
133	DO jk = 1, ipk
134	DO jh = 1, nn_hls
135	zsend_we(:,jh,jk,jl,jf) = ARRAY_IN(nn_hls+jh,:,jk,jl,jf)
136	END DO
137	END DO
138	END DO
139	END DO
140	END IF
141	!
142	IF( llsend_ea ) THEN ! Read Dirichlet lateral conditions
143	iihom = nlci-nreci
144	DO jf = 1, ipf
145	DO jl = 1, ipl
146	DO jk = 1, ipk
147	DO jh = 1, nn_hls
148	zsend_ea(:,jh,jk,jl,jf) = ARRAY_IN(iihom +jh,:,jk,jl,jf)
149	END DO
150	END DO
151	END DO
152	END DO
153	END IF
154	!
155	! Send/receive arrays to the east and to the west
156	imigr = nn_hls * jpj * ipk * ipl * ipf ! Migrations
157	!
158	IF( ln_timing ) CALL tic_tac(.TRUE.)
159	!
160	IF( llsend_ea ) CALL mppsend( 2, zsend_ea(1,1,1,1,1), imigr, noea, ml_req1 )
161	IF( llsend_we ) CALL mppsend( 1, zsend_we(1,1,1,1,1), imigr, nowe, ml_req2 )
162	!
163	IF( llrecv_ea ) CALL mpprecv( 1, zrecv_ea(1,1,1,1,1), imigr, noea )
164	IF( llrecv_we ) CALL mpprecv( 2, zrecv_we(1,1,1,1,1), imigr, nowe )
165	!
166	IF( l_isend .AND. llsend_ea ) CALL mpi_wait(ml_req1, ml_stat, ml_err)
167	IF( l_isend .AND. llsend_we ) CALL mpi_wait(ml_req2, ml_stat, ml_err)
168	!
169	IF( ln_timing ) CALL tic_tac(.FALSE.)
170	!
171	! ! Write Dirichlet lateral conditions
172	! Update with the received arrays
173	IF( llrecv_we ) THEN
174	DO jf = 1, ipf
175	DO jl = 1, ipl
176	DO jk = 1, ipk
177	DO jh = 1, nn_hls
178	ARRAY_IN( jh,:,jk,jl,jf) = zrecv_we(:,jh,jk,jl,jf)
179	END DO
180	END DO
181	END DO
182	END DO
183	END IF
184	!
185	IF( llrecv_ea ) THEN
186	iihom = nlci-nn_hls
187	DO jf = 1, ipf
188	DO jl = 1, ipl
189	DO jk = 1, ipk
190	DO jh = 1, nn_hls
191	ARRAY_IN(iihom+jh,:,jk,jl,jf) = zrecv_ea(:,jh,jk,jl,jf)
192	END DO
193	END DO
194	END DO
195	END DO
196	END IF
197	!
198	! Clean up
199	IF( llsend_we ) DEALLOCATE( zsend_we )
200	IF( llsend_ea ) DEALLOCATE( zsend_ea )
201	IF( llrecv_we ) DEALLOCATE( zrecv_we )
202	IF( llrecv_ea ) DEALLOCATE( zrecv_ea )
203
204	! 3. north fold treatment
205	! -----------------------
206	!
207	! do it before south directions so concerned processes can do it without waiting for the comm with the sourthern neighbor
208	IF( npolj /= 0) THEN
209	!
210	SELECT CASE ( jpni )
211	CASE ( 1 ) ; CALL lbc_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) ) ! only 1 northern proc, no mpp
212	CASE DEFAULT ; CALL mpp_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) ) ! for all northern procs.
213	END SELECT
214	!
215	ENDIF
216
217	! 4. North and south directions
218	! -----------------------------
219	! always closed : we play only with the neigbours
220	!
221	IF( llsend_so ) ALLOCATE( zsend_so(jpi,nn_hls,ipk,ipl,ipf) )
222	IF( llsend_no ) ALLOCATE( zsend_no(jpi,nn_hls,ipk,ipl,ipf) )
223	IF( llrecv_so ) ALLOCATE( zrecv_so(jpi,nn_hls,ipk,ipl,ipf) )
224	IF( llrecv_no ) ALLOCATE( zrecv_no(jpi,nn_hls,ipk,ipl,ipf) )
225	!
226	! Load arrays to the south and to the north to be sent
227	IF( llsend_so ) THEN ! Read Dirichlet lateral conditions
228	DO jf = 1, ipf
229	DO jl = 1, ipl
230	DO jk = 1, ipk
231	DO jh = 1, nn_hls
232	zsend_so(:,jh,jk,jl,jf) = ARRAY_IN(:,nn_hls+jh,jk,jl,jf)
233	END DO
234	END DO
235	END DO
236	END DO
237	END IF
238	!
239	IF( llsend_no ) THEN ! Read Dirichlet lateral conditions
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	zsend_no(:,jh,jk,jl,jf) = ARRAY_IN(:,ijhom +jh,jk,jl,jf)
246	END DO
247	END DO
248	END DO
249	END DO
250	END IF
251	!
252	! Send/receive arrays to the south and to the north
253	imigr = nn_hls * jpi * ipk * ipl * ipf ! Migrations
254	!
255	IF( ln_timing ) CALL tic_tac(.TRUE.)
256	!
257	IF( llsend_no ) CALL mppsend( 4, zsend_no(1,1,1,1,1), imigr, nono, ml_req1 )
258	IF( llsend_so ) CALL mppsend( 3, zsend_so(1,1,1,1,1), imigr, noso, ml_req2 )
259	!
260	IF( llrecv_no ) CALL mpprecv( 3, zrecv_no(1,1,1,1,1), imigr, nono )
261	IF( llrecv_so ) CALL mpprecv( 4, zrecv_so(1,1,1,1,1), imigr, noso )
262	!
263	IF( l_isend .AND. llsend_no ) CALL mpi_wait(ml_req1, ml_stat, ml_err)
264	IF( l_isend .AND. llsend_so ) CALL mpi_wait(ml_req2, ml_stat, ml_err)
265	!
266	IF( ln_timing ) CALL tic_tac(.FALSE.)
267	!
268	! ! Write Dirichlet lateral conditions
269	! Update with the received arrays
270	IF( llrecv_so ) THEN
271	DO jf = 1, ipf
272	DO jl = 1, ipl
273	DO jk = 1, ipk
274	DO jh = 1, nn_hls
275	ARRAY_IN(:, jh,jk,jl,jf) = zrecv_so(:,jh,jk,jl,jf)
276	END DO
277	END DO
278	END DO
279	END DO
280	END IF
281	IF( llrecv_no ) THEN
282	ijhom = nlcj-nn_hls
283	DO jf = 1, ipf
284	DO jl = 1, ipl
285	DO jk = 1, ipk
286	DO jh = 1, nn_hls
287	ARRAY_IN(:,ijhom+jh,jk,jl,jf) = zrecv_no(:,jh,jk,jl,jf)
288	END DO
289	END DO
290	END DO
291	END DO
292	END IF
293	!
294	! Clean up
295	IF( llsend_so ) DEALLOCATE( zsend_so )
296	IF( llsend_no ) DEALLOCATE( zsend_no )
297	IF( llrecv_so ) DEALLOCATE( zrecv_so )
298	IF( llrecv_no ) DEALLOCATE( zrecv_no )
299	!
300	END SUBROUTINE ROUTINE_BDY
301
302	#undef ARRAY_TYPE
303	#undef NAT_IN
304	#undef SGN_IN
305	#undef ARRAY_IN
306	#undef K_SIZE
307	#undef L_SIZE
308	#undef F_SIZE
309	#undef OPT_K
310

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

Download in other formats: