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/2021/dev_r14312_MPI_Interface/src/OCE/LBC – NEMO

Context Navigation

source: NEMO/branches/2021/dev_r14312_MPI_Interface/src/OCE/LBC/mpp_nfd_generic.h90 @ 14349

Last change on this file since 14349 was 14349, checked in by smasson, 3 years ago
dev_r14312_MPI_Interface: further simplifications of lbclk and lbcnfd, #2598
Property svn:keywords set to `Id` Property svn:mime-type set to `text/x-fortran`
File size: 16.5 KB

Line
1
2	SUBROUTINE mpp_nfd_/**/PRECISION( ptab, cd_nat, psgn, kfillmode, pfillval, kfld )
3	TYPE(PTR_4d_/**/PRECISION), DIMENSION(:), INTENT(inout) :: ptab ! pointer of arrays on which apply the b.c.
4	CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: cd_nat ! nature of array grid-points
5	REAL(PRECISION), DIMENSION(:), INTENT(in ) :: psgn ! sign used across the north fold boundary
6	INTEGER , INTENT(in ) :: kfillmode ! filling method for halo over land
7	REAL(PRECISION) , INTENT(in ) :: pfillval ! background value (used at closed boundaries)
8	INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays
9	!
10	LOGICAL :: ll_add_line
11	INTEGER :: ji, jj, jk, jl, jh, jf, jr ! dummy loop indices
12	INTEGER :: ipi, ipj, ipj2, ipk, ipl, ipf ! dimension of the input array
13	INTEGER :: imigr, iihom, ijhom ! local integers
14	INTEGER :: ierr, ibuffsize, iis0, iie0, impp
15	INTEGER :: ii1, ii2, ij1, ij2
16	INTEGER :: ipimax, i0max
17	INTEGER :: ij, iproc, ipni, ijnr
18	INTEGER, DIMENSION (jpmaxngh) :: ml_req_nf ! for mpi_isend when avoiding mpi_allgather
19	INTEGER :: ml_err ! for mpi_isend when avoiding mpi_allgather
20	! ! Workspace for message transfers avoiding mpi_allgather
21	INTEGER :: ipj_b ! sum of lines for all multi fields
22	INTEGER :: i012 ! 0, 1 or 2
23	INTEGER , DIMENSION(:,:) , ALLOCATABLE :: jj_s ! position of sent lines
24	INTEGER , DIMENSION(:,:) , ALLOCATABLE :: jj_b ! position of buffer lines
25	INTEGER , DIMENSION(:) , ALLOCATABLE :: ipj_s ! number of sent lines
26	REAL(PRECISION), DIMENSION(:,:,:,:) , ALLOCATABLE :: ztabb, ztabr, ztabw ! buffer, receive and work arrays
27	REAL(PRECISION), DIMENSION(:,:,:,:,:) , ALLOCATABLE :: znorthloc
28	REAL(PRECISION), DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: znorthglo
29	TYPE(PTR_4D_/**/PRECISION), DIMENSION(:), ALLOCATABLE :: ztabglo ! array or pointer of arrays on which apply the b.c.
30	!!----------------------------------------------------------------------
31	!
32	ipk = SIZE(ptab(1)%pt4d,3)
33	ipl = SIZE(ptab(1)%pt4d,4)
34	ipf = kfld
35	!
36	IF( ln_nnogather ) THEN !== no allgather exchanges ==!
37
38	! --- define number of exchanged lines ---
39	!
40	! In theory we should exchange only nn_hls lines.
41	!
42	! However, some other points are duplicated in the north pole folding:
43	! - c_NFtype='T', grid=T : half of the last line (jpiglo/2+2:jpiglo-nn_hls)
44	! - c_NFtype='T', grid=U : half of the last line (jpiglo/2+1:jpiglo-nn_hls)
45	! - c_NFtype='T', grid=V : all the last line nn_hls+1 and (nn_hls+2:jpiglo-nn_hls)
46	! - c_NFtype='T', grid=F : all the last line (nn_hls+1:jpiglo-nn_hls)
47	! - c_NFtype='F', grid=T : 2 points of the last line (jpiglo/2+1 and jpglo-nn_hls)
48	! - c_NFtype='F', grid=U : no points are duplicated
49	! - c_NFtype='F', grid=V : half of the last line (jpiglo/2+1:jpiglo-nn_hls)
50	! - c_NFtype='F', grid=F : half of the last line (jpiglo/2+1:jpiglo-nn_hls-1)
51	! The order of the calculations may differ for these duplicated points (as, for example jj+1 becomes jj-1)
52	! This explain why these duplicated points may have different values even if they are at the exact same location.
53	! In consequence, we may want to force the folding on these points by setting l_full_nf_update = .TRUE.
54	! This is slightly slower but necessary to avoid different values on identical grid points!!
55	!
56	!!!!!!!!! temporary switch off this optimisation ==> force TRUE !!!!!!!!
57	!!!!!!!!! needed to get the same results without agrif and with agrif and no zoom !!!!!!!!
58	!!!!!!!!! I don't know why we must do that... !!!!!!!!
59	l_full_nf_update = .TRUE.
60	! also force it if not restart during the first 2 steps (leap frog?)
61	ll_add_line = l_full_nf_update .OR. ( ncom_stp <= nit000+1 .AND. .NOT. ln_rstart )
62
63	ALLOCATE(ipj_s(ipf)) ! how many lines do we exchange?
64	IF( ll_add_line ) THEN
65	DO jf = 1, ipf ! Loop over the number of arrays to be processed
66	ipj_s(jf) = nn_hls + COUNT( (/ c_NFtype == 'T' .OR. cd_nat(jf) == 'V' .OR. cd_nat(jf) == 'F' /) )
67	END DO
68	ELSE
69	ipj_s(:) = nn_hls
70	ENDIF
71
72	ipj = MAXVAL(ipj_s(:)) ! Max 2nd dimension of message transfers
73	ipj_b = SUM( ipj_s(:)) ! Total number of lines to be exchanged
74	ALLOCATE( jj_s(ipj, ipf), jj_b(ipj, ipf) )
75
76	! Index of modifying lines in input
77	ij1 = 0
78	DO jf = 1, ipf ! Loop over the number of arrays to be processed
79	!
80	IF( c_NFtype == 'T' ) THEN ! * North fold T-point pivot
81	SELECT CASE ( cd_nat(jf) )
82	CASE ( 'T', 'W', 'U' ) ; i012 = 1 ! T-, U-, W-point
83	CASE ( 'V', 'F' ) ; i012 = 2 ! V-, F-point
84	END SELECT
85	ENDIF
86	IF( c_NFtype == 'F' ) THEN ! * North fold F-point pivot
87	SELECT CASE ( cd_nat(jf) )
88	CASE ( 'T', 'W', 'U' ) ; i012 = 0 ! T-, U-, W-point
89	CASE ( 'V', 'F' ) ; i012 = 1 ! V-, F-point
90	END SELECT
91	ENDIF
92	!
93	DO jj = 1, ipj_s(jf)
94	ij1 = ij1 + 1
95	jj_b(jj,jf) = ij1
96	jj_s(jj,jf) = jpj - 2*nn_hls + jj - i012
97	END DO
98	!
99	END DO
100	!
101	ALLOCATE( ztabb(jpimax,ipj_b,ipk,ipl) ) ! store all the data to be sent in a buffer array
102	ibuffsize = jpimax * ipj_b * ipk * ipl
103	!
104	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk
105	DO jj = 1, ipj_s(jf)
106	ij1 = jj_b(jj,jf)
107	ij2 = jj_s(jj,jf)
108	DO ji = 1, jpi
109	ztabb(ji,ij1,jk,jl) = ptab(jf)%pt4d(ji,ij2,jk,jl)
110	END DO
111	DO ji = jpi+1, jpimax
112	ztabb(ji,ij1,jk,jl) = HUGE(0._/**/PRECISION) ! avoid sending uninitialized values (make sure we don't use it)
113	END DO
114	END DO
115	END DO ; END DO ; END DO
116	!
117	! start waiting time measurement
118	IF( ln_timing ) CALL tic_tac(.TRUE.)
119	!
120	! send the data as soon as possible
121	DO jr = 1, nsndto
122	iproc = nfproc(isendto(jr))
123	IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN
124	#if ! defined key_mpi_off
125	CALL MPI_ISEND( ztabb, ibuffsize, MPI_TYPE, iproc, 5, mpi_comm_oce, ml_req_nf(jr), ierr )
126	#endif
127	ENDIF
128	END DO
129	!
130	ipimax = jpimax * jpmaxngh
131	ALLOCATE( ztabw(jpimax,ipj_b,ipk,ipl), ztabr(ipimax,ipj_b,ipk,ipl) )
132	!
133	DO jr = 1, nsndto
134	!
135	ipni = isendto(jr)
136	iproc = nfproc(ipni)
137	ipi = nfjpi (ipni)
138	!
139	IF( ipni == 1 ) THEN ; iis0 = 1 ! domain left side: as e-w comm already done -> from 1st column
140	ELSE ; iis0 = 1 + nn_hls ! default: -> from inner domain
141	ENDIF
142	IF( ipni == jpni ) THEN ; iie0 = ipi ! domain right side: as e-w comm already done -> until last column
143	ELSE ; iie0 = ipi - nn_hls ! default: -> until inner domain
144	ENDIF
145	impp = nfimpp(ipni) - nfimpp(isendto(1))
146	!
147	IF( iproc == -1 ) THEN ! No neighbour (land proc that was suppressed)
148	!
149	SELECT CASE ( kfillmode )
150	CASE ( jpfillnothing ) ! no filling
151	CASE ( jpfillcopy ) ! filling with inner domain values
152	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk
153	DO jj = 1, ipj_s(jf)
154	ij1 = jj_b(jj,jf)
155	ij2 = jj_s(jj,jf)
156	DO ji = iis0, iie0
157	ztabr(impp+ji,ij1,jk,jl) = ptab(jf)%pt4d(Nis0,ij2,jk,jl) ! chose to take the 1st iner domain point
158	END DO
159	END DO
160	END DO ; END DO ; END DO
161	CASE ( jpfillcst ) ! filling with constant value
162	DO jl = 1, ipl ; DO jk = 1, ipk
163	DO jj = 1, ipj_b
164	DO ji = iis0, iie0
165	ztabr(impp+ji,jj,jk,jl) = pfillval
166	END DO
167	END DO
168	END DO ; END DO
169	END SELECT
170	!
171	ELSE IF( iproc == narea-1 ) THEN ! get data from myself!
172	!
173	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk
174	DO jj = 1, ipj_s(jf)
175	ij1 = jj_b(jj,jf)
176	ij2 = jj_s(jj,jf)
177	DO ji = iis0, iie0
178	ztabr(impp+ji,ij1,jk,jl) = ptab(jf)%pt4d(ji,ij2,jk,jl)
179	END DO
180	END DO
181	END DO ; END DO ; END DO
182	!
183	ELSE ! get data from a neighbour trough communication
184	!
185	#if ! defined key_mpi_off
186	CALL MPI_RECV( ztabw, ibuffsize, MPI_TYPE, iproc, 5, mpi_comm_oce, MPI_STATUS_IGNORE, ierr )
187	#endif
188	DO jl = 1, ipl ; DO jk = 1, ipk
189	DO jj = 1, ipj_b
190	DO ji = iis0, iie0
191	ztabr(impp+ji,jj,jk,jl) = ztabw(ji,jj,jk,jl)
192	END DO
193	END DO
194	END DO ; END DO
195
196	ENDIF
197	!
198	END DO ! nsndto
199	!
200	IF( ln_timing ) CALL tic_tac(.FALSE.)
201	!
202	! North fold boundary condition
203	!
204	DO jf = 1, ipf
205	ij1 = jj_b( 1 ,jf)
206	ij2 = jj_b(ipj_s(jf),jf)
207	CALL lbc_nfd_nogather( ptab(jf)%pt4d(:,:,:,:), ztabr(:,ij1:ij2,:,:), cd_nat(jf), psgn(jf) )
208	END DO
209	!
210	DEALLOCATE( ztabr, ztabw, jj_s, jj_b, ipj_s )
211	!
212	DO jr = 1,nsndto
213	iproc = nfproc(isendto(jr))
214	IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN
215	CALL mpi_wait( ml_req_nf(jr), MPI_STATUS_IGNORE, ml_err ) ! put the wait at the very end just before the deallocate
216	ENDIF
217	END DO
218	DEALLOCATE( ztabb )
219	!
220	ELSE !== allgather exchanges ==!
221	!
222	! how many lines do we exchange at max? -> ipj (no further optimizations in this case...)
223	ipj = nn_hls + 2
224	! how many lines do we need at max? -> ipj2 (no further optimizations in this case...)
225	ipj2 = 2 * nn_hls + 2
226	!
227	i0max = jpimax - 2 * nn_hls
228	ibuffsize = i0max * ipj * ipk * ipl * ipf
229	ALLOCATE( znorthloc(i0max,ipj,ipk,ipl,ipf), znorthglo(i0max,ipj,ipk,ipl,ipf,ndim_rank_north) )
230	!
231	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ! put in znorthloc ipj j-lines of ptab
232	DO jj = 1, ipj
233	ij2 = jpj - ipj2 + jj ! the first ipj lines of the last ipj2 lines
234	DO ji = 1, Ni_0
235	ii2 = Nis0 - 1 + ji ! inner domain: Nis0 to Nie0
236	znorthloc(ji,jj,jk,jl,jf) = ptab(jf)%pt4d(ii2,ij2,jk,jl)
237	END DO
238	DO ji = Ni_0+1, i0max
239	znorthloc(ji,jj,jk,jl,jf) = HUGE(0._/**/PRECISION) ! avoid sending uninitialized values (make sure we don't use it)
240	END DO
241	END DO
242	END DO ; END DO ; END DO
243	!
244	! start waiting time measurement
245	IF( ln_timing ) CALL tic_tac(.TRUE.)
246	#if ! defined key_mpi_off
247	CALL MPI_ALLGATHER( znorthloc, ibuffsize, MPI_TYPE, znorthglo, ibuffsize, MPI_TYPE, ncomm_north, ierr )
248	#endif
249	! stop waiting time measurement
250	IF( ln_timing ) CALL tic_tac(.FALSE.)
251	DEALLOCATE( znorthloc )
252	ALLOCATE( ztabglo(ipf) )
253	DO jf = 1, ipf
254	ALLOCATE( ztabglo(jf)%pt4d(jpiglo,ipj2,ipk,ipl) )
255	END DO
256	!
257	! need to fill only the first ipj lines of ztabglo as lbc_nfd don't use the last nn_hls lines
258	ijnr = 0
259	DO jr = 1, jpni ! recover the global north array
260	iproc = nfproc(jr)
261	impp = nfimpp(jr)
262	ipi = nfjpi( jr) - 2 * nn_hls ! corresponds to Ni_0 but for subdomain iproc
263	IF( iproc == -1 ) THEN ! No neighbour (land proc that was suppressed)
264	!
265	SELECT CASE ( kfillmode )
266	CASE ( jpfillnothing ) ! no filling
267	CASE ( jpfillcopy ) ! filling with inner domain values
268	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk
269	DO jj = 1, ipj
270	ij2 = jpj - ipj2 + jj ! the first ipj lines of the last ipj2 lines
271	DO ji = 1, ipi
272	ii1 = impp + nn_hls + ji - 1 ! corresponds to mig(nn_hls + ji) but for subdomain iproc
273	ztabglo(jf)%pt4d(ii1,jj,jk,jl) = ptab(jf)%pt4d(Nis0,ij2,jk,jl) ! chose to take the 1st inner domain point
274	END DO
275	END DO
276	END DO ; END DO ; END DO
277	CASE ( jpfillcst ) ! filling with constant value
278	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk
279	DO jj = 1, ipj
280	DO ji = 1, ipi
281	ii1 = impp + nn_hls + ji - 1 ! corresponds to mig(nn_hls + ji) but for subdomain iproc
282	ztabglo(jf)%pt4d(ii1,jj,jk,jl) = pfillval
283	END DO
284	END DO
285	END DO ; END DO ; END DO
286	END SELECT
287	!
288	ELSE
289	ijnr = ijnr + 1
290	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk
291	DO jj = 1, ipj
292	DO ji = 1, ipi
293	ii1 = impp + nn_hls + ji - 1 ! corresponds to mig(nn_hls + ji) but for subdomain iproc
294	ztabglo(jf)%pt4d(ii1,jj,jk,jl) = znorthglo(ji,jj,jk,jl,jf,ijnr)
295	END DO
296	END DO
297	END DO ; END DO ; END DO
298	ENDIF
299	!
300	END DO ! jpni
301	DEALLOCATE( znorthglo )
302	!
303	DO jf = 1, ipf
304	CALL lbc_nfd( ztabglo(jf:jf), cd_nat(jf:jf), psgn(jf:jf), 1 ) ! North fold boundary condition
305	DO jl = 1, ipl ; DO jk = 1, ipk ! e-w periodicity
306	DO jj = 1, nn_hls + 1
307	ij1 = ipj2 - (nn_hls + 1) + jj ! need only the last nn_hls + 1 lines until ipj2
308	ztabglo(jf)%pt4d( 1:nn_hls,ij1,jk,jl) = ztabglo(jf)%pt4d(jpiglo-2*nn_hls+1:jpiglo-nn_hls,ij1,jk,jl)
309	ztabglo(jf)%pt4d(jpiglo-nn_hls+1:jpiglo,ij1,jk,jl) = ztabglo(jf)%pt4d( nn_hls+1: 2*nn_hls,ij1,jk,jl)
310	END DO
311	END DO ; END DO
312	END DO
313	!
314	DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ! Scatter back to ARRAY_IN
315	DO jj = 1, nn_hls + 1
316	ij1 = jpj - (nn_hls + 1) + jj ! last nn_hls + 1 lines until jpj
317	ij2 = ipj2 - (nn_hls + 1) + jj ! last nn_hls + 1 lines until ipj2
318	DO ji= 1, jpi
319	ii2 = mig(ji)
320	ptab(jf)%pt4d(ji,ij1,jk,jl) = ztabglo(jf)%pt4d(ii2,ij2,jk,jl)
321	END DO
322	END DO
323	END DO ; END DO ; END DO
324	!
325	DO jf = 1, ipf
326	DEALLOCATE( ztabglo(jf)%pt4d )
327	END DO
328	DEALLOCATE( ztabglo )
329	!
330	ENDIF ! l_north_nogather
331	!
332	END SUBROUTINE mpp_nfd_/**/PRECISION
333

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

Download in other formats: