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

Last change on this file since 13337 was 13337, checked in by jchanut, 4 years ago
#2222, start suppressing key_vertical (add ln_vremap namelist flag)
Property svn:keywords set to `Id`
File size: 63.8 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
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_vremap
172	!
173	CALL Agrif_Bc_variable( tsn_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_vremap
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	use_sign_north = .FALSE.
203	!
204	Agrif_UseSpecialValue = .FALSE.
205	l_vremap = .FALSE.
206	!
207	! --- West --- !
208	IF( lk_west ) THEN
209	ibdy1 = nn_hls + 2 ! halo + land + 1
210	ibdy2 = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells
211	!
212	IF( .NOT.ln_dynspg_ts ) THEN ! Store transport
213	DO ji = mi0(ibdy1), mi1(ibdy2)
214	uu_b(ji,:,Krhs_a) = 0._wp
215	DO jk = 1, jpkm1
216	DO jj = 1, jpj
217	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)
218	END DO
219	END DO
220	DO jj = 1, jpj
221	uu_b(ji,jj,Krhs_a) = uu_b(ji,jj,Krhs_a) * r1_hu(ji,jj,Krhs_a)
222	END DO
223	END DO
224	ENDIF
225	!
226	DO ji = mi0(ibdy1), mi1(ibdy2)
227	zub(ji,:) = 0._wp ! Correct transport
228	DO jk = 1, jpkm1
229	DO jj = 1, jpj
230	zub(ji,jj) = zub(ji,jj) + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk)
231	END DO
232	END DO
233	DO jj=1,jpj
234	zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a)
235	END DO
236	DO jk = 1, jpkm1
237	DO jj = 1, jpj
238	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)
239	END DO
240	END DO
241	END DO
242	!
243	IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate
244	DO ji = mi0(ibdy1), mi1(ibdy2)
245	zvb(ji,:) = 0._wp
246	DO jk = 1, jpkm1
247	DO jj = 1, jpj
248	zvb(ji,jj) = zvb(ji,jj) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk)
249	END DO
250	END DO
251	DO jj = 1, jpj
252	zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a)
253	END DO
254	DO jk = 1, jpkm1
255	DO jj = 1, jpj
256	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)
257	END DO
258	END DO
259	END DO
260	ENDIF
261	!
262	ENDIF
263
264	! --- East --- !
265	IF( lk_east) THEN
266	ibdy1 = jpiglo - ( nn_hls + nbghostcells + 1) ! halo + land + nbghostcells
267	ibdy2 = jpiglo - ( nn_hls + 2 ) ! halo + land + 1
268	!
269	IF( .NOT.ln_dynspg_ts ) THEN ! Store transport
270	DO ji = mi0(ibdy1), mi1(ibdy2)
271	uu_b(ji,:,Krhs_a) = 0._wp
272	DO jk = 1, jpkm1
273	DO jj = 1, jpj
274	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)
275	END DO
276	END DO
277	DO jj = 1, jpj
278	uu_b(ji,jj,Krhs_a) = uu_b(ji,jj,Krhs_a) * r1_hu(ji,jj,Krhs_a)
279	END DO
280	END DO
281	ENDIF
282	!
283	DO ji = mi0(ibdy1), mi1(ibdy2)
284	zub(ji,:) = 0._wp ! Correct transport
285	DO jk = 1, jpkm1
286	DO jj = 1, jpj
287	zub(ji,jj) = zub(ji,jj) + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk)
288	END DO
289	END DO
290	DO jj=1,jpj
291	zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a)
292	END DO
293	DO jk = 1, jpkm1
294	DO jj = 1, jpj
295	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)
296	END DO
297	END DO
298	END DO
299	!
300	IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate
301	ibdy1 = jpiglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1
302	ibdy2 = jpiglo - ( nn_hls + 1 ) ! halo + land + 1 - 1
303	DO ji = mi0(ibdy1), mi1(ibdy2)
304	zvb(ji,:) = 0._wp
305	DO jk = 1, jpkm1
306	DO jj = 1, jpj
307	zvb(ji,jj) = zvb(ji,jj) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk)
308	END DO
309	END DO
310	DO jj = 1, jpj
311	zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a)
312	END DO
313	DO jk = 1, jpkm1
314	DO jj = 1, jpj
315	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)
316	END DO
317	END DO
318	END DO
319	ENDIF
320	!
321	ENDIF
322
323	! --- South --- !
324	IF( lk_south ) THEN
325	jbdy1 = nn_hls + 2 ! halo + land + 1
326	jbdy2 = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells
327	!
328	IF( .NOT.ln_dynspg_ts ) THEN ! Store transport
329	DO jj = mj0(jbdy1), mj1(jbdy2)
330	vv_b(:,jj,Krhs_a) = 0._wp
331	DO jk = 1, jpkm1
332	DO ji = 1, jpi
333	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)
334	END DO
335	END DO
336	DO ji=1,jpi
337	vv_b(ji,jj,Krhs_a) = vv_b(ji,jj,Krhs_a) * r1_hv(ji,jj,Krhs_a)
338	END DO
339	END DO
340	ENDIF
341	!
342	DO jj = mj0(jbdy1), mj1(jbdy2)
343	zvb(:,jj) = 0._wp ! Correct transport
344	DO jk=1,jpkm1
345	DO ji=1,jpi
346	zvb(ji,jj) = zvb(ji,jj) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk)
347	END DO
348	END DO
349	DO ji = 1, jpi
350	zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a)
351	END DO
352	DO jk = 1, jpkm1
353	DO ji = 1, jpi
354	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)
355	END DO
356	END DO
357	END DO
358	!
359	IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate
360	DO jj = mj0(jbdy1), mj1(jbdy2)
361	zub(:,jj) = 0._wp
362	DO jk = 1, jpkm1
363	DO ji = 1, jpi
364	zub(ji,jj) = zub(ji,jj) + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk)
365	END DO
366	END DO
367	DO ji = 1, jpi
368	zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a)
369	END DO
370	DO jk = 1, jpkm1
371	DO ji = 1, jpi
372	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)
373	END DO
374	END DO
375	END DO
376	ENDIF
377	!
378	ENDIF
379
380	! --- North --- !
381	IF( lk_north ) THEN
382	jbdy1 = jpjglo - ( nn_hls + nbghostcells + 1) ! halo + land + nbghostcells
383	jbdy2 = jpjglo - ( nn_hls + 2 ) ! halo + land + 1
384	!
385	IF( .NOT.ln_dynspg_ts ) THEN ! Store transport
386	DO jj = mj0(jbdy1), mj1(jbdy2)
387	vv_b(:,jj,Krhs_a) = 0._wp
388	DO jk = 1, jpkm1
389	DO ji = 1, jpi
390	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)
391	END DO
392	END DO
393	DO ji=1,jpi
394	vv_b(ji,jj,Krhs_a) = vv_b(ji,jj,Krhs_a) * r1_hv(ji,jj,Krhs_a)
395	END DO
396	END DO
397	ENDIF
398	!
399	DO jj = mj0(jbdy1), mj1(jbdy2)
400	zvb(:,jj) = 0._wp ! Correct transport
401	DO jk=1,jpkm1
402	DO ji=1,jpi
403	zvb(ji,jj) = zvb(ji,jj) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk)
404	END DO
405	END DO
406	DO ji = 1, jpi
407	zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a)
408	END DO
409	DO jk = 1, jpkm1
410	DO ji = 1, jpi
411	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)
412	END DO
413	END DO
414	END DO
415	!
416	IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate
417	jbdy1 = jpjglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1
418	jbdy2 = jpjglo - ( nn_hls + 1 ) ! halo + land + 1 - 1
419	DO jj = mj0(jbdy1), mj1(jbdy2)
420	zub(:,jj) = 0._wp
421	DO jk = 1, jpkm1
422	DO ji = 1, jpi
423	zub(ji,jj) = zub(ji,jj) + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk)
424	END DO
425	END DO
426	DO ji = 1, jpi
427	zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a)
428	END DO
429	DO jk = 1, jpkm1
430	DO ji = 1, jpi
431	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)
432	END DO
433	END DO
434	END DO
435	ENDIF
436	!
437	ENDIF
438	!
439	END SUBROUTINE Agrif_dyn
440
441
442	SUBROUTINE Agrif_dyn_ts( jn )
443	!!----------------------------------------------------------------------
444	!! * ROUTINE Agrif_dyn_ts *
445	!!----------------------------------------------------------------------
446	INTEGER, INTENT(in) :: jn
447	!!
448	INTEGER :: ji, jj
449	INTEGER :: istart, iend, jstart, jend
450	!!----------------------------------------------------------------------
451	!
452	IF( Agrif_Root() ) RETURN
453	!
454	!--- West ---!
455	IF( lk_west ) THEN
456	istart = nn_hls + 2 ! halo + land + 1
457	iend = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells
458	DO ji = mi0(istart), mi1(iend)
459	DO jj=1,jpj
460	va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj)
461	ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj)
462	END DO
463	END DO
464	ENDIF
465	!
466	!--- East ---!
467	IF( lk_east ) THEN
468	istart = jpiglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1
469	iend = jpiglo - ( nn_hls + 1 ) ! halo + land + 1 - 1
470	DO ji = mi0(istart), mi1(iend)
471
472	DO jj=1,jpj
473	va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj)
474	END DO
475	END DO
476	istart = jpiglo - ( nn_hls + nbghostcells + 1) ! halo + land + nbghostcells
477	iend = jpiglo - ( nn_hls + 2 ) ! halo + land + 1
478	DO ji = mi0(istart), mi1(iend)
479	DO jj=1,jpj
480	ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj)
481	END DO
482	END DO
483	ENDIF
484	!
485	!--- South ---!
486	IF( lk_south ) THEN
487	jstart = nn_hls + 2 ! halo + land + 1
488	jend = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells
489	DO jj = mj0(jstart), mj1(jend)
490
491	DO ji=1,jpi
492	ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj)
493	va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj)
494	END DO
495	END DO
496	ENDIF
497	!
498	!--- North ---!
499	IF( lk_north ) THEN
500	jstart = jpjglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1
501	jend = jpjglo - ( nn_hls + 1 ) ! halo + land + 1 - 1
502	DO jj = mj0(jstart), mj1(jend)
503	DO ji=1,jpi
504	ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj)
505	END DO
506	END DO
507	jstart = jpjglo - ( nn_hls + nbghostcells + 1) ! halo + land + nbghostcells
508	jend = jpjglo - ( nn_hls + 2 ) ! halo + land + 1
509	DO jj = mj0(jstart), mj1(jend)
510	DO ji=1,jpi
511	va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj)
512	END DO
513	END DO
514	ENDIF
515	!
516	END SUBROUTINE Agrif_dyn_ts
517
518
519	SUBROUTINE Agrif_dyn_ts_flux( jn, zu, zv )
520	!!----------------------------------------------------------------------
521	!! * ROUTINE Agrif_dyn_ts_flux *
522	!!----------------------------------------------------------------------
523	INTEGER, INTENT(in) :: jn
524	REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: zu, zv
525	!!
526	INTEGER :: ji, jj
527	INTEGER :: istart, iend, jstart, jend
528	!!----------------------------------------------------------------------
529	!
530	IF( Agrif_Root() ) RETURN
531	!
532	!--- West ---!
533	IF( lk_west ) THEN
534	istart = nn_hls + 2 ! halo + land + 1
535	iend = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells
536	DO ji = mi0(istart), mi1(iend)
537	DO jj=1,jpj
538	zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj)
539	zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj)
540	END DO
541	END DO
542	ENDIF
543	!
544	!--- East ---!
545	IF( lk_east ) THEN
546	istart = jpiglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1
547	iend = jpiglo - ( nn_hls + 1 ) ! halo + land + 1 - 1
548	DO ji = mi0(istart), mi1(iend)
549	DO jj=1,jpj
550	zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj)
551	END DO
552	END DO
553	istart = jpiglo - ( nn_hls + nbghostcells + 1) ! halo + land + nbghostcells
554	iend = jpiglo - ( nn_hls + 2 ) ! halo + land + 1
555	DO ji = mi0(istart), mi1(iend)
556	DO jj=1,jpj
557	zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj)
558	END DO
559	END DO
560	ENDIF
561	!
562	!--- South ---!
563	IF( lk_south ) THEN
564	jstart = nn_hls + 2 ! halo + land + 1
565	jend = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells
566	DO jj = mj0(jstart), mj1(jend)
567	DO ji=1,jpi
568	zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj)
569	zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj)
570	END DO
571	END DO
572	ENDIF
573	!
574	!--- North ---!
575	IF( lk_north ) THEN
576	jstart = jpjglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1
577	jend = jpjglo - ( nn_hls + 1 ) ! halo + land + 1 - 1
578	DO jj = mj0(jstart), mj1(jend)
579	DO ji=1,jpi
580	zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj)
581	END DO
582	END DO
583	jstart = jpjglo - ( nn_hls + nbghostcells + 1) ! halo + land + nbghostcells
584	jend = jpjglo - ( nn_hls + 2 ) ! halo + land + 1
585	DO jj = mj0(jstart), mj1(jend)
586	DO ji=1,jpi
587	zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj)
588	END DO
589	END DO
590	ENDIF
591	!
592	END SUBROUTINE Agrif_dyn_ts_flux
593
594
595	SUBROUTINE Agrif_dta_ts( kt )
596	!!----------------------------------------------------------------------
597	!! * ROUTINE Agrif_dta_ts *
598	!!----------------------------------------------------------------------
599	INTEGER, INTENT(in) :: kt
600	!!
601	INTEGER :: ji, jj
602	LOGICAL :: ll_int_cons
603	!!----------------------------------------------------------------------
604	!
605	IF( Agrif_Root() ) RETURN
606	!
607	ll_int_cons = ln_bt_fw ! Assume conservative temporal integration in the forward case only
608	!
609	! Enforce volume conservation if no time refinement:
610	IF ( Agrif_rhot()==1 ) ll_int_cons=.TRUE.
611	!
612	! Interpolate barotropic fluxes
613	Agrif_SpecialValue = 0._wp
614	Agrif_UseSpecialValue = ln_spc_dyn
615
616	use_sign_north = .TRUE.
617	sign_north = -1.
618
619	!
620	! Set bdy time interpolation stage to 0 (latter incremented locally do deal with corners)
621	utint_stage(:,:) = 0
622	vtint_stage(:,:) = 0
623	!
624	IF( ll_int_cons ) THEN ! Conservative interpolation
625	! order matters here !!!!!!
626	CALL Agrif_Bc_variable( ub2b_interp_id, calledweight=1._wp, procname=interpub2b ) ! Time integrated
627	CALL Agrif_Bc_variable( vb2b_interp_id, calledweight=1._wp, procname=interpvb2b )
628	!
629	bdy_tinterp = 1
630	CALL Agrif_Bc_variable( unb_id , calledweight=1._wp, procname=interpunb ) ! After
631	CALL Agrif_Bc_variable( vnb_id , calledweight=1._wp, procname=interpvnb )
632	!
633	bdy_tinterp = 2
634	CALL Agrif_Bc_variable( unb_id , calledweight=0._wp, procname=interpunb ) ! Before
635	CALL Agrif_Bc_variable( vnb_id , calledweight=0._wp, procname=interpvnb )
636	ELSE ! Linear interpolation
637	!
638	ubdy(:,:) = 0._wp ; vbdy(:,:) = 0._wp
639	CALL Agrif_Bc_variable( unb_id, procname=interpunb )
640	CALL Agrif_Bc_variable( vnb_id, procname=interpvnb )
641	ENDIF
642	Agrif_UseSpecialValue = .FALSE.
643	use_sign_north = .FALSE.
644	!
645	END SUBROUTINE Agrif_dta_ts
646
647
648	SUBROUTINE Agrif_ssh( kt )
649	!!----------------------------------------------------------------------
650	!! * ROUTINE Agrif_ssh *
651	!!----------------------------------------------------------------------
652	INTEGER, INTENT(in) :: kt
653	!
654	INTEGER :: ji, jj
655	INTEGER :: istart, iend, jstart, jend
656	!!----------------------------------------------------------------------
657	!
658	IF( Agrif_Root() ) RETURN
659	!
660	! Linear time interpolation of sea level
661	!
662	Agrif_SpecialValue = 0._wp
663	Agrif_UseSpecialValue = .TRUE.
664	CALL Agrif_Bc_variable(sshn_id, procname=interpsshn )
665	Agrif_UseSpecialValue = .FALSE.
666	!
667	! --- West --- !
668	IF(lk_west) THEN
669	istart = nn_hls + 2 ! halo + land + 1
670	iend = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells
671	DO ji = mi0(istart), mi1(iend)
672	DO jj = 1, jpj
673	ssh(ji,jj,Krhs_a) = hbdy(ji,jj)
674	END DO
675	END DO
676	ENDIF
677	!
678	! --- East --- !
679	IF(lk_east) THEN
680	istart = jpiglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1
681	iend = jpiglo - ( nn_hls + 1 ) ! halo + land + 1 - 1
682	DO ji = mi0(istart), mi1(iend)
683	DO jj = 1, jpj
684	ssh(ji,jj,Krhs_a) = hbdy(ji,jj)
685	END DO
686	END DO
687	ENDIF
688	!
689	! --- South --- !
690	IF(lk_south) THEN
691	jstart = nn_hls + 2 ! halo + land + 1
692	jend = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells
693	DO jj = mj0(jstart), mj1(jend)
694	DO ji = 1, jpi
695	ssh(ji,jj,Krhs_a) = hbdy(ji,jj)
696	END DO
697	END DO
698	ENDIF
699	!
700	! --- North --- !
701	IF(lk_north) THEN
702	jstart = jpjglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1
703	jend = jpjglo - ( nn_hls + 1 ) ! halo + land + 1 - 1
704	DO jj = mj0(jstart), mj1(jend)
705	DO ji = 1, jpi
706	ssh(ji,jj,Krhs_a) = hbdy(ji,jj)
707	END DO
708	END DO
709	ENDIF
710	!
711	END SUBROUTINE Agrif_ssh
712
713
714	SUBROUTINE Agrif_ssh_ts( jn )
715	!!----------------------------------------------------------------------
716	!! * ROUTINE Agrif_ssh_ts *
717	!!----------------------------------------------------------------------
718	INTEGER, INTENT(in) :: jn
719	!!
720	INTEGER :: ji, jj
721	INTEGER :: istart, iend, jstart, jend
722	!!----------------------------------------------------------------------
723	!
724	IF( Agrif_Root() ) RETURN
725	!
726	! --- West --- !
727	IF(lk_west) THEN
728	istart = nn_hls + 2 ! halo + land + 1
729	iend = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells
730	DO ji = mi0(istart), mi1(iend)
731	DO jj = 1, jpj
732	ssha_e(ji,jj) = hbdy(ji,jj)
733	END DO
734	END DO
735	ENDIF
736	!
737	! --- East --- !
738	IF(lk_east) THEN
739	istart = jpiglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1
740	iend = jpiglo - ( nn_hls + 1 ) ! halo + land + 1 - 1
741	DO ji = mi0(istart), mi1(iend)
742	DO jj = 1, jpj
743	ssha_e(ji,jj) = hbdy(ji,jj)
744	END DO
745	END DO
746	ENDIF
747	!
748	! --- South --- !
749	IF(lk_south) THEN
750	jstart = nn_hls + 2 ! halo + land + 1
751	jend = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells
752	DO jj = mj0(jstart), mj1(jend)
753	DO ji = 1, jpi
754	ssha_e(ji,jj) = hbdy(ji,jj)
755	END DO
756	END DO
757	ENDIF
758	!
759	! --- North --- !
760	IF(lk_north) THEN
761	jstart = jpjglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1
762	jend = jpjglo - ( nn_hls + 1 ) ! halo + land + 1 - 1
763	DO jj = mj0(jstart), mj1(jend)
764	DO ji = 1, jpi
765	ssha_e(ji,jj) = hbdy(ji,jj)
766	END DO
767	END DO
768	ENDIF
769	!
770	END SUBROUTINE Agrif_ssh_ts
771
772
773	SUBROUTINE Agrif_avm
774	!!----------------------------------------------------------------------
775	!! * ROUTINE Agrif_avm *
776	!!----------------------------------------------------------------------
777	REAL(wp) :: zalpha
778	!!----------------------------------------------------------------------
779	!
780	IF( Agrif_Root() ) RETURN
781	!
782	zalpha = 1._wp ! JC: proper time interpolation impossible
783	! => use last available value from parent
784	!
785	Agrif_SpecialValue = 0.e0
786	Agrif_UseSpecialValue = .TRUE.
787	l_vremap = ln_vremap
788	!
789	CALL Agrif_Bc_variable( avm_id, calledweight=zalpha, procname=interpavm )
790	!
791	Agrif_UseSpecialValue = .FALSE.
792	l_vremap = .FALSE.
793	!
794	END SUBROUTINE Agrif_avm
795
796
797	SUBROUTINE interptsn( ptab, i1, i2, j1, j2, k1, k2, n1, n2, before )
798	!!----------------------------------------------------------------------
799	!! * ROUTINE interptsn *
800	!!----------------------------------------------------------------------
801	REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: ptab
802	INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, n1, n2
803	LOGICAL , INTENT(in ) :: before
804	!
805	INTEGER :: ji, jj, jk, jn ! dummy loop indices
806	INTEGER :: N_in, N_out
807	INTEGER :: item
808	! vertical interpolation:
809	REAL(wp) :: zhtot
810	REAL(wp), DIMENSION(k1:k2,1:jpts) :: tabin
811	REAL(wp), DIMENSION(k1:k2) :: h_in, z_in
812	REAL(wp), DIMENSION(1:jpk) :: h_out, z_out
813	!!----------------------------------------------------------------------
814
815	IF( before ) THEN
816
817	item = Kmm_a
818	IF( l_ini_child ) Kmm_a = Kbb_a
819
820	DO jn = 1,jpts
821	DO jk=k1,k2
822	DO jj=j1,j2
823	DO ji=i1,i2
824	ptab(ji,jj,jk,jn) = ts(ji,jj,jk,jn,Kmm_a)
825	END DO
826	END DO
827	END DO
828	END DO
829
830	IF( l_vremap .OR. l_ini_child) THEN
831	! Interpolate thicknesses
832	! Warning: these are masked, hence extrapolated prior interpolation.
833	DO jk=k1,k2
834	DO jj=j1,j2
835	DO ji=i1,i2
836	ptab(ji,jj,jk,jpts+1) = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kmm_a)
837
838	END DO
839	END DO
840	END DO
841
842	! Extrapolate thicknesses in partial bottom cells:
843	! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on
844	IF (ln_zps) THEN
845	DO jj=j1,j2
846	DO ji=i1,i2
847	jk = mbkt(ji,jj)
848	ptab(ji,jj,jk,jpts+1) = 0._wp
849	END DO
850	END DO
851	END IF
852
853	! Save ssh at last level:
854	IF (.NOT.ln_linssh) THEN
855	ptab(i1:i2,j1:j2,k2,jpts+1) = ssh(i1:i2,j1:j2,Kmm_a)*tmask(i1:i2,j1:j2,1)
856	ELSE
857	ptab(i1:i2,j1:j2,k2,jpts+1) = 0._wp
858	END IF
859	ENDIF
860	Kmm_a = item
861
862	ELSE
863	item = Krhs_a
864	IF( l_ini_child ) Krhs_a = Kbb_a
865
866	IF( l_vremap .OR. l_ini_child ) THEN
867	IF (ln_linssh) ptab(i1:i2,j1:j2,k2,n2) = 0._wp
868
869	DO jj=j1,j2
870	DO ji=i1,i2
871	ts(ji,jj,:,:,Krhs_a) = 0.
872	N_in = mbkt_parent(ji,jj)
873	zhtot = 0._wp
874	DO jk=1,N_in !k2 = jpk of parent grid
875	IF (jk==N_in) THEN
876	h_in(jk) = ht0_parent(ji,jj) + ptab(ji,jj,k2,n2) - zhtot
877	ELSE
878	h_in(jk) = ptab(ji,jj,jk,n2)
879	ENDIF
880	zhtot = zhtot + h_in(jk)
881	tabin(jk,:) = ptab(ji,jj,jk,n1:n2-1)
882	END DO
883	z_in(1) = 0.5_wp * h_in(1) - zhtot + ht0_parent(ji,jj)
884	DO jk=2,N_in
885	z_in(jk) = z_in(jk-1) + 0.5_wp * h_in(jk)
886	END DO
887
888	N_out = 0
889	DO jk=1,jpk ! jpk of child grid
890	IF (tmask(ji,jj,jk) == 0._wp) EXIT
891	N_out = N_out + 1
892	h_out(jk) = e3t(ji,jj,jk,Krhs_a)
893	END DO
894
895	z_out(1) = 0.5_wp * h_out(1) - SUM(h_out(1:N_out)) + ht_0(ji,jj)
896	DO jk=2,N_out
897	z_out(jk) = z_out(jk-1) + 0.5_wp * h_out(jk)
898	END DO
899
900	IF (N_in*N_out > 0) THEN
901	IF( l_ini_child ) THEN
902	CALL remap_linear(tabin(1:N_in,1:jpts),z_in(1:N_in),ts(ji,jj,1:N_out,1:jpts,Krhs_a), &
903	& z_out(1:N_out),N_in,N_out,jpts)
904	ELSE
905	CALL reconstructandremap(tabin(1:N_in,1:jpts),h_in(1:N_in),ts(ji,jj,1:N_out,1:jpts,Krhs_a), &
906	& h_out(1:N_out),N_in,N_out,jpts)
907	ENDIF
908	ENDIF
909	END DO
910	END DO
911	Krhs_a = item
912
913	ELSE
914
915	DO jn=1, jpts
916	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)
917	END DO
918	ENDIF
919
920	ENDIF
921	!
922	END SUBROUTINE interptsn
923
924
925	SUBROUTINE interpsshn( ptab, i1, i2, j1, j2, before )
926	!!----------------------------------------------------------------------
927	!! * ROUTINE interpsshn *
928	!!----------------------------------------------------------------------
929	INTEGER , INTENT(in ) :: i1, i2, j1, j2
930	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
931	LOGICAL , INTENT(in ) :: before
932	!
933	!!----------------------------------------------------------------------
934	!
935	IF( before) THEN
936	ptab(i1:i2,j1:j2) = ssh(i1:i2,j1:j2,Kmm_a)
937	ELSE
938	IF( l_ini_child ) THEN
939	ssh(i1:i2,j1:j2,Kmm_a) = ptab(i1:i2,j1:j2) * tmask(i1:i2,j1:j2,1)
940	ELSE
941	hbdy(i1:i2,j1:j2) = ptab(i1:i2,j1:j2) * tmask(i1:i2,j1:j2,1)
942	ENDIF
943	ENDIF
944	!
945	END SUBROUTINE interpsshn
946
947
948	SUBROUTINE interpun( ptab, i1, i2, j1, j2, k1, k2, m1, m2, before )
949	!!----------------------------------------------------------------------
950	!! * ROUTINE interpun *
951	!!---------------------------------------------
952	!!
953	INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,m1,m2
954	REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,m1:m2), INTENT(inout) :: ptab
955	LOGICAL, INTENT(in) :: before
956	!!
957	INTEGER :: ji,jj,jk
958	REAL(wp) :: zrhoy, zhtot
959	! vertical interpolation:
960	REAL(wp), DIMENSION(k1:k2) :: tabin, h_in, z_in
961	REAL(wp), DIMENSION(1:jpk) :: h_out, z_out
962	INTEGER :: N_in, N_out,item
963	REAL(wp) :: h_diff
964	!!---------------------------------------------
965	!
966	IF (before) THEN
967
968	item = Kmm_a
969	IF( l_ini_child ) Kmm_a = Kbb_a
970
971	DO jk=1,jpk
972	DO jj=j1,j2
973	DO ji=i1,i2
974	ptab(ji,jj,jk,1) = (e2u(ji,jj) * e3u(ji,jj,jk,Kmm_a) * uu(ji,jj,jk,Kmm_a)*umask(ji,jj,jk))
975	IF( l_vremap .OR. l_ini_child) THEN
976	! Interpolate thicknesses (masked for subsequent extrapolation)
977	ptab(ji,jj,jk,2) = umask(ji,jj,jk) * e2u(ji,jj) * e3u(ji,jj,jk,Kmm_a)
978	ENDIF
979	END DO
980	END DO
981	END DO
982
983	IF( l_vremap .OR. l_ini_child ) THEN
984	! Extrapolate thicknesses in partial bottom cells:
985	! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on
986	IF (ln_zps) THEN
987	DO jj=j1,j2
988	DO ji=i1,i2
989	jk = mbku(ji,jj)
990	ptab(ji,jj,jk,2) = 0._wp
991	END DO
992	END DO
993	END IF
994
995	! Save ssh at last level:
996	ptab(i1:i2,j1:j2,k2,2) = 0._wp
997	IF (.NOT.ln_linssh) THEN
998	! This vertical sum below should be replaced by the sea-level at U-points (optimization):
999	DO jk=1,jpk
1000	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)
1001	END DO
1002	ptab(i1:i2,j1:j2,k2,2) = ptab(i1:i2,j1:j2,k2,2) - hu_0(i1:i2,j1:j2)
1003	END IF
1004	ENDIF
1005
1006	Kmm_a = item
1007	!
1008	ELSE
1009	zrhoy = Agrif_rhoy()
1010
1011	IF( l_vremap .OR. l_ini_child) THEN
1012	! VERTICAL REFINEMENT BEGIN
1013
1014	IF (ln_linssh) ptab(i1:i2,j1:j2,k2,2) = 0._wp
1015
1016	DO ji=i1,i2
1017	DO jj=j1,j2
1018	uu(ji,jj,:,Krhs_a) = 0._wp
1019	N_in = mbku_parent(ji,jj)
1020	zhtot = 0._wp
1021	DO jk=1,N_in
1022	IF (jk==N_in) THEN
1023	h_in(jk) = hu0_parent(ji,jj) + ptab(ji,jj,k2,2) - zhtot
1024	ELSE
1025	h_in(jk) = ptab(ji,jj,jk,2)/(e2u(ji,jj)*zrhoy)
1026	ENDIF
1027	zhtot = zhtot + h_in(jk)
1028	IF( h_in(jk) .GT. 0. ) THEN
1029	tabin(jk) = ptab(ji,jj,jk,1)/(e2u(ji,jj)zrhoyh_in(jk))
1030	ELSE
1031	tabin(jk) = 0.
1032	ENDIF
1033	END DO
1034	z_in(1) = 0.5_wp * h_in(1) - zhtot + hu0_parent(ji,jj)
1035	DO jk=2,N_in
1036	z_in(jk) = z_in(jk-1) + 0.5_wp * h_in(jk)
1037	END DO
1038
1039	N_out = 0
1040	DO jk=1,jpk
1041	IF (umask(ji,jj,jk) == 0) EXIT
1042	N_out = N_out + 1
1043	h_out(N_out) = e3u(ji,jj,jk,Krhs_a)
1044	END DO
1045
1046	z_out(1) = 0.5_wp * h_out(1) - SUM(h_out(1:N_out)) + hu_0(ji,jj)
1047	DO jk=2,N_out
1048	z_out(jk) = z_out(jk-1) + 0.5_wp * h_out(jk)
1049	END DO
1050
1051	IF (N_in*N_out > 0) THEN
1052	IF( l_ini_child ) THEN
1053	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)
1054	ELSE
1055	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)
1056	ENDIF
1057	ENDIF
1058	END DO
1059	END DO
1060	ELSE
1061	DO jk = 1, jpkm1
1062	DO jj=j1,j2
1063	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) )
1064	END DO
1065	END DO
1066	ENDIF
1067
1068	ENDIF
1069	!
1070	END SUBROUTINE interpun
1071
1072
1073	SUBROUTINE interpvn( ptab, i1, i2, j1, j2, k1, k2, m1, m2, before )
1074	!!----------------------------------------------------------------------
1075	!! * ROUTINE interpvn *
1076	!!----------------------------------------------------------------------
1077	!
1078	INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,m1,m2
1079	REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,m1:m2), INTENT(inout) :: ptab
1080	LOGICAL, INTENT(in) :: before
1081	!
1082	INTEGER :: ji,jj,jk
1083	REAL(wp) :: zrhox
1084	! vertical interpolation:
1085	REAL(wp), DIMENSION(k1:k2) :: tabin, h_in, z_in
1086	REAL(wp), DIMENSION(1:jpk) :: h_out, z_out
1087	INTEGER :: N_in, N_out, item
1088	REAL(wp) :: h_diff, zhtot
1089	!!---------------------------------------------
1090	!
1091	IF (before) THEN
1092
1093	item = Kmm_a
1094	IF( l_ini_child ) Kmm_a = Kbb_a
1095
1096	DO jk=k1,k2
1097	DO jj=j1,j2
1098	DO ji=i1,i2
1099	ptab(ji,jj,jk,1) = (e1v(ji,jj) * e3v(ji,jj,jk,Kmm_a) * vv(ji,jj,jk,Kmm_a)*vmask(ji,jj,jk))
1100	IF( l_vremap .OR. l_ini_child) THEN
1101	! Interpolate thicknesses (masked for subsequent extrapolation)
1102	ptab(ji,jj,jk,2) = vmask(ji,jj,jk) * e1v(ji,jj) * e3v(ji,jj,jk,Kmm_a)
1103	ENDIF
1104	END DO
1105	END DO
1106	END DO
1107
1108	IF( l_vremap .OR. l_ini_child) THEN
1109	! Extrapolate thicknesses in partial bottom cells:
1110	! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on
1111	IF (ln_zps) THEN
1112	DO jj=j1,j2
1113	DO ji=i1,i2
1114	jk = mbkv(ji,jj)
1115	ptab(ji,jj,jk,2) = 0._wp
1116	END DO
1117	END DO
1118	END IF
1119	! Save ssh at last level:
1120	ptab(i1:i2,j1:j2,k2,2) = 0._wp
1121	IF (.NOT.ln_linssh) THEN
1122	! This vertical sum below should be replaced by the sea-level at V-points (optimization):
1123	DO jk=1,jpk
1124	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)
1125	END DO
1126	ptab(i1:i2,j1:j2,k2,2) = ptab(i1:i2,j1:j2,k2,2) - hv_0(i1:i2,j1:j2)
1127	END IF
1128	ENDIF
1129	item = Kmm_a
1130
1131	ELSE
1132	zrhox = Agrif_rhox()
1133
1134	IF( l_vremap .OR. l_ini_child ) THEN
1135
1136	IF (ln_linssh) ptab(i1:i2,j1:j2,k2,2) = 0._wp
1137
1138	DO jj=j1,j2
1139	DO ji=i1,i2
1140	vv(ji,jj,:,Krhs_a) = 0._wp
1141	N_in = mbkv_parent(ji,jj)
1142	zhtot = 0._wp
1143	DO jk=1,N_in
1144	IF (jk==N_in) THEN
1145	h_in(jk) = hv0_parent(ji,jj) + ptab(ji,jj,k2,2) - zhtot
1146	ELSE
1147	h_in(jk) = ptab(ji,jj,jk,2)/(e1v(ji,jj)*zrhox)
1148	ENDIF
1149	zhtot = zhtot + h_in(jk)
1150	IF( h_in(jk) .GT. 0. ) THEN
1151	tabin(jk) = ptab(ji,jj,jk,1)/(e1v(ji,jj)zrhoxh_in(jk))
1152	ELSE
1153	tabin(jk) = 0.
1154	ENDIF
1155	END DO
1156
1157	z_in(1) = 0.5_wp * h_in(1) - zhtot + hv0_parent(ji,jj)
1158	DO jk=2,N_in
1159	z_in(jk) = z_in(jk-1) + 0.5_wp * h_in(jk)
1160	END DO
1161
1162	N_out = 0
1163	DO jk=1,jpk
1164	IF (vmask(ji,jj,jk) == 0) EXIT
1165	N_out = N_out + 1
1166	h_out(N_out) = e3v(ji,jj,jk,Krhs_a)
1167	END DO
1168
1169	z_out(1) = 0.5_wp * h_out(1) - SUM(h_out(1:N_out)) + hv_0(ji,jj)
1170	DO jk=2,N_out
1171	z_out(jk) = z_out(jk-1) + 0.5_wp * h_out(jk)
1172	END DO
1173
1174	IF (N_in*N_out > 0) THEN
1175	IF( l_ini_child ) THEN
1176	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)
1177	ELSE
1178	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)
1179	ENDIF
1180	ENDIF
1181	END DO
1182	END DO
1183	ELSE
1184	DO jk = 1, jpkm1
1185	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) )
1186	END DO
1187	ENDIF
1188	ENDIF
1189	!
1190	END SUBROUTINE interpvn
1191
1192	SUBROUTINE interpunb( ptab, i1, i2, j1, j2, before)
1193	!!----------------------------------------------------------------------
1194	!! * ROUTINE interpunb *
1195	!!----------------------------------------------------------------------
1196	INTEGER , INTENT(in ) :: i1, i2, j1, j2
1197	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
1198	LOGICAL , INTENT(in ) :: before
1199	!
1200	INTEGER :: ji, jj
1201	REAL(wp) :: zrhoy, zrhot, zt0, zt1, ztcoeff
1202	!!----------------------------------------------------------------------
1203	!
1204	IF( before ) THEN
1205	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)
1206	ELSE
1207	zrhoy = Agrif_Rhoy()
1208	zrhot = Agrif_rhot()
1209	! Time indexes bounds for integration
1210	zt0 = REAL(Agrif_NbStepint() , wp) / zrhot
1211	zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot
1212	!
1213	DO ji = i1, i2
1214	DO jj = j1, j2
1215	IF ( utint_stage(ji,jj) < (bdy_tinterp + 1) ) THEN
1216	IF ( utint_stage(ji,jj) == 1 ) THEN
1217	ztcoeff = zrhot * ( zt1*2._wp ( zt1 - 1._wp) &
1218	& - zt0*2._wp ( zt0 - 1._wp) )
1219	ELSEIF( utint_stage(ji,jj) == 2 ) THEN
1220	ztcoeff = zrhot * ( zt1 * ( zt1 - 1._wp)**2._wp &
1221	& - zt0 * ( zt0 - 1._wp)**2._wp )
1222	ELSEIF( utint_stage(ji,jj) == 0 ) THEN
1223	ztcoeff = 1._wp
1224	ELSE
1225	ztcoeff = 0._wp
1226	ENDIF
1227	!
1228	ubdy(ji,jj) = ubdy(ji,jj) + ztcoeff * ptab(ji,jj)
1229	!
1230	IF (( utint_stage(ji,jj) == 2 ).OR.( utint_stage(ji,jj) == 0 )) THEN
1231	ubdy(ji,jj) = ubdy(ji,jj) / (zrhoye2u(ji,jj)) umask(ji,jj,1)
1232	ENDIF
1233	!
1234	utint_stage(ji,jj) = utint_stage(ji,jj) + 1
1235	ENDIF
1236	END DO
1237	END DO
1238	END IF
1239	!
1240	END SUBROUTINE interpunb
1241
1242
1243	SUBROUTINE interpvnb( ptab, i1, i2, j1, j2, before )
1244	!!----------------------------------------------------------------------
1245	!! * ROUTINE interpvnb *
1246	!!----------------------------------------------------------------------
1247	INTEGER , INTENT(in ) :: i1, i2, j1, j2
1248	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
1249	LOGICAL , INTENT(in ) :: before
1250	!
1251	INTEGER :: ji, jj
1252	REAL(wp) :: zrhox, zrhot, zt0, zt1, ztcoeff
1253	!!----------------------------------------------------------------------
1254	!
1255	IF( before ) THEN
1256	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)
1257	ELSE
1258	zrhox = Agrif_Rhox()
1259	zrhot = Agrif_rhot()
1260	! Time indexes bounds for integration
1261	zt0 = REAL(Agrif_NbStepint() , wp) / zrhot
1262	zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot
1263	!
1264	DO ji = i1, i2
1265	DO jj = j1, j2
1266	IF ( vtint_stage(ji,jj) < (bdy_tinterp + 1) ) THEN
1267	IF ( vtint_stage(ji,jj) == 1 ) THEN
1268	ztcoeff = zrhot * ( zt1*2._wp ( zt1 - 1._wp) &
1269	& - zt0*2._wp ( zt0 - 1._wp) )
1270	ELSEIF( vtint_stage(ji,jj) == 2 ) THEN
1271	ztcoeff = zrhot * ( zt1 * ( zt1 - 1._wp)**2._wp &
1272	& - zt0 * ( zt0 - 1._wp)**2._wp )
1273	ELSEIF( vtint_stage(ji,jj) == 0 ) THEN
1274	ztcoeff = 1._wp
1275	ELSE
1276	ztcoeff = 0._wp
1277	ENDIF
1278	!
1279	vbdy(ji,jj) = vbdy(ji,jj) + ztcoeff * ptab(ji,jj)
1280	!
1281	IF (( vtint_stage(ji,jj) == 2 ).OR.( vtint_stage(ji,jj) == 0 )) THEN
1282	vbdy(ji,jj) = vbdy(ji,jj) / (zrhoxe1v(ji,jj)) vmask(ji,jj,1)
1283	ENDIF
1284	!
1285	vtint_stage(ji,jj) = vtint_stage(ji,jj) + 1
1286	ENDIF
1287	END DO
1288	END DO
1289	ENDIF
1290	!
1291	END SUBROUTINE interpvnb
1292
1293
1294	SUBROUTINE interpub2b( ptab, i1, i2, j1, j2, before )
1295	!!----------------------------------------------------------------------
1296	!! * ROUTINE interpub2b *
1297	!!----------------------------------------------------------------------
1298	INTEGER , INTENT(in ) :: i1, i2, j1, j2
1299	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
1300	LOGICAL , INTENT(in ) :: before
1301	!
1302	INTEGER :: ji,jj
1303	REAL(wp) :: zrhot, zt0, zt1, zat
1304	!!----------------------------------------------------------------------
1305	IF( before ) THEN
1306	IF ( ln_bt_fw ) THEN
1307	ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * ub2_b(i1:i2,j1:j2)
1308	ELSE
1309	ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * un_adv(i1:i2,j1:j2)
1310	ENDIF
1311	ELSE
1312	zrhot = Agrif_rhot()
1313	! Time indexes bounds for integration
1314	zt0 = REAL(Agrif_NbStepint() , wp) / zrhot
1315	zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot
1316	! Polynomial interpolation coefficients:
1317	zat = zrhot * ( zt1*2._wp (-2._wp*zt1 + 3._wp) &
1318	& - zt0*2._wp (-2._wp*zt0 + 3._wp) )
1319	!
1320	ubdy(i1:i2,j1:j2) = zat * ptab(i1:i2,j1:j2)
1321	!
1322	! Update interpolation stage:
1323	utint_stage(i1:i2,j1:j2) = 1
1324	ENDIF
1325	!
1326	END SUBROUTINE interpub2b
1327
1328
1329	SUBROUTINE interpvb2b( ptab, i1, i2, j1, j2, before )
1330	!!----------------------------------------------------------------------
1331	!! * ROUTINE interpvb2b *
1332	!!----------------------------------------------------------------------
1333	INTEGER , INTENT(in ) :: i1, i2, j1, j2
1334	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
1335	LOGICAL , INTENT(in ) :: before
1336	!
1337	INTEGER :: ji,jj
1338	REAL(wp) :: zrhot, zt0, zt1, zat
1339	!!----------------------------------------------------------------------
1340	!
1341	IF( before ) THEN
1342	IF ( ln_bt_fw ) THEN
1343	ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * vb2_b(i1:i2,j1:j2)
1344	ELSE
1345	ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * vn_adv(i1:i2,j1:j2)
1346	ENDIF
1347	ELSE
1348	zrhot = Agrif_rhot()
1349	! Time indexes bounds for integration
1350	zt0 = REAL(Agrif_NbStepint() , wp) / zrhot
1351	zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot
1352	! Polynomial interpolation coefficients:
1353	zat = zrhot * ( zt1*2._wp (-2._wp*zt1 + 3._wp) &
1354	& - zt0*2._wp (-2._wp*zt0 + 3._wp) )
1355	!
1356	vbdy(i1:i2,j1:j2) = zat * ptab(i1:i2,j1:j2)
1357	!
1358	! update interpolation stage:
1359	vtint_stage(i1:i2,j1:j2) = 1
1360	ENDIF
1361	!
1362	END SUBROUTINE interpvb2b
1363
1364
1365	SUBROUTINE interpe3t( ptab, i1, i2, j1, j2, k1, k2, before )
1366	!!----------------------------------------------------------------------
1367	!! * ROUTINE interpe3t *
1368	!!----------------------------------------------------------------------
1369	INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2
1370	REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab
1371	LOGICAL , INTENT(in ) :: before
1372	!
1373	INTEGER :: ji, jj, jk
1374	!!----------------------------------------------------------------------
1375	!
1376	IF( before ) THEN
1377	ptab(i1:i2,j1:j2,k1:k2) = tmask(i1:i2,j1:j2,k1:k2) * e3t_0(i1:i2,j1:j2,k1:k2)
1378	ELSE
1379	!
1380	DO jk = k1, k2
1381	DO jj = j1, j2
1382	DO ji = i1, i2
1383	IF( ABS( ptab(ji,jj,jk) - tmask(ji,jj,jk) * e3t_0(ji,jj,jk) ) > 1.D-2) THEN
1384	WRITE(numout,*) ' Agrif error for e3t_0: parent , child, i, j, k ', &
1385	& ptab(ji,jj,jk), tmask(ji,jj,jk) * e3t_0(ji,jj,jk), &
1386	& mig0(ji), mjg0(jj), jk
1387	! kindic_agr = kindic_agr + 1
1388	ENDIF
1389	END DO
1390	END DO
1391	END DO
1392	!
1393	ENDIF
1394	!
1395	END SUBROUTINE interpe3t
1396
1397	SUBROUTINE interpglamt( ptab, i1, i2, j1, j2, before )
1398	!!----------------------------------------------------------------------
1399	!! * ROUTINE interpglamt *
1400	!!----------------------------------------------------------------------
1401	INTEGER , INTENT(in ) :: i1, i2, j1, j2
1402	REAL(wp),DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
1403	LOGICAL , INTENT(in ) :: before
1404	!
1405	INTEGER :: ji, jj, jk
1406	REAL(wp):: ztst
1407	!!----------------------------------------------------------------------
1408	!
1409	IF( before ) THEN
1410	ptab(i1:i2,j1:j2) = glamt(i1:i2,j1:j2)
1411	ELSE
1412	ztst = MAXVAL(ABS(glamt(i1:i2,j1:j2)))*1.e-4
1413	DO jj = j1, j2
1414	DO ji = i1, i2
1415	IF( ABS( ptab(ji,jj) - glamt(ji,jj) ) > ztst ) THEN
1416	WRITE(numout,*) ' Agrif error for glamt: parent, child, i, j ', ptab(ji,jj), glamt(ji,jj), mig0(ji), mig0(jj)
1417	! kindic_agr = kindic_agr + 1
1418	ENDIF
1419	END DO
1420	END DO
1421	ENDIF
1422	!
1423	END SUBROUTINE interpglamt
1424
1425
1426	SUBROUTINE interpgphit( ptab, i1, i2, j1, j2, before )
1427	!!----------------------------------------------------------------------
1428	!! * ROUTINE interpgphit *
1429	!!----------------------------------------------------------------------
1430	INTEGER , INTENT(in ) :: i1, i2, j1, j2
1431	REAL(wp),DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
1432	LOGICAL , INTENT(in ) :: before
1433	!
1434	INTEGER :: ji, jj, jk
1435	REAL(wp):: ztst
1436	!!----------------------------------------------------------------------
1437	!
1438	IF( before ) THEN
1439	ptab(i1:i2,j1:j2) = gphit(i1:i2,j1:j2)
1440	ELSE
1441	ztst = MAXVAL(ABS(gphit(i1:i2,j1:j2)))*1.e-4
1442	DO jj = j1, j2
1443	DO ji = i1, i2
1444	IF( ABS( ptab(ji,jj) - gphit(ji,jj) ) > ztst ) THEN
1445	WRITE(numout,*) ' Agrif error for gphit: parent, child, i, j ', ptab(ji,jj), gphit(ji,jj), mig0(ji), mig0(jj)
1446	! kindic_agr = kindic_agr + 1
1447	ENDIF
1448	END DO
1449	END DO
1450	ENDIF
1451	!
1452	END SUBROUTINE interpgphit
1453
1454
1455	SUBROUTINE interpavm( ptab, i1, i2, j1, j2, k1, k2, m1, m2, before )
1456	!!----------------------------------------------------------------------
1457	!! * ROUTINE interavm *
1458	!!----------------------------------------------------------------------
1459	INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, m1, m2
1460	REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,m1:m2), INTENT(inout) :: ptab
1461	LOGICAL , INTENT(in ) :: before
1462	!
1463	INTEGER :: ji, jj, jk
1464	INTEGER :: N_in, N_out
1465	REAL(wp), DIMENSION(k1:k2) :: tabin, z_in
1466	REAL(wp), DIMENSION(1:jpk) :: z_out
1467	!!----------------------------------------------------------------------
1468	!
1469	IF (before) THEN
1470	DO jk=k1,k2
1471	DO jj=j1,j2
1472	DO ji=i1,i2
1473	ptab(ji,jj,jk,1) = avm_k(ji,jj,jk)
1474	END DO
1475	END DO
1476	END DO
1477
1478	IF( l_vremap ) THEN
1479	! Interpolate thicknesses
1480	! Warning: these are masked, hence extrapolated prior interpolation.
1481	DO jk=k1,k2
1482	DO jj=j1,j2
1483	DO ji=i1,i2
1484	ptab(ji,jj,jk,2) = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kmm_a)
1485	END DO
1486	END DO
1487	END DO
1488
1489	! Extrapolate thicknesses in partial bottom cells:
1490	! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on
1491	IF (ln_zps) THEN
1492	DO jj=j1,j2
1493	DO ji=i1,i2
1494	jk = mbkt(ji,jj)
1495	ptab(ji,jj,jk,2) = 0._wp
1496	END DO
1497	END DO
1498	END IF
1499
1500	! Save ssh at last level:
1501	IF (.NOT.ln_linssh) THEN
1502	ptab(i1:i2,j1:j2,k2,2) = ssh(i1:i2,j1:j2,Kmm_a)*tmask(i1:i2,j1:j2,1)
1503	ELSE
1504	ptab(i1:i2,j1:j2,k2,2) = 0._wp
1505	END IF
1506	ENDIF
1507
1508	ELSE
1509
1510	IF( l_vremap ) THEN
1511	IF (ln_linssh) ptab(i1:i2,j1:j2,k2,2) = 0._wp
1512	avm_k(i1:i2,j1:j2,k1:k2) = 0._wp
1513
1514	DO jj = j1, j2
1515	DO ji =i1, i2
1516	N_in = mbkt_parent(ji,jj)
1517	IF ( tmask(ji,jj,1) == 0._wp) N_in = 0
1518	z_in(N_in+1) = ht0_parent(ji,jj) + ptab(ji,jj,k2,2)
1519	DO jk = N_in, 1, -1 ! Parent vertical grid
1520	z_in(jk) = z_in(jk+1) - ptab(ji,jj,jk,2)
1521	tabin(jk) = ptab(ji,jj,jk,1)
1522	END DO
1523	N_out = mbkt(ji,jj)
1524	DO jk = 1, N_out ! Child vertical grid
1525	z_out(jk) = gdepw(ji,jj,jk,Kmm_a)
1526	END DO
1527	IF (N_in*N_out > 0) THEN
1528	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)
1529	ENDIF
1530	END DO
1531	END DO
1532	ELSE
1533	avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2,1)
1534	ENDIF
1535	ENDIF
1536	!
1537	END SUBROUTINE interpavm
1538
1539
1540	SUBROUTINE interpmbkt( ptab, i1, i2, j1, j2, before )
1541	!!----------------------------------------------------------------------
1542	!! * ROUTINE interpmbkt *
1543	!!----------------------------------------------------------------------
1544	INTEGER , INTENT(in ) :: i1, i2, j1, j2
1545	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
1546	LOGICAL , INTENT(in ) :: before
1547	!
1548	!!----------------------------------------------------------------------
1549	!
1550	IF( before) THEN
1551	ptab(i1:i2,j1:j2) = REAL(mbkt(i1:i2,j1:j2),wp)
1552	ELSE
1553	mbkt_parent(i1:i2,j1:j2) = NINT(ptab(i1:i2,j1:j2))
1554	ENDIF
1555	!
1556	END SUBROUTINE interpmbkt
1557
1558
1559	SUBROUTINE interpht0( ptab, i1, i2, j1, j2, before )
1560	!!----------------------------------------------------------------------
1561	!! * ROUTINE interpht0 *
1562	!!----------------------------------------------------------------------
1563	INTEGER , INTENT(in ) :: i1, i2, j1, j2
1564	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
1565	LOGICAL , INTENT(in ) :: before
1566	!
1567	!!----------------------------------------------------------------------
1568	!
1569	IF( before) THEN
1570	ptab(i1:i2,j1:j2) = ht_0(i1:i2,j1:j2)
1571	ELSE
1572	ht0_parent(i1:i2,j1:j2) = ptab(i1:i2,j1:j2)
1573	ENDIF
1574	!
1575	END SUBROUTINE interpht0
1576
1577	SUBROUTINE Agrif_check_bat( iindic )
1578	!!----------------------------------------------------------------------
1579	!! * ROUTINE Agrif_check_bat *
1580	!!----------------------------------------------------------------------
1581	INTEGER, INTENT(inout) :: iindic
1582	!!
1583	INTEGER :: ji, jj
1584	INTEGER :: istart, iend, jstart, jend, ispon
1585	!!----------------------------------------------------------------------
1586	!
1587	!
1588	! --- West --- !
1589	IF(lk_west) THEN
1590	ispon = nn_sponge_len * Agrif_irhox() + 1
1591	istart = nn_hls + 2 ! halo + land + 1
1592	iend = nn_hls + 1 + nbghostcells + ispon ! halo + land + nbghostcells + sponge
1593	jstart = nn_hls + 2
1594	jend = jpjglo - nn_hls - 1
1595	DO ji = mi0(istart), mi1(iend)
1596	DO jj = mj0(jstart), mj1(jend)
1597	IF ( ABS(ht0_parent(ji,jj)-ht_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
1598	END DO
1599	DO jj = mj0(jstart), mj1(jend-1)
1600	IF ( ABS(hv0_parent(ji,jj)-hv_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
1601	END DO
1602	END DO
1603	DO ji = mi0(istart), mi1(iend-1)
1604	DO jj = mj0(jstart), mj1(jend)
1605	IF ( ABS(hu0_parent(ji,jj)-hu_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
1606	END DO
1607	END DO
1608	ENDIF
1609	!
1610	! --- East --- !
1611	IF(lk_east) THEN
1612	ispon = nn_sponge_len * Agrif_irhox() + 1
1613	istart = jpiglo - ( nn_hls + nbghostcells + ispon ) ! halo + land + nbghostcells + sponge - 1
1614	iend = jpiglo - ( nn_hls + 1 ) ! halo + land + 1 - 1
1615	jstart = nn_hls + 2
1616	jend = jpjglo - nn_hls - 1
1617	DO ji = mi0(istart), mi1(iend)
1618	DO jj = mj0(jstart), mj1(jend)
1619	IF ( ABS(ht0_parent(ji,jj)-ht_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
1620	END DO
1621	DO jj = mj0(jstart), mj1(jend-1)
1622	IF ( ABS(hv0_parent(ji,jj)-hv_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
1623	END DO
1624	END DO
1625	DO ji = mi0(istart), mi1(iend-1)
1626	DO jj = mj0(jstart), mj1(jend)
1627	IF ( ABS(hu0_parent(ji,jj)-hu_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
1628	END DO
1629	END DO
1630	ENDIF
1631	!
1632	! --- South --- !
1633	IF(lk_south) THEN
1634	ispon = nn_sponge_len * Agrif_irhoy() + 1
1635	jstart = nn_hls + 2 ! halo + land + 1
1636	jend = nn_hls + 1 + nbghostcells + ispon ! halo + land + nbghostcells + sponge
1637	istart = nn_hls + 2
1638	iend = jpiglo - nn_hls - 1
1639	DO jj = mj0(jstart), mj1(jend)
1640	DO ji = mi0(istart), mi1(iend)
1641	IF ( ABS(ht0_parent(ji,jj)-ht_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
1642	END DO
1643	DO ji = mi0(istart), mi1(iend-1)
1644	IF ( ABS(hu0_parent(ji,jj)-hu_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
1645	END DO
1646	END DO
1647	DO jj = mj0(jstart), mj1(jend-1)
1648	DO ji = mi0(istart), mi1(iend)
1649	IF ( ABS(hv0_parent(ji,jj)-hv_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
1650	END DO
1651	END DO
1652	ENDIF
1653	!
1654	! --- North --- !
1655	IF(lk_north) THEN
1656	ispon = nn_sponge_len * Agrif_irhoy() + 1
1657	jstart = jpjglo - ( nn_hls + nbghostcells + ispon) ! halo + land + nbghostcells +sponge - 1
1658	jend = jpjglo - ( nn_hls + 1 ) ! halo + land + 1 - 1
1659	istart = nn_hls + 2
1660	iend = jpiglo - nn_hls - 1
1661	DO jj = mj0(jstart), mj1(jend)
1662	DO ji = mi0(istart), mi1(iend)
1663	IF ( ABS(ht0_parent(ji,jj)-ht_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
1664	END DO
1665	DO ji = mi0(istart), mi1(iend-1)
1666	IF ( ABS(hu0_parent(ji,jj)-hu_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
1667	END DO
1668	END DO
1669	DO jj = mj0(jstart), mj1(jend-1)
1670	DO ji = mi0(istart), mi1(iend)
1671	IF ( ABS(hv0_parent(ji,jj)-hv_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
1672	END DO
1673	END DO
1674	ENDIF
1675	!
1676	END SUBROUTINE Agrif_check_bat
1677
1678	#else
1679	!!----------------------------------------------------------------------
1680	!! Empty module no AGRIF zoom
1681	!!----------------------------------------------------------------------
1682	CONTAINS
1683	SUBROUTINE Agrif_OCE_Interp_empty
1684	WRITE(,) 'agrif_oce_interp : You should not have seen this print! error?'
1685	END SUBROUTINE Agrif_OCE_Interp_empty
1686	#endif
1687
1688	!!======================================================================
1689	END MODULE agrif_oce_interp

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

Download in other formats: