New URL for NEMO forge! http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.

agrif_oce_interp.F90 in NEMO/branches/2020/dev_r13312_AGRIF-03-04_jchanut_vinterp_tstep/src/NST – NEMO

Context Navigation

source: NEMO/branches/2020/dev_r13312_AGRIF-03-04_jchanut_vinterp_tstep/src/NST/agrif_oce_interp.F90 @ 14048

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

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

Download in other formats: