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/OCE/DYN – NEMO

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:
1 deleted
18 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/OCE/DYN/divhor.F90

    r12141 r12377  
    2020   USE oce             ! ocean dynamics and tracers 
    2121   USE dom_oce         ! ocean space and time domain 
    22    USE sbc_oce, ONLY : ln_rnf, ln_isf ! surface boundary condition: ocean 
    23    USE sbcrnf          ! river runoff  
    24    USE sbcisf          ! ice shelf 
    25    USE iscplhsb        ! ice sheet / ocean coupling 
    26    USE iscplini        ! ice sheet / ocean coupling 
     22   USE sbc_oce, ONLY : ln_rnf      ! river runoff 
     23   USE sbcrnf , ONLY : sbc_rnf_div ! river runoff  
     24   USE isf_oce, ONLY : ln_isf      ! ice shelf 
     25   USE isfhdiv, ONLY : isf_hdiv    ! ice shelf 
    2726#if defined key_asminc    
    2827   USE asminc          ! Assimilation increment 
    … …  
    4039 
    4140   !! * Substitutions 
    42 #  include "vectopt_loop_substitute.h90" 
     41#  include "do_loop_substitute.h90" 
    4342   !!---------------------------------------------------------------------- 
    4443   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    4847CONTAINS 
    4948 
    50    SUBROUTINE div_hor( kt ) 
     49   SUBROUTINE div_hor( kt, Kbb, Kmm ) 
    5150      !!---------------------------------------------------------------------- 
    5251      !!                  ***  ROUTINE div_hor  *** 
    … …  
    5554      !! 
    5655      !! ** Method  :   the now divergence is computed as : 
    57       !!         hdivn = 1/(e1e2t*e3t) ( di[e2u*e3u un] + dj[e1v*e3v vn] ) 
     56      !!         hdiv = 1/(e1e2t*e3t) ( di[e2u*e3u un] + dj[e1v*e3v vn] ) 
    5857      !!      and correct with runoff inflow (div_rnf) and cross land flow (div_cla)  
    5958      !! 
    60       !! ** Action  : - update hdivn, the now horizontal divergence 
     59      !! ** Action  : - update hdiv, the now horizontal divergence 
    6160      !!---------------------------------------------------------------------- 
    62       INTEGER, INTENT(in) ::   kt   ! ocean time-step index 
     61      INTEGER, INTENT(in) ::   kt        ! ocean time-step index 
     62      INTEGER, INTENT(in) ::   Kbb, Kmm  ! ocean time level indices 
    6363      ! 
    6464      INTEGER  ::   ji, jj, jk    ! dummy loop indices 
    6565      REAL(wp) ::   zraur, zdep   ! local scalars 
     66      REAL(wp), DIMENSION(jpi,jpj) :: ztmp 
    6667      !!---------------------------------------------------------------------- 
    6768      ! 
    … …  
    7273         IF(lwp) WRITE(numout,*) 'div_hor : horizontal velocity divergence ' 
    7374         IF(lwp) WRITE(numout,*) '~~~~~~~   ' 
    74          hdivn(:,:,:) = 0._wp    ! initialize hdivn for the halos at the first time step 
     75         hdiv(:,:,:) = 0._wp    ! initialize hdiv for the halos at the first time step 
    7576      ENDIF 
    7677      ! 
    77       DO jk = 1, jpkm1                                      !==  Horizontal divergence  ==! 
    78          DO jj = 2, jpjm1 
    79             DO ji = fs_2, fs_jpim1   ! vector opt. 
    80                hdivn(ji,jj,jk) = (  e2u(ji  ,jj) * e3u_n(ji  ,jj,jk) * un(ji  ,jj,jk)      & 
    81                   &               - e2u(ji-1,jj) * e3u_n(ji-1,jj,jk) * un(ji-1,jj,jk)      & 
    82                   &               + e1v(ji,jj  ) * e3v_n(ji,jj  ,jk) * vn(ji,jj  ,jk)      & 
    83                   &               - e1v(ji,jj-1) * e3v_n(ji,jj-1,jk) * vn(ji,jj-1,jk)  )   & 
    84                   &            * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) 
    85             END DO   
    86          END DO   
    87       END DO 
     78      DO_3D_00_00( 1, jpkm1 ) 
     79         hdiv(ji,jj,jk) = (  e2u(ji  ,jj) * e3u(ji  ,jj,jk,Kmm) * uu(ji  ,jj,jk,Kmm)      & 
     80            &               - e2u(ji-1,jj) * e3u(ji-1,jj,jk,Kmm) * uu(ji-1,jj,jk,Kmm)      & 
     81            &               + e1v(ji,jj  ) * e3v(ji,jj  ,jk,Kmm) * vv(ji,jj  ,jk,Kmm)      & 
     82            &               - e1v(ji,jj-1) * e3v(ji,jj-1,jk,Kmm) * vv(ji,jj-1,jk,Kmm)  )   & 
     83            &            * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
     84      END_3D 
     85      ! 
    8886#if defined key_agrif 
    8987      IF( .NOT. Agrif_Root() ) THEN 
    90          IF( nbondi == -1 .OR. nbondi == 2 )   hdivn(   2   ,  :   ,:) = 0._wp      ! west 
    91          IF( nbondi ==  1 .OR. nbondi == 2 )   hdivn( nlci-1,  :   ,:) = 0._wp      ! east 
    92          IF( nbondj == -1 .OR. nbondj == 2 )   hdivn(   :   ,  2   ,:) = 0._wp      ! south 
    93          IF( nbondj ==  1 .OR. nbondj == 2 )   hdivn(   :   ,nlcj-1,:) = 0._wp      ! north 
     88         IF( nbondi == -1 .OR. nbondi == 2 )   hdiv(   2   ,  :   ,:) = 0._wp      ! west 
     89         IF( nbondi ==  1 .OR. nbondi == 2 )   hdiv( nlci-1,  :   ,:) = 0._wp      ! east 
     90         IF( nbondj == -1 .OR. nbondj == 2 )   hdiv(   :   ,  2   ,:) = 0._wp      ! south 
     91         IF( nbondj ==  1 .OR. nbondj == 2 )   hdiv(   :   ,nlcj-1,:) = 0._wp      ! north 
    9492      ENDIF 
    9593#endif 
    9694      ! 
    97       IF( ln_rnf )   CALL sbc_rnf_div( hdivn )              !==  runoffs    ==!   (update hdivn field) 
     95      IF( ln_rnf )   CALL sbc_rnf_div( hdiv, Kmm )                     !==  runoffs    ==!   (update hdiv field) 
    9896      ! 
    9997#if defined key_asminc  
    100       IF( ln_sshinc .AND. ln_asmiau )   CALL ssh_asm_div( kt, hdivn )   !==  SSH assimilation  ==!   (update hdivn field) 
     98      IF( ln_sshinc .AND. ln_asmiau )   CALL ssh_asm_div( kt, Kbb, Kmm, hdiv )   !==  SSH assimilation  ==!   (update hdiv field) 
    10199      !  
    102100#endif 
    103       IF( ln_isf )   CALL sbc_isf_div( hdivn )      !==  ice shelf  ==!   (update hdivn field) 
    104101      ! 
    105       IF( ln_iscpl .AND. ln_hsb )   CALL iscpl_div( hdivn ) !==  ice sheet  ==!   (update hdivn field) 
     102      IF( ln_isf )                      CALL isf_hdiv( kt, Kmm, hdiv )           !==  ice shelf         ==!   (update hdiv field) 
    106103      ! 
    107       CALL lbc_lnk( 'divhor', hdivn, 'T', 1. )   !   (no sign change) 
     104      CALL lbc_lnk( 'divhor', hdiv, 'T', 1. )   !   (no sign change) 
    108105      ! 
    109106      IF( ln_timing )   CALL timing_stop('div_hor') 

  • NEMO/trunk/src/OCE/DYN/dynadv.F90

    r11536 r12377  
    4444   INTEGER, PUBLIC, PARAMETER ::   np_FLX_ubs = 3   ! flux   form : 3rd order Upstream Biased Scheme 
    4545 
    46    !! * Substitutions 
    47 #  include "vectopt_loop_substitute.h90" 
    4846   !!---------------------------------------------------------------------- 
    4947   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    5351CONTAINS 
    5452 
    55    SUBROUTINE dyn_adv( kt ) 
     53   SUBROUTINE dyn_adv( kt, Kbb, Kmm, puu, pvv, Krhs ) 
    5654      !!--------------------------------------------------------------------- 
    5755      !!                  ***  ROUTINE dyn_adv  *** 
    … …  
    5957      !! ** Purpose :   compute the ocean momentum advection trend. 
    6058      !! 
    61       !! ** Method  : - Update (ua,va) with the advection term following n_dynadv 
     59      !! ** Method  : - Update (puu(:,:,:,Krhs),pvv(:,:,:,Krhs)) with the advection term following n_dynadv 
    6260      !! 
    6361      !!      NB: in flux form advection (ln_dynadv_cen2 or ln_dynadv_ubs=T)  
    … …  
    6664      !!      (see dynvor module). 
    6765      !!---------------------------------------------------------------------- 
    68       INTEGER, INTENT( in ) ::   kt   ! ocean time-step index 
     66      INTEGER                             , INTENT( in )  ::  kt               ! ocean time-step index 
     67      INTEGER                             , INTENT( in )  ::  Kbb, Kmm, Krhs   ! ocean time level indices 
     68      REAL(wp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) ::  puu, pvv         ! ocean velocities and RHS of momentum equation 
    6969      !!---------------------------------------------------------------------- 
    7070      ! 
    … …  
    7373      SELECT CASE( n_dynadv )    !==  compute advection trend and add it to general trend  ==! 
    7474      CASE( np_VEC_c2  )      
    75          CALL dyn_keg     ( kt, nn_dynkeg )    ! vector form : horizontal gradient of kinetic energy 
    76          CALL dyn_zad     ( kt )               ! vector form : vertical advection 
     75         CALL dyn_keg     ( kt, nn_dynkeg,      Kmm, puu, pvv, Krhs )    ! vector form : horizontal gradient of kinetic energy 
     76         CALL dyn_zad     ( kt,                 Kmm, puu, pvv, Krhs )    ! vector form : vertical advection 
    7777      CASE( np_FLX_c2  )  
    78          CALL dyn_adv_cen2( kt )               ! 2nd order centered scheme 
     78         CALL dyn_adv_cen2( kt,                 Kmm, puu, pvv, Krhs )    ! 2nd order centered scheme 
    7979      CASE( np_FLX_ubs )    
    80          CALL dyn_adv_ubs ( kt )               ! 3rd order UBS      scheme (UP3) 
     80         CALL dyn_adv_ubs ( kt,            Kbb, Kmm, puu, pvv, Krhs )    ! 3rd order UBS      scheme (UP3) 
    8181      END SELECT 
    8282      ! 
    … …  
    104104      ENDIF 
    105105      ! 
    106       REWIND( numnam_ref )              ! Namelist namdyn_adv in reference namelist : Momentum advection scheme 
    107106      READ  ( numnam_ref, namdyn_adv, IOSTAT = ios, ERR = 901) 
    108107901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namdyn_adv in reference namelist' ) 
    109       REWIND( numnam_cfg )              ! Namelist namdyn_adv in configuration namelist : Momentum advection scheme 
    110108      READ  ( numnam_cfg, namdyn_adv, IOSTAT = ios, ERR = 902 ) 
    111109902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namdyn_adv in configuration namelist' ) 

  • NEMO/trunk/src/OCE/DYN/dynadv_cen2.F90

    r10068 r12377  
    2727 
    2828   !! * Substitutions 
    29 #  include "vectopt_loop_substitute.h90" 
     29#  include "do_loop_substitute.h90" 
    3030   !!---------------------------------------------------------------------- 
    3131   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    3535CONTAINS 
    3636 
    37    SUBROUTINE dyn_adv_cen2( kt ) 
     37   SUBROUTINE dyn_adv_cen2( kt, Kmm, puu, pvv, Krhs ) 
    3838      !!---------------------------------------------------------------------- 
    3939      !!                  ***  ROUTINE dyn_adv_cen2  *** 
    … …  
    4444      !! ** Method  :   Trend evaluated using now fields (centered in time)  
    4545      !! 
    46       !! ** Action  :   (ua,va) updated with the now vorticity term trend 
     46      !! ** Action  :   (puu(:,:,:,Krhs),pvv(:,:,:,Krhs)) updated with the now vorticity term trend 
    4747      !!---------------------------------------------------------------------- 
    48       INTEGER, INTENT( in ) ::   kt   ! ocean time-step index 
     48      INTEGER                             , INTENT( in )  ::  kt           ! ocean time-step index 
     49      INTEGER                             , INTENT( in )  ::  Kmm, Krhs    ! ocean time level indices 
     50      REAL(wp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) ::  puu, pvv     ! ocean velocities and RHS of momentum equation 
    4951      ! 
    5052      INTEGER  ::   ji, jj, jk   ! dummy loop indices 
    … …  
    6062      ! 
    6163      IF( l_trddyn ) THEN           ! trends: store the input trends 
    62          zfu_uw(:,:,:) = ua(:,:,:) 
    63          zfv_vw(:,:,:) = va(:,:,:) 
     64         zfu_uw(:,:,:) = puu(:,:,:,Krhs) 
     65         zfv_vw(:,:,:) = pvv(:,:,:,Krhs) 
    6466      ENDIF 
    6567      ! 
    … …  
    6769      ! 
    6870      DO jk = 1, jpkm1                    ! horizontal transport 
    69          zfu(:,:,jk) = 0.25_wp * e2u(:,:) * e3u_n(:,:,jk) * un(:,:,jk) 
    70          zfv(:,:,jk) = 0.25_wp * e1v(:,:) * e3v_n(:,:,jk) * vn(:,:,jk) 
    71          DO jj = 1, jpjm1                 ! horizontal momentum fluxes (at T- and F-point) 
    72             DO ji = 1, fs_jpim1   ! vector opt. 
    73                zfu_t(ji+1,jj  ,jk) = ( zfu(ji,jj,jk) + zfu(ji+1,jj,jk) ) * ( un(ji,jj,jk) + un(ji+1,jj  ,jk) ) 
    74                zfv_f(ji  ,jj  ,jk) = ( zfv(ji,jj,jk) + zfv(ji+1,jj,jk) ) * ( un(ji,jj,jk) + un(ji  ,jj+1,jk) ) 
    75                zfu_f(ji  ,jj  ,jk) = ( zfu(ji,jj,jk) + zfu(ji,jj+1,jk) ) * ( vn(ji,jj,jk) + vn(ji+1,jj  ,jk) ) 
    76                zfv_t(ji  ,jj+1,jk) = ( zfv(ji,jj,jk) + zfv(ji,jj+1,jk) ) * ( vn(ji,jj,jk) + vn(ji  ,jj+1,jk) ) 
    77             END DO 
    78          END DO 
    79          DO jj = 2, jpjm1                 ! divergence of horizontal momentum fluxes 
    80             DO ji = fs_2, fs_jpim1   ! vector opt. 
    81                ua(ji,jj,jk) = ua(ji,jj,jk) - (  zfu_t(ji+1,jj,jk) - zfu_t(ji,jj  ,jk)    & 
    82                   &                           + zfv_f(ji  ,jj,jk) - zfv_f(ji,jj-1,jk)  ) * r1_e1e2u(ji,jj) / e3u_n(ji,jj,jk) 
    83                va(ji,jj,jk) = va(ji,jj,jk) - (  zfu_f(ji,jj  ,jk) - zfu_f(ji-1,jj,jk)    & 
    84                   &                           + zfv_t(ji,jj+1,jk) - zfv_t(ji  ,jj,jk)  ) * r1_e1e2v(ji,jj) / e3v_n(ji,jj,jk) 
    85             END DO 
    86          END DO 
     71         zfu(:,:,jk) = 0.25_wp * e2u(:,:) * e3u(:,:,jk,Kmm) * puu(:,:,jk,Kmm) 
     72         zfv(:,:,jk) = 0.25_wp * e1v(:,:) * e3v(:,:,jk,Kmm) * pvv(:,:,jk,Kmm) 
     73         DO_2D_10_10 
     74            zfu_t(ji+1,jj  ,jk) = ( zfu(ji,jj,jk) + zfu(ji+1,jj,jk) ) * ( puu(ji,jj,jk,Kmm) + puu(ji+1,jj  ,jk,Kmm) ) 
     75            zfv_f(ji  ,jj  ,jk) = ( zfv(ji,jj,jk) + zfv(ji+1,jj,jk) ) * ( puu(ji,jj,jk,Kmm) + puu(ji  ,jj+1,jk,Kmm) ) 
     76            zfu_f(ji  ,jj  ,jk) = ( zfu(ji,jj,jk) + zfu(ji,jj+1,jk) ) * ( pvv(ji,jj,jk,Kmm) + pvv(ji+1,jj  ,jk,Kmm) ) 
     77            zfv_t(ji  ,jj+1,jk) = ( zfv(ji,jj,jk) + zfv(ji,jj+1,jk) ) * ( pvv(ji,jj,jk,Kmm) + pvv(ji  ,jj+1,jk,Kmm) ) 
     78         END_2D 
     79         DO_2D_00_00 
     80            puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) - (  zfu_t(ji+1,jj,jk) - zfu_t(ji,jj  ,jk)    & 
     81               &                           + zfv_f(ji  ,jj,jk) - zfv_f(ji,jj-1,jk)  ) * r1_e1e2u(ji,jj) / e3u(ji,jj,jk,Kmm) 
     82            pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) - (  zfu_f(ji,jj  ,jk) - zfu_f(ji-1,jj,jk)    & 
     83               &                           + zfv_t(ji,jj+1,jk) - zfv_t(ji  ,jj,jk)  ) * r1_e1e2v(ji,jj) / e3v(ji,jj,jk,Kmm) 
     84         END_2D 
    8785      END DO 
    8886      ! 
    8987      IF( l_trddyn ) THEN           ! trends: send trend to trddyn for diagnostic 
    90          zfu_uw(:,:,:) = ua(:,:,:) - zfu_uw(:,:,:) 
    91          zfv_vw(:,:,:) = va(:,:,:) - zfv_vw(:,:,:) 
    92          CALL trd_dyn( zfu_uw, zfv_vw, jpdyn_keg, kt ) 
    93          zfu_t(:,:,:) = ua(:,:,:) 
    94          zfv_t(:,:,:) = va(:,:,:) 
     88         zfu_uw(:,:,:) = puu(:,:,:,Krhs) - zfu_uw(:,:,:) 
     89         zfv_vw(:,:,:) = pvv(:,:,:,Krhs) - zfv_vw(:,:,:) 
     90         CALL trd_dyn( zfu_uw, zfv_vw, jpdyn_keg, kt, Kmm ) 
     91         zfu_t(:,:,:) = puu(:,:,:,Krhs) 
     92         zfv_t(:,:,:) = pvv(:,:,:,Krhs) 
    9593      ENDIF 
    9694      ! 
    9795      !                             !==  Vertical advection  ==! 
    9896      ! 
    99       DO jj = 2, jpjm1                    ! surface/bottom advective fluxes set to zero 
    100          DO ji = fs_2, fs_jpim1 
    101             zfu_uw(ji,jj,jpk) = 0._wp   ;   zfv_vw(ji,jj,jpk) = 0._wp 
    102             zfu_uw(ji,jj, 1 ) = 0._wp   ;   zfv_vw(ji,jj, 1 ) = 0._wp 
    103          END DO 
    104       END DO 
     97      DO_2D_00_00 
     98         zfu_uw(ji,jj,jpk) = 0._wp   ;   zfv_vw(ji,jj,jpk) = 0._wp 
     99         zfu_uw(ji,jj, 1 ) = 0._wp   ;   zfv_vw(ji,jj, 1 ) = 0._wp 
     100      END_2D 
    105101      IF( ln_linssh ) THEN                ! linear free surface: advection through the surface 
    106          DO jj = 2, jpjm1 
    107             DO ji = fs_2, fs_jpim1 
    108                zfu_uw(ji,jj,1) = 0.5_wp * ( e1e2t(ji,jj) * wn(ji,jj,1) + e1e2t(ji+1,jj) * wn(ji+1,jj,1) ) * un(ji,jj,1) 
    109                zfv_vw(ji,jj,1) = 0.5_wp * ( e1e2t(ji,jj) * wn(ji,jj,1) + e1e2t(ji,jj+1) * wn(ji,jj+1,1) ) * vn(ji,jj,1) 
    110             END DO 
    111          END DO 
     102         DO_2D_00_00 
     103            zfu_uw(ji,jj,1) = 0.5_wp * ( e1e2t(ji,jj) * ww(ji,jj,1) + e1e2t(ji+1,jj) * ww(ji+1,jj,1) ) * puu(ji,jj,1,Kmm) 
     104            zfv_vw(ji,jj,1) = 0.5_wp * ( e1e2t(ji,jj) * ww(ji,jj,1) + e1e2t(ji,jj+1) * ww(ji,jj+1,1) ) * pvv(ji,jj,1,Kmm) 
     105         END_2D 
    112106      ENDIF 
    113107      DO jk = 2, jpkm1                    ! interior advective fluxes 
    114          DO jj = 2, jpj                       ! 1/4 * Vertical transport 
    115             DO ji = 2, jpi 
    116                zfw(ji,jj,jk) = 0.25_wp * e1e2t(ji,jj) * wn(ji,jj,jk) 
    117             END DO 
    118          END DO 
    119          DO jj = 2, jpjm1 
    120             DO ji = fs_2, fs_jpim1   ! vector opt. 
    121                zfu_uw(ji,jj,jk) = ( zfw(ji,jj,jk) + zfw(ji+1,jj  ,jk) ) * ( un(ji,jj,jk) + un(ji,jj,jk-1) ) 
    122                zfv_vw(ji,jj,jk) = ( zfw(ji,jj,jk) + zfw(ji  ,jj+1,jk) ) * ( vn(ji,jj,jk) + vn(ji,jj,jk-1) ) 
    123             END DO 
    124          END DO 
     108         DO_2D_01_01 
     109            zfw(ji,jj,jk) = 0.25_wp * e1e2t(ji,jj) * ww(ji,jj,jk) 
     110         END_2D 
     111         DO_2D_00_00 
     112            zfu_uw(ji,jj,jk) = ( zfw(ji,jj,jk) + zfw(ji+1,jj  ,jk) ) * ( puu(ji,jj,jk,Kmm) + puu(ji,jj,jk-1,Kmm) ) 
     113            zfv_vw(ji,jj,jk) = ( zfw(ji,jj,jk) + zfw(ji  ,jj+1,jk) ) * ( pvv(ji,jj,jk,Kmm) + pvv(ji,jj,jk-1,Kmm) ) 
     114         END_2D 
    125115      END DO 
    126       DO jk = 1, jpkm1                    ! divergence of vertical momentum flux divergence 
    127          DO jj = 2, jpjm1  
    128             DO ji = fs_2, fs_jpim1   ! vector opt. 
    129                ua(ji,jj,jk) = ua(ji,jj,jk) - ( zfu_uw(ji,jj,jk) - zfu_uw(ji,jj,jk+1) ) * r1_e1e2u(ji,jj) / e3u_n(ji,jj,jk) 
    130                va(ji,jj,jk) = va(ji,jj,jk) - ( zfv_vw(ji,jj,jk) - zfv_vw(ji,jj,jk+1) ) * r1_e1e2v(ji,jj) / e3v_n(ji,jj,jk) 
    131             END DO 
    132          END DO 
    133       END DO 
     116      DO_3D_00_00( 1, jpkm1 ) 
     117         puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) - ( zfu_uw(ji,jj,jk) - zfu_uw(ji,jj,jk+1) ) * r1_e1e2u(ji,jj) / e3u(ji,jj,jk,Kmm) 
     118         pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) - ( zfv_vw(ji,jj,jk) - zfv_vw(ji,jj,jk+1) ) * r1_e1e2v(ji,jj) / e3v(ji,jj,jk,Kmm) 
     119      END_3D 
    134120      ! 
    135121      IF( l_trddyn ) THEN                 ! trends: send trend to trddyn for diagnostic 
    136          zfu_t(:,:,:) = ua(:,:,:) - zfu_t(:,:,:) 
    137          zfv_t(:,:,:) = va(:,:,:) - zfv_t(:,:,:) 
    138          CALL trd_dyn( zfu_t, zfv_t, jpdyn_zad, kt ) 
     122         zfu_t(:,:,:) = puu(:,:,:,Krhs) - zfu_t(:,:,:) 
     123         zfv_t(:,:,:) = pvv(:,:,:,Krhs) - zfv_t(:,:,:) 
     124         CALL trd_dyn( zfu_t, zfv_t, jpdyn_zad, kt, Kmm ) 
    139125      ENDIF 
    140126      !                                   ! Control print 
    141       IF(ln_ctl)   CALL prt_ctl( tab3d_1=ua, clinfo1=' cen2 adv - Ua: ', mask1=umask,   & 
    142          &                       tab3d_2=va, clinfo2=           ' Va: ', mask2=vmask, clinfo3='dyn' ) 
     127      IF(sn_cfctl%l_prtctl)   CALL prt_ctl( tab3d_1=puu(:,:,:,Krhs), clinfo1=' cen2 adv - Ua: ', mask1=umask,   & 
     128         &                                  tab3d_2=pvv(:,:,:,Krhs), clinfo2=           ' Va: ', mask2=vmask, clinfo3='dyn' ) 
    143129      ! 
    144130   END SUBROUTINE dyn_adv_cen2 

  • NEMO/trunk/src/OCE/DYN/dynadv_ubs.F90

    r10425 r12377  
    3333 
    3434   !! * Substitutions 
    35 #  include "vectopt_loop_substitute.h90" 
     35#  include "do_loop_substitute.h90" 
    3636   !!---------------------------------------------------------------------- 
    3737   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    4141CONTAINS 
    4242 
    43    SUBROUTINE dyn_adv_ubs( kt ) 
     43   SUBROUTINE dyn_adv_ubs( kt, Kbb, Kmm, puu, pvv, Krhs ) 
    4444      !!---------------------------------------------------------------------- 
    4545      !!                  ***  ROUTINE dyn_adv_ubs  *** 
    … …  
    6464      !!      gamma1=1/3 and gamma2=1/32. 
    6565      !! 
    66       !! ** Action : - (ua,va) updated with the 3D advective momentum trends 
     66      !! ** Action : - (puu(:,:,:,Krhs),pvv(:,:,:,Krhs)) updated with the 3D advective momentum trends 
    6767      !! 
    6868      !! Reference : Shchepetkin & McWilliams, 2005, Ocean Modelling.  
    6969      !!---------------------------------------------------------------------- 
    70       INTEGER, INTENT(in) ::   kt   ! ocean time-step index 
     70      INTEGER                             , INTENT( in )  ::  kt              ! ocean time-step index 
     71      INTEGER                             , INTENT( in )  ::  Kbb, Kmm, Krhs  ! ocean time level indices 
     72      REAL(wp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) ::  puu, pvv        ! ocean velocities and RHS of momentum equation 
    7173      ! 
    7274      INTEGER  ::   ji, jj, jk   ! dummy loop indices 
    … …  
    9597      ! 
    9698      IF( l_trddyn ) THEN           ! trends: store the input trends 
    97          zfu_uw(:,:,:) = ua(:,:,:) 
    98          zfv_vw(:,:,:) = va(:,:,:) 
     99         zfu_uw(:,:,:) = puu(:,:,:,Krhs) 
     100         zfv_vw(:,:,:) = pvv(:,:,:,Krhs) 
    99101      ENDIF 
    100102      !                                      ! =========================== ! 
    … …  
    102104         !                                   ! =========================== ! 
    103105         !                                         ! horizontal volume fluxes 
    104          zfu(:,:,jk) = e2u(:,:) * e3u_n(:,:,jk) * un(:,:,jk) 
    105          zfv(:,:,jk) = e1v(:,:) * e3v_n(:,:,jk) * vn(:,:,jk) 
     106         zfu(:,:,jk) = e2u(:,:) * e3u(:,:,jk,Kmm) * puu(:,:,jk,Kmm) 
     107         zfv(:,:,jk) = e1v(:,:) * e3v(:,:,jk,Kmm) * pvv(:,:,jk,Kmm) 
    106108         !             
    107          DO jj = 2, jpjm1                          ! laplacian 
    108             DO ji = fs_2, fs_jpim1   ! vector opt. 
    109                zlu_uu(ji,jj,jk,1) = ( ub (ji+1,jj  ,jk) - 2.*ub (ji,jj,jk) + ub (ji-1,jj  ,jk) ) * umask(ji,jj,jk) 
    110                zlv_vv(ji,jj,jk,1) = ( vb (ji  ,jj+1,jk) - 2.*vb (ji,jj,jk) + vb (ji  ,jj-1,jk) ) * vmask(ji,jj,jk) 
    111                zlu_uv(ji,jj,jk,1) = ( ub (ji  ,jj+1,jk) - ub (ji  ,jj  ,jk) ) * fmask(ji  ,jj  ,jk)   & 
    112                   &               - ( ub (ji  ,jj  ,jk) - ub (ji  ,jj-1,jk) ) * fmask(ji  ,jj-1,jk) 
    113                zlv_vu(ji,jj,jk,1) = ( vb (ji+1,jj  ,jk) - vb (ji  ,jj  ,jk) ) * fmask(ji  ,jj  ,jk)   & 
    114                   &               - ( vb (ji  ,jj  ,jk) - vb (ji-1,jj  ,jk) ) * fmask(ji-1,jj  ,jk) 
    115                ! 
    116                zlu_uu(ji,jj,jk,2) = ( zfu(ji+1,jj  ,jk) - 2.*zfu(ji,jj,jk) + zfu(ji-1,jj  ,jk) ) * umask(ji,jj,jk) 
    117                zlv_vv(ji,jj,jk,2) = ( zfv(ji  ,jj+1,jk) - 2.*zfv(ji,jj,jk) + zfv(ji  ,jj-1,jk) ) * vmask(ji,jj,jk) 
    118                zlu_uv(ji,jj,jk,2) = ( zfu(ji  ,jj+1,jk) - zfu(ji  ,jj  ,jk) ) * fmask(ji  ,jj  ,jk)   & 
    119                   &               - ( zfu(ji  ,jj  ,jk) - zfu(ji  ,jj-1,jk) ) * fmask(ji  ,jj-1,jk) 
    120                zlv_vu(ji,jj,jk,2) = ( zfv(ji+1,jj  ,jk) - zfv(ji  ,jj  ,jk) ) * fmask(ji  ,jj  ,jk)   & 
    121                   &               - ( zfv(ji  ,jj  ,jk) - zfv(ji-1,jj  ,jk) ) * fmask(ji-1,jj  ,jk) 
    122             END DO 
    123          END DO 
     109         DO_2D_00_00 
     110            zlu_uu(ji,jj,jk,1) = ( puu (ji+1,jj  ,jk,Kbb) - 2.*puu (ji,jj,jk,Kbb) + puu (ji-1,jj  ,jk,Kbb) ) * umask(ji,jj,jk) 
     111            zlv_vv(ji,jj,jk,1) = ( pvv (ji  ,jj+1,jk,Kbb) - 2.*pvv (ji,jj,jk,Kbb) + pvv (ji  ,jj-1,jk,Kbb) ) * vmask(ji,jj,jk) 
     112            zlu_uv(ji,jj,jk,1) = ( puu (ji  ,jj+1,jk,Kbb) - puu (ji  ,jj  ,jk,Kbb) ) * fmask(ji  ,jj  ,jk)   & 
     113               &               - ( puu (ji  ,jj  ,jk,Kbb) - puu (ji  ,jj-1,jk,Kbb) ) * fmask(ji  ,jj-1,jk) 
     114            zlv_vu(ji,jj,jk,1) = ( pvv (ji+1,jj  ,jk,Kbb) - pvv (ji  ,jj  ,jk,Kbb) ) * fmask(ji  ,jj  ,jk)   & 
     115               &               - ( pvv (ji  ,jj  ,jk,Kbb) - pvv (ji-1,jj  ,jk,Kbb) ) * fmask(ji-1,jj  ,jk) 
     116            ! 
     117            zlu_uu(ji,jj,jk,2) = ( zfu(ji+1,jj  ,jk) - 2.*zfu(ji,jj,jk) + zfu(ji-1,jj  ,jk) ) * umask(ji,jj,jk) 
     118            zlv_vv(ji,jj,jk,2) = ( zfv(ji  ,jj+1,jk) - 2.*zfv(ji,jj,jk) + zfv(ji  ,jj-1,jk) ) * vmask(ji,jj,jk) 
     119            zlu_uv(ji,jj,jk,2) = ( zfu(ji  ,jj+1,jk) - zfu(ji  ,jj  ,jk) ) * fmask(ji  ,jj  ,jk)   & 
     120               &               - ( zfu(ji  ,jj  ,jk) - zfu(ji  ,jj-1,jk) ) * fmask(ji  ,jj-1,jk) 
     121            zlv_vu(ji,jj,jk,2) = ( zfv(ji+1,jj  ,jk) - zfv(ji  ,jj  ,jk) ) * fmask(ji  ,jj  ,jk)   & 
     122               &               - ( zfv(ji  ,jj  ,jk) - zfv(ji-1,jj  ,jk) ) * fmask(ji-1,jj  ,jk) 
     123         END_2D 
    124124      END DO 
    125125      CALL lbc_lnk_multi( 'dynadv_ubs', zlu_uu(:,:,:,1), 'U', 1. , zlu_uv(:,:,:,1), 'U', 1.,  & 
    … …  
    132132      DO jk = 1, jpkm1                       ! ====================== ! 
    133133         !                                         ! horizontal volume fluxes 
    134          zfu(:,:,jk) = 0.25_wp * e2u(:,:) * e3u_n(:,:,jk) * un(:,:,jk) 
    135          zfv(:,:,jk) = 0.25_wp * e1v(:,:) * e3v_n(:,:,jk) * vn(:,:,jk) 
     134         zfu(:,:,jk) = 0.25_wp * e2u(:,:) * e3u(:,:,jk,Kmm) * puu(:,:,jk,Kmm) 
     135         zfv(:,:,jk) = 0.25_wp * e1v(:,:) * e3v(:,:,jk,Kmm) * pvv(:,:,jk,Kmm) 
    136136         ! 
    137          DO jj = 1, jpjm1                          ! horizontal momentum fluxes at T- and F-point 
    138             DO ji = 1, fs_jpim1   ! vector opt. 
    139                zui = ( un(ji,jj,jk) + un(ji+1,jj  ,jk) ) 
    140                zvj = ( vn(ji,jj,jk) + vn(ji  ,jj+1,jk) ) 
    141                ! 
    142                IF( zui > 0 ) THEN   ;   zl_u = zlu_uu(ji  ,jj,jk,1) 
    143                ELSE                 ;   zl_u = zlu_uu(ji+1,jj,jk,1) 
    144                ENDIF 
    145                IF( zvj > 0 ) THEN   ;   zl_v = zlv_vv(ji,jj  ,jk,1) 
    146                ELSE                 ;   zl_v = zlv_vv(ji,jj+1,jk,1) 
    147                ENDIF 
    148                ! 
    149                zfu_t(ji+1,jj  ,jk) = ( zfu(ji,jj,jk) + zfu(ji+1,jj  ,jk)                               & 
    150                   &                    - gamma2 * ( zlu_uu(ji,jj,jk,2) + zlu_uu(ji+1,jj  ,jk,2) )  )   & 
    151                   &                * ( zui - gamma1 * zl_u) 
    152                zfv_t(ji  ,jj+1,jk) = ( zfv(ji,jj,jk) + zfv(ji  ,jj+1,jk)                               & 
    153                   &                    - gamma2 * ( zlv_vv(ji,jj,jk,2) + zlv_vv(ji  ,jj+1,jk,2) )  )   & 
    154                   &                * ( zvj - gamma1 * zl_v) 
    155                ! 
    156                zfuj = ( zfu(ji,jj,jk) + zfu(ji  ,jj+1,jk) ) 
    157                zfvi = ( zfv(ji,jj,jk) + zfv(ji+1,jj  ,jk) ) 
    158                IF( zfuj > 0 ) THEN   ;    zl_v = zlv_vu( ji  ,jj  ,jk,1) 
    159                ELSE                  ;    zl_v = zlv_vu( ji+1,jj,jk,1) 
    160                ENDIF 
    161                IF( zfvi > 0 ) THEN   ;    zl_u = zlu_uv( ji,jj  ,jk,1) 
    162                ELSE                  ;    zl_u = zlu_uv( ji,jj+1,jk,1) 
    163                ENDIF 
    164                ! 
    165                zfv_f(ji  ,jj  ,jk) = ( zfvi - gamma2 * ( zlv_vu(ji,jj,jk,2) + zlv_vu(ji+1,jj  ,jk,2) )  )   & 
    166                   &                * ( un(ji,jj,jk) + un(ji  ,jj+1,jk) - gamma1 * zl_u ) 
    167                zfu_f(ji  ,jj  ,jk) = ( zfuj - gamma2 * ( zlu_uv(ji,jj,jk,2) + zlu_uv(ji  ,jj+1,jk,2) )  )   & 
    168                   &                * ( vn(ji,jj,jk) + vn(ji+1,jj  ,jk) - gamma1 * zl_v ) 
    169             END DO 
    170          END DO 
    171          DO jj = 2, jpjm1                          ! divergence of horizontal momentum fluxes 
    172             DO ji = fs_2, fs_jpim1   ! vector opt. 
    173                ua(ji,jj,jk) = ua(ji,jj,jk) - (  zfu_t(ji+1,jj,jk) - zfu_t(ji,jj  ,jk)    & 
    174                   &                           + zfv_f(ji  ,jj,jk) - zfv_f(ji,jj-1,jk)  ) * r1_e1e2u(ji,jj) / e3u_n(ji,jj,jk) 
    175                va(ji,jj,jk) = va(ji,jj,jk) - (  zfu_f(ji,jj  ,jk) - zfu_f(ji-1,jj,jk)    & 
    176                   &                           + zfv_t(ji,jj+1,jk) - zfv_t(ji  ,jj,jk)  ) * r1_e1e2v(ji,jj) / e3v_n(ji,jj,jk) 
    177             END DO 
    178          END DO 
     137         DO_2D_10_10 
     138            zui = ( puu(ji,jj,jk,Kmm) + puu(ji+1,jj  ,jk,Kmm) ) 
     139            zvj = ( pvv(ji,jj,jk,Kmm) + pvv(ji  ,jj+1,jk,Kmm) ) 
     140            ! 
     141            IF( zui > 0 ) THEN   ;   zl_u = zlu_uu(ji  ,jj,jk,1) 
     142            ELSE                 ;   zl_u = zlu_uu(ji+1,jj,jk,1) 
     143            ENDIF 
     144            IF( zvj > 0 ) THEN   ;   zl_v = zlv_vv(ji,jj  ,jk,1) 
     145            ELSE                 ;   zl_v = zlv_vv(ji,jj+1,jk,1) 
     146            ENDIF 
     147            ! 
     148            zfu_t(ji+1,jj  ,jk) = ( zfu(ji,jj,jk) + zfu(ji+1,jj  ,jk)                               & 
     149               &                    - gamma2 * ( zlu_uu(ji,jj,jk,2) + zlu_uu(ji+1,jj  ,jk,2) )  )   & 
     150               &                * ( zui - gamma1 * zl_u) 
     151            zfv_t(ji  ,jj+1,jk) = ( zfv(ji,jj,jk) + zfv(ji  ,jj+1,jk)                               & 
     152               &                    - gamma2 * ( zlv_vv(ji,jj,jk,2) + zlv_vv(ji  ,jj+1,jk,2) )  )   & 
     153               &                * ( zvj - gamma1 * zl_v) 
     154            ! 
     155            zfuj = ( zfu(ji,jj,jk) + zfu(ji  ,jj+1,jk) ) 
     156            zfvi = ( zfv(ji,jj,jk) + zfv(ji+1,jj  ,jk) ) 
     157            IF( zfuj > 0 ) THEN   ;    zl_v = zlv_vu( ji  ,jj  ,jk,1) 
     158            ELSE                  ;    zl_v = zlv_vu( ji+1,jj,jk,1) 
     159            ENDIF 
     160            IF( zfvi > 0 ) THEN   ;    zl_u = zlu_uv( ji,jj  ,jk,1) 
     161            ELSE                  ;    zl_u = zlu_uv( ji,jj+1,jk,1) 
     162            ENDIF 
     163            ! 
     164            zfv_f(ji  ,jj  ,jk) = ( zfvi - gamma2 * ( zlv_vu(ji,jj,jk,2) + zlv_vu(ji+1,jj  ,jk,2) )  )   & 
     165               &                * ( puu(ji,jj,jk,Kmm) + puu(ji  ,jj+1,jk,Kmm) - gamma1 * zl_u ) 
     166            zfu_f(ji  ,jj  ,jk) = ( zfuj - gamma2 * ( zlu_uv(ji,jj,jk,2) + zlu_uv(ji  ,jj+1,jk,2) )  )   & 
     167               &                * ( pvv(ji,jj,jk,Kmm) + pvv(ji+1,jj  ,jk,Kmm) - gamma1 * zl_v ) 
     168         END_2D 
     169         DO_2D_00_00 
     170            puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) - (  zfu_t(ji+1,jj,jk) - zfu_t(ji,jj  ,jk)    & 
     171               &                           + zfv_f(ji  ,jj,jk) - zfv_f(ji,jj-1,jk)  ) * r1_e1e2u(ji,jj) / e3u(ji,jj,jk,Kmm) 
     172            pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) - (  zfu_f(ji,jj  ,jk) - zfu_f(ji-1,jj,jk)    & 
     173               &                           + zfv_t(ji,jj+1,jk) - zfv_t(ji  ,jj,jk)  ) * r1_e1e2v(ji,jj) / e3v(ji,jj,jk,Kmm) 
     174         END_2D 
    179175      END DO 
    180176      IF( l_trddyn ) THEN                          ! trends: send trends to trddyn for diagnostic 
    181          zfu_uw(:,:,:) = ua(:,:,:) - zfu_uw(:,:,:) 
    182          zfv_vw(:,:,:) = va(:,:,:) - zfv_vw(:,:,:) 
    183          CALL trd_dyn( zfu_uw, zfv_vw, jpdyn_keg, kt ) 
    184          zfu_t(:,:,:) = ua(:,:,:) 
    185          zfv_t(:,:,:) = va(:,:,:) 
     177         zfu_uw(:,:,:) = puu(:,:,:,Krhs) - zfu_uw(:,:,:) 
     178         zfv_vw(:,:,:) = pvv(:,:,:,Krhs) - zfv_vw(:,:,:) 
     179         CALL trd_dyn( zfu_uw, zfv_vw, jpdyn_keg, kt, Kmm ) 
     180         zfu_t(:,:,:) = puu(:,:,:,Krhs) 
     181         zfv_t(:,:,:) = pvv(:,:,:,Krhs) 
    186182      ENDIF 
    187183      !                                      ! ==================== ! 
    188184      !                                      !  Vertical advection  ! 
    189185      !                                      ! ==================== ! 
    190       DO jj = 2, jpjm1                             ! surface/bottom advective fluxes set to zero                   
    191          DO ji = fs_2, fs_jpim1 
    192             zfu_uw(ji,jj,jpk) = 0._wp 
    193             zfv_vw(ji,jj,jpk) = 0._wp 
    194             zfu_uw(ji,jj, 1 ) = 0._wp 
    195             zfv_vw(ji,jj, 1 ) = 0._wp 
    196          END DO 
     186      DO_2D_00_00 
     187         zfu_uw(ji,jj,jpk) = 0._wp 
     188         zfv_vw(ji,jj,jpk) = 0._wp 
     189         zfu_uw(ji,jj, 1 ) = 0._wp 
     190         zfv_vw(ji,jj, 1 ) = 0._wp 
     191      END_2D 
     192      IF( ln_linssh ) THEN                         ! constant volume : advection through the surface 
     193         DO_2D_00_00 
     194            zfu_uw(ji,jj,1) = 0.5_wp * ( e1e2t(ji,jj) * ww(ji,jj,1) + e1e2t(ji+1,jj) * ww(ji+1,jj,1) ) * puu(ji,jj,1,Kmm) 
     195            zfv_vw(ji,jj,1) = 0.5_wp * ( e1e2t(ji,jj) * ww(ji,jj,1) + e1e2t(ji,jj+1) * ww(ji,jj+1,1) ) * pvv(ji,jj,1,Kmm) 
     196         END_2D 
     197      ENDIF 
     198      DO jk = 2, jpkm1                          ! interior fluxes 
     199         DO_2D_01_01 
     200            zfw(ji,jj,jk) = 0.25_wp * e1e2t(ji,jj) * ww(ji,jj,jk) 
     201         END_2D 
     202         DO_2D_00_00 
     203            zfu_uw(ji,jj,jk) = ( zfw(ji,jj,jk)+ zfw(ji+1,jj,jk) ) * ( puu(ji,jj,jk,Kmm) + puu(ji,jj,jk-1,Kmm) ) 
     204            zfv_vw(ji,jj,jk) = ( zfw(ji,jj,jk)+ zfw(ji,jj+1,jk) ) * ( pvv(ji,jj,jk,Kmm) + pvv(ji,jj,jk-1,Kmm) ) 
     205         END_2D 
    197206      END DO 
    198       IF( ln_linssh ) THEN                         ! constant volume : advection through the surface 
    199          DO jj = 2, jpjm1 
    200             DO ji = fs_2, fs_jpim1 
    201                zfu_uw(ji,jj,1) = 0.5_wp * ( e1e2t(ji,jj) * wn(ji,jj,1) + e1e2t(ji+1,jj) * wn(ji+1,jj,1) ) * un(ji,jj,1) 
    202                zfv_vw(ji,jj,1) = 0.5_wp * ( e1e2t(ji,jj) * wn(ji,jj,1) + e1e2t(ji,jj+1) * wn(ji,jj+1,1) ) * vn(ji,jj,1) 
    203             END DO 
    204          END DO 
    205       ENDIF 
    206       DO jk = 2, jpkm1                          ! interior fluxes 
    207          DO jj = 2, jpj 
    208             DO ji = 2, jpi 
    209                zfw(ji,jj,jk) = 0.25_wp * e1e2t(ji,jj) * wn(ji,jj,jk) 
    210             END DO 
    211          END DO 
    212          DO jj = 2, jpjm1 
    213             DO ji = fs_2, fs_jpim1   ! vector opt. 
    214                zfu_uw(ji,jj,jk) = ( zfw(ji,jj,jk)+ zfw(ji+1,jj,jk) ) * ( un(ji,jj,jk) + un(ji,jj,jk-1) ) 
    215                zfv_vw(ji,jj,jk) = ( zfw(ji,jj,jk)+ zfw(ji,jj+1,jk) ) * ( vn(ji,jj,jk) + vn(ji,jj,jk-1) ) 
    216             END DO 
    217          END DO 
    218       END DO 
    219       DO jk = 1, jpkm1                          ! divergence of vertical momentum flux divergence 
    220          DO jj = 2, jpjm1 
    221             DO ji = fs_2, fs_jpim1   ! vector opt. 
    222                ua(ji,jj,jk) =  ua(ji,jj,jk) - ( zfu_uw(ji,jj,jk) - zfu_uw(ji,jj,jk+1) ) * r1_e1e2u(ji,jj) / e3u_n(ji,jj,jk) 
    223                va(ji,jj,jk) =  va(ji,jj,jk) - ( zfv_vw(ji,jj,jk) - zfv_vw(ji,jj,jk+1) ) * r1_e1e2v(ji,jj) / e3v_n(ji,jj,jk) 
    224             END DO 
    225          END DO 
    226       END DO 
     207      DO_3D_00_00( 1, jpkm1 ) 
     208         puu(ji,jj,jk,Krhs) =  puu(ji,jj,jk,Krhs) - ( zfu_uw(ji,jj,jk) - zfu_uw(ji,jj,jk+1) ) * r1_e1e2u(ji,jj) / e3u(ji,jj,jk,Kmm) 
     209         pvv(ji,jj,jk,Krhs) =  pvv(ji,jj,jk,Krhs) - ( zfv_vw(ji,jj,jk) - zfv_vw(ji,jj,jk+1) ) * r1_e1e2v(ji,jj) / e3v(ji,jj,jk,Kmm) 
     210      END_3D 
    227211      ! 
    228212      IF( l_trddyn ) THEN                       ! save the vertical advection trend for diagnostic 
    229          zfu_t(:,:,:) = ua(:,:,:) - zfu_t(:,:,:) 
    230          zfv_t(:,:,:) = va(:,:,:) - zfv_t(:,:,:) 
    231          CALL trd_dyn( zfu_t, zfv_t, jpdyn_zad, kt ) 
     213         zfu_t(:,:,:) = puu(:,:,:,Krhs) - zfu_t(:,:,:) 
     214         zfv_t(:,:,:) = pvv(:,:,:,Krhs) - zfv_t(:,:,:) 
     215         CALL trd_dyn( zfu_t, zfv_t, jpdyn_zad, kt, Kmm ) 
    232216      ENDIF 
    233217      !                                         ! Control print 
    234       IF(ln_ctl)   CALL prt_ctl( tab3d_1=ua, clinfo1=' ubs2 adv - Ua: ', mask1=umask,   & 
    235          &                       tab3d_2=va, clinfo2=           ' Va: ', mask2=vmask, clinfo3='dyn' ) 
     218      IF(sn_cfctl%l_prtctl)   CALL prt_ctl( tab3d_1=puu(:,:,:,Krhs), clinfo1=' ubs2 adv - Ua: ', mask1=umask,   & 
     219         &                                  tab3d_2=pvv(:,:,:,Krhs), clinfo2=           ' Va: ', mask2=vmask, clinfo3='dyn' ) 
    236220      ! 
    237221   END SUBROUTINE dyn_adv_ubs 

  • NEMO/trunk/src/OCE/DYN/dynhpg.F90

    r11536 r12377  
    3131   !!---------------------------------------------------------------------- 
    3232   USE oce             ! ocean dynamics and tracers 
     33   USE isf_oce , ONLY : risfload  ! ice shelf  (risfload variable) 
     34   USE isfload , ONLY : isf_load  ! ice shelf  (isf_load routine ) 
    3335   USE sbc_oce         ! surface variable (only for the flag with ice shelf) 
    3436   USE dom_oce         ! ocean space and time domain 
    … …  
    7375 
    7476   !! * Substitutions 
    75 #  include "vectopt_loop_substitute.h90" 
     77#  include "do_loop_substitute.h90" 
    7678   !!---------------------------------------------------------------------- 
    7779   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    8183CONTAINS 
    8284 
    83    SUBROUTINE dyn_hpg( kt ) 
     85   SUBROUTINE dyn_hpg( kt, Kmm, puu, pvv, Krhs ) 
    8486      !!--------------------------------------------------------------------- 
    8587      !!                  ***  ROUTINE dyn_hpg  *** 
    … …  
    8890      !!              using the scheme defined in the namelist 
    8991      !! 
    90       !! ** Action : - Update (ua,va) with the now hydrastatic pressure trend 
     92      !! ** Action : - Update (puu(:,:,:,Krhs),pvv(:,:,:,Krhs)) with the now hydrastatic pressure trend 
    9193      !!             - send trends to trd_dyn for futher diagnostics (l_trddyn=T) 
    9294      !!---------------------------------------------------------------------- 
    93       INTEGER, INTENT(in) ::   kt   ! ocean time-step index 
     95      INTEGER                             , INTENT( in )  ::  kt          ! ocean time-step index 
     96      INTEGER                             , INTENT( in )  ::  Kmm, Krhs   ! ocean time level indices 
     97      REAL(wp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) ::  puu, pvv    ! ocean velocities and RHS of momentum equation 
     98      ! 
    9499      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   ztrdu, ztrdv 
    95100      !!---------------------------------------------------------------------- 
    … …  
    97102      IF( ln_timing )   CALL timing_start('dyn_hpg') 
    98103      ! 
    99       IF( l_trddyn ) THEN                    ! Temporary saving of ua and va trends (l_trddyn) 
     104      IF( l_trddyn ) THEN                    ! Temporary saving of puu(:,:,:,Krhs) and pvv(:,:,:,Krhs) trends (l_trddyn) 
    100105         ALLOCATE( ztrdu(jpi,jpj,jpk) , ztrdv(jpi,jpj,jpk) ) 
    101          ztrdu(:,:,:) = ua(:,:,:) 
    102          ztrdv(:,:,:) = va(:,:,:) 
     106         ztrdu(:,:,:) = puu(:,:,:,Krhs) 
     107         ztrdv(:,:,:) = pvv(:,:,:,Krhs) 
    103108      ENDIF 
    104109      ! 
    105110      SELECT CASE ( nhpg )      ! Hydrostatic pressure gradient computation 
    106       CASE ( np_zco )   ;   CALL hpg_zco    ( kt )      ! z-coordinate 
    107       CASE ( np_zps )   ;   CALL hpg_zps    ( kt )      ! z-coordinate plus partial steps (interpolation) 
    108       CASE ( np_sco )   ;   CALL hpg_sco    ( kt )      ! s-coordinate (standard jacobian formulation) 
    109       CASE ( np_djc )   ;   CALL hpg_djc    ( kt )      ! s-coordinate (Density Jacobian with Cubic polynomial) 
    110       CASE ( np_prj )   ;   CALL hpg_prj    ( kt )      ! s-coordinate (Pressure Jacobian scheme) 
    111       CASE ( np_isf )   ;   CALL hpg_isf    ( kt )      ! s-coordinate similar to sco modify for ice shelf 
     111      CASE ( np_zco )   ;   CALL hpg_zco    ( kt, Kmm, puu, pvv, Krhs )  ! z-coordinate 
     112      CASE ( np_zps )   ;   CALL hpg_zps    ( kt, Kmm, puu, pvv, Krhs )  ! z-coordinate plus partial steps (interpolation) 
     113      CASE ( np_sco )   ;   CALL hpg_sco    ( kt, Kmm, puu, pvv, Krhs )  ! s-coordinate (standard jacobian formulation) 
     114      CASE ( np_djc )   ;   CALL hpg_djc    ( kt, Kmm, puu, pvv, Krhs )  ! s-coordinate (Density Jacobian with Cubic polynomial) 
     115      CASE ( np_prj )   ;   CALL hpg_prj    ( kt, Kmm, puu, pvv, Krhs )  ! s-coordinate (Pressure Jacobian scheme) 
     116      CASE ( np_isf )   ;   CALL hpg_isf    ( kt, Kmm, puu, pvv, Krhs )  ! s-coordinate similar to sco modify for ice shelf 
    112117      END SELECT 
    113118      ! 
    114119      IF( l_trddyn ) THEN      ! save the hydrostatic pressure gradient trends for momentum trend diagnostics 
    115          ztrdu(:,:,:) = ua(:,:,:) - ztrdu(:,:,:) 
    116          ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:) 
    117          CALL trd_dyn( ztrdu, ztrdv, jpdyn_hpg, kt ) 
     120         ztrdu(:,:,:) = puu(:,:,:,Krhs) - ztrdu(:,:,:) 
     121         ztrdv(:,:,:) = pvv(:,:,:,Krhs) - ztrdv(:,:,:) 
     122         CALL trd_dyn( ztrdu, ztrdv, jpdyn_hpg, kt, Kmm ) 
    118123         DEALLOCATE( ztrdu , ztrdv ) 
    119124      ENDIF 
    120125      ! 
    121       IF(ln_ctl)   CALL prt_ctl( tab3d_1=ua, clinfo1=' hpg  - Ua: ', mask1=umask,   & 
    122          &                       tab3d_2=va, clinfo2=       ' Va: ', mask2=vmask, clinfo3='dyn' ) 
     126      IF(sn_cfctl%l_prtctl)   CALL prt_ctl( tab3d_1=puu(:,:,:,Krhs), clinfo1=' hpg  - Ua: ', mask1=umask,   & 
     127         &                                  tab3d_2=pvv(:,:,:,Krhs), clinfo2=       ' Va: ', mask2=vmask, clinfo3='dyn' ) 
    123128      ! 
    124129      IF( ln_timing )   CALL timing_stop('dyn_hpg') 
    … …  
    127132 
    128133 
    129    SUBROUTINE dyn_hpg_init 
     134   SUBROUTINE dyn_hpg_init( Kmm ) 
    130135      !!---------------------------------------------------------------------- 
    131136      !!                 ***  ROUTINE dyn_hpg_init  *** 
    … …  
    137142      !!      with the type of vertical coordinate used (zco, zps, sco) 
    138143      !!---------------------------------------------------------------------- 
     144      INTEGER, INTENT( in ) :: Kmm   ! ocean time level index 
     145      ! 
    139146      INTEGER ::   ioptio = 0      ! temporary integer 
    140147      INTEGER ::   ios             ! Local integer output status for namelist read 
    … …  
    150157      !!---------------------------------------------------------------------- 
    151158      ! 
    152       REWIND( numnam_ref )              ! Namelist namdyn_hpg in reference namelist : Hydrostatic pressure gradient 
    153159      READ  ( numnam_ref, namdyn_hpg, IOSTAT = ios, ERR = 901) 
    154160901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namdyn_hpg in reference namelist' ) 
    155161      ! 
    156       REWIND( numnam_cfg )              ! Namelist namdyn_hpg in configuration namelist : Hydrostatic pressure gradient 
    157162      READ  ( numnam_cfg, namdyn_hpg, IOSTAT = ios, ERR = 902 ) 
    158163902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namdyn_hpg in configuration namelist' ) 
    … …  
    213218      ENDIF 
    214219      !                           
    215       IF ( .NOT. ln_isfcav ) THEN     !--- no ice shelf load 
    216          riceload(:,:) = 0._wp 
    217          ! 
    218       ELSE                            !--- set an ice shelf load 
    219          ! 
    220          IF(lwp) WRITE(numout,*) 
    221          IF(lwp) WRITE(numout,*) '   ice shelf case: set the ice-shelf load' 
    222          ALLOCATE( zts_top(jpi,jpj,jpts) , zrhd(jpi,jpj,jpk) , zrhdtop_isf(jpi,jpj) , ziceload(jpi,jpj) )  
    223          ! 
    224          znad = 1._wp                     !- To use density and not density anomaly 
    225          ! 
    226          !                                !- assume water displaced by the ice shelf is at T=-1.9 and S=34.4 (rude) 
    227          zts_top(:,:,jp_tem) = -1.9_wp   ;   zts_top(:,:,jp_sal) = 34.4_wp 
    228          ! 
    229          DO jk = 1, jpk                   !- compute density of the water displaced by the ice shelf  
    230             CALL eos( zts_top(:,:,:), gdept_n(:,:,jk), zrhd(:,:,jk) ) 
    231          END DO 
    232          ! 
    233          !                                !- compute rhd at the ice/oce interface (ice shelf side) 
    234          CALL eos( zts_top , risfdep, zrhdtop_isf ) 
    235          ! 
    236          !                                !- Surface value + ice shelf gradient 
    237          ziceload = 0._wp                       ! compute pressure due to ice shelf load  
    238          DO jj = 1, jpj                         ! (used to compute hpgi/j for all the level from 1 to miku/v) 
    239             DO ji = 1, jpi                      ! divided by 2 later 
    240                ikt = mikt(ji,jj) 
    241                ziceload(ji,jj) = ziceload(ji,jj) + (znad + zrhd(ji,jj,1) ) * e3w_n(ji,jj,1) * (1._wp - tmask(ji,jj,1)) 
    242                DO jk = 2, ikt-1 
    243                   ziceload(ji,jj) = ziceload(ji,jj) + (2._wp * znad + zrhd(ji,jj,jk-1) + zrhd(ji,jj,jk)) * e3w_n(ji,jj,jk) & 
    244                      &                              * (1._wp - tmask(ji,jj,jk)) 
    245                END DO 
    246                IF (ikt  >=  2) ziceload(ji,jj) = ziceload(ji,jj) + (2._wp * znad + zrhdtop_isf(ji,jj) + zrhd(ji,jj,ikt-1)) & 
    247                   &                                              * ( risfdep(ji,jj) - gdept_n(ji,jj,ikt-1) ) 
    248             END DO 
    249          END DO 
    250          riceload(:,:) = ziceload(:,:)  ! need to be saved for diaar5 
    251          ! 
    252          DEALLOCATE( zts_top , zrhd , zrhdtop_isf , ziceload )  
    253       ENDIF 
    254       ! 
    255220   END SUBROUTINE dyn_hpg_init 
    256221 
    257222 
    258    SUBROUTINE hpg_zco( kt ) 
     223   SUBROUTINE hpg_zco( kt, Kmm, puu, pvv, Krhs ) 
    259224      !!--------------------------------------------------------------------- 
    260225      !!                  ***  ROUTINE hpg_zco  *** 
    … …  
    266231      !!      level:    zhpi = grav ..... 
    267232      !!                zhpj = grav ..... 
    268       !!      add it to the general momentum trend (ua,va). 
    269       !!            ua = ua - 1/e1u * zhpi 
    270       !!            va = va - 1/e2v * zhpj 
    271       !! 
    272       !! ** Action : - Update (ua,va) with the now hydrastatic pressure trend 
    273       !!---------------------------------------------------------------------- 
    274       INTEGER, INTENT(in) ::   kt    ! ocean time-step index 
     233      !!      add it to the general momentum trend (puu(:,:,:,Krhs),pvv(:,:,:,Krhs)). 
     234      !!            puu(:,:,:,Krhs) = puu(:,:,:,Krhs) - 1/e1u * zhpi 
     235      !!            pvv(:,:,:,Krhs) = pvv(:,:,:,Krhs) - 1/e2v * zhpj 
     236      !! 
     237      !! ** Action : - Update (puu(:,:,:,Krhs),pvv(:,:,:,Krhs)) with the now hydrastatic pressure trend 
     238      !!---------------------------------------------------------------------- 
     239      INTEGER                             , INTENT( in )  ::  kt          ! ocean time-step index 
     240      INTEGER                             , INTENT( in )  ::  Kmm, Krhs   ! ocean time level indices 
     241      REAL(wp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) ::  puu, pvv    ! ocean velocities and RHS of momentum equation 
    275242      ! 
    276243      INTEGER  ::   ji, jj, jk       ! dummy loop indices 
    … …  
    288255 
    289256      ! Surface value 
    290       DO jj = 2, jpjm1 
    291          DO ji = fs_2, fs_jpim1   ! vector opt. 
    292             zcoef1 = zcoef0 * e3w_n(ji,jj,1) 
    293             ! hydrostatic pressure gradient 
    294             zhpi(ji,jj,1) = zcoef1 * ( rhd(ji+1,jj,1) - rhd(ji,jj,1) ) * r1_e1u(ji,jj) 
    295             zhpj(ji,jj,1) = zcoef1 * ( rhd(ji,jj+1,1) - rhd(ji,jj,1) ) * r1_e2v(ji,jj) 
    296             ! add to the general momentum trend 
    297             ua(ji,jj,1) = ua(ji,jj,1) + zhpi(ji,jj,1) 
    298             va(ji,jj,1) = va(ji,jj,1) + zhpj(ji,jj,1) 
    299          END DO 
    300       END DO 
     257      DO_2D_00_00 
     258         zcoef1 = zcoef0 * e3w(ji,jj,1,Kmm) 
     259         ! hydrostatic pressure gradient 
     260         zhpi(ji,jj,1) = zcoef1 * ( rhd(ji+1,jj,1) - rhd(ji,jj,1) ) * r1_e1u(ji,jj) 
     261         zhpj(ji,jj,1) = zcoef1 * ( rhd(ji,jj+1,1) - rhd(ji,jj,1) ) * r1_e2v(ji,jj) 
     262         ! add to the general momentum trend 
     263         puu(ji,jj,1,Krhs) = puu(ji,jj,1,Krhs) + zhpi(ji,jj,1) 
     264         pvv(ji,jj,1,Krhs) = pvv(ji,jj,1,Krhs) + zhpj(ji,jj,1) 
     265      END_2D 
    301266 
    302267      ! 
    303268      ! interior value (2=<jk=<jpkm1) 
    304       DO jk = 2, jpkm1 
    305          DO jj = 2, jpjm1 
    306             DO ji = fs_2, fs_jpim1   ! vector opt. 
    307                zcoef1 = zcoef0 * e3w_n(ji,jj,jk) 
    308                ! hydrostatic pressure gradient 
    309                zhpi(ji,jj,jk) = zhpi(ji,jj,jk-1)   & 
    310                   &           + zcoef1 * (  ( rhd(ji+1,jj,jk)+rhd(ji+1,jj,jk-1) )    & 
    311                   &                       - ( rhd(ji  ,jj,jk)+rhd(ji  ,jj,jk-1) )  ) * r1_e1u(ji,jj) 
    312  
    313                zhpj(ji,jj,jk) = zhpj(ji,jj,jk-1)   & 
    314                   &           + zcoef1 * (  ( rhd(ji,jj+1,jk)+rhd(ji,jj+1,jk-1) )    & 
    315                   &                       - ( rhd(ji,jj,  jk)+rhd(ji,jj  ,jk-1) )  ) * r1_e2v(ji,jj) 
    316                ! add to the general momentum trend 
    317                ua(ji,jj,jk) = ua(ji,jj,jk) + zhpi(ji,jj,jk) 
    318                va(ji,jj,jk) = va(ji,jj,jk) + zhpj(ji,jj,jk) 
    319             END DO 
    320          END DO 
    321       END DO 
     269      DO_3D_00_00( 2, jpkm1 ) 
     270         zcoef1 = zcoef0 * e3w(ji,jj,jk,Kmm) 
     271         ! hydrostatic pressure gradient 
     272         zhpi(ji,jj,jk) = zhpi(ji,jj,jk-1)   & 
     273            &           + zcoef1 * (  ( rhd(ji+1,jj,jk)+rhd(ji+1,jj,jk-1) )    & 
     274            &                       - ( rhd(ji  ,jj,jk)+rhd(ji  ,jj,jk-1) )  ) * r1_e1u(ji,jj) 
     275 
     276         zhpj(ji,jj,jk) = zhpj(ji,jj,jk-1)   & 
     277            &           + zcoef1 * (  ( rhd(ji,jj+1,jk)+rhd(ji,jj+1,jk-1) )    & 
     278            &                       - ( rhd(ji,jj,  jk)+rhd(ji,jj  ,jk-1) )  ) * r1_e2v(ji,jj) 
     279         ! add to the general momentum trend 
     280         puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + zhpi(ji,jj,jk) 
     281         pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) + zhpj(ji,jj,jk) 
     282      END_3D 
    322283      ! 
    323284   END SUBROUTINE hpg_zco 
    324285 
    325286 
    326    SUBROUTINE hpg_zps( kt ) 
     287   SUBROUTINE hpg_zps( kt, Kmm, puu, pvv, Krhs ) 
    327288      !!--------------------------------------------------------------------- 
    328289      !!                 ***  ROUTINE hpg_zps  *** 
    … …  
    330291      !! ** Method  :   z-coordinate plus partial steps case.  blahblah... 
    331292      !! 
    332       !! ** Action  : - Update (ua,va) with the now hydrastatic pressure trend 
    333       !!---------------------------------------------------------------------- 
    334       INTEGER, INTENT(in) ::   kt    ! ocean time-step index 
     293      !! ** Action  : - Update (puu(:,:,:,Krhs),pvv(:,:,:,Krhs)) with the now hydrastatic pressure trend 
     294      !!---------------------------------------------------------------------- 
     295      INTEGER                             , INTENT( in )  ::  kt          ! ocean time-step index 
     296      INTEGER                             , INTENT( in )  ::  Kmm, Krhs   ! ocean time level indices 
     297      REAL(wp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) ::  puu, pvv    ! ocean velocities and RHS of momentum equation 
    335298      !! 
    336299      INTEGER  ::   ji, jj, jk                       ! dummy loop indices 
    … …  
    348311 
    349312      ! Partial steps: Compute NOW horizontal gradient of t, s, rd at the last ocean level 
    350       CALL zps_hde( kt, jpts, tsn, zgtsu, zgtsv, rhd, zgru , zgrv ) 
     313      CALL zps_hde( kt, Kmm, jpts, ts(:,:,:,:,Kmm), zgtsu, zgtsv, rhd, zgru , zgrv ) 
    351314 
    352315      ! Local constant initialization 
    … …  
    354317 
    355318      !  Surface value (also valid in partial step case) 
    356       DO jj = 2, jpjm1 
    357          DO ji = fs_2, fs_jpim1   ! vector opt. 
    358             zcoef1 = zcoef0 * e3w_n(ji,jj,1) 
    359             ! hydrostatic pressure gradient 
    360             zhpi(ji,jj,1) = zcoef1 * ( rhd(ji+1,jj  ,1) - rhd(ji,jj,1) ) * r1_e1u(ji,jj) 
    361             zhpj(ji,jj,1) = zcoef1 * ( rhd(ji  ,jj+1,1) - rhd(ji,jj,1) ) * r1_e2v(ji,jj) 
    362             ! add to the general momentum trend 
    363             ua(ji,jj,1) = ua(ji,jj,1) + zhpi(ji,jj,1) 
    364             va(ji,jj,1) = va(ji,jj,1) + zhpj(ji,jj,1) 
    365          END DO 
    366       END DO 
     319      DO_2D_00_00 
     320         zcoef1 = zcoef0 * e3w(ji,jj,1,Kmm) 
     321         ! hydrostatic pressure gradient 
     322         zhpi(ji,jj,1) = zcoef1 * ( rhd(ji+1,jj  ,1) - rhd(ji,jj,1) ) * r1_e1u(ji,jj) 
     323         zhpj(ji,jj,1) = zcoef1 * ( rhd(ji  ,jj+1,1) - rhd(ji,jj,1) ) * r1_e2v(ji,jj) 
     324         ! add to the general momentum trend 
     325         puu(ji,jj,1,Krhs) = puu(ji,jj,1,Krhs) + zhpi(ji,jj,1) 
     326         pvv(ji,jj,1,Krhs) = pvv(ji,jj,1,Krhs) + zhpj(ji,jj,1) 
     327      END_2D 
    367328 
    368329      ! interior value (2=<jk=<jpkm1) 
    369       DO jk = 2, jpkm1 
    370          DO jj = 2, jpjm1 
    371             DO ji = fs_2, fs_jpim1   ! vector opt. 
    372                zcoef1 = zcoef0 * e3w_n(ji,jj,jk) 
    373                ! hydrostatic pressure gradient 
    374                zhpi(ji,jj,jk) = zhpi(ji,jj,jk-1)   & 
    375                   &           + zcoef1 * (  ( rhd(ji+1,jj,jk) + rhd(ji+1,jj,jk-1) )   & 
    376                   &                       - ( rhd(ji  ,jj,jk) + rhd(ji  ,jj,jk-1) )  ) * r1_e1u(ji,jj) 
    377  
    378                zhpj(ji,jj,jk) = zhpj(ji,jj,jk-1)   & 
    379                   &           + zcoef1 * (  ( rhd(ji,jj+1,jk) + rhd(ji,jj+1,jk-1) )   & 
    380                   &                       - ( rhd(ji,jj,  jk) + rhd(ji,jj  ,jk-1) )  ) * r1_e2v(ji,jj) 
    381                ! add to the general momentum trend 
    382                ua(ji,jj,jk) = ua(ji,jj,jk) + zhpi(ji,jj,jk) 
    383                va(ji,jj,jk) = va(ji,jj,jk) + zhpj(ji,jj,jk) 
    384             END DO 
    385          END DO 
    386       END DO 
     330      DO_3D_00_00( 2, jpkm1 ) 
     331         zcoef1 = zcoef0 * e3w(ji,jj,jk,Kmm) 
     332         ! hydrostatic pressure gradient 
     333         zhpi(ji,jj,jk) = zhpi(ji,jj,jk-1)   & 
     334            &           + zcoef1 * (  ( rhd(ji+1,jj,jk) + rhd(ji+1,jj,jk-1) )   & 
     335            &                       - ( rhd(ji  ,jj,jk) + rhd(ji  ,jj,jk-1) )  ) * r1_e1u(ji,jj) 
     336 
     337         zhpj(ji,jj,jk) = zhpj(ji,jj,jk-1)   & 
     338            &           + zcoef1 * (  ( rhd(ji,jj+1,jk) + rhd(ji,jj+1,jk-1) )   & 
     339            &                       - ( rhd(ji,jj,  jk) + rhd(ji,jj  ,jk-1) )  ) * r1_e2v(ji,jj) 
     340         ! add to the general momentum trend 
     341         puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + zhpi(ji,jj,jk) 
     342         pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) + zhpj(ji,jj,jk) 
     343      END_3D 
    387344 
    388345      ! partial steps correction at the last level  (use zgru & zgrv computed in zpshde.F90) 
    389       DO jj = 2, jpjm1 
    390          DO ji = 2, jpim1 
    391             iku = mbku(ji,jj) 
    392             ikv = mbkv(ji,jj) 
    393             zcoef2 = zcoef0 * MIN( e3w_n(ji,jj,iku), e3w_n(ji+1,jj  ,iku) ) 
    394             zcoef3 = zcoef0 * MIN( e3w_n(ji,jj,ikv), e3w_n(ji  ,jj+1,ikv) ) 
    395             IF( iku > 1 ) THEN            ! on i-direction (level 2 or more) 
    396                ua  (ji,jj,iku) = ua(ji,jj,iku) - zhpi(ji,jj,iku)         ! subtract old value 
    397                zhpi(ji,jj,iku) = zhpi(ji,jj,iku-1)                   &   ! compute the new one 
    398                   &            + zcoef2 * ( rhd(ji+1,jj,iku-1) - rhd(ji,jj,iku-1) + zgru(ji,jj) ) * r1_e1u(ji,jj) 
    399                ua  (ji,jj,iku) = ua(ji,jj,iku) + zhpi(ji,jj,iku)         ! add the new one to the general momentum trend 
    400             ENDIF 
    401             IF( ikv > 1 ) THEN            ! on j-direction (level 2 or more) 
    402                va  (ji,jj,ikv) = va(ji,jj,ikv) - zhpj(ji,jj,ikv)         ! subtract old value 
    403                zhpj(ji,jj,ikv) = zhpj(ji,jj,ikv-1)                   &   ! compute the new one 
    404                   &            + zcoef3 * ( rhd(ji,jj+1,ikv-1) - rhd(ji,jj,ikv-1) + zgrv(ji,jj) ) * r1_e2v(ji,jj) 
    405                va  (ji,jj,ikv) = va(ji,jj,ikv) + zhpj(ji,jj,ikv)         ! add the new one to the general momentum trend 
    406             ENDIF 
    407          END DO 
    408       END DO 
     346      DO_2D_00_00 
     347         iku = mbku(ji,jj) 
     348         ikv = mbkv(ji,jj) 
     349         zcoef2 = zcoef0 * MIN( e3w(ji,jj,iku,Kmm), e3w(ji+1,jj  ,iku,Kmm) ) 
     350         zcoef3 = zcoef0 * MIN( e3w(ji,jj,ikv,Kmm), e3w(ji  ,jj+1,ikv,Kmm) ) 
     351         IF( iku > 1 ) THEN            ! on i-direction (level 2 or more) 
     352            puu  (ji,jj,iku,Krhs) = puu(ji,jj,iku,Krhs) - zhpi(ji,jj,iku)         ! subtract old value 
     353            zhpi(ji,jj,iku) = zhpi(ji,jj,iku-1)                   &   ! compute the new one 
     354               &            + zcoef2 * ( rhd(ji+1,jj,iku-1) - rhd(ji,jj,iku-1) + zgru(ji,jj) ) * r1_e1u(ji,jj) 
     355            puu  (ji,jj,iku,Krhs) = puu(ji,jj,iku,Krhs) + zhpi(ji,jj,iku)         ! add the new one to the general momentum trend 
     356         ENDIF 
     357         IF( ikv > 1 ) THEN            ! on j-direction (level 2 or more) 
     358            pvv  (ji,jj,ikv,Krhs) = pvv(ji,jj,ikv,Krhs) - zhpj(ji,jj,ikv)         ! subtract old value 
     359            zhpj(ji,jj,ikv) = zhpj(ji,jj,ikv-1)                   &   ! compute the new one 
     360               &            + zcoef3 * ( rhd(ji,jj+1,ikv-1) - rhd(ji,jj,ikv-1) + zgrv(ji,jj) ) * r1_e2v(ji,jj) 
     361            pvv  (ji,jj,ikv,Krhs) = pvv(ji,jj,ikv,Krhs) + zhpj(ji,jj,ikv)         ! add the new one to the general momentum trend 
     362         ENDIF 
     363      END_2D 
    409364      ! 
    410365   END SUBROUTINE hpg_zps 
    411366 
    412367 
    413    SUBROUTINE hpg_sco( kt ) 
     368   SUBROUTINE hpg_sco( kt, Kmm, puu, pvv, Krhs ) 
    414369      !!--------------------------------------------------------------------- 
    415370      !!                  ***  ROUTINE hpg_sco  *** 
    … …  
    423378      !!         zhpi = grav .....  + 1/e1u mi(rhd) di[ grav dep3w ] 
    424379      !!         zhpj = grav .....  + 1/e2v mj(rhd) dj[ grav dep3w ] 
    425       !!      add it to the general momentum trend (ua,va). 
    426       !!         ua = ua - 1/e1u * zhpi 
    427       !!         va = va - 1/e2v * zhpj 
    428       !! 
    429       !! ** Action : - Update (ua,va) with the now hydrastatic pressure trend 
    430       !!---------------------------------------------------------------------- 
    431       INTEGER, INTENT(in) ::   kt    ! ocean time-step index 
     380      !!      add it to the general momentum trend (puu(:,:,:,Krhs),pvv(:,:,:,Krhs)). 
     381      !!         puu(:,:,:,Krhs) = puu(:,:,:,Krhs) - 1/e1u * zhpi 
     382      !!         pvv(:,:,:,Krhs) = pvv(:,:,:,Krhs) - 1/e2v * zhpj 
     383      !! 
     384      !! ** Action : - Update (puu(:,:,:,Krhs),pvv(:,:,:,Krhs)) with the now hydrastatic pressure trend 
     385      !!---------------------------------------------------------------------- 
     386      INTEGER                             , INTENT( in )  ::  kt          ! ocean time-step index 
     387      INTEGER                             , INTENT( in )  ::  Kmm, Krhs   ! ocean time level indices 
     388      REAL(wp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) ::  puu, pvv    ! ocean velocities and RHS of momentum equation 
    432389      !! 
    433390      INTEGER  ::   ji, jj, jk, jii, jjj                 ! dummy loop indices 
    … …  
    452409      ! 
    453410      IF( ln_wd_il ) THEN 
    454         DO jj = 2, jpjm1 
    455            DO ji = 2, jpim1  
    456              ll_tmp1 = MIN(  sshn(ji,jj)               ,  sshn(ji+1,jj) ) >                & 
    457                   &    MAX( -ht_0(ji,jj)               , -ht_0(ji+1,jj) ) .AND.            & 
    458                   &    MAX(  sshn(ji,jj) +  ht_0(ji,jj),  sshn(ji+1,jj) + ht_0(ji+1,jj) )  & 
    459                   &                                                       > rn_wdmin1 + rn_wdmin2 
    460              ll_tmp2 = ( ABS( sshn(ji,jj)              -  sshn(ji+1,jj) ) > 1.E-12 ) .AND. (       & 
    461                   &    MAX(   sshn(ji,jj)              ,  sshn(ji+1,jj) ) >                & 
    462                   &    MAX(  -ht_0(ji,jj)              , -ht_0(ji+1,jj) ) + rn_wdmin1 + rn_wdmin2 ) 
    463  
    464              IF(ll_tmp1) THEN 
    465                zcpx(ji,jj) = 1.0_wp 
    466              ELSE IF(ll_tmp2) THEN 
    467                ! no worries about  sshn(ji+1,jj) -  sshn(ji  ,jj) = 0, it won't happen ! here 
    468                zcpx(ji,jj) = ABS( (sshn(ji+1,jj) + ht_0(ji+1,jj) - sshn(ji,jj) - ht_0(ji,jj)) & 
    469                            &    / (sshn(ji+1,jj) - sshn(ji  ,jj)) ) 
    470              ELSE 
    471                zcpx(ji,jj) = 0._wp 
    472              END IF 
    473        
    474              ll_tmp1 = MIN(  sshn(ji,jj)              ,  sshn(ji,jj+1) ) >                & 
    475                   &    MAX( -ht_0(ji,jj)              , -ht_0(ji,jj+1) ) .AND.            & 
    476                   &    MAX(  sshn(ji,jj) + ht_0(ji,jj),  sshn(ji,jj+1) + ht_0(ji,jj+1) )  & 
    477                   &                                                      > rn_wdmin1 + rn_wdmin2 
    478              ll_tmp2 = ( ABS( sshn(ji,jj)             -  sshn(ji,jj+1) ) > 1.E-12 ) .AND. (        & 
    479                   &    MAX(   sshn(ji,jj)             ,  sshn(ji,jj+1) ) >                & 
    480                   &    MAX(  -ht_0(ji,jj)             , -ht_0(ji,jj+1) ) + rn_wdmin1 + rn_wdmin2 ) 
    481  
    482              IF(ll_tmp1) THEN 
    483                zcpy(ji,jj) = 1.0_wp 
    484              ELSE IF(ll_tmp2) THEN 
    485                ! no worries about  sshn(ji,jj+1) -  sshn(ji,jj  ) = 0, it won't happen ! here 
    486                zcpy(ji,jj) = ABS( (sshn(ji,jj+1) + ht_0(ji,jj+1) - sshn(ji,jj) - ht_0(ji,jj)) & 
    487                            &    / (sshn(ji,jj+1) - sshn(ji,jj  )) ) 
    488              ELSE 
    489                zcpy(ji,jj) = 0._wp 
    490              END IF 
    491            END DO 
    492         END DO 
     411        DO_2D_00_00 
     412          ll_tmp1 = MIN(  ssh(ji,jj,Kmm)               ,  ssh(ji+1,jj,Kmm) ) >                & 
     413               &    MAX( -ht_0(ji,jj)               , -ht_0(ji+1,jj) ) .AND.            & 
     414               &    MAX(  ssh(ji,jj,Kmm) +  ht_0(ji,jj),  ssh(ji+1,jj,Kmm) + ht_0(ji+1,jj) )  & 
     415               &                                                       > rn_wdmin1 + rn_wdmin2 
     416          ll_tmp2 = ( ABS( ssh(ji,jj,Kmm)              -  ssh(ji+1,jj,Kmm) ) > 1.E-12 ) .AND. (       & 
     417               &    MAX(   ssh(ji,jj,Kmm)              ,  ssh(ji+1,jj,Kmm) ) >                & 
     418               &    MAX(  -ht_0(ji,jj)              , -ht_0(ji+1,jj) ) + rn_wdmin1 + rn_wdmin2 ) 
     419 
     420          IF(ll_tmp1) THEN 
     421            zcpx(ji,jj) = 1.0_wp 
     422          ELSE IF(ll_tmp2) THEN 
     423            ! no worries about  ssh(ji+1,jj,Kmm) -  ssh(ji  ,jj,Kmm) = 0, it won't happen ! here 
     424            zcpx(ji,jj) = ABS( (ssh(ji+1,jj,Kmm) + ht_0(ji+1,jj) - ssh(ji,jj,Kmm) - ht_0(ji,jj)) & 
     425                        &    / (ssh(ji+1,jj,Kmm) - ssh(ji  ,jj,Kmm)) ) 
     426          ELSE 
     427            zcpx(ji,jj) = 0._wp 
     428          END IF 
     429    
     430          ll_tmp1 = MIN(  ssh(ji,jj,Kmm)              ,  ssh(ji,jj+1,Kmm) ) >                & 
     431               &    MAX( -ht_0(ji,jj)              , -ht_0(ji,jj+1) ) .AND.            & 
     432               &    MAX(  ssh(ji,jj,Kmm) + ht_0(ji,jj),  ssh(ji,jj+1,Kmm) + ht_0(ji,jj+1) )  & 
     433               &                                                      > rn_wdmin1 + rn_wdmin2 
     434          ll_tmp2 = ( ABS( ssh(ji,jj,Kmm)             -  ssh(ji,jj+1,Kmm) ) > 1.E-12 ) .AND. (        & 
     435               &    MAX(   ssh(ji,jj,Kmm)             ,  ssh(ji,jj+1,Kmm) ) >                & 
     436               &    MAX(  -ht_0(ji,jj)             , -ht_0(ji,jj+1) ) + rn_wdmin1 + rn_wdmin2 ) 
     437 
     438          IF(ll_tmp1) THEN 
     439            zcpy(ji,jj) = 1.0_wp 
     440          ELSE IF(ll_tmp2) THEN 
     441            ! no worries about  ssh(ji,jj+1,Kmm) -  ssh(ji,jj  ,Kmm) = 0, it won't happen ! here 
     442            zcpy(ji,jj) = ABS( (ssh(ji,jj+1,Kmm) + ht_0(ji,jj+1) - ssh(ji,jj,Kmm) - ht_0(ji,jj)) & 
     443                        &    / (ssh(ji,jj+1,Kmm) - ssh(ji,jj  ,Kmm)) ) 
     444          ELSE 
     445            zcpy(ji,jj) = 0._wp 
     446          END IF 
     447        END_2D 
    493448        CALL lbc_lnk_multi( 'dynhpg', zcpx, 'U', 1., zcpy, 'V', 1. ) 
    494449      END IF 
    495450 
    496451      ! Surface value 
    497       DO jj = 2, jpjm1 
    498          DO ji = fs_2, fs_jpim1   ! vector opt. 
    499             ! hydrostatic pressure gradient along s-surfaces 
    500             zhpi(ji,jj,1) = zcoef0 * (  e3w_n(ji+1,jj  ,1) * ( znad + rhd(ji+1,jj  ,1) )    & 
    501                &                      - e3w_n(ji  ,jj  ,1) * ( znad + rhd(ji  ,jj  ,1) )  ) * r1_e1u(ji,jj) 
    502             zhpj(ji,jj,1) = zcoef0 * (  e3w_n(ji  ,jj+1,1) * ( znad + rhd(ji  ,jj+1,1) )    & 
    503                &                      - e3w_n(ji  ,jj  ,1) * ( znad + rhd(ji  ,jj  ,1) )  ) * r1_e2v(ji,jj) 
    504             ! s-coordinate pressure gradient correction 
    505             zuap = -zcoef0 * ( rhd    (ji+1,jj,1) + rhd    (ji,jj,1) + 2._wp * znad )   & 
    506                &           * ( gde3w_n(ji+1,jj,1) - gde3w_n(ji,jj,1) ) * r1_e1u(ji,jj) 
    507             zvap = -zcoef0 * ( rhd    (ji,jj+1,1) + rhd    (ji,jj,1) + 2._wp * znad )   & 
    508                &           * ( gde3w_n(ji,jj+1,1) - gde3w_n(ji,jj,1) ) * r1_e2v(ji,jj) 
    509             ! 
    510             IF( ln_wd_il ) THEN 
    511                zhpi(ji,jj,1) = zhpi(ji,jj,1) * zcpx(ji,jj) 
    512                zhpj(ji,jj,1) = zhpj(ji,jj,1) * zcpy(ji,jj)  
    513                zuap = zuap * zcpx(ji,jj) 
    514                zvap = zvap * zcpy(ji,jj) 
    515             ENDIF 
    516             ! 
    517             ! add to the general momentum trend 
    518             ua(ji,jj,1) = ua(ji,jj,1) + zhpi(ji,jj,1) + zuap 
    519             va(ji,jj,1) = va(ji,jj,1) + zhpj(ji,jj,1) + zvap 
    520          END DO 
    521       END DO 
     452      DO_2D_00_00 
     453         ! hydrostatic pressure gradient along s-surfaces 
     454         zhpi(ji,jj,1) = zcoef0 * (  e3w(ji+1,jj  ,1,Kmm) * ( znad + rhd(ji+1,jj  ,1) )    & 
     455            &                      - e3w(ji  ,jj  ,1,Kmm) * ( znad + rhd(ji  ,jj  ,1) )  ) * r1_e1u(ji,jj) 
     456         zhpj(ji,jj,1) = zcoef0 * (  e3w(ji  ,jj+1,1,Kmm) * ( znad + rhd(ji  ,jj+1,1) )    & 
     457            &                      - e3w(ji  ,jj  ,1,Kmm) * ( znad + rhd(ji  ,jj  ,1) )  ) * r1_e2v(ji,jj) 
     458         ! s-coordinate pressure gradient correction 
     459         zuap = -zcoef0 * ( rhd    (ji+1,jj,1) + rhd    (ji,jj,1) + 2._wp * znad )   & 
     460            &           * ( gde3w(ji+1,jj,1) - gde3w(ji,jj,1) ) * r1_e1u(ji,jj) 
     461         zvap = -zcoef0 * ( rhd    (ji,jj+1,1) + rhd    (ji,jj,1) + 2._wp * znad )   & 
     462            &           * ( gde3w(ji,jj+1,1) - gde3w(ji,jj,1) ) * r1_e2v(ji,jj) 
     463         ! 
     464         IF( ln_wd_il ) THEN 
     465            zhpi(ji,jj,1) = zhpi(ji,jj,1) * zcpx(ji,jj) 
     466            zhpj(ji,jj,1) = zhpj(ji,jj,1) * zcpy(ji,jj)  
     467            zuap = zuap * zcpx(ji,jj) 
     468            zvap = zvap * zcpy(ji,jj) 
     469         ENDIF 
     470         ! 
     471         ! add to the general momentum trend 
     472         puu(ji,jj,1,Krhs) = puu(ji,jj,1,Krhs) + zhpi(ji,jj,1) + zuap 
     473         pvv(ji,jj,1,Krhs) = pvv(ji,jj,1,Krhs) + zhpj(ji,jj,1) + zvap 
     474      END_2D 
    522475 
    523476      ! interior value (2=<jk=<jpkm1) 
    524       DO jk = 2, jpkm1 
    525          DO jj = 2, jpjm1 
    526             DO ji = fs_2, fs_jpim1   ! vector opt. 
    527                ! hydrostatic pressure gradient along s-surfaces 
    528                zhpi(ji,jj,jk) = zhpi(ji,jj,jk-1) + zcoef0 * r1_e1u(ji,jj)   & 
    529                   &           * (  e3w_n(ji+1,jj,jk) * ( rhd(ji+1,jj,jk) + rhd(ji+1,jj,jk-1) + 2*znad )   & 
    530                   &              - e3w_n(ji  ,jj,jk) * ( rhd(ji  ,jj,jk) + rhd(ji  ,jj,jk-1) + 2*znad )  ) 
    531                zhpj(ji,jj,jk) = zhpj(ji,jj,jk-1) + zcoef0 * r1_e2v(ji,jj)   & 
    532                   &           * (  e3w_n(ji,jj+1,jk) * ( rhd(ji,jj+1,jk) + rhd(ji,jj+1,jk-1) + 2*znad )   & 
    533                   &              - e3w_n(ji,jj  ,jk) * ( rhd(ji,jj,  jk) + rhd(ji,jj  ,jk-1) + 2*znad )  ) 
    534                ! s-coordinate pressure gradient correction 
    535                zuap = -zcoef0 * ( rhd    (ji+1,jj  ,jk) + rhd    (ji,jj,jk) + 2._wp * znad )   & 
    536                   &           * ( gde3w_n(ji+1,jj  ,jk) - gde3w_n(ji,jj,jk) ) * r1_e1u(ji,jj) 
    537                zvap = -zcoef0 * ( rhd    (ji  ,jj+1,jk) + rhd    (ji,jj,jk) + 2._wp * znad )   & 
    538                   &           * ( gde3w_n(ji  ,jj+1,jk) - gde3w_n(ji,jj,jk) ) * r1_e2v(ji,jj) 
    539                ! 
    540                IF( ln_wd_il ) THEN 
    541                   zhpi(ji,jj,jk) = zhpi(ji,jj,jk) * zcpx(ji,jj) 
    542                   zhpj(ji,jj,jk) = zhpj(ji,jj,jk) * zcpy(ji,jj)  
    543                   zuap = zuap * zcpx(ji,jj) 
    544                   zvap = zvap * zcpy(ji,jj) 
    545                ENDIF 
    546                ! 
    547                ! add to the general momentum trend 
    548                ua(ji,jj,jk) = ua(ji,jj,jk) + zhpi(ji,jj,jk) + zuap 
    549                va(ji,jj,jk) = va(ji,jj,jk) + zhpj(ji,jj,jk) + zvap 
    550             END DO 
    551          END DO 
    552       END DO 
     477      DO_3D_00_00( 2, jpkm1 ) 
     478         ! hydrostatic pressure gradient along s-surfaces 
     479         zhpi(ji,jj,jk) = zhpi(ji,jj,jk-1) + zcoef0 * r1_e1u(ji,jj)   & 
     480            &           * (  e3w(ji+1,jj,jk,Kmm) * ( rhd(ji+1,jj,jk) + rhd(ji+1,jj,jk-1) + 2*znad )   & 
     481            &              - e3w(ji  ,jj,jk,Kmm) * ( rhd(ji  ,jj,jk) + rhd(ji  ,jj,jk-1) + 2*znad )  ) 
     482         zhpj(ji,jj,jk) = zhpj(ji,jj,jk-1) + zcoef0 * r1_e2v(ji,jj)   & 
     483            &           * (  e3w(ji,jj+1,jk,Kmm) * ( rhd(ji,jj+1,jk) + rhd(ji,jj+1,jk-1) + 2*znad )   & 
     484            &              - e3w(ji,jj  ,jk,Kmm) * ( rhd(ji,jj,  jk) + rhd(ji,jj  ,jk-1) + 2*znad )  ) 
     485         ! s-coordinate pressure gradient correction 
     486         zuap = -zcoef0 * ( rhd    (ji+1,jj  ,jk) + rhd    (ji,jj,jk) + 2._wp * znad )   & 
     487            &           * ( gde3w(ji+1,jj  ,jk) - gde3w(ji,jj,jk) ) * r1_e1u(ji,jj) 
     488         zvap = -zcoef0 * ( rhd    (ji  ,jj+1,jk) + rhd    (ji,jj,jk) + 2._wp * znad )   & 
     489            &           * ( gde3w(ji  ,jj+1,jk) - gde3w(ji,jj,jk) ) * r1_e2v(ji,jj) 
     490         ! 
     491         IF( ln_wd_il ) THEN 
     492            zhpi(ji,jj,jk) = zhpi(ji,jj,jk) * zcpx(ji,jj) 
     493            zhpj(ji,jj,jk) = zhpj(ji,jj,jk) * zcpy(ji,jj)  
     494            zuap = zuap * zcpx(ji,jj) 
     495            zvap = zvap * zcpy(ji,jj) 
     496         ENDIF 
     497         ! 
     498         ! add to the general momentum trend 
     499         puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + zhpi(ji,jj,jk) + zuap 
     500         pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) + zhpj(ji,jj,jk) + zvap 
     501      END_3D 
    553502      ! 
    554503      IF( ln_wd_il )  DEALLOCATE( zcpx , zcpy ) 
    … …  
    557506 
    558507 
    559    SUBROUTINE hpg_isf( kt ) 
     508   SUBROUTINE hpg_isf( kt, Kmm, puu, pvv, Krhs ) 
    560509      !!--------------------------------------------------------------------- 
    561510      !!                  ***  ROUTINE hpg_isf  *** 
    … …  
    569518      !!         zhpi = grav .....  + 1/e1u mi(rhd) di[ grav dep3w ] 
    570519      !!         zhpj = grav .....  + 1/e2v mj(rhd) dj[ grav dep3w ] 
    571       !!      add it to the general momentum trend (ua,va). 
    572       !!         ua = ua - 1/e1u * zhpi 
    573       !!         va = va - 1/e2v * zhpj 
    574       !!      iceload is added and partial cell case are added to the top and bottom 
     520      !!      add it to the general momentum trend (puu(:,:,:,Krhs),pvv(:,:,:,Krhs)). 
     521      !!         puu(:,:,:,Krhs) = puu(:,:,:,Krhs) - 1/e1u * zhpi 
     522      !!         pvv(:,:,:,Krhs) = pvv(:,:,:,Krhs) - 1/e2v * zhpj 
     523      !!      iceload is added 
    575524      !!       
    576       !! ** Action : - Update (ua,va) with the now hydrastatic pressure trend 
    577       !!---------------------------------------------------------------------- 
    578       INTEGER, INTENT(in) ::   kt    ! ocean time-step index 
     525      !! ** Action : - Update (puu(:,:,:,Krhs),pvv(:,:,:,Krhs)) with the now hydrastatic pressure trend 
     526      !!---------------------------------------------------------------------- 
     527      INTEGER                             , INTENT( in )  ::  kt          ! ocean time-step index 
     528      INTEGER                             , INTENT( in )  ::  Kmm, Krhs   ! ocean time level indices 
     529      REAL(wp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) ::  puu, pvv    ! ocean velocities and RHS of momentum equation 
    579530      !! 
    580531      INTEGER  ::   ji, jj, jk, ikt, iktp1i, iktp1j   ! dummy loop indices 
    … …  
    597548        DO jj = 1, jpj 
    598549          ikt = mikt(ji,jj) 
    599           zts_top(ji,jj,1) = tsn(ji,jj,ikt,1) 
    600           zts_top(ji,jj,2) = tsn(ji,jj,ikt,2) 
     550          zts_top(ji,jj,1) = ts(ji,jj,ikt,1,Kmm) 
     551          zts_top(ji,jj,2) = ts(ji,jj,ikt,2,Kmm) 
    601552        END DO 
    602553      END DO 
    … …  
    606557!===== Compute surface value =====================================================  
    607558!================================================================================== 
    608       DO jj = 2, jpjm1 
    609          DO ji = fs_2, fs_jpim1   ! vector opt. 
    610             ikt    = mikt(ji,jj) 
    611             iktp1i = mikt(ji+1,jj) 
    612             iktp1j = mikt(ji,jj+1) 
    613             ! hydrostatic pressure gradient along s-surfaces and ice shelf pressure 
    614             ! we assume ISF is in isostatic equilibrium 
    615             zhpi(ji,jj,1) = zcoef0 / e1u(ji,jj) * ( 0.5_wp * e3w_n(ji+1,jj,iktp1i)                                    & 
    616                &                                    * ( 2._wp * znad + rhd(ji+1,jj,iktp1i) + zrhdtop_oce(ji+1,jj) )   & 
    617                &                                  - 0.5_wp * e3w_n(ji,jj,ikt)                                         & 
    618                &                                    * ( 2._wp * znad + rhd(ji,jj,ikt) + zrhdtop_oce(ji,jj) )          & 
    619                &                                  + ( riceload(ji+1,jj) - riceload(ji,jj))                            )  
    620             zhpj(ji,jj,1) = zcoef0 / e2v(ji,jj) * ( 0.5_wp * e3w_n(ji,jj+1,iktp1j)                                    & 
    621                &                                    * ( 2._wp * znad + rhd(ji,jj+1,iktp1j) + zrhdtop_oce(ji,jj+1) )   & 
    622                &                                  - 0.5_wp * e3w_n(ji,jj,ikt)                                         &  
    623                &                                    * ( 2._wp * znad + rhd(ji,jj,ikt) + zrhdtop_oce(ji,jj) )          & 
    624                &                                  + ( riceload(ji,jj+1) - riceload(ji,jj))                            )  
    625             ! s-coordinate pressure gradient correction (=0 if z coordinate) 
    626             zuap = -zcoef0 * ( rhd    (ji+1,jj,1) + rhd    (ji,jj,1) + 2._wp * znad )   & 
    627                &           * ( gde3w_n(ji+1,jj,1) - gde3w_n(ji,jj,1) ) * r1_e1u(ji,jj) 
    628             zvap = -zcoef0 * ( rhd    (ji,jj+1,1) + rhd    (ji,jj,1) + 2._wp * znad )   & 
    629                &           * ( gde3w_n(ji,jj+1,1) - gde3w_n(ji,jj,1) ) * r1_e2v(ji,jj) 
    630             ! add to the general momentum trend 
    631             ua(ji,jj,1) = ua(ji,jj,1) + (zhpi(ji,jj,1) + zuap) * umask(ji,jj,1) 
    632             va(ji,jj,1) = va(ji,jj,1) + (zhpj(ji,jj,1) + zvap) * vmask(ji,jj,1) 
    633          END DO 
    634       END DO 
     559      DO_2D_00_00 
     560         ikt    = mikt(ji,jj) 
     561         iktp1i = mikt(ji+1,jj) 
     562         iktp1j = mikt(ji,jj+1) 
     563         ! hydrostatic pressure gradient along s-surfaces and ice shelf pressure 
     564         ! we assume ISF is in isostatic equilibrium 
     565         zhpi(ji,jj,1) = zcoef0 / e1u(ji,jj) * ( 0.5_wp * e3w(ji+1,jj,iktp1i,Kmm)                                    & 
     566            &                                    * ( 2._wp * znad + rhd(ji+1,jj,iktp1i) + zrhdtop_oce(ji+1,jj) )   & 
     567            &                                  - 0.5_wp * e3w(ji,jj,ikt,Kmm)                                         & 
     568            &                                    * ( 2._wp * znad + rhd(ji,jj,ikt) + zrhdtop_oce(ji,jj) )          & 
     569            &                                  + ( risfload(ji+1,jj) - risfload(ji,jj))                            )  
     570         zhpj(ji,jj,1) = zcoef0 / e2v(ji,jj) * ( 0.5_wp * e3w(ji,jj+1,iktp1j,Kmm)                                    & 
     571            &                                    * ( 2._wp * znad + rhd(ji,jj+1,iktp1j) + zrhdtop_oce(ji,jj+1) )   & 
     572            &                                  - 0.5_wp * e3w(ji,jj,ikt,Kmm)                                         &  
     573            &                                    * ( 2._wp * znad + rhd(ji,jj,ikt) + zrhdtop_oce(ji,jj) )          & 
     574            &                                  + ( risfload(ji,jj+1) - risfload(ji,jj))                            )  
     575         ! s-coordinate pressure gradient correction (=0 if z coordinate) 
     576         zuap = -zcoef0 * ( rhd    (ji+1,jj,1) + rhd    (ji,jj,1) + 2._wp * znad )   & 
     577            &           * ( gde3w(ji+1,jj,1) - gde3w(ji,jj,1) ) * r1_e1u(ji,jj) 
     578         zvap = -zcoef0 * ( rhd    (ji,jj+1,1) + rhd    (ji,jj,1) + 2._wp * znad )   & 
     579            &           * ( gde3w(ji,jj+1,1) - gde3w(ji,jj,1) ) * r1_e2v(ji,jj) 
     580         ! add to the general momentum trend 
     581         puu(ji,jj,1,Krhs) = puu(ji,jj,1,Krhs) + (zhpi(ji,jj,1) + zuap) * umask(ji,jj,1) 
     582         pvv(ji,jj,1,Krhs) = pvv(ji,jj,1,Krhs) + (zhpj(ji,jj,1) + zvap) * vmask(ji,jj,1) 
     583      END_2D 
    635584!==================================================================================      
    636585!===== Compute interior value =====================================================  
    637586!================================================================================== 
    638587      ! interior value (2=<jk=<jpkm1) 
    639       DO jk = 2, jpkm1 
    640          DO jj = 2, jpjm1 
    641             DO ji = fs_2, fs_jpim1   ! vector opt. 
    642                ! hydrostatic pressure gradient along s-surfaces 
    643                zhpi(ji,jj,jk) = zhpi(ji,jj,jk-1) + zcoef0 / e1u(ji,jj)   & 
    644                   &           * (  e3w_n(ji+1,jj,jk) * ( rhd(ji+1,jj,jk) + rhd(ji+1,jj,jk-1) + 2*znad ) * wmask(ji+1,jj,jk)   & 
    645                   &              - e3w_n(ji  ,jj,jk) * ( rhd(ji  ,jj,jk) + rhd(ji  ,jj,jk-1) + 2*znad ) * wmask(ji  ,jj,jk)   ) 
    646                zhpj(ji,jj,jk) = zhpj(ji,jj,jk-1) + zcoef0 / e2v(ji,jj)   & 
    647                   &           * (  e3w_n(ji,jj+1,jk) * ( rhd(ji,jj+1,jk) + rhd(ji,jj+1,jk-1) + 2*znad ) * wmask(ji,jj+1,jk)   & 
    648                   &              - e3w_n(ji,jj  ,jk) * ( rhd(ji,jj,  jk) + rhd(ji,jj  ,jk-1) + 2*znad ) * wmask(ji,jj  ,jk)   ) 
    649                ! s-coordinate pressure gradient correction 
    650                zuap = -zcoef0 * ( rhd   (ji+1,jj  ,jk) + rhd   (ji,jj,jk) + 2._wp * znad )   & 
    651                   &           * ( gde3w_n(ji+1,jj  ,jk) - gde3w_n(ji,jj,jk) ) / e1u(ji,jj) 
    652                zvap = -zcoef0 * ( rhd   (ji  ,jj+1,jk) + rhd   (ji,jj,jk) + 2._wp * znad )   & 
    653                   &           * ( gde3w_n(ji  ,jj+1,jk) - gde3w_n(ji,jj,jk) ) / e2v(ji,jj) 
    654                ! add to the general momentum trend 
    655                ua(ji,jj,jk) = ua(ji,jj,jk) + (zhpi(ji,jj,jk) + zuap) * umask(ji,jj,jk) 
    656                va(ji,jj,jk) = va(ji,jj,jk) + (zhpj(ji,jj,jk) + zvap) * vmask(ji,jj,jk) 
    657             END DO 
    658          END DO 
    659       END DO 
     588      DO_3D_00_00( 2, jpkm1 ) 
     589         ! hydrostatic pressure gradient along s-surfaces 
     590         zhpi(ji,jj,jk) = zhpi(ji,jj,jk-1) + zcoef0 / e1u(ji,jj)   & 
     591            &           * (  e3w(ji+1,jj,jk,Kmm) * ( rhd(ji+1,jj,jk) + rhd(ji+1,jj,jk-1) + 2*znad ) * wmask(ji+1,jj,jk)   & 
     592            &              - e3w(ji  ,jj,jk,Kmm) * ( rhd(ji  ,jj,jk) + rhd(ji  ,jj,jk-1) + 2*znad ) * wmask(ji  ,jj,jk)   ) 
     593         zhpj(ji,jj,jk) = zhpj(ji,jj,jk-1) + zcoef0 / e2v(ji,jj)   & 
     594            &           * (  e3w(ji,jj+1,jk,Kmm) * ( rhd(ji,jj+1,jk) + rhd(ji,jj+1,jk-1) + 2*znad ) * wmask(ji,jj+1,jk)   & 
     595            &              - e3w(ji,jj  ,jk,Kmm) * ( rhd(ji,jj,  jk) + rhd(ji,jj  ,jk-1) + 2*znad ) * wmask(ji,jj  ,jk)   ) 
     596         ! s-coordinate pressure gradient correction 
     597         zuap = -zcoef0 * ( rhd   (ji+1,jj  ,jk) + rhd   (ji,jj,jk) + 2._wp * znad )   & 
     598            &           * ( gde3w(ji+1,jj  ,jk) - gde3w(ji,jj,jk) ) / e1u(ji,jj) 
     599         zvap = -zcoef0 * ( rhd   (ji  ,jj+1,jk) + rhd   (ji,jj,jk) + 2._wp * znad )   & 
     600            &           * ( gde3w(ji  ,jj+1,jk) - gde3w(ji,jj,jk) ) / e2v(ji,jj) 
     601         ! add to the general momentum trend 
     602         puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + (zhpi(ji,jj,jk) + zuap) * umask(ji,jj,jk) 
     603         pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) + (zhpj(ji,jj,jk) + zvap) * vmask(ji,jj,jk) 
     604      END_3D 
    660605      ! 
    661606   END SUBROUTINE hpg_isf 
    662607 
    663608 
    664    SUBROUTINE hpg_djc( kt ) 
     609   SUBROUTINE hpg_djc( kt, Kmm, puu, pvv, Krhs ) 
    665610      !!--------------------------------------------------------------------- 
    666611      !!                  ***  ROUTINE hpg_djc  *** 
    … …  
    670615      !! Reference: Shchepetkin and McWilliams, J. Geophys. Res., 108(C3), 3090, 2003 
    671616      !!---------------------------------------------------------------------- 
    672       INTEGER, INTENT(in) ::   kt    ! ocean time-step index 
     617      INTEGER                             , INTENT( in )  ::  kt          ! ocean time-step index 
     618      INTEGER                             , INTENT( in )  ::  Kmm, Krhs   ! ocean time level indices 
     619      REAL(wp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) ::  puu, pvv    ! ocean velocities and RHS of momentum equation 
    673620      !! 
    674621      INTEGER  ::   ji, jj, jk          ! dummy loop indices 
    … …  
    686633      IF( ln_wd_il ) THEN 
    687634         ALLOCATE( zcpx(jpi,jpj) , zcpy(jpi,jpj) ) 
    688         DO jj = 2, jpjm1 
    689            DO ji = 2, jpim1  
    690              ll_tmp1 = MIN(  sshn(ji,jj)              ,  sshn(ji+1,jj) ) >                & 
    691                   &    MAX( -ht_0(ji,jj)              , -ht_0(ji+1,jj) ) .AND.            & 
    692                   &    MAX(  sshn(ji,jj) + ht_0(ji,jj),  sshn(ji+1,jj) + ht_0(ji+1,jj) )  & 
    693                   &                                                      > rn_wdmin1 + rn_wdmin2 
    694              ll_tmp2 = ( ABS( sshn(ji,jj)             -  sshn(ji+1,jj) ) > 1.E-12 ) .AND. (        & 
    695                   &    MAX(   sshn(ji,jj)             ,  sshn(ji+1,jj) ) >                & 
    696                   &    MAX(  -ht_0(ji,jj)             , -ht_0(ji+1,jj) ) + rn_wdmin1 + rn_wdmin2 ) 
    697              IF(ll_tmp1) THEN 
    698                zcpx(ji,jj) = 1.0_wp 
    699              ELSE IF(ll_tmp2) THEN 
    700                ! no worries about  sshn(ji+1,jj) -  sshn(ji  ,jj) = 0, it won't happen ! here 
    701                zcpx(ji,jj) = ABS( (sshn(ji+1,jj) + ht_0(ji+1,jj) - sshn(ji,jj) - ht_0(ji,jj)) & 
    702                            &    / (sshn(ji+1,jj) - sshn(ji  ,jj)) ) 
    703              ELSE 
    704                zcpx(ji,jj) = 0._wp 
    705              END IF 
    706        
    707              ll_tmp1 = MIN(  sshn(ji,jj)              ,  sshn(ji,jj+1) ) >                & 
    708                   &    MAX( -ht_0(ji,jj)              , -ht_0(ji,jj+1) ) .AND.            & 
    709                   &    MAX(  sshn(ji,jj) + ht_0(ji,jj),  sshn(ji,jj+1) + ht_0(ji,jj+1) )  & 
    710                   &                                                      > rn_wdmin1 + rn_wdmin2 
    711              ll_tmp2 = ( ABS( sshn(ji,jj)             -  sshn(ji,jj+1) ) > 1.E-12 ) .AND. (        & 
    712                   &    MAX(   sshn(ji,jj)             ,  sshn(ji,jj+1) ) >                & 
    713                   &    MAX(  -ht_0(ji,jj)             , -ht_0(ji,jj+1) ) + rn_wdmin1 + rn_wdmin2 ) 
    714  
    715              IF(ll_tmp1) THEN 
    716                zcpy(ji,jj) = 1.0_wp 
    717              ELSE IF(ll_tmp2) THEN 
    718                ! no worries about  sshn(ji,jj+1) -  sshn(ji,jj  ) = 0, it won't happen ! here 
    719                zcpy(ji,jj) = ABS( (sshn(ji,jj+1) + ht_0(ji,jj+1) - sshn(ji,jj) - ht_0(ji,jj)) & 
    720                            &    / (sshn(ji,jj+1) - sshn(ji,jj  )) ) 
    721              ELSE 
    722                zcpy(ji,jj) = 0._wp 
    723              END IF 
    724            END DO 
    725         END DO 
     635        DO_2D_00_00 
     636          ll_tmp1 = MIN(  ssh(ji,jj,Kmm)              ,  ssh(ji+1,jj,Kmm) ) >                & 
     637               &    MAX( -ht_0(ji,jj)              , -ht_0(ji+1,jj) ) .AND.            & 
     638               &    MAX(  ssh(ji,jj,Kmm) + ht_0(ji,jj),  ssh(ji+1,jj,Kmm) + ht_0(ji+1,jj) )  & 
     639               &                                                      > rn_wdmin1 + rn_wdmin2 
     640          ll_tmp2 = ( ABS( ssh(ji,jj,Kmm)             -  ssh(ji+1,jj,Kmm) ) > 1.E-12 ) .AND. (        & 
     641               &    MAX(   ssh(ji,jj,Kmm)             ,  ssh(ji+1,jj,Kmm) ) >                & 
     642               &    MAX(  -ht_0(ji,jj)             , -ht_0(ji+1,jj) ) + rn_wdmin1 + rn_wdmin2 ) 
     643          IF(ll_tmp1) THEN 
     644            zcpx(ji,jj) = 1.0_wp 
     645          ELSE IF(ll_tmp2) THEN 
     646            ! no worries about  ssh(ji+1,jj,Kmm) -  ssh(ji  ,jj,Kmm) = 0, it won't happen ! here 
     647            zcpx(ji,jj) = ABS( (ssh(ji+1,jj,Kmm) + ht_0(ji+1,jj) - ssh(ji,jj,Kmm) - ht_0(ji,jj)) & 
     648                        &    / (ssh(ji+1,jj,Kmm) - ssh(ji  ,jj,Kmm)) ) 
     649          ELSE 
     650            zcpx(ji,jj) = 0._wp 
     651          END IF 
     652    
     653          ll_tmp1 = MIN(  ssh(ji,jj,Kmm)              ,  ssh(ji,jj+1,Kmm) ) >                & 
     654               &    MAX( -ht_0(ji,jj)              , -ht_0(ji,jj+1) ) .AND.            & 
     655               &    MAX(  ssh(ji,jj,Kmm) + ht_0(ji,jj),  ssh(ji,jj+1,Kmm) + ht_0(ji,jj+1) )  & 
     656               &                                                      > rn_wdmin1 + rn_wdmin2 
     657          ll_tmp2 = ( ABS( ssh(ji,jj,Kmm)             -  ssh(ji,jj+1,Kmm) ) > 1.E-12 ) .AND. (        & 
     658               &    MAX(   ssh(ji,jj,Kmm)             ,  ssh(ji,jj+1,Kmm) ) >                & 
     659               &    MAX(  -ht_0(ji,jj)             , -ht_0(ji,jj+1) ) + rn_wdmin1 + rn_wdmin2 ) 
     660 
     661          IF(ll_tmp1) THEN 
     662            zcpy(ji,jj) = 1.0_wp 
     663          ELSE IF(ll_tmp2) THEN 
     664            ! no worries about  ssh(ji,jj+1,Kmm) -  ssh(ji,jj  ,Kmm) = 0, it won't happen ! here 
     665            zcpy(ji,jj) = ABS( (ssh(ji,jj+1,Kmm) + ht_0(ji,jj+1) - ssh(ji,jj,Kmm) - ht_0(ji,jj)) & 
     666                        &    / (ssh(ji,jj+1,Kmm) - ssh(ji,jj  ,Kmm)) ) 
     667          ELSE 
     668            zcpy(ji,jj) = 0._wp 
     669          END IF 
     670        END_2D 
    726671        CALL lbc_lnk_multi( 'dynhpg', zcpx, 'U', 1., zcpy, 'V', 1. ) 
    727672      END IF 
    … …  
    744689!!bug gm   Not a true bug, but... dzz=e3w  for dzx, dzy verify what it is really 
    745690 
    746       DO jk = 2, jpkm1 
    747          DO jj = 2, jpjm1 
    748             DO ji = fs_2, fs_jpim1   ! vector opt. 
    749                drhoz(ji,jj,jk) = rhd    (ji  ,jj  ,jk) - rhd    (ji,jj,jk-1) 
    750                dzz  (ji,jj,jk) = gde3w_n(ji  ,jj  ,jk) - gde3w_n(ji,jj,jk-1) 
    751                drhox(ji,jj,jk) = rhd    (ji+1,jj  ,jk) - rhd    (ji,jj,jk  ) 
    752                dzx  (ji,jj,jk) = gde3w_n(ji+1,jj  ,jk) - gde3w_n(ji,jj,jk  ) 
    753                drhoy(ji,jj,jk) = rhd    (ji  ,jj+1,jk) - rhd    (ji,jj,jk  ) 
    754                dzy  (ji,jj,jk) = gde3w_n(ji  ,jj+1,jk) - gde3w_n(ji,jj,jk  ) 
    755             END DO 
    756          END DO 
    757       END DO 
     691      DO_3D_00_00( 2, jpkm1 ) 
     692         drhoz(ji,jj,jk) = rhd    (ji  ,jj  ,jk) - rhd    (ji,jj,jk-1) 
     693         dzz  (ji,jj,jk) = gde3w(ji  ,jj  ,jk) - gde3w(ji,jj,jk-1) 
     694         drhox(ji,jj,jk) = rhd    (ji+1,jj  ,jk) - rhd    (ji,jj,jk  ) 
     695         dzx  (ji,jj,jk) = gde3w(ji+1,jj  ,jk) - gde3w(ji,jj,jk  ) 
     696         drhoy(ji,jj,jk) = rhd    (ji  ,jj+1,jk) - rhd    (ji,jj,jk  ) 
     697         dzy  (ji,jj,jk) = gde3w(ji  ,jj+1,jk) - gde3w(ji,jj,jk  ) 
     698      END_3D 
    758699 
    759700      !------------------------------------------------------------------------- 
    … …  
    765706!!bug  gm  idem for drhox, drhoy et ji=jpi and jj=jpj 
    766707 
    767       DO jk = 2, jpkm1 
    768          DO jj = 2, jpjm1 
    769             DO ji = fs_2, fs_jpim1   ! vector opt. 
    770                cffw = 2._wp * drhoz(ji  ,jj  ,jk) * drhoz(ji,jj,jk-1) 
    771  
    772                cffu = 2._wp * drhox(ji+1,jj  ,jk) * drhox(ji,jj,jk  ) 
    773                cffx = 2._wp * dzx  (ji+1,jj  ,jk) * dzx  (ji,jj,jk  ) 
    774  
    775                cffv = 2._wp * drhoy(ji  ,jj+1,jk) * drhoy(ji,jj,jk  ) 
    776                cffy = 2._wp * dzy  (ji  ,jj+1,jk) * dzy  (ji,jj,jk  ) 
    777  
    778                IF( cffw > zep) THEN 
    779                   drhow(ji,jj,jk) = 2._wp *   drhoz(ji,jj,jk) * drhoz(ji,jj,jk-1)   & 
    780                      &                    / ( drhoz(ji,jj,jk) + drhoz(ji,jj,jk-1) ) 
    781                ELSE 
    782                   drhow(ji,jj,jk) = 0._wp 
    783                ENDIF 
    784  
    785                dzw(ji,jj,jk) = 2._wp *   dzz(ji,jj,jk) * dzz(ji,jj,jk-1)   & 
    786                   &                  / ( dzz(ji,jj,jk) + dzz(ji,jj,jk-1) ) 
    787  
    788                IF( cffu > zep ) THEN 
    789                   drhou(ji,jj,jk) = 2._wp *   drhox(ji+1,jj,jk) * drhox(ji,jj,jk)   & 
    790                      &                    / ( drhox(ji+1,jj,jk) + drhox(ji,jj,jk) ) 
    791                ELSE 
    792                   drhou(ji,jj,jk ) = 0._wp 
    793                ENDIF 
    794  
    795                IF( cffx > zep ) THEN 
    796                   dzu(ji,jj,jk) = 2._wp *   dzx(ji+1,jj,jk) * dzx(ji,jj,jk)   & 
    797                      &                  / ( dzx(ji+1,jj,jk) + dzx(ji,jj,jk) ) 
    798                ELSE 
    799                   dzu(ji,jj,jk) = 0._wp 
    800                ENDIF 
    801  
    802                IF( cffv > zep ) THEN 
    803                   drhov(ji,jj,jk) = 2._wp *   drhoy(ji,jj+1,jk) * drhoy(ji,jj,jk)   & 
    804                      &                    / ( drhoy(ji,jj+1,jk) + drhoy(ji,jj,jk) ) 
    805                ELSE 
    806                   drhov(ji,jj,jk) = 0._wp 
    807                ENDIF 
    808  
    809                IF( cffy > zep ) THEN 
    810                   dzv(ji,jj,jk) = 2._wp *   dzy(ji,jj+1,jk) * dzy(ji,jj,jk)   & 
    811                      &                  / ( dzy(ji,jj+1,jk) + dzy(ji,jj,jk) ) 
    812                ELSE 
    813                   dzv(ji,jj,jk) = 0._wp 
    814                ENDIF 
    815  
    816             END DO 
    817          END DO 
    818       END DO 
     708      DO_3D_00_00( 2, jpkm1 ) 
     709         cffw = 2._wp * drhoz(ji  ,jj  ,jk) * drhoz(ji,jj,jk-1) 
     710 
     711         cffu = 2._wp * drhox(ji+1,jj  ,jk) * drhox(ji,jj,jk  ) 
     712         cffx = 2._wp * dzx  (ji+1,jj  ,jk) * dzx  (ji,jj,jk  ) 
     713 
     714         cffv = 2._wp * drhoy(ji  ,jj+1,jk) * drhoy(ji,jj,jk  ) 
     715         cffy = 2._wp * dzy  (ji  ,jj+1,jk) * dzy  (ji,jj,jk  ) 
     716 
     717         IF( cffw > zep) THEN 
     718            drhow(ji,jj,jk) = 2._wp *   drhoz(ji,jj,jk) * drhoz(ji,jj,jk-1)   & 
     719               &                    / ( drhoz(ji,jj,jk) + drhoz(ji,jj,jk-1) ) 
     720         ELSE 
     721            drhow(ji,jj,jk) = 0._wp 
     722         ENDIF 
     723 
     724         dzw(ji,jj,jk) = 2._wp *   dzz(ji,jj,jk) * dzz(ji,jj,jk-1)   & 
     725            &                  / ( dzz(ji,jj,jk) + dzz(ji,jj,jk-1) ) 
     726 
     727         IF( cffu > zep ) THEN 
     728            drhou(ji,jj,jk) = 2._wp *   drhox(ji+1,jj,jk) * drhox(ji,jj,jk)   & 
     729               &                    / ( drhox(ji+1,jj,jk) + drhox(ji,jj,jk) ) 
     730         ELSE 
     731            drhou(ji,jj,jk ) = 0._wp 
     732         ENDIF 
     733 
     734         IF( cffx > zep ) THEN 
     735            dzu(ji,jj,jk) = 2._wp *   dzx(ji+1,jj,jk) * dzx(ji,jj,jk)   & 
     736               &                  / ( dzx(ji+1,jj,jk) + dzx(ji,jj,jk) ) 
     737         ELSE 
     738            dzu(ji,jj,jk) = 0._wp 
     739         ENDIF 
     740 
     741         IF( cffv > zep ) THEN 
     742            drhov(ji,jj,jk) = 2._wp *   drhoy(ji,jj+1,jk) * drhoy(ji,jj,jk)   & 
     743               &                    / ( drhoy(ji,jj+1,jk) + drhoy(ji,jj,jk) ) 
     744         ELSE 
     745            drhov(ji,jj,jk) = 0._wp 
     746         ENDIF 
     747 
     748         IF( cffy > zep ) THEN 
     749            dzv(ji,jj,jk) = 2._wp *   dzy(ji,jj+1,jk) * dzy(ji,jj,jk)   & 
     750               &                  / ( dzy(ji,jj+1,jk) + dzy(ji,jj,jk) ) 
     751         ELSE 
     752            dzv(ji,jj,jk) = 0._wp 
     753         ENDIF 
     754 
     755      END_3D 
    819756 
    820757      !---------------------------------------------------------------------------------- 
    … …  
    837774!          true if gde3w is really defined as the sum of the e3w scale factors as, it seems to me, it should be 
    838775 
    839       DO jj = 2, jpjm1 
    840          DO ji = fs_2, fs_jpim1   ! vector opt. 
    841             rho_k(ji,jj,1) = -grav * ( e3w_n(ji,jj,1) - gde3w_n(ji,jj,1) )               & 
    842                &                   * (  rhd(ji,jj,1)                                     & 
    843                &                     + 0.5_wp * ( rhd    (ji,jj,2) - rhd    (ji,jj,1) )  & 
    844                &                              * ( e3w_n  (ji,jj,1) - gde3w_n(ji,jj,1) )  & 
    845                &                              / ( gde3w_n(ji,jj,2) - gde3w_n(ji,jj,1) )  ) 
    846          END DO 
    847       END DO 
     776      DO_2D_00_00 
     777         rho_k(ji,jj,1) = -grav * ( e3w(ji,jj,1,Kmm) - gde3w(ji,jj,1) )               & 
     778            &                   * (  rhd(ji,jj,1)                                     & 
     779            &                     + 0.5_wp * ( rhd    (ji,jj,2) - rhd    (ji,jj,1) )  & 
     780            &                              * ( e3w  (ji,jj,1,Kmm) - gde3w(ji,jj,1) )  & 
     781            &                              / ( gde3w(ji,jj,2) - gde3w(ji,jj,1) )  ) 
     782      END_2D 
    848783 
    849784!!bug gm    : here also, simplification is possible 
    850785!!bug gm    : optimisation: 1/10 and 1/12 the division should be done before the loop 
    851786 
    852       DO jk = 2, jpkm1 
    853          DO jj = 2, jpjm1 
    854             DO ji = fs_2, fs_jpim1   ! vector opt. 
    855  
    856                rho_k(ji,jj,jk) = zcoef0 * ( rhd    (ji,jj,jk) + rhd    (ji,jj,jk-1) )                                   & 
    857                   &                     * ( gde3w_n(ji,jj,jk) - gde3w_n(ji,jj,jk-1) )                                   & 
    858                   &            - grav * z1_10 * (                                                                   & 
    859                   &     ( drhow  (ji,jj,jk) - drhow  (ji,jj,jk-1) )                                                     & 
    860                   &   * ( gde3w_n(ji,jj,jk) - gde3w_n(ji,jj,jk-1) - z1_12 * ( dzw  (ji,jj,jk) + dzw  (ji,jj,jk-1) ) )   & 
    861                   &   - ( dzw    (ji,jj,jk) - dzw    (ji,jj,jk-1) )                                                     & 
    862                   &   * ( rhd    (ji,jj,jk) - rhd    (ji,jj,jk-1) - z1_12 * ( drhow(ji,jj,jk) + drhow(ji,jj,jk-1) ) )   & 
    863                   &                             ) 
    864  
    865                rho_i(ji,jj,jk) = zcoef0 * ( rhd    (ji+1,jj,jk) + rhd    (ji,jj,jk) )                                   & 
    866                   &                     * ( gde3w_n(ji+1,jj,jk) - gde3w_n(ji,jj,jk) )                                   & 
    867                   &            - grav* z1_10 * (                                                                    & 
    868                   &     ( drhou  (ji+1,jj,jk) - drhou  (ji,jj,jk) )                                                     & 
    869                   &   * ( gde3w_n(ji+1,jj,jk) - gde3w_n(ji,jj,jk) - z1_12 * ( dzu  (ji+1,jj,jk) + dzu  (ji,jj,jk) ) )   & 
    870                   &   - ( dzu    (ji+1,jj,jk) - dzu    (ji,jj,jk) )                                                     & 
    871                   &   * ( rhd    (ji+1,jj,jk) - rhd    (ji,jj,jk) - z1_12 * ( drhou(ji+1,jj,jk) + drhou(ji,jj,jk) ) )   & 
    872                   &                            ) 
    873  
    874                rho_j(ji,jj,jk) = zcoef0 * ( rhd    (ji,jj+1,jk) + rhd    (ji,jj,jk) )                                 & 
    875                   &                     * ( gde3w_n(ji,jj+1,jk) - gde3w_n(ji,jj,jk) )                                   & 
    876                   &            - grav* z1_10 * (                                                                    & 
    877                   &     ( drhov  (ji,jj+1,jk) - drhov  (ji,jj,jk) )                                                     & 
    878                   &   * ( gde3w_n(ji,jj+1,jk) - gde3w_n(ji,jj,jk) - z1_12 * ( dzv  (ji,jj+1,jk) + dzv  (ji,jj,jk) ) )   & 
    879                   &   - ( dzv    (ji,jj+1,jk) - dzv    (ji,jj,jk) )                                                     & 
    880                   &   * ( rhd    (ji,jj+1,jk) - rhd    (ji,jj,jk) - z1_12 * ( drhov(ji,jj+1,jk) + drhov(ji,jj,jk) ) )   & 
    881                   &                            ) 
    882  
    883             END DO 
    884          END DO 
    885       END DO 
     787      DO_3D_00_00( 2, jpkm1 ) 
     788 
     789         rho_k(ji,jj,jk) = zcoef0 * ( rhd    (ji,jj,jk) + rhd    (ji,jj,jk-1) )                                   & 
     790            &                     * ( gde3w(ji,jj,jk) - gde3w(ji,jj,jk-1) )                                   & 
     791            &            - grav * z1_10 * (                                                                   & 
     792            &     ( drhow  (ji,jj,jk) - drhow  (ji,jj,jk-1) )                                                     & 
     793            &   * ( gde3w(ji,jj,jk) - gde3w(ji,jj,jk-1) - z1_12 * ( dzw  (ji,jj,jk) + dzw  (ji,jj,jk-1) ) )   & 
     794            &   - ( dzw    (ji,jj,jk) - dzw    (ji,jj,jk-1) )                                                     & 
     795            &   * ( rhd    (ji,jj,jk) - rhd    (ji,jj,jk-1) - z1_12 * ( drhow(ji,jj,jk) + drhow(ji,jj,jk-1) ) )   & 
     796            &                             ) 
     797 
     798         rho_i(ji,jj,jk) = zcoef0 * ( rhd    (ji+1,jj,jk) + rhd    (ji,jj,jk) )                                   & 
     799            &                     * ( gde3w(ji+1,jj,jk) - gde3w(ji,jj,jk) )                                   & 
     800            &            - grav* z1_10 * (                                                                    & 
     801            &     ( drhou  (ji+1,jj,jk) - drhou  (ji,jj,jk) )                                                     & 
     802            &   * ( gde3w(ji+1,jj,jk) - gde3w(ji,jj,jk) - z1_12 * ( dzu  (ji+1,jj,jk) + dzu  (ji,jj,jk) ) )   & 
     803            &   - ( dzu    (ji+1,jj,jk) - dzu    (ji,jj,jk) )                                                     & 
     804            &   * ( rhd    (ji+1,jj,jk) - rhd    (ji,jj,jk) - z1_12 * ( drhou(ji+1,jj,jk) + drhou(ji,jj,jk) ) )   & 
     805            &                            ) 
     806 
     807         rho_j(ji,jj,jk) = zcoef0 * ( rhd    (ji,jj+1,jk) + rhd    (ji,jj,jk) )                                 & 
     808            &                     * ( gde3w(ji,jj+1,jk) - gde3w(ji,jj,jk) )                                   & 
     809            &            - grav* z1_10 * (                                                                    & 
     810            &     ( drhov  (ji,jj+1,jk) - drhov  (ji,jj,jk) )                                                     & 
     811            &   * ( gde3w(ji,jj+1,jk) - gde3w(ji,jj,jk) - z1_12 * ( dzv  (ji,jj+1,jk) + dzv  (ji,jj,jk) ) )   & 
     812            &   - ( dzv    (ji,jj+1,jk) - dzv    (ji,jj,jk) )                                                     & 
     813            &   * ( rhd    (ji,jj+1,jk) - rhd    (ji,jj,jk) - z1_12 * ( drhov(ji,jj+1,jk) + drhov(ji,jj,jk) ) )   & 
     814            &                            ) 
     815 
     816      END_3D 
    886817      CALL lbc_lnk_multi( 'dynhpg', rho_k, 'W', 1., rho_i, 'U', 1., rho_j, 'V', 1. ) 
    887818 
    … …  
    889820      !  Surface value 
    890821      ! --------------- 
    891       DO jj = 2, jpjm1 
    892          DO ji = fs_2, fs_jpim1   ! vector opt. 
    893             zhpi(ji,jj,1) = ( rho_k(ji+1,jj  ,1) - rho_k(ji,jj,1) - rho_i(ji,jj,1) ) * r1_e1u(ji,jj) 
    894             zhpj(ji,jj,1) = ( rho_k(ji  ,jj+1,1) - rho_k(ji,jj,1) - rho_j(ji,jj,1) ) * r1_e2v(ji,jj) 
    895             IF( ln_wd_il ) THEN 
    896               zhpi(ji,jj,1) = zhpi(ji,jj,1) * zcpx(ji,jj) 
    897               zhpj(ji,jj,1) = zhpj(ji,jj,1) * zcpy(ji,jj)  
    898             ENDIF 
    899             ! add to the general momentum trend 
    900             ua(ji,jj,1) = ua(ji,jj,1) + zhpi(ji,jj,1) 
    901             va(ji,jj,1) = va(ji,jj,1) + zhpj(ji,jj,1) 
    902          END DO 
    903       END DO 
     822      DO_2D_00_00 
     823         zhpi(ji,jj,1) = ( rho_k(ji+1,jj  ,1) - rho_k(ji,jj,1) - rho_i(ji,jj,1) ) * r1_e1u(ji,jj) 
     824         zhpj(ji,jj,1) = ( rho_k(ji  ,jj+1,1) - rho_k(ji,jj,1) - rho_j(ji,jj,1) ) * r1_e2v(ji,jj) 
     825         IF( ln_wd_il ) THEN 
     826           zhpi(ji,jj,1) = zhpi(ji,jj,1) * zcpx(ji,jj) 
     827           zhpj(ji,jj,1) = zhpj(ji,jj,1) * zcpy(ji,jj)  
     828         ENDIF 
     829         ! add to the general momentum trend 
     830         puu(ji,jj,1,Krhs) = puu(ji,jj,1,Krhs) + zhpi(ji,jj,1) 
     831         pvv(ji,jj,1,Krhs) = pvv(ji,jj,1,Krhs) + zhpj(ji,jj,1) 
     832      END_2D 
    904833 
    905834      ! ---------------- 
    906835      !  interior value   (2=<jk=<jpkm1) 
    907836      ! ---------------- 
    908       DO jk = 2, jpkm1 
    909          DO jj = 2, jpjm1 
    910             DO ji = fs_2, fs_jpim1   ! vector opt. 
    911                ! hydrostatic pressure gradient along s-surfaces 
    912                zhpi(ji,jj,jk) = zhpi(ji,jj,jk-1)                                & 
    913                   &           + (  ( rho_k(ji+1,jj,jk) - rho_k(ji,jj,jk  ) )    & 
    914                   &              - ( rho_i(ji  ,jj,jk) - rho_i(ji,jj,jk-1) )  ) * r1_e1u(ji,jj) 
    915                zhpj(ji,jj,jk) = zhpj(ji,jj,jk-1)                                & 
    916                   &           + (  ( rho_k(ji,jj+1,jk) - rho_k(ji,jj,jk  ) )    & 
    917                   &               -( rho_j(ji,jj  ,jk) - rho_j(ji,jj,jk-1) )  ) * r1_e2v(ji,jj) 
    918                IF( ln_wd_il ) THEN 
    919                  zhpi(ji,jj,jk) = zhpi(ji,jj,jk) * zcpx(ji,jj) 
    920                  zhpj(ji,jj,jk) = zhpj(ji,jj,jk) * zcpy(ji,jj)  
    921                ENDIF 
    922                ! add to the general momentum trend 
    923                ua(ji,jj,jk) = ua(ji,jj,jk) + zhpi(ji,jj,jk) 
    924                va(ji,jj,jk) = va(ji,jj,jk) + zhpj(ji,jj,jk) 
    925             END DO 
    926          END DO 
    927       END DO 
     837      DO_3D_00_00( 2, jpkm1 ) 
     838         ! hydrostatic pressure gradient along s-surfaces 
     839         zhpi(ji,jj,jk) = zhpi(ji,jj,jk-1)                                & 
     840            &           + (  ( rho_k(ji+1,jj,jk) - rho_k(ji,jj,jk  ) )    & 
     841            &              - ( rho_i(ji  ,jj,jk) - rho_i(ji,jj,jk-1) )  ) * r1_e1u(ji,jj) 
     842         zhpj(ji,jj,jk) = zhpj(ji,jj,jk-1)                                & 
     843            &           + (  ( rho_k(ji,jj+1,jk) - rho_k(ji,jj,jk  ) )    & 
     844            &               -( rho_j(ji,jj  ,jk) - rho_j(ji,jj,jk-1) )  ) * r1_e2v(ji,jj) 
     845         IF( ln_wd_il ) THEN 
     846           zhpi(ji,jj,jk) = zhpi(ji,jj,jk) * zcpx(ji,jj) 
     847           zhpj(ji,jj,jk) = zhpj(ji,jj,jk) * zcpy(ji,jj)  
     848         ENDIF 
     849         ! add to the general momentum trend 
     850         puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + zhpi(ji,jj,jk) 
     851         pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) + zhpj(ji,jj,jk) 
     852      END_3D 
    928853      ! 
    929854      IF( ln_wd_il )   DEALLOCATE( zcpx, zcpy ) 
    … …  
    932857 
    933858 
    934    SUBROUTINE hpg_prj( kt ) 
     859   SUBROUTINE hpg_prj( kt, Kmm, puu, pvv, Krhs ) 
    935860      !!--------------------------------------------------------------------- 
    936861      !!                  ***  ROUTINE hpg_prj  *** 
    … …  
    941866      !!      all vertical coordinate systems 
    942867      !! 
    943       !! ** Action : - Update (ua,va) with the now hydrastatic pressure trend 
     868      !! ** Action : - Update (puu(:,:,:,Krhs),pvv(:,:,:,Krhs)) with the now hydrastatic pressure trend 
    944869      !!---------------------------------------------------------------------- 
    945870      INTEGER, PARAMETER  :: polynomial_type = 1    ! 1: cubic spline, 2: linear 
    946       INTEGER, INTENT(in) ::   kt                   ! ocean time-step index 
     871      INTEGER                             , INTENT( in )  ::  kt          ! ocean time-step index 
     872      INTEGER                             , INTENT( in )  ::  Kmm, Krhs   ! ocean time level indices 
     873      REAL(wp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) ::  puu, pvv    ! ocean velocities and RHS of momentum equation 
    947874      !! 
    948875      INTEGER  ::   ji, jj, jk, jkk                 ! dummy loop indices 
    … …  
    974901      IF( ln_wd_il ) THEN 
    975902         ALLOCATE( zcpx(jpi,jpj) , zcpy(jpi,jpj) ) 
    976          DO jj = 2, jpjm1 
    977            DO ji = 2, jpim1  
    978              ll_tmp1 = MIN(  sshn(ji,jj)              ,  sshn(ji+1,jj) ) >                & 
    979                   &    MAX( -ht_0(ji,jj)              , -ht_0(ji+1,jj) ) .AND.            & 
    980                   &    MAX(  sshn(ji,jj) + ht_0(ji,jj),  sshn(ji+1,jj) + ht_0(ji+1,jj) )  & 
    981                   &                                                      > rn_wdmin1 + rn_wdmin2 
    982              ll_tmp2 = ( ABS( sshn(ji,jj)             -  sshn(ji+1,jj) ) > 1.E-12 ) .AND. (         & 
    983                   &    MAX(   sshn(ji,jj)             ,  sshn(ji+1,jj) ) >                & 
    984                   &    MAX(  -ht_0(ji,jj)             , -ht_0(ji+1,jj) ) + rn_wdmin1 + rn_wdmin2 ) 
    985  
    986              IF(ll_tmp1) THEN 
    987                zcpx(ji,jj) = 1.0_wp 
    988              ELSE IF(ll_tmp2) THEN 
    989                ! no worries about  sshn(ji+1,jj) -  sshn(ji  ,jj) = 0, it won't happen ! here 
    990                zcpx(ji,jj) = ABS( (sshn(ji+1,jj) + ht_0(ji+1,jj) - sshn(ji,jj) - ht_0(ji,jj)) & 
    991                            &    / (sshn(ji+1,jj) -  sshn(ji  ,jj)) ) 
    992                
    993                 zcpx(ji,jj) = max(min( zcpx(ji,jj) , 1.0_wp),0.0_wp) 
    994              ELSE 
    995                zcpx(ji,jj) = 0._wp 
    996              END IF 
    997        
    998              ll_tmp1 = MIN(  sshn(ji,jj)              ,  sshn(ji,jj+1) ) >                & 
    999                   &    MAX( -ht_0(ji,jj)              , -ht_0(ji,jj+1) ) .AND.            & 
    1000                   &    MAX(  sshn(ji,jj) + ht_0(ji,jj),  sshn(ji,jj+1) + ht_0(ji,jj+1) )  & 
    1001                   &                                                      > rn_wdmin1 + rn_wdmin2 
    1002              ll_tmp2 = ( ABS( sshn(ji,jj)             -  sshn(ji,jj+1) ) > 1.E-12 ) .AND. (      & 
    1003                   &    MAX(   sshn(ji,jj)             ,  sshn(ji,jj+1) ) >                & 
    1004                   &    MAX(  -ht_0(ji,jj)             , -ht_0(ji,jj+1) ) + rn_wdmin1 + rn_wdmin2 ) 
    1005  
    1006              IF(ll_tmp1) THEN 
    1007                zcpy(ji,jj) = 1.0_wp 
    1008              ELSE IF(ll_tmp2) THEN 
    1009                ! no worries about  sshn(ji,jj+1) -  sshn(ji,jj  ) = 0, it won't happen ! here 
    1010                zcpy(ji,jj) = ABS( (sshn(ji,jj+1) + ht_0(ji,jj+1) - sshn(ji,jj) - ht_0(ji,jj)) & 
    1011                            &    / (sshn(ji,jj+1) - sshn(ji,jj  )) ) 
    1012                 zcpy(ji,jj) = max(min( zcpy(ji,jj) , 1.0_wp),0.0_wp) 
    1013  
    1014                ELSE 
    1015                   zcpy(ji,jj) = 0._wp 
    1016                ENDIF 
    1017             END DO 
    1018          END DO 
     903         DO_2D_00_00 
     904          ll_tmp1 = MIN(  ssh(ji,jj,Kmm)              ,  ssh(ji+1,jj,Kmm) ) >                & 
     905               &    MAX( -ht_0(ji,jj)              , -ht_0(ji+1,jj) ) .AND.            & 
     906               &    MAX(  ssh(ji,jj,Kmm) + ht_0(ji,jj),  ssh(ji+1,jj,Kmm) + ht_0(ji+1,jj) )  & 
     907               &                                                      > rn_wdmin1 + rn_wdmin2 
     908          ll_tmp2 = ( ABS( ssh(ji,jj,Kmm)             -  ssh(ji+1,jj,Kmm) ) > 1.E-12 ) .AND. (         & 
     909               &    MAX(   ssh(ji,jj,Kmm)             ,  ssh(ji+1,jj,Kmm) ) >                & 
     910               &    MAX(  -ht_0(ji,jj)             , -ht_0(ji+1,jj) ) + rn_wdmin1 + rn_wdmin2 ) 
     911 
     912          IF(ll_tmp1) THEN 
     913            zcpx(ji,jj) = 1.0_wp 
     914          ELSE IF(ll_tmp2) THEN 
     915            ! no worries about  ssh(ji+1,jj,Kmm) -  ssh(ji  ,jj,Kmm) = 0, it won't happen ! here 
     916            zcpx(ji,jj) = ABS( (ssh(ji+1,jj,Kmm) + ht_0(ji+1,jj) - ssh(ji,jj,Kmm) - ht_0(ji,jj)) & 
     917                        &    / (ssh(ji+1,jj,Kmm) -  ssh(ji  ,jj,Kmm)) ) 
     918            
     919             zcpx(ji,jj) = max(min( zcpx(ji,jj) , 1.0_wp),0.0_wp) 
     920          ELSE 
     921            zcpx(ji,jj) = 0._wp 
     922          END IF 
     923    
     924          ll_tmp1 = MIN(  ssh(ji,jj,Kmm)              ,  ssh(ji,jj+1,Kmm) ) >                & 
     925               &    MAX( -ht_0(ji,jj)              , -ht_0(ji,jj+1) ) .AND.            & 
     926               &    MAX(  ssh(ji,jj,Kmm) + ht_0(ji,jj),  ssh(ji,jj+1,Kmm) + ht_0(ji,jj+1) )  & 
     927               &                                                      > rn_wdmin1 + rn_wdmin2 
     928          ll_tmp2 = ( ABS( ssh(ji,jj,Kmm)             -  ssh(ji,jj+1,Kmm) ) > 1.E-12 ) .AND. (      & 
     929               &    MAX(   ssh(ji,jj,Kmm)             ,  ssh(ji,jj+1,Kmm) ) >                & 
     930               &    MAX(  -ht_0(ji,jj)             , -ht_0(ji,jj+1) ) + rn_wdmin1 + rn_wdmin2 ) 
     931 
     932          IF(ll_tmp1) THEN 
     933            zcpy(ji,jj) = 1.0_wp 
     934          ELSE IF(ll_tmp2) THEN 
     935            ! no worries about  ssh(ji,jj+1,Kmm) -  ssh(ji,jj  ,Kmm) = 0, it won't happen ! here 
     936            zcpy(ji,jj) = ABS( (ssh(ji,jj+1,Kmm) + ht_0(ji,jj+1) - ssh(ji,jj,Kmm) - ht_0(ji,jj)) & 
     937                        &    / (ssh(ji,jj+1,Kmm) - ssh(ji,jj  ,Kmm)) ) 
     938             zcpy(ji,jj) = max(min( zcpy(ji,jj) , 1.0_wp),0.0_wp) 
     939 
     940            ELSE 
     941               zcpy(ji,jj) = 0._wp 
     942            ENDIF 
     943         END_2D 
    1019944         CALL lbc_lnk_multi( 'dynhpg', zcpx, 'U', 1., zcpy, 'V', 1. ) 
    1020945      ENDIF 
    … …  
    1025950 
    1026951      ! Preparing vertical density profile "zrhh(:,:,:)" for hybrid-sco coordinate 
    1027       DO jj = 1, jpj 
    1028         DO ji = 1, jpi 
    1029           jk = mbkt(ji,jj)+1 
    1030           IF(     jk <=  0   ) THEN   ;   zrhh(ji,jj,    :   ) = 0._wp 
    1031           ELSEIF( jk ==  1   ) THEN   ;   zrhh(ji,jj,jk+1:jpk) = rhd(ji,jj,jk) 
    1032           ELSEIF( jk < jpkm1 ) THEN 
    1033              DO jkk = jk+1, jpk 
    1034                 zrhh(ji,jj,jkk) = interp1(gde3w_n(ji,jj,jkk  ), gde3w_n(ji,jj,jkk-1),   & 
    1035                    &                      gde3w_n(ji,jj,jkk-2), rhd    (ji,jj,jkk-1), rhd(ji,jj,jkk-2)) 
    1036              END DO 
    1037           ENDIF 
    1038         END DO 
    1039       END DO 
     952      DO_2D_11_11 
     953       jk = mbkt(ji,jj)+1 
     954       IF(     jk <=  0   ) THEN   ;   zrhh(ji,jj,    :   ) = 0._wp 
     955       ELSEIF( jk ==  1   ) THEN   ;   zrhh(ji,jj,jk+1:jpk) = rhd(ji,jj,jk) 
     956       ELSEIF( jk < jpkm1 ) THEN 
     957          DO jkk = jk+1, jpk 
     958             zrhh(ji,jj,jkk) = interp1(gde3w(ji,jj,jkk  ), gde3w(ji,jj,jkk-1),   & 
     959                &                      gde3w(ji,jj,jkk-2), rhd    (ji,jj,jkk-1), rhd(ji,jj,jkk-2)) 
     960          END DO 
     961       ENDIF 
     962      END_2D 
    1040963 
    1041964      ! Transfer the depth of "T(:,:,:)" to vertical coordinate "zdept(:,:,:)" 
    1042       DO jj = 1, jpj 
    1043          DO ji = 1, jpi 
    1044             zdept(ji,jj,1) = 0.5_wp * e3w_n(ji,jj,1) - sshn(ji,jj) * znad 
    1045          END DO 
    1046       END DO 
    1047  
    1048       DO jk = 2, jpk 
    1049          DO jj = 1, jpj 
    1050             DO ji = 1, jpi 
    1051                zdept(ji,jj,jk) = zdept(ji,jj,jk-1) + e3w_n(ji,jj,jk) 
    1052             END DO 
    1053          END DO 
    1054       END DO 
     965      DO_2D_11_11 
     966         zdept(ji,jj,1) = 0.5_wp * e3w(ji,jj,1,Kmm) - ssh(ji,jj,Kmm) * znad 
     967      END_2D 
     968 
     969      DO_3D_11_11( 2, jpk ) 
     970         zdept(ji,jj,jk) = zdept(ji,jj,jk-1) + e3w(ji,jj,jk,Kmm) 
     971      END_3D 
    1055972 
    1056973      fsp(:,:,:) = zrhh (:,:,:) 
    … …  
    1063980 
    1064981      ! Integrate the hydrostatic pressure "zhpi(:,:,:)" at "T(ji,jj,1)" 
    1065       DO jj = 2, jpj 
    1066         DO ji = 2, jpi 
    1067           zrhdt1 = zrhh(ji,jj,1) - interp3( zdept(ji,jj,1), asp(ji,jj,1), bsp(ji,jj,1),  & 
    1068              &                                              csp(ji,jj,1), dsp(ji,jj,1) ) * 0.25_wp * e3w_n(ji,jj,1) 
    1069  
    1070           ! assuming linear profile across the top half surface layer 
    1071           zhpi(ji,jj,1) =  0.5_wp * e3w_n(ji,jj,1) * zrhdt1 
    1072         END DO 
    1073       END DO 
     982      DO_2D_01_01 
     983       zrhdt1 = zrhh(ji,jj,1) - interp3( zdept(ji,jj,1), asp(ji,jj,1), bsp(ji,jj,1),  & 
     984          &                                              csp(ji,jj,1), dsp(ji,jj,1) ) * 0.25_wp * e3w(ji,jj,1,Kmm) 
     985 
     986       ! assuming linear profile across the top half surface layer 
     987       zhpi(ji,jj,1) =  0.5_wp * e3w(ji,jj,1,Kmm) * zrhdt1 
     988      END_2D 
    1074989 
    1075990      ! Calculate the pressure "zhpi(:,:,:)" at "T(ji,jj,2:jpkm1)" 
    1076       DO jk = 2, jpkm1 
    1077         DO jj = 2, jpj 
    1078           DO ji = 2, jpi 
    1079             zhpi(ji,jj,jk) = zhpi(ji,jj,jk-1) +                                  & 
    1080                &             integ_spline( zdept(ji,jj,jk-1), zdept(ji,jj,jk),   & 
    1081                &                           asp  (ji,jj,jk-1), bsp  (ji,jj,jk-1), & 
    1082                &                           csp  (ji,jj,jk-1), dsp  (ji,jj,jk-1)  ) 
    1083           END DO 
    1084         END DO 
    1085       END DO 
     991      DO_3D_01_01( 2, jpkm1 ) 
     992      zhpi(ji,jj,jk) = zhpi(ji,jj,jk-1) +                                  & 
     993         &             integ_spline( zdept(ji,jj,jk-1), zdept(ji,jj,jk),   & 
     994         &                           asp  (ji,jj,jk-1), bsp  (ji,jj,jk-1), & 
     995         &                           csp  (ji,jj,jk-1), dsp  (ji,jj,jk-1)  ) 
     996      END_3D 
    1086997 
    1087998      ! Z coordinate of U(ji,jj,1:jpkm1) and V(ji,jj,1:jpkm1) 
    1088999 
    10891000      ! Prepare zsshu_n and zsshv_n 
    1090       DO jj = 2, jpjm1 
    1091         DO ji = 2, jpim1 
     1001      DO_2D_00_00 
    10921002!!gm BUG ?    if it is ssh at u- & v-point then it should be: 
    1093 !          zsshu_n(ji,jj) = (e1e2t(ji,jj) * sshn(ji,jj) + e1e2t(ji+1,jj) * sshn(ji+1,jj)) * & 
     1003!          zsshu_n(ji,jj) = (e1e2t(ji,jj) * ssh(ji,jj,Kmm) + e1e2t(ji+1,jj) * ssh(ji+1,jj,Kmm)) * & 
    10941004!                         & r1_e1e2u(ji,jj) * umask(ji,jj,1) * 0.5_wp  
    1095 !          zsshv_n(ji,jj) = (e1e2t(ji,jj) * sshn(ji,jj) + e1e2t(ji,jj+1) * sshn(ji,jj+1)) * & 
     1005!          zsshv_n(ji,jj) = (e1e2t(ji,jj) * ssh(ji,jj,Kmm) + e1e2t(ji,jj+1) * ssh(ji,jj+1,Kmm)) * & 
    10961006!                         & r1_e1e2v(ji,jj) * vmask(ji,jj,1) * 0.5_wp  
    10971007!!gm not this: 
    1098           zsshu_n(ji,jj) = (e1e2u(ji,jj) * sshn(ji,jj) + e1e2u(ji+1, jj) * sshn(ji+1,jj)) * & 
    1099                          & r1_e1e2u(ji,jj) * umask(ji,jj,1) * 0.5_wp  
    1100           zsshv_n(ji,jj) = (e1e2v(ji,jj) * sshn(ji,jj) + e1e2v(ji+1, jj) * sshn(ji,jj+1)) * & 
    1101                          & r1_e1e2v(ji,jj) * vmask(ji,jj,1) * 0.5_wp  
    1102         END DO 
    1103       END DO 
     1008       zsshu_n(ji,jj) = (e1e2u(ji,jj) * ssh(ji,jj,Kmm) + e1e2u(ji+1, jj) * ssh(ji+1,jj,Kmm)) * & 
     1009                      & r1_e1e2u(ji,jj) * umask(ji,jj,1) * 0.5_wp  
     1010       zsshv_n(ji,jj) = (e1e2v(ji,jj) * ssh(ji,jj,Kmm) + e1e2v(ji+1, jj) * ssh(ji,jj+1,Kmm)) * & 
     1011                      & r1_e1e2v(ji,jj) * vmask(ji,jj,1) * 0.5_wp  
     1012      END_2D 
    11041013 
    11051014      CALL lbc_lnk_multi ('dynhpg', zsshu_n, 'U', 1., zsshv_n, 'V', 1. ) 
    11061015 
    1107       DO jj = 2, jpjm1 
    1108         DO ji = 2, jpim1 
    1109           zu(ji,jj,1) = - ( e3u_n(ji,jj,1) - zsshu_n(ji,jj) * znad)  
    1110           zv(ji,jj,1) = - ( e3v_n(ji,jj,1) - zsshv_n(ji,jj) * znad) 
    1111         END DO 
    1112       END DO 
    1113  
    1114       DO jk = 2, jpkm1 
    1115         DO jj = 2, jpjm1 
    1116           DO ji = 2, jpim1 
    1117             zu(ji,jj,jk) = zu(ji,jj,jk-1) - e3u_n(ji,jj,jk) 
    1118             zv(ji,jj,jk) = zv(ji,jj,jk-1) - e3v_n(ji,jj,jk) 
    1119           END DO 
    1120         END DO 
    1121       END DO 
    1122  
    1123       DO jk = 1, jpkm1 
    1124         DO jj = 2, jpjm1 
    1125           DO ji = 2, jpim1 
    1126             zu(ji,jj,jk) = zu(ji,jj,jk) + 0.5_wp * e3u_n(ji,jj,jk) 
    1127             zv(ji,jj,jk) = zv(ji,jj,jk) + 0.5_wp * e3v_n(ji,jj,jk) 
    1128           END DO 
    1129         END DO 
    1130       END DO 
    1131  
    1132       DO jk = 1, jpkm1 
    1133         DO jj = 2, jpjm1 
    1134           DO ji = 2, jpim1 
    1135             zu(ji,jj,jk) = MIN(  zu(ji,jj,jk) , MAX( -zdept(ji,jj,jk) , -zdept(ji+1,jj,jk) )  ) 
    1136             zu(ji,jj,jk) = MAX(  zu(ji,jj,jk) , MIN( -zdept(ji,jj,jk) , -zdept(ji+1,jj,jk) )  ) 
    1137             zv(ji,jj,jk) = MIN(  zv(ji,jj,jk) , MAX( -zdept(ji,jj,jk) , -zdept(ji,jj+1,jk) )  ) 
    1138             zv(ji,jj,jk) = MAX(  zv(ji,jj,jk) , MIN( -zdept(ji,jj,jk) , -zdept(ji,jj+1,jk) )  ) 
    1139           END DO 
    1140         END DO 
    1141       END DO 
    1142  
    1143  
    1144       DO jk = 1, jpkm1 
    1145         DO jj = 2, jpjm1 
    1146           DO ji = 2, jpim1 
    1147             zpwes = 0._wp; zpwed = 0._wp 
    1148             zpnss = 0._wp; zpnsd = 0._wp 
    1149             zuijk = zu(ji,jj,jk) 
    1150             zvijk = zv(ji,jj,jk) 
    1151  
    1152             !!!!!     for u equation 
    1153             IF( jk <= mbku(ji,jj) ) THEN 
    1154                IF( -zdept(ji+1,jj,jk) >= -zdept(ji,jj,jk) ) THEN 
    1155                  jis = ji + 1; jid = ji 
    1156                ELSE 
    1157                  jis = ji;     jid = ji +1 
    1158                ENDIF 
    1159  
    1160                ! integrate the pressure on the shallow side 
    1161                jk1 = jk 
    1162                DO WHILE ( -zdept(jis,jj,jk1) > zuijk ) 
    1163                  IF( jk1 == mbku(ji,jj) ) THEN 
    1164                    zuijk = -zdept(jis,jj,jk1) 
    1165                    EXIT 
    1166                  ENDIF 
    1167                  zdeps = MIN(zdept(jis,jj,jk1+1), -zuijk) 
    1168                  zpwes = zpwes +                                    & 
    1169                       integ_spline(zdept(jis,jj,jk1), zdeps,            & 
    1170                              asp(jis,jj,jk1),    bsp(jis,jj,jk1), & 
    1171                              csp(jis,jj,jk1),    dsp(jis,jj,jk1)) 
    1172                  jk1 = jk1 + 1 
    1173                END DO 
    1174  
    1175                ! integrate the pressure on the deep side 
    1176                jk1 = jk 
    1177                DO WHILE ( -zdept(jid,jj,jk1) < zuijk ) 
    1178                  IF( jk1 == 1 ) THEN 
    1179                    zdeps = zdept(jid,jj,1) + MIN(zuijk, sshn(jid,jj)*znad) 
    1180                    zrhdt1 = zrhh(jid,jj,1) - interp3(zdept(jid,jj,1), asp(jid,jj,1), & 
    1181                                                      bsp(jid,jj,1),   csp(jid,jj,1), & 
    1182                                                      dsp(jid,jj,1)) * zdeps 
    1183                    zpwed  = zpwed + 0.5_wp * (zrhh(jid,jj,1) + zrhdt1) * zdeps 
    1184                    EXIT 
    1185                  ENDIF 
    1186                  zdeps = MAX(zdept(jid,jj,jk1-1), -zuijk) 
    1187                  zpwed = zpwed +                                        & 
    1188                         integ_spline(zdeps,              zdept(jid,jj,jk1), & 
    1189                                asp(jid,jj,jk1-1), bsp(jid,jj,jk1-1),  & 
    1190                                csp(jid,jj,jk1-1), dsp(jid,jj,jk1-1) ) 
    1191                  jk1 = jk1 - 1 
    1192                END DO 
    1193  
    1194                ! update the momentum trends in u direction 
    1195  
    1196                zdpdx1 = zcoef0 * r1_e1u(ji,jj) * ( zhpi(ji+1,jj,jk) - zhpi(ji,jj,jk) ) 
    1197                IF( .NOT.ln_linssh ) THEN 
    1198                  zdpdx2 = zcoef0 * r1_e1u(ji,jj) * & 
    1199                     &    ( REAL(jis-jid, wp) * (zpwes + zpwed) + (sshn(ji+1,jj)-sshn(ji,jj)) ) 
    1200                 ELSE 
    1201                  zdpdx2 = zcoef0 * r1_e1u(ji,jj) * REAL(jis-jid, wp) * (zpwes + zpwed) 
    1202                ENDIF 
    1203                IF( ln_wd_il ) THEN 
    1204                   zdpdx1 = zdpdx1 * zcpx(ji,jj) * wdrampu(ji,jj) 
    1205                   zdpdx2 = zdpdx2 * zcpx(ji,jj) * wdrampu(ji,jj) 
    1206                ENDIF 
    1207                ua(ji,jj,jk) = ua(ji,jj,jk) + (zdpdx1 + zdpdx2) * umask(ji,jj,jk)  
    1208             ENDIF 
    1209  
    1210             !!!!!     for v equation 
    1211             IF( jk <= mbkv(ji,jj) ) THEN 
    1212                IF( -zdept(ji,jj+1,jk) >= -zdept(ji,jj,jk) ) THEN 
    1213                  jjs = jj + 1; jjd = jj 
    1214                ELSE 
    1215                  jjs = jj    ; jjd = jj + 1 
    1216                ENDIF 
    1217  
    1218                ! integrate the pressure on the shallow side 
    1219                jk1 = jk 
    1220                DO WHILE ( -zdept(ji,jjs,jk1) > zvijk ) 
    1221                  IF( jk1 == mbkv(ji,jj) ) THEN 
    1222                    zvijk = -zdept(ji,jjs,jk1) 
    1223                    EXIT 
    1224                  ENDIF 
    1225                  zdeps = MIN(zdept(ji,jjs,jk1+1), -zvijk) 
    1226                  zpnss = zpnss +                                      & 
    1227                         integ_spline(zdept(ji,jjs,jk1), zdeps,            & 
    1228                                asp(ji,jjs,jk1),    bsp(ji,jjs,jk1), & 
    1229                                csp(ji,jjs,jk1),    dsp(ji,jjs,jk1) ) 
    1230                  jk1 = jk1 + 1 
    1231                END DO 
    1232  
    1233                ! integrate the pressure on the deep side 
    1234                jk1 = jk 
    1235                DO WHILE ( -zdept(ji,jjd,jk1) < zvijk ) 
    1236                  IF( jk1 == 1 ) THEN 
    1237                    zdeps = zdept(ji,jjd,1) + MIN(zvijk, sshn(ji,jjd)*znad) 
    1238                    zrhdt1 = zrhh(ji,jjd,1) - interp3(zdept(ji,jjd,1), asp(ji,jjd,1), & 
    1239                                                      bsp(ji,jjd,1),   csp(ji,jjd,1), & 
    1240                                                      dsp(ji,jjd,1) ) * zdeps 
    1241                    zpnsd  = zpnsd + 0.5_wp * (zrhh(ji,jjd,1) + zrhdt1) * zdeps 
    1242                    EXIT 
    1243                  ENDIF 
    1244                  zdeps = MAX(zdept(ji,jjd,jk1-1), -zvijk) 
    1245                  zpnsd = zpnsd +                                        & 
    1246                         integ_spline(zdeps,              zdept(ji,jjd,jk1), & 
    1247                                asp(ji,jjd,jk1-1), bsp(ji,jjd,jk1-1), & 
    1248                                csp(ji,jjd,jk1-1), dsp(ji,jjd,jk1-1) ) 
    1249                  jk1 = jk1 - 1 
    1250                END DO 
    1251  
    1252  
    1253                ! update the momentum trends in v direction 
    1254  
    1255                zdpdy1 = zcoef0 * r1_e2v(ji,jj) * ( zhpi(ji,jj+1,jk) - zhpi(ji,jj,jk) ) 
    1256                IF( .NOT.ln_linssh ) THEN 
    1257                   zdpdy2 = zcoef0 * r1_e2v(ji,jj) * & 
    1258                           ( REAL(jjs-jjd, wp) * (zpnss + zpnsd) + (sshn(ji,jj+1)-sshn(ji,jj)) ) 
    1259                ELSE 
    1260                   zdpdy2 = zcoef0 * r1_e2v(ji,jj) * REAL(jjs-jjd, wp) * (zpnss + zpnsd ) 
    1261                ENDIF 
    1262                IF( ln_wd_il ) THEN 
    1263                   zdpdy1 = zdpdy1 * zcpy(ji,jj) * wdrampv(ji,jj)  
    1264                   zdpdy2 = zdpdy2 * zcpy(ji,jj) * wdrampv(ji,jj)  
    1265                ENDIF 
    1266  
    1267                va(ji,jj,jk) = va(ji,jj,jk) + (zdpdy1 + zdpdy2) * vmask(ji,jj,jk) 
    1268             ENDIF 
    1269                ! 
    1270             END DO 
     1016      DO_2D_00_00 
     1017       zu(ji,jj,1) = - ( e3u(ji,jj,1,Kmm) - zsshu_n(ji,jj) * znad)  
     1018       zv(ji,jj,1) = - ( e3v(ji,jj,1,Kmm) - zsshv_n(ji,jj) * znad) 
     1019      END_2D 
     1020 
     1021      DO_3D_00_00( 2, jpkm1 ) 
     1022      zu(ji,jj,jk) = zu(ji,jj,jk-1) - e3u(ji,jj,jk,Kmm) 
     1023      zv(ji,jj,jk) = zv(ji,jj,jk-1) - e3v(ji,jj,jk,Kmm) 
     1024      END_3D 
     1025 
     1026      DO_3D_00_00( 1, jpkm1 ) 
     1027      zu(ji,jj,jk) = zu(ji,jj,jk) + 0.5_wp * e3u(ji,jj,jk,Kmm) 
     1028      zv(ji,jj,jk) = zv(ji,jj,jk) + 0.5_wp * e3v(ji,jj,jk,Kmm) 
     1029      END_3D 
     1030 
     1031      DO_3D_00_00( 1, jpkm1 ) 
     1032      zu(ji,jj,jk) = MIN(  zu(ji,jj,jk) , MAX( -zdept(ji,jj,jk) , -zdept(ji+1,jj,jk) )  ) 
     1033      zu(ji,jj,jk) = MAX(  zu(ji,jj,jk) , MIN( -zdept(ji,jj,jk) , -zdept(ji+1,jj,jk) )  ) 
     1034      zv(ji,jj,jk) = MIN(  zv(ji,jj,jk) , MAX( -zdept(ji,jj,jk) , -zdept(ji,jj+1,jk) )  ) 
     1035      zv(ji,jj,jk) = MAX(  zv(ji,jj,jk) , MIN( -zdept(ji,jj,jk) , -zdept(ji,jj+1,jk) )  ) 
     1036      END_3D 
     1037 
     1038 
     1039      DO_3D_00_00( 1, jpkm1 ) 
     1040      zpwes = 0._wp; zpwed = 0._wp 
     1041      zpnss = 0._wp; zpnsd = 0._wp 
     1042      zuijk = zu(ji,jj,jk) 
     1043      zvijk = zv(ji,jj,jk) 
     1044 
     1045      !!!!!     for u equation 
     1046      IF( jk <= mbku(ji,jj) ) THEN 
     1047         IF( -zdept(ji+1,jj,jk) >= -zdept(ji,jj,jk) ) THEN 
     1048           jis = ji + 1; jid = ji 
     1049         ELSE 
     1050           jis = ji;     jid = ji +1 
     1051         ENDIF 
     1052 
     1053         ! integrate the pressure on the shallow side 
     1054         jk1 = jk 
     1055         DO WHILE ( -zdept(jis,jj,jk1) > zuijk ) 
     1056           IF( jk1 == mbku(ji,jj) ) THEN 
     1057             zuijk = -zdept(jis,jj,jk1) 
     1058             EXIT 
     1059           ENDIF 
     1060           zdeps = MIN(zdept(jis,jj,jk1+1), -zuijk) 
     1061           zpwes = zpwes +                                    & 
     1062                integ_spline(zdept(jis,jj,jk1), zdeps,            & 
     1063                       asp(jis,jj,jk1),    bsp(jis,jj,jk1), & 
     1064                       csp(jis,jj,jk1),    dsp(jis,jj,jk1)) 
     1065           jk1 = jk1 + 1 
    12711066         END DO 
    1272       END DO 
     1067 
     1068         ! integrate the pressure on the deep side 
     1069         jk1 = jk 
     1070         DO WHILE ( -zdept(jid,jj,jk1) < zuijk ) 
     1071           IF( jk1 == 1 ) THEN 
     1072             zdeps = zdept(jid,jj,1) + MIN(zuijk, ssh(jid,jj,Kmm)*znad) 
     1073             zrhdt1 = zrhh(jid,jj,1) - interp3(zdept(jid,jj,1), asp(jid,jj,1), & 
     1074                                               bsp(jid,jj,1),   csp(jid,jj,1), & 
     1075                                               dsp(jid,jj,1)) * zdeps 
     1076             zpwed  = zpwed + 0.5_wp * (zrhh(jid,jj,1) + zrhdt1) * zdeps 
     1077             EXIT 
     1078           ENDIF 
     1079           zdeps = MAX(zdept(jid,jj,jk1-1), -zuijk) 
     1080           zpwed = zpwed +                                        & 
     1081                  integ_spline(zdeps,              zdept(jid,jj,jk1), & 
     1082                         asp(jid,jj,jk1-1), bsp(jid,jj,jk1-1),  & 
     1083                         csp(jid,jj,jk1-1), dsp(jid,jj,jk1-1) ) 
     1084           jk1 = jk1 - 1 
     1085         END DO 
     1086 
     1087         ! update the momentum trends in u direction 
     1088 
     1089         zdpdx1 = zcoef0 * r1_e1u(ji,jj) * ( zhpi(ji+1,jj,jk) - zhpi(ji,jj,jk) ) 
     1090         IF( .NOT.ln_linssh ) THEN 
     1091           zdpdx2 = zcoef0 * r1_e1u(ji,jj) * & 
     1092              &    ( REAL(jis-jid, wp) * (zpwes + zpwed) + (ssh(ji+1,jj,Kmm)-ssh(ji,jj,Kmm)) ) 
     1093          ELSE 
     1094           zdpdx2 = zcoef0 * r1_e1u(ji,jj) * REAL(jis-jid, wp) * (zpwes + zpwed) 
     1095         ENDIF 
     1096         IF( ln_wd_il ) THEN 
     1097            zdpdx1 = zdpdx1 * zcpx(ji,jj) * wdrampu(ji,jj) 
     1098            zdpdx2 = zdpdx2 * zcpx(ji,jj) * wdrampu(ji,jj) 
     1099         ENDIF 
     1100         puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + (zdpdx1 + zdpdx2) * umask(ji,jj,jk)  
     1101      ENDIF 
     1102 
     1103      !!!!!     for v equation 
     1104      IF( jk <= mbkv(ji,jj) ) THEN 
     1105         IF( -zdept(ji,jj+1,jk) >= -zdept(ji,jj,jk) ) THEN 
     1106           jjs = jj + 1; jjd = jj 
     1107         ELSE 
     1108           jjs = jj    ; jjd = jj + 1 
     1109         ENDIF 
     1110 
     1111         ! integrate the pressure on the shallow side 
     1112         jk1 = jk 
     1113         DO WHILE ( -zdept(ji,jjs,jk1) > zvijk ) 
     1114           IF( jk1 == mbkv(ji,jj) ) THEN 
     1115             zvijk = -zdept(ji,jjs,jk1) 
     1116             EXIT 
     1117           ENDIF 
     1118           zdeps = MIN(zdept(ji,jjs,jk1+1), -zvijk) 
     1119           zpnss = zpnss +                                      & 
     1120                  integ_spline(zdept(ji,jjs,jk1), zdeps,            & 
     1121                         asp(ji,jjs,jk1),    bsp(ji,jjs,jk1), & 
     1122                         csp(ji,jjs,jk1),    dsp(ji,jjs,jk1) ) 
     1123           jk1 = jk1 + 1 
     1124         END DO 
     1125 
     1126         ! integrate the pressure on the deep side 
     1127         jk1 = jk 
     1128         DO WHILE ( -zdept(ji,jjd,jk1) < zvijk ) 
     1129           IF( jk1 == 1 ) THEN 
     1130             zdeps = zdept(ji,jjd,1) + MIN(zvijk, ssh(ji,jjd,Kmm)*znad) 
     1131             zrhdt1 = zrhh(ji,jjd,1) - interp3(zdept(ji,jjd,1), asp(ji,jjd,1), & 
     1132                                               bsp(ji,jjd,1),   csp(ji,jjd,1), & 
     1133                                               dsp(ji,jjd,1) ) * zdeps 
     1134             zpnsd  = zpnsd + 0.5_wp * (zrhh(ji,jjd,1) + zrhdt1) * zdeps 
     1135             EXIT 
     1136           ENDIF 
     1137           zdeps = MAX(zdept(ji,jjd,jk1-1), -zvijk) 
     1138           zpnsd = zpnsd +                                        & 
     1139                  integ_spline(zdeps,              zdept(ji,jjd,jk1), & 
     1140                         asp(ji,jjd,jk1-1), bsp(ji,jjd,jk1-1), & 
     1141                         csp(ji,jjd,jk1-1), dsp(ji,jjd,jk1-1) ) 
     1142           jk1 = jk1 - 1 
     1143         END DO 
     1144 
     1145 
     1146         ! update the momentum trends in v direction 
     1147 
     1148         zdpdy1 = zcoef0 * r1_e2v(ji,jj) * ( zhpi(ji,jj+1,jk) - zhpi(ji,jj,jk) ) 
     1149         IF( .NOT.ln_linssh ) THEN 
     1150            zdpdy2 = zcoef0 * r1_e2v(ji,jj) * & 
     1151                    ( REAL(jjs-jjd, wp) * (zpnss + zpnsd) + (ssh(ji,jj+1,Kmm)-ssh(ji,jj,Kmm)) ) 
     1152         ELSE 
     1153            zdpdy2 = zcoef0 * r1_e2v(ji,jj) * REAL(jjs-jjd, wp) * (zpnss + zpnsd ) 
     1154         ENDIF 
     1155         IF( ln_wd_il ) THEN 
     1156            zdpdy1 = zdpdy1 * zcpy(ji,jj) * wdrampv(ji,jj)  
     1157            zdpdy2 = zdpdy2 * zcpy(ji,jj) * wdrampv(ji,jj)  
     1158         ENDIF 
     1159 
     1160         pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) + (zdpdy1 + zdpdy2) * vmask(ji,jj,jk) 
     1161      ENDIF 
     1162         ! 
     1163      END_3D 
    12731164      ! 
    12741165      IF( ln_wd_il )   DEALLOCATE( zcpx, zcpy ) 

  • NEMO/trunk/src/OCE/DYN/dynkeg.F90

    r11536 r12377  
    3636    
    3737   !! * Substitutions 
    38 #  include "vectopt_loop_substitute.h90" 
     38#  include "do_loop_substitute.h90" 
    3939   !!---------------------------------------------------------------------- 
    4040   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    4444CONTAINS 
    4545 
    46    SUBROUTINE dyn_keg( kt, kscheme ) 
     46   SUBROUTINE dyn_keg( kt, kscheme, Kmm, puu, pvv, Krhs ) 
    4747      !!---------------------------------------------------------------------- 
    4848      !!                  ***  ROUTINE dyn_keg  *** 
    … …  
    5757      !!              * kscheme = nkeg_HW : Hollingsworth correction following 
    5858      !!      Arakawa (2001). The now horizontal kinetic energy is given by: 
    59       !!         zhke = 1/6 [ mi-1(  2 * un^2 + ((un(j+1)+un(j-1))/2)^2  ) 
    60       !!                    + mj-1(  2 * vn^2 + ((vn(i+1)+vn(i-1))/2)^2  ) ] 
     59      !!         zhke = 1/6 [ mi-1(  2 * un^2 + ((u(j+1)+u(j-1))/2)^2  ) 
     60      !!                    + mj-1(  2 * vn^2 + ((v(i+1)+v(i-1))/2)^2  ) ] 
    6161      !!       
    6262      !!      Take its horizontal gradient and add it to the general momentum 
    63       !!      trend (ua,va). 
    64       !!         ua = ua - 1/e1u di[ zhke ] 
    65       !!         va = va - 1/e2v dj[ zhke ] 
     63      !!      trend. 
     64      !!         u(rhs) = u(rhs) - 1/e1u di[ zhke ] 
     65      !!         v(rhs) = v(rhs) - 1/e2v dj[ zhke ] 
    6666      !! 
    67       !! ** Action : - Update the (ua, va) with the hor. ke gradient trend 
     67      !! ** Action : - Update the (puu(:,:,:,Krhs), pvv(:,:,:,Krhs)) with the hor. ke gradient trend 
    6868      !!             - send this trends to trd_dyn (l_trddyn=T) for post-processing 
    6969      !! 
    … …  
    7171      !!                 Hollingsworth et al., Quart. J. Roy. Meteor. Soc., 1983. 
    7272      !!---------------------------------------------------------------------- 
    73       INTEGER, INTENT( in ) ::   kt        ! ocean time-step index 
    74       INTEGER, INTENT( in ) ::   kscheme   ! =0/1   type of KEG scheme  
     73      INTEGER                             , INTENT( in )  ::  kt               ! ocean time-step index 
     74      INTEGER                             , INTENT( in )  ::  kscheme          ! =0/1   type of KEG scheme  
     75      INTEGER                             , INTENT( in )  ::  Kmm, Krhs        ! ocean time level indices 
     76      REAL(wp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) ::  puu, pvv         ! ocean velocities and RHS of momentum equation 
    7577      ! 
    7678      INTEGER  ::   ji, jj, jk             ! dummy loop indices 
    … …  
    9092      IF( l_trddyn ) THEN           ! Save the input trends 
    9193         ALLOCATE( ztrdu(jpi,jpj,jpk) , ztrdv(jpi,jpj,jpk) ) 
    92          ztrdu(:,:,:) = ua(:,:,:)  
    93          ztrdv(:,:,:) = va(:,:,:)  
     94         ztrdu(:,:,:) = puu(:,:,:,Krhs)  
     95         ztrdv(:,:,:) = pvv(:,:,:,Krhs)  
    9496      ENDIF 
    9597       
    … …  
    99101      ! 
    100102      CASE ( nkeg_C2 )                          !--  Standard scheme  --! 
    101          DO jk = 1, jpkm1 
    102             DO jj = 2, jpj 
    103                DO ji = fs_2, jpi   ! vector opt. 
    104                   zu =    un(ji-1,jj  ,jk) * un(ji-1,jj  ,jk)   & 
    105                      &  + un(ji  ,jj  ,jk) * un(ji  ,jj  ,jk) 
    106                   zv =    vn(ji  ,jj-1,jk) * vn(ji  ,jj-1,jk)   & 
    107                      &  + vn(ji  ,jj  ,jk) * vn(ji  ,jj  ,jk) 
    108                   zhke(ji,jj,jk) = 0.25_wp * ( zv + zu ) 
    109                END DO   
    110             END DO 
    111          END DO 
     103         DO_3D_01_01( 1, jpkm1 ) 
     104            zu =    puu(ji-1,jj  ,jk,Kmm) * puu(ji-1,jj  ,jk,Kmm)   & 
     105               &  + puu(ji  ,jj  ,jk,Kmm) * puu(ji  ,jj  ,jk,Kmm) 
     106            zv =    pvv(ji  ,jj-1,jk,Kmm) * pvv(ji  ,jj-1,jk,Kmm)   & 
     107               &  + pvv(ji  ,jj  ,jk,Kmm) * pvv(ji  ,jj  ,jk,Kmm) 
     108            zhke(ji,jj,jk) = 0.25_wp * ( zv + zu ) 
     109         END_3D 
    112110      CASE ( nkeg_HW )                          !--  Hollingsworth scheme  --! 
    113          DO jk = 1, jpkm1 
    114             DO jj = 2, jpjm1        
    115                DO ji = fs_2, jpim1   ! vector opt. 
    116                   zu = 8._wp * ( un(ji-1,jj  ,jk) * un(ji-1,jj  ,jk)    & 
    117                      &         + un(ji  ,jj  ,jk) * un(ji  ,jj  ,jk) )  & 
    118                      &   +     ( un(ji-1,jj-1,jk) + un(ji-1,jj+1,jk) ) * ( un(ji-1,jj-1,jk) + un(ji-1,jj+1,jk) )   & 
    119                      &   +     ( un(ji  ,jj-1,jk) + un(ji  ,jj+1,jk) ) * ( un(ji  ,jj-1,jk) + un(ji  ,jj+1,jk) ) 
    120                      ! 
    121                   zv = 8._wp * ( vn(ji  ,jj-1,jk) * vn(ji  ,jj-1,jk)    & 
    122                      &         + vn(ji  ,jj  ,jk) * vn(ji  ,jj  ,jk) )  & 
    123                      &  +      ( vn(ji-1,jj-1,jk) + vn(ji+1,jj-1,jk) ) * ( vn(ji-1,jj-1,jk) + vn(ji+1,jj-1,jk) )   & 
    124                      &  +      ( vn(ji-1,jj  ,jk) + vn(ji+1,jj  ,jk) ) * ( vn(ji-1,jj  ,jk) + vn(ji+1,jj  ,jk) ) 
    125                   zhke(ji,jj,jk) = r1_48 * ( zv + zu ) 
    126                END DO   
    127             END DO 
    128          END DO 
     111         DO_3D_00_00( 1, jpkm1 ) 
     112            zu = 8._wp * ( puu(ji-1,jj  ,jk,Kmm) * puu(ji-1,jj  ,jk,Kmm)    & 
     113               &         + puu(ji  ,jj  ,jk,Kmm) * puu(ji  ,jj  ,jk,Kmm) )  & 
     114               &   +     ( puu(ji-1,jj-1,jk,Kmm) + puu(ji-1,jj+1,jk,Kmm) ) * ( puu(ji-1,jj-1,jk,Kmm) + puu(ji-1,jj+1,jk,Kmm) )   & 
     115               &   +     ( puu(ji  ,jj-1,jk,Kmm) + puu(ji  ,jj+1,jk,Kmm) ) * ( puu(ji  ,jj-1,jk,Kmm) + puu(ji  ,jj+1,jk,Kmm) ) 
     116               ! 
     117            zv = 8._wp * ( pvv(ji  ,jj-1,jk,Kmm) * pvv(ji  ,jj-1,jk,Kmm)    & 
     118               &         + pvv(ji  ,jj  ,jk,Kmm) * pvv(ji  ,jj  ,jk,Kmm) )  & 
     119               &  +      ( pvv(ji-1,jj-1,jk,Kmm) + pvv(ji+1,jj-1,jk,Kmm) ) * ( pvv(ji-1,jj-1,jk,Kmm) + pvv(ji+1,jj-1,jk,Kmm) )   & 
     120               &  +      ( pvv(ji-1,jj  ,jk,Kmm) + pvv(ji+1,jj  ,jk,Kmm) ) * ( pvv(ji-1,jj  ,jk,Kmm) + pvv(ji+1,jj  ,jk,Kmm) ) 
     121            zhke(ji,jj,jk) = r1_48 * ( zv + zu ) 
     122         END_3D 
    129123         CALL lbc_lnk( 'dynkeg', zhke, 'T', 1. ) 
    130124         ! 
    131125      END SELECT  
    132126      ! 
    133       DO jk = 1, jpkm1                    !==  grad( KE ) added to the general momentum trends  ==! 
    134          DO jj = 2, jpjm1 
    135             DO ji = fs_2, fs_jpim1   ! vector opt. 
    136                ua(ji,jj,jk) = ua(ji,jj,jk) - ( zhke(ji+1,jj  ,jk) - zhke(ji,jj,jk) ) / e1u(ji,jj) 
    137                va(ji,jj,jk) = va(ji,jj,jk) - ( zhke(ji  ,jj+1,jk) - zhke(ji,jj,jk) ) / e2v(ji,jj) 
    138             END DO  
    139          END DO 
    140       END DO 
     127      DO_3D_00_00( 1, jpkm1 ) 
     128         puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) - ( zhke(ji+1,jj  ,jk) - zhke(ji,jj,jk) ) / e1u(ji,jj) 
     129         pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) - ( zhke(ji  ,jj+1,jk) - zhke(ji,jj,jk) ) / e2v(ji,jj) 
     130      END_3D 
    141131      ! 
    142132      IF( l_trddyn ) THEN                 ! save the Kinetic Energy trends for diagnostic 
    143          ztrdu(:,:,:) = ua(:,:,:) - ztrdu(:,:,:) 
    144          ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:) 
    145          CALL trd_dyn( ztrdu, ztrdv, jpdyn_keg, kt ) 
     133         ztrdu(:,:,:) = puu(:,:,:,Krhs) - ztrdu(:,:,:) 
     134         ztrdv(:,:,:) = pvv(:,:,:,Krhs) - ztrdv(:,:,:) 
     135         CALL trd_dyn( ztrdu, ztrdv, jpdyn_keg, kt, Kmm ) 
    146136         DEALLOCATE( ztrdu , ztrdv ) 
    147137      ENDIF 
    148138      ! 
    149       IF(ln_ctl)   CALL prt_ctl( tab3d_1=ua, clinfo1=' keg  - Ua: ', mask1=umask,   & 
    150          &                       tab3d_2=va, clinfo2=       ' Va: ', mask2=vmask, clinfo3='dyn' ) 
     139      IF(sn_cfctl%l_prtctl)   CALL prt_ctl( tab3d_1=puu(:,:,:,Krhs), clinfo1=' keg  - Ua: ', mask1=umask,   & 
     140         &                                  tab3d_2=pvv(:,:,:,Krhs), clinfo2=       ' Va: ', mask2=vmask, clinfo3='dyn' ) 
    151141      ! 
    152142      IF( ln_timing )   CALL timing_stop('dyn_keg') 

  • NEMO/trunk/src/OCE/DYN/dynldf.F90

    r10068 r12377  
    3434   PUBLIC   dyn_ldf_init  ! called by opa  module  
    3535 
    36    !! * Substitutions 
    37 #  include "vectopt_loop_substitute.h90" 
    3836   !!---------------------------------------------------------------------- 
    3937   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    4341CONTAINS 
    4442 
    45    SUBROUTINE dyn_ldf( kt ) 
     43   SUBROUTINE dyn_ldf( kt, Kbb, Kmm, puu, pvv, Krhs ) 
    4644      !!---------------------------------------------------------------------- 
    4745      !!                  ***  ROUTINE dyn_ldf  *** 
    … …  
    4947      !! ** Purpose :   compute the lateral ocean dynamics physics. 
    5048      !!---------------------------------------------------------------------- 
    51       INTEGER, INTENT(in) ::   kt   ! ocean time-step index 
     49      INTEGER                             , INTENT( in )  ::  kt               ! ocean time-step index 
     50      INTEGER                             , INTENT( in )  ::  Kbb, Kmm, Krhs   ! ocean time level indices 
     51      REAL(wp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) ::  puu, pvv         ! ocean velocities and RHS of momentum equation 
    5252      ! 
    5353      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   ztrdu, ztrdv 
    … …  
    5858      IF( l_trddyn )   THEN                      ! temporary save of momentum trends 
    5959         ALLOCATE( ztrdu(jpi,jpj,jpk) , ztrdv(jpi,jpj,jpk) ) 
    60          ztrdu(:,:,:) = ua(:,:,:)  
    61          ztrdv(:,:,:) = va(:,:,:)  
     60         ztrdu(:,:,:) = puu(:,:,:,Krhs)  
     61         ztrdv(:,:,:) = pvv(:,:,:,Krhs)  
    6262      ENDIF 
    6363 
    6464      SELECT CASE ( nldf_dyn )                   ! compute lateral mixing trend and add it to the general trend 
    6565      ! 
    66       CASE ( np_lap   )    ;   CALL dyn_ldf_lap( kt, ub, vb, ua, va, 1 )      ! iso-level    laplacian 
    67       CASE ( np_lap_i )    ;   CALL dyn_ldf_iso( kt )                         ! rotated      laplacian 
    68       CASE ( np_blp   )    ;   CALL dyn_ldf_blp( kt, ub, vb, ua, va    )      ! iso-level bi-laplacian 
     66      CASE ( np_lap   )   
     67         CALL dyn_ldf_lap( kt, Kbb, Kmm, puu(:,:,:,Kbb), pvv(:,:,:,Kbb), puu(:,:,:,Krhs), pvv(:,:,:,Krhs), 1 ) ! iso-level    laplacian 
     68      CASE ( np_lap_i )  
     69         CALL dyn_ldf_iso( kt, Kbb, Kmm, puu, pvv, Krhs    )                                                   ! rotated      laplacian 
     70      CASE ( np_blp   )   
     71         CALL dyn_ldf_blp( kt, Kbb, Kmm, puu(:,:,:,Kbb), pvv(:,:,:,Kbb), puu(:,:,:,Krhs), pvv(:,:,:,Krhs)    ) ! iso-level bi-laplacian 
    6972      ! 
    7073      END SELECT 
    7174 
    7275      IF( l_trddyn ) THEN                        ! save the horizontal diffusive trends for further diagnostics 
    73          ztrdu(:,:,:) = ua(:,:,:) - ztrdu(:,:,:) 
    74          ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:) 
    75          CALL trd_dyn( ztrdu, ztrdv, jpdyn_ldf, kt ) 
     76         ztrdu(:,:,:) = puu(:,:,:,Krhs) - ztrdu(:,:,:) 
     77         ztrdv(:,:,:) = pvv(:,:,:,Krhs) - ztrdv(:,:,:) 
     78         CALL trd_dyn( ztrdu, ztrdv, jpdyn_ldf, kt, Kmm ) 
    7679         DEALLOCATE ( ztrdu , ztrdv ) 
    7780      ENDIF 
    7881      !                                          ! print sum trends (used for debugging) 
    79       IF(ln_ctl)   CALL prt_ctl( tab3d_1=ua, clinfo1=' ldf  - Ua: ', mask1=umask,   & 
    80          &                       tab3d_2=va, clinfo2=       ' Va: ', mask2=vmask, clinfo3='dyn' ) 
     82      IF(sn_cfctl%l_prtctl)   CALL prt_ctl( tab3d_1=puu(:,:,:,Krhs), clinfo1=' ldf  - Ua: ', mask1=umask,   & 
     83         &                                  tab3d_2=pvv(:,:,:,Krhs), clinfo2=       ' Va: ', mask2=vmask, clinfo3='dyn' ) 
    8184      ! 
    8285      IF( ln_timing )   CALL timing_stop('dyn_ldf') 

  • NEMO/trunk/src/OCE/DYN/dynldf_iso.F90

    r10425 r12377  
    4141 
    4242   !! * Substitutions 
    43 #  include "vectopt_loop_substitute.h90" 
     43#  include "do_loop_substitute.h90" 
    4444   !!---------------------------------------------------------------------- 
    4545   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    6060 
    6161 
    62    SUBROUTINE dyn_ldf_iso( kt ) 
     62   SUBROUTINE dyn_ldf_iso( kt, Kbb, Kmm, puu, pvv, Krhs ) 
    6363      !!---------------------------------------------------------------------- 
    6464      !!                     ***  ROUTINE dyn_ldf_iso  *** 
    … …  
    8181      !!      horizontal fluxes associated with the rotated lateral mixing: 
    8282      !!      u-component: 
    83       !!         ziut = ( ahmt + rn_ahm_b ) e2t * e3t / e1t  di[ ub ] 
    84       !!               -  ahmt              e2t * mi-1(uslp) dk[ mi(mk(ub)) ] 
    85       !!         zjuf = ( ahmf + rn_ahm_b ) e1f * e3f / e2f  dj[ ub ] 
    86       !!               -  ahmf              e1f * mi(vslp)   dk[ mj(mk(ub)) ] 
     83      !!         ziut = ( ahmt + rn_ahm_b ) e2t * e3t / e1t  di[ uu ] 
     84      !!               -  ahmt              e2t * mi-1(uslp) dk[ mi(mk(uu)) ] 
     85      !!         zjuf = ( ahmf + rn_ahm_b ) e1f * e3f / e2f  dj[ uu ] 
     86      !!               -  ahmf              e1f * mi(vslp)   dk[ mj(mk(uu)) ] 
    8787      !!      v-component: 
    88       !!         zivf = ( ahmf + rn_ahm_b ) e2t * e3t / e1t  di[ vb ] 
    89       !!               -  ahmf              e2t * mj(uslp)   dk[ mi(mk(vb)) ] 
    90       !!         zjvt = ( ahmt + rn_ahm_b ) e1f * e3f / e2f  dj[ ub ] 
    91       !!               -  ahmt              e1f * mj-1(vslp) dk[ mj(mk(vb)) ] 
     88      !!         zivf = ( ahmf + rn_ahm_b ) e2t * e3t / e1t  di[ vv ] 
     89      !!               -  ahmf              e2t * mj(uslp)   dk[ mi(mk(vv)) ] 
     90      !!         zjvt = ( ahmt + rn_ahm_b ) e1f * e3f / e2f  dj[ vv ] 
     91      !!               -  ahmt              e1f * mj-1(vslp) dk[ mj(mk(vv)) ] 
    9292      !!      take the horizontal divergence of the fluxes: 
    9393      !!         diffu = 1/(e1u*e2u*e3u) {  di  [ ziut ] + dj-1[ zjuf ]  } 
    9494      !!         diffv = 1/(e1v*e2v*e3v) {  di-1[ zivf ] + dj  [ zjvt ]  } 
    95       !!      Add this trend to the general trend (ua,va): 
    96       !!         ua = ua + diffu 
     95      !!      Add this trend to the general trend (uu(rhs),vv(rhs)): 
     96      !!         uu(rhs) = uu(rhs) + diffu 
    9797      !!      CAUTION: here the isopycnal part is with a coeff. of aht. This 
    9898      !!      should be modified for applications others than orca_r2 (!!bug) 
    9999      !! 
    100100      !! ** Action : 
    101       !!       -(ua,va) updated with the before geopotential harmonic mixing trend 
     101      !!       -(puu(:,:,:,Krhs),pvv(:,:,:,Krhs)) updated with the before geopotential harmonic mixing trend 
    102102      !!       -(akzu,akzv) to accompt for the diagonal vertical component 
    103103      !!                    of the rotated operator in dynzdf module 
    104104      !!---------------------------------------------------------------------- 
    105       INTEGER, INTENT( in ) ::   kt   ! ocean time-step index 
     105      INTEGER                             , INTENT( in )  ::  kt               ! ocean time-step index 
     106      INTEGER                             , INTENT( in )  ::  Kbb, Kmm, Krhs   ! ocean time level indices 
     107      REAL(wp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) ::  puu, pvv         ! ocean velocities and RHS of momentum equation 
    106108      ! 
    107109      INTEGER  ::   ji, jj, jk   ! dummy loop indices 
    … …  
    125127      IF( ln_dynldf_hor .AND. ln_traldf_iso ) THEN 
    126128         ! 
    127          DO jk = 1, jpk         ! set the slopes of iso-level 
    128             DO jj = 2, jpjm1 
    129                DO ji = 2, jpim1 
    130                   uslp (ji,jj,jk) = - ( gdept_b(ji+1,jj,jk) - gdept_b(ji ,jj ,jk) ) * r1_e1u(ji,jj) * umask(ji,jj,jk) 
    131                   vslp (ji,jj,jk) = - ( gdept_b(ji,jj+1,jk) - gdept_b(ji ,jj ,jk) ) * r1_e2v(ji,jj) * vmask(ji,jj,jk) 
    132                   wslpi(ji,jj,jk) = - ( gdepw_b(ji+1,jj,jk) - gdepw_b(ji-1,jj,jk) ) * r1_e1t(ji,jj) * tmask(ji,jj,jk) * 0.5 
    133                   wslpj(ji,jj,jk) = - ( gdepw_b(ji,jj+1,jk) - gdepw_b(ji,jj-1,jk) ) * r1_e2t(ji,jj) * tmask(ji,jj,jk) * 0.5 
    134                END DO 
    135             END DO 
    136          END DO 
     129         DO_3D_00_00( 1, jpk ) 
     130            uslp (ji,jj,jk) = - ( gdept(ji+1,jj,jk,Kbb) - gdept(ji ,jj ,jk,Kbb) ) * r1_e1u(ji,jj) * umask(ji,jj,jk) 
     131            vslp (ji,jj,jk) = - ( gdept(ji,jj+1,jk,Kbb) - gdept(ji ,jj ,jk,Kbb) ) * r1_e2v(ji,jj) * vmask(ji,jj,jk) 
     132            wslpi(ji,jj,jk) = - ( gdepw(ji+1,jj,jk,Kbb) - gdepw(ji-1,jj,jk,Kbb) ) * r1_e1t(ji,jj) * tmask(ji,jj,jk) * 0.5 
     133            wslpj(ji,jj,jk) = - ( gdepw(ji,jj+1,jk,Kbb) - gdepw(ji,jj-1,jk,Kbb) ) * r1_e2t(ji,jj) * tmask(ji,jj,jk) * 0.5 
     134         END_3D 
    137135         ! Lateral boundary conditions on the slopes 
    138136         CALL lbc_lnk_multi( 'dynldf_iso', uslp , 'U', -1., vslp , 'V', -1., wslpi, 'W', -1., wslpj, 'W', -1. ) 
    … …  
    151149         !                             zdkv(jk=1)=zdkv(jk=2) 
    152150 
    153          zdk1u(:,:) = ( ub(:,:,jk) -ub(:,:,jk+1) ) * umask(:,:,jk+1) 
    154          zdk1v(:,:) = ( vb(:,:,jk) -vb(:,:,jk+1) ) * vmask(:,:,jk+1) 
     151         zdk1u(:,:) = ( puu(:,:,jk,Kbb) -puu(:,:,jk+1,Kbb) ) * umask(:,:,jk+1) 
     152         zdk1v(:,:) = ( pvv(:,:,jk,Kbb) -pvv(:,:,jk+1,Kbb) ) * vmask(:,:,jk+1) 
    155153 
    156154         IF( jk == 1 ) THEN 
    … …  
    158156            zdkv(:,:) = zdk1v(:,:) 
    159157         ELSE 
    160             zdku(:,:) = ( ub(:,:,jk-1) - ub(:,:,jk) ) * umask(:,:,jk) 
    161             zdkv(:,:) = ( vb(:,:,jk-1) - vb(:,:,jk) ) * vmask(:,:,jk) 
     158            zdku(:,:) = ( puu(:,:,jk-1,Kbb) - puu(:,:,jk,Kbb) ) * umask(:,:,jk) 
     159            zdkv(:,:) = ( pvv(:,:,jk-1,Kbb) - pvv(:,:,jk,Kbb) ) * vmask(:,:,jk) 
    162160         ENDIF 
    163161 
    … …  
    169167 
    170168         IF( ln_zps ) THEN      ! z-coordinate - partial steps : min(e3u) 
    171             DO jj = 2, jpjm1 
    172                DO ji = fs_2, jpi   ! vector opt. 
    173                   zabe1 = ( ahmt(ji,jj,jk)+rn_ahm_b ) * e2t(ji,jj) * MIN( e3u_n(ji,jj,jk), e3u_n(ji-1,jj,jk) ) * r1_e1t(ji,jj) 
    174  
    175                   zmskt = 1._wp / MAX(   umask(ji-1,jj,jk  )+umask(ji,jj,jk+1)     & 
    176                      &                 + umask(ji-1,jj,jk+1)+umask(ji,jj,jk  ) , 1._wp ) 
    177  
    178                   zcof1 = - zaht_0 * e2t(ji,jj) * zmskt * 0.5  * ( uslp(ji-1,jj,jk) + uslp(ji,jj,jk) ) 
    179     
    180                   ziut(ji,jj) = (  zabe1 * ( ub(ji,jj,jk) - ub(ji-1,jj,jk) )    & 
    181                      &           + zcof1 * ( zdku (ji,jj) + zdk1u(ji-1,jj)      & 
    182                      &                      +zdk1u(ji,jj) + zdku (ji-1,jj) )  ) * tmask(ji,jj,jk) 
    183                END DO 
    184             END DO 
     169            DO_2D_00_01 
     170               zabe1 = ( ahmt(ji,jj,jk)+rn_ahm_b ) * e2t(ji,jj) * MIN( e3u(ji,jj,jk,Kmm), e3u(ji-1,jj,jk,Kmm) ) * r1_e1t(ji,jj) 
     171 
     172               zmskt = 1._wp / MAX(   umask(ji-1,jj,jk  )+umask(ji,jj,jk+1)     & 
     173                  &                 + umask(ji-1,jj,jk+1)+umask(ji,jj,jk  ) , 1._wp ) 
     174 
     175               zcof1 = - zaht_0 * e2t(ji,jj) * zmskt * 0.5  * ( uslp(ji-1,jj,jk) + uslp(ji,jj,jk) ) 
     176 
     177               ziut(ji,jj) = (  zabe1 * ( puu(ji,jj,jk,Kbb) - puu(ji-1,jj,jk,Kbb) )    & 
     178                  &           + zcof1 * ( zdku (ji,jj) + zdk1u(ji-1,jj)      & 
     179                  &                      +zdk1u(ji,jj) + zdku (ji-1,jj) )  ) * tmask(ji,jj,jk) 
     180            END_2D 
    185181         ELSE                   ! other coordinate system (zco or sco) : e3t 
    186             DO jj = 2, jpjm1 
    187                DO ji = fs_2, jpi   ! vector opt. 
    188                   zabe1 = ( ahmt(ji,jj,jk)+rn_ahm_b ) * e2t(ji,jj) * e3t_n(ji,jj,jk) * r1_e1t(ji,jj) 
    189  
    190                   zmskt = 1._wp / MAX(   umask(ji-1,jj,jk  ) + umask(ji,jj,jk+1)     & 
    191                      &                 + umask(ji-1,jj,jk+1) + umask(ji,jj,jk  ) , 1._wp ) 
    192  
    193                   zcof1 = - zaht_0 * e2t(ji,jj) * zmskt * 0.5  * ( uslp(ji-1,jj,jk) + uslp(ji,jj,jk) ) 
    194  
    195                   ziut(ji,jj) = (  zabe1 * ( ub(ji,jj,jk) - ub(ji-1,jj,jk) )   & 
    196                      &           + zcof1 * ( zdku (ji,jj) + zdk1u(ji-1,jj)     & 
    197                      &                      +zdk1u(ji,jj) + zdku (ji-1,jj) )  ) * tmask(ji,jj,jk) 
    198                END DO 
    199             END DO 
     182            DO_2D_00_01 
     183               zabe1 = ( ahmt(ji,jj,jk)+rn_ahm_b ) * e2t(ji,jj) * e3t(ji,jj,jk,Kmm) * r1_e1t(ji,jj) 
     184 
     185               zmskt = 1._wp / MAX(   umask(ji-1,jj,jk  ) + umask(ji,jj,jk+1)     & 
     186                  &                 + umask(ji-1,jj,jk+1) + umask(ji,jj,jk  ) , 1._wp ) 
     187 
     188               zcof1 = - zaht_0 * e2t(ji,jj) * zmskt * 0.5  * ( uslp(ji-1,jj,jk) + uslp(ji,jj,jk) ) 
     189 
     190               ziut(ji,jj) = (  zabe1 * ( puu(ji,jj,jk,Kbb) - puu(ji-1,jj,jk,Kbb) )   & 
     191                  &           + zcof1 * ( zdku (ji,jj) + zdk1u(ji-1,jj)     & 
     192                  &                      +zdk1u(ji,jj) + zdku (ji-1,jj) )  ) * tmask(ji,jj,jk) 
     193            END_2D 
    200194         ENDIF 
    201195 
    202196         ! j-flux at f-point 
    203          DO jj = 1, jpjm1 
    204             DO ji = 1, fs_jpim1   ! vector opt. 
    205                zabe2 = ( ahmf(ji,jj,jk) + rn_ahm_b ) * e1f(ji,jj) * e3f_n(ji,jj,jk) * r1_e2f(ji,jj) 
    206  
    207                zmskf = 1._wp / MAX(   umask(ji,jj+1,jk  )+umask(ji,jj,jk+1)     & 
    208                   &                 + umask(ji,jj+1,jk+1)+umask(ji,jj,jk  ) , 1._wp ) 
    209  
    210                zcof2 = - zaht_0 * e1f(ji,jj) * zmskf * 0.5  * ( vslp(ji+1,jj,jk) + vslp(ji,jj,jk) ) 
    211  
    212                zjuf(ji,jj) = (  zabe2 * ( ub(ji,jj+1,jk) - ub(ji,jj,jk) )   & 
    213                   &           + zcof2 * ( zdku (ji,jj+1) + zdk1u(ji,jj)     & 
    214                   &                      +zdk1u(ji,jj+1) + zdku (ji,jj) )  ) * fmask(ji,jj,jk) 
    215             END DO 
    216          END DO 
     197         DO_2D_10_10 
     198            zabe2 = ( ahmf(ji,jj,jk) + rn_ahm_b ) * e1f(ji,jj) * e3f(ji,jj,jk) * r1_e2f(ji,jj) 
     199 
     200            zmskf = 1._wp / MAX(   umask(ji,jj+1,jk  )+umask(ji,jj,jk+1)     & 
     201               &                 + umask(ji,jj+1,jk+1)+umask(ji,jj,jk  ) , 1._wp ) 
     202 
     203            zcof2 = - zaht_0 * e1f(ji,jj) * zmskf * 0.5  * ( vslp(ji+1,jj,jk) + vslp(ji,jj,jk) ) 
     204 
     205            zjuf(ji,jj) = (  zabe2 * ( puu(ji,jj+1,jk,Kbb) - puu(ji,jj,jk,Kbb) )   & 
     206               &           + zcof2 * ( zdku (ji,jj+1) + zdk1u(ji,jj)     & 
     207               &                      +zdk1u(ji,jj+1) + zdku (ji,jj) )  ) * fmask(ji,jj,jk) 
     208         END_2D 
    217209 
    218210         !                                |   t   | 
    … …  
    222214         ! i-flux at f-point              |   t   | 
    223215 
    224          DO jj = 2, jpjm1 
    225             DO ji = 1, fs_jpim1   ! vector opt. 
    226                zabe1 = ( ahmf(ji,jj,jk) + rn_ahm_b ) * e2f(ji,jj) * e3f_n(ji,jj,jk) * r1_e1f(ji,jj) 
    227  
    228                zmskf = 1._wp / MAX(  vmask(ji+1,jj,jk  )+vmask(ji,jj,jk+1)     & 
    229                   &                + vmask(ji+1,jj,jk+1)+vmask(ji,jj,jk  ) , 1._wp ) 
    230  
    231                zcof1 = - zaht_0 * e2f(ji,jj) * zmskf * 0.5 * ( uslp(ji,jj+1,jk) + uslp(ji,jj,jk) ) 
    232  
    233                zivf(ji,jj) = (  zabe1 * ( vb(ji+1,jj,jk) - vb(ji,jj,jk) )    & 
    234                   &           + zcof1 * (  zdkv (ji,jj) + zdk1v(ji+1,jj)      & 
    235                   &                      + zdk1v(ji,jj) + zdkv (ji+1,jj) )  ) * fmask(ji,jj,jk) 
    236             END DO 
    237          END DO 
     216         DO_2D_00_10 
     217            zabe1 = ( ahmf(ji,jj,jk) + rn_ahm_b ) * e2f(ji,jj) * e3f(ji,jj,jk) * r1_e1f(ji,jj) 
     218 
     219            zmskf = 1._wp / MAX(  vmask(ji+1,jj,jk  )+vmask(ji,jj,jk+1)     & 
     220               &                + vmask(ji+1,jj,jk+1)+vmask(ji,jj,jk  ) , 1._wp ) 
     221 
     222            zcof1 = - zaht_0 * e2f(ji,jj) * zmskf * 0.5 * ( uslp(ji,jj+1,jk) + uslp(ji,jj,jk) ) 
     223 
     224            zivf(ji,jj) = (  zabe1 * ( pvv(ji+1,jj,jk,Kbb) - pvv(ji,jj,jk,Kbb) )    & 
     225               &           + zcof1 * (  zdkv (ji,jj) + zdk1v(ji+1,jj)      & 
     226               &                      + zdk1v(ji,jj) + zdkv (ji+1,jj) )  ) * fmask(ji,jj,jk) 
     227         END_2D 
    238228 
    239229         ! j-flux at t-point 
    240230         IF( ln_zps ) THEN      ! z-coordinate - partial steps : min(e3u) 
    241             DO jj = 2, jpj 
    242                DO ji = 1, fs_jpim1   ! vector opt. 
    243                   zabe2 = ( ahmt(ji,jj,jk)+rn_ahm_b ) * e1t(ji,jj) * MIN( e3v_n(ji,jj,jk), e3v_n(ji,jj-1,jk) ) * r1_e2t(ji,jj) 
    244  
    245                   zmskt = 1._wp / MAX(  vmask(ji,jj-1,jk  )+vmask(ji,jj,jk+1)     & 
    246                      &                + vmask(ji,jj-1,jk+1)+vmask(ji,jj,jk  ) , 1._wp ) 
    247  
    248                   zcof2 = - zaht_0 * e1t(ji,jj) * zmskt * 0.5 * ( vslp(ji,jj-1,jk) + vslp(ji,jj,jk) ) 
    249  
    250                   zjvt(ji,jj) = (  zabe2 * ( vb(ji,jj,jk) - vb(ji,jj-1,jk) )    & 
    251                      &           + zcof2 * ( zdkv (ji,jj-1) + zdk1v(ji,jj)      & 
    252                      &                      +zdk1v(ji,jj-1) + zdkv (ji,jj) )  ) * tmask(ji,jj,jk) 
    253                END DO 
    254             END DO 
     231            DO_2D_01_10 
     232               zabe2 = ( ahmt(ji,jj,jk)+rn_ahm_b ) * e1t(ji,jj) * MIN( e3v(ji,jj,jk,Kmm), e3v(ji,jj-1,jk,Kmm) ) * r1_e2t(ji,jj) 
     233 
     234               zmskt = 1._wp / MAX(  vmask(ji,jj-1,jk  )+vmask(ji,jj,jk+1)     & 
     235                  &                + vmask(ji,jj-1,jk+1)+vmask(ji,jj,jk  ) , 1._wp ) 
     236 
     237               zcof2 = - zaht_0 * e1t(ji,jj) * zmskt * 0.5 * ( vslp(ji,jj-1,jk) + vslp(ji,jj,jk) ) 
     238 
     239               zjvt(ji,jj) = (  zabe2 * ( pvv(ji,jj,jk,Kbb) - pvv(ji,jj-1,jk,Kbb) )    & 
     240                  &           + zcof2 * ( zdkv (ji,jj-1) + zdk1v(ji,jj)      & 
     241                  &                      +zdk1v(ji,jj-1) + zdkv (ji,jj) )  ) * tmask(ji,jj,jk) 
     242            END_2D 
    255243         ELSE                   ! other coordinate system (zco or sco) : e3t 
    256             DO jj = 2, jpj 
    257                DO ji = 1, fs_jpim1   ! vector opt. 
    258                   zabe2 = ( ahmt(ji,jj,jk)+rn_ahm_b ) * e1t(ji,jj) * e3t_n(ji,jj,jk) * r1_e2t(ji,jj) 
    259  
    260                   zmskt = 1./MAX(  vmask(ji,jj-1,jk  )+vmask(ji,jj,jk+1)   & 
    261                      &           + vmask(ji,jj-1,jk+1)+vmask(ji,jj,jk  ), 1. ) 
    262  
    263                   zcof2 = - zaht_0 * e1t(ji,jj) * zmskt * 0.5 * ( vslp(ji,jj-1,jk) + vslp(ji,jj,jk) ) 
    264  
    265                   zjvt(ji,jj) = (  zabe2 * ( vb(ji,jj,jk) - vb(ji,jj-1,jk) )   & 
    266                      &           + zcof2 * ( zdkv (ji,jj-1) + zdk1v(ji,jj)     & 
    267                      &                      +zdk1v(ji,jj-1) + zdkv (ji,jj) )  ) * tmask(ji,jj,jk) 
    268                END DO 
    269             END DO 
     244            DO_2D_01_10 
     245               zabe2 = ( ahmt(ji,jj,jk)+rn_ahm_b ) * e1t(ji,jj) * e3t(ji,jj,jk,Kmm) * r1_e2t(ji,jj) 
     246 
     247               zmskt = 1./MAX(  vmask(ji,jj-1,jk  )+vmask(ji,jj,jk+1)   & 
     248                  &           + vmask(ji,jj-1,jk+1)+vmask(ji,jj,jk  ), 1. ) 
     249 
     250               zcof2 = - zaht_0 * e1t(ji,jj) * zmskt * 0.5 * ( vslp(ji,jj-1,jk) + vslp(ji,jj,jk) ) 
     251 
     252               zjvt(ji,jj) = (  zabe2 * ( pvv(ji,jj,jk,Kbb) - pvv(ji,jj-1,jk,Kbb) )   & 
     253                  &           + zcof2 * ( zdkv (ji,jj-1) + zdk1v(ji,jj)     & 
     254                  &                      +zdk1v(ji,jj-1) + zdkv (ji,jj) )  ) * tmask(ji,jj,jk) 
     255            END_2D 
    270256         ENDIF 
    271257 
    … …  
    273259         ! Second derivative (divergence) and add to the general trend 
    274260         ! ----------------------------------------------------------- 
    275          DO jj = 2, jpjm1 
    276             DO ji = 2, jpim1          !!gm Question vectop possible??? !!bug 
    277                ua(ji,jj,jk) = ua(ji,jj,jk) + (  ziut(ji+1,jj) - ziut(ji,jj  )    & 
    278                   &                           + zjuf(ji  ,jj) - zjuf(ji,jj-1)  ) * r1_e1e2u(ji,jj) / e3u_n(ji,jj,jk) 
    279                va(ji,jj,jk) = va(ji,jj,jk) + (  zivf(ji,jj  ) - zivf(ji-1,jj)    & 
    280                   &                           + zjvt(ji,jj+1) - zjvt(ji,jj  )  ) * r1_e1e2v(ji,jj) / e3v_n(ji,jj,jk) 
    281             END DO 
    282          END DO 
     261         DO_2D_00_00 
     262            puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + (  ziut(ji+1,jj) - ziut(ji,jj  )    & 
     263               &                           + zjuf(ji  ,jj) - zjuf(ji,jj-1)  ) * r1_e1e2u(ji,jj) / e3u(ji,jj,jk,Kmm) 
     264            pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) + (  zivf(ji,jj  ) - zivf(ji-1,jj)    & 
     265               &                           + zjvt(ji,jj+1) - zjvt(ji,jj  )  ) * r1_e1e2v(ji,jj) / e3v(ji,jj,jk,Kmm) 
     266         END_2D 
    283267         !                                             ! =============== 
    284268      END DO                                           !   End of slab 
    … …  
    286270 
    287271      ! print sum trends (used for debugging) 
    288       IF(ln_ctl)   CALL prt_ctl( tab3d_1=ua, clinfo1=' ldfh - Ua: ', mask1=umask, & 
    289          &                       tab3d_2=va, clinfo2=       ' Va: ', mask2=vmask, clinfo3='dyn' ) 
     272      IF(sn_cfctl%l_prtctl)   CALL prt_ctl( tab3d_1=puu(:,:,:,Krhs), clinfo1=' ldfh - Ua: ', mask1=umask, & 
     273         &                                  tab3d_2=pvv(:,:,:,Krhs), clinfo2=       ' Va: ', mask2=vmask, clinfo3='dyn' ) 
    290274 
    291275 
    … …  
    306290            DO ji = 2, jpi 
    307291               ! i-gradient of u at jj 
    308                zdiu (ji,jk) = tmask(ji,jj  ,jk) * ( ub(ji,jj  ,jk) - ub(ji-1,jj  ,jk) ) 
     292               zdiu (ji,jk) = tmask(ji,jj  ,jk) * ( puu(ji,jj  ,jk,Kbb) - puu(ji-1,jj  ,jk,Kbb) ) 
    309293               ! j-gradient of u and v at jj 
    310                zdju (ji,jk) = fmask(ji,jj  ,jk) * ( ub(ji,jj+1,jk) - ub(ji  ,jj  ,jk) ) 
    311                zdjv (ji,jk) = tmask(ji,jj  ,jk) * ( vb(ji,jj  ,jk) - vb(ji  ,jj-1,jk) ) 
     294               zdju (ji,jk) = fmask(ji,jj  ,jk) * ( puu(ji,jj+1,jk,Kbb) - puu(ji  ,jj  ,jk,Kbb) ) 
     295               zdjv (ji,jk) = tmask(ji,jj  ,jk) * ( pvv(ji,jj  ,jk,Kbb) - pvv(ji  ,jj-1,jk,Kbb) ) 
    312296               ! j-gradient of u and v at jj+1 
    313                zdj1u(ji,jk) = fmask(ji,jj-1,jk) * ( ub(ji,jj  ,jk) - ub(ji  ,jj-1,jk) ) 
    314                zdj1v(ji,jk) = tmask(ji,jj+1,jk) * ( vb(ji,jj+1,jk) - vb(ji  ,jj  ,jk) ) 
     297               zdj1u(ji,jk) = fmask(ji,jj-1,jk) * ( puu(ji,jj  ,jk,Kbb) - puu(ji  ,jj-1,jk,Kbb) ) 
     298               zdj1v(ji,jk) = tmask(ji,jj+1,jk) * ( pvv(ji,jj+1,jk,Kbb) - pvv(ji  ,jj  ,jk,Kbb) ) 
    315299            END DO 
    316300         END DO 
    … …  
    318302            DO ji = 1, jpim1 
    319303               ! i-gradient of v at jj 
    320                zdiv (ji,jk) = fmask(ji,jj  ,jk) * ( vb(ji+1,jj,jk) - vb(ji  ,jj  ,jk) ) 
     304               zdiv (ji,jk) = fmask(ji,jj  ,jk) * ( pvv(ji+1,jj,jk,Kbb) - pvv(ji  ,jj  ,jk,Kbb) ) 
    321305            END DO 
    322306         END DO 
    … …  
    391375         DO jk = 1, jpkm1 
    392376            DO ji = 2, jpim1 
    393                ua(ji,jj,jk) = ua(ji,jj,jk) + ( zfuw(ji,jk) - zfuw(ji,jk+1) ) * r1_e1e2u(ji,jj) / e3u_n(ji,jj,jk) 
    394                va(ji,jj,jk) = va(ji,jj,jk) + ( zfvw(ji,jk) - zfvw(ji,jk+1) ) * r1_e1e2v(ji,jj) / e3v_n(ji,jj,jk) 
     377               puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + ( zfuw(ji,jk) - zfuw(ji,jk+1) ) * r1_e1e2u(ji,jj) / e3u(ji,jj,jk,Kmm) 
     378               pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) + ( zfvw(ji,jk) - zfvw(ji,jk+1) ) * r1_e1e2v(ji,jj) / e3v(ji,jj,jk,Kmm) 
    395379            END DO 
    396380         END DO 

  • NEMO/trunk/src/OCE/DYN/dynldf_lap_blp.F90

    r10425 r12377  
    2727 
    2828   !! * Substitutions 
    29 #  include "vectopt_loop_substitute.h90" 
     29#  include "do_loop_substitute.h90" 
    3030   !!---------------------------------------------------------------------- 
    3131   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    3535CONTAINS 
    3636 
    37    SUBROUTINE dyn_ldf_lap( kt, pub, pvb, pua, pva, kpass ) 
     37   SUBROUTINE dyn_ldf_lap( kt, Kbb, Kmm, pu, pv, pu_rhs, pv_rhs, kpass ) 
    3838      !!---------------------------------------------------------------------- 
    3939      !!                     ***  ROUTINE dyn_ldf_lap  *** 
    … …  
    4545      !!      writen as :   grad_h( ahmt div_h(U )) - curl_h( ahmf curl_z(U) )  
    4646      !! 
    47       !! ** Action : - pua, pva increased by the harmonic operator applied on pub, pvb. 
     47      !! ** Action : - pu_rhs, pv_rhs increased by the harmonic operator applied on pu, pv. 
    4848      !!---------------------------------------------------------------------- 
    4949      INTEGER                         , INTENT(in   ) ::   kt         ! ocean time-step index 
     50      INTEGER                         , INTENT(in   ) ::   Kbb, Kmm   ! ocean time level indices 
    5051      INTEGER                         , INTENT(in   ) ::   kpass      ! =1/2 first or second passage 
    51       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in   ) ::   pub, pvb   ! before velocity  [m/s] 
    52       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pua, pva   ! velocity trend   [m/s2] 
     52      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in   ) ::   pu, pv     ! before velocity  [m/s] 
     53      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pu_rhs, pv_rhs   ! velocity trend   [m/s2] 
    5354      ! 
    5455      INTEGER  ::   ji, jj, jk   ! dummy loop indices 
    … …  
    7172      DO jk = 1, jpkm1                                 ! Horizontal slab 
    7273         !                                             ! =============== 
    73          DO jj = 2, jpj 
    74             DO ji = fs_2, jpi   ! vector opt. 
    75                !                                      ! ahm * e3 * curl  (computed from 1 to jpim1/jpjm1) 
     74         DO_2D_01_01 
     75            !                                      ! ahm * e3 * curl  (computed from 1 to jpim1/jpjm1) 
    7676!!gm open question here : e3f  at before or now ?    probably now... 
    7777!!gm note that ahmf has already been multiplied by fmask 
    78                zcur(ji-1,jj-1) = ahmf(ji-1,jj-1,jk) * e3f_n(ji-1,jj-1,jk) * r1_e1e2f(ji-1,jj-1)       & 
    79                   &     * (  e2v(ji  ,jj-1) * pvb(ji  ,jj-1,jk) - e2v(ji-1,jj-1) * pvb(ji-1,jj-1,jk)  & 
    80                   &        - e1u(ji-1,jj  ) * pub(ji-1,jj  ,jk) + e1u(ji-1,jj-1) * pub(ji-1,jj-1,jk)  ) 
    81                !                                      ! ahm * div        (computed from 2 to jpi/jpj) 
     78            zcur(ji-1,jj-1) = ahmf(ji-1,jj-1,jk) * e3f(ji-1,jj-1,jk) * r1_e1e2f(ji-1,jj-1)       & 
     79               &     * (  e2v(ji  ,jj-1) * pv(ji  ,jj-1,jk) - e2v(ji-1,jj-1) * pv(ji-1,jj-1,jk)  & 
     80               &        - e1u(ji-1,jj  ) * pu(ji-1,jj  ,jk) + e1u(ji-1,jj-1) * pu(ji-1,jj-1,jk)  ) 
     81            !                                      ! ahm * div        (computed from 2 to jpi/jpj) 
    8282!!gm note that ahmt has already been multiplied by tmask 
    83                zdiv(ji,jj)     = ahmt(ji,jj,jk) * r1_e1e2t(ji,jj) / e3t_b(ji,jj,jk)                                         & 
    84                   &     * (  e2u(ji,jj)*e3u_b(ji,jj,jk) * pub(ji,jj,jk) - e2u(ji-1,jj)*e3u_b(ji-1,jj,jk) * pub(ji-1,jj,jk)  & 
    85                   &        + e1v(ji,jj)*e3v_b(ji,jj,jk) * pvb(ji,jj,jk) - e1v(ji,jj-1)*e3v_b(ji,jj-1,jk) * pvb(ji,jj-1,jk)  ) 
    86             END DO   
    87          END DO   
     83            zdiv(ji,jj)     = ahmt(ji,jj,jk) * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kbb)                                         & 
     84               &     * (  e2u(ji,jj)*e3u(ji,jj,jk,Kbb) * pu(ji,jj,jk) - e2u(ji-1,jj)*e3u(ji-1,jj,jk,Kbb) * pu(ji-1,jj,jk)  & 
     85               &        + e1v(ji,jj)*e3v(ji,jj,jk,Kbb) * pv(ji,jj,jk) - e1v(ji,jj-1)*e3v(ji,jj-1,jk,Kbb) * pv(ji,jj-1,jk)  ) 
     86         END_2D 
    8887         ! 
    89          DO jj = 2, jpjm1                             ! - curl( curl) + grad( div ) 
    90             DO ji = fs_2, fs_jpim1   ! vector opt. 
    91                pua(ji,jj,jk) = pua(ji,jj,jk) + zsign * (                                                 & 
    92                   &              - ( zcur(ji  ,jj) - zcur(ji,jj-1) ) * r1_e2u(ji,jj) / e3u_n(ji,jj,jk)   & 
    93                   &              + ( zdiv(ji+1,jj) - zdiv(ji,jj  ) ) * r1_e1u(ji,jj)                     ) 
    94                   ! 
    95                pva(ji,jj,jk) = pva(ji,jj,jk) + zsign * (                                                 & 
    96                   &                ( zcur(ji,jj  ) - zcur(ji-1,jj) ) * r1_e1v(ji,jj) / e3v_n(ji,jj,jk)   & 
    97                   &              + ( zdiv(ji,jj+1) - zdiv(ji  ,jj) ) * r1_e2v(ji,jj)                     ) 
    98             END DO 
    99          END DO 
     88         DO_2D_00_00 
     89            pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + zsign * (                                                 & 
     90               &              - ( zcur(ji  ,jj) - zcur(ji,jj-1) ) * r1_e2u(ji,jj) / e3u(ji,jj,jk,Kmm)   & 
     91               &              + ( zdiv(ji+1,jj) - zdiv(ji,jj  ) ) * r1_e1u(ji,jj)                     ) 
     92               ! 
     93            pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) + zsign * (                                                 & 
     94               &                ( zcur(ji,jj  ) - zcur(ji-1,jj) ) * r1_e1v(ji,jj) / e3v(ji,jj,jk,Kmm)   & 
     95               &              + ( zdiv(ji,jj+1) - zdiv(ji  ,jj) ) * r1_e2v(ji,jj)                     ) 
     96         END_2D 
    10097         !                                             ! =============== 
    10198      END DO                                           !   End of slab 
    … …  
    105102 
    106103 
    107    SUBROUTINE dyn_ldf_blp( kt, pub, pvb, pua, pva ) 
     104   SUBROUTINE dyn_ldf_blp( kt, Kbb, Kmm, pu, pv, pu_rhs, pv_rhs ) 
    108105      !!---------------------------------------------------------------------- 
    109106      !!                 ***  ROUTINE dyn_ldf_blp  *** 
    … …  
    116113      !!      It is computed by two successive calls to dyn_ldf_lap routine 
    117114      !! 
    118       !! ** Action :   pta   updated with the before rotated bilaplacian diffusion 
     115      !! ** Action :   pt(:,:,:,:,Krhs)   updated with the before rotated bilaplacian diffusion 
    119116      !!---------------------------------------------------------------------- 
    120117      INTEGER                         , INTENT(in   ) ::   kt         ! ocean time-step index 
    121       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in   ) ::   pub, pvb   ! before velocity fields 
    122       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pua, pva   ! momentum trend 
     118      INTEGER                         , INTENT(in   ) ::   Kbb, Kmm   ! ocean time level indices 
     119      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in   ) ::   pu, pv     ! before velocity fields 
     120      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pu_rhs, pv_rhs   ! momentum trend 
    123121      ! 
    124122      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zulap, zvlap   ! laplacian at u- and v-point 
    … …  
    134132      zvlap(:,:,:) = 0._wp 
    135133      ! 
    136       CALL dyn_ldf_lap( kt, pub, pvb, zulap, zvlap, 1 )   ! rotated laplacian applied to ptb (output in zlap) 
     134      CALL dyn_ldf_lap( kt, Kbb, Kmm, pu, pv, zulap, zvlap, 1 )   ! rotated laplacian applied to pt (output in zlap,Kbb) 
    137135      ! 
    138136      CALL lbc_lnk_multi( 'dynldf_lap_blp', zulap, 'U', -1., zvlap, 'V', -1. )             ! Lateral boundary conditions 
    139137      ! 
    140       CALL dyn_ldf_lap( kt, zulap, zvlap, pua, pva, 2 )   ! rotated laplacian applied to zlap (output in pta) 
     138      CALL dyn_ldf_lap( kt, Kbb, Kmm, zulap, zvlap, pu_rhs, pv_rhs, 2 )   ! rotated laplacian applied to zlap (output in pt(:,:,:,:,Krhs)) 
    141139      ! 
    142140   END SUBROUTINE dyn_ldf_blp 

  • NEMO/trunk/src/OCE/DYN/dynspg.F90

    r11536 r12377  
    2121   USE dynspg_exp     ! surface pressure gradient     (dyn_spg_exp routine) 
    2222   USE dynspg_ts      ! surface pressure gradient     (dyn_spg_ts  routine) 
    23    USE sbctide        !  
    24    USE updtide        !  
     23   USE tide_mod       ! 
    2524   USE trd_oce        ! trends: ocean variables 
    2625   USE trddyn         ! trend manager: dynamics 
    … …  
    4342   INTEGER, PARAMETER ::   np_EXP = 0   !       explicit time stepping 
    4443   INTEGER, PARAMETER ::   np_NO  =-1   ! no surface pressure gradient, no scheme 
     44   ! 
     45   REAL(wp) ::   zt0step !   Time of day at the beginning of the time step 
    4546 
    4647   !! * Substitutions 
    47 #  include "vectopt_loop_substitute.h90" 
     48#  include "do_loop_substitute.h90" 
    4849   !!---------------------------------------------------------------------- 
    4950   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    5354CONTAINS 
    5455 
    55    SUBROUTINE dyn_spg( kt ) 
     56   SUBROUTINE dyn_spg( kt, Kbb, Kmm, Krhs, puu, pvv, pssh, puu_b, pvv_b, Kaa ) 
    5657      !!---------------------------------------------------------------------- 
    5758      !!                  ***  ROUTINE dyn_spg  *** 
    … …  
    7172      !!             period is used to prevent the divergence of odd and even time step. 
    7273      !!---------------------------------------------------------------------- 
    73       INTEGER, INTENT(in) ::   kt   ! ocean time-step index 
     74      INTEGER                             , INTENT( in )  ::  kt                  ! ocean time-step index 
     75      INTEGER                             , INTENT( in )  ::  Kbb, Kmm, Krhs, Kaa ! ocean time level indices 
     76      REAL(wp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) ::  puu, pvv            ! ocean velocities and RHS of momentum equation 
     77      REAL(wp), DIMENSION(jpi,jpj,jpt)    , INTENT(inout) ::  pssh, puu_b, pvv_b  ! SSH and barotropic velocities at main time levels 
    7478      ! 
    7579      INTEGER  ::   ji, jj, jk                   ! dummy loop indices 
    … …  
    8387      IF( l_trddyn )   THEN                      ! temporary save of ta and sa trends 
    8488         ALLOCATE( ztrdu(jpi,jpj,jpk) , ztrdv(jpi,jpj,jpk) )  
    85          ztrdu(:,:,:) = ua(:,:,:) 
    86          ztrdv(:,:,:) = va(:,:,:) 
     89         ztrdu(:,:,:) = puu(:,:,:,Krhs) 
     90         ztrdv(:,:,:) = pvv(:,:,:,Krhs) 
    8791      ENDIF 
    8892      ! 
    … …  
    9195         .OR.  ln_ice_embd ) THEN                                            ! embedded sea-ice 
    9296         ! 
    93          DO jj = 2, jpjm1 
    94             DO ji = fs_2, fs_jpim1   ! vector opt. 
    95                spgu(ji,jj) = 0._wp 
    96                spgv(ji,jj) = 0._wp 
    97             END DO 
    98          END DO          
     97         DO_2D_00_00 
     98            spgu(ji,jj) = 0._wp 
     99            spgv(ji,jj) = 0._wp 
     100         END_2D 
    99101         ! 
    100102         IF( ln_apr_dyn .AND. .NOT.ln_dynspg_ts ) THEN   !==  Atmospheric pressure gradient (added later in time-split case) ==! 
    101103            zg_2 = grav * 0.5 
    102             DO jj = 2, jpjm1                          ! gradient of Patm using inverse barometer ssh 
    103                DO ji = fs_2, fs_jpim1   ! vector opt. 
    104                   spgu(ji,jj) = spgu(ji,jj) + zg_2 * (  ssh_ib (ji+1,jj) - ssh_ib (ji,jj)    & 
    105                      &                                + ssh_ibb(ji+1,jj) - ssh_ibb(ji,jj)  ) * r1_e1u(ji,jj) 
    106                   spgv(ji,jj) = spgv(ji,jj) + zg_2 * (  ssh_ib (ji,jj+1) - ssh_ib (ji,jj)    & 
    107                      &                                + ssh_ibb(ji,jj+1) - ssh_ibb(ji,jj)  ) * r1_e2v(ji,jj) 
    108                END DO 
    109             END DO 
     104            DO_2D_00_00 
     105               spgu(ji,jj) = spgu(ji,jj) + zg_2 * (  ssh_ib (ji+1,jj) - ssh_ib (ji,jj)    & 
     106                  &                                + ssh_ibb(ji+1,jj) - ssh_ibb(ji,jj)  ) * r1_e1u(ji,jj) 
     107               spgv(ji,jj) = spgv(ji,jj) + zg_2 * (  ssh_ib (ji,jj+1) - ssh_ib (ji,jj)    & 
     108                  &                                + ssh_ibb(ji,jj+1) - ssh_ibb(ji,jj)  ) * r1_e2v(ji,jj) 
     109            END_2D 
    110110         ENDIF 
    111111         ! 
    … …  
    113113         IF( .NOT.ln_dynspg_ts .AND. ( ln_tide_pot .AND. ln_tide )  ) THEN   ! N.B. added directly at sub-time-step in ts-case 
    114114            ! 
    115             CALL upd_tide( kt )                      ! update tide potential 
     115            ! Update tide potential at the beginning of current time step 
     116            zt0step = REAL(nsec_day, wp)-0.5_wp*rdt 
     117            CALL upd_tide(zt0step, Kmm) 
    116118            ! 
    117             DO jj = 2, jpjm1                         ! add tide potential forcing 
    118                DO ji = fs_2, fs_jpim1   ! vector opt. 
    119                   spgu(ji,jj) = spgu(ji,jj) + grav * ( pot_astro(ji+1,jj) - pot_astro(ji,jj) ) * r1_e1u(ji,jj) 
    120                   spgv(ji,jj) = spgv(ji,jj) + grav * ( pot_astro(ji,jj+1) - pot_astro(ji,jj) ) * r1_e2v(ji,jj) 
    121                END DO  
    122             END DO 
     119            DO_2D_00_00 
     120               spgu(ji,jj) = spgu(ji,jj) + grav * ( pot_astro(ji+1,jj) - pot_astro(ji,jj) ) * r1_e1u(ji,jj) 
     121               spgv(ji,jj) = spgv(ji,jj) + grav * ( pot_astro(ji,jj+1) - pot_astro(ji,jj) ) * r1_e2v(ji,jj) 
     122            END_2D 
    123123            ! 
    124124            IF (ln_scal_load) THEN 
    125125               zld = rn_scal_load * grav 
    126                DO jj = 2, jpjm1                    ! add scalar approximation for load potential 
    127                   DO ji = fs_2, fs_jpim1   ! vector opt. 
    128                      spgu(ji,jj) = spgu(ji,jj) + zld * ( sshn(ji+1,jj) - sshn(ji,jj) ) * r1_e1u(ji,jj) 
    129                      spgv(ji,jj) = spgv(ji,jj) + zld * ( sshn(ji,jj+1) - sshn(ji,jj) ) * r1_e2v(ji,jj) 
    130                   END DO  
    131                END DO 
     126               DO_2D_00_00 
     127                  spgu(ji,jj) = spgu(ji,jj) + zld * ( pssh(ji+1,jj,Kmm) - pssh(ji,jj,Kmm) ) * r1_e1u(ji,jj) 
     128                  spgv(ji,jj) = spgv(ji,jj) + zld * ( pssh(ji,jj+1,Kmm) - pssh(ji,jj,Kmm) ) * r1_e2v(ji,jj) 
     129               END_2D 
    132130            ENDIF 
    133131         ENDIF 
    … …  
    138136            zgrau0r     = - grav * r1_rau0 
    139137            zpice(:,:) = (  zintp * snwice_mass(:,:) + ( 1.- zintp ) * snwice_mass_b(:,:)  ) * zgrau0r 
    140             DO jj = 2, jpjm1 
    141                DO ji = fs_2, fs_jpim1   ! vector opt. 
    142                   spgu(ji,jj) = spgu(ji,jj) + ( zpice(ji+1,jj) - zpice(ji,jj) ) * r1_e1u(ji,jj) 
    143                   spgv(ji,jj) = spgv(ji,jj) + ( zpice(ji,jj+1) - zpice(ji,jj) ) * r1_e2v(ji,jj) 
    144                END DO 
    145             END DO 
     138            DO_2D_00_00 
     139               spgu(ji,jj) = spgu(ji,jj) + ( zpice(ji+1,jj) - zpice(ji,jj) ) * r1_e1u(ji,jj) 
     140               spgv(ji,jj) = spgv(ji,jj) + ( zpice(ji,jj+1) - zpice(ji,jj) ) * r1_e2v(ji,jj) 
     141            END_2D 
    146142            DEALLOCATE( zpice )          
    147143         ENDIF 
    148144         ! 
    149          DO jk = 1, jpkm1                    !== Add all terms to the general trend 
    150             DO jj = 2, jpjm1 
    151                DO ji = fs_2, fs_jpim1   ! vector opt. 
    152                   ua(ji,jj,jk) = ua(ji,jj,jk) + spgu(ji,jj) 
    153                   va(ji,jj,jk) = va(ji,jj,jk) + spgv(ji,jj) 
    154                END DO 
    155             END DO 
    156          END DO     
     145         DO_3D_00_00( 1, jpkm1 ) 
     146            puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + spgu(ji,jj) 
     147            pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) + spgv(ji,jj) 
     148         END_3D 
    157149         ! 
    158150!!gm add here a call to dyn_trd for ice pressure gradient, the surf pressure trends ???? 
    … …  
    161153      ! 
    162154      SELECT CASE ( nspg )                   !== surface pressure gradient computed and add to the general trend ==! 
    163       CASE ( np_EXP )   ;   CALL dyn_spg_exp( kt )              ! explicit 
    164       CASE ( np_TS  )   ;   CALL dyn_spg_ts ( kt )              ! time-splitting 
     155      CASE ( np_EXP )   ;   CALL dyn_spg_exp( kt,      Kmm,       puu, pvv, Krhs )                    ! explicit 
     156      CASE ( np_TS  )   ;   CALL dyn_spg_ts ( kt, Kbb, Kmm, Krhs, puu, pvv, pssh, puu_b, pvv_b, Kaa ) ! time-splitting 
    165157      END SELECT 
    166158      !                     
    167159      IF( l_trddyn )   THEN                  ! save the surface pressure gradient trends for further diagnostics 
    168          ztrdu(:,:,:) = ua(:,:,:) - ztrdu(:,:,:) 
    169          ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:) 
    170          CALL trd_dyn( ztrdu, ztrdv, jpdyn_spg, kt ) 
     160         ztrdu(:,:,:) = puu(:,:,:,Krhs) - ztrdu(:,:,:) 
     161         ztrdv(:,:,:) = pvv(:,:,:,Krhs) - ztrdv(:,:,:) 
     162         CALL trd_dyn( ztrdu, ztrdv, jpdyn_spg, kt, Kmm ) 
    171163         DEALLOCATE( ztrdu , ztrdv )  
    172164      ENDIF 
    173165      !                                      ! print mean trends (used for debugging) 
    174       IF(ln_ctl)   CALL prt_ctl( tab3d_1=ua, clinfo1=' spg  - Ua: ', mask1=umask, & 
    175          &                       tab3d_2=va, clinfo2=       ' Va: ', mask2=vmask, clinfo3='dyn' ) 
     166      IF(sn_cfctl%l_prtctl)   CALL prt_ctl( tab3d_1=puu(:,:,:,Krhs), clinfo1=' spg  - Ua: ', mask1=umask, & 
     167         &                                  tab3d_2=pvv(:,:,:,Krhs), clinfo2=       ' Va: ', mask2=vmask, clinfo3='dyn' ) 
    176168      ! 
    177169      IF( ln_timing )   CALL timing_stop('dyn_spg') 
    … …  
    200192      ENDIF 
    201193      ! 
    202       REWIND( numnam_ref )              ! Namelist namdyn_spg in reference namelist : Free surface 
    203194      READ  ( numnam_ref, namdyn_spg, IOSTAT = ios, ERR = 901) 
    204195901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namdyn_spg in reference namelist' ) 
    205196      ! 
    206       REWIND( numnam_cfg )              ! Namelist namdyn_spg in configuration namelist : Free surface 
    207197      READ  ( numnam_cfg, namdyn_spg, IOSTAT = ios, ERR = 902 ) 
    208198902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namdyn_spg in configuration namelist' ) 

  • NEMO/trunk/src/OCE/DYN/dynspg_exp.F90

    r10068 r12377  
    3030 
    3131   !! * Substitutions 
    32 #  include "vectopt_loop_substitute.h90" 
     32#  include "do_loop_substitute.h90" 
    3333   !!---------------------------------------------------------------------- 
    3434   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    3838CONTAINS 
    3939 
    40    SUBROUTINE dyn_spg_exp( kt ) 
     40   SUBROUTINE dyn_spg_exp( kt, Kmm, puu, pvv, Krhs ) 
    4141      !!---------------------------------------------------------------------- 
    4242      !!                  ***  routine dyn_spg_exp  *** 
    … …  
    4848      !! ** Method  :   Explicit free surface formulation. Add to the general 
    4949      !!              momentum trend the surface pressure gradient : 
    50       !!                      (ua,va) = (ua,va) + (spgu,spgv) 
    51       !!              where spgu = -1/rau0 d/dx(ps) = -g/e1u di( sshn ) 
    52       !!                    spgv = -1/rau0 d/dy(ps) = -g/e2v dj( sshn ) 
     50      !!                      (uu(rhs),vv(rhs)) = (uu(rhs),vv(rhs)) + (spgu,spgv) 
     51      !!              where spgu = -1/rau0 d/dx(ps) = -g/e1u di( ssh(now) ) 
     52      !!                    spgv = -1/rau0 d/dy(ps) = -g/e2v dj( ssh(now) ) 
    5353      !! 
    54       !! ** Action :   (ua,va)   trend of horizontal velocity increased by  
     54      !! ** Action :   (puu(:,:,:,Krhs),pvv(:,:,:,Krhs))   trend of horizontal velocity increased by  
    5555      !!                         the surf. pressure gradient trend 
    5656      !!--------------------------------------------------------------------- 
    57       INTEGER, INTENT(in)  ::   kt   ! ocean time-step index 
     57      INTEGER                             , INTENT( in )  ::  kt        ! ocean time-step index 
     58      INTEGER                             , INTENT( in )  ::  Kmm, Krhs ! ocean time level indices 
     59      REAL(wp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) ::  puu, pvv  ! ocean velocities and RHS of momentum equation 
    5860      !! 
    5961      INTEGER ::   ji, jj, jk   ! dummy loop indices 
    … …  
    7274      IF( ln_linssh ) THEN          !* linear free surface : add the surface pressure gradient trend 
    7375         ! 
    74          DO jj = 2, jpjm1                    ! now surface pressure gradient 
    75             DO ji = fs_2, fs_jpim1   ! vector opt. 
    76                spgu(ji,jj) = - grav * ( sshn(ji+1,jj) - sshn(ji,jj) ) * r1_e1u(ji,jj) 
    77                spgv(ji,jj) = - grav * ( sshn(ji,jj+1) - sshn(ji,jj) ) * r1_e2v(ji,jj) 
    78             END DO  
    79          END DO 
     76         DO_2D_00_00 
     77            spgu(ji,jj) = - grav * ( ssh(ji+1,jj,Kmm) - ssh(ji,jj,Kmm) ) * r1_e1u(ji,jj) 
     78            spgv(ji,jj) = - grav * ( ssh(ji,jj+1,Kmm) - ssh(ji,jj,Kmm) ) * r1_e2v(ji,jj) 
     79         END_2D 
    8080         ! 
    81          DO jk = 1, jpkm1                    ! Add it to the general trend 
    82             DO jj = 2, jpjm1 
    83                DO ji = fs_2, fs_jpim1   ! vector opt. 
    84                   ua(ji,jj,jk) = ua(ji,jj,jk) + spgu(ji,jj) 
    85                   va(ji,jj,jk) = va(ji,jj,jk) + spgv(ji,jj) 
    86                END DO 
    87             END DO 
    88          END DO 
     81         DO_3D_00_00( 1, jpkm1 ) 
     82            puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + spgu(ji,jj) 
     83            pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) + spgv(ji,jj) 
     84         END_3D 
    8985         ! 
    9086      ENDIF 

  • NEMO/trunk/src/OCE/DYN/dynspg_ts.F90

    r12206 r12377  
    11MODULE dynspg_ts 
    22 
    3    !! Includes ROMS wd scheme with diagnostic outputs ; un and ua updates are commented out !  
     3   !! Includes ROMS wd scheme with diagnostic outputs ; puu(:,:,:,Kmm) and puu(:,:,:,Krhs) updates are commented out !  
    44 
    55   !!====================================================================== 
    … …  
    3131   USE dom_oce         ! ocean space and time domain 
    3232   USE sbc_oce         ! surface boundary condition: ocean 
     33   USE isf_oce         ! ice shelf variable (fwfisf) 
    3334   USE zdf_oce         ! vertical physics: variables 
    3435   USE zdfdrg          ! vertical physics: top/bottom drag coef. 
    35    USE sbcisf          ! ice shelf variable (fwfisf) 
    3636   USE sbcapr          ! surface boundary condition: atmospheric pressure 
    3737   USE dynadv    , ONLY: ln_dynadv_vec 
    … …  
    4444   USE bdytides        ! open boundary condition data 
    4545   USE bdydyn2d        ! open boundary conditions on barotropic variables 
    46    USE sbctide         ! tides 
    47    USE updtide         ! tide potential 
     46   USE tide_mod        ! 
    4847   USE sbcwave         ! surface wave 
    4948#if defined key_agrif 
    … …  
    8786 
    8887   !! * Substitutions 
    89 #  include "vectopt_loop_substitute.h90" 
     88#  include "do_loop_substitute.h90" 
    9089   !!---------------------------------------------------------------------- 
    9190   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    117116 
    118117 
    119    SUBROUTINE dyn_spg_ts( kt ) 
     118   SUBROUTINE dyn_spg_ts( kt, Kbb, Kmm, Krhs, puu, pvv, pssh, puu_b, pvv_b, Kaa ) 
    120119      !!---------------------------------------------------------------------- 
    121120      !! 
    … …  
    132131      !! 
    133132      !! ** Action : 
    134       !!      -Update the filtered free surface at step "n+1"      : ssha 
    135       !!      -Update filtered barotropic velocities at step "n+1" : ua_b, va_b 
     133      !!      -Update the filtered free surface at step "n+1"      : pssh(:,:,Kaa) 
     134      !!      -Update filtered barotropic velocities at step "n+1" : puu_b(:,:,:,Kaa), vv_b(:,:,:,Kaa) 
    136135      !!      -Compute barotropic advective fluxes at step "n"     : un_adv, vn_adv 
    137136      !!      These are used to advect tracers and are compliant with discrete 
    138137      !!      continuity equation taken at the baroclinic time steps. This  
    139138      !!      ensures tracers conservation. 
    140       !!      - (ua, va) momentum trend updated with barotropic component. 
     139      !!      - (puu(:,:,:,Krhs), pvv(:,:,:,Krhs)) momentum trend updated with barotropic component. 
    141140      !! 
    142141      !! References : Shchepetkin and McWilliams, Ocean Modelling, 2005.  
    143142      !!--------------------------------------------------------------------- 
    144       INTEGER, INTENT(in)  ::   kt   ! ocean time-step index 
     143      INTEGER                             , INTENT( in )  ::  kt                  ! ocean time-step index 
     144      INTEGER                             , INTENT( in )  ::  Kbb, Kmm, Krhs, Kaa ! ocean time level indices 
     145      REAL(wp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) ::  puu, pvv            ! ocean velocities and RHS of momentum equation 
     146      REAL(wp), DIMENSION(jpi,jpj,jpt)    , INTENT(inout) ::  pssh, puu_b, pvv_b  ! SSH and barotropic velocities at main time levels 
    145147      ! 
    146148      INTEGER  ::   ji, jj, jk, jn        ! dummy loop indices 
    … …  
    168170      REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: ztwdmask, zuwdmask, zvwdmask ! ROMS wetting and drying masks at t,u,v points 
    169171      REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zuwdav2, zvwdav2    ! averages over the sub-steps of zuwdmask and zvwdmask 
     172      REAL(wp) ::   zt0substep !   Time of day at the beginning of the time substep 
    170173      !!---------------------------------------------------------------------- 
    171174      ! 
    … …  
    223226      !                                   !=  zu_frc =  1/H e3*d/dt(Ua)  =!  (Vertical mean of Ua, the 3D trends) 
    224227      !                                   !  ---------------------------  ! 
    225       zu_frc(:,:) = SUM( e3u_n(:,:,:) * ua(:,:,:) * umask(:,:,:) , DIM=3 ) * r1_hu_n(:,:) 
    226       zv_frc(:,:) = SUM( e3v_n(:,:,:) * va(:,:,:) * vmask(:,:,:) , DIM=3 ) * r1_hv_n(:,:) 
    227       ! 
    228       ! 
    229       !                                   !=  Ua => baroclinic trend  =!   (remove its vertical mean) 
    230       DO jk = 1, jpkm1                    !  ------------------------  ! 
    231          ua(:,:,jk) = ( ua(:,:,jk) - zu_frc(:,:) ) * umask(:,:,jk) 
    232          va(:,:,jk) = ( va(:,:,jk) - zv_frc(:,:) ) * vmask(:,:,jk) 
     228      zu_frc(:,:) = SUM( e3u(:,:,:,Kmm) * uu(:,:,:,Krhs) * umask(:,:,:) , DIM=3 ) * r1_hu(:,:,Kmm) 
     229      zv_frc(:,:) = SUM( e3v(:,:,:,Kmm) * vv(:,:,:,Krhs) * vmask(:,:,:) , DIM=3 ) * r1_hv(:,:,Kmm) 
     230      ! 
     231      ! 
     232      !                                   !=  U(Krhs) => baroclinic trend  =!   (remove its vertical mean) 
     233      DO jk = 1, jpkm1                    !  -----------------------------  ! 
     234         uu(:,:,jk,Krhs) = ( uu(:,:,jk,Krhs) - zu_frc(:,:) ) * umask(:,:,jk) 
     235         vv(:,:,jk,Krhs) = ( vv(:,:,jk,Krhs) - zv_frc(:,:) ) * vmask(:,:,jk) 
    233236      END DO 
    234237       
    … …  
    239242      !                                   !  -------------------------------------------------  ! 
    240243      ! 
    241       IF( kt == nit000 .OR. .NOT. ln_linssh )   CALL dyn_cor_2D_init   ! Set zwz, the barotropic Coriolis force coefficient 
     244      IF( kt == nit000 .OR. .NOT. ln_linssh )   CALL dyn_cor_2D_init( Kmm )   ! Set zwz, the barotropic Coriolis force coefficient 
    242245      !       ! recompute zwz = f/depth  at every time step for (.NOT.ln_linssh) as the water colomn height changes 
    243246      ! 
    244247      !                                         !* 2D Coriolis trends 
    245       zhU(:,:) = un_b(:,:) * hu_n(:,:) * e2u(:,:)        ! now fluxes  
    246       zhV(:,:) = vn_b(:,:) * hv_n(:,:) * e1v(:,:)        ! NB: FULL domain : put a value in last row and column 
    247       ! 
    248       CALL dyn_cor_2d( hu_n, hv_n, un_b, vn_b, zhU, zhV,  &   ! <<== in 
    249          &                               zu_trd, zv_trd   )   ! ==>> out 
     248      zhU(:,:) = puu_b(:,:,Kmm) * hu(:,:,Kmm) * e2u(:,:)        ! now fluxes  
     249      zhV(:,:) = pvv_b(:,:,Kmm) * hv(:,:,Kmm) * e1v(:,:)        ! NB: FULL domain : put a value in last row and column 
     250      ! 
     251      CALL dyn_cor_2d( hu(:,:,Kmm), hv(:,:,Kmm), puu_b(:,:,Kmm), pvv_b(:,:,Kmm), zhU, zhV,  &   ! <<== in 
     252         &                                                                     zu_trd, zv_trd   )   ! ==>> out 
    250253      ! 
    251254      IF( .NOT.ln_linssh ) THEN                 !* surface pressure gradient   (variable volume only) 
    252255         ! 
    253256         IF( ln_wd_il ) THEN                       ! W/D : limiter applied to spgspg 
    254             CALL wad_spg( sshn, zcpx, zcpy )          ! Calculating W/D gravity filters, zcpx and zcpy 
    255             DO jj = 2, jpjm1 
    256                DO ji = 2, jpim1                ! SPG with the application of W/D gravity filters 
    257                   zu_trd(ji,jj) = zu_trd(ji,jj) - grav * ( sshn(ji+1,jj  ) - sshn(ji  ,jj ) )   & 
    258                      &                          * r1_e1u(ji,jj) * zcpx(ji,jj)  * wdrampu(ji,jj)  !jth 
    259                   zv_trd(ji,jj) = zv_trd(ji,jj) - grav * ( sshn(ji  ,jj+1) - sshn(ji  ,jj ) )   & 
    260                      &                          * r1_e2v(ji,jj) * zcpy(ji,jj)  * wdrampv(ji,jj)  !jth 
    261                END DO 
    262             END DO 
     257            CALL wad_spg( pssh(:,:,Kmm), zcpx, zcpy )          ! Calculating W/D gravity filters, zcpx and zcpy 
     258            DO_2D_00_00 
     259               zu_trd(ji,jj) = zu_trd(ji,jj) - grav * ( pssh(ji+1,jj  ,Kmm) - pssh(ji  ,jj ,Kmm) )   & 
     260                  &                          * r1_e1u(ji,jj) * zcpx(ji,jj)  * wdrampu(ji,jj)  !jth 
     261               zv_trd(ji,jj) = zv_trd(ji,jj) - grav * ( pssh(ji  ,jj+1,Kmm) - pssh(ji  ,jj ,Kmm) )   & 
     262                  &                          * r1_e2v(ji,jj) * zcpy(ji,jj)  * wdrampv(ji,jj)  !jth 
     263            END_2D 
    263264         ELSE                                      ! now suface pressure gradient 
    264             DO jj = 2, jpjm1 
    265                DO ji = fs_2, fs_jpim1   ! vector opt. 
    266                   zu_trd(ji,jj) = zu_trd(ji,jj) - grav * (  sshn(ji+1,jj  ) - sshn(ji  ,jj  )  ) * r1_e1u(ji,jj) 
    267                   zv_trd(ji,jj) = zv_trd(ji,jj) - grav * (  sshn(ji  ,jj+1) - sshn(ji  ,jj  )  ) * r1_e2v(ji,jj)  
    268                END DO 
    269             END DO 
    270          ENDIF 
    271          ! 
    272       ENDIF 
    273       ! 
    274       DO jj = 2, jpjm1                          ! Remove coriolis term (and possibly spg) from barotropic trend 
    275          DO ji = fs_2, fs_jpim1 
    276              zu_frc(ji,jj) = zu_frc(ji,jj) - zu_trd(ji,jj) * ssumask(ji,jj) 
    277              zv_frc(ji,jj) = zv_frc(ji,jj) - zv_trd(ji,jj) * ssvmask(ji,jj) 
    278           END DO 
    279       END DO  
     265            DO_2D_00_00 
     266               zu_trd(ji,jj) = zu_trd(ji,jj) - grav * (  pssh(ji+1,jj  ,Kmm) - pssh(ji  ,jj  ,Kmm)  ) * r1_e1u(ji,jj) 
     267               zv_trd(ji,jj) = zv_trd(ji,jj) - grav * (  pssh(ji  ,jj+1,Kmm) - pssh(ji  ,jj  ,Kmm)  ) * r1_e2v(ji,jj)  
     268            END_2D 
     269         ENDIF 
     270         ! 
     271      ENDIF 
     272      ! 
     273      DO_2D_00_00 
     274          zu_frc(ji,jj) = zu_frc(ji,jj) - zu_trd(ji,jj) * ssumask(ji,jj) 
     275          zv_frc(ji,jj) = zv_frc(ji,jj) - zv_trd(ji,jj) * ssvmask(ji,jj) 
     276      END_2D 
    280277      ! 
    281278      !                                   !=  Add bottom stress contribution from baroclinic velocities  =! 
    282279      !                                   !  -----------------------------------------------------------  ! 
    283       CALL dyn_drg_init( zu_frc, zv_frc,  zCdU_u, zCdU_v )      ! also provide the barotropic drag coefficients 
    284       ! 
     280      CALL dyn_drg_init( Kbb, Kmm, puu, pvv, puu_b ,pvv_b, zu_frc, zv_frc,  zCdU_u, zCdU_v )      ! also provide the barotropic drag coefficients 
    285281      !                                   !=  Add atmospheric pressure forcing  =! 
    286282      !                                   !  ----------------------------------  ! 
    287283      IF( ln_apr_dyn ) THEN 
    288284         IF( ln_bt_fw ) THEN                          ! FORWARD integration: use kt+1/2 pressure (NOW+1/2) 
    289             DO jj = 2, jpjm1               
    290                DO ji = fs_2, fs_jpim1   ! vector opt. 
    291                   zu_frc(ji,jj) = zu_frc(ji,jj) + grav * (  ssh_ib (ji+1,jj  ) - ssh_ib (ji,jj) ) * r1_e1u(ji,jj) 
    292                   zv_frc(ji,jj) = zv_frc(ji,jj) + grav * (  ssh_ib (ji  ,jj+1) - ssh_ib (ji,jj) ) * r1_e2v(ji,jj) 
    293                END DO 
    294             END DO 
     285            DO_2D_00_00 
     286               zu_frc(ji,jj) = zu_frc(ji,jj) + grav * (  ssh_ib (ji+1,jj  ) - ssh_ib (ji,jj) ) * r1_e1u(ji,jj) 
     287               zv_frc(ji,jj) = zv_frc(ji,jj) + grav * (  ssh_ib (ji  ,jj+1) - ssh_ib (ji,jj) ) * r1_e2v(ji,jj) 
     288            END_2D 
    295289         ELSE                                         ! CENTRED integration: use kt-1/2 + kt+1/2 pressure (NOW) 
    296290            zztmp = grav * r1_2 
    297             DO jj = 2, jpjm1               
    298                DO ji = fs_2, fs_jpim1   ! vector opt. 
    299                   zu_frc(ji,jj) = zu_frc(ji,jj) + zztmp * (  ssh_ib (ji+1,jj  ) - ssh_ib (ji,jj)  & 
    300                        &                                   + ssh_ibb(ji+1,jj  ) - ssh_ibb(ji,jj)  ) * r1_e1u(ji,jj) 
    301                   zv_frc(ji,jj) = zv_frc(ji,jj) + zztmp * (  ssh_ib (ji  ,jj+1) - ssh_ib (ji,jj)  & 
    302                        &                                   + ssh_ibb(ji  ,jj+1) - ssh_ibb(ji,jj)  ) * r1_e2v(ji,jj) 
    303                END DO 
    304             END DO 
    305          ENDIF  
     291            DO_2D_00_00 
     292               zu_frc(ji,jj) = zu_frc(ji,jj) + zztmp * (  ssh_ib (ji+1,jj  ) - ssh_ib (ji,jj)  & 
     293                    &                                   + ssh_ibb(ji+1,jj  ) - ssh_ibb(ji,jj)  ) * r1_e1u(ji,jj) 
     294               zv_frc(ji,jj) = zv_frc(ji,jj) + zztmp * (  ssh_ib (ji  ,jj+1) - ssh_ib (ji,jj)  & 
     295                    &                                   + ssh_ibb(ji  ,jj+1) - ssh_ibb(ji,jj)  ) * r1_e2v(ji,jj) 
     296            END_2D 
     297         ENDIF 
    306298      ENDIF 
    307299      ! 
    … …  
    309301      !                                   !  ----------------------------------  ! 
    310302      IF( ln_bt_fw ) THEN                        ! Add wind forcing 
    311          DO jj = 2, jpjm1 
    312             DO ji = fs_2, fs_jpim1   ! vector opt. 
    313                zu_frc(ji,jj) =  zu_frc(ji,jj) + r1_rau0 * utau(ji,jj) * r1_hu_n(ji,jj) 
    314                zv_frc(ji,jj) =  zv_frc(ji,jj) + r1_rau0 * vtau(ji,jj) * r1_hv_n(ji,jj) 
    315             END DO 
    316          END DO 
     303         DO_2D_00_00 
     304            zu_frc(ji,jj) =  zu_frc(ji,jj) + r1_rau0 * utau(ji,jj) * r1_hu(ji,jj,Kmm) 
     305            zv_frc(ji,jj) =  zv_frc(ji,jj) + r1_rau0 * vtau(ji,jj) * r1_hv(ji,jj,Kmm) 
     306         END_2D 
    317307      ELSE 
    318308         zztmp = r1_rau0 * r1_2 
    319          DO jj = 2, jpjm1 
    320             DO ji = fs_2, fs_jpim1   ! vector opt. 
    321                zu_frc(ji,jj) =  zu_frc(ji,jj) + zztmp * ( utau_b(ji,jj) + utau(ji,jj) ) * r1_hu_n(ji,jj) 
    322                zv_frc(ji,jj) =  zv_frc(ji,jj) + zztmp * ( vtau_b(ji,jj) + vtau(ji,jj) ) * r1_hv_n(ji,jj) 
    323             END DO 
    324          END DO 
     309         DO_2D_00_00 
     310            zu_frc(ji,jj) =  zu_frc(ji,jj) + zztmp * ( utau_b(ji,jj) + utau(ji,jj) ) * r1_hu(ji,jj,Kmm) 
     311            zv_frc(ji,jj) =  zv_frc(ji,jj) + zztmp * ( vtau_b(ji,jj) + vtau(ji,jj) ) * r1_hv(ji,jj,Kmm) 
     312         END_2D 
    325313      ENDIF   
    326314      ! 
    … …  
    331319      !                                   ! ---------------------------------------------------  ! 
    332320      IF (ln_bt_fw) THEN                          ! FORWARD integration: use kt+1/2 fluxes (NOW+1/2) 
    333          zssh_frc(:,:) = r1_rau0 * ( emp(:,:)             - rnf(:,:)              + fwfisf(:,:)                  ) 
     321         zssh_frc(:,:) = r1_rau0 * ( emp(:,:) - rnf(:,:) + fwfisf_cav(:,:) + fwfisf_par(:,:) ) 
    334322      ELSE                                        ! CENTRED integration: use kt-1/2 + kt+1/2 fluxes (NOW) 
    335323         zztmp = r1_rau0 * r1_2 
    336          zssh_frc(:,:) = zztmp * (  emp(:,:) + emp_b(:,:) - rnf(:,:) - rnf_b(:,:) + fwfisf(:,:) + fwfisf_b(:,:)  ) 
     324         zssh_frc(:,:) = zztmp * (  emp(:,:)        + emp_b(:,:)                    & 
     325                &                 - rnf(:,:)        - rnf_b(:,:)                    & 
     326                &                 + fwfisf_cav(:,:) + fwfisf_cav_b(:,:)             & 
     327                &                 + fwfisf_par(:,:) + fwfisf_par_b(:,:)             ) 
    337328      ENDIF 
    338329      !                                   !=  Add Stokes drift divergence  =!   (if exist) 
    … …  
    340331         zssh_frc(:,:) = zssh_frc(:,:) + div_sd(:,:) 
    341332      ENDIF 
     333      ! 
     334      !                                         ! ice sheet coupling 
     335      IF ( ln_isf .AND. ln_isfcpl ) THEN 
     336         ! 
     337         ! ice sheet coupling 
     338         IF( ln_rstart .AND. kt == nit000 ) THEN 
     339            zssh_frc(:,:) = zssh_frc(:,:) + risfcpl_ssh(:,:) 
     340         END IF 
     341         ! 
     342         ! conservation option 
     343         IF( ln_isfcpl_cons ) THEN 
     344            zssh_frc(:,:) = zssh_frc(:,:) + risfcpl_cons_ssh(:,:) 
     345         END IF 
     346         ! 
     347      END IF 
    342348      ! 
    343349#if defined key_asminc 
    … …  
    372378      ! 
    373379      IF( ln_linssh ) THEN    ! mid-step ocean depth is fixed (hup2_e=hu_n=hu_0) 
    374          zhup2_e(:,:) = hu_n(:,:) 
    375          zhvp2_e(:,:) = hv_n(:,:) 
    376          zhtp2_e(:,:) = ht_n(:,:) 
     380         zhup2_e(:,:) = hu(:,:,Kmm) 
     381         zhvp2_e(:,:) = hv(:,:,Kmm) 
     382         zhtp2_e(:,:) = ht(:,:) 
    377383      ENDIF 
    378384      ! 
    379385      IF (ln_bt_fw) THEN                  ! FORWARD integration: start from NOW fields                     
    380          sshn_e(:,:) =    sshn(:,:)             
    381          un_e  (:,:) =    un_b(:,:)             
    382          vn_e  (:,:) =    vn_b(:,:) 
    383          ! 
    384          hu_e  (:,:) =    hu_n(:,:)        
    385          hv_e  (:,:) =    hv_n(:,:)  
    386          hur_e (:,:) = r1_hu_n(:,:)     
    387          hvr_e (:,:) = r1_hv_n(:,:) 
     386         sshn_e(:,:) =    pssh(:,:,Kmm)             
     387         un_e  (:,:) =    puu_b(:,:,Kmm)             
     388         vn_e  (:,:) =    pvv_b(:,:,Kmm) 
     389         ! 
     390         hu_e  (:,:) =    hu(:,:,Kmm)        
     391         hv_e  (:,:) =    hv(:,:,Kmm)  
     392         hur_e (:,:) = r1_hu(:,:,Kmm)     
     393         hvr_e (:,:) = r1_hv(:,:,Kmm) 
    388394      ELSE                                ! CENTRED integration: start from BEFORE fields 
    389          sshn_e(:,:) =    sshb(:,:) 
    390          un_e  (:,:) =    ub_b(:,:)          
    391          vn_e  (:,:) =    vb_b(:,:) 
    392          ! 
    393          hu_e  (:,:) =    hu_b(:,:)        
    394          hv_e  (:,:) =    hv_b(:,:)  
    395          hur_e (:,:) = r1_hu_b(:,:)     
    396          hvr_e (:,:) = r1_hv_b(:,:) 
     395         sshn_e(:,:) =    pssh(:,:,Kbb) 
     396         un_e  (:,:) =    puu_b(:,:,Kbb)          
     397         vn_e  (:,:) =    pvv_b(:,:,Kbb) 
     398         ! 
     399         hu_e  (:,:) =    hu(:,:,Kbb)        
     400         hv_e  (:,:) =    hv(:,:,Kbb)  
     401         hur_e (:,:) = r1_hu(:,:,Kbb)     
     402         hvr_e (:,:) = r1_hv(:,:,Kbb) 
    397403      ENDIF 
    398404      ! 
    399405      ! Initialize sums: 
    400       ua_b  (:,:) = 0._wp       ! After barotropic velocities (or transport if flux form)           
    401       va_b  (:,:) = 0._wp 
    402       ssha  (:,:) = 0._wp       ! Sum for after averaged sea level 
     406      puu_b  (:,:,Kaa) = 0._wp       ! After barotropic velocities (or transport if flux form)           
     407      pvv_b  (:,:,Kaa) = 0._wp 
     408      pssh  (:,:,Kaa) = 0._wp       ! Sum for after averaged sea level 
    403409      un_adv(:,:) = 0._wp       ! Sum for now transport issued from ts loop 
    404410      vn_adv(:,:) = 0._wp 
    … …  
    419425         !                    !==  Update the forcing ==! (BDY and tides) 
    420426         ! 
    421          IF( ln_bdy      .AND. ln_tide )   CALL bdy_dta_tides( kt, kit=jn, kt_offset= noffset+1 ) 
    422          IF( ln_tide_pot .AND. ln_tide )   CALL upd_tide     ( kt, kit=jn, kt_offset= noffset   ) 
     427         IF( ln_bdy      .AND. ln_tide )   CALL bdy_dta_tides( kt, kit=jn, pt_offset= REAL(noffset+1,wp) ) 
     428         ! Update tide potential at the beginning of current time substep 
     429         IF( ln_tide_pot .AND. ln_tide ) THEN 
     430            zt0substep = REAL(nsec_day, wp) - 0.5_wp*rdt + (jn + noffset - 1) * rdt / REAL(nn_baro, wp) 
     431            CALL upd_tide(zt0substep, Kmm) 
     432         END IF 
    423433         ! 
    424434         !                    !==  extrapolation at mid-step  ==!   (jn+1/2) 
    … …  
    457467            ! 
    458468            !                          ! ocean u- and v-depth at mid-step   (separate DO-loops remove the need of a lbc_lnk) 
    459             DO jj = 1, jpj 
    460                DO ji = 1, jpim1   ! not jpi-column 
    461                   zhup2_e(ji,jj) = hu_0(ji,jj) + r1_2 * r1_e1e2u(ji,jj)                        & 
    462                        &                              * (  e1e2t(ji  ,jj) * zsshp2_e(ji  ,jj)  & 
    463                        &                                 + e1e2t(ji+1,jj) * zsshp2_e(ji+1,jj)  ) * ssumask(ji,jj) 
    464                END DO 
    465             END DO 
    466             DO jj = 1, jpjm1        ! not jpj-row 
    467                DO ji = 1, jpi 
    468                   zhvp2_e(ji,jj) = hv_0(ji,jj) + r1_2 * r1_e1e2v(ji,jj)                        & 
    469                        &                              * (  e1e2t(ji,jj  ) * zsshp2_e(ji,jj  )  & 
    470                        &                                 + e1e2t(ji,jj+1) * zsshp2_e(ji,jj+1)  ) * ssvmask(ji,jj) 
    471                END DO 
    472             END DO 
     469            DO_2D_11_10 
     470               zhup2_e(ji,jj) = hu_0(ji,jj) + r1_2 * r1_e1e2u(ji,jj)                        & 
     471                    &                              * (  e1e2t(ji  ,jj) * zsshp2_e(ji  ,jj)  & 
     472                    &                                 + e1e2t(ji+1,jj) * zsshp2_e(ji+1,jj)  ) * ssumask(ji,jj) 
     473            END_2D 
     474            DO_2D_10_11 
     475               zhvp2_e(ji,jj) = hv_0(ji,jj) + r1_2 * r1_e1e2v(ji,jj)                        & 
     476                    &                              * (  e1e2t(ji,jj  ) * zsshp2_e(ji,jj  )  & 
     477                    &                                 + e1e2t(ji,jj+1) * zsshp2_e(ji,jj+1)  ) * ssvmask(ji,jj) 
     478            END_2D 
    473479            ! 
    474480         ENDIF 
    … …  
    479485         !                             ! values of zhup2_e and zhvp2_e on the halo are not needed in bdy_vol2d 
    480486         IF( ln_bdy .AND. ln_vol ) CALL bdy_vol2d( kt, jn, ua_e, va_e, zhup2_e, zhvp2_e ) 
    481          ! 
     487         !       
    482488         !                             ! resulting flux at mid-step (not over the full domain) 
    483489         zhU(1:jpim1,1:jpj  ) = e2u(1:jpim1,1:jpj  ) * ua_e(1:jpim1,1:jpj  ) * zhup2_e(1:jpim1,1:jpj  )   ! not jpi-column 
    … …  
    486492#if defined key_agrif 
    487493         ! Set fluxes during predictor step to ensure volume conservation 
    488          IF( .NOT.Agrif_Root() .AND. ln_bt_fw ) THEN 
    489             IF((nbondi == -1).OR.(nbondi == 2)) THEN 
    490                DO jj = 1, jpj 
    491                   zhU(2:nbghostcells+1,jj) = ubdy_w(1:nbghostcells,jj) * e2u(2:nbghostcells+1,jj) 
    492                   zhV(2:nbghostcells+1,jj) = vbdy_w(1:nbghostcells,jj) * e1v(2:nbghostcells+1,jj) 
    493                END DO 
    494             ENDIF 
    495             IF((nbondi ==  1).OR.(nbondi == 2)) THEN 
    496                DO jj=1,jpj 
    497                   zhU(nlci-nbghostcells-1:nlci-2,jj) = ubdy_e(1:nbghostcells,jj) * e2u(nlci-nbghostcells-1:nlci-2,jj) 
    498                   zhV(nlci-nbghostcells  :nlci-1,jj) = vbdy_e(1:nbghostcells,jj) * e1v(nlci-nbghostcells  :nlci-1,jj) 
    499                END DO 
    500             ENDIF 
    501             IF((nbondj == -1).OR.(nbondj == 2)) THEN 
    502                DO ji=1,jpi 
    503                   zhV(ji,2:nbghostcells+1) = vbdy_s(ji,1:nbghostcells) * e1v(ji,2:nbghostcells+1) 
    504                   zhU(ji,2:nbghostcells+1) = ubdy_s(ji,1:nbghostcells) * e2u(ji,2:nbghostcells+1) 
    505                END DO 
    506             ENDIF 
    507             IF((nbondj ==  1).OR.(nbondj == 2)) THEN 
    508                DO ji=1,jpi 
    509                   zhV(ji,nlcj-nbghostcells-1:nlcj-2) = vbdy_n(ji,1:nbghostcells) * e1v(ji,nlcj-nbghostcells-1:nlcj-2) 
    510                   zhU(ji,nlcj-nbghostcells  :nlcj-1) = ubdy_n(ji,1:nbghostcells) * e2u(ji,nlcj-nbghostcells  :nlcj-1) 
    511                END DO 
    512             ENDIF 
    513          ENDIF 
     494         IF( .NOT.Agrif_Root() .AND. ln_bt_fw ) CALL agrif_dyn_ts_flux( jn, zhU, zhV ) 
    514495#endif 
    515496         IF( ln_wd_il )   CALL wad_lmt_bt(zhU, zhV, sshn_e, zssh_frc, rdtbt)    !!gm wad_lmt_bt use of lbc_lnk on zhU, zhV 
    … …  
    526507         !--        ssh    =  ssh   - delta_t' * [ frc + div( flux      ) ]      --! 
    527508         !-------------------------------------------------------------------------! 
    528          DO jj = 2, jpjm1        ! INNER domain                              
    529             DO ji = 2, jpim1 
    530                zhdiv = (   zhU(ji,jj) - zhU(ji-1,jj) + zhV(ji,jj) - zhV(ji,jj-1)   ) * r1_e1e2t(ji,jj) 
    531                ssha_e(ji,jj) = (  sshn_e(ji,jj) - rdtbt * ( zssh_frc(ji,jj) + zhdiv )  ) * ssmask(ji,jj) 
    532             END DO 
    533          END DO 
     509         DO_2D_00_00 
     510            zhdiv = (   zhU(ji,jj) - zhU(ji-1,jj) + zhV(ji,jj) - zhV(ji,jj-1)   ) * r1_e1e2t(ji,jj) 
     511            ssha_e(ji,jj) = (  sshn_e(ji,jj) - rdtbt * ( zssh_frc(ji,jj) + zhdiv )  ) * ssmask(ji,jj) 
     512         END_2D 
    534513         ! 
    535514         CALL lbc_lnk_multi( 'dynspg_ts', ssha_e, 'T', 1._wp,  zhU, 'U', -1._wp,  zhV, 'V', -1._wp ) 
    … …  
    553532         ! Sea Surface Height at u-,v-points (vvl case only) 
    554533         IF( .NOT.ln_linssh ) THEN                                 
    555             DO jj = 2, jpjm1   ! INNER domain, will be extended to whole domain later 
    556                DO ji = 2, jpim1      ! NO Vector Opt. 
    557                   zsshu_a(ji,jj) = r1_2 * ssumask(ji,jj) * r1_e1e2u(ji,jj)    & 
    558                      &              * ( e1e2t(ji  ,jj  )  * ssha_e(ji  ,jj  ) & 
    559                      &              +   e1e2t(ji+1,jj  )  * ssha_e(ji+1,jj  ) ) 
    560                   zsshv_a(ji,jj) = r1_2 * ssvmask(ji,jj) * r1_e1e2v(ji,jj)    & 
    561                      &              * ( e1e2t(ji  ,jj  )  * ssha_e(ji  ,jj  ) & 
    562                      &              +   e1e2t(ji  ,jj+1)  * ssha_e(ji  ,jj+1) ) 
    563                END DO 
    564             END DO 
     534            DO_2D_00_00 
     535               zsshu_a(ji,jj) = r1_2 * ssumask(ji,jj) * r1_e1e2u(ji,jj)    & 
     536                  &              * ( e1e2t(ji  ,jj  )  * ssha_e(ji  ,jj  ) & 
     537                  &              +   e1e2t(ji+1,jj  )  * ssha_e(ji+1,jj  ) ) 
     538               zsshv_a(ji,jj) = r1_2 * ssvmask(ji,jj) * r1_e1e2v(ji,jj)    & 
     539                  &              * ( e1e2t(ji  ,jj  )  * ssha_e(ji  ,jj  ) & 
     540                  &              +   e1e2t(ji  ,jj+1)  * ssha_e(ji  ,jj+1) ) 
     541            END_2D 
    565542         ENDIF    
    566543         !          
    … …  
    575552         !                             ! Surface pressure gradient 
    576553         zldg = ( 1._wp - rn_scal_load ) * grav    ! local factor 
    577          DO jj = 2, jpjm1                             
    578             DO ji = 2, jpim1 
    579                zu_spg(ji,jj) = - zldg * ( zsshp2_e(ji+1,jj) - zsshp2_e(ji,jj) ) * r1_e1u(ji,jj) 
    580                zv_spg(ji,jj) = - zldg * ( zsshp2_e(ji,jj+1) - zsshp2_e(ji,jj) ) * r1_e2v(ji,jj) 
    581             END DO 
    582          END DO 
     554         DO_2D_00_00 
     555            zu_spg(ji,jj) = - zldg * ( zsshp2_e(ji+1,jj) - zsshp2_e(ji,jj) ) * r1_e1u(ji,jj) 
     556            zv_spg(ji,jj) = - zldg * ( zsshp2_e(ji,jj+1) - zsshp2_e(ji,jj) ) * r1_e2v(ji,jj) 
     557         END_2D 
    583558         IF( ln_wd_il ) THEN        ! W/D : gravity filters applied on pressure gradient 
    584559            CALL wad_spg( zsshp2_e, zcpx, zcpy )   ! Calculating W/D gravity filters 
    … …  
    595570         ! Add tidal astronomical forcing if defined 
    596571         IF ( ln_tide .AND. ln_tide_pot ) THEN 
    597             DO jj = 2, jpjm1 
    598                DO ji = fs_2, fs_jpim1   ! vector opt. 
    599                   zu_trd(ji,jj) = zu_trd(ji,jj) + grav * ( pot_astro(ji+1,jj) - pot_astro(ji,jj) ) * r1_e1u(ji,jj) 
    600                   zv_trd(ji,jj) = zv_trd(ji,jj) + grav * ( pot_astro(ji,jj+1) - pot_astro(ji,jj) ) * r1_e2v(ji,jj) 
    601                END DO 
    602             END DO 
     572            DO_2D_00_00 
     573               zu_trd(ji,jj) = zu_trd(ji,jj) + grav * ( pot_astro(ji+1,jj) - pot_astro(ji,jj) ) * r1_e1u(ji,jj) 
     574               zv_trd(ji,jj) = zv_trd(ji,jj) + grav * ( pot_astro(ji,jj+1) - pot_astro(ji,jj) ) * r1_e2v(ji,jj) 
     575            END_2D 
    603576         ENDIF 
    604577         ! 
    … …  
    606579!jth do implicitly instead 
    607580         IF ( .NOT. ll_wd ) THEN ! Revert to explicit for bit comparison tests in non wad runs 
    608             DO jj = 2, jpjm1 
    609                DO ji = fs_2, fs_jpim1   ! vector opt. 
    610                   zu_trd(ji,jj) = zu_trd(ji,jj) + zCdU_u(ji,jj) * un_e(ji,jj) * hur_e(ji,jj) 
    611                   zv_trd(ji,jj) = zv_trd(ji,jj) + zCdU_v(ji,jj) * vn_e(ji,jj) * hvr_e(ji,jj) 
    612                END DO 
    613             END DO 
     581            DO_2D_00_00 
     582               zu_trd(ji,jj) = zu_trd(ji,jj) + zCdU_u(ji,jj) * un_e(ji,jj) * hur_e(ji,jj) 
     583               zv_trd(ji,jj) = zv_trd(ji,jj) + zCdU_v(ji,jj) * vn_e(ji,jj) * hvr_e(ji,jj) 
     584            END_2D 
    614585         ENDIF 
    615586         ! 
    … …  
    626597         !------------------------------------------------------------------------------------------------------------------------! 
    627598         IF( ln_dynadv_vec .OR. ln_linssh ) THEN      !* Vector form 
    628             DO jj = 2, jpjm1 
    629                DO ji = fs_2, fs_jpim1   ! vector opt. 
    630                   ua_e(ji,jj) = (                                 un_e(ji,jj)   &  
    631                             &     + rdtbt * (                   zu_spg(ji,jj)   & 
    632                             &                                 + zu_trd(ji,jj)   & 
    633                             &                                 + zu_frc(ji,jj) ) &  
    634                             &   ) * ssumask(ji,jj) 
    635  
    636                   va_e(ji,jj) = (                                 vn_e(ji,jj)   & 
    637                             &     + rdtbt * (                   zv_spg(ji,jj)   & 
    638                             &                                 + zv_trd(ji,jj)   & 
    639                             &                                 + zv_frc(ji,jj) ) & 
    640                             &   ) * ssvmask(ji,jj) 
    641                END DO 
    642             END DO 
     599            DO_2D_00_00 
     600               ua_e(ji,jj) = (                                 un_e(ji,jj)   &  
     601                         &     + rdtbt * (                   zu_spg(ji,jj)   & 
     602                         &                                 + zu_trd(ji,jj)   & 
     603                         &                                 + zu_frc(ji,jj) ) &  
     604                         &   ) * ssumask(ji,jj) 
     605 
     606               va_e(ji,jj) = (                                 vn_e(ji,jj)   & 
     607                         &     + rdtbt * (                   zv_spg(ji,jj)   & 
     608                         &                                 + zv_trd(ji,jj)   & 
     609                         &                                 + zv_frc(ji,jj) ) & 
     610                         &   ) * ssvmask(ji,jj) 
     611            END_2D 
    643612            ! 
    644613         ELSE                           !* Flux form 
    645             DO jj = 2, jpjm1 
    646                DO ji = 2, jpim1 
    647                   !                    ! hu_e, hv_e hold depth at jn,  zhup2_e, zhvp2_e hold extrapolated depth at jn+1/2 
    648                   !                    ! backward interpolated depth used in spg terms at jn+1/2 
    649                   zhu_bck = hu_0(ji,jj) + r1_2*r1_e1e2u(ji,jj) * (  e1e2t(ji  ,jj) * zsshp2_e(ji  ,jj)    & 
    650                        &                                          + e1e2t(ji+1,jj) * zsshp2_e(ji+1,jj)  ) * ssumask(ji,jj) 
    651                   zhv_bck = hv_0(ji,jj) + r1_2*r1_e1e2v(ji,jj) * (  e1e2t(ji,jj  ) * zsshp2_e(ji,jj  )    & 
    652                        &                                          + e1e2t(ji,jj+1) * zsshp2_e(ji,jj+1)  ) * ssvmask(ji,jj) 
    653                   !                    ! inverse depth at jn+1 
    654                   z1_hu = ssumask(ji,jj) / ( hu_0(ji,jj) + zsshu_a(ji,jj) + 1._wp - ssumask(ji,jj) ) 
    655                   z1_hv = ssvmask(ji,jj) / ( hv_0(ji,jj) + zsshv_a(ji,jj) + 1._wp - ssvmask(ji,jj) ) 
    656                   ! 
    657                   ua_e(ji,jj) = (               hu_e  (ji,jj) *   un_e (ji,jj)      &  
    658                        &            + rdtbt * (  zhu_bck        * zu_spg (ji,jj)  &   ! 
    659                        &                       + zhup2_e(ji,jj) * zu_trd (ji,jj)  &   ! 
    660                        &                       +  hu_n  (ji,jj) * zu_frc (ji,jj)  )   ) * z1_hu 
    661                   ! 
    662                   va_e(ji,jj) = (               hv_e  (ji,jj) *   vn_e (ji,jj)      & 
    663                        &            + rdtbt * (  zhv_bck        * zv_spg (ji,jj)  &   ! 
    664                        &                       + zhvp2_e(ji,jj) * zv_trd (ji,jj)  &   ! 
    665                        &                       +  hv_n  (ji,jj) * zv_frc (ji,jj)  )   ) * z1_hv 
    666                END DO 
    667             END DO 
     614            DO_2D_00_00 
     615               !                    ! hu_e, hv_e hold depth at jn,  zhup2_e, zhvp2_e hold extrapolated depth at jn+1/2 
     616               !                    ! backward interpolated depth used in spg terms at jn+1/2 
     617               zhu_bck = hu_0(ji,jj) + r1_2*r1_e1e2u(ji,jj) * (  e1e2t(ji  ,jj) * zsshp2_e(ji  ,jj)    & 
     618                    &                                          + e1e2t(ji+1,jj) * zsshp2_e(ji+1,jj)  ) * ssumask(ji,jj) 
     619               zhv_bck = hv_0(ji,jj) + r1_2*r1_e1e2v(ji,jj) * (  e1e2t(ji,jj  ) * zsshp2_e(ji,jj  )    & 
     620                    &                                          + e1e2t(ji,jj+1) * zsshp2_e(ji,jj+1)  ) * ssvmask(ji,jj) 
     621               !                    ! inverse depth at jn+1 
     622               z1_hu = ssumask(ji,jj) / ( hu_0(ji,jj) + zsshu_a(ji,jj) + 1._wp - ssumask(ji,jj) ) 
     623               z1_hv = ssvmask(ji,jj) / ( hv_0(ji,jj) + zsshv_a(ji,jj) + 1._wp - ssvmask(ji,jj) ) 
     624               ! 
     625               ua_e(ji,jj) = (               hu_e  (ji,jj) *   un_e (ji,jj)      &  
     626                    &            + rdtbt * (  zhu_bck        * zu_spg (ji,jj)  &   ! 
     627                    &                       + zhup2_e(ji,jj) * zu_trd (ji,jj)  &   ! 
     628                    &                       +  hu(ji,jj,Kmm) * zu_frc (ji,jj)  )   ) * z1_hu 
     629               ! 
     630               va_e(ji,jj) = (               hv_e  (ji,jj) *   vn_e (ji,jj)      & 
     631                    &            + rdtbt * (  zhv_bck        * zv_spg (ji,jj)  &   ! 
     632                    &                       + zhvp2_e(ji,jj) * zv_trd (ji,jj)  &   ! 
     633                    &                       +  hv(ji,jj,Kmm) * zv_frc (ji,jj)  )   ) * z1_hv 
     634            END_2D 
    668635         ENDIF 
    669636!jth implicit bottom friction: 
    670637         IF ( ll_wd ) THEN ! revert to explicit for bit comparison tests in non wad runs 
    671             DO jj = 2, jpjm1 
    672                DO ji = fs_2, fs_jpim1   ! vector opt. 
    673                      ua_e(ji,jj) =  ua_e(ji,jj) /(1.0 -   rdtbt * zCdU_u(ji,jj) * hur_e(ji,jj)) 
    674                      va_e(ji,jj) =  va_e(ji,jj) /(1.0 -   rdtbt * zCdU_v(ji,jj) * hvr_e(ji,jj)) 
    675                END DO 
    676             END DO 
     638            DO_2D_00_00 
     639                  ua_e(ji,jj) =  ua_e(ji,jj) /(1.0 -   rdtbt * zCdU_u(ji,jj) * hur_e(ji,jj)) 
     640                  va_e(ji,jj) =  va_e(ji,jj) /(1.0 -   rdtbt * zCdU_v(ji,jj) * hvr_e(ji,jj)) 
     641            END_2D 
    677642         ENDIF 
    678643        
    … …  
    713678         za1 = wgtbtp1(jn)                                     
    714679         IF( ln_dynadv_vec .OR. ln_linssh ) THEN    ! Sum velocities 
    715             ua_b  (:,:) = ua_b  (:,:) + za1 * ua_e  (:,:)  
    716             va_b  (:,:) = va_b  (:,:) + za1 * va_e  (:,:)  
     680            puu_b  (:,:,Kaa) = puu_b  (:,:,Kaa) + za1 * ua_e  (:,:)  
     681            pvv_b  (:,:,Kaa) = pvv_b  (:,:,Kaa) + za1 * va_e  (:,:)  
    717682         ELSE                                       ! Sum transports 
    718683            IF ( .NOT.ln_wd_dl ) THEN   
    719                ua_b  (:,:) = ua_b  (:,:) + za1 * ua_e  (:,:) * hu_e (:,:) 
    720                va_b  (:,:) = va_b  (:,:) + za1 * va_e  (:,:) * hv_e (:,:) 
     684               puu_b  (:,:,Kaa) = puu_b  (:,:,Kaa) + za1 * ua_e  (:,:) * hu_e (:,:) 
     685               pvv_b  (:,:,Kaa) = pvv_b  (:,:,Kaa) + za1 * va_e  (:,:) * hv_e (:,:) 
    721686            ELSE  
    722                ua_b  (:,:) = ua_b  (:,:) + za1 * ua_e  (:,:) * hu_e (:,:) * zuwdmask(:,:) 
    723                va_b  (:,:) = va_b  (:,:) + za1 * va_e  (:,:) * hv_e (:,:) * zvwdmask(:,:) 
     687               puu_b  (:,:,Kaa) = puu_b  (:,:,Kaa) + za1 * ua_e  (:,:) * hu_e (:,:) * zuwdmask(:,:) 
     688               pvv_b  (:,:,Kaa) = pvv_b  (:,:,Kaa) + za1 * va_e  (:,:) * hv_e (:,:) * zvwdmask(:,:) 
    724689            END IF  
    725690         ENDIF 
    726691         !                                          ! Sum sea level 
    727          ssha(:,:) = ssha(:,:) + za1 * ssha_e(:,:) 
     692         pssh(:,:,Kaa) = pssh(:,:,Kaa) + za1 * ssha_e(:,:) 
    728693 
    729694         !                                                 ! ==================== ! 
    … …  
    737702      IF (ln_bt_fw) THEN 
    738703         IF( .NOT.( kt == nit000 .AND. neuler==0 ) ) THEN 
    739             DO jj = 1, jpj 
    740                DO ji = 1, jpi 
    741                   zun_save = un_adv(ji,jj) 
    742                   zvn_save = vn_adv(ji,jj) 
    743                   !                          ! apply the previously computed correction  
    744                   un_adv(ji,jj) = r1_2 * ( ub2_b(ji,jj) + zun_save - atfp * un_bf(ji,jj) ) 
    745                   vn_adv(ji,jj) = r1_2 * ( vb2_b(ji,jj) + zvn_save - atfp * vn_bf(ji,jj) ) 
    746                   !                          ! Update corrective fluxes for next time step 
    747                   un_bf(ji,jj)  = atfp * un_bf(ji,jj) + ( zun_save - ub2_b(ji,jj) ) 
    748                   vn_bf(ji,jj)  = atfp * vn_bf(ji,jj) + ( zvn_save - vb2_b(ji,jj) ) 
    749                   !                          ! Save integrated transport for next computation 
    750                   ub2_b(ji,jj) = zun_save 
    751                   vb2_b(ji,jj) = zvn_save 
    752                END DO 
    753             END DO 
     704            DO_2D_11_11 
     705               zun_save = un_adv(ji,jj) 
     706               zvn_save = vn_adv(ji,jj) 
     707               !                          ! apply the previously computed correction  
     708               un_adv(ji,jj) = r1_2 * ( ub2_b(ji,jj) + zun_save - atfp * un_bf(ji,jj) ) 
     709               vn_adv(ji,jj) = r1_2 * ( vb2_b(ji,jj) + zvn_save - atfp * vn_bf(ji,jj) ) 
     710               !                          ! Update corrective fluxes for next time step 
     711               un_bf(ji,jj)  = atfp * un_bf(ji,jj) + ( zun_save - ub2_b(ji,jj) ) 
     712               vn_bf(ji,jj)  = atfp * vn_bf(ji,jj) + ( zvn_save - vb2_b(ji,jj) ) 
     713               !                          ! Save integrated transport for next computation 
     714               ub2_b(ji,jj) = zun_save 
     715               vb2_b(ji,jj) = zvn_save 
     716            END_2D 
    754717         ELSE 
    755718            un_bf(:,:) = 0._wp            ! corrective fluxes for next time step set to zero 
    … …  
    765728      IF( ln_dynadv_vec .OR. ln_linssh ) THEN 
    766729         DO jk=1,jpkm1 
    767             ua(:,:,jk) = ua(:,:,jk) + ( ua_b(:,:) - ub_b(:,:) ) * r1_2dt_b 
    768             va(:,:,jk) = va(:,:,jk) + ( va_b(:,:) - vb_b(:,:) ) * r1_2dt_b 
     730            puu(:,:,jk,Krhs) = puu(:,:,jk,Krhs) + ( puu_b(:,:,Kaa) - puu_b(:,:,Kbb) ) * r1_2dt_b 
     731            pvv(:,:,jk,Krhs) = pvv(:,:,jk,Krhs) + ( pvv_b(:,:,Kaa) - pvv_b(:,:,Kbb) ) * r1_2dt_b 
    769732         END DO 
    770733      ELSE 
    771          ! At this stage, ssha has been corrected: compute new depths at velocity points 
    772          DO jj = 1, jpjm1 
    773             DO ji = 1, jpim1      ! NO Vector Opt. 
    774                zsshu_a(ji,jj) = r1_2 * ssumask(ji,jj)  * r1_e1e2u(ji,jj) & 
    775                   &              * ( e1e2t(ji  ,jj) * ssha(ji  ,jj)      & 
    776                   &              +   e1e2t(ji+1,jj) * ssha(ji+1,jj) ) 
    777                zsshv_a(ji,jj) = r1_2 * ssvmask(ji,jj)  * r1_e1e2v(ji,jj) & 
    778                   &              * ( e1e2t(ji,jj  ) * ssha(ji,jj  )      & 
    779                   &              +   e1e2t(ji,jj+1) * ssha(ji,jj+1) ) 
    780             END DO 
    781          END DO 
     734         ! At this stage, pssh(:,:,:,Krhs) has been corrected: compute new depths at velocity points 
     735         DO_2D_10_10 
     736            zsshu_a(ji,jj) = r1_2 * ssumask(ji,jj)  * r1_e1e2u(ji,jj) & 
     737               &              * ( e1e2t(ji  ,jj) * pssh(ji  ,jj,Kaa)      & 
     738               &              +   e1e2t(ji+1,jj) * pssh(ji+1,jj,Kaa) ) 
     739            zsshv_a(ji,jj) = r1_2 * ssvmask(ji,jj)  * r1_e1e2v(ji,jj) & 
     740               &              * ( e1e2t(ji,jj  ) * pssh(ji,jj  ,Kaa)      & 
     741               &              +   e1e2t(ji,jj+1) * pssh(ji,jj+1,Kaa) ) 
     742         END_2D 
    782743         CALL lbc_lnk_multi( 'dynspg_ts', zsshu_a, 'U', 1._wp, zsshv_a, 'V', 1._wp ) ! Boundary conditions 
    783744         ! 
    784745         DO jk=1,jpkm1 
    785             ua(:,:,jk) = ua(:,:,jk) + r1_hu_n(:,:) * ( ua_b(:,:) - ub_b(:,:) * hu_b(:,:) ) * r1_2dt_b 
    786             va(:,:,jk) = va(:,:,jk) + r1_hv_n(:,:) * ( va_b(:,:) - vb_b(:,:) * hv_b(:,:) ) * r1_2dt_b 
     746            puu(:,:,jk,Krhs) = puu(:,:,jk,Krhs) + r1_hu(:,:,Kmm) * ( puu_b(:,:,Kaa) - puu_b(:,:,Kbb) * hu(:,:,Kbb) ) * r1_2dt_b 
     747            pvv(:,:,jk,Krhs) = pvv(:,:,jk,Krhs) + r1_hv(:,:,Kmm) * ( pvv_b(:,:,Kaa) - pvv_b(:,:,Kbb) * hv(:,:,Kbb) ) * r1_2dt_b 
    787748         END DO 
    788749         ! Save barotropic velocities not transport: 
    789          ua_b(:,:) =  ua_b(:,:) / ( hu_0(:,:) + zsshu_a(:,:) + 1._wp - ssumask(:,:) ) 
    790          va_b(:,:) =  va_b(:,:) / ( hv_0(:,:) + zsshv_a(:,:) + 1._wp - ssvmask(:,:) ) 
     750         puu_b(:,:,Kaa) =  puu_b(:,:,Kaa) / ( hu_0(:,:) + zsshu_a(:,:) + 1._wp - ssumask(:,:) ) 
     751         pvv_b(:,:,Kaa) =  pvv_b(:,:,Kaa) / ( hv_0(:,:) + zsshv_a(:,:) + 1._wp - ssvmask(:,:) ) 
    791752      ENDIF 
    792753 
    … …  
    794755      ! Correct velocities so that the barotropic velocity equals (un_adv, vn_adv) (in all cases)   
    795756      DO jk = 1, jpkm1 
    796          un(:,:,jk) = ( un(:,:,jk) + un_adv(:,:)*r1_hu_n(:,:) - un_b(:,:) ) * umask(:,:,jk) 
    797          vn(:,:,jk) = ( vn(:,:,jk) + vn_adv(:,:)*r1_hv_n(:,:) - vn_b(:,:) ) * vmask(:,:,jk) 
     757         puu(:,:,jk,Kmm) = ( puu(:,:,jk,Kmm) + un_adv(:,:)*r1_hu(:,:,Kmm) - puu_b(:,:,Kmm) ) * umask(:,:,jk) 
     758         pvv(:,:,jk,Kmm) = ( pvv(:,:,jk,Kmm) + vn_adv(:,:)*r1_hv(:,:,Kmm) - pvv_b(:,:,Kmm) ) * vmask(:,:,jk) 
    798759      END DO 
    799760 
    800761      IF ( ln_wd_dl .and. ln_wd_dl_bc) THEN  
    801          ! need to set lbc here because not done prior time averaging 
    802          CALL lbc_lnk_multi( 'dynspg_ts', zuwdav2, 'U', 1._wp, zvwdav2, 'V', 1._wp) 
    803762         DO jk = 1, jpkm1 
    804             un(:,:,jk) = ( un_adv(:,:)*r1_hu_n(:,:) & 
    805                        & + zuwdav2(:,:)*(un(:,:,jk) - un_adv(:,:)*r1_hu_n(:,:)) ) * umask(:,:,jk)  
    806             vn(:,:,jk) = ( vn_adv(:,:)*r1_hv_n(:,:) &  
    807                        & + zvwdav2(:,:)*(vn(:,:,jk) - vn_adv(:,:)*r1_hv_n(:,:)) ) * vmask(:,:,jk)   
     763            puu(:,:,jk,Kmm) = ( un_adv(:,:)*r1_hu(:,:,Kmm) & 
     764                       & + zuwdav2(:,:)*(puu(:,:,jk,Kmm) - un_adv(:,:)*r1_hu(:,:,Kmm)) ) * umask(:,:,jk)  
     765            pvv(:,:,jk,Kmm) = ( vn_adv(:,:)*r1_hv(:,:,Kmm) &  
     766                       & + zvwdav2(:,:)*(pvv(:,:,jk,Kmm) - vn_adv(:,:)*r1_hv(:,:,Kmm)) ) * vmask(:,:,jk)   
    808767         END DO 
    809768      END IF  
    810769 
    811770       
    812       CALL iom_put(  "ubar", un_adv(:,:)*r1_hu_n(:,:) )    ! barotropic i-current 
    813       CALL iom_put(  "vbar", vn_adv(:,:)*r1_hv_n(:,:) )    ! barotropic i-current 
     771      CALL iom_put(  "ubar", un_adv(:,:)*r1_hu(:,:,Kmm) )    ! barotropic i-current 
     772      CALL iom_put(  "vbar", vn_adv(:,:)*r1_hv(:,:,Kmm) )    ! barotropic i-current 
    814773      ! 
    815774#if defined key_agrif 
    … …  
    834793      IF( ln_wd_dl )   DEALLOCATE( ztwdmask, zuwdmask, zvwdmask, zuwdav2, zvwdav2 ) 
    835794      ! 
    836       CALL iom_put( "baro_u" , un_b )  ! Barotropic  U Velocity 
    837       CALL iom_put( "baro_v" , vn_b )  ! Barotropic  V Velocity 
     795      CALL iom_put( "baro_u" , puu_b(:,:,Kmm) )  ! Barotropic  U Velocity 
     796      CALL iom_put( "baro_v" , pvv_b(:,:,Kmm) )  ! Barotropic  V Velocity 
    838797      ! 
    839798   END SUBROUTINE dyn_spg_ts 
    … …  
    1002961      REAL(wp) ::   zxr2, zyr2, zcmax   ! local scalar 
    1003962      REAL(wp), DIMENSION(jpi,jpj) ::   zcu 
    1004       INTEGER  :: inum 
    1005963      !!---------------------------------------------------------------------- 
    1006964      ! 
    1007965      ! Max courant number for ext. grav. waves 
    1008966      ! 
    1009       DO jj = 1, jpj 
    1010          DO ji =1, jpi 
    1011             zxr2 = r1_e1t(ji,jj) * r1_e1t(ji,jj) 
    1012             zyr2 = r1_e2t(ji,jj) * r1_e2t(ji,jj) 
    1013             zcu(ji,jj) = SQRT( grav * MAX(ht_0(ji,jj),0._wp) * (zxr2 + zyr2) ) 
    1014          END DO 
    1015       END DO 
     967      DO_2D_11_11 
     968         zxr2 = r1_e1t(ji,jj) * r1_e1t(ji,jj) 
     969         zyr2 = r1_e2t(ji,jj) * r1_e2t(ji,jj) 
     970         zcu(ji,jj) = SQRT( grav * MAX(ht_0(ji,jj),0._wp) * (zxr2 + zyr2) ) 
     971      END_2D 
    1016972      ! 
    1017973      zcmax = MAXVAL( zcu(:,:) ) 
    … …  
    11101066 
    11111067    
    1112    SUBROUTINE dyn_cor_2d_init 
     1068   SUBROUTINE dyn_cor_2D_init( Kmm ) 
    11131069      !!--------------------------------------------------------------------- 
    1114       !!                   ***  ROUTINE dyn_cor_2d_init  *** 
     1070      !!                   ***  ROUTINE dyn_cor_2D_init  *** 
    11151071      !! 
    11161072      !! ** Purpose : Set time splitting options 
    … …  
    11241080      !! Compute zwz = f / ( height of the water colomn ) 
    11251081      !!---------------------------------------------------------------------- 
     1082      INTEGER,  INTENT(in)         ::  Kmm  ! Time index 
    11261083      INTEGER  ::   ji ,jj, jk              ! dummy loop indices 
    11271084      REAL(wp) ::   z1_ht 
    … …  
    11331090         SELECT CASE( nn_een_e3f )              !* ff_f/e3 at F-point 
    11341091         CASE ( 0 )                                   ! original formulation  (masked averaging of e3t divided by 4) 
    1135             DO jj = 1, jpjm1 
    1136                DO ji = 1, jpim1 
    1137                   zwz(ji,jj) =   ( ht_n(ji  ,jj+1) + ht_n(ji+1,jj+1) +                    & 
    1138                        &             ht_n(ji  ,jj  ) + ht_n(ji+1,jj  )   ) * 0.25_wp   
    1139                   IF( zwz(ji,jj) /= 0._wp )   zwz(ji,jj) = ff_f(ji,jj) / zwz(ji,jj) 
    1140                END DO 
    1141             END DO 
     1092            DO_2D_10_10 
     1093               zwz(ji,jj) =   ( ht(ji  ,jj+1) + ht(ji+1,jj+1) +                    & 
     1094                    &           ht(ji  ,jj  ) + ht(ji+1,jj  )   ) * 0.25_wp   
     1095               IF( zwz(ji,jj) /= 0._wp )   zwz(ji,jj) = ff_f(ji,jj) / zwz(ji,jj) 
     1096            END_2D 
    11421097         CASE ( 1 )                                   ! new formulation  (masked averaging of e3t divided by the sum of mask) 
    1143             DO jj = 1, jpjm1 
    1144                DO ji = 1, jpim1 
    1145                   zwz(ji,jj) =             (  ht_n  (ji  ,jj+1) + ht_n  (ji+1,jj+1)      & 
    1146                        &                      + ht_n  (ji  ,jj  ) + ht_n  (ji+1,jj  )  )   & 
    1147                        &       / ( MAX( 1._wp,  ssmask(ji  ,jj+1) + ssmask(ji+1,jj+1)      & 
    1148                        &                      + ssmask(ji  ,jj  ) + ssmask(ji+1,jj  )  )   ) 
    1149                   IF( zwz(ji,jj) /= 0._wp )   zwz(ji,jj) = ff_f(ji,jj) / zwz(ji,jj) 
    1150                END DO 
    1151             END DO 
     1098            DO_2D_10_10 
     1099               zwz(ji,jj) =             (  ht  (ji  ,jj+1) + ht  (ji+1,jj+1)      & 
     1100                    &                    + ht  (ji  ,jj  ) + ht  (ji+1,jj  )  )   & 
     1101                    &       / ( MAX( 1._wp,  ssmask(ji  ,jj+1) + ssmask(ji+1,jj+1)      & 
     1102                    &                      + ssmask(ji  ,jj  ) + ssmask(ji+1,jj  )  )   ) 
     1103               IF( zwz(ji,jj) /= 0._wp )   zwz(ji,jj) = ff_f(ji,jj) / zwz(ji,jj) 
     1104            END_2D 
    11521105         END SELECT 
    11531106         CALL lbc_lnk( 'dynspg_ts', zwz, 'F', 1._wp ) 
    11541107         ! 
    11551108         ftne(1,:) = 0._wp ; ftnw(1,:) = 0._wp ; ftse(1,:) = 0._wp ; ftsw(1,:) = 0._wp 
    1156          DO jj = 2, jpj 
    1157             DO ji = 2, jpi 
    1158                ftne(ji,jj) = zwz(ji-1,jj  ) + zwz(ji  ,jj  ) + zwz(ji  ,jj-1) 
    1159                ftnw(ji,jj) = zwz(ji-1,jj-1) + zwz(ji-1,jj  ) + zwz(ji  ,jj  ) 
    1160                ftse(ji,jj) = zwz(ji  ,jj  ) + zwz(ji  ,jj-1) + zwz(ji-1,jj-1) 
    1161                ftsw(ji,jj) = zwz(ji  ,jj-1) + zwz(ji-1,jj-1) + zwz(ji-1,jj  ) 
    1162             END DO 
    1163          END DO 
     1109         DO_2D_01_01 
     1110            ftne(ji,jj) = zwz(ji-1,jj  ) + zwz(ji  ,jj  ) + zwz(ji  ,jj-1) 
     1111            ftnw(ji,jj) = zwz(ji-1,jj-1) + zwz(ji-1,jj  ) + zwz(ji  ,jj  ) 
     1112            ftse(ji,jj) = zwz(ji  ,jj  ) + zwz(ji  ,jj-1) + zwz(ji-1,jj-1) 
     1113            ftsw(ji,jj) = zwz(ji  ,jj-1) + zwz(ji-1,jj-1) + zwz(ji-1,jj  ) 
     1114         END_2D 
    11641115         ! 
    11651116      CASE( np_EET )                  != EEN scheme using e3t (energy conserving scheme) 
    11661117         ftne(1,:) = 0._wp ; ftnw(1,:) = 0._wp ; ftse(1,:) = 0._wp ; ftsw(1,:) = 0._wp 
    1167          DO jj = 2, jpj 
    1168             DO ji = 2, jpi 
    1169                z1_ht = ssmask(ji,jj) / ( ht_n(ji,jj) + 1._wp - ssmask(ji,jj) ) 
    1170                ftne(ji,jj) = ( ff_f(ji-1,jj  ) + ff_f(ji  ,jj  ) + ff_f(ji  ,jj-1) ) * z1_ht 
    1171                ftnw(ji,jj) = ( ff_f(ji-1,jj-1) + ff_f(ji-1,jj  ) + ff_f(ji  ,jj  ) ) * z1_ht 
    1172                ftse(ji,jj) = ( ff_f(ji  ,jj  ) + ff_f(ji  ,jj-1) + ff_f(ji-1,jj-1) ) * z1_ht 
    1173                ftsw(ji,jj) = ( ff_f(ji  ,jj-1) + ff_f(ji-1,jj-1) + ff_f(ji-1,jj  ) ) * z1_ht 
    1174             END DO 
    1175          END DO 
     1118         DO_2D_01_01 
     1119            z1_ht = ssmask(ji,jj) / ( ht(ji,jj) + 1._wp - ssmask(ji,jj) ) 
     1120            ftne(ji,jj) = ( ff_f(ji-1,jj  ) + ff_f(ji  ,jj  ) + ff_f(ji  ,jj-1) ) * z1_ht 
     1121            ftnw(ji,jj) = ( ff_f(ji-1,jj-1) + ff_f(ji-1,jj  ) + ff_f(ji  ,jj  ) ) * z1_ht 
     1122            ftse(ji,jj) = ( ff_f(ji  ,jj  ) + ff_f(ji  ,jj-1) + ff_f(ji-1,jj-1) ) * z1_ht 
     1123            ftsw(ji,jj) = ( ff_f(ji  ,jj-1) + ff_f(ji-1,jj-1) + ff_f(ji-1,jj  ) ) * z1_ht 
     1124         END_2D 
    11761125         ! 
    11771126      CASE( np_ENE, np_ENS , np_MIX )  != all other schemes (ENE, ENS, MIX) except ENT ! 
    … …  
    12001149            ! 
    12011150            !zhf(:,:) = hbatf(:,:) 
    1202             DO jj = 1, jpjm1 
    1203                DO ji = 1, jpim1 
    1204                   zhf(ji,jj) =    (   ht_0  (ji,jj  ) + ht_0  (ji+1,jj  )          & 
    1205                        &            + ht_0  (ji,jj+1) + ht_0  (ji+1,jj+1)   )      & 
    1206                        &     / MAX(   ssmask(ji,jj  ) + ssmask(ji+1,jj  )          & 
    1207                        &            + ssmask(ji,jj+1) + ssmask(ji+1,jj+1) , 1._wp  ) 
    1208                END DO 
    1209             END DO 
     1151            DO_2D_10_10 
     1152               zhf(ji,jj) =    (   ht_0  (ji,jj  ) + ht_0  (ji+1,jj  )          & 
     1153                    &            + ht_0  (ji,jj+1) + ht_0  (ji+1,jj+1)   )      & 
     1154                    &     / MAX(   ssmask(ji,jj  ) + ssmask(ji+1,jj  )          & 
     1155                    &            + ssmask(ji,jj+1) + ssmask(ji+1,jj+1) , 1._wp  ) 
     1156            END_2D 
    12101157         ENDIF 
    12111158         ! 
    … …  
    12161163         DO jk = 1, jpkm1 
    12171164            DO jj = 1, jpjm1 
    1218                zhf(:,jj) = zhf(:,jj) + e3f_n(:,jj,jk) * umask(:,jj,jk) * umask(:,jj+1,jk) 
     1165               zhf(:,jj) = zhf(:,jj) + e3f(:,jj,jk) * umask(:,jj,jk) * umask(:,jj+1,jk) 
    12191166            END DO 
    12201167         END DO 
    12211168         CALL lbc_lnk( 'dynspg_ts', zhf, 'F', 1._wp ) 
    12221169         ! JC: TBC. hf should be greater than 0  
    1223          DO jj = 1, jpj 
    1224             DO ji = 1, jpi 
    1225                IF( zhf(ji,jj) /= 0._wp )   zwz(ji,jj) = 1._wp / zhf(ji,jj) 
    1226             END DO 
    1227          END DO 
     1170         DO_2D_11_11 
     1171            IF( zhf(ji,jj) /= 0._wp )   zwz(ji,jj) = 1._wp / zhf(ji,jj) 
     1172         END_2D 
    12281173         zwz(:,:) = ff_f(:,:) * zwz(:,:) 
    12291174      END SELECT 
    … …  
    12331178 
    12341179 
    1235    SUBROUTINE dyn_cor_2d( hu_n, hv_n, un_b, vn_b, zhU, zhV,    zu_trd, zv_trd   ) 
     1180   SUBROUTINE dyn_cor_2d( phu, phv, punb, pvnb, zhU, zhV,    zu_trd, zv_trd   ) 
    12361181      !!--------------------------------------------------------------------- 
    12371182      !!                   ***  ROUTINE dyn_cor_2d  *** 
    … …  
    12411186      INTEGER  ::   ji ,jj                             ! dummy loop indices 
    12421187      REAL(wp) ::   zx1, zx2, zy1, zy2, z1_hu, z1_hv   !   -      - 
    1243       REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) :: hu_n, hv_n, un_b, vn_b, zhU, zhV 
     1188      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) :: phu, phv, punb, pvnb, zhU, zhV 
    12441189      REAL(wp), DIMENSION(jpi,jpj), INTENT(  out) :: zu_trd, zv_trd 
    12451190      !!---------------------------------------------------------------------- 
    12461191      SELECT CASE( nvor_scheme ) 
    12471192      CASE( np_ENT )                ! enstrophy conserving scheme (f-point) 
    1248          DO jj = 2, jpjm1 
    1249             DO ji = 2, jpim1 
    1250                z1_hu = ssumask(ji,jj) / ( hu_n(ji,jj) + 1._wp - ssumask(ji,jj) ) 
    1251                z1_hv = ssvmask(ji,jj) / ( hv_n(ji,jj) + 1._wp - ssvmask(ji,jj) ) 
    1252                zu_trd(ji,jj) = + r1_4 * r1_e1e2u(ji,jj) * z1_hu                    & 
    1253                   &               * (  e1e2t(ji+1,jj)*ht_n(ji+1,jj)*ff_t(ji+1,jj) * ( vn_b(ji+1,jj) + vn_b(ji+1,jj-1) )   & 
    1254                   &                  + e1e2t(ji  ,jj)*ht_n(ji  ,jj)*ff_t(ji  ,jj) * ( vn_b(ji  ,jj) + vn_b(ji  ,jj-1) )   ) 
    1255                   ! 
    1256                zv_trd(ji,jj) = - r1_4 * r1_e1e2v(ji,jj) * z1_hv                    & 
    1257                   &               * (  e1e2t(ji,jj+1)*ht_n(ji,jj+1)*ff_t(ji,jj+1) * ( un_b(ji,jj+1) + un_b(ji-1,jj+1) )   &  
    1258                   &                  + e1e2t(ji,jj  )*ht_n(ji,jj  )*ff_t(ji,jj  ) * ( un_b(ji,jj  ) + un_b(ji-1,jj  ) )   )  
    1259             END DO   
    1260          END DO   
     1193         DO_2D_00_00 
     1194            z1_hu = ssumask(ji,jj) / ( phu(ji,jj) + 1._wp - ssumask(ji,jj) ) 
     1195            z1_hv = ssvmask(ji,jj) / ( phv(ji,jj) + 1._wp - ssvmask(ji,jj) ) 
     1196            zu_trd(ji,jj) = + r1_4 * r1_e1e2u(ji,jj) * z1_hu                    & 
     1197               &               * (  e1e2t(ji+1,jj)*ht(ji+1,jj)*ff_t(ji+1,jj) * ( pvnb(ji+1,jj) + pvnb(ji+1,jj-1) )   & 
     1198               &                  + e1e2t(ji  ,jj)*ht(ji  ,jj)*ff_t(ji  ,jj) * ( pvnb(ji  ,jj) + pvnb(ji  ,jj-1) )   ) 
     1199               ! 
     1200            zv_trd(ji,jj) = - r1_4 * r1_e1e2v(ji,jj) * z1_hv                    & 
     1201               &               * (  e1e2t(ji,jj+1)*ht(ji,jj+1)*ff_t(ji,jj+1) * ( punb(ji,jj+1) + punb(ji-1,jj+1) )   &  
     1202               &                  + e1e2t(ji,jj  )*ht(ji,jj  )*ff_t(ji,jj  ) * ( punb(ji,jj  ) + punb(ji-1,jj  ) )   )  
     1203         END_2D 
    12611204         !          
    12621205      CASE( np_ENE , np_MIX )        ! energy conserving scheme (t-point) ENE or MIX 
    1263          DO jj = 2, jpjm1 
    1264             DO ji = fs_2, fs_jpim1   ! vector opt. 
    1265                zy1 = ( zhV(ji,jj-1) + zhV(ji+1,jj-1) ) * r1_e1u(ji,jj) 
    1266                zy2 = ( zhV(ji,jj  ) + zhV(ji+1,jj  ) ) * r1_e1u(ji,jj) 
    1267                zx1 = ( zhU(ji-1,jj) + zhU(ji-1,jj+1) ) * r1_e2v(ji,jj) 
    1268                zx2 = ( zhU(ji  ,jj) + zhU(ji  ,jj+1) ) * r1_e2v(ji,jj) 
    1269                ! energy conserving formulation for planetary vorticity term 
    1270                zu_trd(ji,jj) =   r1_4 * ( zwz(ji  ,jj-1) * zy1 + zwz(ji,jj) * zy2 ) 
    1271                zv_trd(ji,jj) = - r1_4 * ( zwz(ji-1,jj  ) * zx1 + zwz(ji,jj) * zx2 ) 
    1272             END DO 
    1273          END DO 
     1206         DO_2D_00_00 
     1207            zy1 = ( zhV(ji,jj-1) + zhV(ji+1,jj-1) ) * r1_e1u(ji,jj) 
     1208            zy2 = ( zhV(ji,jj  ) + zhV(ji+1,jj  ) ) * r1_e1u(ji,jj) 
     1209            zx1 = ( zhU(ji-1,jj) + zhU(ji-1,jj+1) ) * r1_e2v(ji,jj) 
     1210            zx2 = ( zhU(ji  ,jj) + zhU(ji  ,jj+1) ) * r1_e2v(ji,jj) 
     1211            ! energy conserving formulation for planetary vorticity term 
     1212            zu_trd(ji,jj) =   r1_4 * ( zwz(ji  ,jj-1) * zy1 + zwz(ji,jj) * zy2 ) 
     1213            zv_trd(ji,jj) = - r1_4 * ( zwz(ji-1,jj  ) * zx1 + zwz(ji,jj) * zx2 ) 
     1214         END_2D 
    12741215         ! 
    12751216      CASE( np_ENS )                ! enstrophy conserving scheme (f-point) 
    1276          DO jj = 2, jpjm1 
    1277             DO ji = fs_2, fs_jpim1   ! vector opt. 
    1278                zy1 =   r1_8 * ( zhV(ji  ,jj-1) + zhV(ji+1,jj-1) & 
    1279                  &            + zhV(ji  ,jj  ) + zhV(ji+1,jj  ) ) * r1_e1u(ji,jj) 
    1280                zx1 = - r1_8 * ( zhU(ji-1,jj  ) + zhU(ji-1,jj+1) & 
    1281                  &            + zhU(ji  ,jj  ) + zhU(ji  ,jj+1) ) * r1_e2v(ji,jj) 
    1282                zu_trd(ji,jj)  = zy1 * ( zwz(ji  ,jj-1) + zwz(ji,jj) ) 
    1283                zv_trd(ji,jj)  = zx1 * ( zwz(ji-1,jj  ) + zwz(ji,jj) ) 
    1284             END DO 
    1285          END DO 
     1217         DO_2D_00_00 
     1218            zy1 =   r1_8 * ( zhV(ji  ,jj-1) + zhV(ji+1,jj-1) & 
     1219              &            + zhV(ji  ,jj  ) + zhV(ji+1,jj  ) ) * r1_e1u(ji,jj) 
     1220            zx1 = - r1_8 * ( zhU(ji-1,jj  ) + zhU(ji-1,jj+1) & 
     1221              &            + zhU(ji  ,jj  ) + zhU(ji  ,jj+1) ) * r1_e2v(ji,jj) 
     1222            zu_trd(ji,jj)  = zy1 * ( zwz(ji  ,jj-1) + zwz(ji,jj) ) 
     1223            zv_trd(ji,jj)  = zx1 * ( zwz(ji-1,jj  ) + zwz(ji,jj) ) 
     1224         END_2D 
    12861225         ! 
    12871226      CASE( np_EET , np_EEN )      ! energy & enstrophy scheme (using e3t or e3f)          
    1288          DO jj = 2, jpjm1 
    1289             DO ji = fs_2, fs_jpim1   ! vector opt. 
    1290                zu_trd(ji,jj) = + r1_12 * r1_e1u(ji,jj) * (  ftne(ji,jj  ) * zhV(ji  ,jj  ) & 
    1291                 &                                         + ftnw(ji+1,jj) * zhV(ji+1,jj  ) & 
    1292                 &                                         + ftse(ji,jj  ) * zhV(ji  ,jj-1) & 
    1293                 &                                         + ftsw(ji+1,jj) * zhV(ji+1,jj-1) ) 
    1294                zv_trd(ji,jj) = - r1_12 * r1_e2v(ji,jj) * (  ftsw(ji,jj+1) * zhU(ji-1,jj+1) & 
    1295                 &                                         + ftse(ji,jj+1) * zhU(ji  ,jj+1) & 
    1296                 &                                         + ftnw(ji,jj  ) * zhU(ji-1,jj  ) & 
    1297                 &                                         + ftne(ji,jj  ) * zhU(ji  ,jj  ) ) 
    1298             END DO 
    1299          END DO 
     1227         DO_2D_00_00 
     1228            zu_trd(ji,jj) = + r1_12 * r1_e1u(ji,jj) * (  ftne(ji,jj  ) * zhV(ji  ,jj  ) & 
     1229             &                                         + ftnw(ji+1,jj) * zhV(ji+1,jj  ) & 
     1230             &                                         + ftse(ji,jj  ) * zhV(ji  ,jj-1) & 
     1231             &                                         + ftsw(ji+1,jj) * zhV(ji+1,jj-1) ) 
     1232            zv_trd(ji,jj) = - r1_12 * r1_e2v(ji,jj) * (  ftsw(ji,jj+1) * zhU(ji-1,jj+1) & 
     1233             &                                         + ftse(ji,jj+1) * zhU(ji  ,jj+1) & 
     1234             &                                         + ftnw(ji,jj  ) * zhU(ji-1,jj  ) & 
     1235             &                                         + ftne(ji,jj  ) * zhU(ji  ,jj  ) ) 
     1236         END_2D 
    13001237         ! 
    13011238      END SELECT 
    … …  
    13221259      ! 
    13231260      IF( ln_wd_dl_rmp ) THEN      
    1324          DO jj = 1, jpj 
    1325             DO ji = 1, jpi                     
    1326                IF    ( pssh(ji,jj) + ht_0(ji,jj) >  2._wp * rn_wdmin1 ) THEN  
    1327                   !           IF    ( pssh(ji,jj) + ht_0(ji,jj) >          rn_wdmin2 ) THEN  
    1328                   ptmsk(ji,jj) = 1._wp 
    1329                ELSEIF( pssh(ji,jj) + ht_0(ji,jj) >          rn_wdmin1 ) THEN 
    1330                   ptmsk(ji,jj) = TANH( 50._wp*( ( pssh(ji,jj) + ht_0(ji,jj) -  rn_wdmin1 )*r_rn_wdmin1) ) 
    1331                ELSE  
    1332                   ptmsk(ji,jj) = 0._wp 
    1333                ENDIF 
    1334             END DO 
    1335          END DO 
     1261         DO_2D_11_11 
     1262            IF    ( pssh(ji,jj) + ht_0(ji,jj) >  2._wp * rn_wdmin1 ) THEN  
     1263               !           IF    ( pssh(ji,jj) + ht_0(ji,jj) >          rn_wdmin2 ) THEN  
     1264               ptmsk(ji,jj) = 1._wp 
     1265            ELSEIF( pssh(ji,jj) + ht_0(ji,jj) >          rn_wdmin1 ) THEN 
     1266               ptmsk(ji,jj) = TANH( 50._wp*( ( pssh(ji,jj) + ht_0(ji,jj) -  rn_wdmin1 )*r_rn_wdmin1) ) 
     1267            ELSE  
     1268               ptmsk(ji,jj) = 0._wp 
     1269            ENDIF 
     1270         END_2D 
    13361271      ELSE   
    1337          DO jj = 1, jpj 
    1338             DO ji = 1, jpi                               
    1339                IF ( pssh(ji,jj) + ht_0(ji,jj) >  rn_wdmin1 ) THEN   ;   ptmsk(ji,jj) = 1._wp 
    1340                ELSE                                                 ;   ptmsk(ji,jj) = 0._wp 
    1341                ENDIF 
    1342             END DO 
    1343          END DO 
     1272         DO_2D_11_11 
     1273            IF ( pssh(ji,jj) + ht_0(ji,jj) >  rn_wdmin1 ) THEN   ;   ptmsk(ji,jj) = 1._wp 
     1274            ELSE                                                 ;   ptmsk(ji,jj) = 0._wp 
     1275            ENDIF 
     1276         END_2D 
    13441277      ENDIF 
    13451278      ! 
    … …  
    13651298      !!---------------------------------------------------------------------- 
    13661299      ! 
    1367       DO jj = 1, jpj 
    1368          DO ji = 1, jpim1   ! not jpi-column 
    1369             IF ( phU(ji,jj) > 0._wp ) THEN   ;   pUmsk(ji,jj) = pTmsk(ji  ,jj)  
    1370             ELSE                             ;   pUmsk(ji,jj) = pTmsk(ji+1,jj)   
    1371             ENDIF 
    1372             phU(ji,jj) = pUmsk(ji,jj)*phU(ji,jj) 
    1373             pu (ji,jj) = pUmsk(ji,jj)*pu (ji,jj) 
    1374          END DO 
    1375       END DO 
    1376       ! 
    1377       DO jj = 1, jpjm1   ! not jpj-row 
    1378          DO ji = 1, jpi 
    1379             IF ( phV(ji,jj) > 0._wp ) THEN   ;   pVmsk(ji,jj) = pTmsk(ji,jj  ) 
    1380             ELSE                             ;   pVmsk(ji,jj) = pTmsk(ji,jj+1)   
    1381             ENDIF 
    1382             phV(ji,jj) = pVmsk(ji,jj)*phV(ji,jj)  
    1383             pv (ji,jj) = pVmsk(ji,jj)*pv (ji,jj) 
    1384          END DO 
    1385       END DO 
     1300      DO_2D_11_10 
     1301         IF ( phU(ji,jj) > 0._wp ) THEN   ;   pUmsk(ji,jj) = pTmsk(ji  ,jj)  
     1302         ELSE                             ;   pUmsk(ji,jj) = pTmsk(ji+1,jj)   
     1303         ENDIF 
     1304         phU(ji,jj) = pUmsk(ji,jj)*phU(ji,jj) 
     1305         pu (ji,jj) = pUmsk(ji,jj)*pu (ji,jj) 
     1306      END_2D 
     1307      ! 
     1308      DO_2D_10_11 
     1309         IF ( phV(ji,jj) > 0._wp ) THEN   ;   pVmsk(ji,jj) = pTmsk(ji,jj  ) 
     1310         ELSE                             ;   pVmsk(ji,jj) = pTmsk(ji,jj+1)   
     1311         ENDIF 
     1312         phV(ji,jj) = pVmsk(ji,jj)*phV(ji,jj)  
     1313         pv (ji,jj) = pVmsk(ji,jj)*pv (ji,jj) 
     1314      END_2D 
    13861315      ! 
    13871316   END SUBROUTINE wad_Umsk 
    13881317 
    13891318 
    1390    SUBROUTINE wad_spg( sshn, zcpx, zcpy ) 
     1319   SUBROUTINE wad_spg( pshn, zcpx, zcpy ) 
    13911320      !!--------------------------------------------------------------------- 
    13921321      !!                   ***  ROUTINE  wad_sp  *** 
    … …  
    13961325      INTEGER  ::   ji ,jj               ! dummy loop indices 
    13971326      LOGICAL  ::   ll_tmp1, ll_tmp2 
    1398       REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) :: sshn 
     1327      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) :: pshn 
    13991328      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: zcpx, zcpy 
    14001329      !!---------------------------------------------------------------------- 
    1401       DO jj = 2, jpjm1 
    1402          DO ji = 2, jpim1  
    1403             ll_tmp1 = MIN(  sshn(ji,jj)               ,  sshn(ji+1,jj) ) >                & 
    1404                  &      MAX( -ht_0(ji,jj)               , -ht_0(ji+1,jj) ) .AND.            & 
    1405                  &      MAX(  sshn(ji,jj) + ht_0(ji,jj) ,  sshn(ji+1,jj) + ht_0(ji+1,jj) )  & 
    1406                  &                                                         > rn_wdmin1 + rn_wdmin2 
    1407             ll_tmp2 = ( ABS( sshn(ji+1,jj)            -  sshn(ji  ,jj))  > 1.E-12 ).AND.( & 
    1408                  &      MAX(   sshn(ji,jj)              ,  sshn(ji+1,jj) ) >                & 
    1409                  &      MAX(  -ht_0(ji,jj)              , -ht_0(ji+1,jj) ) + rn_wdmin1 + rn_wdmin2 ) 
    1410             IF(ll_tmp1) THEN 
    1411                zcpx(ji,jj) = 1.0_wp 
    1412             ELSEIF(ll_tmp2) THEN 
    1413                ! no worries about  sshn(ji+1,jj) -  sshn(ji  ,jj) = 0, it won't happen ! here 
    1414                zcpx(ji,jj) = ABS( (sshn(ji+1,jj) + ht_0(ji+1,jj) - sshn(ji,jj) - ht_0(ji,jj)) & 
    1415                     &    / (sshn(ji+1,jj) - sshn(ji  ,jj)) ) 
    1416                zcpx(ji,jj) = max(min( zcpx(ji,jj) , 1.0_wp),0.0_wp) 
    1417             ELSE 
    1418                zcpx(ji,jj) = 0._wp 
    1419             ENDIF 
    1420             ! 
    1421             ll_tmp1 = MIN(  sshn(ji,jj)               ,  sshn(ji,jj+1) ) >                & 
    1422                  &      MAX( -ht_0(ji,jj)               , -ht_0(ji,jj+1) ) .AND.            & 
    1423                  &      MAX(  sshn(ji,jj) + ht_0(ji,jj) ,  sshn(ji,jj+1) + ht_0(ji,jj+1) )  & 
    1424                  &                                                       > rn_wdmin1 + rn_wdmin2 
    1425             ll_tmp2 = ( ABS( sshn(ji,jj)              -  sshn(ji,jj+1))  > 1.E-12 ).AND.( & 
    1426                  &      MAX(   sshn(ji,jj)              ,  sshn(ji,jj+1) ) >                & 
    1427                  &      MAX(  -ht_0(ji,jj)              , -ht_0(ji,jj+1) ) + rn_wdmin1 + rn_wdmin2 ) 
    1428              
    1429             IF(ll_tmp1) THEN 
    1430                zcpy(ji,jj) = 1.0_wp 
    1431             ELSE IF(ll_tmp2) THEN 
    1432                ! no worries about  sshn(ji,jj+1) -  sshn(ji,jj  ) = 0, it won't happen ! here 
    1433                zcpy(ji,jj) = ABS( (sshn(ji,jj+1) + ht_0(ji,jj+1) - sshn(ji,jj) - ht_0(ji,jj)) & 
    1434                     &             / (sshn(ji,jj+1) - sshn(ji,jj  )) ) 
    1435                zcpy(ji,jj) = MAX(  0._wp , MIN( zcpy(ji,jj) , 1.0_wp )  ) 
    1436             ELSE 
    1437                zcpy(ji,jj) = 0._wp 
    1438             ENDIF 
    1439          END DO 
    1440       END DO 
     1330      DO_2D_00_00 
     1331         ll_tmp1 = MIN(  pshn(ji,jj)               ,  pshn(ji+1,jj) ) >                & 
     1332              &      MAX( -ht_0(ji,jj)               , -ht_0(ji+1,jj) ) .AND.            & 
     1333              &      MAX(  pshn(ji,jj) + ht_0(ji,jj) ,  pshn(ji+1,jj) + ht_0(ji+1,jj) )  & 
     1334              &                                                         > rn_wdmin1 + rn_wdmin2 
     1335         ll_tmp2 = ( ABS( pshn(ji+1,jj)            -  pshn(ji  ,jj))  > 1.E-12 ).AND.( & 
     1336              &      MAX(   pshn(ji,jj)              ,  pshn(ji+1,jj) ) >                & 
     1337              &      MAX(  -ht_0(ji,jj)              , -ht_0(ji+1,jj) ) + rn_wdmin1 + rn_wdmin2 ) 
     1338         IF(ll_tmp1) THEN 
     1339            zcpx(ji,jj) = 1.0_wp 
     1340         ELSEIF(ll_tmp2) THEN 
     1341            ! no worries about  pshn(ji+1,jj) -  pshn(ji  ,jj) = 0, it won't happen ! here 
     1342            zcpx(ji,jj) = ABS( (pshn(ji+1,jj) + ht_0(ji+1,jj) - pshn(ji,jj) - ht_0(ji,jj)) & 
     1343                 &           / (pshn(ji+1,jj) - pshn(ji  ,jj)) ) 
     1344            zcpx(ji,jj) = max(min( zcpx(ji,jj) , 1.0_wp),0.0_wp) 
     1345         ELSE 
     1346            zcpx(ji,jj) = 0._wp 
     1347         ENDIF 
     1348         ! 
     1349         ll_tmp1 = MIN(  pshn(ji,jj)               ,  pshn(ji,jj+1) ) >                & 
     1350              &      MAX( -ht_0(ji,jj)               , -ht_0(ji,jj+1) ) .AND.            & 
     1351              &      MAX(  pshn(ji,jj) + ht_0(ji,jj) ,  pshn(ji,jj+1) + ht_0(ji,jj+1) )  & 
     1352              &                                                       > rn_wdmin1 + rn_wdmin2 
     1353         ll_tmp2 = ( ABS( pshn(ji,jj)              -  pshn(ji,jj+1))  > 1.E-12 ).AND.( & 
     1354              &      MAX(   pshn(ji,jj)              ,  pshn(ji,jj+1) ) >                & 
     1355              &      MAX(  -ht_0(ji,jj)              , -ht_0(ji,jj+1) ) + rn_wdmin1 + rn_wdmin2 ) 
     1356          
     1357         IF(ll_tmp1) THEN 
     1358            zcpy(ji,jj) = 1.0_wp 
     1359         ELSE IF(ll_tmp2) THEN 
     1360            ! no worries about  pshn(ji,jj+1) -  pshn(ji,jj  ) = 0, it won't happen ! here 
     1361            zcpy(ji,jj) = ABS( (pshn(ji,jj+1) + ht_0(ji,jj+1) - pshn(ji,jj) - ht_0(ji,jj)) & 
     1362                 &           / (pshn(ji,jj+1) - pshn(ji,jj  )) ) 
     1363            zcpy(ji,jj) = MAX(  0._wp , MIN( zcpy(ji,jj) , 1.0_wp )  ) 
     1364         ELSE 
     1365            zcpy(ji,jj) = 0._wp 
     1366         ENDIF 
     1367      END_2D 
    14411368             
    14421369   END SUBROUTINE wad_spg 
    … …  
    14441371 
    14451372 
    1446    SUBROUTINE dyn_drg_init( pu_RHSi, pv_RHSi, pCdU_u, pCdU_v ) 
     1373   SUBROUTINE dyn_drg_init( Kbb, Kmm, puu, pvv, puu_b ,pvv_b, pu_RHSi, pv_RHSi, pCdU_u, pCdU_v ) 
    14471374      !!---------------------------------------------------------------------- 
    14481375      !!                  ***  ROUTINE dyn_drg_init  *** 
    … …  
    14541381      !! ** Method  :   computation done over the INNER domain only  
    14551382      !!---------------------------------------------------------------------- 
    1456       REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   pu_RHSi, pv_RHSi   ! baroclinic part of the barotropic RHS 
    1457       REAL(wp), DIMENSION(jpi,jpj), INTENT(  out) ::   pCdU_u , pCdU_v    ! barotropic drag coefficients 
     1383      INTEGER                             , INTENT(in   ) ::  Kbb, Kmm           ! ocean time level indices 
     1384      REAL(wp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(in   ) ::  puu, pvv           ! ocean velocities and RHS of momentum equation 
     1385      REAL(wp), DIMENSION(jpi,jpj,jpt)    , INTENT(in   ) ::  puu_b, pvv_b       ! barotropic velocities at main time levels 
     1386      REAL(wp), DIMENSION(jpi,jpj)        , INTENT(inout) ::  pu_RHSi, pv_RHSi   ! baroclinic part of the barotropic RHS 
     1387      REAL(wp), DIMENSION(jpi,jpj)        , INTENT(  out) ::  pCdU_u , pCdU_v    ! barotropic drag coefficients 
    14581388      ! 
    14591389      INTEGER  ::   ji, jj   ! dummy loop indices 
    … …  
    14671397      IF( ln_isfcav ) THEN          ! top+bottom friction (ocean cavities) 
    14681398          
    1469          DO jj = 2, jpjm1 
    1470             DO ji = 2, jpim1     ! INNER domain 
    1471                pCdU_u(ji,jj) = r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) + rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) 
    1472                pCdU_v(ji,jj) = r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) + rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) 
    1473             END DO 
    1474          END DO 
     1399         DO_2D_00_00 
     1400            pCdU_u(ji,jj) = r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) + rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) 
     1401            pCdU_v(ji,jj) = r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) + rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) 
     1402         END_2D 
    14751403      ELSE                          ! bottom friction only 
    1476          DO jj = 2, jpjm1 
    1477             DO ji = 2, jpim1  ! INNER domain 
    1478                pCdU_u(ji,jj) = r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) 
    1479                pCdU_v(ji,jj) = r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) 
    1480             END DO 
    1481          END DO 
     1404         DO_2D_00_00 
     1405            pCdU_u(ji,jj) = r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) 
     1406            pCdU_v(ji,jj) = r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) 
     1407         END_2D 
    14821408      ENDIF 
    14831409      ! 
    … …  
    14861412      IF( ln_bt_fw ) THEN                 ! FORWARD integration: use NOW bottom baroclinic velocities 
    14871413          
    1488          DO jj = 2, jpjm1 
    1489             DO ji = 2, jpim1  ! INNER domain 
    1490                ikbu = mbku(ji,jj)        
    1491                ikbv = mbkv(ji,jj)     
    1492                zu_i(ji,jj) = un(ji,jj,ikbu) - un_b(ji,jj) 
    1493                zv_i(ji,jj) = vn(ji,jj,ikbv) - vn_b(ji,jj) 
    1494             END DO 
    1495          END DO 
     1414         DO_2D_00_00 
     1415            ikbu = mbku(ji,jj)        
     1416            ikbv = mbkv(ji,jj)     
     1417            zu_i(ji,jj) = puu(ji,jj,ikbu,Kmm) - puu_b(ji,jj,Kmm) 
     1418            zv_i(ji,jj) = pvv(ji,jj,ikbv,Kmm) - pvv_b(ji,jj,Kmm) 
     1419         END_2D 
    14961420      ELSE                                ! CENTRED integration: use BEFORE bottom baroclinic velocities 
    14971421          
    1498          DO jj = 2, jpjm1 
    1499             DO ji = 2, jpim1   ! INNER domain 
    1500                ikbu = mbku(ji,jj)        
    1501                ikbv = mbkv(ji,jj)     
    1502                zu_i(ji,jj) = ub(ji,jj,ikbu) - ub_b(ji,jj) 
    1503                zv_i(ji,jj) = vb(ji,jj,ikbv) - vb_b(ji,jj) 
    1504             END DO 
    1505          END DO 
     1422         DO_2D_00_00 
     1423            ikbu = mbku(ji,jj)        
     1424            ikbv = mbkv(ji,jj)     
     1425            zu_i(ji,jj) = puu(ji,jj,ikbu,Kbb) - puu_b(ji,jj,Kbb) 
     1426            zv_i(ji,jj) = pvv(ji,jj,ikbv,Kbb) - pvv_b(ji,jj,Kbb) 
     1427         END_2D 
    15061428      ENDIF 
    15071429      ! 
    15081430      IF( ln_wd_il ) THEN      ! W/D : use the "clipped" bottom friction   !!gm   explain WHY, please ! 
    15091431         zztmp = -1._wp / rdtbt 
    1510          DO jj = 2, jpjm1 
    1511             DO ji = 2, jpim1    ! INNER domain 
    1512                pu_RHSi(ji,jj) = pu_RHSi(ji,jj) + zu_i(ji,jj) *  wdrampu(ji,jj) * MAX(                                 &  
    1513                     &                              r1_hu_n(ji,jj) * r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) , zztmp  ) 
    1514                pv_RHSi(ji,jj) = pv_RHSi(ji,jj) + zv_i(ji,jj) *  wdrampv(ji,jj) * MAX(                                 &  
    1515                     &                              r1_hv_n(ji,jj) * r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) , zztmp  ) 
    1516             END DO 
    1517          END DO 
     1432         DO_2D_00_00 
     1433            pu_RHSi(ji,jj) = pu_RHSi(ji,jj) + zu_i(ji,jj) *  wdrampu(ji,jj) * MAX(                                 &  
     1434                 &                              r1_hu(ji,jj,Kmm) * r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) , zztmp  ) 
     1435            pv_RHSi(ji,jj) = pv_RHSi(ji,jj) + zv_i(ji,jj) *  wdrampv(ji,jj) * MAX(                                 &  
     1436                 &                              r1_hv(ji,jj,Kmm) * r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) , zztmp  ) 
     1437         END_2D 
    15181438      ELSE                    ! use "unclipped" drag (even if explicit friction is used in 3D calculation) 
    15191439          
    1520          DO jj = 2, jpjm1 
    1521             DO ji = 2, jpim1    ! INNER domain 
    1522                pu_RHSi(ji,jj) = pu_RHSi(ji,jj) + r1_hu_n(ji,jj) * r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) * zu_i(ji,jj) 
    1523                pv_RHSi(ji,jj) = pv_RHSi(ji,jj) + r1_hv_n(ji,jj) * r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) * zv_i(ji,jj) 
    1524             END DO 
    1525          END DO 
     1440         DO_2D_00_00 
     1441            pu_RHSi(ji,jj) = pu_RHSi(ji,jj) + r1_hu(ji,jj,Kmm) * r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) * zu_i(ji,jj) 
     1442            pv_RHSi(ji,jj) = pv_RHSi(ji,jj) + r1_hv(ji,jj,Kmm) * r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) * zv_i(ji,jj) 
     1443         END_2D 
    15261444      END IF 
    15271445      ! 
    … …  
    15321450         IF( ln_bt_fw ) THEN                ! FORWARD integration: use NOW top baroclinic velocity 
    15331451             
    1534             DO jj = 2, jpjm1 
    1535                DO ji = 2, jpim1   ! INNER domain 
    1536                   iktu = miku(ji,jj) 
    1537                   iktv = mikv(ji,jj) 
    1538                   zu_i(ji,jj) = un(ji,jj,iktu) - un_b(ji,jj) 
    1539                   zv_i(ji,jj) = vn(ji,jj,iktv) - vn_b(ji,jj) 
    1540                END DO 
    1541             END DO 
     1452            DO_2D_00_00 
     1453               iktu = miku(ji,jj) 
     1454               iktv = mikv(ji,jj) 
     1455               zu_i(ji,jj) = puu(ji,jj,iktu,Kmm) - puu_b(ji,jj,Kmm) 
     1456               zv_i(ji,jj) = pvv(ji,jj,iktv,Kmm) - pvv_b(ji,jj,Kmm) 
     1457            END_2D 
    15421458         ELSE                                ! CENTRED integration: use BEFORE top baroclinic velocity 
    15431459             
    1544             DO jj = 2, jpjm1 
    1545                DO ji = 2, jpim1      ! INNER domain 
    1546                   iktu = miku(ji,jj) 
    1547                   iktv = mikv(ji,jj) 
    1548                   zu_i(ji,jj) = ub(ji,jj,iktu) - ub_b(ji,jj) 
    1549                   zv_i(ji,jj) = vb(ji,jj,iktv) - vb_b(ji,jj) 
    1550                END DO 
    1551             END DO 
     1460            DO_2D_00_00 
     1461               iktu = miku(ji,jj) 
     1462               iktv = mikv(ji,jj) 
     1463               zu_i(ji,jj) = puu(ji,jj,iktu,Kbb) - puu_b(ji,jj,Kbb) 
     1464               zv_i(ji,jj) = pvv(ji,jj,iktv,Kbb) - pvv_b(ji,jj,Kbb) 
     1465            END_2D 
    15521466         ENDIF 
    15531467         ! 
    15541468         !                    ! use "unclipped" top drag (even if explicit friction is used in 3D calculation) 
    15551469          
    1556          DO jj = 2, jpjm1 
    1557             DO ji = 2, jpim1    ! INNER domain 
    1558                pu_RHSi(ji,jj) = pu_RHSi(ji,jj) + r1_hu_n(ji,jj) * r1_2*( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) * zu_i(ji,jj) 
    1559                pv_RHSi(ji,jj) = pv_RHSi(ji,jj) + r1_hv_n(ji,jj) * r1_2*( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) * zv_i(ji,jj) 
    1560             END DO 
    1561          END DO 
     1470         DO_2D_00_00 
     1471            pu_RHSi(ji,jj) = pu_RHSi(ji,jj) + r1_hu(ji,jj,Kmm) * r1_2*( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) * zu_i(ji,jj) 
     1472            pv_RHSi(ji,jj) = pv_RHSi(ji,jj) + r1_hv(ji,jj,Kmm) * r1_2*( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) * zv_i(ji,jj) 
     1473         END_2D 
    15621474         ! 
    15631475      ENDIF 

  • NEMO/trunk/src/OCE/DYN/dynvor.F90

    r11536 r12377  
    8888    
    8989   !! * Substitutions 
    90 #  include "vectopt_loop_substitute.h90" 
     90#  include "do_loop_substitute.h90" 
    9191   !!---------------------------------------------------------------------- 
    9292   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    9696CONTAINS 
    9797 
    98    SUBROUTINE dyn_vor( kt ) 
     98   SUBROUTINE dyn_vor( kt, Kmm, puu, pvv, Krhs ) 
    9999      !!---------------------------------------------------------------------- 
    100100      !! 
    101101      !! ** Purpose :   compute the lateral ocean tracer physics. 
    102102      !! 
    103       !! ** Action : - Update (ua,va) with the now vorticity term trend 
     103      !! ** Action : - Update (puu(:,:,:,Krhs),pvv(:,:,:,Krhs)) with the now vorticity term trend 
    104104      !!             - save the trends in (ztrdu,ztrdv) in 2 parts (relative 
    105105      !!               and planetary vorticity trends) and send them to trd_dyn  
    106106      !!               for futher diagnostics (l_trddyn=T) 
    107107      !!---------------------------------------------------------------------- 
    108       INTEGER, INTENT( in ) ::   kt   ! ocean time-step index 
     108      INTEGER                             , INTENT( in  ) ::   kt          ! ocean time-step index 
     109      INTEGER                             , INTENT( in  ) ::   Kmm, Krhs   ! ocean time level indices 
     110      REAL(wp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) ::   puu, pvv    ! ocean velocity field and RHS of momentum equation 
    109111      ! 
    110112      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::  ztrdu, ztrdv 
    … …  
    117119         ALLOCATE( ztrdu(jpi,jpj,jpk), ztrdv(jpi,jpj,jpk) ) 
    118120         ! 
    119          ztrdu(:,:,:) = ua(:,:,:)            !* planetary vorticity trend (including Stokes-Coriolis force) 
    120          ztrdv(:,:,:) = va(:,:,:) 
     121         ztrdu(:,:,:) = puu(:,:,:,Krhs)            !* planetary vorticity trend (including Stokes-Coriolis force) 
     122         ztrdv(:,:,:) = pvv(:,:,:,Krhs) 
    121123         SELECT CASE( nvor_scheme ) 
    122          CASE( np_ENS )           ;   CALL vor_ens( kt, ncor, un , vn , ua, va )   ! enstrophy conserving scheme 
    123             IF( ln_stcor )            CALL vor_ens( kt, ncor, usd, vsd, ua, va )   ! add the Stokes-Coriolis trend 
    124          CASE( np_ENE, np_MIX )   ;   CALL vor_ene( kt, ncor, un , vn , ua, va )   ! energy conserving scheme 
    125             IF( ln_stcor )            CALL vor_ene( kt, ncor, usd, vsd, ua, va )   ! add the Stokes-Coriolis trend 
    126          CASE( np_ENT )           ;   CALL vor_enT( kt, ncor, un , vn , ua, va )   ! energy conserving scheme (T-pts) 
    127             IF( ln_stcor )            CALL vor_enT( kt, ncor, usd, vsd, ua, va )   ! add the Stokes-Coriolis trend 
    128          CASE( np_EET )           ;   CALL vor_eeT( kt, ncor, un , vn , ua, va )   ! energy conserving scheme (een with e3t) 
    129             IF( ln_stcor )            CALL vor_eeT( kt, ncor, usd, vsd, ua, va )   ! add the Stokes-Coriolis trend 
    130          CASE( np_EEN )           ;   CALL vor_een( kt, ncor, un , vn , ua, va )   ! energy & enstrophy scheme 
    131             IF( ln_stcor )            CALL vor_een( kt, ncor, usd, vsd, ua, va )   ! add the Stokes-Coriolis trend 
     124         CASE( np_ENS )           ;   CALL vor_ens( kt, Kmm, ncor, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )   ! enstrophy conserving scheme 
     125            IF( ln_stcor )            CALL vor_ens( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )   ! add the Stokes-Coriolis trend 
     126         CASE( np_ENE, np_MIX )   ;   CALL vor_ene( kt, Kmm, ncor, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )   ! energy conserving scheme 
     127            IF( ln_stcor )            CALL vor_ene( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )   ! add the Stokes-Coriolis trend 
     128         CASE( np_ENT )           ;   CALL vor_enT( kt, Kmm, ncor, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )   ! energy conserving scheme (T-pts) 
     129            IF( ln_stcor )            CALL vor_enT( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )   ! add the Stokes-Coriolis trend 
     130         CASE( np_EET )           ;   CALL vor_eeT( kt, Kmm, ncor, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )   ! energy conserving scheme (een with e3t) 
     131            IF( ln_stcor )            CALL vor_eeT( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )   ! add the Stokes-Coriolis trend 
     132         CASE( np_EEN )           ;   CALL vor_een( kt, Kmm, ncor, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )   ! energy & enstrophy scheme 
     133            IF( ln_stcor )            CALL vor_een( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )   ! add the Stokes-Coriolis trend 
    132134         END SELECT 
    133          ztrdu(:,:,:) = ua(:,:,:) - ztrdu(:,:,:) 
    134          ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:) 
    135          CALL trd_dyn( ztrdu, ztrdv, jpdyn_pvo, kt ) 
     135         ztrdu(:,:,:) = puu(:,:,:,Krhs) - ztrdu(:,:,:) 
     136         ztrdv(:,:,:) = pvv(:,:,:,Krhs) - ztrdv(:,:,:) 
     137         CALL trd_dyn( ztrdu, ztrdv, jpdyn_pvo, kt, Kmm ) 
    136138         ! 
    137139         IF( n_dynadv /= np_LIN_dyn ) THEN   !* relative vorticity or metric trend (only in non-linear case) 
    138             ztrdu(:,:,:) = ua(:,:,:) 
    139             ztrdv(:,:,:) = va(:,:,:) 
     140            ztrdu(:,:,:) = puu(:,:,:,Krhs) 
     141            ztrdv(:,:,:) = pvv(:,:,:,Krhs) 
    140142            SELECT CASE( nvor_scheme ) 
    141             CASE( np_ENT )           ;   CALL vor_enT( kt, nrvm, un , vn , ua, va )  ! energy conserving scheme (T-pts) 
    142             CASE( np_EET )           ;   CALL vor_eeT( kt, nrvm, un , vn , ua, va )  ! energy conserving scheme (een with e3t) 
    143             CASE( np_ENE )           ;   CALL vor_ene( kt, nrvm, un , vn , ua, va )  ! energy conserving scheme 
    144             CASE( np_ENS, np_MIX )   ;   CALL vor_ens( kt, nrvm, un , vn , ua, va )  ! enstrophy conserving scheme 
    145             CASE( np_EEN )           ;   CALL vor_een( kt, nrvm, un , vn , ua, va )  ! energy & enstrophy scheme 
     143            CASE( np_ENT )           ;   CALL vor_enT( kt, Kmm, nrvm, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )  ! energy conserving scheme (T-pts) 
     144            CASE( np_EET )           ;   CALL vor_eeT( kt, Kmm, nrvm, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )  ! energy conserving scheme (een with e3t) 
     145            CASE( np_ENE )           ;   CALL vor_ene( kt, Kmm, nrvm, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )  ! energy conserving scheme 
     146            CASE( np_ENS, np_MIX )   ;   CALL vor_ens( kt, Kmm, nrvm, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )  ! enstrophy conserving scheme 
     147            CASE( np_EEN )           ;   CALL vor_een( kt, Kmm, nrvm, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )  ! energy & enstrophy scheme 
    146148            END SELECT 
    147             ztrdu(:,:,:) = ua(:,:,:) - ztrdu(:,:,:) 
    148             ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:) 
    149             CALL trd_dyn( ztrdu, ztrdv, jpdyn_rvo, kt ) 
     149            ztrdu(:,:,:) = puu(:,:,:,Krhs) - ztrdu(:,:,:) 
     150            ztrdv(:,:,:) = pvv(:,:,:,Krhs) - ztrdv(:,:,:) 
     151            CALL trd_dyn( ztrdu, ztrdv, jpdyn_rvo, kt, Kmm ) 
    150152         ENDIF 
    151153         ! 
    … …  
    156158         SELECT CASE ( nvor_scheme )      !==  vorticity trend added to the general trend  ==! 
    157159         CASE( np_ENT )                        !* energy conserving scheme  (T-pts) 
    158                              CALL vor_enT( kt, ntot, un , vn , ua, va )   ! total vorticity trend 
    159             IF( ln_stcor )   CALL vor_enT( kt, ncor, usd, vsd, ua, va )   ! add the Stokes-Coriolis trend 
     160                             CALL vor_enT( kt, Kmm, ntot, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )   ! total vorticity trend 
     161            IF( ln_stcor )   CALL vor_enT( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )   ! add the Stokes-Coriolis trend 
    160162         CASE( np_EET )                        !* energy conserving scheme (een scheme using e3t) 
    161                              CALL vor_eeT( kt, ntot, un , vn , ua, va )   ! total vorticity trend 
    162             IF( ln_stcor )   CALL vor_eeT( kt, ncor, usd, vsd, ua, va )   ! add the Stokes-Coriolis trend 
     163                             CALL vor_eeT( kt, Kmm, ntot, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )   ! total vorticity trend 
     164            IF( ln_stcor )   CALL vor_eeT( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )   ! add the Stokes-Coriolis trend 
    163165         CASE( np_ENE )                        !* energy conserving scheme 
    164                              CALL vor_ene( kt, ntot, un , vn , ua, va )   ! total vorticity trend 
    165             IF( ln_stcor )   CALL vor_ene( kt, ncor, usd, vsd, ua, va )   ! add the Stokes-Coriolis trend 
     166                             CALL vor_ene( kt, Kmm, ntot, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )   ! total vorticity trend 
     167            IF( ln_stcor )   CALL vor_ene( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )   ! add the Stokes-Coriolis trend 
    166168         CASE( np_ENS )                        !* enstrophy conserving scheme 
    167                              CALL vor_ens( kt, ntot, un , vn , ua, va )  ! total vorticity trend 
    168             IF( ln_stcor )   CALL vor_ens( kt, ncor, usd, vsd, ua, va )  ! add the Stokes-Coriolis trend 
     169                             CALL vor_ens( kt, Kmm, ntot, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )  ! total vorticity trend 
     170            IF( ln_stcor )   CALL vor_ens( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )  ! add the Stokes-Coriolis trend 
    169171         CASE( np_MIX )                        !* mixed ene-ens scheme 
    170                              CALL vor_ens( kt, nrvm, un , vn , ua, va )   ! relative vorticity or metric trend (ens) 
    171                              CALL vor_ene( kt, ncor, un , vn , ua, va )   ! planetary vorticity trend (ene) 
    172             IF( ln_stcor )   CALL vor_ene( kt, ncor, usd, vsd, ua, va )   ! add the Stokes-Coriolis trend 
     172                             CALL vor_ens( kt, Kmm, nrvm, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )   ! relative vorticity or metric trend (ens) 
     173                             CALL vor_ene( kt, Kmm, ncor, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )   ! planetary vorticity trend (ene) 
     174            IF( ln_stcor )   CALL vor_ene( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )   ! add the Stokes-Coriolis trend 
    173175         CASE( np_EEN )                        !* energy and enstrophy conserving scheme 
    174                              CALL vor_een( kt, ntot, un , vn , ua, va )   ! total vorticity trend 
    175             IF( ln_stcor )   CALL vor_een( kt, ncor, usd, vsd, ua, va )   ! add the Stokes-Coriolis trend 
     176                             CALL vor_een( kt, Kmm, ntot, puu(:,:,:,Kmm) , pvv(:,:,:,Kmm) , puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )   ! total vorticity trend 
     177            IF( ln_stcor )   CALL vor_een( kt, Kmm, ncor, usd, vsd, puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )   ! add the Stokes-Coriolis trend 
    176178         END SELECT 
    177179         ! 
    … …  
    179181      ! 
    180182      !                       ! print sum trends (used for debugging) 
    181       IF(ln_ctl) CALL prt_ctl( tab3d_1=ua, clinfo1=' vor  - Ua: ', mask1=umask,               & 
    182          &                     tab3d_2=va, clinfo2=       ' Va: ', mask2=vmask, clinfo3='dyn' ) 
     183      IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=puu(:,:,:,Krhs), clinfo1=' vor  - Ua: ', mask1=umask,               & 
     184         &                                tab3d_2=pvv(:,:,:,Krhs), clinfo2=       ' Va: ', mask2=vmask, clinfo3='dyn' ) 
    183185      ! 
    184186      IF( ln_timing )   CALL timing_stop('dyn_vor') 
    … …  
    187189 
    188190 
    189    SUBROUTINE vor_enT( kt, kvor, pu, pv, pu_rhs, pv_rhs ) 
     191   SUBROUTINE vor_enT( kt, Kmm, kvor, pu, pv, pu_rhs, pv_rhs ) 
    190192      !!---------------------------------------------------------------------- 
    191193      !!                  ***  ROUTINE vor_enT  *** 
    … …  
    203205      !!       where rvor is the relative vorticity at f-point 
    204206      !! 
    205       !! ** Action : - Update (ua,va) with the now vorticity term trend 
     207      !! ** Action : - Update (pu_rhs,pv_rhs) with the now vorticity term trend 
    206208      !!---------------------------------------------------------------------- 
    207209      INTEGER                         , INTENT(in   ) ::   kt               ! ocean time-step index 
     210      INTEGER                         , INTENT(in   ) ::   Kmm              ! ocean time level index 
    208211      INTEGER                         , INTENT(in   ) ::   kvor             ! total, planetary, relative, or metric 
    209212      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pu, pv           ! now velocities 
    … …  
    226229      CASE ( np_RVO )                           !* relative vorticity 
    227230         DO jk = 1, jpkm1                                 ! Horizontal slab 
    228             DO jj = 1, jpjm1 
    229                DO ji = 1, jpim1 
    230                   zwz(ji,jj,jk) = (  e2v(ji+1,jj) * pv(ji+1,jj,jk) - e2v(ji,jj) * pv(ji,jj,jk)  & 
    231                      &             - e1u(ji,jj+1) * pu(ji,jj+1,jk) + e1u(ji,jj) * pu(ji,jj,jk)  ) * r1_e1e2f(ji,jj) 
    232                END DO 
    233             END DO 
     231            DO_2D_10_10 
     232               zwz(ji,jj,jk) = (  e2v(ji+1,jj) * pv(ji+1,jj,jk) - e2v(ji,jj) * pv(ji,jj,jk)  & 
     233                  &             - e1u(ji,jj+1) * pu(ji,jj+1,jk) + e1u(ji,jj) * pu(ji,jj,jk)  ) * r1_e1e2f(ji,jj) 
     234            END_2D 
    234235            IF( ln_dynvor_msk ) THEN                     ! mask/unmask relative vorticity  
    235                DO jj = 1, jpjm1 
    236                   DO ji = 1, jpim1 
    237                      zwz(ji,jj,jk) = zwz(ji,jj,jk) * fmask(ji,jj,jk) 
    238                   END DO 
    239                END DO 
     236               DO_2D_10_10 
     237                  zwz(ji,jj,jk) = zwz(ji,jj,jk) * fmask(ji,jj,jk) 
     238               END_2D 
    240239            ENDIF 
    241240         END DO 
    … …  
    245244      CASE ( np_CRV )                           !* Coriolis + relative vorticity 
    246245         DO jk = 1, jpkm1                                 ! Horizontal slab 
    247             DO jj = 1, jpjm1 
    248                DO ji = 1, jpim1                          ! relative vorticity 
    249                   zwz(ji,jj,jk) = (   e2v(ji+1,jj) * pv(ji+1,jj,jk) - e2v(ji,jj) * pv(ji,jj,jk)   & 
    250                      &              - e1u(ji,jj+1) * pu(ji,jj+1,jk) + e1u(ji,jj) * pu(ji,jj,jk)   ) * r1_e1e2f(ji,jj) 
    251                END DO 
    252             END DO 
     246            DO_2D_10_10 
     247               zwz(ji,jj,jk) = (   e2v(ji+1,jj) * pv(ji+1,jj,jk) - e2v(ji,jj) * pv(ji,jj,jk)   & 
     248                  &              - e1u(ji,jj+1) * pu(ji,jj+1,jk) + e1u(ji,jj) * pu(ji,jj,jk)   ) * r1_e1e2f(ji,jj) 
     249            END_2D 
    253250            IF( ln_dynvor_msk ) THEN                     ! mask/unmask relative vorticity  
    254                DO jj = 1, jpjm1 
    255                   DO ji = 1, jpim1 
    256                      zwz(ji,jj,jk) = zwz(ji,jj,jk) * fmask(ji,jj,jk) 
    257                   END DO 
    258                END DO 
     251               DO_2D_10_10 
     252                  zwz(ji,jj,jk) = zwz(ji,jj,jk) * fmask(ji,jj,jk) 
     253               END_2D 
    259254            ENDIF 
    260255         END DO 
    … …  
    270265         SELECT CASE( kvor )                 !==  volume weighted vorticity considered  ==! 
    271266         CASE ( np_COR )                           !* Coriolis (planetary vorticity) 
    272             zwt(:,:) = ff_t(:,:) * e1e2t(:,:)*e3t_n(:,:,jk) 
     267            zwt(:,:) = ff_t(:,:) * e1e2t(:,:)*e3t(:,:,jk,Kmm) 
    273268         CASE ( np_RVO )                           !* relative vorticity 
    274             DO jj = 2, jpj 
    275                DO ji = 2, jpi   ! vector opt. 
    276                   zwt(ji,jj) = r1_4 * (   zwz(ji-1,jj  ,jk) + zwz(ji,jj  ,jk)   & 
    277                      &                  + zwz(ji-1,jj-1,jk) + zwz(ji,jj-1,jk) ) * e1e2t(ji,jj)*e3t_n(ji,jj,jk) 
    278                END DO 
    279             END DO 
     269            DO_2D_01_01 
     270               zwt(ji,jj) = r1_4 * (   zwz(ji-1,jj  ,jk) + zwz(ji,jj  ,jk)   & 
     271                  &                  + zwz(ji-1,jj-1,jk) + zwz(ji,jj-1,jk) ) * e1e2t(ji,jj)*e3t(ji,jj,jk,Kmm) 
     272            END_2D 
    280273         CASE ( np_MET )                           !* metric term 
    281             DO jj = 2, jpj 
    282                DO ji = 2, jpi 
    283                   zwt(ji,jj) = (   ( pv(ji,jj,jk) + pv(ji,jj-1,jk) ) * di_e2u_2(ji,jj)   & 
    284                      &           - ( pu(ji,jj,jk) + pu(ji-1,jj,jk) ) * dj_e1v_2(ji,jj)   ) * e3t_n(ji,jj,jk) 
    285                END DO 
    286             END DO 
     274            DO_2D_01_01 
     275               zwt(ji,jj) = (   ( pv(ji,jj,jk) + pv(ji,jj-1,jk) ) * di_e2u_2(ji,jj)   & 
     276                  &           - ( pu(ji,jj,jk) + pu(ji-1,jj,jk) ) * dj_e1v_2(ji,jj)   ) * e3t(ji,jj,jk,Kmm) 
     277            END_2D 
    287278         CASE ( np_CRV )                           !* Coriolis + relative vorticity 
    288             DO jj = 2, jpj 
    289                DO ji = 2, jpi   ! vector opt. 
    290                   zwt(ji,jj) = (  ff_t(ji,jj) + r1_4 * ( zwz(ji-1,jj  ,jk) + zwz(ji,jj  ,jk)    & 
    291                      &                                 + zwz(ji-1,jj-1,jk) + zwz(ji,jj-1,jk) )  ) * e1e2t(ji,jj)*e3t_n(ji,jj,jk) 
    292                END DO 
    293             END DO 
     279            DO_2D_01_01 
     280               zwt(ji,jj) = (  ff_t(ji,jj) + r1_4 * ( zwz(ji-1,jj  ,jk) + zwz(ji,jj  ,jk)    & 
     281                  &                                 + zwz(ji-1,jj-1,jk) + zwz(ji,jj-1,jk) )  ) * e1e2t(ji,jj)*e3t(ji,jj,jk,Kmm) 
     282            END_2D 
    294283         CASE ( np_CME )                           !* Coriolis + metric 
    295             DO jj = 2, jpj 
    296                DO ji = 2, jpi   ! vector opt. 
    297                   zwt(ji,jj) = (  ff_t(ji,jj) * e1e2t(ji,jj)                           & 
    298                        &        + ( pv(ji,jj,jk) + pv(ji,jj-1,jk) ) * di_e2u_2(ji,jj)  & 
    299                        &        - ( pu(ji,jj,jk) + pu(ji-1,jj,jk) ) * dj_e1v_2(ji,jj)  ) * e3t_n(ji,jj,jk) 
    300                END DO 
    301             END DO 
     284            DO_2D_01_01 
     285               zwt(ji,jj) = (  ff_t(ji,jj) * e1e2t(ji,jj)                           & 
     286                    &        + ( pv(ji,jj,jk) + pv(ji,jj-1,jk) ) * di_e2u_2(ji,jj)  & 
     287                    &        - ( pu(ji,jj,jk) + pu(ji-1,jj,jk) ) * dj_e1v_2(ji,jj)  ) * e3t(ji,jj,jk,Kmm) 
     288            END_2D 
    302289         CASE DEFAULT                                             ! error 
    303290            CALL ctl_stop('STOP','dyn_vor: wrong value for kvor'  ) 
    … …  
    305292         ! 
    306293         !                                   !==  compute and add the vorticity term trend  =! 
    307          DO jj = 2, jpjm1 
    308             DO ji = 2, jpim1   ! vector opt. 
    309                pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + r1_4 * r1_e1e2u(ji,jj) / e3u_n(ji,jj,jk)                    & 
    310                   &                                * (  zwt(ji+1,jj) * ( pv(ji+1,jj,jk) + pv(ji+1,jj-1,jk) )   & 
    311                   &                                   + zwt(ji  ,jj) * ( pv(ji  ,jj,jk) + pv(ji  ,jj-1,jk) )   ) 
    312                   ! 
    313                pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) - r1_4 * r1_e1e2v(ji,jj) / e3v_n(ji,jj,jk)                    & 
    314                   &                                * (  zwt(ji,jj+1) * ( pu(ji,jj+1,jk) + pu(ji-1,jj+1,jk) )   &  
    315                   &                                   + zwt(ji,jj  ) * ( pu(ji,jj  ,jk) + pu(ji-1,jj  ,jk) )   )  
    316             END DO   
    317          END DO   
     294         DO_2D_00_00 
     295            pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + r1_4 * r1_e1e2u(ji,jj) / e3u(ji,jj,jk,Kmm)                    & 
     296               &                                * (  zwt(ji+1,jj) * ( pv(ji+1,jj,jk) + pv(ji+1,jj-1,jk) )   & 
     297               &                                   + zwt(ji  ,jj) * ( pv(ji  ,jj,jk) + pv(ji  ,jj-1,jk) )   ) 
     298               ! 
     299            pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) - r1_4 * r1_e1e2v(ji,jj) / e3v(ji,jj,jk,Kmm)                    & 
     300               &                                * (  zwt(ji,jj+1) * ( pu(ji,jj+1,jk) + pu(ji-1,jj+1,jk) )   &  
     301               &                                   + zwt(ji,jj  ) * ( pu(ji,jj  ,jk) + pu(ji-1,jj  ,jk) )   )  
     302         END_2D 
    318303         !                                             ! =============== 
    319304      END DO                                           !   End of slab 
    … …  
    322307 
    323308 
    324    SUBROUTINE vor_ene( kt, kvor, pun, pvn, pua, pva ) 
     309   SUBROUTINE vor_ene( kt, Kmm, kvor, pu, pv, pu_rhs, pv_rhs ) 
    325310      !!---------------------------------------------------------------------- 
    326311      !!                  ***  ROUTINE vor_ene  *** 
    … …  
    334319      !!         The general trend of momentum is increased due to the vorticity  
    335320      !!       term which is given by: 
    336       !!          voru = 1/e1u  mj-1[ (rvor+f)/e3f  mi(e1v*e3v vn) ] 
    337       !!          vorv = 1/e2v  mi-1[ (rvor+f)/e3f  mj(e2u*e3u un) ] 
     321      !!          voru = 1/e1u  mj-1[ (rvor+f)/e3f  mi(e1v*e3v pvv(:,:,:,Kmm)) ] 
     322      !!          vorv = 1/e2v  mi-1[ (rvor+f)/e3f  mj(e2u*e3u puu(:,:,:,Kmm)) ] 
    338323      !!       where rvor is the relative vorticity 
    339324      !! 
    340       !! ** Action : - Update (ua,va) with the now vorticity term trend 
     325      !! ** Action : - Update (pu_rhs,pv_rhs) with the now vorticity term trend 
    341326      !! 
    342327      !! References : Sadourny, r., 1975, j. atmos. sciences, 32, 680-689. 
    343328      !!---------------------------------------------------------------------- 
    344329      INTEGER                         , INTENT(in   ) ::   kt          ! ocean time-step index 
     330      INTEGER                         , INTENT(in   ) ::   Kmm              ! ocean time level index 
    345331      INTEGER                         , INTENT(in   ) ::   kvor        ! total, planetary, relative, or metric 
    346       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pun, pvn    ! now velocities 
    347       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pua, pva    ! total v-trend 
     332      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pu, pv    ! now velocities 
     333      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pu_rhs, pv_rhs    ! total v-trend 
    348334      ! 
    349335      INTEGER  ::   ji, jj, jk           ! dummy loop indices 
    … …  
    366352            zwz(:,:) = ff_f(:,:)  
    367353         CASE ( np_RVO )                           !* relative vorticity 
    368             DO jj = 1, jpjm1 
    369                DO ji = 1, fs_jpim1   ! vector opt. 
    370                   zwz(ji,jj) = (  e2v(ji+1,jj  ) * pvn(ji+1,jj  ,jk) - e2v(ji,jj) * pvn(ji,jj,jk)    & 
    371                      &          - e1u(ji  ,jj+1) * pun(ji  ,jj+1,jk) + e1u(ji,jj) * pun(ji,jj,jk)  ) * r1_e1e2f(ji,jj) 
    372                END DO 
    373             END DO 
     354            DO_2D_10_10 
     355               zwz(ji,jj) = (  e2v(ji+1,jj  ) * pv(ji+1,jj  ,jk) - e2v(ji,jj) * pv(ji,jj,jk)    & 
     356                  &          - e1u(ji  ,jj+1) * pu(ji  ,jj+1,jk) + e1u(ji,jj) * pu(ji,jj,jk)  ) * r1_e1e2f(ji,jj) 
     357            END_2D 
    374358         CASE ( np_MET )                           !* metric term 
    375             DO jj = 1, jpjm1 
    376                DO ji = 1, fs_jpim1   ! vector opt. 
    377                   zwz(ji,jj) = ( pvn(ji+1,jj  ,jk) + pvn(ji,jj,jk) ) * di_e2v_2e1e2f(ji,jj)   & 
    378                      &       - ( pun(ji  ,jj+1,jk) + pun(ji,jj,jk) ) * dj_e1u_2e1e2f(ji,jj) 
    379                END DO 
    380             END DO 
     359            DO_2D_10_10 
     360               zwz(ji,jj) = ( pv(ji+1,jj  ,jk) + pv(ji,jj,jk) ) * di_e2v_2e1e2f(ji,jj)   & 
     361                  &       - ( pu(ji  ,jj+1,jk) + pu(ji,jj,jk) ) * dj_e1u_2e1e2f(ji,jj) 
     362            END_2D 
    381363         CASE ( np_CRV )                           !* Coriolis + relative vorticity 
    382             DO jj = 1, jpjm1 
    383                DO ji = 1, fs_jpim1   ! vector opt. 
    384                   zwz(ji,jj) = ff_f(ji,jj) + (  e2v(ji+1,jj) * pvn(ji+1,jj,jk) - e2v(ji,jj) * pvn(ji,jj,jk)      & 
    385                      &                        - e1u(ji,jj+1) * pun(ji,jj+1,jk) + e1u(ji,jj) * pun(ji,jj,jk)  ) * r1_e1e2f(ji,jj) 
    386                END DO 
    387             END DO 
     364            DO_2D_10_10 
     365               zwz(ji,jj) = ff_f(ji,jj) + (  e2v(ji+1,jj) * pv(ji+1,jj,jk) - e2v(ji,jj) * pv(ji,jj,jk)      & 
     366                  &                        - e1u(ji,jj+1) * pu(ji,jj+1,jk) + e1u(ji,jj) * pu(ji,jj,jk)  ) * r1_e1e2f(ji,jj) 
     367            END_2D 
    388368         CASE ( np_CME )                           !* Coriolis + metric 
    389             DO jj = 1, jpjm1 
    390                DO ji = 1, fs_jpim1   ! vector opt. 
    391                   zwz(ji,jj) = ff_f(ji,jj) + ( pvn(ji+1,jj  ,jk) + pvn(ji,jj,jk) ) * di_e2v_2e1e2f(ji,jj)   & 
    392                      &                     - ( pun(ji  ,jj+1,jk) + pun(ji,jj,jk) ) * dj_e1u_2e1e2f(ji,jj) 
    393                END DO 
    394             END DO 
     369            DO_2D_10_10 
     370               zwz(ji,jj) = ff_f(ji,jj) + ( pv(ji+1,jj  ,jk) + pv(ji,jj,jk) ) * di_e2v_2e1e2f(ji,jj)   & 
     371                  &                     - ( pu(ji  ,jj+1,jk) + pu(ji,jj,jk) ) * dj_e1u_2e1e2f(ji,jj) 
     372            END_2D 
    395373         CASE DEFAULT                                             ! error 
    396374            CALL ctl_stop('STOP','dyn_vor: wrong value for kvor'  ) 
    … …  
    398376         ! 
    399377         IF( ln_dynvor_msk ) THEN          !==  mask/unmask vorticity ==! 
    400             DO jj = 1, jpjm1 
    401                DO ji = 1, fs_jpim1   ! vector opt. 
    402                   zwz(ji,jj) = zwz(ji,jj) * fmask(ji,jj,jk) 
    403                END DO 
    404             END DO 
     378            DO_2D_10_10 
     379               zwz(ji,jj) = zwz(ji,jj) * fmask(ji,jj,jk) 
     380            END_2D 
    405381         ENDIF 
    406382 
    407383         IF( ln_sco ) THEN 
    408             zwz(:,:) = zwz(:,:) / e3f_n(:,:,jk) 
    409             zwx(:,:) = e2u(:,:) * e3u_n(:,:,jk) * pun(:,:,jk) 
    410             zwy(:,:) = e1v(:,:) * e3v_n(:,:,jk) * pvn(:,:,jk) 
     384            zwz(:,:) = zwz(:,:) / e3f(:,:,jk) 
     385            zwx(:,:) = e2u(:,:) * e3u(:,:,jk,Kmm) * pu(:,:,jk) 
     386            zwy(:,:) = e1v(:,:) * e3v(:,:,jk,Kmm) * pv(:,:,jk) 
    411387         ELSE 
    412             zwx(:,:) = e2u(:,:) * pun(:,:,jk) 
    413             zwy(:,:) = e1v(:,:) * pvn(:,:,jk) 
     388            zwx(:,:) = e2u(:,:) * pu(:,:,jk) 
     389            zwy(:,:) = e1v(:,:) * pv(:,:,jk) 
    414390         ENDIF 
    415391         !                                   !==  compute and add the vorticity term trend  =! 
    416          DO jj = 2, jpjm1 
    417             DO ji = fs_2, fs_jpim1   ! vector opt. 
    418                zy1 = zwy(ji,jj-1) + zwy(ji+1,jj-1) 
    419                zy2 = zwy(ji,jj  ) + zwy(ji+1,jj  ) 
    420                zx1 = zwx(ji-1,jj) + zwx(ji-1,jj+1) 
    421                zx2 = zwx(ji  ,jj) + zwx(ji  ,jj+1) 
    422                pua(ji,jj,jk) = pua(ji,jj,jk) + r1_4 * r1_e1u(ji,jj) * ( zwz(ji  ,jj-1) * zy1 + zwz(ji,jj) * zy2 ) 
    423                pva(ji,jj,jk) = pva(ji,jj,jk) - r1_4 * r1_e2v(ji,jj) * ( zwz(ji-1,jj  ) * zx1 + zwz(ji,jj) * zx2 )  
    424             END DO   
    425          END DO   
     392         DO_2D_00_00 
     393            zy1 = zwy(ji,jj-1) + zwy(ji+1,jj-1) 
     394            zy2 = zwy(ji,jj  ) + zwy(ji+1,jj  ) 
     395            zx1 = zwx(ji-1,jj) + zwx(ji-1,jj+1) 
     396            zx2 = zwx(ji  ,jj) + zwx(ji  ,jj+1) 
     397            pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + r1_4 * r1_e1u(ji,jj) * ( zwz(ji  ,jj-1) * zy1 + zwz(ji,jj) * zy2 ) 
     398            pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) - r1_4 * r1_e2v(ji,jj) * ( zwz(ji-1,jj  ) * zx1 + zwz(ji,jj) * zx2 )  
     399         END_2D 
    426400         !                                             ! =============== 
    427401      END DO                                           !   End of slab 
    … …  
    430404 
    431405 
    432    SUBROUTINE vor_ens( kt, kvor, pun, pvn, pua, pva ) 
     406   SUBROUTINE vor_ens( kt, Kmm, kvor, pu, pv, pu_rhs, pv_rhs ) 
    433407      !!---------------------------------------------------------------------- 
    434408      !!                ***  ROUTINE vor_ens  *** 
    … …  
    441415      !!      potential enstrophy of a horizontally non-divergent flow. the 
    442416      !!      trend of the vorticity term is given by: 
    443       !!          voru = 1/e1u  mj-1[ (rvor+f)/e3f ]  mj-1[ mi(e1v*e3v vn) ] 
    444       !!          vorv = 1/e2v  mi-1[ (rvor+f)/e3f ]  mi-1[ mj(e2u*e3u un) ] 
    445       !!      Add this trend to the general momentum trend (ua,va): 
    446       !!          (ua,va) = (ua,va) + ( voru , vorv ) 
    447       !! 
    448       !! ** Action : - Update (ua,va) arrays with the now vorticity term trend 
     417      !!          voru = 1/e1u  mj-1[ (rvor+f)/e3f ]  mj-1[ mi(e1v*e3v pvv(:,:,:,Kmm)) ] 
     418      !!          vorv = 1/e2v  mi-1[ (rvor+f)/e3f ]  mi-1[ mj(e2u*e3u puu(:,:,:,Kmm)) ] 
     419      !!      Add this trend to the general momentum trend: 
     420      !!          (u(rhs),v(Krhs)) = (u(rhs),v(Krhs)) + ( voru , vorv ) 
     421      !! 
     422      !! ** Action : - Update (pu_rhs,pv_rhs)) arrays with the now vorticity term trend 
    449423      !! 
    450424      !! References : Sadourny, r., 1975, j. atmos. sciences, 32, 680-689. 
    451425      !!---------------------------------------------------------------------- 
    452426      INTEGER                         , INTENT(in   ) ::   kt          ! ocean time-step index 
     427      INTEGER                         , INTENT(in   ) ::   Kmm              ! ocean time level index 
    453428      INTEGER                         , INTENT(in   ) ::   kvor        ! total, planetary, relative, or metric 
    454       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pun, pvn    ! now velocities 
    455       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pua, pva    ! total v-trend 
     429      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pu, pv    ! now velocities 
     430      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pu_rhs, pv_rhs    ! total v-trend 
    456431      ! 
    457432      INTEGER  ::   ji, jj, jk   ! dummy loop indices 
    … …  
    473448            zwz(:,:) = ff_f(:,:)  
    474449         CASE ( np_RVO )                           !* relative vorticity 
    475             DO jj = 1, jpjm1 
    476                DO ji = 1, fs_jpim1   ! vector opt. 
    477                   zwz(ji,jj) = (  e2v(ji+1,jj  ) * pvn(ji+1,jj  ,jk) - e2v(ji,jj) * pvn(ji,jj,jk)    & 
    478                      &          - e1u(ji  ,jj+1) * pun(ji  ,jj+1,jk) + e1u(ji,jj) * pun(ji,jj,jk)  ) * r1_e1e2f(ji,jj) 
    479                END DO 
    480             END DO 
     450            DO_2D_10_10 
     451               zwz(ji,jj) = (  e2v(ji+1,jj  ) * pv(ji+1,jj  ,jk) - e2v(ji,jj) * pv(ji,jj,jk)    & 
     452                  &          - e1u(ji  ,jj+1) * pu(ji  ,jj+1,jk) + e1u(ji,jj) * pu(ji,jj,jk)  ) * r1_e1e2f(ji,jj) 
     453            END_2D 
    481454         CASE ( np_MET )                           !* metric term 
    482             DO jj = 1, jpjm1 
    483                DO ji = 1, fs_jpim1   ! vector opt. 
    484                   zwz(ji,jj) = ( pvn(ji+1,jj  ,jk) + pvn(ji,jj,jk) ) * di_e2v_2e1e2f(ji,jj)   & 
    485                      &       - ( pun(ji  ,jj+1,jk) + pun(ji,jj,jk) ) * dj_e1u_2e1e2f(ji,jj) 
    486                END DO 
    487             END DO 
     455            DO_2D_10_10 
     456               zwz(ji,jj) = ( pv(ji+1,jj  ,jk) + pv(ji,jj,jk) ) * di_e2v_2e1e2f(ji,jj)   & 
     457                  &       - ( pu(ji  ,jj+1,jk) + pu(ji,jj,jk) ) * dj_e1u_2e1e2f(ji,jj) 
     458            END_2D 
    488459         CASE ( np_CRV )                           !* Coriolis + relative vorticity 
    489             DO jj = 1, jpjm1 
    490                DO ji = 1, fs_jpim1   ! vector opt. 
    491                   zwz(ji,jj) = ff_f(ji,jj) + (  e2v(ji+1,jj  ) * pvn(ji+1,jj  ,jk) - e2v(ji,jj) * pvn(ji,jj,jk)  & 
    492                      &                        - e1u(ji  ,jj+1) * pun(ji  ,jj+1,jk) + e1u(ji,jj) * pun(ji,jj,jk)  ) * r1_e1e2f(ji,jj) 
    493                END DO 
    494             END DO 
     460            DO_2D_10_10 
     461               zwz(ji,jj) = ff_f(ji,jj) + (  e2v(ji+1,jj  ) * pv(ji+1,jj  ,jk) - e2v(ji,jj) * pv(ji,jj,jk)  & 
     462                  &                        - e1u(ji  ,jj+1) * pu(ji  ,jj+1,jk) + e1u(ji,jj) * pu(ji,jj,jk)  ) * r1_e1e2f(ji,jj) 
     463            END_2D 
    495464         CASE ( np_CME )                           !* Coriolis + metric 
    496             DO jj = 1, jpjm1 
    497                DO ji = 1, fs_jpim1   ! vector opt. 
    498                   zwz(ji,jj) = ff_f(ji,jj) + ( pvn(ji+1,jj  ,jk) + pvn(ji,jj,jk) ) * di_e2v_2e1e2f(ji,jj)   & 
    499                      &                     - ( pun(ji  ,jj+1,jk) + pun(ji,jj,jk) ) * dj_e1u_2e1e2f(ji,jj) 
    500                END DO 
    501             END DO 
     465            DO_2D_10_10 
     466               zwz(ji,jj) = ff_f(ji,jj) + ( pv(ji+1,jj  ,jk) + pv(ji,jj,jk) ) * di_e2v_2e1e2f(ji,jj)   & 
     467                  &                     - ( pu(ji  ,jj+1,jk) + pu(ji,jj,jk) ) * dj_e1u_2e1e2f(ji,jj) 
     468            END_2D 
    502469         CASE DEFAULT                                             ! error 
    503470            CALL ctl_stop('STOP','dyn_vor: wrong value for kvor'  ) 
    … …  
    505472         ! 
    506473         IF( ln_dynvor_msk ) THEN           !==  mask/unmask vorticity ==! 
    507             DO jj = 1, jpjm1 
    508                DO ji = 1, fs_jpim1   ! vector opt. 
    509                   zwz(ji,jj) = zwz(ji,jj) * fmask(ji,jj,jk) 
    510                END DO 
    511             END DO 
     474            DO_2D_10_10 
     475               zwz(ji,jj) = zwz(ji,jj) * fmask(ji,jj,jk) 
     476            END_2D 
    512477         ENDIF 
    513478         ! 
    514479         IF( ln_sco ) THEN                   !==  horizontal fluxes  ==! 
    515             zwz(:,:) = zwz(:,:) / e3f_n(:,:,jk) 
    516             zwx(:,:) = e2u(:,:) * e3u_n(:,:,jk) * pun(:,:,jk) 
    517             zwy(:,:) = e1v(:,:) * e3v_n(:,:,jk) * pvn(:,:,jk) 
     480            zwz(:,:) = zwz(:,:) / e3f(:,:,jk) 
     481            zwx(:,:) = e2u(:,:) * e3u(:,:,jk,Kmm) * pu(:,:,jk) 
     482            zwy(:,:) = e1v(:,:) * e3v(:,:,jk,Kmm) * pv(:,:,jk) 
    518483         ELSE 
    519             zwx(:,:) = e2u(:,:) * pun(:,:,jk) 
    520             zwy(:,:) = e1v(:,:) * pvn(:,:,jk) 
     484            zwx(:,:) = e2u(:,:) * pu(:,:,jk) 
     485            zwy(:,:) = e1v(:,:) * pv(:,:,jk) 
    521486         ENDIF 
    522487         !                                   !==  compute and add the vorticity term trend  =! 
    523          DO jj = 2, jpjm1 
    524             DO ji = fs_2, fs_jpim1   ! vector opt. 
    525                zuav = r1_8 * r1_e1u(ji,jj) * (  zwy(ji  ,jj-1) + zwy(ji+1,jj-1)  & 
    526                   &                           + zwy(ji  ,jj  ) + zwy(ji+1,jj  )  ) 
    527                zvau =-r1_8 * r1_e2v(ji,jj) * (  zwx(ji-1,jj  ) + zwx(ji-1,jj+1)  & 
    528                   &                           + zwx(ji  ,jj  ) + zwx(ji  ,jj+1)  ) 
    529                pua(ji,jj,jk) = pua(ji,jj,jk) + zuav * ( zwz(ji  ,jj-1) + zwz(ji,jj) ) 
    530                pva(ji,jj,jk) = pva(ji,jj,jk) + zvau * ( zwz(ji-1,jj  ) + zwz(ji,jj) ) 
    531             END DO   
    532          END DO   
     488         DO_2D_00_00 
     489            zuav = r1_8 * r1_e1u(ji,jj) * (  zwy(ji  ,jj-1) + zwy(ji+1,jj-1)  & 
     490               &                           + zwy(ji  ,jj  ) + zwy(ji+1,jj  )  ) 
     491            zvau =-r1_8 * r1_e2v(ji,jj) * (  zwx(ji-1,jj  ) + zwx(ji-1,jj+1)  & 
     492               &                           + zwx(ji  ,jj  ) + zwx(ji  ,jj+1)  ) 
     493            pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + zuav * ( zwz(ji  ,jj-1) + zwz(ji,jj) ) 
     494            pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) + zvau * ( zwz(ji-1,jj  ) + zwz(ji,jj) ) 
     495         END_2D 
    533496         !                                             ! =============== 
    534497      END DO                                           !   End of slab 
    … …  
    537500 
    538501 
    539    SUBROUTINE vor_een( kt, kvor, pun, pvn, pua, pva ) 
     502   SUBROUTINE vor_een( kt, Kmm, kvor, pu, pv, pu_rhs, pv_rhs ) 
    540503      !!---------------------------------------------------------------------- 
    541504      !!                ***  ROUTINE vor_een  *** 
    … …  
    548511      !!      both the horizontal kinetic energy and the potential enstrophy 
    549512      !!      when horizontal divergence is zero (see the NEMO documentation) 
    550       !!      Add this trend to the general momentum trend (ua,va). 
    551       !! 
    552       !! ** Action : - Update (ua,va) with the now vorticity term trend 
     513      !!      Add this trend to the general momentum trend (pu_rhs,pv_rhs). 
     514      !! 
     515      !! ** Action : - Update (pu_rhs,pv_rhs) with the now vorticity term trend 
    553516      !! 
    554517      !! References : Arakawa and Lamb 1980, Mon. Wea. Rev., 109, 18-36 
    555518      !!---------------------------------------------------------------------- 
    556519      INTEGER                         , INTENT(in   ) ::   kt          ! ocean time-step index 
     520      INTEGER                         , INTENT(in   ) ::   Kmm              ! ocean time level index 
    557521      INTEGER                         , INTENT(in   ) ::   kvor        ! total, planetary, relative, or metric 
    558       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pun, pvn    ! now velocities 
    559       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pua, pva    ! total v-trend 
     522      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pu, pv    ! now velocities 
     523      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pu_rhs, pv_rhs    ! total v-trend 
    560524      ! 
    561525      INTEGER  ::   ji, jj, jk   ! dummy loop indices 
    … …  
    580544         SELECT CASE( nn_een_e3f )           ! == reciprocal of e3 at F-point 
    581545         CASE ( 0 )                                   ! original formulation  (masked averaging of e3t divided by 4) 
    582             DO jj = 1, jpjm1 
    583                DO ji = 1, fs_jpim1   ! vector opt. 
    584                   ze3f = (  e3t_n(ji,jj+1,jk)*tmask(ji,jj+1,jk) + e3t_n(ji+1,jj+1,jk)*tmask(ji+1,jj+1,jk)   & 
    585                      &    + e3t_n(ji,jj  ,jk)*tmask(ji,jj  ,jk) + e3t_n(ji+1,jj  ,jk)*tmask(ji+1,jj  ,jk)  ) 
    586                   IF( ze3f /= 0._wp ) THEN   ;   z1_e3f(ji,jj) = 4._wp / ze3f 
    587                   ELSE                       ;   z1_e3f(ji,jj) = 0._wp 
    588                   ENDIF 
    589                END DO 
    590             END DO 
     546            DO_2D_10_10 
     547               ze3f = (  e3t(ji,jj+1,jk,Kmm)*tmask(ji,jj+1,jk) + e3t(ji+1,jj+1,jk,Kmm)*tmask(ji+1,jj+1,jk)   & 
     548                  &    + e3t(ji,jj  ,jk,Kmm)*tmask(ji,jj  ,jk) + e3t(ji+1,jj  ,jk,Kmm)*tmask(ji+1,jj  ,jk)  ) 
     549               IF( ze3f /= 0._wp ) THEN   ;   z1_e3f(ji,jj) = 4._wp / ze3f 
     550               ELSE                       ;   z1_e3f(ji,jj) = 0._wp 
     551               ENDIF 
     552            END_2D 
    591553         CASE ( 1 )                                   ! new formulation  (masked averaging of e3t divided by the sum of mask) 
    592             DO jj = 1, jpjm1 
    593                DO ji = 1, fs_jpim1   ! vector opt. 
    594                   ze3f = (  e3t_n(ji,jj+1,jk)*tmask(ji,jj+1,jk) + e3t_n(ji+1,jj+1,jk)*tmask(ji+1,jj+1,jk)   & 
    595                      &    + e3t_n(ji,jj  ,jk)*tmask(ji,jj  ,jk) + e3t_n(ji+1,jj  ,jk)*tmask(ji+1,jj  ,jk)  ) 
    596                   zmsk = (                    tmask(ji,jj+1,jk) +                     tmask(ji+1,jj+1,jk)   & 
    597                      &                      + tmask(ji,jj  ,jk) +                     tmask(ji+1,jj  ,jk)  ) 
    598                   IF( ze3f /= 0._wp ) THEN   ;   z1_e3f(ji,jj) = zmsk / ze3f 
    599                   ELSE                       ;   z1_e3f(ji,jj) = 0._wp 
    600                   ENDIF 
    601                END DO 
    602             END DO 
     554            DO_2D_10_10 
     555               ze3f = (  e3t(ji,jj+1,jk,Kmm)*tmask(ji,jj+1,jk) + e3t(ji+1,jj+1,jk,Kmm)*tmask(ji+1,jj+1,jk)   & 
     556                  &    + e3t(ji,jj  ,jk,Kmm)*tmask(ji,jj  ,jk) + e3t(ji+1,jj  ,jk,Kmm)*tmask(ji+1,jj  ,jk)  ) 
     557               zmsk = (                    tmask(ji,jj+1,jk) +                     tmask(ji+1,jj+1,jk)   & 
     558                  &                      + tmask(ji,jj  ,jk) +                     tmask(ji+1,jj  ,jk)  ) 
     559               IF( ze3f /= 0._wp ) THEN   ;   z1_e3f(ji,jj) = zmsk / ze3f 
     560               ELSE                       ;   z1_e3f(ji,jj) = 0._wp 
     561               ENDIF 
     562            END_2D 
    603563         END SELECT 
    604564         ! 
    605565         SELECT CASE( kvor )                 !==  vorticity considered  ==! 
    606566         CASE ( np_COR )                           !* Coriolis (planetary vorticity) 
    607             DO jj = 1, jpjm1 
    608                DO ji = 1, fs_jpim1   ! vector opt. 
    609                   zwz(ji,jj,jk) = ff_f(ji,jj) * z1_e3f(ji,jj) 
    610                END DO 
    611             END DO 
     567            DO_2D_10_10 
     568               zwz(ji,jj,jk) = ff_f(ji,jj) * z1_e3f(ji,jj) 
     569            END_2D 
    612570         CASE ( np_RVO )                           !* relative vorticity 
    613             DO jj = 1, jpjm1 
    614                DO ji = 1, fs_jpim1   ! vector opt. 
    615                   zwz(ji,jj,jk) = ( e2v(ji+1,jj  ) * pvn(ji+1,jj,jk) - e2v(ji,jj) * pvn(ji,jj,jk)  & 
    616                      &            - e1u(ji  ,jj+1) * pun(ji,jj+1,jk) + e1u(ji,jj) * pun(ji,jj,jk)  ) * r1_e1e2f(ji,jj)*z1_e3f(ji,jj) 
    617                END DO 
    618             END DO 
     571            DO_2D_10_10 
     572               zwz(ji,jj,jk) = ( e2v(ji+1,jj  ) * pv(ji+1,jj,jk) - e2v(ji,jj) * pv(ji,jj,jk)  & 
     573                  &            - e1u(ji  ,jj+1) * pu(ji,jj+1,jk) + e1u(ji,jj) * pu(ji,jj,jk)  ) * r1_e1e2f(ji,jj)*z1_e3f(ji,jj) 
     574            END_2D 
    619575         CASE ( np_MET )                           !* metric term 
    620             DO jj = 1, jpjm1 
    621                DO ji = 1, fs_jpim1   ! vector opt. 
    622                   zwz(ji,jj,jk) = (   ( pvn(ji+1,jj,jk) + pvn(ji,jj,jk) ) * di_e2v_2e1e2f(ji,jj)   & 
    623                      &              - ( pun(ji,jj+1,jk) + pun(ji,jj,jk) ) * dj_e1u_2e1e2f(ji,jj)   ) * z1_e3f(ji,jj) 
    624                END DO 
    625             END DO 
     576            DO_2D_10_10 
     577               zwz(ji,jj,jk) = (   ( pv(ji+1,jj,jk) + pv(ji,jj,jk) ) * di_e2v_2e1e2f(ji,jj)   & 
     578                  &              - ( pu(ji,jj+1,jk) + pu(ji,jj,jk) ) * dj_e1u_2e1e2f(ji,jj)   ) * z1_e3f(ji,jj) 
     579            END_2D 
    626580         CASE ( np_CRV )                           !* Coriolis + relative vorticity 
    627             DO jj = 1, jpjm1 
    628                DO ji = 1, fs_jpim1   ! vector opt. 
    629                   zwz(ji,jj,jk) = (  ff_f(ji,jj) + (  e2v(ji+1,jj  ) * pvn(ji+1,jj,jk) - e2v(ji,jj) * pvn(ji,jj,jk)      & 
    630                      &                              - e1u(ji  ,jj+1) * pun(ji,jj+1,jk) + e1u(ji,jj) * pun(ji,jj,jk)  )   & 
    631                      &                           * r1_e1e2f(ji,jj)   ) * z1_e3f(ji,jj) 
    632                END DO 
    633             END DO 
     581            DO_2D_10_10 
     582               zwz(ji,jj,jk) = (  ff_f(ji,jj) + (  e2v(ji+1,jj  ) * pv(ji+1,jj,jk) - e2v(ji,jj) * pv(ji,jj,jk)      & 
     583                  &                              - e1u(ji  ,jj+1) * pu(ji,jj+1,jk) + e1u(ji,jj) * pu(ji,jj,jk)  )   & 
     584                  &                           * r1_e1e2f(ji,jj)   ) * z1_e3f(ji,jj) 
     585            END_2D 
    634586         CASE ( np_CME )                           !* Coriolis + metric 
    635             DO jj = 1, jpjm1 
    636                DO ji = 1, fs_jpim1   ! vector opt. 
    637                   zwz(ji,jj,jk) = (   ff_f(ji,jj) + ( pvn(ji+1,jj  ,jk) + pvn(ji,jj,jk) ) * di_e2v_2e1e2f(ji,jj)   & 
    638                      &                            - ( pun(ji  ,jj+1,jk) + pun(ji,jj,jk) ) * dj_e1u_2e1e2f(ji,jj)   ) * z1_e3f(ji,jj) 
    639                END DO 
    640             END DO 
     587            DO_2D_10_10 
     588               zwz(ji,jj,jk) = (   ff_f(ji,jj) + ( pv(ji+1,jj  ,jk) + pv(ji,jj,jk) ) * di_e2v_2e1e2f(ji,jj)   & 
     589                  &                            - ( pu(ji  ,jj+1,jk) + pu(ji,jj,jk) ) * dj_e1u_2e1e2f(ji,jj)   ) * z1_e3f(ji,jj) 
     590            END_2D 
    641591         CASE DEFAULT                                             ! error 
    642592            CALL ctl_stop('STOP','dyn_vor: wrong value for kvor'  ) 
    … …  
    644594         ! 
    645595         IF( ln_dynvor_msk ) THEN          !==  mask/unmask vorticity ==! 
    646             DO jj = 1, jpjm1 
    647                DO ji = 1, fs_jpim1   ! vector opt. 
    648                   zwz(ji,jj,jk) = zwz(ji,jj,jk) * fmask(ji,jj,jk) 
    649                END DO 
    650             END DO 
     596            DO_2D_10_10 
     597               zwz(ji,jj,jk) = zwz(ji,jj,jk) * fmask(ji,jj,jk) 
     598            END_2D 
    651599         ENDIF 
    652600      END DO                                           !   End of slab 
    … …  
    657605         ! 
    658606         !                                   !==  horizontal fluxes  ==! 
    659          zwx(:,:) = e2u(:,:) * e3u_n(:,:,jk) * pun(:,:,jk) 
    660          zwy(:,:) = e1v(:,:) * e3v_n(:,:,jk) * pvn(:,:,jk) 
     607         zwx(:,:) = e2u(:,:) * e3u(:,:,jk,Kmm) * pu(:,:,jk) 
     608         zwy(:,:) = e1v(:,:) * e3v(:,:,jk,Kmm) * pv(:,:,jk) 
    661609 
    662610         !                                   !==  compute and add the vorticity term trend  =! 
    … …  
    670618         END DO 
    671619         DO jj = 3, jpj 
    672             DO ji = fs_2, jpi   ! vector opt. ok because we start at jj = 3 
     620            DO ji = 2, jpi   ! vector opt. ok because we start at jj = 3 
    673621               ztne(ji,jj) = zwz(ji-1,jj  ,jk) + zwz(ji  ,jj  ,jk) + zwz(ji  ,jj-1,jk) 
    674622               ztnw(ji,jj) = zwz(ji-1,jj-1,jk) + zwz(ji-1,jj  ,jk) + zwz(ji  ,jj  ,jk) 
    … …  
    677625            END DO 
    678626         END DO 
    679          DO jj = 2, jpjm1 
    680             DO ji = fs_2, fs_jpim1   ! vector opt. 
    681                zua = + r1_12 * r1_e1u(ji,jj) * (  ztne(ji,jj  ) * zwy(ji  ,jj  ) + ztnw(ji+1,jj) * zwy(ji+1,jj  )   & 
    682                   &                             + ztse(ji,jj  ) * zwy(ji  ,jj-1) + ztsw(ji+1,jj) * zwy(ji+1,jj-1) ) 
    683                zva = - r1_12 * r1_e2v(ji,jj) * (  ztsw(ji,jj+1) * zwx(ji-1,jj+1) + ztse(ji,jj+1) * zwx(ji  ,jj+1)   & 
    684                   &                             + ztnw(ji,jj  ) * zwx(ji-1,jj  ) + ztne(ji,jj  ) * zwx(ji  ,jj  ) ) 
    685                pua(ji,jj,jk) = pua(ji,jj,jk) + zua 
    686                pva(ji,jj,jk) = pva(ji,jj,jk) + zva 
    687             END DO   
    688          END DO   
     627         DO_2D_00_00 
     628            zua = + r1_12 * r1_e1u(ji,jj) * (  ztne(ji,jj  ) * zwy(ji  ,jj  ) + ztnw(ji+1,jj) * zwy(ji+1,jj  )   & 
     629               &                             + ztse(ji,jj  ) * zwy(ji  ,jj-1) + ztsw(ji+1,jj) * zwy(ji+1,jj-1) ) 
     630            zva = - r1_12 * r1_e2v(ji,jj) * (  ztsw(ji,jj+1) * zwx(ji-1,jj+1) + ztse(ji,jj+1) * zwx(ji  ,jj+1)   & 
     631               &                             + ztnw(ji,jj  ) * zwx(ji-1,jj  ) + ztne(ji,jj  ) * zwx(ji  ,jj  ) ) 
     632            pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + zua 
     633            pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) + zva 
     634         END_2D 
    689635         !                                             ! =============== 
    690636      END DO                                           !   End of slab 
    … …  
    694640 
    695641 
    696    SUBROUTINE vor_eeT( kt, kvor, pun, pvn, pua, pva ) 
     642   SUBROUTINE vor_eeT( kt, Kmm, kvor, pu, pv, pu_rhs, pv_rhs ) 
    697643      !!---------------------------------------------------------------------- 
    698644      !!                ***  ROUTINE vor_eeT  *** 
    … …  
    705651      !!      a modified version of Arakawa and Lamb (1980) scheme (see vor_een). 
    706652      !!      The change consists in  
    707       !!      Add this trend to the general momentum trend (ua,va). 
    708       !! 
    709       !! ** Action : - Update (ua,va) with the now vorticity term trend 
     653      !!      Add this trend to the general momentum trend (pu_rhs,pv_rhs). 
     654      !! 
     655      !! ** Action : - Update (pu_rhs,pv_rhs) with the now vorticity term trend 
    710656      !! 
    711657      !! References : Arakawa and Lamb 1980, Mon. Wea. Rev., 109, 18-36 
    712658      !!---------------------------------------------------------------------- 
    713659      INTEGER                         , INTENT(in   ) ::   kt          ! ocean time-step index 
     660      INTEGER                         , INTENT(in   ) ::   Kmm              ! ocean time level index 
    714661      INTEGER                         , INTENT(in   ) ::   kvor        ! total, planetary, relative, or metric 
    715       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pun, pvn    ! now velocities 
    716       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pua, pva    ! total v-trend 
     662      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pu, pv    ! now velocities 
     663      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pu_rhs, pv_rhs    ! total v-trend 
    717664      ! 
    718665      INTEGER  ::   ji, jj, jk     ! dummy loop indices 
    … …  
    738685         SELECT CASE( kvor )                 !==  vorticity considered  ==! 
    739686         CASE ( np_COR )                           !* Coriolis (planetary vorticity) 
    740             DO jj = 1, jpjm1 
    741                DO ji = 1, fs_jpim1   ! vector opt. 
    742                   zwz(ji,jj,jk) = ff_f(ji,jj) 
    743                END DO 
    744             END DO 
     687            DO_2D_10_10 
     688               zwz(ji,jj,jk) = ff_f(ji,jj) 
     689            END_2D 
    745690         CASE ( np_RVO )                           !* relative vorticity 
    746             DO jj = 1, jpjm1 
    747                DO ji = 1, fs_jpim1   ! vector opt. 
    748                   zwz(ji,jj,jk) = (  e2v(ji+1,jj  ) * pvn(ji+1,jj  ,jk) - e2v(ji,jj) * pvn(ji,jj,jk)    & 
    749                      &             - e1u(ji  ,jj+1) * pun(ji  ,jj+1,jk) + e1u(ji,jj) * pun(ji,jj,jk)  ) & 
    750                      &          * r1_e1e2f(ji,jj) 
    751                END DO 
    752             END DO 
     691            DO_2D_10_10 
     692               zwz(ji,jj,jk) = (  e2v(ji+1,jj  ) * pv(ji+1,jj  ,jk) - e2v(ji,jj) * pv(ji,jj,jk)    & 
     693                  &             - e1u(ji  ,jj+1) * pu(ji  ,jj+1,jk) + e1u(ji,jj) * pu(ji,jj,jk)  ) & 
     694                  &          * r1_e1e2f(ji,jj) 
     695            END_2D 
    753696         CASE ( np_MET )                           !* metric term 
    754             DO jj = 1, jpjm1 
    755                DO ji = 1, fs_jpim1   ! vector opt. 
    756                   zwz(ji,jj,jk) = ( pvn(ji+1,jj  ,jk) + pvn(ji,jj,jk) ) * di_e2v_2e1e2f(ji,jj)   & 
    757                      &          - ( pun(ji  ,jj+1,jk) + pun(ji,jj,jk) ) * dj_e1u_2e1e2f(ji,jj) 
    758                END DO 
    759             END DO 
     697            DO_2D_10_10 
     698               zwz(ji,jj,jk) = ( pv(ji+1,jj  ,jk) + pv(ji,jj,jk) ) * di_e2v_2e1e2f(ji,jj)   & 
     699                  &          - ( pu(ji  ,jj+1,jk) + pu(ji,jj,jk) ) * dj_e1u_2e1e2f(ji,jj) 
     700            END_2D 
    760701         CASE ( np_CRV )                           !* Coriolis + relative vorticity 
    761             DO jj = 1, jpjm1 
    762                DO ji = 1, fs_jpim1   ! vector opt. 
    763                   zwz(ji,jj,jk) = (  ff_f(ji,jj) + (  e2v(ji+1,jj  ) * pvn(ji+1,jj  ,jk) - e2v(ji,jj) * pvn(ji,jj,jk)    & 
    764                      &                              - e1u(ji  ,jj+1) * pun(ji  ,jj+1,jk) + e1u(ji,jj) * pun(ji,jj,jk)  ) & 
    765                      &                         * r1_e1e2f(ji,jj)    ) 
    766                END DO 
    767             END DO 
     702            DO_2D_10_10 
     703               zwz(ji,jj,jk) = (  ff_f(ji,jj) + (  e2v(ji+1,jj  ) * pv(ji+1,jj  ,jk) - e2v(ji,jj) * pv(ji,jj,jk)    & 
     704                  &                              - e1u(ji  ,jj+1) * pu(ji  ,jj+1,jk) + e1u(ji,jj) * pu(ji,jj,jk)  ) & 
     705                  &                         * r1_e1e2f(ji,jj)    ) 
     706            END_2D 
    768707         CASE ( np_CME )                           !* Coriolis + metric 
    769             DO jj = 1, jpjm1 
    770                DO ji = 1, fs_jpim1   ! vector opt. 
    771                   zwz(ji,jj,jk) = ff_f(ji,jj) + ( pvn(ji+1,jj  ,jk) + pvn(ji,jj,jk) ) * di_e2v_2e1e2f(ji,jj)   & 
    772                      &                        - ( pun(ji  ,jj+1,jk) + pun(ji,jj,jk) ) * dj_e1u_2e1e2f(ji,jj) 
    773                END DO 
    774             END DO 
     708            DO_2D_10_10 
     709               zwz(ji,jj,jk) = ff_f(ji,jj) + ( pv(ji+1,jj  ,jk) + pv(ji,jj,jk) ) * di_e2v_2e1e2f(ji,jj)   & 
     710                  &                        - ( pu(ji  ,jj+1,jk) + pu(ji,jj,jk) ) * dj_e1u_2e1e2f(ji,jj) 
     711            END_2D 
    775712         CASE DEFAULT                                             ! error 
    776713            CALL ctl_stop('STOP','dyn_vor: wrong value for kvor'  ) 
    … …  
    778715         ! 
    779716         IF( ln_dynvor_msk ) THEN          !==  mask/unmask vorticity ==! 
    780             DO jj = 1, jpjm1 
    781                DO ji = 1, fs_jpim1   ! vector opt. 
    782                   zwz(ji,jj,jk) = zwz(ji,jj,jk) * fmask(ji,jj,jk) 
    783                END DO 
    784             END DO 
     717            DO_2D_10_10 
     718               zwz(ji,jj,jk) = zwz(ji,jj,jk) * fmask(ji,jj,jk) 
     719            END_2D 
    785720         ENDIF 
    786721      END DO 
    … …  
    791726 
    792727      !                                   !==  horizontal fluxes  ==! 
    793          zwx(:,:) = e2u(:,:) * e3u_n(:,:,jk) * pun(:,:,jk) 
    794          zwy(:,:) = e1v(:,:) * e3v_n(:,:,jk) * pvn(:,:,jk) 
     728         zwx(:,:) = e2u(:,:) * e3u(:,:,jk,Kmm) * pu(:,:,jk) 
     729         zwy(:,:) = e1v(:,:) * e3v(:,:,jk,Kmm) * pv(:,:,jk) 
    795730 
    796731         !                                   !==  compute and add the vorticity term trend  =! 
    … …  
    798733         ztne(1,:) = 0   ;   ztnw(1,:) = 0   ;   ztse(1,:) = 0   ;   ztsw(1,:) = 0 
    799734         DO ji = 2, jpi          ! split in 2 parts due to vector opt. 
    800                z1_e3t = 1._wp / e3t_n(ji,jj,jk) 
     735               z1_e3t = 1._wp / e3t(ji,jj,jk,Kmm) 
    801736               ztne(ji,jj) = ( zwz(ji-1,jj  ,jk) + zwz(ji  ,jj  ,jk) + zwz(ji  ,jj-1,jk) ) * z1_e3t 
    802737               ztnw(ji,jj) = ( zwz(ji-1,jj-1,jk) + zwz(ji-1,jj  ,jk) + zwz(ji  ,jj  ,jk) ) * z1_e3t 
    … …  
    805740         END DO 
    806741         DO jj = 3, jpj 
    807             DO ji = fs_2, jpi   ! vector opt. ok because we start at jj = 3 
    808                z1_e3t = 1._wp / e3t_n(ji,jj,jk) 
     742            DO ji = 2, jpi   ! vector opt. ok because we start at jj = 3 
     743               z1_e3t = 1._wp / e3t(ji,jj,jk,Kmm) 
    809744               ztne(ji,jj) = ( zwz(ji-1,jj  ,jk) + zwz(ji  ,jj  ,jk) + zwz(ji  ,jj-1,jk) ) * z1_e3t 
    810745               ztnw(ji,jj) = ( zwz(ji-1,jj-1,jk) + zwz(ji-1,jj  ,jk) + zwz(ji  ,jj  ,jk) ) * z1_e3t 
    … …  
    813748            END DO 
    814749         END DO 
    815          DO jj = 2, jpjm1 
    816             DO ji = fs_2, fs_jpim1   ! vector opt. 
    817                zua = + r1_12 * r1_e1u(ji,jj) * (  ztne(ji,jj  ) * zwy(ji  ,jj  ) + ztnw(ji+1,jj) * zwy(ji+1,jj  )   & 
    818                   &                             + ztse(ji,jj  ) * zwy(ji  ,jj-1) + ztsw(ji+1,jj) * zwy(ji+1,jj-1) ) 
    819                zva = - r1_12 * r1_e2v(ji,jj) * (  ztsw(ji,jj+1) * zwx(ji-1,jj+1) + ztse(ji,jj+1) * zwx(ji  ,jj+1)   & 
    820                   &                             + ztnw(ji,jj  ) * zwx(ji-1,jj  ) + ztne(ji,jj  ) * zwx(ji  ,jj  ) ) 
    821                pua(ji,jj,jk) = pua(ji,jj,jk) + zua 
    822                pva(ji,jj,jk) = pva(ji,jj,jk) + zva 
    823             END DO   
    824          END DO   
     750         DO_2D_00_00 
     751            zua = + r1_12 * r1_e1u(ji,jj) * (  ztne(ji,jj  ) * zwy(ji  ,jj  ) + ztnw(ji+1,jj) * zwy(ji+1,jj  )   & 
     752               &                             + ztse(ji,jj  ) * zwy(ji  ,jj-1) + ztsw(ji+1,jj) * zwy(ji+1,jj-1) ) 
     753            zva = - r1_12 * r1_e2v(ji,jj) * (  ztsw(ji,jj+1) * zwx(ji-1,jj+1) + ztse(ji,jj+1) * zwx(ji  ,jj+1)   & 
     754               &                             + ztnw(ji,jj  ) * zwx(ji-1,jj  ) + ztne(ji,jj  ) * zwx(ji  ,jj  ) ) 
     755            pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + zua 
     756            pv_rhs(ji,jj,jk) = pv_rhs(ji,jj,jk) + zva 
     757         END_2D 
    825758         !                                             ! =============== 
    826759      END DO                                           !   End of slab 
    … …  
    849782      ENDIF 
    850783      ! 
    851       REWIND( numnam_ref )              ! Namelist namdyn_vor in reference namelist : Vorticity scheme options 
    852784      READ  ( numnam_ref, namdyn_vor, IOSTAT = ios, ERR = 901) 
    853785901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namdyn_vor in reference namelist' ) 
    854       REWIND( numnam_cfg )              ! Namelist namdyn_vor in configuration namelist : Vorticity scheme options 
    855786      READ  ( numnam_cfg, namdyn_vor, IOSTAT = ios, ERR = 902 ) 
    856787902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namdyn_vor in configuration namelist' ) 
    … …  
    877808      IF(lwp) WRITE(numout,*) '      change fmask value in the angles (T)           ln_vorlat = ', ln_vorlat 
    878809      IF( ln_vorlat .AND. ( ln_dynvor_ene .OR. ln_dynvor_ens .OR. ln_dynvor_mix ) ) THEN 
    879          DO jk = 1, jpk 
    880             DO jj = 1, jpjm1 
    881                DO ji = 1, jpim1 
    882                   IF(    tmask(ji,jj+1,jk) + tmask(ji+1,jj+1,jk)              & 
    883                      & + tmask(ji,jj  ,jk) + tmask(ji+1,jj+1,jk) == 3._wp )   fmask(ji,jj,jk) = 1._wp 
    884                END DO 
    885             END DO 
    886          END DO 
     810         DO_3D_10_10( 1, jpk ) 
     811            IF(    tmask(ji,jj+1,jk) + tmask(ji+1,jj+1,jk)              & 
     812               & + tmask(ji,jj  ,jk) + tmask(ji+1,jj+1,jk) == 3._wp )   fmask(ji,jj,jk) = 1._wp 
     813         END_3D 
    887814         ! 
    888815         CALL lbc_lnk( 'dynvor', fmask, 'F', 1._wp )      ! Lateral boundary conditions on fmask 
    … …  
    920847         CASE( np_ENT )                      !* T-point metric term :   pre-compute di(e2u)/2 and dj(e1v)/2 
    921848            ALLOCATE( di_e2u_2(jpi,jpj), dj_e1v_2(jpi,jpj) ) 
    922             DO jj = 2, jpjm1 
    923                DO ji = 2, jpim1 
    924                   di_e2u_2(ji,jj) = ( e2u(ji,jj) - e2u(ji-1,jj  ) ) * 0.5_wp 
    925                   dj_e1v_2(ji,jj) = ( e1v(ji,jj) - e1v(ji  ,jj-1) ) * 0.5_wp 
    926                END DO 
    927             END DO 
     849            DO_2D_00_00 
     850               di_e2u_2(ji,jj) = ( e2u(ji,jj) - e2u(ji-1,jj  ) ) * 0.5_wp 
     851               dj_e1v_2(ji,jj) = ( e1v(ji,jj) - e1v(ji  ,jj-1) ) * 0.5_wp 
     852            END_2D 
    928853            CALL lbc_lnk_multi( 'dynvor', di_e2u_2, 'T', -1. , dj_e1v_2, 'T', -1. )   ! Lateral boundary conditions 
    929854            ! 
    930855         CASE DEFAULT                        !* F-point metric term :   pre-compute di(e2u)/(2*e1e2f) and dj(e1v)/(2*e1e2f) 
    931856            ALLOCATE( di_e2v_2e1e2f(jpi,jpj), dj_e1u_2e1e2f(jpi,jpj) ) 
    932             DO jj = 1, jpjm1 
    933                DO ji = 1, jpim1 
    934                   di_e2v_2e1e2f(ji,jj) = ( e2v(ji+1,jj  ) - e2v(ji,jj) )  * 0.5 * r1_e1e2f(ji,jj) 
    935                   dj_e1u_2e1e2f(ji,jj) = ( e1u(ji  ,jj+1) - e1u(ji,jj) )  * 0.5 * r1_e1e2f(ji,jj) 
    936                END DO 
    937             END DO 
     857            DO_2D_10_10 
     858               di_e2v_2e1e2f(ji,jj) = ( e2v(ji+1,jj  ) - e2v(ji,jj) )  * 0.5 * r1_e1e2f(ji,jj) 
     859               dj_e1u_2e1e2f(ji,jj) = ( e1u(ji  ,jj+1) - e1u(ji,jj) )  * 0.5 * r1_e1e2f(ji,jj) 
     860            END_2D 
    938861            CALL lbc_lnk_multi( 'dynvor', di_e2v_2e1e2f, 'F', -1. , dj_e1u_2e1e2f, 'F', -1. )   ! Lateral boundary conditions 
    939862         END SELECT 

  • NEMO/trunk/src/OCE/DYN/dynzad.F90

    r10068 r12377  
    2828 
    2929   !! * Substitutions 
    30 #  include "vectopt_loop_substitute.h90" 
     30#  include "do_loop_substitute.h90" 
    3131   !!---------------------------------------------------------------------- 
    3232   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    3636CONTAINS 
    3737 
    38    SUBROUTINE dyn_zad ( kt ) 
     38   SUBROUTINE dyn_zad ( kt, Kmm, puu, pvv, Krhs ) 
    3939      !!---------------------------------------------------------------------- 
    4040      !!                  ***  ROUTINE dynzad  *** 
    … …  
    4444      !! 
    4545      !! ** Method  :   The now vertical advection of momentum is given by: 
    46       !!         w dz(u) = ua + 1/(e1e2u*e3u) mk+1[ mi(e1e2t*wn) dk(un) ] 
    47       !!         w dz(v) = va + 1/(e1e2v*e3v) mk+1[ mj(e1e2t*wn) dk(vn) ] 
    48       !!      Add this trend to the general trend (ua,va): 
    49       !!         (ua,va) = (ua,va) + w dz(u,v) 
     46      !!         w dz(u) = u(rhs) + 1/(e1e2u*e3u) mk+1[ mi(e1e2t*ww) dk(u) ] 
     47      !!         w dz(v) = v(rhs) + 1/(e1e2v*e3v) mk+1[ mj(e1e2t*ww) dk(v) ] 
     48      !!      Add this trend to the general trend (puu(:,:,:,Krhs),pvv(:,:,:,Krhs)): 
     49      !!         (u(rhs),v(rhs)) = (u(rhs),v(rhs)) + w dz(u,v) 
    5050      !! 
    51       !! ** Action  : - Update (ua,va) with the vert. momentum adv. trends 
     51      !! ** Action  : - Update (puu(:,:,:,Krhs),pvv(:,:,:,Krhs)) with the vert. momentum adv. trends 
    5252      !!              - Send the trends to trddyn for diagnostics (l_trddyn=T) 
    5353      !!---------------------------------------------------------------------- 
    54       INTEGER, INTENT(in) ::   kt   ! ocean time-step inedx 
     54      INTEGER                             , INTENT( in )  ::  kt               ! ocean time-step inedx 
     55      INTEGER                             , INTENT( in )  ::  Kmm, Krhs        ! ocean time level indices 
     56      REAL(wp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) ::  puu, pvv         ! ocean velocities and RHS of momentum equation 
    5557      ! 
    5658      INTEGER  ::   ji, jj, jk   ! dummy loop indices 
    … …  
    6870      ENDIF 
    6971 
    70       IF( l_trddyn )   THEN         ! Save ua and va trends 
     72      IF( l_trddyn )   THEN         ! Save puu(:,:,:,Krhs) and pvv(:,:,:,Krhs) trends 
    7173         ALLOCATE( ztrdu(jpi,jpj,jpk) , ztrdv(jpi,jpj,jpk) )  
    72          ztrdu(:,:,:) = ua(:,:,:)  
    73          ztrdv(:,:,:) = va(:,:,:)  
     74         ztrdu(:,:,:) = puu(:,:,:,Krhs)  
     75         ztrdv(:,:,:) = pvv(:,:,:,Krhs)  
    7476      ENDIF 
    7577       
    7678      DO jk = 2, jpkm1              ! Vertical momentum advection at level w and u- and v- vertical 
    77          DO jj = 2, jpj                   ! vertical fluxes  
    78             DO ji = fs_2, jpi             ! vector opt. 
    79                zww(ji,jj) = 0.25_wp * e1e2t(ji,jj) * wn(ji,jj,jk) 
    80             END DO 
    81          END DO 
    82          DO jj = 2, jpjm1                 ! vertical momentum advection at w-point 
    83             DO ji = fs_2, fs_jpim1        ! vector opt. 
    84                zwuw(ji,jj,jk) = ( zww(ji+1,jj  ) + zww(ji,jj) ) * ( un(ji,jj,jk-1) - un(ji,jj,jk) ) 
    85                zwvw(ji,jj,jk) = ( zww(ji  ,jj+1) + zww(ji,jj) ) * ( vn(ji,jj,jk-1) - vn(ji,jj,jk) ) 
    86             END DO   
    87          END DO    
     79         DO_2D_01_01 
     80            zww(ji,jj) = 0.25_wp * e1e2t(ji,jj) * ww(ji,jj,jk) 
     81         END_2D 
     82         DO_2D_00_00 
     83            zwuw(ji,jj,jk) = ( zww(ji+1,jj  ) + zww(ji,jj) ) * ( puu(ji,jj,jk-1,Kmm) - puu(ji,jj,jk,Kmm) ) 
     84            zwvw(ji,jj,jk) = ( zww(ji  ,jj+1) + zww(ji,jj) ) * ( pvv(ji,jj,jk-1,Kmm) - pvv(ji,jj,jk,Kmm) ) 
     85         END_2D 
    8886      END DO 
    8987      ! 
    9088      ! Surface and bottom advective fluxes set to zero 
    91       DO jj = 2, jpjm1         
    92          DO ji = fs_2, fs_jpim1           ! vector opt. 
    93             zwuw(ji,jj, 1 ) = 0._wp 
    94             zwvw(ji,jj, 1 ) = 0._wp 
    95             zwuw(ji,jj,jpk) = 0._wp 
    96             zwvw(ji,jj,jpk) = 0._wp 
    97          END DO   
    98       END DO 
     89      DO_2D_00_00 
     90         zwuw(ji,jj, 1 ) = 0._wp 
     91         zwvw(ji,jj, 1 ) = 0._wp 
     92         zwuw(ji,jj,jpk) = 0._wp 
     93         zwvw(ji,jj,jpk) = 0._wp 
     94      END_2D 
    9995      ! 
    100       DO jk = 1, jpkm1              ! Vertical momentum advection at u- and v-points 
    101          DO jj = 2, jpjm1 
    102             DO ji = fs_2, fs_jpim1       ! vector opt. 
    103                ua(ji,jj,jk) = ua(ji,jj,jk) - ( zwuw(ji,jj,jk) + zwuw(ji,jj,jk+1) ) * r1_e1e2u(ji,jj) / e3u_n(ji,jj,jk) 
    104                va(ji,jj,jk) = va(ji,jj,jk) - ( zwvw(ji,jj,jk) + zwvw(ji,jj,jk+1) ) * r1_e1e2v(ji,jj) / e3v_n(ji,jj,jk) 
    105             END DO   
    106          END DO   
    107       END DO 
     96      DO_3D_00_00( 1, jpkm1 ) 
     97         puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) - ( zwuw(ji,jj,jk) + zwuw(ji,jj,jk+1) ) * r1_e1e2u(ji,jj) / e3u(ji,jj,jk,Kmm) 
     98         pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) - ( zwvw(ji,jj,jk) + zwvw(ji,jj,jk+1) ) * r1_e1e2v(ji,jj) / e3v(ji,jj,jk,Kmm) 
     99      END_3D 
    108100 
    109101      IF( l_trddyn ) THEN           ! save the vertical advection trends for diagnostic 
    110          ztrdu(:,:,:) = ua(:,:,:) - ztrdu(:,:,:) 
    111          ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:) 
    112          CALL trd_dyn( ztrdu, ztrdv, jpdyn_zad, kt ) 
     102         ztrdu(:,:,:) = puu(:,:,:,Krhs) - ztrdu(:,:,:) 
     103         ztrdv(:,:,:) = pvv(:,:,:,Krhs) - ztrdv(:,:,:) 
     104         CALL trd_dyn( ztrdu, ztrdv, jpdyn_zad, kt, Kmm ) 
    113105         DEALLOCATE( ztrdu, ztrdv )  
    114106      ENDIF 
    115107      !                             ! Control print 
    116       IF(ln_ctl)   CALL prt_ctl( tab3d_1=ua, clinfo1=' zad  - Ua: ', mask1=umask,   & 
    117          &                       tab3d_2=va, clinfo2=       ' Va: ', mask2=vmask, clinfo3='dyn' ) 
     108      IF(sn_cfctl%l_prtctl)   CALL prt_ctl( tab3d_1=puu(:,:,:,Krhs), clinfo1=' zad  - Ua: ', mask1=umask,   & 
     109         &                                  tab3d_2=pvv(:,:,:,Krhs), clinfo2=       ' Va: ', mask2=vmask, clinfo3='dyn' ) 
    118110      ! 
    119111      IF( ln_timing )   CALL timing_stop('dyn_zad') 

  • NEMO/trunk/src/OCE/DYN/dynzdf.F90

    r12292 r12377  
    3737 
    3838   !! * Substitutions 
    39 #  include "vectopt_loop_substitute.h90" 
     39#  include "do_loop_substitute.h90" 
    4040   !!---------------------------------------------------------------------- 
    4141   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    4545CONTAINS 
    4646    
    47    SUBROUTINE dyn_zdf( kt ) 
     47   SUBROUTINE dyn_zdf( kt, Kbb, Kmm, Krhs, puu, pvv, Kaa ) 
    4848      !!---------------------------------------------------------------------- 
    4949      !!                  ***  ROUTINE dyn_zdf  *** 
    … …  
    5454      !! 
    5555      !! ** Method  :  - Leap-Frog time stepping on all trends but the vertical mixing 
    56       !!         ua =         ub + 2*dt *       ua             vector form or linear free surf. 
    57       !!         ua = ( e3u_b*ub + 2*dt * e3u_n*ua ) / e3u_a   otherwise 
     56      !!         u(after) =         u(before) + 2*dt *       u(rhs)                vector form or linear free surf. 
     57      !!         u(after) = ( e3u_b*u(before) + 2*dt * e3u_n*u(rhs) ) / e3u(after)   otherwise 
    5858      !!               - update the after velocity with the implicit vertical mixing. 
    5959      !!      This requires to solver the following system:  
    60       !!         ua = ua + 1/e3u_a dk+1[ mi(avm) / e3uw_a dk[ua] ] 
     60      !!         u(after) = u(after) + 1/e3u(after) dk+1[ mi(avm) / e3uw(after) dk[ua] ] 
    6161      !!      with the following surface/top/bottom boundary condition: 
    6262      !!      surface: wind stress input (averaged over kt-1/2 & kt+1/2) 
    6363      !!      top & bottom : top stress (iceshelf-ocean) & bottom stress (cf zdfdrg.F90) 
    6464      !! 
    65       !! ** Action :   (ua,va)   after velocity  
     65      !! ** Action :   (puu(:,:,:,Kaa),pvv(:,:,:,Kaa))   after velocity  
    6666      !!--------------------------------------------------------------------- 
    67       INTEGER, INTENT(in) ::   kt   ! ocean time-step index 
     67      INTEGER                             , INTENT( in )  ::  kt                  ! ocean time-step index 
     68      INTEGER                             , INTENT( in )  ::  Kbb, Kmm, Krhs, Kaa ! ocean time level indices 
     69      REAL(wp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) ::  puu, pvv            ! ocean velocities and RHS of momentum equation 
    6870      ! 
    6971      INTEGER  ::   ji, jj, jk         ! dummy loop indices 
    … …  
    9698      ! 
    9799      !                             !* explicit top/bottom drag case 
    98       IF( .NOT.ln_drgimp )   CALL zdf_drg_exp( kt, ub, vb, ua, va )  ! add top/bottom friction trend to (ua,va) 
     100      IF( .NOT.ln_drgimp )   CALL zdf_drg_exp( kt, Kmm, puu(:,:,:,Kbb), pvv(:,:,:,Kbb), puu(:,:,:,Krhs), pvv(:,:,:,Krhs) )  ! add top/bottom friction trend to (puu(Kaa),pvv(Kaa)) 
    99101      ! 
    100102      ! 
    101103      IF( l_trddyn )   THEN         !* temporary save of ta and sa trends 
    102104         ALLOCATE( ztrdu(jpi,jpj,jpk), ztrdv(jpi,jpj,jpk) )  
    103          ztrdu(:,:,:) = ua(:,:,:) 
    104          ztrdv(:,:,:) = va(:,:,:) 
    105       ENDIF 
    106       ! 
    107       !              !==  RHS: Leap-Frog time stepping on all trends but the vertical mixing  ==!   (put in ua,va) 
     105         ztrdu(:,:,:) = puu(:,:,:,Krhs) 
     106         ztrdv(:,:,:) = pvv(:,:,:,Krhs) 
     107      ENDIF 
     108      ! 
     109      !              !==  RHS: Leap-Frog time stepping on all trends but the vertical mixing  ==!   (put in puu(:,:,:,Kaa),pvv(:,:,:,Kaa)) 
    108110      ! 
    109111      !                    ! time stepping except vertical diffusion 
    110112      IF( ln_dynadv_vec .OR. ln_linssh ) THEN   ! applied on velocity 
    111113         DO jk = 1, jpkm1 
    112             ua(:,:,jk) = ( ub(:,:,jk) + r2dt * ua(:,:,jk) ) * umask(:,:,jk) 
    113             va(:,:,jk) = ( vb(:,:,jk) + r2dt * va(:,:,jk) ) * vmask(:,:,jk) 
     114            puu(:,:,jk,Kaa) = ( puu(:,:,jk,Kbb) + r2dt * puu(:,:,jk,Krhs) ) * umask(:,:,jk) 
     115            pvv(:,:,jk,Kaa) = ( pvv(:,:,jk,Kbb) + r2dt * pvv(:,:,jk,Krhs) ) * vmask(:,:,jk) 
    114116         END DO 
    115117      ELSE                                      ! applied on thickness weighted velocity 
    116118         DO jk = 1, jpkm1 
    117             ua(:,:,jk) = (         e3u_b(:,:,jk) * ub(:,:,jk)  & 
    118                &          + r2dt * e3u_n(:,:,jk) * ua(:,:,jk)  ) / e3u_a(:,:,jk) * umask(:,:,jk) 
    119             va(:,:,jk) = (         e3v_b(:,:,jk) * vb(:,:,jk)  & 
    120                &          + r2dt * e3v_n(:,:,jk) * va(:,:,jk)  ) / e3v_a(:,:,jk) * vmask(:,:,jk) 
     119            puu(:,:,jk,Kaa) = (         e3u(:,:,jk,Kbb) * puu(:,:,jk,Kbb)  & 
     120               &          + r2dt * e3u(:,:,jk,Kmm) * puu(:,:,jk,Krhs)  ) / e3u(:,:,jk,Kaa) * umask(:,:,jk) 
     121            pvv(:,:,jk,Kaa) = (         e3v(:,:,jk,Kbb) * pvv(:,:,jk,Kbb)  & 
     122               &          + r2dt * e3v(:,:,jk,Kmm) * pvv(:,:,jk,Krhs)  ) / e3v(:,:,jk,Kaa) * vmask(:,:,jk) 
    121123         END DO 
    122124      ENDIF 
    … …  
    125127      !     J. Chanut: The bottom stress is computed considering after barotropic velocities, which does  
    126128      !                not lead to the effective stress seen over the whole barotropic loop.  
    127       !     G. Madec : in linear free surface, e3u_a = e3u_n = e3u_0, so systematic use of e3u_a 
     129      !     G. Madec : in linear free surface, e3u(:,:,:,Kaa) = e3u(:,:,:,Kmm) = e3u_0, so systematic use of e3u(:,:,:,Kaa) 
    128130      IF( ln_drgimp .AND. ln_dynspg_ts ) THEN 
    129131         DO jk = 1, jpkm1        ! remove barotropic velocities 
    130             ua(:,:,jk) = ( ua(:,:,jk) - ua_b(:,:) ) * umask(:,:,jk) 
    131             va(:,:,jk) = ( va(:,:,jk) - va_b(:,:) ) * vmask(:,:,jk) 
     132            puu(:,:,jk,Kaa) = ( puu(:,:,jk,Kaa) - uu_b(:,:,Kaa) ) * umask(:,:,jk) 
     133            pvv(:,:,jk,Kaa) = ( pvv(:,:,jk,Kaa) - vv_b(:,:,Kaa) ) * vmask(:,:,jk) 
    132134         END DO 
    133          DO jj = 2, jpjm1        ! Add bottom/top stress due to barotropic component only 
    134             DO ji = fs_2, fs_jpim1   ! vector opt. 
    135                iku = mbku(ji,jj)         ! ocean bottom level at u- and v-points  
    136                ikv = mbkv(ji,jj)         ! (deepest ocean u- and v-points) 
    137                ze3ua =  ( 1._wp - r_vvl ) * e3u_n(ji,jj,iku) + r_vvl * e3u_a(ji,jj,iku) 
    138                ze3va =  ( 1._wp - r_vvl ) * e3v_n(ji,jj,ikv) + r_vvl * e3v_a(ji,jj,ikv) 
    139                ua(ji,jj,iku) = ua(ji,jj,iku) + r2dt * 0.5*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) * ua_b(ji,jj) / ze3ua 
    140                va(ji,jj,ikv) = va(ji,jj,ikv) + r2dt * 0.5*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) * va_b(ji,jj) / ze3va 
    141             END DO 
    142          END DO 
     135         DO_2D_00_00 
     136            iku = mbku(ji,jj)         ! ocean bottom level at u- and v-points  
     137            ikv = mbkv(ji,jj)         ! (deepest ocean u- and v-points) 
     138            ze3ua =  ( 1._wp - r_vvl ) * e3u(ji,jj,iku,Kmm) + r_vvl * e3u(ji,jj,iku,Kaa) 
     139            ze3va =  ( 1._wp - r_vvl ) * e3v(ji,jj,ikv,Kmm) + r_vvl * e3v(ji,jj,ikv,Kaa) 
     140            puu(ji,jj,iku,Kaa) = puu(ji,jj,iku,Kaa) + r2dt * 0.5*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) * uu_b(ji,jj,Kaa) / ze3ua 
     141            pvv(ji,jj,ikv,Kaa) = pvv(ji,jj,ikv,Kaa) + r2dt * 0.5*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) * vv_b(ji,jj,Kaa) / ze3va 
     142         END_2D 
    143143         IF( ln_isfcav ) THEN    ! Ocean cavities (ISF) 
    144             DO jj = 2, jpjm1         
    145                DO ji = fs_2, fs_jpim1   ! vector opt. 
    146                   iku = miku(ji,jj)         ! top ocean level at u- and v-points  
    147                   ikv = mikv(ji,jj)         ! (first wet ocean u- and v-points) 
    148                   ze3ua =  ( 1._wp - r_vvl ) * e3u_n(ji,jj,iku) + r_vvl * e3u_a(ji,jj,iku) 
    149                   ze3va =  ( 1._wp - r_vvl ) * e3v_n(ji,jj,ikv) + r_vvl * e3v_a(ji,jj,ikv) 
    150                   ua(ji,jj,iku) = ua(ji,jj,iku) + r2dt * 0.5*( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) * ua_b(ji,jj) / ze3ua 
    151                   va(ji,jj,ikv) = va(ji,jj,ikv) + r2dt * 0.5*( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) * va_b(ji,jj) / ze3va 
    152                END DO 
    153             END DO 
     144            DO_2D_00_00 
     145               iku = miku(ji,jj)         ! top ocean level at u- and v-points  
     146               ikv = mikv(ji,jj)         ! (first wet ocean u- and v-points) 
     147               ze3ua =  ( 1._wp - r_vvl ) * e3u(ji,jj,iku,Kmm) + r_vvl * e3u(ji,jj,iku,Kaa) 
     148               ze3va =  ( 1._wp - r_vvl ) * e3v(ji,jj,ikv,Kmm) + r_vvl * e3v(ji,jj,ikv,Kaa) 
     149               puu(ji,jj,iku,Kaa) = puu(ji,jj,iku,Kaa) + r2dt * 0.5*( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) * uu_b(ji,jj,Kaa) / ze3ua 
     150               pvv(ji,jj,ikv,Kaa) = pvv(ji,jj,ikv,Kaa) + r2dt * 0.5*( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) * vv_b(ji,jj,Kaa) / ze3va 
     151            END_2D 
    154152         END IF 
    155153      ENDIF 
    … …  
    162160         SELECT CASE( nldf_dyn ) 
    163161         CASE( np_lap_i )           ! rotated lateral mixing: add its vertical mixing (akzu) 
    164             DO jk = 1, jpkm1 
    165                DO jj = 2, jpjm1  
    166                   DO ji = fs_2, fs_jpim1   ! vector opt. 
    167                      ze3ua =  ( 1._wp - r_vvl ) * e3u_n(ji,jj,jk) + r_vvl * e3u_a(ji,jj,jk)   ! after scale factor at U-point 
    168                      zzwi = - zdt * ( avm(ji+1,jj,jk  ) + avm(ji,jj,jk  ) + akzu(ji,jj,jk  ) )   & 
    169                         &         / ( ze3ua * e3uw_n(ji,jj,jk  ) ) * wumask(ji,jj,jk  ) 
    170                      zzws = - zdt * ( avm(ji+1,jj,jk+1) + avm(ji,jj,jk+1) + akzu(ji,jj,jk+1) )   & 
    171                         &         / ( ze3ua * e3uw_n(ji,jj,jk+1) ) * wumask(ji,jj,jk+1) 
    172                      zWui = ( wi(ji,jj,jk  ) + wi(ji+1,jj,jk  ) ) / ze3ua 
    173                      zWus = ( wi(ji,jj,jk+1) + wi(ji+1,jj,jk+1) ) / ze3ua 
    174                      zwi(ji,jj,jk) = zzwi + zdt * MIN( zWui, 0._wp )  
    175                      zws(ji,jj,jk) = zzws - zdt * MAX( zWus, 0._wp ) 
    176                      zwd(ji,jj,jk) = 1._wp - zzwi - zzws + zdt * ( MAX( zWui, 0._wp ) - MIN( zWus, 0._wp ) ) 
    177                   END DO 
    178                END DO 
    179             END DO 
     162            DO_3D_00_00( 1, jpkm1 ) 
     163               ze3ua =  ( 1._wp - r_vvl ) * e3u(ji,jj,jk,Kmm) + r_vvl * e3u(ji,jj,jk,Kaa)   ! after scale factor at U-point 
     164               zzwi = - zdt * ( avm(ji+1,jj,jk  ) + avm(ji,jj,jk  ) + akzu(ji,jj,jk  ) )   & 
     165                  &         / ( ze3ua * e3uw(ji,jj,jk  ,Kmm) ) * wumask(ji,jj,jk  ) 
     166               zzws = - zdt * ( avm(ji+1,jj,jk+1) + avm(ji,jj,jk+1) + akzu(ji,jj,jk+1) )   & 
     167                  &         / ( ze3ua * e3uw(ji,jj,jk+1,Kmm) ) * wumask(ji,jj,jk+1) 
     168               zWui = ( wi(ji,jj,jk  ) + wi(ji+1,jj,jk  ) ) / ze3ua 
     169               zWus = ( wi(ji,jj,jk+1) + wi(ji+1,jj,jk+1) ) / ze3ua 
     170               zwi(ji,jj,jk) = zzwi + zdt * MIN( zWui, 0._wp )  
     171               zws(ji,jj,jk) = zzws - zdt * MAX( zWus, 0._wp ) 
     172               zwd(ji,jj,jk) = 1._wp - zzwi - zzws + zdt * ( MAX( zWui, 0._wp ) - MIN( zWus, 0._wp ) ) 
     173            END_3D 
    180174         CASE DEFAULT               ! iso-level lateral mixing 
    181             DO jk = 1, jpkm1 
    182                DO jj = 2, jpjm1  
    183                   DO ji = fs_2, fs_jpim1   ! vector opt. 
    184                      ze3ua =  ( 1._wp - r_vvl ) * e3u_n(ji,jj,jk) + r_vvl * e3u_a(ji,jj,jk)   ! after scale factor at U-point 
    185                      zzwi = - zdt * ( avm(ji+1,jj,jk  ) + avm(ji,jj,jk  ) ) / ( ze3ua * e3uw_n(ji,jj,jk  ) ) * wumask(ji,jj,jk  ) 
    186                      zzws = - zdt * ( avm(ji+1,jj,jk+1) + avm(ji,jj,jk+1) ) / ( ze3ua * e3uw_n(ji,jj,jk+1) ) * wumask(ji,jj,jk+1) 
    187                      zWui = ( wi(ji,jj,jk  ) + wi(ji+1,jj,jk  ) ) / ze3ua 
    188                      zWus = ( wi(ji,jj,jk+1) + wi(ji+1,jj,jk+1) ) / ze3ua 
    189                      zwi(ji,jj,jk) = zzwi + zdt * MIN( zWui, 0._wp ) 
    190                      zws(ji,jj,jk) = zzws - zdt * MAX( zWus, 0._wp ) 
    191                      zwd(ji,jj,jk) = 1._wp - zzwi - zzws + zdt * ( MAX( zWui, 0._wp ) - MIN( zWus, 0._wp ) ) 
    192                   END DO 
    193                END DO 
    194             END DO 
     175            DO_3D_00_00( 1, jpkm1 ) 
     176               ze3ua =  ( 1._wp - r_vvl ) * e3u(ji,jj,jk,Kmm) + r_vvl * e3u(ji,jj,jk,Kaa)   ! after scale factor at U-point 
     177               zzwi = - zdt * ( avm(ji+1,jj,jk  ) + avm(ji,jj,jk  ) ) / ( ze3ua * e3uw(ji,jj,jk  ,Kmm) ) * wumask(ji,jj,jk  ) 
     178               zzws = - zdt * ( avm(ji+1,jj,jk+1) + avm(ji,jj,jk+1) ) / ( ze3ua * e3uw(ji,jj,jk+1,Kmm) ) * wumask(ji,jj,jk+1) 
     179               zWui = ( wi(ji,jj,jk  ) + wi(ji+1,jj,jk  ) ) / ze3ua 
     180               zWus = ( wi(ji,jj,jk+1) + wi(ji+1,jj,jk+1) ) / ze3ua 
     181               zwi(ji,jj,jk) = zzwi + zdt * MIN( zWui, 0._wp ) 
     182               zws(ji,jj,jk) = zzws - zdt * MAX( zWus, 0._wp ) 
     183               zwd(ji,jj,jk) = 1._wp - zzwi - zzws + zdt * ( MAX( zWui, 0._wp ) - MIN( zWus, 0._wp ) ) 
     184            END_3D 
    195185         END SELECT 
    196          DO jj = 2, jpjm1     !* Surface boundary conditions 
    197             DO ji = fs_2, fs_jpim1   ! vector opt. 
    198                zwi(ji,jj,1) = 0._wp 
    199                ze3ua =  ( 1._wp - r_vvl ) * e3u_n(ji,jj,1) + r_vvl * e3u_a(ji,jj,1) 
    200                zzws = - zdt * ( avm(ji+1,jj,2) + avm(ji  ,jj,2) ) / ( ze3ua * e3uw_n(ji,jj,2) ) * wumask(ji,jj,2) 
    201                zWus = ( wi(ji  ,jj,2) +  wi(ji+1,jj,2) ) / ze3ua 
    202                zws(ji,jj,1 ) = zzws - zdt * MAX( zWus, 0._wp ) 
    203                zwd(ji,jj,1 ) = 1._wp - zzws - zdt * ( MIN( zWus, 0._wp ) ) 
    204             END DO 
    205          END DO 
     186         DO_2D_00_00 
     187            zwi(ji,jj,1) = 0._wp 
     188            ze3ua =  ( 1._wp - r_vvl ) * e3u(ji,jj,1,Kmm) + r_vvl * e3u(ji,jj,1,Kaa) 
     189            zzws = - zdt * ( avm(ji+1,jj,2) + avm(ji  ,jj,2) ) / ( ze3ua * e3uw(ji,jj,2,Kmm) ) * wumask(ji,jj,2) 
     190            zWus = ( wi(ji  ,jj,2) +  wi(ji+1,jj,2) ) / ze3ua 
     191            zws(ji,jj,1 ) = zzws - zdt * MAX( zWus, 0._wp ) 
     192            zwd(ji,jj,1 ) = 1._wp - zzws - zdt * ( MIN( zWus, 0._wp ) ) 
     193         END_2D 
    206194      ELSE 
    207195         SELECT CASE( nldf_dyn ) 
    208196         CASE( np_lap_i )           ! rotated lateral mixing: add its vertical mixing (akzu) 
    209             DO jk = 1, jpkm1 
    210                DO jj = 2, jpjm1  
    211                   DO ji = fs_2, fs_jpim1   ! vector opt. 
    212                      ze3ua =  ( 1._wp - r_vvl ) * e3u_n(ji,jj,jk) + r_vvl * e3u_a(ji,jj,jk)   ! after scale factor at U-point 
    213                      zzwi = - zdt * ( avm(ji+1,jj,jk  ) + avm(ji,jj,jk  ) + akzu(ji,jj,jk  ) )   & 
    214                         &         / ( ze3ua * e3uw_n(ji,jj,jk  ) ) * wumask(ji,jj,jk  ) 
    215                      zzws = - zdt * ( avm(ji+1,jj,jk+1) + avm(ji,jj,jk+1) + akzu(ji,jj,jk+1) )   & 
    216                         &         / ( ze3ua * e3uw_n(ji,jj,jk+1) ) * wumask(ji,jj,jk+1) 
    217                      zwi(ji,jj,jk) = zzwi 
    218                      zws(ji,jj,jk) = zzws 
    219                      zwd(ji,jj,jk) = 1._wp - zzwi - zzws 
    220                   END DO 
    221                END DO 
    222             END DO 
     197            DO_3D_00_00( 1, jpkm1 ) 
     198               ze3ua =  ( 1._wp - r_vvl ) * e3u(ji,jj,jk,Kmm) + r_vvl * e3u(ji,jj,jk,Kaa)   ! after scale factor at U-point 
     199               zzwi = - zdt * ( avm(ji+1,jj,jk  ) + avm(ji,jj,jk  ) + akzu(ji,jj,jk  ) )   & 
     200                  &         / ( ze3ua * e3uw(ji,jj,jk  ,Kmm) ) * wumask(ji,jj,jk  ) 
     201               zzws = - zdt * ( avm(ji+1,jj,jk+1) + avm(ji,jj,jk+1) + akzu(ji,jj,jk+1) )   & 
     202                  &         / ( ze3ua * e3uw(ji,jj,jk+1,Kmm) ) * wumask(ji,jj,jk+1) 
     203               zwi(ji,jj,jk) = zzwi 
     204               zws(ji,jj,jk) = zzws 
     205               zwd(ji,jj,jk) = 1._wp - zzwi - zzws 
     206            END_3D 
    223207         CASE DEFAULT               ! iso-level lateral mixing 
    224             DO jk = 1, jpkm1 
    225                DO jj = 2, jpjm1  
    226                   DO ji = fs_2, fs_jpim1   ! vector opt. 
    227                      ze3ua =  ( 1._wp - r_vvl ) * e3u_n(ji,jj,jk) + r_vvl * e3u_a(ji,jj,jk)   ! after scale factor at U-point 
    228                      zzwi = - zdt * ( avm(ji+1,jj,jk  ) + avm(ji,jj,jk  ) ) / ( ze3ua * e3uw_n(ji,jj,jk  ) ) * wumask(ji,jj,jk  ) 
    229                      zzws = - zdt * ( avm(ji+1,jj,jk+1) + avm(ji,jj,jk+1) ) / ( ze3ua * e3uw_n(ji,jj,jk+1) ) * wumask(ji,jj,jk+1) 
    230                      zwi(ji,jj,jk) = zzwi 
    231                      zws(ji,jj,jk) = zzws 
    232                      zwd(ji,jj,jk) = 1._wp - zzwi - zzws 
    233                   END DO 
    234                END DO 
    235             END DO 
     208            DO_3D_00_00( 1, jpkm1 ) 
     209               ze3ua =  ( 1._wp - r_vvl ) * e3u(ji,jj,jk,Kmm) + r_vvl * e3u(ji,jj,jk,Kaa)   ! after scale factor at U-point 
     210               zzwi = - zdt * ( avm(ji+1,jj,jk  ) + avm(ji,jj,jk  ) ) / ( ze3ua * e3uw(ji,jj,jk  ,Kmm) ) * wumask(ji,jj,jk  ) 
     211               zzws = - zdt * ( avm(ji+1,jj,jk+1) + avm(ji,jj,jk+1) ) / ( ze3ua * e3uw(ji,jj,jk+1,Kmm) ) * wumask(ji,jj,jk+1) 
     212               zwi(ji,jj,jk) = zzwi 
     213               zws(ji,jj,jk) = zzws 
     214               zwd(ji,jj,jk) = 1._wp - zzwi - zzws 
     215            END_3D 
    236216         END SELECT 
    237          DO jj = 2, jpjm1     !* Surface boundary conditions 
    238             DO ji = fs_2, fs_jpim1   ! vector opt. 
    239                zwi(ji,jj,1) = 0._wp 
    240                zwd(ji,jj,1) = 1._wp - zws(ji,jj,1) 
    241             END DO 
    242          END DO 
     217         DO_2D_00_00 
     218            zwi(ji,jj,1) = 0._wp 
     219            zwd(ji,jj,1) = 1._wp - zws(ji,jj,1) 
     220         END_2D 
    243221      ENDIF 
    244222      ! 
    … …  
    251229      ! 
    252230      IF ( ln_drgimp ) THEN      ! implicit bottom friction 
    253          DO jj = 2, jpjm1 
    254             DO ji = 2, jpim1 
    255                iku = mbku(ji,jj)       ! ocean bottom level at u- and v-points 
    256                ze3ua =  ( 1._wp - r_vvl ) * e3u_n(ji,jj,iku) + r_vvl * e3u_a(ji,jj,iku)   ! after scale factor at T-point 
    257                zwd(ji,jj,iku) = zwd(ji,jj,iku) - r2dt * 0.5*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) / ze3ua 
    258             END DO 
    259          END DO 
     231         DO_2D_00_00 
     232            iku = mbku(ji,jj)       ! ocean bottom level at u- and v-points 
     233            ze3ua =  ( 1._wp - r_vvl ) * e3u(ji,jj,iku,Kmm) + r_vvl * e3u(ji,jj,iku,Kaa)   ! after scale factor at T-point 
     234            zwd(ji,jj,iku) = zwd(ji,jj,iku) - r2dt * 0.5*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) / ze3ua 
     235         END_2D 
    260236         IF ( ln_isfcav ) THEN   ! top friction (always implicit) 
    261             DO jj = 2, jpjm1 
    262                DO ji = 2, jpim1 
    263                   !!gm   top Cd is masked (=0 outside cavities) no need of test on mik>=2  ==>> it has been suppressed 
    264                   iku = miku(ji,jj)       ! ocean top level at u- and v-points  
    265                   ze3ua =  ( 1._wp - r_vvl ) * e3u_n(ji,jj,iku) + r_vvl * e3u_a(ji,jj,iku)   ! after scale factor at T-point 
    266                   zwd(ji,jj,iku) = zwd(ji,jj,iku) - r2dt * 0.5*( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) / ze3ua 
    267                END DO 
    268             END DO 
     237            DO_2D_00_00 
     238               !!gm   top Cd is masked (=0 outside cavities) no need of test on mik>=2  ==>> it has been suppressed 
     239               iku = miku(ji,jj)       ! ocean top level at u- and v-points  
     240               ze3ua =  ( 1._wp - r_vvl ) * e3u(ji,jj,iku,Kmm) + r_vvl * e3u(ji,jj,iku,Kaa)   ! after scale factor at T-point 
     241               zwd(ji,jj,iku) = zwd(ji,jj,iku) - r2dt * 0.5*( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) / ze3ua 
     242            END_2D 
    269243         END IF 
    270244      ENDIF 
    … …  
    282256      !   m is decomposed in the product of an upper and a lower triangular matrix 
    283257      !   The 3 diagonal terms are in 2d arrays: zwd, zws, zwi 
    284       !   The solution (the after velocity) is in ua 
     258      !   The solution (the after velocity) is in puu(:,:,:,Kaa) 
    285259      !----------------------------------------------------------------------- 
    286260      ! 
    287       DO jk = 2, jpkm1        !==  First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1   (increasing k)  == 
    288          DO jj = 2, jpjm1    
    289             DO ji = fs_2, fs_jpim1   ! vector opt. 
    290                zwd(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) / zwd(ji,jj,jk-1) 
    291             END DO 
    292          END DO 
    293       END DO 
    294       ! 
    295       DO jj = 2, jpjm1        !==  second recurrence:    SOLk = RHSk - Lk / Dk-1  Lk-1  ==! 
    296          DO ji = fs_2, fs_jpim1   ! vector opt. 
    297             ze3ua =  ( 1._wp - r_vvl ) * e3u_n(ji,jj,1) + r_vvl * e3u_a(ji,jj,1)  
    298             ua(ji,jj,1) = ua(ji,jj,1) + r2dt * 0.5_wp * ( utau_b(ji,jj) + utau(ji,jj) )   & 
    299                &                                      / ( ze3ua * rau0 ) * umask(ji,jj,1)  
    300          END DO 
    301       END DO 
    302       DO jk = 2, jpkm1 
    303          DO jj = 2, jpjm1 
    304             DO ji = fs_2, fs_jpim1 
    305                ua(ji,jj,jk) = ua(ji,jj,jk) - zwi(ji,jj,jk) / zwd(ji,jj,jk-1) * ua(ji,jj,jk-1) 
    306             END DO 
    307          END DO 
    308       END DO 
    309       ! 
    310       DO jj = 2, jpjm1        !==  thrid recurrence : SOLk = ( Lk - Uk * Ek+1 ) / Dk  ==! 
    311          DO ji = fs_2, fs_jpim1   ! vector opt. 
    312             ua(ji,jj,jpkm1) = ua(ji,jj,jpkm1) / zwd(ji,jj,jpkm1) 
    313          END DO 
    314       END DO 
    315       DO jk = jpk-2, 1, -1 
    316          DO jj = 2, jpjm1 
    317             DO ji = fs_2, fs_jpim1 
    318                ua(ji,jj,jk) = ( ua(ji,jj,jk) - zws(ji,jj,jk) * ua(ji,jj,jk+1) ) / zwd(ji,jj,jk) 
    319             END DO 
    320          END DO 
    321       END DO 
     261      DO_3D_00_00( 2, jpkm1 ) 
     262         zwd(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) / zwd(ji,jj,jk-1) 
     263      END_3D 
     264      ! 
     265      DO_2D_00_00 
     266         ze3ua =  ( 1._wp - r_vvl ) * e3u(ji,jj,1,Kmm) + r_vvl * e3u(ji,jj,1,Kaa)  
     267         puu(ji,jj,1,Kaa) = puu(ji,jj,1,Kaa) + r2dt * 0.5_wp * ( utau_b(ji,jj) + utau(ji,jj) )   & 
     268            &                                      / ( ze3ua * rau0 ) * umask(ji,jj,1)  
     269      END_2D 
     270      DO_3D_00_00( 2, jpkm1 ) 
     271         puu(ji,jj,jk,Kaa) = puu(ji,jj,jk,Kaa) - zwi(ji,jj,jk) / zwd(ji,jj,jk-1) * puu(ji,jj,jk-1,Kaa) 
     272      END_3D 
     273      ! 
     274      DO_2D_00_00 
     275         puu(ji,jj,jpkm1,Kaa) = puu(ji,jj,jpkm1,Kaa) / zwd(ji,jj,jpkm1) 
     276      END_2D 
     277      DO_3DS_00_00( jpk-2, 1, -1 ) 
     278         puu(ji,jj,jk,Kaa) = ( puu(ji,jj,jk,Kaa) - zws(ji,jj,jk) * puu(ji,jj,jk+1,Kaa) ) / zwd(ji,jj,jk) 
     279      END_3D 
    322280      ! 
    323281      !              !==  Vertical diffusion on v  ==! 
    … …  
    328286         SELECT CASE( nldf_dyn ) 
    329287         CASE( np_lap_i )           ! rotated lateral mixing: add its vertical mixing (akzv) 
    330             DO jk = 1, jpkm1 
    331                DO jj = 2, jpjm1  
    332                   DO ji = fs_2, fs_jpim1   ! vector opt. 
    333                      ze3va =  ( 1._wp - r_vvl ) * e3v_n(ji,jj,jk) + r_vvl * e3v_a(ji,jj,jk)   ! after scale factor at V-point 
    334                      zzwi = - zdt * ( avm(ji,jj+1,jk  ) + avm(ji,jj,jk  ) + akzv(ji,jj,jk  ) )   & 
    335                         &         / ( ze3va * e3vw_n(ji,jj,jk  ) ) * wvmask(ji,jj,jk  ) 
    336                      zzws = - zdt * ( avm(ji,jj+1,jk+1) + avm(ji,jj,jk+1) + akzv(ji,jj,jk+1) )   & 
    337                         &         / ( ze3va * e3vw_n(ji,jj,jk+1) ) * wvmask(ji,jj,jk+1) 
    338                      zWvi = ( wi(ji,jj,jk  ) + wi(ji,jj+1,jk  ) ) / ze3va 
    339                      zWvs = ( wi(ji,jj,jk+1) + wi(ji,jj+1,jk+1) ) / ze3va 
    340                      zwi(ji,jj,jk) = zzwi + zdt * MIN( zWvi, 0._wp ) 
    341                      zws(ji,jj,jk) = zzws - zdt * MAX( zWvs, 0._wp ) 
    342                      zwd(ji,jj,jk) = 1._wp - zzwi - zzws - zdt * ( - MAX( zWvi, 0._wp ) + MIN( zWvs, 0._wp ) ) 
    343                   END DO 
    344                END DO 
    345             END DO 
     288            DO_3D_00_00( 1, jpkm1 ) 
     289               ze3va =  ( 1._wp - r_vvl ) * e3v(ji,jj,jk,Kmm) + r_vvl * e3v(ji,jj,jk,Kaa)   ! after scale factor at V-point 
     290               zzwi = - zdt * ( avm(ji,jj+1,jk  ) + avm(ji,jj,jk  ) + akzv(ji,jj,jk  ) )   & 
     291                  &         / ( ze3va * e3vw(ji,jj,jk  ,Kmm) ) * wvmask(ji,jj,jk  ) 
     292               zzws = - zdt * ( avm(ji,jj+1,jk+1) + avm(ji,jj,jk+1) + akzv(ji,jj,jk+1) )   & 
     293                  &         / ( ze3va * e3vw(ji,jj,jk+1,Kmm) ) * wvmask(ji,jj,jk+1) 
     294               zWvi = ( wi(ji,jj,jk  ) + wi(ji,jj+1,jk  ) ) / ze3va 
     295               zWvs = ( wi(ji,jj,jk+1) + wi(ji,jj+1,jk+1) ) / ze3va 
     296               zwi(ji,jj,jk) = zzwi + zdt * MIN( zWvi, 0._wp ) 
     297               zws(ji,jj,jk) = zzws - zdt * MAX( zWvs, 0._wp ) 
     298               zwd(ji,jj,jk) = 1._wp - zzwi - zzws - zdt * ( - MAX( zWvi, 0._wp ) + MIN( zWvs, 0._wp ) ) 
     299            END_3D 
    346300         CASE DEFAULT               ! iso-level lateral mixing 
    347             DO jk = 1, jpkm1 
    348                DO jj = 2, jpjm1  
    349                   DO ji = fs_2, fs_jpim1   ! vector opt. 
    350                      ze3va =  ( 1._wp - r_vvl ) * e3v_n(ji,jj,jk) + r_vvl * e3v_a(ji,jj,jk)   ! after scale factor at V-point 
    351                      zzwi = - zdt * ( avm(ji,jj+1,jk  ) + avm(ji,jj,jk  ) ) / ( ze3va * e3vw_n(ji,jj,jk  ) ) * wvmask(ji,jj,jk  ) 
    352                      zzws = - zdt * ( avm(ji,jj+1,jk+1) + avm(ji,jj,jk+1) ) / ( ze3va * e3vw_n(ji,jj,jk+1) ) * wvmask(ji,jj,jk+1) 
    353                      zWvi = ( wi(ji,jj,jk  ) + wi(ji,jj+1,jk  ) ) / ze3va 
    354                      zWvs = ( wi(ji,jj,jk+1) + wi(ji,jj+1,jk+1) ) / ze3va 
    355                      zwi(ji,jj,jk) = zzwi  + zdt * MIN( zWvi, 0._wp ) 
    356                      zws(ji,jj,jk) = zzws  - zdt * MAX( zWvs, 0._wp ) 
    357                      zwd(ji,jj,jk) = 1._wp - zzwi - zzws - zdt * ( - MAX( zWvi, 0._wp ) + MIN( zWvs, 0._wp ) ) 
    358                   END DO 
    359                END DO 
    360             END DO 
     301            DO_3D_00_00( 1, jpkm1 ) 
     302               ze3va =  ( 1._wp - r_vvl ) * e3v(ji,jj,jk,Kmm) + r_vvl * e3v(ji,jj,jk,Kaa)   ! after scale factor at V-point 
     303               zzwi = - zdt * ( avm(ji,jj+1,jk  ) + avm(ji,jj,jk  ) ) / ( ze3va * e3vw(ji,jj,jk  ,Kmm) ) * wvmask(ji,jj,jk  ) 
     304               zzws = - zdt * ( avm(ji,jj+1,jk+1) + avm(ji,jj,jk+1) ) / ( ze3va * e3vw(ji,jj,jk+1,Kmm) ) * wvmask(ji,jj,jk+1) 
     305               zWvi = ( wi(ji,jj,jk  ) + wi(ji,jj+1,jk  ) ) / ze3va 
     306               zWvs = ( wi(ji,jj,jk+1) + wi(ji,jj+1,jk+1) ) / ze3va 
     307               zwi(ji,jj,jk) = zzwi  + zdt * MIN( zWvi, 0._wp ) 
     308               zws(ji,jj,jk) = zzws  - zdt * MAX( zWvs, 0._wp ) 
     309               zwd(ji,jj,jk) = 1._wp - zzwi - zzws - zdt * ( - MAX( zWvi, 0._wp ) + MIN( zWvs, 0._wp ) ) 
     310            END_3D 
    361311         END SELECT 
    362          DO jj = 2, jpjm1     !* Surface boundary conditions 
    363             DO ji = fs_2, fs_jpim1   ! vector opt. 
    364                zwi(ji,jj,1) = 0._wp 
    365                ze3va =  ( 1._wp - r_vvl ) * e3v_n(ji,jj,1) + r_vvl * e3v_a(ji,jj,1) 
    366                zzws = - zdt * ( avm(ji,jj+1,2) + avm(ji,jj,2) ) / ( ze3va * e3vw_n(ji,jj,2) ) * wvmask(ji,jj,2) 
    367                zWvs = ( wi(ji,jj  ,2) +  wi(ji,jj+1,2) ) / ze3va 
    368                zws(ji,jj,1 ) = zzws - zdt * MAX( zWvs, 0._wp ) 
    369                zwd(ji,jj,1 ) = 1._wp - zzws - zdt * ( MIN( zWvs, 0._wp ) ) 
    370             END DO 
    371          END DO 
     312         DO_2D_00_00 
     313            zwi(ji,jj,1) = 0._wp 
     314            ze3va =  ( 1._wp - r_vvl ) * e3v(ji,jj,1,Kmm) + r_vvl * e3v(ji,jj,1,Kaa) 
     315            zzws = - zdt * ( avm(ji,jj+1,2) + avm(ji,jj,2) ) / ( ze3va * e3vw(ji,jj,2,Kmm) ) * wvmask(ji,jj,2) 
     316            zWvs = ( wi(ji,jj  ,2) +  wi(ji,jj+1,2) ) / ze3va 
     317            zws(ji,jj,1 ) = zzws - zdt * MAX( zWvs, 0._wp ) 
     318            zwd(ji,jj,1 ) = 1._wp - zzws - zdt * ( MIN( zWvs, 0._wp ) ) 
     319         END_2D 
    372320      ELSE 
    373321         SELECT CASE( nldf_dyn ) 
    374322         CASE( np_lap_i )           ! rotated lateral mixing: add its vertical mixing (akzu) 
    375             DO jk = 1, jpkm1 
    376                DO jj = 2, jpjm1    
    377                   DO ji = fs_2, fs_jpim1   ! vector opt. 
    378                      ze3va =  ( 1._wp - r_vvl ) * e3v_n(ji,jj,jk) + r_vvl * e3v_a(ji,jj,jk)   ! after scale factor at V-point 
    379                      zzwi = - zdt * ( avm(ji,jj+1,jk  ) + avm(ji,jj,jk  ) + akzv(ji,jj,jk  ) )   & 
    380                         &         / ( ze3va * e3vw_n(ji,jj,jk  ) ) * wvmask(ji,jj,jk  ) 
    381                      zzws = - zdt * ( avm(ji,jj+1,jk+1) + avm(ji,jj,jk+1) + akzv(ji,jj,jk+1) )   & 
    382                         &         / ( ze3va * e3vw_n(ji,jj,jk+1) ) * wvmask(ji,jj,jk+1) 
    383                      zwi(ji,jj,jk) = zzwi 
    384                      zws(ji,jj,jk) = zzws 
    385                      zwd(ji,jj,jk) = 1._wp - zzwi - zzws 
    386                   END DO 
    387                END DO 
    388             END DO 
     323            DO_3D_00_00( 1, jpkm1 ) 
     324               ze3va =  ( 1._wp - r_vvl ) * e3v(ji,jj,jk,Kmm) + r_vvl * e3v(ji,jj,jk,Kaa)   ! after scale factor at V-point 
     325               zzwi = - zdt * ( avm(ji,jj+1,jk  ) + avm(ji,jj,jk  ) + akzv(ji,jj,jk  ) )   & 
     326                  &         / ( ze3va * e3vw(ji,jj,jk  ,Kmm) ) * wvmask(ji,jj,jk  ) 
     327               zzws = - zdt * ( avm(ji,jj+1,jk+1) + avm(ji,jj,jk+1) + akzv(ji,jj,jk+1) )   & 
     328                  &         / ( ze3va * e3vw(ji,jj,jk+1,Kmm) ) * wvmask(ji,jj,jk+1) 
     329               zwi(ji,jj,jk) = zzwi 
     330               zws(ji,jj,jk) = zzws 
     331               zwd(ji,jj,jk) = 1._wp - zzwi - zzws 
     332            END_3D 
    389333         CASE DEFAULT               ! iso-level lateral mixing 
    390             DO jk = 1, jpkm1 
    391                DO jj = 2, jpjm1    
    392                   DO ji = fs_2, fs_jpim1   ! vector opt. 
    393                      ze3va =  ( 1._wp - r_vvl ) * e3v_n(ji,jj,jk) + r_vvl * e3v_a(ji,jj,jk)   ! after scale factor at V-point 
    394                      zzwi = - zdt * ( avm(ji,jj+1,jk  ) + avm(ji,jj,jk  ) ) / ( ze3va * e3vw_n(ji,jj,jk  ) ) * wvmask(ji,jj,jk  ) 
    395                      zzws = - zdt * ( avm(ji,jj+1,jk+1) + avm(ji,jj,jk+1) ) / ( ze3va * e3vw_n(ji,jj,jk+1) ) * wvmask(ji,jj,jk+1) 
    396                      zwi(ji,jj,jk) = zzwi 
    397                      zws(ji,jj,jk) = zzws 
    398                      zwd(ji,jj,jk) = 1._wp - zzwi - zzws 
    399                   END DO 
    400                END DO 
    401             END DO 
     334            DO_3D_00_00( 1, jpkm1 ) 
     335               ze3va =  ( 1._wp - r_vvl ) * e3v(ji,jj,jk,Kmm) + r_vvl * e3v(ji,jj,jk,Kaa)   ! after scale factor at V-point 
     336               zzwi = - zdt * ( avm(ji,jj+1,jk  ) + avm(ji,jj,jk  ) ) / ( ze3va * e3vw(ji,jj,jk  ,Kmm) ) * wvmask(ji,jj,jk  ) 
     337               zzws = - zdt * ( avm(ji,jj+1,jk+1) + avm(ji,jj,jk+1) ) / ( ze3va * e3vw(ji,jj,jk+1,Kmm) ) * wvmask(ji,jj,jk+1) 
     338               zwi(ji,jj,jk) = zzwi 
     339               zws(ji,jj,jk) = zzws 
     340               zwd(ji,jj,jk) = 1._wp - zzwi - zzws 
     341            END_3D 
    402342         END SELECT 
    403          DO jj = 2, jpjm1        !* Surface boundary conditions 
    404             DO ji = fs_2, fs_jpim1   ! vector opt. 
    405                zwi(ji,jj,1) = 0._wp 
    406                zwd(ji,jj,1) = 1._wp - zws(ji,jj,1) 
    407             END DO 
    408          END DO 
     343         DO_2D_00_00 
     344            zwi(ji,jj,1) = 0._wp 
     345            zwd(ji,jj,1) = 1._wp - zws(ji,jj,1) 
     346         END_2D 
    409347      ENDIF 
    410348      ! 
    … …  
    416354      ! 
    417355      IF( ln_drgimp ) THEN 
    418          DO jj = 2, jpjm1 
    419             DO ji = 2, jpim1 
    420                ikv = mbkv(ji,jj)       ! (deepest ocean u- and v-points) 
    421                ze3va =  ( 1._wp - r_vvl ) * e3v_n(ji,jj,ikv) + r_vvl * e3v_a(ji,jj,ikv)   ! after scale factor at T-point 
    422                zwd(ji,jj,ikv) = zwd(ji,jj,ikv) - r2dt * 0.5*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) / ze3va            
    423             END DO 
    424          END DO 
     356         DO_2D_00_00 
     357            ikv = mbkv(ji,jj)       ! (deepest ocean u- and v-points) 
     358            ze3va =  ( 1._wp - r_vvl ) * e3v(ji,jj,ikv,Kmm) + r_vvl * e3v(ji,jj,ikv,Kaa)   ! after scale factor at T-point 
     359            zwd(ji,jj,ikv) = zwd(ji,jj,ikv) - r2dt * 0.5*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) / ze3va            
     360         END_2D 
    425361         IF ( ln_isfcav ) THEN 
    426             DO jj = 2, jpjm1 
    427                DO ji = 2, jpim1 
    428                   ikv = mikv(ji,jj)       ! (first wet ocean u- and v-points) 
    429                   ze3va =  ( 1._wp - r_vvl ) * e3v_n(ji,jj,ikv) + r_vvl * e3v_a(ji,jj,ikv)   ! after scale factor at T-point 
    430                   zwd(ji,jj,ikv) = zwd(ji,jj,ikv) - r2dt * 0.5*( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) / ze3va 
    431                END DO 
    432             END DO 
     362            DO_2D_00_00 
     363               ikv = mikv(ji,jj)       ! (first wet ocean u- and v-points) 
     364               ze3va =  ( 1._wp - r_vvl ) * e3v(ji,jj,ikv,Kmm) + r_vvl * e3v(ji,jj,ikv,Kaa)   ! after scale factor at T-point 
     365               zwd(ji,jj,ikv) = zwd(ji,jj,ikv) - r2dt * 0.5*( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) / ze3va 
     366            END_2D 
    433367         ENDIF 
    434368      ENDIF 
    … …  
    449383      !----------------------------------------------------------------------- 
    450384      ! 
    451       DO jk = 2, jpkm1        !==  First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1   (increasing k)  == 
    452          DO jj = 2, jpjm1    
    453             DO ji = fs_2, fs_jpim1   ! vector opt. 
    454                zwd(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) / zwd(ji,jj,jk-1) 
    455             END DO 
    456          END DO 
    457       END DO 
    458       ! 
    459       DO jj = 2, jpjm1        !==  second recurrence:    SOLk = RHSk - Lk / Dk-1  Lk-1  ==! 
    460          DO ji = fs_2, fs_jpim1   ! vector opt.           
    461             ze3va =  ( 1._wp - r_vvl ) * e3v_n(ji,jj,1) + r_vvl * e3v_a(ji,jj,1)  
    462             va(ji,jj,1) = va(ji,jj,1) + r2dt * 0.5_wp * ( vtau_b(ji,jj) + vtau(ji,jj) )   & 
    463                &                                      / ( ze3va * rau0 ) * vmask(ji,jj,1)  
    464          END DO 
    465       END DO 
    466       DO jk = 2, jpkm1 
    467          DO jj = 2, jpjm1 
    468             DO ji = fs_2, fs_jpim1   ! vector opt. 
    469                va(ji,jj,jk) = va(ji,jj,jk) - zwi(ji,jj,jk) / zwd(ji,jj,jk-1) * va(ji,jj,jk-1) 
    470             END DO 
    471          END DO 
    472       END DO 
    473       ! 
    474       DO jj = 2, jpjm1        !==  third recurrence : SOLk = ( Lk - Uk * SOLk+1 ) / Dk  ==! 
    475          DO ji = fs_2, fs_jpim1   ! vector opt. 
    476             va(ji,jj,jpkm1) = va(ji,jj,jpkm1) / zwd(ji,jj,jpkm1) 
    477          END DO 
    478       END DO 
    479       DO jk = jpk-2, 1, -1 
    480          DO jj = 2, jpjm1 
    481             DO ji = fs_2, fs_jpim1 
    482                va(ji,jj,jk) = ( va(ji,jj,jk) - zws(ji,jj,jk) * va(ji,jj,jk+1) ) / zwd(ji,jj,jk) 
    483             END DO 
    484          END DO 
    485       END DO 
     385      DO_3D_00_00( 2, jpkm1 ) 
     386         zwd(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) / zwd(ji,jj,jk-1) 
     387      END_3D 
     388      ! 
     389      DO_2D_00_00 
     390         ze3va =  ( 1._wp - r_vvl ) * e3v(ji,jj,1,Kmm) + r_vvl * e3v(ji,jj,1,Kaa)  
     391         pvv(ji,jj,1,Kaa) = pvv(ji,jj,1,Kaa) + r2dt * 0.5_wp * ( vtau_b(ji,jj) + vtau(ji,jj) )   & 
     392            &                                      / ( ze3va * rau0 ) * vmask(ji,jj,1)  
     393      END_2D 
     394      DO_3D_00_00( 2, jpkm1 ) 
     395         pvv(ji,jj,jk,Kaa) = pvv(ji,jj,jk,Kaa) - zwi(ji,jj,jk) / zwd(ji,jj,jk-1) * pvv(ji,jj,jk-1,Kaa) 
     396      END_3D 
     397      ! 
     398      DO_2D_00_00 
     399         pvv(ji,jj,jpkm1,Kaa) = pvv(ji,jj,jpkm1,Kaa) / zwd(ji,jj,jpkm1) 
     400      END_2D 
     401      DO_3DS_00_00( jpk-2, 1, -1 ) 
     402         pvv(ji,jj,jk,Kaa) = ( pvv(ji,jj,jk,Kaa) - zws(ji,jj,jk) * pvv(ji,jj,jk+1,Kaa) ) / zwd(ji,jj,jk) 
     403      END_3D 
    486404      ! 
    487405      IF( l_trddyn )   THEN                      ! save the vertical diffusive trends for further diagnostics 
    488          ztrdu(:,:,:) = ( ua(:,:,:) - ub(:,:,:) ) / r2dt - ztrdu(:,:,:) 
    489          ztrdv(:,:,:) = ( va(:,:,:) - vb(:,:,:) ) / r2dt - ztrdv(:,:,:) 
    490          CALL trd_dyn( ztrdu, ztrdv, jpdyn_zdf, kt ) 
     406         ztrdu(:,:,:) = ( puu(:,:,:,Kaa) - puu(:,:,:,Kbb) ) / r2dt - ztrdu(:,:,:) 
     407         ztrdv(:,:,:) = ( pvv(:,:,:,Kaa) - pvv(:,:,:,Kbb) ) / r2dt - ztrdv(:,:,:) 
     408         CALL trd_dyn( ztrdu, ztrdv, jpdyn_zdf, kt, Kmm ) 
    491409         DEALLOCATE( ztrdu, ztrdv )  
    492410      ENDIF 
    493411      !                                          ! print mean trends (used for debugging) 
    494       IF(ln_ctl)   CALL prt_ctl( tab3d_1=ua, clinfo1=' zdf  - Ua: ', mask1=umask,               & 
    495          &                       tab3d_2=va, clinfo2=       ' Va: ', mask2=vmask, clinfo3='dyn' ) 
     412      IF(sn_cfctl%l_prtctl)   CALL prt_ctl( tab3d_1=puu(:,:,:,Kaa), clinfo1=' zdf  - Ua: ', mask1=umask,               & 
     413         &                                  tab3d_2=pvv(:,:,:,Kaa), clinfo2=       ' Va: ', mask2=vmask, clinfo3='dyn' ) 
    496414         ! 
    497415      IF( ln_timing )   CALL timing_stop('dyn_zdf') 

  • NEMO/trunk/src/OCE/DYN/sshwzv.F90

    r11414 r12377  
    1010   !!            3.3  !  2011-10  (M. Leclair) split former ssh_wzv routine and remove all vvl related work 
    1111   !!            4.0  !  2018-12  (A. Coward) add mixed implicit/explicit advection 
     12   !!            4.1  !  2019-08  (A. Coward, D. Storkey) Rename ssh_nxt -> ssh_atf. Now only does time filtering. 
    1213   !!---------------------------------------------------------------------- 
    1314 
    1415   !!---------------------------------------------------------------------- 
    1516   !!   ssh_nxt       : after ssh 
    16    !!   ssh_swp       : filter ans swap the ssh arrays 
     17   !!   ssh_atf       : time filter the ssh arrays 
    1718   !!   wzv           : compute now vertical velocity 
    1819   !!---------------------------------------------------------------------- 
    1920   USE oce            ! ocean dynamics and tracers variables 
     21   USE isf_oce        ! ice shelf 
    2022   USE dom_oce        ! ocean space and time domain variables  
    2123   USE sbc_oce        ! surface boundary condition: ocean 
    … …  
    4446   PUBLIC   wzv        ! called by step.F90 
    4547   PUBLIC   wAimp      ! called by step.F90 
    46    PUBLIC   ssh_swp    ! called by step.F90 
     48   PUBLIC   ssh_atf    ! called by step.F90 
    4749 
    4850   !! * Substitutions 
    49 #  include "vectopt_loop_substitute.h90" 
     51#  include "do_loop_substitute.h90" 
    5052   !!---------------------------------------------------------------------- 
    5153   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    5557CONTAINS 
    5658 
    57    SUBROUTINE ssh_nxt( kt ) 
     59   SUBROUTINE ssh_nxt( kt, Kbb, Kmm, pssh, Kaa ) 
    5860      !!---------------------------------------------------------------------- 
    5961      !!                ***  ROUTINE ssh_nxt  *** 
    6062      !!                    
    61       !! ** Purpose :   compute the after ssh (ssha) 
     63      !! ** Purpose :   compute the after ssh (ssh(Kaa)) 
    6264      !! 
    6365      !! ** Method  : - Using the incompressibility hypothesis, the ssh increment 
    … …  
    6567      !!      by the time step. 
    6668      !! 
    67       !! ** action  :   ssha, after sea surface height 
     69      !! ** action  :   ssh(:,:,Kaa), after sea surface height 
    6870      !! 
    6971      !! Reference  : Leclair, M., and G. Madec, 2009, Ocean Modelling. 
    7072      !!---------------------------------------------------------------------- 
    71       INTEGER, INTENT(in) ::   kt   ! time step 
     73      INTEGER                         , INTENT(in   ) ::   kt             ! time step 
     74      INTEGER                         , INTENT(in   ) ::   Kbb, Kmm, Kaa  ! time level index 
     75      REAL(wp), DIMENSION(jpi,jpj,jpt), INTENT(inout) ::   pssh           ! sea-surface height 
    7276      !  
    7377      INTEGER  ::   jk            ! dummy loop indice 
    … …  
    9296      !                                           !------------------------------! 
    9397      IF(ln_wd_il) THEN 
    94          CALL wad_lmt(sshb, zcoef * (emp_b(:,:) + emp(:,:)), z2dt) 
    95       ENDIF 
    96  
    97       CALL div_hor( kt )                               ! Horizontal divergence 
     98         CALL wad_lmt(pssh(:,:,Kbb), zcoef * (emp_b(:,:) + emp(:,:)), z2dt, Kmm, uu, vv ) 
     99      ENDIF 
     100 
     101      CALL div_hor( kt, Kbb, Kmm )                     ! Horizontal divergence 
    98102      ! 
    99103      zhdiv(:,:) = 0._wp 
    100104      DO jk = 1, jpkm1                                 ! Horizontal divergence of barotropic transports 
    101         zhdiv(:,:) = zhdiv(:,:) + e3t_n(:,:,jk) * hdivn(:,:,jk) 
     105        zhdiv(:,:) = zhdiv(:,:) + e3t(:,:,jk,Kmm) * hdiv(:,:,jk) 
    102106      END DO 
    103107      !                                                ! Sea surface elevation time stepping 
    … …  
    105109      ! compute the vertical velocity which can be used to compute the non-linear terms of the momentum equations. 
    106110      !  
    107       ssha(:,:) = (  sshb(:,:) - z2dt * ( zcoef * ( emp_b(:,:) + emp(:,:) ) + zhdiv(:,:) )  ) * ssmask(:,:) 
     111      pssh(:,:,Kaa) = (  pssh(:,:,Kbb) - z2dt * ( zcoef * ( emp_b(:,:) + emp(:,:) ) + zhdiv(:,:) )  ) * ssmask(:,:) 
    108112      ! 
    109113#if defined key_agrif 
    110       CALL agrif_ssh( kt ) 
     114      Kbb_a = Kbb; Kmm_a = Kmm; Krhs_a = Kaa; CALL agrif_ssh( kt ) 
    111115#endif 
    112116      ! 
    113117      IF ( .NOT.ln_dynspg_ts ) THEN 
    114118         IF( ln_bdy ) THEN 
    115             CALL lbc_lnk( 'sshwzv', ssha, 'T', 1. )    ! Not sure that's necessary 
    116             CALL bdy_ssh( ssha )             ! Duplicate sea level across open boundaries 
     119            CALL lbc_lnk( 'sshwzv', pssh(:,:,Kaa), 'T', 1. )    ! Not sure that's necessary 
     120            CALL bdy_ssh( pssh(:,:,Kaa) )             ! Duplicate sea level across open boundaries 
    117121         ENDIF 
    118122      ENDIF 
    … …  
    121125      !                                           !------------------------------! 
    122126      ! 
    123       IF(ln_ctl)   CALL prt_ctl( tab2d_1=ssha, clinfo1=' ssha  - : ', mask1=tmask ) 
     127      IF(sn_cfctl%l_prtctl)   CALL prt_ctl( tab2d_1=pssh(:,:,Kaa), clinfo1=' pssh(:,:,Kaa)  - : ', mask1=tmask ) 
    124128      ! 
    125129      IF( ln_timing )   CALL timing_stop('ssh_nxt') 
    … …  
    128132 
    129133    
    130    SUBROUTINE wzv( kt ) 
     134   SUBROUTINE wzv( kt, Kbb, Kmm, pww, Kaa ) 
    131135      !!---------------------------------------------------------------------- 
    132136      !!                ***  ROUTINE wzv  *** 
    … …  
    139143      !!        The boundary conditions are w=0 at the bottom (no flux) and. 
    140144      !! 
    141       !! ** action  :   wn      : now vertical velocity 
     145      !! ** action  :   pww      : now vertical velocity 
    142146      !! 
    143147      !! Reference  : Leclair, M., and G. Madec, 2009, Ocean Modelling. 
    144148      !!---------------------------------------------------------------------- 
    145       INTEGER, INTENT(in) ::   kt   ! time step 
     149      INTEGER                         , INTENT(in)    ::   kt             ! time step 
     150      INTEGER                         , INTENT(in)    ::   Kbb, Kmm, Kaa  ! time level indices 
     151      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pww            ! now vertical velocity 
    146152      ! 
    147153      INTEGER  ::   ji, jj, jk   ! dummy loop indices 
    … …  
    157163         IF(lwp) WRITE(numout,*) '~~~~~ ' 
    158164         ! 
    159          wn(:,:,jpk) = 0._wp                  ! bottom boundary condition: w=0 (set once for all) 
     165         pww(:,:,jpk) = 0._wp                  ! bottom boundary condition: w=0 (set once for all) 
    160166      ENDIF 
    161167      !                                           !------------------------------! 
    … …  
    171177            ! horizontal divergence of thickness diffusion transport ( velocity multiplied by e3t) 
    172178            ! - ML - note: computation already done in dom_vvl_sf_nxt. Could be optimized (not critical and clearer this way) 
    173             DO jj = 2, jpjm1 
    174                DO ji = fs_2, fs_jpim1   ! vector opt. 
    175                   zhdiv(ji,jj,jk) = r1_e1e2t(ji,jj) * ( un_td(ji,jj,jk) - un_td(ji-1,jj,jk) + vn_td(ji,jj,jk) - vn_td(ji,jj-1,jk) ) 
    176                END DO 
    177             END DO 
     179            DO_2D_00_00 
     180               zhdiv(ji,jj,jk) = r1_e1e2t(ji,jj) * ( un_td(ji,jj,jk) - un_td(ji-1,jj,jk) + vn_td(ji,jj,jk) - vn_td(ji,jj-1,jk) ) 
     181            END_2D 
    178182         END DO 
    179183         CALL lbc_lnk('sshwzv', zhdiv, 'T', 1.)  ! - ML - Perhaps not necessary: not used for horizontal "connexions" 
    180184         !                             ! Is it problematic to have a wrong vertical velocity in boundary cells? 
    181          !                             ! Same question holds for hdivn. Perhaps just for security 
     185         !                             ! Same question holds for hdiv. Perhaps just for security 
    182186         DO jk = jpkm1, 1, -1                       ! integrate from the bottom the hor. divergence 
    183187            ! computation of w 
    184             wn(:,:,jk) = wn(:,:,jk+1) - (  e3t_n(:,:,jk) * hdivn(:,:,jk) + zhdiv(:,:,jk)    & 
    185                &                         + z1_2dt * ( e3t_a(:,:,jk) - e3t_b(:,:,jk) )     ) * tmask(:,:,jk) 
     188            pww(:,:,jk) = pww(:,:,jk+1) - (  e3t(:,:,jk,Kmm) * hdiv(:,:,jk) + zhdiv(:,:,jk)    & 
     189               &                         + z1_2dt * ( e3t(:,:,jk,Kaa) - e3t(:,:,jk,Kbb) )     ) * tmask(:,:,jk) 
    186190         END DO 
    187          !          IF( ln_vvl_layer ) wn(:,:,:) = 0.e0 
     191         !          IF( ln_vvl_layer ) pww(:,:,:) = 0.e0 
    188192         DEALLOCATE( zhdiv )  
    189193      ELSE   ! z_star and linear free surface cases 
    190194         DO jk = jpkm1, 1, -1                       ! integrate from the bottom the hor. divergence 
    191195            ! computation of w 
    192             wn(:,:,jk) = wn(:,:,jk+1) - (  e3t_n(:,:,jk) * hdivn(:,:,jk)                 & 
    193                &                         + z1_2dt * ( e3t_a(:,:,jk) - e3t_b(:,:,jk) )  ) * tmask(:,:,jk) 
     196            pww(:,:,jk) = pww(:,:,jk+1) - (  e3t(:,:,jk,Kmm) * hdiv(:,:,jk)                 & 
     197               &                         + z1_2dt * ( e3t(:,:,jk,Kaa) - e3t(:,:,jk,Kbb) )  ) * tmask(:,:,jk) 
    194198         END DO 
    195199      ENDIF 
    … …  
    197201      IF( ln_bdy ) THEN 
    198202         DO jk = 1, jpkm1 
    199             wn(:,:,jk) = wn(:,:,jk) * bdytmask(:,:) 
     203            pww(:,:,jk) = pww(:,:,jk) * bdytmask(:,:) 
    200204         END DO 
    201205      ENDIF 
    … …  
    203207#if defined key_agrif  
    204208      IF( .NOT. AGRIF_Root() ) THEN  
    205          IF ((nbondi ==  1).OR.(nbondi == 2)) wn(nlci-1 , :     ,:) = 0.e0      ! east  
    206          IF ((nbondi == -1).OR.(nbondi == 2)) wn(2      , :     ,:) = 0.e0      ! west  
    207          IF ((nbondj ==  1).OR.(nbondj == 2)) wn(:      ,nlcj-1 ,:) = 0.e0      ! north  
    208          IF ((nbondj == -1).OR.(nbondj == 2)) wn(:      ,2      ,:) = 0.e0      ! south  
     209         IF ((nbondi ==  1).OR.(nbondi == 2)) pww(nlci-1 , :     ,:) = 0.e0      ! east  
     210         IF ((nbondi == -1).OR.(nbondi == 2)) pww(2      , :     ,:) = 0.e0      ! west  
     211         IF ((nbondj ==  1).OR.(nbondj == 2)) pww(:      ,nlcj-1 ,:) = 0.e0      ! north  
     212         IF ((nbondj == -1).OR.(nbondj == 2)) pww(:      ,2      ,:) = 0.e0      ! south  
    209213      ENDIF  
    210214#endif  
    … …  
    215219 
    216220 
    217    SUBROUTINE ssh_swp( kt ) 
    218       !!---------------------------------------------------------------------- 
    219       !!                    ***  ROUTINE ssh_nxt  *** 
    220       !! 
    221       !! ** Purpose :   achieve the sea surface  height time stepping by  
    222       !!              applying Asselin time filter and swapping the arrays 
    223       !!              ssha  already computed in ssh_nxt   
     221   SUBROUTINE ssh_atf( kt, Kbb, Kmm, Kaa, pssh ) 
     222      !!---------------------------------------------------------------------- 
     223      !!                    ***  ROUTINE ssh_atf  *** 
     224      !! 
     225      !! ** Purpose :   Apply Asselin time filter to now SSH. 
    224226      !! 
    225227      !! ** Method  : - apply Asselin time fiter to now ssh (excluding the forcing 
    226228      !!              from the filter, see Leclair and Madec 2010) and swap : 
    227       !!                sshn = ssha + atfp * ( sshb -2 sshn + ssha ) 
     229      !!                pssh(:,:,Kmm) = pssh(:,:,Kaa) + atfp * ( pssh(:,:,Kbb) -2 pssh(:,:,Kmm) + pssh(:,:,Kaa) ) 
    228230      !!                            - atfp * rdt * ( emp_b - emp ) / rau0 
    229       !!                sshn = ssha 
    230       !! 
    231       !! ** action  : - sshb, sshn   : before & now sea surface height 
    232       !!                               ready for the next time step 
     231      !! 
     232      !! ** action  : - pssh(:,:,Kmm) time filtered 
    233233      !! 
    234234      !! Reference  : Leclair, M., and G. Madec, 2009, Ocean Modelling. 
    235235      !!---------------------------------------------------------------------- 
    236       INTEGER, INTENT(in) ::   kt   ! ocean time-step index 
     236      INTEGER                         , INTENT(in   ) ::   kt             ! ocean time-step index 
     237      INTEGER                         , INTENT(in   ) ::   Kbb, Kmm, Kaa  ! ocean time level indices 
     238      REAL(wp), DIMENSION(jpi,jpj,jpt), INTENT(inout) ::   pssh           ! SSH field 
    237239      ! 
    238240      REAL(wp) ::   zcoef   ! local scalar 
    239241      !!---------------------------------------------------------------------- 
    240242      ! 
    241       IF( ln_timing )   CALL timing_start('ssh_swp') 
     243      IF( ln_timing )   CALL timing_start('ssh_atf') 
    242244      ! 
    243245      IF( kt == nit000 ) THEN 
    244246         IF(lwp) WRITE(numout,*) 
    245          IF(lwp) WRITE(numout,*) 'ssh_swp : Asselin time filter and swap of sea surface height' 
     247         IF(lwp) WRITE(numout,*) 'ssh_atf : Asselin time filter of sea surface height' 
    246248         IF(lwp) WRITE(numout,*) '~~~~~~~ ' 
    247249      ENDIF 
    248250      !              !==  Euler time-stepping: no filter, just swap  ==! 
    249       IF ( neuler == 0 .AND. kt == nit000 ) THEN 
    250          sshn(:,:) = ssha(:,:)                              ! now    <-- after  (before already = now) 
    251          ! 
    252       ELSE           !==  Leap-Frog time-stepping: Asselin filter + swap  ==! 
    253          !                                                  ! before <-- now filtered 
    254          sshb(:,:) = sshn(:,:) + atfp * ( sshb(:,:) - 2 * sshn(:,:) + ssha(:,:) ) 
    255          IF( .NOT.ln_linssh ) THEN                          ! before <-- with forcing removed 
     251      IF ( .NOT.( neuler == 0 .AND. kt == nit000 ) ) THEN   ! Only do time filtering for leapfrog timesteps 
     252         !                                                  ! filtered "now" field 
     253         pssh(:,:,Kmm) = pssh(:,:,Kmm) + atfp * ( pssh(:,:,Kbb) - 2 * pssh(:,:,Kmm) + pssh(:,:,Kaa) ) 
     254         IF( .NOT.ln_linssh ) THEN                          ! "now" <-- with forcing removed 
    256255            zcoef = atfp * rdt * r1_rau0 
    257             sshb(:,:) = sshb(:,:) - zcoef * (     emp_b(:,:) - emp   (:,:)   & 
    258                &                             -    rnf_b(:,:) + rnf   (:,:)   & 
    259                &                             + fwfisf_b(:,:) - fwfisf(:,:)   ) * ssmask(:,:) 
     256            pssh(:,:,Kmm) = pssh(:,:,Kmm) - zcoef * (     emp_b(:,:) - emp   (:,:)   & 
     257               &                             - rnf_b(:,:)        + rnf   (:,:)       & 
     258               &                             + fwfisf_cav_b(:,:) - fwfisf_cav(:,:)   & 
     259               &                             + fwfisf_par_b(:,:) - fwfisf_par(:,:)   ) * ssmask(:,:) 
     260 
     261            ! ice sheet coupling 
     262            IF ( ln_isf .AND. ln_isfcpl .AND. kt == nit000+1) pssh(:,:,Kbb) = pssh(:,:,Kbb) - atfp * rdt * ( risfcpl_ssh(:,:) - 0.0 ) * ssmask(:,:) 
     263 
    260264         ENDIF 
    261          sshn(:,:) = ssha(:,:)                              ! now <-- after 
    262       ENDIF 
    263       ! 
    264       IF(ln_ctl)   CALL prt_ctl( tab2d_1=sshb, clinfo1=' sshb  - : ', mask1=tmask ) 
    265       ! 
    266       IF( ln_timing )   CALL timing_stop('ssh_swp') 
    267       ! 
    268    END SUBROUTINE ssh_swp 
    269  
    270    SUBROUTINE wAimp( kt ) 
     265      ENDIF 
     266      ! 
     267      IF(sn_cfctl%l_prtctl)   CALL prt_ctl( tab2d_1=pssh(:,:,Kmm), clinfo1=' pssh(:,:,Kmm)  - : ', mask1=tmask ) 
     268      ! 
     269      IF( ln_timing )   CALL timing_stop('ssh_atf') 
     270      ! 
     271   END SUBROUTINE ssh_atf 
     272 
     273   SUBROUTINE wAimp( kt, Kmm ) 
    271274      !!---------------------------------------------------------------------- 
    272275      !!                ***  ROUTINE wAimp  *** 
    … …  
    277280      !! ** Method  : -  
    278281      !! 
    279       !! ** action  :   wn      : now vertical velocity (to be handled explicitly) 
     282      !! ** action  :   ww      : now vertical velocity (to be handled explicitly) 
    280283      !!            :   wi      : now vertical velocity (for implicit treatment) 
    281284      !! 
    … …  
    285288      !!---------------------------------------------------------------------- 
    286289      INTEGER, INTENT(in) ::   kt   ! time step 
     290      INTEGER, INTENT(in) ::   Kmm  ! time level index 
    287291      ! 
    288292      INTEGER  ::   ji, jj, jk   ! dummy loop indices 
    … …  
    305309      ! Calculate Courant numbers 
    306310      IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN 
    307          DO jk = 1, jpkm1 
    308             DO jj = 2, jpjm1 
    309                DO ji = 2, fs_jpim1   ! vector opt. 
    310                   z1_e3t = 1._wp / e3t_n(ji,jj,jk) 
    311                   ! 2*rdt and not r2dt (for restartability) 
    312                   Cu_adv(ji,jj,jk) = 2._wp * rdt * ( ( MAX( wn(ji,jj,jk) , 0._wp ) - MIN( wn(ji,jj,jk+1) , 0._wp ) )                       &   
    313                      &                             + ( MAX( e2u(ji  ,jj)*e3u_n(ji  ,jj,jk)*un(ji  ,jj,jk) + un_td(ji  ,jj,jk), 0._wp ) -   & 
    314                      &                                 MIN( e2u(ji-1,jj)*e3u_n(ji-1,jj,jk)*un(ji-1,jj,jk) + un_td(ji-1,jj,jk), 0._wp ) )   & 
    315                      &                               * r1_e1e2t(ji,jj)                                                                     & 
    316                      &                             + ( MAX( e1v(ji,jj  )*e3v_n(ji,jj  ,jk)*vn(ji,jj  ,jk) + vn_td(ji,jj  ,jk), 0._wp ) -   & 
    317                      &                                 MIN( e1v(ji,jj-1)*e3v_n(ji,jj-1,jk)*vn(ji,jj-1,jk) + vn_td(ji,jj-1,jk), 0._wp ) )   & 
    318                      &                               * r1_e1e2t(ji,jj)                                                                     & 
    319                      &                             ) * z1_e3t 
    320                END DO 
    321             END DO 
    322          END DO 
     311         DO_3D_00_00( 1, jpkm1 ) 
     312            z1_e3t = 1._wp / e3t(ji,jj,jk,Kmm) 
     313            ! 2*rdt and not r2dt (for restartability) 
     314            Cu_adv(ji,jj,jk) = 2._wp * rdt * ( ( MAX( ww(ji,jj,jk) , 0._wp ) - MIN( ww(ji,jj,jk+1) , 0._wp ) )                       &   
     315               &                             + ( MAX( e2u(ji  ,jj)*e3u(ji  ,jj,jk,Kmm)*uu(ji  ,jj,jk,Kmm) + un_td(ji  ,jj,jk), 0._wp ) -   & 
     316               &                                 MIN( e2u(ji-1,jj)*e3u(ji-1,jj,jk,Kmm)*uu(ji-1,jj,jk,Kmm) + un_td(ji-1,jj,jk), 0._wp ) )   & 
     317               &                               * r1_e1e2t(ji,jj)                                                                     & 
     318               &                             + ( MAX( e1v(ji,jj  )*e3v(ji,jj  ,jk,Kmm)*vv(ji,jj  ,jk,Kmm) + vn_td(ji,jj  ,jk), 0._wp ) -   & 
     319               &                                 MIN( e1v(ji,jj-1)*e3v(ji,jj-1,jk,Kmm)*vv(ji,jj-1,jk,Kmm) + vn_td(ji,jj-1,jk), 0._wp ) )   & 
     320               &                               * r1_e1e2t(ji,jj)                                                                     & 
     321               &                             ) * z1_e3t 
     322         END_3D 
    323323      ELSE 
    324          DO jk = 1, jpkm1 
    325             DO jj = 2, jpjm1 
    326                DO ji = 2, fs_jpim1   ! vector opt. 
    327                   z1_e3t = 1._wp / e3t_n(ji,jj,jk) 
    328                   ! 2*rdt and not r2dt (for restartability) 
    329                   Cu_adv(ji,jj,jk) = 2._wp * rdt * ( ( MAX( wn(ji,jj,jk) , 0._wp ) - MIN( wn(ji,jj,jk+1) , 0._wp ) )   &  
    330                      &                             + ( MAX( e2u(ji  ,jj)*e3u_n(ji  ,jj,jk)*un(ji  ,jj,jk), 0._wp ) -   & 
    331                      &                                 MIN( e2u(ji-1,jj)*e3u_n(ji-1,jj,jk)*un(ji-1,jj,jk), 0._wp ) )   & 
    332                      &                               * r1_e1e2t(ji,jj)                                                 & 
    333                      &                             + ( MAX( e1v(ji,jj  )*e3v_n(ji,jj  ,jk)*vn(ji,jj  ,jk), 0._wp ) -   & 
    334                      &                                 MIN( e1v(ji,jj-1)*e3v_n(ji,jj-1,jk)*vn(ji,jj-1,jk), 0._wp ) )   & 
    335                      &                               * r1_e1e2t(ji,jj)                                                 & 
    336                      &                             ) * z1_e3t 
    337                END DO 
    338             END DO 
    339          END DO 
     324         DO_3D_00_00( 1, jpkm1 ) 
     325            z1_e3t = 1._wp / e3t(ji,jj,jk,Kmm) 
     326            ! 2*rdt and not r2dt (for restartability) 
     327            Cu_adv(ji,jj,jk) = 2._wp * rdt * ( ( MAX( ww(ji,jj,jk) , 0._wp ) - MIN( ww(ji,jj,jk+1) , 0._wp ) )   &  
     328               &                             + ( MAX( e2u(ji  ,jj)*e3u(ji  ,jj,jk,Kmm)*uu(ji  ,jj,jk,Kmm), 0._wp ) -   & 
     329               &                                 MIN( e2u(ji-1,jj)*e3u(ji-1,jj,jk,Kmm)*uu(ji-1,jj,jk,Kmm), 0._wp ) )   & 
     330               &                               * r1_e1e2t(ji,jj)                                                 & 
     331               &                             + ( MAX( e1v(ji,jj  )*e3v(ji,jj  ,jk,Kmm)*vv(ji,jj  ,jk,Kmm), 0._wp ) -   & 
     332               &                                 MIN( e1v(ji,jj-1)*e3v(ji,jj-1,jk,Kmm)*vv(ji,jj-1,jk,Kmm), 0._wp ) )   & 
     333               &                               * r1_e1e2t(ji,jj)                                                 & 
     334               &                             ) * z1_e3t 
     335         END_3D 
    340336      ENDIF 
    341337      CALL lbc_lnk( 'sshwzv', Cu_adv, 'T', 1. ) 
    … …  
    344340      ! 
    345341      IF( MAXVAL( Cu_adv(:,:,:) ) > Cu_min ) THEN       ! Quick check if any breaches anywhere 
    346          DO jk = jpkm1, 2, -1                           ! or scan Courant criterion and partition 
    347             DO jj = 1, jpj                              ! w where necessary 
    348                DO ji = 1, jpi 
    349                   ! 
    350                   zCu = MAX( Cu_adv(ji,jj,jk) , Cu_adv(ji,jj,jk-1) ) 
     342         DO_3DS_11_11( jpkm1, 2, -1 ) 
     343            ! 
     344            zCu = MAX( Cu_adv(ji,jj,jk) , Cu_adv(ji,jj,jk-1) ) 
    351345! alt: 
    352 !                  IF ( wn(ji,jj,jk) > 0._wp ) THEN  
     346!                  IF ( ww(ji,jj,jk) > 0._wp ) THEN  
    353347!                     zCu =  Cu_adv(ji,jj,jk)  
    354348!                  ELSE 
    355349!                     zCu =  Cu_adv(ji,jj,jk-1) 
    356350!                  ENDIF  
    357                   ! 
    358                   IF( zCu <= Cu_min ) THEN              !<-- Fully explicit 
    359                      zcff = 0._wp 
    360                   ELSEIF( zCu < Cu_cut ) THEN           !<-- Mixed explicit 
    361                      zcff = ( zCu - Cu_min )**2 
    362                      zcff = zcff / ( Fcu + zcff ) 
    363                   ELSE                                  !<-- Mostly implicit 
    364                      zcff = ( zCu - Cu_max )/ zCu 
    365                   ENDIF 
    366                   zcff = MIN(1._wp, zcff) 
    367                   ! 
    368                   wi(ji,jj,jk) =           zcff   * wn(ji,jj,jk) 
    369                   wn(ji,jj,jk) = ( 1._wp - zcff ) * wn(ji,jj,jk) 
    370                   ! 
    371                   Cu_adv(ji,jj,jk) = zcff               ! Reuse array to output coefficient below and in stp_ctl 
    372                END DO 
    373             END DO 
    374          END DO 
     351            ! 
     352            IF( zCu <= Cu_min ) THEN              !<-- Fully explicit 
     353               zcff = 0._wp 
     354            ELSEIF( zCu < Cu_cut ) THEN           !<-- Mixed explicit 
     355               zcff = ( zCu - Cu_min )**2 
     356               zcff = zcff / ( Fcu + zcff ) 
     357            ELSE                                  !<-- Mostly implicit 
     358               zcff = ( zCu - Cu_max )/ zCu 
     359            ENDIF 
     360            zcff = MIN(1._wp, zcff) 
     361            ! 
     362            wi(ji,jj,jk) =           zcff   * ww(ji,jj,jk) 
     363            ww(ji,jj,jk) = ( 1._wp - zcff ) * ww(ji,jj,jk) 
     364            ! 
     365            Cu_adv(ji,jj,jk) = zcff               ! Reuse array to output coefficient below and in stp_ctl 
     366         END_3D 
    375367         Cu_adv(:,:,1) = 0._wp  
    376368      ELSE 
    … …  
    381373      CALL iom_put("wimp",wi)  
    382374      CALL iom_put("wi_cff",Cu_adv) 
    383       CALL iom_put("wexp",wn) 
     375      CALL iom_put("wexp",ww) 
    384376      ! 
    385377      IF( ln_timing )   CALL timing_stop('wAimp') 

  • NEMO/trunk/src/OCE/DYN/wet_dry.F90

    r11536 r12377  
    3131   PRIVATE 
    3232 
     33   !! * Substitutions 
     34#  include "do_loop_substitute.h90" 
    3335   !!---------------------------------------------------------------------- 
    3436   !! critical depths,filters, limiters,and masks for  Wetting and Drying 
    … …  
    6163 
    6264   !! * Substitutions 
    63 #  include "vectopt_loop_substitute.h90" 
    6465   !!---------------------------------------------------------------------- 
    6566CONTAINS 
    … …  
    7980      !!---------------------------------------------------------------------- 
    8081      ! 
    81       REWIND( numnam_ref )              ! Namelist namwad in reference namelist : Parameters for Wetting/Drying 
    8282      READ  ( numnam_ref, namwad, IOSTAT = ios, ERR = 905) 
    8383905   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namwad in reference namelist' )  
    84       REWIND( numnam_cfg )              ! Namelist namwad in configuration namelist : Parameters for Wetting/Drying 
    8584      READ  ( numnam_cfg, namwad, IOSTAT = ios, ERR = 906) 
    8685906   IF( ios >  0 )   CALL ctl_nam ( ios , 'namwad in configuration namelist' ) 
    … …  
    122121 
    123122 
    124    SUBROUTINE wad_lmt( sshb1, sshemp, z2dt ) 
     123   SUBROUTINE wad_lmt( psshb1, psshemp, z2dt, Kmm, puu, pvv ) 
    125124      !!---------------------------------------------------------------------- 
    126125      !!                  ***  ROUTINE wad_lmt  *** 
    … …  
    132131      !! ** Action  : - calculate flux limiter and W/D flag 
    133132      !!---------------------------------------------------------------------- 
    134       REAL(wp), DIMENSION(:,:), INTENT(inout) ::   sshb1        !!gm DOCTOR names: should start with p ! 
    135       REAL(wp), DIMENSION(:,:), INTENT(in   ) ::   sshemp 
    136       REAL(wp)                , INTENT(in   ) ::   z2dt 
     133      REAL(wp), DIMENSION(:,:)            , INTENT(inout) ::   psshb1 
     134      REAL(wp), DIMENSION(:,:)            , INTENT(in   ) ::   psshemp 
     135      REAL(wp)                            , INTENT(in   ) ::   z2dt 
     136      INTEGER                             , INTENT(in   ) ::   Kmm       ! time level index 
     137      REAL(wp), DIMENSION(jpi,jpj,jpk,jpt), INTENT(inout) ::   puu, pvv  ! velocity arrays 
    137138      ! 
    138139      INTEGER  ::   ji, jj, jk, jk1     ! dummy loop indices 
    … …  
    150151      ! 
    151152      DO jk = 1, jpkm1 
    152          un(:,:,jk) = un(:,:,jk) * zwdlmtu(:,:)  
    153          vn(:,:,jk) = vn(:,:,jk) * zwdlmtv(:,:)  
     153         puu(:,:,jk,Kmm) = puu(:,:,jk,Kmm) * zwdlmtu(:,:)  
     154         pvv(:,:,jk,Kmm) = pvv(:,:,jk,Kmm) * zwdlmtv(:,:)  
    154155      END DO 
    155156      jflag  = 0 
    … …  
    165166      ! 
    166167      DO jk = 1, jpkm1     ! Horizontal Flux in u and v direction 
    167          zflxu(:,:) = zflxu(:,:) + e3u_n(:,:,jk) * un(:,:,jk) * umask(:,:,jk) 
    168          zflxv(:,:) = zflxv(:,:) + e3v_n(:,:,jk) * vn(:,:,jk) * vmask(:,:,jk) 
     168         zflxu(:,:) = zflxu(:,:) + e3u(:,:,jk,Kmm) * puu(:,:,jk,Kmm) * umask(:,:,jk) 
     169         zflxv(:,:) = zflxv(:,:) + e3v(:,:,jk,Kmm) * pvv(:,:,jk,Kmm) * vmask(:,:,jk) 
    169170      END DO 
    170171      zflxu(:,:) = zflxu(:,:) * e2u(:,:) 
    … …  
    172173      ! 
    173174      wdmask(:,:) = 1._wp 
    174       DO jj = 2, jpj 
    175          DO ji = 2, jpi  
    176             ! 
    177             IF( tmask(ji,jj,1)        < 0.5_wp )   CYCLE    ! we don't care about land cells 
    178             IF( ht_0(ji,jj) - ssh_ref > zdepwd )   CYCLE    ! and cells which are unlikely to dry 
    179             ! 
    180             zflxp(ji,jj) = MAX( zflxu(ji,jj) , 0._wp ) - MIN( zflxu(ji-1,jj  ) , 0._wp )   & 
    181                &         + MAX( zflxv(ji,jj) , 0._wp ) - MIN( zflxv(ji,  jj-1) , 0._wp )  
    182             zflxn(ji,jj) = MIN( zflxu(ji,jj) , 0._wp ) - MAX( zflxu(ji-1,jj  ) , 0._wp )   & 
    183                &         + MIN( zflxv(ji,jj) , 0._wp ) - MAX( zflxv(ji,  jj-1) , 0._wp )  
    184             ! 
    185             zdep2 = ht_0(ji,jj) + sshb1(ji,jj) - rn_wdmin1 
    186             IF( zdep2 <= 0._wp ) THEN     ! add more safty, but not necessary 
    187                sshb1(ji,jj) = rn_wdmin1 - ht_0(ji,jj) 
    188                IF(zflxu(ji,  jj) > 0._wp) zwdlmtu(ji  ,jj) = 0._wp 
    189                IF(zflxu(ji-1,jj) < 0._wp) zwdlmtu(ji-1,jj) = 0._wp 
    190                IF(zflxv(ji,  jj) > 0._wp) zwdlmtv(ji  ,jj) = 0._wp 
    191                IF(zflxv(ji,jj-1) < 0._wp) zwdlmtv(ji,jj-1) = 0._wp  
    192                wdmask(ji,jj) = 0._wp 
    193             END IF 
    194          END DO 
    195       END DO 
     175      DO_2D_01_01 
     176         ! 
     177         IF( tmask(ji,jj,1)        < 0.5_wp )   CYCLE    ! we don't care about land cells 
     178         IF( ht_0(ji,jj) - ssh_ref > zdepwd )   CYCLE    ! and cells which are unlikely to dry 
     179         ! 
     180         zflxp(ji,jj) = MAX( zflxu(ji,jj) , 0._wp ) - MIN( zflxu(ji-1,jj  ) , 0._wp )   & 
     181            &         + MAX( zflxv(ji,jj) , 0._wp ) - MIN( zflxv(ji,  jj-1) , 0._wp )  
     182         zflxn(ji,jj) = MIN( zflxu(ji,jj) , 0._wp ) - MAX( zflxu(ji-1,jj  ) , 0._wp )   & 
     183            &         + MIN( zflxv(ji,jj) , 0._wp ) - MAX( zflxv(ji,  jj-1) , 0._wp )  
     184         ! 
     185         zdep2 = ht_0(ji,jj) + psshb1(ji,jj) - rn_wdmin1 
     186         IF( zdep2 <= 0._wp ) THEN     ! add more safty, but not necessary 
     187            psshb1(ji,jj) = rn_wdmin1 - ht_0(ji,jj) 
     188            IF(zflxu(ji,  jj) > 0._wp) zwdlmtu(ji  ,jj) = 0._wp 
     189            IF(zflxu(ji-1,jj) < 0._wp) zwdlmtu(ji-1,jj) = 0._wp 
     190            IF(zflxv(ji,  jj) > 0._wp) zwdlmtv(ji  ,jj) = 0._wp 
     191            IF(zflxv(ji,jj-1) < 0._wp) zwdlmtv(ji,jj-1) = 0._wp  
     192            wdmask(ji,jj) = 0._wp 
     193         END IF 
     194      END_2D 
    196195      ! 
    197196      !           ! HPG limiter from jholt 
    198       wdramp(:,:) = min((ht_0(:,:) + sshb1(:,:) - rn_wdmin1)/(rn_wdmin0 - rn_wdmin1),1.0_wp) 
     197      wdramp(:,:) = min((ht_0(:,:) + psshb1(:,:) - rn_wdmin1)/(rn_wdmin0 - rn_wdmin1),1.0_wp) 
    199198      !jth assume don't need a lbc_lnk here 
    200       DO jj = 1, jpjm1 
    201          DO ji = 1, jpim1 
    202             wdrampu(ji,jj) = MIN( wdramp(ji,jj) , wdramp(ji+1,jj) ) 
    203             wdrampv(ji,jj) = MIN( wdramp(ji,jj) , wdramp(ji,jj+1) ) 
    204          END DO 
    205       END DO 
     199      DO_2D_10_10 
     200         wdrampu(ji,jj) = MIN( wdramp(ji,jj) , wdramp(ji+1,jj) ) 
     201         wdrampv(ji,jj) = MIN( wdramp(ji,jj) , wdramp(ji,jj+1) ) 
     202      END_2D 
    206203      !           ! end HPG limiter 
    207204      ! 
    … …  
    213210         jflag = 0     ! flag indicating if any further iterations are needed 
    214211         ! 
    215          DO jj = 2, jpj 
    216             DO ji = 2, jpi  
    217                IF( tmask(ji, jj, 1) < 0.5_wp )   CYCLE  
    218                IF( ht_0(ji,jj)      > zdepwd )   CYCLE 
    219                ! 
    220                ztmp = e1e2t(ji,jj) 
    221                ! 
    222                zzflxp = MAX( zflxu1(ji,jj) , 0._wp ) - MIN( zflxu1(ji-1,jj  ) , 0._wp)   & 
    223                   &   + MAX( zflxv1(ji,jj) , 0._wp ) - MIN( zflxv1(ji,  jj-1) , 0._wp)  
    224                zzflxn = MIN( zflxu1(ji,jj) , 0._wp ) - MAX( zflxu1(ji-1,jj  ) , 0._wp)   & 
    225                   &   + MIN( zflxv1(ji,jj) , 0._wp ) - MAX( zflxv1(ji,  jj-1) , 0._wp)  
    226                ! 
    227                zdep1 = (zzflxp + zzflxn) * z2dt / ztmp 
    228                zdep2 = ht_0(ji,jj) + sshb1(ji,jj) - rn_wdmin1 - z2dt * sshemp(ji,jj) 
    229                ! 
    230                IF( zdep1 > zdep2 ) THEN 
    231                   wdmask(ji, jj) = 0._wp 
    232                   zcoef = ( ( zdep2 - rn_wdmin2 ) * ztmp - zzflxn * z2dt ) / ( zflxp(ji,jj) * z2dt ) 
    233                   !zcoef = ( ( zdep2 - rn_wdmin2 ) * ztmp - zzflxn * z2dt ) / ( zzflxp * z2dt ) 
    234                   ! flag if the limiter has been used but stop flagging if the only 
    235                   ! changes have zeroed the coefficient since further iterations will 
    236                   ! not change anything 
    237                   IF( zcoef > 0._wp ) THEN   ;   jflag = 1  
    238                   ELSE                       ;   zcoef = 0._wp 
    239                   ENDIF 
    240                   IF( jk1 > nn_wdit )   zcoef = 0._wp 
    241                   IF( zflxu1(ji  ,jj  ) > 0._wp )   zwdlmtu(ji  ,jj  ) = zcoef 
    242                   IF( zflxu1(ji-1,jj  ) < 0._wp )   zwdlmtu(ji-1,jj  ) = zcoef 
    243                   IF( zflxv1(ji  ,jj  ) > 0._wp )   zwdlmtv(ji  ,jj  ) = zcoef 
    244                   IF( zflxv1(ji  ,jj-1) < 0._wp )   zwdlmtv(ji  ,jj-1) = zcoef 
     212         DO_2D_01_01 
     213            IF( tmask(ji, jj, 1) < 0.5_wp )   CYCLE  
     214            IF( ht_0(ji,jj)      > zdepwd )   CYCLE 
     215            ! 
     216            ztmp = e1e2t(ji,jj) 
     217            ! 
     218            zzflxp = MAX( zflxu1(ji,jj) , 0._wp ) - MIN( zflxu1(ji-1,jj  ) , 0._wp)   & 
     219               &   + MAX( zflxv1(ji,jj) , 0._wp ) - MIN( zflxv1(ji,  jj-1) , 0._wp)  
     220            zzflxn = MIN( zflxu1(ji,jj) , 0._wp ) - MAX( zflxu1(ji-1,jj  ) , 0._wp)   & 
     221               &   + MIN( zflxv1(ji,jj) , 0._wp ) - MAX( zflxv1(ji,  jj-1) , 0._wp)  
     222            ! 
     223            zdep1 = (zzflxp + zzflxn) * z2dt / ztmp 
     224            zdep2 = ht_0(ji,jj) + psshb1(ji,jj) - rn_wdmin1 - z2dt * psshemp(ji,jj) 
     225            ! 
     226            IF( zdep1 > zdep2 ) THEN 
     227               wdmask(ji, jj) = 0._wp 
     228               zcoef = ( ( zdep2 - rn_wdmin2 ) * ztmp - zzflxn * z2dt ) / ( zflxp(ji,jj) * z2dt ) 
     229               !zcoef = ( ( zdep2 - rn_wdmin2 ) * ztmp - zzflxn * z2dt ) / ( zzflxp * z2dt ) 
     230               ! flag if the limiter has been used but stop flagging if the only 
     231               ! changes have zeroed the coefficient since further iterations will 
     232               ! not change anything 
     233               IF( zcoef > 0._wp ) THEN   ;   jflag = 1  
     234               ELSE                       ;   zcoef = 0._wp 
    245235               ENDIF 
    246             END DO 
    247          END DO 
     236               IF( jk1 > nn_wdit )   zcoef = 0._wp 
     237               IF( zflxu1(ji  ,jj  ) > 0._wp )   zwdlmtu(ji  ,jj  ) = zcoef 
     238               IF( zflxu1(ji-1,jj  ) < 0._wp )   zwdlmtu(ji-1,jj  ) = zcoef 
     239               IF( zflxv1(ji  ,jj  ) > 0._wp )   zwdlmtv(ji  ,jj  ) = zcoef 
     240               IF( zflxv1(ji  ,jj-1) < 0._wp )   zwdlmtv(ji  ,jj-1) = zcoef 
     241            ENDIF 
     242         END_2D 
    248243         CALL lbc_lnk_multi( 'wet_dry', zwdlmtu, 'U', 1., zwdlmtv, 'V', 1. ) 
    249244         ! 
    … …  
    255250      ! 
    256251      DO jk = 1, jpkm1 
    257          un(:,:,jk) = un(:,:,jk) * zwdlmtu(:,:)  
    258          vn(:,:,jk) = vn(:,:,jk) * zwdlmtv(:,:)  
     252         puu(:,:,jk,Kmm) = puu(:,:,jk,Kmm) * zwdlmtu(:,:)  
     253         pvv(:,:,jk,Kmm) = pvv(:,:,jk,Kmm) * zwdlmtv(:,:)  
    259254      END DO 
    260       un_b(:,:) = un_b(:,:) * zwdlmtu(:, :) 
    261       vn_b(:,:) = vn_b(:,:) * zwdlmtv(:, :) 
     255      uu_b(:,:,Kmm) = uu_b(:,:,Kmm) * zwdlmtu(:, :) 
     256      vv_b(:,:,Kmm) = vv_b(:,:,Kmm) * zwdlmtv(:, :) 
    262257      ! 
    263258!!gm TO BE SUPPRESSED ?  these lbc_lnk are useless since zwdlmtu and zwdlmtv are defined everywhere ! 
    264       CALL lbc_lnk_multi( 'wet_dry', un  , 'U', -1., vn  , 'V', -1. ) 
    265       CALL lbc_lnk_multi( 'wet_dry', un_b, 'U', -1., vn_b, 'V', -1. ) 
     259      CALL lbc_lnk_multi( 'wet_dry', puu(:,:,:,Kmm)  , 'U', -1., pvv(:,:,:,Kmm)  , 'V', -1. ) 
     260      CALL lbc_lnk_multi( 'wet_dry', uu_b(:,:,Kmm), 'U', -1., vv_b(:,:,Kmm), 'V', -1. ) 
    266261!!gm 
    267262      ! 
    268263      IF(jflag == 1 .AND. lwp)   WRITE(numout,*) 'Need more iterations in wad_lmt!!!' 
    269264      ! 
    270       !IF( ln_rnf      )   CALL sbc_rnf_div( hdivn )          ! runoffs (update hdivn field) 
     265      !IF( ln_rnf      )   CALL sbc_rnf_div( hdiv )          ! runoffs (update hdiv field) 
    271266      ! 
    272267      IF( ln_timing )   CALL timing_stop('wad_lmt')      ! 
    … …  
    311306      zwdlmtv(:,:) = 1._wp 
    312307      ! 
    313       DO jj = 2, jpj      ! Horizontal Flux in u and v direction 
    314          DO ji = 2, jpi  
    315             ! 
    316             IF( tmask(ji, jj, 1 ) < 0.5_wp) CYCLE   ! we don't care about land cells 
    317             IF( ht_0(ji,jj) > zdepwd )      CYCLE   ! and cells which are unlikely to dry 
    318             ! 
    319             zflxp(ji,jj) = MAX( zflxu(ji,jj) , 0._wp ) - MIN( zflxu(ji-1,jj  ) , 0._wp )   & 
    320                &         + MAX( zflxv(ji,jj) , 0._wp ) - MIN( zflxv(ji,  jj-1) , 0._wp )  
    321             zflxn(ji,jj) = MIN( zflxu(ji,jj) , 0._wp ) - MAX( zflxu(ji-1,jj  ) , 0._wp )   & 
    322                &         + MIN( zflxv(ji,jj) , 0._wp ) - MAX( zflxv(ji,  jj-1) , 0._wp )  
    323             ! 
    324             zdep2 = ht_0(ji,jj) + sshn_e(ji,jj) - rn_wdmin1 
    325             IF( zdep2 <= 0._wp ) THEN  !add more safety, but not necessary 
    326               sshn_e(ji,jj) = rn_wdmin1 - ht_0(ji,jj) 
    327               IF( zflxu(ji  ,jj  ) > 0._wp)   zwdlmtu(ji  ,jj  ) = 0._wp 
    328               IF( zflxu(ji-1,jj  ) < 0._wp)   zwdlmtu(ji-1,jj  ) = 0._wp 
    329               IF( zflxv(ji  ,jj  ) > 0._wp)   zwdlmtv(ji  ,jj  ) = 0._wp 
    330               IF( zflxv(ji  ,jj-1) < 0._wp)   zwdlmtv(ji  ,jj-1) = 0._wp  
    331             ENDIF 
    332          END DO 
    333       END DO 
     308      DO_2D_01_01 
     309         ! 
     310         IF( tmask(ji, jj, 1 ) < 0.5_wp) CYCLE   ! we don't care about land cells 
     311         IF( ht_0(ji,jj) > zdepwd )      CYCLE   ! and cells which are unlikely to dry 
     312         ! 
     313         zflxp(ji,jj) = MAX( zflxu(ji,jj) , 0._wp ) - MIN( zflxu(ji-1,jj  ) , 0._wp )   & 
     314            &         + MAX( zflxv(ji,jj) , 0._wp ) - MIN( zflxv(ji,  jj-1) , 0._wp )  
     315         zflxn(ji,jj) = MIN( zflxu(ji,jj) , 0._wp ) - MAX( zflxu(ji-1,jj  ) , 0._wp )   & 
     316            &         + MIN( zflxv(ji,jj) , 0._wp ) - MAX( zflxv(ji,  jj-1) , 0._wp )  
     317         ! 
     318         zdep2 = ht_0(ji,jj) + sshn_e(ji,jj) - rn_wdmin1 
     319         IF( zdep2 <= 0._wp ) THEN  !add more safety, but not necessary 
     320           sshn_e(ji,jj) = rn_wdmin1 - ht_0(ji,jj) 
     321           IF( zflxu(ji  ,jj  ) > 0._wp)   zwdlmtu(ji  ,jj  ) = 0._wp 
     322           IF( zflxu(ji-1,jj  ) < 0._wp)   zwdlmtu(ji-1,jj  ) = 0._wp 
     323           IF( zflxv(ji  ,jj  ) > 0._wp)   zwdlmtv(ji  ,jj  ) = 0._wp 
     324           IF( zflxv(ji  ,jj-1) < 0._wp)   zwdlmtv(ji  ,jj-1) = 0._wp  
     325         ENDIF 
     326      END_2D 
    334327      ! 
    335328      DO jk1 = 1, nn_wdit + 1      !! start limiter iterations  
    … …  
    339332         jflag = 0     ! flag indicating if any further iterations are needed 
    340333         ! 
    341          DO jj = 2, jpj 
    342             DO ji = 2, jpi  
    343                ! 
    344                IF( tmask(ji, jj, 1 ) < 0.5_wp )   CYCLE  
    345                IF( ht_0(ji,jj)       > zdepwd )   CYCLE 
    346                ! 
    347                ztmp = e1e2t(ji,jj) 
    348                ! 
    349                zzflxp = max(zflxu1(ji,jj), 0._wp) - min(zflxu1(ji-1,jj),   0._wp)   & 
    350                   &   + max(zflxv1(ji,jj), 0._wp) - min(zflxv1(ji,  jj-1), 0._wp)  
    351                zzflxn = min(zflxu1(ji,jj), 0._wp) - max(zflxu1(ji-1,jj),   0._wp)   & 
    352                   &   + min(zflxv1(ji,jj), 0._wp) - max(zflxv1(ji,  jj-1), 0._wp)  
    353            
    354                zdep1 = (zzflxp + zzflxn) * z2dt / ztmp 
    355                zdep2 = ht_0(ji,jj) + sshn_e(ji,jj) - rn_wdmin1 - z2dt * zssh_frc(ji,jj) 
    356            
    357                IF(zdep1 > zdep2) THEN 
    358                  zcoef = ( ( zdep2 - rn_wdmin2 ) * ztmp - zzflxn * z2dt ) / ( zflxp(ji,jj) * z2dt ) 
    359                  !zcoef = ( ( zdep2 - rn_wdmin2 ) * ztmp - zzflxn * z2dt ) / ( zzflxp * z2dt ) 
    360                  ! flag if the limiter has been used but stop flagging if the only 
    361                  ! changes have zeroed the coefficient since further iterations will 
    362                  ! not change anything 
    363                  IF( zcoef > 0._wp ) THEN 
    364                     jflag = 1  
    365                  ELSE 
    366                     zcoef = 0._wp 
    367                  ENDIF 
    368                  IF(jk1 > nn_wdit) zcoef = 0._wp 
    369                  IF(zflxu1(ji,  jj) > 0._wp) zwdlmtu(ji  ,jj) = zcoef 
    370                  IF(zflxu1(ji-1,jj) < 0._wp) zwdlmtu(ji-1,jj) = zcoef 
    371                  IF(zflxv1(ji,  jj) > 0._wp) zwdlmtv(ji  ,jj) = zcoef 
    372                  IF(zflxv1(ji,jj-1) < 0._wp) zwdlmtv(ji,jj-1) = zcoef 
    373                END IF 
    374             END DO ! ji loop 
    375          END DO  ! jj loop 
     334         DO_2D_01_01 
     335            ! 
     336            IF( tmask(ji, jj, 1 ) < 0.5_wp )   CYCLE  
     337            IF( ht_0(ji,jj)       > zdepwd )   CYCLE 
     338            ! 
     339            ztmp = e1e2t(ji,jj) 
     340            ! 
     341            zzflxp = max(zflxu1(ji,jj), 0._wp) - min(zflxu1(ji-1,jj),   0._wp)   & 
     342               &   + max(zflxv1(ji,jj), 0._wp) - min(zflxv1(ji,  jj-1), 0._wp)  
     343            zzflxn = min(zflxu1(ji,jj), 0._wp) - max(zflxu1(ji-1,jj),   0._wp)   & 
     344               &   + min(zflxv1(ji,jj), 0._wp) - max(zflxv1(ji,  jj-1), 0._wp)  
     345        
     346            zdep1 = (zzflxp + zzflxn) * z2dt / ztmp 
     347            zdep2 = ht_0(ji,jj) + sshn_e(ji,jj) - rn_wdmin1 - z2dt * zssh_frc(ji,jj) 
     348        
     349            IF(zdep1 > zdep2) THEN 
     350              zcoef = ( ( zdep2 - rn_wdmin2 ) * ztmp - zzflxn * z2dt ) / ( zflxp(ji,jj) * z2dt ) 
     351              !zcoef = ( ( zdep2 - rn_wdmin2 ) * ztmp - zzflxn * z2dt ) / ( zzflxp * z2dt ) 
     352              ! flag if the limiter has been used but stop flagging if the only 
     353              ! changes have zeroed the coefficient since further iterations will 
     354              ! not change anything 
     355              IF( zcoef > 0._wp ) THEN 
     356                 jflag = 1  
     357              ELSE 
     358                 zcoef = 0._wp 
     359              ENDIF 
     360              IF(jk1 > nn_wdit) zcoef = 0._wp 
     361              IF(zflxu1(ji,  jj) > 0._wp) zwdlmtu(ji  ,jj) = zcoef 
     362              IF(zflxu1(ji-1,jj) < 0._wp) zwdlmtu(ji-1,jj) = zcoef 
     363              IF(zflxv1(ji,  jj) > 0._wp) zwdlmtv(ji  ,jj) = zcoef 
     364              IF(zflxv1(ji,jj-1) < 0._wp) zwdlmtv(ji,jj-1) = zcoef 
     365            END IF 
     366         END_2D 
    376367         ! 
    377368         CALL lbc_lnk_multi( 'wet_dry', zwdlmtu, 'U', 1., zwdlmtv, 'V', 1. ) 
    … …  
    392383      IF( jflag == 1 .AND. lwp )   WRITE(numout,*) 'Need more iterations in wad_lmt_bt!!!' 
    393384      ! 
    394       !IF( ln_rnf      )   CALL sbc_rnf_div( hdivn )          ! runoffs (update hdivn field) 
     385      !IF( ln_rnf      )   CALL sbc_rnf_div( hdiv )          ! runoffs (update hdiv field) 
    395386      ! 
    396387      IF( ln_timing )   CALL timing_stop('wad_lmt_bt')      ! 
Note: See TracChangeset for help on using the changeset viewer.