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
RevLine 
[636]1MODULE agrif_opa_interp
[1605]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)
[5656]9   !!            3.6  !  2014-09  (R. Benshila)
[1605]10   !!----------------------------------------------------------------------
[7646]11#if defined key_agrif
[1605]12   !!----------------------------------------------------------------------
13   !!   'key_agrif'                                              AGRIF zoom
14   !!----------------------------------------------------------------------
15   !!   Agrif_tra     :
16   !!   Agrif_dyn     :
17   !!   interpu       :
18   !!   interpv       :
19   !!----------------------------------------------------------------------
[636]20   USE par_oce
21   USE oce
22   USE dom_oce     
[6140]23   USE zdf_oce
[782]24   USE agrif_oce
[1605]25   USE phycst
[8741]26   USE dynspg_ts, ONLY: un_adv, vn_adv
[6140]27   !
[1605]28   USE in_out_manager
[2715]29   USE agrif_opa_sponge
30   USE lib_mpp
[4292]31   USE wrk_nemo
[5656]32 
[636]33   IMPLICIT NONE
34   PRIVATE
[4292]35
[4486]36   PUBLIC   Agrif_tra, Agrif_dyn, Agrif_ssh, Agrif_dyn_ts, Agrif_ssh_ts, Agrif_dta_ts
[5930]37   PUBLIC   interpun, interpvn
[5656]38   PUBLIC   interptsn,  interpsshn
39   PUBLIC   interpunb, interpvnb, interpub2b, interpvb2b
40   PUBLIC   interpe3t, interpumsk, interpvmsk
[8741]41# if defined key_zdftke || defined key_zdfgls
42   PUBLIC   Agrif_avm, interpavm
[5656]43# endif
[390]44
[6140]45   INTEGER ::   bdy_tinterp = 0
46
[1605]47#  include "vectopt_loop_substitute.h90"
[1156]48   !!----------------------------------------------------------------------
[6140]49   !! NEMO/NST 3.7 , NEMO Consortium (2015)
[1156]50   !! $Id$
[2528]51   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
[1156]52   !!----------------------------------------------------------------------
[5656]53CONTAINS
54
[782]55   SUBROUTINE Agrif_tra
[1605]56      !!----------------------------------------------------------------------
[5656]57      !!                  ***  ROUTINE Agrif_tra  ***
[1605]58      !!----------------------------------------------------------------------
[636]59      !
[1605]60      IF( Agrif_Root() )   RETURN
[6140]61      !
62      Agrif_SpecialValue    = 0._wp
[636]63      Agrif_UseSpecialValue = .TRUE.
[6140]64      !
[5656]65      CALL Agrif_Bc_variable( tsn_id, procname=interptsn )
[6140]66      !
[636]67      Agrif_UseSpecialValue = .FALSE.
[1605]68      !
[636]69   END SUBROUTINE Agrif_tra
70
[1605]71
[636]72   SUBROUTINE Agrif_dyn( kt )
[1605]73      !!----------------------------------------------------------------------
74      !!                  ***  ROUTINE Agrif_DYN  ***
75      !!---------------------------------------------------------------------- 
76      INTEGER, INTENT(in) ::   kt
[6140]77      !
78      INTEGER ::   ji, jj, jk       ! dummy loop indices
79      INTEGER ::   j1, j2, i1, i2
80      REAL(wp), POINTER, DIMENSION(:,:) ::   zub, zvb
[1605]81      !!---------------------------------------------------------------------- 
[6140]82      !
[1605]83      IF( Agrif_Root() )   RETURN
[6140]84      !
85      CALL wrk_alloc( jpi,jpj,   zub, zvb )
86      !
87      Agrif_SpecialValue    = 0._wp
[5656]88      Agrif_UseSpecialValue = ln_spc_dyn
[6140]89      !
90      CALL Agrif_Bc_variable( un_interp_id, procname=interpun )
91      CALL Agrif_Bc_variable( vn_interp_id, procname=interpvn )
92      !
[5656]93      Agrif_UseSpecialValue = .FALSE.
[6140]94      !
[5656]95      ! prevent smoothing in ghost cells
[6140]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
[782]102
[6140]103      IF( nbondi == -1 .OR. nbondi == 2 ) THEN
104         !
[5930]105         ! Smoothing
106         ! ---------
[6140]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)
[5930]112               END DO
[636]113            END DO
[6140]114            DO jj = 1, jpj
115               ua_b(2,jj) = ua_b(2,jj) * r1_hu_a(2,jj)           
[636]116            END DO
[5930]117         ENDIF
[6140]118         !
[8965]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
[636]125            END DO
[8965]126         END IF
[6140]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)
[636]132            END DO
133         END DO
134         DO jj=1,jpj
[6140]135            zub(2,jj) = zub(2,jj) * r1_hu_a(2,jj)
[636]136         END DO
[390]137
[636]138         DO jk=1,jpkm1
[5930]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)
[636]141            END DO
142         END DO
[390]143
[4486]144         ! Set tangential velocities to time splitting estimate
[5930]145         !-----------------------------------------------------
[6140]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)
[5930]151               END DO
152            END DO
[6140]153            DO jj = 1, jpj
154               zvb(2,jj) = zvb(2,jj) * r1_hv_a(2,jj)
[4486]155            END DO
[6140]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)
[5930]159               END DO
160            END DO
161         ENDIF
[6140]162         !
[5930]163         ! Mask domain edges:
164         !-------------------
[6140]165         DO jk = 1, jpkm1
166            DO jj = 1, jpj
[5930]167               ua(1,jj,jk) = 0._wp
168               va(1,jj,jk) = 0._wp
[4486]169            END DO
[5930]170         END DO         
[6140]171         !
[636]172      ENDIF
[390]173
[6140]174      IF( nbondi == 1 .OR. nbondi == 2 ) THEN
[5930]175
176         ! Smoothing
177         ! ---------
[6140]178         IF( .NOT.ln_dynspg_ts ) THEN  ! Store transport
179            ua_b(nlci-2,:) = 0._wp
[5930]180            DO jk=1,jpkm1
181               DO jj=1,jpj
[6140]182                  ua_b(nlci-2,jj) = ua_b(nlci-2,jj) + e3u_a(nlci-2,jj,jk) * ua(nlci-2,jj,jk)
[5930]183               END DO
[636]184            END DO
185            DO jj=1,jpj
[6140]186               ua_b(nlci-2,jj) = ua_b(nlci-2,jj) * r1_hu_a(nlci-2,jj)           
[5930]187            END DO
188         ENDIF
189
[8965]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
[636]196            END DO
[8965]197         ENDIF
[5930]198
[6140]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)
[636]203            END DO
204         END DO
[6140]205         DO jj = 1, jpj
206            zub(nlci-2,jj) = zub(nlci-2,jj) * r1_hu_a(nlci-2,jj)
[636]207         END DO
[5930]208
[6140]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)
[636]212            END DO
213         END DO
[6140]214         !
[4486]215         ! Set tangential velocities to time splitting estimate
[5930]216         !-----------------------------------------------------
[6140]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)
[5930]222               END DO
223            END DO
[4486]224            DO jj=1,jpj
[6140]225               zvb(nlci-1,jj) = zvb(nlci-1,jj) * r1_hv_a(nlci-1,jj)
[4486]226            END DO
[6140]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)
[5930]230               END DO
231            END DO
232         ENDIF
[6140]233         !
[5930]234         ! Mask domain edges:
235         !-------------------
[6140]236         DO jk = 1, jpkm1
237            DO jj = 1, jpj
[5930]238               ua(nlci-1,jj,jk) = 0._wp
239               va(nlci  ,jj,jk) = 0._wp
[4486]240            END DO
[5930]241         END DO 
[6140]242         !
[636]243      ENDIF
[390]244
[6140]245      IF( nbondj == -1 .OR. nbondj == 2 ) THEN
[390]246
[5930]247         ! Smoothing
248         ! ---------
[6140]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)
[5930]254               END DO
[636]255            END DO
256            DO ji=1,jpi
[6140]257               va_b(ji,2) = va_b(ji,2) * r1_hv_a(ji,2)           
[636]258            END DO
[5930]259         ENDIF
[6140]260         !
[8965]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
[636]267            END DO
[8965]268         ENDIF
[6140]269         !
270         zvb(:,2) = 0._wp              ! Correct transport
[636]271         DO jk=1,jpkm1
272            DO ji=1,jpi
[6140]273               zvb(ji,2) = zvb(ji,2) + e3v_a(ji,2,jk) * va(ji,2,jk) * vmask(ji,2,jk)
[636]274            END DO
275         END DO
[6140]276         DO ji = 1, jpi
277            zvb(ji,2) = zvb(ji,2) * r1_hv_a(ji,2)
[636]278         END DO
[6140]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)
[636]282            END DO
283         END DO
[390]284
[4486]285         ! Set tangential velocities to time splitting estimate
[5930]286         !-----------------------------------------------------
[6140]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)
[5930]292               END DO
293            END DO
[6140]294            DO ji = 1, jpi
295               zub(ji,2) = zub(ji,2) * r1_hu_a(ji,2)
[4486]296            END DO
297
[6140]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)
[5930]301               END DO
302            END DO
303         ENDIF
[4486]304
[5930]305         ! Mask domain edges:
306         !-------------------
[6140]307         DO jk = 1, jpkm1
308            DO ji = 1, jpi
[5930]309               ua(ji,1,jk) = 0._wp
310               va(ji,1,jk) = 0._wp
[4486]311            END DO
[5930]312         END DO
313
[636]314      ENDIF
[390]315
[6140]316      IF( nbondj == 1 .OR. nbondj == 2 ) THEN
317         !
[5930]318         ! Smoothing
319         ! ---------
[6140]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)
[5930]325               END DO
[636]326            END DO
[6140]327            DO ji = 1, jpi
328               va_b(ji,nlcj-2) = va_b(ji,nlcj-2) * r1_hv_a(ji,nlcj-2)           
[636]329            END DO
[5930]330         ENDIF
[6140]331         !
[8965]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
[636]338            END DO
[8965]339         ENDIF
[6140]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)
[636]345            END DO
346         END DO
[6140]347         DO ji = 1, jpi
348            zvb(ji,nlcj-2) = zvb(ji,nlcj-2) * r1_hv_a(ji,nlcj-2)
[636]349         END DO
[6140]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)
[636]353            END DO
354         END DO
[6140]355         !
[4486]356         ! Set tangential velocities to time splitting estimate
[5930]357         !-----------------------------------------------------
[6140]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)
[5930]363               END DO
364            END DO
[6140]365            DO ji = 1, jpi
366               zub(ji,nlcj-1) = zub(ji,nlcj-1) * r1_hu_a(ji,nlcj-1)
[4486]367            END DO
[6140]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)
[5930]372               END DO
373            END DO
374         ENDIF
[6140]375         !
[5930]376         ! Mask domain edges:
377         !-------------------
[6140]378         DO jk = 1, jpkm1
379            DO ji = 1, jpi
[5930]380               ua(ji,nlcj  ,jk) = 0._wp
381               va(ji,nlcj-1,jk) = 0._wp
[4486]382            END DO
[5930]383         END DO 
[6140]384         !
[636]385      ENDIF
[2715]386      !
[6140]387      CALL wrk_dealloc( jpi,jpj,   zub, zvb )
[2715]388      !
[636]389   END SUBROUTINE Agrif_dyn
[390]390
[6140]391
[4486]392   SUBROUTINE Agrif_dyn_ts( jn )
[4292]393      !!----------------------------------------------------------------------
394      !!                  ***  ROUTINE Agrif_dyn_ts  ***
395      !!---------------------------------------------------------------------- 
396      !!
[4486]397      INTEGER, INTENT(in) ::   jn
[4292]398      !!
399      INTEGER :: ji, jj
[4486]400      !!---------------------------------------------------------------------- 
[6140]401      !
[4486]402      IF( Agrif_Root() )   RETURN
[6140]403      !
[4486]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)
[5656]407            ! Specified fluxes:
[4486]408            ua_e(2,jj) = ubdy_w(jj) * hur_e(2,jj)
[5656]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)) )
[4486]412         END DO
413      ENDIF
[6140]414      !
[4486]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)
[5656]418            ! Specified fluxes:
[4486]419            ua_e(nlci-2,jj) = ubdy_e(jj) * hur_e(nlci-2,jj)
[5656]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)) )
[4486]423         END DO
424      ENDIF
[6140]425      !
[4486]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)
[5656]429            ! Specified fluxes:
[4486]430            va_e(ji,2) = vbdy_s(ji) * hvr_e(ji,2)
[5656]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)) )
[4486]434         END DO
435      ENDIF
[6140]436      !
[4486]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)
[5656]440            ! Specified fluxes:
[4486]441            va_e(ji,nlcj-2) = vbdy_n(ji) * hvr_e(ji,nlcj-2)
[5656]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)) )
[4486]445         END DO
446      ENDIF
447      !
448   END SUBROUTINE Agrif_dyn_ts
449
[6140]450
[4486]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
[4292]460      !!---------------------------------------------------------------------- 
[6140]461      !
[4292]462      IF( Agrif_Root() )   RETURN
[6140]463      !
464      ll_int_cons = ln_bt_fw ! Assume conservative temporal integration in the forward case only
465      !
[8741]466      ! Enforce volume conservation if no time refinement: 
467      IF ( Agrif_rhot()==1 ) ll_int_cons=.TRUE. 
[6140]468      !
[4486]469      ! Interpolate barotropic fluxes
[8741]470      Agrif_SpecialValue=0._wp
[4486]471      Agrif_UseSpecialValue = ln_spc_dyn
[6140]472      !
473      IF( ll_int_cons ) THEN  ! Conservative interpolation
[5656]474         ! orders matters here !!!!!!
[6140]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 )
[5656]477         bdy_tinterp = 1
[6140]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  )
[5656]480         bdy_tinterp = 2
[6140]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  )         
[4486]483      ELSE ! Linear interpolation
[5656]484         bdy_tinterp = 0
[6140]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
[8741]489         CALL Agrif_Bc_variable( unb_id, procname=interpunb )
490         CALL Agrif_Bc_variable( vnb_id, procname=interpvnb )
[4486]491      ENDIF
492      Agrif_UseSpecialValue = .FALSE.
[5656]493      !
[4486]494   END SUBROUTINE Agrif_dta_ts
495
[6140]496
[2486]497   SUBROUTINE Agrif_ssh( kt )
498      !!----------------------------------------------------------------------
[8741]499      !!                  ***  ROUTINE Agrif_ssh  ***
[2486]500      !!---------------------------------------------------------------------- 
501      INTEGER, INTENT(in) ::   kt
502      !!
[8741]503      INTEGER :: ji, jj
[2486]504      !!---------------------------------------------------------------------- 
[6140]505      !
[2486]506      IF( Agrif_Root() )   RETURN
[8741]507      !     
508      ! Linear interpolation in time of sea level
[6140]509      !
[8741]510      Agrif_SpecialValue    = 0._wp
511      Agrif_UseSpecialValue = .TRUE.
512      CALL Agrif_Bc_variable(sshn_id, procname=interpsshn )
513      Agrif_UseSpecialValue = .FALSE.
514      !
[2486]515      IF((nbondi == -1).OR.(nbondi == 2)) THEN
[8741]516         DO jj=1,jpj
517            ssha(2,jj) = hbdy_w(jj)
518         END DO
[2486]519      ENDIF
[6140]520      !
[2486]521      IF((nbondi == 1).OR.(nbondi == 2)) THEN
[8741]522         DO jj=1,jpj
523            ssha(nlci-1,jj) = hbdy_e(jj)
524         END DO
[2486]525      ENDIF
[6140]526      !
[2486]527      IF((nbondj == -1).OR.(nbondj == 2)) THEN
[8741]528         DO ji=1,jpi
529            ssha(ji,2) = hbdy_s(ji)
530         END DO
[2486]531      ENDIF
[6140]532      !
[2486]533      IF((nbondj == 1).OR.(nbondj == 2)) THEN
[8741]534         DO ji=1,jpi
535            ssha(ji,nlcj-1) = hbdy_n(ji)
536         END DO
[2486]537      ENDIF
[6140]538      !
[2486]539   END SUBROUTINE Agrif_ssh
540
[6140]541
[4486]542   SUBROUTINE Agrif_ssh_ts( jn )
[4292]543      !!----------------------------------------------------------------------
544      !!                  ***  ROUTINE Agrif_ssh_ts  ***
545      !!---------------------------------------------------------------------- 
[4486]546      INTEGER, INTENT(in) ::   jn
[4292]547      !!
[4486]548      INTEGER :: ji,jj
[4292]549      !!---------------------------------------------------------------------- 
[6140]550      !
[8741]551      !
552      IF( Agrif_Root() )   RETURN
553      !
[4292]554      IF((nbondi == -1).OR.(nbondi == 2)) THEN
[6140]555         DO jj = 1, jpj
[4486]556            ssha_e(2,jj) = hbdy_w(jj)
557         END DO
[4292]558      ENDIF
[6140]559      !
[4292]560      IF((nbondi == 1).OR.(nbondi == 2)) THEN
[6140]561         DO jj = 1, jpj
[4486]562            ssha_e(nlci-1,jj) = hbdy_e(jj)
563         END DO
[4292]564      ENDIF
[6140]565      !
[4292]566      IF((nbondj == -1).OR.(nbondj == 2)) THEN
[6140]567         DO ji = 1, jpi
[4486]568            ssha_e(ji,2) = hbdy_s(ji)
569         END DO
[4292]570      ENDIF
[6140]571      !
[4292]572      IF((nbondj == 1).OR.(nbondj == 2)) THEN
[6140]573         DO ji = 1, jpi
[4486]574            ssha_e(ji,nlcj-1) = hbdy_n(ji)
575         END DO
[4292]576      ENDIF
[6140]577      !
[4292]578   END SUBROUTINE Agrif_ssh_ts
579
[8741]580# if defined key_zdftke || defined key_zdfgls
[6140]581
[8741]582   SUBROUTINE Agrif_avm
[4292]583      !!----------------------------------------------------------------------
[8741]584      !!                  ***  ROUTINE Agrif_avm  ***
[5656]585      !!---------------------------------------------------------------------- 
586      REAL(wp) ::   zalpha
[6140]587      !!---------------------------------------------------------------------- 
[5656]588      !
[8741]589      IF( Agrif_Root() )   RETURN
[6140]590      !
[8741]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      !
[5656]596      Agrif_SpecialValue    = 0.e0
597      Agrif_UseSpecialValue = .TRUE.
[6140]598      !
[5656]599      CALL Agrif_Bc_variable(avm_id ,calledweight=zalpha, procname=interpavm)       
[6140]600      !
[5656]601      Agrif_UseSpecialValue = .FALSE.
602      !
[8741]603   END SUBROUTINE Agrif_avm
[6140]604   
[5656]605# endif
606
[6140]607   SUBROUTINE interptsn( ptab, i1, i2, j1, j2, k1, k2, n1, n2, before, nb, ndir )
608      !!----------------------------------------------------------------------
[5656]609      !!   *** ROUTINE interptsn ***
[6140]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
[5656]615      !
616      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices
[6140]617      INTEGER  ::   imin, imax, jmin, jmax
[5656]618      REAL(wp) ::   zrhox , zalpha1, zalpha2, zalpha3
619      REAL(wp) ::   zalpha4, zalpha5, zalpha6, zalpha7
[6140]620      LOGICAL  ::   western_side, eastern_side,northern_side,southern_side
621      !!----------------------------------------------------------------------
622      !
[5656]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
[8965]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
[5656]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         !
[6140]667         IF( eastern_side ) THEN
[5656]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
[6140]672                     IF( umask(nlci-2,jj,jk) == 0._wp ) THEN
[5656]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)
[6140]676                        IF( un(nlci-2,jj,jk) > 0._wp ) THEN
[5656]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
[5930]683               tsa(nlci,j1:j2,k1:k2,jn) = 0._wp
[6140]684            END DO
[5656]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
[6140]692                     IF( vmask(ji,nlcj-2,jk) == 0._wp ) THEN
[5656]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)       
[6140]696                        IF (vn(ji,nlcj-2,jk) > 0._wp ) THEN
[5656]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
[5930]703               tsa(i1:i2,nlcj,k1:k2,jn) = 0._wp
[6140]704            END DO
[5656]705         ENDIF
706         !
[6140]707         IF( western_side ) THEN           
[5656]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
[6140]712                     IF( umask(2,jj,jk) == 0._wp ) THEN
[5656]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)       
[6140]716                        IF( un(2,jj,jk) < 0._wp ) THEN
[5656]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
[5930]722               tsa(1,j1:j2,k1:k2,jn) = 0._wp
[5656]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)
[6140]729               DO jk = 1, jpk     
[5656]730                  DO ji=imin,imax
[6140]731                     IF( vmask(ji,2,jk) == 0._wp ) THEN
[5656]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)
[6140]735                        IF( vn(ji,2,jk) < 0._wp ) THEN
[5656]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
[5930]741               tsa(i1:i2,1,k1:k2,jn) = 0._wp
[6140]742            END DO
[5656]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
[6140]768
769   SUBROUTINE interpsshn( ptab, i1, i2, j1, j2, before, nb, ndir )
[5656]770      !!----------------------------------------------------------------------
[4292]771      !!                  ***  ROUTINE interpsshn  ***
772      !!---------------------------------------------------------------------- 
[6140]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      !
[5656]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
[6140]796
797   SUBROUTINE interpun( ptab, i1, i2, j1, j2, k1, k2, before )
798      !!----------------------------------------------------------------------
[5656]799      !!   *** ROUTINE interpun ***
[6140]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
[5656]804      !
[6140]805      INTEGER  ::   ji, jj, jk
806      REAL(wp) ::   zrhoy 
807      !!----------------------------------------------------------------------
808      !
809      IF( before ) THEN
[8741]810         DO jk = 1, jpkm1
[6140]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)
[5656]812         END DO
813      ELSE
814         zrhoy = Agrif_Rhoy()
[6140]815         DO jk = 1, jpkm1
[5656]816            DO jj=j1,j2
[8741]817               ua(i1:i2,jj,jk) = ptab(i1:i2,jj,jk) / ( zrhoy * e2u(i1:i2,jj) * e3u_a(i1:i2,jj,jk) )
[5656]818            END DO
819         END DO
820      ENDIF
821      !
822   END SUBROUTINE interpun
823
[6140]824
825   SUBROUTINE interpvn( ptab, i1, i2, j1, j2, k1, k2, before )
826      !!----------------------------------------------------------------------
[5656]827      !!   *** ROUTINE interpvn ***
[6140]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
[5656]832      !
[6140]833      INTEGER  ::   ji, jj, jk
834      REAL(wp) ::   zrhox 
835      !!----------------------------------------------------------------------
[5656]836      !     
[8741]837      IF( before ) THEN 
838         DO jk = 1, jpkm1
[6140]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)
[5656]840         END DO
841      ELSE         
842         zrhox= Agrif_Rhox()
[6140]843         DO jk = 1, jpkm1
[8741]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) )
[5656]845         END DO
846      ENDIF
847      !       
848   END SUBROUTINE interpvn
[6140]849   
[636]850
[6140]851   SUBROUTINE interpunb( ptab, i1, i2, j1, j2, before, nb, ndir )
[1605]852      !!----------------------------------------------------------------------
[5656]853      !!                  ***  ROUTINE interpunb  ***
[1605]854      !!---------------------------------------------------------------------- 
[6140]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
[1605]863      !!---------------------------------------------------------------------- 
[5656]864      !
[6140]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)
[5656]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)        &
[6140]880               &               - zt0**2._wp * (       zt0 - 1._wp)        )
[5656]881         ELSEIF( bdy_tinterp == 2 ) THEN
882            ztcoeff = zrhot * (  zt1        * (       zt1 - 1._wp)**2._wp &
[6140]883               &               - zt0        * (       zt0 - 1._wp)**2._wp ) 
[636]884
[5656]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
[6140]904               ubdy_w(j1:j2) = ubdy_w(j1:j2) / (zrhoy*e2u(i1,j1:j2)) * umask(i1,j1:j2,1)
[5656]905            ENDIF
906            IF(eastern_side) THEN
[6140]907               ubdy_e(j1:j2) = ubdy_e(j1:j2) / (zrhoy*e2u(i1,j1:j2)) * umask(i1,j1:j2,1)
[5656]908            ENDIF
909            IF(southern_side) THEN
[6140]910               ubdy_s(i1:i2) = ubdy_s(i1:i2) / (zrhoy*e2u(i1:i2,j1)) * umask(i1:i2,j1,1)
[5656]911            ENDIF
912            IF(northern_side) THEN
[6140]913               ubdy_n(i1:i2) = ubdy_n(i1:i2) / (zrhoy*e2u(i1:i2,j1)) * umask(i1:i2,j1,1)
[5656]914            ENDIF
915         ENDIF
916      ENDIF
917      !
918   END SUBROUTINE interpunb
[636]919
[6140]920
921   SUBROUTINE interpvnb( ptab, i1, i2, j1, j2, before, nb, ndir )
[1605]922      !!----------------------------------------------------------------------
[5656]923      !!                  ***  ROUTINE interpvnb  ***
[1605]924      !!---------------------------------------------------------------------- 
[6140]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
[1605]933      !!---------------------------------------------------------------------- 
[5656]934      !
[6140]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)
[5656]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)        &
[6140]949               &               - zt0**2._wp * (       zt0 - 1._wp)        )
[5656]950         ELSEIF( bdy_tinterp == 2 ) THEN
951            ztcoeff = zrhot * (  zt1        * (       zt1 - 1._wp)**2._wp &
[6140]952               &               - zt0        * (       zt0 - 1._wp)**2._wp ) 
[5656]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
[390]991
[6140]992
993   SUBROUTINE interpub2b( ptab, i1, i2, j1, j2, before, nb, ndir )
[1605]994      !!----------------------------------------------------------------------
[5656]995      !!                  ***  ROUTINE interpub2b  ***
[1605]996      !!---------------------------------------------------------------------- 
[6140]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
[1605]1005      !!---------------------------------------------------------------------- 
[5656]1006      IF( before ) THEN
[8741]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
[5656]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:
[6140]1022         zat = zrhot * (  zt1**2._wp * (-2._wp*zt1 + 3._wp)    &
1023            &           - zt0**2._wp * (-2._wp*zt0 + 3._wp)    ) 
[5656]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
[6140]1032   
[636]1033
[6140]1034   SUBROUTINE interpvb2b( ptab, i1, i2, j1, j2, before, nb, ndir )
[4292]1035      !!----------------------------------------------------------------------
[5656]1036      !!                  ***  ROUTINE interpvb2b  ***
[4292]1037      !!---------------------------------------------------------------------- 
[6140]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
[4292]1046      !!---------------------------------------------------------------------- 
[5656]1047      !
1048      IF( before ) THEN
[8741]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
[5656]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:
[6140]1064         zat = zrhot * (  zt1**2._wp * (-2._wp*zt1 + 3._wp)    &
1065            &           - zt0**2._wp * (-2._wp*zt0 + 3._wp)    ) 
[5656]1066         !
[6140]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) 
[5656]1071      ENDIF
1072      !     
1073   END SUBROUTINE interpvb2b
[4292]1074
[6140]1075
1076   SUBROUTINE interpe3t( ptab, i1, i2, j1, j2, k1, k2, before, nb, ndir )
[5656]1077      !!----------------------------------------------------------------------
1078      !!                  ***  ROUTINE interpe3t  ***
1079      !!---------------------------------------------------------------------- 
[6140]1080      INTEGER                              , INTENT(in   ) :: i1, i2, j1, j2, k1, k2
[5656]1081      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab
[6140]1082      LOGICAL                              , INTENT(in   ) :: before
1083      INTEGER                              , INTENT(in   ) :: nb , ndir
[5656]1084      !
1085      INTEGER :: ji, jj, jk
1086      LOGICAL :: western_side, eastern_side, northern_side, southern_side
1087      REAL(wp) :: ztmpmsk     
1088      !!---------------------------------------------------------------------- 
1089      !   
[6140]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)
[5656]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)
[4292]1097
[6140]1098         DO jk = k1, k2
1099            DO jj = j1, j2
1100               DO ji = i1, i2
[5656]1101                  ! Get velocity mask at boundary edge points:
[6140]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
[5656]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
[6140]1117                     WRITE(numout,*) '      ptab(ji,jj,jk), e3t(ji,jj,jk) ', ptab(ji,jj,jk), e3t_0(ji,jj,jk)
[5656]1118                     kindic_agr = kindic_agr + 1
1119                  ENDIF
1120               END DO
1121            END DO
1122         END DO
[6140]1123         !
[5656]1124      ENDIF
1125      !
1126   END SUBROUTINE interpe3t
1127
[6140]1128
1129   SUBROUTINE interpumsk( ptab, i1, i2, j1, j2, k1, k2, before, nb, ndir )
[4292]1130      !!----------------------------------------------------------------------
[5656]1131      !!                  ***  ROUTINE interpumsk  ***
[4292]1132      !!---------------------------------------------------------------------- 
[6140]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
[5656]1137      !
[6140]1138      INTEGER ::   ji, jj, jk
1139      LOGICAL ::   western_side, eastern_side   
[4292]1140      !!---------------------------------------------------------------------- 
[5656]1141      !   
[6140]1142      IF( before ) THEN
1143         ptab(i1:i2,j1:j2,k1:k2) = umask(i1:i2,j1:j2,k1:k2)
[5656]1144      ELSE
[6140]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
[5656]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
[4292]1164         END DO
[6140]1165         !
[5656]1166      ENDIF
1167      !
1168   END SUBROUTINE interpumsk
[4292]1169
[6140]1170
1171   SUBROUTINE interpvmsk( ptab, i1, i2, j1, j2, k1, k2, before, nb, ndir )
[4486]1172      !!----------------------------------------------------------------------
[5656]1173      !!                  ***  ROUTINE interpvmsk  ***
[4486]1174      !!---------------------------------------------------------------------- 
[6140]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
[5656]1179      !
[6140]1180      INTEGER ::   ji, jj, jk
1181      LOGICAL ::   northern_side, southern_side     
[4486]1182      !!---------------------------------------------------------------------- 
[5656]1183      !   
[6140]1184      IF( before ) THEN
1185         ptab(i1:i2,j1:j2,k1:k2) = vmask(i1:i2,j1:j2,k1:k2)
[5656]1186      ELSE
1187         southern_side = (nb == 2).AND.(ndir == 1)
1188         northern_side = (nb == 2).AND.(ndir == 2)
[6140]1189         DO jk = k1, k2
1190            DO jj = j1, j2
1191               DO ji = i1, i2
[5656]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
[4486]1206         END DO
[6140]1207         !
[5656]1208      ENDIF
1209      !
1210   END SUBROUTINE interpvmsk
[4486]1211
[8741]1212# if defined key_zdftke || defined key_zdfgls
[5656]1213
[6140]1214   SUBROUTINE interpavm( ptab, i1, i2, j1, j2, k1, k2, before )
[4486]1215      !!----------------------------------------------------------------------
[5656]1216      !!                  ***  ROUTINE interavm  ***
[4486]1217      !!---------------------------------------------------------------------- 
[6140]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
[4486]1221      !!---------------------------------------------------------------------- 
[5656]1222      !     
[6140]1223      IF( before ) THEN
[5656]1224         ptab (i1:i2,j1:j2,k1:k2) = avm_k(i1:i2,j1:j2,k1:k2)
1225      ELSE
[8741]1226         avm  (i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2)
[5656]1227      ENDIF
1228      !
1229   END SUBROUTINE interpavm
[4486]1230
[8741]1231# endif /* key_zdftke || key_zdfgls */
[4486]1232
[390]1233#else
[1605]1234   !!----------------------------------------------------------------------
1235   !!   Empty module                                          no AGRIF zoom
1236   !!----------------------------------------------------------------------
[636]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
[390]1241#endif
[1605]1242
1243   !!======================================================================
[636]1244END MODULE agrif_opa_interp
Note: See TracBrowser for help on using the repository browser.