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 @ 14227

Last change on this file since 14227 was 14227, checked in by smasson, 3 years ago
trunk: replace remaining OPA by OCE
Property svn:keywords set to `Id`
File size: 72.4 KB

Line
1	MODULE agrif_oce_interp
2	!!======================================================================
3	!! * MODULE agrif_oce_interp *
4	!! AGRIF: interpolation package for the ocean dynamics (OCE)
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	USE lbclnk
37
38	IMPLICIT NONE
39	PRIVATE
40
41	PUBLIC Agrif_dyn, Agrif_ssh, Agrif_dyn_ts, Agrif_dyn_ts_flux, Agrif_ssh_ts, Agrif_dta_ts
42	PUBLIC Agrif_tra, Agrif_avm
43	PUBLIC interpun , interpvn
44	PUBLIC interptsn, interpsshn, interpavm
45	PUBLIC interpunb, interpvnb , interpub2b, interpvb2b
46	PUBLIC interpe3t, interpglamt, interpgphit
47	PUBLIC interpht0, interpmbkt, interpe3t0_vremap
48	PUBLIC agrif_istate_oce, agrif_istate_ssh ! called by icestate.F90 and domvvl.F90
49	PUBLIC agrif_check_bat
50
51	INTEGER :: bdy_tinterp = 0
52
53	!! * Substitutions
54	# include "domzgr_substitute.h90"
55	!! NEMO/NST 4.0 , NEMO Consortium (2018)
56	!! $Id$
57	!! Software governed by the CeCILL license (see ./LICENSE)
58	!!----------------------------------------------------------------------
59	CONTAINS
60
61	SUBROUTINE Agrif_istate_oce( Kbb, Kmm, Kaa )
62	!!----------------------------------------------------------------------
63	!! * ROUTINE agrif_istate_oce *
64	!!
65	!! set initial t, s, u, v, ssh from parent
66	!!----------------------------------------------------------------------
67	!
68	IMPLICIT NONE
69	!
70	INTEGER, INTENT(in) :: Kbb, Kmm, Kaa
71	INTEGER :: jn
72	!!----------------------------------------------------------------------
73	IF(lwp) WRITE(numout,*) ' '
74	IF(lwp) WRITE(numout,*) 'Agrif_istate_oce : interp child initial state from parent'
75	IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~~~'
76	IF(lwp) WRITE(numout,*) ' '
77
78	IF ( .NOT.Agrif_Parent(l_1st_euler) ) &
79	& CALL ctl_stop('AGRIF hot start requires to force Euler first step on parent')
80
81	l_ini_child = .TRUE.
82	Agrif_SpecialValue = 0.0_wp
83	Agrif_UseSpecialValue = .TRUE.
84
85	ts(:,:,:,:,Kbb) = 0.0_wp
86	uu(:,:,:,Kbb) = 0.0_wp
87	vv(:,:,:,Kbb) = 0.0_wp
88
89	Krhs_a = Kbb ; Kmm_a = Kbb
90
91	CALL Agrif_Init_Variable(tsini_id, procname=interptsn)
92
93	Agrif_UseSpecialValue = ln_spc_dyn
94	use_sign_north = .TRUE.
95	sign_north = -1._wp
96	CALL Agrif_Init_Variable(uini_id , procname=interpun )
97	CALL Agrif_Init_Variable(vini_id , procname=interpvn )
98	use_sign_north = .FALSE.
99
100	Agrif_UseSpecialValue = .FALSE.
101	l_ini_child = .FALSE.
102
103	Krhs_a = Kaa ; Kmm_a = Kmm
104
105	DO jn = 1, jpts
106	ts(:,:,:,jn,Kbb) = ts(:,:,:,jn,Kbb) * tmask(:,:,:)
107	END DO
108	uu(:,:,:,Kbb) = uu(:,:,:,Kbb) * umask(:,:,:)
109	vv(:,:,:,Kbb) = vv(:,:,:,Kbb) * vmask(:,:,:)
110
111	CALL lbc_lnk_multi( 'agrif_istate_oce', uu(:,:,: ,Kbb), 'U', -1.0_wp , vv(:,:,:,Kbb), 'V', -1.0_wp )
112	CALL lbc_lnk( 'agrif_istate_oce', ts(:,:,:,:,Kbb), 'T', 1.0_wp )
113
114	END SUBROUTINE Agrif_istate_oce
115
116
117	SUBROUTINE Agrif_istate_ssh( Kbb, Kmm, Kaa )
118	!!----------------------------------------------------------------------
119	!! * ROUTINE agrif_istate_ssh *
120	!!
121	!! set initial ssh from parent
122	!!----------------------------------------------------------------------
123	!
124	IMPLICIT NONE
125	!
126	INTEGER, INTENT(in) :: Kbb, Kmm, Kaa
127	!!----------------------------------------------------------------------
128	IF(lwp) WRITE(numout,*) ' '
129	IF(lwp) WRITE(numout,*) 'Agrif_istate_ssh : interp child ssh from parent'
130	IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~~~'
131	IF(lwp) WRITE(numout,*) ' '
132
133	IF ( .NOT.Agrif_Parent(l_1st_euler) ) &
134	& CALL ctl_stop('AGRIF hot start requires to force Euler first step on parent')
135
136	Krhs_a = Kbb ; Kmm_a = Kbb
137	!
138	Agrif_SpecialValue = 0._wp
139	Agrif_UseSpecialValue = .TRUE.
140	l_ini_child = .TRUE.
141	!
142	ssh(:,:,Kbb) = 0._wp
143	CALL Agrif_Init_Variable(sshini_id, procname=interpsshn)
144	!
145	Agrif_UseSpecialValue = .FALSE.
146	l_ini_child = .FALSE.
147	!
148	Krhs_a = Kaa ; Kmm_a = Kmm
149	!
150	CALL lbc_lnk( 'Agrif_istate_ssh', ssh(:,:,Kbb), 'T', 1._wp )
151	!
152	ssh(:,:,Kmm) = ssh(:,:,Kbb)
153	ssh(:,:,Kaa) = 0._wp
154
155	END SUBROUTINE Agrif_istate_ssh
156
157
158	SUBROUTINE Agrif_tra
159	!!----------------------------------------------------------------------
160	!! * ROUTINE Agrif_tra *
161	!!----------------------------------------------------------------------
162	!
163	IF( Agrif_Root() ) RETURN
164	!
165	Agrif_SpecialValue = 0._wp
166	Agrif_UseSpecialValue = .TRUE.
167	l_vremap = ln_vert_remap
168	!
169	CALL Agrif_Bc_variable( ts_interp_id, procname=interptsn )
170	!
171	Agrif_UseSpecialValue = .FALSE.
172	l_vremap = .FALSE.
173	!
174	END SUBROUTINE Agrif_tra
175
176
177	SUBROUTINE Agrif_dyn( kt )
178	!!----------------------------------------------------------------------
179	!! * ROUTINE Agrif_DYN *
180	!!----------------------------------------------------------------------
181	INTEGER, INTENT(in) :: kt
182	!
183	INTEGER :: ji, jj, jk ! dummy loop indices
184	INTEGER :: ibdy1, jbdy1, ibdy2, jbdy2
185	REAL(wp), DIMENSION(jpi,jpj) :: zub, zvb
186	!!----------------------------------------------------------------------
187	!
188	IF( Agrif_Root() ) RETURN
189	!
190	Agrif_SpecialValue = 0.0_wp
191	Agrif_UseSpecialValue = ln_spc_dyn
192	l_vremap = ln_vert_remap
193	!
194	use_sign_north = .TRUE.
195	sign_north = -1.0_wp
196	CALL Agrif_Bc_variable( un_interp_id, procname=interpun )
197	CALL Agrif_Bc_variable( vn_interp_id, procname=interpvn )
198
199	IF( .NOT.ln_dynspg_ts ) THEN ! Get transports
200	ubdy(:,:) = 0._wp ; vbdy(:,:) = 0._wp
201	utint_stage(:,:) = 0 ; vtint_stage(:,:) = 0
202	CALL Agrif_Bc_variable( unb_interp_id, procname=interpunb )
203	CALL Agrif_Bc_variable( vnb_interp_id, procname=interpvnb )
204	ENDIF
205
206	use_sign_north = .FALSE.
207	!
208	Agrif_UseSpecialValue = .FALSE.
209	l_vremap = .FALSE.
210	!
211	! Ensure below that vertically integrated transports match
212	! either transports out of time splitting procedure (ln_dynspg_ts=.TRUE.)
213	! or parent grid transports (ln_dynspg_ts=.FALSE.)
214	!
215	! --- West --- !
216	IF( lk_west ) THEN
217	ibdy1 = nn_hls + 2 ! halo + land + 1
218	ibdy2 = nn_hls + 1 + nbghostcells + nn_shift_bar*Agrif_Rhox() ! halo + land + nbghostcells
219	!
220	IF( .NOT.ln_dynspg_ts ) THEN ! Store transport
221	DO ji = mi0(ibdy1), mi1(ibdy2)
222	DO jj = 1, jpj
223	uu_b(ji,jj,Krhs_a) = ubdy(ji,jj) * r1_hu(ji,jj,Krhs_a)
224	vv_b(ji,jj,Krhs_a) = vbdy(ji,jj) * r1_hv(ji,jj,Krhs_a)
225	END DO
226	END DO
227	ENDIF
228	!
229	DO ji = mi0(ibdy1), mi1(ibdy2)
230	zub(ji,:) = 0._wp
231	DO jk = 1, jpkm1
232	DO jj = 1, jpj
233	zub(ji,jj) = zub(ji,jj) + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk)
234	END DO
235	END DO
236	DO jj=1,jpj
237	zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a)
238	END DO
239	DO jk = 1, jpkm1
240	DO jj = 1, jpj
241	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)
242	END DO
243	END DO
244	END DO
245	!
246	DO ji = mi0(ibdy1), mi1(ibdy2)
247	zvb(ji,:) = 0._wp
248	DO jk = 1, jpkm1
249	DO jj = 1, jpj
250	zvb(ji,jj) = zvb(ji,jj) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk)
251	END DO
252	END DO
253	DO jj = 1, jpj
254	zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a)
255	END DO
256	DO jk = 1, jpkm1
257	DO jj = 1, jpj
258	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)
259	END DO
260	END DO
261	END DO
262	!
263	ENDIF
264
265	! --- East --- !
266	IF( lk_east) THEN
267	ibdy1 = jpiglo - ( nn_hls + nbghostcells + 1) - nn_shift_bar*Agrif_Rhox()
268	ibdy2 = jpiglo - ( nn_hls + 2 )
269	!
270	IF( .NOT.ln_dynspg_ts ) THEN
271	DO ji = mi0(ibdy1), mi1(ibdy2)
272	DO jj = 1, jpj
273	uu_b(ji,jj,Krhs_a) = ubdy(ji,jj) * r1_hu(ji,jj,Krhs_a)
274	END DO
275	END DO
276	ENDIF
277	!
278	DO ji = mi0(ibdy1), mi1(ibdy2)
279	zub(ji,:) = 0._wp
280	DO jk = 1, jpkm1
281	DO jj = 1, jpj
282	zub(ji,jj) = zub(ji,jj) + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk)
283	END DO
284	END DO
285	DO jj=1,jpj
286	zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a)
287	END DO
288	DO jk = 1, jpkm1
289	DO jj = 1, jpj
290	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)
291	END DO
292	END DO
293	END DO
294	!
295	ibdy1 = jpiglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhox()
296	ibdy2 = jpiglo - ( nn_hls + 1 )
297	!
298	IF( .NOT.ln_dynspg_ts ) THEN
299	DO ji = mi0(ibdy1), mi1(ibdy2)
300	DO jj = 1, jpj
301	vv_b(ji,jj,Krhs_a) = vbdy(ji,jj) * r1_hv(ji,jj,Krhs_a)
302	END DO
303	END DO
304	ENDIF
305	!
306	DO ji = mi0(ibdy1), mi1(ibdy2)
307	zvb(ji,:) = 0._wp
308	DO jk = 1, jpkm1
309	DO jj = 1, jpj
310	zvb(ji,jj) = zvb(ji,jj) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk)
311	END DO
312	END DO
313	DO jj = 1, jpj
314	zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a)
315	END DO
316	DO jk = 1, jpkm1
317	DO jj = 1, jpj
318	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)
319	END DO
320	END DO
321	END DO
322	!
323	ENDIF
324
325	! --- South --- !
326	IF( lk_south ) THEN
327	jbdy1 = nn_hls + 2
328	jbdy2 = nn_hls + 1 + nbghostcells + nn_shift_bar*Agrif_Rhoy()
329	!
330	IF( .NOT.ln_dynspg_ts ) THEN
331	DO jj = mj0(jbdy1), mj1(jbdy2)
332	DO ji = 1, jpi
333	uu_b(ji,jj,Krhs_a) = ubdy(ji,jj) * r1_hu(ji,jj,Krhs_a)
334	vv_b(ji,jj,Krhs_a) = vbdy(ji,jj) * r1_hv(ji,jj,Krhs_a)
335	END DO
336	END DO
337	ENDIF
338	!
339	DO jj = mj0(jbdy1), mj1(jbdy2)
340	zvb(:,jj) = 0._wp
341	DO jk=1,jpkm1
342	DO ji=1,jpi
343	zvb(ji,jj) = zvb(ji,jj) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk)
344	END DO
345	END DO
346	DO ji = 1, jpi
347	zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a)
348	END DO
349	DO jk = 1, jpkm1
350	DO ji = 1, jpi
351	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)
352	END DO
353	END DO
354	END DO
355	!
356	DO jj = mj0(jbdy1), mj1(jbdy2)
357	zub(:,jj) = 0._wp
358	DO jk = 1, jpkm1
359	DO ji = 1, jpi
360	zub(ji,jj) = zub(ji,jj) + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk)
361	END DO
362	END DO
363	DO ji = 1, jpi
364	zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a)
365	END DO
366	DO jk = 1, jpkm1
367	DO ji = 1, jpi
368	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)
369	END DO
370	END DO
371	END DO
372	!
373	ENDIF
374
375	! --- North --- !
376	IF( lk_north ) THEN
377	jbdy1 = jpjglo - ( nn_hls + nbghostcells + 1) - nn_shift_bar*Agrif_Rhoy()
378	jbdy2 = jpjglo - ( nn_hls + 2 )
379	!
380	IF( .NOT.ln_dynspg_ts ) THEN
381	DO jj = mj0(jbdy1), mj1(jbdy2)
382	DO ji = 1, jpi
383	vv_b(ji,jj,Krhs_a) = vbdy(ji,jj) * r1_hv(ji,jj,Krhs_a)
384	END DO
385	END DO
386	ENDIF
387	!
388	DO jj = mj0(jbdy1), mj1(jbdy2)
389	zvb(:,jj) = 0._wp
390	DO jk=1,jpkm1
391	DO ji=1,jpi
392	zvb(ji,jj) = zvb(ji,jj) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk)
393	END DO
394	END DO
395	DO ji = 1, jpi
396	zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a)
397	END DO
398	DO jk = 1, jpkm1
399	DO ji = 1, jpi
400	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)
401	END DO
402	END DO
403	END DO
404	!
405	jbdy1 = jpjglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhoy()
406	jbdy2 = jpjglo - ( nn_hls + 1 )
407	!
408	IF( .NOT.ln_dynspg_ts ) THEN
409	DO jj = mj0(jbdy1), mj1(jbdy2)
410	DO ji = 1, jpi
411	uu_b(ji,jj,Krhs_a) = ubdy(ji,jj) * r1_hu(ji,jj,Krhs_a)
412	END DO
413	END DO
414	ENDIF
415	!
416	DO jj = mj0(jbdy1), mj1(jbdy2)
417	zub(:,jj) = 0._wp
418	DO jk = 1, jpkm1
419	DO ji = 1, jpi
420	zub(ji,jj) = zub(ji,jj) + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk)
421	END DO
422	END DO
423	DO ji = 1, jpi
424	zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a)
425	END DO
426	DO jk = 1, jpkm1
427	DO ji = 1, jpi
428	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)
429	END DO
430	END DO
431	END DO
432	!
433	ENDIF
434	!
435	END SUBROUTINE Agrif_dyn
436
437
438	SUBROUTINE Agrif_dyn_ts( jn )
439	!!----------------------------------------------------------------------
440	!! * ROUTINE Agrif_dyn_ts *
441	!!----------------------------------------------------------------------
442	INTEGER, INTENT(in) :: jn
443	!!
444	INTEGER :: ji, jj
445	INTEGER :: istart, iend, jstart, jend
446	!!----------------------------------------------------------------------
447	!
448	IF( Agrif_Root() ) RETURN
449	!
450	!--- West ---!
451	IF( lk_west ) THEN
452	istart = nn_hls + 2 ! halo + land + 1
453	iend = nn_hls + 1 + nbghostcells + nn_shift_bar*Agrif_Rhox() ! halo + land + nbghostcells
454	DO ji = mi0(istart), mi1(iend)
455	DO jj=1,jpj
456	va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj)
457	ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj)
458	END DO
459	END DO
460	ENDIF
461	!
462	!--- East ---!
463	IF( lk_east ) THEN
464	istart = jpiglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhox()
465	iend = jpiglo - ( nn_hls + 1 )
466	DO ji = mi0(istart), mi1(iend)
467
468	DO jj=1,jpj
469	va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj)
470	END DO
471	END DO
472	istart = jpiglo - ( nn_hls + nbghostcells + 1) - nn_shift_bar*Agrif_Rhox()
473	iend = jpiglo - ( nn_hls + 2 )
474	DO ji = mi0(istart), mi1(iend)
475	DO jj=1,jpj
476	ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj)
477	END DO
478	END DO
479	ENDIF
480	!
481	!--- South ---!
482	IF( lk_south ) THEN
483	jstart = nn_hls + 2
484	jend = nn_hls + 1 + nbghostcells + nn_shift_bar*Agrif_Rhoy()
485	DO jj = mj0(jstart), mj1(jend)
486
487	DO ji=1,jpi
488	ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj)
489	va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj)
490	END DO
491	END DO
492	ENDIF
493	!
494	!--- North ---!
495	IF( lk_north ) THEN
496	jstart = jpjglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhoy()
497	jend = jpjglo - ( nn_hls + 1 )
498	DO jj = mj0(jstart), mj1(jend)
499	DO ji=1,jpi
500	ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj)
501	END DO
502	END DO
503	jstart = jpjglo - ( nn_hls + nbghostcells + 1) - nn_shift_bar*Agrif_Rhoy()
504	jend = jpjglo - ( nn_hls + 2 )
505	DO jj = mj0(jstart), mj1(jend)
506	DO ji=1,jpi
507	va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj)
508	END DO
509	END DO
510	ENDIF
511	!
512	END SUBROUTINE Agrif_dyn_ts
513
514
515	SUBROUTINE Agrif_dyn_ts_flux( jn, zu, zv )
516	!!----------------------------------------------------------------------
517	!! * ROUTINE Agrif_dyn_ts_flux *
518	!!----------------------------------------------------------------------
519	INTEGER, INTENT(in) :: jn
520	REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: zu, zv
521	!!
522	INTEGER :: ji, jj
523	INTEGER :: istart, iend, jstart, jend
524	!!----------------------------------------------------------------------
525	!
526	IF( Agrif_Root() ) RETURN
527	!
528	!--- West ---!
529	IF( lk_west ) THEN
530	istart = nn_hls + 2
531	iend = nn_hls + 1 + nbghostcells + nn_shift_bar*Agrif_Rhox()
532	DO ji = mi0(istart), mi1(iend)
533	DO jj=1,jpj
534	zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj)
535	zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj)
536	END DO
537	END DO
538	ENDIF
539	!
540	!--- East ---!
541	IF( lk_east ) THEN
542	istart = jpiglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhox()
543	iend = jpiglo - ( nn_hls + 1 )
544	DO ji = mi0(istart), mi1(iend)
545	DO jj=1,jpj
546	zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj)
547	END DO
548	END DO
549	istart = jpiglo - ( nn_hls + nbghostcells + 1) - nn_shift_bar*Agrif_Rhox()
550	iend = jpiglo - ( nn_hls + 2 )
551	DO ji = mi0(istart), mi1(iend)
552	DO jj=1,jpj
553	zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj)
554	END DO
555	END DO
556	ENDIF
557	!
558	!--- South ---!
559	IF( lk_south ) THEN
560	jstart = nn_hls + 2
561	jend = nn_hls + 1 + nbghostcells + nn_shift_bar*Agrif_Rhoy()
562	DO jj = mj0(jstart), mj1(jend)
563	DO ji=1,jpi
564	zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj)
565	zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj)
566	END DO
567	END DO
568	ENDIF
569	!
570	!--- North ---!
571	IF( lk_north ) THEN
572	jstart = jpjglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhoy()
573	jend = jpjglo - ( nn_hls + 1 )
574	DO jj = mj0(jstart), mj1(jend)
575	DO ji=1,jpi
576	zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj)
577	END DO
578	END DO
579	jstart = jpjglo - ( nn_hls + nbghostcells + 1) - nn_shift_bar*Agrif_Rhoy()
580	jend = jpjglo - ( nn_hls + 2 )
581	DO jj = mj0(jstart), mj1(jend)
582	DO ji=1,jpi
583	zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj)
584	END DO
585	END DO
586	ENDIF
587	!
588	END SUBROUTINE Agrif_dyn_ts_flux
589
590
591	SUBROUTINE Agrif_dta_ts( kt )
592	!!----------------------------------------------------------------------
593	!! * ROUTINE Agrif_dta_ts *
594	!!----------------------------------------------------------------------
595	INTEGER, INTENT(in) :: kt
596	!!
597	LOGICAL :: ll_int_cons
598	!!----------------------------------------------------------------------
599	!
600	IF( Agrif_Root() ) RETURN
601	!
602	ll_int_cons = ln_bt_fw ! Assume conservative temporal integration in the forward case only
603	!
604	! Enforce volume conservation if no time refinement:
605	IF ( Agrif_rhot()==1 ) ll_int_cons=.TRUE.
606	!
607	! Interpolate barotropic fluxes
608	Agrif_SpecialValue = 0._wp
609	Agrif_UseSpecialValue = ln_spc_dyn
610
611	use_sign_north = .TRUE.
612	sign_north = -1.
613
614	!
615	! Set bdy time interpolation stage to 0 (latter incremented locally do deal with corners)
616	utint_stage(:,:) = 0
617	vtint_stage(:,:) = 0
618	!
619	IF( ll_int_cons ) THEN ! Conservative interpolation
620	IF ( lk_tint2d_notinterp ) THEN
621	Agrif_UseSpecialValue = .FALSE.
622	CALL Agrif_Bc_variable( ub2b_interp_id, calledweight=1._wp, procname=interpub2b_const )
623	CALL Agrif_Bc_variable( vb2b_interp_id, calledweight=1._wp, procname=interpvb2b_const )
624	! Divergence conserving correction terms:
625	IF ( Agrif_Rhox()>1 ) CALL Agrif_Bc_variable( ub2b_cor_id, calledweight=1._wp, procname=ub2b_cor )
626	IF ( Agrif_Rhoy()>1 ) CALL Agrif_Bc_variable( vb2b_cor_id, calledweight=1._wp, procname=vb2b_cor )
627	ELSE
628	! order matters here !!!!!!
629	CALL Agrif_Bc_variable( ub2b_interp_id, calledweight=1._wp, procname=interpub2b ) ! Time integrated
630	CALL Agrif_Bc_variable( vb2b_interp_id, calledweight=1._wp, procname=interpvb2b )
631	!
632	bdy_tinterp = 1
633	CALL Agrif_Bc_variable( unb_interp_id , calledweight=1._wp, procname=interpunb ) ! After
634	CALL Agrif_Bc_variable( vnb_interp_id , calledweight=1._wp, procname=interpvnb )
635	!
636	bdy_tinterp = 2
637	CALL Agrif_Bc_variable( unb_interp_id , calledweight=0._wp, procname=interpunb ) ! Before
638	CALL Agrif_Bc_variable( vnb_interp_id , calledweight=0._wp, procname=interpvnb )
639	ENDIF
640	ELSE ! Linear interpolation
641	!
642	ubdy(:,:) = 0._wp ; vbdy(:,:) = 0._wp
643	CALL Agrif_Bc_variable( unb_interp_id, procname=interpunb )
644	CALL Agrif_Bc_variable( vnb_interp_id, procname=interpvnb )
645	ENDIF
646	Agrif_UseSpecialValue = .FALSE.
647	use_sign_north = .FALSE.
648	!
649	END SUBROUTINE Agrif_dta_ts
650
651
652	SUBROUTINE Agrif_ssh( kt )
653	!!----------------------------------------------------------------------
654	!! * ROUTINE Agrif_ssh *
655	!!----------------------------------------------------------------------
656	INTEGER, INTENT(in) :: kt
657	!
658	INTEGER :: ji, jj
659	INTEGER :: istart, iend, jstart, jend
660	!!----------------------------------------------------------------------
661	!
662	IF( Agrif_Root() ) RETURN
663	!
664	! Linear time interpolation of sea level
665	!
666	Agrif_SpecialValue = 0._wp
667	Agrif_UseSpecialValue = .TRUE.
668	CALL Agrif_Bc_variable(sshn_id, procname=interpsshn )
669	Agrif_UseSpecialValue = .FALSE.
670	!
671	! --- West --- !
672	IF(lk_west) THEN
673	istart = nn_hls + 2 ! halo + land + 1
674	iend = nn_hls + 1 + nbghostcells + nn_shift_bar*Agrif_Rhox() ! halo + land + nbghostcells
675	DO ji = mi0(istart), mi1(iend)
676	DO jj = 1, jpj
677	ssh(ji,jj,Krhs_a) = hbdy(ji,jj)
678	END DO
679	END DO
680	ENDIF
681	!
682	! --- East --- !
683	IF(lk_east) THEN
684	istart = jpiglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhox() ! halo + land + nbghostcells - 1
685	iend = jpiglo - ( nn_hls + 1 ) ! halo + land + 1 - 1
686	DO ji = mi0(istart), mi1(iend)
687	DO jj = 1, jpj
688	ssh(ji,jj,Krhs_a) = hbdy(ji,jj)
689	END DO
690	END DO
691	ENDIF
692	!
693	! --- South --- !
694	IF(lk_south) THEN
695	jstart = nn_hls + 2 ! halo + land + 1
696	jend = nn_hls + 1 + nbghostcells + nn_shift_bar*Agrif_Rhoy() ! halo + land + nbghostcells
697	DO jj = mj0(jstart), mj1(jend)
698	DO ji = 1, jpi
699	ssh(ji,jj,Krhs_a) = hbdy(ji,jj)
700	END DO
701	END DO
702	ENDIF
703	!
704	! --- North --- !
705	IF(lk_north) THEN
706	jstart = jpjglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhoy() ! halo + land + nbghostcells - 1
707	jend = jpjglo - ( nn_hls + 1 ) ! halo + land + 1 - 1
708	DO jj = mj0(jstart), mj1(jend)
709	DO ji = 1, jpi
710	ssh(ji,jj,Krhs_a) = hbdy(ji,jj)
711	END DO
712	END DO
713	ENDIF
714	!
715	END SUBROUTINE Agrif_ssh
716
717
718	SUBROUTINE Agrif_ssh_ts( jn )
719	!!----------------------------------------------------------------------
720	!! * ROUTINE Agrif_ssh_ts *
721	!!----------------------------------------------------------------------
722	INTEGER, INTENT(in) :: jn
723	!!
724	INTEGER :: ji, jj
725	INTEGER :: istart, iend, jstart, jend
726	!!----------------------------------------------------------------------
727	!
728	IF( Agrif_Root() ) RETURN
729	!
730	! --- West --- !
731	IF(lk_west) THEN
732	istart = nn_hls + 2 ! halo + land + 1
733	iend = nn_hls + 1 + nbghostcells + nn_shift_bar*Agrif_Rhox() ! halo + land + nbghostcells
734	DO ji = mi0(istart), mi1(iend)
735	DO jj = 1, jpj
736	ssha_e(ji,jj) = hbdy(ji,jj)
737	END DO
738	END DO
739	ENDIF
740	!
741	! --- East --- !
742	IF(lk_east) THEN
743	istart = jpiglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhox() ! halo + land + nbghostcells - 1
744	iend = jpiglo - ( nn_hls + 1 ) ! halo + land + 1 - 1
745	DO ji = mi0(istart), mi1(iend)
746	DO jj = 1, jpj
747	ssha_e(ji,jj) = hbdy(ji,jj)
748	END DO
749	END DO
750	ENDIF
751	!
752	! --- South --- !
753	IF(lk_south) THEN
754	jstart = nn_hls + 2 ! halo + land + 1
755	jend = nn_hls + 1 + nbghostcells + nn_shift_bar*Agrif_Rhoy() ! halo + land + nbghostcells
756	DO jj = mj0(jstart), mj1(jend)
757	DO ji = 1, jpi
758	ssha_e(ji,jj) = hbdy(ji,jj)
759	END DO
760	END DO
761	ENDIF
762	!
763	! --- North --- !
764	IF(lk_north) THEN
765	jstart = jpjglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhoy() ! halo + land + nbghostcells - 1
766	jend = jpjglo - ( nn_hls + 1 ) ! halo + land + 1 - 1
767	DO jj = mj0(jstart), mj1(jend)
768	DO ji = 1, jpi
769	ssha_e(ji,jj) = hbdy(ji,jj)
770	END DO
771	END DO
772	ENDIF
773	!
774	END SUBROUTINE Agrif_ssh_ts
775
776
777	SUBROUTINE Agrif_avm
778	!!----------------------------------------------------------------------
779	!! * ROUTINE Agrif_avm *
780	!!----------------------------------------------------------------------
781	REAL(wp) :: zalpha
782	!!----------------------------------------------------------------------
783	!
784	IF( Agrif_Root() ) RETURN
785	!
786	zalpha = 1._wp ! JC: proper time interpolation impossible
787	! => use last available value from parent
788	!
789	Agrif_SpecialValue = 0.e0
790	Agrif_UseSpecialValue = .TRUE.
791	l_vremap = ln_vert_remap
792	!
793	CALL Agrif_Bc_variable( avm_id, calledweight=zalpha, procname=interpavm )
794	!
795	Agrif_UseSpecialValue = .FALSE.
796	l_vremap = .FALSE.
797	!
798	END SUBROUTINE Agrif_avm
799
800
801	SUBROUTINE interptsn( ptab, i1, i2, j1, j2, k1, k2, n1, n2, before )
802	!!----------------------------------------------------------------------
803	REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: ptab
804	INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, n1, n2
805	LOGICAL , INTENT(in ) :: before
806	!
807	INTEGER :: ji, jj, jk, jn ! dummy loop indices
808	INTEGER :: N_in, N_out
809	INTEGER :: item
810	! vertical interpolation:
811	REAL(wp) :: zhtot, zwgt
812	REAL(wp), DIMENSION(k1:k2,1:jpts) :: tabin, tabin_i
813	REAL(wp), DIMENSION(k1:k2) :: z_in, h_in_i, z_in_i
814	REAL(wp), DIMENSION(1:jpk) :: h_out, z_out
815	!!----------------------------------------------------------------------
816
817	IF( before ) THEN
818
819	item = Kmm_a
820	IF( l_ini_child ) Kmm_a = Kbb_a
821
822	DO jn = 1,jpts
823	DO jk=k1,k2
824	DO jj=j1,j2
825	DO ji=i1,i2
826	ptab(ji,jj,jk,jn) = ts(ji,jj,jk,jn,Kmm_a)
827	END DO
828	END DO
829	END DO
830	END DO
831
832	IF( l_vremap .OR. l_ini_child .OR. ln_zps ) THEN
833
834	! Fill cell depths (i.e. gdept) to be interpolated
835	! Warning: these are masked, hence extrapolated prior interpolation.
836	DO jj=j1,j2
837	DO ji=i1,i2
838	ptab(ji,jj,k1,jpts+1) = 0.5_wp * tmask(ji,jj,k1) * e3t(ji,jj,k1,Kmm_a)
839	DO jk=k1+1,k2
840	ptab(ji,jj,jk,jpts+1) = tmask(ji,jj,jk) * &
841	& ( ptab(ji,jj,jk-1,jpts+1) + 0.5_wp * (e3t(ji,jj,jk-1,Kmm_a)+e3t(ji,jj,jk,Kmm_a)) )
842	END DO
843	END DO
844	END DO
845
846	! Save ssh at last level:
847	IF (.NOT.ln_linssh) THEN
848	ptab(i1:i2,j1:j2,k2,jpts+1) = ssh(i1:i2,j1:j2,Kmm_a)*tmask(i1:i2,j1:j2,1)
849	END IF
850	ENDIF
851	Kmm_a = item
852
853	ELSE
854	item = Krhs_a
855	IF( l_ini_child ) Krhs_a = Kbb_a
856
857	IF( l_vremap .OR. l_ini_child ) THEN
858	IF (ln_linssh) ptab(i1:i2,j1:j2,k2,n2) = 0._wp
859	DO jj=j1,j2
860	DO ji=i1,i2
861	ts(ji,jj,:,:,Krhs_a) = 0.
862	!
863	! Build vertical grids:
864	N_in = mbkt_parent(ji,jj)
865	N_out = mbkt(ji,jj)
866	IF (N_in*N_out > 0) THEN
867	! Input grid (account for partial cells if any):
868	DO jk=1,N_in
869	z_in(jk) = ptab(ji,jj,jk,n2) - ptab(ji,jj,k2,n2)
870	tabin(jk,1:jpts) = ptab(ji,jj,jk,1:jpts)
871	END DO
872
873	! Intermediate grid:
874	IF ( l_vremap ) THEN
875	DO jk = 1, N_in
876	h_in_i(jk) = e3t0_parent(ji,jj,jk) * &
877	& (1._wp + ptab(ji,jj,k2,n2)/(ht0_parent(ji,jj)*ssmask(ji,jj) + 1._wp - ssmask(ji,jj)))
878	END DO
879	z_in_i(1) = 0.5_wp * h_in_i(1)
880	DO jk=2,N_in
881	z_in_i(jk) = z_in_i(jk-1) + 0.5_wp * ( h_in_i(jk) + h_in_i(jk-1) )
882	END DO
883	z_in_i(1:N_in) = z_in_i(1:N_in) - ptab(ji,jj,k2,n2)
884	ENDIF
885
886	! Output (Child) grid:
887	DO jk=1,N_out
888	h_out(jk) = e3t(ji,jj,jk,Krhs_a)
889	END DO
890	z_out(1) = 0.5_wp * h_out(1)
891	DO jk=2,N_out
892	z_out(jk) = z_out(jk-1) + 0.5_wp * ( h_out(jk)+h_out(jk-1) )
893	END DO
894	IF (.NOT.ln_linssh) z_out(1:N_out) = z_out(1:N_out) - ssh(ji,jj,Krhs_a)
895
896	IF( l_ini_child ) THEN
897	CALL remap_linear(tabin(1:N_in,1:jpts),z_in(1:N_in),ts(ji,jj,1:N_out,1:jpts,Krhs_a), &
898	& z_out(1:N_out),N_in,N_out,jpts)
899	ELSE
900	CALL remap_linear(tabin(1:N_in,1:jpts),z_in(1:N_in),tabin_i(1:N_in,1:jpts), &
901	& z_in_i(1:N_in),N_in,N_in,jpts)
902	CALL reconstructandremap(tabin_i(1:N_in,1:jpts),h_in_i(1:N_in),ts(ji,jj,1:N_out,1:jpts,Krhs_a), &
903	& h_out(1:N_out),N_in,N_out,jpts)
904	ENDIF
905	ENDIF
906	END DO
907	END DO
908	Krhs_a = item
909
910	ELSE
911
912	IF ( Agrif_Parent(ln_zps) ) THEN ! Account for partial cells
913	! linear vertical interpolation
914	DO jj=j1,j2
915	DO ji=i1,i2
916	!
917	N_in = mbkt(ji,jj)
918	N_out = mbkt(ji,jj)
919	z_in(1) = ptab(ji,jj,1,n2)
920	tabin(1,1:jpts) = ptab(ji,jj,1,1:jpts)
921	DO jk=2, N_in
922	z_in(jk) = ptab(ji,jj,jk,n2)
923	tabin(jk,1:jpts) = ptab(ji,jj,jk,1:jpts)
924	END DO
925	IF (.NOT.ln_linssh) z_in(1:N_in) = z_in(1:N_in) - ptab(ji,jj,k2,n2)
926	z_out(1) = 0.5_wp * e3t(ji,jj,1,Krhs_a)
927	DO jk=2, N_out
928	z_out(jk) = z_out(jk-1) + 0.5_wp * (e3t(ji,jj,jk-1,Krhs_a) + e3t(ji,jj,jk,Krhs_a))
929	END DO
930	IF (.NOT.ln_linssh) z_out(1:N_out) = z_out(1:N_out) - ssh(ji,jj,Krhs_a)
931	CALL remap_linear(tabin(1:N_in,1:jpts),z_in(1:N_in),ptab(ji,jj,1:N_out,1:jpts), &
932	& z_out(1:N_out),N_in,N_out,jpts)
933	END DO
934	END DO
935	ENDIF
936
937	DO jn =1, jpts
938	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)
939	END DO
940	ENDIF
941
942	ENDIF
943	!
944	END SUBROUTINE interptsn
945
946
947	SUBROUTINE interpsshn( ptab, i1, i2, j1, j2, before )
948	!!----------------------------------------------------------------------
949	!! * ROUTINE interpsshn *
950	!!----------------------------------------------------------------------
951	INTEGER , INTENT(in ) :: i1, i2, j1, j2
952	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
953	LOGICAL , INTENT(in ) :: before
954	!
955	!!----------------------------------------------------------------------
956	!
957	IF( before) THEN
958	ptab(i1:i2,j1:j2) = ssh(i1:i2,j1:j2,Kmm_a)
959	ELSE
960	IF( l_ini_child ) THEN
961	ssh(i1:i2,j1:j2,Krhs_a) = ptab(i1:i2,j1:j2) * tmask(i1:i2,j1:j2,1)
962	ELSE
963	hbdy(i1:i2,j1:j2) = ptab(i1:i2,j1:j2) * tmask(i1:i2,j1:j2,1)
964	ENDIF
965	ENDIF
966	!
967	END SUBROUTINE interpsshn
968
969
970	SUBROUTINE interpun( ptab, i1, i2, j1, j2, k1, k2, m1, m2, before )
971	!!----------------------------------------------------------------------
972	!! * ROUTINE interpun *
973	!!---------------------------------------------
974	!!
975	INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,m1,m2
976	REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,m1:m2), INTENT(inout) :: ptab
977	LOGICAL, INTENT(in) :: before
978	!!
979	INTEGER :: ji,jj,jk
980	REAL(wp) :: zrhoy, zhtot
981	! vertical interpolation:
982	REAL(wp), DIMENSION(k1:k2) :: tabin, h_in, z_in
983	REAL(wp), DIMENSION(1:jpk) :: h_out, z_out
984	INTEGER :: N_in, N_out,item
985	REAL(wp) :: h_diff
986	!!---------------------------------------------
987	!
988	IF (before) THEN
989
990	item = Kmm_a
991	IF( l_ini_child ) Kmm_a = Kbb_a
992
993	DO jk=1,jpk
994	DO jj=j1,j2
995	DO ji=i1,i2
996	ptab(ji,jj,jk,1) = (e2u(ji,jj) * e3u(ji,jj,jk,Kmm_a) * uu(ji,jj,jk,Kmm_a)*umask(ji,jj,jk))
997	IF( l_vremap .OR. l_ini_child) THEN
998	! Interpolate thicknesses (masked for subsequent extrapolation)
999	ptab(ji,jj,jk,2) = umask(ji,jj,jk) * e2u(ji,jj) * e3u(ji,jj,jk,Kmm_a)
1000	ENDIF
1001	END DO
1002	END DO
1003	END DO
1004
1005	IF( l_vremap .OR. l_ini_child ) THEN
1006	! Extrapolate thicknesses in partial bottom cells:
1007	! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on
1008	IF (ln_zps) THEN
1009	DO jj=j1,j2
1010	DO ji=i1,i2
1011	jk = mbku(ji,jj)
1012	ptab(ji,jj,jk,2) = 0._wp
1013	END DO
1014	END DO
1015	END IF
1016
1017	! Save ssh at last level:
1018	ptab(i1:i2,j1:j2,k2,2) = 0._wp
1019	IF (.NOT.ln_linssh) THEN
1020	! This vertical sum below should be replaced by the sea-level at U-points (optimization):
1021	DO jk=1,jpk
1022	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)
1023	END DO
1024	ptab(i1:i2,j1:j2,k2,2) = ptab(i1:i2,j1:j2,k2,2) - hu_0(i1:i2,j1:j2)
1025	END IF
1026	ENDIF
1027
1028	Kmm_a = item
1029	!
1030	ELSE
1031	zrhoy = Agrif_rhoy()
1032
1033	IF( l_vremap .OR. l_ini_child) THEN
1034	! VERTICAL REFINEMENT BEGIN
1035
1036	IF (ln_linssh) ptab(i1:i2,j1:j2,k2,2) = 0._wp
1037
1038	DO ji=i1,i2
1039	DO jj=j1,j2
1040	uu(ji,jj,:,Krhs_a) = 0._wp
1041	N_in = mbku_parent(ji,jj)
1042	N_out = mbku(ji,jj)
1043	IF (N_in*N_out > 0) THEN
1044	zhtot = 0._wp
1045	DO jk=1,N_in
1046	!IF (jk==N_in) THEN
1047	! h_in(jk) = hu0_parent(ji,jj) + ptab(ji,jj,k2,2) - zhtot
1048	!ELSE
1049	! h_in(jk) = ptab(ji,jj,jk,2)/(e2u(ji,jj)*zrhoy)
1050	!ENDIF
1051	IF ( l_vremap ) THEN
1052	h_in(jk) = e3u0_parent(ji,jj,jk)
1053	ELSE
1054	IF (jk==N_in) THEN
1055	h_in(jk) = hu0_parent(ji,jj) + ptab(ji,jj,k2,2) - zhtot
1056	ELSE
1057	h_in(jk) = ptab(ji,jj,jk,2)/(e2u(ji,jj)*zrhoy)
1058	ENDIF
1059	ENDIF
1060	zhtot = zhtot + h_in(jk)
1061	IF( h_in(jk) .GT. 0. ) THEN
1062	tabin(jk) = ptab(ji,jj,jk,1)/(e2u(ji,jj)zrhoyh_in(jk))
1063	ELSE
1064	tabin(jk) = 0.
1065	ENDIF
1066	END DO
1067	z_in(1) = 0.5_wp * h_in(1) - zhtot + hu0_parent(ji,jj)
1068	DO jk=2,N_in
1069	z_in(jk) = z_in(jk-1) + 0.5_wp * (h_in(jk)+h_in(jk-1))
1070	END DO
1071
1072	DO jk=1, N_out
1073	h_out(jk) = e3u(ji,jj,jk,Krhs_a)
1074	END DO
1075
1076	z_out(1) = 0.5_wp * h_out(1) - SUM(h_out(1:N_out)) + hu_0(ji,jj)
1077	DO jk=2,N_out
1078	z_out(jk) = z_out(jk-1) + 0.5_wp * (h_out(jk-1) + h_out(jk))
1079	END DO
1080
1081	IF( l_ini_child ) THEN
1082	CALL remap_linear (tabin(1:N_in),z_in(1:N_in),uu(ji,jj,1:N_out,Krhs_a),z_out(1:N_out),N_in,N_out,1)
1083	ELSE
1084	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)
1085	ENDIF
1086	ENDIF
1087	END DO
1088	END DO
1089	ELSE
1090	DO jk = 1, jpkm1
1091	DO jj=j1,j2
1092	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) )
1093	END DO
1094	END DO
1095	ENDIF
1096
1097	ENDIF
1098	!
1099	END SUBROUTINE interpun
1100
1101
1102	SUBROUTINE interpvn( ptab, i1, i2, j1, j2, k1, k2, m1, m2, before )
1103	!!----------------------------------------------------------------------
1104	!! * ROUTINE interpvn *
1105	!!----------------------------------------------------------------------
1106	!
1107	INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,m1,m2
1108	REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,m1:m2), INTENT(inout) :: ptab
1109	LOGICAL, INTENT(in) :: before
1110	!
1111	INTEGER :: ji,jj,jk
1112	REAL(wp) :: zrhox
1113	! vertical interpolation:
1114	REAL(wp), DIMENSION(k1:k2) :: tabin, h_in, z_in
1115	REAL(wp), DIMENSION(1:jpk) :: h_out, z_out
1116	INTEGER :: N_in, N_out, item
1117	REAL(wp) :: h_diff, zhtot
1118	!!---------------------------------------------
1119	!
1120	IF (before) THEN
1121
1122	item = Kmm_a
1123	IF( l_ini_child ) Kmm_a = Kbb_a
1124
1125	DO jk=k1,k2
1126	DO jj=j1,j2
1127	DO ji=i1,i2
1128	ptab(ji,jj,jk,1) = (e1v(ji,jj) * e3v(ji,jj,jk,Kmm_a) * vv(ji,jj,jk,Kmm_a)*vmask(ji,jj,jk))
1129	IF( l_vremap .OR. l_ini_child) THEN
1130	! Interpolate thicknesses (masked for subsequent extrapolation)
1131	ptab(ji,jj,jk,2) = vmask(ji,jj,jk) * e1v(ji,jj) * e3v(ji,jj,jk,Kmm_a)
1132	ENDIF
1133	END DO
1134	END DO
1135	END DO
1136
1137	IF( l_vremap .OR. l_ini_child) THEN
1138	! Extrapolate thicknesses in partial bottom cells:
1139	! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on
1140	IF (ln_zps) THEN
1141	DO jj=j1,j2
1142	DO ji=i1,i2
1143	jk = mbkv(ji,jj)
1144	ptab(ji,jj,jk,2) = 0._wp
1145	END DO
1146	END DO
1147	END IF
1148	! Save ssh at last level:
1149	ptab(i1:i2,j1:j2,k2,2) = 0._wp
1150	IF (.NOT.ln_linssh) THEN
1151	! This vertical sum below should be replaced by the sea-level at V-points (optimization):
1152	DO jk=1,jpk
1153	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)
1154	END DO
1155	ptab(i1:i2,j1:j2,k2,2) = ptab(i1:i2,j1:j2,k2,2) - hv_0(i1:i2,j1:j2)
1156	END IF
1157	ENDIF
1158	item = Kmm_a
1159
1160	ELSE
1161	zrhox = Agrif_rhox()
1162
1163	IF( l_vremap .OR. l_ini_child ) THEN
1164
1165	IF (ln_linssh) ptab(i1:i2,j1:j2,k2,2) = 0._wp
1166
1167	DO jj=j1,j2
1168	DO ji=i1,i2
1169	vv(ji,jj,:,Krhs_a) = 0._wp
1170	N_in = mbkv_parent(ji,jj)
1171	N_out = mbkv(ji,jj)
1172
1173	IF (N_in*N_out > 0) THEN
1174	zhtot = 0._wp
1175	DO jk=1,N_in
1176	!IF (jk==N_in) THEN
1177	! h_in(jk) = hv0_parent(ji,jj) + ptab(ji,jj,k2,2) - zhtot
1178	!ELSE
1179	! h_in(jk) = ptab(ji,jj,jk,2)/(e1v(ji,jj)*zrhox)
1180	!ENDIF
1181	IF (l_vremap) THEN
1182	h_in(jk) = e3v0_parent(ji,jj,jk)
1183	ELSE
1184	IF (jk==N_in) THEN
1185	h_in(jk) = hv0_parent(ji,jj) + ptab(ji,jj,k2,2) - zhtot
1186	ELSE
1187	h_in(jk) = ptab(ji,jj,jk,2)/(e1v(ji,jj)*zrhox)
1188	ENDIF
1189	ENDIF
1190	zhtot = zhtot + h_in(jk)
1191	IF( h_in(jk) .GT. 0. ) THEN
1192	tabin(jk) = ptab(ji,jj,jk,1)/(e1v(ji,jj)zrhoxh_in(jk))
1193	ELSE
1194	tabin(jk) = 0.
1195	ENDIF
1196	END DO
1197
1198	z_in(1) = 0.5_wp * h_in(1) - zhtot + hv0_parent(ji,jj)
1199	DO jk=2,N_in
1200	z_in(jk) = z_in(jk-1) + 0.5_wp * (h_in(jk-1)+h_in(jk))
1201	END DO
1202
1203	DO jk=1,N_out
1204	h_out(jk) = e3v(ji,jj,jk,Krhs_a)
1205	END DO
1206
1207	z_out(1) = 0.5_wp * h_out(1) - SUM(h_out(1:N_out)) + hv_0(ji,jj)
1208	DO jk=2,N_out
1209	z_out(jk) = z_out(jk-1) + 0.5_wp * (h_out(jk-1)+h_out(jk))
1210	END DO
1211
1212	IF( l_ini_child ) THEN
1213	CALL remap_linear (tabin(1:N_in),z_in(1:N_in),vv(ji,jj,1:N_out,Krhs_a),z_out(1:N_out),N_in,N_out,1)
1214	ELSE
1215	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)
1216	ENDIF
1217	ENDIF
1218	END DO
1219	END DO
1220	ELSE
1221	DO jk = 1, jpkm1
1222	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) )
1223	END DO
1224	ENDIF
1225	ENDIF
1226	!
1227	END SUBROUTINE interpvn
1228
1229	SUBROUTINE interpunb( ptab, i1, i2, j1, j2, before)
1230	!!----------------------------------------------------------------------
1231	!! * ROUTINE interpunb *
1232	!!----------------------------------------------------------------------
1233	INTEGER , INTENT(in ) :: i1, i2, j1, j2
1234	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
1235	LOGICAL , INTENT(in ) :: before
1236	!
1237	INTEGER :: ji, jj
1238	REAL(wp) :: zrhoy, zrhot, zt0, zt1, ztcoeff
1239	!!----------------------------------------------------------------------
1240	!
1241	IF( before ) THEN
1242	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)
1243	ELSE
1244	zrhoy = Agrif_Rhoy()
1245	zrhot = Agrif_rhot()
1246	! Time indexes bounds for integration
1247	zt0 = REAL(Agrif_NbStepint() , wp) / zrhot
1248	zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot
1249	!
1250	DO ji = i1, i2
1251	DO jj = j1, j2
1252	IF ( utint_stage(ji,jj) < (bdy_tinterp + 1) ) THEN
1253	IF ( utint_stage(ji,jj) == 1 ) THEN
1254	ztcoeff = zrhot * ( zt1*2._wp ( zt1 - 1._wp) &
1255	& - zt0*2._wp ( zt0 - 1._wp) )
1256	ELSEIF( utint_stage(ji,jj) == 2 ) THEN
1257	ztcoeff = zrhot * ( zt1 * ( zt1 - 1._wp)**2._wp &
1258	& - zt0 * ( zt0 - 1._wp)**2._wp )
1259	ELSEIF( utint_stage(ji,jj) == 0 ) THEN
1260	ztcoeff = 1._wp
1261	ELSE
1262	ztcoeff = 0._wp
1263	ENDIF
1264	!
1265	ubdy(ji,jj) = ubdy(ji,jj) + ztcoeff * ptab(ji,jj)
1266	!
1267	IF (( utint_stage(ji,jj) == 2 ).OR.( utint_stage(ji,jj) == 0 )) THEN
1268	ubdy(ji,jj) = ubdy(ji,jj) / (zrhoye2u(ji,jj)) umask(ji,jj,1)
1269	ENDIF
1270	!
1271	utint_stage(ji,jj) = utint_stage(ji,jj) + 1
1272	ENDIF
1273	END DO
1274	END DO
1275	END IF
1276	!
1277	END SUBROUTINE interpunb
1278
1279
1280	SUBROUTINE interpvnb( ptab, i1, i2, j1, j2, before )
1281	!!----------------------------------------------------------------------
1282	!! * ROUTINE interpvnb *
1283	!!----------------------------------------------------------------------
1284	INTEGER , INTENT(in ) :: i1, i2, j1, j2
1285	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
1286	LOGICAL , INTENT(in ) :: before
1287	!
1288	INTEGER :: ji, jj
1289	REAL(wp) :: zrhox, zrhot, zt0, zt1, ztcoeff
1290	!!----------------------------------------------------------------------
1291	!
1292	IF( before ) THEN
1293	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)
1294	ELSE
1295	zrhox = Agrif_Rhox()
1296	zrhot = Agrif_rhot()
1297	! Time indexes bounds for integration
1298	zt0 = REAL(Agrif_NbStepint() , wp) / zrhot
1299	zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot
1300	!
1301	DO ji = i1, i2
1302	DO jj = j1, j2
1303	IF ( vtint_stage(ji,jj) < (bdy_tinterp + 1) ) THEN
1304	IF ( vtint_stage(ji,jj) == 1 ) THEN
1305	ztcoeff = zrhot * ( zt1*2._wp ( zt1 - 1._wp) &
1306	& - zt0*2._wp ( zt0 - 1._wp) )
1307	ELSEIF( vtint_stage(ji,jj) == 2 ) THEN
1308	ztcoeff = zrhot * ( zt1 * ( zt1 - 1._wp)**2._wp &
1309	& - zt0 * ( zt0 - 1._wp)**2._wp )
1310	ELSEIF( vtint_stage(ji,jj) == 0 ) THEN
1311	ztcoeff = 1._wp
1312	ELSE
1313	ztcoeff = 0._wp
1314	ENDIF
1315	!
1316	vbdy(ji,jj) = vbdy(ji,jj) + ztcoeff * ptab(ji,jj)
1317	!
1318	IF (( vtint_stage(ji,jj) == 2 ).OR.( vtint_stage(ji,jj) == 0 )) THEN
1319	vbdy(ji,jj) = vbdy(ji,jj) / (zrhoxe1v(ji,jj)) vmask(ji,jj,1)
1320	ENDIF
1321	!
1322	vtint_stage(ji,jj) = vtint_stage(ji,jj) + 1
1323	ENDIF
1324	END DO
1325	END DO
1326	ENDIF
1327	!
1328	END SUBROUTINE interpvnb
1329
1330
1331	SUBROUTINE interpub2b( ptab, i1, i2, j1, j2, before )
1332	!!----------------------------------------------------------------------
1333	!! * ROUTINE interpub2b *
1334	!!----------------------------------------------------------------------
1335	INTEGER , INTENT(in ) :: i1, i2, j1, j2
1336	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
1337	LOGICAL , INTENT(in ) :: before
1338	!
1339	INTEGER :: ji,jj
1340	REAL(wp) :: zrhot, zt0, zt1, zat
1341	!!----------------------------------------------------------------------
1342	IF( before ) THEN
1343	! IF ( ln_bt_fw ) THEN
1344	ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * ub2_b(i1:i2,j1:j2)
1345	! ELSE
1346	! ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * un_adv(i1:i2,j1:j2)
1347	! ENDIF
1348	ELSE
1349	zrhot = Agrif_rhot()
1350	! Time indexes bounds for integration
1351	zt0 = REAL(Agrif_NbStepint() , wp) / zrhot
1352	zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot
1353	! Polynomial interpolation coefficients:
1354	zat = zrhot * ( zt1*2._wp (-2._wp*zt1 + 3._wp) &
1355	& - zt0*2._wp (-2._wp*zt0 + 3._wp) )
1356	!
1357	ubdy(i1:i2,j1:j2) = zat * ptab(i1:i2,j1:j2)
1358	!
1359	! Update interpolation stage:
1360	utint_stage(i1:i2,j1:j2) = 1
1361	ENDIF
1362	!
1363	END SUBROUTINE interpub2b
1364
1365	SUBROUTINE interpub2b_const( ptab, i1, i2, j1, j2, before )
1366	!!----------------------------------------------------------------------
1367	!! * ROUTINE interpub2b_const *
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	REAL(wp) :: zrhoy
1374	!!----------------------------------------------------------------------
1375	IF( before ) THEN
1376	! IF ( ln_bt_fw ) THEN
1377	ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * ub2_b(i1:i2,j1:j2)
1378	! ELSE
1379	! ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * un_adv(i1:i2,j1:j2)
1380	! ENDIF
1381	ELSE
1382	zrhoy = Agrif_Rhoy()
1383	!
1384	ubdy(i1:i2,j1:j2) = ptab(i1:i2,j1:j2) &
1385	& / (zrhoye2u(i1:i2,j1:j2)) umask(i1:i2,j1:j2,1)
1386	!
1387	ENDIF
1388	!
1389	END SUBROUTINE interpub2b_const
1390
1391
1392	SUBROUTINE ub2b_cor( ptab, i1, i2, j1, j2, before )
1393	!!----------------------------------------------------------------------
1394	!! * ROUTINE ub2b_cor *
1395	!!----------------------------------------------------------------------
1396	INTEGER , INTENT(in ) :: i1, i2, j1, j2
1397	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
1398	LOGICAL , INTENT(in ) :: before
1399	!
1400	INTEGER :: ji, jj
1401	REAL(wp) :: zrhox, zrhoy, zx
1402	!!----------------------------------------------------------------------
1403	IF( before ) THEN
1404	ptab(:,:) = 0._wp
1405	DO ji=i1+1,i2-1
1406	DO jj=j1+1,j2-1
1407	ptab(ji,jj) = 0.25_wp( ( vb2_b(ji+1,jj )e1v(ji+1,jj ) &
1408	& -vb2_b(ji-1,jj )*e1v(ji-1,jj ) ) &
1409	& -( vb2_b(ji+1,jj-1)*e1v(ji+1,jj-1) &
1410	& -vb2_b(ji-1,jj-1)*e1v(ji-1,jj-1) ) )
1411	END DO
1412	END DO
1413	ELSE
1414	!
1415	zrhox = Agrif_Rhox()
1416	zrhoy = Agrif_Rhoy()
1417	DO ji=i1,i2
1418	DO jj=j1,j2
1419	IF (utint_stage(ji,jj)==0) THEN
1420	zx = 2._wp*MOD(ABS(mig0(ji)-nbghostcells-1), INT(Agrif_Rhox()))/zrhox - 1._wp
1421	ubdy(ji,jj) = ubdy(ji,jj) + 0.25_wp(1._wp-zxzx) * ptab(ji,jj) &
1422	& / zrhoy r1_e2u(ji,jj) umask(ji,jj,1)
1423	utint_stage(ji,jj) = 1
1424	ENDIF
1425	END DO
1426	END DO
1427	!
1428	ENDIF
1429	!
1430	END SUBROUTINE ub2b_cor
1431
1432
1433	SUBROUTINE interpvb2b( ptab, i1, i2, j1, j2, before )
1434	!!----------------------------------------------------------------------
1435	!! * ROUTINE interpvb2b *
1436	!!----------------------------------------------------------------------
1437	INTEGER , INTENT(in ) :: i1, i2, j1, j2
1438	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
1439	LOGICAL , INTENT(in ) :: before
1440	!
1441	INTEGER :: ji,jj
1442	REAL(wp) :: zrhot, zt0, zt1, zat
1443	!!----------------------------------------------------------------------
1444	!
1445	IF( before ) THEN
1446	! IF ( ln_bt_fw ) THEN
1447	ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * vb2_b(i1:i2,j1:j2)
1448	! ELSE
1449	! ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * vn_adv(i1:i2,j1:j2)
1450	! ENDIF
1451	ELSE
1452	zrhot = Agrif_rhot()
1453	! Time indexes bounds for integration
1454	zt0 = REAL(Agrif_NbStepint() , wp) / zrhot
1455	zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot
1456	! Polynomial interpolation coefficients:
1457	zat = zrhot * ( zt1*2._wp (-2._wp*zt1 + 3._wp) &
1458	& - zt0*2._wp (-2._wp*zt0 + 3._wp) )
1459	!
1460	vbdy(i1:i2,j1:j2) = zat * ptab(i1:i2,j1:j2)
1461	!
1462	! update interpolation stage:
1463	vtint_stage(i1:i2,j1:j2) = 1
1464	ENDIF
1465	!
1466	END SUBROUTINE interpvb2b
1467
1468
1469	SUBROUTINE interpvb2b_const( ptab, i1, i2, j1, j2, before )
1470	!!----------------------------------------------------------------------
1471	!! * ROUTINE interpub2b_const *
1472	!!----------------------------------------------------------------------
1473	INTEGER , INTENT(in ) :: i1, i2, j1, j2
1474	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
1475	LOGICAL , INTENT(in ) :: before
1476	!
1477	REAL(wp) :: zrhox
1478	!!----------------------------------------------------------------------
1479	IF( before ) THEN
1480	! IF ( ln_bt_fw ) THEN
1481	ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * vb2_b(i1:i2,j1:j2)
1482	! ELSE
1483	! ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * vn_adv(i1:i2,j1:j2)
1484	! ENDIF
1485	ELSE
1486	zrhox = Agrif_Rhox()
1487	!
1488	vbdy(i1:i2,j1:j2) = ptab(i1:i2,j1:j2) &
1489	& / (zrhoxe1v(i1:i2,j1:j2)) vmask(i1:i2,j1:j2,1)
1490	!
1491	ENDIF
1492	!
1493	END SUBROUTINE interpvb2b_const
1494
1495
1496	SUBROUTINE vb2b_cor( ptab, i1, i2, j1, j2, before )
1497	!!----------------------------------------------------------------------
1498	!! * ROUTINE vb2b_cor *
1499	!!----------------------------------------------------------------------
1500	INTEGER , INTENT(in ) :: i1, i2, j1, j2
1501	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
1502	LOGICAL , INTENT(in ) :: before
1503	!
1504	INTEGER :: ji, jj
1505	REAL(wp) :: zrhox, zrhoy, zy
1506	!!----------------------------------------------------------------------
1507	IF( before ) THEN
1508	ptab(:,:) = 0._wp
1509	DO ji=i1+1,i2-1
1510	DO jj=j1+1,j2-1
1511	ptab(ji,jj) = 0.25_wp( ( ub2_b(ji ,jj+1)e2u(ji ,jj+1) &
1512	& -ub2_b(ji ,jj-1)*e2u(ji ,jj-1) ) &
1513	& -( ub2_b(ji-1,jj+1)*e2u(ji-1,jj+1) &
1514	& -ub2_b(ji-1,jj-1)*e2u(ji-1,jj-1) ) )
1515	END DO
1516	END DO
1517	ELSE
1518	!
1519	zrhox = Agrif_Rhox()
1520	zrhoy = Agrif_Rhoy()
1521	DO ji=i1,i2
1522	DO jj=j1,j2
1523	IF (vtint_stage(ji,jj)==0) THEN
1524	zy = 2._wp*MOD(ABS(mjg0(jj)-nbghostcells-1), INT(Agrif_Rhoy()))/zrhoy - 1._wp
1525	vbdy(ji,jj) = vbdy(ji,jj) + 0.25_wp(1._wp-zyzy) * ptab(ji,jj) &
1526	& / zrhox * r1_e1v(ji,jj) * vmask(ji,jj,1)
1527	vtint_stage(ji,jj) = 1
1528	ENDIF
1529	END DO
1530	END DO
1531	!
1532	ENDIF
1533	!
1534	END SUBROUTINE vb2b_cor
1535
1536
1537	SUBROUTINE interpe3t( ptab, i1, i2, j1, j2, k1, k2, before )
1538	!!----------------------------------------------------------------------
1539	!! * ROUTINE interpe3t *
1540	!!----------------------------------------------------------------------
1541	INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2
1542	REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab
1543	LOGICAL , INTENT(in ) :: before
1544	!
1545	INTEGER :: ji, jj, jk
1546	!!----------------------------------------------------------------------
1547	!
1548	IF( before ) THEN
1549	ptab(i1:i2,j1:j2,k1:k2) = tmask(i1:i2,j1:j2,k1:k2) * e3t_0(i1:i2,j1:j2,k1:k2)
1550	ELSE
1551	!
1552	DO jk = k1, k2
1553	DO jj = j1, j2
1554	DO ji = i1, i2
1555	IF( ABS( ptab(ji,jj,jk) - tmask(ji,jj,jk) * e3t_0(ji,jj,jk) ) > 1.D-2) THEN
1556	WRITE(numout,*) ' Agrif error for e3t_0: parent , child, i, j, k ', &
1557	& ptab(ji,jj,jk), tmask(ji,jj,jk) * e3t_0(ji,jj,jk), &
1558	& mig0(ji), mjg0(jj), jk
1559	kindic_agr = kindic_agr + 1
1560	ENDIF
1561	END DO
1562	END DO
1563	END DO
1564	!
1565	ENDIF
1566	!
1567	END SUBROUTINE interpe3t
1568
1569
1570	SUBROUTINE interpe3t0_vremap( ptab, i1, i2, j1, j2, k1, k2, before )
1571	!!----------------------------------------------------------------------
1572	!! * ROUTINE interpe3t0_vremap *
1573	!!----------------------------------------------------------------------
1574	INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2
1575	REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab
1576	LOGICAL , INTENT(in ) :: before
1577	!
1578	INTEGER :: ji, jj, jk
1579	REAL(wp) :: zh
1580	!!----------------------------------------------------------------------
1581	!
1582	IF( before ) THEN
1583	IF ( ln_zps ) THEN
1584	DO jk = k1, k2
1585	DO jj = j1, j2
1586	DO ji = i1, i2
1587	ptab(ji, jj, jk) = e3t_1d(jk)
1588	END DO
1589	END DO
1590	END DO
1591	ELSE
1592	ptab(i1:i2,j1:j2,k1:k2) = e3t_0(i1:i2,j1:j2,k1:k2)
1593	ENDIF
1594	ELSE
1595	!
1596	DO jk = k1, k2
1597	DO jj = j1, j2
1598	DO ji = i1, i2
1599	e3t0_parent(ji,jj,jk) = ptab(ji,jj,jk)
1600	END DO
1601	END DO
1602	END DO
1603
1604	! Retrieve correct scale factor at the bottom:
1605	DO jj = j1, j2
1606	DO ji = i1, i2
1607	zh = 0._wp
1608	DO jk = 1, mbkt_parent(ji, jj)-1
1609	zh = zh + e3t0_parent(ji,jj,jk)
1610	END DO
1611	e3t0_parent(ji,jj,mbkt_parent(ji,jj)) = ht0_parent(ji, jj) - zh
1612	END DO
1613	END DO
1614
1615	ENDIF
1616	!
1617	END SUBROUTINE interpe3t0_vremap
1618
1619
1620	SUBROUTINE interpglamt( ptab, i1, i2, j1, j2, before )
1621	!!----------------------------------------------------------------------
1622	!! * ROUTINE interpglamt *
1623	!!----------------------------------------------------------------------
1624	INTEGER , INTENT(in ) :: i1, i2, j1, j2
1625	REAL(wp),DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
1626	LOGICAL , INTENT(in ) :: before
1627	!
1628	INTEGER :: ji, jj, jk
1629	REAL(wp):: ztst
1630	!!----------------------------------------------------------------------
1631	!
1632	IF( before ) THEN
1633	ptab(i1:i2,j1:j2) = glamt(i1:i2,j1:j2)
1634	ELSE
1635	ztst = MAXVAL(ABS(glamt(i1:i2,j1:j2)))*1.e-4
1636	DO jj = j1, j2
1637	DO ji = i1, i2
1638	IF( ABS( ptab(ji,jj) - glamt(ji,jj) ) > ztst ) THEN
1639	WRITE(numout,*) ' Agrif error for glamt: parent, child, i, j ', ptab(ji,jj), glamt(ji,jj), mig0(ji), mig0(jj)
1640	! kindic_agr = kindic_agr + 1
1641	ENDIF
1642	END DO
1643	END DO
1644	ENDIF
1645	!
1646	END SUBROUTINE interpglamt
1647
1648
1649	SUBROUTINE interpgphit( ptab, i1, i2, j1, j2, before )
1650	!!----------------------------------------------------------------------
1651	!! * ROUTINE interpgphit *
1652	!!----------------------------------------------------------------------
1653	INTEGER , INTENT(in ) :: i1, i2, j1, j2
1654	REAL(wp),DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
1655	LOGICAL , INTENT(in ) :: before
1656	!
1657	INTEGER :: ji, jj, jk
1658	REAL(wp):: ztst
1659	!!----------------------------------------------------------------------
1660	!
1661	IF( before ) THEN
1662	ptab(i1:i2,j1:j2) = gphit(i1:i2,j1:j2)
1663	ELSE
1664	ztst = MAXVAL(ABS(gphit(i1:i2,j1:j2)))*1.e-4
1665	DO jj = j1, j2
1666	DO ji = i1, i2
1667	IF( ABS( ptab(ji,jj) - gphit(ji,jj) ) > ztst ) THEN
1668	WRITE(numout,*) ' Agrif error for gphit: parent, child, i, j ', ptab(ji,jj), gphit(ji,jj), mig0(ji), mig0(jj)
1669	! kindic_agr = kindic_agr + 1
1670	ENDIF
1671	END DO
1672	END DO
1673	ENDIF
1674	!
1675	END SUBROUTINE interpgphit
1676
1677
1678	SUBROUTINE interpavm( ptab, i1, i2, j1, j2, k1, k2, m1, m2, before )
1679	!!----------------------------------------------------------------------
1680	!! * ROUTINE interavm *
1681	!!----------------------------------------------------------------------
1682	INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, m1, m2
1683	REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,m1:m2), INTENT(inout) :: ptab
1684	LOGICAL , INTENT(in ) :: before
1685	!
1686	INTEGER :: ji, jj, jk
1687	INTEGER :: N_in, N_out
1688	REAL(wp), DIMENSION(k1:k2) :: tabin, z_in
1689	REAL(wp), DIMENSION(1:jpk) :: z_out
1690	!!----------------------------------------------------------------------
1691	!
1692	IF (before) THEN
1693	DO jk=k1,k2
1694	DO jj=j1,j2
1695	DO ji=i1,i2
1696	ptab(ji,jj,jk,1) = avm_k(ji,jj,jk)
1697	END DO
1698	END DO
1699	END DO
1700
1701	IF( l_vremap ) THEN
1702	! Interpolate interfaces
1703	! Warning: these are masked, hence extrapolated prior interpolation.
1704	DO jk=k1,k2
1705	DO jj=j1,j2
1706	DO ji=i1,i2
1707	ptab(ji,jj,jk,2) = tmask(ji,jj,jk) * gdepw(ji,jj,jk,Kmm_a)
1708	END DO
1709	END DO
1710	END DO
1711
1712	! Save ssh at last level:
1713	IF (.NOT.ln_linssh) THEN
1714	ptab(i1:i2,j1:j2,k2,2) = ssh(i1:i2,j1:j2,Kmm_a)*tmask(i1:i2,j1:j2,1)
1715	ELSE
1716	ptab(i1:i2,j1:j2,k2,2) = 0._wp
1717	END IF
1718	ENDIF
1719
1720	ELSE
1721
1722	IF( l_vremap ) THEN
1723	IF (ln_linssh) ptab(i1:i2,j1:j2,k2,2) = 0._wp
1724	avm_k(i1:i2,j1:j2,1:jpkm1) = 0._wp
1725
1726	DO jj = j1, j2
1727	DO ji =i1, i2
1728	N_in = mbkt_parent(ji,jj)
1729	N_out = mbkt(ji,jj)
1730	IF (N_in*N_out > 0) THEN
1731	DO jk = 1, N_in ! Parent vertical grid
1732	z_in(jk) = ptab(ji,jj,jk,2) - ptab(ji,jj,k2,2)
1733	tabin(jk) = ptab(ji,jj,jk,1)
1734	END DO
1735	DO jk = 1, N_out ! Child vertical grid
1736	z_out(jk) = gdepw(ji,jj,jk,Kmm_a) - ssh(ji,jj,Kmm_a)
1737	END DO
1738	IF (.NOT.ln_linssh) z_out(1:N_out) = z_out(1:N_out) - ssh(ji,jj,Kmm_a)
1739
1740	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)
1741	ENDIF
1742	END DO
1743	END DO
1744	ELSE
1745	avm_k(i1:i2,j1:j2,1:jpkm1) = ptab (i1:i2,j1:j2,1:jpkm1,1)
1746	ENDIF
1747	ENDIF
1748	!
1749	END SUBROUTINE interpavm
1750
1751
1752	SUBROUTINE interpmbkt( ptab, i1, i2, j1, j2, before )
1753	!!----------------------------------------------------------------------
1754	!! * ROUTINE interpmbkt *
1755	!!----------------------------------------------------------------------
1756	INTEGER , INTENT(in ) :: i1, i2, j1, j2
1757	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
1758	LOGICAL , INTENT(in ) :: before
1759	!
1760	!!----------------------------------------------------------------------
1761	!
1762	IF( before) THEN
1763	ptab(i1:i2,j1:j2) = REAL(mbkt(i1:i2,j1:j2),wp)
1764	ELSE
1765	mbkt_parent(i1:i2,j1:j2) = NINT(ptab(i1:i2,j1:j2))
1766	ENDIF
1767	!
1768	END SUBROUTINE interpmbkt
1769
1770
1771	SUBROUTINE interpht0( ptab, i1, i2, j1, j2, before )
1772	!!----------------------------------------------------------------------
1773	!! * ROUTINE interpht0 *
1774	!!----------------------------------------------------------------------
1775	INTEGER , INTENT(in ) :: i1, i2, j1, j2
1776	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
1777	LOGICAL , INTENT(in ) :: before
1778	!
1779	!!----------------------------------------------------------------------
1780	!
1781	IF( before) THEN
1782	ptab(i1:i2,j1:j2) = ht_0(i1:i2,j1:j2)
1783	ELSE
1784	ht0_parent(i1:i2,j1:j2) = ptab(i1:i2,j1:j2)
1785	ENDIF
1786	!
1787	END SUBROUTINE interpht0
1788
1789	SUBROUTINE Agrif_check_bat( iindic )
1790	!!----------------------------------------------------------------------
1791	!! * ROUTINE Agrif_check_bat *
1792	!!----------------------------------------------------------------------
1793	INTEGER, INTENT(inout) :: iindic
1794	!!
1795	INTEGER :: ji, jj
1796	INTEGER :: istart, iend, jstart, jend, ispon
1797	!!----------------------------------------------------------------------
1798	!
1799	!
1800	! --- West --- !
1801	IF(lk_west) THEN
1802	ispon = nn_sponge_len * Agrif_irhox()
1803	istart = nn_hls + 2 ! halo + land + 1
1804	iend = nn_hls + 1 + nbghostcells + ispon ! halo + land + nbghostcells + sponge
1805	jstart = nn_hls + 2
1806	jend = jpjglo - nn_hls - 1
1807	DO ji = mi0(istart), mi1(iend)
1808	DO jj = mj0(jstart), mj1(jend)
1809	IF ( ABS(ht0_parent(ji,jj)-ht_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
1810	END DO
1811	DO jj = mj0(jstart), mj1(jend-1)
1812	IF ( ABS(hv0_parent(ji,jj)-hv_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
1813	END DO
1814	END DO
1815	DO ji = mi0(istart), mi1(iend-1)
1816	DO jj = mj0(jstart), mj1(jend)
1817	IF ( ABS(hu0_parent(ji,jj)-hu_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
1818	END DO
1819	END DO
1820	ENDIF
1821	!
1822	! --- East --- !
1823	IF(lk_east) THEN
1824	ispon = nn_sponge_len * Agrif_irhox()
1825	istart = jpiglo - ( nn_hls + nbghostcells + ispon ) ! halo + land + nbghostcells + sponge - 1
1826	iend = jpiglo - ( nn_hls + 1 ) ! halo + land + 1 - 1
1827	jstart = nn_hls + 2
1828	jend = jpjglo - nn_hls - 1
1829	DO ji = mi0(istart), mi1(iend)
1830	DO jj = mj0(jstart), mj1(jend)
1831	IF ( ABS(ht0_parent(ji,jj)-ht_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
1832	END DO
1833	DO jj = mj0(jstart), mj1(jend-1)
1834	IF ( ABS(hv0_parent(ji,jj)-hv_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
1835	END DO
1836	END DO
1837	DO ji = mi0(istart+1), mi1(iend-1)
1838	DO jj = mj0(jstart), mj1(jend)
1839	IF ( ABS(hu0_parent(ji,jj)-hu_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
1840	END DO
1841	END DO
1842	ENDIF
1843	!
1844	! --- South --- !
1845	IF(lk_south) THEN
1846	ispon = nn_sponge_len * Agrif_irhoy()
1847	jstart = nn_hls + 2 ! halo + land + 1
1848	jend = nn_hls + 1 + nbghostcells + ispon ! halo + land + nbghostcells + sponge
1849	istart = nn_hls + 2
1850	iend = jpiglo - nn_hls - 1
1851	DO jj = mj0(jstart), mj1(jend)
1852	DO ji = mi0(istart), mi1(iend)
1853	IF ( ABS(ht0_parent(ji,jj)-ht_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
1854	END DO
1855	DO ji = mi0(istart), mi1(iend-1)
1856	IF ( ABS(hu0_parent(ji,jj)-hu_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
1857	END DO
1858	END DO
1859	DO jj = mj0(jstart), mj1(jend-1)
1860	DO ji = mi0(istart), mi1(iend)
1861	IF ( ABS(hv0_parent(ji,jj)-hv_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
1862	END DO
1863	END DO
1864	ENDIF
1865	!
1866	! --- North --- !
1867	IF(lk_north) THEN
1868	ispon = nn_sponge_len * Agrif_irhoy()
1869	jstart = jpjglo - ( nn_hls + nbghostcells + ispon) ! halo + land + nbghostcells +sponge - 1
1870	jend = jpjglo - ( nn_hls + 1 ) ! halo + land + 1 - 1
1871	istart = nn_hls + 2
1872	iend = jpiglo - nn_hls - 1
1873	DO jj = mj0(jstart), mj1(jend)
1874	DO ji = mi0(istart), mi1(iend)
1875	IF ( ABS(ht0_parent(ji,jj)-ht_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
1876	END DO
1877	DO ji = mi0(istart), mi1(iend-1)
1878	IF ( ABS(hu0_parent(ji,jj)-hu_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
1879	END DO
1880	END DO
1881	DO jj = mj0(jstart+1), mj1(jend-1)
1882	DO ji = mi0(istart), mi1(iend)
1883	IF ( ABS(hv0_parent(ji,jj)-hv_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
1884	END DO
1885	END DO
1886	ENDIF
1887	!
1888	END SUBROUTINE Agrif_check_bat
1889
1890	#else
1891	!!----------------------------------------------------------------------
1892	!! Empty module no AGRIF zoom
1893	!!----------------------------------------------------------------------
1894	CONTAINS
1895	SUBROUTINE Agrif_OCE_Interp_empty
1896	WRITE(,) 'agrif_oce_interp : You should not have seen this print! error?'
1897	END SUBROUTINE Agrif_OCE_Interp_empty
1898	#endif
1899
1900	!!======================================================================
1901	END MODULE agrif_oce_interp

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

Download in other formats: