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.

agrif_oce_interp.F90 in NEMO/trunk/src/NST – NEMO

Context Navigation

source: NEMO/trunk/src/NST/agrif_oce_interp.F90 @ 9780

Last change on this file since 9780 was 9759, checked in by jchanut, 6 years ago
Mask tracers in AGRIF ghost zone (comestic)
Property svn:keywords set to `Id`
File size: 58.0 KB

Line
1	MODULE agrif_oce_interp
2	!!======================================================================
3	!! * MODULE agrif_oce_interp *
4	!! AGRIF: interpolation package for the ocean dynamics (OPA)
5	!!======================================================================
6	!! History : 2.0 ! 2002-06 (L. Debreu) Original cade
7	!! 3.2 ! 2009-04 (R. Benshila)
8	!! 3.6 ! 2014-09 (R. Benshila)
9	!!----------------------------------------------------------------------
10	#if defined key_agrif
11	!!----------------------------------------------------------------------
12	!! 'key_agrif' AGRIF zoom
13	!!----------------------------------------------------------------------
14	!! Agrif_tra :
15	!! Agrif_dyn :
16	!! Agrif_ssh :
17	!! Agrif_dyn_ts :
18	!! Agrif_dta_ts :
19	!! Agrif_ssh_ts :
20	!! Agrif_avm :
21	!! interpu :
22	!! interpv :
23	!!----------------------------------------------------------------------
24	USE par_oce
25	USE oce
26	USE dom_oce
27	USE zdf_oce
28	USE agrif_oce
29	USE phycst
30	USE dynspg_ts, ONLY: un_adv, vn_adv
31	!
32	USE in_out_manager
33	USE agrif_oce_sponge
34	USE lib_mpp
35
36	IMPLICIT NONE
37	PRIVATE
38
39	PUBLIC Agrif_dyn, Agrif_ssh, Agrif_dyn_ts, Agrif_ssh_ts, Agrif_dta_ts
40	PUBLIC Agrif_tra, Agrif_avm
41	PUBLIC interpun , interpvn
42	PUBLIC interptsn, interpsshn, interpavm
43	PUBLIC interpunb, interpvnb , interpub2b, interpvb2b
44	PUBLIC interpe3t, interpumsk, interpvmsk
45
46	INTEGER :: bdy_tinterp = 0
47
48	# include "vectopt_loop_substitute.h90"
49	!!----------------------------------------------------------------------
50	!! NEMO/NST 4.0 , NEMO Consortium (2018)
51	!! $Id$
52	!! Software governed by the CeCILL licence (./LICENSE)
53	!!----------------------------------------------------------------------
54	CONTAINS
55
56	SUBROUTINE Agrif_tra
57	!!----------------------------------------------------------------------
58	!! * ROUTINE Agrif_tra *
59	!!----------------------------------------------------------------------
60	!
61	IF( Agrif_Root() ) RETURN
62	!
63	Agrif_SpecialValue = 0._wp
64	Agrif_UseSpecialValue = .TRUE.
65	!
66	CALL Agrif_Bc_variable( tsn_id, procname=interptsn )
67	!
68	Agrif_UseSpecialValue = .FALSE.
69	!
70	END SUBROUTINE Agrif_tra
71
72
73	SUBROUTINE Agrif_dyn( kt )
74	!!----------------------------------------------------------------------
75	!! * ROUTINE Agrif_DYN *
76	!!----------------------------------------------------------------------
77	INTEGER, INTENT(in) :: kt
78	!
79	INTEGER :: ji, jj, jk ! dummy loop indices
80	INTEGER :: j1, j2, i1, i2
81	INTEGER :: ibdy1, jbdy1, ibdy2, jbdy2
82	REAL(wp), DIMENSION(jpi,jpj) :: zub, zvb
83	!!----------------------------------------------------------------------
84	!
85	IF( Agrif_Root() ) RETURN
86	!
87	Agrif_SpecialValue = 0._wp
88	Agrif_UseSpecialValue = ln_spc_dyn
89	!
90	CALL Agrif_Bc_variable( un_interp_id, procname=interpun )
91	CALL Agrif_Bc_variable( vn_interp_id, procname=interpvn )
92	!
93	Agrif_UseSpecialValue = .FALSE.
94	!
95	! prevent smoothing in ghost cells
96	i1 = 1 ; i2 = jpi
97	j1 = 1 ; j2 = jpj
98	IF( nbondj == -1 .OR. nbondj == 2 ) j1 = 2 + nbghostcells
99	IF( nbondj == +1 .OR. nbondj == 2 ) j2 = nlcj - nbghostcells - 1
100	IF( nbondi == -1 .OR. nbondi == 2 ) i1 = 2 + nbghostcells
101	IF( nbondi == +1 .OR. nbondi == 2 ) i2 = nlci - nbghostcells - 1
102
103	! --- West --- !
104	IF( nbondi == -1 .OR. nbondi == 2 ) THEN
105	ibdy1 = 2
106	ibdy2 = 1+nbghostcells
107	!
108	IF( .NOT.ln_dynspg_ts ) THEN ! Store transport
109	ua_b(ibdy1:ibdy2,:) = 0._wp
110	DO jk = 1, jpkm1
111	DO jj = 1, jpj
112	ua_b(ibdy1:ibdy2,jj) = ua_b(ibdy1:ibdy2,jj) &
113	& + e3u_a(ibdy1:ibdy2,jj,jk) * ua(ibdy1:ibdy2,jj,jk) * umask(ibdy1:ibdy2,jj,jk)
114	END DO
115	END DO
116	DO jj = 1, jpj
117	ua_b(ibdy1:ibdy2,jj) = ua_b(ibdy1:ibdy2,jj) * r1_hu_a(ibdy1:ibdy2,jj)
118	END DO
119	ENDIF
120	!
121	IF( .NOT.lk_agrif_clp ) THEN
122	DO jk=1,jpkm1 ! Smooth
123	DO jj=j1,j2
124	ua(ibdy2,jj,jk) = 0.25_wp(ua(ibdy2-1,jj,jk)+2._wpua(ibdy2,jj,jk)+ua(ibdy2+1,jj,jk))
125	END DO
126	END DO
127	ENDIF
128	!
129	zub(ibdy1:ibdy2,:) = 0._wp ! Correct transport
130	DO jk = 1, jpkm1
131	DO jj = 1, jpj
132	zub(ibdy1:ibdy2,jj) = zub(ibdy1:ibdy2,jj) &
133	& + e3u_a(ibdy1:ibdy2,jj,jk) * ua(ibdy1:ibdy2,jj,jk)*umask(ibdy1:ibdy2,jj,jk)
134	END DO
135	END DO
136	DO jj=1,jpj
137	zub(ibdy1:ibdy2,jj) = zub(ibdy1:ibdy2,jj) * r1_hu_a(ibdy1:ibdy2,jj)
138	END DO
139
140	DO jk = 1, jpkm1
141	DO jj = 1, jpj
142	ua(ibdy1:ibdy2,jj,jk) = ( ua(ibdy1:ibdy2,jj,jk) &
143	& + ua_b(ibdy1:ibdy2,jj)-zub(ibdy1:ibdy2,jj)) * umask(ibdy1:ibdy2,jj,jk)
144	END DO
145	END DO
146
147	IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate
148	zvb(ibdy1:ibdy2,:) = 0._wp
149	DO jk = 1, jpkm1
150	DO jj = 1, jpj
151	zvb(ibdy1:ibdy2,jj) = zvb(ibdy1:ibdy2,jj) &
152	& + e3v_a(ibdy1:ibdy2,jj,jk) * va(ibdy1:ibdy2,jj,jk) * vmask(ibdy1:ibdy2,jj,jk)
153	END DO
154	END DO
155	DO jj = 1, jpj
156	zvb(ibdy1:ibdy2,jj) = zvb(ibdy1:ibdy2,jj) * r1_hv_a(ibdy1:ibdy2,jj)
157	END DO
158	DO jk = 1, jpkm1
159	DO jj = 1, jpj
160	va(ibdy1:ibdy2,jj,jk) = ( va(ibdy1:ibdy2,jj,jk) &
161	& + va_b(ibdy1:ibdy2,jj)-zvb(ibdy1:ibdy2,jj))*vmask(ibdy1:ibdy2,jj,jk)
162	END DO
163	END DO
164	ENDIF
165	!
166	DO jk = 1, jpkm1 ! Mask domain edges
167	DO jj = 1, jpj
168	ua(1,jj,jk) = 0._wp
169	va(1,jj,jk) = 0._wp
170	END DO
171	END DO
172	ENDIF
173
174	! --- East --- !
175	IF( nbondi == 1 .OR. nbondi == 2 ) THEN
176	ibdy1 = nlci-1-nbghostcells
177	ibdy2 = nlci-2
178	!
179	IF( .NOT.ln_dynspg_ts ) THEN ! Store transport
180	ua_b(ibdy1:ibdy2,:) = 0._wp
181	DO jk = 1, jpkm1
182	DO jj = 1, jpj
183	ua_b(ibdy1:ibdy2,jj) = ua_b(ibdy1:ibdy2,jj) &
184	& + e3u_a(ibdy1:ibdy2,jj,jk) * ua(ibdy1:ibdy2,jj,jk) * umask(ibdy1:ibdy2,jj,jk)
185	END DO
186	END DO
187	DO jj = 1, jpj
188	ua_b(ibdy1:ibdy2,jj) = ua_b(ibdy1:ibdy2,jj) * r1_hu_a(ibdy1:ibdy2,jj)
189	END DO
190	ENDIF
191	!
192	IF( .NOT.lk_agrif_clp ) THEN
193	DO jk=1,jpkm1 ! Smooth
194	DO jj=j1,j2
195	ua(ibdy1,jj,jk) = 0.25_wp(ua(ibdy1-1,jj,jk)+2._wpua(ibdy1,jj,jk)+ua(ibdy1+1,jj,jk))
196	END DO
197	END DO
198	ENDIF
199	!
200	zub(ibdy1:ibdy2,:) = 0._wp ! Correct transport
201	DO jk = 1, jpkm1
202	DO jj = 1, jpj
203	zub(ibdy1:ibdy2,jj) = zub(ibdy1:ibdy2,jj) &
204	& + e3u_a(ibdy1:ibdy2,jj,jk) * ua(ibdy1:ibdy2,jj,jk) * umask(ibdy1:ibdy2,jj,jk)
205	END DO
206	END DO
207	DO jj=1,jpj
208	zub(ibdy1:ibdy2,jj) = zub(ibdy1:ibdy2,jj) * r1_hu_a(ibdy1:ibdy2,jj)
209	END DO
210
211	DO jk = 1, jpkm1
212	DO jj = 1, jpj
213	ua(ibdy1:ibdy2,jj,jk) = ( ua(ibdy1:ibdy2,jj,jk) &
214	& + ua_b(ibdy1:ibdy2,jj)-zub(ibdy1:ibdy2,jj))*umask(ibdy1:ibdy2,jj,jk)
215	END DO
216	END DO
217
218	IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate
219	ibdy1 = ibdy1 + 1
220	ibdy2 = ibdy2 + 1
221	zvb(ibdy1:ibdy2,:) = 0._wp
222	DO jk = 1, jpkm1
223	DO jj = 1, jpj
224	zvb(ibdy1:ibdy2,jj) = zvb(ibdy1:ibdy2,jj) &
225	& + e3v_a(ibdy1:ibdy2,jj,jk) * va(ibdy1:ibdy2,jj,jk) * vmask(ibdy1:ibdy2,jj,jk)
226	END DO
227	END DO
228	DO jj = 1, jpj
229	zvb(ibdy1:ibdy2,jj) = zvb(ibdy1:ibdy2,jj) * r1_hv_a(ibdy1:ibdy2,jj)
230	END DO
231	DO jk = 1, jpkm1
232	DO jj = 1, jpj
233	va(ibdy1:ibdy2,jj,jk) = ( va(ibdy1:ibdy2,jj,jk) &
234	& + va_b(ibdy1:ibdy2,jj)-zvb(ibdy1:ibdy2,jj)) * vmask(ibdy1:ibdy2,jj,jk)
235	END DO
236	END DO
237	ENDIF
238	!
239	DO jk = 1, jpkm1 ! Mask domain edges
240	DO jj = 1, jpj
241	ua(nlci-1,jj,jk) = 0._wp
242	va(nlci ,jj,jk) = 0._wp
243	END DO
244	END DO
245	ENDIF
246
247	! --- South --- !
248	IF( nbondj == -1 .OR. nbondj == 2 ) THEN
249	jbdy1 = 2
250	jbdy2 = 1+nbghostcells
251	!
252	IF( .NOT.ln_dynspg_ts ) THEN ! Store transport
253	va_b(:,jbdy1:jbdy2) = 0._wp
254	DO jk = 1, jpkm1
255	DO ji = 1, jpi
256	va_b(ji,jbdy1:jbdy2) = va_b(ji,jbdy1:jbdy2) &
257	& + e3v_a(ji,jbdy1:jbdy2,jk) * va(ji,jbdy1:jbdy2,jk) * vmask(ji,jbdy1:jbdy2,jk)
258	END DO
259	END DO
260	DO ji=1,jpi
261	va_b(ji,jbdy1:jbdy2) = va_b(ji,jbdy1:jbdy2) * r1_hv_a(ji,jbdy1:jbdy2)
262	END DO
263	ENDIF
264	!
265	IF ( .NOT.lk_agrif_clp ) THEN
266	DO jk = 1, jpkm1 ! Smooth
267	DO ji = i1, i2
268	va(ji,jbdy2,jk) = 0.25_wp(va(ji,jbdy2-1,jk)+2._wpva(ji,jbdy2,jk)+va(ji,jbdy2+1,jk))
269	END DO
270	END DO
271	ENDIF
272	!
273	zvb(:,jbdy1:jbdy2) = 0._wp ! Correct transport
274	DO jk=1,jpkm1
275	DO ji=1,jpi
276	zvb(ji,jbdy1:jbdy2) = zvb(ji,jbdy1:jbdy2) &
277	& + e3v_a(ji,jbdy1:jbdy2,jk) * va(ji,jbdy1:jbdy2,jk) * vmask(ji,jbdy1:jbdy2,jk)
278	END DO
279	END DO
280	DO ji = 1, jpi
281	zvb(ji,jbdy1:jbdy2) = zvb(ji,jbdy1:jbdy2) * r1_hv_a(ji,jbdy1:jbdy2)
282	END DO
283
284	DO jk = 1, jpkm1
285	DO ji = 1, jpi
286	va(ji,jbdy1:jbdy2,jk) = ( va(ji,jbdy1:jbdy2,jk) &
287	& + va_b(ji,jbdy1:jbdy2) - zvb(ji,jbdy1:jbdy2) ) * vmask(ji,jbdy1:jbdy2,jk)
288	END DO
289	END DO
290
291	IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate
292	zub(:,jbdy1:jbdy2) = 0._wp
293	DO jk = 1, jpkm1
294	DO ji = 1, jpi
295	zub(ji,jbdy1:jbdy2) = zub(ji,jbdy1:jbdy2) &
296	& + e3u_a(ji,jbdy1:jbdy2,jk) * ua(ji,jbdy1:jbdy2,jk) * umask(ji,jbdy1:jbdy2,jk)
297	END DO
298	END DO
299	DO ji = 1, jpi
300	zub(ji,jbdy1:jbdy2) = zub(ji,jbdy1:jbdy2) * r1_hu_a(ji,jbdy1:jbdy2)
301	END DO
302
303	DO jk = 1, jpkm1
304	DO ji = 1, jpi
305	ua(ji,jbdy1:jbdy2,jk) = ( ua(ji,jbdy1:jbdy2,jk) &
306	& + ua_b(ji,jbdy1:jbdy2) - zub(ji,jbdy1:jbdy2) ) * umask(ji,jbdy1:jbdy2,jk)
307	END DO
308	END DO
309	ENDIF
310	!
311	DO jk = 1, jpkm1 ! Mask domain edges
312	DO ji = 1, jpi
313	ua(ji,1,jk) = 0._wp
314	va(ji,1,jk) = 0._wp
315	END DO
316	END DO
317	ENDIF
318
319	! --- North --- !
320	IF( nbondj == 1 .OR. nbondj == 2 ) THEN
321	jbdy1 = nlcj-1-nbghostcells
322	jbdy2 = nlcj-2
323	!
324	IF( .NOT.ln_dynspg_ts ) THEN ! Store transport
325	va_b(:,jbdy1:jbdy2) = 0._wp
326	DO jk = 1, jpkm1
327	DO ji = 1, jpi
328	va_b(ji,jbdy1:jbdy2) = va_b(ji,jbdy1:jbdy2) &
329	& + e3v_a(ji,jbdy1:jbdy2,jk) * va(ji,jbdy1:jbdy2,jk) * vmask(ji,jbdy1:jbdy2,jk)
330	END DO
331	END DO
332	DO ji=1,jpi
333	va_b(ji,jbdy1:jbdy2) = va_b(ji,jbdy1:jbdy2) * r1_hv_a(ji,jbdy1:jbdy2)
334	END DO
335	ENDIF
336	!
337	IF ( .NOT.lk_agrif_clp ) THEN
338	DO jk = 1, jpkm1 ! Smooth
339	DO ji = i1, i2
340	va(ji,jbdy1,jk) = 0.25_wp(va(ji,jbdy1-1,jk)+2._wpva(ji,jbdy1,jk)+va(ji,jbdy1+1,jk))
341	END DO
342	END DO
343	ENDIF
344	!
345	zvb(:,jbdy1:jbdy2) = 0._wp ! Correct transport
346	DO jk=1,jpkm1
347	DO ji=1,jpi
348	zvb(ji,jbdy1:jbdy2) = zvb(ji,jbdy1:jbdy2) &
349	& + e3v_a(ji,jbdy1:jbdy2,jk) * va(ji,jbdy1:jbdy2,jk) * vmask(ji,jbdy1:jbdy2,jk)
350	END DO
351	END DO
352	DO ji = 1, jpi
353	zvb(ji,jbdy1:jbdy2) = zvb(ji,jbdy1:jbdy2) * r1_hv_a(ji,jbdy1:jbdy2)
354	END DO
355
356	DO jk = 1, jpkm1
357	DO ji = 1, jpi
358	va(ji,jbdy1:jbdy2,jk) = ( va(ji,jbdy1:jbdy2,jk) &
359	& + va_b(ji,jbdy1:jbdy2) - zvb(ji,jbdy1:jbdy2) ) * vmask(ji,jbdy1:jbdy2,jk)
360	END DO
361	END DO
362
363	IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate
364	jbdy1 = jbdy1 + 1
365	jbdy2 = jbdy2 + 1
366	zub(:,jbdy1:jbdy2) = 0._wp
367	DO jk = 1, jpkm1
368	DO ji = 1, jpi
369	zub(ji,jbdy1:jbdy2) = zub(ji,jbdy1:jbdy2) &
370	& + e3u_a(ji,jbdy1:jbdy2,jk) * ua(ji,jbdy1:jbdy2,jk) * umask(ji,jbdy1:jbdy2,jk)
371	END DO
372	END DO
373	DO ji = 1, jpi
374	zub(ji,jbdy1:jbdy2) = zub(ji,jbdy1:jbdy2) * r1_hu_a(ji,jbdy1:jbdy2)
375	END DO
376
377	DO jk = 1, jpkm1
378	DO ji = 1, jpi
379	ua(ji,jbdy1:jbdy2,jk) = ( ua(ji,jbdy1:jbdy2,jk) &
380	& + ua_b(ji,jbdy1:jbdy2) - zub(ji,jbdy1:jbdy2) ) * umask(ji,jbdy1:jbdy2,jk)
381	END DO
382	END DO
383	ENDIF
384	!
385	DO jk = 1, jpkm1 ! Mask domain edges
386	DO ji = 1, jpi
387	ua(ji,nlcj ,jk) = 0._wp
388	va(ji,nlcj-1,jk) = 0._wp
389	END DO
390	END DO
391	ENDIF
392	!
393	END SUBROUTINE Agrif_dyn
394
395
396	SUBROUTINE Agrif_dyn_ts( jn )
397	!!----------------------------------------------------------------------
398	!! * ROUTINE Agrif_dyn_ts *
399	!!----------------------------------------------------------------------
400	INTEGER, INTENT(in) :: jn
401	!!
402	INTEGER :: ji, jj
403	!!----------------------------------------------------------------------
404	!
405	IF( Agrif_Root() ) RETURN
406	!
407	IF((nbondi == -1).OR.(nbondi == 2)) THEN
408	DO jj=1,jpj
409	va_e(2:nbghostcells+1,jj) = vbdy_w(1:nbghostcells,jj) * hvr_e(2:nbghostcells+1,jj)
410	! Specified fluxes:
411	ua_e(2:nbghostcells+1,jj) = ubdy_w(1:nbghostcells,jj) * hur_e(2:nbghostcells+1,jj)
412	! Characteristics method (only if ghostcells=1):
413	!alt ua_e(2,jj) = 0.5_wp * ( ubdy_w(jj) * hur_e(2,jj) + ua_e(3,jj) &
414	!alt & - sqrt(grav * hur_e(2,jj)) * (sshn_e(3,jj) - hbdy_w(jj)) )
415	END DO
416	ENDIF
417	!
418	IF((nbondi == 1).OR.(nbondi == 2)) THEN
419	DO jj=1,jpj
420	va_e(nlci-nbghostcells:nlci-1,jj) = vbdy_e(1:nbghostcells,jj) * hvr_e(nlci-nbghostcells:nlci-1,jj)
421	! Specified fluxes:
422	ua_e(nlci-nbghostcells-1:nlci-2,jj) = ubdy_e(1:nbghostcells,jj) * hur_e(nlci-nbghostcells-1:nlci-2,jj)
423	! Characteristics method (only if ghostcells=1):
424	!alt ua_e(nlci-2,jj) = 0.5_wp * ( ubdy_e(jj) * hur_e(nlci-2,jj) + ua_e(nlci-3,jj) &
425	!alt & + sqrt(grav * hur_e(nlci-2,jj)) * (sshn_e(nlci-2,jj) - hbdy_e(jj)) )
426	END DO
427	ENDIF
428	!
429	IF((nbondj == -1).OR.(nbondj == 2)) THEN
430	DO ji=1,jpi
431	ua_e(ji,2:nbghostcells+1) = ubdy_s(ji,1:nbghostcells) * hur_e(ji,2:nbghostcells+1)
432	! Specified fluxes:
433	va_e(ji,2:nbghostcells+1) = vbdy_s(ji,1:nbghostcells) * hvr_e(ji,2:nbghostcells+1)
434	! Characteristics method (only if ghostcells=1):
435	!alt va_e(ji,2) = 0.5_wp * ( vbdy_s(ji) * hvr_e(ji,2) + va_e(ji,3) &
436	!alt & - sqrt(grav * hvr_e(ji,2)) * (sshn_e(ji,3) - hbdy_s(ji)) )
437	END DO
438	ENDIF
439	!
440	IF((nbondj == 1).OR.(nbondj == 2)) THEN
441	DO ji=1,jpi
442	ua_e(ji,nlcj-nbghostcells:nlcj-1) = ubdy_n(ji,1:nbghostcells) * hur_e(ji,nlcj-nbghostcells:nlcj-1)
443	! Specified fluxes:
444	va_e(ji,nlcj-nbghostcells-1:nlcj-2) = vbdy_n(ji,1:nbghostcells) * hvr_e(ji,nlcj-nbghostcells-1:nlcj-2)
445	! Characteristics method (only if ghostcells=1):
446	!alt va_e(ji,nlcj-2) = 0.5_wp * ( vbdy_n(ji) * hvr_e(ji,nlcj-2) + va_e(ji,nlcj-3) &
447	!alt & + sqrt(grav * hvr_e(ji,nlcj-2)) * (sshn_e(ji,nlcj-2) - hbdy_n(ji)) )
448	END DO
449	ENDIF
450	!
451	END SUBROUTINE Agrif_dyn_ts
452
453
454	SUBROUTINE Agrif_dta_ts( kt )
455	!!----------------------------------------------------------------------
456	!! * ROUTINE Agrif_dta_ts *
457	!!----------------------------------------------------------------------
458	INTEGER, INTENT(in) :: kt
459	!!
460	INTEGER :: ji, jj
461	LOGICAL :: ll_int_cons
462	!!----------------------------------------------------------------------
463	!
464	IF( Agrif_Root() ) RETURN
465	!
466	ll_int_cons = ln_bt_fw ! Assume conservative temporal integration in the forward case only
467	!
468	! Enforce volume conservation if no time refinement:
469	IF ( Agrif_rhot()==1 ) ll_int_cons=.TRUE.
470	!
471	! Interpolate barotropic fluxes
472	Agrif_SpecialValue=0._wp
473	Agrif_UseSpecialValue = ln_spc_dyn
474	!
475	IF( ll_int_cons ) THEN ! Conservative interpolation
476	! order matters here !!!!!!
477	CALL Agrif_Bc_variable( ub2b_interp_id, calledweight=1._wp, procname=interpub2b ) ! Time integrated
478	CALL Agrif_Bc_variable( vb2b_interp_id, calledweight=1._wp, procname=interpvb2b )
479	bdy_tinterp = 1
480	CALL Agrif_Bc_variable( unb_id , calledweight=1._wp, procname=interpunb ) ! After
481	CALL Agrif_Bc_variable( vnb_id , calledweight=1._wp, procname=interpvnb )
482	bdy_tinterp = 2
483	CALL Agrif_Bc_variable( unb_id , calledweight=0._wp, procname=interpunb ) ! Before
484	CALL Agrif_Bc_variable( vnb_id , calledweight=0._wp, procname=interpvnb )
485	ELSE ! Linear interpolation
486	bdy_tinterp = 0
487	ubdy_w(:,:) = 0._wp ; vbdy_w(:,:) = 0._wp
488	ubdy_e(:,:) = 0._wp ; vbdy_e(:,:) = 0._wp
489	ubdy_n(:,:) = 0._wp ; vbdy_n(:,:) = 0._wp
490	ubdy_s(:,:) = 0._wp ; vbdy_s(:,:) = 0._wp
491	CALL Agrif_Bc_variable( unb_id, procname=interpunb )
492	CALL Agrif_Bc_variable( vnb_id, procname=interpvnb )
493	ENDIF
494	Agrif_UseSpecialValue = .FALSE.
495	!
496	END SUBROUTINE Agrif_dta_ts
497
498
499	SUBROUTINE Agrif_ssh( kt )
500	!!----------------------------------------------------------------------
501	!! * ROUTINE Agrif_ssh *
502	!!----------------------------------------------------------------------
503	INTEGER, INTENT(in) :: kt
504	!
505	INTEGER :: ji, jj, indx, indy
506	!!----------------------------------------------------------------------
507	!
508	IF( Agrif_Root() ) RETURN
509	!
510	! Linear time interpolation of sea level
511	!
512	Agrif_SpecialValue = 0._wp
513	Agrif_UseSpecialValue = .TRUE.
514	CALL Agrif_Bc_variable(sshn_id, procname=interpsshn )
515	Agrif_UseSpecialValue = .FALSE.
516	!
517	! --- West --- !
518	IF((nbondi == -1).OR.(nbondi == 2)) THEN
519	indx = 1+nbghostcells
520	DO jj = 1, jpj
521	DO ji = 2, indx
522	ssha(ji,jj) = hbdy_w(ji-1,jj)
523	ENDDO
524	ENDDO
525	ENDIF
526	!
527	! --- East --- !
528	IF((nbondi == 1).OR.(nbondi == 2)) THEN
529	indx = nlci-nbghostcells
530	DO jj = 1, jpj
531	DO ji = indx, nlci-1
532	ssha(ji,jj) = hbdy_e(ji-indx+1,jj)
533	ENDDO
534	ENDDO
535	ENDIF
536	!
537	! --- South --- !
538	IF((nbondj == -1).OR.(nbondj == 2)) THEN
539	indy = 1+nbghostcells
540	DO jj = 2, indy
541	DO ji = 1, jpi
542	ssha(ji,jj) = hbdy_s(ji,jj-1)
543	ENDDO
544	ENDDO
545	ENDIF
546	!
547	! --- North --- !
548	IF((nbondj == 1).OR.(nbondj == 2)) THEN
549	indy = nlcj-nbghostcells
550	DO jj = indy, nlcj-1
551	DO ji = 1, jpi
552	ssha(ji,jj) = hbdy_n(ji,jj-indy+1)
553	ENDDO
554	ENDDO
555	ENDIF
556	!
557	END SUBROUTINE Agrif_ssh
558
559
560	SUBROUTINE Agrif_ssh_ts( jn )
561	!!----------------------------------------------------------------------
562	!! * ROUTINE Agrif_ssh_ts *
563	!!----------------------------------------------------------------------
564	INTEGER, INTENT(in) :: jn
565	!!
566	INTEGER :: ji, jj, indx, indy
567	!!----------------------------------------------------------------------
568	!! clem ghost (starting at i,j=1 is important I think otherwise you introduce a grad(ssh)/=0 at point 2)
569	!
570	IF( Agrif_Root() ) RETURN
571	!
572	! --- West --- !
573	IF((nbondi == -1).OR.(nbondi == 2)) THEN
574	indx = 1+nbghostcells
575	DO jj = 1, jpj
576	DO ji = 2, indx
577	ssha_e(ji,jj) = hbdy_w(ji-1,jj)
578	ENDDO
579	ENDDO
580	ENDIF
581	!
582	! --- East --- !
583	IF((nbondi == 1).OR.(nbondi == 2)) THEN
584	indx = nlci-nbghostcells
585	DO jj = 1, jpj
586	DO ji = indx, nlci-1
587	ssha_e(ji,jj) = hbdy_e(ji-indx+1,jj)
588	ENDDO
589	ENDDO
590	ENDIF
591	!
592	! --- South --- !
593	IF((nbondj == -1).OR.(nbondj == 2)) THEN
594	indy = 1+nbghostcells
595	DO jj = 2, indy
596	DO ji = 1, jpi
597	ssha_e(ji,jj) = hbdy_s(ji,jj-1)
598	ENDDO
599	ENDDO
600	ENDIF
601	!
602	! --- North --- !
603	IF((nbondj == 1).OR.(nbondj == 2)) THEN
604	indy = nlcj-nbghostcells
605	DO jj = indy, nlcj-1
606	DO ji = 1, jpi
607	ssha_e(ji,jj) = hbdy_n(ji,jj-indy+1)
608	ENDDO
609	ENDDO
610	ENDIF
611	!
612	END SUBROUTINE Agrif_ssh_ts
613
614	SUBROUTINE Agrif_avm
615	!!----------------------------------------------------------------------
616	!! * ROUTINE Agrif_avm *
617	!!----------------------------------------------------------------------
618	REAL(wp) :: zalpha
619	!!----------------------------------------------------------------------
620	!
621	IF( Agrif_Root() ) RETURN
622	!
623	zalpha = 1._wp ! JC: proper time interpolation impossible
624	! => use last available value from parent
625	!
626	Agrif_SpecialValue = 0.e0
627	Agrif_UseSpecialValue = .TRUE.
628	!
629	CALL Agrif_Bc_variable( avm_id, calledweight=zalpha, procname=interpavm )
630	!
631	Agrif_UseSpecialValue = .FALSE.
632	!
633	END SUBROUTINE Agrif_avm
634
635
636	SUBROUTINE interptsn( ptab, i1, i2, j1, j2, k1, k2, n1, n2, before, nb, ndir )
637	!!----------------------------------------------------------------------
638	!! * ROUTINE interptsn *
639	!!----------------------------------------------------------------------
640	REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: ptab
641	INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, n1, n2
642	LOGICAL , INTENT(in ) :: before
643	INTEGER , INTENT(in ) :: nb , ndir
644	!
645	INTEGER :: ji, jj, jk, jn, iref, jref, ibdy, jbdy ! dummy loop indices
646	INTEGER :: imin, imax, jmin, jmax, N_in, N_out
647	REAL(wp) :: zrhox, z1, z2, z3, z4, z5, z6, z7
648	LOGICAL :: western_side, eastern_side,northern_side,southern_side
649	! vertical interpolation:
650	REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk,n1:n2) :: ptab_child
651	REAL(wp), DIMENSION(k1:k2,n1:n2-1) :: tabin
652	REAL(wp), DIMENSION(k1:k2) :: h_in
653	REAL(wp), DIMENSION(1:jpk) :: h_out
654	REAL(wp) :: h_diff
655
656	IF( before ) THEN
657	DO jn = 1,jpts
658	DO jk=k1,k2
659	DO jj=j1,j2
660	DO ji=i1,i2
661	ptab(ji,jj,jk,jn) = tsn(ji,jj,jk,jn)
662	END DO
663	END DO
664	END DO
665	END DO
666
667	# if defined key_vertical
668	DO jk=k1,k2
669	DO jj=j1,j2
670	DO ji=i1,i2
671	ptab(ji,jj,jk,jpts+1) = tmask(ji,jj,jk) * e3t_n(ji,jj,jk)
672	END DO
673	END DO
674	END DO
675	# endif
676	ELSE
677
678	western_side = (nb == 1).AND.(ndir == 1) ; eastern_side = (nb == 1).AND.(ndir == 2)
679	southern_side = (nb == 2).AND.(ndir == 1) ; northern_side = (nb == 2).AND.(ndir == 2)
680
681	# if defined key_vertical
682	DO jj=j1,j2
683	DO ji=i1,i2
684	iref = ji
685	jref = jj
686	if(western_side) iref=MAX(2,ji)
687	if(eastern_side) iref=MIN(nlci-1,ji)
688	if(southern_side) jref=MAX(2,jj)
689	if(northern_side) jref=MIN(nlcj-1,jj)
690	N_in = 0
691	DO jk=k1,k2 !k2 = jpk of parent grid
692	IF (ptab(ji,jj,jk,n2) == 0) EXIT
693	N_in = N_in + 1
694	tabin(jk,:) = ptab(ji,jj,jk,n1:n2-1)
695	h_in(N_in) = ptab(ji,jj,jk,n2)
696	END DO
697	N_out = 0
698	DO jk=1,jpk ! jpk of child grid
699	IF (tmask(iref,jref,jk) == 0) EXIT
700	N_out = N_out + 1
701	h_out(jk) = e3t_n(iref,jref,jk)
702	ENDDO
703	IF (N_in > 0) THEN
704	DO jn=1,jpts
705	call reconstructandremap(tabin(1:N_in,jn),h_in,ptab_child(ji,jj,1:N_out,jn),h_out,N_in,N_out)
706	ENDDO
707	ENDIF
708	ENDDO
709	ENDDO
710	# else
711	ptab_child(i1:i2,j1:j2,1:jpk,1:jpts) = ptab(i1:i2,j1:j2,1:jpk,1:jpts)
712	# endif
713	!
714	DO jn=1, jpts
715	tsa(i1:i2,j1:j2,1:jpk,jn)=ptab_child(i1:i2,j1:j2,1:jpk,jn)*tmask(i1:i2,j1:j2,1:jpk)
716	END DO
717
718	IF ( .NOT.lk_agrif_clp ) THEN
719	!
720	zrhox = Agrif_Rhox()
721	z1 = ( zrhox - 1. ) * 0.5
722	z3 = ( zrhox - 1. ) / ( zrhox + 1. )
723	z6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. )
724	z7 = - ( zrhox - 1. ) / ( zrhox + 3. )
725	!
726	z2 = 1. - z1
727	z4 = 1. - z3
728	z5 = 1. - z6 - z7
729	!
730	imin = i1 ; imax = i2
731	jmin = j1 ; jmax = j2
732	!
733	! Remove CORNERS
734	IF((nbondj == -1).OR.(nbondj == 2)) jmin = 2 + nbghostcells
735	IF((nbondj == +1).OR.(nbondj == 2)) jmax = nlcj - nbghostcells - 1
736	IF((nbondi == -1).OR.(nbondi == 2)) imin = 1 + nbghostcells
737	IF((nbondi == +1).OR.(nbondi == 2)) imax = nlci - nbghostcells - 1
738	!
739	IF( eastern_side ) THEN
740	ibdy = nlci-nbghostcells
741	DO jn = 1, jpts
742	tsa(ibdy+1,jmin:jmax,k1:k2,jn) = z1 * ptab_child(ibdy+1,jmin:jmax,k1:k2,jn) + z2 * ptab_child(ibdy,jmin:jmax,k1:k2,jn)
743	DO jk = 1, jpkm1
744	DO jj = jmin,jmax
745	IF( umask(ibdy-1,jj,jk) == 0._wp ) THEN
746	tsa(ibdy,jj,jk,jn) = tsa(ibdy+1,jj,jk,jn) * tmask(ibdy,jj,jk)
747	ELSE
748	tsa(ibdy,jj,jk,jn)=(z4tsa(ibdy+1,jj,jk,jn)+z3tsa(ibdy-1,jj,jk,jn))*tmask(ibdy,jj,jk)
749	IF( un(ibdy-1,jj,jk) > 0._wp ) THEN
750	tsa(ibdy,jj,jk,jn)=( z6tsa(ibdy-1,jj,jk,jn)+z5tsa(ibdy+1,jj,jk,jn) &
751	+ z7tsa(ibdy-2,jj,jk,jn) ) tmask(ibdy,jj,jk)
752	ENDIF
753	ENDIF
754	END DO
755	END DO
756	! Restore ghost points:
757	tsa(ibdy+1,jmin:jmax,k1:k2,jn) = ptab_child(ibdy+1,jmin:jmax,k1:k2,jn) * tmask(ibdy+1,jmin:jmax,k1:k2)
758	END DO
759	ENDIF
760	!
761	IF( northern_side ) THEN
762	jbdy = nlcj-nbghostcells
763	DO jn = 1, jpts
764	tsa(imin:imax,jbdy+1,k1:k2,jn) = z1 * ptab_child(imin:imax,jbdy+1,k1:k2,jn) + z2 * ptab_child(imin:imax,jbdy,k1:k2,jn)
765	DO jk = 1, jpkm1
766	DO ji = imin,imax
767	IF( vmask(ji,jbdy-1,jk) == 0._wp ) THEN
768	tsa(ji,jbdy,jk,jn) = tsa(ji,jbdy+1,jk,jn) * tmask(ji,jbdy,jk)
769	ELSE
770	tsa(ji,jbdy,jk,jn)=(z4tsa(ji,jbdy+1,jk,jn)+z3tsa(ji,jbdy-1,jk,jn))*tmask(ji,jbdy,jk)
771	IF (vn(ji,jbdy-1,jk) > 0._wp ) THEN
772	tsa(ji,jbdy,jk,jn)=( z6tsa(ji,jbdy-1,jk,jn)+z5tsa(ji,jbdy+1,jk,jn) &
773	+ z7tsa(ji,jbdy-2,jk,jn) ) tmask(ji,jbdy,jk)
774	ENDIF
775	ENDIF
776	END DO
777	END DO
778	! Restore ghost points:
779	tsa(imin:imax,jbdy+1,k1:k2,jn) = ptab_child(imin:imax,jbdy+1,k1:k2,jn) * tmask(imin:imax,jbdy+1,k1:k2)
780	END DO
781	ENDIF
782	!
783	IF( western_side ) THEN
784	ibdy = 1+nbghostcells
785	DO jn = 1, jpts
786	tsa(ibdy-1,jmin:jmax,k1:k2,jn) = z1 * ptab_child(ibdy-1,jmin:jmax,k1:k2,jn) + z2 * ptab_child(ibdy,jmin:jmax,k1:k2,jn)
787	DO jk = 1, jpkm1
788	DO jj = jmin,jmax
789	IF( umask(ibdy,jj,jk) == 0._wp ) THEN
790	tsa(ibdy,jj,jk,jn) = tsa(ibdy-1,jj,jk,jn) * tmask(ibdy,jj,jk)
791	ELSE
792	tsa(ibdy,jj,jk,jn)=(z4tsa(ibdy-1,jj,jk,jn)+z3tsa(ibdy+1,jj,jk,jn))*tmask(ibdy,jj,jk)
793	IF( un(ibdy,jj,jk) < 0._wp ) THEN
794	tsa(ibdy,jj,jk,jn)=(z6tsa(ibdy+1,jj,jk,jn)+z5tsa(ibdy-1,jj,jk,jn)+z7tsa(ibdy+2,jj,jk,jn))tmask(ibdy,jj,jk)
795	ENDIF
796	ENDIF
797	END DO
798	END DO
799	! Restore ghost points:
800	tsa(ibdy-1,jmin:jmax,k1:k2,jn) = ptab_child(ibdy-1,jmin:jmax,k1:k2,jn) * tmask(ibdy-1,jmin:jmax,k1:k2)
801	END DO
802	ENDIF
803	!
804	IF( southern_side ) THEN
805	jbdy=1+nbghostcells
806	DO jn = 1, jpts
807	tsa(imin:imax,jbdy-1,k1:k2,jn) = z1 * ptab_child(imin:imax,jbdy-1,k1:k2,jn) + z2 * ptab_child(imin:imax,jbdy,k1:k2,jn)
808	DO jk = 1, jpk
809	DO ji=imin,imax
810	IF( vmask(ji,jbdy,jk) == 0._wp ) THEN
811	tsa(ji,jbdy,jk,jn)=tsa(ji,jbdy-1,jk,jn) * tmask(ji,jbdy,jk)
812	ELSE
813	tsa(ji,jbdy,jk,jn)=(z4tsa(ji,jbdy-1,jk,jn)+z3tsa(ji,jbdy+1,jk,jn))*tmask(ji,jbdy,jk)
814	IF( vn(ji,jbdy,jk) < 0._wp ) THEN
815	tsa(ji,jbdy,jk,jn)=(z6tsa(ji,jbdy+1,jk,jn)+z5tsa(ji,jbdy-1,jk,jn)+z7tsa(ji,jbdy+2,jk,jn))tmask(ji,jbdy,jk)
816	ENDIF
817	ENDIF
818	END DO
819	END DO
820	! Restore ghost points:
821	tsa(imin:imax,jbdy-1,k1:k2,jn) = tsa(imin:imax,jbdy-1,k1:k2,jn) * tmask(imin:imax,jbdy-1,k1:k2)
822	END DO
823	ENDIF
824	!
825	ENDIF
826	ENDIF
827	!
828	END SUBROUTINE interptsn
829
830	SUBROUTINE interpsshn( ptab, i1, i2, j1, j2, before, nb, ndir )
831	!!----------------------------------------------------------------------
832	!! * ROUTINE interpsshn *
833	!!----------------------------------------------------------------------
834	INTEGER , INTENT(in ) :: i1, i2, j1, j2
835	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
836	LOGICAL , INTENT(in ) :: before
837	INTEGER , INTENT(in ) :: nb , ndir
838	!
839	LOGICAL :: western_side, eastern_side,northern_side,southern_side
840	!!----------------------------------------------------------------------
841	!
842	IF( before) THEN
843	ptab(i1:i2,j1:j2) = sshn(i1:i2,j1:j2)
844	ELSE
845	western_side = (nb == 1).AND.(ndir == 1)
846	eastern_side = (nb == 1).AND.(ndir == 2)
847	southern_side = (nb == 2).AND.(ndir == 1)
848	northern_side = (nb == 2).AND.(ndir == 2)
849	!! clem ghost
850	IF(western_side) hbdy_w(1:nbghostcells,j1:j2) = ptab(i1:i2,j1:j2) * tmask(i1:i2,j1:j2,1)
851	IF(eastern_side) hbdy_e(1:nbghostcells,j1:j2) = ptab(i1:i2,j1:j2) * tmask(i1:i2,j1:j2,1)
852	IF(southern_side) hbdy_s(i1:i2,1:nbghostcells) = ptab(i1:i2,j1:j2) * tmask(i1:i2,j1:j2,1)
853	IF(northern_side) hbdy_n(i1:i2,1:nbghostcells) = ptab(i1:i2,j1:j2) * tmask(i1:i2,j1:j2,1)
854	ENDIF
855	!
856	END SUBROUTINE interpsshn
857
858	SUBROUTINE interpun( ptab, i1, i2, j1, j2, k1, k2, m1, m2, before, nb, ndir )
859	!!----------------------------------------------------------------------
860	!! * ROUTINE interpun *
861	!!---------------------------------------------
862	!!
863	INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,m1,m2
864	REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,m1:m2), INTENT(inout) :: ptab
865	LOGICAL, INTENT(in) :: before
866	INTEGER, INTENT(in) :: nb , ndir
867	!!
868	INTEGER :: ji,jj,jk
869	REAL(wp) :: zrhoy
870	! vertical interpolation:
871	REAL(wp), DIMENSION(k1:k2) :: tabin, h_in
872	REAL(wp), DIMENSION(1:jpk) :: h_out
873	INTEGER :: N_in, N_out, iref
874	REAL(wp) :: h_diff
875	LOGICAL :: western_side, eastern_side
876	!!---------------------------------------------
877	!
878	IF (before) THEN
879	DO jk=1,jpk
880	DO jj=j1,j2
881	DO ji=i1,i2
882	ptab(ji,jj,jk,1) = (e2u(ji,jj) * e3u_n(ji,jj,jk) * un(ji,jj,jk)*umask(ji,jj,jk))
883	# if defined key_vertical
884	ptab(ji,jj,jk,2) = (umask(ji,jj,jk) * e2u(ji,jj) * e3u_n(ji,jj,jk))
885	# endif
886	END DO
887	END DO
888	END DO
889	ELSE
890	zrhoy = Agrif_rhoy()
891	# if defined key_vertical
892	! VERTICAL REFINEMENT BEGIN
893	western_side = (nb == 1).AND.(ndir == 1)
894	eastern_side = (nb == 1).AND.(ndir == 2)
895
896	DO ji=i1,i2
897	iref = ji
898	IF (western_side) iref = MAX(2,ji)
899	IF (eastern_side) iref = MIN(nlci-2,ji)
900	DO jj=j1,j2
901	N_in = 0
902	DO jk=k1,k2
903	IF (ptab(ji,jj,jk,2) == 0) EXIT
904	N_in = N_in + 1
905	tabin(jk) = ptab(ji,jj,jk,1)/ptab(ji,jj,jk,2)
906	h_in(N_in) = ptab(ji,jj,jk,2)/(e2u(ji,jj)*zrhoy)
907	ENDDO
908
909	IF (N_in == 0) THEN
910	ua(ji,jj,:) = 0._wp
911	CYCLE
912	ENDIF
913
914	N_out = 0
915	DO jk=1,jpk
916	if (umask(iref,jj,jk) == 0) EXIT
917	N_out = N_out + 1
918	h_out(N_out) = e3u_a(iref,jj,jk)
919	ENDDO
920
921	IF (N_out == 0) THEN
922	ua(ji,jj,:) = 0._wp
923	CYCLE
924	ENDIF
925
926	IF (N_in * N_out > 0) THEN
927	h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in))
928	! Should be able to remove the next IF/ELSEIF statement once scale factors are dealt with properly
929	if (h_diff < -1.e4) then
930	print *,'CHECK YOUR BATHY ...', h_diff, sum(h_out(1:N_out)), sum(h_in(1:N_in))
931	! stop
932	endif
933	ENDIF
934	call reconstructandremap(tabin(1:N_in),h_in(1:N_in),ua(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out)
935	ENDDO
936	ENDDO
937
938	# else
939	DO jk = 1, jpkm1
940	DO jj=j1,j2
941	ua(i1:i2,jj,jk) = ptab(i1:i2,jj,jk,1) / ( zrhoy * e2u(i1:i2,jj) * e3u_a(i1:i2,jj,jk) )
942	END DO
943	END DO
944	# endif
945
946	ENDIF
947	!
948	END SUBROUTINE interpun
949
950	SUBROUTINE interpvn( ptab, i1, i2, j1, j2, k1, k2, m1, m2, before, nb, ndir )
951	!!----------------------------------------------------------------------
952	!! * ROUTINE interpvn *
953	!!----------------------------------------------------------------------
954	!
955	INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,m1,m2
956	REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,m1:m2), INTENT(inout) :: ptab
957	LOGICAL, INTENT(in) :: before
958	INTEGER, INTENT(in) :: nb , ndir
959	!
960	INTEGER :: ji,jj,jk
961	REAL(wp) :: zrhox
962	! vertical interpolation:
963	REAL(wp), DIMENSION(k1:k2) :: tabin, h_in
964	REAL(wp), DIMENSION(1:jpk) :: h_out
965	INTEGER :: N_in, N_out, jref
966	REAL(wp) :: h_diff
967	LOGICAL :: northern_side,southern_side
968	!!---------------------------------------------
969	!
970	IF (before) THEN
971	DO jk=k1,k2
972	DO jj=j1,j2
973	DO ji=i1,i2
974	ptab(ji,jj,jk,1) = (e1v(ji,jj) * e3v_n(ji,jj,jk) * vn(ji,jj,jk)*vmask(ji,jj,jk))
975	# if defined key_vertical
976	ptab(ji,jj,jk,2) = vmask(ji,jj,jk) * e1v(ji,jj) * e3v_n(ji,jj,jk)
977	# endif
978	END DO
979	END DO
980	END DO
981	ELSE
982	zrhox = Agrif_rhox()
983	# if defined key_vertical
984
985	southern_side = (nb == 2).AND.(ndir == 1)
986	northern_side = (nb == 2).AND.(ndir == 2)
987
988	DO jj=j1,j2
989	jref = jj
990	IF (southern_side) jref = MAX(2,jj)
991	IF (northern_side) jref = MIN(nlcj-2,jj)
992	DO ji=i1,i2
993	N_in = 0
994	DO jk=k1,k2
995	if (ptab(ji,jj,jk,2) == 0) EXIT
996	N_in = N_in + 1
997	tabin(jk) = ptab(ji,jj,jk,1)/ptab(ji,jj,jk,2)
998	h_in(N_in) = ptab(ji,jj,jk,2)/(e1v(ji,jj)*zrhox)
999	END DO
1000	IF (N_in == 0) THEN
1001	va(ji,jj,:) = 0._wp
1002	CYCLE
1003	ENDIF
1004
1005	N_out = 0
1006	DO jk=1,jpk
1007	if (vmask(ji,jref,jk) == 0) EXIT
1008	N_out = N_out + 1
1009	h_out(N_out) = e3v_a(ji,jref,jk)
1010	END DO
1011	IF (N_out == 0) THEN
1012	va(ji,jj,:) = 0._wp
1013	CYCLE
1014	ENDIF
1015	call reconstructandremap(tabin(1:N_in),h_in(1:N_in),va(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out)
1016	END DO
1017	END DO
1018	# else
1019	DO jk = 1, jpkm1
1020	va(i1:i2,j1:j2,jk) = ptab(i1:i2,j1:j2,jk,1) / ( zrhox * e1v(i1:i2,j1:j2) * e3v_a(i1:i2,j1:j2,jk) )
1021	END DO
1022	# endif
1023	ENDIF
1024	!
1025	END SUBROUTINE interpvn
1026
1027	SUBROUTINE interpunb( ptab, i1, i2, j1, j2, before, nb, ndir )
1028	!!----------------------------------------------------------------------
1029	!! * ROUTINE interpunb *
1030	!!----------------------------------------------------------------------
1031	INTEGER , INTENT(in ) :: i1, i2, j1, j2
1032	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
1033	LOGICAL , INTENT(in ) :: before
1034	INTEGER , INTENT(in ) :: nb , ndir
1035	!
1036	INTEGER :: ji, jj
1037	REAL(wp) :: zrhoy, zrhot, zt0, zt1, ztcoeff
1038	LOGICAL :: western_side, eastern_side,northern_side,southern_side
1039	!!----------------------------------------------------------------------
1040	!
1041	IF( before ) THEN
1042	ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * hu_n(i1:i2,j1:j2) * un_b(i1:i2,j1:j2)
1043	ELSE
1044	western_side = (nb == 1).AND.(ndir == 1)
1045	eastern_side = (nb == 1).AND.(ndir == 2)
1046	southern_side = (nb == 2).AND.(ndir == 1)
1047	northern_side = (nb == 2).AND.(ndir == 2)
1048	zrhoy = Agrif_Rhoy()
1049	zrhot = Agrif_rhot()
1050	! Time indexes bounds for integration
1051	zt0 = REAL(Agrif_NbStepint() , wp) / zrhot
1052	zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot
1053	! Polynomial interpolation coefficients:
1054	IF( bdy_tinterp == 1 ) THEN
1055	ztcoeff = zrhot * ( zt1*2._wp ( zt1 - 1._wp) &
1056	& - zt0*2._wp ( zt0 - 1._wp) )
1057	ELSEIF( bdy_tinterp == 2 ) THEN
1058	ztcoeff = zrhot * ( zt1 * ( zt1 - 1._wp)**2._wp &
1059	& - zt0 * ( zt0 - 1._wp)**2._wp )
1060	ELSE
1061	ztcoeff = 1
1062	ENDIF
1063	!
1064	IF(western_side) ubdy_w(1:nbghostcells,j1:j2) = ubdy_w(1:nbghostcells,j1:j2) + ztcoeff * ptab(i1:i2,j1:j2)
1065	IF(eastern_side) ubdy_e(1:nbghostcells,j1:j2) = ubdy_e(1:nbghostcells,j1:j2) + ztcoeff * ptab(i1:i2,j1:j2)
1066	IF(southern_side) ubdy_s(i1:i2,1:nbghostcells) = ubdy_s(i1:i2,1:nbghostcells) + ztcoeff * ptab(i1:i2,j1:j2)
1067	IF(northern_side) ubdy_n(i1:i2,1:nbghostcells) = ubdy_n(i1:i2,1:nbghostcells) + ztcoeff * ptab(i1:i2,j1:j2)
1068	!
1069	IF( bdy_tinterp == 0 .OR. bdy_tinterp == 2) THEN
1070	IF(western_side) ubdy_w(1:nbghostcells,j1:j2) = ubdy_w(1:nbghostcells,j1:j2) / (zrhoye2u(i1:i2,j1:j2)) umask(i1:i2,j1:j2,1)
1071	IF(eastern_side) ubdy_e(1:nbghostcells,j1:j2) = ubdy_e(1:nbghostcells,j1:j2) / (zrhoye2u(i1:i2,j1:j2)) umask(i1:i2,j1:j2,1)
1072	IF(southern_side) ubdy_s(i1:i2,1:nbghostcells) = ubdy_s(i1:i2,1:nbghostcells) / (zrhoye2u(i1:i2,j1:j2)) umask(i1:i2,j1:j2,1)
1073	IF(northern_side) ubdy_n(i1:i2,1:nbghostcells) = ubdy_n(i1:i2,1:nbghostcells) / (zrhoye2u(i1:i2,j1:j2)) umask(i1:i2,j1:j2,1)
1074	ENDIF
1075	ENDIF
1076	!
1077	END SUBROUTINE interpunb
1078
1079
1080	SUBROUTINE interpvnb( ptab, i1, i2, j1, j2, before, nb, ndir )
1081	!!----------------------------------------------------------------------
1082	!! * ROUTINE interpvnb *
1083	!!----------------------------------------------------------------------
1084	INTEGER , INTENT(in ) :: i1, i2, j1, j2
1085	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
1086	LOGICAL , INTENT(in ) :: before
1087	INTEGER , INTENT(in ) :: nb , ndir
1088	!
1089	INTEGER :: ji,jj
1090	REAL(wp) :: zrhox, zrhot, zt0, zt1, ztcoeff
1091	LOGICAL :: western_side, eastern_side,northern_side,southern_side
1092	!!----------------------------------------------------------------------
1093	!
1094	IF( before ) THEN
1095	ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * hv_n(i1:i2,j1:j2) * vn_b(i1:i2,j1:j2)
1096	ELSE
1097	western_side = (nb == 1).AND.(ndir == 1)
1098	eastern_side = (nb == 1).AND.(ndir == 2)
1099	southern_side = (nb == 2).AND.(ndir == 1)
1100	northern_side = (nb == 2).AND.(ndir == 2)
1101	zrhox = Agrif_Rhox()
1102	zrhot = Agrif_rhot()
1103	! Time indexes bounds for integration
1104	zt0 = REAL(Agrif_NbStepint() , wp) / zrhot
1105	zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot
1106	IF( bdy_tinterp == 1 ) THEN
1107	ztcoeff = zrhot * ( zt1*2._wp ( zt1 - 1._wp) &
1108	& - zt0*2._wp ( zt0 - 1._wp) )
1109	ELSEIF( bdy_tinterp == 2 ) THEN
1110	ztcoeff = zrhot * ( zt1 * ( zt1 - 1._wp)**2._wp &
1111	& - zt0 * ( zt0 - 1._wp)**2._wp )
1112	ELSE
1113	ztcoeff = 1
1114	ENDIF
1115	!! clem ghost
1116	IF(western_side) vbdy_w(1:nbghostcells,j1:j2) = vbdy_w(1:nbghostcells,j1:j2) + ztcoeff * ptab(i1:i2,j1:j2)
1117	IF(eastern_side) vbdy_e(1:nbghostcells,j1:j2) = vbdy_e(1:nbghostcells,j1:j2) + ztcoeff * ptab(i1:i2,j1:j2)
1118	IF(southern_side) vbdy_s(i1:i2,1:nbghostcells) = vbdy_s(i1:i2,1:nbghostcells) + ztcoeff * ptab(i1:i2,j1:j2)
1119	IF(northern_side) vbdy_n(i1:i2,1:nbghostcells) = vbdy_n(i1:i2,1:nbghostcells) + ztcoeff * ptab(i1:i2,j1:j2)
1120	!
1121	IF( bdy_tinterp == 0 .OR. bdy_tinterp == 2) THEN
1122	IF(western_side) vbdy_w(1:nbghostcells,j1:j2) = vbdy_w(1:nbghostcells,j1:j2) / (zrhoxe1v(i1:i2,j1:j2)) vmask(i1:i2,j1:j2,1)
1123	IF(eastern_side) vbdy_e(1:nbghostcells,j1:j2) = vbdy_e(1:nbghostcells,j1:j2) / (zrhoxe1v(i1:i2,j1:j2)) vmask(i1:i2,j1:j2,1)
1124	IF(southern_side) vbdy_s(i1:i2,1:nbghostcells) = vbdy_s(i1:i2,1:nbghostcells) / (zrhoxe1v(i1:i2,j1:j2)) vmask(i1:i2,j1:j2,1)
1125	IF(northern_side) vbdy_n(i1:i2,1:nbghostcells) = vbdy_n(i1:i2,1:nbghostcells) / (zrhoxe1v(i1:i2,j1:j2)) vmask(i1:i2,j1:j2,1)
1126	ENDIF
1127	ENDIF
1128	!
1129	END SUBROUTINE interpvnb
1130
1131
1132	SUBROUTINE interpub2b( ptab, i1, i2, j1, j2, before, nb, ndir )
1133	!!----------------------------------------------------------------------
1134	!! * ROUTINE interpub2b *
1135	!!----------------------------------------------------------------------
1136	INTEGER , INTENT(in ) :: i1, i2, j1, j2
1137	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
1138	LOGICAL , INTENT(in ) :: before
1139	INTEGER , INTENT(in ) :: nb , ndir
1140	!
1141	INTEGER :: ji,jj
1142	REAL(wp) :: zrhot, zt0, zt1,zat
1143	LOGICAL :: western_side, eastern_side,northern_side,southern_side
1144	!!----------------------------------------------------------------------
1145	IF( before ) THEN
1146	IF ( ln_bt_fw ) THEN
1147	ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * ub2_b(i1:i2,j1:j2)
1148	ELSE
1149	ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * un_adv(i1:i2,j1:j2)
1150	ENDIF
1151	ELSE
1152	western_side = (nb == 1).AND.(ndir == 1)
1153	eastern_side = (nb == 1).AND.(ndir == 2)
1154	southern_side = (nb == 2).AND.(ndir == 1)
1155	northern_side = (nb == 2).AND.(ndir == 2)
1156	zrhot = Agrif_rhot()
1157	! Time indexes bounds for integration
1158	zt0 = REAL(Agrif_NbStepint() , wp) / zrhot
1159	zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot
1160	! Polynomial interpolation coefficients:
1161	zat = zrhot * ( zt1*2._wp (-2._wp*zt1 + 3._wp) &
1162	& - zt0*2._wp (-2._wp*zt0 + 3._wp) )
1163	!! clem ghost
1164	IF(western_side ) ubdy_w(1:nbghostcells,j1:j2) = zat * ptab(i1:i2,j1:j2)
1165	IF(eastern_side ) ubdy_e(1:nbghostcells,j1:j2) = zat * ptab(i1:i2,j1:j2)
1166	IF(southern_side) ubdy_s(i1:i2,1:nbghostcells) = zat * ptab(i1:i2,j1:j2)
1167	IF(northern_side) ubdy_n(i1:i2,1:nbghostcells) = zat * ptab(i1:i2,j1:j2)
1168	ENDIF
1169	!
1170	END SUBROUTINE interpub2b
1171
1172
1173	SUBROUTINE interpvb2b( ptab, i1, i2, j1, j2, before, nb, ndir )
1174	!!----------------------------------------------------------------------
1175	!! * ROUTINE interpvb2b *
1176	!!----------------------------------------------------------------------
1177	INTEGER , INTENT(in ) :: i1, i2, j1, j2
1178	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
1179	LOGICAL , INTENT(in ) :: before
1180	INTEGER , INTENT(in ) :: nb , ndir
1181	!
1182	INTEGER :: ji,jj
1183	REAL(wp) :: zrhot, zt0, zt1,zat
1184	LOGICAL :: western_side, eastern_side,northern_side,southern_side
1185	!!----------------------------------------------------------------------
1186	!
1187	IF( before ) THEN
1188	IF ( ln_bt_fw ) THEN
1189	ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * vb2_b(i1:i2,j1:j2)
1190	ELSE
1191	ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * vn_adv(i1:i2,j1:j2)
1192	ENDIF
1193	ELSE
1194	western_side = (nb == 1).AND.(ndir == 1)
1195	eastern_side = (nb == 1).AND.(ndir == 2)
1196	southern_side = (nb == 2).AND.(ndir == 1)
1197	northern_side = (nb == 2).AND.(ndir == 2)
1198	zrhot = Agrif_rhot()
1199	! Time indexes bounds for integration
1200	zt0 = REAL(Agrif_NbStepint() , wp) / zrhot
1201	zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot
1202	! Polynomial interpolation coefficients:
1203	zat = zrhot * ( zt1*2._wp (-2._wp*zt1 + 3._wp) &
1204	& - zt0*2._wp (-2._wp*zt0 + 3._wp) )
1205	!
1206	IF(western_side ) vbdy_w(1:nbghostcells,j1:j2) = zat * ptab(i1:i2,j1:j2)
1207	IF(eastern_side ) vbdy_e(1:nbghostcells,j1:j2) = zat * ptab(i1:i2,j1:j2)
1208	IF(southern_side) vbdy_s(i1:i2,1:nbghostcells) = zat * ptab(i1:i2,j1:j2)
1209	IF(northern_side) vbdy_n(i1:i2,1:nbghostcells) = zat * ptab(i1:i2,j1:j2)
1210	ENDIF
1211	!
1212	END SUBROUTINE interpvb2b
1213
1214
1215	SUBROUTINE interpe3t( ptab, i1, i2, j1, j2, k1, k2, before, nb, ndir )
1216	!!----------------------------------------------------------------------
1217	!! * ROUTINE interpe3t *
1218	!!----------------------------------------------------------------------
1219	INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2
1220	REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab
1221	LOGICAL , INTENT(in ) :: before
1222	INTEGER , INTENT(in ) :: nb , ndir
1223	!
1224	INTEGER :: ji, jj, jk
1225	LOGICAL :: western_side, eastern_side, northern_side, southern_side
1226	!!----------------------------------------------------------------------
1227	!
1228	IF( before ) THEN
1229	ptab(i1:i2,j1:j2,k1:k2) = tmask(i1:i2,j1:j2,k1:k2) * e3t_0(i1:i2,j1:j2,k1:k2)
1230	ELSE
1231	western_side = (nb == 1).AND.(ndir == 1)
1232	eastern_side = (nb == 1).AND.(ndir == 2)
1233	southern_side = (nb == 2).AND.(ndir == 1)
1234	northern_side = (nb == 2).AND.(ndir == 2)
1235	!
1236	DO jk = k1, k2
1237	DO jj = j1, j2
1238	DO ji = i1, i2
1239	!
1240	IF( ABS( ptab(ji,jj,jk) - tmask(ji,jj,jk) * e3t_0(ji,jj,jk) ) > 1.D-2) THEN
1241	IF (western_side.AND.(ptab(i1+nbghostcells-1,jj,jk)>0._wp)) THEN
1242	WRITE(numout,*) 'ERROR bathymetry merge at the western border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk
1243	WRITE(numout,*) ptab(ji,jj,jk), e3t_0(ji,jj,jk)
1244	kindic_agr = kindic_agr + 1
1245	ELSEIF (eastern_side.AND.(ptab(i2-nbghostcells+1,jj,jk)>0._wp)) THEN
1246	WRITE(numout,*) 'ERROR bathymetry merge at the eastern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk
1247	WRITE(numout,*) ptab(ji,jj,jk), e3t_0(ji,jj,jk)
1248	kindic_agr = kindic_agr + 1
1249	ELSEIF (southern_side.AND.(ptab(ji,j1+nbghostcells-1,jk)>0._wp)) THEN
1250	WRITE(numout,*) 'ERROR bathymetry merge at the southern border ji,jj,jk', ji+nimpp-1,jj+njmpp-1,jk
1251	WRITE(numout,*) ptab(ji,jj,jk), e3t_0(ji,jj,jk)
1252	kindic_agr = kindic_agr + 1
1253	ELSEIF (northern_side.AND.(ptab(ji,j2-nbghostcells+1,jk)>0._wp)) THEN
1254	WRITE(numout,*) 'ERROR bathymetry merge at the northen border ji,jj,jk', ji+nimpp-1,jj+njmpp-1,jk
1255	WRITE(numout,*) ptab(ji,jj,jk), e3t_0(ji,jj,jk)
1256	kindic_agr = kindic_agr + 1
1257	ENDIF
1258	ENDIF
1259	END DO
1260	END DO
1261	END DO
1262	!
1263	ENDIF
1264	!
1265	END SUBROUTINE interpe3t
1266
1267
1268	SUBROUTINE interpumsk( ptab, i1, i2, j1, j2, k1, k2, before, nb, ndir )
1269	!!----------------------------------------------------------------------
1270	!! * ROUTINE interpumsk *
1271	!!----------------------------------------------------------------------
1272	INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2
1273	REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab
1274	LOGICAL , INTENT(in ) :: before
1275	INTEGER , INTENT(in ) :: nb , ndir
1276	!
1277	INTEGER :: ji, jj, jk
1278	LOGICAL :: western_side, eastern_side
1279	!!----------------------------------------------------------------------
1280	!
1281	IF( before ) THEN
1282	ptab(i1:i2,j1:j2,k1:k2) = umask(i1:i2,j1:j2,k1:k2)
1283	ELSE
1284	western_side = (nb == 1).AND.(ndir == 1)
1285	eastern_side = (nb == 1).AND.(ndir == 2)
1286	DO jk = k1, k2
1287	DO jj = j1, j2
1288	DO ji = i1, i2
1289	! Velocity mask at boundary edge points:
1290	IF (ABS(ptab(ji,jj,jk) - umask(ji,jj,jk)) > 1.D-2) THEN
1291	IF (western_side) THEN
1292	WRITE(numout,*) 'ERROR with umask at the western border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk
1293	WRITE(numout,*) ' masks: parent, child ', ptab(ji,jj,jk), umask(ji,jj,jk)
1294	kindic_agr = kindic_agr + 1
1295	ELSEIF (eastern_side) THEN
1296	WRITE(numout,*) 'ERROR with umask at the eastern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk
1297	WRITE(numout,*) ' masks: parent, child ', ptab(ji,jj,jk), umask(ji,jj,jk)
1298	kindic_agr = kindic_agr + 1
1299	ENDIF
1300	ENDIF
1301	END DO
1302	END DO
1303	END DO
1304	!
1305	ENDIF
1306	!
1307	END SUBROUTINE interpumsk
1308
1309
1310	SUBROUTINE interpvmsk( ptab, i1, i2, j1, j2, k1, k2, before, nb, ndir )
1311	!!----------------------------------------------------------------------
1312	!! * ROUTINE interpvmsk *
1313	!!----------------------------------------------------------------------
1314	INTEGER , INTENT(in ) :: i1,i2,j1,j2,k1,k2
1315	REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab
1316	LOGICAL , INTENT(in ) :: before
1317	INTEGER , INTENT(in ) :: nb , ndir
1318	!
1319	INTEGER :: ji, jj, jk
1320	LOGICAL :: northern_side, southern_side
1321	!!----------------------------------------------------------------------
1322	!
1323	IF( before ) THEN
1324	ptab(i1:i2,j1:j2,k1:k2) = vmask(i1:i2,j1:j2,k1:k2)
1325	ELSE
1326	southern_side = (nb == 2).AND.(ndir == 1)
1327	northern_side = (nb == 2).AND.(ndir == 2)
1328	DO jk = k1, k2
1329	DO jj = j1, j2
1330	DO ji = i1, i2
1331	! Velocity mask at boundary edge points:
1332	IF (ABS(ptab(ji,jj,jk) - vmask(ji,jj,jk)) > 1.D-2) THEN
1333	IF (southern_side) THEN
1334	WRITE(numout,*) 'ERROR with vmask at the southern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk
1335	WRITE(numout,*) ' masks: parent, child ', ptab(ji,jj,jk), vmask(ji,jj,jk)
1336	kindic_agr = kindic_agr + 1
1337	ELSEIF (northern_side) THEN
1338	WRITE(numout,*) 'ERROR with vmask at the northern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk
1339	WRITE(numout,*) ' masks: parent, child ', ptab(ji,jj,jk), vmask(ji,jj,jk)
1340	kindic_agr = kindic_agr + 1
1341	ENDIF
1342	ENDIF
1343	END DO
1344	END DO
1345	END DO
1346	!
1347	ENDIF
1348	!
1349	END SUBROUTINE interpvmsk
1350
1351
1352	SUBROUTINE interpavm( ptab, i1, i2, j1, j2, k1, k2, m1, m2, before )
1353	!!----------------------------------------------------------------------
1354	!! * ROUTINE interavm *
1355	!!----------------------------------------------------------------------
1356	INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, m1, m2
1357	REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,m1:m2), INTENT(inout) :: ptab
1358	LOGICAL , INTENT(in ) :: before
1359	REAL(wp), DIMENSION(k1:k2) :: tabin, h_in
1360	REAL(wp), DIMENSION(1:jpk) :: h_out
1361	INTEGER :: N_in, N_out, ji, jj, jk
1362	!!----------------------------------------------------------------------
1363	!
1364	IF (before) THEN
1365	DO jk=k1,k2
1366	DO jj=j1,j2
1367	DO ji=i1,i2
1368	ptab(ji,jj,jk,1) = avm_k(ji,jj,jk)
1369	END DO
1370	END DO
1371	END DO
1372	#ifdef key_vertical
1373	DO jk=k1,k2
1374	DO jj=j1,j2
1375	DO ji=i1,i2
1376	ptab(ji,jj,jk,2) = wmask(ji,jj,jk) * e3w_n(ji,jj,jk)
1377	END DO
1378	END DO
1379	END DO
1380	#endif
1381	ELSE
1382	#ifdef key_vertical
1383	avm_k(i1:i2,j1:j2,1:jpk) = 0.
1384	DO jj=j1,j2
1385	DO ji=i1,i2
1386	N_in = 0
1387	DO jk=k1,k2 !k2 = jpk of parent grid
1388	IF (ptab(ji,jj,jk,2) == 0) EXIT
1389	N_in = N_in + 1
1390	tabin(jk) = ptab(ji,jj,jk,1)
1391	h_in(N_in) = ptab(ji,jj,jk,2)
1392	END DO
1393	N_out = 0
1394	DO jk=1,jpk ! jpk of child grid
1395	IF (wmask(ji,jj,jk) == 0) EXIT
1396	N_out = N_out + 1
1397	h_out(jk) = e3t_n(ji,jj,jk)
1398	ENDDO
1399	IF (N_in > 0) THEN
1400	CALL reconstructandremap(tabin(1:N_in),h_in,avm_k(ji,jj,1:N_out),h_out,N_in,N_out)
1401	ENDIF
1402	ENDDO
1403	ENDDO
1404	#else
1405	avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2,1)
1406	#endif
1407	ENDIF
1408	!
1409	END SUBROUTINE interpavm
1410
1411	#else
1412	!!----------------------------------------------------------------------
1413	!! Empty module no AGRIF zoom
1414	!!----------------------------------------------------------------------
1415	CONTAINS
1416	SUBROUTINE Agrif_OCE_Interp_empty
1417	WRITE(,) 'agrif_oce_interp : You should not have seen this print! error?'
1418	END SUBROUTINE Agrif_OCE_Interp_empty
1419	#endif
1420
1421	!!======================================================================
1422	END MODULE agrif_oce_interp

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

Download in other formats: