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_nfd_generic.h90 in NEMO/branches/2020/dev_r13383_HPC-02_Daley_Tiling/src/OCE/LBC – NEMO

Context Navigation

source: NEMO/branches/2020/dev_r13383_HPC-02_Daley_Tiling/src/OCE/LBC/mpp_nfd_generic.h90 @ 13553

Last change on this file since 13553 was 13553, checked in by hadcv, 4 years ago
Merge in trunk up to [13550]
Property svn:keywords set to `Id` Property svn:mime-type set to `text/x-fortran`
File size: 19.2 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 LBC_ARG (jf)
6	# if defined DIM_2d
7	# if defined SINGLE_PRECISION
8	# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_sp) , INTENT(inout) :: ptab(f)
9	# else
10	# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_dp) , INTENT(inout) :: ptab(f)
11	# endif
12	# define ARRAY_IN(i,j,k,l,f) ptab(f)%pt2d(i,j)
13	# define K_SIZE(ptab) 1
14	# define L_SIZE(ptab) 1
15	# endif
16	# if defined DIM_3d
17	# if defined SINGLE_PRECISION
18	# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_sp) , INTENT(inout) :: ptab(f)
19	# else
20	# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_dp) , INTENT(inout) :: ptab(f)
21	# endif
22	# define ARRAY_IN(i,j,k,l,f) ptab(f)%pt3d(i,j,k)
23	# define K_SIZE(ptab) SIZE(ptab(1)%pt3d,3)
24	# define L_SIZE(ptab) 1
25	# endif
26	# if defined DIM_4d
27	# if defined SINGLE_PRECISION
28	# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_sp) , INTENT(inout) :: ptab(f)
29	# else
30	# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_dp) , INTENT(inout) :: ptab(f)
31	# endif
32	# define ARRAY_IN(i,j,k,l,f) ptab(f)%pt4d(i,j,k,l)
33	# define K_SIZE(ptab) SIZE(ptab(1)%pt4d,3)
34	# define L_SIZE(ptab) SIZE(ptab(1)%pt4d,4)
35	# endif
36	#else
37	! !== IN: ptab is an array ==!
38	# if defined SINGLE_PRECISION
39	# define ARRAY_TYPE(i,j,k,l,f) REAL(sp) , INTENT(inout) :: ARRAY_IN(i,j,k,l,f)
40	# else
41	# define ARRAY_TYPE(i,j,k,l,f) REAL(dp) , INTENT(inout) :: ARRAY_IN(i,j,k,l,f)
42	# endif
43	# define NAT_IN(k) cd_nat
44	# define SGN_IN(k) psgn
45	# define F_SIZE(ptab) 1
46	# define LBC_ARG
47	# if defined DIM_2d
48	# define ARRAY_IN(i,j,k,l,f) ptab(i,j)
49	# define K_SIZE(ptab) 1
50	# define L_SIZE(ptab) 1
51	# endif
52	# if defined DIM_3d
53	# define ARRAY_IN(i,j,k,l,f) ptab(i,j,k)
54	# define K_SIZE(ptab) SIZE(ptab,3)
55	# define L_SIZE(ptab) 1
56	# endif
57	# if defined DIM_4d
58	# define ARRAY_IN(i,j,k,l,f) ptab(i,j,k,l)
59	# define K_SIZE(ptab) SIZE(ptab,3)
60	# define L_SIZE(ptab) SIZE(ptab,4)
61	# endif
62	#endif
63
64	# if defined SINGLE_PRECISION
65	# define PRECISION sp
66	# define SENDROUTINE mppsend_sp
67	# define RECVROUTINE mpprecv_sp
68	# define MPI_TYPE MPI_REAL
69	# define HUGEVAL(x) HUGE(x/**/_sp)
70	# else
71	# define PRECISION dp
72	# define SENDROUTINE mppsend_dp
73	# define RECVROUTINE mpprecv_dp
74	# define MPI_TYPE MPI_DOUBLE_PRECISION
75	# define HUGEVAL(x) HUGE(x/**/_dp)
76	# endif
77
78	SUBROUTINE ROUTINE_NFD( ptab, cd_nat, psgn, kfillmode, pfillval, kfld )
79	!!----------------------------------------------------------------------
80	ARRAY_TYPE(:,:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied
81	CHARACTER(len=1) , INTENT(in ) :: NAT_IN(:) ! nature of array grid-points
82	REAL(wp) , INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary
83	INTEGER , INTENT(in ) :: kfillmode ! filling method for halo over land
84	REAL(wp) , INTENT(in ) :: pfillval ! background value (used at closed boundaries)
85	INTEGER, OPTIONAL, INTENT(in ) :: kfld ! number of pt3d arrays
86	!
87	LOGICAL :: ll_add_line
88	INTEGER :: ji, jj, jk, jl, jh, jf, jr ! dummy loop indices
89	INTEGER :: ipi, ipj, ipj2, ipk, ipl, ipf ! dimension of the input array
90	INTEGER :: imigr, iihom, ijhom ! local integers
91	INTEGER :: ierr, ibuffsize, iis0, iie0, impp
92	INTEGER :: ii1, ii2, ij1, ij2
93	INTEGER :: ipimax, i0max
94	INTEGER :: ij, iproc, ipni, ijnr
95	INTEGER, DIMENSION (jpmaxngh) :: ml_req_nf ! for mpi_isend when avoiding mpi_allgather
96	INTEGER :: ml_err ! for mpi_isend when avoiding mpi_allgather
97	INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for mpi_isend when avoiding mpi_allgather
98	! ! Workspace for message transfers avoiding mpi_allgather
99	INTEGER :: ipj_b ! sum of lines for all multi fields
100	INTEGER :: i012 ! 0, 1 or 2
101	INTEGER , DIMENSION(:,:) , ALLOCATABLE :: jj_s ! position of sent lines
102	INTEGER , DIMENSION(:,:) , ALLOCATABLE :: jj_b ! position of buffer lines
103	INTEGER , DIMENSION(:) , ALLOCATABLE :: ipj_s ! number of sent lines
104	REAL(PRECISION), DIMENSION(:,:,:,:) , ALLOCATABLE :: ztabb, ztabr, ztabw ! buffer, receive and work arrays
105	REAL(PRECISION), DIMENSION(:,:,:,:,:) , ALLOCATABLE :: ztabglo, znorthloc
106	REAL(PRECISION), DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: znorthglo
107	!!----------------------------------------------------------------------
108	#if defined key_mpp_mpi
109	!
110	ipk = K_SIZE(ptab) ! 3rd dimension
111	ipl = L_SIZE(ptab) ! 4th -
112	ipf = F_SIZE(ptab) ! 5th - use in "multi" case (array of pointers)
113	!
114	IF( l_north_nogather ) THEN !== no allgather exchanges ==!
115
116	! --- define number of exchanged lines ---
117	!
118	! In theory we should exchange only nn_hls lines.
119	!
120	! However, some other points are duplicated in the north pole folding:
121	! - jperio=[34], grid=T : half of the last line (jpiglo/2+2:jpiglo-nn_hls)
122	! - jperio=[34], grid=U : half of the last line (jpiglo/2+1:jpiglo-nn_hls)
123	! - jperio=[34], grid=V : all the last line nn_hls+1 and (nn_hls+2:jpiglo-nn_hls)
124	! - jperio=[34], grid=F : all the last line (nn_hls+1:jpiglo-nn_hls)
125	! - jperio=[56], grid=T : 2 points of the last line (jpiglo/2+1 and jpglo-nn_hls)
126	! - jperio=[56], grid=U : no points are duplicated
127	! - jperio=[56], grid=V : half of the last line (jpiglo/2+1:jpiglo-nn_hls)
128	! - jperio=[56], grid=F : half of the last line (jpiglo/2+1:jpiglo-nn_hls-1)
129	! The order of the calculations may differ for these duplicated points (as, for example jj+1 becomes jj-1)
130	! This explain why these duplicated points may have different values even if they are at the exact same location.
131	! In consequence, we may want to force the folding on these points by setting l_full_nf_update = .TRUE.
132	! This is slightly slower but necessary to avoid different values on identical grid points!!
133	!
134	!!!!!!!!! temporary switch off this optimisation ==> force TRUE !!!!!!!!
135	!!!!!!!!! needed to get the same results without agrif and with agrif and no zoom !!!!!!!!
136	!!!!!!!!! I don't know why we must do that... !!!!!!!!
137	l_full_nf_update = .TRUE.
138	! also force it if not restart during the first 2 steps (leap frog?)
139	ll_add_line = l_full_nf_update .OR. ( ncom_stp <= nit000+1 .AND. .NOT. ln_rstart )
140
141	ALLOCATE(ipj_s(ipf)) ! how many lines do we exchange?
142	IF( ll_add_line ) THEN
143	DO jf = 1, ipf ! Loop over the number of arrays to be processed
144	ipj_s(jf) = nn_hls + COUNT( (/ npolj == 3 .OR. npolj == 4 .OR. NAT_IN(jf) == 'V' .OR. NAT_IN(jf) == 'F' /) )
145	END DO
146	ELSE
147	ipj_s(:) = nn_hls
148	ENDIF
149
150	ipj = MAXVAL(ipj_s(:)) ! Max 2nd dimension of message transfers
151	ipj_b = SUM( ipj_s(:)) ! Total number of lines to be exchanged
152	ALLOCATE( jj_s(ipj, ipf), jj_b(ipj, ipf) )
153
154	! Index of modifying lines in input
155	ij1 = 0
156	DO jf = 1, ipf ! Loop over the number of arrays to be processed
157	!
158	SELECT CASE ( npolj )
159	CASE ( 3, 4 ) ! * North fold T-point pivot
160	SELECT CASE ( NAT_IN(jf) )
161	CASE ( 'T', 'W', 'U' ) ; i012 = 1 ! T-, U-, W-point
162	CASE ( 'V', 'F' ) ; i012 = 2 ! V-, F-point
163	END SELECT
164	CASE ( 5, 6 ) ! * North fold F-point pivot
165	SELECT CASE ( NAT_IN(jf) )
166	CASE ( 'T', 'W', 'U' ) ; i012 = 0 ! T-, U-, W-point
167	CASE ( 'V', 'F' ) ; i012 = 1 ! V-, F-point
168	END SELECT
169	END SELECT
170	!
171	DO jj = 1, ipj_s(jf)
172	ij1 = ij1 + 1
173	jj_b(jj,jf) = ij1
174	jj_s(jj,jf) = jpj - 2*nn_hls + jj - i012
175	END DO
176	!
177	END DO
178	!
179	ALLOCATE( ztabb(jpimax,ipj_b,ipk,ipl) ) ! store all the data to be sent in a buffer array
180	ibuffsize = jpimax * ipj_b * ipk * ipl
181	!
182	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk
183	DO jj = 1, ipj_s(jf)
184	ij1 = jj_b(jj,jf)
185	ij2 = jj_s(jj,jf)
186	DO ji = 1, jpi
187	ztabb(ji,ij1,jk,jl) = ARRAY_IN(ji,ij2,jk,jl,jf)
188	END DO
189	DO ji = jpi+1, jpimax
190	ztabb(ji,ij1,jk,jl) = HUGEVAL(0.) ! avoid sending uninitialized values (make sure we don't use it)
191	END DO
192	END DO
193	END DO ; END DO ; END DO
194	!
195	! start waiting time measurement
196	IF( ln_timing ) CALL tic_tac(.TRUE.)
197	!
198	! send the data as soon as possible
199	DO jr = 1, nsndto
200	iproc = nfproc(isendto(jr))
201	IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN
202	CALL SENDROUTINE( 5, ztabb, ibuffsize, iproc, ml_req_nf(jr) )
203	ENDIF
204	END DO
205	!
206	ipimax = jpimax * jpmaxngh
207	ALLOCATE( ztabw(jpimax,ipj_b,ipk,ipl), ztabr(ipimax,ipj_b,ipk,ipl) )
208	!
209	DO jr = 1, nsndto
210	!
211	ipni = isendto(jr)
212	iproc = nfproc(ipni)
213	ipi = nfjpi (ipni)
214	!
215	IF( ipni == 1 ) THEN ; iis0 = 1 ! domain left side: as e-w comm already done -> from 1st column
216	ELSE ; iis0 = 1 + nn_hls ! default: -> from inner domain
217	ENDIF
218	IF( ipni == jpni ) THEN ; iie0 = ipi ! domain right side: as e-w comm already done -> until last column
219	ELSE ; iie0 = ipi - nn_hls ! default: -> until inner domain
220	ENDIF
221	impp = nfimpp(ipni) - nfimpp(isendto(1))
222	!
223	IF( iproc == -1 ) THEN ! No neighbour (land proc that was suppressed)
224	!
225	SELECT CASE ( kfillmode )
226	CASE ( jpfillnothing ) ! no filling
227	CASE ( jpfillcopy ) ! filling with inner domain values
228	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk
229	DO jj = 1, ipj_s(jf)
230	ij1 = jj_b(jj,jf)
231	ij2 = jj_s(jj,jf)
232	DO ji = iis0, iie0
233	ztabr(impp+ji,ij1,jk,jl) = ARRAY_IN(Nis0,ij2,jk,jl,jf) ! chose to take the 1st iner domain point
234	END DO
235	END DO
236	END DO ; END DO ; END DO
237	CASE ( jpfillcst ) ! filling with constant value
238	DO jl = 1, ipl ; DO jk = 1, ipk
239	DO jj = 1, ipj_b
240	DO ji = iis0, iie0
241	ztabr(impp+ji,jj,jk,jl) = pfillval
242	END DO
243	END DO
244	END DO ; END DO
245	END SELECT
246	!
247	ELSE IF( iproc == narea-1 ) THEN ! get data from myself!
248	!
249	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk
250	DO jj = 1, ipj_s(jf)
251	ij1 = jj_b(jj,jf)
252	ij2 = jj_s(jj,jf)
253	DO ji = iis0, iie0
254	ztabr(impp+ji,ij1,jk,jl) = ARRAY_IN(ji,ij2,jk,jl,jf)
255	END DO
256	END DO
257	END DO ; END DO ; END DO
258	!
259	ELSE ! get data from a neighbour trough communication
260	!
261	CALL RECVROUTINE(5, ztabw, ibuffsize, iproc)
262	DO jl = 1, ipl ; DO jk = 1, ipk
263	DO jj = 1, ipj_b
264	DO ji = iis0, iie0
265	ztabr(impp+ji,jj,jk,jl) = ztabw(ji,jj,jk,jl)
266	END DO
267	END DO
268	END DO ; END DO
269
270	ENDIF
271	!
272	END DO ! nsndto
273	!
274	IF( ln_timing ) CALL tic_tac(.FALSE.)
275	!
276	! North fold boundary condition
277	!
278	DO jf = 1, ipf
279	ij1 = jj_b( 1 ,jf)
280	ij2 = jj_b(ipj_s(jf),jf)
281	CALL lbc_nfd_nogather( ARRAY_IN(:,:,:,:,jf), ztabr(:,ij1:ij2,:,:), cd_nat LBC_ARG, psgn LBC_ARG )
282	END DO
283	!
284	DEALLOCATE( ztabr, ztabw, jj_s, jj_b, ipj_s )
285	!
286	DO jr = 1,nsndto
287	iproc = nfproc(isendto(jr))
288	IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN
289	CALL mpi_wait( ml_req_nf(jr), ml_stat, ml_err ) ! put the wait at the very end just before the deallocate
290	ENDIF
291	END DO
292	DEALLOCATE( ztabb )
293	!
294	ELSE !== allgather exchanges ==!
295	!
296	! how many lines do we exchange at max? -> ipj (no further optimizations in this case...)
297	ipj = nn_hls + 2
298	! how many lines do we need at max? -> ipj2 (no further optimizations in this case...)
299	ipj2 = 2 * nn_hls + 2
300	!
301	i0max = jpimax - 2 * nn_hls
302	ibuffsize = i0max * ipj * ipk * ipl * ipf
303	ALLOCATE( znorthloc(i0max,ipj,ipk,ipl,ipf), znorthglo(i0max,ipj,ipk,ipl,ipf,ndim_rank_north) )
304	!
305	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ! put in znorthloc ipj j-lines of ptab
306	DO jj = 1, ipj
307	ij2 = jpj - ipj2 + jj ! the first ipj lines of the last ipj2 lines
308	DO ji = 1, Ni_0
309	ii2 = Nis0 - 1 + ji ! inner domain: Nis0 to Nie0
310	znorthloc(ji,jj,jk,jl,jf) = ARRAY_IN(ii2,ij2,jk,jl,jf)
311	END DO
312	DO ji = Ni_0+1, i0max
313	znorthloc(ji,jj,jk,jl,jf) = HUGEVAL(0.) ! avoid sending uninitialized values (make sure we don't use it)
314	END DO
315	END DO
316	END DO ; END DO ; END DO
317	!
318	! start waiting time measurement
319	IF( ln_timing ) CALL tic_tac(.TRUE.)
320	#if defined key_mpp_mpi
321	CALL MPI_ALLGATHER( znorthloc, ibuffsize, MPI_TYPE, znorthglo, ibuffsize, MPI_TYPE, ncomm_north, ierr )
322	#endif
323	! stop waiting time measurement
324	IF( ln_timing ) CALL tic_tac(.FALSE.)
325	DEALLOCATE( znorthloc )
326	ALLOCATE( ztabglo(jpiglo,ipj2,ipk,ipl,ipf) )
327	!
328	! need to fill only the first ipj lines of ztabglo as lbc_nfd don't use the last nn_hls lines
329	ijnr = 0
330	DO jr = 1, jpni ! recover the global north array
331	iproc = nfproc(jr)
332	impp = nfimpp(jr)
333	ipi = nfjpi( jr) - 2 * nn_hls ! corresponds to Ni_0 but for subdomain iproc
334	IF( iproc == -1 ) THEN ! No neighbour (land proc that was suppressed)
335	!
336	SELECT CASE ( kfillmode )
337	CASE ( jpfillnothing ) ! no filling
338	CASE ( jpfillcopy ) ! filling with inner domain values
339	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk
340	DO jj = 1, ipj
341	ij2 = jpj - ipj2 + jj ! the first ipj lines of the last ipj2 lines
342	DO ji = 1, ipi
343	ii1 = impp + nn_hls + ji - 1 ! corresponds to mig(nn_hls + ji) but for subdomain iproc
344	ztabglo(ii1,jj,jk,jl,jf) = ARRAY_IN(Nis0,ij2,jk,jl,jf) ! chose to take the 1st iner domain point
345	END DO
346	END DO
347	END DO ; END DO ; END DO
348	CASE ( jpfillcst ) ! filling with constant value
349	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk
350	DO jj = 1, ipj
351	DO ji = 1, ipi
352	ii1 = impp + nn_hls + ji - 1 ! corresponds to mig(nn_hls + ji) but for subdomain iproc
353	ztabglo(ii1,jj,jk,jl,jf) = pfillval
354	END DO
355	END DO
356	END DO ; END DO ; END DO
357	END SELECT
358	!
359	ELSE
360	ijnr = ijnr + 1
361	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk
362	DO jj = 1, ipj
363	DO ji = 1, ipi
364	ii1 = impp + nn_hls + ji - 1 ! corresponds to mig(nn_hls + ji) but for subdomain iproc
365	ztabglo(ii1,jj,jk,jl,jf) = znorthglo(ji,jj,jk,jl,jf,ijnr)
366	END DO
367	END DO
368	END DO ; END DO ; END DO
369	ENDIF
370	!
371	END DO ! jpni
372	DEALLOCATE( znorthglo )
373	!
374	DO jf = 1, ipf
375	CALL lbc_nfd( ztabglo(:,:,:,:,jf), cd_nat LBC_ARG, psgn LBC_ARG ) ! North fold boundary condition
376	DO jl = 1, ipl ; DO jk = 1, ipk ! e-w periodicity
377	DO jj = 1, nn_hls + 1
378	ij1 = ipj2 - (nn_hls + 1) + jj ! need only the last nn_hls + 1 lines until ipj2
379	ztabglo( 1:nn_hls,ij1,jk,jl,jf) = ztabglo(jpiglo-2*nn_hls+1:jpiglo-nn_hls,ij1,jk,jl,jf)
380	ztabglo(jpiglo-nn_hls+1:jpiglo,ij1,jk,jl,jf) = ztabglo( nn_hls+1: 2*nn_hls,ij1,jk,jl,jf)
381	END DO
382	END DO ; END DO
383	END DO
384	!
385	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ! Scatter back to ARRAY_IN
386	DO jj = 1, nn_hls + 1
387	ij1 = jpj - (nn_hls + 1) + jj ! last nn_hls + 1 lines until jpj
388	ij2 = ipj2 - (nn_hls + 1) + jj ! last nn_hls + 1 lines until ipj2
389	DO ji= 1, jpi
390	ii2 = mig(ji)
391	ARRAY_IN(ji,ij1,jk,jl,jf) = ztabglo(ii2,ij2,jk,jl,jf)
392	END DO
393	END DO
394	END DO ; END DO ; END DO
395	!
396	DEALLOCATE( ztabglo )
397	!
398	ENDIF ! l_north_nogather
399	!
400	#endif
401	END SUBROUTINE ROUTINE_NFD
402
403	#undef PRECISION
404	#undef MPI_TYPE
405	#undef SENDROUTINE
406	#undef RECVROUTINE
407	#undef ARRAY_TYPE
408	#undef NAT_IN
409	#undef SGN_IN
410	#undef ARRAY_IN
411	#undef K_SIZE
412	#undef L_SIZE
413	#undef F_SIZE
414	#undef LBC_ARG
415	#undef HUGEVAL

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

Download in other formats: