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_r12558_HPC-08_epico_Extra_Halo/src/OCE/LBC – NEMO

Context Navigation

source: NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/LBC/mpp_nfd_generic.h90 @ 12992

Last change on this file since 12992 was 12992, checked in by francesca, 5 years ago
Extra_Halo: BENCH test case with halo 2 - verified version - ticket #2366
Property svn:keywords set to `Id` Property svn:mime-type set to `text/x-fortran`
File size: 13.5 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	# 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	! !== IN: ptab is an array ==!
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 F_SIZE(ptab) 1
30	# define LBC_ARG
31	# if defined DIM_2d
32	# define ARRAY_IN(i,j,k,l,f) ptab(i,j)
33	# define K_SIZE(ptab) 1
34	# define L_SIZE(ptab) 1
35	# endif
36	# if defined DIM_3d
37	# define ARRAY_IN(i,j,k,l,f) ptab(i,j,k)
38	# define K_SIZE(ptab) SIZE(ptab,3)
39	# define L_SIZE(ptab) 1
40	# endif
41	# if defined DIM_4d
42	# define ARRAY_IN(i,j,k,l,f) ptab(i,j,k,l)
43	# define K_SIZE(ptab) SIZE(ptab,3)
44	# define L_SIZE(ptab) SIZE(ptab,4)
45	# endif
46	#endif
47
48	SUBROUTINE ROUTINE_NFD( ptab, cd_nat, psgn, kfld )
49	!!----------------------------------------------------------------------
50	ARRAY_TYPE(:,:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied
51	CHARACTER(len=1) , INTENT(in ) :: NAT_IN(:) ! nature of array grid-points
52	REAL(wp) , INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary
53	INTEGER, OPTIONAL, INTENT(in ) :: kfld ! number of pt3d arrays
54	!
55	INTEGER :: ji, jj, jk, jl, jh, jf, jr ! dummy loop indices
56	INTEGER :: ipi, ipk, ipl, ipf ! dimension of the input array
57	INTEGER :: imigr, iihom, ijhom ! local integers
58	INTEGER :: ierr, ibuffsize, ijpi, iis0, iie0, iilb
59	INTEGER :: ij, iproc
60	INTEGER, DIMENSION (jpmaxngh) :: ml_req_nf ! for mpi_isend when avoiding mpi_allgather
61	INTEGER :: ml_err ! for mpi_isend when avoiding mpi_allgather
62	INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for mpi_isend when avoiding mpi_allgather
63	! ! Workspace for message transfers avoiding mpi_allgather
64	INTEGER :: ipf_j ! sum of lines for all multi fields
65	INTEGER :: js ! counter
66	INTEGER, DIMENSION(:,:), ALLOCATABLE :: jj_s ! position of sent lines
67	INTEGER, DIMENSION(:), ALLOCATABLE :: ipj_s ! number of sent lines
68	REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: ztabl
69	REAL(wp), DIMENSION(:,:,:,:,:) , ALLOCATABLE :: ztab, ztabr
70	REAL(wp), DIMENSION(:,:,:,:,:) , ALLOCATABLE :: znorthloc, zfoldwk
71	REAL(wp), DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: znorthgloio
72	!!----------------------------------------------------------------------
73	!
74	ipk = K_SIZE(ptab) ! 3rd dimension
75	ipl = L_SIZE(ptab) ! 4th -
76	ipf = F_SIZE(ptab) ! 5th - use in "multi" case (array of pointers)
77	!
78	IF( l_north_nogather ) THEN !== no allgather exchanges ==!
79
80	ALLOCATE(ipj_s(ipf))
81
82	ijpj = 2 + nn_hls -1 ! Max 2nd dimension of message transfers (last two j-line only)
83	ipj_s(:) = 1 + nn_hls -1 ! Real 2nd dimension of message transfers (depending on perf requirement)
84	! by default, only one line is exchanged
85
86	ALLOCATE( jj_s(ipf,ijpj) )
87
88	! re-define number of exchanged lines :
89	! must be two during the first two time steps
90	! to correct possible incoherent values on North fold lines from restart
91
92	!!!!!!!!! temporary switch off this optimisation ==> force TRUE !!!!!!!!
93	!!!!!!!!! needed to get the same results without agrif and with agrif and no zoom !!!!!!!!
94	!!!!!!!!! I don't know why we must do that... !!!!!!!!
95	l_full_nf_update = .TRUE.
96
97	! Two lines update (slower but necessary to avoid different values ion identical grid points
98	IF ( l_full_nf_update .OR. & ! if coupling fields
99	( ncom_stp == nit000 .AND. .NOT. ln_rstart ) ) & ! at first time step, if not restart
100	ipj_s(:) = 2 + nn_hls -1
101
102	! Index of modifying lines in input
103	DO jf = 1, ipf ! Loop over the number of arrays to be processed
104	!
105	SELECT CASE ( npolj )
106	!
107	CASE ( 3, 4 ) ! * North fold T-point pivot
108	!
109	SELECT CASE ( NAT_IN(jf) )
110	!
111	CASE ( 'T' , 'W' ,'U' ) ! T-, U-, W-point
112	DO ji = 1, nn_hls+1
113	jj_s(jf,ji) = jpj - 2*nn_hls +ji -1
114	ENDDO
115	CASE ( 'V' , 'F' ) ! V-, F-point
116	DO ji = 1, nn_hls+1
117	jj_s(jf,ji) = jpj - 2*nn_hls +ji - 2
118	ENDDO
119	END SELECT
120	!
121	CASE ( 5, 6 ) ! * North fold F-point pivot
122	SELECT CASE ( NAT_IN(jf) )
123	!
124	CASE ( 'T' , 'W' ,'U' ) ! T-, U-, W-point
125	DO ji = 1, nn_hls
126	jj_s(jf,ji) = jpj - 2*nn_hls + ji
127	ENDDO
128	ipj_s(jf) = nn_hls ! need only one line anyway
129	CASE ( 'V' , 'F' ) ! V-, F-point
130	DO ji = 1, nn_hls+1
131	jj_s(jf,ji) = jpj - 2*nn_hls +ji -1
132	ENDDO
133	END SELECT
134	!
135	END SELECT
136	!
137	ENDDO
138	!
139	ipf_j = sum (ipj_s(:)) ! Total number of lines to be exchanged
140	!
141	ALLOCATE( znorthloc(jpimax,ipf_j,ipk,ipl,1) )
142	!
143	js = 0
144	DO jf = 1, ipf ! Loop over the number of arrays to be processed
145	DO jj = 1, ipj_s(jf)
146	js = js + 1
147	DO jl = 1, ipl
148	DO jk = 1, ipk
149	znorthloc(1:jpi,js,jk,jl,1) = ARRAY_IN(1:jpi,jj_s(jf,jj),jk,jl,jf)
150	END DO
151	END DO
152	END DO
153	END DO
154	!
155	ibuffsize = jpimax * ipf_j * ipk * ipl
156	!
157	ALLOCATE( zfoldwk(jpimax,ipf_j,ipk,ipl,1) )
158	ALLOCATE( ztabr(jpimax*jpmaxngh,ijpj,ipk,ipl,ipf) )
159	! when some processors of the north fold are suppressed,
160	! values of ztab* arrays corresponding to these suppressed domain won't be defined
161	! and we need a default definition to 0.
162	! a better test should be: a testing if "suppressed land-processors" belongs to the north-pole folding
163	IF ( jpni*jpnj /= jpnij ) ztabr(:,:,:,:,:) = 0._wp
164	!
165	! start waiting time measurement
166	IF( ln_timing ) CALL tic_tac(.TRUE.)
167	!
168	DO jr = 1, nsndto
169	IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN
170	CALL mppsend( 5, znorthloc, ibuffsize, nfipproc(isendto(jr),jpnj), ml_req_nf(jr) )
171	ENDIF
172	END DO
173	!
174	DO jr = 1,nsndto
175	iproc = nfipproc(isendto(jr),jpnj)
176	IF(iproc /= -1) THEN
177	iilb = nimppt(iproc+1)
178	ijpi = jpiall(iproc+1)
179	iis0 = nis0all(iproc+1)
180	iie0 = nie0all(iproc+1)
181	IF( iilb == 1 ) iis0 = 1 ! e-w boundary already done -> force to take 1st column
182	IF( iilb + ijpi - 1 == jpiglo ) iie0 = ijpi ! e-w boundary already done -> force to take last column
183	iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj)
184	ENDIF
185	IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN
186	CALL mpprecv(5, zfoldwk, ibuffsize, iproc)
187	js = 0
188	DO jf = 1, ipf ; DO jj = 1, ipj_s(jf)
189	js = js + 1
190	DO jl = 1, ipl
191	DO jk = 1, ipk
192	DO ji = iis0, iie0
193	ztabr(iilb+ji,jj,jk,jl,jf) = zfoldwk(ji,js,jk,jl,1)
194	END DO
195	END DO
196	END DO
197	END DO; END DO
198	ELSE IF( iproc == narea-1 ) THEN
199	DO jf = 1, ipf ; DO jj = 1, ipj_s(jf)
200	DO jl = 1, ipl
201	DO jk = 1, ipk
202	DO ji = iis0, iie0
203	ztabr(iilb+ji,jj,jk,jl,jf) = ARRAY_IN(ji,jj_s(jf,jj),jk,jl,jf)
204	END DO
205	END DO
206	END DO
207	END DO; END DO
208	ENDIF
209	END DO
210	DO jr = 1,nsndto
211	IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN
212	CALL mpi_wait( ml_req_nf(jr), ml_stat, ml_err )
213	ENDIF
214	END DO
215	!
216	IF( ln_timing ) CALL tic_tac(.FALSE.)
217	!
218	! North fold boundary condition
219	!
220	DO jf = 1, ipf
221	CALL lbc_nfd_nogather( ARRAY_IN(:,:,:,:,jf), ztabr(:,1:ipj_s(jf),:,:,jf), cd_nat LBC_ARG, psgn LBC_ARG )
222	END DO
223	!
224	DEALLOCATE( zfoldwk, ztabr, jj_s, ipj_s )
225	!
226	ELSE !== allgather exchanges ==!
227	!
228	ijpj = 4 ! 2nd dimension of message transfers (last j-lines)
229	!
230	ALLOCATE( znorthloc(jpimax,ijpj,ipk,ipl,ipf) )
231	!
232	DO jf = 1, ipf ! put in znorthloc the last ijpj j-lines of ptab
233	DO jl = 1, ipl
234	DO jk = 1, ipk
235	DO jj = jpj - ijpj +1, jpj
236	ij = jj - jpj + ijpj
237	znorthloc(1:jpi,ij,jk,jl,jf) = ARRAY_IN(1:jpi,jj,jk,jl,jf)
238	END DO
239	END DO
240	END DO
241	END DO
242	!
243	ibuffsize = jpimax * ijpj * ipk * ipl * ipf
244	!
245	ALLOCATE( ztab (jpiglo,ijpj,ipk,ipl,ipf ) )
246	ALLOCATE( znorthgloio(jpimax,ijpj,ipk,ipl,ipf,jpni) )
247	!
248	! when some processors of the north fold are suppressed,
249	! values of ztab* arrays corresponding to these suppressed domain won't be defined
250	! and we need a default definition to 0.
251	! a better test should be: a testing if "suppressed land-processors" belongs to the north-pole folding
252	IF ( jpni*jpnj /= jpnij ) ztab(:,:,:,:,:) = 0._wp
253	!
254	! start waiting time measurement
255	IF( ln_timing ) CALL tic_tac(.TRUE.)
256	CALL MPI_ALLGATHER( znorthloc , ibuffsize, MPI_DOUBLE_PRECISION, &
257	& znorthgloio, ibuffsize, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
258	!
259	! stop waiting time measurement
260	IF( ln_timing ) CALL tic_tac(.FALSE.)
261	!
262	DO jr = 1, ndim_rank_north ! recover the global north array
263	iproc = nrank_north(jr) + 1
264	iilb = nimppt(iproc)
265	ijpi = jpiall(iproc)
266	iis0 = nis0all(iproc)
267	iie0 = nie0all(iproc)
268	IF( iilb == 1 ) iis0 = 1 ! e-w boundary already done -> force to take 1st column
269	IF( iilb + ijpi - 1 == jpiglo ) iie0 = ijpi ! e-w boundary already done -> force to take last column
270	DO jf = 1, ipf
271	DO jl = 1, ipl
272	DO jk = 1, ipk
273	DO jj = 1, ijpj
274	DO ji = iis0, iie0
275	ztab(ji+iilb-1,jj,jk,jl,jf) = znorthgloio(ji,jj,jk,jl,jf,jr)
276	END DO
277	END DO
278	END DO
279	END DO
280	END DO
281	END DO
282	DO jf = 1, ipf
283	CALL lbc_nfd( ztab(:,:,:,:,jf), cd_nat LBC_ARG, psgn LBC_ARG ) ! North fold boundary condition
284	END DO
285	!
286	DO jf = 1, ipf
287	DO jl = 1, ipl
288	DO jk = 1, ipk
289	DO jj = jpj-ijpj+1, jpj ! Scatter back to ARRAY_IN
290	ij = jj - jpj + ijpj
291	DO ji= 1, jpi
292	ARRAY_IN(ji,jj,jk,jl,jf) = ztab(ji+nimpp-1,ij,jk,jl,jf)
293	END DO
294	END DO
295	END DO
296	END DO
297	END DO
298	!
299	!
300	DEALLOCATE( ztab )
301	DEALLOCATE( znorthgloio )
302	ENDIF
303	!
304	DEALLOCATE( znorthloc )
305	!
306	END SUBROUTINE ROUTINE_NFD
307
308	#undef ARRAY_TYPE
309	#undef NAT_IN
310	#undef SGN_IN
311	#undef ARRAY_IN
312	#undef K_SIZE
313	#undef L_SIZE
314	#undef F_SIZE
315	#undef LBC_ARG

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

Download in other formats: