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.

lbc_nfd_nogather_generic.h90 in NEMO/branches/UKMO/dev_r9950_GO6_mixing/src/OCE/LBC – NEMO

Context Navigation

source: NEMO/branches/UKMO/dev_r9950_GO6_mixing/src/OCE/LBC/lbc_nfd_nogather_generic.h90 @ 10323

Last change on this file since 10323 was 10323, checked in by davestorkey, 5 years ago
UKMO/dev_r9950_GO6_mixing: Update to be relative to rev 10321 of NEMO4_beta_mirror branch.
Property svn:keywords set to `Id` Property svn:mime-type set to `text/x-fortran`
File size: 14.8 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	# if defined DIM_2d
6	# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D),INTENT(inout)::ptab(f)
7	# define ARRAY_IN(i,j,k,l,f) ptab(f)%pt2d(i,j)
8	# define K_SIZE(ptab) 1
9	# define L_SIZE(ptab) 1
10	# define ARRAY2_TYPE(i,j,k,l,f) TYPE(PTR_2D),INTENT(inout)::ptab2(f)
11	# define ARRAY2_IN(i,j,k,l,f) ptab2(f)%pt2d(i,j)
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	# define ARRAY2_TYPE(i,j,k,l,f) TYPE(PTR_3D),INTENT(inout)::ptab2(f)
19	# define ARRAY2_IN(i,j,k,l,f) ptab2(f)%pt3d(i,j,k)
20	# endif
21	# if defined DIM_4d
22	# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D),INTENT(inout)::ptab(f)
23	# define ARRAY_IN(i,j,k,l,f) ptab(f)%pt4d(i,j,k,l)
24	# define K_SIZE(ptab) SIZE(ptab(1)%pt4d,3)
25	# define L_SIZE(ptab) SIZE(ptab(1)%pt4d,4)
26	# define ARRAY2_TYPE(i,j,k,l,f) TYPE(PTR_4D),INTENT(inout)::ptab2(f)
27	# define ARRAY2_IN(i,j,k,l,f) ptab2(f)%pt4d(i,j,k,l)
28	# endif
29	#else
30	! !== IN: ptab is an array ==!
31	# define NAT_IN(k) cd_nat
32	# define SGN_IN(k) psgn
33	# define F_SIZE(ptab) 1
34	# if defined DIM_2d
35	# define ARRAY_IN(i,j,k,l,f) ptab(i,j)
36	# define K_SIZE(ptab) 1
37	# define L_SIZE(ptab) 1
38	# define ARRAY2_IN(i,j,k,l,f) ptab2(i,j)
39	# endif
40	# if defined DIM_3d
41	# define ARRAY_IN(i,j,k,l,f) ptab(i,j,k)
42	# define K_SIZE(ptab) SIZE(ptab,3)
43	# define L_SIZE(ptab) 1
44	# define ARRAY2_IN(i,j,k,l,f) ptab2(i,j,k)
45	# endif
46	# if defined DIM_4d
47	# define ARRAY_IN(i,j,k,l,f) ptab(i,j,k,l)
48	# define K_SIZE(ptab) SIZE(ptab,3)
49	# define L_SIZE(ptab) SIZE(ptab,4)
50	# define ARRAY2_IN(i,j,k,l,f) ptab2(i,j,k,l)
51	# endif
52	# define ARRAY_TYPE(i,j,k,l,f) REAL(wp),INTENT(inout)::ARRAY_IN(i,j,k,l,f)
53	# define ARRAY2_TYPE(i,j,k,l,f) REAL(wp),INTENT(inout)::ARRAY2_IN(i,j,k,l,f)
54	#endif
55
56	SUBROUTINE ROUTINE_NFD( ptab, ptab2, cd_nat, psgn, kfld )
57	!!----------------------------------------------------------------------
58	!!
59	!! ** Purpose : lateral boundary condition : North fold treatment
60	!! without allgather exchanges.
61	!!
62	!!----------------------------------------------------------------------
63	ARRAY_TYPE(:,:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied
64	ARRAY2_TYPE(:,:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied
65	CHARACTER(len=1) , INTENT(in ) :: NAT_IN(:) ! nature of array grid-points
66	REAL(wp) , INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary
67	INTEGER, OPTIONAL, INTENT(in ) :: kfld ! number of pt3d arrays
68	!
69	INTEGER :: ji, jj, jk, jl, jh, jf ! dummy loop indices
70	INTEGER :: ipi, ipj, ipk, ipl, ipf ! dimension of the input array
71	INTEGER :: ijt, iju, ijpj, ijpjm1, ijta, ijua, jia, startloop, endloop
72	!!----------------------------------------------------------------------
73	ipk = K_SIZE(ptab) ! 3rd dimension
74	ipl = L_SIZE(ptab) ! 4th -
75	ipf = F_SIZE(ptab) ! 5th - use in "multi" case (array of pointers)
76	!
77	!
78	SELECT CASE ( jpni )
79	CASE ( 1 ) ; ijpj = nlcj ! 1 proc only along the i-direction
80	CASE DEFAULT ; ijpj = 4 ! several proc along the i-direction
81	END SELECT
82	ijpjm1 = ijpj-1
83	!
84	!
85	DO jf = 1, ipf ! Loop over the number of arrays to be processed
86	!
87	SELECT CASE ( npolj )
88	!
89	CASE ( 3, 4 ) ! * North fold T-point pivot
90	!
91	SELECT CASE ( NAT_IN(jf) )
92	!
93	CASE ( 'T' , 'W' ) ! T-, W-point
94	IF ( nimpp /= 1 ) THEN ; startloop = 1
95	ELSE ; startloop = 2
96	ENDIF
97	!
98	DO ji = startloop, nlci
99	ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4
100	ARRAY_IN(ji,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj-2,:,:,jf)
101	END DO
102	IF( nimpp == 1 ) THEN
103	ARRAY_IN(1,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(3,ijpj-2,:,:,jf)
104	ENDIF
105	!
106	IF( nimpp >= jpiglo/2+1 ) THEN
107	startloop = 1
108	ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN
109	startloop = jpiglo/2+1 - nimpp + 1
110	ELSE
111	startloop = nlci + 1
112	ENDIF
113	IF( startloop <= nlci ) THEN
114	DO ji = startloop, nlci
115	ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4
116	jia = ji + nimpp - 1
117	ijta = jpiglo - jia + 2
118	IF( ijta >= startloop+nimpp-1 .AND. ijta < jia ) THEN
119	ARRAY_IN(ji,ijpjm1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijta-nimpp+1,ijpjm1,:,:,jf)
120	ELSE
121	ARRAY_IN(ji,ijpjm1,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpjm1,:,:,jf)
122	ENDIF
123	END DO
124	ENDIF
125	!
126	CASE ( 'U' ) ! U-point
127	IF( nimpp + nlci - 1 /= jpiglo ) THEN
128	endloop = nlci
129	ELSE
130	endloop = nlci - 1
131	ENDIF
132	DO ji = 1, endloop
133	iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
134	ARRAY_IN(ji,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj-2,:,:,jf)
135	END DO
136	IF (nimpp .eq. 1) THEN
137	ARRAY_IN( 1 ,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY_IN( 2 ,ijpj-2,:,:,jf)
138	ENDIF
139	IF((nimpp + nlci - 1) .eq. jpiglo) THEN
140	ARRAY_IN(nlci,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(nlci-1,ijpj-2,:,:,jf)
141	ENDIF
142	!
143	IF( nimpp + nlci - 1 /= jpiglo ) THEN
144	endloop = nlci
145	ELSE
146	endloop = nlci - 1
147	ENDIF
148	IF( nimpp >= jpiglo/2 ) THEN
149	startloop = 1
150	ELSEIF( ( nimpp+nlci-1 >= jpiglo/2 ) .AND. ( nimpp < jpiglo/2 ) ) THEN
151	startloop = jpiglo/2 - nimpp + 1
152	ELSE
153	startloop = endloop + 1
154	ENDIF
155	IF( startloop <= endloop ) THEN
156	DO ji = startloop, endloop
157	iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
158	jia = ji + nimpp - 1
159	ijua = jpiglo - jia + 1
160	IF( ijua >= startloop+nimpp-1 .AND. ijua < jia ) THEN
161	ARRAY_IN(ji,ijpjm1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijua-nimpp+1,ijpjm1,:,:,jf)
162	ELSE
163	ARRAY_IN(ji,ijpjm1,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpjm1,:,:,jf)
164	ENDIF
165	END DO
166	ENDIF
167	!
168	CASE ( 'V' ) ! V-point
169	IF( nimpp /= 1 ) THEN
170	startloop = 1
171	ELSE
172	startloop = 2
173	ENDIF
174	DO ji = startloop, nlci
175	ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4
176	ARRAY_IN(ji,ijpj-1,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj-2,:,:,jf)
177	ARRAY_IN(ji,ijpj ,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj-3,:,:,jf)
178	END DO
179	IF (nimpp .eq. 1) THEN
180	ARRAY_IN(1,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(3,ijpj-3,:,:,jf)
181	ENDIF
182	CASE ( 'F' ) ! F-point
183	IF( nimpp + nlci - 1 /= jpiglo ) THEN
184	endloop = nlci
185	ELSE
186	endloop = nlci - 1
187	ENDIF
188	DO ji = 1, endloop
189	iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
190	ARRAY_IN(ji,ijpj-1,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj-2,:,:,jf)
191	ARRAY_IN(ji,ijpj ,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj-3,:,:,jf)
192	END DO
193	IF (nimpp .eq. 1) THEN
194	ARRAY_IN( 1 ,ijpj ,:,:,jf) = SGN_IN(jf) * ARRAY_IN( 2 ,ijpj-3,:,:,jf)
195	ARRAY_IN( 1 ,ijpj-1,:,:,jf) = SGN_IN(jf) * ARRAY_IN( 2 ,ijpj-2,:,:,jf)
196	ENDIF
197	IF((nimpp + nlci - 1) .eq. jpiglo) THEN
198	ARRAY_IN(nlci,ijpj ,:,:,jf) = SGN_IN(jf) * ARRAY_IN(nlci-1,ijpj-3,:,:,jf)
199	ARRAY_IN(nlci,ijpj-1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(nlci-1,ijpj-2,:,:,jf)
200	ENDIF
201	!
202	CASE ( 'I' ) ! ice U-V point (I-point)
203	IF( nimpp /= 1 ) THEN
204	startloop = 1
205	ELSE
206	startloop = 3
207	ARRAY_IN(2,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(3,ijpjm1,:,:,jf)
208	ENDIF
209	DO ji = startloop, nlci
210	iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 5
211	ARRAY_IN(ji,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpjm1,:,:,jf)
212	END DO
213	END SELECT
214	!
215	CASE ( 5, 6 ) ! * North fold F-point pivot
216	!
217	SELECT CASE ( NAT_IN(jf) )
218	CASE ( 'T' , 'W' ) ! T-, W-point
219	DO ji = 1, nlci
220	ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
221	ARRAY_IN(ji,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj-1,:,:,jf)
222	END DO
223	!
224	CASE ( 'U' ) ! U-point
225	IF( nimpp + nlci - 1 /= jpiglo ) THEN
226	endloop = nlci
227	ELSE
228	endloop = nlci - 1
229	ENDIF
230	DO ji = 1, endloop
231	iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2
232	ARRAY_IN(ji,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj-1,:,:,jf)
233	END DO
234	IF((nimpp + nlci - 1) .eq. jpiglo) THEN
235	ARRAY_IN(nlci,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(1,ijpj-1,:,:,jf)
236	ENDIF
237	!
238	CASE ( 'V' ) ! V-point
239	DO ji = 1, nlci
240	ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
241	ARRAY_IN(ji,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj-2,:,:,jf)
242	END DO
243	!
244	IF( nimpp >= jpiglo/2+1 ) THEN
245	startloop = 1
246	ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN
247	startloop = jpiglo/2+1 - nimpp + 1
248	ELSE
249	startloop = nlci + 1
250	ENDIF
251	IF( startloop <= nlci ) THEN
252	DO ji = startloop, nlci
253	ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
254	ARRAY_IN(ji,ijpjm1,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpjm1,:,:,jf)
255	END DO
256	ENDIF
257	!
258	CASE ( 'F' ) ! F-point
259	IF( nimpp + nlci - 1 /= jpiglo ) THEN
260	endloop = nlci
261	ELSE
262	endloop = nlci - 1
263	ENDIF
264	DO ji = 1, endloop
265	iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2
266	ARRAY_IN(ji,ijpj ,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj-2,:,:,jf)
267	END DO
268	IF((nimpp + nlci - 1) .eq. jpiglo) THEN
269	ARRAY_IN(nlci,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(1,ijpj-2,:,:,jf)
270	ENDIF
271	!
272	IF( nimpp + nlci - 1 /= jpiglo ) THEN
273	endloop = nlci
274	ELSE
275	endloop = nlci - 1
276	ENDIF
277	IF( nimpp >= jpiglo/2+1 ) THEN
278	startloop = 1
279	ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN
280	startloop = jpiglo/2+1 - nimpp + 1
281	ELSE
282	startloop = endloop + 1
283	ENDIF
284	IF( startloop <= endloop ) THEN
285	DO ji = startloop, endloop
286	iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2
287	ARRAY_IN(ji,ijpjm1,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpjm1,:,:,jf)
288	END DO
289	ENDIF
290	!
291	CASE ( 'I' ) ! ice U-V point (I-point)
292	IF( nimpp /= 1 ) THEN
293	startloop = 1
294	ELSE
295	startloop = 2
296	ENDIF
297	IF( nimpp + nlci - 1 /= jpiglo ) THEN
298	endloop = nlci
299	ELSE
300	endloop = nlci - 1
301	ENDIF
302	DO ji = startloop , endloop
303	ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4
304	ARRAY_IN(ji,ijpj,:,:,jf) = 0.5 * (ARRAY_IN(ji,ijpjm1,:,:,jf) + SGN_IN(jf) * ARRAY2_IN(ijt,ijpjm1,:,:,jf))
305	END DO
306	!
307	END SELECT
308	!
309	CASE DEFAULT ! * closed : the code probably never go through
310	!
311	SELECT CASE ( NAT_IN(jf))
312	CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points
313	ARRAY_IN(:, 1 ,:,:,jf) = 0._wp
314	ARRAY_IN(:,ijpj,:,:,jf) = 0._wp
315	CASE ( 'F' ) ! F-point
316	ARRAY_IN(:,ijpj,:,:,jf) = 0._wp
317	CASE ( 'I' ) ! ice U-V point
318	ARRAY_IN(:, 1 ,:,:,jf) = 0._wp
319	ARRAY_IN(:,ijpj,:,:,jf) = 0._wp
320	END SELECT
321	!
322	END SELECT ! npolj
323	!
324	END DO ! End jf loop
325	END SUBROUTINE ROUTINE_NFD
326	#undef ARRAY_TYPE
327	#undef ARRAY_IN
328	#undef NAT_IN
329	#undef SGN_IN
330	#undef K_SIZE
331	#undef L_SIZE
332	#undef F_SIZE
333	#undef ARRAY2_TYPE
334	#undef ARRAY2_IN

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

Download in other formats: