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/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/NST – NEMO

Context Navigation

source: NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/NST/agrif_oce_interp.F90 @ 13229

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

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

Download in other formats: