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_opa_interp.F90 in branches/2015/dev_r5803_UKMO_AGRIF_Vert_interp/NEMOGCM/NEMO/NST_SRC – NEMO

Context Navigation

source: branches/2015/dev_r5803_UKMO_AGRIF_Vert_interp/NEMOGCM/NEMO/NST_SRC/agrif_opa_interp.F90 @ 8100

Last change on this file since 8100 was 8100, checked in by timgraham, 7 years ago
Bug fixes and small changes to interptsn, interpun and interpvn to work with sloping bathymetry
Property svn:keywords set to `Id`
File size: 57.9 KB

Line
1	MODULE agrif_opa_interp
2	!!======================================================================
3	!! * MODULE agrif_opa_interp *
4	!! AGRIF: interpolation package
5	!!======================================================================
6	!! History : 2.0 ! 2002-06 (XXX) Original cade
7	!! - ! 2005-11 (XXX)
8	!! 3.2 ! 2009-04 (R. Benshila)
9	!! 3.6 ! 2014-09 (R. Benshila)
10	!!----------------------------------------------------------------------
11	#if defined key_agrif && ! defined key_offline
12	!!----------------------------------------------------------------------
13	!! 'key_agrif' AGRIF zoom
14	!! NOT 'key_offline' NO off-line tracers
15	!!----------------------------------------------------------------------
16	!! Agrif_tra :
17	!! Agrif_dyn :
18	!! interpu :
19	!! interpv :
20	!!----------------------------------------------------------------------
21	USE par_oce
22	USE oce
23	USE dom_oce
24	USE zdf_oce
25	USE agrif_oce
26	USE phycst
27	!
28	USE in_out_manager
29	USE agrif_opa_sponge
30	USE lib_mpp
31	USE wrk_nemo
32
33	IMPLICIT NONE
34	PRIVATE
35
36	PUBLIC Agrif_tra, Agrif_dyn, Agrif_ssh, Agrif_dyn_ts, Agrif_ssh_ts, Agrif_dta_ts
37	! VERTICAL REFINEMENT BEGIN
38	PUBLIC Agrif_Init_InterpScales
39	! VERTICAL REFINEMENT END
40	PUBLIC interpun, interpvn
41	PUBLIC interptsn, interpsshn
42	PUBLIC interpunb, interpvnb, interpub2b, interpvb2b
43	PUBLIC interpe3t, interpumsk, interpvmsk
44	# if defined key_zdftke
45	PUBLIC Agrif_tke, interpavm
46	# endif
47
48	INTEGER :: bdy_tinterp = 0
49
50	# include "vectopt_loop_substitute.h90"
51	!!----------------------------------------------------------------------
52	!! NEMO/NST 3.7 , NEMO Consortium (2015)
53	!! $Id$
54	!! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
55	!!----------------------------------------------------------------------
56	! VERTICAL REFINEMENT BEGIN
57	REAL, DIMENSION(:,:,:), ALLOCATABLE :: interp_scales_t, interp_scales_u, interp_scales_v
58	!$AGRIF_DO_NOT_TREAT
59	LOGICAL :: scaleT, scaleU, scaleV = .FALSE.
60	!$AGRIF_END_DO_NOT_TREAT
61	! VERTICAL REFINEMENT END
62
63	CONTAINS
64
65	! VERTICAL REFINEMENT BEGIN
66
67	SUBROUTINE Agrif_Init_InterpScales
68
69	scaleT = .TRUE.
70	Call Agrif_Bc_Variable(scales_t_id,calledweight=1.,procname=interpscales)
71	scaleT = .FALSE.
72
73	scaleU = .TRUE.
74	Call Agrif_Bc_Variable(scales_u_id,calledweight=1.,procname=interpscales)
75	scaleU = .FALSE.
76
77	scaleV = .TRUE.
78	Call Agrif_Bc_Variable(scales_v_id,calledweight=1.,procname=interpscales)
79	scaleV = .FALSE.
80
81	END SUBROUTINE Agrif_Init_InterpScales
82
83	SUBROUTINE interpscales(ptab,i1,i2,j1,j2,k1,k2,before)
84	!!---------------------------------------------
85	!! * ROUTINE interpscales *
86	!!---------------------------------------------
87
88	INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2
89	REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab
90
91	INTEGER :: ji, jj, jk
92	LOGICAL :: before
93
94	IF (before) THEN
95	IF (scaleT ) THEN
96	DO jk=k1,k2
97	DO jj=j1,j2
98	DO ji=i1,i2
99	! ptab(ji,jj,jk) = e3t_n(ji,jj,jk) * tmask(ji,jj,jk)
100	ptab(ji,jj,jk) = e3t_n(ji,jj,jk)
101	END DO
102	END DO
103	END DO
104	ELSEIF (scaleU) THEN
105	DO jk=k1,k2
106	DO jj=j1,j2
107	DO ji=i1,i2
108	! ptab(ji,jj,jk) = e3u_n(ji,jj,jk) * umask(ji,jj,jk)
109	! ptab(ji,jj,jk) = e3u_n(ji,jj,jk)
110	ptab(ji,jj,jk) = umask(ji,jj,jk)
111	END DO
112	END DO
113	END DO
114	ELSEIF (scaleV) THEN
115	DO jk=k1,k2
116	DO jj=j1,j2
117	DO ji=i1,i2
118	! ptab(ji,jj,jk) = e3v_n(ji,jj,jk) * vmask(ji,jj,jk)
119	! ptab(ji,jj,jk) = e3v_n(ji,jj,jk)
120	ptab(ji,jj,jk) = vmask(ji,jj,jk)
121	END DO
122	END DO
123	END DO
124	ENDIF
125	ELSE
126	IF (scaleT ) THEN
127	IF (.not.allocated(interp_scales_t)) allocate(interp_scales_t(jpi,jpj,k1:k2))
128	DO jk=k1,k2
129	DO jj=j1,j2
130	DO ji=i1,i2
131	interp_scales_t(ji,jj,jk) = ptab(ji,jj,jk)
132	END DO
133	END DO
134	END DO
135	ELSEIF (scaleU) THEN
136	IF (.not.allocated(interp_scales_u)) allocate(interp_scales_u(jpi,jpj,k1:k2))
137	DO jk=k1,k2
138	DO jj=j1,j2
139	DO ji=i1,i2
140	interp_scales_u(ji,jj,jk) = ptab(ji,jj,jk)
141	END DO
142	END DO
143	END DO
144	ELSEIF (scaleV) THEN
145	IF (.not.allocated(interp_scales_v)) allocate(interp_scales_v(jpi,jpj,k1:k2))
146	DO jk=k1,k2
147	DO jj=j1,j2
148	DO ji=i1,i2
149	interp_scales_v(ji,jj,jk) = ptab(ji,jj,jk)
150	END DO
151	END DO
152	END DO
153	ENDIF
154	ENDIF
155
156	END SUBROUTINE interpscales
157
158	! VERTICAL REFINEMENT END
159
160	SUBROUTINE Agrif_tra
161	!!----------------------------------------------------------------------
162	!! * ROUTINE Agrif_tra *
163	!!----------------------------------------------------------------------
164	!
165	IF( Agrif_Root() ) RETURN
166	!
167	Agrif_SpecialValue = 0._wp
168	Agrif_UseSpecialValue = .TRUE.
169	!
170	CALL Agrif_Bc_variable( tsn_id, procname=interptsn )
171	!
172	Agrif_UseSpecialValue = .FALSE.
173	!
174	END SUBROUTINE Agrif_tra
175
176
177	SUBROUTINE Agrif_dyn( kt )
178	!!----------------------------------------------------------------------
179	!! * ROUTINE Agrif_DYN *
180	!!----------------------------------------------------------------------
181	INTEGER, INTENT(in) :: kt
182	!
183	INTEGER :: ji, jj, jk ! dummy loop indices
184	INTEGER :: j1, j2, i1, i2
185	REAL(wp), POINTER, DIMENSION(:,:) :: zub, zvb
186	!!----------------------------------------------------------------------
187	!
188	IF( Agrif_Root() ) RETURN
189	!
190	CALL wrk_alloc( jpi,jpj, zub, zvb )
191	!
192	Agrif_SpecialValue = 0._wp
193	Agrif_UseSpecialValue = ln_spc_dyn
194	!
195	CALL Agrif_Bc_variable( un_interp_id, procname=interpun )
196	CALL Agrif_Bc_variable( vn_interp_id, procname=interpvn )
197	!
198	Agrif_UseSpecialValue = .FALSE.
199	!
200	! prevent smoothing in ghost cells
201	i1 = 1 ; i2 = jpi
202	j1 = 1 ; j2 = jpj
203	IF( nbondj == -1 .OR. nbondj == 2 ) j1 = 3
204	IF( nbondj == +1 .OR. nbondj == 2 ) j2 = nlcj-2
205	IF( nbondi == -1 .OR. nbondi == 2 ) i1 = 3
206	IF( nbondi == +1 .OR. nbondi == 2 ) i2 = nlci-2
207
208	IF( nbondi == -1 .OR. nbondi == 2 ) THEN
209	!
210	! Smoothing
211	! ---------
212	IF( .NOT.ln_dynspg_ts ) THEN ! Store transport
213	ua_b(2,:) = 0._wp
214	DO jk = 1, jpkm1
215	DO jj = 1, jpj
216	ua_b(2,jj) = ua_b(2,jj) + e3u_a(2,jj,jk) * ua(2,jj,jk)
217	END DO
218	END DO
219	DO jj = 1, jpj
220	ua_b(2,jj) = ua_b(2,jj) * r1_hu_a(2,jj)
221	END DO
222	ENDIF
223	!
224	DO jk=1,jpkm1 ! Smooth
225	DO jj=j1,j2
226	ua(2,jj,jk) = 0.25_wp(ua(1,jj,jk)+2._wpua(2,jj,jk)+ua(3,jj,jk))
227	ua(2,jj,jk) = ua(2,jj,jk) * umask(2,jj,jk)
228	END DO
229	END DO
230	!
231	zub(2,:) = 0._wp ! Correct transport
232	DO jk = 1, jpkm1
233	DO jj = 1, jpj
234	zub(2,jj) = zub(2,jj) + e3u_a(2,jj,jk) * ua(2,jj,jk)
235	END DO
236	END DO
237	DO jj=1,jpj
238	zub(2,jj) = zub(2,jj) * r1_hu_a(2,jj)
239	END DO
240
241	DO jk=1,jpkm1
242	DO jj=1,jpj
243	ua(2,jj,jk) = (ua(2,jj,jk)+ua_b(2,jj)-zub(2,jj))*umask(2,jj,jk)
244	END DO
245	END DO
246
247	! Set tangential velocities to time splitting estimate
248	!-----------------------------------------------------
249	IF( ln_dynspg_ts ) THEN
250	zvb(2,:) = 0._wp
251	DO jk = 1, jpkm1
252	DO jj = 1, jpj
253	zvb(2,jj) = zvb(2,jj) + e3v_a(2,jj,jk) * va(2,jj,jk)
254	END DO
255	END DO
256	DO jj = 1, jpj
257	zvb(2,jj) = zvb(2,jj) * r1_hv_a(2,jj)
258	END DO
259	DO jk = 1, jpkm1
260	DO jj = 1, jpj
261	va(2,jj,jk) = (va(2,jj,jk)+va_b(2,jj)-zvb(2,jj)) * vmask(2,jj,jk)
262	END DO
263	END DO
264	ENDIF
265	!
266	! Mask domain edges:
267	!-------------------
268	DO jk = 1, jpkm1
269	DO jj = 1, jpj
270	ua(1,jj,jk) = 0._wp
271	va(1,jj,jk) = 0._wp
272	END DO
273	END DO
274	!
275	ENDIF
276
277	IF( nbondi == 1 .OR. nbondi == 2 ) THEN
278
279	! Smoothing
280	! ---------
281	IF( .NOT.ln_dynspg_ts ) THEN ! Store transport
282	ua_b(nlci-2,:) = 0._wp
283	DO jk=1,jpkm1
284	DO jj=1,jpj
285	ua_b(nlci-2,jj) = ua_b(nlci-2,jj) + e3u_a(nlci-2,jj,jk) * ua(nlci-2,jj,jk)
286	END DO
287	END DO
288	DO jj=1,jpj
289	ua_b(nlci-2,jj) = ua_b(nlci-2,jj) * r1_hu_a(nlci-2,jj)
290	END DO
291	ENDIF
292
293	DO jk = 1, jpkm1 ! Smooth
294	DO jj = j1, j2
295	ua(nlci-2,jj,jk) = 0.25_wp * umask(nlci-2,jj,jk) &
296	& * ( ua(nlci-3,jj,jk) + 2._wp*ua(nlci-2,jj,jk) + ua(nlci-1,jj,jk) )
297	END DO
298	END DO
299
300	zub(nlci-2,:) = 0._wp ! Correct transport
301	DO jk = 1, jpkm1
302	DO jj = 1, jpj
303	zub(nlci-2,jj) = zub(nlci-2,jj) + e3u_a(nlci-2,jj,jk) * ua(nlci-2,jj,jk)
304	END DO
305	END DO
306	DO jj = 1, jpj
307	zub(nlci-2,jj) = zub(nlci-2,jj) * r1_hu_a(nlci-2,jj)
308	END DO
309
310	DO jk = 1, jpkm1
311	DO jj = 1, jpj
312	ua(nlci-2,jj,jk) = ( ua(nlci-2,jj,jk) + ua_b(nlci-2,jj) - zub(nlci-2,jj) ) * umask(nlci-2,jj,jk)
313	END DO
314	END DO
315	!
316	! Set tangential velocities to time splitting estimate
317	!-----------------------------------------------------
318	IF( ln_dynspg_ts ) THEN
319	zvb(nlci-1,:) = 0._wp
320	DO jk = 1, jpkm1
321	DO jj = 1, jpj
322	zvb(nlci-1,jj) = zvb(nlci-1,jj) + e3v_a(nlci-1,jj,jk) * va(nlci-1,jj,jk)
323	END DO
324	END DO
325	DO jj=1,jpj
326	zvb(nlci-1,jj) = zvb(nlci-1,jj) * r1_hv_a(nlci-1,jj)
327	END DO
328	DO jk = 1, jpkm1
329	DO jj = 1, jpj
330	va(nlci-1,jj,jk) = ( va(nlci-1,jj,jk) + va_b(nlci-1,jj) - zvb(nlci-1,jj) ) * vmask(nlci-1,jj,jk)
331	END DO
332	END DO
333	ENDIF
334	!
335	! Mask domain edges:
336	!-------------------
337	DO jk = 1, jpkm1
338	DO jj = 1, jpj
339	ua(nlci-1,jj,jk) = 0._wp
340	va(nlci ,jj,jk) = 0._wp
341	END DO
342	END DO
343	!
344	ENDIF
345
346	IF( nbondj == -1 .OR. nbondj == 2 ) THEN
347
348	! Smoothing
349	! ---------
350	IF( .NOT.ln_dynspg_ts ) THEN ! Store transport
351	va_b(:,2) = 0._wp
352	DO jk = 1, jpkm1
353	DO ji = 1, jpi
354	va_b(ji,2) = va_b(ji,2) + e3v_a(ji,2,jk) * va(ji,2,jk)
355	END DO
356	END DO
357	DO ji=1,jpi
358	va_b(ji,2) = va_b(ji,2) * r1_hv_a(ji,2)
359	END DO
360	ENDIF
361	!
362	DO jk = 1, jpkm1 ! Smooth
363	DO ji = i1, i2
364	va(ji,2,jk) = 0.25_wp * vmask(ji,2,jk) &
365	& * ( va(ji,1,jk) + 2._wp*va(ji,2,jk) + va(ji,3,jk) )
366	END DO
367	END DO
368	!
369	zvb(:,2) = 0._wp ! Correct transport
370	DO jk=1,jpkm1
371	DO ji=1,jpi
372	zvb(ji,2) = zvb(ji,2) + e3v_a(ji,2,jk) * va(ji,2,jk) * vmask(ji,2,jk)
373	END DO
374	END DO
375	DO ji = 1, jpi
376	zvb(ji,2) = zvb(ji,2) * r1_hv_a(ji,2)
377	END DO
378	DO jk = 1, jpkm1
379	DO ji = 1, jpi
380	va(ji,2,jk) = ( va(ji,2,jk) + va_b(ji,2) - zvb(ji,2) ) * vmask(ji,2,jk)
381	END DO
382	END DO
383
384	! Set tangential velocities to time splitting estimate
385	!-----------------------------------------------------
386	IF( ln_dynspg_ts ) THEN
387	zub(:,2) = 0._wp
388	DO jk = 1, jpkm1
389	DO ji = 1, jpi
390	zub(ji,2) = zub(ji,2) + e3u_a(ji,2,jk) * ua(ji,2,jk) * umask(ji,2,jk)
391	END DO
392	END DO
393	DO ji = 1, jpi
394	zub(ji,2) = zub(ji,2) * r1_hu_a(ji,2)
395	END DO
396
397	DO jk = 1, jpkm1
398	DO ji = 1, jpi
399	ua(ji,2,jk) = ( ua(ji,2,jk) + ua_b(ji,2) - zub(ji,2) ) * umask(ji,2,jk)
400	END DO
401	END DO
402	ENDIF
403
404	! Mask domain edges:
405	!-------------------
406	DO jk = 1, jpkm1
407	DO ji = 1, jpi
408	ua(ji,1,jk) = 0._wp
409	va(ji,1,jk) = 0._wp
410	END DO
411	END DO
412
413	ENDIF
414
415	IF( nbondj == 1 .OR. nbondj == 2 ) THEN
416	!
417	! Smoothing
418	! ---------
419	IF( .NOT.ln_dynspg_ts ) THEN ! Store transport
420	va_b(:,nlcj-2) = 0._wp
421	DO jk = 1, jpkm1
422	DO ji = 1, jpi
423	va_b(ji,nlcj-2) = va_b(ji,nlcj-2) + e3v_a(ji,nlcj-2,jk) * va(ji,nlcj-2,jk)
424	END DO
425	END DO
426	DO ji = 1, jpi
427	va_b(ji,nlcj-2) = va_b(ji,nlcj-2) * r1_hv_a(ji,nlcj-2)
428	END DO
429	ENDIF
430	!
431	DO jk = 1, jpkm1 ! Smooth
432	DO ji = i1, i2
433	va(ji,nlcj-2,jk) = 0.25_wp * vmask(ji,nlcj-2,jk) &
434	& * ( va(ji,nlcj-3,jk) + 2._wp * va(ji,nlcj-2,jk) + va(ji,nlcj-1,jk) )
435	END DO
436	END DO
437	!
438	zvb(:,nlcj-2) = 0._wp ! Correct transport
439	DO jk = 1, jpkm1
440	DO ji = 1, jpi
441	zvb(ji,nlcj-2) = zvb(ji,nlcj-2) + e3v_a(ji,nlcj-2,jk) * va(ji,nlcj-2,jk) * vmask(ji,nlcj-2,jk)
442	END DO
443	END DO
444	DO ji = 1, jpi
445	zvb(ji,nlcj-2) = zvb(ji,nlcj-2) * r1_hv_a(ji,nlcj-2)
446	END DO
447	DO jk = 1, jpkm1
448	DO ji = 1, jpi
449	va(ji,nlcj-2,jk) = ( va(ji,nlcj-2,jk) + va_b(ji,nlcj-2) - zvb(ji,nlcj-2) ) * vmask(ji,nlcj-2,jk)
450	END DO
451	END DO
452	!
453	! Set tangential velocities to time splitting estimate
454	!-----------------------------------------------------
455	IF( ln_dynspg_ts ) THEN
456	zub(:,nlcj-1) = 0._wp
457	DO jk = 1, jpkm1
458	DO ji = 1, jpi
459	zub(ji,nlcj-1) = zub(ji,nlcj-1) + e3u_a(ji,nlcj-1,jk) * ua(ji,nlcj-1,jk) * umask(ji,nlcj-1,jk)
460	END DO
461	END DO
462	DO ji = 1, jpi
463	zub(ji,nlcj-1) = zub(ji,nlcj-1) * r1_hu_a(ji,nlcj-1)
464	END DO
465	!
466	DO jk = 1, jpkm1
467	DO ji = 1, jpi
468	ua(ji,nlcj-1,jk) = ( ua(ji,nlcj-1,jk) + ua_b(ji,nlcj-1) - zub(ji,nlcj-1) ) * umask(ji,nlcj-1,jk)
469	END DO
470	END DO
471	ENDIF
472	!
473	! Mask domain edges:
474	!-------------------
475	DO jk = 1, jpkm1
476	DO ji = 1, jpi
477	ua(ji,nlcj ,jk) = 0._wp
478	va(ji,nlcj-1,jk) = 0._wp
479	END DO
480	END DO
481	!
482	ENDIF
483	!
484	CALL wrk_dealloc( jpi,jpj, zub, zvb )
485	!
486	END SUBROUTINE Agrif_dyn
487
488
489	SUBROUTINE Agrif_dyn_ts( jn )
490	!!----------------------------------------------------------------------
491	!! * ROUTINE Agrif_dyn_ts *
492	!!----------------------------------------------------------------------
493	!!
494	INTEGER, INTENT(in) :: jn
495	!!
496	INTEGER :: ji, jj
497	!!----------------------------------------------------------------------
498	!
499	IF( Agrif_Root() ) RETURN
500	!
501	IF((nbondi == -1).OR.(nbondi == 2)) THEN
502	DO jj=1,jpj
503	va_e(2,jj) = vbdy_w(jj) * hvr_e(2,jj)
504	! Specified fluxes:
505	ua_e(2,jj) = ubdy_w(jj) * hur_e(2,jj)
506	! Characteristics method:
507	!alt ua_e(2,jj) = 0.5_wp * ( ubdy_w(jj) * hur_e(2,jj) + ua_e(3,jj) &
508	!alt & - sqrt(grav * hur_e(2,jj)) * (sshn_e(3,jj) - hbdy_w(jj)) )
509	END DO
510	ENDIF
511	!
512	IF((nbondi == 1).OR.(nbondi == 2)) THEN
513	DO jj=1,jpj
514	va_e(nlci-1,jj) = vbdy_e(jj) * hvr_e(nlci-1,jj)
515	! Specified fluxes:
516	ua_e(nlci-2,jj) = ubdy_e(jj) * hur_e(nlci-2,jj)
517	! Characteristics method:
518	!alt ua_e(nlci-2,jj) = 0.5_wp * ( ubdy_e(jj) * hur_e(nlci-2,jj) + ua_e(nlci-3,jj) &
519	!alt & + sqrt(grav * hur_e(nlci-2,jj)) * (sshn_e(nlci-2,jj) - hbdy_e(jj)) )
520	END DO
521	ENDIF
522	!
523	IF((nbondj == -1).OR.(nbondj == 2)) THEN
524	DO ji=1,jpi
525	ua_e(ji,2) = ubdy_s(ji) * hur_e(ji,2)
526	! Specified fluxes:
527	va_e(ji,2) = vbdy_s(ji) * hvr_e(ji,2)
528	! Characteristics method:
529	!alt va_e(ji,2) = 0.5_wp * ( vbdy_s(ji) * hvr_e(ji,2) + va_e(ji,3) &
530	!alt & - sqrt(grav * hvr_e(ji,2)) * (sshn_e(ji,3) - hbdy_s(ji)) )
531	END DO
532	ENDIF
533	!
534	IF((nbondj == 1).OR.(nbondj == 2)) THEN
535	DO ji=1,jpi
536	ua_e(ji,nlcj-1) = ubdy_n(ji) * hur_e(ji,nlcj-1)
537	! Specified fluxes:
538	va_e(ji,nlcj-2) = vbdy_n(ji) * hvr_e(ji,nlcj-2)
539	! Characteristics method:
540	!alt va_e(ji,nlcj-2) = 0.5_wp * ( vbdy_n(ji) * hvr_e(ji,nlcj-2) + va_e(ji,nlcj-3) &
541	!alt & + sqrt(grav * hvr_e(ji,nlcj-2)) * (sshn_e(ji,nlcj-2) - hbdy_n(ji)) )
542	END DO
543	ENDIF
544	!
545	END SUBROUTINE Agrif_dyn_ts
546
547
548	SUBROUTINE Agrif_dta_ts( kt )
549	!!----------------------------------------------------------------------
550	!! * ROUTINE Agrif_dta_ts *
551	!!----------------------------------------------------------------------
552	!!
553	INTEGER, INTENT(in) :: kt
554	!!
555	INTEGER :: ji, jj
556	LOGICAL :: ll_int_cons
557	REAL(wp) :: zrhot, zt
558	!!----------------------------------------------------------------------
559	!
560	IF( Agrif_Root() ) RETURN
561	!
562	ll_int_cons = ln_bt_fw ! Assume conservative temporal integration in the forward case only
563	!
564	zrhot = Agrif_rhot()
565	!
566	! "Central" time index for interpolation:
567	IF( ln_bt_fw ) THEN
568	zt = REAL( Agrif_NbStepint()+0.5_wp, wp ) / zrhot
569	ELSE
570	zt = REAL( Agrif_NbStepint() , wp ) / zrhot
571	ENDIF
572	!
573	! Linear interpolation of sea level
574	Agrif_SpecialValue = 0._wp
575	Agrif_UseSpecialValue = .TRUE.
576	CALL Agrif_Bc_variable( sshn_id, calledweight=zt, procname=interpsshn )
577	Agrif_UseSpecialValue = .FALSE.
578	!
579	! Interpolate barotropic fluxes
580	Agrif_SpecialValue=0.
581	Agrif_UseSpecialValue = ln_spc_dyn
582	!
583	IF( ll_int_cons ) THEN ! Conservative interpolation
584	! orders matters here !!!!!!
585	CALL Agrif_Bc_variable( ub2b_interp_id, calledweight=1._wp, procname=interpub2b ) ! Time integrated
586	CALL Agrif_Bc_variable( vb2b_interp_id, calledweight=1._wp, procname=interpvb2b )
587	bdy_tinterp = 1
588	CALL Agrif_Bc_variable( unb_id , calledweight=1._wp, procname=interpunb ) ! After
589	CALL Agrif_Bc_variable( vnb_id , calledweight=1._wp, procname=interpvnb )
590	bdy_tinterp = 2
591	CALL Agrif_Bc_variable( unb_id , calledweight=0._wp, procname=interpunb ) ! Before
592	CALL Agrif_Bc_variable( vnb_id , calledweight=0._wp, procname=interpvnb )
593	ELSE ! Linear interpolation
594	bdy_tinterp = 0
595	ubdy_w(:) = 0._wp ; vbdy_w(:) = 0._wp
596	ubdy_e(:) = 0._wp ; vbdy_e(:) = 0._wp
597	ubdy_n(:) = 0._wp ; vbdy_n(:) = 0._wp
598	ubdy_s(:) = 0._wp ; vbdy_s(:) = 0._wp
599	CALL Agrif_Bc_variable( unb_id, calledweight=zt, procname=interpunb )
600	CALL Agrif_Bc_variable( vnb_id, calledweight=zt, procname=interpvnb )
601	ENDIF
602	Agrif_UseSpecialValue = .FALSE.
603	!
604	END SUBROUTINE Agrif_dta_ts
605
606
607	SUBROUTINE Agrif_ssh( kt )
608	!!----------------------------------------------------------------------
609	!! * ROUTINE Agrif_DYN *
610	!!----------------------------------------------------------------------
611	INTEGER, INTENT(in) :: kt
612	!!
613	!!----------------------------------------------------------------------
614	!
615	IF( Agrif_Root() ) RETURN
616	!
617	IF((nbondi == -1).OR.(nbondi == 2)) THEN
618	ssha(2,:)=ssha(3,:)
619	sshn(2,:)=sshn(3,:)
620	ENDIF
621	!
622	IF((nbondi == 1).OR.(nbondi == 2)) THEN
623	ssha(nlci-1,:)=ssha(nlci-2,:)
624	sshn(nlci-1,:)=sshn(nlci-2,:)
625	ENDIF
626	!
627	IF((nbondj == -1).OR.(nbondj == 2)) THEN
628	ssha(:,2)=ssha(:,3)
629	sshn(:,2)=sshn(:,3)
630	ENDIF
631	!
632	IF((nbondj == 1).OR.(nbondj == 2)) THEN
633	ssha(:,nlcj-1)=ssha(:,nlcj-2)
634	sshn(:,nlcj-1)=sshn(:,nlcj-2)
635	ENDIF
636	!
637	END SUBROUTINE Agrif_ssh
638
639
640	SUBROUTINE Agrif_ssh_ts( jn )
641	!!----------------------------------------------------------------------
642	!! * ROUTINE Agrif_ssh_ts *
643	!!----------------------------------------------------------------------
644	INTEGER, INTENT(in) :: jn
645	!!
646	INTEGER :: ji,jj
647	!!----------------------------------------------------------------------
648	!
649	IF((nbondi == -1).OR.(nbondi == 2)) THEN
650	DO jj = 1, jpj
651	ssha_e(2,jj) = hbdy_w(jj)
652	END DO
653	ENDIF
654	!
655	IF((nbondi == 1).OR.(nbondi == 2)) THEN
656	DO jj = 1, jpj
657	ssha_e(nlci-1,jj) = hbdy_e(jj)
658	END DO
659	ENDIF
660	!
661	IF((nbondj == -1).OR.(nbondj == 2)) THEN
662	DO ji = 1, jpi
663	ssha_e(ji,2) = hbdy_s(ji)
664	END DO
665	ENDIF
666	!
667	IF((nbondj == 1).OR.(nbondj == 2)) THEN
668	DO ji = 1, jpi
669	ssha_e(ji,nlcj-1) = hbdy_n(ji)
670	END DO
671	ENDIF
672	!
673	END SUBROUTINE Agrif_ssh_ts
674
675	# if defined key_zdftke
676
677	SUBROUTINE Agrif_tke
678	!!----------------------------------------------------------------------
679	!! * ROUTINE Agrif_tke *
680	!!----------------------------------------------------------------------
681	REAL(wp) :: zalpha
682	!!----------------------------------------------------------------------
683	!
684	return
685
686	zalpha = REAL( Agrif_NbStepint() + Agrif_IRhot() - 1, wp ) / REAL( Agrif_IRhot(), wp )
687	IF( zalpha > 1. ) zalpha = 1.
688	!
689	Agrif_SpecialValue = 0.e0
690	Agrif_UseSpecialValue = .TRUE.
691	!
692	CALL Agrif_Bc_variable(avm_id ,calledweight=zalpha, procname=interpavm)
693	!
694	Agrif_UseSpecialValue = .FALSE.
695	!
696	END SUBROUTINE Agrif_tke
697
698	# endif
699
700	SUBROUTINE interptsn( ptab, i1, i2, j1, j2, k1, k2, n1, n2, before, nb, ndir )
701	!!----------------------------------------------------------------------
702	!! * ROUTINE interptsn *
703	!!----------------------------------------------------------------------
704	REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: ptab
705	INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, n1, n2
706	LOGICAL , INTENT(in ) :: before
707	INTEGER , INTENT(in ) :: nb , ndir
708	!
709	INTEGER :: ji, jj, jk, jn ! dummy loop indices
710	INTEGER :: imin, imax, jmin, jmax
711	REAL(wp) :: zrhox , zalpha1, zalpha2, zalpha3
712	REAL(wp) :: zalpha4, zalpha5, zalpha6, zalpha7
713	LOGICAL :: western_side, eastern_side,northern_side,southern_side
714	! VERTICAL REFINEMENT BEGIN
715	REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk,n1:n2) :: ptab_child
716	REAL(wp), DIMENSION(k1:k2,n1:n2-1) :: tabin
717	REAL(wp) :: h_in(k1:k2)
718	REAL(wp) :: h_out(1:jpk)
719	INTEGER :: N_in, N_out
720	REAL(wp) :: h_diff
721	REAL(wp) :: zrhoxy
722	! VERTICAL REFINEMENT END
723
724	zrhoxy = Agrif_rhox()*Agrif_rhoy()
725	IF (before) THEN
726	DO jn = n1,n2-1
727	DO jk=k1,k2
728	DO jj=j1,j2
729	DO ji=i1,i2
730	ptab(ji,jj,jk,jn) = tsn(ji,jj,jk,jn) * e1e2t(ji,jj) * e3t_n(ji,jj,jk)
731	END DO
732	END DO
733	END DO
734	END DO
735	DO jk=k1,k2
736	DO jj=j1,j2
737	DO ji=i1,i2
738	ptab(ji,jj,jk,n2) = tmask(ji,jj,jk) * e1e2t(ji,jj) * e3t_n(ji,jj,jk)
739	END DO
740	END DO
741	END DO
742
743	ELSE
744	! VERTICAL REFINEMENT BEGIN
745
746	ptab_child(:,:,:,:) = 0.
747	do jj=j1,j2
748	do ji=i1,i2
749	N_in = 0
750	DO jk=k1,k2 !k2 = jpk of parent grid
751	IF (ptab(ji,jj,jk,n2) == 0) EXIT
752	N_in = N_in + 1
753	tabin(jk,:) = ptab(ji,jj,jk,n1:n2-1)/ptab(ji,jj,jk,n2)
754	h_in(N_in) = ptab(ji,jj,jk,n2)/(e1e2t(ji,jj)*zrhoxy)
755	END DO
756	N_out = 0
757	DO jk=1,jpk ! jpk of child grid
758	IF (tmask(ji,jj,jk) == 0) EXIT ! TODO: Will not work with ISF. !This doesn't seem to work at the moment in GYRE but is OK in overflow model
759	N_out = N_out + 1
760	h_out(jk) = e3t_n(ji,jj,jk) !Child grid scale factors. Could multiply by e1e2t here instead of division above
761	ENDDO
762	IF (N_in > 0) THEN
763	h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in))
764	! if (h_diff > 0) then
765	! h_in(N_in+1) = h_diff
766	! N_in = N_in + 1
767	! else
768	! h_out(N_out+1) = -h_diff
769	! N_out = N_out + 1
770	! endif
771	ptab(ji,jj,k2,:) = ptab(ji,jj,k2-1,:) !what is this line for?????
772	do jn=1,jpts
773	call reconstructandremap(tabin(1:N_in,jn),h_in,ptab_child(ji,jj,1:N_out,jn),h_out,N_in,N_out)
774	enddo
775	! if (abs(h_diff) > 1000.) then
776	! do jn=1,jpts
777	! do jk=1,N_out
778	! print *,'AVANT APRES = ',ji,jj,jk,N_out,ptab(ji,jj,jk,jn),ptab_child(ji,jj,jk,jn)
779	! enddo
780	! enddo
781	! endif
782	ENDIF
783	enddo
784	enddo
785
786
787	! VERTICAL REFINEMENT END
788
789	!
790	western_side = (nb == 1).AND.(ndir == 1)
791	eastern_side = (nb == 1).AND.(ndir == 2)
792	southern_side = (nb == 2).AND.(ndir == 1)
793	northern_side = (nb == 2).AND.(ndir == 2)
794	!
795	zrhox = Agrif_Rhox()
796	!
797	zalpha1 = ( zrhox - 1. ) * 0.5
798	zalpha2 = 1. - zalpha1
799	!
800	zalpha3 = ( zrhox - 1. ) / ( zrhox + 1. )
801	zalpha4 = 1. - zalpha3
802	!
803	zalpha6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. )
804	zalpha7 = - ( zrhox - 1. ) / ( zrhox + 3. )
805	zalpha5 = 1. - zalpha6 - zalpha7
806	!
807	imin = i1
808	imax = i2
809	jmin = j1
810	jmax = j2
811	!
812	! Remove CORNERS
813	IF((nbondj == -1).OR.(nbondj == 2)) jmin = 3
814	IF((nbondj == +1).OR.(nbondj == 2)) jmax = nlcj-2
815	IF((nbondi == -1).OR.(nbondi == 2)) imin = 3
816	IF((nbondi == +1).OR.(nbondi == 2)) imax = nlci-2
817	!
818	! VERTICAL REFINEMENT BEGIN
819
820	! WARNING :
821	! ptab replaced by ptab_child in the following
822	! k1 k2 replaced by 1 jpk
823	! VERTICAL REFINEMENT END
824	IF( eastern_side) THEN
825	DO jn = 1, jpts
826	tsa(nlci,j1:j2,1:jpk,jn) = zalpha1 * ptab_child(nlci,j1:j2,1:jpk,jn) + zalpha2 * ptab_child(nlci-1,j1:j2,1:jpk,jn)
827	DO jk = 1, jpkm1
828	DO jj = jmin,jmax
829	IF( umask(nlci-2,jj,jk) == 0._wp ) THEN
830	tsa(nlci-1,jj,jk,jn) = tsa(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk)
831	ELSE
832	tsa(nlci-1,jj,jk,jn)=(zalpha4tsa(nlci,jj,jk,jn)+zalpha3tsa(nlci-2,jj,jk,jn))*tmask(nlci-1,jj,jk)
833	IF( un(nlci-2,jj,jk) > 0._wp ) THEN
834	tsa(nlci-1,jj,jk,jn)=( zalpha6tsa(nlci-2,jj,jk,jn)+zalpha5tsa(nlci,jj,jk,jn) &
835	+ zalpha7tsa(nlci-3,jj,jk,jn) ) tmask(nlci-1,jj,jk)
836	ENDIF
837	ENDIF
838	END DO
839	END DO
840	tsa(nlci,j1:j2,k1:k2,jn) = 0._wp
841	END DO
842	ENDIF
843	!
844	IF( northern_side ) THEN
845	DO jn = 1, jpts
846	tsa(i1:i2,nlcj,1:jpk,jn) = zalpha1 * ptab_child(i1:i2,nlcj,1:jpk,jn) + zalpha2 * ptab_child(i1:i2,nlcj-1,1:jpk,jn)
847	DO jk = 1, jpkm1
848	DO ji = imin,imax
849	IF( vmask(ji,nlcj-2,jk) == 0._wp ) THEN
850	tsa(ji,nlcj-1,jk,jn) = tsa(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk)
851	ELSE
852	tsa(ji,nlcj-1,jk,jn)=(zalpha4tsa(ji,nlcj,jk,jn)+zalpha3tsa(ji,nlcj-2,jk,jn))*tmask(ji,nlcj-1,jk)
853	IF (vn(ji,nlcj-2,jk) > 0._wp ) THEN
854	tsa(ji,nlcj-1,jk,jn)=( zalpha6tsa(ji,nlcj-2,jk,jn)+zalpha5tsa(ji,nlcj,jk,jn) &
855	+ zalpha7tsa(ji,nlcj-3,jk,jn) ) tmask(ji,nlcj-1,jk)
856	ENDIF
857	ENDIF
858	END DO
859	END DO
860	tsa(i1:i2,nlcj,k1:k2,jn) = 0._wp
861	END DO
862	ENDIF
863	!
864	IF( western_side ) THEN
865	DO jn = 1, jpts
866	tsa(1,j1:j2,1:jpk,jn) = zalpha1 * ptab_child(1,j1:j2,1:jpk,jn) + zalpha2 * ptab_child(2,j1:j2,1:jpk,jn)
867	DO jk = 1, jpkm1
868	DO jj = jmin,jmax
869	IF( umask(2,jj,jk) == 0._wp ) THEN
870	tsa(2,jj,jk,jn) = tsa(1,jj,jk,jn) * tmask(2,jj,jk)
871	ELSE
872	tsa(2,jj,jk,jn)=(zalpha4tsa(1,jj,jk,jn)+zalpha3tsa(3,jj,jk,jn))*tmask(2,jj,jk)
873	IF( un(2,jj,jk) < 0._wp ) THEN
874	tsa(2,jj,jk,jn)=(zalpha6tsa(3,jj,jk,jn)+zalpha5tsa(1,jj,jk,jn)+zalpha7tsa(4,jj,jk,jn))tmask(2,jj,jk)
875	ENDIF
876	ENDIF
877	END DO
878	END DO
879	tsa(1,j1:j2,k1:k2,jn) = 0._wp
880	END DO
881	ENDIF
882	!
883	IF( southern_side ) THEN
884	DO jn = 1, jpts
885	tsa(i1:i2,1,1:jpk,jn) = zalpha1 * ptab_child(i1:i2,1,1:jpk,jn) + zalpha2 * ptab_child(i1:i2,2,1:jpk,jn)
886	DO jk = 1, jpk
887	DO ji=imin,imax
888	IF( vmask(ji,2,jk) == 0._wp ) THEN
889	tsa(ji,2,jk,jn)=tsa(ji,1,jk,jn) * tmask(ji,2,jk)
890	ELSE
891	tsa(ji,2,jk,jn)=(zalpha4tsa(ji,1,jk,jn)+zalpha3tsa(ji,3,jk,jn))*tmask(ji,2,jk)
892	IF( vn(ji,2,jk) < 0._wp ) THEN
893	tsa(ji,2,jk,jn)=(zalpha6tsa(ji,3,jk,jn)+zalpha5tsa(ji,1,jk,jn)+zalpha7tsa(ji,4,jk,jn))tmask(ji,2,jk)
894	ENDIF
895	ENDIF
896	END DO
897	END DO
898	tsa(i1:i2,1,k1:k2,jn) = 0._wp
899	END DO
900	ENDIF
901	!
902	! Treatment of corners
903	!
904	! East south
905	IF ((eastern_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN
906	tsa(nlci-1,2,:,:) = ptab_child(nlci-1,2,:,1:jpts)
907	ENDIF
908	! East north
909	IF ((eastern_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN
910	tsa(nlci-1,nlcj-1,:,:) = ptab_child(nlci-1,nlcj-1,:,1:jpts)
911	ENDIF
912	! West south
913	IF ((western_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN
914	tsa(2,2,:,:) = ptab_child(2,2,:,1:jpts)
915	ENDIF
916	! West north
917	IF ((western_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN
918	tsa(2,nlcj-1,:,:) = ptab_child(2,nlcj-1,:,1:jpts)
919	ENDIF
920	!
921	ENDIF
922	!
923	END SUBROUTINE interptsn
924
925
926	SUBROUTINE interpsshn( ptab, i1, i2, j1, j2, before, nb, ndir )
927	!!----------------------------------------------------------------------
928	!! * ROUTINE interpsshn *
929	!!----------------------------------------------------------------------
930	INTEGER , INTENT(in ) :: i1, i2, j1, j2
931	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
932	LOGICAL , INTENT(in ) :: before
933	INTEGER , INTENT(in ) :: nb , ndir
934	!
935	LOGICAL :: western_side, eastern_side,northern_side,southern_side
936	!!----------------------------------------------------------------------
937	!
938	IF( before) THEN
939	ptab(i1:i2,j1:j2) = sshn(i1:i2,j1:j2)
940	ELSE
941	western_side = (nb == 1).AND.(ndir == 1)
942	eastern_side = (nb == 1).AND.(ndir == 2)
943	southern_side = (nb == 2).AND.(ndir == 1)
944	northern_side = (nb == 2).AND.(ndir == 2)
945	IF(western_side) hbdy_w(j1:j2) = ptab(i1,j1:j2) * tmask(i1,j1:j2,1)
946	IF(eastern_side) hbdy_e(j1:j2) = ptab(i1,j1:j2) * tmask(i1,j1:j2,1)
947	IF(southern_side) hbdy_s(i1:i2) = ptab(i1:i2,j1) * tmask(i1:i2,j1,1)
948	IF(northern_side) hbdy_n(i1:i2) = ptab(i1:i2,j1) * tmask(i1:i2,j1,1)
949	ENDIF
950	!
951	END SUBROUTINE interpsshn
952
953	SUBROUTINE interpun(ptab,i1,i2,j1,j2,k1,k2,m1,m2,before,nb,ndir)
954	!!---------------------------------------------
955	!! * ROUTINE interpun *
956	!!---------------------------------------------
957	!!
958	INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,m1,m2
959	REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,m1:m2), INTENT(inout) :: ptab
960	LOGICAL, INTENT(in) :: before
961	INTEGER, INTENT(in) :: nb , ndir
962	!!
963	INTEGER :: ji,jj,jk
964	REAL(wp) :: zrhoy
965	! VERTICAL REFINEMENT BEGIN
966	REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: ptab_child
967	REAL(wp), DIMENSION(k1:k2) :: tabin
968	REAL(wp) :: h_in(k1:k2)
969	REAL(wp) :: h_out(1:jpk)
970	INTEGER :: N_in, N_out
971	REAL(wp) :: h_diff
972	LOGICAL :: western_side, eastern_side
973	INTEGER :: iref
974
975	! VERTICAL REFINEMENT END
976	!!---------------------------------------------
977	!
978	zrhoy = Agrif_rhoy()
979	IF (before) THEN
980	!We can't use zero as the special value because we need to include zeros
981	!when interpolating the scale factors
982	IF(Agrif_UseSpecialValue) THEN
983	Agrif_SpecialValue = -999._wp
984	ELSE
985	Agrif_SpecialValue = 0._wp
986	ENDIF
987	DO jk=1,jpk
988	DO jj=j1,j2
989	DO ji=i1,i2
990	ptab(ji,jj,jk,1) = (e2u(ji,jj) * e3u_n(ji,jj,jk) * un(ji,jj,jk)*umask(ji,jj,jk)) - &
991	& ((umask(ji,jj,jk)-1) * Agrif_SpecialValue)
992	ptab(ji,jj,jk,2) = (umask(ji,jj,jk) * e2u(ji,jj) * e3u_n(ji,jj,jk))
993	END DO
994	END DO
995	END DO
996	ELSE
997	! VERTICAL REFINEMENT BEGIN
998	western_side = (nb == 1).AND.(ndir == 1)
999	eastern_side = (nb == 1).AND.(ndir == 2)
1000
1001	Agrif_SpecialValue = 0._wp ! reset specialvalue to zero now interpolation completed
1002
1003	ptab_child(:,:,:) = 0.
1004	DO jj=j1,j2
1005	DO ji=i1,i2
1006	iref = ji
1007	IF (western_side) iref = 2
1008	IF (eastern_side) iref = nlci-2
1009
1010	N_in = 0
1011	DO jk=k1,k2
1012	IF (ptab(ji,jj,jk,2) == 0) EXIT
1013	N_in = N_in + 1
1014	tabin(jk) = ptab(ji,jj,jk,1)/ptab(ji,jj,jk,2)
1015	h_in(N_in) = ptab(ji,jj,jk,2)/(e2u(ji,jj) * zrhoy)
1016	ENDDO
1017
1018	IF (N_in == 0) THEN
1019	ptab_child(ji,jj,:) = 0.
1020	CYCLE
1021	ENDIF
1022
1023	N_out = 0
1024	DO jk=1,jpk
1025	if (umask(ji,jj,jk) == 0) EXIT
1026	N_out = N_out + 1
1027	h_out(N_out) = e3u_n(ji,jj,jk)
1028	ENDDO
1029
1030	IF (N_out == 0) THEN
1031	ptab_child(ji,jj,:) = 0.
1032	CYCLE
1033	ENDIF
1034
1035	! IF (N_in * N_out > 0) THEN
1036	! h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in))
1037	! Should be able to remove the next IF/ELSEIF statement once scale factors are dealt with properly
1038	! if (h_diff < 0.) then
1039	! print *,'CHECK YOUR BATHY ...', h_diff, sum(h_out(1:N_out)), sum(h_in(1:N_in))
1040	! stop
1041	! endif
1042	! ENDIF
1043	call reconstructandremap(tabin(1:N_in),h_in(1:N_in),ptab_child(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out)
1044
1045	ENDDO
1046	ENDDO
1047
1048	! in the following
1049	! remove division of ua by fs e3u (already done) and also zrhoy and e2u
1050	! VERTICAL REFINEMENT END
1051
1052	DO jk = 1, jpkm1
1053	DO jj=j1,j2
1054	ua(i1:i2,jj,jk) = ptab_child(i1:i2,jj,jk)
1055	!/(zrhoy*e2u(i1:i2,jj)))
1056	END DO
1057	END DO
1058	ENDIF
1059	!
1060	END SUBROUTINE interpun
1061
1062
1063
1064	SUBROUTINE interpvn(ptab,i1,i2,j1,j2,k1,k2,m1,m2,before,nb,ndir)
1065	!!---------------------------------------------
1066	!! * ROUTINE interpvn *
1067	!!----------------------------------------------------------------------
1068	!
1069	INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,m1,m2
1070	REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,m1:m2), INTENT(inout) :: ptab
1071	LOGICAL, INTENT(in) :: before
1072	INTEGER, INTENT(in) :: nb , ndir
1073	!
1074	INTEGER :: ji,jj,jk
1075	REAL(wp) :: zrhox
1076	! VERTICAL REFINEMENT BEGIN
1077	REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: ptab_child
1078	REAL(wp), DIMENSION(k1:k2) :: tabin
1079	REAL(wp) :: h_in(k1:k2)
1080	REAL(wp) :: h_out(1:jpk)
1081	INTEGER :: N_in, N_out
1082	REAL(wp) :: h_diff
1083	LOGICAL :: northern_side,southern_side
1084	INTEGER :: jref
1085
1086	! VERTICAL REFINEMENT END
1087	!!---------------------------------------------
1088	!
1089	zrhox = Agrif_rhox()
1090	IF (before) THEN
1091	IF(Agrif_UseSpecialValue) THEN
1092	Agrif_SpecialValue = -999._wp
1093	ELSE
1094	Agrif_SpecialValue = 0._wp
1095	ENDIF
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_n(ji,jj,jk) * vn(ji,jj,jk)
1100	ptab(ji,jj,jk,2) = vmask(ji,jj,jk) * e1v(ji,jj) * e3v_n(ji,jj,jk)
1101	END DO
1102	END DO
1103	END DO
1104	ELSE
1105	! VERTICAL REFINEMENT BEGIN
1106	ptab_child(:,:,:) = 0.
1107	southern_side = (nb == 2).AND.(ndir == 1)
1108	northern_side = (nb == 2).AND.(ndir == 2)
1109
1110	Agrif_SpecialValue = 0._wp !Reset special value to zero now interpolation is done
1111
1112	do jj=j1,j2
1113	jref = jj
1114	IF (southern_side) jref = 2
1115	IF (northern_side) jref = nlcj-2
1116	do ji=i1,i2
1117
1118	N_in = 0
1119	do jk=k1,k2
1120	if (ptab(ji,jj,jk,2) == 0) EXIT
1121	N_in = N_in + 1
1122	tabin(jk) = ptab(ji,jj,jk,1)/ptab(ji,jj,jk,2)
1123	h_in(N_in) = ptab(ji,jj,jk,2)/(e1v(ji,jj)*zrhox)
1124	enddo
1125	IF (N_in == 0) THEN
1126	ptab_child(ji,jj,:) = 0.
1127	CYCLE
1128	ENDIF
1129
1130	N_out = 0
1131	do jk=1,jpk
1132	if (vmask(ji,jref,jk) == 0) EXIT
1133	N_out = N_out + 1
1134	h_out(N_out) = e3v_n(ji,jj,jk)
1135	enddo
1136	IF (N_out == 0) THEN
1137	ptab_child(ji,jj,:) = 0.
1138	CYCLE
1139	ENDIF
1140
1141	! IF (N_in * N_out > 0) THEN
1142	! h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in))
1143	! Should be able to remove the next IF/ELSEIF statement once scale factors are dealt with properly
1144	! if (h_diff < 0.) then
1145	! print *,'CHECK YOUR BATHY interpvn...', h_diff, sum(h_out(1:N_out)), sum(h_in(1:N_in))
1146	! stop
1147	! endif
1148	! ENDIF
1149	call reconstructandremap(tabin(1:N_in),h_in(1:N_in),ptab_child(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out)
1150
1151	enddo
1152	enddo
1153	! in the following
1154	! remove division of va by fs e3v, zrhox and e1v (already done)
1155	! VERTICAL REFINEMENT END
1156	DO jk=1,jpkm1
1157	DO jj=j1,j2
1158	va(i1:i2,jj,jk) = ptab_child(i1:i2,jj,jk)
1159	END DO
1160	END DO
1161	ENDIF
1162	!
1163	END SUBROUTINE interpvn
1164
1165
1166	SUBROUTINE interpunb( ptab, i1, i2, j1, j2, before, nb, ndir )
1167	!!----------------------------------------------------------------------
1168	!! * ROUTINE interpunb *
1169	!!----------------------------------------------------------------------
1170	INTEGER , INTENT(in ) :: i1, i2, j1, j2
1171	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
1172	LOGICAL , INTENT(in ) :: before
1173	INTEGER , INTENT(in ) :: nb , ndir
1174	!
1175	INTEGER :: ji, jj
1176	REAL(wp) :: zrhoy, zrhot, zt0, zt1, ztcoeff
1177	LOGICAL :: western_side, eastern_side,northern_side,southern_side
1178	!!----------------------------------------------------------------------
1179	!
1180	IF( before ) THEN
1181	ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * hu_n(i1:i2,j1:j2) * un_b(i1:i2,j1:j2)
1182	ELSE
1183	western_side = (nb == 1).AND.(ndir == 1)
1184	eastern_side = (nb == 1).AND.(ndir == 2)
1185	southern_side = (nb == 2).AND.(ndir == 1)
1186	northern_side = (nb == 2).AND.(ndir == 2)
1187	zrhoy = Agrif_Rhoy()
1188	zrhot = Agrif_rhot()
1189	! Time indexes bounds for integration
1190	zt0 = REAL(Agrif_NbStepint() , wp) / zrhot
1191	zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot
1192	! Polynomial interpolation coefficients:
1193	IF( bdy_tinterp == 1 ) THEN
1194	ztcoeff = zrhot * ( zt1*2._wp ( zt1 - 1._wp) &
1195	& - zt0*2._wp ( zt0 - 1._wp) )
1196	ELSEIF( bdy_tinterp == 2 ) THEN
1197	ztcoeff = zrhot * ( zt1 * ( zt1 - 1._wp)**2._wp &
1198	& - zt0 * ( zt0 - 1._wp)**2._wp )
1199
1200	ELSE
1201	ztcoeff = 1
1202	ENDIF
1203	!
1204	IF(western_side) THEN
1205	ubdy_w(j1:j2) = ubdy_w(j1:j2) + ztcoeff * ptab(i1,j1:j2)
1206	ENDIF
1207	IF(eastern_side) THEN
1208	ubdy_e(j1:j2) = ubdy_e(j1:j2) + ztcoeff * ptab(i1,j1:j2)
1209	ENDIF
1210	IF(southern_side) THEN
1211	ubdy_s(i1:i2) = ubdy_s(i1:i2) + ztcoeff * ptab(i1:i2,j1)
1212	ENDIF
1213	IF(northern_side) THEN
1214	ubdy_n(i1:i2) = ubdy_n(i1:i2) + ztcoeff * ptab(i1:i2,j1)
1215	ENDIF
1216	!
1217	IF( bdy_tinterp == 0 .OR. bdy_tinterp == 2) THEN
1218	IF(western_side) THEN
1219	ubdy_w(j1:j2) = ubdy_w(j1:j2) / (zrhoye2u(i1,j1:j2)) umask(i1,j1:j2,1)
1220	ENDIF
1221	IF(eastern_side) THEN
1222	ubdy_e(j1:j2) = ubdy_e(j1:j2) / (zrhoye2u(i1,j1:j2)) umask(i1,j1:j2,1)
1223	ENDIF
1224	IF(southern_side) THEN
1225	ubdy_s(i1:i2) = ubdy_s(i1:i2) / (zrhoye2u(i1:i2,j1)) umask(i1:i2,j1,1)
1226	ENDIF
1227	IF(northern_side) THEN
1228	ubdy_n(i1:i2) = ubdy_n(i1:i2) / (zrhoye2u(i1:i2,j1)) umask(i1:i2,j1,1)
1229	ENDIF
1230	ENDIF
1231	ENDIF
1232	!
1233	END SUBROUTINE interpunb
1234
1235
1236	SUBROUTINE interpvnb( ptab, i1, i2, j1, j2, before, nb, ndir )
1237	!!----------------------------------------------------------------------
1238	!! * ROUTINE interpvnb *
1239	!!----------------------------------------------------------------------
1240	INTEGER , INTENT(in ) :: i1, i2, j1, j2
1241	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
1242	LOGICAL , INTENT(in ) :: before
1243	INTEGER , INTENT(in ) :: nb , ndir
1244	!
1245	INTEGER :: ji,jj
1246	REAL(wp) :: zrhox, zrhot, zt0, zt1, ztcoeff
1247	LOGICAL :: western_side, eastern_side,northern_side,southern_side
1248	!!----------------------------------------------------------------------
1249	!
1250	IF( before ) THEN
1251	ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * hv_n(i1:i2,j1:j2) * vn_b(i1:i2,j1:j2)
1252	ELSE
1253	western_side = (nb == 1).AND.(ndir == 1)
1254	eastern_side = (nb == 1).AND.(ndir == 2)
1255	southern_side = (nb == 2).AND.(ndir == 1)
1256	northern_side = (nb == 2).AND.(ndir == 2)
1257	zrhox = Agrif_Rhox()
1258	zrhot = Agrif_rhot()
1259	! Time indexes bounds for integration
1260	zt0 = REAL(Agrif_NbStepint() , wp) / zrhot
1261	zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot
1262	IF( bdy_tinterp == 1 ) THEN
1263	ztcoeff = zrhot * ( zt1*2._wp ( zt1 - 1._wp) &
1264	& - zt0*2._wp ( zt0 - 1._wp) )
1265	ELSEIF( bdy_tinterp == 2 ) THEN
1266	ztcoeff = zrhot * ( zt1 * ( zt1 - 1._wp)**2._wp &
1267	& - zt0 * ( zt0 - 1._wp)**2._wp )
1268	ELSE
1269	ztcoeff = 1
1270	ENDIF
1271	!
1272	IF(western_side) THEN
1273	vbdy_w(j1:j2) = vbdy_w(j1:j2) + ztcoeff * ptab(i1,j1:j2)
1274	ENDIF
1275	IF(eastern_side) THEN
1276	vbdy_e(j1:j2) = vbdy_e(j1:j2) + ztcoeff * ptab(i1,j1:j2)
1277	ENDIF
1278	IF(southern_side) THEN
1279	vbdy_s(i1:i2) = vbdy_s(i1:i2) + ztcoeff * ptab(i1:i2,j1)
1280	ENDIF
1281	IF(northern_side) THEN
1282	vbdy_n(i1:i2) = vbdy_n(i1:i2) + ztcoeff * ptab(i1:i2,j1)
1283	ENDIF
1284	!
1285	IF( bdy_tinterp == 0 .OR. bdy_tinterp == 2) THEN
1286	IF(western_side) THEN
1287	vbdy_w(j1:j2) = vbdy_w(j1:j2) / (zrhox*e1v(i1,j1:j2)) &
1288	& * vmask(i1,j1:j2,1)
1289	ENDIF
1290	IF(eastern_side) THEN
1291	vbdy_e(j1:j2) = vbdy_e(j1:j2) / (zrhox*e1v(i1,j1:j2)) &
1292	& * vmask(i1,j1:j2,1)
1293	ENDIF
1294	IF(southern_side) THEN
1295	vbdy_s(i1:i2) = vbdy_s(i1:i2) / (zrhox*e1v(i1:i2,j1)) &
1296	& * vmask(i1:i2,j1,1)
1297	ENDIF
1298	IF(northern_side) THEN
1299	vbdy_n(i1:i2) = vbdy_n(i1:i2) / (zrhox*e1v(i1:i2,j1)) &
1300	& * vmask(i1:i2,j1,1)
1301	ENDIF
1302	ENDIF
1303	ENDIF
1304	!
1305	END SUBROUTINE interpvnb
1306
1307
1308	SUBROUTINE interpub2b( ptab, i1, i2, j1, j2, before, nb, ndir )
1309	!!----------------------------------------------------------------------
1310	!! * ROUTINE interpub2b *
1311	!!----------------------------------------------------------------------
1312	INTEGER , INTENT(in ) :: i1, i2, j1, j2
1313	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
1314	LOGICAL , INTENT(in ) :: before
1315	INTEGER , INTENT(in ) :: nb , ndir
1316	!
1317	INTEGER :: ji,jj
1318	REAL(wp) :: zrhot, zt0, zt1,zat
1319	LOGICAL :: western_side, eastern_side,northern_side,southern_side
1320	!!----------------------------------------------------------------------
1321	IF( before ) THEN
1322	ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * ub2_b(i1:i2,j1:j2)
1323	ELSE
1324	western_side = (nb == 1).AND.(ndir == 1)
1325	eastern_side = (nb == 1).AND.(ndir == 2)
1326	southern_side = (nb == 2).AND.(ndir == 1)
1327	northern_side = (nb == 2).AND.(ndir == 2)
1328	zrhot = Agrif_rhot()
1329	! Time indexes bounds for integration
1330	zt0 = REAL(Agrif_NbStepint() , wp) / zrhot
1331	zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot
1332	! Polynomial interpolation coefficients:
1333	zat = zrhot * ( zt1*2._wp (-2._wp*zt1 + 3._wp) &
1334	& - zt0*2._wp (-2._wp*zt0 + 3._wp) )
1335	!
1336	IF(western_side ) ubdy_w(j1:j2) = zat * ptab(i1,j1:j2)
1337	IF(eastern_side ) ubdy_e(j1:j2) = zat * ptab(i1,j1:j2)
1338	IF(southern_side) ubdy_s(i1:i2) = zat * ptab(i1:i2,j1)
1339	IF(northern_side) ubdy_n(i1:i2) = zat * ptab(i1:i2,j1)
1340	ENDIF
1341	!
1342	END SUBROUTINE interpub2b
1343
1344
1345	SUBROUTINE interpvb2b( ptab, i1, i2, j1, j2, before, nb, ndir )
1346	!!----------------------------------------------------------------------
1347	!! * ROUTINE interpvb2b *
1348	!!----------------------------------------------------------------------
1349	INTEGER , INTENT(in ) :: i1, i2, j1, j2
1350	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
1351	LOGICAL , INTENT(in ) :: before
1352	INTEGER , INTENT(in ) :: nb , ndir
1353	!
1354	INTEGER :: ji,jj
1355	REAL(wp) :: zrhot, zt0, zt1,zat
1356	LOGICAL :: western_side, eastern_side,northern_side,southern_side
1357	!!----------------------------------------------------------------------
1358	!
1359	IF( before ) THEN
1360	ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * vb2_b(i1:i2,j1:j2)
1361	ELSE
1362	western_side = (nb == 1).AND.(ndir == 1)
1363	eastern_side = (nb == 1).AND.(ndir == 2)
1364	southern_side = (nb == 2).AND.(ndir == 1)
1365	northern_side = (nb == 2).AND.(ndir == 2)
1366	zrhot = Agrif_rhot()
1367	! Time indexes bounds for integration
1368	zt0 = REAL(Agrif_NbStepint() , wp) / zrhot
1369	zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot
1370	! Polynomial interpolation coefficients:
1371	zat = zrhot * ( zt1*2._wp (-2._wp*zt1 + 3._wp) &
1372	& - zt0*2._wp (-2._wp*zt0 + 3._wp) )
1373	!
1374	IF(western_side ) vbdy_w(j1:j2) = zat * ptab(i1,j1:j2)
1375	IF(eastern_side ) vbdy_e(j1:j2) = zat * ptab(i1,j1:j2)
1376	IF(southern_side) vbdy_s(i1:i2) = zat * ptab(i1:i2,j1)
1377	IF(northern_side) vbdy_n(i1:i2) = zat * ptab(i1:i2,j1)
1378	ENDIF
1379	!
1380	END SUBROUTINE interpvb2b
1381
1382
1383	SUBROUTINE interpe3t( ptab, i1, i2, j1, j2, k1, k2, before, nb, ndir )
1384	!!----------------------------------------------------------------------
1385	!! * ROUTINE interpe3t *
1386	!!----------------------------------------------------------------------
1387	INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2
1388	REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab
1389	LOGICAL , INTENT(in ) :: before
1390	INTEGER , INTENT(in ) :: nb , ndir
1391	!
1392	INTEGER :: ji, jj, jk
1393	LOGICAL :: western_side, eastern_side, northern_side, southern_side
1394	REAL(wp) :: ztmpmsk
1395	!!----------------------------------------------------------------------
1396	!
1397	IF( before ) THEN
1398	ptab(i1:i2,j1:j2,k1:k2) = tmask(i1:i2,j1:j2,k1:k2) * e3t_0(i1:i2,j1:j2,k1:k2)
1399	ELSE
1400	western_side = (nb == 1).AND.(ndir == 1)
1401	eastern_side = (nb == 1).AND.(ndir == 2)
1402	southern_side = (nb == 2).AND.(ndir == 1)
1403	northern_side = (nb == 2).AND.(ndir == 2)
1404
1405	DO jk = k1, k2
1406	DO jj = j1, j2
1407	DO ji = i1, i2
1408	! Get velocity mask at boundary edge points:
1409	IF( western_side ) ztmpmsk = umask(ji ,jj ,1)
1410	IF( eastern_side ) ztmpmsk = umask(nlci-2,jj ,1)
1411	IF( northern_side) ztmpmsk = vmask(ji ,nlcj-2,1)
1412	IF( southern_side) ztmpmsk = vmask(ji ,2 ,1)
1413	!
1414	IF( ABS( ptab(ji,jj,jk) - tmask(ji,jj,jk) * e3t_0(ji,jj,jk) )*ztmpmsk > 1.D-2) THEN
1415	IF (western_side) THEN
1416	WRITE(numout,*) 'ERROR bathymetry merge at the western border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk
1417	ELSEIF (eastern_side) THEN
1418	WRITE(numout,*) 'ERROR bathymetry merge at the eastern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk
1419	ELSEIF (southern_side) THEN
1420	WRITE(numout,*) 'ERROR bathymetry merge at the southern border ji,jj,jk', ji+nimpp-1,jj+njmpp-1,jk
1421	ELSEIF (northern_side) THEN
1422	WRITE(numout,*) 'ERROR bathymetry merge at the northen border ji,jj,jk', ji+nimpp-1,jj+njmpp-1,jk
1423	ENDIF
1424	WRITE(numout,*) ' ptab(ji,jj,jk), e3t(ji,jj,jk) ', ptab(ji,jj,jk), e3t_0(ji,jj,jk)
1425	kindic_agr = kindic_agr + 1
1426	ENDIF
1427	END DO
1428	END DO
1429	END DO
1430	!
1431	ENDIF
1432	!
1433	END SUBROUTINE interpe3t
1434
1435
1436	SUBROUTINE interpumsk( ptab, i1, i2, j1, j2, k1, k2, before, nb, ndir )
1437	!!----------------------------------------------------------------------
1438	!! * ROUTINE interpumsk *
1439	!!----------------------------------------------------------------------
1440	INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2
1441	REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab
1442	LOGICAL , INTENT(in ) :: before
1443	INTEGER , INTENT(in ) :: nb , ndir
1444	!
1445	INTEGER :: ji, jj, jk
1446	LOGICAL :: western_side, eastern_side
1447	!!----------------------------------------------------------------------
1448	!
1449	IF( before ) THEN
1450	ptab(i1:i2,j1:j2,k1:k2) = umask(i1:i2,j1:j2,k1:k2)
1451	ELSE
1452	western_side = (nb == 1).AND.(ndir == 1)
1453	eastern_side = (nb == 1).AND.(ndir == 2)
1454	DO jk = k1, k2
1455	DO jj = j1, j2
1456	DO ji = i1, i2
1457	! Velocity mask at boundary edge points:
1458	IF (ABS(ptab(ji,jj,jk) - umask(ji,jj,jk)) > 1.D-2) THEN
1459	IF (western_side) THEN
1460	WRITE(numout,*) 'ERROR with umask at the western border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk
1461	WRITE(numout,*) ' masks: parent, child ', ptab(ji,jj,jk), umask(ji,jj,jk)
1462	kindic_agr = kindic_agr + 1
1463	ELSEIF (eastern_side) THEN
1464	WRITE(numout,*) 'ERROR with umask at the eastern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk
1465	WRITE(numout,*) ' masks: parent, child ', ptab(ji,jj,jk), umask(ji,jj,jk)
1466	kindic_agr = kindic_agr + 1
1467	ENDIF
1468	ENDIF
1469	END DO
1470	END DO
1471	END DO
1472	!
1473	ENDIF
1474	!
1475	END SUBROUTINE interpumsk
1476
1477
1478	SUBROUTINE interpvmsk( ptab, i1, i2, j1, j2, k1, k2, before, nb, ndir )
1479	!!----------------------------------------------------------------------
1480	!! * ROUTINE interpvmsk *
1481	!!----------------------------------------------------------------------
1482	INTEGER , INTENT(in ) :: i1,i2,j1,j2,k1,k2
1483	REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab
1484	LOGICAL , INTENT(in ) :: before
1485	INTEGER , INTENT(in ) :: nb , ndir
1486	!
1487	INTEGER :: ji, jj, jk
1488	LOGICAL :: northern_side, southern_side
1489	!!----------------------------------------------------------------------
1490	!
1491	IF( before ) THEN
1492	ptab(i1:i2,j1:j2,k1:k2) = vmask(i1:i2,j1:j2,k1:k2)
1493	ELSE
1494	southern_side = (nb == 2).AND.(ndir == 1)
1495	northern_side = (nb == 2).AND.(ndir == 2)
1496	DO jk = k1, k2
1497	DO jj = j1, j2
1498	DO ji = i1, i2
1499	! Velocity mask at boundary edge points:
1500	IF (ABS(ptab(ji,jj,jk) - vmask(ji,jj,jk)) > 1.D-2) THEN
1501	IF (southern_side) THEN
1502	WRITE(numout,*) 'ERROR with vmask at the southern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk
1503	WRITE(numout,*) ' masks: parent, child ', ptab(ji,jj,jk), vmask(ji,jj,jk)
1504	kindic_agr = kindic_agr + 1
1505	ELSEIF (northern_side) THEN
1506	WRITE(numout,*) 'ERROR with vmask at the northern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk
1507	WRITE(numout,*) ' masks: parent, child ', ptab(ji,jj,jk), vmask(ji,jj,jk)
1508	kindic_agr = kindic_agr + 1
1509	ENDIF
1510	ENDIF
1511	END DO
1512	END DO
1513	END DO
1514	!
1515	ENDIF
1516	!
1517	END SUBROUTINE interpvmsk
1518
1519	# if defined key_zdftke
1520
1521	SUBROUTINE interpavm( ptab, i1, i2, j1, j2, k1, k2, before )
1522	!!----------------------------------------------------------------------
1523	!! * ROUTINE interavm *
1524	!!----------------------------------------------------------------------
1525	INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2
1526	REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab
1527	LOGICAL , INTENT(in ) :: before
1528	!!----------------------------------------------------------------------
1529	!
1530	IF( before ) THEN
1531	ptab (i1:i2,j1:j2,k1:k2) = avm_k(i1:i2,j1:j2,k1:k2)
1532	ELSE
1533	avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2)
1534	ENDIF
1535	!
1536	END SUBROUTINE interpavm
1537
1538	# endif /* key_zdftke */
1539
1540	#else
1541	!!----------------------------------------------------------------------
1542	!! Empty module no AGRIF zoom
1543	!!----------------------------------------------------------------------
1544	CONTAINS
1545	SUBROUTINE Agrif_OPA_Interp_empty
1546	WRITE(,) 'agrif_opa_interp : You should not have seen this print! error?'
1547	END SUBROUTINE Agrif_OPA_Interp_empty
1548	#endif
1549
1550	!!======================================================================
1551	END MODULE agrif_opa_interp

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

Download in other formats: