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.
Changeset 12377 for NEMO/trunk/src/NST – NEMO

Changeset 12377 for NEMO/trunk/src/NST


Ignore:
Timestamp:
2020-02-12T15:39:06+01:00 (4 years ago)
Author:
acc
Message:

The big one. Merging all 2019 developments from the option 1 branch back onto the trunk.

This changeset reproduces 2019/dev_r11943_MERGE_2019 on the trunk using a 2-URL merge
onto a working copy of the trunk. I.e.:

svn merge --ignore-ancestry \

​svn+ssh://acc@forge.ipsl.jussieu.fr/ipsl/forge/projets/nemo/svn/NEMO/trunk \
​svn+ssh://acc@forge.ipsl.jussieu.fr/ipsl/forge/projets/nemo/svn/NEMO/branches/2019/dev_r11943_MERGE_2019 ./

The --ignore-ancestry flag avoids problems that may otherwise arise from the fact that
the merge history been trunk and branch may have been applied in a different order but
care has been taken before this step to ensure that all applicable fixes and updates
are present in the merge branch.

The trunk state just before this step has been branched to releases/release-4.0-HEAD
and that branch has been immediately tagged as releases/release-4.0.2. Any fixes
or additions in response to tickets on 4.0, 4.0.1 or 4.0.2 should be done on
releases/release-4.0-HEAD. From now on future 'point' releases (e.g. 4.0.2) will
remain unchanged with periodic releases as needs demand. Note release-4.0-HEAD is a
transitional naming convention. Future full releases, say 4.2, will have a release-4.2
branch which fulfills this role and the first point release (e.g. 4.2.0) will be made
immediately following the release branch creation.

2020 developments can be started from any trunk revision later than this one.

Location:
NEMO/trunk
Files:
11 edited
1 copied

Legend:

Unmodified
Added
Removed

  • NEMO/trunk

    • Property svn:externals

      •  

        old new  
        33^/utils/build/mk@HEAD         mk 
        44^/utils/tools@HEAD            tools 
        5 ^/vendors/AGRIF/dev@HEAD      ext/AGRIF 
         5^/vendors/AGRIF/dev_r11615_ENHANCE-04_namelists_as_internalfiles_agrif@HEAD      ext/AGRIF 
        66^/vendors/FCM@HEAD            ext/FCM 
        77^/vendors/IOIPSL@HEAD         ext/IOIPSL 

  • NEMO/trunk/src/NST/agrif_all_update.F90

    r10069 r12377  
    1 #define TWO_WAY 
    2  
    3  MODULE agrif_all_update 
     1MODULE agrif_all_update 
    42   !!====================================================================== 
    53   !!                   ***  MODULE  agrif_all_update  *** 
    … …  
    4139      !!               Order of update matters here ! 
    4240      !!---------------------------------------------------------------------- 
    43 # if defined TWO_WAY 
    44       IF (Agrif_Root()) RETURN 
     41      IF (( .NOT.ln_agrif_2way ).OR.(Agrif_Root())) RETURN 
    4542      ! 
    4643      IF (lwp.AND.lk_agrif_debug) Write(*,*) ' --> START AGRIF UPDATE from grid Number',Agrif_Fixed() 
    … …  
    6764      ! 
    6865      Agrif_UseSpecialValueInUpdate = .FALSE. 
    69 #endif 
    7066    END SUBROUTINE agrif_Update_All 
    7167 

  • NEMO/trunk/src/NST/agrif_ice_update.F90

    r10069 r12377  
    1 #define TWO_WAY 
    2 !!#undef TWO_WAY 
    31#undef DECAL_FEEDBACK  /* SEPARATION of INTERFACES*/ 
    42 
    … …  
    6361      Agrif_UseSpecialValueInUpdate = .TRUE. 
    6462 
    65 # if defined TWO_WAY 
    6663# if ! defined DECAL_FEEDBACK 
    6764      CALL Agrif_Update_Variable( tra_ice_id , procname = update_tra_ice  ) 
    … …  
    7976!      CALL Agrif_Update_Variable( u_ice_id   , locupdate=(/0,1/), procname = update_u_ice    ) 
    8077!      CALL Agrif_Update_Variable( v_ice_id   , locupdate=(/0,1/), procname = update_v_ice    ) 
    81 # endif 
    8278      Agrif_SpecialValueFineGrid    = 0. 
    8379      Agrif_UseSpecialValueInUpdate = .FALSE. 

  • NEMO/trunk/src/NST/agrif_oce.F90

    r10425 r12377  
    1717 
    1818   PUBLIC agrif_oce_alloc ! routine called by nemo_init in nemogcm.F90 
    19 #if defined key_vertical 
    20    PUBLIC reconstructandremap ! remapping routine 
    21 #endif    
     19   
    2220   !                                              !!* Namelist namagrif: AGRIF parameters 
    23    LOGICAL , PUBLIC ::   ln_spc_dyn    = .FALSE.   !: 
    24    INTEGER , PUBLIC, PARAMETER ::   nn_sponge_len = 2  !: Sponge width (in number of parent grid points) 
     21   LOGICAL , PUBLIC ::   ln_agrif_2way = .TRUE.    !: activate two way nesting  
     22   LOGICAL , PUBLIC ::   ln_spc_dyn    = .FALSE.   !: use zeros (.false.) or not (.true.) in 
     23                                                   !: bdys dynamical fields interpolation 
    2524   REAL(wp), PUBLIC ::   rn_sponge_tra = 2800.     !: sponge coeff. for tracers 
    2625   REAL(wp), PUBLIC ::   rn_sponge_dyn = 2800.     !: sponge coeff. for dynamics 
     26   REAL(wp), PUBLIC ::   rn_trelax_tra = 0.01      !: time relaxation parameter for tracers 
     27   REAL(wp), PUBLIC ::   rn_trelax_dyn = 0.01      !: time relaxation parameter for momentum 
    2728   LOGICAL , PUBLIC ::   ln_chk_bathy  = .FALSE.   !: check of parent bathymetry  
    28    LOGICAL , PUBLIC ::   lk_agrif_clp  = .FALSE.   !: Force clamped bcs 
    29    !                                              !!! OLD namelist names 
    30    REAL(wp), PUBLIC ::   visc_tra                  !: sponge coeff. for tracers 
    31    REAL(wp), PUBLIC ::   visc_dyn                  !: sponge coeff. for dynamics 
    32  
     29   ! 
     30   INTEGER , PUBLIC, PARAMETER ::   nn_sponge_len = 2  !: Sponge width (in number of parent grid points) 
    3331   LOGICAL , PUBLIC :: spongedoneT = .FALSE.       !: tracer   sponge layer indicator 
    3432   LOGICAL , PUBLIC :: spongedoneU = .FALSE.       !: dynamics sponge layer indicator 
    … …  
    4240   LOGICAL , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tabspongedone_u 
    4341   LOGICAL , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tabspongedone_v 
    44    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fsaht_spu, fsaht_spv !: sponge diffusivities 
    45    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fsahm_spt, fsahm_spf !: sponge viscosities 
     42   INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: utint_stage 
     43   INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: vtint_stage 
     44   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fspu, fspv !: sponge arrays 
     45   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fspt, fspf !:   "      " 
    4646 
    4747   ! Barotropic arrays used to store open boundary data during time-splitting loop: 
    48    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::  ubdy_w, vbdy_w, hbdy_w 
    49    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::  ubdy_e, vbdy_e, hbdy_e 
    50    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::  ubdy_n, vbdy_n, hbdy_n 
    51    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::  ubdy_s, vbdy_s, hbdy_s 
     48   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::  ubdy, vbdy, hbdy 
     49   INTEGER , PUBLIC,              SAVE                 ::  Kbb_a, Kmm_a, Krhs_a   !: AGRIF module-specific copies of time-level indices 
    5250 
     51# if defined key_vertical 
     52   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ht0_parent, hu0_parent, hv0_parent 
     53   INTEGER,  PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mbkt_parent, mbku_parent, mbkv_parent 
     54# endif 
    5355 
    5456   INTEGER, PUBLIC :: tsn_id                                                  ! AGRIF profile for tracers interpolation and update 
    … …  
    6466   INTEGER, PUBLIC :: scales_t_id 
    6567   INTEGER, PUBLIC :: avt_id, avm_id, en_id                ! TKE related identificators 
    66    INTEGER, PUBLIC :: umsk_id, vmsk_id 
     68   INTEGER, PUBLIC :: mbkt_id, ht0_id 
    6769   INTEGER, PUBLIC :: kindic_agr 
    6870    
    … …  
    8284      ierr(:) = 0 
    8385      ! 
    84       ALLOCATE( fsaht_spu(jpi,jpj), fsaht_spv(jpi,jpj),   & 
    85          &      fsahm_spt(jpi,jpj), fsahm_spf(jpi,jpj),   & 
    86          &      tabspongedone_tsn(jpi,jpj),           & 
     86      ALLOCATE( fspu(jpi,jpj), fspv(jpi,jpj),          & 
     87         &      fspt(jpi,jpj), fspf(jpi,jpj),               & 
     88         &      tabspongedone_tsn(jpi,jpj),                 & 
     89         &      utint_stage(jpi,jpj), vtint_stage(jpi,jpj), & 
    8790# if defined key_top          
    8891         &      tabspongedone_trn(jpi,jpj),           & 
    89 # endif          
     92# endif    
     93# if defined key_vertical 
     94         &      ht0_parent(jpi,jpj), mbkt_parent(jpi,jpj),  & 
     95         &      hu0_parent(jpi,jpj), mbku_parent(jpi,jpj),  & 
     96         &      hv0_parent(jpi,jpj), mbkv_parent(jpi,jpj),  & 
     97# endif       
    9098         &      tabspongedone_u  (jpi,jpj),           & 
    9199         &      tabspongedone_v  (jpi,jpj), STAT = ierr(1) ) 
    92100 
    93       ALLOCATE( ubdy_w(nbghostcells,jpj), vbdy_w(nbghostcells,jpj), hbdy_w(nbghostcells,jpj),   & 
    94          &      ubdy_e(nbghostcells,jpj), vbdy_e(nbghostcells,jpj), hbdy_e(nbghostcells,jpj),   &  
    95          &      ubdy_n(jpi,nbghostcells), vbdy_n(jpi,nbghostcells), hbdy_n(jpi,nbghostcells),   &  
    96          &      ubdy_s(jpi,nbghostcells), vbdy_s(jpi,nbghostcells), hbdy_s(jpi,nbghostcells), STAT = ierr(2) ) 
     101      ALLOCATE( ubdy(jpi,jpj), vbdy(jpi,jpj), hbdy(jpi,jpj), STAT = ierr(2) ) 
    97102 
    98103      agrif_oce_alloc = MAXVAL(ierr) 
    … …  
    100105   END FUNCTION agrif_oce_alloc 
    101106 
    102 #if defined key_vertical 
    103    SUBROUTINE reconstructandremap(tabin,hin,tabout,hout,N,Nout)       
    104       !!---------------------------------------------------------------------- 
    105       !!                ***  FUNCTION reconstructandremap  *** 
    106       !!---------------------------------------------------------------------- 
    107       IMPLICIT NONE 
    108       INTEGER N, Nout 
    109       REAL(wp) tabin(N), tabout(Nout) 
    110       REAL(wp) hin(N), hout(Nout) 
    111       REAL(wp) coeffremap(N,3),zwork(N,3) 
    112       REAL(wp) zwork2(N+1,3) 
    113       INTEGER jk 
    114       DOUBLE PRECISION, PARAMETER :: dsmll=1.0d-8   
    115       REAL(wp) q,q01,q02,q001,q002,q0 
    116       REAL(wp) z_win(1:N+1), z_wout(1:Nout+1) 
    117       REAL(wp),PARAMETER :: dpthin = 1.D-3 
    118       INTEGER :: k1, kbox, ktop, ka, kbot 
    119       REAL(wp) :: tsum, qbot, rpsum, zbox, ztop, zthk, zbot, offset, qtop 
    120  
    121       z_win(1)=0.; z_wout(1)= 0. 
    122       DO jk=1,N 
    123          z_win(jk+1)=z_win(jk)+hin(jk) 
    124       ENDDO  
    125        
    126       DO jk=1,Nout 
    127          z_wout(jk+1)=z_wout(jk)+hout(jk)        
    128       ENDDO        
    129  
    130       DO jk=2,N 
    131          zwork(jk,1)=1./(hin(jk-1)+hin(jk)) 
    132       ENDDO 
    133          
    134       DO jk=2,N-1 
    135          q0 = 1./(hin(jk-1)+hin(jk)+hin(jk+1)) 
    136          zwork(jk,2)=hin(jk-1)+2.*hin(jk)+hin(jk+1) 
    137          zwork(jk,3)=q0 
    138       ENDDO        
    139       
    140       DO jk= 2,N 
    141          zwork2(jk,1)=zwork(jk,1)*(tabin(jk)-tabin(jk-1)) 
    142       ENDDO 
    143          
    144       coeffremap(:,1) = tabin(:) 
    145   
    146       DO jk=2,N-1 
    147          q001 = hin(jk)*zwork2(jk+1,1) 
    148          q002 = hin(jk)*zwork2(jk,1)         
    149          IF (q001*q002 < 0) then 
    150             q001 = 0. 
    151             q002 = 0. 
    152          ENDIF 
    153          q=zwork(jk,2) 
    154          q01=q*zwork2(jk+1,1) 
    155          q02=q*zwork2(jk,1) 
    156          IF (abs(q001) > abs(q02)) q001 = q02 
    157          IF (abs(q002) > abs(q01)) q002 = q01 
    158          
    159          q=(q001-q002)*zwork(jk,3) 
    160          q001=q001-q*hin(jk+1) 
    161          q002=q002+q*hin(jk-1) 
    162          
    163          coeffremap(jk,3)=coeffremap(jk,1)+q001 
    164          coeffremap(jk,2)=coeffremap(jk,1)-q002 
    165          
    166          zwork2(jk,1)=(2.*q001-q002)**2 
    167          zwork2(jk,2)=(2.*q002-q001)**2 
    168       ENDDO 
    169          
    170       DO jk=1,N 
    171          IF(jk.EQ.1 .OR. jk.EQ.N .OR. hin(jk).LE.dpthin) THEN 
    172             coeffremap(jk,3) = coeffremap(jk,1) 
    173             coeffremap(jk,2) = coeffremap(jk,1) 
    174             zwork2(jk,1) = 0. 
    175             zwork2(jk,2) = 0. 
    176          ENDIF 
    177       ENDDO 
    178          
    179       DO jk=2,N 
    180          q002=max(zwork2(jk-1,2),dsmll) 
    181          q001=max(zwork2(jk,1),dsmll) 
    182          zwork2(jk,3)=(q001*coeffremap(jk-1,3)+q002*coeffremap(jk,2))/(q001+q002) 
    183       ENDDO 
    184          
    185       zwork2(1,3) = 2*coeffremap(1,1)-zwork2(2,3) 
    186       zwork2(N+1,3)=2*coeffremap(N,1)-zwork2(N,3) 
    187   
    188       DO jk=1,N 
    189          q01=zwork2(jk+1,3)-coeffremap(jk,1) 
    190          q02=coeffremap(jk,1)-zwork2(jk,3) 
    191          q001=2.*q01 
    192          q002=2.*q02 
    193          IF (q01*q02<0) then 
    194             q01=0. 
    195             q02=0. 
    196          ELSEIF (abs(q01)>abs(q002)) then 
    197             q01=q002 
    198          ELSEIF (abs(q02)>abs(q001)) then 
    199             q02=q001 
    200          ENDIF 
    201          coeffremap(jk,2)=coeffremap(jk,1)-q02 
    202          coeffremap(jk,3)=coeffremap(jk,1)+q01 
    203       ENDDO 
    204  
    205       zbot=0.0 
    206       kbot=1 
    207       DO jk=1,Nout 
    208          ztop=zbot  !top is bottom of previous layer 
    209          ktop=kbot 
    210          IF     (ztop.GE.z_win(ktop+1)) then 
    211             ktop=ktop+1 
    212          ENDIF 
    213          
    214          zbot=z_wout(jk+1) 
    215          zthk=zbot-ztop 
    216  
    217          IF(zthk.GT.dpthin .AND. ztop.LT.z_wout(Nout+1)) THEN 
    218  
    219             kbot=ktop 
    220             DO while (z_win(kbot+1).lt.zbot.and.kbot.lt.N) 
    221                kbot=kbot+1 
    222             ENDDO 
    223             zbox=zbot 
    224             DO k1= jk+1,Nout 
    225                IF     (z_wout(k1+1)-z_wout(k1).GT.dpthin) THEN 
    226                   exit !thick layer 
    227                ELSE 
    228                   zbox=z_wout(k1+1)  !include thin adjacent layers 
    229                   IF(zbox.EQ.z_wout(Nout+1)) THEN 
    230                      exit !at bottom 
    231                   ENDIF 
    232                ENDIF 
    233             ENDDO 
    234             zthk=zbox-ztop 
    235  
    236             kbox=ktop 
    237             DO while (z_win(kbox+1).lt.zbox.and.kbox.lt.N) 
    238                kbox=kbox+1 
    239             ENDDO 
    240            
    241             IF(ktop.EQ.kbox) THEN 
    242                IF(z_wout(jk).NE.z_win(kbox).OR.z_wout(jk+1).NE.z_win(kbox+1)) THEN 
    243                   IF(hin(kbox).GT.dpthin) THEN 
    244                      q001 = (zbox-z_win(kbox))/hin(kbox) 
    245                      q002 = (ztop-z_win(kbox))/hin(kbox) 
    246                      q01=q001**2+q002**2+q001*q002+1.-2.*(q001+q002) 
    247                      q02=q01-1.+(q001+q002) 
    248                      q0=1.-q01-q02 
    249                   ELSE 
    250                      q0 = 1.0 
    251                      q01 = 0. 
    252                      q02 = 0. 
    253                   ENDIF 
    254                   tabout(jk)=q0*coeffremap(kbox,1)+q01*coeffremap(kbox,2)+q02*coeffremap(kbox,3) 
    255                ELSE 
    256                   tabout(jk) = tabin(kbox) 
    257                ENDIF  
    258             ELSE 
    259                IF(ktop.LE.jk .AND. kbox.GE.jk) THEN 
    260                   ka = jk 
    261                ELSEIF (kbox-ktop.GE.3) THEN 
    262                   ka = (kbox+ktop)/2 
    263                ELSEIF (hin(ktop).GE.hin(kbox)) THEN 
    264                   ka = ktop 
    265                ELSE 
    266                   ka = kbox 
    267                ENDIF !choose ka 
    268      
    269                offset=coeffremap(ka,1) 
    270      
    271                qtop = z_win(ktop+1)-ztop !partial layer thickness 
    272                IF(hin(ktop).GT.dpthin) THEN 
    273                   q=(ztop-z_win(ktop))/hin(ktop) 
    274                   q01=q*(q-1.) 
    275                   q02=q01+q 
    276                   q0=1-q01-q02             
    277                ELSE 
    278                   q0 = 1. 
    279                   q01 = 0. 
    280                   q02 = 0. 
    281                ENDIF 
    282                 
    283                tsum =((q0*coeffremap(ktop,1)+q01*coeffremap(ktop,2)+q02*coeffremap(ktop,3))-offset)*qtop 
    284      
    285                DO k1= ktop+1,kbox-1 
    286                   tsum =tsum +(coeffremap(k1,1)-offset)*hin(k1) 
    287                ENDDO !k1 
    288                 
    289                qbot = zbox-z_win(kbox) !partial layer thickness 
    290                IF(hin(kbox).GT.dpthin) THEN 
    291                   q=qbot/hin(kbox) 
    292                   q01=(q-1.)**2 
    293                   q02=q01-1.+q 
    294                   q0=1-q01-q02                             
    295                ELSE 
    296                   q0 = 1.0 
    297                   q01 = 0. 
    298                   q02 = 0. 
    299                ENDIF 
    300                
    301                tsum = tsum +((q0*coeffremap(kbox,1)+q01*coeffremap(kbox,2)+q02*coeffremap(kbox,3))-offset)*qbot 
    302                 
    303                rpsum=1.0d0/zthk 
    304                tabout(jk)=offset+tsum*rpsum 
    305                   
    306             ENDIF !single or multiple layers 
    307          ELSE 
    308             IF (jk==1) THEN 
    309                write(*,'(a7,i4,i4,3f12.5)')'problem = ',N,Nout,zthk,z_wout(jk+1),hout(1) 
    310             ENDIF 
    311             tabout(jk) = tabout(jk-1) 
    312               
    313          ENDIF !normal:thin layer 
    314       ENDDO !jk 
    315              
    316       return 
    317       end subroutine reconstructandremap 
    318 #endif 
    319  
    320107#endif 
    321108   !!====================================================================== 

  • NEMO/trunk/src/NST/agrif_oce_interp.F90

    r10068 r12377  
    3333   USE agrif_oce_sponge 
    3434   USE lib_mpp 
     35   USE vremap 
    3536  
    3637   IMPLICIT NONE 
    3738   PRIVATE 
    3839 
    39    PUBLIC   Agrif_dyn, Agrif_ssh, Agrif_dyn_ts, Agrif_ssh_ts, Agrif_dta_ts 
     40   PUBLIC   Agrif_dyn, Agrif_ssh, Agrif_dyn_ts, Agrif_dyn_ts_flux, Agrif_ssh_ts, Agrif_dta_ts 
    4041   PUBLIC   Agrif_tra, Agrif_avm 
    4142   PUBLIC   interpun , interpvn 
    4243   PUBLIC   interptsn, interpsshn, interpavm 
    4344   PUBLIC   interpunb, interpvnb , interpub2b, interpvb2b 
    44    PUBLIC   interpe3t, interpumsk, interpvmsk 
    45  
     45   PUBLIC   interpe3t 
     46#if defined key_vertical 
     47   PUBLIC   interpht0, interpmbkt 
     48# endif 
    4649   INTEGER ::   bdy_tinterp = 0 
    4750 
    48 #  include "vectopt_loop_substitute.h90" 
    4951   !!---------------------------------------------------------------------- 
    5052   !! NEMO/NST 4.0 , NEMO Consortium (2018) 
    … …  
    7880      ! 
    7981      INTEGER ::   ji, jj, jk       ! dummy loop indices 
    80       INTEGER ::   j1, j2, i1, i2 
    8182      INTEGER ::   ibdy1, jbdy1, ibdy2, jbdy2 
    8283      REAL(wp), DIMENSION(jpi,jpj) ::   zub, zvb 
    … …  
    9394      Agrif_UseSpecialValue = .FALSE. 
    9495      ! 
    95       ! prevent smoothing in ghost cells 
    96       i1 =  1   ;   i2 = nlci 
    97       j1 =  1   ;   j2 = nlcj 
    98       IF( nbondj == -1 .OR. nbondj == 2 )   j1 = 2 + nbghostcells 
    99       IF( nbondj == +1 .OR. nbondj == 2 )   j2 = nlcj - nbghostcells - 1 
    100       IF( nbondi == -1 .OR. nbondi == 2 )   i1 = 2 + nbghostcells  
    101       IF( nbondi == +1 .OR. nbondi == 2 )   i2 = nlci - nbghostcells - 1 
    102  
    10396      ! --- West --- ! 
    104       IF( nbondi == -1 .OR. nbondi == 2 ) THEN 
    105          ibdy1 = 2 
    106          ibdy2 = 1+nbghostcells  
    107          ! 
    108          IF( .NOT.ln_dynspg_ts ) THEN  ! Store transport 
    109             ua_b(ibdy1:ibdy2,:) = 0._wp 
     97      ibdy1 = 2 
     98      ibdy2 = 1+nbghostcells  
     99      ! 
     100      IF( .NOT.ln_dynspg_ts ) THEN  ! Store transport 
     101         DO ji = mi0(ibdy1), mi1(ibdy2) 
     102            uu_b(ji,:,Krhs_a) = 0._wp 
     103 
    110104            DO jk = 1, jpkm1 
    111105               DO jj = 1, jpj 
    112                   ua_b(ibdy1:ibdy2,jj) = ua_b(ibdy1:ibdy2,jj) &  
    113                       & + e3u_a(ibdy1:ibdy2,jj,jk) * ua(ibdy1:ibdy2,jj,jk) * umask(ibdy1:ibdy2,jj,jk) 
    114                END DO 
    115             END DO 
     106                  uu_b(ji,jj,Krhs_a) = uu_b(ji,jj,Krhs_a) + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk) 
     107               END DO 
     108            END DO 
     109 
    116110            DO jj = 1, jpj 
    117                ua_b(ibdy1:ibdy2,jj) = ua_b(ibdy1:ibdy2,jj) * r1_hu_a(ibdy1:ibdy2,jj) 
    118             END DO 
    119          ENDIF 
    120          ! 
    121          IF( .NOT.lk_agrif_clp ) THEN 
    122             DO jk=1,jpkm1              ! Smooth 
    123                DO jj=j1,j2 
    124                   ua(ibdy2,jj,jk) = 0.25_wp*(ua(ibdy2-1,jj,jk)+2._wp*ua(ibdy2,jj,jk)+ua(ibdy2+1,jj,jk)) 
    125                END DO 
    126             END DO 
    127          ENDIF 
    128          ! 
    129          zub(ibdy1:ibdy2,:) = 0._wp    ! Correct transport 
     111               uu_b(ji,jj,Krhs_a) = uu_b(ji,jj,Krhs_a) * r1_hu(ji,jj,Krhs_a) 
     112            END DO 
     113         END DO 
     114      ENDIF 
     115      ! 
     116      DO ji = mi0(ibdy1), mi1(ibdy2) 
     117         zub(ji,:) = 0._wp    ! Correct transport 
    130118         DO jk = 1, jpkm1 
    131119            DO jj = 1, jpj 
    132                zub(ibdy1:ibdy2,jj) = zub(ibdy1:ibdy2,jj) &  
    133                   & + e3u_a(ibdy1:ibdy2,jj,jk)  * ua(ibdy1:ibdy2,jj,jk)*umask(ibdy1:ibdy2,jj,jk) 
     120               zub(ji,jj) = zub(ji,jj) &  
     121                  & + e3u(ji,jj,jk,Krhs_a)  * uu(ji,jj,jk,Krhs_a)*umask(ji,jj,jk) 
    134122            END DO 
    135123         END DO 
    136124         DO jj=1,jpj 
    137             zub(ibdy1:ibdy2,jj) = zub(ibdy1:ibdy2,jj) * r1_hu_a(ibdy1:ibdy2,jj) 
     125            zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a) 
    138126         END DO 
    139127             
    140128         DO jk = 1, jpkm1 
    141129            DO jj = 1, jpj 
    142                ua(ibdy1:ibdy2,jj,jk) = ( ua(ibdy1:ibdy2,jj,jk) & 
    143                  & + ua_b(ibdy1:ibdy2,jj)-zub(ibdy1:ibdy2,jj)) * umask(ibdy1:ibdy2,jj,jk) 
    144             END DO 
    145          END DO 
     130               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) 
     131            END DO 
     132         END DO 
     133      END DO 
    146134             
    147          IF( ln_dynspg_ts ) THEN       ! Set tangential velocities to time splitting estimate 
    148             zvb(ibdy1:ibdy2,:) = 0._wp 
     135      IF( ln_dynspg_ts ) THEN       ! Set tangential velocities to time splitting estimate 
     136         DO ji = mi0(ibdy1), mi1(ibdy2) 
     137            zvb(ji,:) = 0._wp 
    149138            DO jk = 1, jpkm1 
    150139               DO jj = 1, jpj 
    151                   zvb(ibdy1:ibdy2,jj) = zvb(ibdy1:ibdy2,jj) &  
    152                      & + e3v_a(ibdy1:ibdy2,jj,jk) * va(ibdy1:ibdy2,jj,jk) * vmask(ibdy1:ibdy2,jj,jk) 
     140                  zvb(ji,jj) = zvb(ji,jj) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk) 
    153141               END DO 
    154142            END DO 
    155143            DO jj = 1, jpj 
    156                zvb(ibdy1:ibdy2,jj) = zvb(ibdy1:ibdy2,jj) * r1_hv_a(ibdy1:ibdy2,jj) 
     144               zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a) 
    157145            END DO 
    158146            DO jk = 1, jpkm1 
    159147               DO jj = 1, jpj 
    160                   va(ibdy1:ibdy2,jj,jk) = ( va(ibdy1:ibdy2,jj,jk) &  
    161                     & + va_b(ibdy1:ibdy2,jj)-zvb(ibdy1:ibdy2,jj))*vmask(ibdy1:ibdy2,jj,jk) 
    162                END DO 
    163             END DO 
    164          ENDIF 
    165          ! 
    166          DO jk = 1, jpkm1              ! Mask domain edges 
    167             DO jj = 1, jpj 
    168                ua(1,jj,jk) = 0._wp 
    169                va(1,jj,jk) = 0._wp 
    170             END DO 
    171          END DO  
     148                  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) 
     149               END DO 
     150            END DO 
     151         END DO 
    172152      ENDIF 
    173153 
    174154      ! --- East --- ! 
    175       IF( nbondi ==  1 .OR. nbondi == 2 ) THEN 
    176          ibdy1 = nlci-1-nbghostcells 
    177          ibdy2 = nlci-2  
    178          ! 
    179          IF( .NOT.ln_dynspg_ts ) THEN  ! Store transport 
    180             ua_b(ibdy1:ibdy2,:) = 0._wp 
     155      ibdy1 = jpiglo-1-nbghostcells 
     156      ibdy2 = jpiglo-2  
     157      ! 
     158      IF( .NOT.ln_dynspg_ts ) THEN  ! Store transport 
     159         DO ji = mi0(ibdy1), mi1(ibdy2) 
     160            uu_b(ji,:,Krhs_a) = 0._wp 
    181161            DO jk = 1, jpkm1 
    182162               DO jj = 1, jpj 
    183                   ua_b(ibdy1:ibdy2,jj) = ua_b(ibdy1:ibdy2,jj) &  
    184                       & + e3u_a(ibdy1:ibdy2,jj,jk) * ua(ibdy1:ibdy2,jj,jk) * umask(ibdy1:ibdy2,jj,jk) 
     163                  uu_b(ji,jj,Krhs_a) = uu_b(ji,jj,Krhs_a) &  
     164                      & + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk) 
    185165               END DO 
    186166            END DO 
    187167            DO jj = 1, jpj 
    188                ua_b(ibdy1:ibdy2,jj) = ua_b(ibdy1:ibdy2,jj) * r1_hu_a(ibdy1:ibdy2,jj) 
    189             END DO 
    190          ENDIF 
    191          ! 
    192          IF( .NOT.lk_agrif_clp ) THEN 
    193             DO jk=1,jpkm1              ! Smooth 
    194                DO jj=j1,j2 
    195                   ua(ibdy1,jj,jk) = 0.25_wp*(ua(ibdy1-1,jj,jk)+2._wp*ua(ibdy1,jj,jk)+ua(ibdy1+1,jj,jk)) 
    196                END DO 
    197             END DO 
    198          ENDIF 
    199          ! 
    200          zub(ibdy1:ibdy2,:) = 0._wp    ! Correct transport 
     168               uu_b(ji,jj,Krhs_a) = uu_b(ji,jj,Krhs_a) * r1_hu(ji,jj,Krhs_a) 
     169            END DO 
     170         END DO 
     171      ENDIF 
     172      ! 
     173      DO ji = mi0(ibdy1), mi1(ibdy2) 
     174         zub(ji,:) = 0._wp    ! Correct transport 
    201175         DO jk = 1, jpkm1 
    202176            DO jj = 1, jpj 
    203                zub(ibdy1:ibdy2,jj) = zub(ibdy1:ibdy2,jj) &  
    204                   & + e3u_a(ibdy1:ibdy2,jj,jk)  * ua(ibdy1:ibdy2,jj,jk) * umask(ibdy1:ibdy2,jj,jk) 
     177               zub(ji,jj) = zub(ji,jj) &  
     178                  & + e3u(ji,jj,jk,Krhs_a)  * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk) 
    205179            END DO 
    206180         END DO 
    207181         DO jj=1,jpj 
    208             zub(ibdy1:ibdy2,jj) = zub(ibdy1:ibdy2,jj) * r1_hu_a(ibdy1:ibdy2,jj) 
     182            zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a) 
    209183         END DO 
    210184             
    211185         DO jk = 1, jpkm1 
    212186            DO jj = 1, jpj 
    213                ua(ibdy1:ibdy2,jj,jk) = ( ua(ibdy1:ibdy2,jj,jk) &  
    214                  & + ua_b(ibdy1:ibdy2,jj)-zub(ibdy1:ibdy2,jj))*umask(ibdy1:ibdy2,jj,jk) 
    215             END DO 
    216          END DO 
     187               uu(ji,jj,jk,Krhs_a) = ( uu(ji,jj,jk,Krhs_a) &  
     188                 & + uu_b(ji,jj,Krhs_a)-zub(ji,jj))*umask(ji,jj,jk) 
     189            END DO 
     190         END DO 
     191      END DO 
    217192             
    218          IF( ln_dynspg_ts ) THEN       ! Set tangential velocities to time splitting estimate 
    219             ibdy1 = ibdy1 + 1 
    220             ibdy2 = ibdy2 + 1  
    221             zvb(ibdy1:ibdy2,:) = 0._wp 
     193      IF( ln_dynspg_ts ) THEN       ! Set tangential velocities to time splitting estimate 
     194         ibdy1 = jpiglo-nbghostcells 
     195         ibdy2 = jpiglo-1  
     196         DO ji = mi0(ibdy1), mi1(ibdy2) 
     197            zvb(ji,:) = 0._wp 
    222198            DO jk = 1, jpkm1 
    223199               DO jj = 1, jpj 
    224                   zvb(ibdy1:ibdy2,jj) = zvb(ibdy1:ibdy2,jj) & 
    225                      & + e3v_a(ibdy1:ibdy2,jj,jk) * va(ibdy1:ibdy2,jj,jk) * vmask(ibdy1:ibdy2,jj,jk) 
     200                  zvb(ji,jj) = zvb(ji,jj) & 
     201                     & + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk) 
    226202               END DO 
    227203            END DO 
    228204            DO jj = 1, jpj 
    229                zvb(ibdy1:ibdy2,jj) = zvb(ibdy1:ibdy2,jj) * r1_hv_a(ibdy1:ibdy2,jj) 
     205               zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a) 
    230206            END DO 
    231207            DO jk = 1, jpkm1 
    232208               DO jj = 1, jpj 
    233                   va(ibdy1:ibdy2,jj,jk) = ( va(ibdy1:ibdy2,jj,jk) &  
    234                       & + va_b(ibdy1:ibdy2,jj)-zvb(ibdy1:ibdy2,jj)) * vmask(ibdy1:ibdy2,jj,jk) 
    235                END DO 
    236             END DO 
    237          ENDIF 
    238          ! 
    239          DO jk = 1, jpkm1              ! Mask domain edges 
    240             DO jj = 1, jpj 
    241                ua(nlci-1,jj,jk) = 0._wp 
    242                va(nlci  ,jj,jk) = 0._wp 
    243             END DO 
    244          END DO  
     209                  vv(ji,jj,jk,Krhs_a) = ( vv(ji,jj,jk,Krhs_a) &  
     210                      & + vv_b(ji,jj,Krhs_a)-zvb(ji,jj)) * vmask(ji,jj,jk) 
     211               END DO 
     212            END DO 
     213         END DO 
    245214      ENDIF 
    246215 
    247216      ! --- South --- ! 
    248       IF( nbondj == -1 .OR. nbondj == 2 ) THEN 
    249          jbdy1 = 2 
    250          jbdy2 = 1+nbghostcells  
    251          ! 
    252          IF( .NOT.ln_dynspg_ts ) THEN  ! Store transport 
    253             va_b(:,jbdy1:jbdy2) = 0._wp 
     217      jbdy1 = 2 
     218      jbdy2 = 1+nbghostcells  
     219      ! 
     220      IF( .NOT.ln_dynspg_ts ) THEN  ! Store transport 
     221         DO jj = mj0(jbdy1), mj1(jbdy2) 
     222            vv_b(:,jj,Krhs_a) = 0._wp 
    254223            DO jk = 1, jpkm1 
    255224               DO ji = 1, jpi 
    256                   va_b(ji,jbdy1:jbdy2) = va_b(ji,jbdy1:jbdy2) &  
    257                       & + e3v_a(ji,jbdy1:jbdy2,jk) * va(ji,jbdy1:jbdy2,jk) * vmask(ji,jbdy1:jbdy2,jk) 
     225                  vv_b(ji,jj,Krhs_a) = vv_b(ji,jj,Krhs_a) &  
     226                      & + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk) 
    258227               END DO 
    259228            END DO 
    260229            DO ji=1,jpi 
    261                va_b(ji,jbdy1:jbdy2) = va_b(ji,jbdy1:jbdy2) * r1_hv_a(ji,jbdy1:jbdy2) 
    262             END DO 
    263          ENDIF 
    264          ! 
    265          IF ( .NOT.lk_agrif_clp ) THEN 
    266             DO jk = 1, jpkm1           ! Smooth 
    267                DO ji = i1, i2 
    268                   va(ji,jbdy2,jk) = 0.25_wp*(va(ji,jbdy2-1,jk)+2._wp*va(ji,jbdy2,jk)+va(ji,jbdy2+1,jk)) 
    269                END DO 
    270             END DO 
    271          ENDIF 
    272          ! 
    273          zvb(:,jbdy1:jbdy2) = 0._wp    ! Correct transport 
     230               vv_b(ji,jj,Krhs_a) = vv_b(ji,jj,Krhs_a) * r1_hv(ji,jj,Krhs_a)      
     231            END DO 
     232         END DO 
     233      ENDIF 
     234      ! 
     235      DO jj = mj0(jbdy1), mj1(jbdy2) 
     236         zvb(:,jj) = 0._wp    ! Correct transport 
    274237         DO jk=1,jpkm1 
    275238            DO ji=1,jpi 
    276                zvb(ji,jbdy1:jbdy2) = zvb(ji,jbdy1:jbdy2) &  
    277                   & + e3v_a(ji,jbdy1:jbdy2,jk) * va(ji,jbdy1:jbdy2,jk) * vmask(ji,jbdy1:jbdy2,jk) 
     239               zvb(ji,jj) = zvb(ji,jj) &  
     240                  & + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk) 
    278241            END DO 
    279242         END DO 
    280243         DO ji = 1, jpi 
    281             zvb(ji,jbdy1:jbdy2) = zvb(ji,jbdy1:jbdy2) * r1_hv_a(ji,jbdy1:jbdy2) 
     244            zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a) 
    282245         END DO 
    283246 
    284247         DO jk = 1, jpkm1 
    285248            DO ji = 1, jpi 
    286                va(ji,jbdy1:jbdy2,jk) = ( va(ji,jbdy1:jbdy2,jk) &  
    287                  & + va_b(ji,jbdy1:jbdy2) - zvb(ji,jbdy1:jbdy2) ) * vmask(ji,jbdy1:jbdy2,jk) 
    288             END DO 
    289          END DO 
     249               vv(ji,jj,jk,Krhs_a) = ( vv(ji,jj,jk,Krhs_a) &  
     250                 & + vv_b(ji,jj,Krhs_a) - zvb(ji,jj) ) * vmask(ji,jj,jk) 
     251            END DO 
     252         END DO 
     253      END DO 
    290254             
    291          IF( ln_dynspg_ts ) THEN       ! Set tangential velocities to time splitting estimate 
    292             zub(:,jbdy1:jbdy2) = 0._wp 
     255      IF( ln_dynspg_ts ) THEN       ! Set tangential velocities to time splitting estimate 
     256         DO jj = mj0(jbdy1), mj1(jbdy2) 
     257            zub(:,jj) = 0._wp 
    293258            DO jk = 1, jpkm1 
    294259               DO ji = 1, jpi 
    295                   zub(ji,jbdy1:jbdy2) = zub(ji,jbdy1:jbdy2) &  
    296                      & + e3u_a(ji,jbdy1:jbdy2,jk) * ua(ji,jbdy1:jbdy2,jk) * umask(ji,jbdy1:jbdy2,jk) 
     260                  zub(ji,jj) = zub(ji,jj) &  
     261                     & + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk) 
    297262               END DO 
    298263            END DO 
    299264            DO ji = 1, jpi 
    300                zub(ji,jbdy1:jbdy2) = zub(ji,jbdy1:jbdy2) * r1_hu_a(ji,jbdy1:jbdy2) 
     265               zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a) 
    301266            END DO 
    302267                
    303268            DO jk = 1, jpkm1 
    304269               DO ji = 1, jpi 
    305                   ua(ji,jbdy1:jbdy2,jk) = ( ua(ji,jbdy1:jbdy2,jk) &  
    306                     & + ua_b(ji,jbdy1:jbdy2) - zub(ji,jbdy1:jbdy2) ) * umask(ji,jbdy1:jbdy2,jk) 
    307                END DO 
    308             END DO 
    309          ENDIF 
    310          ! 
    311          DO jk = 1, jpkm1              ! Mask domain edges 
    312             DO ji = 1, jpi 
    313                ua(ji,1,jk) = 0._wp 
    314                va(ji,1,jk) = 0._wp 
    315             END DO 
    316          END DO  
     270                  uu(ji,jj,jk,Krhs_a) = ( uu(ji,jj,jk,Krhs_a) &  
     271                    & + uu_b(ji,jj,Krhs_a) - zub(ji,jj) ) * umask(ji,jj,jk) 
     272               END DO 
     273            END DO 
     274         END DO 
    317275      ENDIF 
    318276 
    319277      ! --- North --- ! 
    320       IF( nbondj ==  1 .OR. nbondj == 2 ) THEN 
    321          jbdy1 = nlcj-1-nbghostcells 
    322          jbdy2 = nlcj-2  
    323          ! 
    324          IF( .NOT.ln_dynspg_ts ) THEN  ! Store transport 
    325             va_b(:,jbdy1:jbdy2) = 0._wp 
     278      jbdy1 = jpjglo-1-nbghostcells 
     279      jbdy2 = jpjglo-2  
     280      ! 
     281      IF( .NOT.ln_dynspg_ts ) THEN  ! Store transport 
     282         DO jj = mj0(jbdy1), mj1(jbdy2) 
     283            vv_b(:,jj,Krhs_a) = 0._wp 
    326284            DO jk = 1, jpkm1 
    327285               DO ji = 1, jpi 
    328                   va_b(ji,jbdy1:jbdy2) = va_b(ji,jbdy1:jbdy2) &  
    329                       & + e3v_a(ji,jbdy1:jbdy2,jk) * va(ji,jbdy1:jbdy2,jk) * vmask(ji,jbdy1:jbdy2,jk) 
     286                  vv_b(ji,jj,Krhs_a) = vv_b(ji,jj,Krhs_a) &  
     287                      & + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk) 
    330288               END DO 
    331289            END DO 
    332290            DO ji=1,jpi 
    333                va_b(ji,jbdy1:jbdy2) = va_b(ji,jbdy1:jbdy2) * r1_hv_a(ji,jbdy1:jbdy2) 
    334             END DO 
    335          ENDIF 
    336          ! 
    337          IF ( .NOT.lk_agrif_clp ) THEN 
    338             DO jk = 1, jpkm1           ! Smooth 
    339                DO ji = i1, i2 
    340                   va(ji,jbdy1,jk) = 0.25_wp*(va(ji,jbdy1-1,jk)+2._wp*va(ji,jbdy1,jk)+va(ji,jbdy1+1,jk)) 
    341                END DO 
    342             END DO 
    343          ENDIF 
    344          ! 
    345          zvb(:,jbdy1:jbdy2) = 0._wp    ! Correct transport 
     291               vv_b(ji,jj,Krhs_a) = vv_b(ji,jj,Krhs_a) * r1_hv(ji,jj,Krhs_a) 
     292            END DO 
     293         END DO 
     294      ENDIF 
     295      ! 
     296      DO jj = mj0(jbdy1), mj1(jbdy2) 
     297         zvb(:,jj) = 0._wp    ! Correct transport 
    346298         DO jk=1,jpkm1 
    347299            DO ji=1,jpi 
    348                zvb(ji,jbdy1:jbdy2) = zvb(ji,jbdy1:jbdy2) &  
    349                   & + e3v_a(ji,jbdy1:jbdy2,jk) * va(ji,jbdy1:jbdy2,jk) * vmask(ji,jbdy1:jbdy2,jk) 
     300               zvb(ji,jj) = zvb(ji,jj) &  
     301                  & + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk) 
    350302            END DO 
    351303         END DO 
    352304         DO ji = 1, jpi 
    353             zvb(ji,jbdy1:jbdy2) = zvb(ji,jbdy1:jbdy2) * r1_hv_a(ji,jbdy1:jbdy2) 
     305            zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a) 
    354306         END DO 
    355307 
    356308         DO jk = 1, jpkm1 
    357309            DO ji = 1, jpi 
    358                va(ji,jbdy1:jbdy2,jk) = ( va(ji,jbdy1:jbdy2,jk) &  
    359                  & + va_b(ji,jbdy1:jbdy2) - zvb(ji,jbdy1:jbdy2) ) * vmask(ji,jbdy1:jbdy2,jk) 
    360             END DO 
    361          END DO 
     310               vv(ji,jj,jk,Krhs_a) = ( vv(ji,jj,jk,Krhs_a) &  
     311                 & + vv_b(ji,jj,Krhs_a) - zvb(ji,jj) ) * vmask(ji,jj,jk) 
     312            END DO 
     313         END DO 
     314      END DO 
    362315             
    363          IF( ln_dynspg_ts ) THEN       ! Set tangential velocities to time splitting estimate 
    364             jbdy1 = jbdy1 + 1 
    365             jbdy2 = jbdy2 + 1  
    366             zub(:,jbdy1:jbdy2) = 0._wp 
     316      IF( ln_dynspg_ts ) THEN       ! Set tangential velocities to time splitting estimate 
     317         jbdy1 = jpjglo-nbghostcells 
     318         jbdy2 = jpjglo-1 
     319         DO jj = mj0(jbdy1), mj1(jbdy2) 
     320            zub(:,jj) = 0._wp 
    367321            DO jk = 1, jpkm1 
    368322               DO ji = 1, jpi 
    369                   zub(ji,jbdy1:jbdy2) = zub(ji,jbdy1:jbdy2) &  
    370                      & + e3u_a(ji,jbdy1:jbdy2,jk) * ua(ji,jbdy1:jbdy2,jk) * umask(ji,jbdy1:jbdy2,jk) 
     323                  zub(ji,jj) = zub(ji,jj) &  
     324                     & + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk) 
    371325               END DO 
    372326            END DO 
    373327            DO ji = 1, jpi 
    374                zub(ji,jbdy1:jbdy2) = zub(ji,jbdy1:jbdy2) * r1_hu_a(ji,jbdy1:jbdy2) 
     328               zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a) 
    375329            END DO 
    376330                
    377331            DO jk = 1, jpkm1 
    378332               DO ji = 1, jpi 
    379                   ua(ji,jbdy1:jbdy2,jk) = ( ua(ji,jbdy1:jbdy2,jk) &  
    380                     & + ua_b(ji,jbdy1:jbdy2) - zub(ji,jbdy1:jbdy2) ) * umask(ji,jbdy1:jbdy2,jk) 
    381                END DO 
    382             END DO 
    383          ENDIF 
    384          ! 
    385          DO jk = 1, jpkm1              ! Mask domain edges 
    386             DO ji = 1, jpi 
    387                ua(ji,nlcj  ,jk) = 0._wp 
    388                va(ji,nlcj-1,jk) = 0._wp 
    389             END DO 
    390          END DO  
     333                  uu(ji,jj,jk,Krhs_a) = ( uu(ji,jj,jk,Krhs_a) &  
     334                    & + uu_b(ji,jj,Krhs_a) - zub(ji,jj) ) * umask(ji,jj,jk) 
     335               END DO 
     336            END DO 
     337         END DO 
    391338      ENDIF 
    392339      ! 
    … …  
    401348      !! 
    402349      INTEGER :: ji, jj 
     350      INTEGER :: istart, iend, jstart, jend 
    403351      !!----------------------------------------------------------------------   
    404352      ! 
    405353      IF( Agrif_Root() )   RETURN 
    406354      ! 
    407       IF((nbondi == -1).OR.(nbondi == 2)) THEN 
     355      !--- West ---! 
     356      istart = 2 
     357      iend   = nbghostcells+1 
     358      DO ji = mi0(istart), mi1(iend) 
    408359         DO jj=1,jpj 
    409             va_e(2:nbghostcells+1,jj) = vbdy_w(1:nbghostcells,jj) * hvr_e(2:nbghostcells+1,jj) 
    410             ! Specified fluxes: 
    411             ua_e(2:nbghostcells+1,jj) = ubdy_w(1:nbghostcells,jj) * hur_e(2:nbghostcells+1,jj) 
    412             ! Characteristics method (only if ghostcells=1): 
    413             !alt            ua_e(2,jj) = 0.5_wp * ( ubdy_w(jj) * hur_e(2,jj) + ua_e(3,jj) & 
    414             !alt                       &           - sqrt(grav * hur_e(2,jj)) * (sshn_e(3,jj) - hbdy_w(jj)) ) 
    415          END DO 
    416       ENDIF 
    417       ! 
    418       IF((nbondi == 1).OR.(nbondi == 2)) THEN 
     360            va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj) 
     361            ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj) 
     362         END DO 
     363      END DO 
     364      ! 
     365      !--- East ---! 
     366      istart = jpiglo-nbghostcells 
     367      iend   = jpiglo-1 
     368      DO ji = mi0(istart), mi1(iend) 
    419369         DO jj=1,jpj 
    420             va_e(nlci-nbghostcells:nlci-1,jj)   = vbdy_e(1:nbghostcells,jj) * hvr_e(nlci-nbghostcells:nlci-1,jj) 
    421             ! Specified fluxes: 
    422             ua_e(nlci-nbghostcells-1:nlci-2,jj) = ubdy_e(1:nbghostcells,jj) * hur_e(nlci-nbghostcells-1:nlci-2,jj) 
    423             ! Characteristics method (only if ghostcells=1): 
    424             !alt            ua_e(nlci-2,jj) = 0.5_wp * ( ubdy_e(jj) * hur_e(nlci-2,jj) + ua_e(nlci-3,jj) & 
    425             !alt                            &           + sqrt(grav * hur_e(nlci-2,jj)) * (sshn_e(nlci-2,jj) - hbdy_e(jj)) ) 
    426          END DO 
    427       ENDIF 
    428       ! 
    429       IF((nbondj == -1).OR.(nbondj == 2)) THEN 
     370            va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj) 
     371         END DO 
     372      END DO 
     373      istart = jpiglo-nbghostcells-1 
     374      iend   = jpiglo-2 
     375      DO ji = mi0(istart), mi1(iend) 
     376         DO jj=1,jpj 
     377            ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj) 
     378         END DO 
     379      END DO 
     380      ! 
     381      !--- South ---! 
     382      jstart = 2 
     383      jend   = nbghostcells+1 
     384      DO jj = mj0(jstart), mj1(jend) 
    430385         DO ji=1,jpi 
    431             ua_e(ji,2:nbghostcells+1) = ubdy_s(ji,1:nbghostcells) * hur_e(ji,2:nbghostcells+1) 
    432             ! Specified fluxes: 
    433             va_e(ji,2:nbghostcells+1) = vbdy_s(ji,1:nbghostcells) * hvr_e(ji,2:nbghostcells+1) 
    434             ! Characteristics method (only if ghostcells=1): 
    435             !alt            va_e(ji,2) = 0.5_wp * ( vbdy_s(ji) * hvr_e(ji,2) + va_e(ji,3) & 
    436             !alt                       &           - sqrt(grav * hvr_e(ji,2)) * (sshn_e(ji,3) - hbdy_s(ji)) ) 
    437          END DO 
    438       ENDIF 
    439       ! 
    440       IF((nbondj == 1).OR.(nbondj == 2)) THEN 
     386            ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj) 
     387            va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj) 
     388         END DO 
     389      END DO 
     390      ! 
     391      !--- North ---! 
     392      jstart = jpjglo-nbghostcells 
     393      jend   = jpjglo-1 
     394      DO jj = mj0(jstart), mj1(jend) 
    441395         DO ji=1,jpi 
    442             ua_e(ji,nlcj-nbghostcells:nlcj-1)   = ubdy_n(ji,1:nbghostcells) * hur_e(ji,nlcj-nbghostcells:nlcj-1) 
    443             ! Specified fluxes: 
    444             va_e(ji,nlcj-nbghostcells-1:nlcj-2) = vbdy_n(ji,1:nbghostcells) * hvr_e(ji,nlcj-nbghostcells-1:nlcj-2) 
    445             ! Characteristics method (only if ghostcells=1): 
    446             !alt            va_e(ji,nlcj-2) = 0.5_wp * ( vbdy_n(ji) * hvr_e(ji,nlcj-2)  + va_e(ji,nlcj-3) & 
    447             !alt                            &           + sqrt(grav * hvr_e(ji,nlcj-2)) * (sshn_e(ji,nlcj-2) - hbdy_n(ji)) ) 
    448          END DO 
    449       ENDIF 
     396            ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj) 
     397         END DO 
     398      END DO 
     399      jstart = jpjglo-nbghostcells-1 
     400      jend   = jpjglo-2 
     401      DO jj = mj0(jstart), mj1(jend) 
     402         DO ji=1,jpi 
     403            va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj) 
     404         END DO 
     405      END DO 
    450406      ! 
    451407   END SUBROUTINE Agrif_dyn_ts 
    452408 
     409   SUBROUTINE Agrif_dyn_ts_flux( jn, zu, zv ) 
     410      !!---------------------------------------------------------------------- 
     411      !!                  ***  ROUTINE Agrif_dyn_ts_flux  *** 
     412      !!----------------------------------------------------------------------   
     413      INTEGER, INTENT(in) ::   jn 
     414      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   zu, zv 
     415      !! 
     416      INTEGER :: ji, jj 
     417      INTEGER :: istart, iend, jstart, jend 
     418      !!----------------------------------------------------------------------   
     419      ! 
     420      IF( Agrif_Root() )   RETURN 
     421      ! 
     422      !--- West ---! 
     423      istart = 2 
     424      iend   = nbghostcells+1 
     425      DO ji = mi0(istart), mi1(iend) 
     426         DO jj=1,jpj 
     427            zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj) 
     428            zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj) 
     429         END DO 
     430      END DO 
     431      ! 
     432      !--- East ---! 
     433      istart = jpiglo-nbghostcells 
     434      iend   = jpiglo-1 
     435      DO ji = mi0(istart), mi1(iend) 
     436         DO jj=1,jpj 
     437            zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj) 
     438         END DO 
     439      END DO 
     440      istart = jpiglo-nbghostcells-1 
     441      iend   = jpiglo-2 
     442      DO ji = mi0(istart), mi1(iend) 
     443         DO jj=1,jpj 
     444            zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj) 
     445         END DO 
     446      END DO 
     447      ! 
     448      !--- South ---! 
     449      jstart = 2 
     450      jend   = nbghostcells+1 
     451      DO jj = mj0(jstart), mj1(jend) 
     452         DO ji=1,jpi 
     453            zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj) 
     454            zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj) 
     455         END DO 
     456      END DO 
     457      ! 
     458      !--- North ---! 
     459      jstart = jpjglo-nbghostcells 
     460      jend   = jpjglo-1 
     461      DO jj = mj0(jstart), mj1(jend) 
     462         DO ji=1,jpi 
     463            zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj) 
     464         END DO 
     465      END DO 
     466      jstart = jpjglo-nbghostcells-1 
     467      jend   = jpjglo-2 
     468      DO jj = mj0(jstart), mj1(jend) 
     469         DO ji=1,jpi 
     470            zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj) 
     471         END DO 
     472      END DO 
     473      ! 
     474   END SUBROUTINE Agrif_dyn_ts_flux 
    453475 
    454476   SUBROUTINE Agrif_dta_ts( kt ) 
    … …  
    470492      ! 
    471493      ! Interpolate barotropic fluxes 
    472       Agrif_SpecialValue=0._wp 
     494      Agrif_SpecialValue = 0._wp 
    473495      Agrif_UseSpecialValue = ln_spc_dyn 
     496      ! 
     497      ! Set bdy time interpolation stage to 0 (latter incremented locally do deal with corners) 
     498      utint_stage(:,:) = 0 
     499      vtint_stage(:,:) = 0 
    474500      ! 
    475501      IF( ll_int_cons ) THEN  ! Conservative interpolation 
    476502         ! order matters here !!!!!! 
    477503         CALL Agrif_Bc_variable( ub2b_interp_id, calledweight=1._wp, procname=interpub2b ) ! Time integrated 
    478          CALL Agrif_Bc_variable( vb2b_interp_id, calledweight=1._wp, procname=interpvb2b ) 
     504         CALL Agrif_Bc_variable( vb2b_interp_id, calledweight=1._wp, procname=interpvb2b )  
     505         ! 
    479506         bdy_tinterp = 1 
    480507         CALL Agrif_Bc_variable( unb_id        , calledweight=1._wp, procname=interpunb  ) ! After 
    481          CALL Agrif_Bc_variable( vnb_id        , calledweight=1._wp, procname=interpvnb  ) 
     508         CALL Agrif_Bc_variable( vnb_id        , calledweight=1._wp, procname=interpvnb  )   
     509         ! 
    482510         bdy_tinterp = 2 
    483511         CALL Agrif_Bc_variable( unb_id        , calledweight=0._wp, procname=interpunb  ) ! Before 
    484          CALL Agrif_Bc_variable( vnb_id        , calledweight=0._wp, procname=interpvnb  )          
     512         CALL Agrif_Bc_variable( vnb_id        , calledweight=0._wp, procname=interpvnb  )    
    485513      ELSE ! Linear interpolation 
    486          bdy_tinterp = 0 
    487          ubdy_w(:,:) = 0._wp   ;   vbdy_w(:,:) = 0._wp  
    488          ubdy_e(:,:) = 0._wp   ;   vbdy_e(:,:) = 0._wp  
    489          ubdy_n(:,:) = 0._wp   ;   vbdy_n(:,:) = 0._wp  
    490          ubdy_s(:,:) = 0._wp   ;   vbdy_s(:,:) = 0._wp 
     514         ! 
     515         ubdy(:,:) = 0._wp   ;   vbdy(:,:) = 0._wp  
    491516         CALL Agrif_Bc_variable( unb_id, procname=interpunb ) 
    492517         CALL Agrif_Bc_variable( vnb_id, procname=interpvnb ) 
    … …  
    503528      INTEGER, INTENT(in) ::   kt 
    504529      ! 
    505       INTEGER  :: ji, jj, indx, indy 
     530      INTEGER  :: ji, jj 
     531      INTEGER  :: istart, iend, jstart, jend 
    506532      !!----------------------------------------------------------------------   
    507533      ! 
    … …  
    516542      ! 
    517543      ! --- West --- ! 
    518       IF((nbondi == -1).OR.(nbondi == 2)) THEN 
    519          indx = 1+nbghostcells 
     544      istart = 2 
     545      iend   = 1 + nbghostcells 
     546      DO ji = mi0(istart), mi1(iend) 
    520547         DO jj = 1, jpj 
    521             DO ji = 2, indx 
    522                ssha(ji,jj) = hbdy_w(ji-1,jj) 
    523             ENDDO 
     548            ssh(ji,jj,Krhs_a) = hbdy(ji,jj) 
    524549         ENDDO 
    525       ENDIF 
     550      ENDDO 
    526551      ! 
    527552      ! --- East --- ! 
    528       IF((nbondi == 1).OR.(nbondi == 2)) THEN 
    529          indx = nlci-nbghostcells 
     553      istart = jpiglo - nbghostcells 
     554      iend   = jpiglo - 1 
     555      DO ji = mi0(istart), mi1(iend) 
    530556         DO jj = 1, jpj 
    531             DO ji = indx, nlci-1 
    532                ssha(ji,jj) = hbdy_e(ji-indx+1,jj) 
    533             ENDDO 
     557            ssh(ji,jj,Krhs_a) = hbdy(ji,jj) 
    534558         ENDDO 
    535       ENDIF 
     559      ENDDO 
    536560      ! 
    537561      ! --- South --- ! 
    538       IF((nbondj == -1).OR.(nbondj == 2)) THEN 
    539          indy = 1+nbghostcells 
    540          DO jj = 2, indy 
    541             DO ji = 1, jpi 
    542                ssha(ji,jj) = hbdy_s(ji,jj-1) 
    543             ENDDO 
     562      jstart = 2 
     563      jend   = 1 + nbghostcells 
     564      DO jj = mj0(jstart), mj1(jend) 
     565         DO ji = 1, jpi 
     566            ssh(ji,jj,Krhs_a) = hbdy(ji,jj) 
    544567         ENDDO 
    545       ENDIF 
     568      ENDDO 
    546569      ! 
    547570      ! --- North --- ! 
    548       IF((nbondj == 1).OR.(nbondj == 2)) THEN 
    549          indy = nlcj-nbghostcells 
    550          DO jj = indy, nlcj-1 
    551             DO ji = 1, jpi 
    552                ssha(ji,jj) = hbdy_n(ji,jj-indy+1) 
    553             ENDDO 
     571      jstart = jpjglo - nbghostcells 
     572      jend   = jpjglo - 1 
     573      DO jj = mj0(jstart), mj1(jend) 
     574         DO ji = 1, jpi 
     575            ssh(ji,jj,Krhs_a) = hbdy(ji,jj) 
    554576         ENDDO 
    555       ENDIF 
     577      ENDDO 
    556578      ! 
    557579   END SUBROUTINE Agrif_ssh 
    … …  
    564586      INTEGER, INTENT(in) ::   jn 
    565587      !! 
    566       INTEGER :: ji, jj, indx, indy 
    567       !!----------------------------------------------------------------------   
    568       !! clem ghost (starting at i,j=1 is important I think otherwise you introduce a grad(ssh)/=0 at point 2) 
     588      INTEGER :: ji, jj 
     589      INTEGER  :: istart, iend, jstart, jend 
     590      !!----------------------------------------------------------------------   
    569591      ! 
    570592      IF( Agrif_Root() )   RETURN 
    571593      ! 
    572594      ! --- West --- ! 
    573       IF((nbondi == -1).OR.(nbondi == 2)) THEN 
    574          indx = 1+nbghostcells 
     595      istart = 2 
     596      iend   = 1+nbghostcells 
     597      DO ji = mi0(istart), mi1(iend) 
    575598         DO jj = 1, jpj 
    576             DO ji = 2, indx 
    577                ssha_e(ji,jj) = hbdy_w(ji-1,jj) 
    578             ENDDO 
     599            ssha_e(ji,jj) = hbdy(ji,jj) 
    579600         ENDDO 
    580       ENDIF 
     601      ENDDO 
    581602      ! 
    582603      ! --- East --- ! 
    583       IF((nbondi == 1).OR.(nbondi == 2)) THEN 
    584          indx = nlci-nbghostcells 
     604      istart = jpiglo - nbghostcells 
     605      iend   = jpiglo - 1 
     606      DO ji = mi0(istart), mi1(iend) 
    585607         DO jj = 1, jpj 
    586             DO ji = indx, nlci-1 
    587                ssha_e(ji,jj) = hbdy_e(ji-indx+1,jj) 
    588             ENDDO 
     608            ssha_e(ji,jj) = hbdy(ji,jj) 
    589609         ENDDO 
    590       ENDIF 
     610      ENDDO 
    591611      ! 
    592612      ! --- South --- ! 
    593       IF((nbondj == -1).OR.(nbondj == 2)) THEN 
    594          indy = 1+nbghostcells 
    595          DO jj = 2, indy 
    596             DO ji = 1, jpi 
    597                ssha_e(ji,jj) = hbdy_s(ji,jj-1) 
    598             ENDDO 
     613      jstart = 2 
     614      jend   = 1+nbghostcells 
     615      DO jj = mj0(jstart), mj1(jend) 
     616         DO ji = 1, jpi 
     617            ssha_e(ji,jj) = hbdy(ji,jj) 
    599618         ENDDO 
    600       ENDIF 
     619      ENDDO 
    601620      ! 
    602621      ! --- North --- ! 
    603       IF((nbondj == 1).OR.(nbondj == 2)) THEN 
    604          indy = nlcj-nbghostcells 
    605          DO jj = indy, nlcj-1 
    606             DO ji = 1, jpi 
    607                ssha_e(ji,jj) = hbdy_n(ji,jj-indy+1) 
    608             ENDDO 
     622      jstart = jpjglo - nbghostcells 
     623      jend   = jpjglo - 1 
     624      DO jj = mj0(jstart), mj1(jend) 
     625         DO ji = 1, jpi 
     626            ssha_e(ji,jj) = hbdy(ji,jj) 
    609627         ENDDO 
    610       ENDIF 
     628      ENDDO 
    611629      ! 
    612630   END SUBROUTINE Agrif_ssh_ts 
    … …  
    634652    
    635653 
    636    SUBROUTINE interptsn( ptab, i1, i2, j1, j2, k1, k2, n1, n2, before, nb, ndir ) 
     654   SUBROUTINE interptsn( ptab, i1, i2, j1, j2, k1, k2, n1, n2, before ) 
    637655      !!---------------------------------------------------------------------- 
    638656      !!                  *** ROUTINE interptsn *** 
    … …  
    641659      INTEGER                                     , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2, n1, n2 
    642660      LOGICAL                                     , INTENT(in   ) ::   before 
    643       INTEGER                                     , INTENT(in   ) ::   nb , ndir 
    644       ! 
    645       INTEGER  ::   ji, jj, jk, jn, iref, jref, ibdy, jbdy   ! dummy loop indices 
    646       INTEGER  ::   imin, imax, jmin, jmax, N_in, N_out 
    647       REAL(wp) ::   zrho, z1, z2, z3, z4, z5, z6, z7 
    648       LOGICAL :: western_side, eastern_side,northern_side,southern_side 
     661      ! 
     662      INTEGER  ::   ji, jj, jk, jn  ! dummy loop indices 
     663      INTEGER  ::   N_in, N_out 
    649664      ! vertical interpolation: 
    650       REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk,n1:n2) :: ptab_child 
    651       REAL(wp), DIMENSION(k1:k2,n1:n2-1) :: tabin 
     665      REAL(wp) :: zhtot 
     666      REAL(wp), DIMENSION(k1:k2,1:jpts) :: tabin 
    652667      REAL(wp), DIMENSION(k1:k2) :: h_in 
    653668      REAL(wp), DIMENSION(1:jpk) :: h_out 
    654       REAL(wp) :: h_diff 
     669      !!---------------------------------------------------------------------- 
    655670 
    656671      IF( before ) THEN          
    … …  
    659674               DO jj=j1,j2 
    660675                 DO ji=i1,i2 
    661                        ptab(ji,jj,jk,jn) = tsn(ji,jj,jk,jn) 
     676                       ptab(ji,jj,jk,jn) = ts(ji,jj,jk,jn,Kmm_a) 
    662677                 END DO 
    663678              END DO 
    … …  
    666681 
    667682# if defined key_vertical 
     683        ! Interpolate thicknesses 
     684        ! Warning: these are masked, hence extrapolated prior interpolation. 
    668685        DO jk=k1,k2 
    669686           DO jj=j1,j2 
    670687              DO ji=i1,i2 
    671                  ptab(ji,jj,jk,jpts+1) = tmask(ji,jj,jk) * e3t_n(ji,jj,jk)  
     688                  ptab(ji,jj,jk,jpts+1) = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kmm_a) 
    672689              END DO 
    673690           END DO 
    674691        END DO 
     692 
     693        ! Extrapolate thicknesses in partial bottom cells: 
     694        ! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on 
     695        IF (ln_zps) THEN 
     696           DO jj=j1,j2 
     697              DO ji=i1,i2 
     698                  jk = mbkt(ji,jj) 
     699                  ptab(ji,jj,jk,jpts+1) = 0._wp 
     700              END DO 
     701           END DO            
     702        END IF 
     703      
     704        ! Save ssh at last level: 
     705        IF (.NOT.ln_linssh) THEN 
     706           ptab(i1:i2,j1:j2,k2,jpts+1) = ssh(i1:i2,j1:j2,Kmm_a)*tmask(i1:i2,j1:j2,1)  
     707        ELSE 
     708           ptab(i1:i2,j1:j2,k2,jpts+1) = 0._wp 
     709        END IF       
    675710# endif 
    676711      ELSE  
    677712 
    678          western_side  = (nb == 1).AND.(ndir == 1)   ;   eastern_side  = (nb == 1).AND.(ndir == 2) 
    679          southern_side = (nb == 2).AND.(ndir == 1)   ;   northern_side = (nb == 2).AND.(ndir == 2) 
    680  
    681 # if defined key_vertical               
     713# if defined key_vertical  
     714         IF (ln_linssh) ptab(i1:i2,j1:j2,k2,n2) = 0._wp  
     715             
    682716         DO jj=j1,j2 
    683717            DO ji=i1,i2 
    684                iref = ji 
    685                jref = jj 
    686                if(western_side) iref=MAX(2,ji) 
    687                if(eastern_side) iref=MIN(nlci-1,ji) 
    688                if(southern_side) jref=MAX(2,jj) 
    689                if(northern_side) jref=MIN(nlcj-1,jj) 
    690                N_in = 0 
    691                DO jk=k1,k2 !k2 = jpk of parent grid 
    692                   IF (ptab(ji,jj,jk,n2) == 0) EXIT 
    693                   N_in = N_in + 1 
     718               ts(ji,jj,:,:,Krhs_a) = 0._wp 
     719               N_in = mbkt_parent(ji,jj) 
     720               zhtot = 0._wp 
     721               DO jk=1,N_in !k2 = jpk of parent grid 
     722                  IF (jk==N_in) THEN 
     723                     h_in(jk) = ht0_parent(ji,jj) + ptab(ji,jj,k2,n2) - zhtot 
     724                  ELSE 
     725                     h_in(jk) = ptab(ji,jj,jk,n2) 
     726                  ENDIF 
     727                  zhtot = zhtot + h_in(jk) 
    694728                  tabin(jk,:) = ptab(ji,jj,jk,n1:n2-1) 
    695                   h_in(N_in) = ptab(ji,jj,jk,n2) 
    696729               END DO 
    697730               N_out = 0 
    698731               DO jk=1,jpk ! jpk of child grid 
    699                   IF (tmask(iref,jref,jk) == 0) EXIT  
     732                  IF (tmask(ji,jj,jk) == 0._wp) EXIT  
    700733                  N_out = N_out + 1 
    701                   h_out(jk) = e3t_n(iref,jref,jk) 
     734                  h_out(jk) = e3t(ji,jj,jk,Krhs_a) 
    702735               ENDDO 
    703                IF (N_in > 0) THEN 
    704                   DO jn=1,jpts 
    705                      call reconstructandremap(tabin(1:N_in,jn),h_in,ptab_child(ji,jj,1:N_out,jn),h_out,N_in,N_out) 
    706                   ENDDO 
     736               IF (N_in*N_out > 0) THEN 
     737                  CALL reconstructandremap(tabin(1:N_in,1:jpts),h_in(1:N_in),ts(ji,jj,1:N_out,1:jpts,Krhs_a),h_out(1:N_out),N_in,N_out,jpts) 
    707738               ENDIF 
    708739            ENDDO 
    709740         ENDDO 
    710741# else 
    711          ptab_child(i1:i2,j1:j2,1:jpk,1:jpts) = ptab(i1:i2,j1:j2,1:jpk,1:jpts) 
    712 # endif 
    713742         ! 
    714743         DO jn=1, jpts 
    715             tsa(i1:i2,j1:j2,1:jpk,jn)=ptab_child(i1:i2,j1:j2,1:jpk,jn)*tmask(i1:i2,j1:j2,1:jpk)  
    716          END DO 
    717  
    718          IF ( .NOT.lk_agrif_clp ) THEN  
    719             ! 
    720             imin = i1 ; imax = i2 
    721             jmin = j1 ; jmax = j2 
    722             !  
    723             ! Remove CORNERS 
    724             IF((nbondj == -1).OR.(nbondj == 2)) jmin = 2 + nbghostcells 
    725             IF((nbondj == +1).OR.(nbondj == 2)) jmax = nlcj - nbghostcells - 1 
    726             IF((nbondi == -1).OR.(nbondi == 2)) imin = 2 + nbghostcells 
    727             IF((nbondi == +1).OR.(nbondi == 2)) imax = nlci - nbghostcells - 1       
    728             ! 
    729             IF( eastern_side ) THEN 
    730                zrho = Agrif_Rhox() 
    731                z1 = ( zrho - 1._wp ) * 0.5_wp                     
    732                z3 = ( zrho - 1._wp ) / ( zrho + 1._wp )          
    733                z6 = 2._wp * ( zrho - 1._wp ) / ( zrho + 1._wp ) 
    734                z7 =       - ( zrho - 1._wp ) / ( zrho + 3._wp ) 
    735                z2 = 1._wp - z1 ; z4 = 1._wp - z3 ; z5 = 1._wp - z6 - z7 
    736                ! 
    737                ibdy = nlci-nbghostcells 
    738                DO jn = 1, jpts 
    739                   tsa(ibdy+1,jmin:jmax,1:jpkm1,jn) = z1 * ptab_child(ibdy+1,jmin:jmax,1:jpkm1,jn) + z2 * ptab_child(ibdy,jmin:jmax,1:jpkm1,jn) 
    740                   DO jk = 1, jpkm1 
    741                      DO jj = jmin,jmax 
    742                         IF( umask(ibdy-1,jj,jk) == 0._wp ) THEN 
    743                            tsa(ibdy,jj,jk,jn) = tsa(ibdy+1,jj,jk,jn) * tmask(ibdy,jj,jk) 
    744                         ELSE 
    745                            tsa(ibdy,jj,jk,jn)=(z4*tsa(ibdy+1,jj,jk,jn)+z3*tsa(ibdy-1,jj,jk,jn))*tmask(ibdy,jj,jk) 
    746                            IF( un(ibdy-1,jj,jk) > 0._wp ) THEN 
    747                               tsa(ibdy,jj,jk,jn)=( z6*tsa(ibdy-1,jj,jk,jn)+z5*tsa(ibdy+1,jj,jk,jn) &  
    748                                                  + z7*tsa(ibdy-2,jj,jk,jn) ) * tmask(ibdy,jj,jk) 
    749                            ENDIF 
    750                         ENDIF 
    751                      END DO 
    752                   END DO 
    753                   ! Restore ghost points: 
    754                   tsa(ibdy+1,jmin:jmax,1:jpkm1,jn) = ptab_child(ibdy+1,jmin:jmax,1:jpkm1,jn) * tmask(ibdy+1,jmin:jmax,1:jpkm1) 
    755                END DO 
    756             ENDIF 
    757             !  
    758             IF( northern_side ) THEN 
    759                zrho = Agrif_Rhoy() 
    760                z1 = ( zrho - 1._wp ) * 0.5_wp                     
    761                z3 = ( zrho - 1._wp ) / ( zrho + 1._wp )          
    762                z6 = 2._wp * ( zrho - 1._wp ) / ( zrho + 1._wp ) 
    763                z7 =       - ( zrho - 1._wp ) / ( zrho + 3._wp ) 
    764                z2 = 1._wp - z1 ; z4 = 1._wp - z3 ; z5 = 1._wp - z6 - z7 
    765                ! 
    766                jbdy = nlcj-nbghostcells          
    767                DO jn = 1, jpts 
    768                   tsa(imin:imax,jbdy+1,1:jpkm1,jn) = z1 * ptab_child(imin:imax,jbdy+1,1:jpkm1,jn) + z2 * ptab_child(imin:imax,jbdy,1:jpkm1,jn) 
    769                   DO jk = 1, jpkm1 
    770                      DO ji = imin,imax 
    771                         IF( vmask(ji,jbdy-1,jk) == 0._wp ) THEN 
    772                            tsa(ji,jbdy,jk,jn) = tsa(ji,jbdy+1,jk,jn) * tmask(ji,jbdy,jk) 
    773                         ELSE 
    774                            tsa(ji,jbdy,jk,jn)=(z4*tsa(ji,jbdy+1,jk,jn)+z3*tsa(ji,jbdy-1,jk,jn))*tmask(ji,jbdy,jk)         
    775                            IF (vn(ji,jbdy-1,jk) > 0._wp ) THEN 
    776                               tsa(ji,jbdy,jk,jn)=( z6*tsa(ji,jbdy-1,jk,jn)+z5*tsa(ji,jbdy+1,jk,jn)  & 
    777                                                  + z7*tsa(ji,jbdy-2,jk,jn) ) * tmask(ji,jbdy,jk) 
    778                            ENDIF 
    779                         ENDIF 
    780                      END DO 
    781                   END DO 
    782                   ! Restore ghost points: 
    783                   tsa(imin:imax,jbdy+1,1:jpkm1,jn) = ptab_child(imin:imax,jbdy+1,1:jpkm1,jn) * tmask(imin:imax,jbdy+1,1:jpkm1) 
    784                END DO 
    785             ENDIF 
    786             ! 
    787             IF( western_side ) THEN 
    788                zrho = Agrif_Rhox() 
    789                z1 = ( zrho - 1._wp ) * 0.5_wp                     
    790                z3 = ( zrho - 1._wp ) / ( zrho + 1._wp )          
    791                z6 = 2._wp * ( zrho - 1._wp ) / ( zrho + 1._wp ) 
    792                z7 =       - ( zrho - 1._wp ) / ( zrho + 3._wp ) 
    793                z2 = 1._wp - z1 ; z4 = 1._wp - z3 ; z5 = 1._wp - z6 - z7 
    794                !     
    795                ibdy = 1+nbghostcells        
    796                DO jn = 1, jpts 
    797                   tsa(ibdy-1,jmin:jmax,1:jpkm1,jn) = z1 * ptab_child(ibdy-1,jmin:jmax,1:jpkm1,jn) + z2 * ptab_child(ibdy,jmin:jmax,1:jpkm1,jn) 
    798                   DO jk = 1, jpkm1 
    799                      DO jj = jmin,jmax 
    800                         IF( umask(ibdy,jj,jk) == 0._wp ) THEN 
    801                            tsa(ibdy,jj,jk,jn) = tsa(ibdy-1,jj,jk,jn) * tmask(ibdy,jj,jk) 
    802                         ELSE 
    803                            tsa(ibdy,jj,jk,jn)=(z4*tsa(ibdy-1,jj,jk,jn)+z3*tsa(ibdy+1,jj,jk,jn))*tmask(ibdy,jj,jk)         
    804                            IF( un(ibdy,jj,jk) < 0._wp ) THEN 
    805                               tsa(ibdy,jj,jk,jn)=( z6*tsa(ibdy+1,jj,jk,jn)+z5*tsa(ibdy-1,jj,jk,jn) & 
    806                                                  + z7*tsa(ibdy+2,jj,jk,jn) ) * tmask(ibdy,jj,jk) 
    807                            ENDIF 
    808                         ENDIF 
    809                      END DO 
    810                   END DO 
    811                   ! Restore ghost points: 
    812                   tsa(ibdy-1,jmin:jmax,1:jpkm1,jn) = ptab_child(ibdy-1,jmin:jmax,1:jpkm1,jn) * tmask(ibdy-1,jmin:jmax,1:jpkm1) 
    813                END DO 
    814             ENDIF 
    815             ! 
    816             IF( southern_side ) THEN 
    817                zrho = Agrif_Rhoy() 
    818                z1 = ( zrho - 1._wp ) * 0.5_wp                     
    819                z3 = ( zrho - 1._wp ) / ( zrho + 1._wp )          
    820                z6 = 2._wp * ( zrho - 1._wp ) / ( zrho + 1._wp ) 
    821                z7 =       - ( zrho - 1._wp ) / ( zrho + 3._wp ) 
    822                z2 = 1._wp - z1 ; z4 = 1._wp - z3 ; z5 = 1._wp - z6 - z7 
    823                !   
    824                jbdy=1+nbghostcells         
    825                DO jn = 1, jpts 
    826                   tsa(imin:imax,jbdy-1,1:jpkm1,jn) = z1 * ptab_child(imin:imax,jbdy-1,1:jpkm1,jn) + z2 * ptab_child(imin:imax,jbdy,1:jpkm1,jn) 
    827                   DO jk = 1, jpkm1       
    828                      DO ji = imin,imax 
    829                         IF( vmask(ji,jbdy,jk) == 0._wp ) THEN 
    830                            tsa(ji,jbdy,jk,jn)=tsa(ji,jbdy-1,jk,jn) * tmask(ji,jbdy,jk) 
    831                         ELSE 
    832                            tsa(ji,jbdy,jk,jn)=(z4*tsa(ji,jbdy-1,jk,jn)+z3*tsa(ji,jbdy+1,jk,jn))*tmask(ji,jbdy,jk) 
    833                            IF( vn(ji,jbdy,jk) < 0._wp ) THEN 
    834                               tsa(ji,jbdy,jk,jn)=( z6*tsa(ji,jbdy+1,jk,jn)+z5*tsa(ji,jbdy-1,jk,jn) &  
    835                                                  + z7*tsa(ji,jbdy+2,jk,jn) ) * tmask(ji,jbdy,jk) 
    836                            ENDIF 
    837                         ENDIF 
    838                      END DO 
    839                   END DO 
    840                   ! Restore ghost points: 
    841                   tsa(imin:imax,jbdy-1,1:jpkm1,jn) = ptab_child(imin:imax,jbdy-1,1:jpkm1,jn) * tmask(imin:imax,jbdy-1,1:jpkm1) 
    842                END DO 
    843             ENDIF 
    844             ! 
    845          ENDIF 
     744            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)  
     745         END DO 
     746# endif 
     747 
    846748      ENDIF 
    847749      ! 
    848750   END SUBROUTINE interptsn 
    849751 
    850    SUBROUTINE interpsshn( ptab, i1, i2, j1, j2, before, nb, ndir ) 
     752   SUBROUTINE interpsshn( ptab, i1, i2, j1, j2, before ) 
    851753      !!---------------------------------------------------------------------- 
    852754      !!                  ***  ROUTINE interpsshn  *** 
    … …  
    855757      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab 
    856758      LOGICAL                         , INTENT(in   ) ::   before 
    857       INTEGER                         , INTENT(in   ) ::   nb , ndir 
    858       ! 
    859       LOGICAL :: western_side, eastern_side,northern_side,southern_side 
     759      ! 
    860760      !!----------------------------------------------------------------------   
    861761      ! 
    862762      IF( before) THEN 
    863          ptab(i1:i2,j1:j2) = sshn(i1:i2,j1:j2) 
     763         ptab(i1:i2,j1:j2) = ssh(i1:i2,j1:j2,Kmm_a) 
    864764      ELSE 
    865          western_side  = (nb == 1).AND.(ndir == 1) 
    866          eastern_side  = (nb == 1).AND.(ndir == 2) 
    867          southern_side = (nb == 2).AND.(ndir == 1) 
    868          northern_side = (nb == 2).AND.(ndir == 2) 
    869          !! clem ghost 
    870          IF(western_side)  hbdy_w(1:nbghostcells,j1:j2) = ptab(i1:i2,j1:j2) * tmask(i1:i2,j1:j2,1) 
    871          IF(eastern_side)  hbdy_e(1:nbghostcells,j1:j2) = ptab(i1:i2,j1:j2) * tmask(i1:i2,j1:j2,1) 
    872          IF(southern_side) hbdy_s(i1:i2,1:nbghostcells) = ptab(i1:i2,j1:j2) * tmask(i1:i2,j1:j2,1)  
    873          IF(northern_side) hbdy_n(i1:i2,1:nbghostcells) = ptab(i1:i2,j1:j2) * tmask(i1:i2,j1:j2,1) 
     765         hbdy(i1:i2,j1:j2) = ptab(i1:i2,j1:j2) * tmask(i1:i2,j1:j2,1) 
    874766      ENDIF 
    875767      ! 
    876768   END SUBROUTINE interpsshn 
    877769 
    878    SUBROUTINE interpun( ptab, i1, i2, j1, j2, k1, k2, m1, m2, before, nb, ndir ) 
     770   SUBROUTINE interpun( ptab, i1, i2, j1, j2, k1, k2, m1, m2, before ) 
    879771      !!---------------------------------------------------------------------- 
    880772      !!                  *** ROUTINE interpun *** 
    … …  
    884776      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,m1:m2), INTENT(inout) :: ptab 
    885777      LOGICAL, INTENT(in) :: before 
    886       INTEGER, INTENT(in) :: nb , ndir 
    887778      !! 
    888779      INTEGER :: ji,jj,jk 
    889       REAL(wp) :: zrhoy 
     780      REAL(wp) :: zrhoy, zhtot 
    890781      ! vertical interpolation: 
    891782      REAL(wp), DIMENSION(k1:k2) :: tabin, h_in 
    892783      REAL(wp), DIMENSION(1:jpk) :: h_out 
    893       INTEGER  :: N_in, N_out, iref 
     784      INTEGER  :: N_in, N_out 
    894785      REAL(wp) :: h_diff 
    895       LOGICAL  :: western_side, eastern_side 
    896786      !!---------------------------------------------     
    897787      ! 
    … …  
    900790            DO jj=j1,j2 
    901791               DO ji=i1,i2 
    902                   ptab(ji,jj,jk,1) = (e2u(ji,jj) * e3u_n(ji,jj,jk) * un(ji,jj,jk)*umask(ji,jj,jk))  
     792                  ptab(ji,jj,jk,1) = (e2u(ji,jj) * e3u(ji,jj,jk,Kmm_a) * uu(ji,jj,jk,Kmm_a)*umask(ji,jj,jk))  
    903793# if defined key_vertical 
    904                   ptab(ji,jj,jk,2) = (umask(ji,jj,jk) * e2u(ji,jj) * e3u_n(ji,jj,jk)) 
     794                  ! Interpolate thicknesses (masked for subsequent extrapolation) 
     795                  ptab(ji,jj,jk,2) = umask(ji,jj,jk) * e2u(ji,jj) * e3u(ji,jj,jk,Kmm_a) 
    905796# endif 
    906797               END DO 
    907798            END DO 
    908799         END DO 
     800# if defined key_vertical 
     801         ! Extrapolate thicknesses in partial bottom cells: 
     802         ! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on 
     803         IF (ln_zps) THEN 
     804            DO jj=j1,j2 
     805               DO ji=i1,i2 
     806                  jk = mbku(ji,jj) 
     807                  ptab(ji,jj,jk,2) = 0._wp 
     808               END DO 
     809            END DO            
     810         END IF 
     811        ! Save ssh at last level: 
     812        ptab(i1:i2,j1:j2,k2,2) = 0._wp 
     813        IF (.NOT.ln_linssh) THEN 
     814           ! This vertical sum below should be replaced by the sea-level at U-points (optimization): 
     815           DO jk=1,jpk 
     816              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) 
     817           END DO 
     818           ptab(i1:i2,j1:j2,k2,2) = ptab(i1:i2,j1:j2,k2,2) - hu_0(i1:i2,j1:j2) 
     819        END IF  
     820# endif 
     821         ! 
    909822      ELSE 
    910823         zrhoy = Agrif_rhoy() 
    911824# if defined key_vertical 
    912825! VERTICAL REFINEMENT BEGIN 
    913          western_side  = (nb == 1).AND.(ndir == 1) 
    914          eastern_side  = (nb == 1).AND.(ndir == 2) 
     826 
     827         IF (ln_linssh) ptab(i1:i2,j1:j2,k2,2) = 0._wp  
    915828 
    916829         DO ji=i1,i2 
    917             iref = ji 
    918             IF (western_side) iref = MAX(2,ji) 
    919             IF (eastern_side) iref = MIN(nlci-2,ji) 
    920830            DO jj=j1,j2 
    921                N_in = 0 
    922                DO jk=k1,k2 
    923                   IF (ptab(ji,jj,jk,2) == 0) EXIT 
    924                   N_in = N_in + 1 
    925                   tabin(jk) = ptab(ji,jj,jk,1)/ptab(ji,jj,jk,2) 
    926                   h_in(N_in) = ptab(ji,jj,jk,2)/(e2u(ji,jj)*zrhoy)  
     831               uu(ji,jj,:,Krhs_a) = 0._wp 
     832               N_in = mbku_parent(ji,jj) 
     833               zhtot = 0._wp 
     834               DO jk=1,N_in 
     835                  IF (jk==N_in) THEN 
     836                     h_in(jk) = hu0_parent(ji,jj) + ptab(ji,jj,k2,2) - zhtot 
     837                  ELSE 
     838                     h_in(jk) = ptab(ji,jj,jk,2)/(e2u(ji,jj)*zrhoy)  
     839                  ENDIF 
     840                  zhtot = zhtot + h_in(jk) 
     841                  tabin(jk) = ptab(ji,jj,jk,1)/(e2u(ji,jj)*zrhoy*h_in(jk)) 
    927842              ENDDO 
    928           
    929               IF (N_in == 0) THEN 
    930                  ua(ji,jj,:) = 0._wp 
    931                  CYCLE 
    932               ENDIF 
    933           
     843                   
    934844              N_out = 0 
    935845              DO jk=1,jpk 
    936                  if (umask(iref,jj,jk) == 0) EXIT 
     846                 if (umask(ji,jj,jk) == 0) EXIT 
    937847                 N_out = N_out + 1 
    938                  h_out(N_out) = e3u_a(iref,jj,jk) 
     848                 h_out(N_out) = e3u(ji,jj,jk,Krhs_a) 
    939849              ENDDO 
    940           
    941               IF (N_out == 0) THEN 
    942                  ua(ji,jj,:) = 0._wp 
    943                  CYCLE 
     850              IF (N_in*N_out > 0) THEN 
     851                 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) 
    944852              ENDIF 
    945           
    946               IF (N_in * N_out > 0) THEN 
    947                  h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in)) 
    948 ! Should be able to remove the next IF/ELSEIF statement once scale factors are dealt with properly 
    949                  if (h_diff < -1.e4) then 
    950                     print *,'CHECK YOUR BATHY ...', h_diff, sum(h_out(1:N_out)), sum(h_in(1:N_in)) 
    951 !                    stop 
    952                  endif 
    953               ENDIF 
    954               call reconstructandremap(tabin(1:N_in),h_in(1:N_in),ua(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out) 
    955853            ENDDO 
    956854         ENDDO 
    … …  
    959857         DO jk = 1, jpkm1 
    960858            DO jj=j1,j2 
    961                ua(i1:i2,jj,jk) = ptab(i1:i2,jj,jk,1) / ( zrhoy * e2u(i1:i2,jj) * e3u_a(i1:i2,jj,jk) ) 
     859               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) ) 
    962860            END DO 
    963861         END DO 
    … …  
    968866   END SUBROUTINE interpun 
    969867 
    970    SUBROUTINE interpvn( ptab, i1, i2, j1, j2, k1, k2, m1, m2, before, nb, ndir ) 
     868   SUBROUTINE interpvn( ptab, i1, i2, j1, j2, k1, k2, m1, m2, before ) 
    971869      !!---------------------------------------------------------------------- 
    972870      !!                  *** ROUTINE interpvn *** 
    … …  
    976874      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,m1:m2), INTENT(inout) :: ptab 
    977875      LOGICAL, INTENT(in) :: before 
    978       INTEGER, INTENT(in) :: nb , ndir 
    979876      ! 
    980877      INTEGER :: ji,jj,jk 
    … …  
    983880      REAL(wp), DIMENSION(k1:k2) :: tabin, h_in 
    984881      REAL(wp), DIMENSION(1:jpk) :: h_out 
    985       INTEGER  :: N_in, N_out, jref 
    986       REAL(wp) :: h_diff 
    987       LOGICAL  :: northern_side,southern_side 
     882      INTEGER  :: N_in, N_out 
     883      REAL(wp) :: h_diff, zhtot 
    988884      !!---------------------------------------------     
    989885      !       
    … …  
    992888            DO jj=j1,j2 
    993889               DO ji=i1,i2 
    994                   ptab(ji,jj,jk,1) = (e1v(ji,jj) * e3v_n(ji,jj,jk) * vn(ji,jj,jk)*vmask(ji,jj,jk)) 
     890                  ptab(ji,jj,jk,1) = (e1v(ji,jj) * e3v(ji,jj,jk,Kmm_a) * vv(ji,jj,jk,Kmm_a)*vmask(ji,jj,jk)) 
    995891# if defined key_vertical 
    996                   ptab(ji,jj,jk,2) = vmask(ji,jj,jk) * e1v(ji,jj) * e3v_n(ji,jj,jk) 
     892                  ! Interpolate thicknesses (masked for subsequent extrapolation) 
     893                  ptab(ji,jj,jk,2) = vmask(ji,jj,jk) * e1v(ji,jj) * e3v(ji,jj,jk,Kmm_a) 
    997894# endif 
    998895               END DO 
    999896            END DO 
    1000897         END DO 
     898# if defined key_vertical 
     899         ! Extrapolate thicknesses in partial bottom cells: 
     900         ! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on 
     901         IF (ln_zps) THEN 
     902            DO jj=j1,j2 
     903               DO ji=i1,i2 
     904                  jk = mbkv(ji,jj) 
     905                  ptab(ji,jj,jk,2) = 0._wp 
     906               END DO 
     907            END DO            
     908         END IF 
     909        ! Save ssh at last level: 
     910        ptab(i1:i2,j1:j2,k2,2) = 0._wp 
     911        IF (.NOT.ln_linssh) THEN 
     912           ! This vertical sum below should be replaced by the sea-level at V-points (optimization): 
     913           DO jk=1,jpk 
     914              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) 
     915           END DO 
     916           ptab(i1:i2,j1:j2,k2,2) = ptab(i1:i2,j1:j2,k2,2) - hv_0(i1:i2,j1:j2) 
     917        END IF  
     918# endif 
    1001919      ELSE        
    1002920         zrhox = Agrif_rhox() 
    1003921# if defined key_vertical 
    1004922 
    1005          southern_side = (nb == 2).AND.(ndir == 1) 
    1006          northern_side = (nb == 2).AND.(ndir == 2) 
     923         IF (ln_linssh) ptab(i1:i2,j1:j2,k2,2) = 0._wp  
    1007924 
    1008925         DO jj=j1,j2 
    1009             jref = jj 
    1010             IF (southern_side) jref = MAX(2,jj) 
    1011             IF (northern_side) jref = MIN(nlcj-2,jj) 
    1012926            DO ji=i1,i2 
    1013                N_in = 0 
    1014                DO jk=k1,k2 
    1015                   if (ptab(ji,jj,jk,2) == 0) EXIT 
    1016                   N_in = N_in + 1 
    1017                   tabin(jk) = ptab(ji,jj,jk,1)/ptab(ji,jj,jk,2) 
    1018                   h_in(N_in) = ptab(ji,jj,jk,2)/(e1v(ji,jj)*zrhox) 
    1019                END DO 
    1020                IF (N_in == 0) THEN 
    1021                   va(ji,jj,:) = 0._wp 
    1022                   CYCLE 
    1023                ENDIF 
     927               vv(ji,jj,:,Krhs_a) = 0._wp 
     928               N_in = mbkv_parent(ji,jj) 
     929               zhtot = 0._wp 
     930               DO jk=1,N_in 
     931                  IF (jk==N_in) THEN 
     932                     h_in(jk) = hv0_parent(ji,jj) + ptab(ji,jj,k2,2) - zhtot 
     933                  ELSE 
     934                     h_in(jk) = ptab(ji,jj,jk,2)/(e1v(ji,jj)*zrhox)  
     935                  ENDIF 
     936                  zhtot = zhtot + h_in(jk) 
     937                  tabin(jk) = ptab(ji,jj,jk,1)/(e1v(ji,jj)*zrhox*h_in(jk)) 
     938              ENDDO 
    1024939          
    1025940               N_out = 0 
    1026941               DO jk=1,jpk 
    1027                   if (vmask(ji,jref,jk) == 0) EXIT 
     942                  if (vmask(ji,jj,jk) == 0) EXIT 
    1028943                  N_out = N_out + 1 
    1029                   h_out(N_out) = e3v_a(ji,jref,jk) 
    1030                END DO 
    1031                IF (N_out == 0) THEN 
    1032                  va(ji,jj,:) = 0._wp 
    1033                  CYCLE 
     944                  h_out(N_out) = e3v(ji,jj,jk,Krhs_a) 
     945               END DO 
     946               IF (N_in*N_out > 0) THEN 
     947                  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) 
    1034948               ENDIF 
    1035                call reconstructandremap(tabin(1:N_in),h_in(1:N_in),va(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out) 
    1036949            END DO 
    1037950         END DO 
    1038951# else 
    1039952         DO jk = 1, jpkm1 
    1040             va(i1:i2,j1:j2,jk) = ptab(i1:i2,j1:j2,jk,1) / ( zrhox * e1v(i1:i2,j1:j2) * e3v_a(i1:i2,j1:j2,jk) ) 
     953            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) ) 
    1041954         END DO 
    1042955# endif 
    … …  
    1045958   END SUBROUTINE interpvn 
    1046959 
    1047    SUBROUTINE interpunb( ptab, i1, i2, j1, j2, before, nb, ndir ) 
     960   SUBROUTINE interpunb( ptab, i1, i2, j1, j2, before) 
    1048961      !!---------------------------------------------------------------------- 
    1049962      !!                  ***  ROUTINE interpunb  *** 
    … …  
    1052965      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab 
    1053966      LOGICAL                         , INTENT(in   ) ::   before 
    1054       INTEGER                         , INTENT(in   ) ::   nb , ndir 
    1055967      ! 
    1056968      INTEGER  ::   ji, jj 
    1057969      REAL(wp) ::   zrhoy, zrhot, zt0, zt1, ztcoeff 
    1058       LOGICAL  ::   western_side, eastern_side,northern_side,southern_side 
    1059970      !!----------------------------------------------------------------------   
    1060971      ! 
    1061972      IF( before ) THEN  
    1062          ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * hu_n(i1:i2,j1:j2) * un_b(i1:i2,j1:j2) 
     973         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) 
    1063974      ELSE 
    1064          western_side  = (nb == 1).AND.(ndir == 1) 
    1065          eastern_side  = (nb == 1).AND.(ndir == 2) 
    1066          southern_side = (nb == 2).AND.(ndir == 1) 
    1067          northern_side = (nb == 2).AND.(ndir == 2) 
    1068975         zrhoy = Agrif_Rhoy() 
    1069976         zrhot = Agrif_rhot() 
    … …  
    1071978         zt0 = REAL(Agrif_NbStepint()  , wp) / zrhot 
    1072979         zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot       
    1073          ! Polynomial interpolation coefficients: 
    1074          IF( bdy_tinterp == 1 ) THEN 
    1075             ztcoeff = zrhot * (  zt1**2._wp * (       zt1 - 1._wp)        & 
    1076                &               - zt0**2._wp * (       zt0 - 1._wp)        ) 
    1077          ELSEIF( bdy_tinterp == 2 ) THEN 
    1078             ztcoeff = zrhot * (  zt1        * (       zt1 - 1._wp)**2._wp & 
    1079                &               - zt0        * (       zt0 - 1._wp)**2._wp ) 
    1080          ELSE 
    1081             ztcoeff = 1 
    1082          ENDIF 
    1083          !    
    1084          IF(western_side)   ubdy_w(1:nbghostcells,j1:j2) = ubdy_w(1:nbghostcells,j1:j2) + ztcoeff * ptab(i1:i2,j1:j2)   
    1085          IF(eastern_side)   ubdy_e(1:nbghostcells,j1:j2) = ubdy_e(1:nbghostcells,j1:j2) + ztcoeff * ptab(i1:i2,j1:j2)   
    1086          IF(southern_side)  ubdy_s(i1:i2,1:nbghostcells) = ubdy_s(i1:i2,1:nbghostcells) + ztcoeff * ptab(i1:i2,j1:j2) 
    1087          IF(northern_side)  ubdy_n(i1:i2,1:nbghostcells) = ubdy_n(i1:i2,1:nbghostcells) + ztcoeff * ptab(i1:i2,j1:j2)  
    1088          !             
    1089          IF( bdy_tinterp == 0 .OR. bdy_tinterp == 2) THEN 
    1090             IF(western_side)   ubdy_w(1:nbghostcells,j1:j2) = ubdy_w(1:nbghostcells,j1:j2) / (zrhoy*e2u(i1:i2,j1:j2)) * umask(i1:i2,j1:j2,1) 
    1091             IF(eastern_side)   ubdy_e(1:nbghostcells,j1:j2) = ubdy_e(1:nbghostcells,j1:j2) / (zrhoy*e2u(i1:i2,j1:j2)) * umask(i1:i2,j1:j2,1) 
    1092             IF(southern_side)  ubdy_s(i1:i2,1:nbghostcells) = ubdy_s(i1:i2,1:nbghostcells) / (zrhoy*e2u(i1:i2,j1:j2)) * umask(i1:i2,j1:j2,1) 
    1093             IF(northern_side)  ubdy_n(i1:i2,1:nbghostcells) = ubdy_n(i1:i2,1:nbghostcells) / (zrhoy*e2u(i1:i2,j1:j2)) * umask(i1:i2,j1:j2,1) 
    1094          ENDIF 
    1095       ENDIF 
     980         !  
     981         DO ji = i1, i2 
     982            DO jj = j1, j2 
     983               IF ( utint_stage(ji,jj) < (bdy_tinterp + 1) ) THEN 
     984                  IF    ( utint_stage(ji,jj) == 1  ) THEN 
     985                     ztcoeff = zrhot * (  zt1**2._wp * (       zt1 - 1._wp)        & 
     986                        &               - zt0**2._wp * (       zt0 - 1._wp)        ) 
     987                  ELSEIF( utint_stage(ji,jj) == 2  ) THEN 
     988                     ztcoeff = zrhot * (  zt1        * (       zt1 - 1._wp)**2._wp & 
     989                        &               - zt0        * (       zt0 - 1._wp)**2._wp ) 
     990                  ELSEIF( utint_stage(ji,jj) == 0  ) THEN                 
     991                     ztcoeff = 1._wp 
     992                  ELSE 
     993                     ztcoeff = 0._wp 
     994                  ENDIF 
     995                  !    
     996                  ubdy(ji,jj) = ubdy(ji,jj) + ztcoeff * ptab(ji,jj) 
     997                  !             
     998                  IF (( utint_stage(ji,jj) == 2 ).OR.( utint_stage(ji,jj) == 0 )) THEN 
     999                     ubdy(ji,jj) = ubdy(ji,jj) / (zrhoy*e2u(ji,jj)) * umask(ji,jj,1) 
     1000                  ENDIF 
     1001                  ! 
     1002                  utint_stage(ji,jj) = utint_stage(ji,jj) + 1 
     1003               ENDIF 
     1004            END DO 
     1005         END DO 
     1006      END IF 
    10961007      !  
    10971008   END SUBROUTINE interpunb 
    10981009 
    10991010 
    1100    SUBROUTINE interpvnb( ptab, i1, i2, j1, j2, before, nb, ndir ) 
     1011   SUBROUTINE interpvnb( ptab, i1, i2, j1, j2, before ) 
    11011012      !!---------------------------------------------------------------------- 
    11021013      !!                  ***  ROUTINE interpvnb  *** 
    … …  
    11051016      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab 
    11061017      LOGICAL                         , INTENT(in   ) ::   before 
    1107       INTEGER                         , INTENT(in   ) ::   nb , ndir 
    1108       ! 
    1109       INTEGER  ::   ji,jj 
     1018      ! 
     1019      INTEGER  ::   ji, jj 
    11101020      REAL(wp) ::   zrhox, zrhot, zt0, zt1, ztcoeff    
    1111       LOGICAL  ::   western_side, eastern_side,northern_side,southern_side 
    11121021      !!----------------------------------------------------------------------   
    11131022      !  
    11141023      IF( before ) THEN  
    1115          ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * hv_n(i1:i2,j1:j2) * vn_b(i1:i2,j1:j2) 
     1024         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) 
    11161025      ELSE 
    1117          western_side  = (nb == 1).AND.(ndir == 1) 
    1118          eastern_side  = (nb == 1).AND.(ndir == 2) 
    1119          southern_side = (nb == 2).AND.(ndir == 1) 
    1120          northern_side = (nb == 2).AND.(ndir == 2) 
    11211026         zrhox = Agrif_Rhox() 
    11221027         zrhot = Agrif_rhot() 
    11231028         ! Time indexes bounds for integration 
    11241029         zt0 = REAL(Agrif_NbStepint()  , wp) / zrhot 
    1125          zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot       
    1126          IF( bdy_tinterp == 1 ) THEN 
    1127             ztcoeff = zrhot * (  zt1**2._wp * (       zt1 - 1._wp)        & 
    1128                &               - zt0**2._wp * (       zt0 - 1._wp)        ) 
    1129          ELSEIF( bdy_tinterp == 2 ) THEN 
    1130             ztcoeff = zrhot * (  zt1        * (       zt1 - 1._wp)**2._wp & 
    1131                &               - zt0        * (       zt0 - 1._wp)**2._wp )  
    1132          ELSE 
    1133             ztcoeff = 1 
    1134          ENDIF 
    1135          !! clem ghost 
    1136          IF(western_side)   vbdy_w(1:nbghostcells,j1:j2) = vbdy_w(1:nbghostcells,j1:j2) + ztcoeff * ptab(i1:i2,j1:j2)   
    1137          IF(eastern_side)   vbdy_e(1:nbghostcells,j1:j2) = vbdy_e(1:nbghostcells,j1:j2) + ztcoeff * ptab(i1:i2,j1:j2)    
    1138          IF(southern_side)  vbdy_s(i1:i2,1:nbghostcells) = vbdy_s(i1:i2,1:nbghostcells) + ztcoeff * ptab(i1:i2,j1:j2) 
    1139          IF(northern_side)  vbdy_n(i1:i2,1:nbghostcells) = vbdy_n(i1:i2,1:nbghostcells) + ztcoeff * ptab(i1:i2,j1:j2)  
    1140          !             
    1141          IF( bdy_tinterp == 0 .OR. bdy_tinterp == 2) THEN 
    1142             IF(western_side)   vbdy_w(1:nbghostcells,j1:j2) = vbdy_w(1:nbghostcells,j1:j2) / (zrhox*e1v(i1:i2,j1:j2)) * vmask(i1:i2,j1:j2,1) 
    1143             IF(eastern_side)   vbdy_e(1:nbghostcells,j1:j2) = vbdy_e(1:nbghostcells,j1:j2) / (zrhox*e1v(i1:i2,j1:j2)) * vmask(i1:i2,j1:j2,1) 
    1144             IF(southern_side)  vbdy_s(i1:i2,1:nbghostcells) = vbdy_s(i1:i2,1:nbghostcells) / (zrhox*e1v(i1:i2,j1:j2)) * vmask(i1:i2,j1:j2,1) 
    1145             IF(northern_side)  vbdy_n(i1:i2,1:nbghostcells) = vbdy_n(i1:i2,1:nbghostcells) / (zrhox*e1v(i1:i2,j1:j2)) * vmask(i1:i2,j1:j2,1) 
    1146          ENDIF 
     1030         zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot  
     1031         !      
     1032         DO ji = i1, i2 
     1033            DO jj = j1, j2 
     1034               IF ( vtint_stage(ji,jj) < (bdy_tinterp + 1) ) THEN 
     1035                  IF    ( vtint_stage(ji,jj) == 1  ) THEN 
     1036                     ztcoeff = zrhot * (  zt1**2._wp * (       zt1 - 1._wp)        & 
     1037                        &               - zt0**2._wp * (       zt0 - 1._wp)        ) 
     1038                  ELSEIF( vtint_stage(ji,jj) == 2  ) THEN 
     1039                     ztcoeff = zrhot * (  zt1        * (       zt1 - 1._wp)**2._wp & 
     1040                        &               - zt0        * (       zt0 - 1._wp)**2._wp ) 
     1041                  ELSEIF( vtint_stage(ji,jj) == 0  ) THEN                 
     1042                     ztcoeff = 1._wp 
     1043                  ELSE 
     1044                     ztcoeff = 0._wp 
     1045                  ENDIF 
     1046                  !    
     1047                  vbdy(ji,jj) = vbdy(ji,jj) + ztcoeff * ptab(ji,jj) 
     1048                  !             
     1049                  IF (( vtint_stage(ji,jj) == 2 ).OR.( vtint_stage(ji,jj) == 0 )) THEN 
     1050                     vbdy(ji,jj) = vbdy(ji,jj) / (zrhox*e1v(ji,jj)) * vmask(ji,jj,1) 
     1051                  ENDIF 
     1052                  ! 
     1053                  vtint_stage(ji,jj) = vtint_stage(ji,jj) + 1 
     1054               ENDIF 
     1055            END DO 
     1056         END DO           
    11471057      ENDIF 
    11481058      ! 
    … …  
    11501060 
    11511061 
    1152    SUBROUTINE interpub2b( ptab, i1, i2, j1, j2, before, nb, ndir ) 
     1062   SUBROUTINE interpub2b( ptab, i1, i2, j1, j2, before ) 
    11531063      !!---------------------------------------------------------------------- 
    11541064      !!                  ***  ROUTINE interpub2b  *** 
    … …  
    11571067      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab 
    11581068      LOGICAL                         , INTENT(in   ) ::   before 
    1159       INTEGER                         , INTENT(in   ) ::   nb , ndir 
    11601069      ! 
    11611070      INTEGER  ::   ji,jj 
    1162       REAL(wp) ::   zrhot, zt0, zt1,zat 
    1163       LOGICAL  ::   western_side, eastern_side,northern_side,southern_side 
     1071      REAL(wp) ::   zrhot, zt0, zt1, zat 
    11641072      !!----------------------------------------------------------------------   
    11651073      IF( before ) THEN 
    … …  
    11701078         ENDIF 
    11711079      ELSE 
    1172          western_side  = (nb == 1).AND.(ndir == 1) 
    1173          eastern_side  = (nb == 1).AND.(ndir == 2) 
    1174          southern_side = (nb == 2).AND.(ndir == 1) 
    1175          northern_side = (nb == 2).AND.(ndir == 2) 
    1176          zrhot = Agrif_rhot() 
    1177          ! Time indexes bounds for integration 
    1178          zt0 = REAL(Agrif_NbStepint()  , wp) / zrhot 
    1179          zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot 
    1180          ! Polynomial interpolation coefficients: 
    1181          zat = zrhot * (  zt1**2._wp * (-2._wp*zt1 + 3._wp)    & 
    1182             &           - zt0**2._wp * (-2._wp*zt0 + 3._wp)    )  
    1183          !! clem ghost 
    1184          IF(western_side ) ubdy_w(1:nbghostcells,j1:j2) = zat * ptab(i1:i2,j1:j2)   
    1185          IF(eastern_side ) ubdy_e(1:nbghostcells,j1:j2) = zat * ptab(i1:i2,j1:j2)   
    1186          IF(southern_side) ubdy_s(i1:i2,1:nbghostcells) = zat * ptab(i1:i2,j1:j2) 
    1187          IF(northern_side) ubdy_n(i1:i2,1:nbghostcells) = zat * ptab(i1:i2,j1:j2)  
    1188       ENDIF 
    1189       !  
    1190    END SUBROUTINE interpub2b 
    1191     
    1192  
    1193    SUBROUTINE interpvb2b( ptab, i1, i2, j1, j2, before, nb, ndir ) 
    1194       !!---------------------------------------------------------------------- 
    1195       !!                  ***  ROUTINE interpvb2b  *** 
    1196       !!----------------------------------------------------------------------   
    1197       INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2 
    1198       REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab 
    1199       LOGICAL                         , INTENT(in   ) ::   before 
    1200       INTEGER                         , INTENT(in   ) ::   nb , ndir 
    1201       ! 
    1202       INTEGER ::   ji,jj 
    1203       REAL(wp) ::   zrhot, zt0, zt1,zat 
    1204       LOGICAL ::   western_side, eastern_side,northern_side,southern_side 
    1205       !!----------------------------------------------------------------------   
    1206       ! 
    1207       IF( before ) THEN 
    1208          IF ( ln_bt_fw ) THEN 
    1209             ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * vb2_b(i1:i2,j1:j2) 
    1210          ELSE 
    1211             ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * vn_adv(i1:i2,j1:j2) 
    1212          ENDIF 
    1213       ELSE       
    1214          western_side  = (nb == 1).AND.(ndir == 1) 
    1215          eastern_side  = (nb == 1).AND.(ndir == 2) 
    1216          southern_side = (nb == 2).AND.(ndir == 1) 
    1217          northern_side = (nb == 2).AND.(ndir == 2) 
    12181080         zrhot = Agrif_rhot() 
    12191081         ! Time indexes bounds for integration 
    … …  
    12241086            &           - zt0**2._wp * (-2._wp*zt0 + 3._wp)    )  
    12251087         ! 
    1226          IF(western_side )   vbdy_w(1:nbghostcells,j1:j2) = zat * ptab(i1:i2,j1:j2)   
    1227          IF(eastern_side )   vbdy_e(1:nbghostcells,j1:j2) = zat * ptab(i1:i2,j1:j2)   
    1228          IF(southern_side)   vbdy_s(i1:i2,1:nbghostcells) = zat * ptab(i1:i2,j1:j2) 
    1229          IF(northern_side)   vbdy_n(i1:i2,1:nbghostcells) = zat * ptab(i1:i2,j1:j2)  
     1088         ubdy(i1:i2,j1:j2) = zat * ptab(i1:i2,j1:j2)  
     1089         ! 
     1090         ! Update interpolation stage: 
     1091         utint_stage(i1:i2,j1:j2) = 1 
     1092      ENDIF 
     1093      !  
     1094   END SUBROUTINE interpub2b 
     1095    
     1096 
     1097   SUBROUTINE interpvb2b( ptab, i1, i2, j1, j2, before ) 
     1098      !!---------------------------------------------------------------------- 
     1099      !!                  ***  ROUTINE interpvb2b  *** 
     1100      !!----------------------------------------------------------------------   
     1101      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2 
     1102      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab 
     1103      LOGICAL                         , INTENT(in   ) ::   before 
     1104      ! 
     1105      INTEGER ::   ji,jj 
     1106      REAL(wp) ::   zrhot, zt0, zt1, zat 
     1107      !!----------------------------------------------------------------------   
     1108      ! 
     1109      IF( before ) THEN 
     1110         IF ( ln_bt_fw ) THEN 
     1111            ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * vb2_b(i1:i2,j1:j2) 
     1112         ELSE 
     1113            ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * vn_adv(i1:i2,j1:j2) 
     1114         ENDIF 
     1115      ELSE       
     1116         zrhot = Agrif_rhot() 
     1117         ! Time indexes bounds for integration 
     1118         zt0 = REAL(Agrif_NbStepint()  , wp) / zrhot 
     1119         zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot 
     1120         ! Polynomial interpolation coefficients: 
     1121         zat = zrhot * (  zt1**2._wp * (-2._wp*zt1 + 3._wp)    & 
     1122            &           - zt0**2._wp * (-2._wp*zt0 + 3._wp)    )  
     1123         ! 
     1124         vbdy(i1:i2,j1:j2) = zat * ptab(i1:i2,j1:j2) 
     1125         ! 
     1126         ! update interpolation stage: 
     1127         vtint_stage(i1:i2,j1:j2) = 1 
    12301128      ENDIF 
    12311129      !       
    … …  
    12331131 
    12341132 
    1235    SUBROUTINE interpe3t( ptab, i1, i2, j1, j2, k1, k2, before, nb, ndir ) 
     1133   SUBROUTINE interpe3t( ptab, i1, i2, j1, j2, k1, k2, before ) 
    12361134      !!---------------------------------------------------------------------- 
    12371135      !!                  ***  ROUTINE interpe3t  *** 
    … …  
    12401138      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 
    12411139      LOGICAL                              , INTENT(in   ) :: before 
    1242       INTEGER                              , INTENT(in   ) :: nb , ndir 
    12431140      ! 
    12441141      INTEGER :: ji, jj, jk 
    1245       LOGICAL :: western_side, eastern_side, northern_side, southern_side 
    12461142      !!----------------------------------------------------------------------   
    12471143      !     
    … …  
    12491145         ptab(i1:i2,j1:j2,k1:k2) = tmask(i1:i2,j1:j2,k1:k2) * e3t_0(i1:i2,j1:j2,k1:k2) 
    12501146      ELSE 
    1251          western_side  = (nb == 1).AND.(ndir == 1) 
    1252          eastern_side  = (nb == 1).AND.(ndir == 2) 
    1253          southern_side = (nb == 2).AND.(ndir == 1) 
    1254          northern_side = (nb == 2).AND.(ndir == 2) 
    12551147         ! 
    12561148         DO jk = k1, k2 
    12571149            DO jj = j1, j2 
    12581150               DO ji = i1, i2 
    1259                   ! 
    12601151                  IF( ABS( ptab(ji,jj,jk) - tmask(ji,jj,jk) * e3t_0(ji,jj,jk) ) > 1.D-2) THEN 
    1261                      IF (western_side.AND.(ptab(i1+nbghostcells-1,jj,jk)>0._wp)) THEN 
    1262                         WRITE(numout,*) 'ERROR bathymetry merge at the western border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk 
    1263                         WRITE(numout,*)  ptab(ji,jj,jk), e3t_0(ji,jj,jk)  
    1264                         kindic_agr = kindic_agr + 1 
    1265                      ELSEIF (eastern_side.AND.(ptab(i2-nbghostcells+1,jj,jk)>0._wp)) THEN 
    1266                         WRITE(numout,*) 'ERROR bathymetry merge at the eastern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk 
    1267                         WRITE(numout,*)  ptab(ji,jj,jk), e3t_0(ji,jj,jk) 
    1268                         kindic_agr = kindic_agr + 1 
    1269                      ELSEIF (southern_side.AND.(ptab(ji,j1+nbghostcells-1,jk)>0._wp)) THEN 
    1270                         WRITE(numout,*) 'ERROR bathymetry merge at the southern border ji,jj,jk', ji+nimpp-1,jj+njmpp-1,jk 
    1271                         WRITE(numout,*)  ptab(ji,jj,jk), e3t_0(ji,jj,jk) 
    1272                         kindic_agr = kindic_agr + 1 
    1273                      ELSEIF (northern_side.AND.(ptab(ji,j2-nbghostcells+1,jk)>0._wp)) THEN 
    1274                         WRITE(numout,*) 'ERROR bathymetry merge at the northen border ji,jj,jk', ji+nimpp-1,jj+njmpp-1,jk 
    1275                         WRITE(numout,*)  ptab(ji,jj,jk), e3t_0(ji,jj,jk) 
    1276                         kindic_agr = kindic_agr + 1 
    1277                      ENDIF 
     1152                     WRITE(numout,*) ' Agrif error for e3t_0: parent , child, i, j, k ',  &  
     1153                     &                 ptab(ji,jj,jk), tmask(ji,jj,jk) * e3t_0(ji,jj,jk), & 
     1154                     &                 ji+nimpp-1, jj+njmpp-1, jk 
     1155                     kindic_agr = kindic_agr + 1 
    12781156                  ENDIF 
    12791157               END DO 
    … …  
    12841162      !  
    12851163   END SUBROUTINE interpe3t 
    1286  
    1287  
    1288    SUBROUTINE interpumsk( ptab, i1, i2, j1, j2, k1, k2, before, nb, ndir ) 
    1289       !!---------------------------------------------------------------------- 
    1290       !!                  ***  ROUTINE interpumsk  *** 
    1291       !!----------------------------------------------------------------------   
    1292       INTEGER                              , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2 
    1293       REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) ::   ptab 
    1294       LOGICAL                              , INTENT(in   ) ::   before 
    1295       INTEGER                              , INTENT(in   ) ::   nb , ndir 
    1296       ! 
    1297       INTEGER ::   ji, jj, jk 
    1298       LOGICAL ::   western_side, eastern_side    
    1299       !!----------------------------------------------------------------------   
    1300       !     
    1301       IF( before ) THEN 
    1302          ptab(i1:i2,j1:j2,k1:k2) = umask(i1:i2,j1:j2,k1:k2) 
    1303       ELSE 
    1304          western_side = (nb == 1).AND.(ndir == 1) 
    1305          eastern_side = (nb == 1).AND.(ndir == 2) 
    1306          DO jk = k1, k2 
    1307             DO jj = j1, j2 
    1308                DO ji = i1, i2 
    1309                    ! Velocity mask at boundary edge points: 
    1310                   IF (ABS(ptab(ji,jj,jk) - umask(ji,jj,jk)) > 1.D-2) THEN 
    1311                      IF (western_side) THEN 
    1312                         WRITE(numout,*) 'ERROR with umask at the western border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk 
    1313                         WRITE(numout,*) '      masks: parent, child ', ptab(ji,jj,jk), umask(ji,jj,jk) 
    1314                         kindic_agr = kindic_agr + 1 
    1315                      ELSEIF (eastern_side) THEN 
    1316                         WRITE(numout,*) 'ERROR with umask at the eastern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk 
    1317                         WRITE(numout,*) '      masks: parent, child ', ptab(ji,jj,jk), umask(ji,jj,jk) 
    1318                         kindic_agr = kindic_agr + 1 
    1319                      ENDIF 
    1320                   ENDIF 
    1321                END DO 
    1322             END DO 
    1323          END DO 
    1324          ! 
    1325       ENDIF 
    1326       !  
    1327    END SUBROUTINE interpumsk 
    1328  
    1329  
    1330    SUBROUTINE interpvmsk( ptab, i1, i2, j1, j2, k1, k2, before, nb, ndir ) 
    1331       !!---------------------------------------------------------------------- 
    1332       !!                  ***  ROUTINE interpvmsk  *** 
    1333       !!----------------------------------------------------------------------   
    1334       INTEGER                              , INTENT(in   ) ::   i1,i2,j1,j2,k1,k2 
    1335       REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) ::   ptab 
    1336       LOGICAL                              , INTENT(in   ) ::   before 
    1337       INTEGER                              , INTENT(in   ) :: nb , ndir 
    1338       ! 
    1339       INTEGER ::   ji, jj, jk 
    1340       LOGICAL ::   northern_side, southern_side      
    1341       !!----------------------------------------------------------------------   
    1342       !     
    1343       IF( before ) THEN 
    1344          ptab(i1:i2,j1:j2,k1:k2) = vmask(i1:i2,j1:j2,k1:k2) 
    1345       ELSE 
    1346          southern_side = (nb == 2).AND.(ndir == 1) 
    1347          northern_side = (nb == 2).AND.(ndir == 2) 
    1348          DO jk = k1, k2 
    1349             DO jj = j1, j2 
    1350                DO ji = i1, i2 
    1351                    ! Velocity mask at boundary edge points: 
    1352                   IF (ABS(ptab(ji,jj,jk) - vmask(ji,jj,jk)) > 1.D-2) THEN 
    1353                      IF (southern_side) THEN 
    1354                         WRITE(numout,*) 'ERROR with vmask at the southern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk 
    1355                         WRITE(numout,*) '      masks: parent, child ', ptab(ji,jj,jk), vmask(ji,jj,jk) 
    1356                         kindic_agr = kindic_agr + 1 
    1357                      ELSEIF (northern_side) THEN 
    1358                         WRITE(numout,*) 'ERROR with vmask at the northern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk 
    1359                         WRITE(numout,*) '      masks: parent, child ', ptab(ji,jj,jk), vmask(ji,jj,jk) 
    1360                         kindic_agr = kindic_agr + 1 
    1361                      ENDIF 
    1362                   ENDIF 
    1363                END DO 
    1364             END DO 
    1365          END DO 
    1366          ! 
    1367       ENDIF 
    1368       !  
    1369    END SUBROUTINE interpvmsk 
    13701164 
    13711165 
    … …  
    13771171      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,m1:m2), INTENT(inout) ::   ptab 
    13781172      LOGICAL                                    , INTENT(in   ) ::   before 
    1379       REAL(wp), DIMENSION(k1:k2) :: tabin, h_in 
    1380       REAL(wp), DIMENSION(1:jpk) :: h_out 
    1381       INTEGER  :: N_in, N_out, ji, jj, jk 
     1173      ! 
     1174      INTEGER  :: ji, jj, jk 
     1175      INTEGER  :: N_in, N_out 
     1176      REAL(wp), DIMENSION(k1:k2) :: tabin, z_in 
     1177      REAL(wp), DIMENSION(1:jpk) :: z_out 
    13821178      !!----------------------------------------------------------------------   
    13831179      !       
    … …  
    13901186           END DO 
    13911187        END DO 
    1392 #ifdef key_vertical          
     1188 
     1189# if defined key_vertical 
     1190        ! Interpolate thicknesses 
     1191        ! Warning: these are masked, hence extrapolated prior interpolation. 
    13931192        DO jk=k1,k2 
    13941193           DO jj=j1,j2 
    13951194              DO ji=i1,i2 
    1396                  ptab(ji,jj,jk,2) = wmask(ji,jj,jk) * e3w_n(ji,jj,jk)  
     1195                  ptab(ji,jj,jk,2) = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kmm_a) 
    13971196              END DO 
    13981197           END DO 
    13991198        END DO 
    1400 #endif 
     1199 
     1200        ! Extrapolate thicknesses in partial bottom cells: 
     1201        ! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on 
     1202        IF (ln_zps) THEN 
     1203           DO jj=j1,j2 
     1204              DO ji=i1,i2 
     1205                  jk = mbkt(ji,jj) 
     1206                  ptab(ji,jj,jk,2) = 0._wp 
     1207              END DO 
     1208           END DO            
     1209        END IF 
     1210      
     1211        ! Save ssh at last level: 
     1212        IF (.NOT.ln_linssh) THEN 
     1213           ptab(i1:i2,j1:j2,k2,2) = ssh(i1:i2,j1:j2,Kmm_a)*tmask(i1:i2,j1:j2,1)  
     1214        ELSE 
     1215           ptab(i1:i2,j1:j2,k2,2) = 0._wp 
     1216        END IF       
     1217# endif 
    14011218      ELSE  
    14021219#ifdef key_vertical          
    1403          avm_k(i1:i2,j1:j2,1:jpk) = 0. 
    1404          DO jj=j1,j2 
    1405             DO ji=i1,i2 
    1406                N_in = 0 
    1407                DO jk=k1,k2 !k2 = jpk of parent grid 
    1408                   IF (ptab(ji,jj,jk,2) == 0) EXIT 
    1409                   N_in = N_in + 1 
    1410                   tabin(jk) = ptab(ji,jj,jk,1) 
    1411                   h_in(N_in) = ptab(ji,jj,jk,2) 
    1412                END DO 
    1413                N_out = 0 
    1414                DO jk=1,jpk ! jpk of child grid 
    1415                   IF (wmask(ji,jj,jk) == 0) EXIT  
    1416                   N_out = N_out + 1 
    1417                   h_out(jk) = e3t_n(ji,jj,jk) 
     1220         IF (ln_linssh) ptab(i1:i2,j1:j2,k2,2) = 0._wp  
     1221         avm_k(i1:i2,j1:j2,k1:k2) = 0._wp 
     1222             
     1223         DO jj = j1, j2 
     1224            DO ji =i1, i2 
     1225               N_in = mbkt_parent(ji,jj) 
     1226               IF ( tmask(ji,jj,1) == 0._wp) N_in = 0 
     1227               z_in(N_in+1) = ht0_parent(ji,jj) + ptab(ji,jj,k2,2) 
     1228               DO jk = N_in, 1, -1  ! Parent vertical grid                
     1229                     z_in(jk) = z_in(jk+1) - ptab(ji,jj,jk,2) 
     1230                    tabin(jk) = ptab(ji,jj,jk,1) 
     1231               END DO 
     1232               N_out = mbkt(ji,jj)  
     1233               DO jk = 1, N_out        ! Child vertical grid 
     1234                  z_out(jk) = gdepw(ji,jj,jk,Kmm_a) 
    14181235               ENDDO 
    1419                IF (N_in > 0) THEN 
    1420                   CALL reconstructandremap(tabin(1:N_in),h_in,avm_k(ji,jj,1:N_out),h_out,N_in,N_out) 
     1236               IF (N_in*N_out > 0) THEN 
     1237                  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) 
    14211238               ENDIF 
    14221239            ENDDO 
    … …  
    14281245      ! 
    14291246   END SUBROUTINE interpavm 
     1247 
     1248# if defined key_vertical 
     1249   SUBROUTINE interpmbkt( ptab, i1, i2, j1, j2, before ) 
     1250      !!---------------------------------------------------------------------- 
     1251      !!                  ***  ROUTINE interpsshn  *** 
     1252      !!----------------------------------------------------------------------   
     1253      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2 
     1254      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab 
     1255      LOGICAL                         , INTENT(in   ) ::   before 
     1256      ! 
     1257      !!----------------------------------------------------------------------   
     1258      ! 
     1259      IF( before) THEN 
     1260         ptab(i1:i2,j1:j2) = REAL(mbkt(i1:i2,j1:j2),wp) 
     1261      ELSE 
     1262         mbkt_parent(i1:i2,j1:j2) = NINT(ptab(i1:i2,j1:j2)) 
     1263      ENDIF 
     1264      ! 
     1265   END SUBROUTINE interpmbkt 
     1266 
     1267   SUBROUTINE interpht0( ptab, i1, i2, j1, j2, before ) 
     1268      !!---------------------------------------------------------------------- 
     1269      !!                  ***  ROUTINE interpsshn  *** 
     1270      !!----------------------------------------------------------------------   
     1271      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2 
     1272      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab 
     1273      LOGICAL                         , INTENT(in   ) ::   before 
     1274      ! 
     1275      !!----------------------------------------------------------------------   
     1276      ! 
     1277      IF( before) THEN 
     1278         ptab(i1:i2,j1:j2) = ht_0(i1:i2,j1:j2) 
     1279      ELSE 
     1280         ht0_parent(i1:i2,j1:j2) = ptab(i1:i2,j1:j2) 
     1281      ENDIF 
     1282      ! 
     1283   END SUBROUTINE interpht0 
     1284#endif 
    14301285 
    14311286#else 

  • NEMO/trunk/src/NST/agrif_oce_sponge.F90

    r10425 r12377  
    2222   USE agrif_oce 
    2323   USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
     24   USE iom 
     25   USE vremap 
    2426 
    2527   IMPLICIT NONE 
    … …  
    2931   PUBLIC interptsn_sponge, interpun_sponge, interpvn_sponge 
    3032 
     33   !! * Substitutions 
     34#  include "do_loop_substitute.h90" 
    3135   !!---------------------------------------------------------------------- 
    3236   !! NEMO/NST 4.0 , NEMO Consortium (2018) 
    … …  
    5862#endif 
    5963      ! 
     64      CALL iom_put( 'agrif_spu', fspu(:,:)) 
     65      CALL iom_put( 'agrif_spv', fspv(:,:)) 
     66      ! 
    6067   END SUBROUTINE Agrif_Sponge_Tra 
    6168 
    … …  
    8592#endif 
    8693      ! 
     94      CALL iom_put( 'agrif_spt', fspt(:,:)) 
     95      CALL iom_put( 'agrif_spf', fspf(:,:)) 
     96      ! 
    8797   END SUBROUTINE Agrif_Sponge_dyn 
    8898 
    … …  
    93103      !!---------------------------------------------------------------------- 
    94104      INTEGER  ::   ji, jj, ind1, ind2 
    95       INTEGER  ::   ispongearea 
    96       REAL(wp) ::   z1_spongearea 
     105      INTEGER  ::   ispongearea, jspongearea 
     106      REAL(wp) ::   z1_ispongearea, z1_jspongearea 
    97107      REAL(wp), DIMENSION(jpi,jpj) :: ztabramp 
    98       !!---------------------------------------------------------------------- 
    99       ! 
     108      REAL(wp), DIMENSION(jpjmax)  :: zmskwest,  zmskeast 
     109      REAL(wp), DIMENSION(jpimax)  :: zmsknorth, zmsksouth 
     110      !!---------------------------------------------------------------------- 
     111      ! 
     112      ! Sponge 1d example with: 
     113      !      iraf = 3 ; nbghost = 3 ; nn_sponge_len = 2 
     114      !                         
     115      !coarse :     U     T     U     T     U     T     U 
     116      !|            |           |           |           | 
     117      !fine :     t u t u t u t u t u t u t u t u t u t u t 
     118      !sponge val:0   0   0   1  5/6 4/6 3/6 2/6 1/6  0   0 
     119      !           |   ghost     | <-- sponge area  -- > | 
     120      !           |   points    |                       | 
     121      !                         |--> dynamical interface 
     122 
    100123#if defined SPONGE || defined SPONGE_TOP 
    101124      IF (( .NOT. spongedoneT ).OR.( .NOT. spongedoneU )) THEN 
     125         ! 
     126         ! Retrieve masks at open boundaries: 
     127 
     128         ! --- West --- ! 
     129         ztabramp(:,:) = 0._wp 
     130         ind1 = 1+nbghostcells 
     131         DO ji = mi0(ind1), mi1(ind1)                 
     132            ztabramp(ji,:) = ssumask(ji,:) 
     133         END DO 
     134         ! 
     135         zmskwest(:) = 0._wp 
     136         zmskwest(1:jpj) = MAXVAL(ztabramp(:,:), dim=1) 
     137 
     138         ! --- East --- ! 
     139         ztabramp(:,:) = 0._wp 
     140         ind1 = jpiglo - nbghostcells - 1 
     141         DO ji = mi0(ind1), mi1(ind1)                  
     142            ztabramp(ji,:) = ssumask(ji,:) 
     143         END DO 
     144         ! 
     145         zmskeast(:) = 0._wp 
     146         zmskeast(1:jpj) = MAXVAL(ztabramp(:,:), dim=1) 
     147 
     148         ! --- South --- ! 
     149         ztabramp(:,:) = 0._wp 
     150         ind1 = 1+nbghostcells 
     151         DO jj = mj0(ind1), mj1(ind1)                  
     152            ztabramp(:,jj) = ssvmask(:,jj) 
     153         END DO 
     154         ! 
     155         zmsksouth(:) = 0._wp 
     156         zmsksouth(1:jpi) = MAXVAL(ztabramp(:,:), dim=2) 
     157 
     158         ! --- North --- ! 
     159         ztabramp(:,:) = 0._wp 
     160         ind1 = jpjglo - nbghostcells - 1 
     161         DO jj = mj0(ind1), mj1(ind1)                  
     162            ztabramp(:,jj) = ssvmask(:,jj) 
     163         END DO 
     164         ! 
     165         zmsknorth(:) = 0._wp 
     166         zmsknorth(1:jpi) = MAXVAL(ztabramp(:,:), dim=2) 
     167         ! JC: SPONGE MASKING TO BE SORTED OUT: 
     168         zmskwest(:)  = 1._wp 
     169         zmskeast(:)  = 1._wp 
     170         zmsknorth(:) = 1._wp 
     171         zmsksouth(:) = 1._wp 
     172#if defined key_mpp_mpi 
     173!         CALL mpp_max( 'AGRIF_sponge', zmskwest(:) , jpjmax ) 
     174!         CALL mpp_max( 'AGRIF_Sponge', zmskeast(:) , jpjmax ) 
     175!         CALL mpp_max( 'AGRIF_Sponge', zmsksouth(:), jpimax ) 
     176!         CALL mpp_max( 'AGRIF_Sponge', zmsknorth(:), jpimax ) 
     177#endif 
     178 
    102179         ! Define ramp from boundaries towards domain interior at T-points 
    103180         ! Store it in ztabramp 
    104181 
    105          ispongearea  = 1 + nn_sponge_len * Agrif_irhox() 
    106          z1_spongearea = 1._wp / REAL( ispongearea ) 
     182         ispongearea  = nn_sponge_len * Agrif_irhox() 
     183         z1_ispongearea = 1._wp / REAL( ispongearea ) 
     184         jspongearea  = nn_sponge_len * Agrif_irhoy() 
     185         z1_jspongearea = 1._wp / REAL( jspongearea ) 
    107186          
    108187         ztabramp(:,:) = 0._wp 
    109188 
     189         ! Trick to remove sponge in 2DV domains: 
     190         IF ( nbcellsx <= 3 ) ispongearea = -1 
     191         IF ( nbcellsy <= 3 ) jspongearea = -1 
     192 
    110193         ! --- West --- ! 
    111          IF( (nbondi == -1) .OR. (nbondi == 2) ) THEN 
    112             ind1 = 1+nbghostcells 
    113             ind2 = 1+nbghostcells + ispongearea  
     194         ind1 = 1+nbghostcells 
     195         ind2 = 1+nbghostcells + ispongearea  
     196         DO ji = mi0(ind1), mi1(ind2)    
     197            DO jj = 1, jpj                
     198               ztabramp(ji,jj) = REAL( ind2 - mig(ji) ) * z1_ispongearea * zmskwest(jj) 
     199            END DO 
     200         END DO 
     201 
     202         ! ghost cells: 
     203         ind1 = 1 
     204         ind2 = nbghostcells + 1 
     205         DO ji = mi0(ind1), mi1(ind2)    
     206            DO jj = 1, jpj                
     207               ztabramp(ji,jj) = zmskwest(jj) 
     208            END DO 
     209         END DO 
     210 
     211         ! --- East --- ! 
     212         ind1 = jpiglo - nbghostcells - ispongearea 
     213         ind2 = jpiglo - nbghostcells 
     214         DO ji = mi0(ind1), mi1(ind2) 
    114215            DO jj = 1, jpj 
    115                DO ji = ind1, ind2                 
    116                   ztabramp(ji,jj) = REAL( ind2 - ji ) * z1_spongearea * umask(ind1,jj,1) 
    117                END DO 
     216               ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL( mig(ji) - ind1 ) * z1_ispongearea) * zmskeast(jj) 
    118217            ENDDO 
    119          ENDIF 
    120  
    121          ! --- East --- ! 
    122          IF( (nbondi == 1) .OR. (nbondi == 2) ) THEN 
    123             ind1 = nlci - nbghostcells - ispongearea 
    124             ind2 = nlci - nbghostcells 
     218         END DO 
     219 
     220         ! ghost cells: 
     221         ind1 = jpiglo - nbghostcells 
     222         ind2 = jpiglo 
     223         DO ji = mi0(ind1), mi1(ind2) 
    125224            DO jj = 1, jpj 
    126                DO ji = ind1, ind2 
    127                   ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL( ji - ind1 ) * z1_spongearea * umask(ind2-1,jj,1) ) 
    128                ENDDO 
     225               ztabramp(ji,jj) = zmskeast(jj) 
    129226            ENDDO 
    130          ENDIF 
     227         END DO 
    131228 
    132229         ! --- South --- ! 
    133          IF( (nbondj == -1) .OR. (nbondj == 2) ) THEN 
    134             ind1 = 1+nbghostcells 
    135             ind2 = 1+nbghostcells + ispongearea 
    136             DO jj = ind1, ind2  
    137                DO ji = 1, jpi 
    138                   ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL( ind2 - jj ) * z1_spongearea * vmask(ji,ind1,1) ) 
    139                END DO 
    140             ENDDO 
    141          ENDIF 
     230         ind1 = 1+nbghostcells 
     231         ind2 = 1+nbghostcells + jspongearea 
     232         DO jj = mj0(ind1), mj1(ind2)  
     233            DO ji = 1, jpi 
     234               ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL( ind2 - mjg(jj) ) * z1_jspongearea) * zmsksouth(ji) 
     235            END DO 
     236         END DO 
     237 
     238         ! ghost cells: 
     239         ind1 = 1 
     240         ind2 = nbghostcells + 1 
     241         DO jj = mj0(ind1), mj1(ind2)  
     242            DO ji = 1, jpi 
     243               ztabramp(ji,jj) = zmsksouth(ji) 
     244            END DO 
     245         END DO 
    142246 
    143247         ! --- North --- ! 
    144          IF( (nbondj == 1) .OR. (nbondj == 2) ) THEN 
    145             ind1 = nlcj - nbghostcells - ispongearea 
    146             ind2 = nlcj - nbghostcells 
    147             DO jj = ind1, ind2 
    148                DO ji = 1, jpi 
    149                   ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL( jj - ind1 ) * z1_spongearea * vmask(ji,ind2-1,1) ) 
    150                END DO 
    151             ENDDO 
    152          ENDIF 
     248         ind1 = jpjglo - nbghostcells - jspongearea 
     249         ind2 = jpjglo - nbghostcells 
     250         DO jj = mj0(ind1), mj1(ind2) 
     251            DO ji = 1, jpi 
     252               ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL( mjg(jj) - ind1 ) * z1_jspongearea) * zmsknorth(ji) 
     253            END DO 
     254         END DO 
     255 
     256         ! ghost cells: 
     257         ind1 = jpjglo - nbghostcells 
     258         ind2 = jpjglo 
     259         DO jj = mj0(ind1), mj1(ind2) 
     260            DO ji = 1, jpi 
     261               ztabramp(ji,jj) = zmsknorth(ji) 
     262            END DO 
     263         END DO 
    153264 
    154265      ENDIF 
    … …  
    156267      ! Tracers 
    157268      IF( .NOT. spongedoneT ) THEN 
    158          fsaht_spu(:,:) = 0._wp 
    159          fsaht_spv(:,:) = 0._wp 
    160          DO jj = 2, jpjm1 
    161             DO ji = 2, jpim1   ! vector opt. 
    162                fsaht_spu(ji,jj) = 0.5_wp * visc_tra * ( ztabramp(ji,jj) + ztabramp(ji+1,jj  ) ) 
    163                fsaht_spv(ji,jj) = 0.5_wp * visc_tra * ( ztabramp(ji,jj) + ztabramp(ji  ,jj+1) ) 
    164             END DO 
    165          END DO 
    166          CALL lbc_lnk( 'agrif_oce_sponge', fsaht_spu, 'U', 1. )   ! Lateral boundary conditions 
    167          CALL lbc_lnk( 'agrif_oce_sponge', fsaht_spv, 'V', 1. ) 
    168           
     269         fspu(:,:) = 0._wp 
     270         fspv(:,:) = 0._wp 
     271         DO_2D_00_00 
     272            fspu(ji,jj) = 0.5_wp * ( ztabramp(ji,jj) + ztabramp(ji+1,jj  ) ) * ssumask(ji,jj) 
     273            fspv(ji,jj) = 0.5_wp * ( ztabramp(ji,jj) + ztabramp(ji  ,jj+1) ) * ssvmask(ji,jj) 
     274         END_2D 
     275         CALL lbc_lnk( 'agrif_Sponge', fspu, 'U', 1. )   ! Lateral boundary conditions 
     276         CALL lbc_lnk( 'agrif_Sponge', fspv, 'V', 1. ) 
     277 
    169278         spongedoneT = .TRUE. 
    170279      ENDIF 
    … …  
    172281      ! Dynamics 
    173282      IF( .NOT. spongedoneU ) THEN 
    174          fsahm_spt(:,:) = 0._wp 
    175          fsahm_spf(:,:) = 0._wp 
    176          DO jj = 2, jpjm1 
    177             DO ji = 2, jpim1   ! vector opt. 
    178                fsahm_spt(ji,jj) = visc_dyn * ztabramp(ji,jj) 
    179                fsahm_spf(ji,jj) = 0.25_wp * visc_dyn * ( ztabramp(ji  ,jj  ) + ztabramp(ji  ,jj+1) & 
    180                                                      &  +ztabramp(ji+1,jj+1) + ztabramp(ji+1,jj  ) ) 
    181             END DO 
    182          END DO 
    183          CALL lbc_lnk( 'agrif_oce_sponge', fsahm_spt, 'T', 1. )   ! Lateral boundary conditions 
    184          CALL lbc_lnk( 'agrif_oce_sponge', fsahm_spf, 'F', 1. ) 
     283         fspt(:,:) = 0._wp 
     284         fspf(:,:) = 0._wp 
     285         DO_2D_00_00 
     286            fspt(ji,jj) = ztabramp(ji,jj) * ssmask(ji,jj) 
     287            fspf(ji,jj) = 0.25_wp * ( ztabramp(ji  ,jj  ) + ztabramp(ji  ,jj+1)   & 
     288                                  &  +ztabramp(ji+1,jj+1) + ztabramp(ji+1,jj  ) ) & 
     289                                  &  * ssvmask(ji,jj) * ssvmask(ji,jj+1) 
     290         END_2D 
     291         CALL lbc_lnk( 'agrif_Sponge', fspt, 'T', 1. )   ! Lateral boundary conditions 
     292         CALL lbc_lnk( 'agrif_Sponge', fspf, 'F', 1. ) 
    185293          
    186294         spongedoneU = .TRUE. 
    187295      ENDIF 
     296 
     297#if defined key_vertical 
     298      ! Remove vertical interpolation where not needed: 
     299      DO_2D_00_00 
     300         IF ((fspu(ji-1,jj)==0._wp).AND.(fspu(ji,jj)==0._wp).AND. & 
     301         &   (fspv(ji,jj-1)==0._wp).AND.(fspv(ji,jj)==0._wp)) mbkt_parent(ji,jj) = 0 
     302! 
     303         IF ((fspt(ji+1,jj)==0._wp).AND.(fspt(ji,jj)==0._wp).AND. & 
     304         &   (fspf(ji,jj-1)==0._wp).AND.(fspf(ji,jj)==0._wp)) mbku_parent(ji,jj) = 0 
     305! 
     306         IF ((fspt(ji,jj+1)==0._wp).AND.(fspt(ji,jj)==0._wp).AND. & 
     307         &   (fspf(ji-1,jj)==0._wp).AND.(fspf(ji,jj)==0._wp)) mbkv_parent(ji,jj) = 0 
     308! 
     309         IF ( ssmask(ji,jj) == 0._wp) mbkt_parent(ji,jj) = 0 
     310         IF (ssumask(ji,jj) == 0._wp) mbku_parent(ji,jj) = 0 
     311         IF (ssvmask(ji,jj) == 0._wp) mbkv_parent(ji,jj) = 0 
     312      END_2D 
     313      ! 
     314      ztabramp(:,:) = REAL( mbkt_parent(:,:), wp )   ;   CALL lbc_lnk( 'Agrif_Sponge', ztabramp, 'T', 1. ) 
     315      mbkt_parent(:,:) = NINT( ztabramp(:,:) ) 
     316      ztabramp(:,:) = REAL( mbku_parent(:,:), wp )   ;   CALL lbc_lnk( 'Agrif_Sponge', ztabramp, 'U', 1. ) 
     317      mbku_parent(:,:) = NINT( ztabramp(:,:) ) 
     318      ztabramp(:,:) = REAL( mbkv_parent(:,:), wp )   ;   CALL lbc_lnk( 'Agrif_Sponge', ztabramp, 'V', 1. ) 
     319      mbkv_parent(:,:) = NINT( ztabramp(:,:) ) 
     320#endif 
    188321      ! 
    189322#endif 
    … …  
    201334      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
    202335      INTEGER  ::   iku, ikv 
    203       REAL(wp) :: ztsa, zabe1, zabe2, zbtr 
     336      REAL(wp) :: ztsa, zabe1, zabe2, zbtr, zhtot, ztrelax 
    204337      REAL(wp), DIMENSION(i1:i2,j1:j2,jpk) :: ztu, ztv 
    205338      REAL(wp), DIMENSION(i1:i2,j1:j2,jpk,n1:n2) ::tsbdiff 
    … …  
    210343      REAL(wp), DIMENSION(1:jpk) :: h_out 
    211344      INTEGER :: N_in, N_out 
    212       REAL(wp) :: h_diff 
    213345      !!---------------------------------------------------------------------- 
    214346      ! 
    … …  
    218350               DO jj=j1,j2 
    219351                  DO ji=i1,i2 
    220                      tabres(ji,jj,jk,jn) = tsb(ji,jj,jk,jn) 
     352                     tabres(ji,jj,jk,jn) = ts(ji,jj,jk,jn,Kbb_a) 
    221353                  END DO 
    222354               END DO 
    … …  
    225357 
    226358# if defined key_vertical 
    227          DO jk=k1,k2 
    228             DO jj=j1,j2 
    229                DO ji=i1,i2 
    230                   tabres(ji,jj,jk,jpts+1) = tmask(ji,jj,jk) * e3t_n(ji,jj,jk)  
    231                END DO 
    232             END DO 
    233          END DO 
     359        ! Interpolate thicknesses 
     360        ! Warning: these are masked, hence extrapolated prior interpolation. 
     361        DO jk=k1,k2 
     362           DO jj=j1,j2 
     363              DO ji=i1,i2 
     364                  tabres(ji,jj,jk,jpts+1) = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kbb_a) 
     365              END DO 
     366           END DO 
     367        END DO 
     368 
     369        ! Extrapolate thicknesses in partial bottom cells: 
     370        ! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on 
     371        IF (ln_zps) THEN 
     372           DO jj=j1,j2 
     373              DO ji=i1,i2 
     374                  jk = mbkt(ji,jj) 
     375                  tabres(ji,jj,jk,jpts+1) = 0._wp 
     376              END DO 
     377           END DO            
     378        END IF 
     379      
     380        ! Save ssh at last level: 
     381        IF (.NOT.ln_linssh) THEN 
     382           tabres(i1:i2,j1:j2,k2,jpts+1) = ssh(i1:i2,j1:j2,Kbb_a)*tmask(i1:i2,j1:j2,1)  
     383        ELSE 
     384           tabres(i1:i2,j1:j2,k2,jpts+1) = 0._wp 
     385        END IF       
    234386# endif 
    235387 
    … …  
    237389         ! 
    238390# if defined key_vertical 
    239          tabres_child(:,:,:,:) = 0. 
     391 
     392         IF (ln_linssh) tabres(i1:i2,j1:j2,k2,n2) = 0._wp 
     393 
    240394         DO jj=j1,j2 
    241395            DO ji=i1,i2 
    242                N_in = 0 
    243                DO jk=k1,k2 !k2 = jpk of parent grid 
    244                   IF (tabres(ji,jj,jk,n2) == 0) EXIT 
    245                   N_in = N_in + 1 
     396               tabres_child(ji,jj,:,:) = 0._wp  
     397               N_in = mbkt_parent(ji,jj) 
     398               zhtot = 0._wp 
     399               DO jk=1,N_in !k2 = jpk of parent grid 
     400                  IF (jk==N_in) THEN 
     401                     h_in(jk) = ht0_parent(ji,jj) + tabres(ji,jj,k2,n2) - zhtot 
     402                  ELSE 
     403                     h_in(jk) = tabres(ji,jj,jk,n2) 
     404                  ENDIF 
     405                  zhtot = zhtot + h_in(jk) 
    246406                  tabin(jk,:) = tabres(ji,jj,jk,n1:n2-1) 
    247                   h_in(N_in) = tabres(ji,jj,jk,n2) 
    248407               END DO 
    249408               N_out = 0 
    … …  
    251410                  IF (tmask(ji,jj,jk) == 0) EXIT  
    252411                  N_out = N_out + 1 
    253                   h_out(jk) = e3t_n(ji,jj,jk) !Child grid scale factors. Could multiply by e1e2t here instead of division above 
     412                  h_out(jk) = e3t(ji,jj,jk,Kbb_a) !Child grid scale factors. Could multiply by e1e2t here instead of division above 
    254413               ENDDO 
    255                IF (N_in > 0) THEN 
    256                   h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in)) 
    257                   tabres(ji,jj,k2,:) = tabres(ji,jj,k2-1,:) !what is this line for????? 
    258                   DO jn=1,jpts 
    259                      call reconstructandremap(tabin(1:N_in,jn),h_in,tabres_child(ji,jj,1:N_out,jn),h_out,N_in,N_out) 
    260                   ENDDO 
     414 
     415               ! Account for small differences in free-surface 
     416               IF ( sum(h_out(1:N_out)) > sum(h_in(1:N_in) )) THEN 
     417                  h_out(1) = h_out(1) - ( sum(h_out(1:N_out))-sum(h_in(1:N_in)) ) 
     418               ELSE 
     419                  h_in(1)   = h_in(1)   - (sum(h_in(1:N_in))-sum(h_out(1:N_out)) ) 
     420               ENDIF 
     421               IF (N_in*N_out > 0) THEN 
     422                  CALL reconstructandremap(tabin(1:N_in,1:jpts),h_in(1:N_in),tabres_child(ji,jj,1:N_out,1:jpts),h_out(1:N_out),N_in,N_out,jpts) 
    261423               ENDIF 
    262424            ENDDO 
    … …  
    268430               DO jk=1,jpkm1 
    269431# if defined key_vertical 
    270                   tsbdiff(ji,jj,jk,1:jpts) = tsb(ji,jj,jk,1:jpts) - tabres_child(ji,jj,jk,1:jpts) 
     432                  tsbdiff(ji,jj,jk,1:jpts) = (ts(ji,jj,jk,1:jpts,Kbb_a) - tabres_child(ji,jj,jk,1:jpts)) * tmask(ji,jj,jk) 
    271433# else 
    272                   tsbdiff(ji,jj,jk,1:jpts) = tsb(ji,jj,jk,1:jpts) - tabres(ji,jj,jk,1:jpts) 
     434                  tsbdiff(ji,jj,jk,1:jpts) = (ts(ji,jj,jk,1:jpts,Kbb_a) - tabres(ji,jj,jk,1:jpts))*tmask(ji,jj,jk) 
    273435# endif 
    274436               ENDDO 
    275437            ENDDO 
    276438         ENDDO 
     439 
     440         !* set relaxation time scale 
     441         IF( neuler == 0 .AND. lk_agrif_fstep ) THEN   ;   ztrelax =   rn_trelax_tra  / (        rdt ) 
     442         ELSE                                          ;   ztrelax =   rn_trelax_tra  / (2._wp * rdt ) 
     443         ENDIF 
    277444 
    278445         DO jn = 1, jpts             
    … …  
    281448               DO jj = j1,j2 
    282449                  DO ji = i1,i2-1 
    283                      zabe1 = fsaht_spu(ji,jj) * umask(ji,jj,jk) * e2_e1u(ji,jj) * e3u_n(ji,jj,jk) 
     450                     zabe1 = rn_sponge_tra * fspu(ji,jj) * umask(ji,jj,jk) * e2_e1u(ji,jj) * e3u(ji,jj,jk,Kmm_a) 
    284451                     ztu(ji,jj,jk) = zabe1 * ( tsbdiff(ji+1,jj  ,jk,jn) - tsbdiff(ji,jj,jk,jn) )  
    285452                  END DO 
    … …  
    288455               DO ji = i1,i2 
    289456                  DO jj = j1,j2-1 
    290                      zabe2 = fsaht_spv(ji,jj) * vmask(ji,jj,jk) * e1_e2v(ji,jj) * e3v_n(ji,jj,jk) 
     457                     zabe2 = rn_sponge_tra * fspv(ji,jj) * vmask(ji,jj,jk) * e1_e2v(ji,jj) * e3v(ji,jj,jk,Kmm_a) 
    291458                     ztv(ji,jj,jk) = zabe2 * ( tsbdiff(ji  ,jj+1,jk,jn) - tsbdiff(ji,jj,jk,jn) ) 
    292459                  END DO 
    … …  
    310477                  DO ji = i1+1,i2-1 
    311478                     IF (.NOT. tabspongedone_tsn(ji,jj)) THEN  
    312                         zbtr = r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) 
     479                        zbtr = r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm_a) 
    313480                        ! horizontal diffusive trends 
    314                         ztsa = zbtr * (  ztu(ji,jj,jk) - ztu(ji-1,jj,jk) + ztv(ji,jj,jk) - ztv(ji,jj-1,jk)  ) 
     481                        ztsa = zbtr * (  ztu(ji,jj,jk) - ztu(ji-1,jj,jk) + ztv(ji,jj,jk) - ztv(ji,jj-1,jk)  ) & 
     482                             &  - ztrelax * fspt(ji,jj) * tsbdiff(ji,jj,jk,jn)  
    315483                        ! add it to the general tracer trends 
    316                         tsa(ji,jj,jk,jn) = tsa(ji,jj,jk,jn) + ztsa 
     484                        ts(ji,jj,jk,jn,Krhs_a) = ts(ji,jj,jk,jn,Krhs_a) + ztsa 
    317485                     ENDIF 
    318486                  END DO 
    … …  
    339507 
    340508      ! sponge parameters  
    341       REAL(wp) :: ze2u, ze1v, zua, zva, zbtr, h_diff 
     509      REAL(wp) :: ze2u, ze1v, zua, zva, zbtr, zhtot, ztrelax 
    342510      REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: ubdiff 
    343511      REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: rotdiff, hdivdiff 
    … …  
    346514      REAL(wp), DIMENSION(k1:k2) :: tabin, h_in 
    347515      REAL(wp), DIMENSION(1:jpk) :: h_out 
    348       INTEGER ::N_in,N_out 
     516      INTEGER ::N_in, N_out 
    349517      !!---------------------------------------------     
    350518      ! 
    351519      IF( before ) THEN 
    352          DO jk=1,jpkm1 
     520         DO jk=k1,k2 
    353521            DO jj=j1,j2 
    354522               DO ji=i1,i2 
    355                   tabres(ji,jj,jk,m1) = ub(ji,jj,jk) 
     523                  tabres(ji,jj,jk,m1) = uu(ji,jj,jk,Kbb_a) 
    356524# if defined key_vertical 
    357                   tabres(ji,jj,jk,m2) = e3u_n(ji,jj,jk)*umask(ji,jj,jk) 
     525                  tabres(ji,jj,jk,m2) = e3u(ji,jj,jk,Kbb_a)*umask(ji,jj,jk) 
    358526# endif 
    359527               END DO 
    … …  
    361529         END DO 
    362530 
     531# if defined key_vertical 
     532         ! Extrapolate thicknesses in partial bottom cells: 
     533         ! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on 
     534         IF (ln_zps) THEN 
     535            DO jj=j1,j2 
     536               DO ji=i1,i2 
     537                  jk = mbku(ji,jj) 
     538                  tabres(ji,jj,jk,m2) = 0._wp 
     539               END DO 
     540            END DO            
     541         END IF 
     542        ! Save ssh at last level: 
     543        tabres(i1:i2,j1:j2,k2,m2) = 0._wp 
     544        IF (.NOT.ln_linssh) THEN 
     545           ! This vertical sum below should be replaced by the sea-level at U-points (optimization): 
     546           DO jk=1,jpk 
     547              tabres(i1:i2,j1:j2,k2,m2) = tabres(i1:i2,j1:j2,k2,m2) + e3u(i1:i2,j1:j2,jk,Kbb_a) * umask(i1:i2,j1:j2,jk) 
     548           END DO 
     549           tabres(i1:i2,j1:j2,k2,m2) = tabres(i1:i2,j1:j2,k2,m2) - hu_0(i1:i2,j1:j2) 
     550        END IF  
     551# endif 
     552 
    363553      ELSE 
    364554 
    365555# if defined key_vertical 
    366          tabres_child(:,:,:) = 0._wp 
     556         IF (ln_linssh) tabres(i1:i2,j1:j2,k2,m2) = 0._wp 
     557 
    367558         DO jj=j1,j2 
    368559            DO ji=i1,i2 
    369                N_in = 0 
    370                DO jk=k1,k2 
    371                   IF (tabres(ji,jj,jk,m2) == 0) EXIT 
    372                   N_in = N_in + 1 
     560               tabres_child(ji,jj,:) = 0._wp 
     561               N_in = mbku_parent(ji,jj) 
     562               zhtot = 0._wp 
     563               DO jk=1,N_in 
     564                  IF (jk==N_in) THEN 
     565                     h_in(jk) = hu0_parent(ji,jj) + tabres(ji,jj,k2,m2) - zhtot 
     566                  ELSE 
     567                     h_in(jk) = tabres(ji,jj,jk,m2) 
     568                  ENDIF 
     569                  zhtot = zhtot + h_in(jk) 
    373570                  tabin(jk) = tabres(ji,jj,jk,m1) 
    374                   h_in(N_in) = tabres(ji,jj,jk,m2) 
    375               ENDDO 
    376               ! 
    377               IF (N_in == 0) THEN 
    378                  tabres_child(ji,jj,:) = 0. 
    379                  CYCLE 
    380               ENDIF 
    381           
    382               N_out = 0 
    383               DO jk=1,jpk 
    384                  if (umask(ji,jj,jk) == 0) EXIT 
    385                  N_out = N_out + 1 
    386                  h_out(N_out) = e3u_n(ji,jj,jk) 
    387               ENDDO 
    388           
    389               IF (N_out == 0) THEN 
    390                  tabres_child(ji,jj,:) = 0. 
    391                  CYCLE 
    392               ENDIF 
    393           
    394               IF (N_in * N_out > 0) THEN 
    395                  h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in)) 
    396                  if (h_diff < -1.e4) then 
    397                     print *,'CHECK YOUR BATHY ...', h_diff, sum(h_out(1:N_out)), sum(h_in(1:N_in)) 
    398                  endif 
    399               ENDIF 
    400               call reconstructandremap(tabin(1:N_in),h_in(1:N_in),tabres_child(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out) 
    401           
     571               ENDDO 
     572               !          
     573               N_out = 0 
     574               DO jk=1,jpk 
     575                  IF (umask(ji,jj,jk) == 0) EXIT 
     576                  N_out = N_out + 1 
     577                  h_out(N_out) = e3u(ji,jj,jk,Kbb_a) 
     578               ENDDO 
     579 
     580               ! Account for small differences in free-surface 
     581               IF ( sum(h_out(1:N_out)) > sum(h_in(1:N_in) )) THEN 
     582                  h_out(1) = h_out(1) - ( sum(h_out(1:N_out))-sum(h_in(1:N_in)) ) 
     583               ELSE 
     584                  h_in(1)   = h_in(1)   - (sum(h_in(1:N_in))-sum(h_out(1:N_out)) ) 
     585               ENDIF 
     586                   
     587               IF (N_in * N_out > 0) THEN 
     588                  CALL reconstructandremap(tabin(1:N_in),h_in(1:N_in),tabres_child(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out,1) 
     589               ENDIF  
    402590            ENDDO 
    403591         ENDDO 
    404592 
    405          ubdiff(i1:i2,j1:j2,:) = (ub(i1:i2,j1:j2,:) - tabres_child(i1:i2,j1:j2,:))*umask(i1:i2,j1:j2,:) 
     593         ubdiff(i1:i2,j1:j2,:) = (uu(i1:i2,j1:j2,:,Kbb_a) - tabres_child(i1:i2,j1:j2,:))*umask(i1:i2,j1:j2,:) 
    406594#else 
    407          ubdiff(i1:i2,j1:j2,:) = (ub(i1:i2,j1:j2,:) - tabres(i1:i2,j1:j2,:,1))*umask(i1:i2,j1:j2,:) 
     595         ubdiff(i1:i2,j1:j2,:) = (uu(i1:i2,j1:j2,:,Kbb_a) - tabres(i1:i2,j1:j2,:,1))*umask(i1:i2,j1:j2,:) 
    408596#endif 
     597         !* set relaxation time scale 
     598         IF( neuler == 0 .AND. lk_agrif_fstep ) THEN   ;   ztrelax =   rn_trelax_dyn  / (        rdt ) 
     599         ELSE                                          ;   ztrelax =   rn_trelax_dyn  / (2._wp * rdt ) 
     600         ENDIF 
    409601         ! 
    410602         DO jk = 1, jpkm1                                 ! Horizontal slab 
    … …  
    416608            DO jj = j1,j2 
    417609               DO ji = i1+1,i2   ! vector opt. 
    418                   zbtr = r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) * fsahm_spt(ji,jj) 
    419                   hdivdiff(ji,jj,jk) = (  e2u(ji  ,jj)*e3u_n(ji  ,jj,jk) * ubdiff(ji  ,jj,jk) & 
    420                                      &   -e2u(ji-1,jj)*e3u_n(ji-1,jj,jk) * ubdiff(ji-1,jj,jk) ) * zbtr 
     610                  zbtr = r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kbb_a) * rn_sponge_dyn * fspt(ji,jj) 
     611                  hdivdiff(ji,jj,jk) = (  e2u(ji  ,jj)*e3u(ji  ,jj,jk,Kbb_a) * ubdiff(ji  ,jj,jk) & 
     612                                     &   -e2u(ji-1,jj)*e3u(ji-1,jj,jk,Kbb_a) * ubdiff(ji-1,jj,jk) ) * zbtr 
    421613               END DO 
    422614            END DO 
    … …  
    424616            DO jj = j1,j2-1 
    425617               DO ji = i1,i2   ! vector opt. 
    426                   zbtr = r1_e1e2f(ji,jj) * e3f_n(ji,jj,jk) * fsahm_spf(ji,jj) 
     618                  zbtr = r1_e1e2f(ji,jj) * e3f(ji,jj,jk) * rn_sponge_dyn * fspf(ji,jj) 
    427619                  rotdiff(ji,jj,jk) = ( -e1u(ji,jj+1) * ubdiff(ji,jj+1,jk)   & 
    428620                                    &   +e1u(ji,jj  ) * ubdiff(ji,jj  ,jk) ) * fmask(ji,jj,jk) * zbtr  
    … …  
    439631                     ze1v = hdivdiff(ji,jj,jk) 
    440632                     ! horizontal diffusive trends 
    441                      zua = - ( ze2u - rotdiff (ji,jj-1,jk) ) / ( e2u(ji,jj) * e3u_n(ji,jj,jk) )   & 
    442                            + ( hdivdiff(ji+1,jj,jk) - ze1v ) * r1_e1u(ji,jj) 
     633                     zua = - ( ze2u - rotdiff (ji,jj-1,jk) ) / ( e2u(ji,jj) * e3u(ji,jj,jk,Kmm_a) )   & 
     634                         & + ( hdivdiff(ji+1,jj,jk) - ze1v ) * r1_e1u(ji,jj) &  
     635                         & - ztrelax  * fspu(ji,jj) * ubdiff(ji,jj,jk) 
    443636 
    444637                     ! add it to the general momentum trends 
    445                      ua(ji,jj,jk) = ua(ji,jj,jk) + zua 
    446  
     638                     uu(ji,jj,jk,Krhs_a) = uu(ji,jj,jk,Krhs_a) + zua                                  
    447639                  END DO 
    448640               ENDIF 
    … …  
    465657 
    466658                     ! horizontal diffusive trends 
    467                      zva = + ( ze2u - rotdiff (ji-1,jj,jk) ) / ( e1v(ji,jj) * e3v_n(ji,jj,jk) )   & 
     659                     zva = + ( ze2u - rotdiff (ji-1,jj,jk) ) / ( e1v(ji,jj) * e3v(ji,jj,jk,Kmm_a) )   & 
    468660                           + ( hdivdiff(ji,jj+1,jk) - ze1v ) * r1_e2v(ji,jj) 
    469661 
    470662                     ! add it to the general momentum trends 
    471                      va(ji,jj,jk) = va(ji,jj,jk) + zva 
     663                     vv(ji,jj,jk,Krhs_a) = vv(ji,jj,jk,Krhs_a) + zva 
    472664                  END DO 
    473665               ENDIF 
    … …  
    492684      ! 
    493685      INTEGER  ::   ji, jj, jk, imax 
    494       REAL(wp) ::   ze2u, ze1v, zua, zva, zbtr, h_diff 
     686      REAL(wp) ::   ze2u, ze1v, zua, zva, zbtr, zhtot, ztrelax 
    495687      REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: vbdiff 
    496688      REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: rotdiff, hdivdiff 
    … …  
    503695       
    504696      IF( before ) THEN  
    505          DO jk=1,jpkm1 
     697         DO jk=k1,k2 
    506698            DO jj=j1,j2 
    507699               DO ji=i1,i2 
    508                   tabres(ji,jj,jk,m1) = vb(ji,jj,jk) 
     700                  tabres(ji,jj,jk,m1) = vv(ji,jj,jk,Kbb_a) 
    509701# if defined key_vertical 
    510                   tabres(ji,jj,jk,m2) = vmask(ji,jj,jk) * e3v_n(ji,jj,jk) 
     702                  tabres(ji,jj,jk,m2) = vmask(ji,jj,jk) * e3v(ji,jj,jk,Kbb_a) 
    511703# endif 
    512704               END DO 
    513705            END DO 
    514706         END DO 
     707 
     708# if defined key_vertical 
     709         ! Extrapolate thicknesses in partial bottom cells: 
     710         ! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on 
     711         IF (ln_zps) THEN 
     712            DO jj=j1,j2 
     713               DO ji=i1,i2 
     714                  jk = mbkv(ji,jj) 
     715                  tabres(ji,jj,jk,m2) = 0._wp 
     716               END DO 
     717            END DO            
     718         END IF 
     719        ! Save ssh at last level: 
     720        tabres(i1:i2,j1:j2,k2,m2) = 0._wp 
     721        IF (.NOT.ln_linssh) THEN 
     722           ! This vertical sum below should be replaced by the sea-level at V-points (optimization): 
     723           DO jk=1,jpk 
     724              tabres(i1:i2,j1:j2,k2,m2) = tabres(i1:i2,j1:j2,k2,m2) + e3v(i1:i2,j1:j2,jk,Kbb_a) * vmask(i1:i2,j1:j2,jk) 
     725           END DO 
     726           tabres(i1:i2,j1:j2,k2,m2) = tabres(i1:i2,j1:j2,k2,m2) - hv_0(i1:i2,j1:j2) 
     727        END IF  
     728# endif 
     729 
    515730      ELSE 
    516731 
    517732# if defined key_vertical 
    518          tabres_child(:,:,:) = 0._wp 
     733         IF (ln_linssh) tabres(i1:i2,j1:j2,k2,m2) = 0._wp 
    519734         DO jj=j1,j2 
    520735            DO ji=i1,i2 
    521                N_in = 0 
    522                DO jk=k1,k2 
    523                   IF (tabres(ji,jj,jk,m2) == 0) EXIT 
    524                   N_in = N_in + 1 
     736               tabres_child(ji,jj,:) = 0._wp 
     737               N_in = mbkv_parent(ji,jj) 
     738               zhtot = 0._wp 
     739               DO jk=1,N_in 
     740                  IF (jk==N_in) THEN 
     741                     h_in(jk) = hv0_parent(ji,jj) + tabres(ji,jj,k2,m2) - zhtot 
     742                  ELSE 
     743                     h_in(jk) = tabres(ji,jj,jk,m2) 
     744                  ENDIF 
     745                  zhtot = zhtot + h_in(jk) 
    525746                  tabin(jk) = tabres(ji,jj,jk,m1) 
    526                   h_in(N_in) = tabres(ji,jj,jk,m2) 
    527               ENDDO 
     747               ENDDO 
     748               !           
     749               N_out = 0 
     750               DO jk=1,jpk 
     751                  IF (vmask(ji,jj,jk) == 0) EXIT 
     752                  N_out = N_out + 1 
     753                  h_out(N_out) = e3v(ji,jj,jk,Kbb_a) 
     754               ENDDO 
     755 
     756               ! Account for small differences in free-surface 
     757               IF ( sum(h_out(1:N_out)) > sum(h_in(1:N_in) )) THEN 
     758                  h_out(1) = h_out(1) - ( sum(h_out(1:N_out))-sum(h_in(1:N_in)) ) 
     759               ELSE 
     760                  h_in(1)   = h_in(1) - (  sum(h_in(1:N_in))-sum(h_out(1:N_out)) ) 
     761               ENDIF 
    528762          
    529               IF (N_in == 0) THEN 
    530                  tabres_child(ji,jj,:) = 0. 
    531                  CYCLE 
    532               ENDIF 
    533           
    534               N_out = 0 
    535               DO jk=1,jpk 
    536                  if (vmask(ji,jj,jk) == 0) EXIT 
    537                  N_out = N_out + 1 
    538                  h_out(N_out) = e3v_n(ji,jj,jk) 
    539               ENDDO 
    540           
    541               IF (N_in * N_out > 0) THEN 
    542                  h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in)) 
    543                  if (h_diff < -1.e4) then 
    544                     print *,'CHECK YOUR BATHY ...', h_diff, sum(h_out(1:N_out)), sum(h_in(1:N_in)) 
    545                  endif 
    546               ENDIF 
    547               call reconstructandremap(tabin(1:N_in),h_in(1:N_in),tabres_child(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out) 
     763               IF (N_in * N_out > 0) THEN 
     764                  CALL reconstructandremap(tabin(1:N_in),h_in(1:N_in),tabres_child(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out,1) 
     765               ENDIF 
    548766            ENDDO 
    549767         ENDDO 
    550768 
    551          vbdiff(i1:i2,j1:j2,:) = (vb(i1:i2,j1:j2,:) - tabres_child(i1:i2,j1:j2,:))*vmask(i1:i2,j1:j2,:)   
     769         vbdiff(i1:i2,j1:j2,:) = (vv(i1:i2,j1:j2,:,Kbb_a) - tabres_child(i1:i2,j1:j2,:))*vmask(i1:i2,j1:j2,:)   
    552770# else 
    553          vbdiff(i1:i2,j1:j2,:) = (vb(i1:i2,j1:j2,:) - tabres(i1:i2,j1:j2,:,1))*vmask(i1:i2,j1:j2,:) 
     771         vbdiff(i1:i2,j1:j2,:) = (vv(i1:i2,j1:j2,:,Kbb_a) - tabres(i1:i2,j1:j2,:,1))*vmask(i1:i2,j1:j2,:) 
    554772# endif 
     773         !* set relaxation time scale 
     774         IF( neuler == 0 .AND. lk_agrif_fstep ) THEN   ;   ztrelax =   rn_trelax_dyn  / (        rdt ) 
     775         ELSE                                          ;   ztrelax =   rn_trelax_dyn  / (2._wp * rdt ) 
     776         ENDIF 
    555777         ! 
    556778         DO jk = 1, jpkm1                                 ! Horizontal slab 
    … …  
    562784            DO jj = j1+1,j2 
    563785               DO ji = i1,i2   ! vector opt. 
    564                   zbtr = r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) * fsahm_spt(ji,jj) 
    565                   hdivdiff(ji,jj,jk) = ( e1v(ji,jj  ) * e3v_n(ji,jj  ,jk) * vbdiff(ji,jj  ,jk)  & 
    566                                      &  -e1v(ji,jj-1) * e3v_n(ji,jj-1,jk) * vbdiff(ji,jj-1,jk)  ) * zbtr 
     786                  zbtr = r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kbb_a) * rn_sponge_dyn * fspt(ji,jj) 
     787                  hdivdiff(ji,jj,jk) = ( e1v(ji,jj  ) * e3v(ji,jj  ,jk,Kbb_a) * vbdiff(ji,jj  ,jk)  & 
     788                                     &  -e1v(ji,jj-1) * e3v(ji,jj-1,jk,Kbb_a) * vbdiff(ji,jj-1,jk)  ) * zbtr 
    567789               END DO 
    568790            END DO 
    569791            DO jj = j1,j2 
    570792               DO ji = i1,i2-1   ! vector opt. 
    571                   zbtr = r1_e1e2f(ji,jj) * e3f_n(ji,jj,jk) * fsahm_spf(ji,jj) 
     793                  zbtr = r1_e1e2f(ji,jj) * e3f(ji,jj,jk) * rn_sponge_dyn * fspf(ji,jj) 
    572794                  rotdiff(ji,jj,jk) = ( e2v(ji+1,jj) * vbdiff(ji+1,jj,jk) &  
    573795                                    &  -e2v(ji  ,jj) * vbdiff(ji  ,jj,jk)  ) * fmask(ji,jj,jk) * zbtr 
    … …  
    586808               IF( .NOT. tabspongedone_u(ji,jj) ) THEN 
    587809                  DO jk = 1, jpkm1 
    588                      ua(ji,jj,jk) = ua(ji,jj,jk)                                                               & 
    589                         & - ( rotdiff (ji  ,jj,jk) - rotdiff (ji,jj-1,jk)) / ( e2u(ji,jj) * e3u_n(ji,jj,jk) )  & 
     810                     uu(ji,jj,jk,Krhs_a) = uu(ji,jj,jk,Krhs_a)                                                               & 
     811                        & - ( rotdiff (ji  ,jj,jk) - rotdiff (ji,jj-1,jk)) / ( e2u(ji,jj) * e3u(ji,jj,jk,Kmm_a) )  & 
    590812                        & + ( hdivdiff(ji+1,jj,jk) - hdivdiff(ji,jj  ,jk)) * r1_e1u(ji,jj) 
    591813                  END DO 
    … …  
    600822               IF( .NOT. tabspongedone_v(ji,jj) ) THEN 
    601823                  DO jk = 1, jpkm1 
    602                      va(ji,jj,jk) = va(ji,jj,jk)                                                                  & 
    603                         &  + ( rotdiff (ji,jj  ,jk) - rotdiff (ji-1,jj,jk) ) / ( e1v(ji,jj) * e3v_n(ji,jj,jk) )   & 
    604                         &  + ( hdivdiff(ji,jj+1,jk) - hdivdiff(ji  ,jj,jk) ) * r1_e2v(ji,jj) 
     824                     vv(ji,jj,jk,Krhs_a) = vv(ji,jj,jk,Krhs_a)                                                                  & 
     825                        &  + ( rotdiff (ji,jj  ,jk) - rotdiff (ji-1,jj,jk) ) / ( e1v(ji,jj) * e3v(ji,jj,jk,Kmm_a) )   & 
     826                        &  + ( hdivdiff(ji,jj+1,jk) - hdivdiff(ji  ,jj,jk) ) * r1_e2v(ji,jj)                      & 
     827                        &  - ztrelax * fspv(ji,jj) * vbdiff(ji,jj,jk) 
    605828                  END DO 
    606829               ENDIF 

  • NEMO/trunk/src/NST/agrif_oce_update.F90

    r10068 r12377  
    1 #define TWO_WAY        /* TWO WAY NESTING */ 
    2 #undef DECAL_FEEDBACK  /* SEPARATION of INTERFACES*/ 
    3 #undef VOL_REFLUX      /* VOLUME REFLUXING*/ 
     1#undef DECAL_FEEDBACK     /* SEPARATION of INTERFACES */ 
     2#undef DECAL_FEEDBACK_2D  /* SEPARATION of INTERFACES (Barotropic mode) */ 
     3#undef VOL_REFLUX         /* VOLUME REFLUXING*/ 
    44  
    55MODULE agrif_oce_update 
    … …  
    2525   USE lib_mpp        ! MPP library 
    2626   USE domvvl         ! Need interpolation routines  
     27   USE vremap         ! Vertical remapping 
    2728 
    2829   IMPLICIT NONE 
    … …  
    4647      IF (Agrif_Root()) RETURN 
    4748      ! 
    48 #if defined TWO_WAY   
    4949      IF (lwp.AND.lk_agrif_debug) Write(*,*) 'Update tracers  from grid Number',Agrif_Fixed() 
    5050 
     51#if defined key_vertical 
     52! Effect of this has to be carrefully checked  
     53! depending on what the nesting tools ensure for 
     54! volume conservation: 
     55      Agrif_UseSpecialValueInUpdate = .FALSE. 
     56#else 
    5157      Agrif_UseSpecialValueInUpdate = .TRUE. 
     58#endif 
    5259      Agrif_SpecialValueFineGrid    = 0._wp 
    5360      !  
    … …  
    6471      Agrif_UseSpecialValueInUpdate = .FALSE. 
    6572      ! 
    66 #endif 
    6773      ! 
    6874   END SUBROUTINE Agrif_Update_Tra 
    … …  
    7581      IF (Agrif_Root()) RETURN 
    7682      ! 
    77 #if defined TWO_WAY 
    7883      IF (lwp.AND.lk_agrif_debug) Write(*,*) 'Update momentum from grid Number',Agrif_Fixed() 
    7984 
    … …  
    95100# endif 
    96101 
    97 # if ! defined DECAL_FEEDBACK 
     102# if ! defined DECAL_FEEDBACK_2D 
    98103      CALL Agrif_Update_Variable(e1u_id,procname = updateU2d) 
    99104      CALL Agrif_Update_Variable(e2v_id,procname = updateV2d)   
    … …  
    103108# endif 
    104109      ! 
    105 # if ! defined DECAL_FEEDBACK 
     110# if ! defined DECAL_FEEDBACK_2D 
    106111      ! Account for updated thicknesses at boundary edges 
    107112      IF (.NOT.ln_linssh) THEN 
    … …  
    113118      IF ( ln_dynspg_ts .AND. ln_bt_fw ) THEN 
    114119         ! Update time integrated transports 
    115 #  if ! defined DECAL_FEEDBACK 
     120#  if ! defined DECAL_FEEDBACK_2D 
    116121         CALL Agrif_Update_Variable(ub2b_update_id,procname = updateub2b) 
    117122         CALL Agrif_Update_Variable(vb2b_update_id,procname = updatevb2b) 
    … …  
    121126#  endif 
    122127      END IF 
    123 #endif 
    124128      ! 
    125129   END SUBROUTINE Agrif_Update_Dyn 
    … …  
    131135      !  
    132136      IF (Agrif_Root()) RETURN 
    133       ! 
    134 #if defined TWO_WAY 
    135137      ! 
    136138      Agrif_UseSpecialValueInUpdate = .TRUE. 
    137139      Agrif_SpecialValueFineGrid = 0. 
    138 # if ! defined DECAL_FEEDBACK 
     140# if ! defined DECAL_FEEDBACK_2D 
    139141      CALL Agrif_Update_Variable(sshn_id,procname = updateSSH) 
    140142# else 
    … …  
    147149      IF ( ln_dynspg_ts.AND.ln_bt_fw ) THEN 
    148150         ! Refluxing on ssh: 
    149 #  if defined DECAL_FEEDBACK 
     151#  if defined DECAL_FEEDBACK_2D 
    150152         CALL Agrif_Update_Variable(ub2b_update_id,locupdate1=(/0, 0/),locupdate2=(/1, 1/),procname = reflux_sshu) 
    151153         CALL Agrif_Update_Variable(vb2b_update_id,locupdate1=(/1, 1/),locupdate2=(/0, 0/),procname = reflux_sshv) 
    … …  
    157159#  endif 
    158160      ! 
    159 #endif 
    160       ! 
    161161   END SUBROUTINE Agrif_Update_ssh 
    162162 
    … …  
    170170      IF (Agrif_Root()) RETURN 
    171171      !        
    172 #  if defined TWO_WAY 
    173  
    174172      Agrif_UseSpecialValueInUpdate = .TRUE. 
    175173      Agrif_SpecialValueFineGrid = 0. 
    … …  
    180178 
    181179      Agrif_UseSpecialValueInUpdate = .FALSE. 
    182  
    183 #  endif 
    184180       
    185181   END SUBROUTINE Agrif_Update_Tke 
    … …  
    192188      ! 
    193189      IF (Agrif_Root()) RETURN 
    194       ! 
    195 #if defined TWO_WAY   
    196190      ! 
    197191      IF (lwp.AND.lk_agrif_debug) Write(*,*) 'Update e3 from grid Number',Agrif_Fixed(), 'Step', Agrif_Nb_Step() 
    … …  
    210204      CALL Agrif_ParentGrid_To_ChildGrid() 
    211205      ! 
    212 #endif 
    213       ! 
    214206   END SUBROUTINE Agrif_Update_vvl 
    215207 
    … …  
    230222      ! ----------------------- 
    231223      ! 
    232       e3u_a(:,:,:) = e3u_n(:,:,:) 
    233       e3v_a(:,:,:) = e3v_n(:,:,:) 
    234 !      ua(:,:,:) = e3u_b(:,:,:) 
    235 !      va(:,:,:) = e3v_b(:,:,:) 
    236       hu_a(:,:) = hu_n(:,:) 
    237       hv_a(:,:) = hv_n(:,:) 
     224      e3u(:,:,:,Krhs_a) = e3u(:,:,:,Kmm_a) 
     225      e3v(:,:,:,Krhs_a) = e3v(:,:,:,Kmm_a) 
     226!      uu(:,:,:,Krhs_a) = e3u(:,:,:,Kbb_a) 
     227!      vv(:,:,:,Krhs_a) = e3v(:,:,:,Kbb_a) 
     228      hu(:,:,Krhs_a) = hu(:,:,Kmm_a) 
     229      hv(:,:,Krhs_a) = hv(:,:,Kmm_a) 
    238230 
    239231      ! 1) NOW fields 
    … …  
    242234         ! Vertical scale factor interpolations 
    243235         ! ------------------------------------ 
    244       CALL dom_vvl_interpol( e3t_n(:,:,:), e3u_n(:,:,:) ,  'U' ) 
    245       CALL dom_vvl_interpol( e3t_n(:,:,:), e3v_n(:,:,:) ,  'V' ) 
    246       CALL dom_vvl_interpol( e3u_n(:,:,:), e3f_n(:,:,:) ,  'F' ) 
    247  
    248       CALL dom_vvl_interpol( e3u_n(:,:,:), e3uw_n(:,:,:), 'UW' ) 
    249       CALL dom_vvl_interpol( e3v_n(:,:,:), e3vw_n(:,:,:), 'VW' ) 
     236      CALL dom_vvl_interpol( e3t(:,:,:,Kmm_a), e3u(:,:,:,Kmm_a) ,  'U' ) 
     237      CALL dom_vvl_interpol( e3t(:,:,:,Kmm_a), e3v(:,:,:,Kmm_a) ,  'V' ) 
     238      CALL dom_vvl_interpol( e3u(:,:,:,Kmm_a), e3f(:,:,:) ,  'F' ) 
     239 
     240      CALL dom_vvl_interpol( e3u(:,:,:,Kmm_a), e3uw(:,:,:,Kmm_a), 'UW' ) 
     241      CALL dom_vvl_interpol( e3v(:,:,:,Kmm_a), e3vw(:,:,:,Kmm_a), 'VW' ) 
    250242 
    251243         ! Update total depths: 
    252244         ! -------------------- 
    253       hu_n(:,:) = 0._wp                        ! Ocean depth at U-points 
    254       hv_n(:,:) = 0._wp                        ! Ocean depth at V-points 
     245      hu(:,:,Kmm_a) = 0._wp                        ! Ocean depth at U-points 
     246      hv(:,:,Kmm_a) = 0._wp                        ! Ocean depth at V-points 
    255247      DO jk = 1, jpkm1 
    256          hu_n(:,:) = hu_n(:,:) + e3u_n(:,:,jk) * umask(:,:,jk) 
    257          hv_n(:,:) = hv_n(:,:) + e3v_n(:,:,jk) * vmask(:,:,jk) 
     248         hu(:,:,Kmm_a) = hu(:,:,Kmm_a) + e3u(:,:,jk,Kmm_a) * umask(:,:,jk) 
     249         hv(:,:,Kmm_a) = hv(:,:,Kmm_a) + e3v(:,:,jk,Kmm_a) * vmask(:,:,jk) 
    258250      END DO 
    259251      !                                        ! Inverse of the local depth 
    260       r1_hu_n(:,:) = ssumask(:,:) / ( hu_n(:,:) + 1._wp - ssumask(:,:) ) 
    261       r1_hv_n(:,:) = ssvmask(:,:) / ( hv_n(:,:) + 1._wp - ssvmask(:,:) ) 
     252      r1_hu(:,:,Kmm_a) = ssumask(:,:) / ( hu(:,:,Kmm_a) + 1._wp - ssumask(:,:) ) 
     253      r1_hv(:,:,Kmm_a) = ssvmask(:,:) / ( hv(:,:,Kmm_a) + 1._wp - ssvmask(:,:) ) 
    262254 
    263255 
    … …  
    268260         ! Vertical scale factor interpolations 
    269261         ! ------------------------------------ 
    270          CALL dom_vvl_interpol( e3t_b(:,:,:), e3u_b(:,:,:),  'U'  ) 
    271          CALL dom_vvl_interpol( e3t_b(:,:,:), e3v_b(:,:,:),  'V'  ) 
    272  
    273          CALL dom_vvl_interpol( e3u_b(:,:,:), e3uw_b(:,:,:), 'UW' ) 
    274          CALL dom_vvl_interpol( e3v_b(:,:,:), e3vw_b(:,:,:), 'VW' ) 
     262         CALL dom_vvl_interpol( e3t(:,:,:,Kbb_a), e3u(:,:,:,Kbb_a),  'U'  ) 
     263         CALL dom_vvl_interpol( e3t(:,:,:,Kbb_a), e3v(:,:,:,Kbb_a),  'V'  ) 
     264 
     265         CALL dom_vvl_interpol( e3u(:,:,:,Kbb_a), e3uw(:,:,:,Kbb_a), 'UW' ) 
     266         CALL dom_vvl_interpol( e3v(:,:,:,Kbb_a), e3vw(:,:,:,Kbb_a), 'VW' ) 
    275267 
    276268         ! Update total depths: 
    277269         ! -------------------- 
    278          hu_b(:,:) = 0._wp                     ! Ocean depth at U-points 
    279          hv_b(:,:) = 0._wp                     ! Ocean depth at V-points 
     270         hu(:,:,Kbb_a) = 0._wp                     ! Ocean depth at U-points 
     271         hv(:,:,Kbb_a) = 0._wp                     ! Ocean depth at V-points 
    280272         DO jk = 1, jpkm1 
    281             hu_b(:,:) = hu_b(:,:) + e3u_b(:,:,jk) * umask(:,:,jk) 
    282             hv_b(:,:) = hv_b(:,:) + e3v_b(:,:,jk) * vmask(:,:,jk) 
     273            hu(:,:,Kbb_a) = hu(:,:,Kbb_a) + e3u(:,:,jk,Kbb_a) * umask(:,:,jk) 
     274            hv(:,:,Kbb_a) = hv(:,:,Kbb_a) + e3v(:,:,jk,Kbb_a) * vmask(:,:,jk) 
    283275         END DO 
    284276         !                                     ! Inverse of the local depth 
    285          r1_hu_b(:,:) = ssumask(:,:) / ( hu_b(:,:) + 1._wp - ssumask(:,:) ) 
    286          r1_hv_b(:,:) = ssvmask(:,:) / ( hv_b(:,:) + 1._wp - ssvmask(:,:) ) 
     277         r1_hu(:,:,Kbb_a) = ssumask(:,:) / ( hu(:,:,Kbb_a) + 1._wp - ssumask(:,:) ) 
     278         r1_hv(:,:,Kbb_a) = ssvmask(:,:) / ( hv(:,:,Kbb_a) + 1._wp - ssvmask(:,:) ) 
    287279      ENDIF 
    288280      ! 
    … …  
    300292      !! 
    301293      INTEGER :: ji,jj,jk,jn 
    302       REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk,n1:n2) :: tabres_child 
     294      INTEGER  :: N_in, N_out 
     295      REAL(wp) :: ztb, ztnu, ztno 
    303296      REAL(wp) :: h_in(k1:k2) 
    304297      REAL(wp) :: h_out(1:jpk) 
    305       INTEGER  :: N_in, N_out 
    306       REAL(wp) :: zrho_xy, h_diff 
    307       REAL(wp) :: tabin(k1:k2,n1:n2) 
     298      REAL(wp) :: tabin(k1:k2,1:jpts) 
     299      REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk,1:jpts) :: tabres_child 
    308300      !!--------------------------------------------- 
    309301      ! 
    310302      IF (before) THEN 
    311          AGRIF_SpecialValue = -999._wp 
    312          zrho_xy = Agrif_rhox() * Agrif_rhoy()  
     303!jc_alt 
     304!         AGRIF_SpecialValue = -999._wp 
    313305         DO jn = n1,n2-1 
    314306            DO jk=k1,k2 
    315307               DO jj=j1,j2 
    316308                  DO ji=i1,i2 
    317                      tabres(ji,jj,jk,jn) = (tsn(ji,jj,jk,jn) * e3t_n(ji,jj,jk) ) & 
    318                                            * tmask(ji,jj,jk) + (tmask(ji,jj,jk)-1)*999._wp 
     309!jc_alt 
     310!                     tabres(ji,jj,jk,jn) = (ts(ji,jj,jk,jn,Kmm_a) * e3t(ji,jj,jk,Kmm_a) ) & 
     311!                                         &  * tmask(ji,jj,jk) + (tmask(ji,jj,jk)-1._wp) * 999._wp 
     312                     tabres(ji,jj,jk,jn) = ts(ji,jj,jk,jn,Kmm_a) * e3t(ji,jj,jk,Kmm_a) 
    319313                  END DO 
    320314               END DO 
    … …  
    324318            DO jj=j1,j2 
    325319               DO ji=i1,i2 
    326                   tabres(ji,jj,jk,n2) = tmask(ji,jj,jk) * e3t_n(ji,jj,jk) & 
    327                                            + (tmask(ji,jj,jk)-1)*999._wp 
     320!jc_alt 
     321!                  tabres(ji,jj,jk,n2) =      tmask(ji,jj,jk) * e3t(ji,jj,jk,Kmm_a) & 
     322!                                      &   + (tmask(ji,jj,jk) - 1._wp) * 999._wp 
     323                  tabres(ji,jj,jk,n2) = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kmm_a) 
    328324               END DO 
    329325            END DO 
    330326         END DO 
    331327      ELSE 
    332          tabres_child(:,:,:,:) = 0. 
     328         tabres_child(:,:,:,:) = 0._wp 
    333329         AGRIF_SpecialValue = 0._wp 
    334330         DO jj=j1,j2 
    … …  
    336332               N_in = 0 
    337333               DO jk=k1,k2 !k2 = jpk of child grid 
    338                   IF (tabres(ji,jj,jk,n2) == 0  ) EXIT 
     334! jc_alt 
     335!                  IF (tabres(ji,jj,jk,n2) < -900._wp  ) EXIT 
     336                  IF (tabres(ji,jj,jk,n2) == 0._wp  ) EXIT 
    339337                  N_in = N_in + 1 
    340338                  tabin(jk,:) = tabres(ji,jj,jk,n1:n2-1)/tabres(ji,jj,jk,n2) 
    … …  
    343341               N_out = 0 
    344342               DO jk=1,jpk ! jpk of parent grid 
    345                   IF (tmask(ji,jj,jk) < -900) EXIT ! TODO: Will not work with ISF 
     343                  IF (tmask(ji,jj,jk) == 0 ) EXIT ! TODO: Will not work with ISF 
    346344                  N_out = N_out + 1 
    347                   h_out(N_out) = e3t_n(ji,jj,jk)  
     345                  h_out(N_out) = e3t(ji,jj,jk,Kmm_a)  
    348346               ENDDO 
    349                IF (N_in > 0) THEN !Remove this? 
    350                   h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in)) 
    351                   IF (h_diff < -1.e-4) THEN 
    352                      print *,'CHECK YOUR bathy T points ...',ji,jj,h_diff,sum(h_in(1:N_in)),sum(h_out(1:N_out)) 
    353                      print *,h_in(1:N_in) 
    354                      print *,h_out(1:N_out) 
    355                      STOP 
    356                   ENDIF 
    357                   DO jn=n1,n2-1 
    358                      CALL reconstructandremap(tabin(1:N_in,jn),h_in(1:N_in),tabres_child(ji,jj,1:N_out,jn),h_out(1:N_out),N_in,N_out) 
    359                   ENDDO 
     347               IF (N_in*N_out > 0) THEN !Remove this? 
     348                  CALL reconstructandremap(tabin(1:N_in,1:jpts),h_in(1:N_in),tabres_child(ji,jj,1:N_out,1:jpts),h_out(1:N_out),N_in,N_out,jpts) 
    360349               ENDIF 
    361350            ENDDO 
    … …  
    364353         IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN 
    365354            ! Add asselin part 
    366             DO jn = n1,n2-1 
    367                DO jk=1,jpk 
    368                   DO jj=j1,j2 
    369                      DO ji=i1,i2 
    370                         IF( tabres_child(ji,jj,jk,jn) .NE. 0. ) THEN 
    371                            tsb(ji,jj,jk,jn) = tsb(ji,jj,jk,jn) &  
    372                                  & + atfp * ( tabres_child(ji,jj,jk,jn) & 
    373                                  &          - tsn(ji,jj,jk,jn) ) * tmask(ji,jj,jk) 
     355            DO jn = 1,jpts 
     356               DO jk = 1, jpkm1 
     357                  DO jj = j1, j2 
     358                     DO ji = i1, i2 
     359                        IF( tabres_child(ji,jj,jk,jn) /= 0._wp ) THEN 
     360                           ztb  = ts(ji,jj,jk,jn,Kbb_a) * e3t(ji,jj,jk,Kbb_a) ! fse3t_b prior update should be used 
     361                           ztnu = tabres_child(ji,jj,jk,jn) * e3t(ji,jj,jk,Kmm_a) 
     362                           ztno = ts(ji,jj,jk,jn,Kmm_a) * e3t(ji,jj,jk,Krhs_a) 
     363                           ts(ji,jj,jk,jn,Kbb_a) = ( ztb + atfp * ( ztnu - ztno) )  &  
     364                                     &        * tmask(ji,jj,jk) / e3t(ji,jj,jk,Kbb_a) 
    374365                        ENDIF 
    375                      ENDDO 
    376                   ENDDO 
    377                ENDDO 
    378             ENDDO 
    379          ENDIF 
    380          DO jn = n1,n2-1 
    381             DO jk=1,jpk 
    382                DO jj=j1,j2 
    383                   DO ji=i1,i2 
    384                      IF( tabres_child(ji,jj,jk,jn) .NE. 0. ) THEN  
    385                         tsn(ji,jj,jk,jn) = tabres_child(ji,jj,jk,jn) * tmask(ji,jj,jk) 
     366                     END DO 
     367                  END DO 
     368               END DO 
     369            END DO 
     370         ENDIF 
     371         DO jn = 1,jpts 
     372            DO jk = 1, jpkm1 
     373               DO jj = j1, j2 
     374                  DO ji = i1, i2 
     375                     IF( tabres_child(ji,jj,jk,jn) /= 0._wp ) THEN  
     376                        ts(ji,jj,jk,jn,Kmm_a) = tabres_child(ji,jj,jk,jn) 
    386377                     END IF 
    387378                  END DO 
    … …  
    389380            END DO 
    390381         END DO 
     382         ! 
     383         IF  ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN 
     384            ts(i1:i2,j1:j2,1:jpkm1,1:jpts,Kbb_a)  = ts(i1:i2,j1:j2,1:jpkm1,1:jpts,Kmm_a) 
     385         ENDIF 
    391386      ENDIF 
    392387      !  
    … …  
    413408                  DO ji=i1,i2 
    414409!> jc tmp 
    415                      tabres(ji,jj,jk,jn) = tsn(ji,jj,jk,jn)  * e3t_n(ji,jj,jk) / e3t_0(ji,jj,jk) 
    416 !                     tabres(ji,jj,jk,jn) = tsn(ji,jj,jk,jn)  * e3t_n(ji,jj,jk) 
     410                     tabres(ji,jj,jk,jn) = ts(ji,jj,jk,jn,Kmm_a)  * e3t(ji,jj,jk,Kmm_a) / e3t_0(ji,jj,jk) 
     411!                     tabres(ji,jj,jk,jn) = ts(ji,jj,jk,jn,Kmm_a)  * e3t(ji,jj,jk,Kmm_a) 
    417412!< jc tmp 
    418413                  END DO 
    … …  
    434429                     DO ji = i1, i2 
    435430                        IF( tabres(ji,jj,jk,jn) /= 0._wp ) THEN 
    436                            ztb  = tsb(ji,jj,jk,jn) * e3t_b(ji,jj,jk) ! fse3t_b prior update should be used 
     431                           ztb  = ts(ji,jj,jk,jn,Kbb_a) * e3t(ji,jj,jk,Kbb_a) ! fse3t_b prior update should be used 
    437432                           ztnu = tabres(ji,jj,jk,jn) 
    438                            ztno = tsn(ji,jj,jk,jn) * e3t_a(ji,jj,jk) 
    439                            tsb(ji,jj,jk,jn) = ( ztb + atfp * ( ztnu - ztno) )  &  
    440                                      &        * tmask(ji,jj,jk) / e3t_b(ji,jj,jk) 
     433                           ztno = ts(ji,jj,jk,jn,Kmm_a) * e3t(ji,jj,jk,Krhs_a) 
     434                           ts(ji,jj,jk,jn,Kbb_a) = ( ztb + atfp * ( ztnu - ztno) )  &  
     435                                     &        * tmask(ji,jj,jk) / e3t(ji,jj,jk,Kbb_a) 
    441436                        ENDIF 
    442437                     END DO 
    … …  
    450445                  DO ji=i1,i2 
    451446                     IF( tabres(ji,jj,jk,jn) /= 0._wp ) THEN  
    452                         tsn(ji,jj,jk,jn) = tabres(ji,jj,jk,jn) / e3t_n(ji,jj,jk) 
     447                        ts(ji,jj,jk,jn,Kmm_a) = tabres(ji,jj,jk,jn) / e3t(ji,jj,jk,Kmm_a) 
    453448                     END IF 
    454449                  END DO 
    … …  
    458453         ! 
    459454         IF  ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN 
    460             tsb(i1:i2,j1:j2,k1:k2,1:jpts)  = tsn(i1:i2,j1:j2,k1:k2,1:jpts) 
     455            ts(i1:i2,j1:j2,k1:k2,1:jpts,Kbb_a)  = ts(i1:i2,j1:j2,k1:k2,1:jpts,Kmm_a) 
    461456         ENDIF 
    462457         ! 
    … …  
    478473      ! 
    479474      INTEGER ::   ji, jj, jk 
    480       REAL(wp)::   zrhoy 
     475      REAL(wp)::   zrhoy, zub, zunu, zuno 
    481476! VERTICAL REFINEMENT BEGIN 
    482477      REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: tabres_child 
    … …  
    491486      IF( before ) THEN 
    492487         zrhoy = Agrif_Rhoy() 
    493          AGRIF_SpecialValue = -999._wp 
     488!jc_alt 
     489!         AGRIF_SpecialValue = -999._wp 
    494490         DO jk=k1,k2 
    495491            DO jj=j1,j2 
    496492               DO ji=i1,i2 
    497                   tabres(ji,jj,jk,1) = zrhoy * e2u(ji,jj) * e3u_n(ji,jj,jk) * umask(ji,jj,jk) * un(ji,jj,jk)  & 
    498                                        + (umask(ji,jj,jk)-1)*999._wp 
    499                   tabres(ji,jj,jk,2) = zrhoy * umask(ji,jj,jk) * e2u(ji,jj) * e3u_n(ji,jj,jk)  & 
    500                                        + (umask(ji,jj,jk)-1)*999._wp 
     493!jc_alt 
     494!                  tabres(ji,jj,jk,1) = zrhoy * e2u(ji,jj) * e3u(ji,jj,jk,Kmm_a) * umask(ji,jj,jk) * uu(ji,jj,jk,Kmm_a)  & 
     495!                                     &  + (umask(ji,jj,jk)-1._wp)*999._wp 
     496                  tabres(ji,jj,jk,1) = zrhoy * e2u(ji,jj) * e3u(ji,jj,jk,Kmm_a) * umask(ji,jj,jk) * uu(ji,jj,jk,Kmm_a)   
     497!jc_alt 
     498!                  tabres(ji,jj,jk,2) = zrhoy * umask(ji,jj,jk) * e2u(ji,jj) * e3u(ji,jj,jk,Kmm_a)  & 
     499!                                     &  + (umask(ji,jj,jk)-1._wp)*999._wp 
     500                  tabres(ji,jj,jk,2) = zrhoy * umask(ji,jj,jk) * e2u(ji,jj) * e3u(ji,jj,jk,Kmm_a) 
    501501               END DO 
    502502            END DO 
    … …  
    511511               tabin(:) = 0._wp 
    512512               DO jk=k1,k2 !k2=jpk of child grid 
    513                   IF( tabres(ji,jj,jk,2) < -900) EXIT 
     513!jc_alt 
     514!                  IF( tabres(ji,jj,jk,2) < -900._wp) EXIT 
     515                  IF( tabres(ji,jj,jk,2) == 0.) EXIT 
    514516                  N_in = N_in + 1 
    515517                  tabin(jk) = tabres(ji,jj,jk,1)/tabres(ji,jj,jk,2) 
    … …  
    520522                  IF (umask(ji,jj,jk) == 0) EXIT 
    521523                  N_out = N_out + 1 
    522                   h_out(N_out) = e3u_n(ji,jj,jk) 
     524                  h_out(N_out) = e3u(ji,jj,jk,Kmm_a) 
    523525               ENDDO 
    524526               IF (N_in * N_out > 0) THEN 
    525527                  h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in)) 
     528                  excess = 0._wp 
    526529                  IF (h_diff < -1.e-4) THEN 
    527530!Even if bathy at T points match it's possible for the U points to be deeper in the child grid.  
    528531!In this case we need to move transport from the child grid cells below bed of parent grid into the bottom cell. 
    529                      excess = 0._wp 
    530532                     DO jk=N_in,1,-1 
    531533                        thick = MIN(-1*h_diff, h_in(jk)) 
    … …  
    540542                     ENDDO 
    541543                  ENDIF 
    542                   CALL reconstructandremap(tabin(1:N_in),h_in(1:N_in),tabres_child(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out) 
     544                  CALL reconstructandremap(tabin(1:N_in),h_in(1:N_in),tabres_child(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out,1) 
    543545                  tabres_child(ji,jj,N_out) = tabres_child(ji,jj,N_out) + excess/(e2u(ji,jj)*h_out(N_out)) 
    544546               ENDIF 
    545547            ENDDO 
    546548         ENDDO 
    547  
     549         ! 
    548550         DO jk=1,jpk 
    549551            DO jj=j1,j2 
    550552               DO ji=i1,i2 
    551553                  IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part 
    552                      ub(ji,jj,jk) = ub(ji,jj,jk) &  
    553                            & + atfp * ( tabres_child(ji,jj,jk) - un(ji,jj,jk) ) * umask(ji,jj,jk) 
     554                     zub  = uu(ji,jj,jk,Kbb_a) * e3u(ji,jj,jk,Kbb_a)  ! fse3t_b prior update should be used 
     555                     zuno = uu(ji,jj,jk,Kmm_a) * e3u(ji,jj,jk,Krhs_a) 
     556                     zunu = tabres_child(ji,jj,jk) * e3u(ji,jj,jk,Kmm_a) 
     557                     uu(ji,jj,jk,Kbb_a) = ( zub + atfp * ( zunu - zuno) ) &       
     558                                    & * umask(ji,jj,jk) / e3u(ji,jj,jk,Kbb_a) 
    554559                  ENDIF 
    555560                  ! 
    556                   un(ji,jj,jk) = tabres_child(ji,jj,jk) * umask(ji,jj,jk) 
    557                END DO 
    558             END DO 
    559          END DO 
     561                  uu(ji,jj,jk,Kmm_a) = tabres_child(ji,jj,jk) * umask(ji,jj,jk) 
     562               END DO 
     563            END DO 
     564         END DO 
     565         ! 
     566         IF  ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN 
     567            uu(i1:i2,j1:j2,1:jpkm1,Kbb_a)  = uu(i1:i2,j1:j2,1:jpkm1,Kmm_a) 
     568         ENDIF 
     569         ! 
    560570      ENDIF 
    561571      !  
    … …  
    579589         zrhoy = Agrif_Rhoy() 
    580590         DO jk = k1, k2 
    581             tabres(i1:i2,j1:j2,jk,1) = zrhoy * e2u(i1:i2,j1:j2) * e3u_n(i1:i2,j1:j2,jk) * un(i1:i2,j1:j2,jk) 
     591            tabres(i1:i2,j1:j2,jk,1) = zrhoy * e2u(i1:i2,j1:j2) * e3u(i1:i2,j1:j2,jk,Kmm_a) * uu(i1:i2,j1:j2,jk,Kmm_a) 
    582592         END DO 
    583593      ELSE 
    … …  
    588598                  ! 
    589599                  IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part 
    590                      zub  = ub(ji,jj,jk) * e3u_b(ji,jj,jk)  ! fse3t_b prior update should be used 
    591                      zuno = un(ji,jj,jk) * e3u_a(ji,jj,jk) 
     600                     zub  = uu(ji,jj,jk,Kbb_a) * e3u(ji,jj,jk,Kbb_a)  ! fse3t_b prior update should be used 
     601                     zuno = uu(ji,jj,jk,Kmm_a) * e3u(ji,jj,jk,Krhs_a) 
    592602                     zunu = tabres(ji,jj,jk,1) 
    593                      ub(ji,jj,jk) = ( zub + atfp * ( zunu - zuno) ) &       
    594                                     & * umask(ji,jj,jk) / e3u_b(ji,jj,jk) 
     603                     uu(ji,jj,jk,Kbb_a) = ( zub + atfp * ( zunu - zuno) ) &       
     604                                    & * umask(ji,jj,jk) / e3u(ji,jj,jk,Kbb_a) 
    595605                  ENDIF 
    596606                  ! 
    597                   un(ji,jj,jk) = tabres(ji,jj,jk,1) * umask(ji,jj,jk) / e3u_n(ji,jj,jk) 
     607                  uu(ji,jj,jk,Kmm_a) = tabres(ji,jj,jk,1) * umask(ji,jj,jk) / e3u(ji,jj,jk,Kmm_a) 
    598608               END DO 
    599609            END DO 
    … …  
    601611         ! 
    602612         IF  ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN 
    603             ub(i1:i2,j1:j2,k1:k2)  = un(i1:i2,j1:j2,k1:k2) 
     613            uu(i1:i2,j1:j2,k1:k2,Kbb_a)  = uu(i1:i2,j1:j2,k1:k2,Kmm_a) 
    604614         ENDIF 
    605615         ! 
    … …  
    632642         IF (western_side) THEN 
    633643            DO jj=j1,j2 
    634                zcor = un_b(i1-1,jj) * hu_a(i1-1,jj) * r1_hu_n(i1-1,jj) - un_b(i1-1,jj) 
    635                un_b(i1-1,jj) = un_b(i1-1,jj) + zcor 
     644               zcor = uu_b(i1-1,jj,Kmm_a) * hu(i1-1,jj,Krhs_a) * r1_hu(i1-1,jj,Kmm_a) - uu_b(i1-1,jj,Kmm_a) 
     645               uu_b(i1-1,jj,Kmm_a) = uu_b(i1-1,jj,Kmm_a) + zcor 
    636646               DO jk=1,jpkm1 
    637                   un(i1-1,jj,jk) = un(i1-1,jj,jk) + zcor * umask(i1-1,jj,jk) 
     647                  uu(i1-1,jj,jk,Kmm_a) = uu(i1-1,jj,jk,Kmm_a) + zcor * umask(i1-1,jj,jk) 
    638648               END DO  
    639649            END DO 
    … …  
    642652         IF (eastern_side) THEN 
    643653            DO jj=j1,j2 
    644                zcor = un_b(i2+1,jj) * hu_a(i2+1,jj) * r1_hu_n(i2+1,jj) - un_b(i2+1,jj) 
    645                un_b(i2+1,jj) = un_b(i2+1,jj) + zcor 
     654               zcor = uu_b(i2+1,jj,Kmm_a) * hu(i2+1,jj,Krhs_a) * r1_hu(i2+1,jj,Kmm_a) - uu_b(i2+1,jj,Kmm_a) 
     655               uu_b(i2+1,jj,Kmm_a) = uu_b(i2+1,jj,Kmm_a) + zcor 
    646656               DO jk=1,jpkm1 
    647                   un(i2+1,jj,jk) = un(i2+1,jj,jk) + zcor * umask(i2+1,jj,jk) 
     657                  uu(i2+1,jj,jk,Kmm_a) = uu(i2+1,jj,jk,Kmm_a) + zcor * umask(i2+1,jj,jk) 
    648658               END DO  
    649659            END DO 
    … …  
    665675      ! 
    666676      INTEGER  ::   ji, jj, jk 
    667       REAL(wp) ::   zrhox 
     677      REAL(wp) ::   zrhox, zvb, zvnu, zvno 
    668678! VERTICAL REFINEMENT BEGIN 
    669679      REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: tabres_child 
    … …  
    678688      IF( before ) THEN 
    679689         zrhox = Agrif_Rhox() 
    680          AGRIF_SpecialValue = -999._wp 
     690!jc_alt 
     691!         AGRIF_SpecialValue = -999._wp 
    681692         DO jk=k1,k2 
    682693            DO jj=j1,j2 
    683694               DO ji=i1,i2 
    684                   tabres(ji,jj,jk,1) = zrhox * e1v(ji,jj) * e3v_n(ji,jj,jk) * vmask(ji,jj,jk) * vn(ji,jj,jk) & 
    685                                        + (vmask(ji,jj,jk)-1)*999._wp 
    686                   tabres(ji,jj,jk,2) = vmask(ji,jj,jk) * zrhox * e1v(ji,jj) * e3v_n(ji,jj,jk) & 
    687                                        + (vmask(ji,jj,jk)-1)*999._wp 
     695!jc_alt 
     696!                  tabres(ji,jj,jk,1) = zrhox * e1v(ji,jj) * e3v(ji,jj,jk,Kmm_a) * vmask(ji,jj,jk) * vv(ji,jj,jk,Kmm_a) & 
     697!                                     & + (vmask(ji,jj,jk)-1._wp) * 999._wp 
     698                  tabres(ji,jj,jk,1) = zrhox * e1v(ji,jj) * e3v(ji,jj,jk,Kmm_a) * vmask(ji,jj,jk) * vv(ji,jj,jk,Kmm_a)  
     699!jc_alt 
     700!                  tabres(ji,jj,jk,2) = zrhox * e1v(ji,jj) * e3v(ji,jj,jk,Kmm_a) * vmask(ji,jj,jk) & 
     701!                                     & + (vmask(ji,jj,jk)-1._wp) * 999._wp 
     702                  tabres(ji,jj,jk,2) = zrhox * e1v(ji,jj) * e3v(ji,jj,jk,Kmm_a) * vmask(ji,jj,jk) 
    688703               END DO 
    689704            END DO 
    … …  
    696711               N_in = 0 
    697712               DO jk=k1,k2 
    698                   IF (tabres(ji,jj,jk,2) < -900) EXIT 
     713!jc_alt 
     714!                  IF (tabres(ji,jj,jk,2) < -900._wp) EXIT 
     715                  IF (tabres(ji,jj,jk,2) == 0) EXIT 
    699716                  N_in = N_in + 1 
    700717                  tabin(jk) = tabres(ji,jj,jk,1)/tabres(ji,jj,jk,2) 
    … …  
    705722                  IF (vmask(ji,jj,jk) == 0) EXIT 
    706723                  N_out = N_out + 1 
    707                   h_out(N_out) = e3v_n(ji,jj,jk) 
     724                  h_out(N_out) = e3v(ji,jj,jk,Kmm_a) 
    708725               ENDDO 
    709726               IF (N_in * N_out > 0) THEN 
    710727                  h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in)) 
     728                  excess = 0._wp 
    711729                  IF (h_diff < -1.e-4) then 
    712 !Even if bathy at T points match it's possible for the U points to be deeper in the child grid.  
     730!Even if bathy at T points match it's possible for the V points to be deeper in the child grid.  
    713731!In this case we need to move transport from the child grid cells below bed of parent grid into the bottom cell. 
    714                      excess = 0._wp 
    715732                     DO jk=N_in,1,-1 
    716733                        thick = MIN(-1*h_diff, h_in(jk)) 
    … …  
    725742                     ENDDO 
    726743                  ENDIF 
    727                   CALL reconstructandremap(tabin(1:N_in),h_in(1:N_in),tabres_child(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out) 
     744                  CALL reconstructandremap(tabin(1:N_in),h_in(1:N_in),tabres_child(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out,1) 
    728745                  tabres_child(ji,jj,N_out) = tabres_child(ji,jj,N_out) + excess/(e1v(ji,jj)*h_out(N_out)) 
    729746               ENDIF 
    730747            ENDDO 
    731748         ENDDO 
    732  
    733          DO jk=1,jpk 
     749         ! 
     750         DO jk=1,jpkm1 
    734751            DO jj=j1,j2 
    735752               DO ji=i1,i2 
    736                   ! 
    737                   IF( .NOT.(lk_agrif_fstep.AND.(neuler==0)) ) THEN ! Add asselin part 
    738                      vb(ji,jj,jk) = vb(ji,jj,jk) &  
    739                            & + atfp * ( tabres_child(ji,jj,jk) - vn(ji,jj,jk) ) * vmask(ji,jj,jk) 
     753                  IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part 
     754                     zvb  = vv(ji,jj,jk,Kbb_a) * e3v(ji,jj,jk,Kbb_a) ! fse3t_b prior update should be used 
     755                     zvno = vv(ji,jj,jk,Kmm_a) * e3v(ji,jj,jk,Krhs_a) 
     756                     zvnu = tabres_child(ji,jj,jk) * e3v(ji,jj,jk,Kmm_a) 
     757                     vv(ji,jj,jk,Kbb_a) = ( zvb + atfp * ( zvnu - zvno) ) &       
     758                                    & * vmask(ji,jj,jk) / e3v(ji,jj,jk,Kbb_a) 
    740759                  ENDIF 
    741760                  ! 
    742                   vn(ji,jj,jk) = tabres_child(ji,jj,jk) * vmask(ji,jj,jk) 
    743                END DO 
    744             END DO 
    745          END DO 
     761                  vv(ji,jj,jk,Kmm_a) = tabres_child(ji,jj,jk) * vmask(ji,jj,jk) 
     762               END DO 
     763            END DO 
     764         END DO 
     765         ! 
     766         IF  ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN 
     767            vv(i1:i2,j1:j2,1:jpkm1,Kbb_a)  = vv(i1:i2,j1:j2,1:jpkm1,Kmm_a) 
     768         ENDIF 
     769         ! 
    746770      ENDIF 
    747771      !  
    … …  
    767791            DO jj=j1,j2 
    768792               DO ji=i1,i2 
    769                   tabres(ji,jj,jk,1) = zrhox * e1v(ji,jj) * e3v_n(ji,jj,jk) * vn(ji,jj,jk) 
     793                  tabres(ji,jj,jk,1) = zrhox * e1v(ji,jj) * e3v(ji,jj,jk,Kmm_a) * vv(ji,jj,jk,Kmm_a) 
    770794               END DO 
    771795            END DO 
    … …  
    778802                  ! 
    779803                  IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part 
    780                      zvb  = vb(ji,jj,jk) * e3v_b(ji,jj,jk) ! fse3t_b prior update should be used 
    781                      zvno = vn(ji,jj,jk) * e3v_a(ji,jj,jk) 
     804                     zvb  = vv(ji,jj,jk,Kbb_a) * e3v(ji,jj,jk,Kbb_a) ! fse3t_b prior update should be used 
     805                     zvno = vv(ji,jj,jk,Kmm_a) * e3v(ji,jj,jk,Krhs_a) 
    782806                     zvnu = tabres(ji,jj,jk,1) 
    783                      vb(ji,jj,jk) = ( zvb + atfp * ( zvnu - zvno) ) &       
    784                                     & * vmask(ji,jj,jk) / e3v_b(ji,jj,jk) 
     807                     vv(ji,jj,jk,Kbb_a) = ( zvb + atfp * ( zvnu - zvno) ) &       
     808                                    & * vmask(ji,jj,jk) / e3v(ji,jj,jk,Kbb_a) 
    785809                  ENDIF 
    786810                  ! 
    787                   vn(ji,jj,jk) = tabres(ji,jj,jk,1) * vmask(ji,jj,jk) / e3v_n(ji,jj,jk) 
     811                  vv(ji,jj,jk,Kmm_a) = tabres(ji,jj,jk,1) * vmask(ji,jj,jk) / e3v(ji,jj,jk,Kmm_a) 
    788812               END DO 
    789813            END DO 
    … …  
    791815         ! 
    792816         IF  ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN 
    793             vb(i1:i2,j1:j2,k1:k2)  = vn(i1:i2,j1:j2,k1:k2) 
     817            vv(i1:i2,j1:j2,k1:k2,Kbb_a)  = vv(i1:i2,j1:j2,k1:k2,Kmm_a) 
    794818         ENDIF 
    795819         ! 
    … …  
    822846         IF (southern_side) THEN 
    823847            DO ji=i1,i2 
    824                zcor = vn_b(ji,j1-1) * hv_a(ji,j1-1) * r1_hv_n(ji,j1-1) - vn_b(ji,j1-1) 
    825                vn_b(ji,j1-1) = vn_b(ji,j1-1) + zcor 
     848               zcor = vv_b(ji,j1-1,Kmm_a) * hv(ji,j1-1,Krhs_a) * r1_hv(ji,j1-1,Kmm_a) - vv_b(ji,j1-1,Kmm_a) 
     849               vv_b(ji,j1-1,Kmm_a) = vv_b(ji,j1-1,Kmm_a) + zcor 
    826850               DO jk=1,jpkm1 
    827                   vn(ji,j1-1,jk) = vn(ji,j1-1,jk) + zcor * vmask(ji,j1-1,jk) 
     851                  vv(ji,j1-1,jk,Kmm_a) = vv(ji,j1-1,jk,Kmm_a) + zcor * vmask(ji,j1-1,jk) 
    828852               END DO  
    829853            END DO 
    … …  
    832856         IF (northern_side) THEN 
    833857            DO ji=i1,i2 
    834                zcor = vn_b(ji,j2+1) * hv_a(ji,j2+1) * r1_hv_n(ji,j2+1) - vn_b(ji,j2+1) 
    835                vn_b(ji,j2+1) = vn_b(ji,j2+1) + zcor 
     858               zcor = vv_b(ji,j2+1,Kmm_a) * hv(ji,j2+1,Krhs_a) * r1_hv(ji,j2+1,Kmm_a) - vv_b(ji,j2+1,Kmm_a) 
     859               vv_b(ji,j2+1,Kmm_a) = vv_b(ji,j2+1,Kmm_a) + zcor 
    836860               DO jk=1,jpkm1 
    837                   vn(ji,j2+1,jk) = vn(ji,j2+1,jk) + zcor * vmask(ji,j2+1,jk) 
     861                  vv(ji,j2+1,jk,Kmm_a) = vv(ji,j2+1,jk,Kmm_a) + zcor * vmask(ji,j2+1,jk) 
    838862               END DO  
    839863            END DO 
    … …  
    862886         DO jj=j1,j2 
    863887            DO ji=i1,i2 
    864                tabres(ji,jj) = zrhoy * un_b(ji,jj) * hu_n(ji,jj) * e2u(ji,jj) 
     888               tabres(ji,jj) = zrhoy * uu_b(ji,jj,Kmm_a) * hu(ji,jj,Kmm_a) * e2u(ji,jj) 
    865889            END DO 
    866890         END DO 
    … …  
    873897               spgu(ji,jj) = 0._wp 
    874898               DO jk=1,jpkm1 
    875                   spgu(ji,jj) = spgu(ji,jj) + e3u_n(ji,jj,jk) * un(ji,jj,jk) 
     899                  spgu(ji,jj) = spgu(ji,jj) + e3u(ji,jj,jk,Kmm_a) * uu(ji,jj,jk,Kmm_a) 
    876900               END DO 
    877901               ! 
    878                zcorr = (tabres(ji,jj) - spgu(ji,jj)) * r1_hu_n(ji,jj) 
     902               zcorr = (tabres(ji,jj) - spgu(ji,jj)) * r1_hu(ji,jj,Kmm_a) 
    879903               DO jk=1,jpkm1               
    880                   un(ji,jj,jk) = un(ji,jj,jk) + zcorr * umask(ji,jj,jk)            
     904                  uu(ji,jj,jk,Kmm_a) = uu(ji,jj,jk,Kmm_a) + zcorr * umask(ji,jj,jk)            
    881905               END DO 
    882906               ! 
    … …  
    884908               IF ( .NOT.ln_dynspg_ts .OR. (ln_dynspg_ts.AND.(.NOT.ln_bt_fw)) ) THEN 
    885909                  IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part 
    886                      zcorr = (tabres(ji,jj) - un_b(ji,jj) * hu_a(ji,jj)) * r1_hu_b(ji,jj) 
    887                      ub_b(ji,jj) = ub_b(ji,jj) + atfp * zcorr * umask(ji,jj,1) 
     910                     zcorr = (tabres(ji,jj) - uu_b(ji,jj,Kmm_a) * hu(ji,jj,Krhs_a)) * r1_hu(ji,jj,Kbb_a) 
     911                     uu_b(ji,jj,Kbb_a) = uu_b(ji,jj,Kbb_a) + atfp * zcorr * umask(ji,jj,1) 
    888912                  END IF 
    889913               ENDIF     
    890                un_b(ji,jj) = tabres(ji,jj) * r1_hu_n(ji,jj) * umask(ji,jj,1) 
     914               uu_b(ji,jj,Kmm_a) = tabres(ji,jj) * r1_hu(ji,jj,Kmm_a) * umask(ji,jj,1) 
    891915               !        
    892916               ! Correct "before" velocities to hold correct bt component: 
    893917               spgu(ji,jj) = 0.e0 
    894918               DO jk=1,jpkm1 
    895                   spgu(ji,jj) = spgu(ji,jj) + e3u_b(ji,jj,jk) * ub(ji,jj,jk) 
     919                  spgu(ji,jj) = spgu(ji,jj) + e3u(ji,jj,jk,Kbb_a) * uu(ji,jj,jk,Kbb_a) 
    896920               END DO 
    897921               ! 
    898                zcorr = ub_b(ji,jj) - spgu(ji,jj) * r1_hu_b(ji,jj) 
     922               zcorr = uu_b(ji,jj,Kbb_a) - spgu(ji,jj) * r1_hu(ji,jj,Kbb_a) 
    899923               DO jk=1,jpkm1               
    900                   ub(ji,jj,jk) = ub(ji,jj,jk) + zcorr * umask(ji,jj,jk)            
     924                  uu(ji,jj,jk,Kbb_a) = uu(ji,jj,jk,Kbb_a) + zcorr * umask(ji,jj,jk)            
    901925               END DO 
    902926               ! 
    … …  
    905929         ! 
    906930         IF  ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN 
    907             ub_b(i1:i2,j1:j2)  = un_b(i1:i2,j1:j2) 
     931            uu_b(i1:i2,j1:j2,Kbb_a)  = uu_b(i1:i2,j1:j2,Kmm_a) 
    908932         ENDIF 
    909933      ENDIF 
    … …  
    928952         DO jj=j1,j2 
    929953            DO ji=i1,i2 
    930                tabres(ji,jj) = zrhox * vn_b(ji,jj) * hv_n(ji,jj) * e1v(ji,jj)  
     954               tabres(ji,jj) = zrhox * vv_b(ji,jj,Kmm_a) * hv(ji,jj,Kmm_a) * e1v(ji,jj)  
    931955            END DO 
    932956         END DO 
    … …  
    939963               spgv(ji,jj) = 0.e0 
    940964               DO jk=1,jpkm1 
    941                   spgv(ji,jj) = spgv(ji,jj) + e3v_n(ji,jj,jk) * vn(ji,jj,jk) 
     965                  spgv(ji,jj) = spgv(ji,jj) + e3v(ji,jj,jk,Kmm_a) * vv(ji,jj,jk,Kmm_a) 
    942966               END DO 
    943967               ! 
    944                zcorr = (tabres(ji,jj) - spgv(ji,jj)) * r1_hv_n(ji,jj) 
     968               zcorr = (tabres(ji,jj) - spgv(ji,jj)) * r1_hv(ji,jj,Kmm_a) 
    945969               DO jk=1,jpkm1               
    946                   vn(ji,jj,jk) = vn(ji,jj,jk) + zcorr * vmask(ji,jj,jk)            
     970                  vv(ji,jj,jk,Kmm_a) = vv(ji,jj,jk,Kmm_a) + zcorr * vmask(ji,jj,jk)            
    947971               END DO 
    948972               ! 
    … …  
    950974               IF ( .NOT.ln_dynspg_ts .OR. (ln_dynspg_ts.AND.(.NOT.ln_bt_fw)) ) THEN 
    951975                  IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part 
    952                      zcorr = (tabres(ji,jj) - vn_b(ji,jj) * hv_a(ji,jj)) * r1_hv_b(ji,jj) 
    953                      vb_b(ji,jj) = vb_b(ji,jj) + atfp * zcorr * vmask(ji,jj,1) 
     976                     zcorr = (tabres(ji,jj) - vv_b(ji,jj,Kmm_a) * hv(ji,jj,Krhs_a)) * r1_hv(ji,jj,Kbb_a) 
     977                     vv_b(ji,jj,Kbb_a) = vv_b(ji,jj,Kbb_a) + atfp * zcorr * vmask(ji,jj,1) 
    954978                  END IF 
    955979               ENDIF               
    956                vn_b(ji,jj) = tabres(ji,jj) * r1_hv_n(ji,jj) * vmask(ji,jj,1) 
     980               vv_b(ji,jj,Kmm_a) = tabres(ji,jj) * r1_hv(ji,jj,Kmm_a) * vmask(ji,jj,1) 
    957981               !        
    958982               ! Correct "before" velocities to hold correct bt component: 
    959983               spgv(ji,jj) = 0.e0 
    960984               DO jk=1,jpkm1 
    961                   spgv(ji,jj) = spgv(ji,jj) + e3v_b(ji,jj,jk) * vb(ji,jj,jk) 
     985                  spgv(ji,jj) = spgv(ji,jj) + e3v(ji,jj,jk,Kbb_a) * vv(ji,jj,jk,Kbb_a) 
    962986               END DO 
    963987               ! 
    964                zcorr = vb_b(ji,jj) - spgv(ji,jj) * r1_hv_b(ji,jj) 
     988               zcorr = vv_b(ji,jj,Kbb_a) - spgv(ji,jj) * r1_hv(ji,jj,Kbb_a) 
    965989               DO jk=1,jpkm1               
    966                   vb(ji,jj,jk) = vb(ji,jj,jk) + zcorr * vmask(ji,jj,jk)            
     990                  vv(ji,jj,jk,Kbb_a) = vv(ji,jj,jk,Kbb_a) + zcorr * vmask(ji,jj,jk)            
    967991               END DO 
    968992               ! 
    … …  
    971995         ! 
    972996         IF  ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN 
    973             vb_b(i1:i2,j1:j2)  = vn_b(i1:i2,j1:j2) 
     997            vv_b(i1:i2,j1:j2,Kbb_a)  = vv_b(i1:i2,j1:j2,Kmm_a) 
    974998         ENDIF 
    975999         ! 
    … …  
    9931017         DO jj=j1,j2 
    9941018            DO ji=i1,i2 
    995                tabres(ji,jj) = sshn(ji,jj) 
     1019               tabres(ji,jj) = ssh(ji,jj,Kmm_a) 
    9961020            END DO 
    9971021         END DO 
    … …  
    10001024            DO jj=j1,j2 
    10011025               DO ji=i1,i2 
    1002                   sshb(ji,jj) =   sshb(ji,jj) & 
    1003                         & + atfp * ( tabres(ji,jj) - sshn(ji,jj) ) * tmask(ji,jj,1) 
     1026                  ssh(ji,jj,Kbb_a) =   ssh(ji,jj,Kbb_a) & 
     1027                        & + atfp * ( tabres(ji,jj) - ssh(ji,jj,Kmm_a) ) * tmask(ji,jj,1) 
    10041028               END DO 
    10051029            END DO 
    … …  
    10081032         DO jj=j1,j2 
    10091033            DO ji=i1,i2 
    1010                sshn(ji,jj) = tabres(ji,jj) * tmask(ji,jj,1) 
     1034               ssh(ji,jj,Kmm_a) = tabres(ji,jj) * tmask(ji,jj,1) 
    10111035            END DO 
    10121036         END DO 
    10131037         ! 
    10141038         IF  ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN 
    1015             sshb(i1:i2,j1:j2)  = sshn(i1:i2,j1:j2) 
     1039            ssh(i1:i2,j1:j2,Kbb_a)  = ssh(i1:i2,j1:j2,Kmm_a) 
    10161040         ENDIF 
    10171041         ! 
    … …  
    10941118            DO jj=j1,j2 
    10951119               zcor = rdt * r1_e1e2t(i1  ,jj) * e2u(i1,jj) * (ub2_b(i1,jj)-tabres(i1,jj))  
    1096                sshn(i1  ,jj) = sshn(i1  ,jj) + zcor 
    1097                IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) sshb(i1  ,jj) = sshb(i1  ,jj) + atfp * zcor 
     1120               ssh(i1  ,jj,Kmm_a) = ssh(i1  ,jj,Kmm_a) + zcor 
     1121               IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) ssh(i1  ,jj,Kbb_a) = ssh(i1  ,jj,Kbb_a) + atfp * zcor 
    10981122            END DO 
    10991123         ENDIF 
    … …  
    11011125            DO jj=j1,j2 
    11021126               zcor = - rdt * r1_e1e2t(i2+1,jj) * e2u(i2,jj) * (ub2_b(i2,jj)-tabres(i2,jj)) 
    1103                sshn(i2+1,jj) = sshn(i2+1,jj) + zcor 
    1104                IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) sshb(i2+1,jj) = sshb(i2+1,jj) + atfp * zcor 
     1127               ssh(i2+1,jj,Kmm_a) = ssh(i2+1,jj,Kmm_a) + zcor 
     1128               IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) ssh(i2+1,jj,Kbb_a) = ssh(i2+1,jj,Kbb_a) + atfp * zcor 
    11051129            END DO 
    11061130         ENDIF 
    … …  
    11821206            DO ji=i1,i2 
    11831207               zcor = rdt * r1_e1e2t(ji,j1  ) * e1v(ji,j1  ) * (vb2_b(ji,j1)-tabres(ji,j1)) 
    1184                sshn(ji,j1  ) = sshn(ji,j1  ) + zcor 
    1185                IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) sshb(ji,j1  ) = sshb(ji,j1) + atfp * zcor 
     1208               ssh(ji,j1  ,Kmm_a) = ssh(ji,j1  ,Kmm_a) + zcor 
     1209               IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) ssh(ji,j1  ,Kbb_a) = ssh(ji,j1,Kbb_a) + atfp * zcor 
    11861210            END DO 
    11871211         ENDIF 
    … …  
    11891213            DO ji=i1,i2 
    11901214               zcor = - rdt * r1_e1e2t(ji,j2+1) * e1v(ji,j2  ) * (vb2_b(ji,j2)-tabres(ji,j2)) 
    1191                sshn(ji,j2+1) = sshn(ji,j2+1) + zcor 
    1192                IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) sshb(ji,j2+1) = sshb(ji,j2+1) + atfp * zcor 
     1215               ssh(ji,j2+1,Kmm_a) = ssh(ji,j2+1,Kmm_a) + zcor 
     1216               IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) ssh(ji,j2+1,Kbb_a) = ssh(ji,j2+1,Kbb_a) + atfp * zcor 
    11931217            END DO 
    11941218         ENDIF 
    … …  
    13191343            DO jj=j1,j2 
    13201344               DO ji=i1,i2 
    1321                   ptab(ji,jj,jk) = e3t_0(ji,jj,jk) * (1._wp + sshn(ji,jj) & 
     1345                  ptab(ji,jj,jk) = e3t_0(ji,jj,jk) * (1._wp + ssh(ji,jj,Kmm_a) & 
    13221346                                     & *ssmask(ji,jj)/(ht_0(ji,jj)-1._wp + ssmask(ji,jj))) 
    13231347               END DO 
    … …  
    13301354         ! Save "old" scale factor (prior update) for subsequent asselin correction 
    13311355         ! of prognostic variables 
    1332          e3t_a(i1:i2,j1:j2,1:jpkm1) = e3t_n(i1:i2,j1:j2,1:jpkm1) 
    1333  
    1334          ! One should also save e3t_b, but lacking of workspace... 
    1335 !         hdivn(i1:i2,j1:j2,1:jpkm1)   = e3t_b(i1:i2,j1:j2,1:jpkm1) 
     1356         e3t(i1:i2,j1:j2,1:jpkm1,Krhs_a) = e3t(i1:i2,j1:j2,1:jpkm1,Kmm_a) 
     1357 
     1358         ! One should also save e3t(:,:,:,Kbb_a), but lacking of workspace... 
     1359!         hdiv(i1:i2,j1:j2,1:jpkm1)   = e3t(i1:i2,j1:j2,1:jpkm1,Kbb_a) 
    13361360 
    13371361         IF (.NOT.(lk_agrif_fstep.AND.(neuler==0) )) THEN 
    … …  
    13391363               DO jj=j1,j2 
    13401364                  DO ji=i1,i2 
    1341                      e3t_b(ji,jj,jk) =  e3t_b(ji,jj,jk) & 
    1342                            & + atfp * ( ptab(ji,jj,jk) - e3t_n(ji,jj,jk) ) 
     1365                     e3t(ji,jj,jk,Kbb_a) =  e3t(ji,jj,jk,Kbb_a) & 
     1366                           & + atfp * ( ptab(ji,jj,jk) - e3t(ji,jj,jk,Kmm_a) ) 
    13431367                  END DO 
    13441368               END DO 
    13451369            END DO 
    13461370            ! 
    1347             e3w_b  (i1:i2,j1:j2,1) = e3w_0(i1:i2,j1:j2,1) + e3t_b(i1:i2,j1:j2,1) - e3t_0(i1:i2,j1:j2,1) 
    1348             gdepw_b(i1:i2,j1:j2,1) = 0.0_wp 
    1349             gdept_b(i1:i2,j1:j2,1) = 0.5_wp * e3w_b(i1:i2,j1:j2,1) 
     1371            e3w  (i1:i2,j1:j2,1,Kbb_a) = e3w_0(i1:i2,j1:j2,1) + e3t(i1:i2,j1:j2,1,Kbb_a) - e3t_0(i1:i2,j1:j2,1) 
     1372            gdepw(i1:i2,j1:j2,1,Kbb_a) = 0.0_wp 
     1373            gdept(i1:i2,j1:j2,1,Kbb_a) = 0.5_wp * e3w(i1:i2,j1:j2,1,Kbb_a) 
    13501374            ! 
    13511375            DO jk = 2, jpk 
    … …  
    13531377                  DO ji = i1,i2             
    13541378                     zcoef = (tmask(ji,jj,jk) - wmask(ji,jj,jk)) 
    1355                      e3w_b(ji,jj,jk)  = e3w_0(ji,jj,jk) + ( 1.0_wp - 0.5_wp * tmask(ji,jj,jk) ) *        &  
    1356                      &                                        ( e3t_b(ji,jj,jk-1) - e3t_0(ji,jj,jk-1) )  & 
     1379                     e3w(ji,jj,jk,Kbb_a)  = e3w_0(ji,jj,jk) + ( 1.0_wp - 0.5_wp * tmask(ji,jj,jk) ) *        &  
     1380                     &                                        ( e3t(ji,jj,jk-1,Kbb_a) - e3t_0(ji,jj,jk-1) )  & 
    13571381                     &                                  +            0.5_wp * tmask(ji,jj,jk)   *        & 
    1358                      &                                        ( e3t_b(ji,jj,jk  ) - e3t_0(ji,jj,jk  ) ) 
    1359                      gdepw_b(ji,jj,jk) = gdepw_b(ji,jj,jk-1) + e3t_b(ji,jj,jk-1) 
    1360                      gdept_b(ji,jj,jk) =      zcoef  * ( gdepw_b(ji,jj,jk  ) + 0.5 * e3w_b(ji,jj,jk))  & 
    1361                          &               + (1-zcoef) * ( gdept_b(ji,jj,jk-1) +       e3w_b(ji,jj,jk))  
     1382                     &                                        ( e3t(ji,jj,jk  ,Kbb_a) - e3t_0(ji,jj,jk  ) ) 
     1383                     gdepw(ji,jj,jk,Kbb_a) = gdepw(ji,jj,jk-1,Kbb_a) + e3t(ji,jj,jk-1,Kbb_a) 
     1384                     gdept(ji,jj,jk,Kbb_a) =      zcoef  * ( gdepw(ji,jj,jk  ,Kbb_a) + 0.5 * e3w(ji,jj,jk,Kbb_a))  & 
     1385                         &               + (1-zcoef) * ( gdept(ji,jj,jk-1,Kbb_a) +       e3w(ji,jj,jk,Kbb_a))  
    13621386                  END DO 
    13631387               END DO 
    … …  
    13701394         ! 
    13711395         ! Update vertical scale factor at T-points: 
    1372          e3t_n(i1:i2,j1:j2,1:jpkm1) = ptab(i1:i2,j1:j2,1:jpkm1) 
     1396         e3t(i1:i2,j1:j2,1:jpkm1,Kmm_a) = ptab(i1:i2,j1:j2,1:jpkm1) 
    13731397         ! 
    13741398         ! Update total depth: 
    1375          ht_n(i1:i2,j1:j2) = 0._wp 
     1399         ht(i1:i2,j1:j2) = 0._wp 
    13761400         DO jk = 1, jpkm1 
    1377             ht_n(i1:i2,j1:j2) = ht_n(i1:i2,j1:j2) + e3t_n(i1:i2,j1:j2,jk) * tmask(i1:i2,j1:j2,jk) 
     1401            ht(i1:i2,j1:j2) = ht(i1:i2,j1:j2) + e3t(i1:i2,j1:j2,jk,Kmm_a) * tmask(i1:i2,j1:j2,jk) 
    13781402         END DO 
    13791403         ! 
    13801404         ! Update vertical scale factor at W-points and depths: 
    1381          e3w_n (i1:i2,j1:j2,1) = e3w_0(i1:i2,j1:j2,1) + e3t_n(i1:i2,j1:j2,1) - e3t_0(i1:i2,j1:j2,1) 
    1382          gdept_n(i1:i2,j1:j2,1) = 0.5_wp * e3w_n(i1:i2,j1:j2,1) 
    1383          gdepw_n(i1:i2,j1:j2,1) = 0.0_wp 
    1384          gde3w_n(i1:i2,j1:j2,1) = gdept_n(i1:i2,j1:j2,1) - (ht_n(i1:i2,j1:j2)-ht_0(i1:i2,j1:j2)) ! Last term in the rhs is ssh 
     1405         e3w (i1:i2,j1:j2,1,Kmm_a) = e3w_0(i1:i2,j1:j2,1) + e3t(i1:i2,j1:j2,1,Kmm_a) - e3t_0(i1:i2,j1:j2,1) 
     1406         gdept(i1:i2,j1:j2,1,Kmm_a) = 0.5_wp * e3w(i1:i2,j1:j2,1,Kmm_a) 
     1407         gdepw(i1:i2,j1:j2,1,Kmm_a) = 0.0_wp 
     1408         gde3w(i1:i2,j1:j2,1) = gdept(i1:i2,j1:j2,1,Kmm_a) - (ht(i1:i2,j1:j2)-ht_0(i1:i2,j1:j2)) ! Last term in the rhs is ssh 
    13851409         ! 
    13861410         DO jk = 2, jpk 
    … …  
    13881412               DO ji = i1,i2             
    13891413               zcoef = (tmask(ji,jj,jk) - wmask(ji,jj,jk)) 
    1390                e3w_n(ji,jj,jk)  = e3w_0(ji,jj,jk) + ( 1.0_wp - 0.5_wp * tmask(ji,jj,jk) ) * ( e3t_n(ji,jj,jk-1) - e3t_0(ji,jj,jk-1) )   & 
    1391                &                                  +            0.5_wp * tmask(ji,jj,jk)   * ( e3t_n(ji,jj,jk  ) - e3t_0(ji,jj,jk  ) ) 
    1392                gdepw_n(ji,jj,jk) = gdepw_n(ji,jj,jk-1) + e3t_n(ji,jj,jk-1) 
    1393                gdept_n(ji,jj,jk) =      zcoef  * ( gdepw_n(ji,jj,jk  ) + 0.5 * e3w_n(ji,jj,jk))  & 
    1394                    &               + (1-zcoef) * ( gdept_n(ji,jj,jk-1) +       e3w_n(ji,jj,jk))  
    1395                gde3w_n(ji,jj,jk) = gdept_n(ji,jj,jk) - (ht_n(ji,jj)-ht_0(ji,jj)) ! Last term in the rhs is ssh 
     1414               e3w(ji,jj,jk,Kmm_a)  = e3w_0(ji,jj,jk) + ( 1.0_wp - 0.5_wp * tmask(ji,jj,jk) ) * ( e3t(ji,jj,jk-1,Kmm_a) - e3t_0(ji,jj,jk-1) )   & 
     1415               &                                  +            0.5_wp * tmask(ji,jj,jk)   * ( e3t(ji,jj,jk  ,Kmm_a) - e3t_0(ji,jj,jk  ) ) 
     1416               gdepw(ji,jj,jk,Kmm_a) = gdepw(ji,jj,jk-1,Kmm_a) + e3t(ji,jj,jk-1,Kmm_a) 
     1417               gdept(ji,jj,jk,Kmm_a) =      zcoef  * ( gdepw(ji,jj,jk  ,Kmm_a) + 0.5 * e3w(ji,jj,jk,Kmm_a))  & 
     1418                   &               + (1-zcoef) * ( gdept(ji,jj,jk-1,Kmm_a) +       e3w(ji,jj,jk,Kmm_a))  
     1419               gde3w(ji,jj,jk) = gdept(ji,jj,jk,Kmm_a) - (ht(ji,jj)-ht_0(ji,jj)) ! Last term in the rhs is ssh 
    13961420               END DO 
    13971421            END DO 
    … …  
    13991423         ! 
    14001424         IF  ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN 
    1401             e3t_b (i1:i2,j1:j2,1:jpk)  = e3t_n (i1:i2,j1:j2,1:jpk) 
    1402             e3w_b (i1:i2,j1:j2,1:jpk)  = e3w_n (i1:i2,j1:j2,1:jpk) 
    1403             gdepw_b(i1:i2,j1:j2,1:jpk) = gdepw_n(i1:i2,j1:j2,1:jpk) 
    1404             gdept_b(i1:i2,j1:j2,1:jpk) = gdept_n(i1:i2,j1:j2,1:jpk) 
     1425            e3t (i1:i2,j1:j2,1:jpk,Kbb_a)  = e3t (i1:i2,j1:j2,1:jpk,Kmm_a) 
     1426            e3w (i1:i2,j1:j2,1:jpk,Kbb_a)  = e3w (i1:i2,j1:j2,1:jpk,Kmm_a) 
     1427            gdepw(i1:i2,j1:j2,1:jpk,Kbb_a) = gdepw(i1:i2,j1:j2,1:jpk,Kmm_a) 
     1428            gdept(i1:i2,j1:j2,1:jpk,Kbb_a) = gdept(i1:i2,j1:j2,1:jpk,Kmm_a) 
    14051429         ENDIF 
    14061430         ! 

  • NEMO/trunk/src/NST/agrif_top_interp.F90

    r10068 r12377  
    1818   USE par_trc 
    1919   USE trc 
     20   USE vremap 
    2021   ! 
    2122   USE lib_mpp     ! MPP library 
    … …  
    4849   END SUBROUTINE Agrif_trc 
    4950 
    50    SUBROUTINE interptrn( ptab, i1, i2, j1, j2, k1, k2, n1, n2, before, nb, ndir ) 
     51   SUBROUTINE interptrn( ptab, i1, i2, j1, j2, k1, k2, n1, n2, before ) 
    5152      !!---------------------------------------------------------------------- 
    5253      !!                  *** ROUTINE interptrn *** 
    … …  
    5556      INTEGER                                     , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2, n1, n2 
    5657      LOGICAL                                     , INTENT(in   ) ::   before 
    57       INTEGER                                     , INTENT(in   ) ::   nb , ndir 
    5858      ! 
    59       INTEGER  ::   ji, jj, jk, jn, iref, jref, ibdy, jbdy   ! dummy loop indices 
     59      INTEGER  ::   ji, jj, jk, jn, ibdy, jbdy   ! dummy loop indices 
    6060      INTEGER  ::   imin, imax, jmin, jmax, N_in, N_out 
    6161      REAL(wp) ::   zrho, z1, z2, z3, z4, z5, z6, z7 
    62       LOGICAL :: western_side, eastern_side,northern_side,southern_side 
     62 
    6363      ! vertical interpolation: 
    64       REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk,n1:n2) :: ptab_child 
    65       REAL(wp), DIMENSION(k1:k2,n1:n2-1) :: tabin 
     64      REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk,1:jptra) :: ptab_child 
     65      REAL(wp), DIMENSION(k1:k2,1:jptra) :: tabin 
    6666      REAL(wp), DIMENSION(k1:k2) :: h_in 
    6767      REAL(wp), DIMENSION(1:jpk) :: h_out 
    68       REAL(wp) :: h_diff 
     68      !!---------------------------------------------------------------------- 
    6969 
    7070      IF( before ) THEN          
    … …  
    7373               DO jj=j1,j2 
    7474                 DO ji=i1,i2 
    75                        ptab(ji,jj,jk,jn) = trn(ji,jj,jk,jn) 
     75                       ptab(ji,jj,jk,jn) = tr(ji,jj,jk,jn,Kmm_a) 
    7676                 END DO 
    7777              END DO 
    … …  
    8383           DO jj=j1,j2 
    8484              DO ji=i1,i2 
    85                  ptab(ji,jj,jk,jptra+1) = tmask(ji,jj,jk) * e3t_n(ji,jj,jk)  
     85                 ptab(ji,jj,jk,jptra+1) = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kmm_a)  
    8686              END DO 
    8787           END DO 
    … …  
    9090      ELSE  
    9191 
    92          western_side  = (nb == 1).AND.(ndir == 1)   ;   eastern_side  = (nb == 1).AND.(ndir == 2) 
    93          southern_side = (nb == 2).AND.(ndir == 1)   ;   northern_side = (nb == 2).AND.(ndir == 2) 
    94  
    95 # if defined key_vertical               
     92# if defined key_vertical 
    9693         DO jj=j1,j2 
    9794            DO ji=i1,i2 
    98                iref = ji 
    99                jref = jj 
    100                if(western_side) iref=MAX(2,ji) 
    101                if(eastern_side) iref=MIN(nlci-1,ji) 
    102                if(southern_side) jref=MAX(2,jj) 
    103                if(northern_side) jref=MIN(nlcj-1,jj) 
     95               ptab_child(ji,jj,:) = 0._wp 
    10496               N_in = 0 
    10597               DO jk=k1,k2 !k2 = jpk of parent grid 
    … …  
    111103               N_out = 0 
    112104               DO jk=1,jpk ! jpk of child grid 
    113                   IF (tmask(iref,jref,jk) == 0) EXIT  
     105                  IF (tmask(ji,jj,jk) == 0) EXIT  
    114106                  N_out = N_out + 1 
    115                   h_out(jk) = e3t_n(iref,jref,jk) 
     107                  h_out(jk) = e3t(ji,jj,jk,Krhs_a) 
    116108               ENDDO 
    117109               IF (N_in > 0) THEN 
    118                   DO jn=1,jptra 
    119                      call reconstructandremap(tabin(1:N_in,jn),h_in,ptab_child(ji,jj,1:N_out,jn),h_out,N_in,N_out) 
    120                   ENDDO 
     110                  CALL reconstructandremap(tabin(1:N_in,1:jptra),h_in,ptab_child(ji,jj,1:N_out,1:jptra),h_out,N_in,N_out,jptra) 
    121111               ENDIF 
    122112            ENDDO 
    … …  
    127117         ! 
    128118         DO jn=1, jptra 
    129             tra(i1:i2,j1:j2,1:jpk,jn)=ptab_child(i1:i2,j1:j2,1:jpk,jn)*tmask(i1:i2,j1:j2,1:jpk)  
     119            tr(i1:i2,j1:j2,1:jpk,jn,Krhs_a)=ptab_child(i1:i2,j1:j2,1:jpk,jn)*tmask(i1:i2,j1:j2,1:jpk)  
    130120         END DO 
    131  
    132          IF ( .NOT.lk_agrif_clp ) THEN  
    133             ! 
    134             imin = i1 ; imax = i2 
    135             jmin = j1 ; jmax = j2 
    136             !  
    137             ! Remove CORNERS 
    138             IF((nbondj == -1).OR.(nbondj == 2)) jmin = 2 + nbghostcells 
    139             IF((nbondj == +1).OR.(nbondj == 2)) jmax = nlcj - nbghostcells - 1 
    140             IF((nbondi == -1).OR.(nbondi == 2)) imin = 2 + nbghostcells 
    141             IF((nbondi == +1).OR.(nbondi == 2)) imax = nlci - nbghostcells - 1       
    142             ! 
    143             IF( eastern_side ) THEN 
    144                zrho = Agrif_Rhox() 
    145                z1 = ( zrho - 1._wp ) * 0.5_wp                     
    146                z3 = ( zrho - 1._wp ) / ( zrho + 1._wp )          
    147                z6 = 2._wp * ( zrho - 1._wp ) / ( zrho + 1._wp ) 
    148                z7 =       - ( zrho - 1._wp ) / ( zrho + 3._wp ) 
    149                z2 = 1._wp - z1 ; z4 = 1._wp - z3 ; z5 = 1._wp - z6 - z7 
    150                ! 
    151                ibdy = nlci-nbghostcells 
    152                DO jn = 1, jptra 
    153                   tra(ibdy+1,jmin:jmax,1:jpkm1,jn) = z1 * ptab_child(ibdy+1,jmin:jmax,1:jpkm1,jn) + z2 * ptab_child(ibdy,jmin:jmax,1:jpkm1,jn) 
    154                   DO jk = 1, jpkm1 
    155                      DO jj = jmin,jmax 
    156                         IF( umask(ibdy-1,jj,jk) == 0._wp ) THEN 
    157                            tra(ibdy,jj,jk,jn) = tra(ibdy+1,jj,jk,jn) * tmask(ibdy,jj,jk) 
    158                         ELSE 
    159                            tra(ibdy,jj,jk,jn)=(z4*tra(ibdy+1,jj,jk,jn)+z3*tra(ibdy-1,jj,jk,jn))*tmask(ibdy,jj,jk) 
    160                            IF( un(ibdy-1,jj,jk) > 0._wp ) THEN 
    161                               tra(ibdy,jj,jk,jn)=( z6*tra(ibdy-1,jj,jk,jn)+z5*tra(ibdy+1,jj,jk,jn) &  
    162                                                  + z7*tra(ibdy-2,jj,jk,jn) ) * tmask(ibdy,jj,jk) 
    163                            ENDIF 
    164                         ENDIF 
    165                      END DO 
    166                   END DO 
    167                   ! Restore ghost points: 
    168                   tra(ibdy+1,jmin:jmax,1:jpkm1,jn) = ptab_child(ibdy+1,jmin:jmax,1:jpkm1,jn) * tmask(ibdy+1,jmin:jmax,1:jpkm1) 
    169                END DO 
    170             ENDIF 
    171             !  
    172             IF( northern_side ) THEN 
    173                zrho = Agrif_Rhoy() 
    174                z1 = ( zrho - 1._wp ) * 0.5_wp                     
    175                z3 = ( zrho - 1._wp ) / ( zrho + 1._wp )          
    176                z6 = 2._wp * ( zrho - 1._wp ) / ( zrho + 1._wp ) 
    177                z7 =       - ( zrho - 1._wp ) / ( zrho + 3._wp ) 
    178                z2 = 1._wp - z1 ; z4 = 1._wp - z3 ; z5 = 1._wp - z6 - z7 
    179                ! 
    180                jbdy = nlcj-nbghostcells          
    181                DO jn = 1, jptra 
    182                   tra(imin:imax,jbdy+1,1:jpkm1,jn) = z1 * ptab_child(imin:imax,jbdy+1,1:jpkm1,jn) + z2 * ptab_child(imin:imax,jbdy,1:jpkm1,jn) 
    183                   DO jk = 1, jpkm1 
    184                      DO ji = imin,imax 
    185                         IF( vmask(ji,jbdy-1,jk) == 0._wp ) THEN 
    186                            tra(ji,jbdy,jk,jn) = tra(ji,jbdy+1,jk,jn) * tmask(ji,jbdy,jk) 
    187                         ELSE 
    188                            tra(ji,jbdy,jk,jn)=(z4*tra(ji,jbdy+1,jk,jn)+z3*tra(ji,jbdy-1,jk,jn))*tmask(ji,jbdy,jk)         
    189                            IF (vn(ji,jbdy-1,jk) > 0._wp ) THEN 
    190                               tra(ji,jbdy,jk,jn)=( z6*tra(ji,jbdy-1,jk,jn)+z5*tra(ji,jbdy+1,jk,jn)  & 
    191                                                  + z7*tra(ji,jbdy-2,jk,jn) ) * tmask(ji,jbdy,jk) 
    192                            ENDIF 
    193                         ENDIF 
    194                      END DO 
    195                   END DO 
    196                   ! Restore ghost points: 
    197                   tra(imin:imax,jbdy+1,1:jpkm1,jn) = ptab_child(imin:imax,jbdy+1,1:jpkm1,jn) * tmask(imin:imax,jbdy+1,1:jpkm1) 
    198                END DO 
    199             ENDIF 
    200             ! 
    201             IF( western_side ) THEN 
    202                zrho = Agrif_Rhox() 
    203                z1 = ( zrho - 1._wp ) * 0.5_wp                     
    204                z3 = ( zrho - 1._wp ) / ( zrho + 1._wp )          
    205                z6 = 2._wp * ( zrho - 1._wp ) / ( zrho + 1._wp ) 
    206                z7 =       - ( zrho - 1._wp ) / ( zrho + 3._wp ) 
    207                z2 = 1._wp - z1 ; z4 = 1._wp - z3 ; z5 = 1._wp - z6 - z7 
    208                !     
    209                ibdy = 1+nbghostcells        
    210                DO jn = 1, jptra 
    211                   tra(ibdy-1,jmin:jmax,1:jpkm1,jn) = z1 * ptab_child(ibdy-1,jmin:jmax,1:jpkm1,jn) + z2 * ptab_child(ibdy,jmin:jmax,1:jpkm1,jn) 
    212                   DO jk = 1, jpkm1 
    213                      DO jj = jmin,jmax 
    214                         IF( umask(ibdy,jj,jk) == 0._wp ) THEN 
    215                            tra(ibdy,jj,jk,jn) = tra(ibdy-1,jj,jk,jn) * tmask(ibdy,jj,jk) 
    216                         ELSE 
    217                            tra(ibdy,jj,jk,jn)=(z4*tra(ibdy-1,jj,jk,jn)+z3*tra(ibdy+1,jj,jk,jn))*tmask(ibdy,jj,jk)         
    218                            IF( un(ibdy,jj,jk) < 0._wp ) THEN 
    219                               tra(ibdy,jj,jk,jn)=( z6*tra(ibdy+1,jj,jk,jn)+z5*tra(ibdy-1,jj,jk,jn) & 
    220                                                  + z7*tra(ibdy+2,jj,jk,jn) ) * tmask(ibdy,jj,jk) 
    221                            ENDIF 
    222                         ENDIF 
    223                      END DO 
    224                   END DO 
    225                   ! Restore ghost points: 
    226                   tra(ibdy-1,jmin:jmax,1:jpkm1,jn) = ptab_child(ibdy-1,jmin:jmax,1:jpkm1,jn) * tmask(ibdy-1,jmin:jmax,1:jpkm1) 
    227                END DO 
    228             ENDIF 
    229             ! 
    230             IF( southern_side ) THEN 
    231                zrho = Agrif_Rhoy() 
    232                z1 = ( zrho - 1._wp ) * 0.5_wp                     
    233                z3 = ( zrho - 1._wp ) / ( zrho + 1._wp )          
    234                z6 = 2._wp * ( zrho - 1._wp ) / ( zrho + 1._wp ) 
    235                z7 =       - ( zrho - 1._wp ) / ( zrho + 3._wp ) 
    236                z2 = 1._wp - z1 ; z4 = 1._wp - z3 ; z5 = 1._wp - z6 - z7 
    237                !   
    238                jbdy=1+nbghostcells         
    239                DO jn = 1, jptra 
    240                   tra(imin:imax,jbdy-1,1:jpkm1,jn) = z1 * ptab_child(imin:imax,jbdy-1,1:jpkm1,jn) + z2 * ptab_child(imin:imax,jbdy,1:jpkm1,jn) 
    241                   DO jk = 1, jpkm1       
    242                      DO ji = imin,imax 
    243                         IF( vmask(ji,jbdy,jk) == 0._wp ) THEN 
    244                            tra(ji,jbdy,jk,jn)=tra(ji,jbdy-1,jk,jn) * tmask(ji,jbdy,jk) 
    245                         ELSE 
    246                            tra(ji,jbdy,jk,jn)=(z4*tra(ji,jbdy-1,jk,jn)+z3*tra(ji,jbdy+1,jk,jn))*tmask(ji,jbdy,jk) 
    247                            IF( vn(ji,jbdy,jk) < 0._wp ) THEN 
    248                               tra(ji,jbdy,jk,jn)=( z6*tra(ji,jbdy+1,jk,jn)+z5*tra(ji,jbdy-1,jk,jn) &  
    249                                                  + z7*tra(ji,jbdy+2,jk,jn) ) * tmask(ji,jbdy,jk) 
    250                            ENDIF 
    251                         ENDIF 
    252                      END DO 
    253                   END DO 
    254                   ! Restore ghost points: 
    255                   tra(imin:imax,jbdy-1,1:jpkm1,jn) = ptab_child(imin:imax,jbdy-1,1:jpkm1,jn) * tmask(imin:imax,jbdy-1,1:jpkm1) 
    256                END DO 
    257             ENDIF 
    258             ! 
    259          ENDIF 
    260121 
    261122      ENDIF 

  • NEMO/trunk/src/NST/agrif_top_sponge.F90

    r10068 r12377  
    2020   USE agrif_oce 
    2121   USE agrif_oce_sponge 
     22   USE vremap 
    2223   ! 
    2324   USE in_out_manager 
    … …  
    6667      ! 
    6768      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
    68       REAL(wp) ::   zabe1, zabe2 
    69       REAL(wp), DIMENSION(i1:i2,j1:j2)             ::   ztu, ztv 
    70       REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2) ::   trbdiff 
     69      REAL(wp) ::   zabe1, zabe2, ztrelax 
     70      REAL(wp), DIMENSION(i1:i2,j1:j2)               ::   ztu, ztv 
     71      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,1:jptra) ::   trbdiff 
    7172      ! vertical interpolation: 
    72       REAL(wp), DIMENSION(i1:i2,j1:j2,jpk,n1:n2) ::tabres_child 
    73       REAL(wp), DIMENSION(k1:k2,n1:n2-1) :: tabin 
     73      REAL(wp), DIMENSION(i1:i2,j1:j2,jpk,1:jptra) ::tabres_child 
     74      REAL(wp), DIMENSION(k1:k2,1:jptra) :: tabin 
    7475      REAL(wp), DIMENSION(k1:k2) :: h_in 
    7576      REAL(wp), DIMENSION(1:jpk) :: h_out 
    … …  
    8384               DO jj=j1,j2 
    8485                  DO ji=i1,i2 
    85                      tabres(ji,jj,jk,jn) = trb(ji,jj,jk,jn) 
     86                     tabres(ji,jj,jk,jn) = tr(ji,jj,jk,jn,Kbb_a) 
    8687                  END DO 
    8788               END DO 
    … …  
    9394            DO jj=j1,j2 
    9495               DO ji=i1,i2 
    95                   tabres(ji,jj,jk,jpts+1) = tmask(ji,jj,jk) * e3t_n(ji,jj,jk)  
     96                  tabres(ji,jj,jk,jpts+1) = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kbb_a)  
    9697               END DO 
    9798            END DO 
    … …  
    114115                  IF (tmask(ji,jj,jk) == 0) EXIT  
    115116                  N_out = N_out + 1 
    116                   h_out(jk) = e3t_n(ji,jj,jk) !Child grid scale factors. Could multiply by e1e2t here instead of division above 
     117                  h_out(jk) = e3t(ji,jj,jk,Kbb_a) !Child grid scale factors. Could multiply by e1e2t here instead of division above 
    117118               ENDDO 
    118119               IF (N_in > 0) THEN 
    119                   h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in)) 
    120                   tabres(ji,jj,k2,:) = tabres(ji,jj,k2-1,:) !what is this line for????? 
    121                   DO jn=1,jptra 
    122                      call reconstructandremap(tabin(1:N_in,jn),h_in,tabres_child(ji,jj,1:N_out,jn),h_out,N_in,N_out) 
    123                   ENDDO 
     120                  CALL reconstructandremap(tabin(1:N_in,1:jptra),h_in,tabres_child(ji,jj,1:N_out,1:jptra),h_out,N_in,N_out,jptra) 
    124121               ENDIF 
    125122            ENDDO 
    … …  
    131128               DO jk=1,jpkm1 
    132129# if defined key_vertical 
    133                   trbdiff(ji,jj,jk,1:jptra) = trb(ji,jj,jk,1:jptra) - tabres_child(ji,jj,jk,1:jptra) 
     130                  trbdiff(ji,jj,jk,1:jptra) = tr(ji,jj,jk,1:jptra,Kbb_a) - tabres_child(ji,jj,jk,1:jptra) 
    134131# else 
    135                   trbdiff(ji,jj,jk,1:jptra) = trb(ji,jj,jk,1:jptra) - tabres(ji,jj,jk,1:jptra) 
     132                  trbdiff(ji,jj,jk,1:jptra) = tr(ji,jj,jk,1:jptra,Kbb_a) - tabres(ji,jj,jk,1:jptra) 
    136133# endif 
    137134               ENDDO 
    … …  
    139136         ENDDO 
    140137 
     138         !* set relaxation time scale 
     139         IF( neuler == 0 .AND. lk_agrif_fstep ) THEN   ;   ztrelax =   rn_trelax_tra  / (        rdt ) 
     140         ELSE                                          ;   ztrelax =   rn_trelax_tra  / (2._wp * rdt ) 
     141         ENDIF 
     142 
    141143         DO jn = 1, jptra 
    142144            DO jk = 1, jpkm1 
    143145               DO jj = j1,j2-1 
    144146                  DO ji = i1,i2-1 
    145                      zabe1 = fsaht_spu(ji,jj) * e2_e1u(ji,jj) * e3u_n(ji,jj,jk) * umask(ji,jj,jk) 
    146                      zabe2 = fsaht_spv(ji,jj) * e1_e2v(ji,jj) * e3v_n(ji,jj,jk) * vmask(ji,jj,jk) 
     147                     zabe1 = rn_sponge_tra * fspu(ji,jj) * e2_e1u(ji,jj) * e3u(ji,jj,jk,Kmm_a) * umask(ji,jj,jk) 
     148                     zabe2 = rn_sponge_tra * fspv(ji,jj) * e1_e2v(ji,jj) * e3v(ji,jj,jk,Kmm_a) * vmask(ji,jj,jk) 
    147149                     ztu(ji,jj) = zabe1 * ( trbdiff(ji+1,jj  ,jk,jn) - trbdiff(ji,jj,jk,jn) ) 
    148150                     ztv(ji,jj) = zabe2 * ( trbdiff(ji  ,jj+1,jk,jn) - trbdiff(ji,jj,jk,jn) ) 
    … …  
    153155                  DO ji = i1+1,i2-1 
    154156                     IF( .NOT. tabspongedone_trn(ji,jj) ) THEN  
    155                         tra(ji,jj,jk,jn) = tra(ji,jj,jk,jn) + (  ztu(ji,jj) - ztu(ji-1,jj  )     & 
     157                        tr(ji,jj,jk,jn,Krhs_a) = tr(ji,jj,jk,jn,Krhs_a) + (  ztu(ji,jj) - ztu(ji-1,jj  )     & 
    156158                           &                                   + ztv(ji,jj) - ztv(ji  ,jj-1)  )  & 
    157                            &                                * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) 
     159                           &                                * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm_a)  & 
     160                           &                                - ztrelax * fspt(ji,jj) * trbdiff(ji,jj,jk,jn) 
    158161                     ENDIF 
    159162                  END DO 

  • NEMO/trunk/src/NST/agrif_top_update.F90

    r11078 r12377  
    1 #define TWO_WAY 
    21#undef DECAL_FEEDBACK 
    32 
    … …  
    2019   USE par_trc 
    2120   USE trc 
     21   USE vremap 
    2222 
    2323   IMPLICIT NONE 
    … …  
    4040      IF (Agrif_Root()) RETURN  
    4141      ! 
    42 #if defined TWO_WAY    
    4342      Agrif_UseSpecialValueInUpdate = .TRUE. 
    4443      Agrif_SpecialValueFineGrid    = 0._wp 
    … …  
    5352      ! 
    5453      Agrif_UseSpecialValueInUpdate = .FALSE. 
    55       ! 
    56 #endif 
    5754      ! 
    5855   END SUBROUTINE Agrif_Update_Trc 
    … …  
    6865      !! 
    6966      INTEGER :: ji,jj,jk,jn 
    70       REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk,n1:n2) :: tabres_child 
     67      REAL(wp) :: ztb, ztnu, ztno 
    7168      REAL(wp) :: h_in(k1:k2) 
    7269      REAL(wp) :: h_out(1:jpk) 
    7370      INTEGER  :: N_in, N_out 
    7471      REAL(wp) :: h_diff 
    75       REAL(wp) :: zrho_xy 
    76       REAL(wp) :: tabin(k1:k2,n1:n2) 
     72      REAL(wp) :: tabin(k1:k2,1:jptra) 
     73      REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk,1:jptra) :: tabres_child 
    7774      !!--------------------------------------------- 
    7875      ! 
    7976      IF (before) THEN 
    8077         AGRIF_SpecialValue = -999._wp 
    81          zrho_xy = Agrif_rhox() * Agrif_rhoy()  
    8278         DO jn = n1,n2-1 
    8379            DO jk=k1,k2 
    8480               DO jj=j1,j2 
    8581                  DO ji=i1,i2 
    86                      tabres(ji,jj,jk,jn) = (trn(ji,jj,jk,jn) * e3t_n(ji,jj,jk) ) & 
     82                     tabres(ji,jj,jk,jn) = (tr(ji,jj,jk,jn,Kmm_a) * e3t(ji,jj,jk,Kmm_a) ) & 
    8783                                           * tmask(ji,jj,jk) + (tmask(ji,jj,jk)-1)*999._wp 
    8884                  END DO 
    … …  
    9389            DO jj=j1,j2 
    9490               DO ji=i1,i2 
    95                   tabres(ji,jj,jk,n2) = tmask(ji,jj,jk) * e3t_n(ji,jj,jk) & 
     91                  tabres(ji,jj,jk,n2) = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kmm_a) & 
    9692                                           + (tmask(ji,jj,jk)-1)*999._wp 
    9793               END DO 
    … …  
    114110                  IF (tmask(ji,jj,jk) < -900) EXIT ! TODO: Will not work with ISF 
    115111                  N_out = N_out + 1 
    116                   h_out(N_out) = e3t_n(ji,jj,jk) !Parent grid scale factors. Could multiply by e1e2t here instead of division above 
     112                  h_out(N_out) = e3t(ji,jj,jk,Kmm_a) !Parent grid scale factors. Could multiply by e1e2t here instead of division above 
    117113               ENDDO 
    118114               IF (N_in > 0) THEN !Remove this? 
    … …  
    124120                     STOP 
    125121                  ENDIF 
    126                   DO jn=1,jptra 
    127                      CALL reconstructandremap(tabin(1:N_in,jn),h_in(1:N_in),tabres_child(ji,jj,1:N_out,jn),h_out(1:N_out),N_in,N_out) 
    128                   ENDDO 
     122                  CALL reconstructandremap(tabin(1:N_in,1:jptra),h_in(1:N_in),tabres_child(ji,jj,1:N_out,1:jptra),h_out(1:N_out),N_in,N_out,jptra) 
    129123               ENDIF 
    130124            ENDDO 
    131125         ENDDO 
    132  
     126         ! 
    133127         IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN 
    134128            ! Add asselin part 
    135129            DO jn = 1,jptra 
    136                DO jk=1,jpk 
     130               DO jk=1,jpkm1 
    137131                  DO jj=j1,j2 
    138132                     DO ji=i1,i2 
    139133                        IF( tabres_child(ji,jj,jk,jn) .NE. 0. ) THEN 
    140                            trb(ji,jj,jk,jn) = trb(ji,jj,jk,jn) &  
    141                                  & + atfp * ( tabres_child(ji,jj,jk,jn) & 
    142                                  &          - trn(ji,jj,jk,jn) ) * tmask(ji,jj,jk) 
     134                           ztb  = tr(ji,jj,jk,jn,Kbb_a) * e3t(ji,jj,jk,Kbb_a) ! fse3t_b prior update should be used 
     135                           ztnu = tabres_child(ji,jj,jk,jn) * e3t(ji,jj,jk,Kmm_a) 
     136                           ztno = tr(ji,jj,jk,jn,Kmm_a) * e3t(ji,jj,jk,Krhs_a) 
     137                           tr(ji,jj,jk,jn,Kbb_a) = ( ztb + atfp * ( ztnu - ztno) )  &  
     138                                     &        * tmask(ji,jj,jk) / e3t(ji,jj,jk,Kbb_a) 
    143139                        ENDIF 
    144140                     ENDDO 
    … …  
    148144         ENDIF 
    149145         DO jn = 1,jptra 
    150             DO jk=1,jpk 
     146            DO jk=1,jpkm1 
    151147               DO jj=j1,j2 
    152148                  DO ji=i1,i2 
    153149                     IF( tabres_child(ji,jj,jk,jn) .NE. 0. ) THEN  
    154                         trn(ji,jj,jk,jn) = tabres_child(ji,jj,jk,jn) * tmask(ji,jj,jk) 
     150                        tr(ji,jj,jk,jn,Kmm_a) = tabres_child(ji,jj,jk,jn) 
    155151                     END IF 
    156152                  END DO 
    … …  
    158154            END DO 
    159155         END DO 
     156         ! 
     157         IF  ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN 
     158            tr(i1:i2,j1:j2,1:jpkm1,1:jptra,Kbb_a)  = tr(i1:i2,j1:j2,1:jpkm1,1:jptra,Kmm_a) 
     159         ENDIF 
     160         ! 
     161 
    160162      ENDIF 
    161163      !  
    … …  
    183185                  DO ji=i1,i2 
    184186!> jc tmp 
    185                      tabres(ji,jj,jk,jn) = trn(ji,jj,jk,jn)  * e3t_n(ji,jj,jk) / e3t_0(ji,jj,jk) 
    186 !                     tabres(ji,jj,jk,jn) = trn(ji,jj,jk,jn)  * e3t_n(ji,jj,jk) 
     187                     tabres(ji,jj,jk,jn) = tr(ji,jj,jk,jn,Kmm_a)  * e3t(ji,jj,jk,Kmm_a) / e3t_0(ji,jj,jk) 
     188!                     tabres(ji,jj,jk,jn) = tr(ji,jj,jk,jn,Kmm_a)  * e3t(ji,jj,jk,Kmm_a) 
    187189!< jc tmp 
    188190                  END DO 
    … …  
    204206                     DO ji=i1,i2 
    205207                        IF( tabres(ji,jj,jk,jn) .NE. 0. ) THEN 
    206                            ztb  = trb(ji,jj,jk,jn) * e3t_b(ji,jj,jk) ! fse3t_b prior update should be used 
     208                           ztb  = tr(ji,jj,jk,jn,Kbb_a) * e3t(ji,jj,jk,Kbb_a) ! fse3t_b prior update should be used 
    207209                           ztnu = tabres(ji,jj,jk,jn) 
    208                            ztno = trn(ji,jj,jk,jn) * e3t_a(ji,jj,jk) 
    209                            trb(ji,jj,jk,jn) = ( ztb + atfp * ( ztnu - ztno) )  &  
    210                                      &        * tmask(ji,jj,jk) / e3t_b(ji,jj,jk) 
     210                           ztno = tr(ji,jj,jk,jn,Kmm_a) * e3t(ji,jj,jk,Krhs_a) 
     211                           tr(ji,jj,jk,jn,Kbb_a) = ( ztb + atfp * ( ztnu - ztno) )  &  
     212                                     &        * tmask(ji,jj,jk) / e3t(ji,jj,jk,Kbb_a) 
    211213                        ENDIF 
    212214                     ENDDO 
    … …  
    220222                  DO ji=i1,i2 
    221223                     IF( tabres(ji,jj,jk,jn) .NE. 0. ) THEN  
    222                         trn(ji,jj,jk,jn) = tabres(ji,jj,jk,jn) / e3t_n(ji,jj,jk) 
     224                        tr(ji,jj,jk,jn,Kmm_a) = tabres(ji,jj,jk,jn) / e3t(ji,jj,jk,Kmm_a) 
    223225                     END IF 
    224226                  END DO 
    … …  
    228230         ! 
    229231         IF  ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN 
    230             trb(i1:i2,j1:j2,k1:k2,n1:n2)  = trn(i1:i2,j1:j2,k1:k2,n1:n2) 
     232            tr(i1:i2,j1:j2,k1:k2,n1:n2,Kbb_a)  = tr(i1:i2,j1:j2,k1:k2,n1:n2,Kmm_a) 
    231233         ENDIF 
    232234         ! 

  • NEMO/trunk/src/NST/agrif_user.F90

    r12138 r12377  
    11#undef UPD_HIGH   /* MIX HIGH UPDATE */ 
    22#if defined key_agrif 
     3   !! * Substitutions 
     4#  include "do_loop_substitute.h90" 
    35   !!---------------------------------------------------------------------- 
    46   !! NEMO/NST 4.0 , NEMO Consortium (2018) 
    … …  
    68   !! Software governed by the CeCILL license (see ./LICENSE) 
    79   !!---------------------------------------------------------------------- 
    8 SUBROUTINE agrif_user 
    9 END SUBROUTINE agrif_user 
    10  
    11 SUBROUTINE agrif_before_regridding 
    12 END SUBROUTINE agrif_before_regridding 
    13  
    14 SUBROUTINE Agrif_InitWorkspace 
    15       !!---------------------------------------------------------------------- 
    16       !!                 *** ROUTINE Agrif_InitWorkspace *** 
    17       !!---------------------------------------------------------------------- 
    18    USE par_oce 
    19    USE dom_oce 
    20    USE nemogcm 
    21    USE mppini 
    22       !! 
    23    IMPLICIT NONE 
    24       !!---------------------------------------------------------------------- 
    25    ! 
    26    IF( .NOT. Agrif_Root() ) THEN 
    27       ! no more static variables 
    28 !!$! JC: change to allow for different vertical levels 
    29 !!$!     jpk is already set 
    30 !!$!     keep it jpk possibly different from jpkglo which  
    31 !!$!     hold parent grid vertical levels number (set earlier) 
    32 !!$!      jpk     = jpkglo  
    33    ENDIF 
    34    ! 
    35 END SUBROUTINE Agrif_InitWorkspace 
    36  
    37  
    38 SUBROUTINE Agrif_InitValues 
     10   SUBROUTINE agrif_user 
     11   END SUBROUTINE agrif_user 
     12 
     13   SUBROUTINE agrif_before_regridding 
     14   END SUBROUTINE agrif_before_regridding 
     15 
     16   SUBROUTINE Agrif_InitWorkspace 
     17   END SUBROUTINE Agrif_InitWorkspace 
     18 
     19   SUBROUTINE Agrif_InitValues 
    3920      !!---------------------------------------------------------------------- 
    4021      !!                 *** ROUTINE Agrif_InitValues *** 
    41       !! 
    42       !! ** Purpose :: Declaration of variables to be interpolated 
    43       !!---------------------------------------------------------------------- 
    44    USE Agrif_Util 
    45    USE oce  
    46    USE dom_oce 
    47    USE nemogcm 
    48    USE tradmp 
    49    USE bdy_oce   , ONLY: ln_bdy 
    50    !! 
    51    IMPLICIT NONE 
    52       !!---------------------------------------------------------------------- 
    53    ! 
    54    CALL nemo_init       !* Initializations of each fine grid 
    55  
    56    !                    !* Agrif initialization 
    57    CALL agrif_nemo_init 
    58    CALL Agrif_InitValues_cont_dom 
    59    CALL Agrif_InitValues_cont 
     22      !!---------------------------------------------------------------------- 
     23      USE nemogcm 
     24      !!---------------------------------------------------------------------- 
     25      ! 
     26      CALL nemo_init       !* Initializations of each fine grid 
     27      Kbb_a = Nbb; Kmm_a = Nnn; Krhs_a = Nrhs   ! agrif_oce module copies of time level indices 
     28      ! 
     29      !                    !* Agrif initialization 
     30      CALL agrif_nemo_init 
     31      CALL Agrif_InitValues_cont_dom 
     32      CALL Agrif_InitValues_cont 
    6033# if defined key_top 
    61    CALL Agrif_InitValues_cont_top 
     34      CALL Agrif_InitValues_cont_top 
    6235# endif 
    6336# if defined key_si3 
    64    CALL Agrif_InitValues_cont_ice 
    65 # endif 
    66    !     
    67 END SUBROUTINE Agrif_initvalues 
    68  
    69  
    70 SUBROUTINE Agrif_InitValues_cont_dom 
    71       !!---------------------------------------------------------------------- 
    72       !!                 *** ROUTINE Agrif_InitValues_cont *** 
    73       !! 
    74       !! ** Purpose ::   Declaration of variables to be interpolated 
    75       !!---------------------------------------------------------------------- 
    76    USE Agrif_Util 
    77    USE oce  
    78    USE dom_oce 
    79    USE nemogcm 
    80    USE in_out_manager 
    81    USE agrif_oce_update 
    82    USE agrif_oce_interp 
    83    USE agrif_oce_sponge 
    84    ! 
    85    IMPLICIT NONE 
    86       !!---------------------------------------------------------------------- 
    87    ! 
    88    ! Declaration of the type of variable which have to be interpolated 
    89    ! 
    90    CALL agrif_declare_var_dom 
    91    ! 
    92 END SUBROUTINE Agrif_InitValues_cont_dom 
    93  
    94  
    95 SUBROUTINE agrif_declare_var_dom 
    96       !!---------------------------------------------------------------------- 
    97       !!                 *** ROUTINE agrif_declare_var *** 
    98       !! 
    99       !! ** Purpose :: Declaration of variables to be interpolated 
    100       !!---------------------------------------------------------------------- 
    101    USE agrif_util 
    102    USE par_oce        
    103    USE oce 
    104    ! 
    105    IMPLICIT NONE 
    106    ! 
    107    INTEGER :: ind1, ind2, ind3 
     37      CALL Agrif_InitValues_cont_ice 
     38# endif 
     39      !     
     40   END SUBROUTINE Agrif_initvalues 
     41 
     42   SUBROUTINE Agrif_InitValues_cont_dom 
     43      !!---------------------------------------------------------------------- 
     44      !!                 *** ROUTINE Agrif_InitValues_cont_dom *** 
     45      !!---------------------------------------------------------------------- 
     46      ! 
     47      CALL agrif_declare_var_dom 
     48      ! 
     49   END SUBROUTINE Agrif_InitValues_cont_dom 
     50 
     51   SUBROUTINE agrif_declare_var_dom 
     52      !!---------------------------------------------------------------------- 
     53      !!                 *** ROUTINE agrif_declare_var_dom *** 
     54      !!---------------------------------------------------------------------- 
     55      USE par_oce, ONLY:  nbghostcells       
     56      ! 
     57      IMPLICIT NONE 
     58      ! 
     59      INTEGER :: ind1, ind2, ind3 
    10860      !!---------------------------------------------------------------------- 
    10961 
    11062      ! 1. Declaration of the type of variable which have to be interpolated 
    11163      !--------------------------------------------------------------------- 
    112    ind1 =     nbghostcells 
    113    ind2 = 1 + nbghostcells 
    114    ind3 = 2 + nbghostcells 
    115    CALL agrif_declare_variable((/1,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),e1u_id) 
    116    CALL agrif_declare_variable((/2,1/),(/ind3,ind2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),e2v_id) 
     64      ind1 =     nbghostcells 
     65      ind2 = 1 + nbghostcells 
     66      ind3 = 2 + nbghostcells 
     67      CALL agrif_declare_variable((/1,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),e1u_id) 
     68      CALL agrif_declare_variable((/2,1/),(/ind3,ind2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),e2v_id) 
    11769 
    11870      ! 2. Type of interpolation 
    11971      !------------------------- 
    120    CALL Agrif_Set_bcinterp( e1u_id, interp1=Agrif_linear, interp2=AGRIF_ppm    ) 
    121    CALL Agrif_Set_bcinterp( e2v_id, interp1=AGRIF_ppm   , interp2=Agrif_linear ) 
     72      CALL Agrif_Set_bcinterp( e1u_id, interp1=Agrif_linear, interp2=AGRIF_ppm    ) 
     73      CALL Agrif_Set_bcinterp( e2v_id, interp1=AGRIF_ppm   , interp2=Agrif_linear ) 
    12274 
    12375      ! 3. Location of interpolation 
    12476      !----------------------------- 
    125    CALL Agrif_Set_bc(e1u_id,(/0,ind1-1/)) 
    126    CALL Agrif_Set_bc(e2v_id,(/0,ind1-1/)) 
     77      CALL Agrif_Set_bc(e1u_id,(/0,ind1-1/)) 
     78      CALL Agrif_Set_bc(e2v_id,(/0,ind1-1/)) 
    12779 
    12880      ! 4. Update type 
    12981      !---------------  
    13082# if defined UPD_HIGH 
    131    CALL Agrif_Set_Updatetype(e1u_id,update1 = Agrif_Update_Average, update2=Agrif_Update_Full_Weighting) 
    132    CALL Agrif_Set_Updatetype(e2v_id,update1 = Agrif_Update_Full_Weighting, update2=Agrif_Update_Average) 
     83      CALL Agrif_Set_Updatetype(e1u_id,update1 = Agrif_Update_Average, update2=Agrif_Update_Full_Weighting) 
     84      CALL Agrif_Set_Updatetype(e2v_id,update1 = Agrif_Update_Full_Weighting, update2=Agrif_Update_Average) 
    13385#else 
    134    CALL Agrif_Set_Updatetype(e1u_id,update1 = Agrif_Update_Copy, update2=Agrif_Update_Average) 
    135    CALL Agrif_Set_Updatetype(e2v_id,update1 = Agrif_Update_Average, update2=Agrif_Update_Copy) 
     86      CALL Agrif_Set_Updatetype(e1u_id,update1 = Agrif_Update_Copy, update2=Agrif_Update_Average) 
     87      CALL Agrif_Set_Updatetype(e2v_id,update1 = Agrif_Update_Average, update2=Agrif_Update_Copy) 
    13688#endif 
    13789 
    138 END SUBROUTINE agrif_declare_var_dom 
    139  
    140  
    141 SUBROUTINE Agrif_InitValues_cont 
     90   END SUBROUTINE agrif_declare_var_dom 
     91 
     92   SUBROUTINE Agrif_InitValues_cont 
    14293      !!---------------------------------------------------------------------- 
    14394      !!                 *** ROUTINE Agrif_InitValues_cont *** 
    144       !! 
    145       !! ** Purpose ::   Declaration of variables to be interpolated 
    146       !!---------------------------------------------------------------------- 
    147    USE agrif_oce_update 
    148    USE agrif_oce_interp 
    149    USE agrif_oce_sponge 
    150    USE Agrif_Util 
    151    USE oce  
    152    USE dom_oce 
    153    USE zdf_oce 
    154    USE nemogcm 
    155    ! 
    156    USE lib_mpp 
    157    USE in_out_manager 
    158    ! 
    159    IMPLICIT NONE 
    160    ! 
    161    LOGICAL :: check_namelist 
    162    CHARACTER(len=15) :: cl_check1, cl_check2, cl_check3, cl_check4  
    163       !!---------------------------------------------------------------------- 
    164  
    165    ! 1. Declaration of the type of variable which have to be interpolated 
    166    !--------------------------------------------------------------------- 
    167    CALL agrif_declare_var 
    168  
    169    ! 2. First interpolations of potentially non zero fields 
    170    !------------------------------------------------------- 
    171    Agrif_SpecialValue    = 0._wp 
    172    Agrif_UseSpecialValue = .TRUE. 
    173    CALL Agrif_Bc_variable(tsn_id,calledweight=1.,procname=interptsn) 
    174    CALL Agrif_Sponge 
    175    tabspongedone_tsn = .FALSE. 
    176    CALL Agrif_Bc_variable(tsn_sponge_id,calledweight=1.,procname=interptsn_sponge) 
    177    ! reset tsa to zero 
    178    tsa(:,:,:,:) = 0. 
    179  
    180    Agrif_UseSpecialValue = ln_spc_dyn 
    181    CALL Agrif_Bc_variable(un_interp_id,calledweight=1.,procname=interpun) 
    182    CALL Agrif_Bc_variable(vn_interp_id,calledweight=1.,procname=interpvn) 
    183    tabspongedone_u = .FALSE. 
    184    tabspongedone_v = .FALSE. 
    185    CALL Agrif_Bc_variable(un_sponge_id,calledweight=1.,procname=interpun_sponge) 
    186    tabspongedone_u = .FALSE. 
    187    tabspongedone_v = .FALSE. 
    188    CALL Agrif_Bc_variable(vn_sponge_id,calledweight=1.,procname=interpvn_sponge) 
    189  
    190    Agrif_UseSpecialValue = .TRUE. 
    191    CALL Agrif_Bc_variable(sshn_id,calledweight=1., procname=interpsshn ) 
    192    hbdy_w(:,:) = 0.e0 ; hbdy_e(:,:) = 0.e0 ; hbdy_n(:,:) = 0.e0 ; hbdy_s(:,:) = 0.e0 
    193    ssha(:,:) = 0.e0 
    194  
    195    IF ( ln_dynspg_ts ) THEN 
     95      !!---------------------------------------------------------------------- 
     96      USE agrif_oce 
     97      USE agrif_oce_interp 
     98      USE agrif_oce_sponge 
     99      USE dom_oce 
     100      USE oce 
     101      USE lib_mpp 
     102      USE lbclnk 
     103      ! 
     104      IMPLICIT NONE 
     105      ! 
     106      INTEGER :: ji, jj 
     107      LOGICAL :: check_namelist 
     108      CHARACTER(len=15) :: cl_check1, cl_check2, cl_check3, cl_check4  
     109#if defined key_vertical 
     110      REAL(wp), DIMENSION(jpi,jpj) ::   zk   ! workspace 
     111#endif 
     112      !!---------------------------------------------------------------------- 
     113 
     114      ! 1. Declaration of the type of variable which have to be interpolated 
     115      !--------------------------------------------------------------------- 
     116      CALL agrif_declare_var 
     117 
     118      ! 2. First interpolations of potentially non zero fields 
     119      !------------------------------------------------------- 
     120 
     121#if defined key_vertical 
     122      ! Build consistent parent bathymetry and number of levels 
     123      ! on the child grid  
     124      Agrif_UseSpecialValue = .FALSE. 
     125      ht0_parent(:,:) = 0._wp 
     126      mbkt_parent(:,:) = 0 
     127      ! 
     128      CALL Agrif_Bc_variable(ht0_id ,calledweight=1.,procname=interpht0 ) 
     129      CALL Agrif_Bc_variable(mbkt_id,calledweight=1.,procname=interpmbkt) 
     130      ! 
     131      ! Assume step wise change of bathymetry near interface 
     132      ! TODO: Switch to linear interpolation of bathymetry in the s-coordinate case 
     133      !       and no refinement 
     134      DO_2D_10_10 
     135         mbku_parent(ji,jj) = MIN(  mbkt_parent(ji+1,jj  ) , mbkt_parent(ji,jj)  ) 
     136         mbkv_parent(ji,jj) = MIN(  mbkt_parent(ji  ,jj+1) , mbkt_parent(ji,jj)  ) 
     137      END_2D 
     138      IF ( ln_sco.AND.Agrif_Parent(ln_sco) ) THEN  
     139         DO_2D_10_10 
     140            hu0_parent(ji,jj) = 0.5_wp * ( ht0_parent(ji,jj)+ht0_parent(ji+1,jj) ) 
     141            hv0_parent(ji,jj) = 0.5_wp * ( ht0_parent(ji,jj)+ht0_parent(ji,jj+1) ) 
     142         END_2D 
     143      ELSE 
     144         DO_2D_10_10 
     145            hu0_parent(ji,jj) = MIN( ht0_parent(ji,jj), ht0_parent(ji+1,jj)) 
     146            hv0_parent(ji,jj) = MIN( ht0_parent(ji,jj), ht0_parent(ji,jj+1)) 
     147         END_2D 
     148 
     149      ENDIF 
     150      ! 
     151      CALL lbc_lnk( 'Agrif_InitValues_cont', hu0_parent, 'U', 1. ) 
     152      CALL lbc_lnk( 'Agrif_InitValues_cont', hv0_parent, 'V', 1. ) 
     153      zk(:,:) = REAL( mbku_parent(:,:), wp )   ;   CALL lbc_lnk( 'Agrif_InitValues_cont', zk, 'U', 1. ) 
     154      mbku_parent(:,:) = MAX( NINT( zk(:,:) ), 1 ) 
     155      zk(:,:) = REAL( mbkv_parent(:,:), wp )   ;   CALL lbc_lnk( 'Agrif_InitValues_cont', zk, 'V', 1. ) 
     156      mbkv_parent(:,:) = MAX( NINT( zk(:,:) ), 1 )    
     157#endif 
     158 
     159      Agrif_SpecialValue    = 0._wp 
     160      Agrif_UseSpecialValue = .TRUE. 
     161      CALL Agrif_Bc_variable(tsn_id,calledweight=1.,procname=interptsn) 
     162      CALL Agrif_Sponge 
     163      tabspongedone_tsn = .FALSE. 
     164      CALL Agrif_Bc_variable(tsn_sponge_id,calledweight=1.,procname=interptsn_sponge) 
     165      ! reset ts(:,:,:,:,Krhs_a) to zero 
     166      ts(:,:,:,:,Krhs_a) = 0._wp 
     167 
    196168      Agrif_UseSpecialValue = ln_spc_dyn 
    197       CALL Agrif_Bc_variable(unb_id,calledweight=1.,procname=interpunb) 
    198       CALL Agrif_Bc_variable(vnb_id,calledweight=1.,procname=interpvnb) 
    199       CALL Agrif_Bc_variable(ub2b_interp_id,calledweight=1.,procname=interpub2b) 
    200       CALL Agrif_Bc_variable(vb2b_interp_id,calledweight=1.,procname=interpvb2b) 
    201       ubdy_w(:,:) = 0.e0 ; vbdy_w(:,:) = 0.e0 
    202       ubdy_e(:,:) = 0.e0 ; vbdy_e(:,:) = 0.e0 
    203       ubdy_n(:,:) = 0.e0 ; vbdy_n(:,:) = 0.e0 
    204       ubdy_s(:,:) = 0.e0 ; vbdy_s(:,:) = 0.e0 
    205    ENDIF 
    206  
    207    Agrif_UseSpecialValue = .FALSE.  
    208    ! reset velocities to zero 
    209    ua(:,:,:) = 0. 
    210    va(:,:,:) = 0. 
    211  
    212    ! 3. Some controls 
    213    !----------------- 
    214    check_namelist = .TRUE. 
    215  
    216    IF( check_namelist ) THEN  
    217  
    218       ! Check time steps            
    219       IF( NINT(Agrif_Rhot()) * NINT(rdt) .NE. Agrif_Parent(rdt) ) THEN 
    220          WRITE(cl_check1,*)  NINT(Agrif_Parent(rdt)) 
    221          WRITE(cl_check2,*)  NINT(rdt) 
    222          WRITE(cl_check3,*)  NINT(Agrif_Parent(rdt)/Agrif_Rhot()) 
    223          CALL ctl_stop( 'Incompatible time step between ocean grids',   & 
    224                &               'parent grid value : '//cl_check1    ,   &  
    225                &               'child  grid value : '//cl_check2    ,   &  
    226                &               'value on child grid should be changed to : '//cl_check3 ) 
    227       ENDIF 
    228  
    229       ! Check run length 
    230       IF( Agrif_IRhot() * (Agrif_Parent(nitend)- & 
    231             Agrif_Parent(nit000)+1) .NE. (nitend-nit000+1) ) THEN 
    232          WRITE(cl_check1,*)  (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1 
    233          WRITE(cl_check2,*)   Agrif_Parent(nitend)   *Agrif_IRhot() 
    234          CALL ctl_warn( 'Incompatible run length between grids'                      ,   & 
    235                &               'nit000 on fine grid will be changed to : '//cl_check1,   & 
    236                &               'nitend on fine grid will be changed to : '//cl_check2    ) 
    237          nit000 = (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1 
    238          nitend =  Agrif_Parent(nitend)   *Agrif_IRhot() 
    239       ENDIF 
    240  
    241       ! Check free surface scheme 
    242       IF ( ( Agrif_Parent(ln_dynspg_ts ).AND.ln_dynspg_exp ).OR.& 
    243          & ( Agrif_Parent(ln_dynspg_exp).AND.ln_dynspg_ts ) ) THEN 
    244          WRITE(cl_check1,*)  Agrif_Parent( ln_dynspg_ts ) 
    245          WRITE(cl_check2,*)  ln_dynspg_ts 
    246          WRITE(cl_check3,*)  Agrif_Parent( ln_dynspg_exp ) 
    247          WRITE(cl_check4,*)  ln_dynspg_exp 
    248          CALL ctl_stop( 'Incompatible free surface scheme between grids' ,  & 
    249                &               'parent grid ln_dynspg_ts  :'//cl_check1  ,  &  
    250                &               'child  grid ln_dynspg_ts  :'//cl_check2  ,  & 
    251                &               'parent grid ln_dynspg_exp :'//cl_check3  ,  & 
    252                &               'child  grid ln_dynspg_exp :'//cl_check4  ,  & 
    253                &               'those logicals should be identical' )                  
    254          STOP 
    255       ENDIF 
    256  
    257       ! Check if identical linear free surface option 
    258       IF ( ( Agrif_Parent(ln_linssh ).AND.(.NOT.ln_linssh )).OR.& 
    259          & ( (.NOT.Agrif_Parent(ln_linssh)).AND.ln_linssh ) ) THEN 
    260          WRITE(cl_check1,*)  Agrif_Parent(ln_linssh ) 
    261          WRITE(cl_check2,*)  ln_linssh 
    262          CALL ctl_stop( 'Incompatible linearized fs option between grids',  & 
    263                &               'parent grid ln_linssh  :'//cl_check1     ,  & 
    264                &               'child  grid ln_linssh  :'//cl_check2     ,  & 
    265                &               'those logicals should be identical' )                   
    266          STOP 
     169      CALL Agrif_Bc_variable(un_interp_id,calledweight=1.,procname=interpun) 
     170      CALL Agrif_Bc_variable(vn_interp_id,calledweight=1.,procname=interpvn) 
     171      tabspongedone_u = .FALSE. 
     172      tabspongedone_v = .FALSE. 
     173      CALL Agrif_Bc_variable(un_sponge_id,calledweight=1.,procname=interpun_sponge) 
     174      tabspongedone_u = .FALSE. 
     175      tabspongedone_v = .FALSE. 
     176      CALL Agrif_Bc_variable(vn_sponge_id,calledweight=1.,procname=interpvn_sponge) 
     177      uu(:,:,:,Krhs_a) = 0._wp 
     178      vv(:,:,:,Krhs_a) = 0._wp 
     179 
     180      Agrif_UseSpecialValue = .TRUE. 
     181      CALL Agrif_Bc_variable(sshn_id,calledweight=1., procname=interpsshn ) 
     182      hbdy(:,:) = 0._wp 
     183      ssh(:,:,Krhs_a) = 0._wp 
     184 
     185      IF ( ln_dynspg_ts ) THEN 
     186         Agrif_UseSpecialValue = ln_spc_dyn 
     187         CALL Agrif_Bc_variable(unb_id,calledweight=1.,procname=interpunb) 
     188         CALL Agrif_Bc_variable(vnb_id,calledweight=1.,procname=interpvnb) 
     189         CALL Agrif_Bc_variable(ub2b_interp_id,calledweight=1.,procname=interpub2b) 
     190         CALL Agrif_Bc_variable(vb2b_interp_id,calledweight=1.,procname=interpvb2b) 
     191         ubdy(:,:) = 0._wp 
     192         vbdy(:,:) = 0._wp 
     193      ENDIF 
     194 
     195      Agrif_UseSpecialValue = .FALSE. 
     196 
     197      ! 3. Some controls 
     198      !----------------- 
     199      check_namelist = .TRUE. 
     200 
     201      IF( check_namelist ) THEN  
     202 
     203         ! Check time steps            
     204         IF( NINT(Agrif_Rhot()) * NINT(rdt) .NE. Agrif_Parent(rdt) ) THEN 
     205            WRITE(cl_check1,*)  NINT(Agrif_Parent(rdt)) 
     206            WRITE(cl_check2,*)  NINT(rdt) 
     207            WRITE(cl_check3,*)  NINT(Agrif_Parent(rdt)/Agrif_Rhot()) 
     208            CALL ctl_stop( 'Incompatible time step between ocean grids',   & 
     209                  &               'parent grid value : '//cl_check1    ,   &  
     210                  &               'child  grid value : '//cl_check2    ,   &  
     211                  &               'value on child grid should be changed to : '//cl_check3 ) 
     212         ENDIF 
     213 
     214         ! Check run length 
     215         IF( Agrif_IRhot() * (Agrif_Parent(nitend)- & 
     216               Agrif_Parent(nit000)+1) .NE. (nitend-nit000+1) ) THEN 
     217            WRITE(cl_check1,*)  (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1 
     218            WRITE(cl_check2,*)   Agrif_Parent(nitend)   *Agrif_IRhot() 
     219            CALL ctl_warn( 'Incompatible run length between grids'                      ,   & 
     220                  &               'nit000 on fine grid will be changed to : '//cl_check1,   & 
     221                  &               'nitend on fine grid will be changed to : '//cl_check2    ) 
     222            nit000 = (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1 
     223            nitend =  Agrif_Parent(nitend)   *Agrif_IRhot() 
     224         ENDIF 
     225 
     226         ! Check free surface scheme 
     227         IF ( ( Agrif_Parent(ln_dynspg_ts ).AND.ln_dynspg_exp ).OR.& 
     228            & ( Agrif_Parent(ln_dynspg_exp).AND.ln_dynspg_ts ) ) THEN 
     229            WRITE(cl_check1,*)  Agrif_Parent( ln_dynspg_ts ) 
     230            WRITE(cl_check2,*)  ln_dynspg_ts 
     231            WRITE(cl_check3,*)  Agrif_Parent( ln_dynspg_exp ) 
     232            WRITE(cl_check4,*)  ln_dynspg_exp 
     233            CALL ctl_stop( 'Incompatible free surface scheme between grids' ,  & 
     234                  &               'parent grid ln_dynspg_ts  :'//cl_check1  ,  &  
     235                  &               'child  grid ln_dynspg_ts  :'//cl_check2  ,  & 
     236                  &               'parent grid ln_dynspg_exp :'//cl_check3  ,  & 
     237                  &               'child  grid ln_dynspg_exp :'//cl_check4  ,  & 
     238                  &               'those logicals should be identical' )                  
     239            STOP 
     240         ENDIF 
     241 
     242         ! Check if identical linear free surface option 
     243         IF ( ( Agrif_Parent(ln_linssh ).AND.(.NOT.ln_linssh )).OR.& 
     244            & ( (.NOT.Agrif_Parent(ln_linssh)).AND.ln_linssh ) ) THEN 
     245            WRITE(cl_check1,*)  Agrif_Parent(ln_linssh ) 
     246            WRITE(cl_check2,*)  ln_linssh 
     247            CALL ctl_stop( 'Incompatible linearized fs option between grids',  & 
     248                  &               'parent grid ln_linssh  :'//cl_check1     ,  & 
     249                  &               'child  grid ln_linssh  :'//cl_check2     ,  & 
     250                  &               'those logicals should be identical' )                   
     251            STOP 
     252         ENDIF 
     253 
    267254      ENDIF 
    268255 
    269256      ! check if masks and bathymetries match 
    270257      IF(ln_chk_bathy) THEN 
     258         Agrif_UseSpecialValue = .FALSE. 
    271259         ! 
     260         IF(lwp) WRITE(numout,*) ' ' 
    272261         IF(lwp) WRITE(numout,*) 'AGRIF: Check Bathymetry and masks near bdys. Level: ', Agrif_Level() 
    273262         ! 
    274263         kindic_agr = 0 
    275          ! check if umask agree with parent along western and eastern boundaries: 
    276          CALL Agrif_Bc_variable(umsk_id,calledweight=1.,procname=interpumsk) 
    277          ! check if vmask agree with parent along northern and southern boundaries: 
    278          CALL Agrif_Bc_variable(vmsk_id,calledweight=1.,procname=interpvmsk) 
    279          ! check if tmask and vertical scale factors agree with parent over first two coarse grid points: 
     264# if ! defined key_vertical 
     265         ! 
     266         ! check if tmask and vertical scale factors agree with parent in sponge area: 
    280267         CALL Agrif_Bc_variable(e3t_id,calledweight=1.,procname=interpe3t) 
    281268         ! 
     269# else 
     270         ! 
     271         ! In case of vertical interpolation, check only that total depths agree between child and parent: 
     272         DO ji = 1, jpi 
     273            DO jj = 1, jpj 
     274               IF ((mbkt_parent(ji,jj)/=0).AND.(ABS(ht0_parent(ji,jj)-ht_0(ji,jj))>1.e-3)) kindic_agr = kindic_agr + 1 
     275               IF ((mbku_parent(ji,jj)/=0).AND.(ABS(hu0_parent(ji,jj)-hu_0(ji,jj))>1.e-3)) kindic_agr = kindic_agr + 1 
     276               IF ((mbkv_parent(ji,jj)/=0).AND.(ABS(hv0_parent(ji,jj)-hv_0(ji,jj))>1.e-3)) kindic_agr = kindic_agr + 1 
     277            END DO 
     278         END DO 
     279# endif 
    282280         CALL mpp_sum( 'agrif_user', kindic_agr ) 
    283281         IF( kindic_agr /= 0 ) THEN 
    284             CALL ctl_stop('Child Bathymetry is not correct near boundaries.') 
     282            CALL ctl_stop('==> Child Bathymetry is NOT correct near boundaries.') 
    285283         ELSE 
    286             IF(lwp) WRITE(numout,*) 'Child Bathymetry is ok near boundaries.' 
    287          END IF 
    288       ENDIF 
    289       ! 
    290    ENDIF 
    291    !  
    292 END SUBROUTINE Agrif_InitValues_cont 
    293  
    294 SUBROUTINE agrif_declare_var 
    295       !!---------------------------------------------------------------------- 
    296       !!                 *** ROUTINE agrif_declarE_var *** 
    297       !! 
    298       !! ** Purpose :: Declaration of variables to be interpolated 
    299       !!---------------------------------------------------------------------- 
    300    USE agrif_util 
    301    USE agrif_oce 
    302    USE par_oce       ! ocean parameters 
    303    USE zdf_oce       ! vertical physics 
    304    USE oce 
    305    ! 
    306    IMPLICIT NONE 
    307    ! 
    308    INTEGER :: ind1, ind2, ind3 
    309       !!---------------------------------------------------------------------- 
    310  
    311    ! 1. Declaration of the type of variable which have to be interpolated 
    312    !--------------------------------------------------------------------- 
    313    ind1 =     nbghostcells 
    314    ind2 = 1 + nbghostcells 
    315    ind3 = 2 + nbghostcells 
     284            IF(lwp) WRITE(numout,*) '==> Child Bathymetry is ok near boundaries.' 
     285            IF(lwp) WRITE(numout,*) ' ' 
     286         END IF   
     287         !     
     288      ENDIF 
     289 
    316290# if defined key_vertical 
    317    CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jpts+1/),tsn_id) 
    318    CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jpts+1/),tsn_sponge_id) 
    319  
    320    CALL agrif_declare_variable((/1,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,2/),un_interp_id) 
    321    CALL agrif_declare_variable((/2,1,0,0/),(/ind3,ind2,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,2/),vn_interp_id) 
    322    CALL agrif_declare_variable((/1,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,2/),un_update_id) 
    323    CALL agrif_declare_variable((/2,1,0,0/),(/ind3,ind2,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,2/),vn_update_id) 
    324    CALL agrif_declare_variable((/1,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,2/),un_sponge_id) 
    325    CALL agrif_declare_variable((/2,1,0,0/),(/ind3,ind2,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,2/),vn_sponge_id) 
     291      ! Additional constrain that should be removed someday: 
     292      IF ( Agrif_Parent(jpk).GT.jpk ) THEN 
     293    CALL ctl_stop( ' With key_vertical, child grids must have jpk greater or equal to the parent value' ) 
     294      ENDIF 
     295# endif 
     296      !  
     297   END SUBROUTINE Agrif_InitValues_cont 
     298 
     299   SUBROUTINE agrif_declare_var 
     300      !!---------------------------------------------------------------------- 
     301      !!                 *** ROUTINE agrif_declare_var *** 
     302      !!---------------------------------------------------------------------- 
     303      USE agrif_util 
     304      USE agrif_oce 
     305      USE par_oce 
     306      USE zdf_oce  
     307      USE oce 
     308      ! 
     309      IMPLICIT NONE 
     310      ! 
     311      INTEGER :: ind1, ind2, ind3 
     312      !!---------------------------------------------------------------------- 
     313 
     314      ! 1. Declaration of the type of variable which have to be interpolated 
     315      !--------------------------------------------------------------------- 
     316      ind1 =     nbghostcells 
     317      ind2 = 1 + nbghostcells 
     318      ind3 = 2 + nbghostcells 
     319# if defined key_vertical 
     320      CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jpts+1/),tsn_id) 
     321      CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jpts+1/),tsn_sponge_id) 
     322 
     323      CALL agrif_declare_variable((/1,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,2/),un_interp_id) 
     324      CALL agrif_declare_variable((/2,1,0,0/),(/ind3,ind2,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,2/),vn_interp_id) 
     325      CALL agrif_declare_variable((/1,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,2/),un_update_id) 
     326      CALL agrif_declare_variable((/2,1,0,0/),(/ind3,ind2,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,2/),vn_update_id) 
     327      CALL agrif_declare_variable((/1,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,2/),un_sponge_id) 
     328      CALL agrif_declare_variable((/2,1,0,0/),(/ind3,ind2,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,2/),vn_sponge_id) 
    326329# else 
    327    CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jpts/),tsn_id) 
    328    CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jpts/),tsn_sponge_id) 
    329  
    330    CALL agrif_declare_variable((/1,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,1/),un_interp_id) 
    331    CALL agrif_declare_variable((/2,1,0,0/),(/ind3,ind2,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,1/),vn_interp_id) 
    332    CALL agrif_declare_variable((/1,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,1/),un_update_id) 
    333    CALL agrif_declare_variable((/2,1,0,0/),(/ind3,ind2,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,1/),vn_update_id) 
    334    CALL agrif_declare_variable((/1,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,1/),un_sponge_id) 
    335    CALL agrif_declare_variable((/2,1,0,0/),(/ind3,ind2,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,1/),vn_sponge_id) 
    336 # endif 
    337  
    338    CALL agrif_declare_variable((/2,2,0/),(/ind3,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),e3t_id) 
    339    CALL agrif_declare_variable((/1,2,0/),(/ind2,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),umsk_id) 
    340    CALL agrif_declare_variable((/2,1,0/),(/ind3,ind2,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),vmsk_id) 
    341  
    342    CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,3/),scales_t_id) 
    343  
    344    CALL agrif_declare_variable((/1,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),unb_id) 
    345    CALL agrif_declare_variable((/2,1/),(/ind3,ind2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),vnb_id) 
    346    CALL agrif_declare_variable((/1,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),ub2b_interp_id) 
    347    CALL agrif_declare_variable((/2,1/),(/ind3,ind2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),vb2b_interp_id) 
    348    CALL agrif_declare_variable((/1,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),ub2b_update_id) 
    349    CALL agrif_declare_variable((/2,1/),(/ind3,ind2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),vb2b_update_id) 
    350  
    351    CALL agrif_declare_variable((/2,2/),(/ind3,ind3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),sshn_id) 
    352  
    353    IF( ln_zdftke.OR.ln_zdfgls ) THEN 
    354 !      CALL agrif_declare_variable((/2,2,0/),(/ind3,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/), en_id) 
    355 !      CALL agrif_declare_variable((/2,2,0/),(/ind3,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),avt_id) 
     330      CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jpts/),tsn_id) 
     331      CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jpts/),tsn_sponge_id) 
     332 
     333      CALL agrif_declare_variable((/1,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,1/),un_interp_id) 
     334      CALL agrif_declare_variable((/2,1,0,0/),(/ind3,ind2,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,1/),vn_interp_id) 
     335      CALL agrif_declare_variable((/1,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,1/),un_update_id) 
     336      CALL agrif_declare_variable((/2,1,0,0/),(/ind3,ind2,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,1/),vn_update_id) 
     337      CALL agrif_declare_variable((/1,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,1/),un_sponge_id) 
     338      CALL agrif_declare_variable((/2,1,0,0/),(/ind3,ind2,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,1/),vn_sponge_id) 
     339# endif 
     340 
     341      CALL agrif_declare_variable((/2,2,0/),(/ind3,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),e3t_id) 
     342 
    356343# if defined key_vertical 
    357       CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,2/),avm_id) 
     344      CALL agrif_declare_variable((/2,2/),(/ind3,ind3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),mbkt_id) 
     345      CALL agrif_declare_variable((/2,2/),(/ind3,ind3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),ht0_id) 
     346# endif 
     347 
     348      CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,3/),scales_t_id) 
     349 
     350      CALL agrif_declare_variable((/1,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),unb_id) 
     351      CALL agrif_declare_variable((/2,1/),(/ind3,ind2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),vnb_id) 
     352      CALL agrif_declare_variable((/1,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),ub2b_interp_id) 
     353      CALL agrif_declare_variable((/2,1/),(/ind3,ind2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),vb2b_interp_id) 
     354      CALL agrif_declare_variable((/1,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),ub2b_update_id) 
     355      CALL agrif_declare_variable((/2,1/),(/ind3,ind2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),vb2b_update_id) 
     356 
     357      CALL agrif_declare_variable((/2,2/),(/ind3,ind3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),sshn_id) 
     358 
     359      IF( ln_zdftke.OR.ln_zdfgls ) THEN 
     360!         CALL agrif_declare_variable((/2,2,0/),(/ind3,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/), en_id) 
     361!         CALL agrif_declare_variable((/2,2,0/),(/ind3,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),avt_id) 
     362# if defined key_vertical 
     363         CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,2/),avm_id) 
    358364# else 
    359       CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,1/),avm_id) 
    360 # endif 
    361    ENDIF 
    362  
    363    ! 2. Type of interpolation 
    364    !------------------------- 
    365    CALL Agrif_Set_bcinterp(tsn_id,interp=AGRIF_linear) 
    366  
    367    CALL Agrif_Set_bcinterp(un_interp_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
    368    CALL Agrif_Set_bcinterp(vn_interp_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
    369  
    370    CALL Agrif_Set_bcinterp(tsn_sponge_id,interp=AGRIF_linear) 
    371  
    372    CALL Agrif_Set_bcinterp(sshn_id,interp=AGRIF_linear) 
    373    CALL Agrif_Set_bcinterp(unb_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
    374    CALL Agrif_Set_bcinterp(vnb_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
    375    CALL Agrif_Set_bcinterp(ub2b_interp_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
    376    CALL Agrif_Set_bcinterp(vb2b_interp_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
    377  
    378  
    379    CALL Agrif_Set_bcinterp(un_sponge_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
    380    CALL Agrif_Set_bcinterp(vn_sponge_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
    381  
    382    CALL Agrif_Set_bcinterp(e3t_id,interp=AGRIF_constant) 
    383    CALL Agrif_Set_bcinterp(umsk_id,interp=AGRIF_constant) 
    384    CALL Agrif_Set_bcinterp(vmsk_id,interp=AGRIF_constant) 
    385  
    386    IF( ln_zdftke.OR.ln_zdfgls )   CALL Agrif_Set_bcinterp( avm_id, interp=AGRIF_linear ) 
    387  
    388    ! 3. Location of interpolation 
    389    !----------------------------- 
    390    CALL Agrif_Set_bc(       tsn_id, (/0,ind1/) ) 
    391    CALL Agrif_Set_bc( un_interp_id, (/0,ind1/) ) 
    392    CALL Agrif_Set_bc( vn_interp_id, (/0,ind1/) ) 
    393  
    394    CALL Agrif_Set_bc( tsn_sponge_id, (/-nn_sponge_len*Agrif_irhox()-1,0/) )  ! if west and rhox=3 and sponge=2 and ghost=1: columns 2 to 9  
    395    CALL Agrif_Set_bc(  un_sponge_id, (/-nn_sponge_len*Agrif_irhox()-1,0/) ) 
    396    CALL Agrif_Set_bc(  vn_sponge_id, (/-nn_sponge_len*Agrif_irhox()-1,0/) ) 
    397  
    398    CALL Agrif_Set_bc(        sshn_id, (/0,ind1-1/) ) 
    399    CALL Agrif_Set_bc(         unb_id, (/0,ind1-1/) ) 
    400    CALL Agrif_Set_bc(         vnb_id, (/0,ind1-1/) ) 
    401    CALL Agrif_Set_bc( ub2b_interp_id, (/0,ind1-1/) ) 
    402    CALL Agrif_Set_bc( vb2b_interp_id, (/0,ind1-1/) ) 
    403  
    404    CALL Agrif_Set_bc(  e3t_id, (/-nn_sponge_len*Agrif_irhox(),ind1-1/) )   ! if west and rhox=3 and ghost=1: column 2 to 6  
    405    CALL Agrif_Set_bc( umsk_id, (/0,0/) ) 
    406    CALL Agrif_Set_bc( vmsk_id, (/0,0/) ) 
    407  
    408  
    409    IF( ln_zdftke.OR.ln_zdfgls )   CALL Agrif_Set_bc( avm_id, (/0,ind1/) ) 
    410  
    411    ! 4. Update type 
    412    !---------------  
    413    CALL Agrif_Set_Updatetype(scales_t_id, update = AGRIF_Update_Average) 
     365         CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,1/),avm_id) 
     366# endif 
     367      ENDIF 
     368 
     369      ! 2. Type of interpolation 
     370      !------------------------- 
     371      CALL Agrif_Set_bcinterp(tsn_id,interp=AGRIF_linear) 
     372 
     373      CALL Agrif_Set_bcinterp(un_interp_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
     374      CALL Agrif_Set_bcinterp(vn_interp_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
     375 
     376      CALL Agrif_Set_bcinterp(tsn_sponge_id,interp=AGRIF_linear) 
     377 
     378      CALL Agrif_Set_bcinterp(sshn_id,interp=AGRIF_linear) 
     379      CALL Agrif_Set_bcinterp(unb_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
     380      CALL Agrif_Set_bcinterp(vnb_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
     381      CALL Agrif_Set_bcinterp(ub2b_interp_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
     382      CALL Agrif_Set_bcinterp(vb2b_interp_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
     383! 
     384! > Divergence conserving alternative: 
     385!      CALL Agrif_Set_bcinterp(sshn_id,interp=AGRIF_constant) 
     386!      CALL Agrif_Set_bcinterp(unb_id,interp1=Agrif_linear,interp2=AGRIF_constant) 
     387!      CALL Agrif_Set_bcinterp(vnb_id,interp1=AGRIF_constant,interp2=Agrif_linear) 
     388!      CALL Agrif_Set_bcinterp(ub2b_interp_id,interp1=Agrif_linear,interp2=AGRIF_constant) 
     389!      CALL Agrif_Set_bcinterp(vb2b_interp_id,interp1=AGRIF_constant,interp2=Agrif_linear) 
     390!< 
     391 
     392      CALL Agrif_Set_bcinterp(un_sponge_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
     393      CALL Agrif_Set_bcinterp(vn_sponge_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
     394 
     395      CALL Agrif_Set_bcinterp(e3t_id,interp=AGRIF_constant) 
     396 
     397# if defined key_vertical 
     398      CALL Agrif_Set_bcinterp(mbkt_id,interp=AGRIF_constant) 
     399      CALL Agrif_Set_bcinterp(ht0_id ,interp=AGRIF_constant) 
     400# endif 
     401 
     402      IF( ln_zdftke.OR.ln_zdfgls )   CALL Agrif_Set_bcinterp( avm_id, interp=AGRIF_linear ) 
     403 
     404      ! 3. Location of interpolation 
     405      !----------------------------- 
     406      CALL Agrif_Set_bc(       tsn_id, (/0,ind1-1/) ) ! if west,  rhox=3 and nbghost=3: columns 2 to 4 
     407      CALL Agrif_Set_bc( un_interp_id, (/0,ind1-1/) )  
     408      CALL Agrif_Set_bc( vn_interp_id, (/0,ind1-1/) ) 
     409 
     410      CALL Agrif_Set_bc( tsn_sponge_id, (/-nn_sponge_len*Agrif_irhox()-1,0/) )  ! if west,  rhox=3, nn_sponge_len=2  
     411      CALL Agrif_Set_bc(  un_sponge_id, (/-nn_sponge_len*Agrif_irhox()-1,0/) )  ! and nbghost=3:  
     412      CALL Agrif_Set_bc(  vn_sponge_id, (/-nn_sponge_len*Agrif_irhox()-1,0/) )  ! columns 4 to 11 
     413 
     414      CALL Agrif_Set_bc(        sshn_id, (/0,ind1-1/) ) 
     415      CALL Agrif_Set_bc(         unb_id, (/0,ind1-1/) ) 
     416      CALL Agrif_Set_bc(         vnb_id, (/0,ind1-1/) ) 
     417      CALL Agrif_Set_bc( ub2b_interp_id, (/0,ind1-1/) ) 
     418      CALL Agrif_Set_bc( vb2b_interp_id, (/0,ind1-1/) ) 
     419 
     420!      CALL Agrif_Set_bc(  e3t_id, (/-nn_sponge_len*Agrif_irhox(),ind1-1/) )   
     421! JC: check near the boundary only until matching in sponge has been sorted out: 
     422      CALL Agrif_Set_bc(  e3t_id, (/0,ind1-1/) )   
     423 
     424# if defined key_vertical  
     425      ! extend the interpolation zone by 1 more point than necessary: 
     426      CALL Agrif_Set_bc(  mbkt_id, (/-nn_sponge_len*Agrif_irhox()-2,ind1/) ) 
     427      CALL Agrif_Set_bc(  ht0_id,  (/-nn_sponge_len*Agrif_irhox()-2,ind1/) ) 
     428# endif 
     429 
     430      IF( ln_zdftke.OR.ln_zdfgls )   CALL Agrif_Set_bc( avm_id, (/0,ind1/) ) 
     431 
     432      ! 4. Update type 
     433      !---------------  
     434      CALL Agrif_Set_Updatetype(scales_t_id, update = AGRIF_Update_Average) 
    414435 
    415436# if defined UPD_HIGH 
    416    CALL Agrif_Set_Updatetype(tsn_id, update = Agrif_Update_Full_Weighting) 
    417    CALL Agrif_Set_Updatetype(un_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Full_Weighting) 
    418    CALL Agrif_Set_Updatetype(vn_update_id,update1 = Agrif_Update_Full_Weighting, update2 = Agrif_Update_Average) 
    419  
    420    CALL Agrif_Set_Updatetype(ub2b_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Full_Weighting) 
    421    CALL Agrif_Set_Updatetype(vb2b_update_id,update1 = Agrif_Update_Full_Weighting, update2 = Agrif_Update_Average) 
    422    CALL Agrif_Set_Updatetype(sshn_id, update = Agrif_Update_Full_Weighting) 
    423    CALL Agrif_Set_Updatetype(e3t_id, update = Agrif_Update_Full_Weighting) 
    424  
    425    IF( ln_zdftke.OR.ln_zdfgls ) THEN 
    426 !      CALL Agrif_Set_Updatetype( en_id, update = AGRIF_Update_Full_Weighting) 
    427 !      CALL Agrif_Set_Updatetype(avt_id, update = AGRIF_Update_Full_Weighting) 
    428 !      CALL Agrif_Set_Updatetype(avm_id, update = AGRIF_Update_Full_Weighting) 
    429    ENDIF 
     437      CALL Agrif_Set_Updatetype(tsn_id, update = Agrif_Update_Full_Weighting) 
     438      CALL Agrif_Set_Updatetype(un_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Full_Weighting) 
     439      CALL Agrif_Set_Updatetype(vn_update_id,update1 = Agrif_Update_Full_Weighting, update2 = Agrif_Update_Average) 
     440 
     441      CALL Agrif_Set_Updatetype(ub2b_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Full_Weighting) 
     442      CALL Agrif_Set_Updatetype(vb2b_update_id,update1 = Agrif_Update_Full_Weighting, update2 = Agrif_Update_Average) 
     443      CALL Agrif_Set_Updatetype(sshn_id,update = Agrif_Update_Full_Weighting) 
     444      CALL Agrif_Set_Updatetype(e3t_id, update = Agrif_Update_Full_Weighting) 
     445 
     446      IF( ln_zdftke.OR.ln_zdfgls ) THEN 
     447!         CALL Agrif_Set_Updatetype( en_id, update = AGRIF_Update_Full_Weighting) 
     448!         CALL Agrif_Set_Updatetype(avt_id, update = AGRIF_Update_Full_Weighting) 
     449!         CALL Agrif_Set_Updatetype(avm_id, update = AGRIF_Update_Full_Weighting) 
     450      ENDIF 
    430451 
    431452#else 
    432    CALL Agrif_Set_Updatetype(tsn_id, update = AGRIF_Update_Average) 
    433    CALL Agrif_Set_Updatetype(un_update_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average) 
    434    CALL Agrif_Set_Updatetype(vn_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy) 
    435  
    436    CALL Agrif_Set_Updatetype(ub2b_update_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average) 
    437    CALL Agrif_Set_Updatetype(vb2b_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy) 
    438    CALL Agrif_Set_Updatetype(sshn_id, update = AGRIF_Update_Average) 
    439    CALL Agrif_Set_Updatetype(e3t_id, update = AGRIF_Update_Average) 
    440  
    441    IF( ln_zdftke.OR.ln_zdfgls ) THEN 
    442 !      CALL Agrif_Set_Updatetype( en_id, update = AGRIF_Update_Average) 
    443 !      CALL Agrif_Set_Updatetype(avt_id, update = AGRIF_Update_Average) 
    444 !      CALL Agrif_Set_Updatetype(avm_id, update = AGRIF_Update_Average) 
    445    ENDIF 
     453      CALL Agrif_Set_Updatetype(tsn_id, update = AGRIF_Update_Average) 
     454      CALL Agrif_Set_Updatetype(un_update_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average) 
     455      CALL Agrif_Set_Updatetype(vn_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy) 
     456 
     457      CALL Agrif_Set_Updatetype(ub2b_update_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average) 
     458      CALL Agrif_Set_Updatetype(vb2b_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy) 
     459      CALL Agrif_Set_Updatetype(sshn_id,update = AGRIF_Update_Average) 
     460      CALL Agrif_Set_Updatetype(e3t_id, update = AGRIF_Update_Average) 
     461 
     462      IF( ln_zdftke.OR.ln_zdfgls ) THEN 
     463!         CALL Agrif_Set_Updatetype( en_id, update = AGRIF_Update_Average) 
     464!         CALL Agrif_Set_Updatetype(avt_id, update = AGRIF_Update_Average) 
     465!         CALL Agrif_Set_Updatetype(avm_id, update = AGRIF_Update_Average) 
     466      ENDIF 
    446467 
    447468#endif 
    448    ! 
    449 END SUBROUTINE agrif_declare_var 
     469      ! 
     470   END SUBROUTINE agrif_declare_var 
    450471 
    451472#if defined key_si3 
    … …  
    453474      !!---------------------------------------------------------------------- 
    454475      !!                 *** ROUTINE Agrif_InitValues_cont_ice *** 
     476      !!---------------------------------------------------------------------- 
     477      USE Agrif_Util 
     478      USE sbc_oce, ONLY : nn_fsbc  ! clem: necessary otherwise Agrif_Parent(nn_fsbc) = nn_fsbc 
     479      USE ice 
     480      USE agrif_ice 
     481      USE in_out_manager 
     482      USE agrif_ice_interp 
     483      USE lib_mpp 
     484      ! 
     485      IMPLICIT NONE 
     486      !!---------------------------------------------------------------------- 
     487      ! 
     488      ! Declaration of the type of variable which have to be interpolated (parent=>child) 
     489      !---------------------------------------------------------------------------------- 
     490      CALL agrif_declare_var_ice 
     491 
     492      ! Controls 
     493 
     494      ! clem: For some reason, nn_fsbc(child)/=1 does not work properly (signal can be largely degraded by the agrif zoom) 
     495      !          the run must satisfy CFL=Uice/(dx/dt) < 0.6/nn_fsbc(child) 
     496      !          therefore, if nn_fsbc(child)>1 one must reduce the time-step in proportion to nn_fsbc(child), which is not acceptable 
     497      !       If a solution is found, the following stop could be removed because the rest of the code take nn_fsbc(child) into account 
     498      IF( nn_fsbc > 1 )  CALL ctl_stop('nn_fsbc(child) must be set to 1 otherwise agrif and sea-ice may not work properly') 
     499 
     500      ! stop if rhot * nn_fsbc(parent) /= N * nn_fsbc(child) with N being integer 
     501      IF( MOD( Agrif_irhot() * Agrif_Parent(nn_fsbc), nn_fsbc ) /= 0 )  THEN 
     502         CALL ctl_stop('rhot * nn_fsbc(parent) /= N * nn_fsbc(child), therefore nn_fsbc(child) should be set to 1 or nn_fsbc(parent)') 
     503      ENDIF 
     504      ! First Interpolations (using "after" ice subtime step => nbstep_ice=1) 
     505      !---------------------------------------------------------------------- 
     506      nbstep_ice = ( Agrif_irhot() * Agrif_Parent(nn_fsbc) / nn_fsbc ) ! clem: to have calledweight=1 in interp (otherwise the western border of the zoom is wrong) 
     507      CALL agrif_interp_ice('U') ! interpolation of ice velocities 
     508      CALL agrif_interp_ice('V') ! interpolation of ice velocities 
     509      CALL agrif_interp_ice('T') ! interpolation of ice tracers  
     510      nbstep_ice = 0    
     511      ! 
     512   END SUBROUTINE Agrif_InitValues_cont_ice 
     513 
     514   SUBROUTINE agrif_declare_var_ice 
     515      !!---------------------------------------------------------------------- 
     516      !!                 *** ROUTINE agrif_declare_var_ice *** 
     517      !!---------------------------------------------------------------------- 
     518      USE Agrif_Util 
     519      USE ice 
     520      USE par_oce, ONLY : nbghostcells 
     521      ! 
     522      IMPLICIT NONE 
     523      ! 
     524      INTEGER :: ind1, ind2, ind3 
     525      !!---------------------------------------------------------------------- 
     526      ! 
     527      ! 1. Declaration of the type of variable which have to be interpolated (parent=>child) 
     528      !       agrif_declare_variable(position,1st point index,--,--,dimensions,name) 
     529      !           ex.:  position=> 1,1 = not-centered (in i and j) 
     530      !                            2,2 =     centered (    -     ) 
     531      !                 index   => 1,1 = one ghost line 
     532      !                            2,2 = two ghost lines 
     533      !------------------------------------------------------------------------------------- 
     534      ind1 =     nbghostcells 
     535      ind2 = 1 + nbghostcells 
     536      ind3 = 2 + nbghostcells 
     537      CALL agrif_declare_variable((/2,2,0/),(/ind3,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpl*(8+nlay_s+nlay_i)/),tra_ice_id) 
     538      CALL agrif_declare_variable((/1,2/)  ,(/ind2,ind3/)  ,(/'x','y'/)    ,(/1,1/)  ,(/nlci,nlcj/)                      ,u_ice_id  ) 
     539      CALL agrif_declare_variable((/2,1/)  ,(/ind3,ind2/)  ,(/'x','y'/)    ,(/1,1/)  ,(/nlci,nlcj/)                      ,v_ice_id  ) 
     540 
     541      ! 2. Set interpolations (normal & tangent to the grid cell for velocities) 
     542      !----------------------------------- 
     543      CALL Agrif_Set_bcinterp(tra_ice_id, interp  = AGRIF_linear) 
     544      CALL Agrif_Set_bcinterp(u_ice_id  , interp1 = Agrif_linear,interp2 = AGRIF_ppm   ) 
     545      CALL Agrif_Set_bcinterp(v_ice_id  , interp1 = AGRIF_ppm   ,interp2 = Agrif_linear) 
     546 
     547      ! 3. Set location of interpolations 
     548      !---------------------------------- 
     549      CALL Agrif_Set_bc(tra_ice_id,(/0,ind1/)) 
     550      CALL Agrif_Set_bc(u_ice_id  ,(/0,ind1/)) 
     551      CALL Agrif_Set_bc(v_ice_id  ,(/0,ind1/)) 
     552 
     553      ! 4. Set update type in case 2 ways (child=>parent) (normal & tangent to the grid cell for velocities) 
     554      !-------------------------------------------------- 
     555# if defined UPD_HIGH 
     556      CALL Agrif_Set_Updatetype(tra_ice_id, update  = Agrif_Update_Full_Weighting) 
     557      CALL Agrif_Set_Updatetype(u_ice_id  , update1 = Agrif_Update_Average       , update2 = Agrif_Update_Full_Weighting) 
     558      CALL Agrif_Set_Updatetype(v_ice_id  , update1 = Agrif_Update_Full_Weighting, update2 = Agrif_Update_Average       ) 
     559#else 
     560      CALL Agrif_Set_Updatetype(tra_ice_id, update  = AGRIF_Update_Average) 
     561      CALL Agrif_Set_Updatetype(u_ice_id  , update1 = Agrif_Update_Copy   , update2 = Agrif_Update_Average) 
     562      CALL Agrif_Set_Updatetype(v_ice_id  , update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy   ) 
     563#endif 
     564 
     565   END SUBROUTINE agrif_declare_var_ice 
     566#endif 
     567 
     568 
     569# if defined key_top 
     570   SUBROUTINE Agrif_InitValues_cont_top 
     571      !!---------------------------------------------------------------------- 
     572      !!                 *** ROUTINE Agrif_InitValues_cont_top *** 
     573      !!---------------------------------------------------------------------- 
     574      USE Agrif_Util 
     575      USE oce  
     576      USE dom_oce 
     577      USE nemogcm 
     578      USE par_trc 
     579      USE lib_mpp 
     580      USE trc 
     581      USE in_out_manager 
     582      USE agrif_oce_sponge 
     583      USE agrif_top_update 
     584      USE agrif_top_interp 
     585      USE agrif_top_sponge 
    455586      !! 
    456       !! ** Purpose :: Initialisation of variables to be interpolated for ice 
    457       !!---------------------------------------------------------------------- 
    458    USE Agrif_Util 
    459    USE sbc_oce, ONLY : nn_fsbc  ! clem: necessary otherwise Agrif_Parent(nn_fsbc) = nn_fsbc 
    460    USE ice 
    461    USE agrif_ice 
    462    USE in_out_manager 
    463    USE agrif_ice_interp 
    464    USE lib_mpp 
    465    ! 
    466    IMPLICIT NONE 
    467       !!---------------------------------------------------------------------- 
    468    ! 
    469    ! Declaration of the type of variable which have to be interpolated (parent=>child) 
    470    !---------------------------------------------------------------------------------- 
    471    CALL agrif_declare_var_ice 
    472  
    473    ! Controls 
    474  
    475    ! clem: For some reason, nn_fsbc(child)/=1 does not work properly (signal can be largely degraded by the agrif zoom) 
    476    !          the run must satisfy CFL=Uice/(dx/dt) < 0.6/nn_fsbc(child) 
    477    !          therefore, if nn_fsbc(child)>1 one must reduce the time-step in proportion to nn_fsbc(child), which is not acceptable 
    478    !       If a solution is found, the following stop could be removed because the rest of the code take nn_fsbc(child) into account 
    479    IF( nn_fsbc > 1 )  CALL ctl_stop('nn_fsbc(child) must be set to 1 otherwise agrif and sea-ice may not work properly') 
    480  
    481    ! stop if rhot * nn_fsbc(parent) /= N * nn_fsbc(child) with N being integer 
    482    IF( MOD( Agrif_irhot() * Agrif_Parent(nn_fsbc), nn_fsbc ) /= 0 )  THEN 
    483       CALL ctl_stop('rhot * nn_fsbc(parent) /= N * nn_fsbc(child), therefore nn_fsbc(child) should be set to 1 or nn_fsbc(parent)') 
    484    ENDIF 
    485    ! First Interpolations (using "after" ice subtime step => nbstep_ice=1) 
    486    !---------------------------------------------------------------------- 
    487    nbstep_ice = ( Agrif_irhot() * Agrif_Parent(nn_fsbc) / nn_fsbc ) ! clem: to have calledweight=1 in interp (otherwise the western border of the zoom is wrong) 
    488    CALL agrif_interp_ice('U') ! interpolation of ice velocities 
    489    CALL agrif_interp_ice('V') ! interpolation of ice velocities 
    490    CALL agrif_interp_ice('T') ! interpolation of ice tracers  
    491    nbstep_ice = 0 
    492     
    493    ! 
    494 END SUBROUTINE Agrif_InitValues_cont_ice 
    495  
    496 SUBROUTINE agrif_declare_var_ice 
    497       !!---------------------------------------------------------------------- 
    498       !!                 *** ROUTINE agrif_declare_var_ice *** 
    499       !! 
    500       !! ** Purpose :: Declaration of variables to be interpolated for ice 
    501       !!---------------------------------------------------------------------- 
    502    USE Agrif_Util 
    503    USE ice 
    504    USE par_oce, ONLY : nbghostcells 
    505    ! 
    506    IMPLICIT NONE 
    507    ! 
    508    INTEGER :: ind1, ind2, ind3 
    509       !!---------------------------------------------------------------------- 
    510    ! 
    511    ! 1. Declaration of the type of variable which have to be interpolated (parent=>child) 
    512    !       agrif_declare_variable(position,1st point index,--,--,dimensions,name) 
    513    !           ex.:  position=> 1,1 = not-centered (in i and j) 
    514    !                            2,2 =     centered (    -     ) 
    515    !                 index   => 1,1 = one ghost line 
    516    !                            2,2 = two ghost lines 
    517    !------------------------------------------------------------------------------------- 
    518    ind1 =     nbghostcells 
    519    ind2 = 1 + nbghostcells 
    520    ind3 = 2 + nbghostcells 
    521    CALL agrif_declare_variable((/2,2,0/),(/ind3,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpl*(8+nlay_s+nlay_i)/),tra_ice_id) 
    522    CALL agrif_declare_variable((/1,2/)  ,(/ind2,ind3/)  ,(/'x','y'/)    ,(/1,1/)  ,(/nlci,nlcj/)                      ,u_ice_id  ) 
    523    CALL agrif_declare_variable((/2,1/)  ,(/ind3,ind2/)  ,(/'x','y'/)    ,(/1,1/)  ,(/nlci,nlcj/)                      ,v_ice_id  ) 
    524  
    525    ! 2. Set interpolations (normal & tangent to the grid cell for velocities) 
    526    !----------------------------------- 
    527    CALL Agrif_Set_bcinterp(tra_ice_id, interp  = AGRIF_linear) 
    528    CALL Agrif_Set_bcinterp(u_ice_id  , interp1 = Agrif_linear,interp2 = AGRIF_ppm   ) 
    529    CALL Agrif_Set_bcinterp(v_ice_id  , interp1 = AGRIF_ppm   ,interp2 = Agrif_linear) 
    530  
    531    ! 3. Set location of interpolations 
    532    !---------------------------------- 
    533    CALL Agrif_Set_bc(tra_ice_id,(/0,ind1/)) 
    534    CALL Agrif_Set_bc(u_ice_id  ,(/0,ind1/)) 
    535    CALL Agrif_Set_bc(v_ice_id  ,(/0,ind1/)) 
    536  
    537    ! 4. Set update type in case 2 ways (child=>parent) (normal & tangent to the grid cell for velocities) 
    538    !-------------------------------------------------- 
    539 # if defined UPD_HIGH 
    540    CALL Agrif_Set_Updatetype(tra_ice_id, update  = Agrif_Update_Full_Weighting) 
    541    CALL Agrif_Set_Updatetype(u_ice_id  , update1 = Agrif_Update_Average       , update2 = Agrif_Update_Full_Weighting) 
    542    CALL Agrif_Set_Updatetype(v_ice_id  , update1 = Agrif_Update_Full_Weighting, update2 = Agrif_Update_Average       ) 
    543 #else 
    544    CALL Agrif_Set_Updatetype(tra_ice_id, update  = AGRIF_Update_Average) 
    545    CALL Agrif_Set_Updatetype(u_ice_id  , update1 = Agrif_Update_Copy   , update2 = Agrif_Update_Average) 
    546    CALL Agrif_Set_Updatetype(v_ice_id  , update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy   ) 
    547 #endif 
    548  
    549 END SUBROUTINE agrif_declare_var_ice 
    550 #endif 
    551  
    552  
    553 # if defined key_top 
    554 SUBROUTINE Agrif_InitValues_cont_top 
    555       !!---------------------------------------------------------------------- 
    556       !!                 *** ROUTINE Agrif_InitValues_cont_top *** 
    557       !! 
    558       !! ** Purpose :: Declaration of variables to be interpolated 
    559       !!---------------------------------------------------------------------- 
    560    USE Agrif_Util 
    561    USE oce  
    562    USE dom_oce 
    563    USE nemogcm 
    564    USE par_trc 
    565    USE lib_mpp 
    566    USE trc 
    567    USE in_out_manager 
    568    USE agrif_oce_sponge 
    569    USE agrif_top_update 
    570    USE agrif_top_interp 
    571    USE agrif_top_sponge 
    572    !! 
    573    IMPLICIT NONE 
    574    ! 
    575    CHARACTER(len=10) :: cl_check1, cl_check2, cl_check3 
    576    LOGICAL :: check_namelist 
    577       !!---------------------------------------------------------------------- 
    578  
    579  
    580    ! 1. Declaration of the type of variable which have to be interpolated 
    581    !--------------------------------------------------------------------- 
    582    CALL agrif_declare_var_top 
    583  
    584    ! 2. First interpolations of potentially non zero fields 
    585    !------------------------------------------------------- 
    586    Agrif_SpecialValue=0. 
    587    Agrif_UseSpecialValue = .TRUE. 
    588    CALL Agrif_Bc_variable(trn_id,calledweight=1.,procname=interptrn) 
    589    Agrif_UseSpecialValue = .FALSE. 
    590    CALL Agrif_Sponge 
    591    tabspongedone_trn = .FALSE. 
    592    CALL Agrif_Bc_variable(trn_sponge_id,calledweight=1.,procname=interptrn_sponge) 
    593    ! reset tsa to zero 
    594    tra(:,:,:,:) = 0. 
    595  
    596  
    597    ! 3. Some controls 
    598    !----------------- 
    599    check_namelist = .TRUE. 
    600  
    601    IF( check_namelist ) THEN 
    602       ! Check time steps 
     587      IMPLICIT NONE 
     588      ! 
     589      CHARACTER(len=10) :: cl_check1, cl_check2, cl_check3 
     590      LOGICAL :: check_namelist 
     591      !!---------------------------------------------------------------------- 
     592 
     593      ! 1. Declaration of the type of variable which have to be interpolated 
     594      !--------------------------------------------------------------------- 
     595      CALL agrif_declare_var_top 
     596 
     597      ! 2. First interpolations of potentially non zero fields 
     598      !------------------------------------------------------- 
     599      Agrif_SpecialValue=0._wp 
     600      Agrif_UseSpecialValue = .TRUE. 
     601      CALL Agrif_Bc_variable(trn_id,calledweight=1.,procname=interptrn) 
     602      Agrif_UseSpecialValue = .FALSE. 
     603      CALL Agrif_Sponge 
     604      tabspongedone_trn = .FALSE. 
     605      CALL Agrif_Bc_variable(trn_sponge_id,calledweight=1.,procname=interptrn_sponge) 
     606      ! reset ts(:,:,:,:,Krhs_a) to zero 
     607      tr(:,:,:,:,Krhs_a) = 0._wp 
     608 
     609      ! 3. Some controls 
     610      !----------------- 
     611      check_namelist = .TRUE. 
     612 
     613      IF( check_namelist ) THEN 
     614         ! Check time steps 
    603615      IF( NINT(Agrif_Rhot()) * NINT(rdt) .NE. Agrif_Parent(rdt) ) THEN 
    604616         WRITE(cl_check1,*)  Agrif_Parent(rdt) 
    … …  
    624636      ENDIF 
    625637 
    626       ! Check passive tracer cell 
    627       IF( nn_dttrc .NE. 1 ) THEN 
    628          WRITE(*,*) 'nn_dttrc should be equal to 1' 
    629       ENDIF 
    630638   ENDIF 
    631639   ! 
    632 END SUBROUTINE Agrif_InitValues_cont_top 
    633  
    634  
    635 SUBROUTINE agrif_declare_var_top 
     640   END SUBROUTINE Agrif_InitValues_cont_top 
     641 
     642 
     643   SUBROUTINE agrif_declare_var_top 
    636644      !!---------------------------------------------------------------------- 
    637645      !!                 *** ROUTINE agrif_declare_var_top *** 
     646      !!---------------------------------------------------------------------- 
     647      USE agrif_util 
     648      USE agrif_oce 
     649      USE dom_oce 
     650      USE trc 
    638651      !! 
    639       !! ** Purpose :: Declaration of TOP variables to be interpolated 
    640       !!---------------------------------------------------------------------- 
    641    USE agrif_util 
    642    USE agrif_oce 
    643    USE dom_oce 
    644    USE trc 
    645    !! 
    646    IMPLICIT NONE 
    647    ! 
    648    INTEGER :: ind1, ind2, ind3 
    649       !!---------------------------------------------------------------------- 
    650  
    651    ! 1. Declaration of the type of variable which have to be interpolated 
    652    !--------------------------------------------------------------------- 
    653    ind1 =     nbghostcells 
    654    ind2 = 1 + nbghostcells 
    655    ind3 = 2 + nbghostcells 
     652      IMPLICIT NONE 
     653      ! 
     654      INTEGER :: ind1, ind2, ind3 
     655      !!---------------------------------------------------------------------- 
     656 
     657      ! 1. Declaration of the type of variable which have to be interpolated 
     658      !--------------------------------------------------------------------- 
     659      ind1 =     nbghostcells 
     660      ind2 = 1 + nbghostcells 
     661      ind3 = 2 + nbghostcells 
    656662# if defined key_vertical 
    657    CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jptra+1/),trn_id) 
    658    CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jptra+1/),trn_sponge_id) 
     663      CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jptra+1/),trn_id) 
     664      CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jptra+1/),trn_sponge_id) 
    659665# else 
    660    CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jptra/),trn_id) 
    661    CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jptra/),trn_sponge_id) 
    662 # endif 
    663  
    664    ! 2. Type of interpolation 
    665    !------------------------- 
    666    CALL Agrif_Set_bcinterp(trn_id,interp=AGRIF_linear) 
    667    CALL Agrif_Set_bcinterp(trn_sponge_id,interp=AGRIF_linear) 
    668  
    669    ! 3. Location of interpolation 
    670    !----------------------------- 
    671    CALL Agrif_Set_bc(trn_id,(/0,ind1/)) 
    672    CALL Agrif_Set_bc(trn_sponge_id,(/-nn_sponge_len*Agrif_irhox()-1,0/)) 
    673  
    674    ! 4. Update type 
    675    !---------------  
     666      CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jptra/),trn_id) 
     667      CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jptra/),trn_sponge_id) 
     668# endif 
     669 
     670      ! 2. Type of interpolation 
     671      !------------------------- 
     672      CALL Agrif_Set_bcinterp(trn_id,interp=AGRIF_linear) 
     673      CALL Agrif_Set_bcinterp(trn_sponge_id,interp=AGRIF_linear) 
     674 
     675      ! 3. Location of interpolation 
     676      !----------------------------- 
     677      CALL Agrif_Set_bc(trn_id,(/0,ind1-1/)) 
     678      CALL Agrif_Set_bc(trn_sponge_id,(/-nn_sponge_len*Agrif_irhox()-1,0/)) 
     679 
     680      ! 4. Update type 
     681      !---------------  
    676682# if defined UPD_HIGH 
    677    CALL Agrif_Set_Updatetype(trn_id, update = Agrif_Update_Full_Weighting) 
     683      CALL Agrif_Set_Updatetype(trn_id, update = Agrif_Update_Full_Weighting) 
    678684#else 
    679    CALL Agrif_Set_Updatetype(trn_id, update = AGRIF_Update_Average) 
     685      CALL Agrif_Set_Updatetype(trn_id, update = AGRIF_Update_Average) 
    680686#endif 
    681687   ! 
    682 END SUBROUTINE agrif_declare_var_top 
    683 # endif 
    684  
    685 SUBROUTINE Agrif_detect( kg, ksizex ) 
     688   END SUBROUTINE agrif_declare_var_top 
     689# endif 
     690 
     691   SUBROUTINE Agrif_detect( kg, ksizex ) 
    686692      !!---------------------------------------------------------------------- 
    687693      !!                      *** ROUTINE Agrif_detect *** 
    688694      !!---------------------------------------------------------------------- 
    689    INTEGER, DIMENSION(2) :: ksizex 
    690    INTEGER, DIMENSION(ksizex(1),ksizex(2)) :: kg  
    691       !!---------------------------------------------------------------------- 
    692    ! 
    693    RETURN 
    694    ! 
    695 END SUBROUTINE Agrif_detect 
    696  
    697  
    698 SUBROUTINE agrif_nemo_init 
     695      INTEGER, DIMENSION(2) :: ksizex 
     696      INTEGER, DIMENSION(ksizex(1),ksizex(2)) :: kg  
     697      !!---------------------------------------------------------------------- 
     698      ! 
     699      RETURN 
     700      ! 
     701   END SUBROUTINE Agrif_detect 
     702 
     703   SUBROUTINE agrif_nemo_init 
    699704      !!---------------------------------------------------------------------- 
    700705      !!                     *** ROUTINE agrif_init *** 
    701706      !!---------------------------------------------------------------------- 
    702    USE agrif_oce  
    703    USE agrif_ice 
    704    USE in_out_manager 
    705    USE lib_mpp 
    706    !! 
    707    IMPLICIT NONE 
    708    ! 
    709    INTEGER  ::   ios                 ! Local integer output status for namelist read 
    710    INTEGER  ::   iminspon 
    711    NAMELIST/namagrif/ rn_sponge_tra, rn_sponge_dyn, ln_spc_dyn, ln_chk_bathy 
     707      USE agrif_oce  
     708      USE agrif_ice 
     709      USE in_out_manager 
     710      USE lib_mpp 
     711      !! 
     712      IMPLICIT NONE 
     713      ! 
     714      INTEGER  ::   ios                 ! Local integer output status for namelist read 
     715      NAMELIST/namagrif/ ln_agrif_2way, rn_sponge_tra, rn_sponge_dyn, rn_trelax_tra, rn_trelax_dyn, & 
     716                       & ln_spc_dyn, ln_chk_bathy 
    712717      !!-------------------------------------------------------------------------------------- 
    713    ! 
    714    REWIND( numnam_ref )              ! Namelist namagrif in reference namelist : AGRIF zoom 
    715    READ  ( numnam_ref, namagrif, IOSTAT = ios, ERR = 901) 
     718      ! 
     719      READ  ( numnam_ref, namagrif, IOSTAT = ios, ERR = 901) 
    716720901 IF( ios /= 0 )   CALL ctl_nam ( ios , 'namagrif in reference namelist' ) 
    717    REWIND( numnam_cfg )              ! Namelist namagrif in configuration namelist : AGRIF zoom 
    718    READ  ( numnam_cfg, namagrif, IOSTAT = ios, ERR = 902 ) 
     721      READ  ( numnam_cfg, namagrif, IOSTAT = ios, ERR = 902 ) 
    719722902 IF( ios >  0 )   CALL ctl_nam ( ios , 'namagrif in configuration namelist' ) 
    720    IF(lwm) WRITE ( numond, namagrif ) 
    721    ! 
    722    IF(lwp) THEN                    ! control print 
    723       WRITE(numout,*) 
    724       WRITE(numout,*) 'agrif_nemo_init : AGRIF parameters' 
    725       WRITE(numout,*) '~~~~~~~~~~~~~~~' 
    726       WRITE(numout,*) '   Namelist namagrif : set AGRIF parameters' 
    727       WRITE(numout,*) '      sponge coefficient for tracers    rn_sponge_tra = ', rn_sponge_tra, ' s' 
    728       WRITE(numout,*) '      sponge coefficient for dynamics   rn_sponge_tra = ', rn_sponge_dyn, ' s' 
    729       WRITE(numout,*) '      use special values for dynamics   ln_spc_dyn    = ', ln_spc_dyn 
    730       WRITE(numout,*) '      check bathymetry                  ln_chk_bathy  = ', ln_chk_bathy 
    731    ENDIF 
    732    ! 
    733    ! convert DOCTOR namelist name into OLD names 
    734    visc_tra      = rn_sponge_tra 
    735    visc_dyn      = rn_sponge_dyn 
    736    ! 
    737    ! Check sponge length: 
    738    IF(     MIN(jpi   ,jpj   ) <=     1 + nbghostcells + (nn_sponge_len * Agrif_irhox() + 1)     & 
    739       .OR. MIN(jpiglo,jpjglo) <= 2* (1 + nbghostcells + (nn_sponge_len * Agrif_irhox() + 1) ) ) & 
    740       &     CALL ctl_stop('STOP','agrif sponge length is too large') 
    741    ! 
    742    IF( agrif_oce_alloc()  > 0 )   CALL ctl_warn('agrif agrif_oce_alloc: allocation of arrays failed') 
    743    ! 
    744 END SUBROUTINE agrif_nemo_init 
     723      IF(lwm) WRITE ( numond, namagrif ) 
     724      ! 
     725      IF(lwp) THEN                    ! control print 
     726         WRITE(numout,*) 
     727         WRITE(numout,*) 'agrif_nemo_init : AGRIF parameters' 
     728         WRITE(numout,*) '~~~~~~~~~~~~~~~' 
     729         WRITE(numout,*) '   Namelist namagrif : set AGRIF parameters' 
     730         WRITE(numout,*) '      Two way nesting activated ln_agrif_2way         = ', ln_agrif_2way 
     731         WRITE(numout,*) '      sponge coefficient for tracers    rn_sponge_tra = ', rn_sponge_tra, ' m^2/s' 
     732         WRITE(numout,*) '      sponge coefficient for dynamics   rn_sponge_tra = ', rn_sponge_dyn, ' m^2/s' 
     733         WRITE(numout,*) '      time relaxation for tracers       rn_trelax_tra = ', rn_trelax_tra, ' ad.' 
     734         WRITE(numout,*) '      time relaxation for dynamics      rn_trelax_dyn = ', rn_trelax_dyn, ' ad.' 
     735         WRITE(numout,*) '      use special values for dynamics   ln_spc_dyn    = ', ln_spc_dyn 
     736         WRITE(numout,*) '      check bathymetry                  ln_chk_bathy  = ', ln_chk_bathy 
     737      ENDIF 
     738      ! 
     739      ! 
     740      IF( agrif_oce_alloc()  > 0 )   CALL ctl_warn('agrif agrif_oce_alloc: allocation of arrays failed') 
     741      ! 
     742   END SUBROUTINE agrif_nemo_init 
    745743 
    746744# if defined key_mpp_mpi 
    747745 
    748 SUBROUTINE Agrif_InvLoc( indloc, nprocloc, i, indglob ) 
     746   SUBROUTINE Agrif_InvLoc( indloc, nprocloc, i, indglob ) 
    749747      !!---------------------------------------------------------------------- 
    750748      !!                     *** ROUTINE Agrif_InvLoc *** 
    751749      !!---------------------------------------------------------------------- 
    752    USE dom_oce 
    753    !! 
    754    IMPLICIT NONE 
    755    ! 
    756    INTEGER :: indglob, indloc, nprocloc, i 
    757       !!---------------------------------------------------------------------- 
    758    ! 
    759    SELECT CASE( i ) 
    760    CASE(1)   ;   indglob = indloc + nimppt(nprocloc+1) - 1 
    761    CASE(2)   ;   indglob = indloc + njmppt(nprocloc+1) - 1 
    762    CASE DEFAULT 
    763       indglob = indloc 
    764    END SELECT 
    765    ! 
    766 END SUBROUTINE Agrif_InvLoc 
    767  
    768  
    769 SUBROUTINE Agrif_get_proc_info( imin, imax, jmin, jmax ) 
     750      USE dom_oce 
     751      !! 
     752      IMPLICIT NONE 
     753      ! 
     754      INTEGER :: indglob, indloc, nprocloc, i 
     755      !!---------------------------------------------------------------------- 
     756      ! 
     757      SELECT CASE( i ) 
     758      CASE(1)   ;   indglob = indloc + nimppt(nprocloc+1) - 1 
     759      CASE(2)   ;   indglob = indloc + njmppt(nprocloc+1) - 1 
     760      CASE DEFAULT 
     761         indglob = indloc 
     762      END SELECT 
     763      ! 
     764   END SUBROUTINE Agrif_InvLoc 
     765 
     766   SUBROUTINE Agrif_get_proc_info( imin, imax, jmin, jmax ) 
    770767      !!---------------------------------------------------------------------- 
    771768      !!                 *** ROUTINE Agrif_get_proc_info *** 
    772769      !!---------------------------------------------------------------------- 
    773    USE par_oce 
    774    !! 
    775    IMPLICIT NONE 
    776    ! 
    777    INTEGER, INTENT(out) :: imin, imax 
    778    INTEGER, INTENT(out) :: jmin, jmax 
    779       !!---------------------------------------------------------------------- 
    780    ! 
    781    imin = nimppt(Agrif_Procrank+1)  ! ????? 
    782    jmin = njmppt(Agrif_Procrank+1)  ! ????? 
    783    imax = imin + jpi - 1 
    784    jmax = jmin + jpj - 1 
    785    !  
    786 END SUBROUTINE Agrif_get_proc_info 
    787  
    788  
    789 SUBROUTINE Agrif_estimate_parallel_cost(imin, imax,jmin, jmax, nbprocs, grid_cost) 
     770      USE par_oce 
     771      !! 
     772      IMPLICIT NONE 
     773      ! 
     774      INTEGER, INTENT(out) :: imin, imax 
     775      INTEGER, INTENT(out) :: jmin, jmax 
     776      !!---------------------------------------------------------------------- 
     777      ! 
     778      imin = nimppt(Agrif_Procrank+1)  ! ????? 
     779      jmin = njmppt(Agrif_Procrank+1)  ! ????? 
     780      imax = imin + jpi - 1 
     781      jmax = jmin + jpj - 1 
     782      !  
     783   END SUBROUTINE Agrif_get_proc_info 
     784 
     785   SUBROUTINE Agrif_estimate_parallel_cost(imin, imax,jmin, jmax, nbprocs, grid_cost) 
    790786      !!---------------------------------------------------------------------- 
    791787      !!                 *** ROUTINE Agrif_estimate_parallel_cost *** 
    792788      !!---------------------------------------------------------------------- 
    793    USE par_oce 
    794    !! 
    795    IMPLICIT NONE 
    796    ! 
    797    INTEGER,  INTENT(in)  :: imin, imax 
    798    INTEGER,  INTENT(in)  :: jmin, jmax 
    799    INTEGER,  INTENT(in)  :: nbprocs 
    800    REAL(wp), INTENT(out) :: grid_cost 
    801       !!---------------------------------------------------------------------- 
    802    ! 
    803    grid_cost = REAL(imax-imin+1,wp)*REAL(jmax-jmin+1,wp) / REAL(nbprocs,wp) 
    804    ! 
    805 END SUBROUTINE Agrif_estimate_parallel_cost 
     789      USE par_oce 
     790      !! 
     791      IMPLICIT NONE 
     792      ! 
     793      INTEGER,  INTENT(in)  :: imin, imax 
     794      INTEGER,  INTENT(in)  :: jmin, jmax 
     795      INTEGER,  INTENT(in)  :: nbprocs 
     796      REAL(wp), INTENT(out) :: grid_cost 
     797      !!---------------------------------------------------------------------- 
     798      ! 
     799      grid_cost = REAL(imax-imin+1,wp)*REAL(jmax-jmin+1,wp) / REAL(nbprocs,wp) 
     800      ! 
     801   END SUBROUTINE Agrif_estimate_parallel_cost 
    806802 
    807803# endif 
    808804 
    809805#else 
    810 SUBROUTINE Subcalledbyagrif 
     806   SUBROUTINE Subcalledbyagrif 
    811807      !!---------------------------------------------------------------------- 
    812808      !!                   *** ROUTINE Subcalledbyagrif *** 
    813809      !!---------------------------------------------------------------------- 
    814    WRITE(*,*) 'Impossible to be here' 
    815 END SUBROUTINE Subcalledbyagrif 
     810      WRITE(*,*) 'Impossible to be here' 
     811   END SUBROUTINE Subcalledbyagrif 
    816812#endif 
Note: See TracChangeset for help on using the changeset viewer.