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_oce_interp.F90 in NEMO/branches/2021/ticket2632_r14588_theta_sbcblk/src/NST – NEMO

source: NEMO/branches/2021/ticket2632_r14588_theta_sbcblk/src/NST/agrif_oce_interp.F90

Last change on this file was 15548, checked in by gsamson, 3 years ago

update branch to the head of the trunk (r15547); ticket #2632

  • Property svn:keywords set to Id
File size: 74.2 KB
RevLine 
[9570]1MODULE agrif_oce_interp
[1605]2   !!======================================================================
[9570]3   !!                   ***  MODULE  agrif_oce_interp  ***
[14227]4   !! AGRIF: interpolation package for the ocean dynamics (OCE)
[1605]5   !!======================================================================
[9019]6   !! History :  2.0  !  2002-06  (L. Debreu)  Original cade
[1605]7   !!            3.2  !  2009-04  (R. Benshila)
[5656]8   !!            3.6  !  2014-09  (R. Benshila)
[1605]9   !!----------------------------------------------------------------------
[7646]10#if defined key_agrif
[1605]11   !!----------------------------------------------------------------------
12   !!   'key_agrif'                                              AGRIF zoom
13   !!----------------------------------------------------------------------
14   !!   Agrif_tra     :
15   !!   Agrif_dyn     :
[9019]16   !!   Agrif_ssh     :
17   !!   Agrif_dyn_ts  :
18   !!   Agrif_dta_ts  :
19   !!   Agrif_ssh_ts  :
20   !!   Agrif_avm     :
[1605]21   !!   interpu       :
22   !!   interpv       :
23   !!----------------------------------------------------------------------
[636]24   USE par_oce
25   USE oce
26   USE dom_oce     
[6140]27   USE zdf_oce
[782]28   USE agrif_oce
[1605]29   USE phycst
[14053]30!!!   USE dynspg_ts, ONLY: un_adv, vn_adv
[6140]31   !
[1605]32   USE in_out_manager
[9570]33   USE agrif_oce_sponge
[2715]34   USE lib_mpp
[12377]35   USE vremap
[13216]36   USE lbclnk
[5656]37 
[636]38   IMPLICIT NONE
39   PRIVATE
[4292]40
[12377]41   PUBLIC   Agrif_dyn, Agrif_ssh, Agrif_dyn_ts, Agrif_dyn_ts_flux, Agrif_ssh_ts, Agrif_dta_ts
[9057]42   PUBLIC   Agrif_tra, Agrif_avm
[9019]43   PUBLIC   interpun , interpvn
[9057]44   PUBLIC   interptsn, interpsshn, interpavm
[9019]45   PUBLIC   interpunb, interpvnb , interpub2b, interpvb2b
[15548]46   PUBLIC   interpglamt, interpgphit
[14086]47   PUBLIC   interpht0, interpmbkt, interpe3t0_vremap
48   PUBLIC   agrif_istate_oce, agrif_istate_ssh   ! called by icestate.F90 and domvvl.F90
49   PUBLIC   agrif_check_bat
[13216]50
[6140]51   INTEGER ::   bdy_tinterp = 0
52
[14053]53   !! * Substitutions
54#  include "domzgr_substitute.h90"
[9598]55   !! NEMO/NST 4.0 , NEMO Consortium (2018)
[1156]56   !! $Id$
[10068]57   !! Software governed by the CeCILL license (see ./LICENSE)
[1156]58   !!----------------------------------------------------------------------
[5656]59CONTAINS
60
[14086]61   SUBROUTINE Agrif_istate_oce( Kbb, Kmm, Kaa )
62      !!----------------------------------------------------------------------
63      !!                 *** ROUTINE agrif_istate_oce ***
64      !!
65      !!                 set initial t, s, u, v, ssh from parent
66      !!----------------------------------------------------------------------
67      !
68      IMPLICIT NONE
69      !
70      INTEGER, INTENT(in)  :: Kbb, Kmm, Kaa
71      INTEGER :: jn
72      !!----------------------------------------------------------------------
73      IF(lwp) WRITE(numout,*) ' '
74      IF(lwp) WRITE(numout,*) 'Agrif_istate_oce : interp child initial state from parent'
75      IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~~~'
76      IF(lwp) WRITE(numout,*) ' '
77
78      IF ( .NOT.Agrif_Parent(l_1st_euler) ) & 
79         & CALL ctl_stop('AGRIF hot start requires to force Euler first step on parent')
80
81      l_ini_child           = .TRUE.
82      Agrif_SpecialValue    = 0.0_wp
83      Agrif_UseSpecialValue = .TRUE.
84
[14170]85      ts(:,:,:,:,Kbb) = 0.0_wp
86      uu(:,:,:,Kbb)   = 0.0_wp
87      vv(:,:,:,Kbb)   = 0.0_wp 
[14086]88       
89      Krhs_a = Kbb   ;   Kmm_a = Kbb
90
91      CALL Agrif_Init_Variable(tsini_id, procname=interptsn)
92
93      Agrif_UseSpecialValue = ln_spc_dyn
94      use_sign_north = .TRUE.
95      sign_north = -1._wp
96      CALL Agrif_Init_Variable(uini_id , procname=interpun )
97      CALL Agrif_Init_Variable(vini_id , procname=interpvn )
98      use_sign_north = .FALSE.
99
100      Agrif_UseSpecialValue = .FALSE.
101      l_ini_child           = .FALSE.
102
103      Krhs_a = Kaa   ;   Kmm_a = Kmm
104
105      DO jn = 1, jpts
106         ts(:,:,:,jn,Kbb) = ts(:,:,:,jn,Kbb) * tmask(:,:,:)
107      END DO
108      uu(:,:,:,Kbb) = uu(:,:,:,Kbb) * umask(:,:,:)     
109      vv(:,:,:,Kbb) = vv(:,:,:,Kbb) * vmask(:,:,:) 
110
[14433]111      CALL lbc_lnk( 'agrif_istate_oce', uu(:,:,:  ,Kbb), 'U', -1.0_wp , vv(:,:,:,Kbb), 'V', -1.0_wp )
[14086]112      CALL lbc_lnk( 'agrif_istate_oce', ts(:,:,:,:,Kbb), 'T',  1.0_wp )
113
114   END SUBROUTINE Agrif_istate_oce
115
116
[14170]117   SUBROUTINE Agrif_istate_ssh( Kbb, Kmm, Kaa )
[14086]118      !!----------------------------------------------------------------------
119      !!                 *** ROUTINE agrif_istate_ssh ***
120      !!
121      !!                    set initial ssh from parent
122      !!----------------------------------------------------------------------
123      !
124      IMPLICIT NONE
125      !
[14170]126      INTEGER, INTENT(in)  :: Kbb, Kmm, Kaa 
[14086]127      !!----------------------------------------------------------------------
128      IF(lwp) WRITE(numout,*) ' '
129      IF(lwp) WRITE(numout,*) 'Agrif_istate_ssh : interp child ssh from parent'
130      IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~~~'
131      IF(lwp) WRITE(numout,*) ' '
132
133      IF ( .NOT.Agrif_Parent(l_1st_euler) ) & 
134         & CALL ctl_stop('AGRIF hot start requires to force Euler first step on parent')
135
[14170]136      Krhs_a = Kbb   ;   Kmm_a = Kbb
137      !
[14086]138      Agrif_SpecialValue    = 0._wp
139      Agrif_UseSpecialValue = .TRUE.
140      l_ini_child           = .TRUE.
141      !
[14170]142      ssh(:,:,Kbb) = 0._wp
[14086]143      CALL Agrif_Init_Variable(sshini_id, procname=interpsshn)
144      !
145      Agrif_UseSpecialValue = .FALSE.
146      l_ini_child           = .FALSE.
[14170]147      !
148      Krhs_a = Kaa   ;   Kmm_a = Kmm
149      !
150      CALL lbc_lnk( 'Agrif_istate_ssh', ssh(:,:,Kbb), 'T', 1._wp )
151      !
152      ssh(:,:,Kmm) = ssh(:,:,Kbb)
153      ssh(:,:,Kaa) = 0._wp
[14086]154
155   END SUBROUTINE Agrif_istate_ssh
156
157
[782]158   SUBROUTINE Agrif_tra
[1605]159      !!----------------------------------------------------------------------
[5656]160      !!                  ***  ROUTINE Agrif_tra  ***
[1605]161      !!----------------------------------------------------------------------
[636]162      !
[1605]163      IF( Agrif_Root() )   RETURN
[6140]164      !
165      Agrif_SpecialValue    = 0._wp
[636]166      Agrif_UseSpecialValue = .TRUE.
[14086]167      l_vremap           = ln_vert_remap
[6140]168      !
[14086]169      CALL Agrif_Bc_variable( ts_interp_id, procname=interptsn )
[6140]170      !
[636]171      Agrif_UseSpecialValue = .FALSE.
[14086]172      l_vremap              = .FALSE.
[1605]173      !
[636]174   END SUBROUTINE Agrif_tra
175
[1605]176
[636]177   SUBROUTINE Agrif_dyn( kt )
[1605]178      !!----------------------------------------------------------------------
179      !!                  ***  ROUTINE Agrif_DYN  ***
180      !!---------------------------------------------------------------------- 
181      INTEGER, INTENT(in) ::   kt
[6140]182      !
183      INTEGER ::   ji, jj, jk       ! dummy loop indices
[9057]184      INTEGER ::   ibdy1, jbdy1, ibdy2, jbdy2
[9019]185      REAL(wp), DIMENSION(jpi,jpj) ::   zub, zvb
[1605]186      !!---------------------------------------------------------------------- 
[6140]187      !
[1605]188      IF( Agrif_Root() )   RETURN
[6140]189      !
[13286]190      Agrif_SpecialValue    = 0.0_wp
[5656]191      Agrif_UseSpecialValue = ln_spc_dyn
[14086]192      l_vremap              = ln_vert_remap
[6140]193      !
[13216]194      use_sign_north = .TRUE.
[13286]195      sign_north = -1.0_wp
[6140]196      CALL Agrif_Bc_variable( un_interp_id, procname=interpun )
197      CALL Agrif_Bc_variable( vn_interp_id, procname=interpvn )
[14086]198
199      IF( .NOT.ln_dynspg_ts ) THEN ! Get transports
[14170]200         ubdy(:,:) = 0._wp    ;  vbdy(:,:) = 0._wp
201         utint_stage(:,:) = 0 ;  vtint_stage(:,:) = 0
[14086]202         CALL Agrif_Bc_variable( unb_interp_id, procname=interpunb )
203         CALL Agrif_Bc_variable( vnb_interp_id, procname=interpvnb )
204      ENDIF
205
[13216]206      use_sign_north = .FALSE.
[6140]207      !
[5656]208      Agrif_UseSpecialValue = .FALSE.
[14086]209      l_vremap              = .FALSE.
[6140]210      !
[14086]211      ! Ensure below that vertically integrated transports match
212      ! either transports out of time splitting procedure (ln_dynspg_ts=.TRUE.)
213      ! or parent grid transports (ln_dynspg_ts=.FALSE.)
214      !
[12377]215      ! --- West --- !
[13216]216      IF( lk_west ) THEN
[13286]217         ibdy1 = nn_hls + 2                  ! halo + land + 1
[15548]218         ibdy2 = nn_hls + nbghostcells + nn_shift_bar*Agrif_Rhox()   ! halo + land + nbghostcells
[13216]219         !
220         IF( .NOT.ln_dynspg_ts ) THEN  ! Store transport
221            DO ji = mi0(ibdy1), mi1(ibdy2)
[6140]222               DO jj = 1, jpj
[14086]223                  uu_b(ji,jj,Krhs_a) = ubdy(ji,jj) * r1_hu(ji,jj,Krhs_a)
224                  vv_b(ji,jj,Krhs_a) = vbdy(ji,jj) * r1_hv(ji,jj,Krhs_a)
[5930]225               END DO
[636]226            END DO
[13216]227         ENDIF
228         !
[12377]229         DO ji = mi0(ibdy1), mi1(ibdy2)
[14086]230            zub(ji,:) = 0._wp 
[9019]231            DO jk = 1, jpkm1
232               DO jj = 1, jpj
[13286]233                  zub(ji,jj) = zub(ji,jj) + e3u(ji,jj,jk,Krhs_a)  * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk)
[9019]234               END DO
[636]235            END DO
[13216]236            DO jj=1,jpj
237               zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a)
[13286]238            END DO
[6140]239            DO jk = 1, jpkm1
240               DO jj = 1, jpj
[13286]241                  uu(ji,jj,jk,Krhs_a) = ( uu(ji,jj,jk,Krhs_a) + uu_b(ji,jj,Krhs_a) - zub(ji,jj) ) * umask(ji,jj,jk)
[5930]242               END DO
243            END DO
[12377]244         END DO
[13286]245         !   
[14086]246         DO ji = mi0(ibdy1), mi1(ibdy2)
247            zvb(ji,:) = 0._wp
248            DO jk = 1, jpkm1
249               DO jj = 1, jpj
250                  zvb(ji,jj) = zvb(ji,jj) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk)
[13216]251               END DO
[14086]252            END DO
253            DO jj = 1, jpj
254               zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a)
255            END DO
256            DO jk = 1, jpkm1
[13216]257               DO jj = 1, jpj
[14086]258                  vv(ji,jj,jk,Krhs_a) = ( vv(ji,jj,jk,Krhs_a) + vv_b(ji,jj,Krhs_a) - zvb(ji,jj) )*vmask(ji,jj,jk)
[13216]259               END DO
260            END DO
[14086]261         END DO
[13286]262         !
[636]263      ENDIF
[390]264
[9019]265      ! --- East --- !
[13216]266      IF( lk_east) THEN
[15548]267         ibdy1 = jpiglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhox()   
[14086]268         ibdy2 = jpiglo - ( nn_hls + 2 )                 
[13216]269         !
[14086]270         IF( .NOT.ln_dynspg_ts ) THEN
[13216]271            DO ji = mi0(ibdy1), mi1(ibdy2)
[9057]272               DO jj = 1, jpj
[14086]273                  uu_b(ji,jj,Krhs_a) = ubdy(ji,jj) * r1_hu(ji,jj,Krhs_a)
[5930]274               END DO
[636]275            END DO
[13216]276         ENDIF
277         !
[12377]278         DO ji = mi0(ibdy1), mi1(ibdy2)
[14086]279            zub(ji,:) = 0._wp   
[6140]280            DO jk = 1, jpkm1
281               DO jj = 1, jpj
[13286]282                  zub(ji,jj) = zub(ji,jj) + e3u(ji,jj,jk,Krhs_a)  * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk)
[5930]283               END DO
284            END DO
[13216]285            DO jj=1,jpj
286               zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a)
[4486]287            END DO
[6140]288            DO jk = 1, jpkm1
289               DO jj = 1, jpj
[13286]290                  uu(ji,jj,jk,Krhs_a) = ( uu(ji,jj,jk,Krhs_a) + uu_b(ji,jj,Krhs_a) - zub(ji,jj) ) * umask(ji,jj,jk)
[5930]291               END DO
292            END DO
[12377]293         END DO
[13286]294         !
[15548]295         ibdy1 = jpiglo - ( nn_hls + nbghostcells - 1 ) - nn_shift_bar*Agrif_Rhox() 
[14170]296         ibdy2 = jpiglo - ( nn_hls + 1 )     
297         !
[14086]298         IF( .NOT.ln_dynspg_ts ) THEN
[13216]299            DO ji = mi0(ibdy1), mi1(ibdy2)
300               DO jj = 1, jpj
[14086]301                  vv_b(ji,jj,Krhs_a) = vbdy(ji,jj) * r1_hv(ji,jj,Krhs_a)
[13216]302               END DO
[14086]303            END DO
304         ENDIF
[14170]305         !
[14086]306         DO ji = mi0(ibdy1), mi1(ibdy2)
307            zvb(ji,:) = 0._wp
308            DO jk = 1, jpkm1
309               DO jj = 1, jpj
310                     zvb(ji,jj) = zvb(ji,jj) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk)
311               END DO
312            END DO
313            DO jj = 1, jpj
314               zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a)
315            END DO
316            DO jk = 1, jpkm1
317               DO jj = 1, jpj
[13286]318                     vv(ji,jj,jk,Krhs_a) = ( vv(ji,jj,jk,Krhs_a) + vv_b(ji,jj,Krhs_a) - zvb(ji,jj) ) * vmask(ji,jj,jk)
[13216]319               END DO
320            END DO
[14086]321         END DO
[13286]322         !
[636]323      ENDIF
[390]324
[9019]325      ! --- South --- !
[13216]326      IF( lk_south ) THEN
[14086]327         jbdy1 = nn_hls + 2                 
[15548]328         jbdy2 = nn_hls + nbghostcells + nn_shift_bar*Agrif_Rhoy()   
[13216]329         !
[14086]330         IF( .NOT.ln_dynspg_ts ) THEN
[13216]331            DO jj = mj0(jbdy1), mj1(jbdy2)
[14170]332               DO ji = 1, jpi
333                  uu_b(ji,jj,Krhs_a) = ubdy(ji,jj) * r1_hu(ji,jj,Krhs_a)
334                  vv_b(ji,jj,Krhs_a) = vbdy(ji,jj) * r1_hv(ji,jj,Krhs_a)
[13216]335               END DO
336            END DO
337         ENDIF
338         !
[12377]339         DO jj = mj0(jbdy1), mj1(jbdy2)
[14086]340            zvb(:,jj) = 0._wp
[13216]341            DO jk=1,jpkm1
342               DO ji=1,jpi
[13286]343                  zvb(ji,jj) = zvb(ji,jj) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk)
[5930]344               END DO
[636]345            END DO
[13216]346            DO ji = 1, jpi
347               zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a)
[636]348            END DO
[6140]349            DO jk = 1, jpkm1
350               DO ji = 1, jpi
[13286]351                  vv(ji,jj,jk,Krhs_a) = ( vv(ji,jj,jk,Krhs_a) + vv_b(ji,jj,Krhs_a) - zvb(ji,jj) ) * vmask(ji,jj,jk)
[5930]352               END DO
353            END DO
[13216]354         END DO
[13286]355         !
[14086]356         DO jj = mj0(jbdy1), mj1(jbdy2)
357            zub(:,jj) = 0._wp
358            DO jk = 1, jpkm1
359               DO ji = 1, jpi
360                  zub(ji,jj) = zub(ji,jj) + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk)
[13216]361               END DO
[14086]362            END DO
363            DO ji = 1, jpi
364               zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a)
365            END DO
366            DO jk = 1, jpkm1
[6140]367               DO ji = 1, jpi
[14086]368                  uu(ji,jj,jk,Krhs_a) = ( uu(ji,jj,jk,Krhs_a) + uu_b(ji,jj,Krhs_a) - zub(ji,jj) ) * umask(ji,jj,jk)
[5930]369               END DO
[9057]370            END DO
[14086]371         END DO
[13286]372         !
[636]373      ENDIF
[390]374
[9019]375      ! --- North --- !
[13216]376      IF( lk_north ) THEN
[15548]377         jbdy1 = jpjglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhoy() 
[14086]378         jbdy2 = jpjglo - ( nn_hls + 2 )
[13216]379         !
[14086]380         IF( .NOT.ln_dynspg_ts ) THEN
[13216]381            DO jj = mj0(jbdy1), mj1(jbdy2)
[14170]382               DO ji = 1, jpi
[14086]383                  vv_b(ji,jj,Krhs_a) = vbdy(ji,jj) * r1_hv(ji,jj,Krhs_a)
[13216]384               END DO
385            END DO
386         ENDIF
387         !
[12377]388         DO jj = mj0(jbdy1), mj1(jbdy2)
[14086]389            zvb(:,jj) = 0._wp 
[13216]390            DO jk=1,jpkm1
391               DO ji=1,jpi
[13286]392                  zvb(ji,jj) = zvb(ji,jj) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk)
[5930]393               END DO
[636]394            END DO
[13216]395            DO ji = 1, jpi
396               zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a)
[636]397            END DO
[9057]398            DO jk = 1, jpkm1
399               DO ji = 1, jpi
[13286]400                  vv(ji,jj,jk,Krhs_a) = ( vv(ji,jj,jk,Krhs_a) + vv_b(ji,jj,Krhs_a) - zvb(ji,jj) ) * vmask(ji,jj,jk)
[9057]401               END DO
402            END DO
[13216]403         END DO
[13286]404         !
[15548]405         jbdy1 = jpjglo - ( nn_hls + nbghostcells -1 ) - nn_shift_bar*Agrif_Rhoy() 
[14086]406         jbdy2 = jpjglo - ( nn_hls + 1 )
[14170]407         !
[14086]408         IF( .NOT.ln_dynspg_ts ) THEN
[13216]409            DO jj = mj0(jbdy1), mj1(jbdy2)
[14170]410               DO ji = 1, jpi
[14086]411                  uu_b(ji,jj,Krhs_a) = ubdy(ji,jj) * r1_hu(ji,jj,Krhs_a)
412               END DO
413            END DO
414         ENDIF
[14170]415         !
[14086]416         DO jj = mj0(jbdy1), mj1(jbdy2)
417            zub(:,jj) = 0._wp
418            DO jk = 1, jpkm1
[6140]419               DO ji = 1, jpi
[14086]420                  zub(ji,jj) = zub(ji,jj) + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk)
[5930]421               END DO
[14086]422            END DO
423            DO ji = 1, jpi
424               zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a)
425            END DO
426            DO jk = 1, jpkm1
427               DO ji = 1, jpi
[13286]428                     uu(ji,jj,jk,Krhs_a) = ( uu(ji,jj,jk,Krhs_a) + uu_b(ji,jj,Krhs_a) - zub(ji,jj) ) * umask(ji,jj,jk)
[13216]429               END DO
[5930]430            END DO
[14086]431         END DO
[13286]432         !
[636]433      ENDIF
[2715]434      !
[636]435   END SUBROUTINE Agrif_dyn
[390]436
[6140]437
[4486]438   SUBROUTINE Agrif_dyn_ts( jn )
[4292]439      !!----------------------------------------------------------------------
440      !!                  ***  ROUTINE Agrif_dyn_ts  ***
441      !!---------------------------------------------------------------------- 
[4486]442      INTEGER, INTENT(in) ::   jn
[4292]443      !!
444      INTEGER :: ji, jj
[12377]445      INTEGER :: istart, iend, jstart, jend
[4486]446      !!---------------------------------------------------------------------- 
[6140]447      !
[4486]448      IF( Agrif_Root() )   RETURN
[9057]449      !
[12377]450      !--- West ---!
[13216]451      IF( lk_west ) THEN
[13286]452         istart = nn_hls + 2                              ! halo + land + 1
[15548]453         iend   = nn_hls + nbghostcells  + nn_shift_bar*Agrif_Rhox()              ! halo + land + nbghostcells
[13216]454         DO ji = mi0(istart), mi1(iend)
455            DO jj=1,jpj
456               va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj)
457               ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj)
458            END DO
[4486]459         END DO
[13216]460      ENDIF
[6140]461      !
[12377]462      !--- East ---!
[13216]463      IF( lk_east ) THEN
[15548]464         istart = jpiglo - ( nn_hls + nbghostcells -1 ) - nn_shift_bar*Agrif_Rhox() 
[14086]465         iend   = jpiglo - ( nn_hls + 1 )               
[13216]466         DO ji = mi0(istart), mi1(iend)
467
468            DO jj=1,jpj
469               va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj)
470            END DO
[4486]471         END DO
[15548]472         istart = jpiglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhox() 
[14086]473         iend   = jpiglo - ( nn_hls + 2 )               
[13216]474         DO ji = mi0(istart), mi1(iend)
475            DO jj=1,jpj
476               ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj)
477            END DO
[12377]478         END DO
[13216]479      ENDIF 
[6140]480      !
[12377]481      !--- South ---!
[13216]482      IF( lk_south ) THEN
[14086]483         jstart = nn_hls + 2                             
[15548]484         jend   = nn_hls + nbghostcells + nn_shift_bar*Agrif_Rhoy()           
[13216]485         DO jj = mj0(jstart), mj1(jend)
486
487            DO ji=1,jpi
488               ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj)
489               va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj)
490            END DO
[4486]491         END DO
[13216]492      ENDIF       
[6140]493      !
[12377]494      !--- North ---!
[13216]495      IF( lk_north ) THEN
[15548]496         jstart = jpjglo - ( nn_hls + nbghostcells -1 ) - nn_shift_bar*Agrif_Rhoy()     
[14086]497         jend   = jpjglo - ( nn_hls + 1 )               
[13216]498         DO jj = mj0(jstart), mj1(jend)
499            DO ji=1,jpi
500               ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj)
501            END DO
[4486]502         END DO
[15548]503         jstart = jpjglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhoy() 
[14086]504         jend   = jpjglo - ( nn_hls + 2 )               
[13216]505         DO jj = mj0(jstart), mj1(jend)
506            DO ji=1,jpi
507               va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj)
508            END DO
[12377]509         END DO
[13216]510      ENDIF 
[4486]511      !
512   END SUBROUTINE Agrif_dyn_ts
513
[13286]514   
[12377]515   SUBROUTINE Agrif_dyn_ts_flux( jn, zu, zv )
516      !!----------------------------------------------------------------------
517      !!                  ***  ROUTINE Agrif_dyn_ts_flux  ***
518      !!---------------------------------------------------------------------- 
519      INTEGER, INTENT(in) ::   jn
520      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   zu, zv
521      !!
522      INTEGER :: ji, jj
523      INTEGER :: istart, iend, jstart, jend
524      !!---------------------------------------------------------------------- 
525      !
526      IF( Agrif_Root() )   RETURN
527      !
528      !--- West ---!
[13216]529      IF( lk_west ) THEN
[14086]530         istart = nn_hls + 2                             
[15548]531         iend   = nn_hls + nbghostcells + nn_shift_bar*Agrif_Rhox() 
[13216]532         DO ji = mi0(istart), mi1(iend)
533            DO jj=1,jpj
534               zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj)
535               zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj)
536            END DO
[12377]537         END DO
[13216]538      ENDIF
[12377]539      !
540      !--- East ---!
[13216]541      IF( lk_east ) THEN
[15548]542         istart = jpiglo - ( nn_hls + nbghostcells -1 ) - nn_shift_bar*Agrif_Rhox()
[14086]543         iend   = jpiglo - ( nn_hls + 1 )                 
[13216]544         DO ji = mi0(istart), mi1(iend)
545            DO jj=1,jpj
546               zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj)
547            END DO
[12377]548         END DO
[15548]549         istart = jpiglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhox() 
[14086]550         iend   = jpiglo - ( nn_hls + 2 )                 
[13216]551         DO ji = mi0(istart), mi1(iend)
552            DO jj=1,jpj
553               zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj)
554            END DO
[12377]555         END DO
[13216]556      ENDIF
[12377]557      !
558      !--- South ---!
[13216]559      IF( lk_south ) THEN
[14086]560         jstart = nn_hls + 2                             
[15548]561         jend   = nn_hls + nbghostcells + nn_shift_bar*Agrif_Rhoy() 
[13216]562         DO jj = mj0(jstart), mj1(jend)
563            DO ji=1,jpi
564               zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj)
565               zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj)
566            END DO
[12377]567         END DO
[13216]568      ENDIF
[12377]569      !
570      !--- North ---!
[13216]571      IF( lk_north ) THEN
[15548]572         jstart = jpjglo - ( nn_hls + nbghostcells -1 ) - nn_shift_bar*Agrif_Rhoy() 
[14086]573         jend   = jpjglo - ( nn_hls + 1 )               
[13216]574         DO jj = mj0(jstart), mj1(jend)
575            DO ji=1,jpi
576               zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj)
577            END DO
[12377]578         END DO
[15548]579         jstart = jpjglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhoy() 
[14086]580         jend   = jpjglo - ( nn_hls + 2 )               
[13216]581         DO jj = mj0(jstart), mj1(jend)
582            DO ji=1,jpi
583               zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj)
584            END DO
[12377]585         END DO
[13216]586      ENDIF
[12377]587      !
588   END SUBROUTINE Agrif_dyn_ts_flux
[6140]589
[13286]590   
[4486]591   SUBROUTINE Agrif_dta_ts( kt )
592      !!----------------------------------------------------------------------
593      !!                  ***  ROUTINE Agrif_dta_ts  ***
594      !!---------------------------------------------------------------------- 
595      INTEGER, INTENT(in) ::   kt
596      !!
597      LOGICAL :: ll_int_cons
[4292]598      !!---------------------------------------------------------------------- 
[6140]599      !
[4292]600      IF( Agrif_Root() )   RETURN
[6140]601      !
602      ll_int_cons = ln_bt_fw ! Assume conservative temporal integration in the forward case only
603      !
[9031]604      ! Enforce volume conservation if no time refinement: 
605      IF ( Agrif_rhot()==1 ) ll_int_cons=.TRUE. 
[6140]606      !
[4486]607      ! Interpolate barotropic fluxes
[12377]608      Agrif_SpecialValue = 0._wp
[4486]609      Agrif_UseSpecialValue = ln_spc_dyn
[13216]610
611      use_sign_north = .TRUE.
612      sign_north = -1.
613
[6140]614      !
[12377]615      ! Set bdy time interpolation stage to 0 (latter incremented locally do deal with corners)
616      utint_stage(:,:) = 0
617      vtint_stage(:,:) = 0
618      !
[6140]619      IF( ll_int_cons ) THEN  ! Conservative interpolation
[14086]620         IF ( lk_tint2d_notinterp ) THEN
[14122]621            Agrif_UseSpecialValue = .FALSE.
[14086]622            CALL Agrif_Bc_variable( ub2b_interp_id, calledweight=1._wp, procname=interpub2b_const )
623            CALL Agrif_Bc_variable( vb2b_interp_id, calledweight=1._wp, procname=interpvb2b_const ) 
624            ! Divergence conserving correction terms:
[14122]625            IF ( Agrif_Rhox()>1 ) CALL Agrif_Bc_variable(    ub2b_cor_id, calledweight=1._wp, procname=ub2b_cor )
626            IF ( Agrif_Rhoy()>1 ) CALL Agrif_Bc_variable(    vb2b_cor_id, calledweight=1._wp, procname=vb2b_cor )
[14086]627         ELSE
628            ! order matters here !!!!!!
629            CALL Agrif_Bc_variable( ub2b_interp_id, calledweight=1._wp, procname=interpub2b ) ! Time integrated
630            CALL Agrif_Bc_variable( vb2b_interp_id, calledweight=1._wp, procname=interpvb2b ) 
631            !
632            bdy_tinterp = 1
633            CALL Agrif_Bc_variable( unb_interp_id , calledweight=1._wp, procname=interpunb  ) ! After
634            CALL Agrif_Bc_variable( vnb_interp_id , calledweight=1._wp, procname=interpvnb  ) 
635            !
636            bdy_tinterp = 2
637            CALL Agrif_Bc_variable( unb_interp_id , calledweight=0._wp, procname=interpunb  ) ! Before
638            CALL Agrif_Bc_variable( vnb_interp_id , calledweight=0._wp, procname=interpvnb  )   
639         ENDIF
[4486]640      ELSE ! Linear interpolation
[12377]641         !
642         ubdy(:,:) = 0._wp   ;   vbdy(:,:) = 0._wp 
[14086]643         CALL Agrif_Bc_variable( unb_interp_id, procname=interpunb )
644         CALL Agrif_Bc_variable( vnb_interp_id, procname=interpvnb )
[4486]645      ENDIF
646      Agrif_UseSpecialValue = .FALSE.
[13216]647      use_sign_north = .FALSE.
[5656]648      !
[4486]649   END SUBROUTINE Agrif_dta_ts
650
[6140]651
[2486]652   SUBROUTINE Agrif_ssh( kt )
653      !!----------------------------------------------------------------------
[9031]654      !!                  ***  ROUTINE Agrif_ssh  ***
[2486]655      !!---------------------------------------------------------------------- 
656      INTEGER, INTENT(in) ::   kt
[9019]657      !
[12377]658      INTEGER  :: ji, jj
659      INTEGER  :: istart, iend, jstart, jend
[2486]660      !!---------------------------------------------------------------------- 
[6140]661      !
[2486]662      IF( Agrif_Root() )   RETURN
[9031]663      !     
[9116]664      ! Linear time interpolation of sea level
[9031]665      !
666      Agrif_SpecialValue    = 0._wp
667      Agrif_UseSpecialValue = .TRUE.
668      CALL Agrif_Bc_variable(sshn_id, procname=interpsshn )
669      Agrif_UseSpecialValue = .FALSE.
670      !
[9116]671      ! --- West --- !
[13216]672      IF(lk_west) THEN
[14086]673         istart = nn_hls + 2                                                          ! halo + land + 1
[15548]674         iend   = nn_hls + nbghostcells + nn_shift_bar*Agrif_Rhox()               ! halo + land + nbghostcells
[13216]675         DO ji = mi0(istart), mi1(iend)
676            DO jj = 1, jpj
677               ssh(ji,jj,Krhs_a) = hbdy(ji,jj)
[13286]678            END DO
679         END DO
[13216]680      ENDIF
[6140]681      !
[9019]682      ! --- East --- !
[13216]683      IF(lk_east) THEN
[15548]684         istart = jpiglo - ( nn_hls + nbghostcells -1 ) - nn_shift_bar*Agrif_Rhox()       ! halo + land + nbghostcells - 1
[14086]685         iend   = jpiglo - ( nn_hls + 1 )                                              ! halo + land + 1            - 1
[13216]686         DO ji = mi0(istart), mi1(iend)
687            DO jj = 1, jpj
688               ssh(ji,jj,Krhs_a) = hbdy(ji,jj)
[13286]689            END DO
690         END DO
[13216]691      ENDIF
[6140]692      !
[9019]693      ! --- South --- !
[13216]694      IF(lk_south) THEN
[14086]695         jstart = nn_hls + 2                                                          ! halo + land + 1
[15548]696         jend   = nn_hls + nbghostcells + nn_shift_bar*Agrif_Rhoy()               ! halo + land + nbghostcells
[13216]697         DO jj = mj0(jstart), mj1(jend)
698            DO ji = 1, jpi
699               ssh(ji,jj,Krhs_a) = hbdy(ji,jj)
[13286]700            END DO
701         END DO
[13216]702      ENDIF
[6140]703      !
[9019]704      ! --- North --- !
[13216]705      IF(lk_north) THEN
[15548]706         jstart = jpjglo - ( nn_hls + nbghostcells -1 ) - nn_shift_bar*Agrif_Rhoy()     ! halo + land + nbghostcells - 1
[14086]707         jend   = jpjglo - ( nn_hls + 1 )                                            ! halo + land + 1            - 1
[13216]708         DO jj = mj0(jstart), mj1(jend)
709            DO ji = 1, jpi
710               ssh(ji,jj,Krhs_a) = hbdy(ji,jj)
[13286]711            END DO
712         END DO
[13216]713      ENDIF
[6140]714      !
[2486]715   END SUBROUTINE Agrif_ssh
716
[6140]717
[4486]718   SUBROUTINE Agrif_ssh_ts( jn )
[4292]719      !!----------------------------------------------------------------------
720      !!                  ***  ROUTINE Agrif_ssh_ts  ***
721      !!---------------------------------------------------------------------- 
[4486]722      INTEGER, INTENT(in) ::   jn
[4292]723      !!
[12377]724      INTEGER :: ji, jj
725      INTEGER  :: istart, iend, jstart, jend
[4292]726      !!---------------------------------------------------------------------- 
[9031]727      !
728      IF( Agrif_Root() )   RETURN
729      !
[9116]730      ! --- West --- !
[13216]731      IF(lk_west) THEN
[14086]732         istart = nn_hls + 2                                                        ! halo + land + 1
[15548]733         iend   = nn_hls + nbghostcells + nn_shift_bar*Agrif_Rhox()             ! halo + land + nbghostcells
[13216]734         DO ji = mi0(istart), mi1(iend)
735            DO jj = 1, jpj
736               ssha_e(ji,jj) = hbdy(ji,jj)
[13286]737            END DO
738         END DO
[13216]739      ENDIF
[6140]740      !
[9116]741      ! --- East --- !
[13216]742      IF(lk_east) THEN
[15548]743         istart = jpiglo - ( nn_hls + nbghostcells -1 ) - nn_shift_bar*Agrif_Rhox()    ! halo + land + nbghostcells - 1
[14086]744         iend   = jpiglo - ( nn_hls + 1 )                                           ! halo + land + 1            - 1
[13216]745         DO ji = mi0(istart), mi1(iend)
746            DO jj = 1, jpj
747               ssha_e(ji,jj) = hbdy(ji,jj)
[13286]748            END DO
749         END DO
[13216]750      ENDIF
[6140]751      !
[9116]752      ! --- South --- !
[13216]753      IF(lk_south) THEN
[14086]754         jstart = nn_hls + 2                                                        ! halo + land + 1
[15548]755         jend   = nn_hls + nbghostcells + nn_shift_bar*Agrif_Rhoy()             ! halo + land + nbghostcells
[13216]756         DO jj = mj0(jstart), mj1(jend)
757            DO ji = 1, jpi
758               ssha_e(ji,jj) = hbdy(ji,jj)
[13286]759            END DO
760         END DO
[13216]761      ENDIF
[6140]762      !
[9116]763      ! --- North --- !
[13216]764      IF(lk_north) THEN
[15548]765         jstart = jpjglo - ( nn_hls + nbghostcells -1 ) - nn_shift_bar*Agrif_Rhoy()    ! halo + land + nbghostcells - 1
[14086]766         jend   = jpjglo - ( nn_hls + 1 )                                           ! halo + land + 1            - 1
[13216]767         DO jj = mj0(jstart), mj1(jend)
768            DO ji = 1, jpi
769               ssha_e(ji,jj) = hbdy(ji,jj)
[13286]770            END DO
771         END DO
[13216]772      ENDIF
[6140]773      !
[4292]774   END SUBROUTINE Agrif_ssh_ts
775
[13286]776   
[9019]777   SUBROUTINE Agrif_avm
[4292]778      !!----------------------------------------------------------------------
[9019]779      !!                  ***  ROUTINE Agrif_avm  ***
[5656]780      !!---------------------------------------------------------------------- 
781      REAL(wp) ::   zalpha
[6140]782      !!---------------------------------------------------------------------- 
[5656]783      !
[9031]784      IF( Agrif_Root() )   RETURN
[6140]785      !
[9031]786      zalpha = 1._wp ! JC: proper time interpolation impossible 
787                     ! => use last available value from parent
788      !
789      Agrif_SpecialValue    = 0.e0
[5656]790      Agrif_UseSpecialValue = .TRUE.
[14086]791      l_vremap              = ln_vert_remap
[6140]792      !
[9019]793      CALL Agrif_Bc_variable( avm_id, calledweight=zalpha, procname=interpavm )       
[6140]794      !
[5656]795      Agrif_UseSpecialValue = .FALSE.
[14086]796      l_vremap              = .FALSE.
[5656]797      !
[9019]798   END SUBROUTINE Agrif_avm
[5656]799
[13286]800
[12377]801   SUBROUTINE interptsn( ptab, i1, i2, j1, j2, k1, k2, n1, n2, before )
[6140]802      !!----------------------------------------------------------------------
803      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) ::   ptab
804      INTEGER                                     , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2, n1, n2
805      LOGICAL                                     , INTENT(in   ) ::   before
[5656]806      !
[12377]807      INTEGER  ::   ji, jj, jk, jn  ! dummy loop indices
808      INTEGER  ::   N_in, N_out
[13216]809      INTEGER  :: item
[9031]810      ! vertical interpolation:
[14086]811      REAL(wp) :: zhtot, zwgt
812      REAL(wp), DIMENSION(k1:k2,1:jpts) :: tabin, tabin_i
813      REAL(wp), DIMENSION(k1:k2) :: z_in, h_in_i, z_in_i
[13216]814      REAL(wp), DIMENSION(1:jpk) :: h_out, z_out
[12377]815      !!----------------------------------------------------------------------
[9031]816
[13216]817      IF( before ) THEN
818
819         item = Kmm_a
820         IF( l_ini_child )   Kmm_a = Kbb_a 
821
[9031]822         DO jn = 1,jpts
823            DO jk=k1,k2
824               DO jj=j1,j2
825                 DO ji=i1,i2
[12377]826                       ptab(ji,jj,jk,jn) = ts(ji,jj,jk,jn,Kmm_a)
[9031]827                 END DO
828              END DO
829           END DO
[13216]830         END DO
[9031]831
[14086]832         IF( l_vremap .OR. l_ini_child .OR. ln_zps ) THEN
833
834            ! Fill cell depths (i.e. gdept) to be interpolated
[13216]835            ! Warning: these are masked, hence extrapolated prior interpolation.
[14086]836            DO jj=j1,j2
837               DO ji=i1,i2
838                  ptab(ji,jj,k1,jpts+1) = 0.5_wp * tmask(ji,jj,k1) * e3t(ji,jj,k1,Kmm_a)
839                  DO jk=k1+1,k2
840                     ptab(ji,jj,jk,jpts+1) = tmask(ji,jj,jk) * &
841                        & ( ptab(ji,jj,jk-1,jpts+1) + 0.5_wp * (e3t(ji,jj,jk-1,Kmm_a)+e3t(ji,jj,jk,Kmm_a)) )
[13216]842                  END DO
843               END DO
844            END DO
[14086]845         
[13216]846            ! Save ssh at last level:
847            IF (.NOT.ln_linssh) THEN
848               ptab(i1:i2,j1:j2,k2,jpts+1) = ssh(i1:i2,j1:j2,Kmm_a)*tmask(i1:i2,j1:j2,1) 
849            END IF     
850         ENDIF
851         Kmm_a = item
852
[9031]853      ELSE
[13216]854         item = Krhs_a
855         IF( l_ini_child )   Krhs_a = Kbb_a 
[9031]856
[13216]857         IF( l_vremap .OR. l_ini_child ) THEN
858            IF (ln_linssh) ptab(i1:i2,j1:j2,k2,n2) = 0._wp 
859            DO jj=j1,j2
860               DO ji=i1,i2
[14086]861                  ts(ji,jj,:,:,Krhs_a) = 0. 
862                  !
863                  ! Build vertical grids:
[13216]864                  N_in = mbkt_parent(ji,jj)
[14218]865                  N_out = mbkt(ji,jj)
866                  IF (N_in*N_out > 0) THEN
867                     ! Input grid (account for partial cells if any):
868                     DO jk=1,N_in
869                        z_in(jk) = ptab(ji,jj,jk,n2) - ptab(ji,jj,k2,n2)
870                        tabin(jk,1:jpts) = ptab(ji,jj,jk,1:jpts)
871                     END DO
[14086]872                 
[14218]873                     ! Intermediate grid:
874                     IF ( l_vremap ) THEN
875                        DO jk = 1, N_in
876                           h_in_i(jk) = e3t0_parent(ji,jj,jk) * & 
877                             &       (1._wp + ptab(ji,jj,k2,n2)/(ht0_parent(ji,jj)*ssmask(ji,jj) + 1._wp - ssmask(ji,jj)))
878                        END DO
879                        z_in_i(1) = 0.5_wp * h_in_i(1)
880                        DO jk=2,N_in
881                           z_in_i(jk) = z_in_i(jk-1) + 0.5_wp * ( h_in_i(jk) + h_in_i(jk-1) )
882                        END DO
883                        z_in_i(1:N_in) = z_in_i(1:N_in)  - ptab(ji,jj,k2,n2)
884                     ENDIF                             
885
886                     ! Output (Child) grid:
887                     DO jk=1,N_out
888                        h_out(jk) = e3t(ji,jj,jk,Krhs_a)
[14086]889                     END DO
[14218]890                     z_out(1) = 0.5_wp * h_out(1)
891                     DO jk=2,N_out
892                        z_out(jk) = z_out(jk-1) + 0.5_wp * ( h_out(jk)+h_out(jk-1) )
[14086]893                     END DO
[14218]894                     IF (.NOT.ln_linssh) z_out(1:N_out) = z_out(1:N_out)  - ssh(ji,jj,Krhs_a)
[13216]895
896                     IF( l_ini_child ) THEN
[14086]897                        CALL remap_linear(tabin(1:N_in,1:jpts),z_in(1:N_in),ts(ji,jj,1:N_out,1:jpts,Krhs_a),              &
[13216]898                                      &   z_out(1:N_out),N_in,N_out,jpts) 
899                     ELSE
[14086]900                        CALL remap_linear(tabin(1:N_in,1:jpts),z_in(1:N_in),tabin_i(1:N_in,1:jpts),                       &
901                                     &   z_in_i(1:N_in),N_in,N_in,jpts)
902                        CALL reconstructandremap(tabin_i(1:N_in,1:jpts),h_in_i(1:N_in),ts(ji,jj,1:N_out,1:jpts,Krhs_a),   &
[13216]903                                      &   h_out(1:N_out),N_in,N_out,jpts) 
904                     ENDIF
[12377]905                  ENDIF
[13286]906               END DO
907            END DO
[13216]908            Krhs_a = item
909 
910         ELSE
911         
[14086]912            IF ( Agrif_Parent(ln_zps) ) THEN ! Account for partial cells
913                                             ! linear vertical interpolation
914               DO jj=j1,j2
915                  DO ji=i1,i2
916                     !
917                     N_in  = mbkt(ji,jj)
918                     N_out = mbkt(ji,jj)
919                     z_in(1) = ptab(ji,jj,1,n2)
920                     tabin(1,1:jpts) = ptab(ji,jj,1,1:jpts)
921                     DO jk=2, N_in
922                        z_in(jk) = ptab(ji,jj,jk,n2)
923                        tabin(jk,1:jpts) = ptab(ji,jj,jk,1:jpts)
924                     END DO
925                     IF (.NOT.ln_linssh) z_in(1:N_in) = z_in(1:N_in) - ptab(ji,jj,k2,n2)
926                     z_out(1) = 0.5_wp * e3t(ji,jj,1,Krhs_a)
927                     DO jk=2, N_out
928                        z_out(jk) = z_out(jk-1) + 0.5_wp * (e3t(ji,jj,jk-1,Krhs_a) + e3t(ji,jj,jk,Krhs_a))
929                     END DO
930                     IF (.NOT.ln_linssh) z_out(1:N_out) = z_out(1:N_out) - ssh(ji,jj,Krhs_a)
931                     CALL remap_linear(tabin(1:N_in,1:jpts),z_in(1:N_in),ptab(ji,jj,1:N_out,1:jpts), &
932                                   &   z_out(1:N_out),N_in,N_out,jpts) 
933                  END DO
934               END DO
935            ENDIF
936
937            DO jn =1, jpts
938               ts(i1:i2,j1:j2,1:jpk,jn,Krhs_a) = ptab(i1:i2,j1:j2,1:jpk,jn)*tmask(i1:i2,j1:j2,1:jpk)
[13216]939            END DO
940         ENDIF
[9116]941
[5656]942      ENDIF
943      !
944   END SUBROUTINE interptsn
945
[13286]946   
[12377]947   SUBROUTINE interpsshn( ptab, i1, i2, j1, j2, before )
[5656]948      !!----------------------------------------------------------------------
[4292]949      !!                  ***  ROUTINE interpsshn  ***
950      !!---------------------------------------------------------------------- 
[6140]951      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
952      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab
953      LOGICAL                         , INTENT(in   ) ::   before
954      !
[5656]955      !!---------------------------------------------------------------------- 
956      !
957      IF( before) THEN
[12377]958         ptab(i1:i2,j1:j2) = ssh(i1:i2,j1:j2,Kmm_a)
[5656]959      ELSE
[14086]960         IF( l_ini_child ) THEN
[14170]961            ssh(i1:i2,j1:j2,Krhs_a) = ptab(i1:i2,j1:j2) * tmask(i1:i2,j1:j2,1)
[14086]962         ELSE
963            hbdy(i1:i2,j1:j2) = ptab(i1:i2,j1:j2) * tmask(i1:i2,j1:j2,1)
964         ENDIF
[5656]965      ENDIF
966      !
967   END SUBROUTINE interpsshn
968
[13286]969   
[12377]970   SUBROUTINE interpun( ptab, i1, i2, j1, j2, k1, k2, m1, m2, before )
[6140]971      !!----------------------------------------------------------------------
[9019]972      !!                  *** ROUTINE interpun ***
[9031]973      !!---------------------------------------------   
974      !!
975      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,m1,m2
976      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,m1:m2), INTENT(inout) :: ptab
977      LOGICAL, INTENT(in) :: before
978      !!
979      INTEGER :: ji,jj,jk
[12377]980      REAL(wp) :: zrhoy, zhtot
[9031]981      ! vertical interpolation:
[13216]982      REAL(wp), DIMENSION(k1:k2) :: tabin, h_in, z_in
983      REAL(wp), DIMENSION(1:jpk) :: h_out, z_out
984      INTEGER  :: N_in, N_out,item
[9031]985      REAL(wp) :: h_diff
986      !!---------------------------------------------   
[5656]987      !
[9031]988      IF (before) THEN
[13216]989
990         item = Kmm_a
991         IF( l_ini_child )   Kmm_a = Kbb_a     
992
[9031]993         DO jk=1,jpk
994            DO jj=j1,j2
995               DO ji=i1,i2
[12377]996                  ptab(ji,jj,jk,1) = (e2u(ji,jj) * e3u(ji,jj,jk,Kmm_a) * uu(ji,jj,jk,Kmm_a)*umask(ji,jj,jk)) 
[13216]997                  IF( l_vremap .OR. l_ini_child) THEN
998                     ! Interpolate thicknesses (masked for subsequent extrapolation)
999                     ptab(ji,jj,jk,2) = umask(ji,jj,jk) * e2u(ji,jj) * e3u(ji,jj,jk,Kmm_a)
1000                  ENDIF
[9031]1001               END DO
1002            END DO
[5656]1003         END DO
[13216]1004
[14086]1005        IF( l_vremap .OR. l_ini_child ) THEN
[12377]1006         ! Extrapolate thicknesses in partial bottom cells:
1007         ! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on
[13216]1008            IF (ln_zps) THEN
1009               DO jj=j1,j2
1010                  DO ji=i1,i2
1011                     jk = mbku(ji,jj)
1012                     ptab(ji,jj,jk,2) = 0._wp
1013                  END DO
1014               END DO           
1015            END IF
1016
1017           ! Save ssh at last level:
1018           ptab(i1:i2,j1:j2,k2,2) = 0._wp
1019           IF (.NOT.ln_linssh) THEN
1020              ! This vertical sum below should be replaced by the sea-level at U-points (optimization):
1021              DO jk=1,jpk
1022                 ptab(i1:i2,j1:j2,k2,2) = ptab(i1:i2,j1:j2,k2,2) + e3u(i1:i2,j1:j2,jk,Kmm_a) * umask(i1:i2,j1:j2,jk)
1023              END DO
1024              ptab(i1:i2,j1:j2,k2,2) = ptab(i1:i2,j1:j2,k2,2) - hu_0(i1:i2,j1:j2)
1025           END IF
1026        ENDIF
1027
1028         Kmm_a = item
[12377]1029         !
[5656]1030      ELSE
[9031]1031         zrhoy = Agrif_rhoy()
[13216]1032
1033        IF( l_vremap .OR. l_ini_child) THEN
[9031]1034! VERTICAL REFINEMENT BEGIN
1035
[13216]1036            IF (ln_linssh) ptab(i1:i2,j1:j2,k2,2) = 0._wp 
[12377]1037
[13216]1038            DO ji=i1,i2
1039               DO jj=j1,j2
1040                  uu(ji,jj,:,Krhs_a) = 0._wp
1041                  N_in = mbku_parent(ji,jj)
[14218]1042                  N_out = mbku(ji,jj)
1043                  IF (N_in*N_out > 0) THEN
1044                     zhtot = 0._wp
1045                     DO jk=1,N_in
1046                        !IF (jk==N_in) THEN
1047                        !   h_in(jk) = hu0_parent(ji,jj) + ptab(ji,jj,k2,2) - zhtot
1048                        !ELSE
1049                        !   h_in(jk) = ptab(ji,jj,jk,2)/(e2u(ji,jj)*zrhoy)
1050                        !ENDIF
1051                        IF ( l_vremap ) THEN
1052                           h_in(jk) = e3u0_parent(ji,jj,jk) 
[14086]1053                        ELSE
[14218]1054                           IF (jk==N_in) THEN
1055                              h_in(jk) = hu0_parent(ji,jj) + ptab(ji,jj,k2,2) - zhtot
1056                           ELSE
1057                              h_in(jk) = ptab(ji,jj,jk,2)/(e2u(ji,jj)*zrhoy) 
1058                           ENDIF
[14086]1059                        ENDIF
[14218]1060                        zhtot = zhtot + h_in(jk)
1061                        IF( h_in(jk) .GT. 0. ) THEN
1062                           tabin(jk) = ptab(ji,jj,jk,1)/(e2u(ji,jj)*zrhoy*h_in(jk))
1063                        ELSE
1064                           tabin(jk) = 0.
1065                        ENDIF
1066                    END DO
1067                    z_in(1) = 0.5_wp * h_in(1) - zhtot + hu0_parent(ji,jj) 
1068                    DO jk=2,N_in
1069                       z_in(jk) = z_in(jk-1) + 0.5_wp * (h_in(jk)+h_in(jk-1))
1070                    END DO
[13216]1071                     
[14218]1072                    DO jk=1, N_out
1073                       h_out(jk) = e3u(ji,jj,jk,Krhs_a)
1074                    END DO
[13216]1075
[14218]1076                    z_out(1) = 0.5_wp * h_out(1) - SUM(h_out(1:N_out)) + hu_0(ji,jj)
1077                    DO jk=2,N_out
1078                       z_out(jk) = z_out(jk-1) + 0.5_wp * (h_out(jk-1) + h_out(jk)) 
1079                    END DO 
[13216]1080
[14218]1081                    IF( l_ini_child ) THEN
1082                       CALL remap_linear       (tabin(1:N_in),z_in(1:N_in),uu(ji,jj,1:N_out,Krhs_a),z_out(1:N_out),N_in,N_out,1)
1083                    ELSE
1084                       CALL reconstructandremap(tabin(1:N_in),h_in(1:N_in),uu(ji,jj,1:N_out,Krhs_a),h_out(1:N_out),N_in,N_out,1)
1085                    ENDIF   
[13216]1086                 ENDIF
[13286]1087               END DO
1088            END DO
[13216]1089         ELSE
1090            DO jk = 1, jpkm1
1091               DO jj=j1,j2
1092                  uu(i1:i2,jj,jk,Krhs_a) = ptab(i1:i2,jj,jk,1) / ( zrhoy * e2u(i1:i2,jj) * e3u(i1:i2,jj,jk,Krhs_a) )
1093               END DO
[5656]1094            END DO
[13216]1095         ENDIF
[9031]1096
[5656]1097      ENDIF
1098      !
1099   END SUBROUTINE interpun
1100
[13286]1101   
[12377]1102   SUBROUTINE interpvn( ptab, i1, i2, j1, j2, k1, k2, m1, m2, before )
[6140]1103      !!----------------------------------------------------------------------
[9019]1104      !!                  *** ROUTINE interpvn ***
[6140]1105      !!----------------------------------------------------------------------
[5656]1106      !
[9031]1107      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,m1,m2
1108      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,m1:m2), INTENT(inout) :: ptab
1109      LOGICAL, INTENT(in) :: before
1110      !
1111      INTEGER :: ji,jj,jk
1112      REAL(wp) :: zrhox
1113      ! vertical interpolation:
[13216]1114      REAL(wp), DIMENSION(k1:k2) :: tabin, h_in, z_in
1115      REAL(wp), DIMENSION(1:jpk) :: h_out, z_out
1116      INTEGER  :: N_in, N_out, item
[12377]1117      REAL(wp) :: h_diff, zhtot
[9031]1118      !!---------------------------------------------   
[5656]1119      !     
[13216]1120      IF (before) THEN   
1121
1122         item = Kmm_a
1123         IF( l_ini_child )   Kmm_a = Kbb_a     
1124       
[9031]1125         DO jk=k1,k2
1126            DO jj=j1,j2
1127               DO ji=i1,i2
[12377]1128                  ptab(ji,jj,jk,1) = (e1v(ji,jj) * e3v(ji,jj,jk,Kmm_a) * vv(ji,jj,jk,Kmm_a)*vmask(ji,jj,jk))
[13216]1129                  IF( l_vremap .OR. l_ini_child) THEN
1130                     ! Interpolate thicknesses (masked for subsequent extrapolation)
1131                     ptab(ji,jj,jk,2) = vmask(ji,jj,jk) * e1v(ji,jj) * e3v(ji,jj,jk,Kmm_a)
1132                  ENDIF
[9031]1133               END DO
1134            END DO
[5656]1135         END DO
[13216]1136
1137         IF( l_vremap .OR. l_ini_child) THEN
[12377]1138         ! Extrapolate thicknesses in partial bottom cells:
1139         ! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on
[13216]1140            IF (ln_zps) THEN
1141               DO jj=j1,j2
1142                  DO ji=i1,i2
1143                     jk = mbkv(ji,jj)
1144                     ptab(ji,jj,jk,2) = 0._wp
1145                  END DO
1146               END DO           
1147            END IF
1148            ! Save ssh at last level:
1149            ptab(i1:i2,j1:j2,k2,2) = 0._wp
1150            IF (.NOT.ln_linssh) THEN
1151               ! This vertical sum below should be replaced by the sea-level at V-points (optimization):
1152               DO jk=1,jpk
1153                  ptab(i1:i2,j1:j2,k2,2) = ptab(i1:i2,j1:j2,k2,2) + e3v(i1:i2,j1:j2,jk,Kmm_a) * vmask(i1:i2,j1:j2,jk)
[12377]1154               END DO
[13216]1155               ptab(i1:i2,j1:j2,k2,2) = ptab(i1:i2,j1:j2,k2,2) - hv_0(i1:i2,j1:j2)
1156            END IF
1157         ENDIF
1158         item = Kmm_a
1159
[9031]1160      ELSE       
1161         zrhox = Agrif_rhox()
1162
[13216]1163         IF( l_vremap .OR. l_ini_child ) THEN
[9031]1164
[13216]1165            IF (ln_linssh) ptab(i1:i2,j1:j2,k2,2) = 0._wp 
1166
1167            DO jj=j1,j2
1168               DO ji=i1,i2
1169                  vv(ji,jj,:,Krhs_a) = 0._wp
1170                  N_in = mbkv_parent(ji,jj)
[14218]1171                  N_out = mbkv(ji,jj)
1172
1173                  IF (N_in*N_out > 0) THEN
1174                     zhtot = 0._wp
1175                     DO jk=1,N_in
1176                        !IF (jk==N_in) THEN
1177                        !   h_in(jk) = hv0_parent(ji,jj) + ptab(ji,jj,k2,2) - zhtot
1178                        !ELSE
1179                        !   h_in(jk) = ptab(ji,jj,jk,2)/(e1v(ji,jj)*zrhox)
1180                        !ENDIF
1181                        IF (l_vremap) THEN
1182                           h_in(jk) = e3v0_parent(ji,jj,jk)
[14086]1183                        ELSE
[14218]1184                           IF (jk==N_in) THEN
1185                              h_in(jk) = hv0_parent(ji,jj) + ptab(ji,jj,k2,2) - zhtot
1186                           ELSE
1187                              h_in(jk) = ptab(ji,jj,jk,2)/(e1v(ji,jj)*zrhox) 
1188                           ENDIF
[14086]1189                        ENDIF
[14218]1190                        zhtot = zhtot + h_in(jk)
1191                        IF( h_in(jk) .GT. 0. ) THEN
1192                          tabin(jk) = ptab(ji,jj,jk,1)/(e1v(ji,jj)*zrhox*h_in(jk))
1193                        ELSE
1194                          tabin(jk)  = 0.
1195                        ENDIF
1196                     END DO
[13216]1197
[14218]1198                     z_in(1) = 0.5_wp * h_in(1) - zhtot + hv0_parent(ji,jj)
1199                     DO jk=2,N_in
1200                        z_in(jk) = z_in(jk-1) + 0.5_wp * (h_in(jk-1)+h_in(jk))
1201                     END DO
[13216]1202
[14218]1203                     DO jk=1,N_out
1204                        h_out(jk) = e3v(ji,jj,jk,Krhs_a)
1205                     END DO
[13216]1206
[14218]1207                     z_out(1) = 0.5_wp * h_out(1) - SUM(h_out(1:N_out)) + hv_0(ji,jj)
1208                     DO jk=2,N_out
1209                        z_out(jk) = z_out(jk-1) + 0.5_wp * (h_out(jk-1)+h_out(jk))
1210                     END DO
[13216]1211 
1212                     IF( l_ini_child ) THEN
1213                        CALL remap_linear       (tabin(1:N_in),z_in(1:N_in),vv(ji,jj,1:N_out,Krhs_a),z_out(1:N_out),N_in,N_out,1)
1214                     ELSE
1215                        CALL reconstructandremap(tabin(1:N_in),h_in(1:N_in),vv(ji,jj,1:N_out,Krhs_a),h_out(1:N_out),N_in,N_out,1)
1216                     ENDIF   
[12377]1217                  ENDIF
[9031]1218               END DO
1219            END DO
[13216]1220         ELSE
1221            DO jk = 1, jpkm1
1222               vv(i1:i2,j1:j2,jk,Krhs_a) = ptab(i1:i2,j1:j2,jk,1) / ( zrhox * e1v(i1:i2,j1:j2) * e3v(i1:i2,j1:j2,jk,Krhs_a) )
1223            END DO
1224         ENDIF
[5656]1225      ENDIF
1226      !       
1227   END SUBROUTINE interpvn
[636]1228
[12377]1229   SUBROUTINE interpunb( ptab, i1, i2, j1, j2, before)
[1605]1230      !!----------------------------------------------------------------------
[5656]1231      !!                  ***  ROUTINE interpunb  ***
[1605]1232      !!---------------------------------------------------------------------- 
[6140]1233      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
1234      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab
1235      LOGICAL                         , INTENT(in   ) ::   before
1236      !
1237      INTEGER  ::   ji, jj
1238      REAL(wp) ::   zrhoy, zrhot, zt0, zt1, ztcoeff
[1605]1239      !!---------------------------------------------------------------------- 
[5656]1240      !
[6140]1241      IF( before ) THEN
[12377]1242         ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * hu(i1:i2,j1:j2,Kmm_a) * uu_b(i1:i2,j1:j2,Kmm_a)
[5656]1243      ELSE
1244         zrhoy = Agrif_Rhoy()
1245         zrhot = Agrif_rhot()
1246         ! Time indexes bounds for integration
1247         zt0 = REAL(Agrif_NbStepint()  , wp) / zrhot
1248         zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot     
[12377]1249         !
1250         DO ji = i1, i2
1251            DO jj = j1, j2
1252               IF ( utint_stage(ji,jj) < (bdy_tinterp + 1) ) THEN
1253                  IF    ( utint_stage(ji,jj) == 1  ) THEN
1254                     ztcoeff = zrhot * (  zt1**2._wp * (       zt1 - 1._wp)        &
1255                        &               - zt0**2._wp * (       zt0 - 1._wp)        )
1256                  ELSEIF( utint_stage(ji,jj) == 2  ) THEN
1257                     ztcoeff = zrhot * (  zt1        * (       zt1 - 1._wp)**2._wp &
1258                        &               - zt0        * (       zt0 - 1._wp)**2._wp )
1259                  ELSEIF( utint_stage(ji,jj) == 0  ) THEN               
1260                     ztcoeff = 1._wp
1261                  ELSE
1262                     ztcoeff = 0._wp
1263                  ENDIF
1264                  !   
1265                  ubdy(ji,jj) = ubdy(ji,jj) + ztcoeff * ptab(ji,jj)
1266                  !           
1267                  IF (( utint_stage(ji,jj) == 2 ).OR.( utint_stage(ji,jj) == 0 )) THEN
1268                     ubdy(ji,jj) = ubdy(ji,jj) / (zrhoy*e2u(ji,jj)) * umask(ji,jj,1)
1269                  ENDIF
1270                  !
1271                  utint_stage(ji,jj) = utint_stage(ji,jj) + 1
1272               ENDIF
1273            END DO
1274         END DO
1275      END IF
[5656]1276      !
1277   END SUBROUTINE interpunb
[636]1278
[6140]1279
[12377]1280   SUBROUTINE interpvnb( ptab, i1, i2, j1, j2, before )
[1605]1281      !!----------------------------------------------------------------------
[5656]1282      !!                  ***  ROUTINE interpvnb  ***
[1605]1283      !!---------------------------------------------------------------------- 
[6140]1284      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
1285      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab
1286      LOGICAL                         , INTENT(in   ) ::   before
1287      !
[12377]1288      INTEGER  ::   ji, jj
[6140]1289      REAL(wp) ::   zrhox, zrhot, zt0, zt1, ztcoeff   
[1605]1290      !!---------------------------------------------------------------------- 
[5656]1291      !
[6140]1292      IF( before ) THEN
[12377]1293         ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * hv(i1:i2,j1:j2,Kmm_a) * vv_b(i1:i2,j1:j2,Kmm_a)
[5656]1294      ELSE
1295         zrhox = Agrif_Rhox()
1296         zrhot = Agrif_rhot()
1297         ! Time indexes bounds for integration
1298         zt0 = REAL(Agrif_NbStepint()  , wp) / zrhot
[12377]1299         zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot 
1300         !     
1301         DO ji = i1, i2
1302            DO jj = j1, j2
1303               IF ( vtint_stage(ji,jj) < (bdy_tinterp + 1) ) THEN
1304                  IF    ( vtint_stage(ji,jj) == 1  ) THEN
1305                     ztcoeff = zrhot * (  zt1**2._wp * (       zt1 - 1._wp)        &
1306                        &               - zt0**2._wp * (       zt0 - 1._wp)        )
1307                  ELSEIF( vtint_stage(ji,jj) == 2  ) THEN
1308                     ztcoeff = zrhot * (  zt1        * (       zt1 - 1._wp)**2._wp &
1309                        &               - zt0        * (       zt0 - 1._wp)**2._wp )
1310                  ELSEIF( vtint_stage(ji,jj) == 0  ) THEN               
1311                     ztcoeff = 1._wp
1312                  ELSE
1313                     ztcoeff = 0._wp
1314                  ENDIF
1315                  !   
1316                  vbdy(ji,jj) = vbdy(ji,jj) + ztcoeff * ptab(ji,jj)
1317                  !           
1318                  IF (( vtint_stage(ji,jj) == 2 ).OR.( vtint_stage(ji,jj) == 0 )) THEN
1319                     vbdy(ji,jj) = vbdy(ji,jj) / (zrhox*e1v(ji,jj)) * vmask(ji,jj,1)
1320                  ENDIF
1321                  !
1322                  vtint_stage(ji,jj) = vtint_stage(ji,jj) + 1
1323               ENDIF
1324            END DO
1325         END DO         
[5656]1326      ENDIF
1327      !
1328   END SUBROUTINE interpvnb
[390]1329
[6140]1330
[12377]1331   SUBROUTINE interpub2b( ptab, i1, i2, j1, j2, before )
[1605]1332      !!----------------------------------------------------------------------
[5656]1333      !!                  ***  ROUTINE interpub2b  ***
[1605]1334      !!---------------------------------------------------------------------- 
[6140]1335      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
1336      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab
1337      LOGICAL                         , INTENT(in   ) ::   before
1338      !
1339      INTEGER  ::   ji,jj
[12377]1340      REAL(wp) ::   zrhot, zt0, zt1, zat
[1605]1341      !!---------------------------------------------------------------------- 
[5656]1342      IF( before ) THEN
[14053]1343!         IF ( ln_bt_fw ) THEN
[9031]1344            ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * ub2_b(i1:i2,j1:j2)
[14053]1345!         ELSE
1346!            ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * un_adv(i1:i2,j1:j2)
1347!         ENDIF
[5656]1348      ELSE
1349         zrhot = Agrif_rhot()
1350         ! Time indexes bounds for integration
1351         zt0 = REAL(Agrif_NbStepint()  , wp) / zrhot
1352         zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot
1353         ! Polynomial interpolation coefficients:
[6140]1354         zat = zrhot * (  zt1**2._wp * (-2._wp*zt1 + 3._wp)    &
1355            &           - zt0**2._wp * (-2._wp*zt0 + 3._wp)    ) 
[12377]1356         !
1357         ubdy(i1:i2,j1:j2) = zat * ptab(i1:i2,j1:j2) 
1358         !
1359         ! Update interpolation stage:
1360         utint_stage(i1:i2,j1:j2) = 1
[5656]1361      ENDIF
1362      !
1363   END SUBROUTINE interpub2b
[6140]1364   
[14086]1365   SUBROUTINE interpub2b_const( ptab, i1, i2, j1, j2, before )
1366      !!----------------------------------------------------------------------
1367      !!                  ***  ROUTINE interpub2b_const  ***
1368      !!---------------------------------------------------------------------- 
1369      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
1370      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab
1371      LOGICAL                         , INTENT(in   ) ::   before
1372      !
1373      REAL(wp) :: zrhoy
1374      !!---------------------------------------------------------------------- 
1375      IF( before ) THEN
1376!         IF ( ln_bt_fw ) THEN
1377            ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * ub2_b(i1:i2,j1:j2)
1378!         ELSE
1379!            ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * un_adv(i1:i2,j1:j2)
1380!         ENDIF
1381      ELSE
1382         zrhoy = Agrif_Rhoy()
1383         !
1384         ubdy(i1:i2,j1:j2) = ptab(i1:i2,j1:j2) & 
1385                           & / (zrhoy*e2u(i1:i2,j1:j2)) * umask(i1:i2,j1:j2,1)
1386         !
1387      ENDIF
1388      !
1389   END SUBROUTINE interpub2b_const
[636]1390
[14086]1391
1392   SUBROUTINE ub2b_cor( ptab, i1, i2, j1, j2, before )
1393      !!----------------------------------------------------------------------
1394      !!                  ***  ROUTINE ub2b_cor  ***
1395      !!---------------------------------------------------------------------- 
1396      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
1397      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab
1398      LOGICAL                         , INTENT(in   ) ::   before
1399      !
1400      INTEGER  :: ji, jj
[15548]1401      INTEGER  :: imin, imax, jmin, jmax
[14086]1402      REAL(wp) :: zrhox, zrhoy, zx
1403      !!---------------------------------------------------------------------- 
1404      IF( before ) THEN
1405         ptab(:,:) = 0._wp
[15548]1406         imin = MAX(i1, 2) ; imax = MIN(i2, jpi-1)
1407         jmin = MAX(j1, 2) ; jmax = MIN(j2, jpj-1)
1408         DO ji=imin,imax
1409            DO jj=jmin,jmax
[14086]1410               ptab(ji,jj) = 0.25_wp*( ( vb2_b(ji+1,jj  )*e1v(ji+1,jj  )   & 
1411                           &            -vb2_b(ji-1,jj  )*e1v(ji-1,jj  ) ) &
1412                           &          -( vb2_b(ji+1,jj-1)*e1v(ji+1,jj-1)   &
1413                           &            -vb2_b(ji-1,jj-1)*e1v(ji-1,jj-1) ) )
1414            END DO
1415         END DO
1416      ELSE
1417         !
1418         zrhox = Agrif_Rhox() 
1419         zrhoy = Agrif_Rhoy()
1420         DO ji=i1,i2
1421            DO jj=j1,j2
1422               IF (utint_stage(ji,jj)==0) THEN
[15548]1423                  zx = 2._wp*MOD(ABS(mig0(ji)-nbghostcells_x_w), INT(Agrif_Rhox()))/zrhox - 1._wp 
[14086]1424                  ubdy(ji,jj) = ubdy(ji,jj) + 0.25_wp*(1._wp-zx*zx) * ptab(ji,jj) & 
1425                              &         / zrhoy *r1_e2u(ji,jj) * umask(ji,jj,1) 
1426                  utint_stage(ji,jj) = 1 
1427               ENDIF
1428            END DO
1429         END DO 
1430         !
1431      ENDIF
1432      !
1433   END SUBROUTINE ub2b_cor
1434
1435
[12377]1436   SUBROUTINE interpvb2b( ptab, i1, i2, j1, j2, before )
[4292]1437      !!----------------------------------------------------------------------
[5656]1438      !!                  ***  ROUTINE interpvb2b  ***
[4292]1439      !!---------------------------------------------------------------------- 
[6140]1440      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
1441      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab
1442      LOGICAL                         , INTENT(in   ) ::   before
1443      !
1444      INTEGER ::   ji,jj
[12377]1445      REAL(wp) ::   zrhot, zt0, zt1, zat
[4292]1446      !!---------------------------------------------------------------------- 
[5656]1447      !
1448      IF( before ) THEN
[14053]1449!         IF ( ln_bt_fw ) THEN
[9031]1450            ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * vb2_b(i1:i2,j1:j2)
[14053]1451!         ELSE
1452!            ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * vn_adv(i1:i2,j1:j2)
1453!         ENDIF
[5656]1454      ELSE     
1455         zrhot = Agrif_rhot()
1456         ! Time indexes bounds for integration
1457         zt0 = REAL(Agrif_NbStepint()  , wp) / zrhot
1458         zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot
1459         ! Polynomial interpolation coefficients:
[6140]1460         zat = zrhot * (  zt1**2._wp * (-2._wp*zt1 + 3._wp)    &
1461            &           - zt0**2._wp * (-2._wp*zt0 + 3._wp)    ) 
[5656]1462         !
[12377]1463         vbdy(i1:i2,j1:j2) = zat * ptab(i1:i2,j1:j2)
1464         !
1465         ! update interpolation stage:
1466         vtint_stage(i1:i2,j1:j2) = 1
[5656]1467      ENDIF
1468      !     
1469   END SUBROUTINE interpvb2b
[4292]1470
[6140]1471
[14086]1472   SUBROUTINE interpvb2b_const( ptab, i1, i2, j1, j2, before )
1473      !!----------------------------------------------------------------------
1474      !!                  ***  ROUTINE interpub2b_const  ***
1475      !!---------------------------------------------------------------------- 
1476      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
1477      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab
1478      LOGICAL                         , INTENT(in   ) ::   before
1479      !
1480      REAL(wp) :: zrhox
1481      !!---------------------------------------------------------------------- 
1482      IF( before ) THEN
1483!         IF ( ln_bt_fw ) THEN
1484            ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * vb2_b(i1:i2,j1:j2)
1485!         ELSE
1486!            ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * vn_adv(i1:i2,j1:j2)
1487!         ENDIF
1488      ELSE
1489         zrhox = Agrif_Rhox()
1490         !
1491         vbdy(i1:i2,j1:j2) = ptab(i1:i2,j1:j2) &
1492                           & / (zrhox*e1v(i1:i2,j1:j2)) * vmask(i1:i2,j1:j2,1)
1493         !
1494      ENDIF
1495      !
1496   END SUBROUTINE interpvb2b_const
1497
1498 
1499   SUBROUTINE vb2b_cor( ptab, i1, i2, j1, j2, before )
1500      !!----------------------------------------------------------------------
1501      !!                  ***  ROUTINE vb2b_cor  ***
1502      !!---------------------------------------------------------------------- 
1503      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
1504      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab
1505      LOGICAL                         , INTENT(in   ) ::   before
1506      !
1507      INTEGER  :: ji, jj
[15548]1508      INTEGER  :: imin, imax, jmin, jmax
[14086]1509      REAL(wp) :: zrhox, zrhoy, zy
1510      !!---------------------------------------------------------------------- 
1511      IF( before ) THEN
1512         ptab(:,:) = 0._wp
[15548]1513         imin = MAX(i1, 2) ; imax = MIN(i2, jpi-1)
1514         jmin = MAX(j1, 2) ; jmax = MIN(j2, jpj-1)
1515         DO ji=imin,imax
1516            DO jj=jmin,jmax
[14086]1517               ptab(ji,jj) = 0.25_wp*( ( ub2_b(ji  ,jj+1)*e2u(ji  ,jj+1)   & 
1518                           &            -ub2_b(ji  ,jj-1)*e2u(ji  ,jj-1) ) &
1519                           &          -( ub2_b(ji-1,jj+1)*e2u(ji-1,jj+1)   &
1520                           &            -ub2_b(ji-1,jj-1)*e2u(ji-1,jj-1) ) )
1521            END DO
1522         END DO
1523      ELSE
1524         !
1525         zrhox = Agrif_Rhox() 
1526         zrhoy = Agrif_Rhoy()
1527         DO ji=i1,i2
1528            DO jj=j1,j2
1529               IF (vtint_stage(ji,jj)==0) THEN
[15548]1530                  zy = 2._wp*MOD(ABS(mjg0(jj)-nbghostcells_y_s), INT(Agrif_Rhoy()))/zrhoy - 1._wp 
[14086]1531                  vbdy(ji,jj) = vbdy(ji,jj) + 0.25_wp*(1._wp-zy*zy) * ptab(ji,jj) & 
1532                              &         / zrhox * r1_e1v(ji,jj) * vmask(ji,jj,1) 
1533                  vtint_stage(ji,jj) = 1 
1534               ENDIF
1535            END DO
1536         END DO 
1537         !
1538      ENDIF
1539      !
1540   END SUBROUTINE vb2b_cor
1541
1542
1543   SUBROUTINE interpe3t0_vremap( ptab, i1, i2, j1, j2, k1, k2, before )
1544      !!----------------------------------------------------------------------
1545      !!                  ***  ROUTINE interpe3t0_vremap  ***
1546      !!---------------------------------------------------------------------- 
1547      INTEGER                              , INTENT(in   ) :: i1, i2, j1, j2, k1, k2
1548      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab
1549      LOGICAL                              , INTENT(in   ) :: before
1550      !
1551      INTEGER :: ji, jj, jk
1552      REAL(wp) :: zh
1553      !!---------------------------------------------------------------------- 
1554      !   
1555      IF( before ) THEN
1556         IF ( ln_zps ) THEN
1557            DO jk = k1, k2
1558               DO jj = j1, j2
1559                  DO ji = i1, i2
1560                     ptab(ji, jj, jk) = e3t_1d(jk)
1561                  END DO
1562               END DO
1563            END DO
1564         ELSE
1565            ptab(i1:i2,j1:j2,k1:k2) = e3t_0(i1:i2,j1:j2,k1:k2)
1566         ENDIF
1567      ELSE
1568         !
1569         DO jk = k1, k2
1570            DO jj = j1, j2
1571               DO ji = i1, i2
1572                  e3t0_parent(ji,jj,jk) = ptab(ji,jj,jk)
1573               END DO
1574            END DO
1575         END DO
1576
1577         ! Retrieve correct scale factor at the bottom:
1578         DO jj = j1, j2
1579            DO ji = i1, i2
[15548]1580               IF ( mbkt_parent(ji,jj) > 1 ) THEN
1581                  zh = 0._wp
1582                  DO jk = 1, mbkt_parent(ji, jj)-1
1583                     zh = zh + e3t0_parent(ji,jj,jk)
1584                  END DO
1585                  e3t0_parent(ji,jj,mbkt_parent(ji,jj)) = ht0_parent(ji, jj) - zh
1586               ENDIF 
[14086]1587            END DO
1588         END DO
1589         
1590      ENDIF
1591      !
1592   END SUBROUTINE interpe3t0_vremap
1593
1594
[13286]1595   SUBROUTINE interpglamt( ptab, i1, i2, j1, j2, before )
1596      !!----------------------------------------------------------------------
1597      !!                  ***  ROUTINE interpglamt  ***
1598      !!---------------------------------------------------------------------- 
1599      INTEGER                        , INTENT(in   ) :: i1, i2, j1, j2
1600      REAL(wp),DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
1601      LOGICAL                        , INTENT(in   ) :: before
1602      !
1603      INTEGER :: ji, jj, jk
1604      REAL(wp):: ztst
1605      !!---------------------------------------------------------------------- 
1606      !   
1607      IF( before ) THEN
1608         ptab(i1:i2,j1:j2) = glamt(i1:i2,j1:j2)
1609      ELSE
1610         ztst = MAXVAL(ABS(glamt(i1:i2,j1:j2)))*1.e-4
1611         DO jj = j1, j2
1612            DO ji = i1, i2
1613               IF( ABS( ptab(ji,jj) - glamt(ji,jj) ) > ztst ) THEN
1614                  WRITE(numout,*) ' Agrif error for glamt: parent, child, i, j ', ptab(ji,jj), glamt(ji,jj), mig0(ji), mig0(jj)
1615!                  kindic_agr = kindic_agr + 1
1616               ENDIF
1617            END DO
1618         END DO
1619      ENDIF
1620      !
1621   END SUBROUTINE interpglamt
1622
1623
1624   SUBROUTINE interpgphit( ptab, i1, i2, j1, j2, before )
1625      !!----------------------------------------------------------------------
1626      !!                  ***  ROUTINE interpgphit  ***
1627      !!---------------------------------------------------------------------- 
1628      INTEGER                        , INTENT(in   ) :: i1, i2, j1, j2
1629      REAL(wp),DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab
1630      LOGICAL                        , INTENT(in   ) :: before
1631      !
1632      INTEGER :: ji, jj, jk
1633      REAL(wp):: ztst
1634      !!---------------------------------------------------------------------- 
1635      !   
1636      IF( before ) THEN
1637         ptab(i1:i2,j1:j2) = gphit(i1:i2,j1:j2)
1638      ELSE
1639         ztst = MAXVAL(ABS(gphit(i1:i2,j1:j2)))*1.e-4
1640         DO jj = j1, j2
1641            DO ji = i1, i2
1642               IF( ABS( ptab(ji,jj) - gphit(ji,jj) ) > ztst ) THEN
1643                  WRITE(numout,*) ' Agrif error for gphit: parent, child, i, j ', ptab(ji,jj), gphit(ji,jj), mig0(ji), mig0(jj)
1644!                  kindic_agr = kindic_agr + 1
1645               ENDIF
1646            END DO
1647         END DO
1648      ENDIF
1649      !
1650   END SUBROUTINE interpgphit
1651
1652
[9031]1653   SUBROUTINE interpavm( ptab, i1, i2, j1, j2, k1, k2, m1, m2, before )
[4486]1654      !!----------------------------------------------------------------------
[5656]1655      !!                  ***  ROUTINE interavm  ***
[4486]1656      !!---------------------------------------------------------------------- 
[9116]1657      INTEGER                                    , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2, m1, m2
[9031]1658      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,m1:m2), INTENT(inout) ::   ptab
[9116]1659      LOGICAL                                    , INTENT(in   ) ::   before
[12377]1660      !
1661      INTEGER  :: ji, jj, jk
1662      INTEGER  :: N_in, N_out
1663      REAL(wp), DIMENSION(k1:k2) :: tabin, z_in
1664      REAL(wp), DIMENSION(1:jpk) :: z_out
[4486]1665      !!---------------------------------------------------------------------- 
[5656]1666      !     
[9031]1667      IF (before) THEN         
1668         DO jk=k1,k2
1669            DO jj=j1,j2
1670              DO ji=i1,i2
1671                    ptab(ji,jj,jk,1) = avm_k(ji,jj,jk)
1672              END DO
1673           END DO
[13216]1674         END DO
[12377]1675
[13216]1676         IF( l_vremap ) THEN
[14218]1677            ! Interpolate interfaces
[13216]1678            ! Warning: these are masked, hence extrapolated prior interpolation.
1679            DO jk=k1,k2
1680               DO jj=j1,j2
1681                  DO ji=i1,i2
[14218]1682                      ptab(ji,jj,jk,2) = tmask(ji,jj,jk) * gdepw(ji,jj,jk,Kmm_a)
[13216]1683                  END DO
1684               END DO
1685            END DO
1686       
1687           ! Save ssh at last level:
1688            IF (.NOT.ln_linssh) THEN
1689               ptab(i1:i2,j1:j2,k2,2) = ssh(i1:i2,j1:j2,Kmm_a)*tmask(i1:i2,j1:j2,1) 
1690            ELSE
1691               ptab(i1:i2,j1:j2,k2,2) = 0._wp
1692            END IF     
1693          ENDIF
1694
[9031]1695      ELSE
[13216]1696
1697         IF( l_vremap ) THEN
1698            IF (ln_linssh) ptab(i1:i2,j1:j2,k2,2) = 0._wp 
[14218]1699            avm_k(i1:i2,j1:j2,1:jpkm1) = 0._wp
[13216]1700               
1701            DO jj = j1, j2
1702               DO ji =i1, i2
1703                  N_in = mbkt_parent(ji,jj)
[14218]1704                  N_out = mbkt(ji,jj)
[13216]1705                  IF (N_in*N_out > 0) THEN
[14218]1706                     DO jk = 1, N_in  ! Parent vertical grid               
1707                        z_in(jk)  = ptab(ji,jj,jk,2) - ptab(ji,jj,k2,2)
1708                        tabin(jk) = ptab(ji,jj,jk,1)
1709                     END DO
1710                     DO jk = 1, N_out        ! Child vertical grid
1711                        z_out(jk) = gdepw(ji,jj,jk,Kmm_a) - ssh(ji,jj,Kmm_a)
1712                     END DO
1713                     IF (.NOT.ln_linssh) z_out(1:N_out) = z_out(1:N_out)  - ssh(ji,jj,Kmm_a)
1714
[13216]1715                     CALL remap_linear(tabin(1:N_in),z_in(1:N_in),avm_k(ji,jj,1:N_out),z_out(1:N_out),N_in,N_out,1)
1716                  ENDIF
[13286]1717               END DO
1718            END DO
[13216]1719         ELSE
[14218]1720            avm_k(i1:i2,j1:j2,1:jpkm1) = ptab (i1:i2,j1:j2,1:jpkm1,1)
[13216]1721         ENDIF
[5656]1722      ENDIF
1723      !
1724   END SUBROUTINE interpavm
[4486]1725
[13286]1726   
[12377]1727   SUBROUTINE interpmbkt( ptab, i1, i2, j1, j2, before )
1728      !!----------------------------------------------------------------------
[14086]1729      !!                  ***  ROUTINE interpmbkt  ***
[12377]1730      !!---------------------------------------------------------------------- 
1731      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
1732      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab
1733      LOGICAL                         , INTENT(in   ) ::   before
1734      !
1735      !!---------------------------------------------------------------------- 
1736      !
1737      IF( before) THEN
1738         ptab(i1:i2,j1:j2) = REAL(mbkt(i1:i2,j1:j2),wp)
1739      ELSE
1740         mbkt_parent(i1:i2,j1:j2) = NINT(ptab(i1:i2,j1:j2))
1741      ENDIF
1742      !
1743   END SUBROUTINE interpmbkt
1744
[13286]1745   
[12377]1746   SUBROUTINE interpht0( ptab, i1, i2, j1, j2, before )
1747      !!----------------------------------------------------------------------
[14086]1748      !!                  ***  ROUTINE interpht0  ***
[12377]1749      !!---------------------------------------------------------------------- 
1750      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
1751      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab
1752      LOGICAL                         , INTENT(in   ) ::   before
1753      !
1754      !!---------------------------------------------------------------------- 
1755      !
1756      IF( before) THEN
1757         ptab(i1:i2,j1:j2) = ht_0(i1:i2,j1:j2)
1758      ELSE
1759         ht0_parent(i1:i2,j1:j2) = ptab(i1:i2,j1:j2)
1760      ENDIF
1761      !
1762   END SUBROUTINE interpht0
1763
[14086]1764   SUBROUTINE Agrif_check_bat( iindic )
[13216]1765      !!----------------------------------------------------------------------
[14086]1766      !!                  ***  ROUTINE Agrif_check_bat  ***
[13216]1767      !!---------------------------------------------------------------------- 
[14086]1768      INTEGER, INTENT(inout) ::   iindic
1769      !!
[15548]1770      INTEGER :: ji, jj, jk
[14086]1771      INTEGER  :: istart, iend, jstart, jend, ispon
[13216]1772      !!---------------------------------------------------------------------- 
1773      !
[14086]1774      !
1775      ! --- West --- !
1776      IF(lk_west) THEN
1777         ispon  = nn_sponge_len * Agrif_irhox()
1778         istart = nn_hls + 2                                  ! halo + land + 1
[15548]1779         iend   = nn_hls + nbghostcells + ispon           ! halo + land + nbghostcells + sponge
1780         jstart = nn_hls + 2 
1781         jend   = jpjglo - nn_hls - 1 
[14086]1782         DO ji = mi0(istart), mi1(iend)
1783            DO jj = mj0(jstart), mj1(jend)
1784               IF ( ABS(ht0_parent(ji,jj)-ht_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
[15548]1785               IF ( .NOT.ln_vert_remap) THEN
1786                  DO jk = 1, jpkm1
1787                     IF ( ABS(e3t0_parent(ji,jj,jk)-e3t_0(ji,jj,jk))*tmask(ji,jj,jk) > 1.e-3 ) iindic = iindic + 1
1788                  END DO
1789               ENDIF
[14086]1790            END DO
1791            DO jj = mj0(jstart), mj1(jend-1)
1792               IF ( ABS(hv0_parent(ji,jj)-hv_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
[15548]1793               IF ( .NOT.ln_vert_remap) THEN
1794                  DO jk = 1, jpkm1
1795                     IF ( ABS(e3v0_parent(ji,jj,jk)-e3v_0(ji,jj,jk))*vmask(ji,jj,jk) > 1.e-3 ) iindic = iindic + 1
1796                  END DO
1797               ENDIF
[14086]1798            END DO
1799         END DO
1800         DO ji = mi0(istart), mi1(iend-1)
1801            DO jj = mj0(jstart), mj1(jend)
1802               IF ( ABS(hu0_parent(ji,jj)-hu_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
[15548]1803               IF ( .NOT.ln_vert_remap) THEN
1804                  DO jk = 1, jpkm1
1805                     IF ( ABS(e3u0_parent(ji,jj,jk)-e3u_0(ji,jj,jk))*umask(ji,jj,jk) > 1.e-3 ) iindic = iindic + 1
1806                  END DO
1807               ENDIF
[14086]1808            END DO
1809         END DO
[13216]1810      ENDIF
1811      !
[14086]1812      ! --- East --- !
1813      IF(lk_east) THEN
1814         ispon  = nn_sponge_len * Agrif_irhox() 
[15548]1815         istart = jpiglo - ( nn_hls + nbghostcells + ispon -1 )  ! halo + land + nbghostcells + sponge - 1
1816         iend   = jpiglo - nn_hls - 1                            ! halo + land + 1                     - 1
1817         jstart = nn_hls + 2 
1818         jend   = jpjglo - nn_hls - 1
[14086]1819         DO ji = mi0(istart), mi1(iend)
1820            DO jj = mj0(jstart), mj1(jend)
1821               IF ( ABS(ht0_parent(ji,jj)-ht_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
[15548]1822               IF ( .NOT.ln_vert_remap) THEN
1823                  DO jk = 1, jpkm1
1824                     IF ( ABS(e3t0_parent(ji,jj,jk)-e3t_0(ji,jj,jk))*tmask(ji,jj,jk) > 1.e-3 ) iindic = iindic + 1
1825                  END DO
1826               ENDIF
[14086]1827            END DO
1828            DO jj = mj0(jstart), mj1(jend-1)
1829               IF ( ABS(hv0_parent(ji,jj)-hv_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
[15548]1830               IF ( .NOT.ln_vert_remap) THEN
1831                  DO jk = 1, jpkm1
1832                     IF ( ABS(e3v0_parent(ji,jj,jk)-e3v_0(ji,jj,jk))*vmask(ji,jj,jk) > 1.e-3 ) iindic = iindic + 1
1833                  END DO
1834               ENDIF
[14086]1835            END DO
1836         END DO
[15548]1837         DO ji = mi0(istart), mi1(iend-1)
[14086]1838            DO jj = mj0(jstart), mj1(jend)
1839               IF ( ABS(hu0_parent(ji,jj)-hu_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
[15548]1840               IF ( .NOT.ln_vert_remap) THEN
1841                  DO jk = 1, jpkm1
1842                     IF ( ABS(e3u0_parent(ji,jj,jk)-e3u_0(ji,jj,jk))*umask(ji,jj,jk) > 1.e-3 ) iindic = iindic + 1
1843                  END DO
1844               ENDIF
[14086]1845            END DO
1846         END DO
1847      ENDIF
1848      !
1849      ! --- South --- !
1850      IF(lk_south) THEN
[15548]1851         ispon  = nn_sponge_len * Agrif_irhoy() 
[14086]1852         jstart = nn_hls + 2                                 ! halo + land + 1
[15548]1853         jend   = nn_hls + nbghostcells + ispon          ! halo + land + nbghostcells + sponge
1854         istart = nn_hls + 2 
1855         iend   = jpiglo - nn_hls - 1 
[14086]1856         DO jj = mj0(jstart), mj1(jend)
1857            DO ji = mi0(istart), mi1(iend)
1858               IF ( ABS(ht0_parent(ji,jj)-ht_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
[15548]1859               IF ( .NOT.ln_vert_remap) THEN
1860                  DO jk = 1, jpkm1
1861                     IF ( ABS(e3t0_parent(ji,jj,jk)-e3t_0(ji,jj,jk))*tmask(ji,jj,jk) > 1.e-3 ) iindic = iindic + 1
1862                  END DO
1863               ENDIF
[14086]1864            END DO
1865            DO ji = mi0(istart), mi1(iend-1)
1866               IF ( ABS(hu0_parent(ji,jj)-hu_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
[15548]1867               IF ( .NOT.ln_vert_remap) THEN
1868                  DO jk = 1, jpkm1
1869                     IF ( ABS(e3u0_parent(ji,jj,jk)-e3u_0(ji,jj,jk))*umask(ji,jj,jk) > 1.e-3 ) iindic = iindic + 1
1870                  END DO
1871               ENDIF
[14086]1872            END DO
1873         END DO
1874         DO jj = mj0(jstart), mj1(jend-1)
1875            DO ji = mi0(istart), mi1(iend)
1876               IF ( ABS(hv0_parent(ji,jj)-hv_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
[15548]1877               IF ( .NOT.ln_vert_remap) THEN
1878                  DO jk = 1, jpkm1
1879                     IF ( ABS(e3v0_parent(ji,jj,jk)-e3v_0(ji,jj,jk))*vmask(ji,jj,jk) > 1.e-3 ) iindic = iindic + 1
1880                  END DO
1881               ENDIF
[14086]1882            END DO
1883         END DO
1884      ENDIF
1885      !
1886      ! --- North --- !
1887      IF(lk_north) THEN
1888         ispon  = nn_sponge_len * Agrif_irhoy() 
[15548]1889         jstart = jpjglo - ( nn_hls + nbghostcells + ispon - 1)  ! halo + land + nbghostcells +sponge - 1
1890         jend   = jpjglo - nn_hls - 1                            ! halo + land + 1            - 1
1891         istart = nn_hls + 2 
1892         iend   = jpiglo - nn_hls - 1 
[14086]1893         DO jj = mj0(jstart), mj1(jend)
1894            DO ji = mi0(istart), mi1(iend)
1895               IF ( ABS(ht0_parent(ji,jj)-ht_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
[15548]1896               IF ( .NOT.ln_vert_remap) THEN
1897                  DO jk = 1, jpkm1
1898                     IF ( ABS(e3t0_parent(ji,jj,jk)-e3t_0(ji,jj,jk))*tmask(ji,jj,jk) > 1.e-3 ) iindic = iindic + 1
1899                  END DO
1900               ENDIF
[14086]1901            END DO
1902            DO ji = mi0(istart), mi1(iend-1)
1903               IF ( ABS(hu0_parent(ji,jj)-hu_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
[15548]1904               IF ( .NOT.ln_vert_remap) THEN
1905                  DO jk = 1, jpkm1
1906                     IF ( ABS(e3u0_parent(ji,jj,jk)-e3u_0(ji,jj,jk))*umask(ji,jj,jk) > 1.e-3 ) iindic = iindic + 1
1907                  END DO
1908               ENDIF
[14086]1909            END DO
1910         END DO
[15548]1911         DO jj = mj0(jstart), mj1(jend-1)
[14086]1912            DO ji = mi0(istart), mi1(iend)
1913               IF ( ABS(hv0_parent(ji,jj)-hv_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1
[15548]1914               IF ( .NOT.ln_vert_remap) THEN
1915                  DO jk = 1, jpkm1
1916                     IF ( ABS(e3v0_parent(ji,jj,jk)-e3v_0(ji,jj,jk))*vmask(ji,jj,jk) > 1.e-3 ) iindic = iindic + 1
1917                  END DO
1918               ENDIF
[14086]1919            END DO
1920         END DO
1921      ENDIF
1922      !
1923   END SUBROUTINE Agrif_check_bat
[13216]1924   
[390]1925#else
[1605]1926   !!----------------------------------------------------------------------
1927   !!   Empty module                                          no AGRIF zoom
1928   !!----------------------------------------------------------------------
[636]1929CONTAINS
[9570]1930   SUBROUTINE Agrif_OCE_Interp_empty
1931      WRITE(*,*)  'agrif_oce_interp : You should not have seen this print! error?'
1932   END SUBROUTINE Agrif_OCE_Interp_empty
[390]1933#endif
[1605]1934
1935   !!======================================================================
[9570]1936END MODULE agrif_oce_interp
Note: See TracBrowser for help on using the repository browser.