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

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

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

Download in other formats: