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/2017/dev_r8624_AGRIF3_VVL/NEMOGCM/NEMO/NST_SRC – NEMO

source: branches/2017/dev_r8624_AGRIF3_VVL/NEMOGCM/NEMO/NST_SRC/agrif_opa_interp.F90 @ 8965

Last change on this file since 8965 was 8965, checked in by jchanut, 6 years ago

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