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

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

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