Context Navigation

agrif_opa_interp.F90 @ 7646

Last change on this file since 7646 was 7646, checked in by timgraham, 8 years ago

Merge of dev_merge_2016 into trunk. UPDATE TO ARCHFILES NEEDED for XIOS2.
LIM_SRC_s/limrhg.F90 to follow in next commit due to change of kind (I'm unable to do it in this commit).
Merged using the following steps:

1) svn merge --reintegrate svn+ssh://forge.ipsl.jussieu.fr/ipsl/forge/projets/nemo/svn/trunk .
2) Resolve minor conflicts in sette.sh and namelist_cfg for ORCA2LIM3 (due to a change in trunk after branch was created)
3) svn commit
4) svn switch svn+ssh://forge.ipsl.jussieu.fr/ipsl/forge/projets/nemo/svn/trunk
5) svn merge svn+ssh://forge.ipsl.jussieu.fr/ipsl/forge/projets/nemo/svn/branches/2016/dev_merge_2016 .
6) At this stage I checked out a clean copy of the branch to compare against what is about to be committed to the trunk.
6) svn commit #Commit code to the trunk

In this commit I have also reverted a change to Fcheck_archfile.sh which was causing problems on the Paris machine.

Property svn:keywords set to Id

File size: 47.4 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
12	!!----------------------------------------------------------------------
13	!! 'key_agrif' AGRIF zoom
14	!!----------------------------------------------------------------------
15	!! Agrif_tra :
16	!! Agrif_dyn :
17	!! interpu :
18	!! interpv :
19	!!----------------------------------------------------------------------
20	USE par_oce
21	USE oce
22	USE dom_oce
23	USE zdf_oce
24	USE agrif_oce
25	USE phycst
26	!
27	USE in_out_manager
28	USE agrif_opa_sponge
29	USE lib_mpp
30	USE wrk_nemo
31
32	IMPLICIT NONE
33	PRIVATE
34
35	PUBLIC Agrif_tra, Agrif_dyn, Agrif_ssh, Agrif_dyn_ts, Agrif_ssh_ts, Agrif_dta_ts
36	PUBLIC interpun, interpvn
37	PUBLIC interptsn, interpsshn
38	PUBLIC interpunb, interpvnb, interpub2b, interpvb2b
39	PUBLIC interpe3t, interpumsk, interpvmsk
40	# if defined key_zdftke
41	PUBLIC Agrif_tke, interpavm
42	# endif
43
44	INTEGER :: bdy_tinterp = 0
45
46	# include "vectopt_loop_substitute.h90"
47	!!----------------------------------------------------------------------
48	!! NEMO/NST 3.7 , NEMO Consortium (2015)
49	!! $Id$
50	!! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
51	!!----------------------------------------------------------------------
52	CONTAINS
53
54	SUBROUTINE Agrif_tra
55	!!----------------------------------------------------------------------
56	!! * ROUTINE Agrif_tra *
57	!!----------------------------------------------------------------------
58	!
59	IF( Agrif_Root() ) RETURN
60	!
61	Agrif_SpecialValue = 0._wp
62	Agrif_UseSpecialValue = .TRUE.
63	!
64	CALL Agrif_Bc_variable( tsn_id, procname=interptsn )
65	!
66	Agrif_UseSpecialValue = .FALSE.
67	!
68	END SUBROUTINE Agrif_tra
69
70
71	SUBROUTINE Agrif_dyn( kt )
72	!!----------------------------------------------------------------------
73	!! * ROUTINE Agrif_DYN *
74	!!----------------------------------------------------------------------
75	INTEGER, INTENT(in) :: kt
76	!
77	INTEGER :: ji, jj, jk ! dummy loop indices
78	INTEGER :: j1, j2, i1, i2
79	REAL(wp), POINTER, DIMENSION(:,:) :: zub, zvb
80	!!----------------------------------------------------------------------
81	!
82	IF( Agrif_Root() ) RETURN
83	!
84	CALL wrk_alloc( jpi,jpj, zub, zvb )
85	!
86	Agrif_SpecialValue = 0._wp
87	Agrif_UseSpecialValue = ln_spc_dyn
88	!
89	CALL Agrif_Bc_variable( un_interp_id, procname=interpun )
90	CALL Agrif_Bc_variable( vn_interp_id, procname=interpvn )
91	!
92	Agrif_UseSpecialValue = .FALSE.
93	!
94	! prevent smoothing in ghost cells
95	i1 = 1 ; i2 = jpi
96	j1 = 1 ; j2 = jpj
97	IF( nbondj == -1 .OR. nbondj == 2 ) j1 = 3
98	IF( nbondj == +1 .OR. nbondj == 2 ) j2 = nlcj-2
99	IF( nbondi == -1 .OR. nbondi == 2 ) i1 = 3
100	IF( nbondi == +1 .OR. nbondi == 2 ) i2 = nlci-2
101
102	IF( nbondi == -1 .OR. nbondi == 2 ) THEN
103	!
104	! Smoothing
105	! ---------
106	IF( .NOT.ln_dynspg_ts ) THEN ! Store transport
107	ua_b(2,:) = 0._wp
108	DO jk = 1, jpkm1
109	DO jj = 1, jpj
110	ua_b(2,jj) = ua_b(2,jj) + e3u_a(2,jj,jk) * ua(2,jj,jk)
111	END DO
112	END DO
113	DO jj = 1, jpj
114	ua_b(2,jj) = ua_b(2,jj) * r1_hu_a(2,jj)
115	END DO
116	ENDIF
117	!
118	DO jk=1,jpkm1 ! Smooth
119	DO jj=j1,j2
120	ua(2,jj,jk) = 0.25_wp(ua(1,jj,jk)+2._wpua(2,jj,jk)+ua(3,jj,jk))
121	ua(2,jj,jk) = ua(2,jj,jk) * umask(2,jj,jk)
122	END DO
123	END DO
124	!
125	zub(2,:) = 0._wp ! Correct transport
126	DO jk = 1, jpkm1
127	DO jj = 1, jpj
128	zub(2,jj) = zub(2,jj) + e3u_a(2,jj,jk) * ua(2,jj,jk)
129	END DO
130	END DO
131	DO jj=1,jpj
132	zub(2,jj) = zub(2,jj) * r1_hu_a(2,jj)
133	END DO
134
135	DO jk=1,jpkm1
136	DO jj=1,jpj
137	ua(2,jj,jk) = (ua(2,jj,jk)+ua_b(2,jj)-zub(2,jj))*umask(2,jj,jk)
138	END DO
139	END DO
140
141	! Set tangential velocities to time splitting estimate
142	!-----------------------------------------------------
143	IF( ln_dynspg_ts ) THEN
144	zvb(2,:) = 0._wp
145	DO jk = 1, jpkm1
146	DO jj = 1, jpj
147	zvb(2,jj) = zvb(2,jj) + e3v_a(2,jj,jk) * va(2,jj,jk)
148	END DO
149	END DO
150	DO jj = 1, jpj
151	zvb(2,jj) = zvb(2,jj) * r1_hv_a(2,jj)
152	END DO
153	DO jk = 1, jpkm1
154	DO jj = 1, jpj
155	va(2,jj,jk) = (va(2,jj,jk)+va_b(2,jj)-zvb(2,jj)) * vmask(2,jj,jk)
156	END DO
157	END DO
158	ENDIF
159	!
160	! Mask domain edges:
161	!-------------------
162	DO jk = 1, jpkm1
163	DO jj = 1, jpj
164	ua(1,jj,jk) = 0._wp
165	va(1,jj,jk) = 0._wp
166	END DO
167	END DO
168	!
169	ENDIF
170
171	IF( nbondi == 1 .OR. nbondi == 2 ) THEN
172
173	! Smoothing
174	! ---------
175	IF( .NOT.ln_dynspg_ts ) THEN ! Store transport
176	ua_b(nlci-2,:) = 0._wp
177	DO jk=1,jpkm1
178	DO jj=1,jpj
179	ua_b(nlci-2,jj) = ua_b(nlci-2,jj) + e3u_a(nlci-2,jj,jk) * ua(nlci-2,jj,jk)
180	END DO
181	END DO
182	DO jj=1,jpj
183	ua_b(nlci-2,jj) = ua_b(nlci-2,jj) * r1_hu_a(nlci-2,jj)
184	END DO
185	ENDIF
186
187	DO jk = 1, jpkm1 ! Smooth
188	DO jj = j1, j2
189	ua(nlci-2,jj,jk) = 0.25_wp * umask(nlci-2,jj,jk) &
190	& * ( ua(nlci-3,jj,jk) + 2._wp*ua(nlci-2,jj,jk) + ua(nlci-1,jj,jk) )
191	END DO
192	END DO
193
194	zub(nlci-2,:) = 0._wp ! Correct transport
195	DO jk = 1, jpkm1
196	DO jj = 1, jpj
197	zub(nlci-2,jj) = zub(nlci-2,jj) + e3u_a(nlci-2,jj,jk) * ua(nlci-2,jj,jk)
198	END DO
199	END DO
200	DO jj = 1, jpj
201	zub(nlci-2,jj) = zub(nlci-2,jj) * r1_hu_a(nlci-2,jj)
202	END DO
203
204	DO jk = 1, jpkm1
205	DO jj = 1, jpj
206	ua(nlci-2,jj,jk) = ( ua(nlci-2,jj,jk) + ua_b(nlci-2,jj) - zub(nlci-2,jj) ) * umask(nlci-2,jj,jk)
207	END DO
208	END DO
209	!
210	! Set tangential velocities to time splitting estimate
211	!-----------------------------------------------------
212	IF( ln_dynspg_ts ) THEN
213	zvb(nlci-1,:) = 0._wp
214	DO jk = 1, jpkm1
215	DO jj = 1, jpj
216	zvb(nlci-1,jj) = zvb(nlci-1,jj) + e3v_a(nlci-1,jj,jk) * va(nlci-1,jj,jk)
217	END DO
218	END DO
219	DO jj=1,jpj
220	zvb(nlci-1,jj) = zvb(nlci-1,jj) * r1_hv_a(nlci-1,jj)
221	END DO
222	DO jk = 1, jpkm1
223	DO jj = 1, jpj
224	va(nlci-1,jj,jk) = ( va(nlci-1,jj,jk) + va_b(nlci-1,jj) - zvb(nlci-1,jj) ) * vmask(nlci-1,jj,jk)
225	END DO
226	END DO
227	ENDIF
228	!
229	! Mask domain edges:
230	!-------------------
231	DO jk = 1, jpkm1
232	DO jj = 1, jpj
233	ua(nlci-1,jj,jk) = 0._wp
234	va(nlci ,jj,jk) = 0._wp
235	END DO
236	END DO
237	!
238	ENDIF
239
240	IF( nbondj == -1 .OR. nbondj == 2 ) THEN
241
242	! Smoothing
243	! ---------
244	IF( .NOT.ln_dynspg_ts ) THEN ! Store transport
245	va_b(:,2) = 0._wp
246	DO jk = 1, jpkm1
247	DO ji = 1, jpi
248	va_b(ji,2) = va_b(ji,2) + e3v_a(ji,2,jk) * va(ji,2,jk)
249	END DO
250	END DO
251	DO ji=1,jpi
252	va_b(ji,2) = va_b(ji,2) * r1_hv_a(ji,2)
253	END DO
254	ENDIF
255	!
256	DO jk = 1, jpkm1 ! Smooth
257	DO ji = i1, i2
258	va(ji,2,jk) = 0.25_wp * vmask(ji,2,jk) &
259	& * ( va(ji,1,jk) + 2._wp*va(ji,2,jk) + va(ji,3,jk) )
260	END DO
261	END DO
262	!
263	zvb(:,2) = 0._wp ! Correct transport
264	DO jk=1,jpkm1
265	DO ji=1,jpi
266	zvb(ji,2) = zvb(ji,2) + e3v_a(ji,2,jk) * va(ji,2,jk) * vmask(ji,2,jk)
267	END DO
268	END DO
269	DO ji = 1, jpi
270	zvb(ji,2) = zvb(ji,2) * r1_hv_a(ji,2)
271	END DO
272	DO jk = 1, jpkm1
273	DO ji = 1, jpi
274	va(ji,2,jk) = ( va(ji,2,jk) + va_b(ji,2) - zvb(ji,2) ) * vmask(ji,2,jk)
275	END DO
276	END DO
277
278	! Set tangential velocities to time splitting estimate
279	!-----------------------------------------------------
280	IF( ln_dynspg_ts ) THEN
281	zub(:,2) = 0._wp
282	DO jk = 1, jpkm1
283	DO ji = 1, jpi
284	zub(ji,2) = zub(ji,2) + e3u_a(ji,2,jk) * ua(ji,2,jk) * umask(ji,2,jk)
285	END DO
286	END DO
287	DO ji = 1, jpi
288	zub(ji,2) = zub(ji,2) * r1_hu_a(ji,2)
289	END DO
290
291	DO jk = 1, jpkm1
292	DO ji = 1, jpi
293	ua(ji,2,jk) = ( ua(ji,2,jk) + ua_b(ji,2) - zub(ji,2) ) * umask(ji,2,jk)
294	END DO
295	END DO
296	ENDIF
297
298	! Mask domain edges:
299	!-------------------
300	DO jk = 1, jpkm1
301	DO ji = 1, jpi
302	ua(ji,1,jk) = 0._wp
303	va(ji,1,jk) = 0._wp
304	END DO
305	END DO
306
307	ENDIF
308
309	IF( nbondj == 1 .OR. nbondj == 2 ) THEN
310	!
311	! Smoothing
312	! ---------
313	IF( .NOT.ln_dynspg_ts ) THEN ! Store transport
314	va_b(:,nlcj-2) = 0._wp
315	DO jk = 1, jpkm1
316	DO ji = 1, jpi
317	va_b(ji,nlcj-2) = va_b(ji,nlcj-2) + e3v_a(ji,nlcj-2,jk) * va(ji,nlcj-2,jk)
318	END DO
319	END DO
320	DO ji = 1, jpi
321	va_b(ji,nlcj-2) = va_b(ji,nlcj-2) * r1_hv_a(ji,nlcj-2)
322	END DO
323	ENDIF
324	!
325	DO jk = 1, jpkm1 ! Smooth
326	DO ji = i1, i2
327	va(ji,nlcj-2,jk) = 0.25_wp * vmask(ji,nlcj-2,jk) &
328	& * ( va(ji,nlcj-3,jk) + 2._wp * va(ji,nlcj-2,jk) + va(ji,nlcj-1,jk) )
329	END DO
330	END DO
331	!
332	zvb(:,nlcj-2) = 0._wp ! Correct transport
333	DO jk = 1, jpkm1
334	DO ji = 1, jpi
335	zvb(ji,nlcj-2) = zvb(ji,nlcj-2) + e3v_a(ji,nlcj-2,jk) * va(ji,nlcj-2,jk) * vmask(ji,nlcj-2,jk)
336	END DO
337	END DO
338	DO ji = 1, jpi
339	zvb(ji,nlcj-2) = zvb(ji,nlcj-2) * r1_hv_a(ji,nlcj-2)
340	END DO
341	DO jk = 1, jpkm1
342	DO ji = 1, jpi
343	va(ji,nlcj-2,jk) = ( va(ji,nlcj-2,jk) + va_b(ji,nlcj-2) - zvb(ji,nlcj-2) ) * vmask(ji,nlcj-2,jk)
344	END DO
345	END DO
346	!
347	! Set tangential velocities to time splitting estimate
348	!-----------------------------------------------------
349	IF( ln_dynspg_ts ) THEN
350	zub(:,nlcj-1) = 0._wp
351	DO jk = 1, jpkm1
352	DO ji = 1, jpi
353	zub(ji,nlcj-1) = zub(ji,nlcj-1) + e3u_a(ji,nlcj-1,jk) * ua(ji,nlcj-1,jk) * umask(ji,nlcj-1,jk)
354	END DO
355	END DO
356	DO ji = 1, jpi
357	zub(ji,nlcj-1) = zub(ji,nlcj-1) * r1_hu_a(ji,nlcj-1)
358	END DO
359	!
360	DO jk = 1, jpkm1
361	DO ji = 1, jpi
362	ua(ji,nlcj-1,jk) = ( ua(ji,nlcj-1,jk) + ua_b(ji,nlcj-1) - zub(ji,nlcj-1) ) * umask(ji,nlcj-1,jk)
363	END DO
364	END DO
365	ENDIF
366	!
367	! Mask domain edges:
368	!-------------------
369	DO jk = 1, jpkm1
370	DO ji = 1, jpi
371	ua(ji,nlcj ,jk) = 0._wp
372	va(ji,nlcj-1,jk) = 0._wp
373	END DO
374	END DO
375	!
376	ENDIF
377	!
378	CALL wrk_dealloc( jpi,jpj, zub, zvb )
379	!
380	END SUBROUTINE Agrif_dyn
381
382
383	SUBROUTINE Agrif_dyn_ts( jn )
384	!!----------------------------------------------------------------------
385	!! * ROUTINE Agrif_dyn_ts *
386	!!----------------------------------------------------------------------
387	!!
388	INTEGER, INTENT(in) :: jn
389	!!
390	INTEGER :: ji, jj
391	!!----------------------------------------------------------------------
392	!
393	IF( Agrif_Root() ) RETURN
394	!
395	IF((nbondi == -1).OR.(nbondi == 2)) THEN
396	DO jj=1,jpj
397	va_e(2,jj) = vbdy_w(jj) * hvr_e(2,jj)
398	! Specified fluxes:
399	ua_e(2,jj) = ubdy_w(jj) * hur_e(2,jj)
400	! Characteristics method:
401	!alt ua_e(2,jj) = 0.5_wp * ( ubdy_w(jj) * hur_e(2,jj) + ua_e(3,jj) &
402	!alt & - sqrt(grav * hur_e(2,jj)) * (sshn_e(3,jj) - hbdy_w(jj)) )
403	END DO
404	ENDIF
405	!
406	IF((nbondi == 1).OR.(nbondi == 2)) THEN
407	DO jj=1,jpj
408	va_e(nlci-1,jj) = vbdy_e(jj) * hvr_e(nlci-1,jj)
409	! Specified fluxes:
410	ua_e(nlci-2,jj) = ubdy_e(jj) * hur_e(nlci-2,jj)
411	! Characteristics method:
412	!alt ua_e(nlci-2,jj) = 0.5_wp * ( ubdy_e(jj) * hur_e(nlci-2,jj) + ua_e(nlci-3,jj) &
413	!alt & + sqrt(grav * hur_e(nlci-2,jj)) * (sshn_e(nlci-2,jj) - hbdy_e(jj)) )
414	END DO
415	ENDIF
416	!
417	IF((nbondj == -1).OR.(nbondj == 2)) THEN
418	DO ji=1,jpi
419	ua_e(ji,2) = ubdy_s(ji) * hur_e(ji,2)
420	! Specified fluxes:
421	va_e(ji,2) = vbdy_s(ji) * hvr_e(ji,2)
422	! Characteristics method:
423	!alt va_e(ji,2) = 0.5_wp * ( vbdy_s(ji) * hvr_e(ji,2) + va_e(ji,3) &
424	!alt & - sqrt(grav * hvr_e(ji,2)) * (sshn_e(ji,3) - hbdy_s(ji)) )
425	END DO
426	ENDIF
427	!
428	IF((nbondj == 1).OR.(nbondj == 2)) THEN
429	DO ji=1,jpi
430	ua_e(ji,nlcj-1) = ubdy_n(ji) * hur_e(ji,nlcj-1)
431	! Specified fluxes:
432	va_e(ji,nlcj-2) = vbdy_n(ji) * hvr_e(ji,nlcj-2)
433	! Characteristics method:
434	!alt va_e(ji,nlcj-2) = 0.5_wp * ( vbdy_n(ji) * hvr_e(ji,nlcj-2) + va_e(ji,nlcj-3) &
435	!alt & + sqrt(grav * hvr_e(ji,nlcj-2)) * (sshn_e(ji,nlcj-2) - hbdy_n(ji)) )
436	END DO
437	ENDIF
438	!
439	END SUBROUTINE Agrif_dyn_ts
440
441
442	SUBROUTINE Agrif_dta_ts( kt )
443	!!----------------------------------------------------------------------
444	!! * ROUTINE Agrif_dta_ts *
445	!!----------------------------------------------------------------------
446	!!
447	INTEGER, INTENT(in) :: kt
448	!!
449	INTEGER :: ji, jj
450	LOGICAL :: ll_int_cons
451	REAL(wp) :: zrhot, zt
452	!!----------------------------------------------------------------------
453	!
454	IF( Agrif_Root() ) RETURN
455	!
456	ll_int_cons = ln_bt_fw ! Assume conservative temporal integration in the forward case only
457	!
458	zrhot = Agrif_rhot()
459	!
460	! "Central" time index for interpolation:
461	IF( ln_bt_fw ) THEN
462	zt = REAL( Agrif_NbStepint()+0.5_wp, wp ) / zrhot
463	ELSE
464	zt = REAL( Agrif_NbStepint() , wp ) / zrhot
465	ENDIF
466	!
467	! Linear interpolation of sea level
468	Agrif_SpecialValue = 0._wp
469	Agrif_UseSpecialValue = .TRUE.
470	CALL Agrif_Bc_variable( sshn_id, calledweight=zt, procname=interpsshn )
471	Agrif_UseSpecialValue = .FALSE.
472	!
473	! Interpolate barotropic fluxes
474	Agrif_SpecialValue=0.
475	Agrif_UseSpecialValue = ln_spc_dyn
476	!
477	IF( ll_int_cons ) THEN ! Conservative interpolation
478	! orders matters here !!!!!!
479	CALL Agrif_Bc_variable( ub2b_interp_id, calledweight=1._wp, procname=interpub2b ) ! Time integrated
480	CALL Agrif_Bc_variable( vb2b_interp_id, calledweight=1._wp, procname=interpvb2b )
481	bdy_tinterp = 1
482	CALL Agrif_Bc_variable( unb_id , calledweight=1._wp, procname=interpunb ) ! After
483	CALL Agrif_Bc_variable( vnb_id , calledweight=1._wp, procname=interpvnb )
484	bdy_tinterp = 2
485	CALL Agrif_Bc_variable( unb_id , calledweight=0._wp, procname=interpunb ) ! Before
486	CALL Agrif_Bc_variable( vnb_id , calledweight=0._wp, procname=interpvnb )
487	ELSE ! Linear interpolation
488	bdy_tinterp = 0
489	ubdy_w(:) = 0._wp ; vbdy_w(:) = 0._wp
490	ubdy_e(:) = 0._wp ; vbdy_e(:) = 0._wp
491	ubdy_n(:) = 0._wp ; vbdy_n(:) = 0._wp
492	ubdy_s(:) = 0._wp ; vbdy_s(:) = 0._wp
493	CALL Agrif_Bc_variable( unb_id, calledweight=zt, procname=interpunb )
494	CALL Agrif_Bc_variable( vnb_id, calledweight=zt, procname=interpvnb )
495	ENDIF
496	Agrif_UseSpecialValue = .FALSE.
497	!
498	END SUBROUTINE Agrif_dta_ts
499
500
501	SUBROUTINE Agrif_ssh( kt )
502	!!----------------------------------------------------------------------
503	!! * ROUTINE Agrif_DYN *
504	!!----------------------------------------------------------------------
505	INTEGER, INTENT(in) :: kt
506	!!
507	!!----------------------------------------------------------------------
508	!
509	IF( Agrif_Root() ) RETURN
510	!
511	IF((nbondi == -1).OR.(nbondi == 2)) THEN
512	ssha(2,:)=ssha(3,:)
513	sshn(2,:)=sshn(3,:)
514	ENDIF
515	!
516	IF((nbondi == 1).OR.(nbondi == 2)) THEN
517	ssha(nlci-1,:)=ssha(nlci-2,:)
518	sshn(nlci-1,:)=sshn(nlci-2,:)
519	ENDIF
520	!
521	IF((nbondj == -1).OR.(nbondj == 2)) THEN
522	ssha(:,2)=ssha(:,3)
523	sshn(:,2)=sshn(:,3)
524	ENDIF
525	!
526	IF((nbondj == 1).OR.(nbondj == 2)) THEN
527	ssha(:,nlcj-1)=ssha(:,nlcj-2)
528	sshn(:,nlcj-1)=sshn(:,nlcj-2)
529	ENDIF
530	!
531	END SUBROUTINE Agrif_ssh
532
533
534	SUBROUTINE Agrif_ssh_ts( jn )
535	!!----------------------------------------------------------------------
536	!! * ROUTINE Agrif_ssh_ts *
537	!!----------------------------------------------------------------------
538	INTEGER, INTENT(in) :: jn
539	!!
540	INTEGER :: ji,jj
541	!!----------------------------------------------------------------------
542	!
543	IF((nbondi == -1).OR.(nbondi == 2)) THEN
544	DO jj = 1, jpj
545	ssha_e(2,jj) = hbdy_w(jj)
546	END DO
547	ENDIF
548	!
549	IF((nbondi == 1).OR.(nbondi == 2)) THEN
550	DO jj = 1, jpj
551	ssha_e(nlci-1,jj) = hbdy_e(jj)
552	END DO
553	ENDIF
554	!
555	IF((nbondj == -1).OR.(nbondj == 2)) THEN
556	DO ji = 1, jpi
557	ssha_e(ji,2) = hbdy_s(ji)
558	END DO
559	ENDIF
560	!
561	IF((nbondj == 1).OR.(nbondj == 2)) THEN
562	DO ji = 1, jpi
563	ssha_e(ji,nlcj-1) = hbdy_n(ji)
564	END DO
565	ENDIF
566	!
567	END SUBROUTINE Agrif_ssh_ts
568
569	# if defined key_zdftke
570
571	SUBROUTINE Agrif_tke
572	!!----------------------------------------------------------------------
573	!! * ROUTINE Agrif_tke *
574	!!----------------------------------------------------------------------
575	REAL(wp) :: zalpha
576	!!----------------------------------------------------------------------
577	!
578	zalpha = REAL( Agrif_NbStepint() + Agrif_IRhot() - 1, wp ) / REAL( Agrif_IRhot(), wp )
579	IF( zalpha > 1. ) zalpha = 1.
580	!
581	Agrif_SpecialValue = 0.e0
582	Agrif_UseSpecialValue = .TRUE.
583	!
584	CALL Agrif_Bc_variable(avm_id ,calledweight=zalpha, procname=interpavm)
585	!
586	Agrif_UseSpecialValue = .FALSE.
587	!
588	END SUBROUTINE Agrif_tke
589
590	# endif
591
592	SUBROUTINE interptsn( ptab, i1, i2, j1, j2, k1, k2, n1, n2, before, nb, ndir )
593	!!----------------------------------------------------------------------
594	!! * ROUTINE interptsn *
595	!!----------------------------------------------------------------------
596	REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: ptab
597	INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, n1, n2
598	LOGICAL , INTENT(in ) :: before
599	INTEGER , INTENT(in ) :: nb , ndir
600	!
601	INTEGER :: ji, jj, jk, jn ! dummy loop indices
602	INTEGER :: imin, imax, jmin, jmax
603	REAL(wp) :: zrhox , zalpha1, zalpha2, zalpha3
604	REAL(wp) :: zalpha4, zalpha5, zalpha6, zalpha7
605	LOGICAL :: western_side, eastern_side,northern_side,southern_side
606	!!----------------------------------------------------------------------
607	!
608	IF (before) THEN
609	ptab(i1:i2,j1:j2,k1:k2,n1:n2) = tsn(i1:i2,j1:j2,k1:k2,n1:n2)
610	ELSE
611	!
612	western_side = (nb == 1).AND.(ndir == 1)
613	eastern_side = (nb == 1).AND.(ndir == 2)
614	southern_side = (nb == 2).AND.(ndir == 1)
615	northern_side = (nb == 2).AND.(ndir == 2)
616	!
617	zrhox = Agrif_Rhox()
618	!
619	zalpha1 = ( zrhox - 1. ) * 0.5
620	zalpha2 = 1. - zalpha1
621	!
622	zalpha3 = ( zrhox - 1. ) / ( zrhox + 1. )
623	zalpha4 = 1. - zalpha3
624	!
625	zalpha6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. )
626	zalpha7 = - ( zrhox - 1. ) / ( zrhox + 3. )
627	zalpha5 = 1. - zalpha6 - zalpha7
628	!
629	imin = i1
630	imax = i2
631	jmin = j1
632	jmax = j2
633	!
634	! Remove CORNERS
635	IF((nbondj == -1).OR.(nbondj == 2)) jmin = 3
636	IF((nbondj == +1).OR.(nbondj == 2)) jmax = nlcj-2
637	IF((nbondi == -1).OR.(nbondi == 2)) imin = 3
638	IF((nbondi == +1).OR.(nbondi == 2)) imax = nlci-2
639	!
640	IF( eastern_side ) THEN
641	DO jn = 1, jpts
642	tsa(nlci,j1:j2,k1:k2,jn) = zalpha1 * ptab(nlci,j1:j2,k1:k2,jn) + zalpha2 * ptab(nlci-1,j1:j2,k1:k2,jn)
643	DO jk = 1, jpkm1
644	DO jj = jmin,jmax
645	IF( umask(nlci-2,jj,jk) == 0._wp ) THEN
646	tsa(nlci-1,jj,jk,jn) = tsa(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk)
647	ELSE
648	tsa(nlci-1,jj,jk,jn)=(zalpha4tsa(nlci,jj,jk,jn)+zalpha3tsa(nlci-2,jj,jk,jn))*tmask(nlci-1,jj,jk)
649	IF( un(nlci-2,jj,jk) > 0._wp ) THEN
650	tsa(nlci-1,jj,jk,jn)=( zalpha6tsa(nlci-2,jj,jk,jn)+zalpha5tsa(nlci,jj,jk,jn) &
651	+ zalpha7tsa(nlci-3,jj,jk,jn) ) tmask(nlci-1,jj,jk)
652	ENDIF
653	ENDIF
654	END DO
655	END DO
656	tsa(nlci,j1:j2,k1:k2,jn) = 0._wp
657	END DO
658	ENDIF
659	!
660	IF( northern_side ) THEN
661	DO jn = 1, jpts
662	tsa(i1:i2,nlcj,k1:k2,jn) = zalpha1 * ptab(i1:i2,nlcj,k1:k2,jn) + zalpha2 * ptab(i1:i2,nlcj-1,k1:k2,jn)
663	DO jk = 1, jpkm1
664	DO ji = imin,imax
665	IF( vmask(ji,nlcj-2,jk) == 0._wp ) THEN
666	tsa(ji,nlcj-1,jk,jn) = tsa(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk)
667	ELSE
668	tsa(ji,nlcj-1,jk,jn)=(zalpha4tsa(ji,nlcj,jk,jn)+zalpha3tsa(ji,nlcj-2,jk,jn))*tmask(ji,nlcj-1,jk)
669	IF (vn(ji,nlcj-2,jk) > 0._wp ) THEN
670	tsa(ji,nlcj-1,jk,jn)=( zalpha6tsa(ji,nlcj-2,jk,jn)+zalpha5tsa(ji,nlcj,jk,jn) &
671	+ zalpha7tsa(ji,nlcj-3,jk,jn) ) tmask(ji,nlcj-1,jk)
672	ENDIF
673	ENDIF
674	END DO
675	END DO
676	tsa(i1:i2,nlcj,k1:k2,jn) = 0._wp
677	END DO
678	ENDIF
679	!
680	IF( western_side ) THEN
681	DO jn = 1, jpts
682	tsa(1,j1:j2,k1:k2,jn) = zalpha1 * ptab(1,j1:j2,k1:k2,jn) + zalpha2 * ptab(2,j1:j2,k1:k2,jn)
683	DO jk = 1, jpkm1
684	DO jj = jmin,jmax
685	IF( umask(2,jj,jk) == 0._wp ) THEN
686	tsa(2,jj,jk,jn) = tsa(1,jj,jk,jn) * tmask(2,jj,jk)
687	ELSE
688	tsa(2,jj,jk,jn)=(zalpha4tsa(1,jj,jk,jn)+zalpha3tsa(3,jj,jk,jn))*tmask(2,jj,jk)
689	IF( un(2,jj,jk) < 0._wp ) THEN
690	tsa(2,jj,jk,jn)=(zalpha6tsa(3,jj,jk,jn)+zalpha5tsa(1,jj,jk,jn)+zalpha7tsa(4,jj,jk,jn))tmask(2,jj,jk)
691	ENDIF
692	ENDIF
693	END DO
694	END DO
695	tsa(1,j1:j2,k1:k2,jn) = 0._wp
696	END DO
697	ENDIF
698	!
699	IF( southern_side ) THEN
700	DO jn = 1, jpts
701	tsa(i1:i2,1,k1:k2,jn) = zalpha1 * ptab(i1:i2,1,k1:k2,jn) + zalpha2 * ptab(i1:i2,2,k1:k2,jn)
702	DO jk = 1, jpk
703	DO ji=imin,imax
704	IF( vmask(ji,2,jk) == 0._wp ) THEN
705	tsa(ji,2,jk,jn)=tsa(ji,1,jk,jn) * tmask(ji,2,jk)
706	ELSE
707	tsa(ji,2,jk,jn)=(zalpha4tsa(ji,1,jk,jn)+zalpha3tsa(ji,3,jk,jn))*tmask(ji,2,jk)
708	IF( vn(ji,2,jk) < 0._wp ) THEN
709	tsa(ji,2,jk,jn)=(zalpha6tsa(ji,3,jk,jn)+zalpha5tsa(ji,1,jk,jn)+zalpha7tsa(ji,4,jk,jn))tmask(ji,2,jk)
710	ENDIF
711	ENDIF
712	END DO
713	END DO
714	tsa(i1:i2,1,k1:k2,jn) = 0._wp
715	END DO
716	ENDIF
717	!
718	! Treatment of corners
719	!
720	! East south
721	IF ((eastern_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN
722	tsa(nlci-1,2,:,:) = ptab(nlci-1,2,:,:)
723	ENDIF
724	! East north
725	IF ((eastern_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN
726	tsa(nlci-1,nlcj-1,:,:) = ptab(nlci-1,nlcj-1,:,:)
727	ENDIF
728	! West south
729	IF ((western_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN
730	tsa(2,2,:,:) = ptab(2,2,:,:)
731	ENDIF
732	! West north
733	IF ((western_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN
734	tsa(2,nlcj-1,:,:) = ptab(2,nlcj-1,:,:)
735	ENDIF
736	!
737	ENDIF
738	!
739	END SUBROUTINE interptsn
740
741
742	SUBROUTINE interpsshn( ptab, i1, i2, j1, j2, before, nb, ndir )
743	!!----------------------------------------------------------------------
744	!! * ROUTINE interpsshn *
745	!!----------------------------------------------------------------------
746	INTEGER , INTENT(in ) :: i1, i2, j1, j2
747	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
748	LOGICAL , INTENT(in ) :: before
749	INTEGER , INTENT(in ) :: nb , ndir
750	!
751	LOGICAL :: western_side, eastern_side,northern_side,southern_side
752	!!----------------------------------------------------------------------
753	!
754	IF( before) THEN
755	ptab(i1:i2,j1:j2) = sshn(i1:i2,j1:j2)
756	ELSE
757	western_side = (nb == 1).AND.(ndir == 1)
758	eastern_side = (nb == 1).AND.(ndir == 2)
759	southern_side = (nb == 2).AND.(ndir == 1)
760	northern_side = (nb == 2).AND.(ndir == 2)
761	IF(western_side) hbdy_w(j1:j2) = ptab(i1,j1:j2) * tmask(i1,j1:j2,1)
762	IF(eastern_side) hbdy_e(j1:j2) = ptab(i1,j1:j2) * tmask(i1,j1:j2,1)
763	IF(southern_side) hbdy_s(i1:i2) = ptab(i1:i2,j1) * tmask(i1:i2,j1,1)
764	IF(northern_side) hbdy_n(i1:i2) = ptab(i1:i2,j1) * tmask(i1:i2,j1,1)
765	ENDIF
766	!
767	END SUBROUTINE interpsshn
768
769
770	SUBROUTINE interpun( ptab, i1, i2, j1, j2, k1, k2, before )
771	!!----------------------------------------------------------------------
772	!! * ROUTINE interpun *
773	!!----------------------------------------------------------------------
774	INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2
775	REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab
776	LOGICAL , INTENT(in ) :: before
777	!
778	INTEGER :: ji, jj, jk
779	REAL(wp) :: zrhoy
780	!!----------------------------------------------------------------------
781	!
782	IF( before ) THEN
783	DO jk = k1, jpk
784	ptab(i1:i2,j1:j2,jk) = e2u(i1:i2,j1:j2) * e3u_n(i1:i2,j1:j2,jk) * un(i1:i2,j1:j2,jk)
785	END DO
786	ELSE
787	zrhoy = Agrif_Rhoy()
788	DO jk = 1, jpkm1
789	DO jj=j1,j2
790	ua(i1:i2,jj,jk) = ptab(i1:i2,jj,jk) / ( zrhoy * e2u(i1:i2,jj) * e3u_n(i1:i2,jj,jk) )
791	END DO
792	END DO
793	ENDIF
794	!
795	END SUBROUTINE interpun
796
797
798	SUBROUTINE interpvn( ptab, i1, i2, j1, j2, k1, k2, before )
799	!!----------------------------------------------------------------------
800	!! * ROUTINE interpvn *
801	!!----------------------------------------------------------------------
802	INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2
803	REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab
804	LOGICAL , INTENT(in ) :: before
805	!
806	INTEGER :: ji, jj, jk
807	REAL(wp) :: zrhox
808	!!----------------------------------------------------------------------
809	!
810	IF( before ) THEN !interpv entre 1 et k2 et interpv2d en jpkp1
811	DO jk = k1, jpk
812	ptab(i1:i2,j1:j2,jk) = e1v(i1:i2,j1:j2) * e3v_n(i1:i2,j1:j2,jk) * vn(i1:i2,j1:j2,jk)
813	END DO
814	ELSE
815	zrhox= Agrif_Rhox()
816	DO jk = 1, jpkm1
817	va(i1:i2,j1:j2,jk) = ptab(i1:i2,j1:j2,jk) / ( zrhox * e1v(i1:i2,j1:j2) * e3v_n(i1:i2,j1:j2,jk) )
818	END DO
819	ENDIF
820	!
821	END SUBROUTINE interpvn
822
823
824	SUBROUTINE interpunb( ptab, i1, i2, j1, j2, before, nb, ndir )
825	!!----------------------------------------------------------------------
826	!! * ROUTINE interpunb *
827	!!----------------------------------------------------------------------
828	INTEGER , INTENT(in ) :: i1, i2, j1, j2
829	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
830	LOGICAL , INTENT(in ) :: before
831	INTEGER , INTENT(in ) :: nb , ndir
832	!
833	INTEGER :: ji, jj
834	REAL(wp) :: zrhoy, zrhot, zt0, zt1, ztcoeff
835	LOGICAL :: western_side, eastern_side,northern_side,southern_side
836	!!----------------------------------------------------------------------
837	!
838	IF( before ) THEN
839	ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * hu_n(i1:i2,j1:j2) * un_b(i1:i2,j1:j2)
840	ELSE
841	western_side = (nb == 1).AND.(ndir == 1)
842	eastern_side = (nb == 1).AND.(ndir == 2)
843	southern_side = (nb == 2).AND.(ndir == 1)
844	northern_side = (nb == 2).AND.(ndir == 2)
845	zrhoy = Agrif_Rhoy()
846	zrhot = Agrif_rhot()
847	! Time indexes bounds for integration
848	zt0 = REAL(Agrif_NbStepint() , wp) / zrhot
849	zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot
850	! Polynomial interpolation coefficients:
851	IF( bdy_tinterp == 1 ) THEN
852	ztcoeff = zrhot * ( zt1*2._wp ( zt1 - 1._wp) &
853	& - zt0*2._wp ( zt0 - 1._wp) )
854	ELSEIF( bdy_tinterp == 2 ) THEN
855	ztcoeff = zrhot * ( zt1 * ( zt1 - 1._wp)**2._wp &
856	& - zt0 * ( zt0 - 1._wp)**2._wp )
857
858	ELSE
859	ztcoeff = 1
860	ENDIF
861	!
862	IF(western_side) THEN
863	ubdy_w(j1:j2) = ubdy_w(j1:j2) + ztcoeff * ptab(i1,j1:j2)
864	ENDIF
865	IF(eastern_side) THEN
866	ubdy_e(j1:j2) = ubdy_e(j1:j2) + ztcoeff * ptab(i1,j1:j2)
867	ENDIF
868	IF(southern_side) THEN
869	ubdy_s(i1:i2) = ubdy_s(i1:i2) + ztcoeff * ptab(i1:i2,j1)
870	ENDIF
871	IF(northern_side) THEN
872	ubdy_n(i1:i2) = ubdy_n(i1:i2) + ztcoeff * ptab(i1:i2,j1)
873	ENDIF
874	!
875	IF( bdy_tinterp == 0 .OR. bdy_tinterp == 2) THEN
876	IF(western_side) THEN
877	ubdy_w(j1:j2) = ubdy_w(j1:j2) / (zrhoye2u(i1,j1:j2)) umask(i1,j1:j2,1)
878	ENDIF
879	IF(eastern_side) THEN
880	ubdy_e(j1:j2) = ubdy_e(j1:j2) / (zrhoye2u(i1,j1:j2)) umask(i1,j1:j2,1)
881	ENDIF
882	IF(southern_side) THEN
883	ubdy_s(i1:i2) = ubdy_s(i1:i2) / (zrhoye2u(i1:i2,j1)) umask(i1:i2,j1,1)
884	ENDIF
885	IF(northern_side) THEN
886	ubdy_n(i1:i2) = ubdy_n(i1:i2) / (zrhoye2u(i1:i2,j1)) umask(i1:i2,j1,1)
887	ENDIF
888	ENDIF
889	ENDIF
890	!
891	END SUBROUTINE interpunb
892
893
894	SUBROUTINE interpvnb( ptab, i1, i2, j1, j2, before, nb, ndir )
895	!!----------------------------------------------------------------------
896	!! * ROUTINE interpvnb *
897	!!----------------------------------------------------------------------
898	INTEGER , INTENT(in ) :: i1, i2, j1, j2
899	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
900	LOGICAL , INTENT(in ) :: before
901	INTEGER , INTENT(in ) :: nb , ndir
902	!
903	INTEGER :: ji,jj
904	REAL(wp) :: zrhox, zrhot, zt0, zt1, ztcoeff
905	LOGICAL :: western_side, eastern_side,northern_side,southern_side
906	!!----------------------------------------------------------------------
907	!
908	IF( before ) THEN
909	ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * hv_n(i1:i2,j1:j2) * vn_b(i1:i2,j1:j2)
910	ELSE
911	western_side = (nb == 1).AND.(ndir == 1)
912	eastern_side = (nb == 1).AND.(ndir == 2)
913	southern_side = (nb == 2).AND.(ndir == 1)
914	northern_side = (nb == 2).AND.(ndir == 2)
915	zrhox = Agrif_Rhox()
916	zrhot = Agrif_rhot()
917	! Time indexes bounds for integration
918	zt0 = REAL(Agrif_NbStepint() , wp) / zrhot
919	zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot
920	IF( bdy_tinterp == 1 ) THEN
921	ztcoeff = zrhot * ( zt1*2._wp ( zt1 - 1._wp) &
922	& - zt0*2._wp ( zt0 - 1._wp) )
923	ELSEIF( bdy_tinterp == 2 ) THEN
924	ztcoeff = zrhot * ( zt1 * ( zt1 - 1._wp)**2._wp &
925	& - zt0 * ( zt0 - 1._wp)**2._wp )
926	ELSE
927	ztcoeff = 1
928	ENDIF
929	!
930	IF(western_side) THEN
931	vbdy_w(j1:j2) = vbdy_w(j1:j2) + ztcoeff * ptab(i1,j1:j2)
932	ENDIF
933	IF(eastern_side) THEN
934	vbdy_e(j1:j2) = vbdy_e(j1:j2) + ztcoeff * ptab(i1,j1:j2)
935	ENDIF
936	IF(southern_side) THEN
937	vbdy_s(i1:i2) = vbdy_s(i1:i2) + ztcoeff * ptab(i1:i2,j1)
938	ENDIF
939	IF(northern_side) THEN
940	vbdy_n(i1:i2) = vbdy_n(i1:i2) + ztcoeff * ptab(i1:i2,j1)
941	ENDIF
942	!
943	IF( bdy_tinterp == 0 .OR. bdy_tinterp == 2) THEN
944	IF(western_side) THEN
945	vbdy_w(j1:j2) = vbdy_w(j1:j2) / (zrhox*e1v(i1,j1:j2)) &
946	& * vmask(i1,j1:j2,1)
947	ENDIF
948	IF(eastern_side) THEN
949	vbdy_e(j1:j2) = vbdy_e(j1:j2) / (zrhox*e1v(i1,j1:j2)) &
950	& * vmask(i1,j1:j2,1)
951	ENDIF
952	IF(southern_side) THEN
953	vbdy_s(i1:i2) = vbdy_s(i1:i2) / (zrhox*e1v(i1:i2,j1)) &
954	& * vmask(i1:i2,j1,1)
955	ENDIF
956	IF(northern_side) THEN
957	vbdy_n(i1:i2) = vbdy_n(i1:i2) / (zrhox*e1v(i1:i2,j1)) &
958	& * vmask(i1:i2,j1,1)
959	ENDIF
960	ENDIF
961	ENDIF
962	!
963	END SUBROUTINE interpvnb
964
965
966	SUBROUTINE interpub2b( ptab, i1, i2, j1, j2, before, nb, ndir )
967	!!----------------------------------------------------------------------
968	!! * ROUTINE interpub2b *
969	!!----------------------------------------------------------------------
970	INTEGER , INTENT(in ) :: i1, i2, j1, j2
971	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
972	LOGICAL , INTENT(in ) :: before
973	INTEGER , INTENT(in ) :: nb , ndir
974	!
975	INTEGER :: ji,jj
976	REAL(wp) :: zrhot, zt0, zt1,zat
977	LOGICAL :: western_side, eastern_side,northern_side,southern_side
978	!!----------------------------------------------------------------------
979	IF( before ) THEN
980	ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * ub2_b(i1:i2,j1:j2)
981	ELSE
982	western_side = (nb == 1).AND.(ndir == 1)
983	eastern_side = (nb == 1).AND.(ndir == 2)
984	southern_side = (nb == 2).AND.(ndir == 1)
985	northern_side = (nb == 2).AND.(ndir == 2)
986	zrhot = Agrif_rhot()
987	! Time indexes bounds for integration
988	zt0 = REAL(Agrif_NbStepint() , wp) / zrhot
989	zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot
990	! Polynomial interpolation coefficients:
991	zat = zrhot * ( zt1*2._wp (-2._wp*zt1 + 3._wp) &
992	& - zt0*2._wp (-2._wp*zt0 + 3._wp) )
993	!
994	IF(western_side ) ubdy_w(j1:j2) = zat * ptab(i1,j1:j2)
995	IF(eastern_side ) ubdy_e(j1:j2) = zat * ptab(i1,j1:j2)
996	IF(southern_side) ubdy_s(i1:i2) = zat * ptab(i1:i2,j1)
997	IF(northern_side) ubdy_n(i1:i2) = zat * ptab(i1:i2,j1)
998	ENDIF
999	!
1000	END SUBROUTINE interpub2b
1001
1002
1003	SUBROUTINE interpvb2b( ptab, i1, i2, j1, j2, before, nb, ndir )
1004	!!----------------------------------------------------------------------
1005	!! * ROUTINE interpvb2b *
1006	!!----------------------------------------------------------------------
1007	INTEGER , INTENT(in ) :: i1, i2, j1, j2
1008	REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
1009	LOGICAL , INTENT(in ) :: before
1010	INTEGER , INTENT(in ) :: nb , ndir
1011	!
1012	INTEGER :: ji,jj
1013	REAL(wp) :: zrhot, zt0, zt1,zat
1014	LOGICAL :: western_side, eastern_side,northern_side,southern_side
1015	!!----------------------------------------------------------------------
1016	!
1017	IF( before ) THEN
1018	ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * vb2_b(i1:i2,j1:j2)
1019	ELSE
1020	western_side = (nb == 1).AND.(ndir == 1)
1021	eastern_side = (nb == 1).AND.(ndir == 2)
1022	southern_side = (nb == 2).AND.(ndir == 1)
1023	northern_side = (nb == 2).AND.(ndir == 2)
1024	zrhot = Agrif_rhot()
1025	! Time indexes bounds for integration
1026	zt0 = REAL(Agrif_NbStepint() , wp) / zrhot
1027	zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot
1028	! Polynomial interpolation coefficients:
1029	zat = zrhot * ( zt1*2._wp (-2._wp*zt1 + 3._wp) &
1030	& - zt0*2._wp (-2._wp*zt0 + 3._wp) )
1031	!
1032	IF(western_side ) vbdy_w(j1:j2) = zat * ptab(i1,j1:j2)
1033	IF(eastern_side ) vbdy_e(j1:j2) = zat * ptab(i1,j1:j2)
1034	IF(southern_side) vbdy_s(i1:i2) = zat * ptab(i1:i2,j1)
1035	IF(northern_side) vbdy_n(i1:i2) = zat * ptab(i1:i2,j1)
1036	ENDIF
1037	!
1038	END SUBROUTINE interpvb2b
1039
1040
1041	SUBROUTINE interpe3t( ptab, i1, i2, j1, j2, k1, k2, before, nb, ndir )
1042	!!----------------------------------------------------------------------
1043	!! * ROUTINE interpe3t *
1044	!!----------------------------------------------------------------------
1045	INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2
1046	REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab
1047	LOGICAL , INTENT(in ) :: before
1048	INTEGER , INTENT(in ) :: nb , ndir
1049	!
1050	INTEGER :: ji, jj, jk
1051	LOGICAL :: western_side, eastern_side, northern_side, southern_side
1052	REAL(wp) :: ztmpmsk
1053	!!----------------------------------------------------------------------
1054	!
1055	IF( before ) THEN
1056	ptab(i1:i2,j1:j2,k1:k2) = tmask(i1:i2,j1:j2,k1:k2) * e3t_0(i1:i2,j1:j2,k1:k2)
1057	ELSE
1058	western_side = (nb == 1).AND.(ndir == 1)
1059	eastern_side = (nb == 1).AND.(ndir == 2)
1060	southern_side = (nb == 2).AND.(ndir == 1)
1061	northern_side = (nb == 2).AND.(ndir == 2)
1062
1063	DO jk = k1, k2
1064	DO jj = j1, j2
1065	DO ji = i1, i2
1066	! Get velocity mask at boundary edge points:
1067	IF( western_side ) ztmpmsk = umask(ji ,jj ,1)
1068	IF( eastern_side ) ztmpmsk = umask(nlci-2,jj ,1)
1069	IF( northern_side) ztmpmsk = vmask(ji ,nlcj-2,1)
1070	IF( southern_side) ztmpmsk = vmask(ji ,2 ,1)
1071	!
1072	IF( ABS( ptab(ji,jj,jk) - tmask(ji,jj,jk) * e3t_0(ji,jj,jk) )*ztmpmsk > 1.D-2) THEN
1073	IF (western_side) THEN
1074	WRITE(numout,*) 'ERROR bathymetry merge at the western border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk
1075	ELSEIF (eastern_side) THEN
1076	WRITE(numout,*) 'ERROR bathymetry merge at the eastern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk
1077	ELSEIF (southern_side) THEN
1078	WRITE(numout,*) 'ERROR bathymetry merge at the southern border ji,jj,jk', ji+nimpp-1,jj+njmpp-1,jk
1079	ELSEIF (northern_side) THEN
1080	WRITE(numout,*) 'ERROR bathymetry merge at the northen border ji,jj,jk', ji+nimpp-1,jj+njmpp-1,jk
1081	ENDIF
1082	WRITE(numout,*) ' ptab(ji,jj,jk), e3t(ji,jj,jk) ', ptab(ji,jj,jk), e3t_0(ji,jj,jk)
1083	kindic_agr = kindic_agr + 1
1084	ENDIF
1085	END DO
1086	END DO
1087	END DO
1088	!
1089	ENDIF
1090	!
1091	END SUBROUTINE interpe3t
1092
1093
1094	SUBROUTINE interpumsk( ptab, i1, i2, j1, j2, k1, k2, before, nb, ndir )
1095	!!----------------------------------------------------------------------
1096	!! * ROUTINE interpumsk *
1097	!!----------------------------------------------------------------------
1098	INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2
1099	REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab
1100	LOGICAL , INTENT(in ) :: before
1101	INTEGER , INTENT(in ) :: nb , ndir
1102	!
1103	INTEGER :: ji, jj, jk
1104	LOGICAL :: western_side, eastern_side
1105	!!----------------------------------------------------------------------
1106	!
1107	IF( before ) THEN
1108	ptab(i1:i2,j1:j2,k1:k2) = umask(i1:i2,j1:j2,k1:k2)
1109	ELSE
1110	western_side = (nb == 1).AND.(ndir == 1)
1111	eastern_side = (nb == 1).AND.(ndir == 2)
1112	DO jk = k1, k2
1113	DO jj = j1, j2
1114	DO ji = i1, i2
1115	! Velocity mask at boundary edge points:
1116	IF (ABS(ptab(ji,jj,jk) - umask(ji,jj,jk)) > 1.D-2) THEN
1117	IF (western_side) THEN
1118	WRITE(numout,*) 'ERROR with umask at the western border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk
1119	WRITE(numout,*) ' masks: parent, child ', ptab(ji,jj,jk), umask(ji,jj,jk)
1120	kindic_agr = kindic_agr + 1
1121	ELSEIF (eastern_side) THEN
1122	WRITE(numout,*) 'ERROR with umask at the eastern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk
1123	WRITE(numout,*) ' masks: parent, child ', ptab(ji,jj,jk), umask(ji,jj,jk)
1124	kindic_agr = kindic_agr + 1
1125	ENDIF
1126	ENDIF
1127	END DO
1128	END DO
1129	END DO
1130	!
1131	ENDIF
1132	!
1133	END SUBROUTINE interpumsk
1134
1135
1136	SUBROUTINE interpvmsk( ptab, i1, i2, j1, j2, k1, k2, before, nb, ndir )
1137	!!----------------------------------------------------------------------
1138	!! * ROUTINE interpvmsk *
1139	!!----------------------------------------------------------------------
1140	INTEGER , INTENT(in ) :: i1,i2,j1,j2,k1,k2
1141	REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab
1142	LOGICAL , INTENT(in ) :: before
1143	INTEGER , INTENT(in ) :: nb , ndir
1144	!
1145	INTEGER :: ji, jj, jk
1146	LOGICAL :: northern_side, southern_side
1147	!!----------------------------------------------------------------------
1148	!
1149	IF( before ) THEN
1150	ptab(i1:i2,j1:j2,k1:k2) = vmask(i1:i2,j1:j2,k1:k2)
1151	ELSE
1152	southern_side = (nb == 2).AND.(ndir == 1)
1153	northern_side = (nb == 2).AND.(ndir == 2)
1154	DO jk = k1, k2
1155	DO jj = j1, j2
1156	DO ji = i1, i2
1157	! Velocity mask at boundary edge points:
1158	IF (ABS(ptab(ji,jj,jk) - vmask(ji,jj,jk)) > 1.D-2) THEN
1159	IF (southern_side) THEN
1160	WRITE(numout,*) 'ERROR with vmask at the southern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk
1161	WRITE(numout,*) ' masks: parent, child ', ptab(ji,jj,jk), vmask(ji,jj,jk)
1162	kindic_agr = kindic_agr + 1
1163	ELSEIF (northern_side) THEN
1164	WRITE(numout,*) 'ERROR with vmask at the northern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk
1165	WRITE(numout,*) ' masks: parent, child ', ptab(ji,jj,jk), vmask(ji,jj,jk)
1166	kindic_agr = kindic_agr + 1
1167	ENDIF
1168	ENDIF
1169	END DO
1170	END DO
1171	END DO
1172	!
1173	ENDIF
1174	!
1175	END SUBROUTINE interpvmsk
1176
1177	# if defined key_zdftke
1178
1179	SUBROUTINE interpavm( ptab, i1, i2, j1, j2, k1, k2, before )
1180	!!----------------------------------------------------------------------
1181	!! * ROUTINE interavm *
1182	!!----------------------------------------------------------------------
1183	INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2
1184	REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab
1185	LOGICAL , INTENT(in ) :: before
1186	!!----------------------------------------------------------------------
1187	!
1188	IF( before ) THEN
1189	ptab (i1:i2,j1:j2,k1:k2) = avm_k(i1:i2,j1:j2,k1:k2)
1190	ELSE
1191	avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2)
1192	ENDIF
1193	!
1194	END SUBROUTINE interpavm
1195
1196	# endif /* key_zdftke */
1197
1198	#else
1199	!!----------------------------------------------------------------------
1200	!! Empty module no AGRIF zoom
1201	!!----------------------------------------------------------------------
1202	CONTAINS
1203	SUBROUTINE Agrif_OPA_Interp_empty
1204	WRITE(,) 'agrif_opa_interp : You should not have seen this print! error?'
1205	END SUBROUTINE Agrif_OPA_Interp_empty
1206	#endif
1207
1208	!!======================================================================
1209	END MODULE agrif_opa_interp

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

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

Context Navigation

source: trunk/NEMOGCM/NEMO/NST_SRC/agrif_opa_interp.F90 @ 7646

Download in other formats: