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

Last change on this file since 14000 was 14000, checked in by jchanut, 3 years ago
#2222, fixes an allocation pb if child initialized from parent (optional)
Property svn:keywords set to `Id`
File size: 73.7 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	DO jn =1, jpts
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
968	ENDIF
969
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
972	END DO
973	ENDIF
974
975	ENDIF
976	!
977	END SUBROUTINE interptsn
978
979
980	SUBROUTINE interpsshn( ptab, i1, i2, j1, j2, before )
981	!!----------------------------------------------------------------------
982	!! * ROUTINE interpsshn *
983	!!----------------------------------------------------------------------
984	INTEGER , INTENT(in ) :: i1, i2, j1, j2
985	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
986	LOGICAL , INTENT(in ) :: before
987	!
988	!!----------------------------------------------------------------------
989	!
990	IF( before) THEN
991	ptab(i1:i2,j1:j2) = ssh(i1:i2,j1:j2,Kmm_a)
992	ELSE
993	IF( l_ini_child ) THEN
994	ssh(i1:i2,j1:j2,Kmm_a) = ptab(i1:i2,j1:j2) * tmask(i1:i2,j1:j2,1)
995	ELSE
996	hbdy(i1:i2,j1:j2) = ptab(i1:i2,j1:j2) * tmask(i1:i2,j1:j2,1)
997	ENDIF
998	ENDIF
999	!
1000	END SUBROUTINE interpsshn
1001
1002
1003	SUBROUTINE interpun( ptab, i1, i2, j1, j2, k1, k2, m1, m2, before )
1004	!!----------------------------------------------------------------------
1005	!! * ROUTINE interpun *
1006	!!---------------------------------------------
1007	!!
1008	INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,m1,m2
1009	REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,m1:m2), INTENT(inout) :: ptab
1010	LOGICAL, INTENT(in) :: before
1011	!!
1012	INTEGER :: ji,jj,jk
1013	REAL(wp) :: zrhoy, zhtot
1014	! vertical interpolation:
1015	REAL(wp), DIMENSION(k1:k2) :: tabin, h_in, z_in
1016	REAL(wp), DIMENSION(1:jpk) :: h_out, z_out
1017	INTEGER :: N_in, N_out,item
1018	REAL(wp) :: h_diff
1019	!!---------------------------------------------
1020	!
1021	IF (before) THEN
1022
1023	item = Kmm_a
1024	IF( l_ini_child ) Kmm_a = Kbb_a
1025
1026	DO jk=1,jpk
1027	DO jj=j1,j2
1028	DO ji=i1,i2
1029	ptab(ji,jj,jk,1) = (e2u(ji,jj) * e3u(ji,jj,jk,Kmm_a) * uu(ji,jj,jk,Kmm_a)*umask(ji,jj,jk))
1030	IF( l_vremap .OR. l_ini_child) THEN
1031	! Interpolate thicknesses (masked for subsequent extrapolation)
1032	ptab(ji,jj,jk,2) = umask(ji,jj,jk) * e2u(ji,jj) * e3u(ji,jj,jk,Kmm_a)
1033	ENDIF
1034	END DO
1035	END DO
1036	END DO
1037
1038	IF( l_vremap .OR. l_ini_child ) THEN
1039	! Extrapolate thicknesses in partial bottom cells:
1040	! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on
1041	IF (ln_zps) THEN
1042	DO jj=j1,j2
1043	DO ji=i1,i2
1044	jk = mbku(ji,jj)
1045	ptab(ji,jj,jk,2) = 0._wp
1046	END DO
1047	END DO
1048	END IF
1049
1050	! Save ssh at last level:
1051	ptab(i1:i2,j1:j2,k2,2) = 0._wp
1052	IF (.NOT.ln_linssh) THEN
1053	! This vertical sum below should be replaced by the sea-level at U-points (optimization):
1054	DO jk=1,jpk
1055	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)
1056	END DO
1057	ptab(i1:i2,j1:j2,k2,2) = ptab(i1:i2,j1:j2,k2,2) - hu_0(i1:i2,j1:j2)
1058	END IF
1059	ENDIF
1060
1061	Kmm_a = item
1062	!
1063	ELSE
1064	zrhoy = Agrif_rhoy()
1065
1066	IF( l_vremap .OR. l_ini_child) THEN
1067	! VERTICAL REFINEMENT BEGIN
1068
1069	IF (ln_linssh) ptab(i1:i2,j1:j2,k2,2) = 0._wp
1070
1071	DO ji=i1,i2
1072	DO jj=j1,j2
1073	uu(ji,jj,:,Krhs_a) = 0._wp
1074	N_in = mbku_parent(ji,jj)
1075	zhtot = 0._wp
1076	DO jk=1,N_in
1077	!IF (jk==N_in) THEN
1078	! h_in(jk) = hu0_parent(ji,jj) + ptab(ji,jj,k2,2) - zhtot
1079	!ELSE
1080	! h_in(jk) = ptab(ji,jj,jk,2)/(e2u(ji,jj)*zrhoy)
1081	!ENDIF
1082	IF ( l_vremap ) THEN
1083	h_in(jk) = e3u0_parent(ji,jj,jk)
1084	zhtot = zhtot + h_in(jk)
1085	ENDIF
1086	IF( h_in(jk) .GT. 0. ) THEN
1087	tabin(jk) = ptab(ji,jj,jk,1)/(e2u(ji,jj)zrhoyh_in(jk))
1088	ELSE
1089	tabin(jk) = 0.
1090	ENDIF
1091	END DO
1092	z_in(1) = 0.5_wp * h_in(1) - zhtot + hu0_parent(ji,jj)
1093	DO jk=2,N_in
1094	z_in(jk) = z_in(jk-1) + 0.5_wp * (h_in(jk)+h_in(jk-1))
1095	END DO
1096
1097	N_out = 0
1098	DO jk=1,jpk
1099	IF (umask(ji,jj,jk) == 0) EXIT
1100	N_out = N_out + 1
1101	h_out(N_out) = e3u(ji,jj,jk,Krhs_a)
1102	END DO
1103
1104	z_out(1) = 0.5_wp * h_out(1) - SUM(h_out(1:N_out)) + hu_0(ji,jj)
1105	DO jk=2,N_out
1106	z_out(jk) = z_out(jk-1) + 0.5_wp * (h_out(jk-1) + h_out(jk))
1107	END DO
1108
1109	IF (N_in*N_out > 0) THEN
1110	IF( l_ini_child ) THEN
1111	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)
1112	ELSE
1113	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)
1114	ENDIF
1115	ENDIF
1116	END DO
1117	END DO
1118	ELSE
1119	DO jk = 1, jpkm1
1120	DO jj=j1,j2
1121	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) )
1122	END DO
1123	END DO
1124	ENDIF
1125
1126	ENDIF
1127	!
1128	END SUBROUTINE interpun
1129
1130
1131	SUBROUTINE interpvn( ptab, i1, i2, j1, j2, k1, k2, m1, m2, before )
1132	!!----------------------------------------------------------------------
1133	!! * ROUTINE interpvn *
1134	!!----------------------------------------------------------------------
1135	!
1136	INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,m1,m2
1137	REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,m1:m2), INTENT(inout) :: ptab
1138	LOGICAL, INTENT(in) :: before
1139	!
1140	INTEGER :: ji,jj,jk
1141	REAL(wp) :: zrhox
1142	! vertical interpolation:
1143	REAL(wp), DIMENSION(k1:k2) :: tabin, h_in, z_in
1144	REAL(wp), DIMENSION(1:jpk) :: h_out, z_out
1145	INTEGER :: N_in, N_out, item
1146	REAL(wp) :: h_diff, zhtot
1147	!!---------------------------------------------
1148	!
1149	IF (before) THEN
1150
1151	item = Kmm_a
1152	IF( l_ini_child ) Kmm_a = Kbb_a
1153
1154	DO jk=k1,k2
1155	DO jj=j1,j2
1156	DO ji=i1,i2
1157	ptab(ji,jj,jk,1) = (e1v(ji,jj) * e3v(ji,jj,jk,Kmm_a) * vv(ji,jj,jk,Kmm_a)*vmask(ji,jj,jk))
1158	IF( l_vremap .OR. l_ini_child) THEN
1159	! Interpolate thicknesses (masked for subsequent extrapolation)
1160	ptab(ji,jj,jk,2) = vmask(ji,jj,jk) * e1v(ji,jj) * e3v(ji,jj,jk,Kmm_a)
1161	ENDIF
1162	END DO
1163	END DO
1164	END DO
1165
1166	IF( l_vremap .OR. l_ini_child) THEN
1167	! Extrapolate thicknesses in partial bottom cells:
1168	! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on
1169	IF (ln_zps) THEN
1170	DO jj=j1,j2
1171	DO ji=i1,i2
1172	jk = mbkv(ji,jj)
1173	ptab(ji,jj,jk,2) = 0._wp
1174	END DO
1175	END DO
1176	END IF
1177	! Save ssh at last level:
1178	ptab(i1:i2,j1:j2,k2,2) = 0._wp
1179	IF (.NOT.ln_linssh) THEN
1180	! This vertical sum below should be replaced by the sea-level at V-points (optimization):
1181	DO jk=1,jpk
1182	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)
1183	END DO
1184	ptab(i1:i2,j1:j2,k2,2) = ptab(i1:i2,j1:j2,k2,2) - hv_0(i1:i2,j1:j2)
1185	END IF
1186	ENDIF
1187	item = Kmm_a
1188
1189	ELSE
1190	zrhox = Agrif_rhox()
1191
1192	IF( l_vremap .OR. l_ini_child ) THEN
1193
1194	IF (ln_linssh) ptab(i1:i2,j1:j2,k2,2) = 0._wp
1195
1196	DO jj=j1,j2
1197	DO ji=i1,i2
1198	vv(ji,jj,:,Krhs_a) = 0._wp
1199	N_in = mbkv_parent(ji,jj)
1200	zhtot = 0._wp
1201	DO jk=1,N_in
1202	!IF (jk==N_in) THEN
1203	! h_in(jk) = hv0_parent(ji,jj) + ptab(ji,jj,k2,2) - zhtot
1204	!ELSE
1205	! h_in(jk) = ptab(ji,jj,jk,2)/(e1v(ji,jj)*zrhox)
1206	!ENDIF
1207	IF (l_vremap) THEN
1208	h_in(jk) = e3v0_parent(ji,jj,jk)
1209	zhtot = zhtot + h_in(jk)
1210	ENDIF
1211	IF( h_in(jk) .GT. 0. ) THEN
1212	tabin(jk) = ptab(ji,jj,jk,1)/(e1v(ji,jj)zrhoxh_in(jk))
1213	ELSE
1214	tabin(jk) = 0.
1215	ENDIF
1216	END DO
1217
1218	z_in(1) = 0.5_wp * h_in(1) - zhtot + hv0_parent(ji,jj)
1219	DO jk=2,N_in
1220	z_in(jk) = z_in(jk-1) + 0.5_wp * (h_in(jk-1)+h_in(jk))
1221	END DO
1222
1223	N_out = 0
1224	DO jk=1,jpk
1225	IF (vmask(ji,jj,jk) == 0) EXIT
1226	N_out = N_out + 1
1227	h_out(N_out) = e3v(ji,jj,jk,Krhs_a)
1228	END DO
1229
1230	z_out(1) = 0.5_wp * h_out(1) - SUM(h_out(1:N_out)) + hv_0(ji,jj)
1231	DO jk=2,N_out
1232	z_out(jk) = z_out(jk-1) + 0.5_wp * (h_out(jk-1)+h_out(jk))
1233	END DO
1234
1235	IF (N_in*N_out > 0) THEN
1236	IF( l_ini_child ) THEN
1237	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)
1238	ELSE
1239	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)
1240	ENDIF
1241	ENDIF
1242	END DO
1243	END DO
1244	ELSE
1245	DO jk = 1, jpkm1
1246	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) )
1247	END DO
1248	ENDIF
1249	ENDIF
1250	!
1251	END SUBROUTINE interpvn
1252
1253	SUBROUTINE interpunb( ptab, i1, i2, j1, j2, before)
1254	!!----------------------------------------------------------------------
1255	!! * ROUTINE interpunb *
1256	!!----------------------------------------------------------------------
1257	INTEGER , INTENT(in ) :: i1, i2, j1, j2
1258	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
1259	LOGICAL , INTENT(in ) :: before
1260	!
1261	INTEGER :: ji, jj
1262	REAL(wp) :: zrhoy, zrhot, zt0, zt1, ztcoeff
1263	!!----------------------------------------------------------------------
1264	!
1265	IF( before ) THEN
1266	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)
1267	ELSE
1268	zrhoy = Agrif_Rhoy()
1269	zrhot = Agrif_rhot()
1270	! Time indexes bounds for integration
1271	zt0 = REAL(Agrif_NbStepint() , wp) / zrhot
1272	zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot
1273	!
1274	DO ji = i1, i2
1275	DO jj = j1, j2
1276	IF ( utint_stage(ji,jj) < (bdy_tinterp + 1) ) THEN
1277	IF ( utint_stage(ji,jj) == 1 ) THEN
1278	ztcoeff = zrhot * ( zt1*2._wp ( zt1 - 1._wp) &
1279	& - zt0*2._wp ( zt0 - 1._wp) )
1280	ELSEIF( utint_stage(ji,jj) == 2 ) THEN
1281	ztcoeff = zrhot * ( zt1 * ( zt1 - 1._wp)**2._wp &
1282	& - zt0 * ( zt0 - 1._wp)**2._wp )
1283	ELSEIF( utint_stage(ji,jj) == 0 ) THEN
1284	ztcoeff = 1._wp
1285	ELSE
1286	ztcoeff = 0._wp
1287	ENDIF
1288	!
1289	ubdy(ji,jj) = ubdy(ji,jj) + ztcoeff * ptab(ji,jj)
1290	!
1291	IF (( utint_stage(ji,jj) == 2 ).OR.( utint_stage(ji,jj) == 0 )) THEN
1292	ubdy(ji,jj) = ubdy(ji,jj) / (zrhoye2u(ji,jj)) umask(ji,jj,1)
1293	ENDIF
1294	!
1295	utint_stage(ji,jj) = utint_stage(ji,jj) + 1
1296	ENDIF
1297	END DO
1298	END DO
1299	END IF
1300	!
1301	END SUBROUTINE interpunb
1302
1303
1304	SUBROUTINE interpvnb( ptab, i1, i2, j1, j2, before )
1305	!!----------------------------------------------------------------------
1306	!! * ROUTINE interpvnb *
1307	!!----------------------------------------------------------------------
1308	INTEGER , INTENT(in ) :: i1, i2, j1, j2
1309	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
1310	LOGICAL , INTENT(in ) :: before
1311	!
1312	INTEGER :: ji, jj
1313	REAL(wp) :: zrhox, zrhot, zt0, zt1, ztcoeff
1314	!!----------------------------------------------------------------------
1315	!
1316	IF( before ) THEN
1317	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)
1318	ELSE
1319	zrhox = Agrif_Rhox()
1320	zrhot = Agrif_rhot()
1321	! Time indexes bounds for integration
1322	zt0 = REAL(Agrif_NbStepint() , wp) / zrhot
1323	zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot
1324	!
1325	DO ji = i1, i2
1326	DO jj = j1, j2
1327	IF ( vtint_stage(ji,jj) < (bdy_tinterp + 1) ) THEN
1328	IF ( vtint_stage(ji,jj) == 1 ) THEN
1329	ztcoeff = zrhot * ( zt1*2._wp ( zt1 - 1._wp) &
1330	& - zt0*2._wp ( zt0 - 1._wp) )
1331	ELSEIF( vtint_stage(ji,jj) == 2 ) THEN
1332	ztcoeff = zrhot * ( zt1 * ( zt1 - 1._wp)**2._wp &
1333	& - zt0 * ( zt0 - 1._wp)**2._wp )
1334	ELSEIF( vtint_stage(ji,jj) == 0 ) THEN
1335	ztcoeff = 1._wp
1336	ELSE
1337	ztcoeff = 0._wp
1338	ENDIF
1339	!
1340	vbdy(ji,jj) = vbdy(ji,jj) + ztcoeff * ptab(ji,jj)
1341	!
1342	IF (( vtint_stage(ji,jj) == 2 ).OR.( vtint_stage(ji,jj) == 0 )) THEN
1343	vbdy(ji,jj) = vbdy(ji,jj) / (zrhoxe1v(ji,jj)) vmask(ji,jj,1)
1344	ENDIF
1345	!
1346	vtint_stage(ji,jj) = vtint_stage(ji,jj) + 1
1347	ENDIF
1348	END DO
1349	END DO
1350	ENDIF
1351	!
1352	END SUBROUTINE interpvnb
1353
1354
1355	SUBROUTINE interpub2b( ptab, i1, i2, j1, j2, before )
1356	!!----------------------------------------------------------------------
1357	!! * ROUTINE interpub2b *
1358	!!----------------------------------------------------------------------
1359	INTEGER , INTENT(in ) :: i1, i2, j1, j2
1360	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
1361	LOGICAL , INTENT(in ) :: before
1362	!
1363	INTEGER :: ji,jj
1364	REAL(wp) :: zrhot, zt0, zt1, zat
1365	!!----------------------------------------------------------------------
1366	IF( before ) THEN
1367	IF ( ln_bt_fw ) THEN
1368	ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * ub2_b(i1:i2,j1:j2)
1369	ELSE
1370	ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * un_adv(i1:i2,j1:j2)
1371	ENDIF
1372	ELSE
1373	zrhot = Agrif_rhot()
1374	! Time indexes bounds for integration
1375	zt0 = REAL(Agrif_NbStepint() , wp) / zrhot
1376	zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot
1377	! Polynomial interpolation coefficients:
1378	zat = zrhot * ( zt1*2._wp (-2._wp*zt1 + 3._wp) &
1379	& - zt0*2._wp (-2._wp*zt0 + 3._wp) )
1380	!
1381	ubdy(i1:i2,j1:j2) = zat * ptab(i1:i2,j1:j2)
1382	!
1383	! Update interpolation stage:
1384	utint_stage(i1:i2,j1:j2) = 1
1385	ENDIF
1386	!
1387	END SUBROUTINE interpub2b
1388
1389	SUBROUTINE interpub2b_const( ptab, i1, i2, j1, j2, before )
1390	!!----------------------------------------------------------------------
1391	!! * ROUTINE interpub2b_const *
1392	!!----------------------------------------------------------------------
1393	INTEGER , INTENT(in ) :: i1, i2, j1, j2
1394	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
1395	LOGICAL , INTENT(in ) :: before
1396	!
1397	REAL(wp) :: zrhoy
1398	!!----------------------------------------------------------------------
1399	IF( before ) THEN
1400	IF ( ln_bt_fw ) THEN
1401	ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * ub2_b(i1:i2,j1:j2)
1402	ELSE
1403	ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * un_adv(i1:i2,j1:j2)
1404	ENDIF
1405	ELSE
1406	zrhoy = Agrif_Rhoy()
1407	!
1408	ubdy(i1:i2,j1:j2) = ptab(i1:i2,j1:j2) &
1409	& / (zrhoye2u(i1:i2,j1:j2)) umask(i1:i2,j1:j2,1)
1410	!
1411	ENDIF
1412	!
1413	END SUBROUTINE interpub2b_const
1414
1415
1416	SUBROUTINE ub2b_cor( ptab, i1, i2, j1, j2, before )
1417	!!----------------------------------------------------------------------
1418	!! * ROUTINE ub2b_cor *
1419	!!----------------------------------------------------------------------
1420	INTEGER , INTENT(in ) :: i1, i2, j1, j2
1421	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
1422	LOGICAL , INTENT(in ) :: before
1423	!
1424	INTEGER :: ji, jj
1425	REAL(wp) :: zrhox, zrhoy, zx
1426	!!----------------------------------------------------------------------
1427	IF( before ) THEN
1428	ptab(:,:) = 0._wp
1429	DO ji=i1+1,i2-1
1430	DO jj=j1+1,j2
1431	ptab(ji,jj) = 0.25_wp( ( vb2_b(ji+1,jj )e1v(ji+1,jj ) &
1432	& -vb2_b(ji-1,jj )*e1v(ji-1,jj ) ) &
1433	& -( vb2_b(ji+1,jj-1)*e1v(ji+1,jj-1) &
1434	& -vb2_b(ji-1,jj-1)*e1v(ji-1,jj-1) ) )
1435	END DO
1436	END DO
1437	ELSE
1438	!
1439	zrhox = Agrif_Rhox()
1440	zrhoy = Agrif_Rhoy()
1441	DO ji=i1,i2
1442	DO jj=j1,j2
1443	IF (utint_stage(ji,jj)==0) THEN
1444	zx = 2._wp*MOD(ABS(mig0(ji)-nbghostcells-1), INT(Agrif_Rhox()))/zrhox - 1._wp
1445	ubdy(ji,jj) = ubdy(ji,jj) + 0.25_wp(1._wp-zxzx) * ptab(ji,jj) &
1446	& / zrhoy r1_e2u(ji,jj) umask(ji,jj,1)
1447	utint_stage(ji,jj) = 1
1448	ENDIF
1449	END DO
1450	END DO
1451	!
1452	ENDIF
1453	!
1454	END SUBROUTINE ub2b_cor
1455
1456
1457	SUBROUTINE interpvb2b( ptab, i1, i2, j1, j2, before )
1458	!!----------------------------------------------------------------------
1459	!! * ROUTINE interpvb2b *
1460	!!----------------------------------------------------------------------
1461	INTEGER , INTENT(in ) :: i1, i2, j1, j2
1462	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
1463	LOGICAL , INTENT(in ) :: before
1464	!
1465	INTEGER :: ji,jj
1466	REAL(wp) :: zrhot, zt0, zt1, zat
1467	!!----------------------------------------------------------------------
1468	!
1469	IF( before ) THEN
1470	IF ( ln_bt_fw ) THEN
1471	ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * vb2_b(i1:i2,j1:j2)
1472	ELSE
1473	ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * vn_adv(i1:i2,j1:j2)
1474	ENDIF
1475	ELSE
1476	zrhot = Agrif_rhot()
1477	! Time indexes bounds for integration
1478	zt0 = REAL(Agrif_NbStepint() , wp) / zrhot
1479	zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot
1480	! Polynomial interpolation coefficients:
1481	zat = zrhot * ( zt1*2._wp (-2._wp*zt1 + 3._wp) &
1482	& - zt0*2._wp (-2._wp*zt0 + 3._wp) )
1483	!
1484	vbdy(i1:i2,j1:j2) = zat * ptab(i1:i2,j1:j2)
1485	!
1486	! update interpolation stage:
1487	vtint_stage(i1:i2,j1:j2) = 1
1488	ENDIF
1489	!
1490	END SUBROUTINE interpvb2b
1491
1492
1493	SUBROUTINE interpvb2b_const( ptab, i1, i2, j1, j2, before )
1494	!!----------------------------------------------------------------------
1495	!! * ROUTINE interpub2b_const *
1496	!!----------------------------------------------------------------------
1497	INTEGER , INTENT(in ) :: i1, i2, j1, j2
1498	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
1499	LOGICAL , INTENT(in ) :: before
1500	!
1501	REAL(wp) :: zrhox
1502	!!----------------------------------------------------------------------
1503	IF( before ) THEN
1504	IF ( ln_bt_fw ) THEN
1505	ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * vb2_b(i1:i2,j1:j2)
1506	ELSE
1507	ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * vn_adv(i1:i2,j1:j2)
1508	ENDIF
1509	ELSE
1510	zrhox = Agrif_Rhox()
1511	!
1512	vbdy(i1:i2,j1:j2) = ptab(i1:i2,j1:j2) &
1513	& / (zrhoxe1v(i1:i2,j1:j2)) vmask(i1:i2,j1:j2,1)
1514	!
1515	ENDIF
1516	!
1517	END SUBROUTINE interpvb2b_const
1518
1519
1520	SUBROUTINE vb2b_cor( ptab, i1, i2, j1, j2, before )
1521	!!----------------------------------------------------------------------
1522	!! * ROUTINE vb2b_cor *
1523	!!----------------------------------------------------------------------
1524	INTEGER , INTENT(in ) :: i1, i2, j1, j2
1525	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
1526	LOGICAL , INTENT(in ) :: before
1527	!
1528	INTEGER :: ji, jj
1529	REAL(wp) :: zrhox, zrhoy, zy
1530	!!----------------------------------------------------------------------
1531	IF( before ) THEN
1532	ptab(:,:) = 0._wp
1533	DO ji=i1+1,i2-1
1534	DO jj=j1+1,j2
1535	ptab(ji,jj) = 0.25_wp( ( ub2_b(ji ,jj+1)e2u(ji ,jj+1) &
1536	& -ub2_b(ji ,jj-1)*e2u(ji ,jj-1) ) &
1537	& -( ub2_b(ji-1,jj+1)*e2u(ji-1,jj+1) &
1538	& -ub2_b(ji-1,jj-1)*e2u(ji-1,jj-1) ) )
1539	END DO
1540	END DO
1541	ELSE
1542	!
1543	zrhox = Agrif_Rhox()
1544	zrhoy = Agrif_Rhoy()
1545	DO ji=i1,i2
1546	DO jj=j1,j2
1547	IF (vtint_stage(ji,jj)==0) THEN
1548	zy = 2._wp*MOD(ABS(mjg0(jj)-nbghostcells-1), INT(Agrif_Rhoy()))/zrhoy - 1._wp
1549	vbdy(ji,jj) = vbdy(ji,jj) + 0.25_wp(1._wp-zyzy) * ptab(ji,jj) &
1550	& / zrhox * r1_e1v(ji,jj) * vmask(ji,jj,1)
1551	vtint_stage(ji,jj) = 1
1552	ENDIF
1553	END DO
1554	END DO
1555	!
1556	ENDIF
1557	!
1558	END SUBROUTINE vb2b_cor
1559
1560
1561	SUBROUTINE interpe3t( ptab, i1, i2, j1, j2, k1, k2, before )
1562	!!----------------------------------------------------------------------
1563	!! * ROUTINE interpe3t *
1564	!!----------------------------------------------------------------------
1565	INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2
1566	REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab
1567	LOGICAL , INTENT(in ) :: before
1568	!
1569	INTEGER :: ji, jj, jk
1570	!!----------------------------------------------------------------------
1571	!
1572	IF( before ) THEN
1573	ptab(i1:i2,j1:j2,k1:k2) = tmask(i1:i2,j1:j2,k1:k2) * e3t_0(i1:i2,j1:j2,k1:k2)
1574	ELSE
1575	!
1576	DO jk = k1, k2
1577	DO jj = j1, j2
1578	DO ji = i1, i2
1579	IF( ABS( ptab(ji,jj,jk) - tmask(ji,jj,jk) * e3t_0(ji,jj,jk) ) > 1.D-2) THEN
1580	WRITE(numout,*) ' Agrif error for e3t_0: parent , child, i, j, k ', &
1581	& ptab(ji,jj,jk), tmask(ji,jj,jk) * e3t_0(ji,jj,jk), &
1582	& mig0(ji), mjg0(jj), jk
1583	! kindic_agr = kindic_agr + 1
1584	ENDIF
1585	END DO
1586	END DO
1587	END DO
1588	!
1589	ENDIF
1590	!
1591	END SUBROUTINE interpe3t
1592
1593
1594	SUBROUTINE interpe3t0_vremap( ptab, i1, i2, j1, j2, k1, k2, before )
1595	!!----------------------------------------------------------------------
1596	!! * ROUTINE interpe3t0_vremap *
1597	!!----------------------------------------------------------------------
1598	INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2
1599	REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab
1600	LOGICAL , INTENT(in ) :: before
1601	!
1602	INTEGER :: ji, jj, jk
1603	REAL(wp) :: zh
1604	!!----------------------------------------------------------------------
1605	!
1606	IF( before ) THEN
1607	IF ( ln_zps ) THEN
1608	DO jk = k1, k2
1609	DO jj = j1, j2
1610	DO ji = i1, i2
1611	ptab(ji, jj, jk) = e3t_1d(jk)
1612	END DO
1613	END DO
1614	END DO
1615	ELSE
1616	ptab(i1:i2,j1:j2,k1:k2) = e3t_0(i1:i2,j1:j2,k1:k2)
1617	ENDIF
1618	ELSE
1619	!
1620	DO jk = k1, k2
1621	DO jj = j1, j2
1622	DO ji = i1, i2
1623	e3t0_parent(ji,jj,jk) = ptab(ji,jj,jk)
1624	END DO
1625	END DO
1626	END DO
1627
1628	! Retrieve correct scale factor at the bottom:
1629	DO jj = j1, j2
1630	DO ji = i1, i2
1631	zh = 0._wp
1632	DO jk = 1, mbkt_parent(ji, jj)-1
1633	zh = zh + e3t0_parent(ji,jj,jk)
1634	END DO
1635	e3t0_parent(ji,jj,mbkt_parent(ji,jj)) = ht0_parent(ji, jj) - zh
1636	END DO
1637	END DO
1638
1639	ENDIF
1640	!
1641	END SUBROUTINE interpe3t0_vremap
1642
1643
1644	SUBROUTINE interpglamt( ptab, i1, i2, j1, j2, before )
1645	!!----------------------------------------------------------------------
1646	!! * ROUTINE interpglamt *
1647	!!----------------------------------------------------------------------
1648	INTEGER , INTENT(in ) :: i1, i2, j1, j2
1649	REAL(wp),DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
1650	LOGICAL , INTENT(in ) :: before
1651	!
1652	INTEGER :: ji, jj, jk
1653	REAL(wp):: ztst
1654	!!----------------------------------------------------------------------
1655	!
1656	IF( before ) THEN
1657	ptab(i1:i2,j1:j2) = glamt(i1:i2,j1:j2)
1658	ELSE
1659	ztst = MAXVAL(ABS(glamt(i1:i2,j1:j2)))*1.e-4
1660	DO jj = j1, j2
1661	DO ji = i1, i2
1662	IF( ABS( ptab(ji,jj) - glamt(ji,jj) ) > ztst ) THEN
1663	WRITE(numout,*) ' Agrif error for glamt: parent, child, i, j ', ptab(ji,jj), glamt(ji,jj), mig0(ji), mig0(jj)
1664	! kindic_agr = kindic_agr + 1
1665	ENDIF
1666	END DO
1667	END DO
1668	ENDIF
1669	!
1670	END SUBROUTINE interpglamt
1671
1672
1673	SUBROUTINE interpgphit( ptab, i1, i2, j1, j2, before )
1674	!!----------------------------------------------------------------------
1675	!! * ROUTINE interpgphit *
1676	!!----------------------------------------------------------------------
1677	INTEGER , INTENT(in ) :: i1, i2, j1, j2
1678	REAL(wp),DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
1679	LOGICAL , INTENT(in ) :: before
1680	!
1681	INTEGER :: ji, jj, jk
1682	REAL(wp):: ztst
1683	!!----------------------------------------------------------------------
1684	!
1685	IF( before ) THEN
1686	ptab(i1:i2,j1:j2) = gphit(i1:i2,j1:j2)
1687	ELSE
1688	ztst = MAXVAL(ABS(gphit(i1:i2,j1:j2)))*1.e-4
1689	DO jj = j1, j2
1690	DO ji = i1, i2
1691	IF( ABS( ptab(ji,jj) - gphit(ji,jj) ) > ztst ) THEN
1692	WRITE(numout,*) ' Agrif error for gphit: parent, child, i, j ', ptab(ji,jj), gphit(ji,jj), mig0(ji), mig0(jj)
1693	! kindic_agr = kindic_agr + 1
1694	ENDIF
1695	END DO
1696	END DO
1697	ENDIF
1698	!
1699	END SUBROUTINE interpgphit
1700
1701
1702	SUBROUTINE interpavm( ptab, i1, i2, j1, j2, k1, k2, m1, m2, before )
1703	!!----------------------------------------------------------------------
1704	!! * ROUTINE interavm *
1705	!!----------------------------------------------------------------------
1706	INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, m1, m2
1707	REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,m1:m2), INTENT(inout) :: ptab
1708	LOGICAL , INTENT(in ) :: before
1709	!
1710	INTEGER :: ji, jj, jk
1711	INTEGER :: N_in, N_out
1712	REAL(wp), DIMENSION(k1:k2) :: tabin, z_in
1713	REAL(wp), DIMENSION(1:jpk) :: z_out
1714	!!----------------------------------------------------------------------
1715	!
1716	IF (before) THEN
1717	DO jk=k1,k2
1718	DO jj=j1,j2
1719	DO ji=i1,i2
1720	ptab(ji,jj,jk,1) = avm_k(ji,jj,jk)
1721	END DO
1722	END DO
1723	END DO
1724
1725	IF( l_vremap ) THEN
1726	! Interpolate thicknesses
1727	! Warning: these are masked, hence extrapolated prior interpolation.
1728	DO jk=k1,k2
1729	DO jj=j1,j2
1730	DO ji=i1,i2
1731	ptab(ji,jj,jk,2) = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kmm_a)
1732	END DO
1733	END DO
1734	END DO
1735
1736	! Extrapolate thicknesses in partial bottom cells:
1737	! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on
1738	IF (ln_zps) THEN
1739	DO jj=j1,j2
1740	DO ji=i1,i2
1741	jk = mbkt(ji,jj)
1742	ptab(ji,jj,jk,2) = 0._wp
1743	END DO
1744	END DO
1745	END IF
1746
1747	! Save ssh at last level:
1748	IF (.NOT.ln_linssh) THEN
1749	ptab(i1:i2,j1:j2,k2,2) = ssh(i1:i2,j1:j2,Kmm_a)*tmask(i1:i2,j1:j2,1)
1750	ELSE
1751	ptab(i1:i2,j1:j2,k2,2) = 0._wp
1752	END IF
1753	ENDIF
1754
1755	ELSE
1756
1757	IF( l_vremap ) THEN
1758	IF (ln_linssh) ptab(i1:i2,j1:j2,k2,2) = 0._wp
1759	avm_k(i1:i2,j1:j2,k1:k2) = 0._wp
1760
1761	DO jj = j1, j2
1762	DO ji =i1, i2
1763	N_in = mbkt_parent(ji,jj)
1764	IF ( tmask(ji,jj,1) == 0._wp) N_in = 0
1765	z_in(N_in+1) = ht0_parent(ji,jj) + ptab(ji,jj,k2,2)
1766	DO jk = N_in, 1, -1 ! Parent vertical grid
1767	z_in(jk) = z_in(jk+1) - ptab(ji,jj,jk,2)
1768	tabin(jk) = ptab(ji,jj,jk,1)
1769	END DO
1770	N_out = mbkt(ji,jj)
1771	DO jk = 1, N_out ! Child vertical grid
1772	z_out(jk) = gdepw(ji,jj,jk,Kmm_a)
1773	END DO
1774	IF (N_in*N_out > 0) THEN
1775	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)
1776	ENDIF
1777	END DO
1778	END DO
1779	ELSE
1780	avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2,1)
1781	ENDIF
1782	ENDIF
1783	!
1784	END SUBROUTINE interpavm
1785
1786
1787	SUBROUTINE interpmbkt( ptab, i1, i2, j1, j2, before )
1788	!!----------------------------------------------------------------------
1789	!! * ROUTINE interpmbkt *
1790	!!----------------------------------------------------------------------
1791	INTEGER , INTENT(in ) :: i1, i2, j1, j2
1792	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
1793	LOGICAL , INTENT(in ) :: before
1794	!
1795	!!----------------------------------------------------------------------
1796	!
1797	IF( before) THEN
1798	ptab(i1:i2,j1:j2) = REAL(mbkt(i1:i2,j1:j2),wp)
1799	ELSE
1800	mbkt_parent(i1:i2,j1:j2) = NINT(ptab(i1:i2,j1:j2))
1801	ENDIF
1802	!
1803	END SUBROUTINE interpmbkt
1804
1805
1806	SUBROUTINE interpht0( ptab, i1, i2, j1, j2, before )
1807	!!----------------------------------------------------------------------
1808	!! * ROUTINE interpht0 *
1809	!!----------------------------------------------------------------------
1810	INTEGER , INTENT(in ) :: i1, i2, j1, j2
1811	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
1812	LOGICAL , INTENT(in ) :: before
1813	!
1814	!!----------------------------------------------------------------------
1815	!
1816	IF( before) THEN
1817	ptab(i1:i2,j1:j2) = ht_0(i1:i2,j1:j2)
1818	ELSE
1819	ht0_parent(i1:i2,j1:j2) = ptab(i1:i2,j1:j2)
1820	ENDIF
1821	!
1822	END SUBROUTINE interpht0
1823
1824	SUBROUTINE Agrif_check_bat( iindic )
1825	!!----------------------------------------------------------------------
1826	!! * ROUTINE Agrif_check_bat *
1827	!!----------------------------------------------------------------------
1828	INTEGER, INTENT(inout) :: iindic
1829	!!
1830	INTEGER :: ji, jj
1831	INTEGER :: istart, iend, jstart, jend, ispon
1832	!!----------------------------------------------------------------------
1833	!
1834	!
1835	! --- West --- !
1836	IF(lk_west) THEN
1837	ispon = nn_sponge_len * Agrif_irhox()
1838	istart = nn_hls + 2 ! halo + land + 1
1839	iend = nn_hls + 1 + nbghostcells + ispon ! halo + land + nbghostcells + sponge
1840	jstart = nn_hls + 2
1841	jend = jpjglo - nn_hls - 1
1842	DO ji = mi0(istart), mi1(iend)
1843	DO jj = mj0(jstart), mj1(jend)
1844	IF ( ABS(ht0_parent(ji,jj)-ht_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
1845	END DO
1846	DO jj = mj0(jstart), mj1(jend-1)
1847	IF ( ABS(hv0_parent(ji,jj)-hv_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
1848	END DO
1849	END DO
1850	DO ji = mi0(istart), mi1(iend-1)
1851	DO jj = mj0(jstart), mj1(jend)
1852	IF ( ABS(hu0_parent(ji,jj)-hu_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
1853	END DO
1854	END DO
1855	ENDIF
1856	!
1857	! --- East --- !
1858	IF(lk_east) THEN
1859	ispon = nn_sponge_len * Agrif_irhox()
1860	istart = jpiglo - ( nn_hls + nbghostcells + ispon ) ! halo + land + nbghostcells + sponge - 1
1861	iend = jpiglo - ( nn_hls + 1 ) ! halo + land + 1 - 1
1862	jstart = nn_hls + 2
1863	jend = jpjglo - nn_hls - 1
1864	DO ji = mi0(istart), mi1(iend)
1865	DO jj = mj0(jstart), mj1(jend)
1866	IF ( ABS(ht0_parent(ji,jj)-ht_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
1867	END DO
1868	DO jj = mj0(jstart), mj1(jend-1)
1869	IF ( ABS(hv0_parent(ji,jj)-hv_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
1870	END DO
1871	END DO
1872	DO ji = mi0(istart+1), mi1(iend-1)
1873	DO jj = mj0(jstart), mj1(jend)
1874	IF ( ABS(hu0_parent(ji,jj)-hu_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
1875	END DO
1876	END DO
1877	ENDIF
1878	!
1879	! --- South --- !
1880	IF(lk_south) THEN
1881	ispon = nn_sponge_len * Agrif_irhoy()
1882	jstart = nn_hls + 2 ! halo + land + 1
1883	jend = nn_hls + 1 + nbghostcells + ispon ! halo + land + nbghostcells + sponge
1884	istart = nn_hls + 2
1885	iend = jpiglo - nn_hls - 1
1886	DO jj = mj0(jstart), mj1(jend)
1887	DO ji = mi0(istart), mi1(iend)
1888	IF ( ABS(ht0_parent(ji,jj)-ht_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
1889	END DO
1890	DO ji = mi0(istart), mi1(iend-1)
1891	IF ( ABS(hu0_parent(ji,jj)-hu_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
1892	END DO
1893	END DO
1894	DO jj = mj0(jstart), mj1(jend-1)
1895	DO ji = mi0(istart), mi1(iend)
1896	IF ( ABS(hv0_parent(ji,jj)-hv_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
1897	END DO
1898	END DO
1899	ENDIF
1900	!
1901	! --- North --- !
1902	IF(lk_north) THEN
1903	ispon = nn_sponge_len * Agrif_irhoy()
1904	jstart = jpjglo - ( nn_hls + nbghostcells + ispon) ! halo + land + nbghostcells +sponge - 1
1905	jend = jpjglo - ( nn_hls + 1 ) ! halo + land + 1 - 1
1906	istart = nn_hls + 2
1907	iend = jpiglo - nn_hls - 1
1908	DO jj = mj0(jstart), mj1(jend)
1909	DO ji = mi0(istart), mi1(iend)
1910	IF ( ABS(ht0_parent(ji,jj)-ht_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
1911	END DO
1912	DO ji = mi0(istart), mi1(iend-1)
1913	IF ( ABS(hu0_parent(ji,jj)-hu_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
1914	END DO
1915	END DO
1916	DO jj = mj0(jstart+1), mj1(jend-1)
1917	DO ji = mi0(istart), mi1(iend)
1918	IF ( ABS(hv0_parent(ji,jj)-hv_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
1919	END DO
1920	END DO
1921	ENDIF
1922	!
1923	END SUBROUTINE Agrif_check_bat
1924
1925	#else
1926	!!----------------------------------------------------------------------
1927	!! Empty module no AGRIF zoom
1928	!!----------------------------------------------------------------------
1929	CONTAINS
1930	SUBROUTINE Agrif_OCE_Interp_empty
1931	WRITE(,) 'agrif_oce_interp : You should not have seen this print! error?'
1932	END SUBROUTINE Agrif_OCE_Interp_empty
1933	#endif
1934
1935	!!======================================================================
1936	END MODULE agrif_oce_interp

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

Download in other formats: