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/TRA – 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
21 edited
2 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/TRA/eosbn2.F90

    r11993 r12377  
    2929   !!   eos_insitu_pot: Compute the insitu and surface referenced potential volumic mass 
    3030   !!   eos_insitu_2d : Compute the in situ density for 2d fields 
    31    !!   bn2           : Compute the Brunt-Vaisala frequency 
    3231   !!   bn2           : compute the Brunt-Vaisala frequency 
    3332   !!   eos_pt_from_ct: compute the potential temperature from the Conservative Temperature 
    … …  
    180179 
    181180   !! * Substitutions 
    182 #  include "vectopt_loop_substitute.h90" 
     181#  include "do_loop_substitute.h90" 
    183182   !!---------------------------------------------------------------------- 
    184183   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    238237      CASE( np_teos10, np_eos80 )                !==  polynomial TEOS-10 / EOS-80 ==! 
    239238         ! 
    240          DO jk = 1, jpkm1 
    241             DO jj = 1, jpj 
    242                DO ji = 1, jpi 
    243                   ! 
    244                   zh  = pdep(ji,jj,jk) * r1_Z0                                  ! depth 
    245                   zt  = pts (ji,jj,jk,jp_tem) * r1_T0                           ! temperature 
    246                   zs  = SQRT( ABS( pts(ji,jj,jk,jp_sal) + rdeltaS ) * r1_S0 )   ! square root salinity 
    247                   ztm = tmask(ji,jj,jk)                                         ! tmask 
     239         DO_3D_11_11( 1, jpkm1 ) 
     240            ! 
     241            zh  = pdep(ji,jj,jk) * r1_Z0                                  ! depth 
     242            zt  = pts (ji,jj,jk,jp_tem) * r1_T0                           ! temperature 
     243            zs  = SQRT( ABS( pts(ji,jj,jk,jp_sal) + rdeltaS ) * r1_S0 )   ! square root salinity 
     244            ztm = tmask(ji,jj,jk)                                         ! tmask 
     245            ! 
     246            zn3 = EOS013*zt   & 
     247               &   + EOS103*zs+EOS003 
     248               ! 
     249            zn2 = (EOS022*zt   & 
     250               &   + EOS112*zs+EOS012)*zt   & 
     251               &   + (EOS202*zs+EOS102)*zs+EOS002 
     252               ! 
     253            zn1 = (((EOS041*zt   & 
     254               &   + EOS131*zs+EOS031)*zt   & 
     255               &   + (EOS221*zs+EOS121)*zs+EOS021)*zt   & 
     256               &   + ((EOS311*zs+EOS211)*zs+EOS111)*zs+EOS011)*zt   & 
     257               &   + (((EOS401*zs+EOS301)*zs+EOS201)*zs+EOS101)*zs+EOS001 
     258               ! 
     259            zn0 = (((((EOS060*zt   & 
     260               &   + EOS150*zs+EOS050)*zt   & 
     261               &   + (EOS240*zs+EOS140)*zs+EOS040)*zt   & 
     262               &   + ((EOS330*zs+EOS230)*zs+EOS130)*zs+EOS030)*zt   & 
     263               &   + (((EOS420*zs+EOS320)*zs+EOS220)*zs+EOS120)*zs+EOS020)*zt   & 
     264               &   + ((((EOS510*zs+EOS410)*zs+EOS310)*zs+EOS210)*zs+EOS110)*zs+EOS010)*zt   & 
     265               &   + (((((EOS600*zs+EOS500)*zs+EOS400)*zs+EOS300)*zs+EOS200)*zs+EOS100)*zs+EOS000 
     266               ! 
     267            zn  = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 
     268            ! 
     269            prd(ji,jj,jk) = (  zn * r1_rau0 - 1._wp  ) * ztm  ! density anomaly (masked) 
     270            ! 
     271         END_3D 
     272         ! 
     273      CASE( np_seos )                !==  simplified EOS  ==! 
     274         ! 
     275         DO_3D_11_11( 1, jpkm1 ) 
     276            zt  = pts  (ji,jj,jk,jp_tem) - 10._wp 
     277            zs  = pts  (ji,jj,jk,jp_sal) - 35._wp 
     278            zh  = pdep (ji,jj,jk) 
     279            ztm = tmask(ji,jj,jk) 
     280            ! 
     281            zn =  - rn_a0 * ( 1._wp + 0.5_wp*rn_lambda1*zt + rn_mu1*zh ) * zt   & 
     282               &  + rn_b0 * ( 1._wp - 0.5_wp*rn_lambda2*zs - rn_mu2*zh ) * zs   & 
     283               &  - rn_nu * zt * zs 
     284               !                                  
     285            prd(ji,jj,jk) = zn * r1_rau0 * ztm                ! density anomaly (masked) 
     286         END_3D 
     287         ! 
     288      END SELECT 
     289      ! 
     290      IF(sn_cfctl%l_prtctl)   CALL prt_ctl( tab3d_1=prd, clinfo1=' eos-insitu  : ', kdim=jpk ) 
     291      ! 
     292      IF( ln_timing )   CALL timing_stop('eos-insitu') 
     293      ! 
     294   END SUBROUTINE eos_insitu 
     295 
     296 
     297   SUBROUTINE eos_insitu_pot( pts, prd, prhop, pdep ) 
     298      !!---------------------------------------------------------------------- 
     299      !!                  ***  ROUTINE eos_insitu_pot  *** 
     300      !! 
     301      !! ** Purpose :   Compute the in situ density (ratio rho/rau0) and the 
     302      !!      potential volumic mass (Kg/m3) from potential temperature and 
     303      !!      salinity fields using an equation of state selected in the 
     304      !!     namelist. 
     305      !! 
     306      !! ** Action  : - prd  , the in situ density (no units) 
     307      !!              - prhop, the potential volumic mass (Kg/m3) 
     308      !! 
     309      !!---------------------------------------------------------------------- 
     310      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in   ) ::   pts    ! 1 : potential temperature  [Celsius] 
     311      !                                                                ! 2 : salinity               [psu] 
     312      REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(  out) ::   prd    ! in situ density            [-] 
     313      REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(  out) ::   prhop  ! potential density (surface referenced) 
     314      REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ) ::   pdep   ! depth                      [m] 
     315      ! 
     316      INTEGER  ::   ji, jj, jk, jsmp             ! dummy loop indices 
     317      INTEGER  ::   jdof 
     318      REAL(wp) ::   zt , zh , zstemp, zs , ztm   ! local scalars 
     319      REAL(wp) ::   zn , zn0, zn1, zn2, zn3      !   -      - 
     320      REAL(wp), DIMENSION(:), ALLOCATABLE :: zn0_sto, zn_sto, zsign    ! local vectors 
     321      !!---------------------------------------------------------------------- 
     322      ! 
     323      IF( ln_timing )   CALL timing_start('eos-pot') 
     324      ! 
     325      SELECT CASE ( neos ) 
     326      ! 
     327      CASE( np_teos10, np_eos80 )                !==  polynomial TEOS-10 / EOS-80 ==! 
     328         ! 
     329         ! Stochastic equation of state 
     330         IF ( ln_sto_eos ) THEN 
     331            ALLOCATE(zn0_sto(1:2*nn_sto_eos)) 
     332            ALLOCATE(zn_sto(1:2*nn_sto_eos)) 
     333            ALLOCATE(zsign(1:2*nn_sto_eos)) 
     334            DO jsmp = 1, 2*nn_sto_eos, 2 
     335              zsign(jsmp)   = 1._wp 
     336              zsign(jsmp+1) = -1._wp 
     337            END DO 
     338            ! 
     339            DO_3D_11_11( 1, jpkm1 ) 
     340               ! 
     341               ! compute density (2*nn_sto_eos) times: 
     342               ! (1) for t+dt, s+ds (with the random TS fluctutation computed in sto_pts) 
     343               ! (2) for t-dt, s-ds (with the opposite fluctuation) 
     344               DO jsmp = 1, nn_sto_eos*2 
     345                  jdof   = (jsmp + 1) / 2 
     346                  zh     = pdep(ji,jj,jk) * r1_Z0                                  ! depth 
     347                  zt     = (pts (ji,jj,jk,jp_tem) + pts_ran(ji,jj,jk,jp_tem,jdof) * zsign(jsmp)) * r1_T0    ! temperature 
     348                  zstemp = pts  (ji,jj,jk,jp_sal) + pts_ran(ji,jj,jk,jp_sal,jdof) * zsign(jsmp) 
     349                  zs     = SQRT( ABS( zstemp + rdeltaS ) * r1_S0 )   ! square root salinity 
     350                  ztm    = tmask(ji,jj,jk)                                         ! tmask 
    248351                  ! 
    249352                  zn3 = EOS013*zt   & 
    … …  
    260363                     &   + (((EOS401*zs+EOS301)*zs+EOS201)*zs+EOS101)*zs+EOS001 
    261364                     ! 
    262                   zn0 = (((((EOS060*zt   & 
     365                  zn0_sto(jsmp) = (((((EOS060*zt   & 
    263366                     &   + EOS150*zs+EOS050)*zt   & 
    264367                     &   + (EOS240*zs+EOS140)*zs+EOS040)*zt   & 
    … …  
    268371                     &   + (((((EOS600*zs+EOS500)*zs+EOS400)*zs+EOS300)*zs+EOS200)*zs+EOS100)*zs+EOS000 
    269372                     ! 
    270                   zn  = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 
     373                  zn_sto(jsmp)  = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0_sto(jsmp) 
     374               END DO 
     375               ! 
     376               ! compute stochastic density as the mean of the (2*nn_sto_eos) densities 
     377               prhop(ji,jj,jk) = 0._wp ; prd(ji,jj,jk) = 0._wp 
     378               DO jsmp = 1, nn_sto_eos*2 
     379                  prhop(ji,jj,jk) = prhop(ji,jj,jk) + zn0_sto(jsmp)                      ! potential density referenced at the surface 
    271380                  ! 
    272                   prd(ji,jj,jk) = (  zn * r1_rau0 - 1._wp  ) * ztm  ! density anomaly (masked) 
    273                   ! 
     381                  prd(ji,jj,jk) = prd(ji,jj,jk) + (  zn_sto(jsmp) * r1_rau0 - 1._wp  )   ! density anomaly (masked) 
    274382               END DO 
    275             END DO 
    276          END DO 
    277          ! 
    278       CASE( np_seos )                !==  simplified EOS  ==! 
    279          ! 
    280          DO jk = 1, jpkm1 
    281             DO jj = 1, jpj 
    282                DO ji = 1, jpi 
    283                   zt  = pts  (ji,jj,jk,jp_tem) - 10._wp 
    284                   zs  = pts  (ji,jj,jk,jp_sal) - 35._wp 
    285                   zh  = pdep (ji,jj,jk) 
    286                   ztm = tmask(ji,jj,jk) 
    287                   ! 
    288                   zn =  - rn_a0 * ( 1._wp + 0.5_wp*rn_lambda1*zt + rn_mu1*zh ) * zt   & 
    289                      &  + rn_b0 * ( 1._wp - 0.5_wp*rn_lambda2*zs - rn_mu2*zh ) * zs   & 
    290                      &  - rn_nu * zt * zs 
    291                      !                                  
    292                   prd(ji,jj,jk) = zn * r1_rau0 * ztm                ! density anomaly (masked) 
    293                END DO 
    294             END DO 
    295          END DO 
    296          ! 
    297       END SELECT 
    298       ! 
    299       IF(ln_ctl)   CALL prt_ctl( tab3d_1=prd, clinfo1=' eos-insitu  : ', kdim=jpk ) 
    300       ! 
    301       IF( ln_timing )   CALL timing_stop('eos-insitu') 
    302       ! 
    303    END SUBROUTINE eos_insitu 
    304  
    305  
    306    SUBROUTINE eos_insitu_pot( pts, prd, prhop, pdep ) 
    307       !!---------------------------------------------------------------------- 
    308       !!                  ***  ROUTINE eos_insitu_pot  *** 
    309       !! 
    310       !! ** Purpose :   Compute the in situ density (ratio rho/rau0) and the 
    311       !!      potential volumic mass (Kg/m3) from potential temperature and 
    312       !!      salinity fields using an equation of state selected in the 
    313       !!     namelist. 
    314       !! 
    315       !! ** Action  : - prd  , the in situ density (no units) 
    316       !!              - prhop, the potential volumic mass (Kg/m3) 
    317       !! 
    318       !!---------------------------------------------------------------------- 
    319       REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in   ) ::   pts    ! 1 : potential temperature  [Celsius] 
    320       !                                                                ! 2 : salinity               [psu] 
    321       REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(  out) ::   prd    ! in situ density            [-] 
    322       REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(  out) ::   prhop  ! potential density (surface referenced) 
    323       REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ) ::   pdep   ! depth                      [m] 
    324       ! 
    325       INTEGER  ::   ji, jj, jk, jsmp             ! dummy loop indices 
    326       INTEGER  ::   jdof 
    327       REAL(wp) ::   zt , zh , zstemp, zs , ztm   ! local scalars 
    328       REAL(wp) ::   zn , zn0, zn1, zn2, zn3      !   -      - 
    329       REAL(wp), DIMENSION(:), ALLOCATABLE :: zn0_sto, zn_sto, zsign    ! local vectors 
    330       !!---------------------------------------------------------------------- 
    331       ! 
    332       IF( ln_timing )   CALL timing_start('eos-pot') 
    333       ! 
    334       SELECT CASE ( neos ) 
    335       ! 
    336       CASE( np_teos10, np_eos80 )                !==  polynomial TEOS-10 / EOS-80 ==! 
    337          ! 
    338          ! Stochastic equation of state 
    339          IF ( ln_sto_eos ) THEN 
    340             ALLOCATE(zn0_sto(1:2*nn_sto_eos)) 
    341             ALLOCATE(zn_sto(1:2*nn_sto_eos)) 
    342             ALLOCATE(zsign(1:2*nn_sto_eos)) 
    343             DO jsmp = 1, 2*nn_sto_eos, 2 
    344               zsign(jsmp)   = 1._wp 
    345               zsign(jsmp+1) = -1._wp 
    346             END DO 
    347             ! 
    348             DO jk = 1, jpkm1 
    349                DO jj = 1, jpj 
    350                   DO ji = 1, jpi 
    351                      ! 
    352                      ! compute density (2*nn_sto_eos) times: 
    353                      ! (1) for t+dt, s+ds (with the random TS fluctutation computed in sto_pts) 
    354                      ! (2) for t-dt, s-ds (with the opposite fluctuation) 
    355                      DO jsmp = 1, nn_sto_eos*2 
    356                         jdof   = (jsmp + 1) / 2 
    357                         zh     = pdep(ji,jj,jk) * r1_Z0                                  ! depth 
    358                         zt     = (pts (ji,jj,jk,jp_tem) + pts_ran(ji,jj,jk,jp_tem,jdof) * zsign(jsmp)) * r1_T0    ! temperature 
    359                         zstemp = pts  (ji,jj,jk,jp_sal) + pts_ran(ji,jj,jk,jp_sal,jdof) * zsign(jsmp) 
    360                         zs     = SQRT( ABS( zstemp + rdeltaS ) * r1_S0 )   ! square root salinity 
    361                         ztm    = tmask(ji,jj,jk)                                         ! tmask 
    362                         ! 
    363                         zn3 = EOS013*zt   & 
    364                            &   + EOS103*zs+EOS003 
    365                            ! 
    366                         zn2 = (EOS022*zt   & 
    367                            &   + EOS112*zs+EOS012)*zt   & 
    368                            &   + (EOS202*zs+EOS102)*zs+EOS002 
    369                            ! 
    370                         zn1 = (((EOS041*zt   & 
    371                            &   + EOS131*zs+EOS031)*zt   & 
    372                            &   + (EOS221*zs+EOS121)*zs+EOS021)*zt   & 
    373                            &   + ((EOS311*zs+EOS211)*zs+EOS111)*zs+EOS011)*zt   & 
    374                            &   + (((EOS401*zs+EOS301)*zs+EOS201)*zs+EOS101)*zs+EOS001 
    375                            ! 
    376                         zn0_sto(jsmp) = (((((EOS060*zt   & 
    377                            &   + EOS150*zs+EOS050)*zt   & 
    378                            &   + (EOS240*zs+EOS140)*zs+EOS040)*zt   & 
    379                            &   + ((EOS330*zs+EOS230)*zs+EOS130)*zs+EOS030)*zt   & 
    380                            &   + (((EOS420*zs+EOS320)*zs+EOS220)*zs+EOS120)*zs+EOS020)*zt   & 
    381                            &   + ((((EOS510*zs+EOS410)*zs+EOS310)*zs+EOS210)*zs+EOS110)*zs+EOS010)*zt   & 
    382                            &   + (((((EOS600*zs+EOS500)*zs+EOS400)*zs+EOS300)*zs+EOS200)*zs+EOS100)*zs+EOS000 
    383                            ! 
    384                         zn_sto(jsmp)  = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0_sto(jsmp) 
    385                      END DO 
    386                      ! 
    387                      ! compute stochastic density as the mean of the (2*nn_sto_eos) densities 
    388                      prhop(ji,jj,jk) = 0._wp ; prd(ji,jj,jk) = 0._wp 
    389                      DO jsmp = 1, nn_sto_eos*2 
    390                         prhop(ji,jj,jk) = prhop(ji,jj,jk) + zn0_sto(jsmp)                      ! potential density referenced at the surface 
    391                         ! 
    392                         prd(ji,jj,jk) = prd(ji,jj,jk) + (  zn_sto(jsmp) * r1_rau0 - 1._wp  )   ! density anomaly (masked) 
    393                      END DO 
    394                      prhop(ji,jj,jk) = 0.5_wp * prhop(ji,jj,jk) * ztm / nn_sto_eos 
    395                      prd  (ji,jj,jk) = 0.5_wp * prd  (ji,jj,jk) * ztm / nn_sto_eos 
    396                   END DO 
    397                END DO 
    398             END DO 
     383               prhop(ji,jj,jk) = 0.5_wp * prhop(ji,jj,jk) * ztm / nn_sto_eos 
     384               prd  (ji,jj,jk) = 0.5_wp * prd  (ji,jj,jk) * ztm / nn_sto_eos 
     385            END_3D 
    399386            DEALLOCATE(zn0_sto,zn_sto,zsign) 
    400387         ! Non-stochastic equation of state 
    401388         ELSE 
    402             DO jk = 1, jpkm1 
    403                DO jj = 1, jpj 
    404                   DO ji = 1, jpi 
    405                      ! 
    406                      zh  = pdep(ji,jj,jk) * r1_Z0                                  ! depth 
    407                      zt  = pts (ji,jj,jk,jp_tem) * r1_T0                           ! temperature 
    408                      zs  = SQRT( ABS( pts(ji,jj,jk,jp_sal) + rdeltaS ) * r1_S0 )   ! square root salinity 
    409                      ztm = tmask(ji,jj,jk)                                         ! tmask 
    410                      ! 
    411                      zn3 = EOS013*zt   & 
    412                         &   + EOS103*zs+EOS003 
    413                         ! 
    414                      zn2 = (EOS022*zt   & 
    415                         &   + EOS112*zs+EOS012)*zt   & 
    416                         &   + (EOS202*zs+EOS102)*zs+EOS002 
    417                         ! 
    418                      zn1 = (((EOS041*zt   & 
    419                         &   + EOS131*zs+EOS031)*zt   & 
    420                         &   + (EOS221*zs+EOS121)*zs+EOS021)*zt   & 
    421                         &   + ((EOS311*zs+EOS211)*zs+EOS111)*zs+EOS011)*zt   & 
    422                         &   + (((EOS401*zs+EOS301)*zs+EOS201)*zs+EOS101)*zs+EOS001 
    423                         ! 
    424                      zn0 = (((((EOS060*zt   & 
    425                         &   + EOS150*zs+EOS050)*zt   & 
    426                         &   + (EOS240*zs+EOS140)*zs+EOS040)*zt   & 
    427                         &   + ((EOS330*zs+EOS230)*zs+EOS130)*zs+EOS030)*zt   & 
    428                         &   + (((EOS420*zs+EOS320)*zs+EOS220)*zs+EOS120)*zs+EOS020)*zt   & 
    429                         &   + ((((EOS510*zs+EOS410)*zs+EOS310)*zs+EOS210)*zs+EOS110)*zs+EOS010)*zt   & 
    430                         &   + (((((EOS600*zs+EOS500)*zs+EOS400)*zs+EOS300)*zs+EOS200)*zs+EOS100)*zs+EOS000 
    431                         ! 
    432                      zn  = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 
    433                      ! 
    434                      prhop(ji,jj,jk) = zn0 * ztm                           ! potential density referenced at the surface 
    435                      ! 
    436                      prd(ji,jj,jk) = (  zn * r1_rau0 - 1._wp  ) * ztm      ! density anomaly (masked) 
    437                   END DO 
    438                END DO 
    439             END DO 
    440          ENDIF 
    441           
    442       CASE( np_seos )                !==  simplified EOS  ==! 
    443          ! 
    444          DO jk = 1, jpkm1 
    445             DO jj = 1, jpj 
    446                DO ji = 1, jpi 
    447                   zt  = pts  (ji,jj,jk,jp_tem) - 10._wp 
    448                   zs  = pts  (ji,jj,jk,jp_sal) - 35._wp 
    449                   zh  = pdep (ji,jj,jk) 
    450                   ztm = tmask(ji,jj,jk) 
    451                   !                                                     ! potential density referenced at the surface 
    452                   zn =  - rn_a0 * ( 1._wp + 0.5_wp*rn_lambda1*zt ) * zt   & 
    453                      &  + rn_b0 * ( 1._wp - 0.5_wp*rn_lambda2*zs ) * zs   & 
    454                      &  - rn_nu * zt * zs 
    455                   prhop(ji,jj,jk) = ( rau0 + zn ) * ztm 
    456                   !                                                     ! density anomaly (masked) 
    457                   zn = zn - ( rn_a0 * rn_mu1 * zt + rn_b0 * rn_mu2 * zs ) * zh 
    458                   prd(ji,jj,jk) = zn * r1_rau0 * ztm 
    459                   ! 
    460                END DO 
    461             END DO 
    462          END DO 
    463          ! 
    464       END SELECT 
    465       ! 
    466       IF(ln_ctl)   CALL prt_ctl( tab3d_1=prd, clinfo1=' eos-pot: ', tab3d_2=prhop, clinfo2=' pot : ', kdim=jpk ) 
    467       ! 
    468       IF( ln_timing )   CALL timing_stop('eos-pot') 
    469       ! 
    470    END SUBROUTINE eos_insitu_pot 
    471  
    472  
    473    SUBROUTINE eos_insitu_2d( pts, pdep, prd ) 
    474       !!---------------------------------------------------------------------- 
    475       !!                  ***  ROUTINE eos_insitu_2d  *** 
    476       !! 
    477       !! ** Purpose :   Compute the in situ density (ratio rho/rau0) from 
    478       !!      potential temperature and salinity using an equation of state 
    479       !!      selected in the nameos namelist. * 2D field case 
    480       !! 
    481       !! ** Action  : - prd , the in situ density (no units) (unmasked) 
    482       !! 
    483       !!---------------------------------------------------------------------- 
    484       REAL(wp), DIMENSION(jpi,jpj,jpts), INTENT(in   ) ::   pts   ! 1 : potential temperature  [Celsius] 
    485       !                                                           ! 2 : salinity               [psu] 
    486       REAL(wp), DIMENSION(jpi,jpj)     , INTENT(in   ) ::   pdep  ! depth                      [m] 
    487       REAL(wp), DIMENSION(jpi,jpj)     , INTENT(  out) ::   prd   ! in situ density 
    488       ! 
    489       INTEGER  ::   ji, jj, jk                ! dummy loop indices 
    490       REAL(wp) ::   zt , zh , zs              ! local scalars 
    491       REAL(wp) ::   zn , zn0, zn1, zn2, zn3   !   -      - 
    492       !!---------------------------------------------------------------------- 
    493       ! 
    494       IF( ln_timing )   CALL timing_start('eos2d') 
    495       ! 
    496       prd(:,:) = 0._wp 
    497       ! 
    498       SELECT CASE( neos ) 
    499       ! 
    500       CASE( np_teos10, np_eos80 )                !==  polynomial TEOS-10 / EOS-80 ==! 
    501          ! 
    502          DO jj = 1, jpjm1 
    503             DO ji = 1, fs_jpim1   ! vector opt. 
    504                ! 
    505                zh  = pdep(ji,jj) * r1_Z0                                  ! depth 
    506                zt  = pts (ji,jj,jp_tem) * r1_T0                           ! temperature 
    507                zs  = SQRT( ABS( pts(ji,jj,jp_sal) + rdeltaS ) * r1_S0 )   ! square root salinity 
     389            DO_3D_11_11( 1, jpkm1 ) 
     390               ! 
     391               zh  = pdep(ji,jj,jk) * r1_Z0                                  ! depth 
     392               zt  = pts (ji,jj,jk,jp_tem) * r1_T0                           ! temperature 
     393               zs  = SQRT( ABS( pts(ji,jj,jk,jp_sal) + rdeltaS ) * r1_S0 )   ! square root salinity 
     394               ztm = tmask(ji,jj,jk)                                         ! tmask 
    508395               ! 
    509396               zn3 = EOS013*zt   & 
    … …  
    530417               zn  = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 
    531418               ! 
    532                prd(ji,jj) = zn * r1_rau0 - 1._wp               ! unmasked in situ density anomaly 
    533                ! 
    534             END DO 
    535          END DO 
    536          ! 
    537          CALL lbc_lnk( 'eosbn2', prd, 'T', 1. )                    ! Lateral boundary conditions 
    538          ! 
     419               prhop(ji,jj,jk) = zn0 * ztm                           ! potential density referenced at the surface 
     420               ! 
     421               prd(ji,jj,jk) = (  zn * r1_rau0 - 1._wp  ) * ztm      ! density anomaly (masked) 
     422            END_3D 
     423         ENDIF 
     424          
    539425      CASE( np_seos )                !==  simplified EOS  ==! 
    540426         ! 
    541          DO jj = 1, jpjm1 
    542             DO ji = 1, fs_jpim1   ! vector opt. 
    543                ! 
    544                zt    = pts  (ji,jj,jp_tem)  - 10._wp 
    545                zs    = pts  (ji,jj,jp_sal)  - 35._wp 
    546                zh    = pdep (ji,jj)                         ! depth at the partial step level 
    547                ! 
    548                zn =  - rn_a0 * ( 1._wp + 0.5_wp*rn_lambda1*zt + rn_mu1*zh ) * zt   & 
    549                   &  + rn_b0 * ( 1._wp - 0.5_wp*rn_lambda2*zs - rn_mu2*zh ) * zs   & 
    550                   &  - rn_nu * zt * zs 
    551                   ! 
    552                prd(ji,jj) = zn * r1_rau0               ! unmasked in situ density anomaly 
    553                ! 
    554             END DO 
    555          END DO 
    556          ! 
    557          CALL lbc_lnk( 'eosbn2', prd, 'T', 1. )                    ! Lateral boundary conditions 
     427         DO_3D_11_11( 1, jpkm1 ) 
     428            zt  = pts  (ji,jj,jk,jp_tem) - 10._wp 
     429            zs  = pts  (ji,jj,jk,jp_sal) - 35._wp 
     430            zh  = pdep (ji,jj,jk) 
     431            ztm = tmask(ji,jj,jk) 
     432            !                                                     ! potential density referenced at the surface 
     433            zn =  - rn_a0 * ( 1._wp + 0.5_wp*rn_lambda1*zt ) * zt   & 
     434               &  + rn_b0 * ( 1._wp - 0.5_wp*rn_lambda2*zs ) * zs   & 
     435               &  - rn_nu * zt * zs 
     436            prhop(ji,jj,jk) = ( rau0 + zn ) * ztm 
     437            !                                                     ! density anomaly (masked) 
     438            zn = zn - ( rn_a0 * rn_mu1 * zt + rn_b0 * rn_mu2 * zs ) * zh 
     439            prd(ji,jj,jk) = zn * r1_rau0 * ztm 
     440            ! 
     441         END_3D 
    558442         ! 
    559443      END SELECT 
    560444      ! 
    561       IF(ln_ctl)   CALL prt_ctl( tab2d_1=prd, clinfo1=' eos2d: ' ) 
     445      IF(sn_cfctl%l_prtctl)   CALL prt_ctl( tab3d_1=prd, clinfo1=' eos-pot: ', tab3d_2=prhop, clinfo2=' pot : ', kdim=jpk ) 
     446      ! 
     447      IF( ln_timing )   CALL timing_stop('eos-pot') 
     448      ! 
     449   END SUBROUTINE eos_insitu_pot 
     450 
     451 
     452   SUBROUTINE eos_insitu_2d( pts, pdep, prd ) 
     453      !!---------------------------------------------------------------------- 
     454      !!                  ***  ROUTINE eos_insitu_2d  *** 
     455      !! 
     456      !! ** Purpose :   Compute the in situ density (ratio rho/rau0) from 
     457      !!      potential temperature and salinity using an equation of state 
     458      !!      selected in the nameos namelist. * 2D field case 
     459      !! 
     460      !! ** Action  : - prd , the in situ density (no units) (unmasked) 
     461      !! 
     462      !!---------------------------------------------------------------------- 
     463      REAL(wp), DIMENSION(jpi,jpj,jpts), INTENT(in   ) ::   pts   ! 1 : potential temperature  [Celsius] 
     464      !                                                           ! 2 : salinity               [psu] 
     465      REAL(wp), DIMENSION(jpi,jpj)     , INTENT(in   ) ::   pdep  ! depth                      [m] 
     466      REAL(wp), DIMENSION(jpi,jpj)     , INTENT(  out) ::   prd   ! in situ density 
     467      ! 
     468      INTEGER  ::   ji, jj, jk                ! dummy loop indices 
     469      REAL(wp) ::   zt , zh , zs              ! local scalars 
     470      REAL(wp) ::   zn , zn0, zn1, zn2, zn3   !   -      - 
     471      !!---------------------------------------------------------------------- 
     472      ! 
     473      IF( ln_timing )   CALL timing_start('eos2d') 
     474      ! 
     475      prd(:,:) = 0._wp 
     476      ! 
     477      SELECT CASE( neos ) 
     478      ! 
     479      CASE( np_teos10, np_eos80 )                !==  polynomial TEOS-10 / EOS-80 ==! 
     480         ! 
     481         DO_2D_11_11 
     482            ! 
     483            zh  = pdep(ji,jj) * r1_Z0                                  ! depth 
     484            zt  = pts (ji,jj,jp_tem) * r1_T0                           ! temperature 
     485            zs  = SQRT( ABS( pts(ji,jj,jp_sal) + rdeltaS ) * r1_S0 )   ! square root salinity 
     486            ! 
     487            zn3 = EOS013*zt   & 
     488               &   + EOS103*zs+EOS003 
     489               ! 
     490            zn2 = (EOS022*zt   & 
     491               &   + EOS112*zs+EOS012)*zt   & 
     492               &   + (EOS202*zs+EOS102)*zs+EOS002 
     493               ! 
     494            zn1 = (((EOS041*zt   & 
     495               &   + EOS131*zs+EOS031)*zt   & 
     496               &   + (EOS221*zs+EOS121)*zs+EOS021)*zt   & 
     497               &   + ((EOS311*zs+EOS211)*zs+EOS111)*zs+EOS011)*zt   & 
     498               &   + (((EOS401*zs+EOS301)*zs+EOS201)*zs+EOS101)*zs+EOS001 
     499               ! 
     500            zn0 = (((((EOS060*zt   & 
     501               &   + EOS150*zs+EOS050)*zt   & 
     502               &   + (EOS240*zs+EOS140)*zs+EOS040)*zt   & 
     503               &   + ((EOS330*zs+EOS230)*zs+EOS130)*zs+EOS030)*zt   & 
     504               &   + (((EOS420*zs+EOS320)*zs+EOS220)*zs+EOS120)*zs+EOS020)*zt   & 
     505               &   + ((((EOS510*zs+EOS410)*zs+EOS310)*zs+EOS210)*zs+EOS110)*zs+EOS010)*zt   & 
     506               &   + (((((EOS600*zs+EOS500)*zs+EOS400)*zs+EOS300)*zs+EOS200)*zs+EOS100)*zs+EOS000 
     507               ! 
     508            zn  = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 
     509            ! 
     510            prd(ji,jj) = zn * r1_rau0 - 1._wp               ! unmasked in situ density anomaly 
     511            ! 
     512         END_2D 
     513         ! 
     514      CASE( np_seos )                !==  simplified EOS  ==! 
     515         ! 
     516         DO_2D_11_11 
     517            ! 
     518            zt    = pts  (ji,jj,jp_tem)  - 10._wp 
     519            zs    = pts  (ji,jj,jp_sal)  - 35._wp 
     520            zh    = pdep (ji,jj)                         ! depth at the partial step level 
     521            ! 
     522            zn =  - rn_a0 * ( 1._wp + 0.5_wp*rn_lambda1*zt + rn_mu1*zh ) * zt   & 
     523               &  + rn_b0 * ( 1._wp - 0.5_wp*rn_lambda2*zs - rn_mu2*zh ) * zs   & 
     524               &  - rn_nu * zt * zs 
     525               ! 
     526            prd(ji,jj) = zn * r1_rau0               ! unmasked in situ density anomaly 
     527            ! 
     528         END_2D 
     529         ! 
     530      END SELECT 
     531      ! 
     532      IF(sn_cfctl%l_prtctl)   CALL prt_ctl( tab2d_1=prd, clinfo1=' eos2d: ' ) 
    562533      ! 
    563534      IF( ln_timing )   CALL timing_stop('eos2d') 
    … …  
    566537 
    567538 
    568    SUBROUTINE rab_3d( pts, pab ) 
     539   SUBROUTINE rab_3d( pts, pab, Kmm ) 
    569540      !!---------------------------------------------------------------------- 
    570541      !!                 ***  ROUTINE rab_3d  *** 
    … …  
    576547      !! ** Action  : - pab     : thermal/haline expansion ratio at T-points 
    577548      !!---------------------------------------------------------------------- 
     549      INTEGER                              , INTENT(in   ) ::   Kmm   ! time level index 
    578550      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in   ) ::   pts   ! pot. temperature & salinity 
    579551      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(  out) ::   pab   ! thermal/haline expansion ratio 
    … …  
    590562      CASE( np_teos10, np_eos80 )                !==  polynomial TEOS-10 / EOS-80 ==! 
    591563         ! 
    592          DO jk = 1, jpkm1 
    593             DO jj = 1, jpj 
    594                DO ji = 1, jpi 
    595                   ! 
    596                   zh  = gdept_n(ji,jj,jk) * r1_Z0                                ! depth 
    597                   zt  = pts (ji,jj,jk,jp_tem) * r1_T0                           ! temperature 
    598                   zs  = SQRT( ABS( pts(ji,jj,jk,jp_sal) + rdeltaS ) * r1_S0 )   ! square root salinity 
    599                   ztm = tmask(ji,jj,jk)                                         ! tmask 
    600                   ! 
    601                   ! alpha 
    602                   zn3 = ALP003 
    603                   ! 
    604                   zn2 = ALP012*zt + ALP102*zs+ALP002 
    605                   ! 
    606                   zn1 = ((ALP031*zt   & 
    607                      &   + ALP121*zs+ALP021)*zt   & 
    608                      &   + (ALP211*zs+ALP111)*zs+ALP011)*zt   & 
    609                      &   + ((ALP301*zs+ALP201)*zs+ALP101)*zs+ALP001 
    610                      ! 
    611                   zn0 = ((((ALP050*zt   & 
    612                      &   + ALP140*zs+ALP040)*zt   & 
    613                      &   + (ALP230*zs+ALP130)*zs+ALP030)*zt   & 
    614                      &   + ((ALP320*zs+ALP220)*zs+ALP120)*zs+ALP020)*zt   & 
    615                      &   + (((ALP410*zs+ALP310)*zs+ALP210)*zs+ALP110)*zs+ALP010)*zt   & 
    616                      &   + ((((ALP500*zs+ALP400)*zs+ALP300)*zs+ALP200)*zs+ALP100)*zs+ALP000 
    617                      ! 
    618                   zn  = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 
    619                   ! 
    620                   pab(ji,jj,jk,jp_tem) = zn * r1_rau0 * ztm 
    621                   ! 
    622                   ! beta 
    623                   zn3 = BET003 
    624                   ! 
    625                   zn2 = BET012*zt + BET102*zs+BET002 
    626                   ! 
    627                   zn1 = ((BET031*zt   & 
    628                      &   + BET121*zs+BET021)*zt   & 
    629                      &   + (BET211*zs+BET111)*zs+BET011)*zt   & 
    630                      &   + ((BET301*zs+BET201)*zs+BET101)*zs+BET001 
    631                      ! 
    632                   zn0 = ((((BET050*zt   & 
    633                      &   + BET140*zs+BET040)*zt   & 
    634                      &   + (BET230*zs+BET130)*zs+BET030)*zt   & 
    635                      &   + ((BET320*zs+BET220)*zs+BET120)*zs+BET020)*zt   & 
    636                      &   + (((BET410*zs+BET310)*zs+BET210)*zs+BET110)*zs+BET010)*zt   & 
    637                      &   + ((((BET500*zs+BET400)*zs+BET300)*zs+BET200)*zs+BET100)*zs+BET000 
    638                      ! 
    639                   zn  = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 
    640                   ! 
    641                   pab(ji,jj,jk,jp_sal) = zn / zs * r1_rau0 * ztm 
    642                   ! 
    643                END DO 
    644             END DO 
    645          END DO 
     564         DO_3D_11_11( 1, jpkm1 ) 
     565            ! 
     566            zh  = gdept(ji,jj,jk,Kmm) * r1_Z0                                ! depth 
     567            zt  = pts (ji,jj,jk,jp_tem) * r1_T0                           ! temperature 
     568            zs  = SQRT( ABS( pts(ji,jj,jk,jp_sal) + rdeltaS ) * r1_S0 )   ! square root salinity 
     569            ztm = tmask(ji,jj,jk)                                         ! tmask 
     570            ! 
     571            ! alpha 
     572            zn3 = ALP003 
     573            ! 
     574            zn2 = ALP012*zt + ALP102*zs+ALP002 
     575            ! 
     576            zn1 = ((ALP031*zt   & 
     577               &   + ALP121*zs+ALP021)*zt   & 
     578               &   + (ALP211*zs+ALP111)*zs+ALP011)*zt   & 
     579               &   + ((ALP301*zs+ALP201)*zs+ALP101)*zs+ALP001 
     580               ! 
     581            zn0 = ((((ALP050*zt   & 
     582               &   + ALP140*zs+ALP040)*zt   & 
     583               &   + (ALP230*zs+ALP130)*zs+ALP030)*zt   & 
     584               &   + ((ALP320*zs+ALP220)*zs+ALP120)*zs+ALP020)*zt   & 
     585               &   + (((ALP410*zs+ALP310)*zs+ALP210)*zs+ALP110)*zs+ALP010)*zt   & 
     586               &   + ((((ALP500*zs+ALP400)*zs+ALP300)*zs+ALP200)*zs+ALP100)*zs+ALP000 
     587               ! 
     588            zn  = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 
     589            ! 
     590            pab(ji,jj,jk,jp_tem) = zn * r1_rau0 * ztm 
     591            ! 
     592            ! beta 
     593            zn3 = BET003 
     594            ! 
     595            zn2 = BET012*zt + BET102*zs+BET002 
     596            ! 
     597            zn1 = ((BET031*zt   & 
     598               &   + BET121*zs+BET021)*zt   & 
     599               &   + (BET211*zs+BET111)*zs+BET011)*zt   & 
     600               &   + ((BET301*zs+BET201)*zs+BET101)*zs+BET001 
     601               ! 
     602            zn0 = ((((BET050*zt   & 
     603               &   + BET140*zs+BET040)*zt   & 
     604               &   + (BET230*zs+BET130)*zs+BET030)*zt   & 
     605               &   + ((BET320*zs+BET220)*zs+BET120)*zs+BET020)*zt   & 
     606               &   + (((BET410*zs+BET310)*zs+BET210)*zs+BET110)*zs+BET010)*zt   & 
     607               &   + ((((BET500*zs+BET400)*zs+BET300)*zs+BET200)*zs+BET100)*zs+BET000 
     608               ! 
     609            zn  = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 
     610            ! 
     611            pab(ji,jj,jk,jp_sal) = zn / zs * r1_rau0 * ztm 
     612            ! 
     613         END_3D 
    646614         ! 
    647615      CASE( np_seos )                  !==  simplified EOS  ==! 
    648616         ! 
    649          DO jk = 1, jpkm1 
    650             DO jj = 1, jpj 
    651                DO ji = 1, jpi 
    652                   zt  = pts (ji,jj,jk,jp_tem) - 10._wp   ! pot. temperature anomaly (t-T0) 
    653                   zs  = pts (ji,jj,jk,jp_sal) - 35._wp   ! abs. salinity anomaly (s-S0) 
    654                   zh  = gdept_n(ji,jj,jk)                ! depth in meters at t-point 
    655                   ztm = tmask(ji,jj,jk)                  ! land/sea bottom mask = surf. mask 
    656                   ! 
    657                   zn  = rn_a0 * ( 1._wp + rn_lambda1*zt + rn_mu1*zh ) + rn_nu*zs 
    658                   pab(ji,jj,jk,jp_tem) = zn * r1_rau0 * ztm   ! alpha 
    659                   ! 
    660                   zn  = rn_b0 * ( 1._wp - rn_lambda2*zs - rn_mu2*zh ) - rn_nu*zt 
    661                   pab(ji,jj,jk,jp_sal) = zn * r1_rau0 * ztm   ! beta 
    662                   ! 
    663                END DO 
    664             END DO 
    665          END DO 
     617         DO_3D_11_11( 1, jpkm1 ) 
     618            zt  = pts (ji,jj,jk,jp_tem) - 10._wp   ! pot. temperature anomaly (t-T0) 
     619            zs  = pts (ji,jj,jk,jp_sal) - 35._wp   ! abs. salinity anomaly (s-S0) 
     620            zh  = gdept(ji,jj,jk,Kmm)                ! depth in meters at t-point 
     621            ztm = tmask(ji,jj,jk)                  ! land/sea bottom mask = surf. mask 
     622            ! 
     623            zn  = rn_a0 * ( 1._wp + rn_lambda1*zt + rn_mu1*zh ) + rn_nu*zs 
     624            pab(ji,jj,jk,jp_tem) = zn * r1_rau0 * ztm   ! alpha 
     625            ! 
     626            zn  = rn_b0 * ( 1._wp - rn_lambda2*zs - rn_mu2*zh ) - rn_nu*zt 
     627            pab(ji,jj,jk,jp_sal) = zn * r1_rau0 * ztm   ! beta 
     628            ! 
     629         END_3D 
    666630         ! 
    667631      CASE DEFAULT 
    … …  
    671635      END SELECT 
    672636      ! 
    673       IF(ln_ctl)   CALL prt_ctl( tab3d_1=pab(:,:,:,jp_tem), clinfo1=' rab_3d_t: ', & 
    674          &                       tab3d_2=pab(:,:,:,jp_sal), clinfo2=' rab_3d_s : ', kdim=jpk ) 
     637      IF(sn_cfctl%l_prtctl)   CALL prt_ctl( tab3d_1=pab(:,:,:,jp_tem), clinfo1=' rab_3d_t: ', & 
     638         &                                  tab3d_2=pab(:,:,:,jp_sal), clinfo2=' rab_3d_s : ', kdim=jpk ) 
    675639      ! 
    676640      IF( ln_timing )   CALL timing_stop('rab_3d') 
    … …  
    679643 
    680644 
    681    SUBROUTINE rab_2d( pts, pdep, pab ) 
     645   SUBROUTINE rab_2d( pts, pdep, pab, Kmm ) 
    682646      !!---------------------------------------------------------------------- 
    683647      !!                 ***  ROUTINE rab_2d  *** 
    … …  
    687651      !! ** Action  : - pab     : thermal/haline expansion ratio at T-points 
    688652      !!---------------------------------------------------------------------- 
     653      INTEGER                              , INTENT(in   ) ::   Kmm   ! time level index 
    689654      REAL(wp), DIMENSION(jpi,jpj,jpts)    , INTENT(in   ) ::   pts    ! pot. temperature & salinity 
    690655      REAL(wp), DIMENSION(jpi,jpj)         , INTENT(in   ) ::   pdep   ! depth                  [m] 
    … …  
    704669      CASE( np_teos10, np_eos80 )                !==  polynomial TEOS-10 / EOS-80 ==! 
    705670         ! 
    706          DO jj = 1, jpjm1 
    707             DO ji = 1, fs_jpim1   ! vector opt. 
    708                ! 
    709                zh  = pdep(ji,jj) * r1_Z0                                  ! depth 
    710                zt  = pts (ji,jj,jp_tem) * r1_T0                           ! temperature 
    711                zs  = SQRT( ABS( pts(ji,jj,jp_sal) + rdeltaS ) * r1_S0 )   ! square root salinity 
    712                ! 
    713                ! alpha 
    714                zn3 = ALP003 
    715                ! 
    716                zn2 = ALP012*zt + ALP102*zs+ALP002 
    717                ! 
    718                zn1 = ((ALP031*zt   & 
    719                   &   + ALP121*zs+ALP021)*zt   & 
    720                   &   + (ALP211*zs+ALP111)*zs+ALP011)*zt   & 
    721                   &   + ((ALP301*zs+ALP201)*zs+ALP101)*zs+ALP001 
    722                   ! 
    723                zn0 = ((((ALP050*zt   & 
    724                   &   + ALP140*zs+ALP040)*zt   & 
    725                   &   + (ALP230*zs+ALP130)*zs+ALP030)*zt   & 
    726                   &   + ((ALP320*zs+ALP220)*zs+ALP120)*zs+ALP020)*zt   & 
    727                   &   + (((ALP410*zs+ALP310)*zs+ALP210)*zs+ALP110)*zs+ALP010)*zt   & 
    728                   &   + ((((ALP500*zs+ALP400)*zs+ALP300)*zs+ALP200)*zs+ALP100)*zs+ALP000 
    729                   ! 
    730                zn  = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 
    731                ! 
    732                pab(ji,jj,jp_tem) = zn * r1_rau0 
    733                ! 
    734                ! beta 
    735                zn3 = BET003 
    736                ! 
    737                zn2 = BET012*zt + BET102*zs+BET002 
    738                ! 
    739                zn1 = ((BET031*zt   & 
    740                   &   + BET121*zs+BET021)*zt   & 
    741                   &   + (BET211*zs+BET111)*zs+BET011)*zt   & 
    742                   &   + ((BET301*zs+BET201)*zs+BET101)*zs+BET001 
    743                   ! 
    744                zn0 = ((((BET050*zt   & 
    745                   &   + BET140*zs+BET040)*zt   & 
    746                   &   + (BET230*zs+BET130)*zs+BET030)*zt   & 
    747                   &   + ((BET320*zs+BET220)*zs+BET120)*zs+BET020)*zt   & 
    748                   &   + (((BET410*zs+BET310)*zs+BET210)*zs+BET110)*zs+BET010)*zt   & 
    749                   &   + ((((BET500*zs+BET400)*zs+BET300)*zs+BET200)*zs+BET100)*zs+BET000 
    750                   ! 
    751                zn  = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 
    752                ! 
    753                pab(ji,jj,jp_sal) = zn / zs * r1_rau0 
    754                ! 
    755                ! 
    756             END DO 
    757          END DO 
    758          !                            ! Lateral boundary conditions 
    759          CALL lbc_lnk_multi( 'eosbn2', pab(:,:,jp_tem), 'T', 1. , pab(:,:,jp_sal), 'T', 1. )                     
     671         DO_2D_11_11 
     672            ! 
     673            zh  = pdep(ji,jj) * r1_Z0                                  ! depth 
     674            zt  = pts (ji,jj,jp_tem) * r1_T0                           ! temperature 
     675            zs  = SQRT( ABS( pts(ji,jj,jp_sal) + rdeltaS ) * r1_S0 )   ! square root salinity 
     676            ! 
     677            ! alpha 
     678            zn3 = ALP003 
     679            ! 
     680            zn2 = ALP012*zt + ALP102*zs+ALP002 
     681            ! 
     682            zn1 = ((ALP031*zt   & 
     683               &   + ALP121*zs+ALP021)*zt   & 
     684               &   + (ALP211*zs+ALP111)*zs+ALP011)*zt   & 
     685               &   + ((ALP301*zs+ALP201)*zs+ALP101)*zs+ALP001 
     686               ! 
     687            zn0 = ((((ALP050*zt   & 
     688               &   + ALP140*zs+ALP040)*zt   & 
     689               &   + (ALP230*zs+ALP130)*zs+ALP030)*zt   & 
     690               &   + ((ALP320*zs+ALP220)*zs+ALP120)*zs+ALP020)*zt   & 
     691               &   + (((ALP410*zs+ALP310)*zs+ALP210)*zs+ALP110)*zs+ALP010)*zt   & 
     692               &   + ((((ALP500*zs+ALP400)*zs+ALP300)*zs+ALP200)*zs+ALP100)*zs+ALP000 
     693               ! 
     694            zn  = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 
     695            ! 
     696            pab(ji,jj,jp_tem) = zn * r1_rau0 
     697            ! 
     698            ! beta 
     699            zn3 = BET003 
     700            ! 
     701            zn2 = BET012*zt + BET102*zs+BET002 
     702            ! 
     703            zn1 = ((BET031*zt   & 
     704               &   + BET121*zs+BET021)*zt   & 
     705               &   + (BET211*zs+BET111)*zs+BET011)*zt   & 
     706               &   + ((BET301*zs+BET201)*zs+BET101)*zs+BET001 
     707               ! 
     708            zn0 = ((((BET050*zt   & 
     709               &   + BET140*zs+BET040)*zt   & 
     710               &   + (BET230*zs+BET130)*zs+BET030)*zt   & 
     711               &   + ((BET320*zs+BET220)*zs+BET120)*zs+BET020)*zt   & 
     712               &   + (((BET410*zs+BET310)*zs+BET210)*zs+BET110)*zs+BET010)*zt   & 
     713               &   + ((((BET500*zs+BET400)*zs+BET300)*zs+BET200)*zs+BET100)*zs+BET000 
     714               ! 
     715            zn  = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 
     716            ! 
     717            pab(ji,jj,jp_sal) = zn / zs * r1_rau0 
     718            ! 
     719            ! 
     720         END_2D 
    760721         ! 
    761722      CASE( np_seos )                  !==  simplified EOS  ==! 
    762723         ! 
    763          DO jj = 1, jpjm1 
    764             DO ji = 1, fs_jpim1   ! vector opt. 
    765                ! 
    766                zt    = pts  (ji,jj,jp_tem) - 10._wp   ! pot. temperature anomaly (t-T0) 
    767                zs    = pts  (ji,jj,jp_sal) - 35._wp   ! abs. salinity anomaly (s-S0) 
    768                zh    = pdep (ji,jj)                   ! depth at the partial step level 
    769                ! 
    770                zn  = rn_a0 * ( 1._wp + rn_lambda1*zt + rn_mu1*zh ) + rn_nu*zs 
    771                pab(ji,jj,jp_tem) = zn * r1_rau0   ! alpha 
    772                ! 
    773                zn  = rn_b0 * ( 1._wp - rn_lambda2*zs - rn_mu2*zh ) - rn_nu*zt 
    774                pab(ji,jj,jp_sal) = zn * r1_rau0   ! beta 
    775                ! 
    776             END DO 
    777          END DO 
    778          !                            ! Lateral boundary conditions 
    779          CALL lbc_lnk_multi( 'eosbn2', pab(:,:,jp_tem), 'T', 1. , pab(:,:,jp_sal), 'T', 1. )                     
     724         DO_2D_11_11 
     725            ! 
     726            zt    = pts  (ji,jj,jp_tem) - 10._wp   ! pot. temperature anomaly (t-T0) 
     727            zs    = pts  (ji,jj,jp_sal) - 35._wp   ! abs. salinity anomaly (s-S0) 
     728            zh    = pdep (ji,jj)                   ! depth at the partial step level 
     729            ! 
     730            zn  = rn_a0 * ( 1._wp + rn_lambda1*zt + rn_mu1*zh ) + rn_nu*zs 
     731            pab(ji,jj,jp_tem) = zn * r1_rau0   ! alpha 
     732            ! 
     733            zn  = rn_b0 * ( 1._wp - rn_lambda2*zs - rn_mu2*zh ) - rn_nu*zt 
     734            pab(ji,jj,jp_sal) = zn * r1_rau0   ! beta 
     735            ! 
     736         END_2D 
    780737         ! 
    781738      CASE DEFAULT 
    … …  
    785742      END SELECT 
    786743      ! 
    787       IF(ln_ctl)   CALL prt_ctl( tab2d_1=pab(:,:,jp_tem), clinfo1=' rab_2d_t: ', & 
    788          &                       tab2d_2=pab(:,:,jp_sal), clinfo2=' rab_2d_s : ' ) 
     744      IF(sn_cfctl%l_prtctl)   CALL prt_ctl( tab2d_1=pab(:,:,jp_tem), clinfo1=' rab_2d_t: ', & 
     745         &                                  tab2d_2=pab(:,:,jp_sal), clinfo2=' rab_2d_s : ' ) 
    789746      ! 
    790747      IF( ln_timing )   CALL timing_stop('rab_2d') 
    … …  
    793750 
    794751 
    795    SUBROUTINE rab_0d( pts, pdep, pab ) 
     752   SUBROUTINE rab_0d( pts, pdep, pab, Kmm ) 
    796753      !!---------------------------------------------------------------------- 
    797754      !!                 ***  ROUTINE rab_0d  *** 
    … …  
    801758      !! ** Action  : - pab     : thermal/haline expansion ratio at T-points 
    802759      !!---------------------------------------------------------------------- 
     760      INTEGER                              , INTENT(in   ) ::   Kmm   ! time level index 
    803761      REAL(wp), DIMENSION(jpts)    , INTENT(in   ) ::   pts    ! pot. temperature & salinity 
    804762      REAL(wp),                      INTENT(in   ) ::   pdep   ! depth                  [m] 
    … …  
    889847 
    890848 
    891    SUBROUTINE bn2( pts, pab, pn2 ) 
     849   SUBROUTINE bn2( pts, pab, pn2, Kmm ) 
    892850      !!---------------------------------------------------------------------- 
    893851      !!                  ***  ROUTINE bn2  *** 
    … …  
    903861      !! 
    904862      !!---------------------------------------------------------------------- 
     863      INTEGER                              , INTENT(in   ) ::   Kmm   ! time level index 
    905864      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in   ) ::  pts   ! pot. temperature and salinity   [Celsius,psu] 
    906865      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in   ) ::  pab   ! thermal/haline expansion coef.  [Celsius-1,psu-1] 
    … …  
    913872      IF( ln_timing )   CALL timing_start('bn2') 
    914873      ! 
    915       DO jk = 2, jpkm1           ! interior points only (2=< jk =< jpkm1 ) 
    916          DO jj = 1, jpj          ! surface and bottom value set to zero one for all in istate.F90 
    917             DO ji = 1, jpi 
    918                zrw =   ( gdepw_n(ji,jj,jk  ) - gdept_n(ji,jj,jk) )   & 
    919                   &  / ( gdept_n(ji,jj,jk-1) - gdept_n(ji,jj,jk) )  
    920                   ! 
    921                zaw = pab(ji,jj,jk,jp_tem) * (1. - zrw) + pab(ji,jj,jk-1,jp_tem) * zrw  
    922                zbw = pab(ji,jj,jk,jp_sal) * (1. - zrw) + pab(ji,jj,jk-1,jp_sal) * zrw 
    923                ! 
    924                pn2(ji,jj,jk) = grav * (  zaw * ( pts(ji,jj,jk-1,jp_tem) - pts(ji,jj,jk,jp_tem) )     & 
    925                   &                    - zbw * ( pts(ji,jj,jk-1,jp_sal) - pts(ji,jj,jk,jp_sal) )  )  & 
    926                   &            / e3w_n(ji,jj,jk) * wmask(ji,jj,jk) 
    927             END DO 
    928          END DO 
    929       END DO 
    930       ! 
    931       IF(ln_ctl)   CALL prt_ctl( tab3d_1=pn2, clinfo1=' bn2  : ', kdim=jpk ) 
     874      DO_3D_11_11( 2, jpkm1 ) 
     875         zrw =   ( gdepw(ji,jj,jk  ,Kmm) - gdept(ji,jj,jk,Kmm) )   & 
     876            &  / ( gdept(ji,jj,jk-1,Kmm) - gdept(ji,jj,jk,Kmm) )  
     877            ! 
     878         zaw = pab(ji,jj,jk,jp_tem) * (1. - zrw) + pab(ji,jj,jk-1,jp_tem) * zrw  
     879         zbw = pab(ji,jj,jk,jp_sal) * (1. - zrw) + pab(ji,jj,jk-1,jp_sal) * zrw 
     880         ! 
     881         pn2(ji,jj,jk) = grav * (  zaw * ( pts(ji,jj,jk-1,jp_tem) - pts(ji,jj,jk,jp_tem) )     & 
     882            &                    - zbw * ( pts(ji,jj,jk-1,jp_sal) - pts(ji,jj,jk,jp_sal) )  )  & 
     883            &            / e3w(ji,jj,jk,Kmm) * wmask(ji,jj,jk) 
     884      END_3D 
     885      ! 
     886      IF(sn_cfctl%l_prtctl)   CALL prt_ctl( tab3d_1=pn2, clinfo1=' bn2  : ', kdim=jpk ) 
    932887      ! 
    933888      IF( ln_timing )   CALL timing_stop('bn2') 
    … …  
    965920      z1_T0   = 1._wp/40._wp 
    966921      ! 
    967       DO jj = 1, jpj 
    968          DO ji = 1, jpi 
    969             ! 
    970             zt  = ctmp   (ji,jj) * z1_T0 
    971             zs  = SQRT( ABS( psal(ji,jj) + zdeltaS ) * r1_S0 ) 
    972             ztm = tmask(ji,jj,1) 
    973             ! 
    974             zn = ((((-2.1385727895e-01_wp*zt   & 
    975                &   - 2.7674419971e-01_wp*zs+1.0728094330_wp)*zt   & 
    976                &   + (2.6366564313_wp*zs+3.3546960647_wp)*zs-7.8012209473_wp)*zt   & 
    977                &   + ((1.8835586562_wp*zs+7.3949191679_wp)*zs-3.3937395875_wp)*zs-5.6414948432_wp)*zt   & 
    978                &   + (((3.5737370589_wp*zs-1.5512427389e+01_wp)*zs+2.4625741105e+01_wp)*zs   & 
    979                &      +1.9912291000e+01_wp)*zs-3.2191146312e+01_wp)*zt   & 
    980                &   + ((((5.7153204649e-01_wp*zs-3.0943149543_wp)*zs+9.3052495181_wp)*zs   & 
    981                &      -9.4528934807_wp)*zs+3.1066408996_wp)*zs-4.3504021262e-01_wp 
    982                ! 
    983             zd = (2.0035003456_wp*zt   & 
    984                &   -3.4570358592e-01_wp*zs+5.6471810638_wp)*zt   & 
    985                &   + (1.5393993508_wp*zs-6.9394762624_wp)*zs+1.2750522650e+01_wp 
    986                ! 
    987             ptmp(ji,jj) = ( zt / z1_T0 + zn / zd ) * ztm 
    988                ! 
    989          END DO 
    990       END DO 
     922      DO_2D_11_11 
     923         ! 
     924         zt  = ctmp   (ji,jj) * z1_T0 
     925         zs  = SQRT( ABS( psal(ji,jj) + zdeltaS ) * r1_S0 ) 
     926         ztm = tmask(ji,jj,1) 
     927         ! 
     928         zn = ((((-2.1385727895e-01_wp*zt   & 
     929            &   - 2.7674419971e-01_wp*zs+1.0728094330_wp)*zt   & 
     930            &   + (2.6366564313_wp*zs+3.3546960647_wp)*zs-7.8012209473_wp)*zt   & 
     931            &   + ((1.8835586562_wp*zs+7.3949191679_wp)*zs-3.3937395875_wp)*zs-5.6414948432_wp)*zt   & 
     932            &   + (((3.5737370589_wp*zs-1.5512427389e+01_wp)*zs+2.4625741105e+01_wp)*zs   & 
     933            &      +1.9912291000e+01_wp)*zs-3.2191146312e+01_wp)*zt   & 
     934            &   + ((((5.7153204649e-01_wp*zs-3.0943149543_wp)*zs+9.3052495181_wp)*zs   & 
     935            &      -9.4528934807_wp)*zs+3.1066408996_wp)*zs-4.3504021262e-01_wp 
     936            ! 
     937         zd = (2.0035003456_wp*zt   & 
     938            &   -3.4570358592e-01_wp*zs+5.6471810638_wp)*zt   & 
     939            &   + (1.5393993508_wp*zs-6.9394762624_wp)*zs+1.2750522650e+01_wp 
     940            ! 
     941         ptmp(ji,jj) = ( zt / z1_T0 + zn / zd ) * ztm 
     942            ! 
     943      END_2D 
    991944      ! 
    992945      IF( ln_timing )   CALL timing_stop('eos_pt_from_ct') 
    … …  
    1020973         ! 
    1021974         z1_S0 = 1._wp / 35.16504_wp 
    1022          DO jj = 1, jpj 
    1023             DO ji = 1, jpi 
    1024                zs= SQRT( ABS( psal(ji,jj) ) * z1_S0 )           ! square root salinity 
    1025                ptf(ji,jj) = ((((1.46873e-03_wp*zs-9.64972e-03_wp)*zs+2.28348e-02_wp)*zs & 
    1026                   &          - 3.12775e-02_wp)*zs+2.07679e-02_wp)*zs-5.87701e-02_wp 
    1027             END DO 
    1028          END DO 
     975         DO_2D_11_11 
     976            zs= SQRT( ABS( psal(ji,jj) ) * z1_S0 )           ! square root salinity 
     977            ptf(ji,jj) = ((((1.46873e-03_wp*zs-9.64972e-03_wp)*zs+2.28348e-02_wp)*zs & 
     978               &          - 3.12775e-02_wp)*zs+2.07679e-02_wp)*zs-5.87701e-02_wp 
     979         END_2D 
    1029980         ptf(:,:) = ptf(:,:) * psal(:,:) 
    1030981         ! 
    … …  
    10931044 
    10941045 
    1095    SUBROUTINE eos_pen( pts, pab_pe, ppen ) 
     1046   SUBROUTINE eos_pen( pts, pab_pe, ppen, Kmm ) 
    10961047      !!---------------------------------------------------------------------- 
    10971048      !!                 ***  ROUTINE eos_pen  *** 
    … …  
    11131064      !!                    pab_pe(:,:,:,jp_sal) is beta_pe 
    11141065      !!---------------------------------------------------------------------- 
     1066      INTEGER                              , INTENT(in   ) ::   Kmm   ! time level index 
    11151067      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in   ) ::   pts     ! pot. temperature & salinity 
    11161068      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(  out) ::   pab_pe  ! alpha_pe and beta_pe 
    … …  
    11281080      CASE( np_teos10, np_eos80 )                !==  polynomial TEOS-10 / EOS-80 ==! 
    11291081         ! 
    1130          DO jk = 1, jpkm1 
    1131             DO jj = 1, jpj 
    1132                DO ji = 1, jpi 
    1133                   ! 
    1134                   zh  = gdept_n(ji,jj,jk) * r1_Z0                                ! depth 
    1135                   zt  = pts (ji,jj,jk,jp_tem) * r1_T0                           ! temperature 
    1136                   zs  = SQRT( ABS( pts(ji,jj,jk,jp_sal) + rdeltaS ) * r1_S0 )   ! square root salinity 
    1137                   ztm = tmask(ji,jj,jk)                                         ! tmask 
    1138                   ! 
    1139                   ! potential energy non-linear anomaly 
    1140                   zn2 = (PEN012)*zt   & 
    1141                      &   + PEN102*zs+PEN002 
    1142                      ! 
    1143                   zn1 = ((PEN021)*zt   & 
    1144                      &   + PEN111*zs+PEN011)*zt   & 
    1145                      &   + (PEN201*zs+PEN101)*zs+PEN001 
    1146                      ! 
    1147                   zn0 = ((((PEN040)*zt   & 
    1148                      &   + PEN130*zs+PEN030)*zt   & 
    1149                      &   + (PEN220*zs+PEN120)*zs+PEN020)*zt   & 
    1150                      &   + ((PEN310*zs+PEN210)*zs+PEN110)*zs+PEN010)*zt   & 
    1151                      &   + (((PEN400*zs+PEN300)*zs+PEN200)*zs+PEN100)*zs+PEN000 
    1152                      ! 
    1153                   zn  = ( zn2 * zh + zn1 ) * zh + zn0 
    1154                   ! 
    1155                   ppen(ji,jj,jk)  = zn * zh * r1_rau0 * ztm 
    1156                   ! 
    1157                   ! alphaPE non-linear anomaly 
    1158                   zn2 = APE002 
    1159                   ! 
    1160                   zn1 = (APE011)*zt   & 
    1161                      &   + APE101*zs+APE001 
    1162                      ! 
    1163                   zn0 = (((APE030)*zt   & 
    1164                      &   + APE120*zs+APE020)*zt   & 
    1165                      &   + (APE210*zs+APE110)*zs+APE010)*zt   & 
    1166                      &   + ((APE300*zs+APE200)*zs+APE100)*zs+APE000 
    1167                      ! 
    1168                   zn  = ( zn2 * zh + zn1 ) * zh + zn0 
    1169                   !                               
    1170                   pab_pe(ji,jj,jk,jp_tem) = zn * zh * r1_rau0 * ztm 
    1171                   ! 
    1172                   ! betaPE non-linear anomaly 
    1173                   zn2 = BPE002 
    1174                   ! 
    1175                   zn1 = (BPE011)*zt   & 
    1176                      &   + BPE101*zs+BPE001 
    1177                      ! 
    1178                   zn0 = (((BPE030)*zt   & 
    1179                      &   + BPE120*zs+BPE020)*zt   & 
    1180                      &   + (BPE210*zs+BPE110)*zs+BPE010)*zt   & 
    1181                      &   + ((BPE300*zs+BPE200)*zs+BPE100)*zs+BPE000 
    1182                      ! 
    1183                   zn  = ( zn2 * zh + zn1 ) * zh + zn0 
    1184                   !                               
    1185                   pab_pe(ji,jj,jk,jp_sal) = zn / zs * zh * r1_rau0 * ztm 
    1186                   ! 
    1187                END DO 
    1188             END DO 
    1189          END DO 
     1082         DO_3D_11_11( 1, jpkm1 ) 
     1083            ! 
     1084            zh  = gdept(ji,jj,jk,Kmm) * r1_Z0                                ! depth 
     1085            zt  = pts (ji,jj,jk,jp_tem) * r1_T0                           ! temperature 
     1086            zs  = SQRT( ABS( pts(ji,jj,jk,jp_sal) + rdeltaS ) * r1_S0 )   ! square root salinity 
     1087            ztm = tmask(ji,jj,jk)                                         ! tmask 
     1088            ! 
     1089            ! potential energy non-linear anomaly 
     1090            zn2 = (PEN012)*zt   & 
     1091               &   + PEN102*zs+PEN002 
     1092               ! 
     1093            zn1 = ((PEN021)*zt   & 
     1094               &   + PEN111*zs+PEN011)*zt   & 
     1095               &   + (PEN201*zs+PEN101)*zs+PEN001 
     1096               ! 
     1097            zn0 = ((((PEN040)*zt   & 
     1098               &   + PEN130*zs+PEN030)*zt   & 
     1099               &   + (PEN220*zs+PEN120)*zs+PEN020)*zt   & 
     1100               &   + ((PEN310*zs+PEN210)*zs+PEN110)*zs+PEN010)*zt   & 
     1101               &   + (((PEN400*zs+PEN300)*zs+PEN200)*zs+PEN100)*zs+PEN000 
     1102               ! 
     1103            zn  = ( zn2 * zh + zn1 ) * zh + zn0 
     1104            ! 
     1105            ppen(ji,jj,jk)  = zn * zh * r1_rau0 * ztm 
     1106            ! 
     1107            ! alphaPE non-linear anomaly 
     1108            zn2 = APE002 
     1109            ! 
     1110            zn1 = (APE011)*zt   & 
     1111               &   + APE101*zs+APE001 
     1112               ! 
     1113            zn0 = (((APE030)*zt   & 
     1114               &   + APE120*zs+APE020)*zt   & 
     1115               &   + (APE210*zs+APE110)*zs+APE010)*zt   & 
     1116               &   + ((APE300*zs+APE200)*zs+APE100)*zs+APE000 
     1117               ! 
     1118            zn  = ( zn2 * zh + zn1 ) * zh + zn0 
     1119            !                               
     1120            pab_pe(ji,jj,jk,jp_tem) = zn * zh * r1_rau0 * ztm 
     1121            ! 
     1122            ! betaPE non-linear anomaly 
     1123            zn2 = BPE002 
     1124            ! 
     1125            zn1 = (BPE011)*zt   & 
     1126               &   + BPE101*zs+BPE001 
     1127               ! 
     1128            zn0 = (((BPE030)*zt   & 
     1129               &   + BPE120*zs+BPE020)*zt   & 
     1130               &   + (BPE210*zs+BPE110)*zs+BPE010)*zt   & 
     1131               &   + ((BPE300*zs+BPE200)*zs+BPE100)*zs+BPE000 
     1132               ! 
     1133            zn  = ( zn2 * zh + zn1 ) * zh + zn0 
     1134            !                               
     1135            pab_pe(ji,jj,jk,jp_sal) = zn / zs * zh * r1_rau0 * ztm 
     1136            ! 
     1137         END_3D 
    11901138         ! 
    11911139      CASE( np_seos )                !==  Vallis (2006) simplified EOS  ==! 
    11921140         ! 
    1193          DO jk = 1, jpkm1 
    1194             DO jj = 1, jpj 
    1195                DO ji = 1, jpi 
    1196                   zt  = pts(ji,jj,jk,jp_tem) - 10._wp  ! temperature anomaly (t-T0) 
    1197                   zs = pts (ji,jj,jk,jp_sal) - 35._wp  ! abs. salinity anomaly (s-S0) 
    1198                   zh  = gdept_n(ji,jj,jk)              ! depth in meters  at t-point 
    1199                   ztm = tmask(ji,jj,jk)                ! tmask 
    1200                   zn  = 0.5_wp * zh * r1_rau0 * ztm 
    1201                   !                                    ! Potential Energy 
    1202                   ppen(ji,jj,jk) = ( rn_a0 * rn_mu1 * zt + rn_b0 * rn_mu2 * zs ) * zn 
    1203                   !                                    ! alphaPE 
    1204                   pab_pe(ji,jj,jk,jp_tem) = - rn_a0 * rn_mu1 * zn 
    1205                   pab_pe(ji,jj,jk,jp_sal) =   rn_b0 * rn_mu2 * zn 
    1206                   ! 
    1207                END DO 
    1208             END DO 
    1209          END DO 
     1141         DO_3D_11_11( 1, jpkm1 ) 
     1142            zt  = pts(ji,jj,jk,jp_tem) - 10._wp  ! temperature anomaly (t-T0) 
     1143            zs = pts (ji,jj,jk,jp_sal) - 35._wp  ! abs. salinity anomaly (s-S0) 
     1144            zh  = gdept(ji,jj,jk,Kmm)              ! depth in meters  at t-point 
     1145            ztm = tmask(ji,jj,jk)                ! tmask 
     1146            zn  = 0.5_wp * zh * r1_rau0 * ztm 
     1147            !                                    ! Potential Energy 
     1148            ppen(ji,jj,jk) = ( rn_a0 * rn_mu1 * zt + rn_b0 * rn_mu2 * zs ) * zn 
     1149            !                                    ! alphaPE 
     1150            pab_pe(ji,jj,jk,jp_tem) = - rn_a0 * rn_mu1 * zn 
     1151            pab_pe(ji,jj,jk,jp_sal) =   rn_b0 * rn_mu2 * zn 
     1152            ! 
     1153         END_3D 
    12101154         ! 
    12111155      CASE DEFAULT 
    … …  
    12351179      !!---------------------------------------------------------------------- 
    12361180      ! 
    1237       REWIND( numnam_ref )              ! Namelist nameos in reference namelist : equation of state 
    12381181      READ  ( numnam_ref, nameos, IOSTAT = ios, ERR = 901 ) 
    12391182901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nameos in reference namelist' ) 
    12401183      ! 
    1241       REWIND( numnam_cfg )              ! Namelist nameos in configuration namelist : equation of state 
    12421184      READ  ( numnam_cfg, nameos, IOSTAT = ios, ERR = 902 ) 
    12431185902   IF( ios >  0 )   CALL ctl_nam ( ios , 'nameos in configuration namelist' ) 

  • NEMO/trunk/src/OCE/TRA/traadv.F90

    r11993 r12377  
    6666   INTEGER, PARAMETER ::   np_QCK     = 5   ! QUICK scheme 
    6767    
    68    !! * Substitutions 
    69 #  include "vectopt_loop_substitute.h90" 
    7068   !!---------------------------------------------------------------------- 
    7169   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    7573CONTAINS 
    7674 
    77    SUBROUTINE tra_adv( kt ) 
     75   SUBROUTINE tra_adv( kt, Kbb, Kmm, pts, Krhs ) 
    7876      !!---------------------------------------------------------------------- 
    7977      !!                  ***  ROUTINE tra_adv  *** 
    … …  
    8179      !! ** Purpose :   compute the ocean tracer advection trend. 
    8280      !! 
    83       !! ** Method  : - Update (ua,va) with the advection term following nadv 
    84       !!---------------------------------------------------------------------- 
    85       INTEGER, INTENT(in) ::   kt   ! ocean time-step index 
     81      !! ** Method  : - Update (uu(:,:,:,Krhs),vv(:,:,:,Krhs)) with the advection term following nadv 
     82      !!---------------------------------------------------------------------- 
     83      INTEGER                                  , INTENT(in)    :: kt             ! ocean time-step index 
     84      INTEGER                                  , INTENT(in)    :: Kbb, Kmm, Krhs ! time level indices 
     85      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts            ! active tracers and RHS of tracer equation 
    8686      ! 
    8787      INTEGER ::   jk   ! dummy loop index 
    88       REAL(wp), DIMENSION(jpi,jpj,jpk)        :: zun, zvn, zwn   ! 3D workspace 
     88      REAL(wp), DIMENSION(jpi,jpj,jpk)        :: zuu, zvv, zww   ! 3D workspace 
    8989      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::   ztrdt, ztrds 
    9090      !!---------------------------------------------------------------------- 
    … …  
    9898      ! 
    9999      !                                         !==  effective transport  ==! 
    100       zun(:,:,jpk) = 0._wp 
    101       zvn(:,:,jpk) = 0._wp 
    102       zwn(:,:,jpk) = 0._wp 
     100      zuu(:,:,jpk) = 0._wp 
     101      zvv(:,:,jpk) = 0._wp 
     102      zww(:,:,jpk) = 0._wp 
    103103      IF( ln_wave .AND. ln_sdw )  THEN 
    104104         DO jk = 1, jpkm1                                                       ! eulerian transport + Stokes Drift 
    105             zun(:,:,jk) = e2u  (:,:) * e3u_n(:,:,jk) * ( un(:,:,jk) + usd(:,:,jk) ) 
    106             zvn(:,:,jk) = e1v  (:,:) * e3v_n(:,:,jk) * ( vn(:,:,jk) + vsd(:,:,jk) ) 
    107             zwn(:,:,jk) = e1e2t(:,:)                 * ( wn(:,:,jk) + wsd(:,:,jk) ) 
     105            zuu(:,:,jk) = e2u  (:,:) * e3u(:,:,jk,Kmm) * ( uu(:,:,jk,Kmm) + usd(:,:,jk) ) 
     106            zvv(:,:,jk) = e1v  (:,:) * e3v(:,:,jk,Kmm) * ( vv(:,:,jk,Kmm) + vsd(:,:,jk) ) 
     107            zww(:,:,jk) = e1e2t(:,:)                 * ( ww(:,:,jk) + wsd(:,:,jk) ) 
    108108         END DO 
    109109      ELSE 
    110110         DO jk = 1, jpkm1 
    111             zun(:,:,jk) = e2u  (:,:) * e3u_n(:,:,jk) * un(:,:,jk)               ! eulerian transport only 
    112             zvn(:,:,jk) = e1v  (:,:) * e3v_n(:,:,jk) * vn(:,:,jk) 
    113             zwn(:,:,jk) = e1e2t(:,:)                 * wn(:,:,jk) 
     111            zuu(:,:,jk) = e2u  (:,:) * e3u(:,:,jk,Kmm) * uu(:,:,jk,Kmm)               ! eulerian transport only 
     112            zvv(:,:,jk) = e1v  (:,:) * e3v(:,:,jk,Kmm) * vv(:,:,jk,Kmm) 
     113            zww(:,:,jk) = e1e2t(:,:)                 * ww(:,:,jk) 
    114114         END DO 
    115115      ENDIF 
    116116      ! 
    117117      IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN                                ! add z-tilde and/or vvl corrections 
    118          zun(:,:,:) = zun(:,:,:) + un_td(:,:,:) 
    119          zvn(:,:,:) = zvn(:,:,:) + vn_td(:,:,:) 
    120       ENDIF 
    121       ! 
    122       zun(:,:,jpk) = 0._wp                                                      ! no transport trough the bottom 
    123       zvn(:,:,jpk) = 0._wp 
    124       zwn(:,:,jpk) = 0._wp 
     118         zuu(:,:,:) = zuu(:,:,:) + un_td(:,:,:) 
     119         zvv(:,:,:) = zvv(:,:,:) + vn_td(:,:,:) 
     120      ENDIF 
     121      ! 
     122      zuu(:,:,jpk) = 0._wp                                                      ! no transport trough the bottom 
     123      zvv(:,:,jpk) = 0._wp 
     124      zww(:,:,jpk) = 0._wp 
    125125      ! 
    126126      IF( ln_ldfeiv .AND. .NOT. ln_traldf_triad )   & 
    127          &              CALL ldf_eiv_trp( kt, nit000, zun, zvn, zwn, 'TRA' )   ! add the eiv transport (if necessary) 
    128       ! 
    129       IF( ln_mle    )   CALL tra_mle_trp( kt, nit000, zun, zvn, zwn, 'TRA' )   ! add the mle transport (if necessary) 
    130       ! 
    131       CALL iom_put( "uocetr_eff", zun )                                        ! output effective transport       
    132       CALL iom_put( "vocetr_eff", zvn ) 
    133       CALL iom_put( "wocetr_eff", zwn ) 
     127         &              CALL ldf_eiv_trp( kt, nit000, zuu, zvv, zww, 'TRA', Kmm, Krhs )   ! add the eiv transport (if necessary) 
     128      ! 
     129      IF( ln_mle    )   CALL tra_mle_trp( kt, nit000, zuu, zvv, zww, 'TRA', Kmm      )   ! add the mle transport (if necessary) 
     130      ! 
     131      CALL iom_put( "uocetr_eff", zuu )                                        ! output effective transport       
     132      CALL iom_put( "vocetr_eff", zvv ) 
     133      CALL iom_put( "wocetr_eff", zww ) 
    134134      ! 
    135135!!gm ??? 
    136       IF( ln_diaptr )   CALL dia_ptr( zvn )                                    ! diagnose the effective MSF  
     136      CALL dia_ptr( kt, Kmm, zvv )                                    ! diagnose the effective MSF  
    137137!!gm ??? 
    138138      ! 
     139 
    139140      IF( l_trdtra )   THEN                    !* Save ta and sa trends 
    140141         ALLOCATE( ztrdt(jpi,jpj,jpk), ztrds(jpi,jpj,jpk) ) 
    141          ztrdt(:,:,:) = tsa(:,:,:,jp_tem) 
    142          ztrds(:,:,:) = tsa(:,:,:,jp_sal) 
     142         ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) 
     143         ztrds(:,:,:) = pts(:,:,:,jp_sal,Krhs) 
    143144      ENDIF 
    144145      ! 
    … …  
    146147      ! 
    147148      CASE ( np_CEN )                                 ! Centered scheme : 2nd / 4th order 
    148          CALL tra_adv_cen    ( kt, nit000, 'TRA',         zun, zvn, zwn     , tsn, tsa, jpts, nn_cen_h, nn_cen_v ) 
     149         CALL tra_adv_cen    ( kt, nit000, 'TRA',         zuu, zvv, zww, Kmm, pts, jpts, Krhs, nn_cen_h, nn_cen_v ) 
    149150      CASE ( np_FCT )                                 ! FCT scheme      : 2nd / 4th order 
    150          CALL tra_adv_fct    ( kt, nit000, 'TRA', r2dt, zun, zvn, zwn, tsb, tsn, tsa, jpts, nn_fct_h, nn_fct_v ) 
     151         CALL tra_adv_fct    ( kt, nit000, 'TRA', r2dt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, nn_fct_h, nn_fct_v ) 
    151152      CASE ( np_MUS )                                 ! MUSCL 
    152          CALL tra_adv_mus    ( kt, nit000, 'TRA', r2dt, zun, zvn, zwn, tsb,      tsa, jpts        , ln_mus_ups )  
     153         CALL tra_adv_mus    ( kt, nit000, 'TRA', r2dt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, ln_mus_ups )  
    153154      CASE ( np_UBS )                                 ! UBS 
    154          CALL tra_adv_ubs    ( kt, nit000, 'TRA', r2dt, zun, zvn, zwn, tsb, tsn, tsa, jpts        , nn_ubs_v   ) 
     155         CALL tra_adv_ubs    ( kt, nit000, 'TRA', r2dt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, nn_ubs_v   ) 
    155156      CASE ( np_QCK )                                 ! QUICKEST 
    156          CALL tra_adv_qck    ( kt, nit000, 'TRA', r2dt, zun, zvn, zwn, tsb, tsn, tsa, jpts                    ) 
     157         CALL tra_adv_qck    ( kt, nit000, 'TRA', r2dt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs ) 
    157158      ! 
    158159      END SELECT 
    … …  
    160161      IF( l_trdtra )   THEN                      ! save the advective trends for further diagnostics 
    161162         DO jk = 1, jpkm1 
    162             ztrdt(:,:,jk) = tsa(:,:,jk,jp_tem) - ztrdt(:,:,jk) 
    163             ztrds(:,:,jk) = tsa(:,:,jk,jp_sal) - ztrds(:,:,jk) 
     163            ztrdt(:,:,jk) = pts(:,:,jk,jp_tem,Krhs) - ztrdt(:,:,jk) 
     164            ztrds(:,:,jk) = pts(:,:,jk,jp_sal,Krhs) - ztrds(:,:,jk) 
    164165         END DO 
    165          CALL trd_tra( kt, 'TRA', jp_tem, jptra_totad, ztrdt ) 
    166          CALL trd_tra( kt, 'TRA', jp_sal, jptra_totad, ztrds ) 
     166         CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_totad, ztrdt ) 
     167         CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_sal, jptra_totad, ztrds ) 
    167168         DEALLOCATE( ztrdt, ztrds ) 
    168169      ENDIF 
    169170      !                                              ! print mean trends (used for debugging) 
    170       IF(ln_ctl)   CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' adv  - Ta: ', mask1=tmask,               & 
    171          &                       tab3d_2=tsa(:,:,:,jp_sal), clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
     171      IF(sn_cfctl%l_prtctl)   CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' adv  - Ta: ', mask1=tmask,               & 
     172         &                                  tab3d_2=pts(:,:,:,jp_sal,Krhs), clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
    172173      ! 
    173174      IF( ln_timing )   CALL timing_stop( 'tra_adv' ) 
    … …  
    194195      ! 
    195196      !                                !==  Namelist  ==! 
    196       REWIND( numnam_ref )                   ! Namelist namtra_adv in reference namelist : Tracer advection scheme 
    197197      READ  ( numnam_ref, namtra_adv, IOSTAT = ios, ERR = 901) 
    198198901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namtra_adv in reference namelist' ) 
    199199      ! 
    200       REWIND( numnam_cfg )                   ! Namelist namtra_adv in configuration namelist : Tracer advection scheme 
    201200      READ  ( numnam_cfg, namtra_adv, IOSTAT = ios, ERR = 902 ) 
    202201902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namtra_adv in configuration namelist' ) 

  • NEMO/trunk/src/OCE/TRA/traadv_cen.F90

    r11993 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 tra_adv_cen( kt, kit000, cdtype, pun, pvn, pwn,     & 
    47       &                                        ptn, pta, kjpt, kn_cen_h, kn_cen_v )  
     46   SUBROUTINE tra_adv_cen( kt, kit000, cdtype, pU, pV, pW,     & 
     47      &                    Kmm, pt, kjpt, Krhs, kn_cen_h, kn_cen_v )  
    4848      !!---------------------------------------------------------------------- 
    4949      !!                  ***  ROUTINE tra_adv_cen  *** 
    … …  
    5959      !!                = 4  ==>> 4th order COMPACT  scheme     -      - 
    6060      !! 
    61       !! ** Action : - update pta  with the now advective tracer trends 
     61      !! ** Action : - update pt(:,:,:,:,Krhs)  with the now advective tracer trends 
    6262      !!             - send trends to trdtra module for further diagnostcs (l_trdtra=T) 
    63       !!             - htr_adv, str_adv : poleward advective heat and salt transport (ln_diaptr=T) 
     63      !!             - poleward advective heat and salt transport (l_diaptr=T) 
    6464      !!---------------------------------------------------------------------- 
    65       INTEGER                              , INTENT(in   ) ::   kt              ! ocean time-step index 
    66       INTEGER                              , INTENT(in   ) ::   kit000          ! first time step index 
    67       CHARACTER(len=3)                     , INTENT(in   ) ::   cdtype          ! =TRA or TRC (tracer indicator) 
    68       INTEGER                              , INTENT(in   ) ::   kjpt            ! number of tracers 
    69       INTEGER                              , INTENT(in   ) ::   kn_cen_h        ! =2/4 (2nd or 4th order scheme) 
    70       INTEGER                              , INTENT(in   ) ::   kn_cen_v        ! =2/4 (2nd or 4th order scheme) 
    71       REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ) ::   pun, pvn, pwn   ! 3 ocean velocity components 
    72       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptn             ! now tracer fields 
    73       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta             ! tracer trend  
     65      INTEGER                                  , INTENT(in   ) ::   kt              ! ocean time-step index 
     66      INTEGER                                  , INTENT(in   ) ::   Kmm, Krhs       ! ocean time level indices 
     67      INTEGER                                  , INTENT(in   ) ::   kit000          ! first time step index 
     68      CHARACTER(len=3)                         , INTENT(in   ) ::   cdtype          ! =TRA or TRC (tracer indicator) 
     69      INTEGER                                  , INTENT(in   ) ::   kjpt            ! number of tracers 
     70      INTEGER                                  , INTENT(in   ) ::   kn_cen_h        ! =2/4 (2nd or 4th order scheme) 
     71      INTEGER                                  , INTENT(in   ) ::   kn_cen_v        ! =2/4 (2nd or 4th order scheme) 
     72      REAL(wp), DIMENSION(jpi,jpj,jpk         ), INTENT(in   ) ::   pU, pV, pW      ! 3 ocean volume flux components 
     73      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) ::   pt              ! tracers and RHS of tracer equation 
    7474      ! 
    7575      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
    … …  
    8989      l_hst = .FALSE. 
    9090      l_ptr = .FALSE. 
    91       IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) )        l_trd = .TRUE. 
    92       IF(   cdtype == 'TRA' .AND. ln_diaptr )                                                 l_ptr = .TRUE.  
     91      IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) )       l_trd = .TRUE. 
     92      IF(   cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) )  )    l_ptr = .TRUE.  
    9393      IF(   cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & 
    94          &                          iom_use("uadv_salttr") .OR. iom_use("vadv_salttr")  ) )   l_hst = .TRUE. 
     94         &                          iom_use("uadv_salttr") .OR. iom_use("vadv_salttr")  ) )  l_hst = .TRUE. 
    9595      ! 
    9696      !                     
    … …  
    103103         ! 
    104104         CASE(  2  )                         !* 2nd order centered 
    105             DO jk = 1, jpkm1 
    106                DO jj = 1, jpjm1 
    107                   DO ji = 1, fs_jpim1   ! vector opt. 
    108                      zwx(ji,jj,jk) = 0.5_wp * pun(ji,jj,jk) * ( ptn(ji,jj,jk,jn) + ptn(ji+1,jj  ,jk,jn) ) 
    109                      zwy(ji,jj,jk) = 0.5_wp * pvn(ji,jj,jk) * ( ptn(ji,jj,jk,jn) + ptn(ji  ,jj+1,jk,jn) ) 
    110                   END DO 
    111                END DO 
    112             END DO 
     105            DO_3D_10_10( 1, jpkm1 ) 
     106               zwx(ji,jj,jk) = 0.5_wp * pU(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj  ,jk,jn,Kmm) ) 
     107               zwy(ji,jj,jk) = 0.5_wp * pV(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji  ,jj+1,jk,jn,Kmm) ) 
     108            END_3D 
    113109            ! 
    114110         CASE(  4  )                         !* 4th order centered 
    115111            ztu(:,:,jpk) = 0._wp                   ! Bottom value : flux set to zero 
    116112            ztv(:,:,jpk) = 0._wp 
    117             DO jk = 1, jpkm1                       ! masked gradient 
    118                DO jj = 2, jpjm1 
    119                   DO ji = fs_2, fs_jpim1   ! vector opt. 
    120                      ztu(ji,jj,jk) = ( ptn(ji+1,jj  ,jk,jn) - ptn(ji,jj,jk,jn) ) * umask(ji,jj,jk) 
    121                      ztv(ji,jj,jk) = ( ptn(ji  ,jj+1,jk,jn) - ptn(ji,jj,jk,jn) ) * vmask(ji,jj,jk) 
    122                   END DO 
    123                END DO 
    124             END DO 
     113            DO_3D_00_00( 1, jpkm1 ) 
     114               ztu(ji,jj,jk) = ( pt(ji+1,jj  ,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * umask(ji,jj,jk) 
     115               ztv(ji,jj,jk) = ( pt(ji  ,jj+1,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * vmask(ji,jj,jk) 
     116            END_3D 
    125117            CALL lbc_lnk_multi( 'traadv_cen', ztu, 'U', -1. , ztv, 'V', -1. )   ! Lateral boundary cond. 
    126118            ! 
    127             DO jk = 1, jpkm1                       ! Horizontal advective fluxes 
    128                DO jj = 2, jpjm1 
    129                   DO ji = 1, fs_jpim1   ! vector opt. 
    130                      zC2t_u = ptn(ji,jj,jk,jn) + ptn(ji+1,jj  ,jk,jn)   ! C2 interpolation of T at u- & v-points (x2) 
    131                      zC2t_v = ptn(ji,jj,jk,jn) + ptn(ji  ,jj+1,jk,jn) 
    132                      !                                                  ! C4 interpolation of T at u- & v-points (x2) 
    133                      zC4t_u =  zC2t_u + r1_6 * ( ztu(ji-1,jj,jk) - ztu(ji+1,jj,jk) ) 
    134                      zC4t_v =  zC2t_v + r1_6 * ( ztv(ji,jj-1,jk) - ztv(ji,jj+1,jk) ) 
    135                      !                                                  ! C4 fluxes 
    136                      zwx(ji,jj,jk) =  0.5_wp * pun(ji,jj,jk) * zC4t_u 
    137                      zwy(ji,jj,jk) =  0.5_wp * pvn(ji,jj,jk) * zC4t_v 
    138                   END DO 
    139                END DO 
    140             END DO          
     119            DO_3D_00_10( 1, jpkm1 ) 
     120               zC2t_u = pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj  ,jk,jn,Kmm)   ! C2 interpolation of T at u- & v-points (x2) 
     121               zC2t_v = pt(ji,jj,jk,jn,Kmm) + pt(ji  ,jj+1,jk,jn,Kmm) 
     122               !                                                  ! C4 interpolation of T at u- & v-points (x2) 
     123               zC4t_u =  zC2t_u + r1_6 * ( ztu(ji-1,jj,jk) - ztu(ji+1,jj,jk) ) 
     124               zC4t_v =  zC2t_v + r1_6 * ( ztv(ji,jj-1,jk) - ztv(ji,jj+1,jk) ) 
     125               !                                                  ! C4 fluxes 
     126               zwx(ji,jj,jk) =  0.5_wp * pU(ji,jj,jk) * zC4t_u 
     127               zwy(ji,jj,jk) =  0.5_wp * pV(ji,jj,jk) * zC4t_v 
     128            END_3D 
    141129            ! 
    142130         CASE DEFAULT 
    … …  
    147135         ! 
    148136         CASE(  2  )                         !* 2nd order centered 
    149             DO jk = 2, jpk 
    150                DO jj = 2, jpjm1 
    151                   DO ji = fs_2, fs_jpim1   ! vector opt. 
    152                      zwz(ji,jj,jk) = 0.5 * pwn(ji,jj,jk) * ( ptn(ji,jj,jk,jn) + ptn(ji,jj,jk-1,jn) ) * wmask(ji,jj,jk) 
    153                   END DO 
    154                END DO 
    155             END DO 
     137            DO_3D_00_00( 2, jpk ) 
     138               zwz(ji,jj,jk) = 0.5 * pW(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji,jj,jk-1,jn,Kmm) ) * wmask(ji,jj,jk) 
     139            END_3D 
    156140            ! 
    157141         CASE(  4  )                         !* 4th order compact 
    158             CALL interp_4th_cpt( ptn(:,:,:,jn) , ztw )      ! ztw = interpolated value of T at w-point 
    159             DO jk = 2, jpkm1 
    160                DO jj = 2, jpjm1 
    161                   DO ji = fs_2, fs_jpim1 
    162                      zwz(ji,jj,jk) = pwn(ji,jj,jk) * ztw(ji,jj,jk) * wmask(ji,jj,jk) 
    163                   END DO 
    164                END DO 
    165             END DO 
     142            CALL interp_4th_cpt( pt(:,:,:,jn,Kmm) , ztw )      ! ztw = interpolated value of T at w-point 
     143            DO_3D_00_00( 2, jpkm1 ) 
     144               zwz(ji,jj,jk) = pW(ji,jj,jk) * ztw(ji,jj,jk) * wmask(ji,jj,jk) 
     145            END_3D 
    166146            ! 
    167147         END SELECT 
    … …  
    169149         IF( ln_linssh ) THEN                !* top value   (linear free surf. only as zwz is multiplied by wmask) 
    170150            IF( ln_isfcav ) THEN                  ! ice-shelf cavities (top of the ocean) 
    171                DO jj = 1, jpj 
    172                   DO ji = 1, jpi 
    173                      zwz(ji,jj, mikt(ji,jj) ) = pwn(ji,jj,mikt(ji,jj)) * ptn(ji,jj,mikt(ji,jj),jn)  
    174                   END DO 
    175                END DO    
     151               DO_2D_11_11 
     152                  zwz(ji,jj, mikt(ji,jj) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kmm)  
     153               END_2D 
    176154            ELSE                                   ! no ice-shelf cavities (only ocean surface) 
    177                zwz(:,:,1) = pwn(:,:,1) * ptn(:,:,1,jn) 
     155               zwz(:,:,1) = pW(:,:,1) * pt(:,:,1,jn,Kmm) 
    178156            ENDIF 
    179157         ENDIF 
    180158         !                
    181          DO jk = 1, jpkm1              !--  Divergence of advective fluxes  --! 
    182             DO jj = 2, jpjm1 
    183                DO ji = fs_2, fs_jpim1   ! vector opt. 
    184                   pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn)    & 
    185                      &             - (  zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk  )    & 
    186                      &                + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk  )    & 
    187                      &                + zwz(ji,jj,jk) - zwz(ji  ,jj  ,jk+1)  ) * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) 
    188                END DO 
    189             END DO 
    190          END DO 
     159         DO_3D_00_00( 1, jpkm1 ) 
     160            pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs)    & 
     161               &             - (  zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk  )    & 
     162               &                + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk  )    & 
     163               &                + zwz(ji,jj,jk) - zwz(ji  ,jj  ,jk+1)  ) * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
     164         END_3D 
    191165         !                             ! trend diagnostics 
    192166         IF( l_trd ) THEN 
    193             CALL trd_tra( kt, cdtype, jn, jptra_xad, zwx, pun, ptn(:,:,:,jn) ) 
    194             CALL trd_tra( kt, cdtype, jn, jptra_yad, zwy, pvn, ptn(:,:,:,jn) ) 
    195             CALL trd_tra( kt, cdtype, jn, jptra_zad, zwz, pwn, ptn(:,:,:,jn) ) 
     167            CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_xad, zwx, pU, pt(:,:,:,jn,Kmm) ) 
     168            CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_yad, zwy, pV, pt(:,:,:,jn,Kmm) ) 
     169            CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_zad, zwz, pW, pt(:,:,:,jn,Kmm) ) 
    196170         END IF 
    197171         !                                 ! "Poleward" heat and salt transports  

  • NEMO/trunk/src/OCE/TRA/traadv_fct.F90

    r12055 r12377  
    4545 
    4646   !! * Substitutions 
    47 #  include "vectopt_loop_substitute.h90" 
     47#  include "do_loop_substitute.h90" 
    4848   !!---------------------------------------------------------------------- 
    4949   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    5353CONTAINS 
    5454 
    55    SUBROUTINE tra_adv_fct( kt, kit000, cdtype, p2dt, pun, pvn, pwn,       & 
    56       &                                              ptb, ptn, pta, kjpt, kn_fct_h, kn_fct_v ) 
     55   SUBROUTINE tra_adv_fct( kt, kit000, cdtype, p2dt, pU, pV, pW,       & 
     56      &                    Kbb, Kmm, pt, kjpt, Krhs, kn_fct_h, kn_fct_v ) 
    5757      !!---------------------------------------------------------------------- 
    5858      !!                  ***  ROUTINE tra_adv_fct  *** 
    … …  
    6666      !!               - corrected flux (monotonic correction)  
    6767      !! 
    68       !! ** Action : - update pta  with the now advective tracer trends 
     68      !! ** Action : - update pt(:,:,:,:,Krhs)  with the now advective tracer trends 
    6969      !!             - send trends to trdtra module for further diagnostics (l_trdtra=T) 
    70       !!             - htr_adv, str_adv : poleward advective heat and salt transport (ln_diaptr=T) 
    71       !!---------------------------------------------------------------------- 
    72       INTEGER                              , INTENT(in   ) ::   kt              ! ocean time-step index 
    73       INTEGER                              , INTENT(in   ) ::   kit000          ! first time step index 
    74       CHARACTER(len=3)                     , INTENT(in   ) ::   cdtype          ! =TRA or TRC (tracer indicator) 
    75       INTEGER                              , INTENT(in   ) ::   kjpt            ! number of tracers 
    76       INTEGER                              , INTENT(in   ) ::   kn_fct_h        ! order of the FCT scheme (=2 or 4) 
    77       INTEGER                              , INTENT(in   ) ::   kn_fct_v        ! order of the FCT scheme (=2 or 4) 
    78       REAL(wp)                             , INTENT(in   ) ::   p2dt            ! tracer time-step 
    79       REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ) ::   pun, pvn, pwn   ! 3 ocean velocity components 
    80       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb, ptn        ! before and now tracer fields 
    81       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta             ! tracer trend  
     70      !!             - poleward advective heat and salt transport (ln_diaptr=T) 
     71      !!---------------------------------------------------------------------- 
     72      INTEGER                                  , INTENT(in   ) ::   kt              ! ocean time-step index 
     73      INTEGER                                  , INTENT(in   ) ::   Kbb, Kmm, Krhs  ! ocean time level indices 
     74      INTEGER                                  , INTENT(in   ) ::   kit000          ! first time step index 
     75      CHARACTER(len=3)                         , INTENT(in   ) ::   cdtype          ! =TRA or TRC (tracer indicator) 
     76      INTEGER                                  , INTENT(in   ) ::   kjpt            ! number of tracers 
     77      INTEGER                                  , INTENT(in   ) ::   kn_fct_h        ! order of the FCT scheme (=2 or 4) 
     78      INTEGER                                  , INTENT(in   ) ::   kn_fct_v        ! order of the FCT scheme (=2 or 4) 
     79      REAL(wp)                                 , INTENT(in   ) ::   p2dt            ! tracer time-step 
     80      REAL(wp), DIMENSION(jpi,jpj,jpk         ), INTENT(in   ) ::   pU, pV, pW      ! 3 ocean volume flux components 
     81      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) ::   pt              ! tracers and RHS of tracer equation 
    8282      ! 
    8383      INTEGER  ::   ji, jj, jk, jn                           ! dummy loop indices   
    … …  
    101101      l_ptr = .FALSE. 
    102102      ll_zAimp = .FALSE. 
    103       IF( ( cdtype =='TRA' .AND. l_trdtra  ) .OR. ( cdtype =='TRC' .AND. l_trdtrc ) )       l_trd = .TRUE. 
    104       IF(   cdtype =='TRA' .AND. ln_diaptr )                                                l_ptr = .TRUE.  
    105       IF(   cdtype =='TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR.  & 
     103      IF( ( cdtype == 'TRA' .AND. l_trdtra  ) .OR. ( cdtype =='TRC' .AND. l_trdtrc ) )      l_trd = .TRUE. 
     104      IF(   cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) ) )    l_ptr = .TRUE.  
     105      IF(   cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR.  & 
    106106         &                         iom_use("uadv_salttr") .OR. iom_use("vadv_salttr")  ) )  l_hst = .TRUE. 
    107107      ! 
    … …  
    128128      IF( ll_zAimp ) THEN 
    129129         ALLOCATE(zwdia(jpi,jpj,jpk), zwinf(jpi,jpj,jpk),zwsup(jpi,jpj,jpk)) 
    130          DO jk = 1, jpkm1 
    131             DO jj = 2, jpjm1 
    132                DO ji = fs_2, fs_jpim1   ! vector opt. (ensure same order of calculation as below if wi=0.) 
    133                   zwdia(ji,jj,jk) =  1._wp + p2dt * ( MAX( wi(ji,jj,jk  ) , 0._wp ) - MIN( wi(ji,jj,jk+1) , 0._wp ) ) / e3t_a(ji,jj,jk) 
    134                   zwinf(ji,jj,jk) =  p2dt * MIN( wi(ji,jj,jk  ) , 0._wp ) / e3t_a(ji,jj,jk) 
    135                   zwsup(ji,jj,jk) = -p2dt * MAX( wi(ji,jj,jk+1) , 0._wp ) / e3t_a(ji,jj,jk) 
    136                END DO 
    137             END DO 
    138          END DO 
     130         DO_3D_00_00( 1, jpkm1 ) 
     131            zwdia(ji,jj,jk) =  1._wp + p2dt * ( MAX( wi(ji,jj,jk  ) , 0._wp ) - MIN( wi(ji,jj,jk+1) , 0._wp ) ) / e3t(ji,jj,jk,Krhs) 
     132            zwinf(ji,jj,jk) =  p2dt * MIN( wi(ji,jj,jk  ) , 0._wp ) / e3t(ji,jj,jk,Krhs) 
     133            zwsup(ji,jj,jk) = -p2dt * MAX( wi(ji,jj,jk+1) , 0._wp ) / e3t(ji,jj,jk,Krhs) 
     134         END_3D 
    139135      END IF 
    140136      ! 
    … …  
    143139         !        !==  upstream advection with initial mass fluxes & intermediate update  ==! 
    144140         !                    !* upstream tracer flux in the i and j direction  
    145          DO jk = 1, jpkm1 
    146             DO jj = 1, jpjm1 
    147                DO ji = 1, fs_jpim1   ! vector opt. 
    148                   ! upstream scheme 
    149                   zfp_ui = pun(ji,jj,jk) + ABS( pun(ji,jj,jk) ) 
    150                   zfm_ui = pun(ji,jj,jk) - ABS( pun(ji,jj,jk) ) 
    151                   zfp_vj = pvn(ji,jj,jk) + ABS( pvn(ji,jj,jk) ) 
    152                   zfm_vj = pvn(ji,jj,jk) - ABS( pvn(ji,jj,jk) ) 
    153                   zwx(ji,jj,jk) = 0.5 * ( zfp_ui * ptb(ji,jj,jk,jn) + zfm_ui * ptb(ji+1,jj  ,jk,jn) ) 
    154                   zwy(ji,jj,jk) = 0.5 * ( zfp_vj * ptb(ji,jj,jk,jn) + zfm_vj * ptb(ji  ,jj+1,jk,jn) ) 
    155                END DO 
    156             END DO 
    157          END DO 
     141         DO_3D_10_10( 1, jpkm1 ) 
     142            ! upstream scheme 
     143            zfp_ui = pU(ji,jj,jk) + ABS( pU(ji,jj,jk) ) 
     144            zfm_ui = pU(ji,jj,jk) - ABS( pU(ji,jj,jk) ) 
     145            zfp_vj = pV(ji,jj,jk) + ABS( pV(ji,jj,jk) ) 
     146            zfm_vj = pV(ji,jj,jk) - ABS( pV(ji,jj,jk) ) 
     147            zwx(ji,jj,jk) = 0.5 * ( zfp_ui * pt(ji,jj,jk,jn,Kbb) + zfm_ui * pt(ji+1,jj  ,jk,jn,Kbb) ) 
     148            zwy(ji,jj,jk) = 0.5 * ( zfp_vj * pt(ji,jj,jk,jn,Kbb) + zfm_vj * pt(ji  ,jj+1,jk,jn,Kbb) ) 
     149         END_3D 
    158150         !                    !* upstream tracer flux in the k direction *! 
    159          DO jk = 2, jpkm1        ! Interior value ( multiplied by wmask) 
    160             DO jj = 1, jpj 
    161                DO ji = 1, jpi 
    162                   zfp_wk = pwn(ji,jj,jk) + ABS( pwn(ji,jj,jk) ) 
    163                   zfm_wk = pwn(ji,jj,jk) - ABS( pwn(ji,jj,jk) ) 
    164                   zwz(ji,jj,jk) = 0.5 * ( zfp_wk * ptb(ji,jj,jk,jn) + zfm_wk * ptb(ji,jj,jk-1,jn) ) * wmask(ji,jj,jk) 
    165                END DO 
    166             END DO 
    167          END DO 
     151         DO_3D_11_11( 2, jpkm1 ) 
     152            zfp_wk = pW(ji,jj,jk) + ABS( pW(ji,jj,jk) ) 
     153            zfm_wk = pW(ji,jj,jk) - ABS( pW(ji,jj,jk) ) 
     154            zwz(ji,jj,jk) = 0.5 * ( zfp_wk * pt(ji,jj,jk,jn,Kbb) + zfm_wk * pt(ji,jj,jk-1,jn,Kbb) ) * wmask(ji,jj,jk) 
     155         END_3D 
    168156         IF( ln_linssh ) THEN    ! top ocean value (only in linear free surface as zwz has been w-masked) 
    169157            IF( ln_isfcav ) THEN             ! top of the ice-shelf cavities and at the ocean surface 
    170                DO jj = 1, jpj 
    171                   DO ji = 1, jpi 
    172                      zwz(ji,jj, mikt(ji,jj) ) = pwn(ji,jj,mikt(ji,jj)) * ptb(ji,jj,mikt(ji,jj),jn)   ! linear free surface  
    173                   END DO 
    174                END DO    
     158               DO_2D_11_11 
     159                  zwz(ji,jj, mikt(ji,jj) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kbb)   ! linear free surface  
     160               END_2D 
    175161            ELSE                             ! no cavities: only at the ocean surface 
    176                zwz(:,:,1) = pwn(:,:,1) * ptb(:,:,1,jn) 
     162               zwz(:,:,1) = pW(:,:,1) * pt(:,:,1,jn,Kbb) 
    177163            ENDIF 
    178164         ENDIF 
    179165         !                
    180          DO jk = 1, jpkm1     !* trend and after field with monotonic scheme 
    181             DO jj = 2, jpjm1 
    182                DO ji = fs_2, fs_jpim1   ! vector opt. 
    183                   !                             ! total intermediate advective trends 
    184                   ztra = - (  zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk  )   & 
    185                      &      + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk  )   & 
    186                      &      + zwz(ji,jj,jk) - zwz(ji  ,jj  ,jk+1) ) * r1_e1e2t(ji,jj) 
    187                   !                             ! update and guess with monotonic sheme 
    188                   pta(ji,jj,jk,jn) =                     pta(ji,jj,jk,jn) +        ztra   / e3t_n(ji,jj,jk) * tmask(ji,jj,jk) 
    189                   zwi(ji,jj,jk)    = ( e3t_b(ji,jj,jk) * ptb(ji,jj,jk,jn) + p2dt * ztra ) / e3t_a(ji,jj,jk) * tmask(ji,jj,jk) 
    190                END DO 
    191             END DO 
    192          END DO 
     166         DO_3D_00_00( 1, jpkm1 ) 
     167            !                             ! total intermediate advective trends 
     168            ztra = - (  zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk  )   & 
     169               &      + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk  )   & 
     170               &      + zwz(ji,jj,jk) - zwz(ji  ,jj  ,jk+1) ) * r1_e1e2t(ji,jj) 
     171            !                             ! update and guess with monotonic sheme 
     172            pt(ji,jj,jk,jn,Krhs) =                     pt(ji,jj,jk,jn,Krhs) +        ztra   / e3t(ji,jj,jk,Kmm) * tmask(ji,jj,jk) 
     173            zwi(ji,jj,jk)    = ( e3t(ji,jj,jk,Kbb) * pt(ji,jj,jk,jn,Kbb) + p2dt * ztra ) / e3t(ji,jj,jk,Krhs) * tmask(ji,jj,jk) 
     174         END_3D 
    193175          
    194176         IF ( ll_zAimp ) THEN 
    … …  
    196178            ! 
    197179            ztw(:,:,1) = 0._wp ; ztw(:,:,jpk) = 0._wp ; 
    198             DO jk = 2, jpkm1        ! Interior value ( multiplied by wmask) 
    199                DO jj = 2, jpjm1 
    200                   DO ji = fs_2, fs_jpim1   ! vector opt.   
    201                      zfp_wk = wi(ji,jj,jk) + ABS( wi(ji,jj,jk) ) 
    202                      zfm_wk = wi(ji,jj,jk) - ABS( wi(ji,jj,jk) ) 
    203                      ztw(ji,jj,jk) =  0.5 * e1e2t(ji,jj) * ( zfp_wk * zwi(ji,jj,jk) + zfm_wk * zwi(ji,jj,jk-1) ) * wmask(ji,jj,jk) 
    204                      zwz(ji,jj,jk) = zwz(ji,jj,jk) + ztw(ji,jj,jk) ! update vertical fluxes 
    205                   END DO 
    206                END DO 
    207             END DO 
    208             DO jk = 1, jpkm1 
    209                DO jj = 2, jpjm1 
    210                   DO ji = fs_2, fs_jpim1   ! vector opt.   
    211                      pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) - ( ztw(ji,jj,jk) - ztw(ji  ,jj  ,jk+1) ) & 
    212                         &                                  * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) 
    213                   END DO 
    214                END DO 
    215             END DO 
     180            DO_3D_00_00( 2, jpkm1 ) 
     181               zfp_wk = wi(ji,jj,jk) + ABS( wi(ji,jj,jk) ) 
     182               zfm_wk = wi(ji,jj,jk) - ABS( wi(ji,jj,jk) ) 
     183               ztw(ji,jj,jk) =  0.5 * e1e2t(ji,jj) * ( zfp_wk * zwi(ji,jj,jk) + zfm_wk * zwi(ji,jj,jk-1) ) * wmask(ji,jj,jk) 
     184               zwz(ji,jj,jk) = zwz(ji,jj,jk) + ztw(ji,jj,jk) ! update vertical fluxes 
     185            END_3D 
     186            DO_3D_00_00( 1, jpkm1 ) 
     187               pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( ztw(ji,jj,jk) - ztw(ji  ,jj  ,jk+1) ) & 
     188                  &                                        * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
     189            END_3D 
    216190            ! 
    217191         END IF 
    … …  
    228202         ! 
    229203         CASE(  2  )                   !- 2nd order centered 
    230             DO jk = 1, jpkm1 
    231                DO jj = 1, jpjm1 
    232                   DO ji = 1, fs_jpim1   ! vector opt. 
    233                      zwx(ji,jj,jk) = 0.5_wp * pun(ji,jj,jk) * ( ptn(ji,jj,jk,jn) + ptn(ji+1,jj,jk,jn) ) - zwx(ji,jj,jk) 
    234                      zwy(ji,jj,jk) = 0.5_wp * pvn(ji,jj,jk) * ( ptn(ji,jj,jk,jn) + ptn(ji,jj+1,jk,jn) ) - zwy(ji,jj,jk) 
    235                   END DO 
    236                END DO 
    237             END DO 
     204            DO_3D_10_10( 1, jpkm1 ) 
     205               zwx(ji,jj,jk) = 0.5_wp * pU(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj,jk,jn,Kmm) ) - zwx(ji,jj,jk) 
     206               zwy(ji,jj,jk) = 0.5_wp * pV(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji,jj+1,jk,jn,Kmm) ) - zwy(ji,jj,jk) 
     207            END_3D 
    238208            ! 
    239209         CASE(  4  )                   !- 4th order centered 
    … …  
    241211            zltv(:,:,jpk) = 0._wp 
    242212            DO jk = 1, jpkm1                 ! Laplacian 
    243                DO jj = 1, jpjm1                    ! 1st derivative (gradient) 
    244                   DO ji = 1, fs_jpim1   ! vector opt. 
    245                      ztu(ji,jj,jk) = ( ptn(ji+1,jj  ,jk,jn) - ptn(ji,jj,jk,jn) ) * umask(ji,jj,jk) 
    246                      ztv(ji,jj,jk) = ( ptn(ji  ,jj+1,jk,jn) - ptn(ji,jj,jk,jn) ) * vmask(ji,jj,jk) 
    247                   END DO 
    248                END DO 
    249                DO jj = 2, jpjm1                    ! 2nd derivative * 1/ 6 
    250                   DO ji = fs_2, fs_jpim1   ! vector opt. 
    251                      zltu(ji,jj,jk) = (  ztu(ji,jj,jk) + ztu(ji-1,jj,jk)  ) * r1_6 
    252                      zltv(ji,jj,jk) = (  ztv(ji,jj,jk) + ztv(ji,jj-1,jk)  ) * r1_6 
    253                   END DO 
    254                END DO 
     213               DO_2D_10_10 
     214                  ztu(ji,jj,jk) = ( pt(ji+1,jj  ,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * umask(ji,jj,jk) 
     215                  ztv(ji,jj,jk) = ( pt(ji  ,jj+1,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * vmask(ji,jj,jk) 
     216               END_2D 
     217               DO_2D_00_00 
     218                  zltu(ji,jj,jk) = (  ztu(ji,jj,jk) + ztu(ji-1,jj,jk)  ) * r1_6 
     219                  zltv(ji,jj,jk) = (  ztv(ji,jj,jk) + ztv(ji,jj-1,jk)  ) * r1_6 
     220               END_2D 
    255221            END DO 
    256222            CALL lbc_lnk_multi( 'traadv_fct', zltu, 'T', 1. , zltv, 'T', 1. )   ! Lateral boundary cond. (unchanged sgn) 
    257223            ! 
    258             DO jk = 1, jpkm1                 ! Horizontal advective fluxes 
    259                DO jj = 1, jpjm1 
    260                   DO ji = 1, fs_jpim1   ! vector opt. 
    261                      zC2t_u = ptn(ji,jj,jk,jn) + ptn(ji+1,jj  ,jk,jn)   ! 2 x C2 interpolation of T at u- & v-points 
    262                      zC2t_v = ptn(ji,jj,jk,jn) + ptn(ji  ,jj+1,jk,jn) 
    263                      !                                                  ! C4 minus upstream advective fluxes  
    264                      zwx(ji,jj,jk) =  0.5_wp * pun(ji,jj,jk) * ( zC2t_u + zltu(ji,jj,jk) - zltu(ji+1,jj,jk) ) - zwx(ji,jj,jk) 
    265                      zwy(ji,jj,jk) =  0.5_wp * pvn(ji,jj,jk) * ( zC2t_v + zltv(ji,jj,jk) - zltv(ji,jj+1,jk) ) - zwy(ji,jj,jk) 
    266                   END DO 
    267                END DO 
    268             END DO          
     224            DO_3D_10_10( 1, jpkm1 ) 
     225               zC2t_u = pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj  ,jk,jn,Kmm)   ! 2 x C2 interpolation of T at u- & v-points 
     226               zC2t_v = pt(ji,jj,jk,jn,Kmm) + pt(ji  ,jj+1,jk,jn,Kmm) 
     227               !                                                  ! C4 minus upstream advective fluxes  
     228               zwx(ji,jj,jk) =  0.5_wp * pU(ji,jj,jk) * ( zC2t_u + zltu(ji,jj,jk) - zltu(ji+1,jj,jk) ) - zwx(ji,jj,jk) 
     229               zwy(ji,jj,jk) =  0.5_wp * pV(ji,jj,jk) * ( zC2t_v + zltv(ji,jj,jk) - zltv(ji,jj+1,jk) ) - zwy(ji,jj,jk) 
     230            END_3D 
    269231            ! 
    270232         CASE(  41 )                   !- 4th order centered       ==>>   !!gm coding attempt   need to be tested 
    271233            ztu(:,:,jpk) = 0._wp             ! Bottom value : flux set to zero 
    272234            ztv(:,:,jpk) = 0._wp 
    273             DO jk = 1, jpkm1                 ! 1st derivative (gradient) 
    274                DO jj = 1, jpjm1 
    275                   DO ji = 1, fs_jpim1   ! vector opt. 
    276                      ztu(ji,jj,jk) = ( ptn(ji+1,jj  ,jk,jn) - ptn(ji,jj,jk,jn) ) * umask(ji,jj,jk) 
    277                      ztv(ji,jj,jk) = ( ptn(ji  ,jj+1,jk,jn) - ptn(ji,jj,jk,jn) ) * vmask(ji,jj,jk) 
    278                   END DO 
    279                END DO 
    280             END DO 
     235            DO_3D_10_10( 1, jpkm1 ) 
     236               ztu(ji,jj,jk) = ( pt(ji+1,jj  ,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * umask(ji,jj,jk) 
     237               ztv(ji,jj,jk) = ( pt(ji  ,jj+1,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * vmask(ji,jj,jk) 
     238            END_3D 
    281239            CALL lbc_lnk_multi( 'traadv_fct', ztu, 'U', -1. , ztv, 'V', -1. )   ! Lateral boundary cond. (unchanged sgn) 
    282240            ! 
    283             DO jk = 1, jpkm1                 ! Horizontal advective fluxes 
    284                DO jj = 2, jpjm1 
    285                   DO ji = 2, fs_jpim1   ! vector opt. 
    286                      zC2t_u = ptn(ji,jj,jk,jn) + ptn(ji+1,jj  ,jk,jn)   ! 2 x C2 interpolation of T at u- & v-points (x2) 
    287                      zC2t_v = ptn(ji,jj,jk,jn) + ptn(ji  ,jj+1,jk,jn) 
    288                      !                                                  ! C4 interpolation of T at u- & v-points (x2) 
    289                      zC4t_u =  zC2t_u + r1_6 * ( ztu(ji-1,jj  ,jk) - ztu(ji+1,jj  ,jk) ) 
    290                      zC4t_v =  zC2t_v + r1_6 * ( ztv(ji  ,jj-1,jk) - ztv(ji  ,jj+1,jk) ) 
    291                      !                                                  ! C4 minus upstream advective fluxes  
    292                      zwx(ji,jj,jk) =  0.5_wp * pun(ji,jj,jk) * zC4t_u - zwx(ji,jj,jk) 
    293                      zwy(ji,jj,jk) =  0.5_wp * pvn(ji,jj,jk) * zC4t_v - zwy(ji,jj,jk) 
    294                   END DO 
    295                END DO 
    296             END DO 
     241            DO_3D_00_00( 1, jpkm1 ) 
     242               zC2t_u = pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj  ,jk,jn,Kmm)   ! 2 x C2 interpolation of T at u- & v-points (x2) 
     243               zC2t_v = pt(ji,jj,jk,jn,Kmm) + pt(ji  ,jj+1,jk,jn,Kmm) 
     244               !                                                  ! C4 interpolation of T at u- & v-points (x2) 
     245               zC4t_u =  zC2t_u + r1_6 * ( ztu(ji-1,jj  ,jk) - ztu(ji+1,jj  ,jk) ) 
     246               zC4t_v =  zC2t_v + r1_6 * ( ztv(ji  ,jj-1,jk) - ztv(ji  ,jj+1,jk) ) 
     247               !                                                  ! C4 minus upstream advective fluxes  
     248               zwx(ji,jj,jk) =  0.5_wp * pU(ji,jj,jk) * zC4t_u - zwx(ji,jj,jk) 
     249               zwy(ji,jj,jk) =  0.5_wp * pV(ji,jj,jk) * zC4t_v - zwy(ji,jj,jk) 
     250            END_3D 
    297251            ! 
    298252         END SELECT 
    … …  
    301255         ! 
    302256         CASE(  2  )                   !- 2nd order centered 
    303             DO jk = 2, jpkm1     
    304                DO jj = 2, jpjm1 
    305                   DO ji = fs_2, fs_jpim1 
    306                      zwz(ji,jj,jk) =  (  pwn(ji,jj,jk) * 0.5_wp * ( ptn(ji,jj,jk,jn) + ptn(ji,jj,jk-1,jn) )   & 
    307                         &              - zwz(ji,jj,jk)  ) * wmask(ji,jj,jk) 
    308                   END DO 
    309                END DO 
    310             END DO 
     257            DO_3D_00_00( 2, jpkm1 ) 
     258               zwz(ji,jj,jk) =  (  pW(ji,jj,jk) * 0.5_wp * ( pt(ji,jj,jk,jn,Kmm) + pt(ji,jj,jk-1,jn,Kmm) )   & 
     259                  &              - zwz(ji,jj,jk)  ) * wmask(ji,jj,jk) 
     260            END_3D 
    311261            ! 
    312262         CASE(  4  )                   !- 4th order COMPACT 
    313             CALL interp_4th_cpt( ptn(:,:,:,jn) , ztw )   ! zwt = COMPACT interpolation of T at w-point 
    314             DO jk = 2, jpkm1 
    315                DO jj = 2, jpjm1 
    316                   DO ji = fs_2, fs_jpim1 
    317                      zwz(ji,jj,jk) = ( pwn(ji,jj,jk) * ztw(ji,jj,jk) - zwz(ji,jj,jk) ) * wmask(ji,jj,jk) 
    318                   END DO 
    319                END DO 
    320             END DO 
     263            CALL interp_4th_cpt( pt(:,:,:,jn,Kmm) , ztw )   ! zwt = COMPACT interpolation of T at w-point 
     264            DO_3D_00_00( 2, jpkm1 ) 
     265               zwz(ji,jj,jk) = ( pW(ji,jj,jk) * ztw(ji,jj,jk) - zwz(ji,jj,jk) ) * wmask(ji,jj,jk) 
     266            END_3D 
    321267            ! 
    322268         END SELECT 
    … …  
    326272         !          
    327273         IF ( ll_zAimp ) THEN 
    328             DO jk = 1, jpkm1     !* trend and after field with monotonic scheme 
    329                DO jj = 2, jpjm1 
    330                   DO ji = fs_2, fs_jpim1   ! vector opt. 
    331                      !                             ! total intermediate advective trends 
    332                      ztra = - (  zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk  )   & 
    333                         &      + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk  )   & 
    334                         &      + zwz(ji,jj,jk) - zwz(ji  ,jj  ,jk+1) ) * r1_e1e2t(ji,jj) 
    335                      ztw(ji,jj,jk)  = zwi(ji,jj,jk) + p2dt * ztra / e3t_a(ji,jj,jk) * tmask(ji,jj,jk) 
    336                   END DO 
    337                END DO 
    338             END DO 
     274            DO_3D_00_00( 1, jpkm1 ) 
     275               !                             ! total intermediate advective trends 
     276               ztra = - (  zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk  )   & 
     277                  &      + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk  )   & 
     278                  &      + zwz(ji,jj,jk) - zwz(ji  ,jj  ,jk+1) ) * r1_e1e2t(ji,jj) 
     279               ztw(ji,jj,jk)  = zwi(ji,jj,jk) + p2dt * ztra / e3t(ji,jj,jk,Krhs) * tmask(ji,jj,jk) 
     280            END_3D 
    339281            ! 
    340282            CALL tridia_solver( zwdia, zwsup, zwinf, ztw, ztw , 0 ) 
    341283            ! 
    342             DO jk = 2, jpkm1        ! Interior value ( multiplied by wmask) 
    343                DO jj = 2, jpjm1 
    344                   DO ji = fs_2, fs_jpim1   ! vector opt. 
    345                      zfp_wk = wi(ji,jj,jk) + ABS( wi(ji,jj,jk) ) 
    346                      zfm_wk = wi(ji,jj,jk) - ABS( wi(ji,jj,jk) ) 
    347                      zwz(ji,jj,jk) =  zwz(ji,jj,jk) + 0.5 * e1e2t(ji,jj) * ( zfp_wk * ztw(ji,jj,jk) + zfm_wk * ztw(ji,jj,jk-1) ) * wmask(ji,jj,jk) 
    348                   END DO 
    349                END DO 
    350             END DO 
     284            DO_3D_00_00( 2, jpkm1 ) 
     285               zfp_wk = wi(ji,jj,jk) + ABS( wi(ji,jj,jk) ) 
     286               zfm_wk = wi(ji,jj,jk) - ABS( wi(ji,jj,jk) ) 
     287               zwz(ji,jj,jk) =  zwz(ji,jj,jk) + 0.5 * e1e2t(ji,jj) * ( zfp_wk * ztw(ji,jj,jk) + zfm_wk * ztw(ji,jj,jk-1) ) * wmask(ji,jj,jk) 
     288            END_3D 
    351289         END IF 
    352290         ! 
    … …  
    355293         !        !==  monotonicity algorithm  ==! 
    356294         ! 
    357          CALL nonosc( ptb(:,:,:,jn), zwx, zwy, zwz, zwi, p2dt ) 
     295         CALL nonosc( Kmm, pt(:,:,:,jn,Kbb), zwx, zwy, zwz, zwi, p2dt ) 
    358296         ! 
    359297         !        !==  final trend with corrected fluxes  ==! 
    360298         ! 
    361          DO jk = 1, jpkm1 
    362             DO jj = 2, jpjm1 
    363                DO ji = fs_2, fs_jpim1   ! vector opt.   
    364                   ztra = - (  zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk  )   & 
    365                      &      + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk  )   & 
    366                      &      + zwz(ji,jj,jk) - zwz(ji  ,jj  ,jk+1) ) * r1_e1e2t(ji,jj) 
    367                   pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + ztra / e3t_n(ji,jj,jk) 
    368                   zwi(ji,jj,jk) = zwi(ji,jj,jk) + p2dt * ztra / e3t_a(ji,jj,jk) * tmask(ji,jj,jk) 
    369                END DO 
    370             END DO 
    371          END DO 
     299         DO_3D_00_00( 1, jpkm1 ) 
     300            ztra = - (  zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk  )   & 
     301               &      + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk  )   & 
     302               &      + zwz(ji,jj,jk) - zwz(ji  ,jj  ,jk+1) ) * r1_e1e2t(ji,jj) 
     303            pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) + ztra / e3t(ji,jj,jk,Kmm) 
     304            zwi(ji,jj,jk) = zwi(ji,jj,jk) + p2dt * ztra / e3t(ji,jj,jk,Krhs) * tmask(ji,jj,jk) 
     305         END_3D 
    372306         ! 
    373307         IF ( ll_zAimp ) THEN 
    374308            ! 
    375309            ztw(:,:,1) = 0._wp ; ztw(:,:,jpk) = 0._wp 
    376             DO jk = 2, jpkm1        ! Interior value ( multiplied by wmask) 
    377                DO jj = 2, jpjm1 
    378                   DO ji = fs_2, fs_jpim1   ! vector opt. 
    379                      zfp_wk = wi(ji,jj,jk) + ABS( wi(ji,jj,jk) ) 
    380                      zfm_wk = wi(ji,jj,jk) - ABS( wi(ji,jj,jk) ) 
    381                      ztw(ji,jj,jk) = - 0.5 * e1e2t(ji,jj) * ( zfp_wk * zwi(ji,jj,jk) + zfm_wk * zwi(ji,jj,jk-1) ) * wmask(ji,jj,jk) 
    382                      zwz(ji,jj,jk) = zwz(ji,jj,jk) + ztw(ji,jj,jk) ! Update vertical fluxes for trend diagnostic 
    383                   END DO 
    384                END DO 
    385             END DO 
    386             DO jk = 1, jpkm1 
    387                DO jj = 2, jpjm1 
    388                   DO ji = fs_2, fs_jpim1   ! vector opt.   
    389                      pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) - ( ztw(ji,jj,jk) - ztw(ji  ,jj  ,jk+1) ) & 
    390                         &                                * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) 
    391                   END DO 
    392                END DO 
    393             END DO 
     310            DO_3D_00_00( 2, jpkm1 ) 
     311               zfp_wk = wi(ji,jj,jk) + ABS( wi(ji,jj,jk) ) 
     312               zfm_wk = wi(ji,jj,jk) - ABS( wi(ji,jj,jk) ) 
     313               ztw(ji,jj,jk) = - 0.5 * e1e2t(ji,jj) * ( zfp_wk * zwi(ji,jj,jk) + zfm_wk * zwi(ji,jj,jk-1) ) * wmask(ji,jj,jk) 
     314               zwz(ji,jj,jk) = zwz(ji,jj,jk) + ztw(ji,jj,jk) ! Update vertical fluxes for trend diagnostic 
     315            END_3D 
     316            DO_3D_00_00( 1, jpkm1 ) 
     317               pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( ztw(ji,jj,jk) - ztw(ji  ,jj  ,jk+1) ) & 
     318                  &                                        * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
     319            END_3D 
    394320         END IF          
    395321         ! 
    … …  
    400326            ! 
    401327            IF( l_trd ) THEN              ! trend diagnostics 
    402                CALL trd_tra( kt, cdtype, jn, jptra_xad, ztrdx, pun, ptn(:,:,:,jn) ) 
    403                CALL trd_tra( kt, cdtype, jn, jptra_yad, ztrdy, pvn, ptn(:,:,:,jn) ) 
    404                CALL trd_tra( kt, cdtype, jn, jptra_zad, ztrdz, pwn, ptn(:,:,:,jn) ) 
     328               CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_xad, ztrdx, pU, pt(:,:,:,jn,Kmm) ) 
     329               CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_yad, ztrdy, pV, pt(:,:,:,jn,Kmm) ) 
     330               CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_zad, ztrdz, pW, pt(:,:,:,jn,Kmm) ) 
    405331            ENDIF 
    406332            !                             ! heat/salt transport 
    … …  
    428354 
    429355 
    430    SUBROUTINE nonosc( pbef, paa, pbb, pcc, paft, p2dt ) 
     356   SUBROUTINE nonosc( Kmm, pbef, paa, pbb, pcc, paft, p2dt ) 
    431357      !!--------------------------------------------------------------------- 
    432358      !!                    ***  ROUTINE nonosc  *** 
    … …  
    441367      !!       in-space based differencing for fluid 
    442368      !!---------------------------------------------------------------------- 
     369      INTEGER                          , INTENT(in   ) ::   Kmm             ! time level index  
    443370      REAL(wp)                         , INTENT(in   ) ::   p2dt            ! tracer time-step 
    444371      REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in   ) ::   pbef, paft      ! before & after field 
    … …  
    466393      DO jk = 1, jpkm1 
    467394         ikm1 = MAX(jk-1,1) 
    468          DO jj = 2, jpjm1 
    469             DO ji = fs_2, fs_jpim1   ! vector opt. 
    470  
    471                ! search maximum in neighbourhood 
    472                zup = MAX(  zbup(ji  ,jj  ,jk  ),   & 
    473                   &        zbup(ji-1,jj  ,jk  ), zbup(ji+1,jj  ,jk  ),   & 
    474                   &        zbup(ji  ,jj-1,jk  ), zbup(ji  ,jj+1,jk  ),   & 
    475                   &        zbup(ji  ,jj  ,ikm1), zbup(ji  ,jj  ,jk+1)  ) 
    476  
    477                ! search minimum in neighbourhood 
    478                zdo = MIN(  zbdo(ji  ,jj  ,jk  ),   & 
    479                   &        zbdo(ji-1,jj  ,jk  ), zbdo(ji+1,jj  ,jk  ),   & 
    480                   &        zbdo(ji  ,jj-1,jk  ), zbdo(ji  ,jj+1,jk  ),   & 
    481                   &        zbdo(ji  ,jj  ,ikm1), zbdo(ji  ,jj  ,jk+1)  ) 
    482  
    483                ! positive part of the flux 
    484                zpos = MAX( 0., paa(ji-1,jj  ,jk  ) ) - MIN( 0., paa(ji  ,jj  ,jk  ) )   & 
    485                   & + MAX( 0., pbb(ji  ,jj-1,jk  ) ) - MIN( 0., pbb(ji  ,jj  ,jk  ) )   & 
    486                   & + MAX( 0., pcc(ji  ,jj  ,jk+1) ) - MIN( 0., pcc(ji  ,jj  ,jk  ) ) 
    487  
    488                ! negative part of the flux 
    489                zneg = MAX( 0., paa(ji  ,jj  ,jk  ) ) - MIN( 0., paa(ji-1,jj  ,jk  ) )   & 
    490                   & + MAX( 0., pbb(ji  ,jj  ,jk  ) ) - MIN( 0., pbb(ji  ,jj-1,jk  ) )   & 
    491                   & + MAX( 0., pcc(ji  ,jj  ,jk  ) ) - MIN( 0., pcc(ji  ,jj  ,jk+1) ) 
    492  
    493                ! up & down beta terms 
    494                zbt = e1e2t(ji,jj) * e3t_n(ji,jj,jk) / p2dt 
    495                zbetup(ji,jj,jk) = ( zup            - paft(ji,jj,jk) ) / ( zpos + zrtrn ) * zbt 
    496                zbetdo(ji,jj,jk) = ( paft(ji,jj,jk) - zdo            ) / ( zneg + zrtrn ) * zbt 
    497             END DO 
    498          END DO 
     395         DO_2D_00_00 
     396 
     397            ! search maximum in neighbourhood 
     398            zup = MAX(  zbup(ji  ,jj  ,jk  ),   & 
     399               &        zbup(ji-1,jj  ,jk  ), zbup(ji+1,jj  ,jk  ),   & 
     400               &        zbup(ji  ,jj-1,jk  ), zbup(ji  ,jj+1,jk  ),   & 
     401               &        zbup(ji  ,jj  ,ikm1), zbup(ji  ,jj  ,jk+1)  ) 
     402 
     403            ! search minimum in neighbourhood 
     404            zdo = MIN(  zbdo(ji  ,jj  ,jk  ),   & 
     405               &        zbdo(ji-1,jj  ,jk  ), zbdo(ji+1,jj  ,jk  ),   & 
     406               &        zbdo(ji  ,jj-1,jk  ), zbdo(ji  ,jj+1,jk  ),   & 
     407               &        zbdo(ji  ,jj  ,ikm1), zbdo(ji  ,jj  ,jk+1)  ) 
     408 
     409            ! positive part of the flux 
     410            zpos = MAX( 0., paa(ji-1,jj  ,jk  ) ) - MIN( 0., paa(ji  ,jj  ,jk  ) )   & 
     411               & + MAX( 0., pbb(ji  ,jj-1,jk  ) ) - MIN( 0., pbb(ji  ,jj  ,jk  ) )   & 
     412               & + MAX( 0., pcc(ji  ,jj  ,jk+1) ) - MIN( 0., pcc(ji  ,jj  ,jk  ) ) 
     413 
     414            ! negative part of the flux 
     415            zneg = MAX( 0., paa(ji  ,jj  ,jk  ) ) - MIN( 0., paa(ji-1,jj  ,jk  ) )   & 
     416               & + MAX( 0., pbb(ji  ,jj  ,jk  ) ) - MIN( 0., pbb(ji  ,jj-1,jk  ) )   & 
     417               & + MAX( 0., pcc(ji  ,jj  ,jk  ) ) - MIN( 0., pcc(ji  ,jj  ,jk+1) ) 
     418 
     419            ! up & down beta terms 
     420            zbt = e1e2t(ji,jj) * e3t(ji,jj,jk,Kmm) / p2dt 
     421            zbetup(ji,jj,jk) = ( zup            - paft(ji,jj,jk) ) / ( zpos + zrtrn ) * zbt 
     422            zbetdo(ji,jj,jk) = ( paft(ji,jj,jk) - zdo            ) / ( zneg + zrtrn ) * zbt 
     423         END_2D 
    499424      END DO 
    500425      CALL lbc_lnk_multi( 'traadv_fct', zbetup, 'T', 1. , zbetdo, 'T', 1. )   ! lateral boundary cond. (unchanged sign) 
    … …  
    502427      ! 3. monotonic flux in the i & j direction (paa & pbb) 
    503428      ! ---------------------------------------- 
    504       DO jk = 1, jpkm1 
    505          DO jj = 2, jpjm1 
    506             DO ji = fs_2, fs_jpim1   ! vector opt. 
    507                zau = MIN( 1._wp, zbetdo(ji,jj,jk), zbetup(ji+1,jj,jk) ) 
    508                zbu = MIN( 1._wp, zbetup(ji,jj,jk), zbetdo(ji+1,jj,jk) ) 
    509                zcu =       ( 0.5  + SIGN( 0.5 , paa(ji,jj,jk) ) ) 
    510                paa(ji,jj,jk) = paa(ji,jj,jk) * ( zcu * zau + ( 1._wp - zcu) * zbu ) 
    511  
    512                zav = MIN( 1._wp, zbetdo(ji,jj,jk), zbetup(ji,jj+1,jk) ) 
    513                zbv = MIN( 1._wp, zbetup(ji,jj,jk), zbetdo(ji,jj+1,jk) ) 
    514                zcv =       ( 0.5  + SIGN( 0.5 , pbb(ji,jj,jk) ) ) 
    515                pbb(ji,jj,jk) = pbb(ji,jj,jk) * ( zcv * zav + ( 1._wp - zcv) * zbv ) 
    516  
    517       ! monotonic flux in the k direction, i.e. pcc 
    518       ! ------------------------------------------- 
    519                za = MIN( 1., zbetdo(ji,jj,jk+1), zbetup(ji,jj,jk) ) 
    520                zb = MIN( 1., zbetup(ji,jj,jk+1), zbetdo(ji,jj,jk) ) 
    521                zc =       ( 0.5  + SIGN( 0.5 , pcc(ji,jj,jk+1) ) ) 
    522                pcc(ji,jj,jk+1) = pcc(ji,jj,jk+1) * ( zc * za + ( 1._wp - zc) * zb ) 
    523             END DO 
    524          END DO 
    525       END DO 
     429      DO_3D_00_00( 1, jpkm1 ) 
     430         zau = MIN( 1._wp, zbetdo(ji,jj,jk), zbetup(ji+1,jj,jk) ) 
     431         zbu = MIN( 1._wp, zbetup(ji,jj,jk), zbetdo(ji+1,jj,jk) ) 
     432         zcu =       ( 0.5  + SIGN( 0.5 , paa(ji,jj,jk) ) ) 
     433         paa(ji,jj,jk) = paa(ji,jj,jk) * ( zcu * zau + ( 1._wp - zcu) * zbu ) 
     434 
     435         zav = MIN( 1._wp, zbetdo(ji,jj,jk), zbetup(ji,jj+1,jk) ) 
     436         zbv = MIN( 1._wp, zbetup(ji,jj,jk), zbetdo(ji,jj+1,jk) ) 
     437         zcv =       ( 0.5  + SIGN( 0.5 , pbb(ji,jj,jk) ) ) 
     438         pbb(ji,jj,jk) = pbb(ji,jj,jk) * ( zcv * zav + ( 1._wp - zcv) * zbv ) 
     439 
     440! monotonic flux in the k direction, i.e. pcc 
     441! ------------------------------------------- 
     442         za = MIN( 1., zbetdo(ji,jj,jk+1), zbetup(ji,jj,jk) ) 
     443         zb = MIN( 1., zbetup(ji,jj,jk+1), zbetdo(ji,jj,jk) ) 
     444         zc =       ( 0.5  + SIGN( 0.5 , pcc(ji,jj,jk+1) ) ) 
     445         pcc(ji,jj,jk+1) = pcc(ji,jj,jk+1) * ( zc * za + ( 1._wp - zc) * zb ) 
     446      END_3D 
    526447      CALL lbc_lnk_multi( 'traadv_fct', paa, 'U', -1. , pbb, 'V', -1. )   ! lateral boundary condition (changed sign) 
    527448      ! 
    … …  
    544465      !!---------------------------------------------------------------------- 
    545466       
    546       DO jk = 3, jpkm1        !==  build the three diagonal matrix  ==! 
    547          DO jj = 1, jpj 
    548             DO ji = 1, jpi 
    549                zwd (ji,jj,jk) = 4._wp 
    550                zwi (ji,jj,jk) = 1._wp 
    551                zws (ji,jj,jk) = 1._wp 
    552                zwrm(ji,jj,jk) = 3._wp * ( pt_in(ji,jj,jk-1) + pt_in(ji,jj,jk) ) 
    553                ! 
    554                IF( tmask(ji,jj,jk+1) == 0._wp) THEN   ! Switch to second order centered at bottom 
    555                   zwd (ji,jj,jk) = 1._wp 
    556                   zwi (ji,jj,jk) = 0._wp 
    557                   zws (ji,jj,jk) = 0._wp 
    558                   zwrm(ji,jj,jk) = 0.5 * ( pt_in(ji,jj,jk-1) + pt_in(ji,jj,jk) )     
    559                ENDIF 
    560             END DO 
    561          END DO 
    562       END DO 
    563       ! 
    564       jk = 2                                          ! Switch to second order centered at top 
    565       DO jj = 1, jpj 
    566          DO ji = 1, jpi 
     467      DO_3D_11_11( 3, jpkm1 ) 
     468         zwd (ji,jj,jk) = 4._wp 
     469         zwi (ji,jj,jk) = 1._wp 
     470         zws (ji,jj,jk) = 1._wp 
     471         zwrm(ji,jj,jk) = 3._wp * ( pt_in(ji,jj,jk-1) + pt_in(ji,jj,jk) ) 
     472         ! 
     473         IF( tmask(ji,jj,jk+1) == 0._wp) THEN   ! Switch to second order centered at bottom 
    567474            zwd (ji,jj,jk) = 1._wp 
    568475            zwi (ji,jj,jk) = 0._wp 
    569476            zws (ji,jj,jk) = 0._wp 
    570             zwrm(ji,jj,jk) = 0.5 * ( pt_in(ji,jj,jk-1) + pt_in(ji,jj,jk) ) 
    571          END DO 
    572       END DO    
     477            zwrm(ji,jj,jk) = 0.5 * ( pt_in(ji,jj,jk-1) + pt_in(ji,jj,jk) )     
     478         ENDIF 
     479      END_3D 
     480      ! 
     481      jk = 2                                          ! Switch to second order centered at top 
     482      DO_2D_11_11 
     483         zwd (ji,jj,jk) = 1._wp 
     484         zwi (ji,jj,jk) = 0._wp 
     485         zws (ji,jj,jk) = 0._wp 
     486         zwrm(ji,jj,jk) = 0.5 * ( pt_in(ji,jj,jk-1) + pt_in(ji,jj,jk) ) 
     487      END_2D 
    573488      ! 
    574489      !                       !==  tridiagonal solve  ==! 
    575       DO jj = 1, jpj                ! first recurrence 
    576          DO ji = 1, jpi 
    577             zwt(ji,jj,2) = zwd(ji,jj,2) 
    578          END DO 
    579       END DO 
    580       DO jk = 3, jpkm1 
    581          DO jj = 1, jpj 
    582             DO ji = 1, jpi 
    583                zwt(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) /zwt(ji,jj,jk-1) 
    584             END DO 
    585          END DO 
    586       END DO 
    587       ! 
    588       DO jj = 1, jpj                ! second recurrence:    Zk = Yk - Ik / Tk-1  Zk-1 
    589          DO ji = 1, jpi 
    590             pt_out(ji,jj,2) = zwrm(ji,jj,2) 
    591          END DO 
    592       END DO 
    593       DO jk = 3, jpkm1 
    594          DO jj = 1, jpj 
    595             DO ji = 1, jpi 
    596                pt_out(ji,jj,jk) = zwrm(ji,jj,jk) - zwi(ji,jj,jk) / zwt(ji,jj,jk-1) *pt_out(ji,jj,jk-1)              
    597             END DO 
    598          END DO 
    599       END DO 
    600  
    601       DO jj = 1, jpj                ! third recurrence: Xk = (Zk - Sk Xk+1 ) / Tk 
    602          DO ji = 1, jpi 
    603             pt_out(ji,jj,jpkm1) = pt_out(ji,jj,jpkm1) / zwt(ji,jj,jpkm1) 
    604          END DO 
    605       END DO 
    606       DO jk = jpk-2, 2, -1 
    607          DO jj = 1, jpj 
    608             DO ji = 1, jpi 
    609                pt_out(ji,jj,jk) = ( pt_out(ji,jj,jk) - zws(ji,jj,jk) * pt_out(ji,jj,jk+1) ) / zwt(ji,jj,jk) 
    610             END DO 
    611          END DO 
    612       END DO 
     490      DO_2D_11_11 
     491         zwt(ji,jj,2) = zwd(ji,jj,2) 
     492      END_2D 
     493      DO_3D_11_11( 3, jpkm1 ) 
     494         zwt(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) /zwt(ji,jj,jk-1) 
     495      END_3D 
     496      ! 
     497      DO_2D_11_11 
     498         pt_out(ji,jj,2) = zwrm(ji,jj,2) 
     499      END_2D 
     500      DO_3D_11_11( 3, jpkm1 ) 
     501         pt_out(ji,jj,jk) = zwrm(ji,jj,jk) - zwi(ji,jj,jk) / zwt(ji,jj,jk-1) *pt_out(ji,jj,jk-1)              
     502      END_3D 
     503 
     504      DO_2D_11_11 
     505         pt_out(ji,jj,jpkm1) = pt_out(ji,jj,jpkm1) / zwt(ji,jj,jpkm1) 
     506      END_2D 
     507      DO_3DS_11_11( jpk-2, 2, -1 ) 
     508         pt_out(ji,jj,jk) = ( pt_out(ji,jj,jk) - zws(ji,jj,jk) * pt_out(ji,jj,jk+1) ) / zwt(ji,jj,jk) 
     509      END_3D 
    613510      !     
    614511   END SUBROUTINE interp_4th_cpt_org 
    … …  
    633530      !                      !==  build the three diagonal matrix & the RHS  ==! 
    634531      ! 
    635       DO jk = 3, jpkm1                 ! interior (from jk=3 to jpk-1) 
    636          DO jj = 2, jpjm1 
    637             DO ji = fs_2, fs_jpim1 
    638                zwd (ji,jj,jk) = 3._wp * wmask(ji,jj,jk) + 1._wp                 !       diagonal 
    639                zwi (ji,jj,jk) =         wmask(ji,jj,jk)                         ! lower diagonal 
    640                zws (ji,jj,jk) =         wmask(ji,jj,jk)                         ! upper diagonal 
    641                zwrm(ji,jj,jk) = 3._wp * wmask(ji,jj,jk)                     &   ! RHS 
    642                   &           *       ( pt_in(ji,jj,jk) + pt_in(ji,jj,jk-1) ) 
    643             END DO 
    644          END DO 
    645       END DO 
     532      DO_3D_00_00( 3, jpkm1 ) 
     533         zwd (ji,jj,jk) = 3._wp * wmask(ji,jj,jk) + 1._wp                 !       diagonal 
     534         zwi (ji,jj,jk) =         wmask(ji,jj,jk)                         ! lower diagonal 
     535         zws (ji,jj,jk) =         wmask(ji,jj,jk)                         ! upper diagonal 
     536         zwrm(ji,jj,jk) = 3._wp * wmask(ji,jj,jk)                     &   ! RHS 
     537            &           *       ( pt_in(ji,jj,jk) + pt_in(ji,jj,jk-1) ) 
     538      END_3D 
    646539      ! 
    647540!!gm 
    … …  
    656549      END IF 
    657550      ! 
    658       DO jj = 2, jpjm1                 ! 2nd order centered at top & bottom 
    659          DO ji = fs_2, fs_jpim1 
    660             ikt = mikt(ji,jj) + 1            ! w-point below the 1st  wet point 
    661             ikb = MAX(mbkt(ji,jj), 2)        !     -   above the last wet point 
    662             ! 
    663             zwd (ji,jj,ikt) = 1._wp          ! top 
    664             zwi (ji,jj,ikt) = 0._wp 
    665             zws (ji,jj,ikt) = 0._wp 
    666             zwrm(ji,jj,ikt) = 0.5_wp * ( pt_in(ji,jj,ikt-1) + pt_in(ji,jj,ikt) ) 
    667             ! 
    668             zwd (ji,jj,ikb) = 1._wp          ! bottom 
    669             zwi (ji,jj,ikb) = 0._wp 
    670             zws (ji,jj,ikb) = 0._wp 
    671             zwrm(ji,jj,ikb) = 0.5_wp * ( pt_in(ji,jj,ikb-1) + pt_in(ji,jj,ikb) )             
    672          END DO 
    673       END DO    
     551      DO_2D_00_00 
     552         ikt = mikt(ji,jj) + 1            ! w-point below the 1st  wet point 
     553         ikb = MAX(mbkt(ji,jj), 2)        !     -   above the last wet point 
     554         ! 
     555         zwd (ji,jj,ikt) = 1._wp          ! top 
     556         zwi (ji,jj,ikt) = 0._wp 
     557         zws (ji,jj,ikt) = 0._wp 
     558         zwrm(ji,jj,ikt) = 0.5_wp * ( pt_in(ji,jj,ikt-1) + pt_in(ji,jj,ikt) ) 
     559         ! 
     560         zwd (ji,jj,ikb) = 1._wp          ! bottom 
     561         zwi (ji,jj,ikb) = 0._wp 
     562         zws (ji,jj,ikb) = 0._wp 
     563         zwrm(ji,jj,ikb) = 0.5_wp * ( pt_in(ji,jj,ikb-1) + pt_in(ji,jj,ikb) )             
     564      END_2D 
    674565      ! 
    675566      !                       !==  tridiagonal solver  ==! 
    676567      ! 
    677       DO jj = 2, jpjm1              !* 1st recurrence:   Tk = Dk - Ik Sk-1 / Tk-1 
    678          DO ji = fs_2, fs_jpim1 
    679             zwt(ji,jj,2) = zwd(ji,jj,2) 
    680          END DO 
    681       END DO 
    682       DO jk = 3, jpkm1 
    683          DO jj = 2, jpjm1 
    684             DO ji = fs_2, fs_jpim1 
    685                zwt(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) /zwt(ji,jj,jk-1) 
    686             END DO 
    687          END DO 
    688       END DO 
    689       ! 
    690       DO jj = 2, jpjm1              !* 2nd recurrence:    Zk = Yk - Ik / Tk-1  Zk-1 
    691          DO ji = fs_2, fs_jpim1 
    692             pt_out(ji,jj,2) = zwrm(ji,jj,2) 
    693          END DO 
    694       END DO 
    695       DO jk = 3, jpkm1 
    696          DO jj = 2, jpjm1 
    697             DO ji = fs_2, fs_jpim1 
    698                pt_out(ji,jj,jk) = zwrm(ji,jj,jk) - zwi(ji,jj,jk) / zwt(ji,jj,jk-1) *pt_out(ji,jj,jk-1)              
    699             END DO 
    700          END DO 
    701       END DO 
    702  
    703       DO jj = 2, jpjm1              !* 3d recurrence:    Xk = (Zk - Sk Xk+1 ) / Tk 
    704          DO ji = fs_2, fs_jpim1 
    705             pt_out(ji,jj,jpkm1) = pt_out(ji,jj,jpkm1) / zwt(ji,jj,jpkm1) 
    706          END DO 
    707       END DO 
    708       DO jk = jpk-2, 2, -1 
    709          DO jj = 2, jpjm1 
    710             DO ji = fs_2, fs_jpim1 
    711                pt_out(ji,jj,jk) = ( pt_out(ji,jj,jk) - zws(ji,jj,jk) * pt_out(ji,jj,jk+1) ) / zwt(ji,jj,jk) 
    712             END DO 
    713          END DO 
    714       END DO 
     568      DO_2D_00_00 
     569         zwt(ji,jj,2) = zwd(ji,jj,2) 
     570      END_2D 
     571      DO_3D_00_00( 3, jpkm1 ) 
     572         zwt(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) /zwt(ji,jj,jk-1) 
     573      END_3D 
     574      ! 
     575      DO_2D_00_00 
     576         pt_out(ji,jj,2) = zwrm(ji,jj,2) 
     577      END_2D 
     578      DO_3D_00_00( 3, jpkm1 ) 
     579         pt_out(ji,jj,jk) = zwrm(ji,jj,jk) - zwi(ji,jj,jk) / zwt(ji,jj,jk-1) *pt_out(ji,jj,jk-1)              
     580      END_3D 
     581 
     582      DO_2D_00_00 
     583         pt_out(ji,jj,jpkm1) = pt_out(ji,jj,jpkm1) / zwt(ji,jj,jpkm1) 
     584      END_2D 
     585      DO_3DS_00_00( jpk-2, 2, -1 ) 
     586         pt_out(ji,jj,jk) = ( pt_out(ji,jj,jk) - zws(ji,jj,jk) * pt_out(ji,jj,jk+1) ) / zwt(ji,jj,jk) 
     587      END_3D 
    715588      !     
    716589   END SUBROUTINE interp_4th_cpt 
    … …  
    749622      kstart =  1  + klev 
    750623      ! 
    751       DO jj = 2, jpjm1              !* 1st recurrence:   Tk = Dk - Ik Sk-1 / Tk-1 
    752          DO ji = fs_2, fs_jpim1 
    753             zwt(ji,jj,kstart) = pD(ji,jj,kstart) 
    754          END DO 
    755       END DO 
    756       DO jk = kstart+1, jpkm1 
    757          DO jj = 2, jpjm1 
    758             DO ji = fs_2, fs_jpim1 
    759                zwt(ji,jj,jk) = pD(ji,jj,jk) - pL(ji,jj,jk) * pU(ji,jj,jk-1) /zwt(ji,jj,jk-1) 
    760             END DO 
    761          END DO 
    762       END DO 
    763       ! 
    764       DO jj = 2, jpjm1              !* 2nd recurrence:    Zk = Yk - Ik / Tk-1  Zk-1 
    765          DO ji = fs_2, fs_jpim1 
    766             pt_out(ji,jj,kstart) = pRHS(ji,jj,kstart) 
    767          END DO 
    768       END DO 
    769       DO jk = kstart+1, jpkm1 
    770          DO jj = 2, jpjm1 
    771             DO ji = fs_2, fs_jpim1 
    772                pt_out(ji,jj,jk) = pRHS(ji,jj,jk) - pL(ji,jj,jk) / zwt(ji,jj,jk-1) *pt_out(ji,jj,jk-1)              
    773             END DO 
    774          END DO 
    775       END DO 
    776  
    777       DO jj = 2, jpjm1              !* 3d recurrence:    Xk = (Zk - Sk Xk+1 ) / Tk 
    778          DO ji = fs_2, fs_jpim1 
    779             pt_out(ji,jj,jpkm1) = pt_out(ji,jj,jpkm1) / zwt(ji,jj,jpkm1) 
    780          END DO 
    781       END DO 
    782       DO jk = jpk-2, kstart, -1 
    783          DO jj = 2, jpjm1 
    784             DO ji = fs_2, fs_jpim1 
    785                pt_out(ji,jj,jk) = ( pt_out(ji,jj,jk) - pU(ji,jj,jk) * pt_out(ji,jj,jk+1) ) / zwt(ji,jj,jk) 
    786             END DO 
    787          END DO 
    788       END DO 
     624      DO_2D_00_00 
     625         zwt(ji,jj,kstart) = pD(ji,jj,kstart) 
     626      END_2D 
     627      DO_3D_00_00( kstart+1, jpkm1 ) 
     628         zwt(ji,jj,jk) = pD(ji,jj,jk) - pL(ji,jj,jk) * pU(ji,jj,jk-1) /zwt(ji,jj,jk-1) 
     629      END_3D 
     630      ! 
     631      DO_2D_00_00 
     632         pt_out(ji,jj,kstart) = pRHS(ji,jj,kstart) 
     633      END_2D 
     634      DO_3D_00_00( kstart+1, jpkm1 ) 
     635         pt_out(ji,jj,jk) = pRHS(ji,jj,jk) - pL(ji,jj,jk) / zwt(ji,jj,jk-1) *pt_out(ji,jj,jk-1)              
     636      END_3D 
     637 
     638      DO_2D_00_00 
     639         pt_out(ji,jj,jpkm1) = pt_out(ji,jj,jpkm1) / zwt(ji,jj,jpkm1) 
     640      END_2D 
     641      DO_3DS_00_00( jpk-2, kstart, -1 ) 
     642         pt_out(ji,jj,jk) = ( pt_out(ji,jj,jk) - pU(ji,jj,jk) * pt_out(ji,jj,jk+1) ) / zwt(ji,jj,jk) 
     643      END_3D 
    789644      ! 
    790645   END SUBROUTINE tridia_solver 

  • NEMO/trunk/src/OCE/TRA/traadv_mus.F90

    r11993 r12377  
    4646 
    4747   !! * Substitutions 
    48 #  include "vectopt_loop_substitute.h90" 
     48#  include "do_loop_substitute.h90" 
    4949   !!---------------------------------------------------------------------- 
    5050   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    5454CONTAINS 
    5555 
    56    SUBROUTINE tra_adv_mus( kt, kit000, cdtype, p2dt, pun, pvn, pwn,             & 
    57       &                                              ptb, pta, kjpt, ld_msc_ups ) 
     56   SUBROUTINE tra_adv_mus( kt, kit000, cdtype, p2dt, pU, pV, pW,             & 
     57      &                    Kbb, Kmm, pt, kjpt, Krhs, ld_msc_ups ) 
    5858      !!---------------------------------------------------------------------- 
    5959      !!                    ***  ROUTINE tra_adv_mus  *** 
    … …  
    6666      !!              ld_msc_ups=T :  
    6767      !! 
    68       !! ** Action : - update pta  with the now advective tracer trends 
     68      !! ** Action : - update pt(:,:,:,:,Krhs)  with the now advective tracer trends 
    6969      !!             - send trends to trdtra module for further diagnostcs (l_trdtra=T) 
    70       !!             - htr_adv, str_adv : poleward advective heat and salt transport (ln_diaptr=T) 
     70      !!             - poleward advective heat and salt transport (ln_diaptr=T) 
    7171      !! 
    7272      !! References : Estubier, A., and M. Levy, Notes Techn. Pole de Modelisation 
    7373      !!              IPSL, Sept. 2000 (http://www.lodyc.jussieu.fr/opa) 
    7474      !!---------------------------------------------------------------------- 
    75       INTEGER                              , INTENT(in   ) ::   kt              ! ocean time-step index 
    76       INTEGER                              , INTENT(in   ) ::   kit000          ! first time step index 
    77       CHARACTER(len=3)                     , INTENT(in   ) ::   cdtype          ! =TRA or TRC (tracer indicator) 
    78       INTEGER                              , INTENT(in   ) ::   kjpt            ! number of tracers 
    79       LOGICAL                              , INTENT(in   ) ::   ld_msc_ups      ! use upstream scheme within muscl 
    80       REAL(wp)                             , INTENT(in   ) ::   p2dt            ! tracer time-step 
    81       REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ) ::   pun, pvn, pwn   ! 3 ocean velocity components 
    82       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb             ! before tracer field 
    83       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta             ! tracer trend  
     75      INTEGER                                  , INTENT(in   ) ::   kt              ! ocean time-step index 
     76      INTEGER                                  , INTENT(in   ) ::   Kbb, Kmm, Krhs  ! ocean time level indices 
     77      INTEGER                                  , INTENT(in   ) ::   kit000          ! first time step index 
     78      CHARACTER(len=3)                         , INTENT(in   ) ::   cdtype          ! =TRA or TRC (tracer indicator) 
     79      INTEGER                                  , INTENT(in   ) ::   kjpt            ! number of tracers 
     80      LOGICAL                                  , INTENT(in   ) ::   ld_msc_ups      ! use upstream scheme within muscl 
     81      REAL(wp)                                 , INTENT(in   ) ::   p2dt            ! tracer time-step 
     82      REAL(wp), DIMENSION(jpi,jpj,jpk         ), INTENT(in   ) ::   pU, pV, pW      ! 3 ocean volume flux components 
     83      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) ::   pt              ! tracers and RHS of tracer equation 
    8484      ! 
    8585      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
    … …  
    120120      l_ptr = .FALSE. 
    121121      IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) )      l_trd = .TRUE. 
    122       IF(   cdtype == 'TRA' .AND. ln_diaptr )                                               l_ptr = .TRUE.  
     122      IF(   cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) )  )   l_ptr = .TRUE.  
    123123      IF(   cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & 
    124124         &                          iom_use("uadv_salttr") .OR. iom_use("vadv_salttr")  ) ) l_hst = .TRUE. 
    … …  
    131131         zwx(:,:,jpk) = 0._wp                   ! bottom values 
    132132         zwy(:,:,jpk) = 0._wp   
    133          DO jk = 1, jpkm1                       ! interior values 
    134             DO jj = 1, jpjm1       
    135                DO ji = 1, fs_jpim1   ! vector opt. 
    136                   zwx(ji,jj,jk) = umask(ji,jj,jk) * ( ptb(ji+1,jj,jk,jn) - ptb(ji,jj,jk,jn) ) 
    137                   zwy(ji,jj,jk) = vmask(ji,jj,jk) * ( ptb(ji,jj+1,jk,jn) - ptb(ji,jj,jk,jn) ) 
    138                END DO 
    139            END DO 
    140          END DO 
     133         DO_3D_10_10( 1, jpkm1 ) 
     134            zwx(ji,jj,jk) = umask(ji,jj,jk) * ( pt(ji+1,jj,jk,jn,Kbb) - pt(ji,jj,jk,jn,Kbb) ) 
     135            zwy(ji,jj,jk) = vmask(ji,jj,jk) * ( pt(ji,jj+1,jk,jn,Kbb) - pt(ji,jj,jk,jn,Kbb) ) 
     136         END_3D 
    141137         ! lateral boundary conditions   (changed sign) 
    142138         CALL lbc_lnk_multi( 'traadv_mus', zwx, 'U', -1. , zwy, 'V', -1. ) 
    … …  
    144140         zslpx(:,:,jpk) = 0._wp                 ! bottom values 
    145141         zslpy(:,:,jpk) = 0._wp 
    146          DO jk = 1, jpkm1                       ! interior values 
    147             DO jj = 2, jpj 
    148                DO ji = fs_2, jpi   ! vector opt. 
    149                   zslpx(ji,jj,jk) =                    ( zwx(ji,jj,jk) + zwx(ji-1,jj  ,jk) )   & 
    150                      &            * ( 0.25 + SIGN( 0.25, zwx(ji,jj,jk) * zwx(ji-1,jj  ,jk) ) ) 
    151                   zslpy(ji,jj,jk) =                    ( zwy(ji,jj,jk) + zwy(ji  ,jj-1,jk) )   & 
    152                      &            * ( 0.25 + SIGN( 0.25, zwy(ji,jj,jk) * zwy(ji  ,jj-1,jk) ) ) 
    153                END DO 
    154             END DO 
    155          END DO 
    156          ! 
    157          DO jk = 1, jpkm1                 !-- Slopes limitation 
    158             DO jj = 2, jpj 
    159                DO ji = fs_2, jpi   ! vector opt. 
    160                   zslpx(ji,jj,jk) = SIGN( 1., zslpx(ji,jj,jk) ) * MIN(    ABS( zslpx(ji  ,jj,jk) ),   & 
    161                      &                                                 2.*ABS( zwx  (ji-1,jj,jk) ),   & 
    162                      &                                                 2.*ABS( zwx  (ji  ,jj,jk) ) ) 
    163                   zslpy(ji,jj,jk) = SIGN( 1., zslpy(ji,jj,jk) ) * MIN(    ABS( zslpy(ji,jj  ,jk) ),   & 
    164                      &                                                 2.*ABS( zwy  (ji,jj-1,jk) ),   & 
    165                      &                                                 2.*ABS( zwy  (ji,jj  ,jk) ) ) 
    166                END DO 
    167            END DO 
    168          END DO 
    169          ! 
    170          DO jk = 1, jpkm1                 !-- MUSCL horizontal advective fluxes 
    171             DO jj = 2, jpjm1 
    172                DO ji = fs_2, fs_jpim1   ! vector opt. 
    173                   ! MUSCL fluxes 
    174                   z0u = SIGN( 0.5, pun(ji,jj,jk) ) 
    175                   zalpha = 0.5 - z0u 
    176                   zu  = z0u - 0.5 * pun(ji,jj,jk) * p2dt * r1_e1e2u(ji,jj) / e3u_n(ji,jj,jk) 
    177                   zzwx = ptb(ji+1,jj,jk,jn) + xind(ji,jj,jk) * zu * zslpx(ji+1,jj,jk) 
    178                   zzwy = ptb(ji  ,jj,jk,jn) + xind(ji,jj,jk) * zu * zslpx(ji  ,jj,jk) 
    179                   zwx(ji,jj,jk) = pun(ji,jj,jk) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) 
    180                   ! 
    181                   z0v = SIGN( 0.5, pvn(ji,jj,jk) ) 
    182                   zalpha = 0.5 - z0v 
    183                   zv  = z0v - 0.5 * pvn(ji,jj,jk) * p2dt * r1_e1e2v(ji,jj) / e3v_n(ji,jj,jk) 
    184                   zzwx = ptb(ji,jj+1,jk,jn) + xind(ji,jj,jk) * zv * zslpy(ji,jj+1,jk) 
    185                   zzwy = ptb(ji,jj  ,jk,jn) + xind(ji,jj,jk) * zv * zslpy(ji,jj  ,jk) 
    186                   zwy(ji,jj,jk) = pvn(ji,jj,jk) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) 
    187                END DO 
    188             END DO 
    189          END DO 
     142         DO_3D_01_01( 1, jpkm1 ) 
     143            zslpx(ji,jj,jk) =                    ( zwx(ji,jj,jk) + zwx(ji-1,jj  ,jk) )   & 
     144               &            * ( 0.25 + SIGN( 0.25, zwx(ji,jj,jk) * zwx(ji-1,jj  ,jk) ) ) 
     145            zslpy(ji,jj,jk) =                    ( zwy(ji,jj,jk) + zwy(ji  ,jj-1,jk) )   & 
     146               &            * ( 0.25 + SIGN( 0.25, zwy(ji,jj,jk) * zwy(ji  ,jj-1,jk) ) ) 
     147         END_3D 
     148         ! 
     149         DO_3D_01_01( 1, jpkm1 ) 
     150            zslpx(ji,jj,jk) = SIGN( 1., zslpx(ji,jj,jk) ) * MIN(    ABS( zslpx(ji  ,jj,jk) ),   & 
     151               &                                                 2.*ABS( zwx  (ji-1,jj,jk) ),   & 
     152               &                                                 2.*ABS( zwx  (ji  ,jj,jk) ) ) 
     153            zslpy(ji,jj,jk) = SIGN( 1., zslpy(ji,jj,jk) ) * MIN(    ABS( zslpy(ji,jj  ,jk) ),   & 
     154               &                                                 2.*ABS( zwy  (ji,jj-1,jk) ),   & 
     155               &                                                 2.*ABS( zwy  (ji,jj  ,jk) ) ) 
     156         END_3D 
     157         ! 
     158         DO_3D_00_00( 1, jpkm1 ) 
     159            ! MUSCL fluxes 
     160            z0u = SIGN( 0.5, pU(ji,jj,jk) ) 
     161            zalpha = 0.5 - z0u 
     162            zu  = z0u - 0.5 * pU(ji,jj,jk) * p2dt * r1_e1e2u(ji,jj) / e3u(ji,jj,jk,Kmm) 
     163            zzwx = pt(ji+1,jj,jk,jn,Kbb) + xind(ji,jj,jk) * zu * zslpx(ji+1,jj,jk) 
     164            zzwy = pt(ji  ,jj,jk,jn,Kbb) + xind(ji,jj,jk) * zu * zslpx(ji  ,jj,jk) 
     165            zwx(ji,jj,jk) = pU(ji,jj,jk) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) 
     166            ! 
     167            z0v = SIGN( 0.5, pV(ji,jj,jk) ) 
     168            zalpha = 0.5 - z0v 
     169            zv  = z0v - 0.5 * pV(ji,jj,jk) * p2dt * r1_e1e2v(ji,jj) / e3v(ji,jj,jk,Kmm) 
     170            zzwx = pt(ji,jj+1,jk,jn,Kbb) + xind(ji,jj,jk) * zv * zslpy(ji,jj+1,jk) 
     171            zzwy = pt(ji,jj  ,jk,jn,Kbb) + xind(ji,jj,jk) * zv * zslpy(ji,jj  ,jk) 
     172            zwy(ji,jj,jk) = pV(ji,jj,jk) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) 
     173         END_3D 
    190174         CALL lbc_lnk_multi( 'traadv_mus', zwx, 'U', -1. , zwy, 'V', -1. )   ! lateral boundary conditions   (changed sign) 
    191175         ! 
    192          DO jk = 1, jpkm1                 !-- Tracer advective trend 
    193             DO jj = 2, jpjm1       
    194                DO ji = fs_2, fs_jpim1   ! vector opt. 
    195                   pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) - ( zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk  )       & 
    196                   &                                     + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk  ) )     & 
    197                   &                                   * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) 
    198                END DO 
    199            END DO 
    200          END DO         
     176         DO_3D_00_00( 1, jpkm1 ) 
     177            pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk  )       & 
     178            &                                     + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk  ) )     & 
     179            &                                   * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
     180         END_3D 
    201181         !                                ! trend diagnostics 
    202182         IF( l_trd )  THEN 
    203             CALL trd_tra( kt, cdtype, jn, jptra_xad, zwx, pun, ptb(:,:,:,jn) ) 
    204             CALL trd_tra( kt, cdtype, jn, jptra_yad, zwy, pvn, ptb(:,:,:,jn) ) 
     183            CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_xad, zwx, pU, pt(:,:,:,jn,Kbb) ) 
     184            CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_yad, zwy, pV, pt(:,:,:,jn,Kbb) ) 
    205185         END IF 
    206186         !                                 ! "Poleward" heat and salt transports  
    … …  
    215195         zwx(:,:,jpk) = 0._wp 
    216196         DO jk = 2, jpkm1                       ! interior values 
    217             zwx(:,:,jk) = tmask(:,:,jk) * ( ptb(:,:,jk-1,jn) - ptb(:,:,jk,jn) ) 
     197            zwx(:,:,jk) = tmask(:,:,jk) * ( pt(:,:,jk-1,jn,Kbb) - pt(:,:,jk,jn,Kbb) ) 
    218198         END DO 
    219199         !                                !-- Slopes of tracer 
    220200         zslpx(:,:,1) = 0._wp                   ! surface values 
    221          DO jk = 2, jpkm1                       ! interior value 
    222             DO jj = 1, jpj 
    223                DO ji = 1, jpi 
    224                   zslpx(ji,jj,jk) =                     ( zwx(ji,jj,jk) + zwx(ji,jj,jk+1) )  & 
    225                      &            * (  0.25 + SIGN( 0.25, zwx(ji,jj,jk) * zwx(ji,jj,jk+1) )  ) 
    226                END DO 
    227             END DO 
    228          END DO 
    229          DO jk = 2, jpkm1                 !-- Slopes limitation 
    230             DO jj = 1, jpj                      ! interior values 
    231                DO ji = 1, jpi 
    232                   zslpx(ji,jj,jk) = SIGN( 1., zslpx(ji,jj,jk) ) * MIN(    ABS( zslpx(ji,jj,jk  ) ),   & 
    233                      &                                                 2.*ABS( zwx  (ji,jj,jk+1) ),   & 
    234                      &                                                 2.*ABS( zwx  (ji,jj,jk  ) )  ) 
    235                END DO 
    236             END DO 
    237          END DO 
    238          DO jk = 1, jpk-2                 !-- vertical advective flux 
    239             DO jj = 2, jpjm1       
    240                DO ji = fs_2, fs_jpim1   ! vector opt. 
    241                   z0w = SIGN( 0.5, pwn(ji,jj,jk+1) ) 
    242                   zalpha = 0.5 + z0w 
    243                   zw  = z0w - 0.5 * pwn(ji,jj,jk+1) * p2dt * r1_e1e2t(ji,jj) / e3w_n(ji,jj,jk+1) 
    244                   zzwx = ptb(ji,jj,jk+1,jn) + xind(ji,jj,jk) * zw * zslpx(ji,jj,jk+1) 
    245                   zzwy = ptb(ji,jj,jk  ,jn) + xind(ji,jj,jk) * zw * zslpx(ji,jj,jk  ) 
    246                   zwx(ji,jj,jk+1) = pwn(ji,jj,jk+1) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) * wmask(ji,jj,jk) 
    247                END DO  
    248             END DO 
    249          END DO 
     201         DO_3D_11_11( 2, jpkm1 ) 
     202            zslpx(ji,jj,jk) =                     ( zwx(ji,jj,jk) + zwx(ji,jj,jk+1) )  & 
     203               &            * (  0.25 + SIGN( 0.25, zwx(ji,jj,jk) * zwx(ji,jj,jk+1) )  ) 
     204         END_3D 
     205         DO_3D_11_11( 2, jpkm1 ) 
     206            zslpx(ji,jj,jk) = SIGN( 1., zslpx(ji,jj,jk) ) * MIN(    ABS( zslpx(ji,jj,jk  ) ),   & 
     207               &                                                 2.*ABS( zwx  (ji,jj,jk+1) ),   & 
     208               &                                                 2.*ABS( zwx  (ji,jj,jk  ) )  ) 
     209         END_3D 
     210         DO_3D_00_00( 1, jpk-2 ) 
     211            z0w = SIGN( 0.5, pW(ji,jj,jk+1) ) 
     212            zalpha = 0.5 + z0w 
     213            zw  = z0w - 0.5 * pW(ji,jj,jk+1) * p2dt * r1_e1e2t(ji,jj) / e3w(ji,jj,jk+1,Kmm) 
     214            zzwx = pt(ji,jj,jk+1,jn,Kbb) + xind(ji,jj,jk) * zw * zslpx(ji,jj,jk+1) 
     215            zzwy = pt(ji,jj,jk  ,jn,Kbb) + xind(ji,jj,jk) * zw * zslpx(ji,jj,jk  ) 
     216            zwx(ji,jj,jk+1) = pW(ji,jj,jk+1) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) * wmask(ji,jj,jk) 
     217         END_3D 
    250218         IF( ln_linssh ) THEN                   ! top values, linear free surface only 
    251219            IF( ln_isfcav ) THEN                      ! ice-shelf cavities (top of the ocean) 
    252                DO jj = 1, jpj 
    253                   DO ji = 1, jpi 
    254                      zwx(ji,jj, mikt(ji,jj) ) = pwn(ji,jj,mikt(ji,jj)) * ptb(ji,jj,mikt(ji,jj),jn) 
    255                   END DO 
    256                END DO    
     220               DO_2D_11_11 
     221                  zwx(ji,jj, mikt(ji,jj) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kbb) 
     222               END_2D 
    257223            ELSE                                      ! no cavities: only at the ocean surface 
    258                zwx(:,:,1) = pwn(:,:,1) * ptb(:,:,1,jn) 
     224               zwx(:,:,1) = pW(:,:,1) * pt(:,:,1,jn,Kbb) 
    259225            ENDIF 
    260226         ENDIF 
    261227         ! 
    262          DO jk = 1, jpkm1                 !-- vertical advective trend 
    263             DO jj = 2, jpjm1       
    264                DO ji = fs_2, fs_jpim1   ! vector opt. 
    265                   pta(ji,jj,jk,jn) =  pta(ji,jj,jk,jn) - ( zwx(ji,jj,jk) - zwx(ji,jj,jk+1) ) * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) 
    266                END DO 
    267             END DO 
    268          END DO 
     228         DO_3D_00_00( 1, jpkm1 ) 
     229            pt(ji,jj,jk,jn,Krhs) =  pt(ji,jj,jk,jn,Krhs) - ( zwx(ji,jj,jk) - zwx(ji,jj,jk+1) ) * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
     230         END_3D 
    269231         !                                ! send trends for diagnostic 
    270          IF( l_trd )  CALL trd_tra( kt, cdtype, jn, jptra_zad, zwx, pwn, ptb(:,:,:,jn) ) 
     232         IF( l_trd )  CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_zad, zwx, pW, pt(:,:,:,jn,Kbb) ) 
    271233         ! 
    272234      END DO                     ! end of tracer loop 

  • NEMO/trunk/src/OCE/TRA/traadv_qck.F90

    r11993 r12377  
    2121   USE trdtra          ! trends manager: tracers  
    2222   USE diaptr          ! poleward transport diagnostics 
     23   USE iom 
    2324   ! 
    2425   USE in_out_manager  ! I/O manager 
    … …  
    3940 
    4041   !! * Substitutions 
    41 #  include "vectopt_loop_substitute.h90" 
     42#  include "do_loop_substitute.h90" 
    4243   !!---------------------------------------------------------------------- 
    4344   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    4748CONTAINS 
    4849 
    49    SUBROUTINE tra_adv_qck ( kt, kit000, cdtype, p2dt, pun, pvn, pwn,      & 
    50       &                                       ptb, ptn, pta, kjpt ) 
     50   SUBROUTINE tra_adv_qck ( kt, kit000, cdtype, p2dt, pU, pV, pW, Kbb, Kmm, pt, kjpt, Krhs ) 
    5151      !!---------------------------------------------------------------------- 
    5252      !!                  ***  ROUTINE tra_adv_qck  *** 
    … …  
    7272      !!         dt = 2*rdtra and the scalar values are tb and sb 
    7373      !! 
    74       !!       On the vertical, the simple centered scheme used ptn 
     74      !!       On the vertical, the simple centered scheme used pt(:,:,:,:,Kmm) 
    7575      !! 
    7676      !!               The fluxes are bounded by the ULTIMATE limiter to 
    … …  
    7878      !!            prevent the appearance of spurious numerical oscillations 
    7979      !! 
    80       !! ** Action : - update pta  with the now advective tracer trends 
     80      !! ** Action : - update pt(:,:,:,:,Krhs)  with the now advective tracer trends 
    8181      !!             - send trends to trdtra module for further diagnostcs (l_trdtra=T) 
    82       !!             - htr_adv, str_adv : poleward advective heat and salt transport (ln_diaptr=T) 
     82      !!             - poleward advective heat and salt transport (ln_diaptr=T) 
    8383      !! 
    8484      !! ** Reference : Leonard (1979, 1991) 
    8585      !!---------------------------------------------------------------------- 
    86       INTEGER                              , INTENT(in   ) ::   kt              ! ocean time-step index 
    87       INTEGER                              , INTENT(in   ) ::   kit000          ! first time step index 
    88       CHARACTER(len=3)                     , INTENT(in   ) ::   cdtype          ! =TRA or TRC (tracer indicator) 
    89       INTEGER                              , INTENT(in   ) ::   kjpt            ! number of tracers 
    90       REAL(wp)                             , INTENT(in   ) ::   p2dt            ! tracer time-step 
    91       REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ) ::   pun, pvn, pwn   ! 3 ocean velocity components 
    92       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb, ptn        ! before and now tracer fields 
    93       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta             ! tracer trend  
     86      INTEGER                                  , INTENT(in   ) ::   kt              ! ocean time-step index 
     87      INTEGER                                  , INTENT(in   ) ::   Kbb, Kmm, Krhs  ! ocean time level indices 
     88      INTEGER                                  , INTENT(in   ) ::   kit000          ! first time step index 
     89      CHARACTER(len=3)                         , INTENT(in   ) ::   cdtype          ! =TRA or TRC (tracer indicator) 
     90      INTEGER                                  , INTENT(in   ) ::   kjpt            ! number of tracers 
     91      REAL(wp)                                 , INTENT(in   ) ::   p2dt            ! tracer time-step 
     92      REAL(wp), DIMENSION(jpi,jpj,jpk         ), INTENT(in   ) ::   pU, pV, pW      ! 3 ocean volume transport components 
     93      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) ::   pt              ! tracers and RHS of tracer equation 
    9494      !!---------------------------------------------------------------------- 
    9595      ! 
    … …  
    103103      l_trd = .FALSE. 
    104104      l_ptr = .FALSE. 
    105       IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) )      l_trd = .TRUE. 
    106       IF(   cdtype == 'TRA' .AND. ln_diaptr )                                              l_ptr = .TRUE.  
     105      IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) )   l_trd = .TRUE. 
     106      IF(   cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) ) ) l_ptr = .TRUE.  
    107107      ! 
    108108      ! 
    109109      !        ! horizontal fluxes are computed with the QUICKEST + ULTIMATE scheme 
    110       CALL tra_adv_qck_i( kt, cdtype, p2dt, pun, ptb, ptn, pta, kjpt )  
    111       CALL tra_adv_qck_j( kt, cdtype, p2dt, pvn, ptb, ptn, pta, kjpt )  
     110      CALL tra_adv_qck_i( kt, cdtype, p2dt, pU, Kbb, Kmm, pt, kjpt, Krhs )  
     111      CALL tra_adv_qck_j( kt, cdtype, p2dt, pV, Kbb, Kmm, pt, kjpt, Krhs )  
    112112 
    113113      !        ! vertical fluxes are computed with the 2nd order centered scheme 
    114       CALL tra_adv_cen2_k( kt, cdtype, pwn,         ptn, pta, kjpt ) 
     114      CALL tra_adv_cen2_k( kt, cdtype, pW, Kmm, pt, kjpt, Krhs ) 
    115115      ! 
    116116   END SUBROUTINE tra_adv_qck 
    117117 
    118118 
    119    SUBROUTINE tra_adv_qck_i( kt, cdtype, p2dt, pun,                  & 
    120       &                                        ptb, ptn, pta, kjpt   ) 
    121       !!---------------------------------------------------------------------- 
    122       !! 
    123       !!---------------------------------------------------------------------- 
    124       INTEGER                              , INTENT(in   ) ::   kt         ! ocean time-step index 
    125       CHARACTER(len=3)                     , INTENT(in   ) ::   cdtype     ! =TRA or TRC (tracer indicator) 
    126       INTEGER                              , INTENT(in   ) ::   kjpt       ! number of tracers 
    127       REAL(wp)                             , INTENT(in   ) ::   p2dt       ! tracer time-step 
    128       REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ) ::   pun        ! i-velocity components 
    129       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb, ptn   ! before and now tracer fields 
    130       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta        ! tracer trend  
     119   SUBROUTINE tra_adv_qck_i( kt, cdtype, p2dt, pU, Kbb, Kmm, pt, kjpt, Krhs ) 
     120      !!---------------------------------------------------------------------- 
     121      !! 
     122      !!---------------------------------------------------------------------- 
     123      INTEGER                                  , INTENT(in   ) ::   kt         ! ocean time-step index 
     124      INTEGER                                  , INTENT(in   ) ::   Kbb, Kmm, Krhs  ! ocean time level indices 
     125      CHARACTER(len=3)                         , INTENT(in   ) ::   cdtype     ! =TRA or TRC (tracer indicator) 
     126      INTEGER                                  , INTENT(in   ) ::   kjpt       ! number of tracers 
     127      REAL(wp)                                 , INTENT(in   ) ::   p2dt       ! tracer time-step 
     128      REAL(wp), DIMENSION(jpi,jpj,jpk         ), INTENT(in   ) ::   pU        ! i-velocity components 
     129      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) ::   pt              ! active tracers and RHS of tracer equation 
    131130      !! 
    132131      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
    … …  
    142141         ! 
    143142!!gm why not using a SHIFT instruction... 
    144          DO jk = 1, jpkm1     !--- Computation of the ustream and downstream value of the tracer and the mask 
    145             DO jj = 2, jpjm1 
    146                DO ji = fs_2, fs_jpim1   ! vector opt. 
    147                   zfc(ji,jj,jk) = ptb(ji-1,jj,jk,jn)        ! Upstream   in the x-direction for the tracer 
    148                   zfd(ji,jj,jk) = ptb(ji+1,jj,jk,jn)        ! Downstream in the x-direction for the tracer 
    149                END DO 
    150             END DO 
    151          END DO 
     143         DO_3D_00_00( 1, jpkm1 ) 
     144            zfc(ji,jj,jk) = pt(ji-1,jj,jk,jn,Kbb)        ! Upstream   in the x-direction for the tracer 
     145            zfd(ji,jj,jk) = pt(ji+1,jj,jk,jn,Kbb)        ! Downstream in the x-direction for the tracer 
     146         END_3D 
    152147         CALL lbc_lnk_multi( 'traadv_qck', zfc(:,:,:), 'T', 1. , zfd(:,:,:), 'T', 1. )   ! Lateral boundary conditions  
    153148          
    … …  
    155150         ! Horizontal advective fluxes 
    156151         ! --------------------------- 
    157          DO jk = 1, jpkm1                              
    158             DO jj = 2, jpjm1 
    159                DO ji = fs_2, fs_jpim1   ! vector opt.          
    160                   zdir = 0.5 + SIGN( 0.5, pun(ji,jj,jk) )   ! if pun > 0 : zdir = 1 otherwise zdir = 0  
    161                   zfu(ji,jj,jk) = zdir * zfc(ji,jj,jk ) + ( 1. - zdir ) * zfd(ji+1,jj,jk)  ! FU in the x-direction for T  
    162                END DO 
    163             END DO 
    164          END DO 
    165          ! 
    166          DO jk = 1, jpkm1   
    167             DO jj = 2, jpjm1 
    168                DO ji = fs_2, fs_jpim1   ! vector opt.    
    169                   zdir = 0.5 + SIGN( 0.5, pun(ji,jj,jk) )   ! if pun > 0 : zdir = 1 otherwise zdir = 0  
    170                   zdx = ( zdir * e1t(ji,jj) + ( 1. - zdir ) * e1t(ji+1,jj) ) * e2u(ji,jj) * e3u_n(ji,jj,jk) 
    171                   zwx(ji,jj,jk)  = ABS( pun(ji,jj,jk) ) * p2dt / zdx    ! (0<zc_cfl<1 : Courant number on x-direction) 
    172                   zfc(ji,jj,jk)  = zdir * ptb(ji  ,jj,jk,jn) + ( 1. - zdir ) * ptb(ji+1,jj,jk,jn)  ! FC in the x-direction for T 
    173                   zfd(ji,jj,jk)  = zdir * ptb(ji+1,jj,jk,jn) + ( 1. - zdir ) * ptb(ji  ,jj,jk,jn)  ! FD in the x-direction for T 
    174                END DO 
    175             END DO 
    176          END DO  
     152         DO_3D_00_00( 1, jpkm1 ) 
     153            zdir = 0.5 + SIGN( 0.5, pU(ji,jj,jk) )   ! if pU > 0 : zdir = 1 otherwise zdir = 0  
     154            zfu(ji,jj,jk) = zdir * zfc(ji,jj,jk ) + ( 1. - zdir ) * zfd(ji+1,jj,jk)  ! FU in the x-direction for T  
     155         END_3D 
     156         ! 
     157         DO_3D_00_00( 1, jpkm1 ) 
     158            zdir = 0.5 + SIGN( 0.5, pU(ji,jj,jk) )   ! if pU > 0 : zdir = 1 otherwise zdir = 0  
     159            zdx = ( zdir * e1t(ji,jj) + ( 1. - zdir ) * e1t(ji+1,jj) ) * e2u(ji,jj) * e3u(ji,jj,jk,Kmm) 
     160            zwx(ji,jj,jk)  = ABS( pU(ji,jj,jk) ) * p2dt / zdx    ! (0<zc_cfl<1 : Courant number on x-direction) 
     161            zfc(ji,jj,jk)  = zdir * pt(ji  ,jj,jk,jn,Kbb) + ( 1. - zdir ) * pt(ji+1,jj,jk,jn,Kbb)  ! FC in the x-direction for T 
     162            zfd(ji,jj,jk)  = zdir * pt(ji+1,jj,jk,jn,Kbb) + ( 1. - zdir ) * pt(ji  ,jj,jk,jn,Kbb)  ! FD in the x-direction for T 
     163         END_3D 
    177164         !--- Lateral boundary conditions  
    178165         CALL lbc_lnk_multi( 'traadv_qck', zfu(:,:,:), 'T', 1. , zfd(:,:,:), 'T', 1., zfc(:,:,:), 'T', 1.,  zwx(:,:,:), 'T', 1. ) 
    … …  
    182169         ! 
    183170         ! Mask at the T-points in the x-direction (mask=0 or mask=1) 
    184          DO jk = 1, jpkm1   
    185             DO jj = 2, jpjm1 
    186                DO ji = fs_2, fs_jpim1   ! vector opt.                
    187                   zfu(ji,jj,jk) = tmask(ji-1,jj,jk) + tmask(ji,jj,jk) + tmask(ji+1,jj,jk) - 2. 
    188                END DO 
    189             END DO 
    190          END DO 
     171         DO_3D_00_00( 1, jpkm1 ) 
     172            zfu(ji,jj,jk) = tmask(ji-1,jj,jk) + tmask(ji,jj,jk) + tmask(ji+1,jj,jk) - 2. 
     173         END_3D 
    191174         CALL lbc_lnk( 'traadv_qck', zfu(:,:,:), 'T', 1. )      ! Lateral boundary conditions  
    192175 
    … …  
    195178         DO jk = 1, jpkm1   
    196179            ! 
    197             DO jj = 2, jpjm1 
    198                DO ji = fs_2, fs_jpim1   ! vector opt.                
    199                   zdir = 0.5 + SIGN( 0.5, pun(ji,jj,jk) )   ! if pun > 0 : zdir = 1 otherwise zdir = 0  
    200                   !--- If the second ustream point is a land point 
    201                   !--- the flux is computed by the 1st order UPWIND scheme 
    202                   zmsk = zdir * zfu(ji,jj,jk) + ( 1. - zdir ) * zfu(ji+1,jj,jk) 
    203                   zwx(ji,jj,jk) = zmsk * zwx(ji,jj,jk) + ( 1. - zmsk ) * zfc(ji,jj,jk) 
    204                   zwx(ji,jj,jk) = zwx(ji,jj,jk) * pun(ji,jj,jk) 
    205                END DO 
    206             END DO 
     180            DO_2D_00_00 
     181               zdir = 0.5 + SIGN( 0.5, pU(ji,jj,jk) )   ! if pU > 0 : zdir = 1 otherwise zdir = 0  
     182               !--- If the second ustream point is a land point 
     183               !--- the flux is computed by the 1st order UPWIND scheme 
     184               zmsk = zdir * zfu(ji,jj,jk) + ( 1. - zdir ) * zfu(ji+1,jj,jk) 
     185               zwx(ji,jj,jk) = zmsk * zwx(ji,jj,jk) + ( 1. - zmsk ) * zfc(ji,jj,jk) 
     186               zwx(ji,jj,jk) = zwx(ji,jj,jk) * pU(ji,jj,jk) 
     187            END_2D 
    207188         END DO 
    208189         ! 
    … …  
    210191         ! 
    211192         ! Computation of the trend 
    212          DO jk = 1, jpkm1   
    213             DO jj = 2, jpjm1 
    214                DO ji = fs_2, fs_jpim1   ! vector opt.   
    215                   zbtr = r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) 
    216                   ! horizontal advective trends 
    217                   ztra = - zbtr * ( zwx(ji,jj,jk) - zwx(ji-1,jj,jk) ) 
    218                   !--- add it to the general tracer trends 
    219                   pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + ztra 
    220                END DO 
    221             END DO 
    222          END DO 
     193         DO_3D_00_00( 1, jpkm1 ) 
     194            zbtr = r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
     195            ! horizontal advective trends 
     196            ztra = - zbtr * ( zwx(ji,jj,jk) - zwx(ji-1,jj,jk) ) 
     197            !--- add it to the general tracer trends 
     198            pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) + ztra 
     199         END_3D 
    223200         !                                 ! trend diagnostics 
    224          IF( l_trd )   CALL trd_tra( kt, cdtype, jn, jptra_xad, zwx, pun, ptn(:,:,:,jn) ) 
     201         IF( l_trd )   CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_xad, zwx, pU, pt(:,:,:,jn,Kmm) ) 
    225202         ! 
    226203      END DO 
    … …  
    229206 
    230207 
    231    SUBROUTINE tra_adv_qck_j( kt, cdtype, p2dt, pvn,                & 
    232       &                                        ptb, ptn, pta, kjpt ) 
    233       !!---------------------------------------------------------------------- 
    234       !! 
    235       !!---------------------------------------------------------------------- 
    236       INTEGER                              , INTENT(in   ) ::   kt         ! ocean time-step index 
    237       CHARACTER(len=3)                     , INTENT(in   ) ::   cdtype     ! =TRA or TRC (tracer indicator) 
    238       INTEGER                              , INTENT(in   ) ::   kjpt       ! number of tracers 
    239       REAL(wp)                             , INTENT(in   ) ::   p2dt       ! tracer time-step 
    240       REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ) ::   pvn        ! j-velocity components 
    241       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb, ptn   ! before and now tracer fields 
    242       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta        ! tracer trend  
     208   SUBROUTINE tra_adv_qck_j( kt, cdtype, p2dt, pV, Kbb, Kmm, pt, kjpt, Krhs ) 
     209      !!---------------------------------------------------------------------- 
     210      !! 
     211      !!---------------------------------------------------------------------- 
     212      INTEGER                                  , INTENT(in   ) ::   kt         ! ocean time-step index 
     213      INTEGER                                  , INTENT(in   ) ::   Kbb, Kmm, Krhs  ! ocean time level indices 
     214      CHARACTER(len=3)                         , INTENT(in   ) ::   cdtype     ! =TRA or TRC (tracer indicator) 
     215      INTEGER                                  , INTENT(in   ) ::   kjpt       ! number of tracers 
     216      REAL(wp)                                 , INTENT(in   ) ::   p2dt       ! tracer time-step 
     217      REAL(wp), DIMENSION(jpi,jpj,jpk         ), INTENT(in   ) ::   pV        ! j-velocity components 
     218      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) ::   pt              ! active tracers and RHS of tracer equation 
    243219      !! 
    244220      INTEGER  :: ji, jj, jk, jn                ! dummy loop indices 
    … …  
    256232            !                                              
    257233            !--- Computation of the ustream and downstream value of the tracer and the mask 
    258             DO jj = 2, jpjm1 
    259                DO ji = fs_2, fs_jpim1   ! vector opt. 
    260                   ! Upstream in the x-direction for the tracer 
    261                   zfc(ji,jj,jk) = ptb(ji,jj-1,jk,jn) 
    262                   ! Downstream in the x-direction for the tracer 
    263                   zfd(ji,jj,jk) = ptb(ji,jj+1,jk,jn) 
    264                END DO 
    265             END DO 
     234            DO_2D_00_00 
     235               ! Upstream in the x-direction for the tracer 
     236               zfc(ji,jj,jk) = pt(ji,jj-1,jk,jn,Kbb) 
     237               ! Downstream in the x-direction for the tracer 
     238               zfd(ji,jj,jk) = pt(ji,jj+1,jk,jn,Kbb) 
     239            END_2D 
    266240         END DO 
    267241         CALL lbc_lnk_multi( 'traadv_qck', zfc(:,:,:), 'T', 1. , zfd(:,:,:), 'T', 1. )   ! Lateral boundary conditions  
    … …  
    272246         ! --------------------------- 
    273247         ! 
    274          DO jk = 1, jpkm1                              
    275             DO jj = 2, jpjm1 
    276                DO ji = fs_2, fs_jpim1   ! vector opt.          
    277                   zdir = 0.5 + SIGN( 0.5, pvn(ji,jj,jk) )   ! if pun > 0 : zdir = 1 otherwise zdir = 0  
    278                   zfu(ji,jj,jk) = zdir * zfc(ji,jj,jk ) + ( 1. - zdir ) * zfd(ji,jj+1,jk)  ! FU in the x-direction for T  
    279                END DO 
    280             END DO 
    281          END DO 
    282          ! 
    283          DO jk = 1, jpkm1   
    284             DO jj = 2, jpjm1 
    285                DO ji = fs_2, fs_jpim1   ! vector opt.    
    286                   zdir = 0.5 + SIGN( 0.5, pvn(ji,jj,jk) )   ! if pun > 0 : zdir = 1 otherwise zdir = 0  
    287                   zdx = ( zdir * e2t(ji,jj) + ( 1. - zdir ) * e2t(ji,jj+1) ) * e1v(ji,jj) * e3v_n(ji,jj,jk) 
    288                   zwy(ji,jj,jk)  = ABS( pvn(ji,jj,jk) ) * p2dt / zdx    ! (0<zc_cfl<1 : Courant number on x-direction) 
    289                   zfc(ji,jj,jk)  = zdir * ptb(ji,jj  ,jk,jn) + ( 1. - zdir ) * ptb(ji,jj+1,jk,jn)  ! FC in the x-direction for T 
    290                   zfd(ji,jj,jk)  = zdir * ptb(ji,jj+1,jk,jn) + ( 1. - zdir ) * ptb(ji,jj  ,jk,jn)  ! FD in the x-direction for T 
    291                END DO 
    292             END DO 
    293          END DO 
     248         DO_3D_00_00( 1, jpkm1 ) 
     249            zdir = 0.5 + SIGN( 0.5, pV(ji,jj,jk) )   ! if pU > 0 : zdir = 1 otherwise zdir = 0  
     250            zfu(ji,jj,jk) = zdir * zfc(ji,jj,jk ) + ( 1. - zdir ) * zfd(ji,jj+1,jk)  ! FU in the x-direction for T  
     251         END_3D 
     252         ! 
     253         DO_3D_00_00( 1, jpkm1 ) 
     254            zdir = 0.5 + SIGN( 0.5, pV(ji,jj,jk) )   ! if pU > 0 : zdir = 1 otherwise zdir = 0  
     255            zdx = ( zdir * e2t(ji,jj) + ( 1. - zdir ) * e2t(ji,jj+1) ) * e1v(ji,jj) * e3v(ji,jj,jk,Kmm) 
     256            zwy(ji,jj,jk)  = ABS( pV(ji,jj,jk) ) * p2dt / zdx    ! (0<zc_cfl<1 : Courant number on x-direction) 
     257            zfc(ji,jj,jk)  = zdir * pt(ji,jj  ,jk,jn,Kbb) + ( 1. - zdir ) * pt(ji,jj+1,jk,jn,Kbb)  ! FC in the x-direction for T 
     258            zfd(ji,jj,jk)  = zdir * pt(ji,jj+1,jk,jn,Kbb) + ( 1. - zdir ) * pt(ji,jj  ,jk,jn,Kbb)  ! FD in the x-direction for T 
     259         END_3D 
    294260 
    295261         !--- Lateral boundary conditions  
    … …  
    300266         ! 
    301267         ! Mask at the T-points in the x-direction (mask=0 or mask=1) 
    302          DO jk = 1, jpkm1   
    303             DO jj = 2, jpjm1 
    304                DO ji = fs_2, fs_jpim1   ! vector opt.                
    305                   zfu(ji,jj,jk) = tmask(ji,jj-1,jk) + tmask(ji,jj,jk) + tmask(ji,jj+1,jk) - 2. 
    306                END DO 
    307             END DO 
    308          END DO 
     268         DO_3D_00_00( 1, jpkm1 ) 
     269            zfu(ji,jj,jk) = tmask(ji,jj-1,jk) + tmask(ji,jj,jk) + tmask(ji,jj+1,jk) - 2. 
     270         END_3D 
    309271         CALL lbc_lnk( 'traadv_qck', zfu(:,:,:), 'T', 1. )    !--- Lateral boundary conditions  
    310272         ! 
    … …  
    312274         DO jk = 1, jpkm1   
    313275            ! 
    314             DO jj = 2, jpjm1 
    315                DO ji = fs_2, fs_jpim1   ! vector opt.                
    316                   zdir = 0.5 + SIGN( 0.5, pvn(ji,jj,jk) )   ! if pun > 0 : zdir = 1 otherwise zdir = 0  
    317                   !--- If the second ustream point is a land point 
    318                   !--- the flux is computed by the 1st order UPWIND scheme 
    319                   zmsk = zdir * zfu(ji,jj,jk) + ( 1. - zdir ) * zfu(ji,jj+1,jk) 
    320                   zwy(ji,jj,jk) = zmsk * zwy(ji,jj,jk) + ( 1. - zmsk ) * zfc(ji,jj,jk) 
    321                   zwy(ji,jj,jk) = zwy(ji,jj,jk) * pvn(ji,jj,jk) 
    322                END DO 
    323             END DO 
     276            DO_2D_00_00 
     277               zdir = 0.5 + SIGN( 0.5, pV(ji,jj,jk) )   ! if pU > 0 : zdir = 1 otherwise zdir = 0  
     278               !--- If the second ustream point is a land point 
     279               !--- the flux is computed by the 1st order UPWIND scheme 
     280               zmsk = zdir * zfu(ji,jj,jk) + ( 1. - zdir ) * zfu(ji,jj+1,jk) 
     281               zwy(ji,jj,jk) = zmsk * zwy(ji,jj,jk) + ( 1. - zmsk ) * zfc(ji,jj,jk) 
     282               zwy(ji,jj,jk) = zwy(ji,jj,jk) * pV(ji,jj,jk) 
     283            END_2D 
    324284         END DO 
    325285         ! 
    … …  
    327287         ! 
    328288         ! Computation of the trend 
    329          DO jk = 1, jpkm1   
    330             DO jj = 2, jpjm1 
    331                DO ji = fs_2, fs_jpim1   ! vector opt.   
    332                   zbtr = r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) 
    333                   ! horizontal advective trends 
    334                   ztra = - zbtr * ( zwy(ji,jj,jk) - zwy(ji,jj-1,jk) ) 
    335                   !--- add it to the general tracer trends 
    336                   pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + ztra 
    337                END DO 
    338             END DO 
    339          END DO 
     289         DO_3D_00_00( 1, jpkm1 ) 
     290            zbtr = r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
     291            ! horizontal advective trends 
     292            ztra = - zbtr * ( zwy(ji,jj,jk) - zwy(ji,jj-1,jk) ) 
     293            !--- add it to the general tracer trends 
     294            pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) + ztra 
     295         END_3D 
    340296         !                                 ! trend diagnostics 
    341          IF( l_trd )   CALL trd_tra( kt, cdtype, jn, jptra_yad, zwy, pvn, ptn(:,:,:,jn) ) 
     297         IF( l_trd )   CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_yad, zwy, pV, pt(:,:,:,jn,Kmm) ) 
    342298         !                                 ! "Poleward" heat and salt transports (contribution of upstream fluxes) 
    343299         IF( l_ptr )   CALL dia_ptr_hst( jn, 'adv', zwy(:,:,:) ) 
    … …  
    348304 
    349305 
    350    SUBROUTINE tra_adv_cen2_k( kt, cdtype, pwn,           & 
    351      &                                    ptn, pta, kjpt ) 
    352       !!---------------------------------------------------------------------- 
    353       !! 
    354       !!---------------------------------------------------------------------- 
    355       INTEGER                              , INTENT(in   ) ::   kt       ! ocean time-step index 
    356       CHARACTER(len=3)                     , INTENT(in   ) ::   cdtype   ! =TRA or TRC (tracer indicator) 
    357       INTEGER                              , INTENT(in   ) ::   kjpt     ! number of tracers 
    358       REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ) ::   pwn      ! vertical velocity  
    359       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptn      ! before and now tracer fields 
    360       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta      ! tracer trend  
     306   SUBROUTINE tra_adv_cen2_k( kt, cdtype, pW, Kmm, pt, kjpt, Krhs ) 
     307      !!---------------------------------------------------------------------- 
     308      !! 
     309      !!---------------------------------------------------------------------- 
     310      INTEGER                                  , INTENT(in   ) ::   kt       ! ocean time-step index 
     311      INTEGER                                  , INTENT(in   ) ::   Kmm, Krhs  ! ocean time level indices 
     312      CHARACTER(len=3)                         , INTENT(in   ) ::   cdtype   ! =TRA or TRC (tracer indicator) 
     313      INTEGER                                  , INTENT(in   ) ::   kjpt     ! number of tracers 
     314      REAL(wp), DIMENSION(jpi,jpj,jpk         ), INTENT(in   ) ::   pW      ! vertical velocity  
     315      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) ::   pt              ! active tracers and RHS of tracer equation 
    361316      ! 
    362317      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
    … …  
    371326         !                                                       ! =========== 
    372327         ! 
    373          DO jk = 2, jpkm1                    !* Interior point   (w-masked 2nd order centered flux) 
    374             DO jj = 2, jpjm1 
    375                DO ji = fs_2, fs_jpim1   ! vector opt. 
    376                   zwz(ji,jj,jk) = 0.5 * pwn(ji,jj,jk) * ( ptn(ji,jj,jk-1,jn) + ptn(ji,jj,jk,jn) ) * wmask(ji,jj,jk) 
    377                END DO 
    378             END DO 
    379          END DO 
     328         DO_3D_00_00( 2, jpkm1 ) 
     329            zwz(ji,jj,jk) = 0.5 * pW(ji,jj,jk) * ( pt(ji,jj,jk-1,jn,Kmm) + pt(ji,jj,jk,jn,Kmm) ) * wmask(ji,jj,jk) 
     330         END_3D 
    380331         IF( ln_linssh ) THEN                !* top value   (only in linear free surf. as zwz is multiplied by wmask) 
    381332            IF( ln_isfcav ) THEN                  ! ice-shelf cavities (top of the ocean) 
    382                DO jj = 1, jpj 
    383                   DO ji = 1, jpi 
    384                      zwz(ji,jj, mikt(ji,jj) ) = pwn(ji,jj,mikt(ji,jj)) * ptn(ji,jj,mikt(ji,jj),jn)   ! linear free surface  
    385                   END DO 
    386                END DO    
     333               DO_2D_11_11 
     334                  zwz(ji,jj, mikt(ji,jj) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kmm)   ! linear free surface  
     335               END_2D 
    387336            ELSE                                   ! no ocean cavities (only ocean surface) 
    388                zwz(:,:,1) = pwn(:,:,1) * ptn(:,:,1,jn) 
     337               zwz(:,:,1) = pW(:,:,1) * pt(:,:,1,jn,Kmm) 
    389338            ENDIF 
    390339         ENDIF 
    391340         ! 
    392          DO jk = 1, jpkm1          !==  Tracer flux divergence added to the general trend  ==! 
    393             DO jj = 2, jpjm1 
    394                DO ji = fs_2, fs_jpim1   ! vector opt. 
    395                   pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) - ( zwz(ji,jj,jk) - zwz(ji,jj,jk+1) )   & 
    396                      &                                * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) 
    397                END DO 
    398             END DO 
    399          END DO 
     341         DO_3D_00_00( 1, jpkm1 ) 
     342            pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( zwz(ji,jj,jk) - zwz(ji,jj,jk+1) )   & 
     343               &                                * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
     344         END_3D 
    400345         !                                 ! Send trends for diagnostic 
    401          IF( l_trd )  CALL trd_tra( kt, cdtype, jn, jptra_zad, zwz, pwn, ptn(:,:,:,jn) ) 
     346         IF( l_trd )  CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_zad, zwz, pW, pt(:,:,:,jn,Kmm) ) 
    402347         ! 
    403348      END DO 
    … …  
    423368      !---------------------------------------------------------------------- 
    424369      ! 
    425       DO jk = 1, jpkm1 
    426          DO jj = 1, jpj 
    427             DO ji = 1, jpi 
    428                zc     = puc(ji,jj,jk)                         ! Courant number 
    429                zcurv  = pfd(ji,jj,jk) + pfu(ji,jj,jk) - 2. * pfc(ji,jj,jk) 
    430                zcoef1 = 0.5 *      ( pfc(ji,jj,jk) + pfd(ji,jj,jk) ) 
    431                zcoef2 = 0.5 * zc * ( pfd(ji,jj,jk) - pfc(ji,jj,jk) ) 
    432                zcoef3 = ( 1. - ( zc * zc ) ) * r1_6 * zcurv 
    433                zfho   = zcoef1 - zcoef2 - zcoef3              !  phi_f QUICKEST  
    434                ! 
    435                zcoef1 = pfd(ji,jj,jk) - pfu(ji,jj,jk) 
    436                zcoef2 = ABS( zcoef1 ) 
    437                zcoef3 = ABS( zcurv ) 
    438                IF( zcoef3 >= zcoef2 ) THEN 
    439                   zfho = pfc(ji,jj,jk)  
    440                ELSE 
    441                   zcoef3 = pfu(ji,jj,jk) + ( ( pfc(ji,jj,jk) - pfu(ji,jj,jk) ) / MAX( zc, 1.e-9 ) )    ! phi_REF 
    442                   IF( zcoef1 >= 0. ) THEN 
    443                      zfho = MAX( pfc(ji,jj,jk), zfho )  
    444                      zfho = MIN( zfho, MIN( zcoef3, pfd(ji,jj,jk) ) )  
    445                   ELSE 
    446                      zfho = MIN( pfc(ji,jj,jk), zfho )  
    447                      zfho = MAX( zfho, MAX( zcoef3, pfd(ji,jj,jk) ) )  
    448                   ENDIF 
    449                ENDIF 
    450                puc(ji,jj,jk) = zfho 
    451             END DO 
    452          END DO 
    453       END DO 
     370      DO_3D_11_11( 1, jpkm1 ) 
     371         zc     = puc(ji,jj,jk)                         ! Courant number 
     372         zcurv  = pfd(ji,jj,jk) + pfu(ji,jj,jk) - 2. * pfc(ji,jj,jk) 
     373         zcoef1 = 0.5 *      ( pfc(ji,jj,jk) + pfd(ji,jj,jk) ) 
     374         zcoef2 = 0.5 * zc * ( pfd(ji,jj,jk) - pfc(ji,jj,jk) ) 
     375         zcoef3 = ( 1. - ( zc * zc ) ) * r1_6 * zcurv 
     376         zfho   = zcoef1 - zcoef2 - zcoef3              !  phi_f QUICKEST  
     377         ! 
     378         zcoef1 = pfd(ji,jj,jk) - pfu(ji,jj,jk) 
     379         zcoef2 = ABS( zcoef1 ) 
     380         zcoef3 = ABS( zcurv ) 
     381         IF( zcoef3 >= zcoef2 ) THEN 
     382            zfho = pfc(ji,jj,jk)  
     383         ELSE 
     384            zcoef3 = pfu(ji,jj,jk) + ( ( pfc(ji,jj,jk) - pfu(ji,jj,jk) ) / MAX( zc, 1.e-9 ) )    ! phi_REF 
     385            IF( zcoef1 >= 0. ) THEN 
     386               zfho = MAX( pfc(ji,jj,jk), zfho )  
     387               zfho = MIN( zfho, MIN( zcoef3, pfd(ji,jj,jk) ) )  
     388            ELSE 
     389               zfho = MIN( pfc(ji,jj,jk), zfho )  
     390               zfho = MAX( zfho, MAX( zcoef3, pfd(ji,jj,jk) ) )  
     391            ENDIF 
     392         ENDIF 
     393         puc(ji,jj,jk) = zfho 
     394      END_3D 
    454395      ! 
    455396   END SUBROUTINE quickest 

  • NEMO/trunk/src/OCE/TRA/traadv_ubs.F90

    r11993 r12377  
    3838 
    3939   !! * Substitutions 
    40 #  include "vectopt_loop_substitute.h90" 
     40#  include "do_loop_substitute.h90" 
    4141   !!---------------------------------------------------------------------- 
    4242   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    4646CONTAINS 
    4747 
    48    SUBROUTINE tra_adv_ubs( kt, kit000, cdtype, p2dt, pun, pvn, pwn,          & 
    49       &                                                ptb, ptn, pta, kjpt, kn_ubs_v ) 
     48   SUBROUTINE tra_adv_ubs( kt, kit000, cdtype, p2dt, pU, pV, pW,          & 
     49      &                    Kbb, Kmm, pt, kjpt, Krhs, kn_ubs_v ) 
    5050      !!---------------------------------------------------------------------- 
    5151      !!                  ***  ROUTINE tra_adv_ubs  *** 
    … …  
    7777      !!      scheme (kn_ubs_v=4). 
    7878      !! 
    79       !! ** Action : - update pta  with the now advective tracer trends 
     79      !! ** Action : - update pt(:,:,:,:,Krhs)  with the now advective tracer trends 
    8080      !!             - send trends to trdtra module for further diagnostcs (l_trdtra=T) 
    81       !!             - htr_adv, str_adv : poleward advective heat and salt transport (ln_diaptr=T) 
     81      !!             - poleward advective heat and salt transport (ln_diaptr=T) 
    8282      !! 
    8383      !! Reference : Shchepetkin, A. F., J. C. McWilliams, 2005, Ocean Modelling, 9, 347-404.  
    8484      !!             Farrow, D.E., Stevens, D.P., 1995, J. Phys. Ocean. 25, 1731Ð1741.  
    8585      !!---------------------------------------------------------------------- 
    86       INTEGER                              , INTENT(in   ) ::   kt              ! ocean time-step index 
    87       INTEGER                              , INTENT(in   ) ::   kit000          ! first time step index 
    88       CHARACTER(len=3)                     , INTENT(in   ) ::   cdtype          ! =TRA or TRC (tracer indicator) 
    89       INTEGER                              , INTENT(in   ) ::   kjpt            ! number of tracers 
    90       INTEGER                              , INTENT(in   ) ::   kn_ubs_v        ! number of tracers 
    91       REAL(wp)                             , INTENT(in   ) ::   p2dt            ! tracer time-step 
    92       REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ) ::   pun, pvn, pwn   ! 3 ocean transport components 
    93       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb, ptn        ! before and now tracer fields 
    94       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta             ! tracer trend  
     86      INTEGER                                  , INTENT(in   ) ::   kt              ! ocean time-step index 
     87      INTEGER                                  , INTENT(in   ) ::   Kbb, Kmm, Krhs  ! ocean time level indices 
     88      INTEGER                                  , INTENT(in   ) ::   kit000          ! first time step index 
     89      CHARACTER(len=3)                         , INTENT(in   ) ::   cdtype          ! =TRA or TRC (tracer indicator) 
     90      INTEGER                                  , INTENT(in   ) ::   kjpt            ! number of tracers 
     91      INTEGER                                  , INTENT(in   ) ::   kn_ubs_v        ! number of tracers 
     92      REAL(wp)                                 , INTENT(in   ) ::   p2dt            ! tracer time-step 
     93      REAL(wp), DIMENSION(jpi,jpj,jpk         ), INTENT(in   ) ::   pU, pV, pW      ! 3 ocean volume transport components 
     94      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) ::   pt              ! tracers and RHS of tracer equation 
    9595      ! 
    9696      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
    … …  
    111111      l_ptr = .FALSE. 
    112112      IF( ( cdtype == 'TRA' .AND. l_trdtra ) .OR. ( cdtype == 'TRC' .AND. l_trdtrc ) )      l_trd = .TRUE. 
    113       IF(   cdtype == 'TRA' .AND. ln_diaptr )                                               l_ptr = .TRUE.  
     113      IF(   cdtype == 'TRA' .AND. ( iom_use( 'sophtadv' ) .OR. iom_use( 'sophtadv' ) )  )   l_ptr = .TRUE.  
    114114      IF(   cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & 
    115115         &                          iom_use("uadv_salttr") .OR. iom_use("vadv_salttr")  ) ) l_hst = .TRUE. 
    … …  
    124124         !                                               
    125125         DO jk = 1, jpkm1        !==  horizontal laplacian of before tracer ==! 
    126             DO jj = 1, jpjm1              ! First derivative (masked gradient) 
    127                DO ji = 1, fs_jpim1   ! vector opt. 
    128                   zeeu = e2_e1u(ji,jj) * e3u_n(ji,jj,jk) * umask(ji,jj,jk) 
    129                   zeev = e1_e2v(ji,jj) * e3v_n(ji,jj,jk) * vmask(ji,jj,jk) 
    130                   ztu(ji,jj,jk) = zeeu * ( ptb(ji+1,jj  ,jk,jn) - ptb(ji,jj,jk,jn) ) 
    131                   ztv(ji,jj,jk) = zeev * ( ptb(ji  ,jj+1,jk,jn) - ptb(ji,jj,jk,jn) ) 
    132                END DO 
    133             END DO 
    134             DO jj = 2, jpjm1              ! Second derivative (divergence) 
    135                DO ji = fs_2, fs_jpim1   ! vector opt. 
    136                   zcoef = 1._wp / ( 6._wp * e3t_n(ji,jj,jk) ) 
    137                   zltu(ji,jj,jk) = (  ztu(ji,jj,jk) - ztu(ji-1,jj,jk)  ) * zcoef 
    138                   zltv(ji,jj,jk) = (  ztv(ji,jj,jk) - ztv(ji,jj-1,jk)  ) * zcoef 
    139                END DO 
    140             END DO 
     126            DO_2D_10_10 
     127               zeeu = e2_e1u(ji,jj) * e3u(ji,jj,jk,Kmm) * umask(ji,jj,jk) 
     128               zeev = e1_e2v(ji,jj) * e3v(ji,jj,jk,Kmm) * vmask(ji,jj,jk) 
     129               ztu(ji,jj,jk) = zeeu * ( pt(ji+1,jj  ,jk,jn,Kbb) - pt(ji,jj,jk,jn,Kbb) ) 
     130               ztv(ji,jj,jk) = zeev * ( pt(ji  ,jj+1,jk,jn,Kbb) - pt(ji,jj,jk,jn,Kbb) ) 
     131            END_2D 
     132            DO_2D_00_00 
     133               zcoef = 1._wp / ( 6._wp * e3t(ji,jj,jk,Kmm) ) 
     134               zltu(ji,jj,jk) = (  ztu(ji,jj,jk) - ztu(ji-1,jj,jk)  ) * zcoef 
     135               zltv(ji,jj,jk) = (  ztv(ji,jj,jk) - ztv(ji,jj-1,jk)  ) * zcoef 
     136            END_2D 
    141137            !                                     
    142138         END DO          
    143139         CALL lbc_lnk( 'traadv_ubs', zltu, 'T', 1. )   ;    CALL lbc_lnk( 'traadv_ubs', zltv, 'T', 1. )   ! Lateral boundary cond. (unchanged sgn) 
    144140         !     
    145          DO jk = 1, jpkm1        !==  Horizontal advective fluxes  ==!     (UBS) 
    146             DO jj = 1, jpjm1 
    147                DO ji = 1, fs_jpim1   ! vector opt. 
    148                   zfp_ui = pun(ji,jj,jk) + ABS( pun(ji,jj,jk) )      ! upstream transport (x2) 
    149                   zfm_ui = pun(ji,jj,jk) - ABS( pun(ji,jj,jk) ) 
    150                   zfp_vj = pvn(ji,jj,jk) + ABS( pvn(ji,jj,jk) ) 
    151                   zfm_vj = pvn(ji,jj,jk) - ABS( pvn(ji,jj,jk) ) 
    152                   !                                                  ! 2nd order centered advective fluxes (x2) 
    153                   zcenut = pun(ji,jj,jk) * ( ptn(ji,jj,jk,jn) + ptn(ji+1,jj  ,jk,jn) ) 
    154                   zcenvt = pvn(ji,jj,jk) * ( ptn(ji,jj,jk,jn) + ptn(ji  ,jj+1,jk,jn) ) 
    155                   !                                                  ! UBS advective fluxes 
    156                   ztu(ji,jj,jk) = 0.5 * ( zcenut - zfp_ui * zltu(ji,jj,jk) - zfm_ui * zltu(ji+1,jj,jk) ) 
    157                   ztv(ji,jj,jk) = 0.5 * ( zcenvt - zfp_vj * zltv(ji,jj,jk) - zfm_vj * zltv(ji,jj+1,jk) ) 
    158                END DO 
    159             END DO 
    160          END DO          
    161          ! 
    162          zltu(:,:,:) = pta(:,:,:,jn)      ! store the initial trends before its update 
     141         DO_3D_10_10( 1, jpkm1 ) 
     142            zfp_ui = pU(ji,jj,jk) + ABS( pU(ji,jj,jk) )      ! upstream transport (x2) 
     143            zfm_ui = pU(ji,jj,jk) - ABS( pU(ji,jj,jk) ) 
     144            zfp_vj = pV(ji,jj,jk) + ABS( pV(ji,jj,jk) ) 
     145            zfm_vj = pV(ji,jj,jk) - ABS( pV(ji,jj,jk) ) 
     146            !                                                  ! 2nd order centered advective fluxes (x2) 
     147            zcenut = pU(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj  ,jk,jn,Kmm) ) 
     148            zcenvt = pV(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji  ,jj+1,jk,jn,Kmm) ) 
     149            !                                                  ! UBS advective fluxes 
     150            ztu(ji,jj,jk) = 0.5 * ( zcenut - zfp_ui * zltu(ji,jj,jk) - zfm_ui * zltu(ji+1,jj,jk) ) 
     151            ztv(ji,jj,jk) = 0.5 * ( zcenvt - zfp_vj * zltv(ji,jj,jk) - zfm_vj * zltv(ji,jj+1,jk) ) 
     152         END_3D 
     153         ! 
     154         zltu(:,:,:) = pt(:,:,:,jn,Krhs)      ! store the initial trends before its update 
    163155         ! 
    164156         DO jk = 1, jpkm1        !==  add the horizontal advective trend  ==! 
    165             DO jj = 2, jpjm1 
    166                DO ji = fs_2, fs_jpim1   ! vector opt. 
    167                   pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn)                        & 
    168                      &             - (  ztu(ji,jj,jk) - ztu(ji-1,jj  ,jk)    & 
    169                      &                + ztv(ji,jj,jk) - ztv(ji  ,jj-1,jk)  ) * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) 
    170                END DO 
    171             END DO 
     157            DO_2D_00_00 
     158               pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs)                        & 
     159                  &             - (  ztu(ji,jj,jk) - ztu(ji-1,jj  ,jk)    & 
     160                  &                + ztv(ji,jj,jk) - ztv(ji  ,jj-1,jk)  ) * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
     161            END_2D 
    172162            !                                              
    173163         END DO 
    174164         ! 
    175          zltu(:,:,:) = pta(:,:,:,jn) - zltu(:,:,:)    ! Horizontal advective trend used in vertical 2nd order FCT case 
     165         zltu(:,:,:) = pt(:,:,:,jn,Krhs) - zltu(:,:,:)    ! Horizontal advective trend used in vertical 2nd order FCT case 
    176166         !                                            ! and/or in trend diagnostic (l_trd=T)  
    177167         !                 
    178168         IF( l_trd ) THEN                  ! trend diagnostics 
    179              CALL trd_tra( kt, cdtype, jn, jptra_xad, ztu, pun, ptn(:,:,:,jn) ) 
    180              CALL trd_tra( kt, cdtype, jn, jptra_yad, ztv, pvn, ptn(:,:,:,jn) ) 
     169             CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_xad, ztu, pU, pt(:,:,:,jn,Kmm) ) 
     170             CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_yad, ztv, pV, pt(:,:,:,jn,Kmm) ) 
    181171         END IF 
    182172         !      
    … …  
    193183         CASE(  2  )                   ! 2nd order FCT  
    194184            !          
    195             IF( l_trd )   zltv(:,:,:) = pta(:,:,:,jn)          ! store pta if trend diag. 
     185            IF( l_trd )   zltv(:,:,:) = pt(:,:,:,jn,Krhs)          ! store pt(:,:,:,:,Krhs) if trend diag. 
    196186            ! 
    197187            !                          !*  upstream advection with initial mass fluxes & intermediate update  ==! 
    198             DO jk = 2, jpkm1                 ! Interior value (w-masked) 
    199                DO jj = 1, jpj 
    200                   DO ji = 1, jpi 
    201                      zfp_wk = pwn(ji,jj,jk) + ABS( pwn(ji,jj,jk) ) 
    202                      zfm_wk = pwn(ji,jj,jk) - ABS( pwn(ji,jj,jk) ) 
    203                      ztw(ji,jj,jk) = 0.5_wp * (  zfp_wk * ptb(ji,jj,jk,jn) + zfm_wk * ptb(ji,jj,jk-1,jn)  ) * wmask(ji,jj,jk) 
    204                   END DO 
    205                END DO 
    206             END DO  
     188            DO_3D_11_11( 2, jpkm1 ) 
     189               zfp_wk = pW(ji,jj,jk) + ABS( pW(ji,jj,jk) ) 
     190               zfm_wk = pW(ji,jj,jk) - ABS( pW(ji,jj,jk) ) 
     191               ztw(ji,jj,jk) = 0.5_wp * (  zfp_wk * pt(ji,jj,jk,jn,Kbb) + zfm_wk * pt(ji,jj,jk-1,jn,Kbb)  ) * wmask(ji,jj,jk) 
     192            END_3D 
    207193            IF( ln_linssh ) THEN             ! top ocean value (only in linear free surface as ztw has been w-masked) 
    208194               IF( ln_isfcav ) THEN                ! top of the ice-shelf cavities and at the ocean surface 
    209                   DO jj = 1, jpj 
    210                      DO ji = 1, jpi 
    211                         ztw(ji,jj, mikt(ji,jj) ) = pwn(ji,jj,mikt(ji,jj)) * ptb(ji,jj,mikt(ji,jj),jn)   ! linear free surface  
    212                      END DO 
    213                   END DO    
     195                  DO_2D_11_11 
     196                     ztw(ji,jj, mikt(ji,jj) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kbb)   ! linear free surface  
     197                  END_2D 
    214198               ELSE                                ! no cavities: only at the ocean surface 
    215                   ztw(:,:,1) = pwn(:,:,1) * ptb(:,:,1,jn) 
     199                  ztw(:,:,1) = pW(:,:,1) * pt(:,:,1,jn,Kbb) 
    216200               ENDIF 
    217201            ENDIF 
    218202            ! 
    219             DO jk = 1, jpkm1           !* trend and after field with monotonic scheme 
    220                DO jj = 2, jpjm1 
    221                   DO ji = fs_2, fs_jpim1   ! vector opt. 
    222                      ztak = - ( ztw(ji,jj,jk) - ztw(ji,jj,jk+1) ) * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) 
    223                      pta(ji,jj,jk,jn) =   pta(ji,jj,jk,jn) +  ztak  
    224                      zti(ji,jj,jk)    = ( ptb(ji,jj,jk,jn) + p2dt * ( ztak + zltu(ji,jj,jk) ) ) * tmask(ji,jj,jk) 
    225                   END DO 
    226                END DO 
    227             END DO 
     203            DO_3D_00_00( 1, jpkm1 ) 
     204               ztak = - ( ztw(ji,jj,jk) - ztw(ji,jj,jk+1) ) * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
     205               pt(ji,jj,jk,jn,Krhs) =   pt(ji,jj,jk,jn,Krhs) +  ztak  
     206               zti(ji,jj,jk)    = ( pt(ji,jj,jk,jn,Kbb) + p2dt * ( ztak + zltu(ji,jj,jk) ) ) * tmask(ji,jj,jk) 
     207            END_3D 
    228208            CALL lbc_lnk( 'traadv_ubs', zti, 'T', 1. )      ! Lateral boundary conditions on zti, zsi   (unchanged sign) 
    229209            ! 
    230210            !                          !*  anti-diffusive flux : high order minus low order 
    231             DO jk = 2, jpkm1        ! Interior value  (w-masked) 
    232                DO jj = 1, jpj 
    233                   DO ji = 1, jpi 
    234                      ztw(ji,jj,jk) = (   0.5_wp * pwn(ji,jj,jk) * ( ptn(ji,jj,jk,jn) + ptn(ji,jj,jk-1,jn) )   & 
    235                         &              - ztw(ji,jj,jk)   ) * wmask(ji,jj,jk) 
    236                   END DO 
    237                END DO 
    238             END DO 
     211            DO_3D_11_11( 2, jpkm1 ) 
     212               ztw(ji,jj,jk) = (   0.5_wp * pW(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji,jj,jk-1,jn,Kmm) )   & 
     213                  &              - ztw(ji,jj,jk)   ) * wmask(ji,jj,jk) 
     214            END_3D 
    239215            !                                            ! top ocean value: high order == upstream  ==>>  zwz=0 
    240216            IF( ln_linssh )   ztw(:,:, 1 ) = 0._wp       ! only ocean surface as interior zwz values have been w-masked 
    241217            ! 
    242             CALL nonosc_z( ptb(:,:,:,jn), ztw, zti, p2dt )      !  monotonicity algorithm 
     218            CALL nonosc_z( Kmm, pt(:,:,:,jn,Kbb), ztw, zti, p2dt )      !  monotonicity algorithm 
    243219            ! 
    244220         CASE(  4  )                               ! 4th order COMPACT 
    245             CALL interp_4th_cpt( ptn(:,:,:,jn) , ztw )         ! 4th order compact interpolation of T at w-point 
    246             DO jk = 2, jpkm1 
    247                DO jj = 2, jpjm1 
    248                   DO ji = fs_2, fs_jpim1 
    249                      ztw(ji,jj,jk) = pwn(ji,jj,jk) * ztw(ji,jj,jk) * wmask(ji,jj,jk) 
    250                   END DO 
    251                END DO 
    252             END DO 
    253             IF( ln_linssh )   ztw(:,:, 1 ) = pwn(:,:,1) * ptn(:,:,1,jn)     !!gm ISF & 4th COMPACT doesn't work 
     221            CALL interp_4th_cpt( pt(:,:,:,jn,Kmm) , ztw )         ! 4th order compact interpolation of T at w-point 
     222            DO_3D_00_00( 2, jpkm1 ) 
     223               ztw(ji,jj,jk) = pW(ji,jj,jk) * ztw(ji,jj,jk) * wmask(ji,jj,jk) 
     224            END_3D 
     225            IF( ln_linssh )   ztw(:,:, 1 ) = pW(:,:,1) * pt(:,:,1,jn,Kmm)     !!gm ISF & 4th COMPACT doesn't work 
    254226            ! 
    255227         END SELECT 
    256228         ! 
    257          DO jk = 1, jpkm1        !  final trend with corrected fluxes 
    258             DO jj = 2, jpjm1  
    259                DO ji = fs_2, fs_jpim1   ! vector opt.    
    260                   pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) - ( ztw(ji,jj,jk) - ztw(ji,jj,jk+1) ) * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) 
    261                END DO 
    262             END DO 
    263          END DO 
     229         DO_3D_00_00( 1, jpkm1 ) 
     230            pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( ztw(ji,jj,jk) - ztw(ji,jj,jk+1) ) * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
     231         END_3D 
    264232         ! 
    265233         IF( l_trd )  THEN       ! vertical advective trend diagnostics 
    266             DO jk = 1, jpkm1                       ! (compute -w.dk[ptn]= -dk[w.ptn] + ptn.dk[w]) 
    267                DO jj = 2, jpjm1 
    268                   DO ji = fs_2, fs_jpim1   ! vector opt. 
    269                      zltv(ji,jj,jk) = pta(ji,jj,jk,jn) - zltv(ji,jj,jk)                          & 
    270                         &           + ptn(ji,jj,jk,jn) * (  pwn(ji,jj,jk) - pwn(ji,jj,jk+1)  )   & 
    271                         &                              * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) 
    272                   END DO 
    273                END DO 
    274             END DO 
    275             CALL trd_tra( kt, cdtype, jn, jptra_zad, zltv ) 
     234            DO_3D_00_00( 1, jpkm1 ) 
     235               zltv(ji,jj,jk) = pt(ji,jj,jk,jn,Krhs) - zltv(ji,jj,jk)                          & 
     236                  &           + pt(ji,jj,jk,jn,Kmm) * (  pW(ji,jj,jk) - pW(ji,jj,jk+1)  )   & 
     237                  &                              * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
     238            END_3D 
     239            CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_zad, zltv ) 
    276240         ENDIF 
    277241         ! 
    … …  
    281245 
    282246 
    283    SUBROUTINE nonosc_z( pbef, pcc, paft, p2dt ) 
     247   SUBROUTINE nonosc_z( Kmm, pbef, pcc, paft, p2dt ) 
    284248      !!--------------------------------------------------------------------- 
    285249      !!                    ***  ROUTINE nonosc_z  *** 
    … …  
    294258      !!       in-space based differencing for fluid 
    295259      !!---------------------------------------------------------------------- 
     260      INTEGER , INTENT(in   )                          ::   Kmm    ! time level index 
    296261      REAL(wp), INTENT(in   )                          ::   p2dt   ! tracer time-step 
    297262      REAL(wp),                DIMENSION (jpi,jpj,jpk) ::   pbef   ! before field 
    … …  
    317282      DO jk = 1, jpkm1     ! search maximum in neighbourhood 
    318283         ikm1 = MAX(jk-1,1) 
    319          DO jj = 2, jpjm1 
    320             DO ji = fs_2, fs_jpim1   ! vector opt. 
    321                zbetup(ji,jj,jk) = MAX(  pbef(ji  ,jj  ,jk  ), paft(ji  ,jj  ,jk  ),   & 
    322                   &                     pbef(ji  ,jj  ,ikm1), pbef(ji  ,jj  ,jk+1),   & 
    323                   &                     paft(ji  ,jj  ,ikm1), paft(ji  ,jj  ,jk+1)  ) 
    324             END DO 
    325          END DO 
     284         DO_2D_00_00 
     285            zbetup(ji,jj,jk) = MAX(  pbef(ji  ,jj  ,jk  ), paft(ji  ,jj  ,jk  ),   & 
     286               &                     pbef(ji  ,jj  ,ikm1), pbef(ji  ,jj  ,jk+1),   & 
     287               &                     paft(ji  ,jj  ,ikm1), paft(ji  ,jj  ,jk+1)  ) 
     288         END_2D 
    326289      END DO 
    327290      !                    ! large positive value (+zbig) inside land 
    … …  
    331294      DO jk = 1, jpkm1     ! search minimum in neighbourhood 
    332295         ikm1 = MAX(jk-1,1) 
    333          DO jj = 2, jpjm1 
    334             DO ji = fs_2, fs_jpim1   ! vector opt. 
    335                zbetdo(ji,jj,jk) = MIN(  pbef(ji  ,jj  ,jk  ), paft(ji  ,jj  ,jk  ),   & 
    336                   &                     pbef(ji  ,jj  ,ikm1), pbef(ji  ,jj  ,jk+1),   & 
    337                   &                     paft(ji  ,jj  ,ikm1), paft(ji  ,jj  ,jk+1)  ) 
    338             END DO 
    339          END DO 
     296         DO_2D_00_00 
     297            zbetdo(ji,jj,jk) = MIN(  pbef(ji  ,jj  ,jk  ), paft(ji  ,jj  ,jk  ),   & 
     298               &                     pbef(ji  ,jj  ,ikm1), pbef(ji  ,jj  ,jk+1),   & 
     299               &                     paft(ji  ,jj  ,ikm1), paft(ji  ,jj  ,jk+1)  ) 
     300         END_2D 
    340301      END DO 
    341302      !                    ! restore masked values to zero 
    … …  
    345306      ! Positive and negative part of fluxes and beta terms 
    346307      ! --------------------------------------------------- 
    347       DO jk = 1, jpkm1 
    348          DO jj = 2, jpjm1 
    349             DO ji = fs_2, fs_jpim1   ! vector opt. 
    350                ! positive & negative part of the flux 
    351                zpos = MAX( 0., pcc(ji  ,jj  ,jk+1) ) - MIN( 0., pcc(ji  ,jj  ,jk  ) ) 
    352                zneg = MAX( 0., pcc(ji  ,jj  ,jk  ) ) - MIN( 0., pcc(ji  ,jj  ,jk+1) ) 
    353                ! up & down beta terms 
    354                zbt = e1e2t(ji,jj) * e3t_n(ji,jj,jk) / p2dt 
    355                zbetup(ji,jj,jk) = ( zbetup(ji,jj,jk) - paft(ji,jj,jk) ) / (zpos+zrtrn) * zbt 
    356                zbetdo(ji,jj,jk) = ( paft(ji,jj,jk) - zbetdo(ji,jj,jk) ) / (zneg+zrtrn) * zbt 
    357             END DO 
    358          END DO 
    359       END DO 
     308      DO_3D_00_00( 1, jpkm1 ) 
     309         ! positive & negative part of the flux 
     310         zpos = MAX( 0., pcc(ji  ,jj  ,jk+1) ) - MIN( 0., pcc(ji  ,jj  ,jk  ) ) 
     311         zneg = MAX( 0., pcc(ji  ,jj  ,jk  ) ) - MIN( 0., pcc(ji  ,jj  ,jk+1) ) 
     312         ! up & down beta terms 
     313         zbt = e1e2t(ji,jj) * e3t(ji,jj,jk,Kmm) / p2dt 
     314         zbetup(ji,jj,jk) = ( zbetup(ji,jj,jk) - paft(ji,jj,jk) ) / (zpos+zrtrn) * zbt 
     315         zbetdo(ji,jj,jk) = ( paft(ji,jj,jk) - zbetdo(ji,jj,jk) ) / (zneg+zrtrn) * zbt 
     316      END_3D 
    360317      ! 
    361318      ! monotonic flux in the k direction, i.e. pcc 
    362319      ! ------------------------------------------- 
    363       DO jk = 2, jpkm1 
    364          DO jj = 2, jpjm1 
    365             DO ji = fs_2, fs_jpim1   ! vector opt. 
    366                za = MIN( 1., zbetdo(ji,jj,jk), zbetup(ji,jj,jk-1) ) 
    367                zb = MIN( 1., zbetup(ji,jj,jk), zbetdo(ji,jj,jk-1) ) 
    368                zc = 0.5 * ( 1.e0 + SIGN( 1.e0, pcc(ji,jj,jk) ) ) 
    369                pcc(ji,jj,jk) = pcc(ji,jj,jk) * ( zc * za + ( 1.e0 - zc) * zb ) 
    370             END DO 
    371          END DO 
    372       END DO 
     320      DO_3D_00_00( 2, jpkm1 ) 
     321         za = MIN( 1., zbetdo(ji,jj,jk), zbetup(ji,jj,jk-1) ) 
     322         zb = MIN( 1., zbetup(ji,jj,jk), zbetdo(ji,jj,jk-1) ) 
     323         zc = 0.5 * ( 1.e0 + SIGN( 1.e0, pcc(ji,jj,jk) ) ) 
     324         pcc(ji,jj,jk) = pcc(ji,jj,jk) * ( zc * za + ( 1.e0 - zc) * zb ) 
     325      END_3D 
    373326      ! 
    374327   END SUBROUTINE nonosc_z 

  • NEMO/trunk/src/OCE/TRA/trabbc.F90

    r12276 r12377  
    4444   TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_qgh   ! structure of input qgh (file informations, fields read) 
    4545  
     46   !! * Substitutions 
     47#  include "do_loop_substitute.h90" 
    4648   !!---------------------------------------------------------------------- 
    4749   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    5153CONTAINS 
    5254 
    53    SUBROUTINE tra_bbc( kt ) 
     55   SUBROUTINE tra_bbc( kt, Kmm, pts, Krhs ) 
    5456      !!---------------------------------------------------------------------- 
    5557      !!                  ***  ROUTINE tra_bbc  *** 
    … …  
    7375      !!              Emile-Geay and Madec, 2009, Ocean Science. 
    7476      !!---------------------------------------------------------------------- 
    75       INTEGER, INTENT(in) ::   kt   ! ocean time-step index 
     77      INTEGER,                                   INTENT(in   ) :: kt         ! ocean time-step index 
     78      INTEGER,                                   INTENT(in   ) :: Kmm, Krhs  ! time level indices 
     79      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts        ! active tracers and RHS of tracer equation 
    7680      ! 
    7781      INTEGER  ::   ji, jj    ! dummy loop indices 
    … …  
    8387      IF( l_trdtra )   THEN         ! Save the input temperature trend 
    8488         ALLOCATE( ztrdt(jpi,jpj,jpk) ) 
    85          ztrdt(:,:,:) = tsa(:,:,:,jp_tem) 
     89         ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) 
    8690      ENDIF 
    8791      !                             !  Add the geothermal trend on temperature 
    88       DO jj = 2, jpjm1 
    89          DO ji = 2, jpim1 
    90             tsa(ji,jj,mbkt(ji,jj),jp_tem) = tsa(ji,jj,mbkt(ji,jj),jp_tem) + qgh_trd0(ji,jj) / e3t_n(ji,jj,mbkt(ji,jj)) 
    91          END DO 
    92       END DO 
     92      DO_2D_00_00 
     93         pts(ji,jj,mbkt(ji,jj),jp_tem,Krhs) = pts(ji,jj,mbkt(ji,jj),jp_tem,Krhs) + qgh_trd0(ji,jj) / e3t(ji,jj,mbkt(ji,jj),Kmm) 
     94      END_2D 
    9395      ! 
    94       CALL lbc_lnk( 'trabbc', tsa(:,:,:,jp_tem) , 'T', 1. ) 
     96      CALL lbc_lnk( 'trabbc', pts(:,:,:,jp_tem,Krhs) , 'T', 1. ) 
    9597      ! 
    9698      IF( l_trdtra ) THEN        ! Send the trend for diagnostics 
    97          ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) 
    98          CALL trd_tra( kt, 'TRA', jp_tem, jptra_bbc, ztrdt ) 
     99         ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) - ztrdt(:,:,:) 
     100         CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_bbc, ztrdt ) 
    99101         DEALLOCATE( ztrdt ) 
    100102      ENDIF 
    101103      ! 
    102104      CALL iom_put ( "hfgeou" , rau0_rcp * qgh_trd0(:,:) ) 
    103       ! 
    104       IF(ln_ctl)   CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' bbc  - Ta: ', mask1=tmask, clinfo3='tra-ta' ) 
     105      IF(sn_cfctl%l_prtctl)   CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' bbc  - Ta: ', mask1=tmask, clinfo3='tra-ta' ) 
    105106      ! 
    106107      IF( ln_timing )   CALL timing_stop('tra_bbc') 
    … …  
    135136      !!---------------------------------------------------------------------- 
    136137      ! 
    137       REWIND( numnam_ref ) 
    138138      READ  ( numnam_ref, nambbc, IOSTAT = ios, ERR = 901) 
    139139901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nambbc in reference namelist' ) 
    140140      ! 
    141       REWIND( numnam_cfg ) 
    142141      READ  ( numnam_cfg, nambbc, IOSTAT = ios, ERR = 902 ) 
    143142902   IF( ios >  0 )   CALL ctl_nam ( ios , 'nambbc in configuration namelist' ) 

  • NEMO/trunk/src/OCE/TRA/trabbl.F90

    r11536 r12377  
    6767 
    6868   !! * Substitutions 
    69 #  include "vectopt_loop_substitute.h90" 
     69#  include "do_loop_substitute.h90" 
    7070   !!---------------------------------------------------------------------- 
    7171   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    8989 
    9090 
    91    SUBROUTINE tra_bbl( kt ) 
     91   SUBROUTINE tra_bbl( kt, Kbb, Kmm, pts, Krhs ) 
    9292      !!---------------------------------------------------------------------- 
    9393      !!                  ***  ROUTINE bbl  *** 
    … …  
    101101      !!              is added to the general tracer trend 
    102102      !!---------------------------------------------------------------------- 
    103       INTEGER, INTENT( in ) ::   kt   ! ocean time-step 
     103      INTEGER,                                   INTENT(in   ) :: kt              ! ocean time-step 
     104      INTEGER,                                   INTENT(in   ) :: Kbb, Kmm, Krhs  ! time level indices 
     105      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts             ! active tracers and RHS of tracer equation 
    104106      ! 
    105107      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   ztrdt, ztrds 
    … …  
    110112      IF( l_trdtra )   THEN                         !* Save the T-S input trends 
    111113         ALLOCATE( ztrdt(jpi,jpj,jpk) , ztrds(jpi,jpj,jpk) ) 
    112          ztrdt(:,:,:) = tsa(:,:,:,jp_tem) 
    113          ztrds(:,:,:) = tsa(:,:,:,jp_sal) 
    114       ENDIF 
    115  
    116       IF( l_bbl )   CALL bbl( kt, nit000, 'TRA' )   !* bbl coef. and transport (only if not already done in trcbbl) 
     114         ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) 
     115         ztrds(:,:,:) = pts(:,:,:,jp_sal,Krhs) 
     116      ENDIF 
     117 
     118      IF( l_bbl )   CALL bbl( kt, nit000, 'TRA', Kbb, Kmm )   !* bbl coef. and transport (only if not already done in trcbbl) 
    117119 
    118120      IF( nn_bbl_ldf == 1 ) THEN                    !* Diffusive bbl 
    119121         ! 
    120          CALL tra_bbl_dif( tsb, tsa, jpts ) 
    121          IF( ln_ctl )  & 
    122          CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' bbl_ldf  - Ta: ', mask1=tmask, & 
    123             &          tab3d_2=tsa(:,:,:,jp_sal), clinfo2=           ' Sa: ', mask2=tmask, clinfo3='tra' ) 
     122         CALL tra_bbl_dif( pts(:,:,:,:,Kbb), pts(:,:,:,:,Krhs), jpts, Kmm ) 
     123         IF( sn_cfctl%l_prtctl )  & 
     124         CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' bbl_ldf  - Ta: ', mask1=tmask, & 
     125            &          tab3d_2=pts(:,:,:,jp_sal,Krhs), clinfo2=           ' Sa: ', mask2=tmask, clinfo3='tra' ) 
    124126         ! lateral boundary conditions ; just need for outputs 
    125127         CALL lbc_lnk_multi( 'trabbl', ahu_bbl, 'U', 1. , ahv_bbl, 'V', 1. ) 
    … …  
    131133      IF( nn_bbl_adv /= 0 ) THEN                    !* Advective bbl 
    132134         ! 
    133          CALL tra_bbl_adv( tsb, tsa, jpts ) 
    134          IF(ln_ctl)   & 
    135          CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' bbl_adv  - Ta: ', mask1=tmask,   & 
    136             &          tab3d_2=tsa(:,:,:,jp_sal), clinfo2=           ' Sa: ', mask2=tmask, clinfo3='tra' ) 
     135         CALL tra_bbl_adv( pts(:,:,:,:,Kbb), pts(:,:,:,:,Krhs), jpts, Kmm ) 
     136         IF(sn_cfctl%l_prtctl)   & 
     137         CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' bbl_adv  - Ta: ', mask1=tmask,   & 
     138            &          tab3d_2=pts(:,:,:,jp_sal,Krhs), clinfo2=           ' Sa: ', mask2=tmask, clinfo3='tra' ) 
    137139         ! lateral boundary conditions ; just need for outputs 
    138140         CALL lbc_lnk_multi( 'trabbl', utr_bbl, 'U', 1. , vtr_bbl, 'V', 1. ) 
    … …  
    143145 
    144146      IF( l_trdtra )   THEN                      ! send the trends for further diagnostics 
    145          ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) 
    146          ztrds(:,:,:) = tsa(:,:,:,jp_sal) - ztrds(:,:,:) 
    147          CALL trd_tra( kt, 'TRA', jp_tem, jptra_bbl, ztrdt ) 
    148          CALL trd_tra( kt, 'TRA', jp_sal, jptra_bbl, ztrds ) 
     147         ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) - ztrdt(:,:,:) 
     148         ztrds(:,:,:) = pts(:,:,:,jp_sal,Krhs) - ztrds(:,:,:) 
     149         CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_bbl, ztrdt ) 
     150         CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_sal, jptra_bbl, ztrds ) 
    149151         DEALLOCATE( ztrdt, ztrds ) 
    150152      ENDIF 
    … …  
    155157 
    156158 
    157    SUBROUTINE tra_bbl_dif( ptb, pta, kjpt ) 
     159   SUBROUTINE tra_bbl_dif( pt, pt_rhs, kjpt, Kmm ) 
    158160      !!---------------------------------------------------------------------- 
    159161      !!                  ***  ROUTINE tra_bbl_dif  *** 
    … …  
    171173      !!      convection is satified) 
    172174      !! 
    173       !! ** Action  :   pta   increased by the bbl diffusive trend 
     175      !! ** Action  :   pt_rhs   increased by the bbl diffusive trend 
    174176      !! 
    175177      !! References : Beckmann, A., and R. Doscher, 1997, J. Phys.Oceanogr., 581-591. 
    … …  
    177179      !!---------------------------------------------------------------------- 
    178180      INTEGER                              , INTENT(in   ) ::   kjpt   ! number of tracers 
    179       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb    ! before and now tracer fields 
    180       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta    ! tracer trend 
     181      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   pt     ! before and now tracer fields 
     182      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pt_rhs ! tracer trend 
     183      INTEGER                              , INTENT(in   ) ::   Kmm    ! time level indices 
    181184      ! 
    182185      INTEGER  ::   ji, jj, jn   ! dummy loop indices 
    … …  
    188191      DO jn = 1, kjpt                                     ! tracer loop 
    189192         !                                                ! =========== 
    190          DO jj = 1, jpj 
    191             DO ji = 1, jpi 
    192                ik = mbkt(ji,jj)                             ! bottom T-level index 
    193                zptb(ji,jj) = ptb(ji,jj,ik,jn)               ! bottom before T and S 
    194             END DO 
    195          END DO 
     193         DO_2D_11_11 
     194            ik = mbkt(ji,jj)                             ! bottom T-level index 
     195            zptb(ji,jj) = pt(ji,jj,ik,jn)                ! bottom before T and S 
     196         END_2D 
    196197         !                
    197          DO jj = 2, jpjm1                                    ! Compute the trend 
    198             DO ji = 2, jpim1 
    199                ik = mbkt(ji,jj)                            ! bottom T-level index 
    200                pta(ji,jj,ik,jn) = pta(ji,jj,ik,jn)                                                  & 
    201                   &             + (  ahu_bbl(ji  ,jj  ) * ( zptb(ji+1,jj  ) - zptb(ji  ,jj  ) )     & 
    202                   &                - ahu_bbl(ji-1,jj  ) * ( zptb(ji  ,jj  ) - zptb(ji-1,jj  ) )     & 
    203                   &                + ahv_bbl(ji  ,jj  ) * ( zptb(ji  ,jj+1) - zptb(ji  ,jj  ) )     & 
    204                   &                - ahv_bbl(ji  ,jj-1) * ( zptb(ji  ,jj  ) - zptb(ji  ,jj-1) )  )  & 
    205                   &             * r1_e1e2t(ji,jj) / e3t_n(ji,jj,ik) 
    206             END DO 
    207          END DO 
     198         DO_2D_00_00 
     199            ik = mbkt(ji,jj)                            ! bottom T-level index 
     200            pt_rhs(ji,jj,ik,jn) = pt_rhs(ji,jj,ik,jn)                                                  & 
     201               &                + (  ahu_bbl(ji  ,jj  ) * ( zptb(ji+1,jj  ) - zptb(ji  ,jj  ) )     & 
     202               &                   - ahu_bbl(ji-1,jj  ) * ( zptb(ji  ,jj  ) - zptb(ji-1,jj  ) )     & 
     203               &                   + ahv_bbl(ji  ,jj  ) * ( zptb(ji  ,jj+1) - zptb(ji  ,jj  ) )     & 
     204               &                   - ahv_bbl(ji  ,jj-1) * ( zptb(ji  ,jj  ) - zptb(ji  ,jj-1) )  )  & 
     205               &                * r1_e1e2t(ji,jj) / e3t(ji,jj,ik,Kmm) 
     206         END_2D 
    208207         !                                                  ! =========== 
    209208      END DO                                                ! end tracer 
    … …  
    212211 
    213212 
    214    SUBROUTINE tra_bbl_adv( ptb, pta, kjpt ) 
     213   SUBROUTINE tra_bbl_adv( pt, pt_rhs, kjpt, Kmm ) 
    215214      !!---------------------------------------------------------------------- 
    216215      !!                  ***  ROUTINE trc_bbl  *** 
    … …  
    228227      !!---------------------------------------------------------------------- 
    229228      INTEGER                              , INTENT(in   ) ::   kjpt   ! number of tracers 
    230       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb    ! before and now tracer fields 
    231       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta    ! tracer trend 
     229      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   pt     ! before and now tracer fields 
     230      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pt_rhs ! tracer trend 
     231      INTEGER                              , INTENT(in   ) ::   Kmm    ! time level indices 
    232232      ! 
    233233      INTEGER  ::   ji, jj, jk, jn           ! dummy loop indices 
    … …  
    250250                  ! 
    251251                  !                                               ! up  -slope T-point (shelf bottom point) 
    252                   zbtr = r1_e1e2t(iis,jj) / e3t_n(iis,jj,ikus) 
    253                   ztra = zu_bbl * ( ptb(iid,jj,ikus,jn) - ptb(iis,jj,ikus,jn) ) * zbtr 
    254                   pta(iis,jj,ikus,jn) = pta(iis,jj,ikus,jn) + ztra 
     252                  zbtr = r1_e1e2t(iis,jj) / e3t(iis,jj,ikus,Kmm) 
     253                  ztra = zu_bbl * ( pt(iid,jj,ikus,jn) - pt(iis,jj,ikus,jn) ) * zbtr 
     254                  pt_rhs(iis,jj,ikus,jn) = pt_rhs(iis,jj,ikus,jn) + ztra 
    255255                  ! 
    256256                  DO jk = ikus, ikud-1                            ! down-slope upper to down T-point (deep column) 
    257                      zbtr = r1_e1e2t(iid,jj) / e3t_n(iid,jj,jk) 
    258                      ztra = zu_bbl * ( ptb(iid,jj,jk+1,jn) - ptb(iid,jj,jk,jn) ) * zbtr 
    259                      pta(iid,jj,jk,jn) = pta(iid,jj,jk,jn) + ztra 
     257                     zbtr = r1_e1e2t(iid,jj) / e3t(iid,jj,jk,Kmm) 
     258                     ztra = zu_bbl * ( pt(iid,jj,jk+1,jn) - pt(iid,jj,jk,jn) ) * zbtr 
     259                     pt_rhs(iid,jj,jk,jn) = pt_rhs(iid,jj,jk,jn) + ztra 
    260260                  END DO 
    261261                  ! 
    262                   zbtr = r1_e1e2t(iid,jj) / e3t_n(iid,jj,ikud) 
    263                   ztra = zu_bbl * ( ptb(iis,jj,ikus,jn) - ptb(iid,jj,ikud,jn) ) * zbtr 
    264                   pta(iid,jj,ikud,jn) = pta(iid,jj,ikud,jn) + ztra 
     262                  zbtr = r1_e1e2t(iid,jj) / e3t(iid,jj,ikud,Kmm) 
     263                  ztra = zu_bbl * ( pt(iis,jj,ikus,jn) - pt(iid,jj,ikud,jn) ) * zbtr 
     264                  pt_rhs(iid,jj,ikud,jn) = pt_rhs(iid,jj,ikud,jn) + ztra 
    265265               ENDIF 
    266266               ! 
    … …  
    272272                  ! 
    273273                  ! up  -slope T-point (shelf bottom point) 
    274                   zbtr = r1_e1e2t(ji,ijs) / e3t_n(ji,ijs,ikvs) 
    275                   ztra = zv_bbl * ( ptb(ji,ijd,ikvs,jn) - ptb(ji,ijs,ikvs,jn) ) * zbtr 
    276                   pta(ji,ijs,ikvs,jn) = pta(ji,ijs,ikvs,jn) + ztra 
     274                  zbtr = r1_e1e2t(ji,ijs) / e3t(ji,ijs,ikvs,Kmm) 
     275                  ztra = zv_bbl * ( pt(ji,ijd,ikvs,jn) - pt(ji,ijs,ikvs,jn) ) * zbtr 
     276                  pt_rhs(ji,ijs,ikvs,jn) = pt_rhs(ji,ijs,ikvs,jn) + ztra 
    277277                  ! 
    278278                  DO jk = ikvs, ikvd-1                            ! down-slope upper to down T-point (deep column) 
    279                      zbtr = r1_e1e2t(ji,ijd) / e3t_n(ji,ijd,jk) 
    280                      ztra = zv_bbl * ( ptb(ji,ijd,jk+1,jn) - ptb(ji,ijd,jk,jn) ) * zbtr 
    281                      pta(ji,ijd,jk,jn) = pta(ji,ijd,jk,jn)  + ztra 
     279                     zbtr = r1_e1e2t(ji,ijd) / e3t(ji,ijd,jk,Kmm) 
     280                     ztra = zv_bbl * ( pt(ji,ijd,jk+1,jn) - pt(ji,ijd,jk,jn) ) * zbtr 
     281                     pt_rhs(ji,ijd,jk,jn) = pt_rhs(ji,ijd,jk,jn)  + ztra 
    282282                  END DO 
    283283                  !                                               ! down-slope T-point (deep bottom point) 
    284                   zbtr = r1_e1e2t(ji,ijd) / e3t_n(ji,ijd,ikvd) 
    285                   ztra = zv_bbl * ( ptb(ji,ijs,ikvs,jn) - ptb(ji,ijd,ikvd,jn) ) * zbtr 
    286                   pta(ji,ijd,ikvd,jn) = pta(ji,ijd,ikvd,jn) + ztra 
     284                  zbtr = r1_e1e2t(ji,ijd) / e3t(ji,ijd,ikvd,Kmm) 
     285                  ztra = zv_bbl * ( pt(ji,ijs,ikvs,jn) - pt(ji,ijd,ikvd,jn) ) * zbtr 
     286                  pt_rhs(ji,ijd,ikvd,jn) = pt_rhs(ji,ijd,ikvd,jn) + ztra 
    287287               ENDIF 
    288288            END DO 
    … …  
    295295 
    296296 
    297    SUBROUTINE bbl( kt, kit000, cdtype ) 
     297   SUBROUTINE bbl( kt, kit000, cdtype, Kbb, Kmm ) 
    298298      !!---------------------------------------------------------------------- 
    299299      !!                  ***  ROUTINE bbl  *** 
    … …  
    324324      INTEGER         , INTENT(in   ) ::   kit000   ! first time step index 
    325325      CHARACTER(len=3), INTENT(in   ) ::   cdtype   ! =TRA or TRC (tracer indicator) 
     326      INTEGER         , INTENT(in   ) ::   Kbb, Kmm ! ocean time level index 
    326327      ! 
    327328      INTEGER  ::   ji, jj                    ! dummy loop indices 
    … …  
    341342      ENDIF 
    342343      !                                        !* bottom variables (T, S, alpha, beta, depth, velocity) 
    343       DO jj = 1, jpj 
    344          DO ji = 1, jpi 
    345             ik = mbkt(ji,jj)                             ! bottom T-level index 
    346             zts (ji,jj,jp_tem) = tsb(ji,jj,ik,jp_tem)    ! bottom before T and S 
    347             zts (ji,jj,jp_sal) = tsb(ji,jj,ik,jp_sal) 
    348             ! 
    349             zdep(ji,jj) = gdept_n(ji,jj,ik)              ! bottom T-level reference depth 
    350             zub (ji,jj) = un(ji,jj,mbku(ji,jj))          ! bottom velocity 
    351             zvb (ji,jj) = vn(ji,jj,mbkv(ji,jj)) 
    352          END DO 
    353       END DO 
    354       ! 
    355       CALL eos_rab( zts, zdep, zab ) 
     344      DO_2D_11_11 
     345         ik = mbkt(ji,jj)                             ! bottom T-level index 
     346         zts (ji,jj,jp_tem) = ts(ji,jj,ik,jp_tem,Kbb) ! bottom before T and S 
     347         zts (ji,jj,jp_sal) = ts(ji,jj,ik,jp_sal,Kbb) 
     348         ! 
     349         zdep(ji,jj) = gdept(ji,jj,ik,Kmm)            ! bottom T-level reference depth 
     350         zub (ji,jj) = uu(ji,jj,mbku(ji,jj),Kmm)      ! bottom velocity 
     351         zvb (ji,jj) = vv(ji,jj,mbkv(ji,jj),Kmm) 
     352      END_2D 
     353      ! 
     354      CALL eos_rab( zts, zdep, zab, Kmm ) 
    356355      ! 
    357356      !                                   !-------------------! 
    358357      IF( nn_bbl_ldf == 1 ) THEN          !   diffusive bbl   ! 
    359358         !                                !-------------------! 
    360          DO jj = 1, jpjm1                      ! (criteria for non zero flux: grad(rho).grad(h) < 0 ) 
    361             DO ji = 1, fs_jpim1   ! vector opt. 
    362                !                                                   ! i-direction 
    363                za = zab(ji+1,jj,jp_tem) + zab(ji,jj,jp_tem)              ! 2*(alpha,beta) at u-point 
    364                zb = zab(ji+1,jj,jp_sal) + zab(ji,jj,jp_sal) 
    365                !                                                         ! 2*masked bottom density gradient 
    366                zgdrho = (  za * ( zts(ji+1,jj,jp_tem) - zts(ji,jj,jp_tem) )    & 
    367                   &      - zb * ( zts(ji+1,jj,jp_sal) - zts(ji,jj,jp_sal) )  ) * umask(ji,jj,1) 
    368                ! 
    369                zsign  = SIGN(  0.5, -zgdrho * REAL( mgrhu(ji,jj) )  )    ! sign of ( i-gradient * i-slope ) 
    370                ahu_bbl(ji,jj) = ( 0.5 - zsign ) * ahu_bbl_0(ji,jj)       ! masked diffusive flux coeff. 
    371                ! 
    372                !                                                   ! j-direction 
    373                za = zab(ji,jj+1,jp_tem) + zab(ji,jj,jp_tem)              ! 2*(alpha,beta) at v-point 
    374                zb = zab(ji,jj+1,jp_sal) + zab(ji,jj,jp_sal) 
    375                !                                                         ! 2*masked bottom density gradient 
    376                zgdrho = (  za * ( zts(ji,jj+1,jp_tem) - zts(ji,jj,jp_tem) )    & 
    377                   &      - zb * ( zts(ji,jj+1,jp_sal) - zts(ji,jj,jp_sal) )  ) * vmask(ji,jj,1) 
    378                ! 
    379                zsign = SIGN(  0.5, -zgdrho * REAL( mgrhv(ji,jj) )  )     ! sign of ( j-gradient * j-slope ) 
    380                ahv_bbl(ji,jj) = ( 0.5 - zsign ) * ahv_bbl_0(ji,jj) 
    381             END DO 
    382          END DO 
     359         DO_2D_10_10 
     360            !                                                   ! i-direction 
     361            za = zab(ji+1,jj,jp_tem) + zab(ji,jj,jp_tem)              ! 2*(alpha,beta) at u-point 
     362            zb = zab(ji+1,jj,jp_sal) + zab(ji,jj,jp_sal) 
     363            !                                                         ! 2*masked bottom density gradient 
     364            zgdrho = (  za * ( zts(ji+1,jj,jp_tem) - zts(ji,jj,jp_tem) )    & 
     365               &      - zb * ( zts(ji+1,jj,jp_sal) - zts(ji,jj,jp_sal) )  ) * umask(ji,jj,1) 
     366            ! 
     367            zsign  = SIGN(  0.5, -zgdrho * REAL( mgrhu(ji,jj) )  )    ! sign of ( i-gradient * i-slope ) 
     368            ahu_bbl(ji,jj) = ( 0.5 - zsign ) * ahu_bbl_0(ji,jj)       ! masked diffusive flux coeff. 
     369            ! 
     370            !                                                   ! j-direction 
     371            za = zab(ji,jj+1,jp_tem) + zab(ji,jj,jp_tem)              ! 2*(alpha,beta) at v-point 
     372            zb = zab(ji,jj+1,jp_sal) + zab(ji,jj,jp_sal) 
     373            !                                                         ! 2*masked bottom density gradient 
     374            zgdrho = (  za * ( zts(ji,jj+1,jp_tem) - zts(ji,jj,jp_tem) )    & 
     375               &      - zb * ( zts(ji,jj+1,jp_sal) - zts(ji,jj,jp_sal) )  ) * vmask(ji,jj,1) 
     376            ! 
     377            zsign = SIGN(  0.5, -zgdrho * REAL( mgrhv(ji,jj) )  )     ! sign of ( j-gradient * j-slope ) 
     378            ahv_bbl(ji,jj) = ( 0.5 - zsign ) * ahv_bbl_0(ji,jj) 
     379         END_2D 
    383380         ! 
    384381      ENDIF 
    … …  
    390387         ! 
    391388         CASE( 1 )                                   != use of upper velocity 
    392             DO jj = 1, jpjm1                                 ! criteria: grad(rho).grad(h)<0  and grad(rho).grad(h)<0 
    393                DO ji = 1, fs_jpim1   ! vector opt. 
    394                   !                                                  ! i-direction 
    395                   za = zab(ji+1,jj,jp_tem) + zab(ji,jj,jp_tem)               ! 2*(alpha,beta) at u-point 
    396                   zb = zab(ji+1,jj,jp_sal) + zab(ji,jj,jp_sal) 
    397                   !                                                          ! 2*masked bottom density gradient  
    398                   zgdrho = (  za * ( zts(ji+1,jj,jp_tem) - zts(ji,jj,jp_tem) )    & 
    399                             - zb * ( zts(ji+1,jj,jp_sal) - zts(ji,jj,jp_sal) )  ) * umask(ji,jj,1) 
    400                   ! 
    401                   zsign = SIGN(  0.5, - zgdrho   * REAL( mgrhu(ji,jj) )  )   ! sign of i-gradient * i-slope 
    402                   zsigna= SIGN(  0.5, zub(ji,jj) * REAL( mgrhu(ji,jj) )  )   ! sign of u * i-slope 
    403                   ! 
    404                   !                                                          ! bbl velocity 
    405                   utr_bbl(ji,jj) = ( 0.5 + zsigna ) * ( 0.5 - zsign ) * e2u(ji,jj) * e3u_bbl_0(ji,jj) * zub(ji,jj) 
    406                   ! 
    407                   !                                                  ! j-direction 
    408                   za = zab(ji,jj+1,jp_tem) + zab(ji,jj,jp_tem)               ! 2*(alpha,beta) at v-point 
    409                   zb = zab(ji,jj+1,jp_sal) + zab(ji,jj,jp_sal) 
    410                   !                                                          ! 2*masked bottom density gradient 
    411                   zgdrho = (  za * ( zts(ji,jj+1,jp_tem) - zts(ji,jj,jp_tem) )    & 
    412                      &      - zb * ( zts(ji,jj+1,jp_sal) - zts(ji,jj,jp_sal) )  ) * vmask(ji,jj,1) 
    413                   zsign = SIGN(  0.5, - zgdrho   * REAL( mgrhv(ji,jj) )  )   ! sign of j-gradient * j-slope 
    414                   zsigna= SIGN(  0.5, zvb(ji,jj) * REAL( mgrhv(ji,jj) )  )   ! sign of u * i-slope 
    415                   ! 
    416                   !                                                          ! bbl transport 
    417                   vtr_bbl(ji,jj) = ( 0.5 + zsigna ) * ( 0.5 - zsign ) * e1v(ji,jj) * e3v_bbl_0(ji,jj) * zvb(ji,jj) 
    418                END DO 
    419             END DO 
     389            DO_2D_10_10 
     390               !                                                  ! i-direction 
     391               za = zab(ji+1,jj,jp_tem) + zab(ji,jj,jp_tem)               ! 2*(alpha,beta) at u-point 
     392               zb = zab(ji+1,jj,jp_sal) + zab(ji,jj,jp_sal) 
     393               !                                                          ! 2*masked bottom density gradient  
     394               zgdrho = (  za * ( zts(ji+1,jj,jp_tem) - zts(ji,jj,jp_tem) )    & 
     395                         - zb * ( zts(ji+1,jj,jp_sal) - zts(ji,jj,jp_sal) )  ) * umask(ji,jj,1) 
     396               ! 
     397               zsign = SIGN(  0.5, - zgdrho   * REAL( mgrhu(ji,jj) )  )   ! sign of i-gradient * i-slope 
     398               zsigna= SIGN(  0.5, zub(ji,jj) * REAL( mgrhu(ji,jj) )  )   ! sign of u * i-slope 
     399               ! 
     400               !                                                          ! bbl velocity 
     401               utr_bbl(ji,jj) = ( 0.5 + zsigna ) * ( 0.5 - zsign ) * e2u(ji,jj) * e3u_bbl_0(ji,jj) * zub(ji,jj) 
     402               ! 
     403               !                                                  ! j-direction 
     404               za = zab(ji,jj+1,jp_tem) + zab(ji,jj,jp_tem)               ! 2*(alpha,beta) at v-point 
     405               zb = zab(ji,jj+1,jp_sal) + zab(ji,jj,jp_sal) 
     406               !                                                          ! 2*masked bottom density gradient 
     407               zgdrho = (  za * ( zts(ji,jj+1,jp_tem) - zts(ji,jj,jp_tem) )    & 
     408                  &      - zb * ( zts(ji,jj+1,jp_sal) - zts(ji,jj,jp_sal) )  ) * vmask(ji,jj,1) 
     409               zsign = SIGN(  0.5, - zgdrho   * REAL( mgrhv(ji,jj) )  )   ! sign of j-gradient * j-slope 
     410               zsigna= SIGN(  0.5, zvb(ji,jj) * REAL( mgrhv(ji,jj) )  )   ! sign of u * i-slope 
     411               ! 
     412               !                                                          ! bbl transport 
     413               vtr_bbl(ji,jj) = ( 0.5 + zsigna ) * ( 0.5 - zsign ) * e1v(ji,jj) * e3v_bbl_0(ji,jj) * zvb(ji,jj) 
     414            END_2D 
    420415            ! 
    421416         CASE( 2 )                                 != bbl velocity = F( delta rho ) 
    422417            zgbbl = grav * rn_gambbl 
    423             DO jj = 1, jpjm1                            ! criteria: rho_up > rho_down 
    424                DO ji = 1, fs_jpim1   ! vector opt. 
    425                   !                                                  ! i-direction 
    426                   ! down-slope T-point i/k-index (deep)  &   up-slope T-point i/k-index (shelf) 
    427                   iid  = ji + MAX( 0, mgrhu(ji,jj) ) 
    428                   iis  = ji + 1 - MAX( 0, mgrhu(ji,jj) ) 
    429                   ! 
    430                   ikud = mbku_d(ji,jj) 
    431                   ikus = mbku(ji,jj) 
    432                   ! 
    433                   za = zab(ji+1,jj,jp_tem) + zab(ji,jj,jp_tem)               ! 2*(alpha,beta) at u-point 
    434                   zb = zab(ji+1,jj,jp_sal) + zab(ji,jj,jp_sal) 
    435                   !                                                          !   masked bottom density gradient 
    436                   zgdrho = 0.5 * (  za * ( zts(iid,jj,jp_tem) - zts(iis,jj,jp_tem) )    & 
    437                      &            - zb * ( zts(iid,jj,jp_sal) - zts(iis,jj,jp_sal) )  ) * umask(ji,jj,1) 
    438                   zgdrho = MAX( 0.e0, zgdrho )                               ! only if shelf is denser than deep 
    439                   ! 
    440                   !                                                          ! bbl transport (down-slope direction) 
    441                   utr_bbl(ji,jj) = e2u(ji,jj) * e3u_bbl_0(ji,jj) * zgbbl * zgdrho * REAL( mgrhu(ji,jj) ) 
    442                   ! 
    443                   !                                                  ! j-direction 
    444                   !  down-slope T-point j/k-index (deep)  &   of the up  -slope T-point j/k-index (shelf) 
    445                   ijd  = jj + MAX( 0, mgrhv(ji,jj) ) 
    446                   ijs  = jj + 1 - MAX( 0, mgrhv(ji,jj) ) 
    447                   ! 
    448                   ikvd = mbkv_d(ji,jj) 
    449                   ikvs = mbkv(ji,jj) 
    450                   ! 
    451                   za = zab(ji,jj+1,jp_tem) + zab(ji,jj,jp_tem)               ! 2*(alpha,beta) at v-point 
    452                   zb = zab(ji,jj+1,jp_sal) + zab(ji,jj,jp_sal) 
    453                   !                                                          !   masked bottom density gradient 
    454                   zgdrho = 0.5 * (  za * ( zts(ji,ijd,jp_tem) - zts(ji,ijs,jp_tem) )    & 
    455                      &            - zb * ( zts(ji,ijd,jp_sal) - zts(ji,ijs,jp_sal) )  ) * vmask(ji,jj,1) 
    456                   zgdrho = MAX( 0.e0, zgdrho )                               ! only if shelf is denser than deep 
    457                   ! 
    458                   !                                                          ! bbl transport (down-slope direction) 
    459                   vtr_bbl(ji,jj) = e1v(ji,jj) * e3v_bbl_0(ji,jj) * zgbbl * zgdrho * REAL( mgrhv(ji,jj) ) 
    460                END DO 
    461             END DO 
     418            DO_2D_10_10 
     419               !                                                  ! i-direction 
     420               ! down-slope T-point i/k-index (deep)  &   up-slope T-point i/k-index (shelf) 
     421               iid  = ji + MAX( 0, mgrhu(ji,jj) ) 
     422               iis  = ji + 1 - MAX( 0, mgrhu(ji,jj) ) 
     423               ! 
     424               ikud = mbku_d(ji,jj) 
     425               ikus = mbku(ji,jj) 
     426               ! 
     427               za = zab(ji+1,jj,jp_tem) + zab(ji,jj,jp_tem)               ! 2*(alpha,beta) at u-point 
     428               zb = zab(ji+1,jj,jp_sal) + zab(ji,jj,jp_sal) 
     429               !                                                          !   masked bottom density gradient 
     430               zgdrho = 0.5 * (  za * ( zts(iid,jj,jp_tem) - zts(iis,jj,jp_tem) )    & 
     431                  &            - zb * ( zts(iid,jj,jp_sal) - zts(iis,jj,jp_sal) )  ) * umask(ji,jj,1) 
     432               zgdrho = MAX( 0.e0, zgdrho )                               ! only if shelf is denser than deep 
     433               ! 
     434               !                                                          ! bbl transport (down-slope direction) 
     435               utr_bbl(ji,jj) = e2u(ji,jj) * e3u_bbl_0(ji,jj) * zgbbl * zgdrho * REAL( mgrhu(ji,jj) ) 
     436               ! 
     437               !                                                  ! j-direction 
     438               !  down-slope T-point j/k-index (deep)  &   of the up  -slope T-point j/k-index (shelf) 
     439               ijd  = jj + MAX( 0, mgrhv(ji,jj) ) 
     440               ijs  = jj + 1 - MAX( 0, mgrhv(ji,jj) ) 
     441               ! 
     442               ikvd = mbkv_d(ji,jj) 
     443               ikvs = mbkv(ji,jj) 
     444               ! 
     445               za = zab(ji,jj+1,jp_tem) + zab(ji,jj,jp_tem)               ! 2*(alpha,beta) at v-point 
     446               zb = zab(ji,jj+1,jp_sal) + zab(ji,jj,jp_sal) 
     447               !                                                          !   masked bottom density gradient 
     448               zgdrho = 0.5 * (  za * ( zts(ji,ijd,jp_tem) - zts(ji,ijs,jp_tem) )    & 
     449                  &            - zb * ( zts(ji,ijd,jp_sal) - zts(ji,ijs,jp_sal) )  ) * vmask(ji,jj,1) 
     450               zgdrho = MAX( 0.e0, zgdrho )                               ! only if shelf is denser than deep 
     451               ! 
     452               !                                                          ! bbl transport (down-slope direction) 
     453               vtr_bbl(ji,jj) = e1v(ji,jj) * e3v_bbl_0(ji,jj) * zgbbl * zgdrho * REAL( mgrhv(ji,jj) ) 
     454            END_2D 
    462455         END SELECT 
    463456         ! 
    … …  
    483476      !!---------------------------------------------------------------------- 
    484477      ! 
    485       REWIND( numnam_ref )              ! Namelist nambbl in reference namelist : Bottom boundary layer scheme 
    486478      READ  ( numnam_ref, nambbl, IOSTAT = ios, ERR = 901) 
    487479901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nambbl in reference namelist' ) 
    488480      ! 
    489       REWIND( numnam_cfg )              ! Namelist nambbl in configuration namelist : Bottom boundary layer scheme 
    490481      READ  ( numnam_cfg, nambbl, IOSTAT = ios, ERR = 902 ) 
    491482902   IF( ios >  0 )   CALL ctl_nam ( ios , 'nambbl in configuration namelist' ) 
    … …  
    517508      ! 
    518509      !                             !* vertical index of  "deep" bottom u- and v-points 
    519       DO jj = 1, jpjm1                    ! (the "shelf" bottom k-indices are mbku and mbkv) 
    520          DO ji = 1, jpim1 
    521             mbku_d(ji,jj) = MAX(  mbkt(ji+1,jj  ) , mbkt(ji,jj)  )   ! >= 1 as mbkt=1 over land 
    522             mbkv_d(ji,jj) = MAX(  mbkt(ji  ,jj+1) , mbkt(ji,jj)  ) 
    523          END DO 
    524       END DO 
     510      DO_2D_10_10 
     511         mbku_d(ji,jj) = MAX(  mbkt(ji+1,jj  ) , mbkt(ji,jj)  )   ! >= 1 as mbkt=1 over land 
     512         mbkv_d(ji,jj) = MAX(  mbkt(ji  ,jj+1) , mbkt(ji,jj)  ) 
     513      END_2D 
    525514      ! converte into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk 
    526515      zmbku(:,:) = REAL( mbku_d(:,:), wp )   ;     zmbkv(:,:) = REAL( mbkv_d(:,:), wp )   
    … …  
    530519      !                             !* sign of grad(H) at u- and v-points; zero if grad(H) = 0 
    531520      mgrhu(:,:) = 0   ;   mgrhv(:,:) = 0 
    532       DO jj = 1, jpjm1 
    533          DO ji = 1, jpim1 
    534             IF( gdept_0(ji+1,jj,mbkt(ji+1,jj)) - gdept_0(ji,jj,mbkt(ji,jj)) /= 0._wp ) THEN 
    535                mgrhu(ji,jj) = INT(  SIGN( 1.e0, gdept_0(ji+1,jj,mbkt(ji+1,jj)) - gdept_0(ji,jj,mbkt(ji,jj)) )  ) 
    536             ENDIF 
    537             ! 
    538             IF( gdept_0(ji,jj+1,mbkt(ji,jj+1)) - gdept_0(ji,jj,mbkt(ji,jj)) /= 0._wp ) THEN 
    539                mgrhv(ji,jj) = INT(  SIGN( 1.e0, gdept_0(ji,jj+1,mbkt(ji,jj+1)) - gdept_0(ji,jj,mbkt(ji,jj)) )  ) 
    540             ENDIF 
    541          END DO 
    542       END DO 
    543       ! 
    544       DO jj = 1, jpjm1              !* bbl thickness at u- (v-) point 
    545          DO ji = 1, jpim1                 ! minimum of top & bottom e3u_0 (e3v_0) 
    546             e3u_bbl_0(ji,jj) = MIN( e3u_0(ji,jj,mbkt(ji+1,jj  )), e3u_0(ji,jj,mbkt(ji,jj)) ) 
    547             e3v_bbl_0(ji,jj) = MIN( e3v_0(ji,jj,mbkt(ji  ,jj+1)), e3v_0(ji,jj,mbkt(ji,jj)) ) 
    548          END DO 
    549       END DO 
     521      DO_2D_10_10 
     522         IF( gdept_0(ji+1,jj,mbkt(ji+1,jj)) - gdept_0(ji,jj,mbkt(ji,jj)) /= 0._wp ) THEN 
     523            mgrhu(ji,jj) = INT(  SIGN( 1.e0, gdept_0(ji+1,jj,mbkt(ji+1,jj)) - gdept_0(ji,jj,mbkt(ji,jj)) )  ) 
     524         ENDIF 
     525         ! 
     526         IF( gdept_0(ji,jj+1,mbkt(ji,jj+1)) - gdept_0(ji,jj,mbkt(ji,jj)) /= 0._wp ) THEN 
     527            mgrhv(ji,jj) = INT(  SIGN( 1.e0, gdept_0(ji,jj+1,mbkt(ji,jj+1)) - gdept_0(ji,jj,mbkt(ji,jj)) )  ) 
     528         ENDIF 
     529      END_2D 
     530      ! 
     531      DO_2D_10_10 
     532         e3u_bbl_0(ji,jj) = MIN( e3u_0(ji,jj,mbkt(ji+1,jj  )), e3u_0(ji,jj,mbkt(ji,jj)) ) 
     533         e3v_bbl_0(ji,jj) = MIN( e3v_0(ji,jj,mbkt(ji  ,jj+1)), e3v_0(ji,jj,mbkt(ji,jj)) ) 
     534      END_2D 
    550535      CALL lbc_lnk_multi( 'trabbl', e3u_bbl_0, 'U', 1. , e3v_bbl_0, 'V', 1. )      ! lateral boundary conditions 
    551536      ! 

  • NEMO/trunk/src/OCE/TRA/tradmp.F90

    r11536 r12377  
    5252 
    5353   !! * Substitutions 
    54 #  include "vectopt_loop_substitute.h90" 
     54#  include "do_loop_substitute.h90" 
    5555   !!---------------------------------------------------------------------- 
    5656   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    7272 
    7373 
    74    SUBROUTINE tra_dmp( kt ) 
     74   SUBROUTINE tra_dmp( kt, Kbb, Kmm, pts, Krhs ) 
    7575      !!---------------------------------------------------------------------- 
    7676      !!                   ***  ROUTINE tra_dmp  *** 
    … …  
    9090      !! ** Action  : - tsa: tracer trends updated with the damping trend 
    9191      !!---------------------------------------------------------------------- 
    92       INTEGER, INTENT(in) ::   kt   ! ocean time-step index 
     92      INTEGER,                                   INTENT(in   ) :: kt              ! ocean time-step index 
     93      INTEGER,                                   INTENT(in   ) :: Kbb, Kmm, Krhs  ! time level indices 
     94      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts             ! active tracers and RHS of tracer equation 
    9395      ! 
    9496      INTEGER ::   ji, jj, jk, jn   ! dummy loop indices 
    … …  
    101103      IF( l_trdtra )   THEN                    !* Save ta and sa trends 
    102104         ALLOCATE( ztrdts(jpi,jpj,jpk,jpts) )  
    103          ztrdts(:,:,:,:) = tsa(:,:,:,:)  
     105         ztrdts(:,:,:,:) = pts(:,:,:,:,Krhs)  
    104106      ENDIF 
    105107      !                           !==  input T-S data at kt  ==! 
    … …  
    110112      CASE( 0 )                        !*  newtonian damping throughout the water column  *! 
    111113         DO jn = 1, jpts 
    112             DO jk = 1, jpkm1 
    113                DO jj = 2, jpjm1 
    114                   DO ji = fs_2, fs_jpim1   ! vector opt. 
    115                      tsa(ji,jj,jk,jn) = tsa(ji,jj,jk,jn) + resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jn) - tsb(ji,jj,jk,jn) ) 
    116                   END DO 
    117                END DO 
    118             END DO 
     114            DO_3D_00_00( 1, jpkm1 ) 
     115               pts(ji,jj,jk,jn,Krhs) = pts(ji,jj,jk,jn,Krhs)           & 
     116                  &                  + resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jn) - pts(ji,jj,jk,jn,Kbb) ) 
     117            END_3D 
    119118         END DO 
    120119         ! 
    121120      CASE ( 1 )                       !*  no damping in the turbocline (avt > 5 cm2/s)  *! 
    122          DO jk = 1, jpkm1 
    123             DO jj = 2, jpjm1 
    124                DO ji = fs_2, fs_jpim1   ! vector opt. 
    125                   IF( avt(ji,jj,jk) <= avt_c ) THEN 
    126                      tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem)   & 
    127                         &                 + resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jp_tem) - tsb(ji,jj,jk,jp_tem) ) 
    128                      tsa(ji,jj,jk,jp_sal) = tsa(ji,jj,jk,jp_sal)   & 
    129                         &                 + resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jp_sal) - tsb(ji,jj,jk,jp_sal) ) 
    130                   ENDIF 
    131                END DO 
    132             END DO 
    133          END DO 
     121         DO_3D_00_00( 1, jpkm1 ) 
     122            IF( avt(ji,jj,jk) <= avt_c ) THEN 
     123               pts(ji,jj,jk,jp_tem,Krhs) = pts(ji,jj,jk,jp_tem,Krhs)   & 
     124                  &                      + resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jp_tem) - pts(ji,jj,jk,jp_tem,Kbb) ) 
     125               pts(ji,jj,jk,jp_sal,Krhs) = pts(ji,jj,jk,jp_sal,Krhs)   & 
     126                  &                      + resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jp_sal) - pts(ji,jj,jk,jp_sal,Kbb) ) 
     127            ENDIF 
     128         END_3D 
    134129         ! 
    135130      CASE ( 2 )                       !*  no damping in the mixed layer   *! 
    136          DO jk = 1, jpkm1 
    137             DO jj = 2, jpjm1 
    138                DO ji = fs_2, fs_jpim1   ! vector opt. 
    139                   IF( gdept_n(ji,jj,jk) >= hmlp (ji,jj) ) THEN 
    140                      tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem)   & 
    141                         &                 + resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jp_tem) - tsb(ji,jj,jk,jp_tem) ) 
    142                      tsa(ji,jj,jk,jp_sal) = tsa(ji,jj,jk,jp_sal)   & 
    143                         &                 + resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jp_sal) - tsb(ji,jj,jk,jp_sal) ) 
    144                   ENDIF 
    145                END DO 
    146             END DO 
    147          END DO 
     131         DO_3D_00_00( 1, jpkm1 ) 
     132            IF( gdept(ji,jj,jk,Kmm) >= hmlp (ji,jj) ) THEN 
     133               pts(ji,jj,jk,jp_tem,Krhs) = pts(ji,jj,jk,jp_tem,Krhs)   & 
     134                  &                      + resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jp_tem) - pts(ji,jj,jk,jp_tem,Kbb) ) 
     135               pts(ji,jj,jk,jp_sal,Krhs) = pts(ji,jj,jk,jp_sal,Krhs)   & 
     136                  &                      + resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jp_sal) - pts(ji,jj,jk,jp_sal,Kbb) ) 
     137            ENDIF 
     138         END_3D 
    148139         ! 
    149140      END SELECT 
    150141      ! 
    151142      IF( l_trdtra )   THEN       ! trend diagnostic 
    152          ztrdts(:,:,:,:) = tsa(:,:,:,:) - ztrdts(:,:,:,:) 
    153          CALL trd_tra( kt, 'TRA', jp_tem, jptra_dmp, ztrdts(:,:,:,jp_tem) ) 
    154          CALL trd_tra( kt, 'TRA', jp_sal, jptra_dmp, ztrdts(:,:,:,jp_sal) ) 
     143         ztrdts(:,:,:,:) = pts(:,:,:,:,Krhs) - ztrdts(:,:,:,:) 
     144         CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_dmp, ztrdts(:,:,:,jp_tem) ) 
     145         CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_sal, jptra_dmp, ztrdts(:,:,:,jp_sal) ) 
    155146         DEALLOCATE( ztrdts )  
    156147      ENDIF 
    157148      !                           ! Control print 
    158       IF(ln_ctl)   CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' dmp  - Ta: ', mask1=tmask,   & 
    159          &                       tab3d_2=tsa(:,:,:,jp_sal), clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
     149      IF(sn_cfctl%l_prtctl)   CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' dmp  - Ta: ', mask1=tmask,   & 
     150         &                                  tab3d_2=pts(:,:,:,jp_sal,Krhs), clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
    160151      ! 
    161152      IF( ln_timing )   CALL timing_stop('tra_dmp') 
    … …  
    177168      !!---------------------------------------------------------------------- 
    178169      ! 
    179       REWIND( numnam_ref )   ! Namelist namtra_dmp in reference namelist : T & S relaxation 
    180170      READ  ( numnam_ref, namtra_dmp, IOSTAT = ios, ERR = 901) 
    181171901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namtra_dmp in reference namelist' ) 
    182172      ! 
    183       REWIND( numnam_cfg )   ! Namelist namtra_dmp in configuration namelist : T & S relaxation 
    184173      READ  ( numnam_cfg, namtra_dmp, IOSTAT = ios, ERR = 902 ) 
    185174902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namtra_dmp in configuration namelist' ) 

  • NEMO/trunk/src/OCE/TRA/traldf.F90

    r10068 r12377  
    3838   PUBLIC   tra_ldf_init   ! called by nemogcm.F90  
    3939    
    40    !! * Substitutions 
    41 #  include "vectopt_loop_substitute.h90" 
    4240   !!---------------------------------------------------------------------- 
    4341   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    4745CONTAINS 
    4846 
    49    SUBROUTINE tra_ldf( kt ) 
     47   SUBROUTINE tra_ldf( kt, Kbb, Kmm, pts, Krhs ) 
    5048      !!---------------------------------------------------------------------- 
    5149      !!                  ***  ROUTINE tra_ldf  *** 
    … …  
    5351      !! ** Purpose :   compute the lateral ocean tracer physics. 
    5452      !!---------------------------------------------------------------------- 
    55       INTEGER, INTENT( in ) ::   kt   ! ocean time-step index 
     53      INTEGER,                                   INTENT(in   ) :: kt              ! ocean time-step index 
     54      INTEGER,                                   INTENT(in   ) :: Kbb, Kmm, Krhs  ! ocean time level indices 
     55      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts             ! active tracers and RHS of tracer equation 
    5656      !! 
    5757      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   ztrdt, ztrds 
    … …  
    6262      IF( l_trdtra )   THEN                    !* Save ta and sa trends 
    6363         ALLOCATE( ztrdt(jpi,jpj,jpk) , ztrds(jpi,jpj,jpk) )  
    64          ztrdt(:,:,:) = tsa(:,:,:,jp_tem)  
    65          ztrds(:,:,:) = tsa(:,:,:,jp_sal) 
     64         ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs)  
     65         ztrds(:,:,:) = pts(:,:,:,jp_sal,Krhs) 
    6666      ENDIF 
    6767      ! 
    6868      SELECT CASE ( nldf_tra )                 !* compute lateral mixing trend and add it to the general trend 
    6969      CASE ( np_lap   )                                  ! laplacian: iso-level operator 
    70          CALL tra_ldf_lap  ( kt, nit000,'TRA', ahtu, ahtv, gtsu, gtsv, gtui, gtvi, tsb,      tsa, jpts,  1  ) 
     70         CALL tra_ldf_lap  ( kt, Kmm, nit000,'TRA', ahtu, ahtv, gtsu, gtsv, gtui, gtvi, pts(:,:,:,:,Kbb), pts(:,:,:,:,Krhs),                   jpts,  1 ) 
    7171      CASE ( np_lap_i )                                  ! laplacian: standard iso-neutral operator (Madec) 
    72          CALL tra_ldf_iso  ( kt, nit000,'TRA', ahtu, ahtv, gtsu, gtsv, gtui, gtvi, tsb, tsb, tsa, jpts,  1  ) 
     72         CALL tra_ldf_iso  ( kt, Kmm, nit000,'TRA', ahtu, ahtv, gtsu, gtsv, gtui, gtvi, pts(:,:,:,:,Kbb), pts(:,:,:,:,Kbb), pts(:,:,:,:,Krhs), jpts,  1 ) 
    7373      CASE ( np_lap_it )                                 ! laplacian: triad iso-neutral operator (griffies) 
    74          CALL tra_ldf_triad( kt, nit000,'TRA', ahtu, ahtv, gtsu, gtsv, gtui, gtvi, tsb, tsb, tsa, jpts,  1  ) 
     74         CALL tra_ldf_triad( kt, Kmm, nit000,'TRA', ahtu, ahtv, gtsu, gtsv, gtui, gtvi, pts(:,:,:,:,Kbb), pts(:,:,:,:,Kbb), pts(:,:,:,:,Krhs), jpts,  1 ) 
    7575      CASE ( np_blp , np_blp_i , np_blp_it )             ! bilaplacian: iso-level & iso-neutral operators 
    76          CALL tra_ldf_blp  ( kt, nit000,'TRA', ahtu, ahtv, gtsu, gtsv, gtui, gtvi, tsb      , tsa, jpts, nldf_tra ) 
     76         CALL tra_ldf_blp  ( kt, Kmm, nit000,'TRA', ahtu, ahtv, gtsu, gtsv, gtui, gtvi, pts(:,:,:,:,Kbb), pts(:,:,:,:,Krhs),            jpts, nldf_tra ) 
    7777      END SELECT 
    7878      ! 
    7979      IF( l_trdtra )   THEN                    !* save the horizontal diffusive trends for further diagnostics 
    80          ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) 
    81          ztrds(:,:,:) = tsa(:,:,:,jp_sal) - ztrds(:,:,:) 
    82          CALL trd_tra( kt, 'TRA', jp_tem, jptra_ldf, ztrdt ) 
    83          CALL trd_tra( kt, 'TRA', jp_sal, jptra_ldf, ztrds ) 
     80         ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) - ztrdt(:,:,:) 
     81         ztrds(:,:,:) = pts(:,:,:,jp_sal,Krhs) - ztrds(:,:,:) 
     82         CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_ldf, ztrdt ) 
     83         CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_sal, jptra_ldf, ztrds ) 
    8484         DEALLOCATE( ztrdt, ztrds )  
    8585      ENDIF 
    8686      !                                        !* print mean trends (used for debugging) 
    87       IF(ln_ctl)   CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' ldf  - Ta: ', mask1=tmask,               & 
    88          &                       tab3d_2=tsa(:,:,:,jp_sal), clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
     87      IF(sn_cfctl%l_prtctl)   CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' ldf  - Ta: ', mask1=tmask,               & 
     88         &                                  tab3d_2=pts(:,:,:,jp_sal,Krhs), clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
    8989      ! 
    9090      IF( ln_timing )   CALL timing_stop('tra_ldf') 

  • NEMO/trunk/src/OCE/TRA/traldf_iso.F90

    r11993 r12377  
    4040 
    4141   !! * Substitutions 
    42 #  include "vectopt_loop_substitute.h90" 
     42#  include "do_loop_substitute.h90" 
    4343   !!---------------------------------------------------------------------- 
    4444   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    4848CONTAINS 
    4949 
    50   SUBROUTINE tra_ldf_iso( kt, kit000, cdtype, pahu, pahv, pgu , pgv ,   & 
    51       &                                                   pgui, pgvi,   & 
    52       &                                       ptb , ptbb, pta , kjpt, kpass ) 
     50  SUBROUTINE tra_ldf_iso( kt, Kmm, kit000, cdtype, pahu, pahv,                    & 
     51      &                                            pgu , pgv    ,   pgui, pgvi,   & 
     52      &                                       pt , pt2 , pt_rhs , kjpt  , kpass ) 
    5353      !!---------------------------------------------------------------------- 
    5454      !!                  ***  ROUTINE tra_ldf_iso  *** 
    … …  
    8787      !!         difft = 1/(e1e2t*e3t) dk[ zftw ] 
    8888      !!      Add this trend to the general trend (ta,sa): 
    89       !!         pta = pta + difft 
    90       !! 
    91       !! ** Action :   Update pta arrays with the before rotated diffusion 
     89      !!         pt_rhs = pt_rhs + difft 
     90      !! 
     91      !! ** Action :   Update pt_rhs arrays with the before rotated diffusion 
    9292      !!---------------------------------------------------------------------- 
    9393      INTEGER                              , INTENT(in   ) ::   kt         ! ocean time-step index 
    … …  
    9696      INTEGER                              , INTENT(in   ) ::   kjpt       ! number of tracers 
    9797      INTEGER                              , INTENT(in   ) ::   kpass      ! =1/2 first or second passage 
     98      INTEGER                              , INTENT(in   ) ::   Kmm        ! ocean time level index 
    9899      REAL(wp), DIMENSION(jpi,jpj,jpk)     , INTENT(in   ) ::   pahu, pahv ! eddy diffusivity at u- and v-points  [m2/s] 
    99100      REAL(wp), DIMENSION(jpi,jpj    ,kjpt), INTENT(in   ) ::   pgu, pgv   ! tracer gradient at pstep levels 
    100101      REAL(wp), DIMENSION(jpi,jpj,    kjpt), INTENT(in   ) ::   pgui, pgvi ! tracer gradient at top   levels 
    101       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb        ! tracer (kpass=1) or laplacian of tracer (kpass=2) 
    102       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptbb       ! tracer (only used in kpass=2) 
    103       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta        ! tracer trend 
     102      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   pt         ! tracer (kpass=1) or laplacian of tracer (kpass=2) 
     103      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   pt2        ! tracer (only used in kpass=2) 
     104      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pt_rhs     ! tracer trend 
    104105      ! 
    105106      INTEGER  ::  ji, jj, jk, jn   ! dummy loop indices 
    … …  
    124125      l_hst = .FALSE. 
    125126      l_ptr = .FALSE. 
    126       IF( cdtype == 'TRA' .AND. ln_diaptr )                                                 l_ptr = .TRUE.  
     127      IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) ) )     l_ptr = .TRUE.  
    127128      IF( cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & 
    128129         &                        iom_use("uadv_salttr") .OR. iom_use("vadv_salttr")  ) )   l_hst = .TRUE. 
    … …  
    144145      IF( kpass == 1 ) THEN                  !==  first pass only  ==! 
    145146         ! 
    146          DO jk = 2, jpkm1 
    147             DO jj = 2, jpjm1 
    148                DO ji = fs_2, fs_jpim1   ! vector opt. 
    149                   ! 
    150                   zmsku = wmask(ji,jj,jk) / MAX(   umask(ji  ,jj,jk-1) + umask(ji-1,jj,jk)          & 
    151                      &                           + umask(ji-1,jj,jk-1) + umask(ji  ,jj,jk) , 1._wp  ) 
    152                   zmskv = wmask(ji,jj,jk) / MAX(   vmask(ji,jj  ,jk-1) + vmask(ji,jj-1,jk)          & 
    153                      &                           + vmask(ji,jj-1,jk-1) + vmask(ji,jj  ,jk) , 1._wp  ) 
    154                      ! 
    155                   zahu_w = (   pahu(ji  ,jj,jk-1) + pahu(ji-1,jj,jk)    & 
    156                      &       + pahu(ji-1,jj,jk-1) + pahu(ji  ,jj,jk)  ) * zmsku 
    157                   zahv_w = (   pahv(ji,jj  ,jk-1) + pahv(ji,jj-1,jk)    & 
    158                      &       + pahv(ji,jj-1,jk-1) + pahv(ji,jj  ,jk)  ) * zmskv 
    159                      ! 
    160                   ah_wslp2(ji,jj,jk) = zahu_w * wslpi(ji,jj,jk) * wslpi(ji,jj,jk)   & 
    161                      &               + zahv_w * wslpj(ji,jj,jk) * wslpj(ji,jj,jk) 
    162                END DO 
    163             END DO 
    164          END DO 
     147         DO_3D_00_00( 2, jpkm1 ) 
     148            ! 
     149            zmsku = wmask(ji,jj,jk) / MAX(   umask(ji  ,jj,jk-1) + umask(ji-1,jj,jk)          & 
     150               &                           + umask(ji-1,jj,jk-1) + umask(ji  ,jj,jk) , 1._wp  ) 
     151            zmskv = wmask(ji,jj,jk) / MAX(   vmask(ji,jj  ,jk-1) + vmask(ji,jj-1,jk)          & 
     152               &                           + vmask(ji,jj-1,jk-1) + vmask(ji,jj  ,jk) , 1._wp  ) 
     153               ! 
     154            zahu_w = (   pahu(ji  ,jj,jk-1) + pahu(ji-1,jj,jk)    & 
     155               &       + pahu(ji-1,jj,jk-1) + pahu(ji  ,jj,jk)  ) * zmsku 
     156            zahv_w = (   pahv(ji,jj  ,jk-1) + pahv(ji,jj-1,jk)    & 
     157               &       + pahv(ji,jj-1,jk-1) + pahv(ji,jj  ,jk)  ) * zmskv 
     158               ! 
     159            ah_wslp2(ji,jj,jk) = zahu_w * wslpi(ji,jj,jk) * wslpi(ji,jj,jk)   & 
     160               &               + zahv_w * wslpj(ji,jj,jk) * wslpj(ji,jj,jk) 
     161         END_3D 
    165162         ! 
    166163         IF( ln_traldf_msc ) THEN                ! stabilizing vertical diffusivity coefficient 
    167             DO jk = 2, jpkm1 
    168                DO jj = 2, jpjm1 
    169                   DO ji = fs_2, fs_jpim1 
    170                      akz(ji,jj,jk) = 0.25_wp * (                                                                     & 
    171                         &              ( pahu(ji  ,jj,jk) + pahu(ji  ,jj,jk-1) ) / ( e1u(ji  ,jj) * e1u(ji  ,jj) )   & 
    172                         &            + ( pahu(ji-1,jj,jk) + pahu(ji-1,jj,jk-1) ) / ( e1u(ji-1,jj) * e1u(ji-1,jj) )   & 
    173                         &            + ( pahv(ji,jj  ,jk) + pahv(ji,jj  ,jk-1) ) / ( e2v(ji,jj  ) * e2v(ji,jj  ) )   & 
    174                         &            + ( pahv(ji,jj-1,jk) + pahv(ji,jj-1,jk-1) ) / ( e2v(ji,jj-1) * e2v(ji,jj-1) )   ) 
    175                   END DO 
    176                END DO 
    177             END DO 
     164            DO_3D_00_00( 2, jpkm1 ) 
     165               akz(ji,jj,jk) = 0.25_wp * (                                                                     & 
     166                  &              ( pahu(ji  ,jj,jk) + pahu(ji  ,jj,jk-1) ) / ( e1u(ji  ,jj) * e1u(ji  ,jj) )   & 
     167                  &            + ( pahu(ji-1,jj,jk) + pahu(ji-1,jj,jk-1) ) / ( e1u(ji-1,jj) * e1u(ji-1,jj) )   & 
     168                  &            + ( pahv(ji,jj  ,jk) + pahv(ji,jj  ,jk-1) ) / ( e2v(ji,jj  ) * e2v(ji,jj  ) )   & 
     169                  &            + ( pahv(ji,jj-1,jk) + pahv(ji,jj-1,jk-1) ) / ( e2v(ji,jj-1) * e2v(ji,jj-1) )   ) 
     170            END_3D 
    178171            ! 
    179172            IF( ln_traldf_blp ) THEN                ! bilaplacian operator 
    180                DO jk = 2, jpkm1 
    181                   DO jj = 1, jpjm1 
    182                      DO ji = 1, fs_jpim1 
    183                         akz(ji,jj,jk) = 16._wp * ah_wslp2(ji,jj,jk)   & 
    184                            &          * (  akz(ji,jj,jk) + ah_wslp2(ji,jj,jk) / ( e3w_n(ji,jj,jk) * e3w_n(ji,jj,jk) )  ) 
    185                      END DO 
    186                   END DO 
    187                END DO 
     173               DO_3D_10_10( 2, jpkm1 ) 
     174                  akz(ji,jj,jk) = 16._wp * ah_wslp2(ji,jj,jk)   & 
     175                     &          * (  akz(ji,jj,jk) + ah_wslp2(ji,jj,jk) / ( e3w(ji,jj,jk,Kmm) * e3w(ji,jj,jk,Kmm) )  ) 
     176               END_3D 
    188177            ELSEIF( ln_traldf_lap ) THEN              ! laplacian operator 
    189                DO jk = 2, jpkm1 
    190                   DO jj = 1, jpjm1 
    191                      DO ji = 1, fs_jpim1 
    192                         ze3w_2 = e3w_n(ji,jj,jk) * e3w_n(ji,jj,jk) 
    193                         zcoef0 = z2dt * (  akz(ji,jj,jk) + ah_wslp2(ji,jj,jk) / ze3w_2  ) 
    194                         akz(ji,jj,jk) = MAX( zcoef0 - 0.5_wp , 0._wp ) * ze3w_2 * z1_2dt 
    195                      END DO 
    196                   END DO 
    197                END DO 
     178               DO_3D_10_10( 2, jpkm1 ) 
     179                  ze3w_2 = e3w(ji,jj,jk,Kmm) * e3w(ji,jj,jk,Kmm) 
     180                  zcoef0 = z2dt * (  akz(ji,jj,jk) + ah_wslp2(ji,jj,jk) / ze3w_2  ) 
     181                  akz(ji,jj,jk) = MAX( zcoef0 - 0.5_wp , 0._wp ) * ze3w_2 * z1_2dt 
     182               END_3D 
    198183           ENDIF 
    199184           ! 
    … …  
    216201 
    217202         ! Horizontal tracer gradient  
    218          DO jk = 1, jpkm1 
    219             DO jj = 1, jpjm1 
    220                DO ji = 1, fs_jpim1   ! vector opt. 
    221                   zdit(ji,jj,jk) = ( ptb(ji+1,jj  ,jk,jn) - ptb(ji,jj,jk,jn) ) * umask(ji,jj,jk) 
    222                   zdjt(ji,jj,jk) = ( ptb(ji  ,jj+1,jk,jn) - ptb(ji,jj,jk,jn) ) * vmask(ji,jj,jk) 
    223                END DO 
    224             END DO 
    225          END DO 
     203         DO_3D_10_10( 1, jpkm1 ) 
     204            zdit(ji,jj,jk) = ( pt(ji+1,jj  ,jk,jn) - pt(ji,jj,jk,jn) ) * umask(ji,jj,jk) 
     205            zdjt(ji,jj,jk) = ( pt(ji  ,jj+1,jk,jn) - pt(ji,jj,jk,jn) ) * vmask(ji,jj,jk) 
     206         END_3D 
    226207         IF( ln_zps ) THEN      ! botton and surface ocean correction of the horizontal gradient 
    227             DO jj = 1, jpjm1              ! bottom correction (partial bottom cell) 
    228                DO ji = 1, fs_jpim1   ! vector opt. 
    229                   zdit(ji,jj,mbku(ji,jj)) = pgu(ji,jj,jn)           
    230                   zdjt(ji,jj,mbkv(ji,jj)) = pgv(ji,jj,jn) 
    231                END DO 
    232             END DO 
     208            DO_2D_10_10 
     209               zdit(ji,jj,mbku(ji,jj)) = pgu(ji,jj,jn)           
     210               zdjt(ji,jj,mbkv(ji,jj)) = pgv(ji,jj,jn) 
     211            END_2D 
    233212            IF( ln_isfcav ) THEN      ! first wet level beneath a cavity 
    234                DO jj = 1, jpjm1 
    235                   DO ji = 1, fs_jpim1   ! vector opt. 
    236                      IF( miku(ji,jj) > 1 )   zdit(ji,jj,miku(ji,jj)) = pgui(ji,jj,jn)           
    237                      IF( mikv(ji,jj) > 1 )   zdjt(ji,jj,mikv(ji,jj)) = pgvi(ji,jj,jn)      
    238                   END DO 
    239                END DO 
     213               DO_2D_10_10 
     214                  IF( miku(ji,jj) > 1 )   zdit(ji,jj,miku(ji,jj)) = pgui(ji,jj,jn)           
     215                  IF( mikv(ji,jj) > 1 )   zdjt(ji,jj,mikv(ji,jj)) = pgvi(ji,jj,jn)      
     216               END_2D 
    240217            ENDIF 
    241218         ENDIF 
    … …  
    248225            ! 
    249226            !                             !== Vertical tracer gradient 
    250             zdk1t(:,:) = ( ptb(:,:,jk,jn) - ptb(:,:,jk+1,jn) ) * wmask(:,:,jk+1)     ! level jk+1 
     227            zdk1t(:,:) = ( pt(:,:,jk,jn) - pt(:,:,jk+1,jn) ) * wmask(:,:,jk+1)     ! level jk+1 
    251228            ! 
    252229            IF( jk == 1 ) THEN   ;   zdkt(:,:) = zdk1t(:,:)                          ! surface: zdkt(jk=1)=zdkt(jk=2) 
    253             ELSE                 ;   zdkt(:,:) = ( ptb(:,:,jk-1,jn) - ptb(:,:,jk,jn) ) * wmask(:,:,jk) 
     230            ELSE                 ;   zdkt(:,:) = ( pt(:,:,jk-1,jn) - pt(:,:,jk,jn) ) * wmask(:,:,jk) 
    254231            ENDIF 
    255             DO jj = 1 , jpjm1            !==  Horizontal fluxes 
    256                DO ji = 1, fs_jpim1   ! vector opt. 
    257                   zabe1 = pahu(ji,jj,jk) * e2_e1u(ji,jj) * e3u_n(ji,jj,jk) 
    258                   zabe2 = pahv(ji,jj,jk) * e1_e2v(ji,jj) * e3v_n(ji,jj,jk) 
    259                   ! 
    260                   zmsku = 1. / MAX(  wmask(ji+1,jj,jk  ) + wmask(ji,jj,jk+1)   & 
    261                      &             + wmask(ji+1,jj,jk+1) + wmask(ji,jj,jk  ), 1. ) 
    262                   ! 
    263                   zmskv = 1. / MAX(  wmask(ji,jj+1,jk  ) + wmask(ji,jj,jk+1)   & 
    264                      &             + wmask(ji,jj+1,jk+1) + wmask(ji,jj,jk  ), 1. ) 
    265                   ! 
    266                   zcof1 = - pahu(ji,jj,jk) * e2u(ji,jj) * uslp(ji,jj,jk) * zmsku 
    267                   zcof2 = - pahv(ji,jj,jk) * e1v(ji,jj) * vslp(ji,jj,jk) * zmskv 
    268                   ! 
    269                   zftu(ji,jj,jk ) = (  zabe1 * zdit(ji,jj,jk)   & 
    270                      &               + zcof1 * (  zdkt (ji+1,jj) + zdk1t(ji,jj)      & 
    271                      &                          + zdk1t(ji+1,jj) + zdkt (ji,jj)  )  ) * umask(ji,jj,jk) 
    272                   zftv(ji,jj,jk) = (  zabe2 * zdjt(ji,jj,jk)   & 
    273                      &               + zcof2 * (  zdkt (ji,jj+1) + zdk1t(ji,jj)      & 
    274                      &                          + zdk1t(ji,jj+1) + zdkt (ji,jj)  )  ) * vmask(ji,jj,jk)                   
    275                END DO 
    276             END DO 
    277             ! 
    278             DO jj = 2 , jpjm1          !== horizontal divergence and add to pta 
    279                DO ji = fs_2, fs_jpim1   ! vector opt. 
    280                   pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + zsign * (  zftu(ji,jj,jk) - zftu(ji-1,jj,jk)      & 
    281                      &                                           + zftv(ji,jj,jk) - zftv(ji,jj-1,jk)  )   & 
    282                      &                                        * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) 
    283                END DO 
    284             END DO 
     232            DO_2D_10_10 
     233               zabe1 = pahu(ji,jj,jk) * e2_e1u(ji,jj) * e3u(ji,jj,jk,Kmm) 
     234               zabe2 = pahv(ji,jj,jk) * e1_e2v(ji,jj) * e3v(ji,jj,jk,Kmm) 
     235               ! 
     236               zmsku = 1. / MAX(  wmask(ji+1,jj,jk  ) + wmask(ji,jj,jk+1)   & 
     237                  &             + wmask(ji+1,jj,jk+1) + wmask(ji,jj,jk  ), 1. ) 
     238               ! 
     239               zmskv = 1. / MAX(  wmask(ji,jj+1,jk  ) + wmask(ji,jj,jk+1)   & 
     240                  &             + wmask(ji,jj+1,jk+1) + wmask(ji,jj,jk  ), 1. ) 
     241               ! 
     242               zcof1 = - pahu(ji,jj,jk) * e2u(ji,jj) * uslp(ji,jj,jk) * zmsku 
     243               zcof2 = - pahv(ji,jj,jk) * e1v(ji,jj) * vslp(ji,jj,jk) * zmskv 
     244               ! 
     245               zftu(ji,jj,jk ) = (  zabe1 * zdit(ji,jj,jk)   & 
     246                  &               + zcof1 * (  zdkt (ji+1,jj) + zdk1t(ji,jj)      & 
     247                  &                          + zdk1t(ji+1,jj) + zdkt (ji,jj)  )  ) * umask(ji,jj,jk) 
     248               zftv(ji,jj,jk) = (  zabe2 * zdjt(ji,jj,jk)   & 
     249                  &               + zcof2 * (  zdkt (ji,jj+1) + zdk1t(ji,jj)      & 
     250                  &                          + zdk1t(ji,jj+1) + zdkt (ji,jj)  )  ) * vmask(ji,jj,jk)                   
     251            END_2D 
     252            ! 
     253            DO_2D_00_00 
     254               pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn) + zsign * (  zftu(ji,jj,jk) - zftu(ji-1,jj,jk)      & 
     255                  &                                                 + zftv(ji,jj,jk) - zftv(ji,jj-1,jk)  )   & 
     256                  &                                              * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
     257            END_2D 
    285258         END DO                                        !   End of slab   
    286259 
    … …  
    288261         !!   III - vertical trend (full) 
    289262         !!---------------------------------------------------------------------- 
    290          ! 
    291          ztfw(fs_2:1,:,:) = 0._wp     ;     ztfw(jpi:fs_jpim1,:,:) = 0._wp   ! avoid to potentially manipulate NaN values 
    292263         ! 
    293264         ! Vertical fluxes 
    … …  
    296267         ztfw(:,:, 1 ) = 0._wp      ;      ztfw(:,:,jpk) = 0._wp 
    297268          
    298          DO jk = 2, jpkm1           ! interior (2=<jk=<jpk-1) 
    299             DO jj = 2, jpjm1 
    300                DO ji = fs_2, fs_jpim1   ! vector opt. 
    301                   ! 
    302                   zmsku = wmask(ji,jj,jk) / MAX(   umask(ji  ,jj,jk-1) + umask(ji-1,jj,jk)          & 
    303                      &                           + umask(ji-1,jj,jk-1) + umask(ji  ,jj,jk) , 1._wp  ) 
    304                   zmskv = wmask(ji,jj,jk) / MAX(   vmask(ji,jj  ,jk-1) + vmask(ji,jj-1,jk)          & 
    305                      &                           + vmask(ji,jj-1,jk-1) + vmask(ji,jj  ,jk) , 1._wp  ) 
    306                      ! 
    307                   zahu_w = (   pahu(ji  ,jj,jk-1) + pahu(ji-1,jj,jk)    & 
    308                      &       + pahu(ji-1,jj,jk-1) + pahu(ji  ,jj,jk)  ) * zmsku 
    309                   zahv_w = (   pahv(ji,jj  ,jk-1) + pahv(ji,jj-1,jk)    & 
    310                      &       + pahv(ji,jj-1,jk-1) + pahv(ji,jj  ,jk)  ) * zmskv 
    311                      ! 
    312                   zcoef3 = - zahu_w * e2t(ji,jj) * zmsku * wslpi (ji,jj,jk)   !wslpi & j are already w-masked 
    313                   zcoef4 = - zahv_w * e1t(ji,jj) * zmskv * wslpj (ji,jj,jk) 
    314                   ! 
    315                   ztfw(ji,jj,jk) = zcoef3 * (   zdit(ji  ,jj  ,jk-1) + zdit(ji-1,jj  ,jk)      & 
    316                      &                        + zdit(ji-1,jj  ,jk-1) + zdit(ji  ,jj  ,jk)  )   & 
    317                      &           + zcoef4 * (   zdjt(ji  ,jj  ,jk-1) + zdjt(ji  ,jj-1,jk)      & 
    318                      &                        + zdjt(ji  ,jj-1,jk-1) + zdjt(ji  ,jj  ,jk)  ) 
    319                END DO 
    320             END DO 
    321          END DO 
     269         DO_3D_00_00( 2, jpkm1 ) 
     270            ! 
     271            zmsku = wmask(ji,jj,jk) / MAX(   umask(ji  ,jj,jk-1) + umask(ji-1,jj,jk)          & 
     272               &                           + umask(ji-1,jj,jk-1) + umask(ji  ,jj,jk) , 1._wp  ) 
     273            zmskv = wmask(ji,jj,jk) / MAX(   vmask(ji,jj  ,jk-1) + vmask(ji,jj-1,jk)          & 
     274               &                           + vmask(ji,jj-1,jk-1) + vmask(ji,jj  ,jk) , 1._wp  ) 
     275               ! 
     276            zahu_w = (   pahu(ji  ,jj,jk-1) + pahu(ji-1,jj,jk)    & 
     277               &       + pahu(ji-1,jj,jk-1) + pahu(ji  ,jj,jk)  ) * zmsku 
     278            zahv_w = (   pahv(ji,jj  ,jk-1) + pahv(ji,jj-1,jk)    & 
     279               &       + pahv(ji,jj-1,jk-1) + pahv(ji,jj  ,jk)  ) * zmskv 
     280               ! 
     281            zcoef3 = - zahu_w * e2t(ji,jj) * zmsku * wslpi (ji,jj,jk)   !wslpi & j are already w-masked 
     282            zcoef4 = - zahv_w * e1t(ji,jj) * zmskv * wslpj (ji,jj,jk) 
     283            ! 
     284            ztfw(ji,jj,jk) = zcoef3 * (   zdit(ji  ,jj  ,jk-1) + zdit(ji-1,jj  ,jk)      & 
     285               &                        + zdit(ji-1,jj  ,jk-1) + zdit(ji  ,jj  ,jk)  )   & 
     286               &           + zcoef4 * (   zdjt(ji  ,jj  ,jk-1) + zdjt(ji  ,jj-1,jk)      & 
     287               &                        + zdjt(ji  ,jj-1,jk-1) + zdjt(ji  ,jj  ,jk)  ) 
     288         END_3D 
    322289         !                                !==  add the vertical 33 flux  ==! 
    323290         IF( ln_traldf_lap ) THEN               ! laplacian case: eddy coef = ah_wslp2 - akz 
    324             DO jk = 2, jpkm1        
    325                DO jj = 2, jpjm1 
    326                   DO ji = fs_2, fs_jpim1 
    327                      ztfw(ji,jj,jk) = ztfw(ji,jj,jk) + e1e2t(ji,jj) / e3w_n(ji,jj,jk) * wmask(ji,jj,jk)   & 
    328                         &                            * ( ah_wslp2(ji,jj,jk) - akz(ji,jj,jk) )             & 
    329                         &                            * ( ptb(ji,jj,jk-1,jn) - ptb(ji,jj,jk,jn) ) 
    330                   END DO 
    331                END DO 
    332             END DO 
     291            DO_3D_00_00( 2, jpkm1 ) 
     292               ztfw(ji,jj,jk) = ztfw(ji,jj,jk) + e1e2t(ji,jj) / e3w(ji,jj,jk,Kmm) * wmask(ji,jj,jk)   & 
     293                  &                            * ( ah_wslp2(ji,jj,jk) - akz(ji,jj,jk) )               & 
     294                  &                            * (  pt(ji,jj,jk-1,jn) -  pt(ji,jj,jk,jn) ) 
     295            END_3D 
    333296            ! 
    334297         ELSE                                   ! bilaplacian  
    335298            SELECT CASE( kpass ) 
    336299            CASE(  1  )                            ! 1st pass : eddy coef = ah_wslp2 
    337                DO jk = 2, jpkm1  
    338                   DO jj = 2, jpjm1 
    339                      DO ji = fs_2, fs_jpim1 
    340                         ztfw(ji,jj,jk) = ztfw(ji,jj,jk)    & 
    341                            &           + ah_wslp2(ji,jj,jk) * e1e2t(ji,jj)   & 
    342                            &           * ( ptb(ji,jj,jk-1,jn) - ptb(ji,jj,jk,jn) ) / e3w_n(ji,jj,jk) * wmask(ji,jj,jk) 
    343                      END DO 
    344                   END DO 
    345                END DO  
    346             CASE(  2  )                         ! 2nd pass : eddy flux = ah_wslp2 and akz applied on ptb  and ptbb gradients, resp. 
    347                DO jk = 2, jpkm1  
    348                   DO jj = 2, jpjm1 
    349                      DO ji = fs_2, fs_jpim1 
    350                         ztfw(ji,jj,jk) = ztfw(ji,jj,jk) + e1e2t(ji,jj) / e3w_n(ji,jj,jk) * wmask(ji,jj,jk)                      & 
    351                            &                            * (  ah_wslp2(ji,jj,jk) * ( ptb (ji,jj,jk-1,jn) - ptb (ji,jj,jk,jn) )   & 
    352                            &                               + akz     (ji,jj,jk) * ( ptbb(ji,jj,jk-1,jn) - ptbb(ji,jj,jk,jn) )   ) 
    353                      END DO 
    354                   END DO 
    355                END DO 
     300               DO_3D_00_00( 2, jpkm1 ) 
     301                  ztfw(ji,jj,jk) = ztfw(ji,jj,jk)                       & 
     302                     &           + ah_wslp2(ji,jj,jk)  * e1e2t(ji,jj)   & 
     303                     &           * ( pt(ji,jj,jk-1,jn) - pt(ji,jj,jk,jn) ) / e3w(ji,jj,jk,Kmm) * wmask(ji,jj,jk) 
     304               END_3D 
     305            CASE(  2  )                         ! 2nd pass : eddy flux = ah_wslp2 and akz applied on pt  and pt2 gradients, resp. 
     306               DO_3D_00_00( 2, jpkm1 ) 
     307                  ztfw(ji,jj,jk) = ztfw(ji,jj,jk) + e1e2t(ji,jj) / e3w(ji,jj,jk,Kmm) * wmask(ji,jj,jk)                  & 
     308                     &                            * (  ah_wslp2(ji,jj,jk) * ( pt (ji,jj,jk-1,jn) - pt (ji,jj,jk,jn) )   & 
     309                     &                            +         akz(ji,jj,jk) * ( pt2(ji,jj,jk-1,jn) - pt2(ji,jj,jk,jn) )   ) 
     310               END_3D 
    356311            END SELECT 
    357312         ENDIF 
    358313         !          
    359          DO jk = 1, jpkm1                 !==  Divergence of vertical fluxes added to pta  ==! 
    360             DO jj = 2, jpjm1 
    361                DO ji = fs_2, fs_jpim1   ! vector opt. 
    362                   pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + zsign * (  ztfw (ji,jj,jk) - ztfw(ji,jj,jk+1)  )   & 
    363                      &                                        * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) 
    364                END DO 
    365             END DO 
    366          END DO 
     314         DO_3D_00_00( 1, jpkm1 ) 
     315            pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn) + zsign * (  ztfw (ji,jj,jk) - ztfw(ji,jj,jk+1)  )   & 
     316               &                                              * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
     317         END_3D 
    367318         ! 
    368319         IF( ( kpass == 1 .AND. ln_traldf_lap ) .OR.  &     !==  first pass only (  laplacian)  ==! 

  • NEMO/trunk/src/OCE/TRA/traldf_lap_blp.F90

    r11993 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 tra_ldf_lap( kt, kit000, cdtype, pahu, pahv, pgu , pgv ,   & 
    48       &                                                   pgui, pgvi,   & 
    49       &                                        ptb , pta , kjpt, kpass )  
     47   SUBROUTINE tra_ldf_lap( kt, Kmm, kit000, cdtype, pahu, pahv  ,               & 
     48      &                                             pgu , pgv   , pgui, pgvi,   & 
     49      &                                             pt  , pt_rhs, kjpt, kpass )  
    5050      !!---------------------------------------------------------------------- 
    5151      !!                  ***  ROUTINE tra_ldf_lap  *** 
    … …  
    5959      !!          difft = 1/(e1e2t*e3t) {  di-1[ pahu e2u*e3u/e1u di(tb) ] 
    6060      !!                                 + dj-1[ pahv e1v*e3v/e2v dj(tb) ] } 
    61       !!      Add this trend to the general tracer trend pta : 
    62       !!          pta = pta + difft 
    63       !! 
    64       !! ** Action  : - Update pta arrays with the before iso-level  
     61      !!      Add this trend to the general tracer trend pt_rhs : 
     62      !!          pt_rhs = pt_rhs + difft 
     63      !! 
     64      !! ** Action  : - Update pt_rhs arrays with the before iso-level  
    6565      !!                harmonic mixing trend. 
    6666      !!---------------------------------------------------------------------- 
    … …  
    7070      INTEGER                              , INTENT(in   ) ::   kjpt       ! number of tracers 
    7171      INTEGER                              , INTENT(in   ) ::   kpass      ! =1/2 first or second passage 
     72      INTEGER                              , INTENT(in   ) ::   Kmm        ! ocean time level index 
    7273      REAL(wp), DIMENSION(jpi,jpj,jpk)     , INTENT(in   ) ::   pahu, pahv ! eddy diffusivity at u- and v-points  [m2/s] 
    7374      REAL(wp), DIMENSION(jpi,jpj    ,kjpt), INTENT(in   ) ::   pgu, pgv   ! tracer gradient at pstep levels 
    7475      REAL(wp), DIMENSION(jpi,jpj,    kjpt), INTENT(in   ) ::   pgui, pgvi ! tracer gradient at top   levels 
    75       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb        ! before and now tracer fields 
    76       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta        ! tracer trend  
     76      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   pt         ! before tracer fields 
     77      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pt_rhs     ! tracer trend  
    7778      ! 
    7879      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
    … …  
    8990      l_hst = .FALSE. 
    9091      l_ptr = .FALSE. 
    91       IF( cdtype == 'TRA' .AND. ln_diaptr )                                                l_ptr = .TRUE.  
     92      IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) ) )     l_ptr = .TRUE. 
    9293      IF( cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & 
    9394         &                        iom_use("uadv_salttr") .OR. iom_use("vadv_salttr")  ) )  l_hst = .TRUE. 
    … …  
    9798      ELSE                    ;   zsign = -1._wp 
    9899      ENDIF 
    99       DO jk = 1, jpkm1 
    100          DO jj = 1, jpjm1 
    101             DO ji = 1, fs_jpim1   ! vector opt. 
    102                zaheeu(ji,jj,jk) = zsign * pahu(ji,jj,jk) * e2_e1u(ji,jj) * e3u_n(ji,jj,jk)   !!gm   * umask(ji,jj,jk) pah masked! 
    103                zaheev(ji,jj,jk) = zsign * pahv(ji,jj,jk) * e1_e2v(ji,jj) * e3v_n(ji,jj,jk)   !!gm   * vmask(ji,jj,jk) 
    104             END DO 
    105          END DO 
    106       END DO 
     100      DO_3D_10_10( 1, jpkm1 ) 
     101         zaheeu(ji,jj,jk) = zsign * pahu(ji,jj,jk) * e2_e1u(ji,jj) * e3u(ji,jj,jk,Kmm)   !!gm   * umask(ji,jj,jk) pah masked! 
     102         zaheev(ji,jj,jk) = zsign * pahv(ji,jj,jk) * e1_e2v(ji,jj) * e3v(ji,jj,jk,Kmm)   !!gm   * vmask(ji,jj,jk) 
     103      END_3D 
    107104      ! 
    108105      !                             ! =========== ! 
    … …  
    110107         !                          ! =========== !     
    111108         !                                
    112          DO jk = 1, jpkm1              !== First derivative (gradient)  ==! 
    113             DO jj = 1, jpjm1 
    114                DO ji = 1, fs_jpim1 
    115                   ztu(ji,jj,jk) = zaheeu(ji,jj,jk) * ( ptb(ji+1,jj  ,jk,jn) - ptb(ji,jj,jk,jn) ) 
    116                   ztv(ji,jj,jk) = zaheev(ji,jj,jk) * ( ptb(ji  ,jj+1,jk,jn) - ptb(ji,jj,jk,jn) ) 
    117                END DO 
    118             END DO 
    119          END DO   
     109         DO_3D_10_10( 1, jpkm1 ) 
     110            ztu(ji,jj,jk) = zaheeu(ji,jj,jk) * ( pt(ji+1,jj  ,jk,jn) - pt(ji,jj,jk,jn) ) 
     111            ztv(ji,jj,jk) = zaheev(ji,jj,jk) * ( pt(ji  ,jj+1,jk,jn) - pt(ji,jj,jk,jn) ) 
     112         END_3D 
    120113         IF( ln_zps ) THEN                ! set gradient at bottom/top ocean level 
    121             DO jj = 1, jpjm1                    ! bottom 
    122                DO ji = 1, fs_jpim1 
    123                   ztu(ji,jj,mbku(ji,jj)) = zaheeu(ji,jj,mbku(ji,jj)) * pgu(ji,jj,jn) 
    124                   ztv(ji,jj,mbkv(ji,jj)) = zaheev(ji,jj,mbkv(ji,jj)) * pgv(ji,jj,jn) 
    125                END DO 
    126             END DO   
     114            DO_2D_10_10 
     115               ztu(ji,jj,mbku(ji,jj)) = zaheeu(ji,jj,mbku(ji,jj)) * pgu(ji,jj,jn) 
     116               ztv(ji,jj,mbkv(ji,jj)) = zaheev(ji,jj,mbkv(ji,jj)) * pgv(ji,jj,jn) 
     117            END_2D 
    127118            IF( ln_isfcav ) THEN                ! top in ocean cavities only 
    128                DO jj = 1, jpjm1 
    129                   DO ji = 1, fs_jpim1   ! vector opt. 
    130                      IF( miku(ji,jj) > 1 )   ztu(ji,jj,miku(ji,jj)) = zaheeu(ji,jj,miku(ji,jj)) * pgui(ji,jj,jn)  
    131                      IF( mikv(ji,jj) > 1 )   ztv(ji,jj,mikv(ji,jj)) = zaheev(ji,jj,mikv(ji,jj)) * pgvi(ji,jj,jn)  
    132                   END DO 
    133                END DO 
     119               DO_2D_10_10 
     120                  IF( miku(ji,jj) > 1 )   ztu(ji,jj,miku(ji,jj)) = zaheeu(ji,jj,miku(ji,jj)) * pgui(ji,jj,jn)  
     121                  IF( mikv(ji,jj) > 1 )   ztv(ji,jj,mikv(ji,jj)) = zaheev(ji,jj,mikv(ji,jj)) * pgvi(ji,jj,jn)  
     122               END_2D 
    134123            ENDIF 
    135124         ENDIF 
    136125         ! 
    137          DO jk = 1, jpkm1              !== Second derivative (divergence) added to the general tracer trends  ==! 
    138             DO jj = 2, jpjm1 
    139                DO ji = fs_2, fs_jpim1 
    140                   pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + (  ztu(ji,jj,jk) - ztu(ji-1,jj,jk)     & 
    141                      &                                   + ztv(ji,jj,jk) - ztv(ji,jj-1,jk) )   & 
    142                      &                                / ( e1e2t(ji,jj) * e3t_n(ji,jj,jk) ) 
    143                END DO 
    144             END DO 
    145          END DO   
     126         DO_3D_00_00( 1, jpkm1 ) 
     127            pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn) + (  ztu(ji,jj,jk) - ztu(ji-1,jj,jk)     & 
     128               &                                      +    ztv(ji,jj,jk) - ztv(ji,jj-1,jk) )   & 
     129               &                                      / ( e1e2t(ji,jj) * e3t(ji,jj,jk,Kmm) ) 
     130         END_3D 
    146131         ! 
    147132         !                             !== "Poleward" diffusive heat or salt transports  ==! 
    … …  
    159144    
    160145 
    161    SUBROUTINE tra_ldf_blp( kt, kit000, cdtype, pahu, pahv, pgu , pgv ,   & 
    162       &                                                    pgui, pgvi,  & 
    163       &                                                    ptb , pta , kjpt, kldf ) 
     146   SUBROUTINE tra_ldf_blp( kt, Kmm, kit000, cdtype, pahu, pahv  ,             & 
     147      &                                             pgu , pgv   , pgui, pgvi, & 
     148      &                                             pt  , pt_rhs, kjpt, kldf ) 
    164149      !!---------------------------------------------------------------------- 
    165150      !!                 ***  ROUTINE tra_ldf_blp  *** 
    … …  
    179164      INTEGER                              , INTENT(in   ) ::   kjpt       ! number of tracers 
    180165      INTEGER                              , INTENT(in   ) ::   kldf       ! type of operator used 
     166      INTEGER                              , INTENT(in   ) ::   Kmm        ! ocean time level indices 
    181167      REAL(wp), DIMENSION(jpi,jpj,jpk)     , INTENT(in   ) ::   pahu, pahv ! eddy diffusivity at u- and v-points  [m2/s] 
    182168      REAL(wp), DIMENSION(jpi,jpj    ,kjpt), INTENT(in   ) ::   pgu, pgv   ! tracer gradient at pstep levels 
    183169      REAL(wp), DIMENSION(jpi,jpj,    kjpt), INTENT(in   ) ::   pgui, pgvi ! tracer gradient at top levels 
    184       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb        ! before and now tracer fields 
    185       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta        ! tracer trend 
     170      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   pt         ! before and now tracer fields 
     171      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pt_rhs     ! tracer trend 
    186172      ! 
    187173      INTEGER ::   ji, jj, jk, jn   ! dummy loop indices 
    … …  
    203189      zlap(:,:,:,:) = 0._wp 
    204190      ! 
    205       SELECT CASE ( kldf )       !==  1st laplacian applied to ptb (output in zlap)  ==! 
     191      SELECT CASE ( kldf )       !==  1st laplacian applied to pt (output in zlap)  ==! 
    206192      ! 
    207193      CASE ( np_blp    )               ! iso-level bilaplacian 
    208          CALL tra_ldf_lap  ( kt, kit000, cdtype, pahu, pahv, pgu, pgv, pgui, pgvi, ptb,      zlap, kjpt, 1 ) 
     194         CALL tra_ldf_lap  ( kt, Kmm, kit000, cdtype, pahu, pahv, pgu, pgv, pgui, pgvi, pt,     zlap, kjpt, 1 ) 
    209195      CASE ( np_blp_i  )               ! rotated   bilaplacian : standard operator (Madec) 
    210          CALL tra_ldf_iso  ( kt, kit000, cdtype, pahu, pahv, pgu, pgv, pgui, pgvi, ptb, ptb, zlap, kjpt, 1 ) 
     196         CALL tra_ldf_iso  ( kt, Kmm, kit000, cdtype, pahu, pahv, pgu, pgv, pgui, pgvi, pt, pt, zlap, kjpt, 1 ) 
    211197      CASE ( np_blp_it )               ! rotated  bilaplacian : triad operator (griffies) 
    212          CALL tra_ldf_triad( kt, kit000, cdtype, pahu, pahv, pgu, pgv, pgui, pgvi, ptb, ptb, zlap, kjpt, 1 ) 
     198         CALL tra_ldf_triad( kt, Kmm, kit000, cdtype, pahu, pahv, pgu, pgv, pgui, pgvi, pt, pt, zlap, kjpt, 1 ) 
    213199      END SELECT 
    214200      ! 
    215201      CALL lbc_lnk( 'traldf_lap_blp', zlap(:,:,:,:) , 'T', 1. )     ! Lateral boundary conditions (unchanged sign) 
    216202      !                                               ! Partial top/bottom cell: GRADh( zlap )   
    217       IF( ln_isfcav .AND. ln_zps ) THEN   ;   CALL zps_hde_isf( kt, kjpt, zlap, zglu, zglv, zgui, zgvi )  ! both top & bottom 
    218       ELSEIF(             ln_zps ) THEN   ;   CALL zps_hde    ( kt, kjpt, zlap, zglu, zglv )              ! only bottom  
    219       ENDIF 
    220       ! 
    221       SELECT CASE ( kldf )       !==  2nd laplacian applied to zlap (output in pta)  ==! 
     203      IF( ln_isfcav .AND. ln_zps ) THEN   ;   CALL zps_hde_isf( kt, Kmm, kjpt, zlap, zglu, zglv, zgui, zgvi )  ! both top & bottom 
     204      ELSEIF(             ln_zps ) THEN   ;   CALL zps_hde    ( kt, Kmm, kjpt, zlap, zglu, zglv )              ! only bottom  
     205      ENDIF 
     206      ! 
     207      SELECT CASE ( kldf )       !==  2nd laplacian applied to zlap (output in pt_rhs)  ==! 
    222208      ! 
    223209      CASE ( np_blp    )               ! iso-level bilaplacian 
    224          CALL tra_ldf_lap  ( kt, kit000, cdtype, pahu, pahv, zglu, zglv, zgui, zgvi, zlap, pta,      kjpt, 2 ) 
     210         CALL tra_ldf_lap  ( kt, Kmm, kit000, cdtype, pahu, pahv, zglu, zglv, zgui, zgvi, zlap, pt_rhs,         kjpt, 2 ) 
    225211      CASE ( np_blp_i  )               ! rotated   bilaplacian : standard operator (Madec) 
    226          CALL tra_ldf_iso  ( kt, kit000, cdtype, pahu, pahv, zglu, zglv, zgui, zgvi, zlap, ptb, pta, kjpt, 2 ) 
     212         CALL tra_ldf_iso  ( kt, Kmm, kit000, cdtype, pahu, pahv, zglu, zglv, zgui, zgvi, zlap, pt    , pt_rhs, kjpt, 2 ) 
    227213      CASE ( np_blp_it )               ! rotated  bilaplacian : triad operator (griffies) 
    228          CALL tra_ldf_triad( kt, kit000, cdtype, pahu, pahv, zglu, zglv, zgui, zgvi, zlap, ptb, pta, kjpt, 2 ) 
     214         CALL tra_ldf_triad( kt, Kmm, kit000, cdtype, pahu, pahv, zglu, zglv, zgui, zgvi, zlap, pt    , pt_rhs, kjpt, 2 ) 
    229215      END SELECT 
    230216      ! 

  • NEMO/trunk/src/OCE/TRA/traldf_triad.F90

    r11993 r12377  
    4040 
    4141   !! * Substitutions 
    42 #  include "vectopt_loop_substitute.h90" 
     42#  include "do_loop_substitute.h90" 
    4343   !!---------------------------------------------------------------------- 
    4444   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    4848CONTAINS 
    4949 
    50   SUBROUTINE tra_ldf_triad( kt, kit000, cdtype, pahu, pahv, pgu , pgv ,   & 
    51       &                                                     pgui, pgvi,  & 
    52       &                                         ptb , ptbb, pta , kjpt, kpass ) 
     50  SUBROUTINE tra_ldf_triad( kt, Kmm, kit000, cdtype, pahu, pahv,               & 
     51      &                                              pgu , pgv  , pgui, pgvi , & 
     52      &                                         pt , pt2, pt_rhs, kjpt, kpass ) 
    5353      !!---------------------------------------------------------------------- 
    5454      !!                  ***  ROUTINE tra_ldf_triad  *** 
    … …  
    6666      !!      see documentation for the desciption 
    6767      !! 
    68       !! ** Action :   pta   updated with the before rotated diffusion 
     68      !! ** Action :   pt_rhs   updated with the before rotated diffusion 
    6969      !!               ah_wslp2 .... 
    7070      !!               akz   stabilizing vertical diffusivity coefficient (used in trazdf_imp) 
    … …  
    7575      INTEGER                              , INTENT(in   ) ::   kjpt       ! number of tracers 
    7676      INTEGER                              , INTENT(in   ) ::   kpass      ! =1/2 first or second passage 
     77      INTEGER                              , INTENT(in)    ::   Kmm        ! ocean time level indices 
    7778      REAL(wp), DIMENSION(jpi,jpj,jpk)     , INTENT(in   ) ::   pahu, pahv ! eddy diffusivity at u- and v-points  [m2/s] 
    7879      REAL(wp), DIMENSION(jpi,jpj    ,kjpt), INTENT(in   ) ::   pgu , pgv  ! tracer gradient at pstep levels 
    7980      REAL(wp), DIMENSION(jpi,jpj,    kjpt), INTENT(in   ) ::   pgui, pgvi ! tracer gradient at top   levels 
    80       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb        ! tracer (kpass=1) or laplacian of tracer (kpass=2) 
    81       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptbb       ! tracer (only used in kpass=2) 
    82       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta        ! tracer trend 
     81      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   pt         ! tracer (kpass=1) or laplacian of tracer (kpass=2) 
     82      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   pt2        ! tracer (only used in kpass=2) 
     83      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pt_rhs     ! tracer trend 
    8384      ! 
    8485      INTEGER  ::  ji, jj, jk, jn   ! dummy loop indices 
    … …  
    110111      l_hst = .FALSE. 
    111112      l_ptr = .FALSE. 
    112       IF( cdtype == 'TRA' .AND. ln_diaptr )                                                 l_ptr = .TRUE.  
     113      IF( cdtype == 'TRA' .AND. ( iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) ) )      l_ptr = .TRUE.  
    113114      IF( cdtype == 'TRA' .AND. ( iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. & 
    114115         &                        iom_use("uadv_salttr") .OR. iom_use("vadv_salttr")  ) )   l_hst = .TRUE. 
    … …  
    139140         DO ip = 0, 1                            ! i-k triads 
    140141            DO kp = 0, 1 
    141                DO jk = 1, jpkm1 
    142                   DO jj = 1, jpjm1 
    143                      DO ji = 1, fs_jpim1 
    144                         ze3wr = 1._wp / e3w_n(ji+ip,jj,jk+kp) 
    145                         zbu   = e1e2u(ji,jj) * e3u_n(ji,jj,jk) 
    146                         zah   = 0.25_wp * pahu(ji,jj,jk) 
    147                         zslope_skew = triadi_g(ji+ip,jj,jk,1-ip,kp) 
    148                         ! Subtract s-coordinate slope at t-points to give slope rel to s-surfaces (do this by *adding* gradient of depth) 
    149                         zslope2 = zslope_skew + ( gdept_n(ji+1,jj,jk) - gdept_n(ji,jj,jk) ) * r1_e1u(ji,jj) * umask(ji,jj,jk+kp) 
    150                         zslope2 = zslope2 *zslope2 
    151                         ah_wslp2(ji+ip,jj,jk+kp) = ah_wslp2(ji+ip,jj,jk+kp) + zah * zbu * ze3wr * r1_e1e2t(ji+ip,jj) * zslope2 
    152                         akz     (ji+ip,jj,jk+kp) = akz     (ji+ip,jj,jk+kp) + zah * r1_e1u(ji,jj)       & 
    153                            &                                                      * r1_e1u(ji,jj) * umask(ji,jj,jk+kp) 
    154                            ! 
    155                        IF( ln_ldfeiv_dia )   zpsi_uw(ji,jj,jk+kp) = zpsi_uw(ji,jj,jk+kp)   & 
    156                            &                                       + 0.25_wp * aeiu(ji,jj,jk) * e2u(ji,jj) * zslope_skew 
    157                      END DO 
    158                   END DO 
    159                END DO 
     142               DO_3D_10_10( 1, jpkm1 ) 
     143                  ze3wr = 1._wp / e3w(ji+ip,jj,jk+kp,Kmm) 
     144                  zbu   = e1e2u(ji,jj) * e3u(ji,jj,jk,Kmm) 
     145                  zah   = 0.25_wp * pahu(ji,jj,jk) 
     146                  zslope_skew = triadi_g(ji+ip,jj,jk,1-ip,kp) 
     147                  ! Subtract s-coordinate slope at t-points to give slope rel to s-surfaces (do this by *adding* gradient of depth) 
     148                  zslope2 = zslope_skew + ( gdept(ji+1,jj,jk,Kmm) - gdept(ji,jj,jk,Kmm) ) * r1_e1u(ji,jj) * umask(ji,jj,jk+kp) 
     149                  zslope2 = zslope2 *zslope2 
     150                  ah_wslp2(ji+ip,jj,jk+kp) = ah_wslp2(ji+ip,jj,jk+kp) + zah * zbu * ze3wr * r1_e1e2t(ji+ip,jj) * zslope2 
     151                  akz     (ji+ip,jj,jk+kp) = akz     (ji+ip,jj,jk+kp) + zah * r1_e1u(ji,jj)       & 
     152                     &                                                      * r1_e1u(ji,jj) * umask(ji,jj,jk+kp) 
     153                     ! 
     154                 IF( ln_ldfeiv_dia )   zpsi_uw(ji,jj,jk+kp) = zpsi_uw(ji,jj,jk+kp)   & 
     155                     &                                       + 0.25_wp * aeiu(ji,jj,jk) * e2u(ji,jj) * zslope_skew 
     156               END_3D 
    160157            END DO 
    161158         END DO 
    … …  
    163160         DO jp = 0, 1                            ! j-k triads  
    164161            DO kp = 0, 1 
    165                DO jk = 1, jpkm1 
    166                   DO jj = 1, jpjm1 
    167                      DO ji = 1, fs_jpim1 
    168                         ze3wr = 1.0_wp / e3w_n(ji,jj+jp,jk+kp) 
    169                         zbv   = e1e2v(ji,jj) * e3v_n(ji,jj,jk) 
    170                         zah   = 0.25_wp * pahv(ji,jj,jk) 
    171                         zslope_skew = triadj_g(ji,jj+jp,jk,1-jp,kp) 
    172                         ! Subtract s-coordinate slope at t-points to give slope rel to s surfaces 
    173                         !    (do this by *adding* gradient of depth) 
    174                         zslope2 = zslope_skew + ( gdept_n(ji,jj+1,jk) - gdept_n(ji,jj,jk) ) * r1_e2v(ji,jj) * vmask(ji,jj,jk+kp) 
    175                         zslope2 = zslope2 * zslope2 
    176                         ah_wslp2(ji,jj+jp,jk+kp) = ah_wslp2(ji,jj+jp,jk+kp) + zah * zbv * ze3wr * r1_e1e2t(ji,jj+jp) * zslope2 
    177                         akz     (ji,jj+jp,jk+kp) = akz     (ji,jj+jp,jk+kp) + zah * r1_e2v(ji,jj)     & 
    178                            &                                                      * r1_e2v(ji,jj) * vmask(ji,jj,jk+kp) 
    179                         ! 
    180                         IF( ln_ldfeiv_dia )   zpsi_vw(ji,jj,jk+kp) = zpsi_vw(ji,jj,jk+kp)   & 
    181                            &                                       + 0.25 * aeiv(ji,jj,jk) * e1v(ji,jj) * zslope_skew 
    182                      END DO 
    183                   END DO 
    184                END DO 
     162               DO_3D_10_10( 1, jpkm1 ) 
     163                  ze3wr = 1.0_wp / e3w(ji,jj+jp,jk+kp,Kmm) 
     164                  zbv   = e1e2v(ji,jj) * e3v(ji,jj,jk,Kmm) 
     165                  zah   = 0.25_wp * pahv(ji,jj,jk) 
     166                  zslope_skew = triadj_g(ji,jj+jp,jk,1-jp,kp) 
     167                  ! Subtract s-coordinate slope at t-points to give slope rel to s surfaces 
     168                  !    (do this by *adding* gradient of depth) 
     169                  zslope2 = zslope_skew + ( gdept(ji,jj+1,jk,Kmm) - gdept(ji,jj,jk,Kmm) ) * r1_e2v(ji,jj) * vmask(ji,jj,jk+kp) 
     170                  zslope2 = zslope2 * zslope2 
     171                  ah_wslp2(ji,jj+jp,jk+kp) = ah_wslp2(ji,jj+jp,jk+kp) + zah * zbv * ze3wr * r1_e1e2t(ji,jj+jp) * zslope2 
     172                  akz     (ji,jj+jp,jk+kp) = akz     (ji,jj+jp,jk+kp) + zah * r1_e2v(ji,jj)     & 
     173                     &                                                      * r1_e2v(ji,jj) * vmask(ji,jj,jk+kp) 
     174                  ! 
     175                  IF( ln_ldfeiv_dia )   zpsi_vw(ji,jj,jk+kp) = zpsi_vw(ji,jj,jk+kp)   & 
     176                     &                                       + 0.25 * aeiv(ji,jj,jk) * e1v(ji,jj) * zslope_skew 
     177               END_3D 
    185178            END DO 
    186179         END DO 
    … …  
    189182            ! 
    190183            IF( ln_traldf_blp ) THEN                ! bilaplacian operator 
    191                DO jk = 2, jpkm1 
    192                   DO jj = 1, jpjm1 
    193                      DO ji = 1, fs_jpim1 
    194                         akz(ji,jj,jk) = 16._wp * ah_wslp2(ji,jj,jk)   & 
    195                            &          * (  akz(ji,jj,jk) + ah_wslp2(ji,jj,jk) / ( e3w_n(ji,jj,jk) * e3w_n(ji,jj,jk) )  ) 
    196                      END DO 
    197                   END DO 
    198                END DO 
     184               DO_3D_10_10( 2, jpkm1 ) 
     185                  akz(ji,jj,jk) = 16._wp * ah_wslp2(ji,jj,jk)   & 
     186                     &          * (  akz(ji,jj,jk) + ah_wslp2(ji,jj,jk) / ( e3w(ji,jj,jk,Kmm) * e3w(ji,jj,jk,Kmm) )  ) 
     187               END_3D 
    199188            ELSEIF( ln_traldf_lap ) THEN              ! laplacian operator 
    200                DO jk = 2, jpkm1 
    201                   DO jj = 1, jpjm1 
    202                      DO ji = 1, fs_jpim1 
    203                         ze3w_2 = e3w_n(ji,jj,jk) * e3w_n(ji,jj,jk) 
    204                         zcoef0 = z2dt * (  akz(ji,jj,jk) + ah_wslp2(ji,jj,jk) / ze3w_2  ) 
    205                         akz(ji,jj,jk) = MAX( zcoef0 - 0.5_wp , 0._wp ) * ze3w_2 * z1_2dt 
    206                      END DO 
    207                   END DO 
    208                END DO 
     189               DO_3D_10_10( 2, jpkm1 ) 
     190                  ze3w_2 = e3w(ji,jj,jk,Kmm) * e3w(ji,jj,jk,Kmm) 
     191                  zcoef0 = z2dt * (  akz(ji,jj,jk) + ah_wslp2(ji,jj,jk) / ze3w_2  ) 
     192                  akz(ji,jj,jk) = MAX( zcoef0 - 0.5_wp , 0._wp ) * ze3w_2 * z1_2dt 
     193               END_3D 
    209194           ENDIF 
    210195           ! 
    … …  
    213198         ENDIF 
    214199         ! 
    215          IF( ln_ldfeiv_dia .AND. cdtype == 'TRA' )   CALL ldf_eiv_dia( zpsi_uw, zpsi_vw ) 
     200         IF( ln_ldfeiv_dia .AND. cdtype == 'TRA' )   CALL ldf_eiv_dia( zpsi_uw, zpsi_vw, Kmm ) 
    216201         ! 
    217202      ENDIF                                  !==  end 1st pass only  ==! 
    … …  
    226211         zftv(:,:,:) = 0._wp 
    227212         ! 
    228          DO jk = 1, jpkm1        !==  before lateral T & S gradients at T-level jk  ==! 
    229             DO jj = 1, jpjm1 
    230                DO ji = 1, fs_jpim1   ! vector opt. 
    231                   zdit(ji,jj,jk) = ( ptb(ji+1,jj  ,jk,jn) - ptb(ji,jj,jk,jn) ) * umask(ji,jj,jk) 
    232                   zdjt(ji,jj,jk) = ( ptb(ji  ,jj+1,jk,jn) - ptb(ji,jj,jk,jn) ) * vmask(ji,jj,jk) 
    233                END DO 
    234             END DO 
    235          END DO 
     213         DO_3D_10_10( 1, jpkm1 ) 
     214            zdit(ji,jj,jk) = ( pt(ji+1,jj  ,jk,jn) - pt(ji,jj,jk,jn) ) * umask(ji,jj,jk) 
     215            zdjt(ji,jj,jk) = ( pt(ji  ,jj+1,jk,jn) - pt(ji,jj,jk,jn) ) * vmask(ji,jj,jk) 
     216         END_3D 
    236217         IF( ln_zps .AND. l_grad_zps ) THEN    ! partial steps: correction at top/bottom ocean level 
    237             DO jj = 1, jpjm1                       ! bottom level 
    238                DO ji = 1, fs_jpim1   ! vector opt. 
    239                   zdit(ji,jj,mbku(ji,jj)) = pgu(ji,jj,jn) 
    240                   zdjt(ji,jj,mbkv(ji,jj)) = pgv(ji,jj,jn) 
    241                END DO 
    242             END DO 
     218            DO_2D_10_10 
     219               zdit(ji,jj,mbku(ji,jj)) = pgu(ji,jj,jn) 
     220               zdjt(ji,jj,mbkv(ji,jj)) = pgv(ji,jj,jn) 
     221            END_2D 
    243222            IF( ln_isfcav ) THEN                   ! top level (ocean cavities only) 
    244                DO jj = 1, jpjm1 
    245                   DO ji = 1, fs_jpim1   ! vector opt. 
    246                      IF( miku(ji,jj)  > 1 )   zdit(ji,jj,miku(ji,jj) ) = pgui(ji,jj,jn)  
    247                      IF( mikv(ji,jj)  > 1 )   zdjt(ji,jj,mikv(ji,jj) ) = pgvi(ji,jj,jn)  
    248                   END DO 
    249                END DO 
     223               DO_2D_10_10 
     224                  IF( miku(ji,jj)  > 1 )   zdit(ji,jj,miku(ji,jj) ) = pgui(ji,jj,jn)  
     225                  IF( mikv(ji,jj)  > 1 )   zdjt(ji,jj,mikv(ji,jj) ) = pgvi(ji,jj,jn)  
     226               END_2D 
    250227            ENDIF 
    251228         ENDIF 
    … …  
    257234         DO jk = 1, jpkm1 
    258235            !                    !==  Vertical tracer gradient at level jk and jk+1 
    259             zdkt3d(:,:,1) = ( ptb(:,:,jk,jn) - ptb(:,:,jk+1,jn) ) * tmask(:,:,jk+1) 
     236            zdkt3d(:,:,1) = ( pt(:,:,jk,jn) - pt(:,:,jk+1,jn) ) * tmask(:,:,jk+1) 
    260237            ! 
    261238            !                    ! surface boundary condition: zdkt3d(jk=0)=zdkt3d(jk=1) 
    262239            IF( jk == 1 ) THEN   ;   zdkt3d(:,:,0) = zdkt3d(:,:,1) 
    263             ELSE                 ;   zdkt3d(:,:,0) = ( ptb(:,:,jk-1,jn) - ptb(:,:,jk,jn) ) * tmask(:,:,jk) 
     240            ELSE                 ;   zdkt3d(:,:,0) = ( pt(:,:,jk-1,jn) - pt(:,:,jk,jn) ) * tmask(:,:,jk) 
    264241            ENDIF 
    265242            ! 
    … …  
    269246               DO ip = 0, 1              !==  Horizontal & vertical fluxes 
    270247                  DO kp = 0, 1 
    271                      DO jj = 1, jpjm1 
    272                         DO ji = 1, fs_jpim1 
    273                            ze1ur = r1_e1u(ji,jj) 
    274                            zdxt  = zdit(ji,jj,jk) * ze1ur 
    275                            ze3wr = 1._wp / e3w_n(ji+ip,jj,jk+kp) 
    276                            zdzt  = zdkt3d(ji+ip,jj,kp) * ze3wr 
    277                            zslope_skew = triadi_g(ji+ip,jj,jk,1-ip,kp) 
    278                            zslope_iso  = triadi  (ji+ip,jj,jk,1-ip,kp) 
    279                            ! 
    280                            zbu = 0.25_wp * e1e2u(ji,jj) * e3u_n(ji,jj,jk) 
    281                            ! ln_botmix_triad is .T. don't mask zah for bottom half cells    !!gm ?????   ahu is masked.... 
    282                            zah = pahu(ji,jj,jk) 
    283                            zah_slp  = zah * zslope_iso 
    284                            IF( ln_ldfeiv )   zaei_slp = aeiu(ji,jj,jk) * zslope_skew 
    285                            zftu(ji   ,jj,jk   ) = zftu(ji   ,jj,jk   ) - ( zah * zdxt + (zah_slp - zaei_slp) * zdzt ) * zbu * ze1ur 
    286                            ztfw(ji+ip,jj,jk+kp) = ztfw(ji+ip,jj,jk+kp) - ( zah_slp + zaei_slp) * zdxt                 * zbu * ze3wr 
    287                         END DO 
    288                      END DO 
     248                     DO_2D_10_10 
     249                        ze1ur = r1_e1u(ji,jj) 
     250                        zdxt  = zdit(ji,jj,jk) * ze1ur 
     251                        ze3wr = 1._wp / e3w(ji+ip,jj,jk+kp,Kmm) 
     252                        zdzt  = zdkt3d(ji+ip,jj,kp) * ze3wr 
     253                        zslope_skew = triadi_g(ji+ip,jj,jk,1-ip,kp) 
     254                        zslope_iso  = triadi  (ji+ip,jj,jk,1-ip,kp) 
     255                        ! 
     256                        zbu = 0.25_wp * e1e2u(ji,jj) * e3u(ji,jj,jk,Kmm) 
     257                        ! ln_botmix_triad is .T. don't mask zah for bottom half cells    !!gm ?????   ahu is masked.... 
     258                        zah = pahu(ji,jj,jk) 
     259                        zah_slp  = zah * zslope_iso 
     260                        IF( ln_ldfeiv )   zaei_slp = aeiu(ji,jj,jk) * zslope_skew 
     261                        zftu(ji   ,jj,jk   ) = zftu(ji   ,jj,jk   ) - ( zah * zdxt + (zah_slp - zaei_slp) * zdzt ) * zbu * ze1ur 
     262                        ztfw(ji+ip,jj,jk+kp) = ztfw(ji+ip,jj,jk+kp) - ( zah_slp + zaei_slp) * zdxt                 * zbu * ze3wr 
     263                     END_2D 
    289264                  END DO 
    290265               END DO 
    … …  
    292267               DO jp = 0, 1 
    293268                  DO kp = 0, 1 
    294                      DO jj = 1, jpjm1 
    295                         DO ji = 1, fs_jpim1 
    296                            ze2vr = r1_e2v(ji,jj) 
    297                            zdyt  = zdjt(ji,jj,jk) * ze2vr 
    298                            ze3wr = 1._wp / e3w_n(ji,jj+jp,jk+kp) 
    299                            zdzt  = zdkt3d(ji,jj+jp,kp) * ze3wr 
    300                            zslope_skew = triadj_g(ji,jj+jp,jk,1-jp,kp) 
    301                            zslope_iso  = triadj(ji,jj+jp,jk,1-jp,kp) 
    302                            zbv = 0.25_wp * e1e2v(ji,jj) * e3v_n(ji,jj,jk) 
    303                            ! ln_botmix_triad is .T. don't mask zah for bottom half cells    !!gm ?????  ahv is masked... 
    304                            zah = pahv(ji,jj,jk) 
    305                            zah_slp = zah * zslope_iso 
    306                            IF( ln_ldfeiv )   zaei_slp = aeiv(ji,jj,jk) * zslope_skew 
    307                            zftv(ji,jj   ,jk   ) = zftv(ji,jj   ,jk   ) - ( zah * zdyt + (zah_slp - zaei_slp) * zdzt ) * zbv * ze2vr 
    308                            ztfw(ji,jj+jp,jk+kp) = ztfw(ji,jj+jp,jk+kp) - ( zah_slp + zaei_slp ) * zdyt                * zbv * ze3wr 
    309                         END DO 
    310                      END DO 
     269                     DO_2D_10_10 
     270                        ze2vr = r1_e2v(ji,jj) 
     271                        zdyt  = zdjt(ji,jj,jk) * ze2vr 
     272                        ze3wr = 1._wp / e3w(ji,jj+jp,jk+kp,Kmm) 
     273                        zdzt  = zdkt3d(ji,jj+jp,kp) * ze3wr 
     274                        zslope_skew = triadj_g(ji,jj+jp,jk,1-jp,kp) 
     275                        zslope_iso  = triadj(ji,jj+jp,jk,1-jp,kp) 
     276                        zbv = 0.25_wp * e1e2v(ji,jj) * e3v(ji,jj,jk,Kmm) 
     277                        ! ln_botmix_triad is .T. don't mask zah for bottom half cells    !!gm ?????  ahv is masked... 
     278                        zah = pahv(ji,jj,jk) 
     279                        zah_slp = zah * zslope_iso 
     280                        IF( ln_ldfeiv )   zaei_slp = aeiv(ji,jj,jk) * zslope_skew 
     281                        zftv(ji,jj   ,jk   ) = zftv(ji,jj   ,jk   ) - ( zah * zdyt + (zah_slp - zaei_slp) * zdzt ) * zbv * ze2vr 
     282                        ztfw(ji,jj+jp,jk+kp) = ztfw(ji,jj+jp,jk+kp) - ( zah_slp + zaei_slp ) * zdyt                * zbv * ze3wr 
     283                     END_2D 
    311284                  END DO 
    312285               END DO 
    … …  
    316289               DO ip = 0, 1               !==  Horizontal & vertical fluxes 
    317290                  DO kp = 0, 1 
    318                      DO jj = 1, jpjm1 
    319                         DO ji = 1, fs_jpim1 
    320                            ze1ur = r1_e1u(ji,jj) 
    321                            zdxt  = zdit(ji,jj,jk) * ze1ur 
    322                            ze3wr = 1._wp / e3w_n(ji+ip,jj,jk+kp) 
    323                            zdzt  = zdkt3d(ji+ip,jj,kp) * ze3wr 
    324                            zslope_skew = triadi_g(ji+ip,jj,jk,1-ip,kp) 
    325                            zslope_iso  = triadi(ji+ip,jj,jk,1-ip,kp) 
    326                            ! 
    327                            zbu = 0.25_wp * e1e2u(ji,jj) * e3u_n(ji,jj,jk) 
    328                            ! ln_botmix_triad is .F. mask zah for bottom half cells 
    329                            zah = pahu(ji,jj,jk) * umask(ji,jj,jk+kp)         ! pahu(ji+ip,jj,jk)   ===>>  ???? 
    330                            zah_slp  = zah * zslope_iso 
    331                            IF( ln_ldfeiv )   zaei_slp = aeiu(ji,jj,jk) * zslope_skew        ! aeit(ji+ip,jj,jk)*zslope_skew 
    332                            zftu(ji   ,jj,jk   ) = zftu(ji   ,jj,jk   ) - ( zah * zdxt + (zah_slp - zaei_slp) * zdzt ) * zbu * ze1ur 
    333                            ztfw(ji+ip,jj,jk+kp) = ztfw(ji+ip,jj,jk+kp) - (zah_slp + zaei_slp) * zdxt * zbu * ze3wr 
    334                         END DO 
    335                      END DO 
     291                     DO_2D_10_10 
     292                        ze1ur = r1_e1u(ji,jj) 
     293                        zdxt  = zdit(ji,jj,jk) * ze1ur 
     294                        ze3wr = 1._wp / e3w(ji+ip,jj,jk+kp,Kmm) 
     295                        zdzt  = zdkt3d(ji+ip,jj,kp) * ze3wr 
     296                        zslope_skew = triadi_g(ji+ip,jj,jk,1-ip,kp) 
     297                        zslope_iso  = triadi(ji+ip,jj,jk,1-ip,kp) 
     298                        ! 
     299                        zbu = 0.25_wp * e1e2u(ji,jj) * e3u(ji,jj,jk,Kmm) 
     300                        ! ln_botmix_triad is .F. mask zah for bottom half cells 
     301                        zah = pahu(ji,jj,jk) * umask(ji,jj,jk+kp)         ! pahu(ji+ip,jj,jk)   ===>>  ???? 
     302                        zah_slp  = zah * zslope_iso 
     303                        IF( ln_ldfeiv )   zaei_slp = aeiu(ji,jj,jk) * zslope_skew        ! aeit(ji+ip,jj,jk)*zslope_skew 
     304                        zftu(ji   ,jj,jk   ) = zftu(ji   ,jj,jk   ) - ( zah * zdxt + (zah_slp - zaei_slp) * zdzt ) * zbu * ze1ur 
     305                        ztfw(ji+ip,jj,jk+kp) = ztfw(ji+ip,jj,jk+kp) - (zah_slp + zaei_slp) * zdxt * zbu * ze3wr 
     306                     END_2D 
    336307                  END DO 
    337308               END DO 
    … …  
    339310               DO jp = 0, 1 
    340311                  DO kp = 0, 1 
    341                      DO jj = 1, jpjm1 
    342                         DO ji = 1, fs_jpim1 
    343                            ze2vr = r1_e2v(ji,jj) 
    344                            zdyt  = zdjt(ji,jj,jk) * ze2vr 
    345                            ze3wr = 1._wp / e3w_n(ji,jj+jp,jk+kp) 
    346                            zdzt  = zdkt3d(ji,jj+jp,kp) * ze3wr 
    347                            zslope_skew = triadj_g(ji,jj+jp,jk,1-jp,kp) 
    348                            zslope_iso  = triadj(ji,jj+jp,jk,1-jp,kp) 
    349                            zbv = 0.25_wp * e1e2v(ji,jj) * e3v_n(ji,jj,jk) 
    350                            ! ln_botmix_triad is .F. mask zah for bottom half cells 
    351                            zah = pahv(ji,jj,jk) * vmask(ji,jj,jk+kp)         ! pahv(ji,jj+jp,jk)  ???? 
    352                            zah_slp = zah * zslope_iso 
    353                            IF( ln_ldfeiv )   zaei_slp = aeiv(ji,jj,jk) * zslope_skew        ! aeit(ji,jj+jp,jk)*zslope_skew 
    354                            zftv(ji,jj,jk) = zftv(ji,jj,jk) - ( zah * zdyt + (zah_slp - zaei_slp) * zdzt ) * zbv * ze2vr 
    355                            ztfw(ji,jj+jp,jk+kp) = ztfw(ji,jj+jp,jk+kp) - (zah_slp + zaei_slp) * zdyt * zbv * ze3wr 
    356                         END DO 
    357                      END DO 
     312                     DO_2D_10_10 
     313                        ze2vr = r1_e2v(ji,jj) 
     314                        zdyt  = zdjt(ji,jj,jk) * ze2vr 
     315                        ze3wr = 1._wp / e3w(ji,jj+jp,jk+kp,Kmm) 
     316                        zdzt  = zdkt3d(ji,jj+jp,kp) * ze3wr 
     317                        zslope_skew = triadj_g(ji,jj+jp,jk,1-jp,kp) 
     318                        zslope_iso  = triadj(ji,jj+jp,jk,1-jp,kp) 
     319                        zbv = 0.25_wp * e1e2v(ji,jj) * e3v(ji,jj,jk,Kmm) 
     320                        ! ln_botmix_triad is .F. mask zah for bottom half cells 
     321                        zah = pahv(ji,jj,jk) * vmask(ji,jj,jk+kp)         ! pahv(ji,jj+jp,jk)  ???? 
     322                        zah_slp = zah * zslope_iso 
     323                        IF( ln_ldfeiv )   zaei_slp = aeiv(ji,jj,jk) * zslope_skew        ! aeit(ji,jj+jp,jk)*zslope_skew 
     324                        zftv(ji,jj,jk) = zftv(ji,jj,jk) - ( zah * zdyt + (zah_slp - zaei_slp) * zdzt ) * zbv * ze2vr 
     325                        ztfw(ji,jj+jp,jk+kp) = ztfw(ji,jj+jp,jk+kp) - (zah_slp + zaei_slp) * zdyt * zbv * ze3wr 
     326                     END_2D 
    358327                  END DO 
    359328               END DO 
    360329            ENDIF 
    361330            !                             !==  horizontal divergence and add to the general trend  ==! 
    362             DO jj = 2 , jpjm1 
    363                DO ji = fs_2, fs_jpim1  ! vector opt. 
    364                   pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + zsign * (  zftu(ji-1,jj,jk) - zftu(ji,jj,jk)       & 
    365                      &                                           + zftv(ji,jj-1,jk) - zftv(ji,jj,jk)   )   & 
    366                      &                                        / (  e1e2t(ji,jj) * e3t_n(ji,jj,jk)  ) 
    367                END DO 
    368             END DO 
     331            DO_2D_00_00 
     332               pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn) + zsign * (  zftu(ji-1,jj,jk) - zftu(ji,jj,jk)       & 
     333                  &                                           + zftv(ji,jj-1,jk) - zftv(ji,jj,jk)   )   & 
     334                  &                                        / (  e1e2t(ji,jj) * e3t(ji,jj,jk,Kmm)  ) 
     335            END_2D 
    369336            ! 
    370337         END DO 
    … …  
    372339         !                                !==  add the vertical 33 flux  ==! 
    373340         IF( ln_traldf_lap ) THEN               ! laplacian case: eddy coef = ah_wslp2 - akz 
    374             DO jk = 2, jpkm1        
    375                DO jj = 1, jpjm1 
    376                   DO ji = fs_2, fs_jpim1 
    377                      ztfw(ji,jj,jk) = ztfw(ji,jj,jk) - e1e2t(ji,jj) / e3w_n(ji,jj,jk) * tmask(ji,jj,jk)   & 
    378                         &                            * ( ah_wslp2(ji,jj,jk) - akz(ji,jj,jk) )             & 
    379                         &                            * ( ptb(ji,jj,jk-1,jn) - ptb(ji,jj,jk,jn) ) 
    380                   END DO 
    381                END DO 
    382             END DO 
     341            DO_3D_10_00( 2, jpkm1 ) 
     342               ztfw(ji,jj,jk) = ztfw(ji,jj,jk) - e1e2t(ji,jj) / e3w(ji,jj,jk,Kmm) * tmask(ji,jj,jk)   & 
     343                  &                            * ( ah_wslp2(ji,jj,jk) - akz(ji,jj,jk) )             & 
     344                  &                            * (  pt(ji,jj,jk-1,jn) - pt(ji,jj,jk,jn) ) 
     345            END_3D 
    383346         ELSE                                   ! bilaplacian  
    384347            SELECT CASE( kpass ) 
    385348            CASE(  1  )                            ! 1st pass : eddy coef = ah_wslp2 
    386                DO jk = 2, jpkm1  
    387                   DO jj = 1, jpjm1 
    388                      DO ji = fs_2, fs_jpim1 
    389                         ztfw(ji,jj,jk) = ztfw(ji,jj,jk) - e1e2t(ji,jj) / e3w_n(ji,jj,jk) * tmask(ji,jj,jk)             & 
    390                            &                            * ah_wslp2(ji,jj,jk) * ( ptb(ji,jj,jk-1,jn) - ptb(ji,jj,jk,jn) ) 
    391                      END DO 
    392                   END DO 
    393                END DO  
    394             CASE(  2  )                            ! 2nd pass : eddy flux = ah_wslp2 and akz applied on ptb  and ptbb gradients, resp. 
    395                DO jk = 2, jpkm1  
    396                   DO jj = 1, jpjm1 
    397                      DO ji = fs_2, fs_jpim1 
    398                         ztfw(ji,jj,jk) = ztfw(ji,jj,jk) - e1e2t(ji,jj) / e3w_n(ji,jj,jk) * tmask(ji,jj,jk)                      & 
    399                            &                            * (  ah_wslp2(ji,jj,jk) * ( ptb (ji,jj,jk-1,jn) - ptb (ji,jj,jk,jn) )   & 
    400                            &                               + akz     (ji,jj,jk) * ( ptbb(ji,jj,jk-1,jn) - ptbb(ji,jj,jk,jn) )   ) 
    401                      END DO 
    402                   END DO 
    403                END DO 
     349               DO_3D_10_00( 2, jpkm1 ) 
     350                  ztfw(ji,jj,jk) = ztfw(ji,jj,jk) - e1e2t(ji,jj) / e3w(ji,jj,jk,Kmm) * tmask(ji,jj,jk)             & 
     351                     &                            * ah_wslp2(ji,jj,jk) * ( pt(ji,jj,jk-1,jn) - pt(ji,jj,jk,jn) ) 
     352               END_3D 
     353            CASE(  2  )                            ! 2nd pass : eddy flux = ah_wslp2 and akz applied on pt  and pt2 gradients, resp. 
     354               DO_3D_10_00( 2, jpkm1 ) 
     355                  ztfw(ji,jj,jk) = ztfw(ji,jj,jk) - e1e2t(ji,jj) / e3w(ji,jj,jk,Kmm) * tmask(ji,jj,jk)                      & 
     356                     &                            * (  ah_wslp2(ji,jj,jk) * ( pt (ji,jj,jk-1,jn) - pt (ji,jj,jk,jn) )   & 
     357                     &                               + akz     (ji,jj,jk) * ( pt2(ji,jj,jk-1,jn) - pt2(ji,jj,jk,jn) )   ) 
     358               END_3D 
    404359            END SELECT  
    405360         ENDIF 
    406361         ! 
    407          DO jk = 1, jpkm1                 !==  Divergence of vertical fluxes added to pta  ==! 
    408             DO jj = 2, jpjm1 
    409                DO ji = fs_2, fs_jpim1  ! vector opt. 
    410                   pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + zsign * (  ztfw(ji,jj,jk+1) - ztfw(ji,jj,jk)  )   & 
    411                      &                                        / ( e1e2t(ji,jj) * e3t_n(ji,jj,jk) ) 
    412                END DO 
    413             END DO 
    414          END DO 
     362         DO_3D_00_00( 1, jpkm1 ) 
     363            pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn) + zsign * (  ztfw(ji,jj,jk+1) - ztfw(ji,jj,jk)  )   & 
     364               &                                              / ( e1e2t(ji,jj) * e3t(ji,jj,jk,Kmm) ) 
     365         END_3D 
    415366         ! 
    416367         IF( ( kpass == 1 .AND. ln_traldf_lap ) .OR.  &     !==  first pass only (  laplacian)  ==! 

  • NEMO/trunk/src/OCE/TRA/tramle.F90

    r11536 r12377  
    4848 
    4949   !! * Substitutions 
    50 #  include "vectopt_loop_substitute.h90" 
     50#  include "do_loop_substitute.h90" 
    5151   !!---------------------------------------------------------------------- 
    5252   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    5656CONTAINS 
    5757 
    58    SUBROUTINE tra_mle_trp( kt, kit000, pu, pv, pw, cdtype ) 
     58   SUBROUTINE tra_mle_trp( kt, kit000, pu, pv, pw, cdtype, Kmm ) 
    5959      !!---------------------------------------------------------------------- 
    6060      !!                  ***  ROUTINE tra_mle_trp  *** 
    … …  
    7171      !!                p.n = p.n + z._mle 
    7272      !! 
    73       !! ** Action  : - (pun,pvn,pwn) increased by the mle transport 
     73      !! ** Action  : - (pu,pv,pw) increased by the mle transport 
    7474      !!                CAUTION, the transport is not updated at the last line/raw 
    7575      !!                         this may be a problem for some advection schemes 
    … …  
    8080      INTEGER                         , INTENT(in   ) ::   kt         ! ocean time-step index 
    8181      INTEGER                         , INTENT(in   ) ::   kit000     ! first time step index 
     82      INTEGER                         , INTENT(in   ) ::   Kmm        ! ocean time level index 
    8283      CHARACTER(len=3)                , INTENT(in   ) ::   cdtype     ! =TRA or TRC (tracer indicator) 
    8384      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pu         ! in : 3 ocean transport components 
    … …  
    9899      inml_mle(:,:) = mbkt(:,:) + 1                    ! init. to number of ocean w-level (T-level + 1) 
    99100      IF ( nla10 > 0 ) THEN                            ! avoid case where first level is thicker than 10m 
    100          DO jk = jpkm1, nlb10, -1                      ! from the bottom to nlb10 (10m) 
    101             DO jj = 1, jpj 
    102                DO ji = 1, jpi                          ! index of the w-level at the ML based 
    103                   IF( rhop(ji,jj,jk) > rhop(ji,jj,nla10) + rn_rho_c_mle )   inml_mle(ji,jj) = jk      ! Mixed layer 
    104                END DO 
    105             END DO 
    106          END DO 
     101         DO_3DS_11_11( jpkm1, nlb10, -1 ) 
     102            IF( rhop(ji,jj,jk) > rhop(ji,jj,nla10) + rn_rho_c_mle )   inml_mle(ji,jj) = jk      ! Mixed layer 
     103         END_3D 
    107104      ENDIF 
    108105      ikmax = MIN( MAXVAL( inml_mle(:,:) ), jpkm1 )                  ! max level of the computation 
    … …  
    112109      zbm (:,:) = 0._wp 
    113110      zn2 (:,:) = 0._wp 
    114       DO jk = 1, ikmax                                 ! MLD and mean buoyancy and N2 over the mixed layer 
    115          DO jj = 1, jpj 
    116             DO ji = 1, jpi 
    117                zc = e3t_n(ji,jj,jk) * REAL( MIN( MAX( 0, inml_mle(ji,jj)-jk ) , 1  )  )    ! zc being 0 outside the ML t-points 
    118                zmld(ji,jj) = zmld(ji,jj) + zc 
    119                zbm (ji,jj) = zbm (ji,jj) + zc * (rau0 - rhop(ji,jj,jk) ) * r1_rau0 
    120                zn2 (ji,jj) = zn2 (ji,jj) + zc * (rn2(ji,jj,jk)+rn2(ji,jj,jk+1))*0.5_wp 
    121             END DO 
    122          END DO 
    123       END DO 
     111      DO_3D_11_11( 1, ikmax ) 
     112         zc = e3t(ji,jj,jk,Kmm) * REAL( MIN( MAX( 0, inml_mle(ji,jj)-jk ) , 1  )  )    ! zc being 0 outside the ML t-points 
     113         zmld(ji,jj) = zmld(ji,jj) + zc 
     114         zbm (ji,jj) = zbm (ji,jj) + zc * (rau0 - rhop(ji,jj,jk) ) * r1_rau0 
     115         zn2 (ji,jj) = zn2 (ji,jj) + zc * (rn2(ji,jj,jk)+rn2(ji,jj,jk+1))*0.5_wp 
     116      END_3D 
    124117 
    125118      SELECT CASE( nn_mld_uv )                         ! MLD at u- & v-pts 
    126119      CASE ( 0 )                                               != min of the 2 neighbour MLDs 
    127          DO jj = 1, jpjm1 
    128             DO ji = 1, fs_jpim1   ! vector opt. 
    129                zhu(ji,jj) = MIN( zmld(ji+1,jj), zmld(ji,jj) ) 
    130                zhv(ji,jj) = MIN( zmld(ji,jj+1), zmld(ji,jj) ) 
    131             END DO 
    132          END DO 
     120         DO_2D_10_10 
     121            zhu(ji,jj) = MIN( zmld(ji+1,jj), zmld(ji,jj) ) 
     122            zhv(ji,jj) = MIN( zmld(ji,jj+1), zmld(ji,jj) ) 
     123         END_2D 
    133124      CASE ( 1 )                                               != average of the 2 neighbour MLDs 
    134          DO jj = 1, jpjm1 
    135             DO ji = 1, fs_jpim1   ! vector opt. 
    136                zhu(ji,jj) = ( zmld(ji+1,jj) + zmld(ji,jj) ) * 0.5_wp 
    137                zhv(ji,jj) = ( zmld(ji,jj+1) + zmld(ji,jj) ) * 0.5_wp 
    138             END DO 
    139          END DO 
     125         DO_2D_10_10 
     126            zhu(ji,jj) = ( zmld(ji+1,jj) + zmld(ji,jj) ) * 0.5_wp 
     127            zhv(ji,jj) = ( zmld(ji,jj+1) + zmld(ji,jj) ) * 0.5_wp 
     128         END_2D 
    140129      CASE ( 2 )                                               != max of the 2 neighbour MLDs 
    141          DO jj = 1, jpjm1 
    142             DO ji = 1, fs_jpim1   ! vector opt. 
    143                zhu(ji,jj) = MAX( zmld(ji+1,jj), zmld(ji,jj) ) 
    144                zhv(ji,jj) = MAX( zmld(ji,jj+1), zmld(ji,jj) ) 
    145             END DO 
    146          END DO 
     130         DO_2D_10_10 
     131            zhu(ji,jj) = MAX( zmld(ji+1,jj), zmld(ji,jj) ) 
     132            zhv(ji,jj) = MAX( zmld(ji,jj+1), zmld(ji,jj) ) 
     133         END_2D 
    147134      END SELECT 
    148135      !                                                ! convert density into buoyancy 
    149       zbm(:,:) = + grav * zbm(:,:) / MAX( e3t_n(:,:,1), zmld(:,:) ) 
     136      zbm(:,:) = + grav * zbm(:,:) / MAX( e3t(:,:,1,Kmm), zmld(:,:) ) 
    150137      ! 
    151138      ! 
    … …  
    158145      ! 
    159146      IF( nn_mle == 0 ) THEN           ! Fox-Kemper et al. 2010 formulation 
    160          DO jj = 1, jpjm1 
    161             DO ji = 1, fs_jpim1   ! vector opt. 
    162                zpsim_u(ji,jj) = rn_ce * zhu(ji,jj) * zhu(ji,jj)  * e2_e1u(ji,jj)                                            & 
    163                   &           * ( zbm(ji+1,jj) - zbm(ji,jj) ) * MIN( 111.e3_wp , e1u(ji,jj) )   & 
    164                   &           / (  MAX( rn_lf * rfu(ji,jj) , SQRT( rb_c * zhu(ji,jj) ) )   ) 
    165                   ! 
    166                zpsim_v(ji,jj) = rn_ce * zhv(ji,jj) * zhv(ji,jj)  * e1_e2v(ji,jj)                                            & 
    167                   &           * ( zbm(ji,jj+1) - zbm(ji,jj) ) * MIN( 111.e3_wp , e2v(ji,jj) )   & 
    168                   &           / (  MAX( rn_lf * rfv(ji,jj) , SQRT( rb_c * zhv(ji,jj) ) )   ) 
    169             END DO 
    170          END DO 
     147         DO_2D_10_10 
     148            zpsim_u(ji,jj) = rn_ce * zhu(ji,jj) * zhu(ji,jj)  * e2_e1u(ji,jj)                                            & 
     149               &           * ( zbm(ji+1,jj) - zbm(ji,jj) ) * MIN( 111.e3_wp , e1u(ji,jj) )   & 
     150               &           / (  MAX( rn_lf * rfu(ji,jj) , SQRT( rb_c * zhu(ji,jj) ) )   ) 
     151               ! 
     152            zpsim_v(ji,jj) = rn_ce * zhv(ji,jj) * zhv(ji,jj)  * e1_e2v(ji,jj)                                            & 
     153               &           * ( zbm(ji,jj+1) - zbm(ji,jj) ) * MIN( 111.e3_wp , e2v(ji,jj) )   & 
     154               &           / (  MAX( rn_lf * rfv(ji,jj) , SQRT( rb_c * zhv(ji,jj) ) )   ) 
     155         END_2D 
    171156         ! 
    172157      ELSEIF( nn_mle == 1 ) THEN       ! New formulation (Lf = 5km fo/ff with fo=Coriolis parameter at latitude rn_lat) 
    173          DO jj = 1, jpjm1 
    174             DO ji = 1, fs_jpim1   ! vector opt. 
    175                zpsim_u(ji,jj) = rc_f *   zhu(ji,jj)   * zhu(ji,jj)   * e2_e1u(ji,jj)               & 
    176                   &                  * ( zbm(ji+1,jj) - zbm(ji,jj) ) * MIN( 111.e3_wp , e1u(ji,jj) ) 
    177                   ! 
    178                zpsim_v(ji,jj) = rc_f *   zhv(ji,jj)   * zhv(ji,jj)   * e1_e2v(ji,jj)               & 
    179                   &                  * ( zbm(ji,jj+1) - zbm(ji,jj) ) * MIN( 111.e3_wp , e2v(ji,jj) ) 
    180             END DO 
    181          END DO 
     158         DO_2D_10_10 
     159            zpsim_u(ji,jj) = rc_f *   zhu(ji,jj)   * zhu(ji,jj)   * e2_e1u(ji,jj)               & 
     160               &                  * ( zbm(ji+1,jj) - zbm(ji,jj) ) * MIN( 111.e3_wp , e1u(ji,jj) ) 
     161               ! 
     162            zpsim_v(ji,jj) = rc_f *   zhv(ji,jj)   * zhv(ji,jj)   * e1_e2v(ji,jj)               & 
     163               &                  * ( zbm(ji,jj+1) - zbm(ji,jj) ) * MIN( 111.e3_wp , e2v(ji,jj) ) 
     164         END_2D 
    182165      ENDIF 
    183166      ! 
    184167      IF( nn_conv == 1 ) THEN              ! No MLE in case of convection 
    185          DO jj = 1, jpjm1 
    186             DO ji = 1, fs_jpim1   ! vector opt. 
    187                IF( MIN( zn2(ji,jj) , zn2(ji+1,jj) ) < 0._wp )   zpsim_u(ji,jj) = 0._wp 
    188                IF( MIN( zn2(ji,jj) , zn2(ji,jj+1) ) < 0._wp )   zpsim_v(ji,jj) = 0._wp 
    189             END DO 
    190          END DO 
     168         DO_2D_10_10 
     169            IF( MIN( zn2(ji,jj) , zn2(ji+1,jj) ) < 0._wp )   zpsim_u(ji,jj) = 0._wp 
     170            IF( MIN( zn2(ji,jj) , zn2(ji,jj+1) ) < 0._wp )   zpsim_v(ji,jj) = 0._wp 
     171         END_2D 
    191172      ENDIF 
    192173      ! 
    193174      !                                      !==  structure function value at uw- and vw-points  ==! 
    194       DO jj = 1, jpjm1 
    195          DO ji = 1, fs_jpim1   ! vector opt. 
    196             zhu(ji,jj) = 1._wp / zhu(ji,jj)                   ! hu --> 1/hu 
    197             zhv(ji,jj) = 1._wp / zhv(ji,jj) 
    198          END DO 
    199       END DO 
     175      DO_2D_10_10 
     176         zhu(ji,jj) = 1._wp / zhu(ji,jj)                   ! hu --> 1/hu 
     177         zhv(ji,jj) = 1._wp / zhv(ji,jj) 
     178      END_2D 
    200179      ! 
    201180      zpsi_uw(:,:,:) = 0._wp 
    202181      zpsi_vw(:,:,:) = 0._wp 
    203182      ! 
    204       DO jk = 2, ikmax                                ! start from 2 : surface value = 0 
    205          DO jj = 1, jpjm1 
    206             DO ji = 1, fs_jpim1   ! vector opt. 
    207                zcuw = 1._wp - ( gdepw_n(ji+1,jj,jk) + gdepw_n(ji,jj,jk) ) * zhu(ji,jj) 
    208                zcvw = 1._wp - ( gdepw_n(ji,jj+1,jk) + gdepw_n(ji,jj,jk) ) * zhv(ji,jj) 
    209                zcuw = zcuw * zcuw 
    210                zcvw = zcvw * zcvw 
    211                zmuw = MAX(  0._wp , ( 1._wp - zcuw ) * ( 1._wp + r5_21 * zcuw )  ) 
    212                zmvw = MAX(  0._wp , ( 1._wp - zcvw ) * ( 1._wp + r5_21 * zcvw )  ) 
    213                ! 
    214                zpsi_uw(ji,jj,jk) = zpsim_u(ji,jj) * zmuw * umask(ji,jj,jk) 
    215                zpsi_vw(ji,jj,jk) = zpsim_v(ji,jj) * zmvw * vmask(ji,jj,jk) 
    216             END DO 
    217          END DO 
    218       END DO 
     183      DO_3D_10_10( 2, ikmax ) 
     184         zcuw = 1._wp - ( gdepw(ji+1,jj,jk,Kmm) + gdepw(ji,jj,jk,Kmm) ) * zhu(ji,jj) 
     185         zcvw = 1._wp - ( gdepw(ji,jj+1,jk,Kmm) + gdepw(ji,jj,jk,Kmm) ) * zhv(ji,jj) 
     186         zcuw = zcuw * zcuw 
     187         zcvw = zcvw * zcvw 
     188         zmuw = MAX(  0._wp , ( 1._wp - zcuw ) * ( 1._wp + r5_21 * zcuw )  ) 
     189         zmvw = MAX(  0._wp , ( 1._wp - zcvw ) * ( 1._wp + r5_21 * zcvw )  ) 
     190         ! 
     191         zpsi_uw(ji,jj,jk) = zpsim_u(ji,jj) * zmuw * umask(ji,jj,jk) 
     192         zpsi_vw(ji,jj,jk) = zpsim_v(ji,jj) * zmvw * vmask(ji,jj,jk) 
     193      END_3D 
    219194      ! 
    220195      !                                      !==  transport increased by the MLE induced transport ==! 
    221196      DO jk = 1, ikmax 
    222          DO jj = 1, jpjm1                          ! CAUTION pu,pv must be defined at row/column i=1 / j=1 
    223             DO ji = 1, fs_jpim1   ! vector opt. 
    224                pu(ji,jj,jk) = pu(ji,jj,jk) + ( zpsi_uw(ji,jj,jk) - zpsi_uw(ji,jj,jk+1) ) 
    225                pv(ji,jj,jk) = pv(ji,jj,jk) + ( zpsi_vw(ji,jj,jk) - zpsi_vw(ji,jj,jk+1) ) 
    226             END DO 
    227          END DO 
    228          DO jj = 2, jpjm1 
    229             DO ji = fs_2, fs_jpim1   ! vector opt. 
    230                pw(ji,jj,jk) = pw(ji,jj,jk) - ( zpsi_uw(ji,jj,jk) - zpsi_uw(ji-1,jj,jk)   & 
    231                   &                          + zpsi_vw(ji,jj,jk) - zpsi_vw(ji,jj-1,jk) ) 
    232             END DO 
    233          END DO 
     197         DO_2D_10_10 
     198            pu(ji,jj,jk) = pu(ji,jj,jk) + ( zpsi_uw(ji,jj,jk) - zpsi_uw(ji,jj,jk+1) ) 
     199            pv(ji,jj,jk) = pv(ji,jj,jk) + ( zpsi_vw(ji,jj,jk) - zpsi_vw(ji,jj,jk+1) ) 
     200         END_2D 
     201         DO_2D_00_00 
     202            pw(ji,jj,jk) = pw(ji,jj,jk) - ( zpsi_uw(ji,jj,jk) - zpsi_uw(ji-1,jj,jk)   & 
     203               &                          + zpsi_vw(ji,jj,jk) - zpsi_vw(ji,jj-1,jk) ) 
     204         END_2D 
    234205      END DO 
    235206 
    … …  
    266237      !!---------------------------------------------------------------------- 
    267238 
    268       REWIND( numnam_ref )              ! Namelist namtra_mle in reference namelist : Tracer advection scheme 
    269239      READ  ( numnam_ref, namtra_mle, IOSTAT = ios, ERR = 901) 
    270240901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namtra_mle in reference namelist' ) 
    271241 
    272       REWIND( numnam_cfg )              ! Namelist namtra_mle in configuration namelist : Tracer advection scheme 
    273242      READ  ( numnam_cfg, namtra_mle, IOSTAT = ios, ERR = 902 ) 
    274243902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namtra_mle in configuration namelist' ) 
    … …  
    313282            IF( ierr /= 0 )   CALL ctl_stop( 'tra_adv_mle_init: failed to allocate arrays' ) 
    314283            z1_t2 = 1._wp / ( rn_time * rn_time ) 
    315             DO jj = 2, jpj                           ! "coriolis+ time^-1" at u- & v-points 
    316                DO ji = fs_2, jpi   ! vector opt. 
    317                   zfu = ( ff_f(ji,jj) + ff_f(ji,jj-1) ) * 0.5_wp 
    318                   zfv = ( ff_f(ji,jj) + ff_f(ji-1,jj) ) * 0.5_wp 
    319                   rfu(ji,jj) = SQRT(  zfu * zfu + z1_t2 ) 
    320                   rfv(ji,jj) = SQRT(  zfv * zfv + z1_t2 ) 
    321                END DO 
    322             END DO 
     284            DO_2D_01_01 
     285               zfu = ( ff_f(ji,jj) + ff_f(ji,jj-1) ) * 0.5_wp 
     286               zfv = ( ff_f(ji,jj) + ff_f(ji-1,jj) ) * 0.5_wp 
     287               rfu(ji,jj) = SQRT(  zfu * zfu + z1_t2 ) 
     288               rfv(ji,jj) = SQRT(  zfv * zfv + z1_t2 ) 
     289            END_2D 
    323290            CALL lbc_lnk_multi( 'tramle', rfu, 'U', 1. , rfv, 'V', 1. ) 
    324291            ! 

  • NEMO/trunk/src/OCE/TRA/tranpc.F90

    r10425 r12377  
    3434 
    3535   !! * Substitutions 
    36 #  include "vectopt_loop_substitute.h90" 
     36#  include "do_loop_substitute.h90" 
    3737   !!---------------------------------------------------------------------- 
    3838   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    4242CONTAINS 
    4343 
    44    SUBROUTINE tra_npc( kt ) 
     44   SUBROUTINE tra_npc( kt, Kmm, Krhs, pts, Kaa ) 
    4545      !!---------------------------------------------------------------------- 
    4646      !!                  ***  ROUTINE tranpc  *** 
    … …  
    5858      !! References :     Madec, et al., 1991, JPO, 21, 9, 1349-1371. 
    5959      !!---------------------------------------------------------------------- 
    60       INTEGER, INTENT(in) ::   kt   ! ocean time-step index 
     60      INTEGER,                                   INTENT(in   ) :: kt              ! ocean time-step index 
     61      INTEGER,                                   INTENT(in   ) :: Kmm, Krhs, Kaa  ! time level indices 
     62      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts             ! active tracers and RHS of tracer equation 
    6163      ! 
    6264      INTEGER  ::   ji, jj, jk   ! dummy loop indices 
    … …  
    6668      REAL(wp) ::   zta, zalfa, zsum_temp, zsum_alfa, zaw, zdz, zsum_z 
    6769      REAL(wp) ::   zsa, zbeta, zsum_sali, zsum_beta, zbw, zrw, z1_r2dt 
    68       REAL(wp), PARAMETER ::   zn2_zero = 1.e-14_wp      ! acceptance criteria for neutrality (N2==0) 
    69       REAL(wp), DIMENSION(        jpk     ) ::   zvn2         ! vertical profile of N2 at 1 given point... 
    70       REAL(wp), DIMENSION(        jpk,jpts) ::   zvts, zvab   ! vertical profile of T & S , and  alpha & betaat 1 given point 
    71       REAL(wp), DIMENSION(jpi,jpj,jpk     ) ::   zn2          ! N^2  
    72       REAL(wp), DIMENSION(jpi,jpj,jpk,jpts) ::   zab          ! alpha and beta 
    73       REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   ztrdt, ztrds   ! 3D workspace 
     70      REAL(wp), PARAMETER ::   zn2_zero = 1.e-14_wp             ! acceptance criteria for neutrality (N2==0) 
     71      REAL(wp), DIMENSION(        jpk     )   ::   zvn2         ! vertical profile of N2 at 1 given point... 
     72      REAL(wp), DIMENSION(        jpk,jpts)   ::   zvts, zvab   ! vertical profile of T & S , and  alpha & betaat 1 given point 
     73      REAL(wp), DIMENSION(jpi,jpj,jpk     )   ::   zn2          ! N^2  
     74      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts)   ::   zab          ! alpha and beta 
     75      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   ztrdt, ztrds ! 3D workspace 
    7476      ! 
    7577      LOGICAL, PARAMETER :: l_LB_debug = .FALSE. ! set to true if you want to follow what is 
    … …  
    8486         IF( l_trdtra )   THEN                    !* Save initial after fields 
    8587            ALLOCATE( ztrdt(jpi,jpj,jpk) , ztrds(jpi,jpj,jpk) ) 
    86             ztrdt(:,:,:) = tsa(:,:,:,jp_tem)  
    87             ztrds(:,:,:) = tsa(:,:,:,jp_sal) 
     88            ztrdt(:,:,:) = pts(:,:,:,jp_tem,Kaa)  
     89            ztrds(:,:,:) = pts(:,:,:,jp_sal,Kaa) 
    8890         ENDIF 
    8991         ! 
    … …  
    9597         ENDIF 
    9698         ! 
    97          CALL eos_rab( tsa, zab )         ! after alpha and beta (given on T-points) 
    98          CALL bn2    ( tsa, zab, zn2 )    ! after Brunt-Vaisala  (given on W-points) 
     99         CALL eos_rab( pts(:,:,:,:,Kaa), zab, Kmm )         ! after alpha and beta (given on T-points) 
     100         CALL bn2    ( pts(:,:,:,:,Kaa), zab, zn2, Kmm )    ! after Brunt-Vaisala  (given on W-points) 
    99101         ! 
    100102         inpcc = 0 
    101103         ! 
    102          DO jj = 2, jpjm1                 ! interior column only 
    103             DO ji = fs_2, fs_jpim1 
     104         DO_2D_00_00 
     105            ! 
     106            IF( tmask(ji,jj,2) == 1 ) THEN      ! At least 2 ocean points 
     107               !                                     ! consider one ocean column  
     108               zvts(:,jp_tem) = pts(ji,jj,:,jp_tem,Kaa)      ! temperature 
     109               zvts(:,jp_sal) = pts(ji,jj,:,jp_sal,Kaa)      ! salinity 
    104110               ! 
    105                IF( tmask(ji,jj,2) == 1 ) THEN      ! At least 2 ocean points 
    106                   !                                     ! consider one ocean column  
    107                   zvts(:,jp_tem) = tsa(ji,jj,:,jp_tem)      ! temperature 
    108                   zvts(:,jp_sal) = tsa(ji,jj,:,jp_sal)      ! salinity 
    109                   ! 
    110                   zvab(:,jp_tem)  = zab(ji,jj,:,jp_tem)     ! Alpha  
    111                   zvab(:,jp_sal)  = zab(ji,jj,:,jp_sal)     ! Beta   
    112                   zvn2(:)         = zn2(ji,jj,:)            ! N^2  
    113                   ! 
    114                   IF( l_LB_debug ) THEN                  !LB debug: 
    115                      lp_monitor_point = .FALSE. 
    116                      IF( ( ji == ilc1 ).AND.( jj == jlc1 ) ) lp_monitor_point = .TRUE. 
    117                      ! writing only if on CPU domain where conv region is: 
    118                      lp_monitor_point = (narea == nncpu).AND.lp_monitor_point                       
    119                   ENDIF                                  !LB debug  end 
    120                   ! 
    121                   ikbot = mbkt(ji,jj)   ! ikbot: ocean bottom T-level 
    122                   ikp = 1                  ! because N2 is irrelevant at the surface level (will start at ikp=2) 
    123                   ilayer = 0 
    124                   jiter  = 0 
    125                   l_column_treated = .FALSE. 
    126                   ! 
    127                   DO WHILE ( .NOT. l_column_treated ) 
    128                      ! 
    129                      jiter = jiter + 1 
    130                      !  
    131                      IF( jiter >= 400 ) EXIT 
    132                      ! 
    133                      l_bottom_reached = .FALSE. 
    134                      ! 
    135                      DO WHILE ( .NOT. l_bottom_reached ) 
    136                         ! 
    137                         ikp = ikp + 1 
    138                         ! 
    139                         !! Testing level ikp for instability 
    140                         !! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 
    141                         IF( zvn2(ikp) <  -zn2_zero ) THEN ! Instability found! 
    142                            ! 
    143                            ilayer = ilayer + 1    ! yet another instable portion of the water column found.... 
    144                            ! 
    145                            IF( lp_monitor_point ) THEN  
     111               zvab(:,jp_tem)  = zab(ji,jj,:,jp_tem)     ! Alpha  
     112               zvab(:,jp_sal)  = zab(ji,jj,:,jp_sal)     ! Beta   
     113               zvn2(:)         = zn2(ji,jj,:)            ! N^2  
     114               ! 
     115               IF( l_LB_debug ) THEN                  !LB debug: 
     116                  lp_monitor_point = .FALSE. 
     117                  IF( ( ji == ilc1 ).AND.( jj == jlc1 ) ) lp_monitor_point = .TRUE. 
     118                  ! writing only if on CPU domain where conv region is: 
     119                  lp_monitor_point = (narea == nncpu).AND.lp_monitor_point                       
     120               ENDIF                                  !LB debug  end 
     121               ! 
     122               ikbot = mbkt(ji,jj)   ! ikbot: ocean bottom T-level 
     123               ikp = 1                  ! because N2 is irrelevant at the surface level (will start at ikp=2) 
     124               ilayer = 0 
     125               jiter  = 0 
     126               l_column_treated = .FALSE. 
     127               ! 
     128               DO WHILE ( .NOT. l_column_treated ) 
     129                  ! 
     130                  jiter = jiter + 1 
     131                  !  
     132                  IF( jiter >= 400 ) EXIT 
     133                  ! 
     134                  l_bottom_reached = .FALSE. 
     135                  ! 
     136                  DO WHILE ( .NOT. l_bottom_reached ) 
     137                     ! 
     138                     ikp = ikp + 1 
     139                     ! 
     140                     !! Testing level ikp for instability 
     141                     !! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 
     142                     IF( zvn2(ikp) <  -zn2_zero ) THEN ! Instability found! 
     143                        ! 
     144                        ilayer = ilayer + 1    ! yet another instable portion of the water column found.... 
     145                        ! 
     146                        IF( lp_monitor_point ) THEN  
     147                           WRITE(numout,*) 
     148                           IF( ilayer == 1 .AND. jiter == 1 ) THEN   ! first time a column is spoted with an instability 
    146149                              WRITE(numout,*) 
    147                               IF( ilayer == 1 .AND. jiter == 1 ) THEN   ! first time a column is spoted with an instability 
    148                                  WRITE(numout,*) 
    149                                  WRITE(numout,*) 'Time step = ',kt,' !!!' 
    150                               ENDIF 
    151                               WRITE(numout,*)  ' * Iteration #',jiter,': found instable portion #',ilayer,   & 
    152                                  &                                    ' in column! Starting at ikp =', ikp 
    153                               WRITE(numout,*)  ' *** N2 for point (i,j) = ',ji,' , ',jj 
    154                               DO jk = 1, klc1 
    155                                  WRITE(numout,*) jk, zvn2(jk) 
    156                               END DO 
    157                               WRITE(numout,*) 
     150                              WRITE(numout,*) 'Time step = ',kt,' !!!' 
    158151                           ENDIF 
    159                            ! 
    160                            IF( jiter == 1 )   inpcc = inpcc + 1  
    161                            ! 
    162                            IF( lp_monitor_point )   WRITE(numout, *) 'Negative N2 at ikp =',ikp,' for layer #', ilayer 
    163                            ! 
    164                            !! ikup is the uppermost point where mixing will start: 
    165                            ikup = ikp - 1 ! ikup is always "at most at ikp-1", less if neutral levels overlying 
    166                            ! 
    167                            !! If the points above ikp-1 have N2 == 0 they must also be mixed: 
    168                            IF( ikp > 2 ) THEN 
    169                               DO jk = ikp-1, 2, -1 
    170                                  IF( ABS(zvn2(jk)) < zn2_zero ) THEN 
    171                                     ikup = ikup - 1  ! 1 more upper level has N2=0 and must be added for the mixing 
    172                                  ELSE 
    173                                     EXIT 
    174                                  ENDIF 
    175                               END DO 
    176                            ENDIF 
    177                            ! 
    178                            IF( ikup < 1 )   CALL ctl_stop( 'tra_npc :  PROBLEM #1') 
    179                            ! 
    180                            zsum_temp = 0._wp 
    181                            zsum_sali = 0._wp 
    182                            zsum_alfa = 0._wp 
    183                            zsum_beta = 0._wp 
    184                            zsum_z    = 0._wp 
    185                                                      
    186                            DO jk = ikup, ikbot      ! Inside the instable (and overlying neutral) portion of the column 
    187                               ! 
    188                               zdz       = e3t_n(ji,jj,jk) 
    189                               zsum_temp = zsum_temp + zvts(jk,jp_tem)*zdz 
    190                               zsum_sali = zsum_sali + zvts(jk,jp_sal)*zdz 
    191                               zsum_alfa = zsum_alfa + zvab(jk,jp_tem)*zdz 
    192                               zsum_beta = zsum_beta + zvab(jk,jp_sal)*zdz 
    193                               zsum_z    = zsum_z    + zdz 
    194                               !                               
    195                               IF( jk == ikbot ) EXIT ! avoid array-index overshoot in case ikbot = jpk, cause we're calling jk+1 next line 
    196                               !! EXIT when we have reached the last layer that is instable (N2<0) or neutral (N2=0): 
    197                               IF( zvn2(jk+1) > zn2_zero ) EXIT 
    198                            END DO 
    199                            
    200                            ikdown = jk ! for the current unstable layer, ikdown is the deepest point with a negative or neutral N2 
    201                            IF( ikup == ikdown )   CALL ctl_stop( 'tra_npc :  PROBLEM #2') 
    202  
    203                            ! Mixing Temperature, salinity, alpha and beta from ikup to ikdown included: 
    204                            zta   = zsum_temp/zsum_z 
    205                            zsa   = zsum_sali/zsum_z 
    206                            zalfa = zsum_alfa/zsum_z 
    207                            zbeta = zsum_beta/zsum_z 
    208  
    209                            IF( lp_monitor_point ) THEN 
    210                               WRITE(numout,*) 'MIXED T, S, alfa and beta between ikup =',ikup,   & 
    211                                  &            ' and ikdown =',ikdown,', in layer #',ilayer 
    212                               WRITE(numout,*) '  => Mean temp. in that portion =', zta 
    213                               WRITE(numout,*) '  => Mean sali. in that portion =', zsa 
    214                               WRITE(numout,*) '  => Mean Alfa  in that portion =', zalfa 
    215                               WRITE(numout,*) '  => Mean Beta  in that portion =', zbeta 
    216                            ENDIF 
    217  
    218                            !! Homogenaizing the temperature, salinity, alpha and beta in this portion of the column 
    219                            DO jk = ikup, ikdown 
    220                               zvts(jk,jp_tem) = zta 
    221                               zvts(jk,jp_sal) = zsa 
    222                               zvab(jk,jp_tem) = zalfa 
    223                               zvab(jk,jp_sal) = zbeta 
    224                            END DO 
    225                             
    226                             
    227                            !! Updating N2 in the relvant portion of the water column 
    228                            !! Temperature, Salinity, Alpha and Beta have been homogenized in the unstable portion 
    229                            !! => Need to re-compute N2! will use Alpha and Beta! 
    230                             
    231                            ikup   = MAX(2,ikup)         ! ikup can never be 1 ! 
    232                            ik_low = MIN(ikdown+1,ikbot) ! we must go 1 point deeper than ikdown! 
    233                             
    234                            DO jk = ikup, ik_low              ! we must go 1 point deeper than ikdown! 
    235  
    236                               !! Interpolating alfa and beta at W point: 
    237                               zrw =  (gdepw_n(ji,jj,jk  ) - gdept_n(ji,jj,jk)) & 
    238                                  & / (gdept_n(ji,jj,jk-1) - gdept_n(ji,jj,jk)) 
    239                               zaw = zvab(jk,jp_tem) * (1._wp - zrw) + zvab(jk-1,jp_tem) * zrw 
    240                               zbw = zvab(jk,jp_sal) * (1._wp - zrw) + zvab(jk-1,jp_sal) * zrw 
    241  
    242                               !! N2 at W point, doing exactly as in eosbn2.F90: 
    243                               zvn2(jk) = grav*( zaw * ( zvts(jk-1,jp_tem) - zvts(jk,jp_tem) )     & 
    244                                  &            - zbw * ( zvts(jk-1,jp_sal) - zvts(jk,jp_sal) )  )  & 
    245                                  &       / e3w_n(ji,jj,jk) * tmask(ji,jj,jk) 
    246  
    247                               !! OR, faster  => just considering the vertical gradient of density 
    248                               !! as only the signa maters... 
    249                               !zvn2(jk) = (  zaw * ( zvts(jk-1,jp_tem) - zvts(jk,jp_tem) )     & 
    250                               !     &      - zbw * ( zvts(jk-1,jp_sal) - zvts(jk,jp_sal) )  ) 
    251  
    252                            END DO 
    253                          
    254                            ikp = MIN(ikdown+1,ikbot) 
    255                             
    256  
    257                         ENDIF  !IF( zvn2(ikp) < 0. ) 
    258  
    259  
    260                         IF( ikp == ikbot ) l_bottom_reached = .TRUE. 
    261                         ! 
    262                      END DO ! DO WHILE ( .NOT. l_bottom_reached ) 
    263  
    264                      IF( ikp /= ikbot )   CALL ctl_stop( 'tra_npc :  PROBLEM #3') 
    265                      
    266                      ! ******* At this stage ikp == ikbot ! ******* 
    267                      
    268                      IF( ilayer > 0 ) THEN      !! least an unstable layer has been found 
    269                         ! 
    270                         IF( lp_monitor_point ) THEN 
    271                            WRITE(numout,*) 
    272                            WRITE(numout,*) 'After ',jiter,' iteration(s), we neutralized ',ilayer,' instable layer(s)' 
    273                            WRITE(numout,*) '   ==> N2 at i,j=',ji,',',jj,' now looks like this:' 
     152                           WRITE(numout,*)  ' * Iteration #',jiter,': found instable portion #',ilayer,   & 
     153                              &                                    ' in column! Starting at ikp =', ikp 
     154                           WRITE(numout,*)  ' *** N2 for point (i,j) = ',ji,' , ',jj 
    274155                           DO jk = 1, klc1 
    275156                              WRITE(numout,*) jk, zvn2(jk) 
    … …  
    278159                        ENDIF 
    279160                        ! 
    280                         ikp    = 1     ! starting again at the surface for the next iteration 
    281                         ilayer = 0 
     161                        IF( jiter == 1 )   inpcc = inpcc + 1  
     162                        ! 
     163                        IF( lp_monitor_point )   WRITE(numout, *) 'Negative N2 at ikp =',ikp,' for layer #', ilayer 
     164                        ! 
     165                        !! ikup is the uppermost point where mixing will start: 
     166                        ikup = ikp - 1 ! ikup is always "at most at ikp-1", less if neutral levels overlying 
     167                        ! 
     168                        !! If the points above ikp-1 have N2 == 0 they must also be mixed: 
     169                        IF( ikp > 2 ) THEN 
     170                           DO jk = ikp-1, 2, -1 
     171                              IF( ABS(zvn2(jk)) < zn2_zero ) THEN 
     172                                 ikup = ikup - 1  ! 1 more upper level has N2=0 and must be added for the mixing 
     173                              ELSE 
     174                                 EXIT 
     175                              ENDIF 
     176                           END DO 
     177                        ENDIF 
     178                        ! 
     179                        IF( ikup < 1 )   CALL ctl_stop( 'tra_npc :  PROBLEM #1') 
     180                        ! 
     181                        zsum_temp = 0._wp 
     182                        zsum_sali = 0._wp 
     183                        zsum_alfa = 0._wp 
     184                        zsum_beta = 0._wp 
     185                        zsum_z    = 0._wp 
     186                                                  
     187                        DO jk = ikup, ikbot      ! Inside the instable (and overlying neutral) portion of the column 
     188                           ! 
     189                           zdz       = e3t(ji,jj,jk,Kmm) 
     190                           zsum_temp = zsum_temp + zvts(jk,jp_tem)*zdz 
     191                           zsum_sali = zsum_sali + zvts(jk,jp_sal)*zdz 
     192                           zsum_alfa = zsum_alfa + zvab(jk,jp_tem)*zdz 
     193                           zsum_beta = zsum_beta + zvab(jk,jp_sal)*zdz 
     194                           zsum_z    = zsum_z    + zdz 
     195                           !                               
     196                           IF( jk == ikbot ) EXIT ! avoid array-index overshoot in case ikbot = jpk, cause we're calling jk+1 next line 
     197                           !! EXIT when we have reached the last layer that is instable (N2<0) or neutral (N2=0): 
     198                           IF( zvn2(jk+1) > zn2_zero ) EXIT 
     199                        END DO 
     200                        
     201                        ikdown = jk ! for the current unstable layer, ikdown is the deepest point with a negative or neutral N2 
     202                        IF( ikup == ikdown )   CALL ctl_stop( 'tra_npc :  PROBLEM #2') 
     203 
     204                        ! Mixing Temperature, salinity, alpha and beta from ikup to ikdown included: 
     205                        zta   = zsum_temp/zsum_z 
     206                        zsa   = zsum_sali/zsum_z 
     207                        zalfa = zsum_alfa/zsum_z 
     208                        zbeta = zsum_beta/zsum_z 
     209 
     210                        IF( lp_monitor_point ) THEN 
     211                           WRITE(numout,*) 'MIXED T, S, alfa and beta between ikup =',ikup,   & 
     212                              &            ' and ikdown =',ikdown,', in layer #',ilayer 
     213                           WRITE(numout,*) '  => Mean temp. in that portion =', zta 
     214                           WRITE(numout,*) '  => Mean sali. in that portion =', zsa 
     215                           WRITE(numout,*) '  => Mean Alfa  in that portion =', zalfa 
     216                           WRITE(numout,*) '  => Mean Beta  in that portion =', zbeta 
     217                        ENDIF 
     218 
     219                        !! Homogenaizing the temperature, salinity, alpha and beta in this portion of the column 
     220                        DO jk = ikup, ikdown 
     221                           zvts(jk,jp_tem) = zta 
     222                           zvts(jk,jp_sal) = zsa 
     223                           zvab(jk,jp_tem) = zalfa 
     224                           zvab(jk,jp_sal) = zbeta 
     225                        END DO 
     226                         
     227                         
     228                        !! Updating N2 in the relvant portion of the water column 
     229                        !! Temperature, Salinity, Alpha and Beta have been homogenized in the unstable portion 
     230                        !! => Need to re-compute N2! will use Alpha and Beta! 
     231                         
     232                        ikup   = MAX(2,ikup)         ! ikup can never be 1 ! 
     233                        ik_low = MIN(ikdown+1,ikbot) ! we must go 1 point deeper than ikdown! 
     234                         
     235                        DO jk = ikup, ik_low              ! we must go 1 point deeper than ikdown! 
     236 
     237                           !! Interpolating alfa and beta at W point: 
     238                           zrw =  (gdepw(ji,jj,jk  ,Kmm) - gdept(ji,jj,jk,Kmm)) & 
     239                              & / (gdept(ji,jj,jk-1,Kmm) - gdept(ji,jj,jk,Kmm)) 
     240                           zaw = zvab(jk,jp_tem) * (1._wp - zrw) + zvab(jk-1,jp_tem) * zrw 
     241                           zbw = zvab(jk,jp_sal) * (1._wp - zrw) + zvab(jk-1,jp_sal) * zrw 
     242 
     243                           !! N2 at W point, doing exactly as in eosbn2.F90: 
     244                           zvn2(jk) = grav*( zaw * ( zvts(jk-1,jp_tem) - zvts(jk,jp_tem) )     & 
     245                              &            - zbw * ( zvts(jk-1,jp_sal) - zvts(jk,jp_sal) )  )  & 
     246                              &       / e3w(ji,jj,jk,Kmm) * tmask(ji,jj,jk) 
     247 
     248                           !! OR, faster  => just considering the vertical gradient of density 
     249                           !! as only the signa maters... 
     250                           !zvn2(jk) = (  zaw * ( zvts(jk-1,jp_tem) - zvts(jk,jp_tem) )     & 
     251                           !     &      - zbw * ( zvts(jk-1,jp_sal) - zvts(jk,jp_sal) )  ) 
     252 
     253                        END DO 
     254                      
     255                        ikp = MIN(ikdown+1,ikbot) 
     256                         
     257 
     258                     ENDIF  !IF( zvn2(ikp) < 0. ) 
     259 
     260 
     261                     IF( ikp == ikbot ) l_bottom_reached = .TRUE. 
     262                     ! 
     263                  END DO ! DO WHILE ( .NOT. l_bottom_reached ) 
     264 
     265                  IF( ikp /= ikbot )   CALL ctl_stop( 'tra_npc :  PROBLEM #3') 
     266                  
     267                  ! ******* At this stage ikp == ikbot ! ******* 
     268                  
     269                  IF( ilayer > 0 ) THEN      !! least an unstable layer has been found 
     270                     ! 
     271                     IF( lp_monitor_point ) THEN 
     272                        WRITE(numout,*) 
     273                        WRITE(numout,*) 'After ',jiter,' iteration(s), we neutralized ',ilayer,' instable layer(s)' 
     274                        WRITE(numout,*) '   ==> N2 at i,j=',ji,',',jj,' now looks like this:' 
     275                        DO jk = 1, klc1 
     276                           WRITE(numout,*) jk, zvn2(jk) 
     277                        END DO 
     278                        WRITE(numout,*) 
    282279                     ENDIF 
    283280                     ! 
    284                      IF( ikp >= ikbot )   l_column_treated = .TRUE. 
    285                      ! 
    286                   END DO ! DO WHILE ( .NOT. l_column_treated ) 
    287  
    288                   !! Updating tsa: 
    289                   tsa(ji,jj,:,jp_tem) = zvts(:,jp_tem) 
    290                   tsa(ji,jj,:,jp_sal) = zvts(:,jp_sal) 
    291  
    292                   !! LB:  Potentially some other global variable beside theta and S can be treated here 
    293                   !!      like BGC tracers. 
    294  
    295                   IF( lp_monitor_point )   WRITE(numout,*) 
    296  
    297                ENDIF ! IF( tmask(ji,jj,3) == 1 ) THEN 
    298  
    299             END DO ! ji 
    300          END DO ! jj 
     281                     ikp    = 1     ! starting again at the surface for the next iteration 
     282                     ilayer = 0 
     283                  ENDIF 
     284                  ! 
     285                  IF( ikp >= ikbot )   l_column_treated = .TRUE. 
     286                  ! 
     287               END DO ! DO WHILE ( .NOT. l_column_treated ) 
     288 
     289               !! Updating pts: 
     290               pts(ji,jj,:,jp_tem,Kaa) = zvts(:,jp_tem) 
     291               pts(ji,jj,:,jp_sal,Kaa) = zvts(:,jp_sal) 
     292 
     293               !! LB:  Potentially some other global variable beside theta and S can be treated here 
     294               !!      like BGC tracers. 
     295 
     296               IF( lp_monitor_point )   WRITE(numout,*) 
     297 
     298            ENDIF ! IF( tmask(ji,jj,3) == 1 ) THEN 
     299 
     300         END_2D 
    301301         ! 
    302302         IF( l_trdtra ) THEN         ! send the Non penetrative mixing trends for diagnostic 
    303303            z1_r2dt = 1._wp / (2._wp * rdt) 
    304             ztrdt(:,:,:) = ( tsa(:,:,:,jp_tem) - ztrdt(:,:,:) ) * z1_r2dt 
    305             ztrds(:,:,:) = ( tsa(:,:,:,jp_sal) - ztrds(:,:,:) ) * z1_r2dt 
    306             CALL trd_tra( kt, 'TRA', jp_tem, jptra_npc, ztrdt ) 
    307             CALL trd_tra( kt, 'TRA', jp_sal, jptra_npc, ztrds ) 
     304            ztrdt(:,:,:) = ( pts(:,:,:,jp_tem,Kaa) - ztrdt(:,:,:) ) * z1_r2dt 
     305            ztrds(:,:,:) = ( pts(:,:,:,jp_sal,Kaa) - ztrds(:,:,:) ) * z1_r2dt 
     306            CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_npc, ztrdt ) 
     307            CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_sal, jptra_npc, ztrds ) 
    308308            DEALLOCATE( ztrdt, ztrds ) 
    309309         ENDIF 
    310310         ! 
    311          CALL lbc_lnk_multi( 'tranpc', tsa(:,:,:,jp_tem), 'T', 1., tsa(:,:,:,jp_sal), 'T', 1. ) 
     311         CALL lbc_lnk_multi( 'tranpc', pts(:,:,:,jp_tem,Kaa), 'T', 1., pts(:,:,:,jp_sal,Kaa), 'T', 1. ) 
    312312         ! 
    313313         IF( lwp .AND. l_LB_debug ) THEN 

  • NEMO/trunk/src/OCE/TRA/traqsr.F90

    r11536 r12377  
    6767 
    6868   !! * Substitutions 
    69 #  include "vectopt_loop_substitute.h90" 
     69#  include "do_loop_substitute.h90" 
    7070   !!---------------------------------------------------------------------- 
    7171   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    7575CONTAINS 
    7676 
    77    SUBROUTINE tra_qsr( kt ) 
     77   SUBROUTINE tra_qsr( kt, Kmm, pts, Krhs ) 
    7878      !!---------------------------------------------------------------------- 
    7979      !!                  ***  ROUTINE tra_qsr  *** 
    … …  
    101101      !!              Morel, A. et Berthon, JF, 1989, Limnol Oceanogr 34(8), 1545-1562 
    102102      !!---------------------------------------------------------------------- 
    103       INTEGER, INTENT(in) ::   kt     ! ocean time-step 
     103      INTEGER,                                   INTENT(in   ) :: kt            ! ocean time-step 
     104      INTEGER,                                   INTENT(in   ) :: Kmm, Krhs     ! time level indices 
     105      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts           ! active tracers and RHS of tracer equation 
    104106      ! 
    105107      INTEGER  ::   ji, jj, jk               ! dummy loop indices 
    … …  
    126128      IF( l_trdtra ) THEN      ! trends diagnostic: save the input temperature trend 
    127129         ALLOCATE( ztrdt(jpi,jpj,jpk) )  
    128          ztrdt(:,:,:) = tsa(:,:,:,jp_tem) 
     130         ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) 
    129131      ENDIF 
    130132      ! 
    … …  
    167169            DO jk = 1, nksr + 1 
    168170               DO jj = 2, jpjm1                       ! Separation in R-G-B depending of the surface Chl 
    169                   DO ji = fs_2, fs_jpim1 
     171                  DO ji = 2, jpim1 
    170172                     zchl    = MIN( 10. , MAX( 0.03, sf_chl(1)%fnow(ji,jj,1) ) ) 
    171173                     zCtot   = 40.6  * zchl**0.459 
    172174                     zze     = 568.2 * zCtot**(-0.746) 
    173175                     IF( zze > 102. ) zze = 200.0 * zCtot**(-0.293) 
    174                      zpsi    = gdepw_n(ji,jj,jk) / zze 
     176                     zpsi    = gdepw(ji,jj,jk,Kmm) / zze 
    175177                     ! 
    176178                     zlogc   = LOG( zchl ) 
    … …  
    195197         ! 
    196198         zcoef  = ( 1. - rn_abs ) / 3._wp    !* surface equi-partition in R-G-B 
    197          DO jj = 2, jpjm1 
    198             DO ji = fs_2, fs_jpim1 
    199                ze0(ji,jj,1) = rn_abs * qsr(ji,jj) 
    200                ze1(ji,jj,1) = zcoef  * qsr(ji,jj) 
    201                ze2(ji,jj,1) = zcoef  * qsr(ji,jj) 
    202                ze3(ji,jj,1) = zcoef  * qsr(ji,jj) 
    203                zea(ji,jj,1) =          qsr(ji,jj) 
    204             END DO 
     199         DO_2D_00_00 
     200            ze0(ji,jj,1) = rn_abs * qsr(ji,jj) 
     201            ze1(ji,jj,1) = zcoef  * qsr(ji,jj) 
     202            ze2(ji,jj,1) = zcoef  * qsr(ji,jj) 
     203            ze3(ji,jj,1) = zcoef  * qsr(ji,jj) 
     204            zea(ji,jj,1) =          qsr(ji,jj) 
     205         END_2D 
     206         ! 
     207         DO jk = 2, nksr+1                   !* interior equi-partition in R-G-B depending of vertical profile of Chl 
     208            DO_2D_00_00 
     209               zchl = MIN( 10. , MAX( 0.03, zchl3d(ji,jj,jk) ) ) 
     210               irgb = NINT( 41 + 20.*LOG10(zchl) + 1.e-15 ) 
     211               zekb(ji,jj) = rkrgb(1,irgb) 
     212               zekg(ji,jj) = rkrgb(2,irgb) 
     213               zekr(ji,jj) = rkrgb(3,irgb) 
     214            END_2D 
     215 
     216            DO_2D_00_00 
     217               zc0 = ze0(ji,jj,jk-1) * EXP( - e3t(ji,jj,jk-1,Kmm) * xsi0r       ) 
     218               zc1 = ze1(ji,jj,jk-1) * EXP( - e3t(ji,jj,jk-1,Kmm) * zekb(ji,jj) ) 
     219               zc2 = ze2(ji,jj,jk-1) * EXP( - e3t(ji,jj,jk-1,Kmm) * zekg(ji,jj) ) 
     220               zc3 = ze3(ji,jj,jk-1) * EXP( - e3t(ji,jj,jk-1,Kmm) * zekr(ji,jj) ) 
     221               ze0(ji,jj,jk) = zc0 
     222               ze1(ji,jj,jk) = zc1 
     223               ze2(ji,jj,jk) = zc2 
     224               ze3(ji,jj,jk) = zc3 
     225               zea(ji,jj,jk) = ( zc0 + zc1 + zc2 + zc3 ) * wmask(ji,jj,jk) 
     226            END_2D 
    205227         END DO 
    206228         ! 
    207          DO jk = 2, nksr+1                   !* interior equi-partition in R-G-B depending of vertical profile of Chl 
    208             DO jj = 2, jpjm1 
    209                DO ji = fs_2, fs_jpim1 
    210                   zchl = MIN( 10. , MAX( 0.03, zchl3d(ji,jj,jk) ) ) 
    211                   irgb = NINT( 41 + 20.*LOG10(zchl) + 1.e-15 ) 
    212                   zekb(ji,jj) = rkrgb(1,irgb) 
    213                   zekg(ji,jj) = rkrgb(2,irgb) 
    214                   zekr(ji,jj) = rkrgb(3,irgb) 
    215                END DO 
    216             END DO 
    217  
    218             DO jj = 2, jpjm1 
    219                DO ji = fs_2, fs_jpim1 
    220                   zc0 = ze0(ji,jj,jk-1) * EXP( - e3t_n(ji,jj,jk-1) * xsi0r       ) 
    221                   zc1 = ze1(ji,jj,jk-1) * EXP( - e3t_n(ji,jj,jk-1) * zekb(ji,jj) ) 
    222                   zc2 = ze2(ji,jj,jk-1) * EXP( - e3t_n(ji,jj,jk-1) * zekg(ji,jj) ) 
    223                   zc3 = ze3(ji,jj,jk-1) * EXP( - e3t_n(ji,jj,jk-1) * zekr(ji,jj) ) 
    224                   ze0(ji,jj,jk) = zc0 
    225                   ze1(ji,jj,jk) = zc1 
    226                   ze2(ji,jj,jk) = zc2 
    227                   ze3(ji,jj,jk) = zc3 
    228                   zea(ji,jj,jk) = ( zc0 + zc1 + zc2 + zc3 ) * wmask(ji,jj,jk) 
    229                END DO 
    230             END DO 
    231          END DO 
    232          ! 
    233          DO jk = 1, nksr                     !* now qsr induced heat content 
    234             DO jj = 2, jpjm1 
    235                DO ji = fs_2, fs_jpim1 
    236                   qsr_hc(ji,jj,jk) = r1_rau0_rcp * ( zea(ji,jj,jk) - zea(ji,jj,jk+1) ) 
    237                END DO 
    238             END DO 
    239          END DO 
     229         DO_3D_00_00( 1, nksr ) 
     230            qsr_hc(ji,jj,jk) = r1_rau0_rcp * ( zea(ji,jj,jk) - zea(ji,jj,jk+1) ) 
     231         END_3D 
    240232         ! 
    241233         DEALLOCATE( zekb , zekg , zekr , ze0 , ze1 , ze2 , ze3 , zea , zchl3d )  
    … …  
    245237         zz0 =        rn_abs   * r1_rau0_rcp      ! surface equi-partition in 2-bands 
    246238         zz1 = ( 1. - rn_abs ) * r1_rau0_rcp 
    247          DO jk = 1, nksr                          ! solar heat absorbed at T-point in the top 400m  
    248             DO jj = 2, jpjm1 
    249                DO ji = fs_2, fs_jpim1 
    250                   zc0 = zz0 * EXP( -gdepw_n(ji,jj,jk  )*xsi0r ) + zz1 * EXP( -gdepw_n(ji,jj,jk  )*xsi1r ) 
    251                   zc1 = zz0 * EXP( -gdepw_n(ji,jj,jk+1)*xsi0r ) + zz1 * EXP( -gdepw_n(ji,jj,jk+1)*xsi1r ) 
    252                   qsr_hc(ji,jj,jk) = qsr(ji,jj) * ( zc0 * wmask(ji,jj,jk) - zc1 * wmask(ji,jj,jk+1) )  
    253                END DO 
    254             END DO 
    255          END DO 
     239         DO_3D_00_00( 1, nksr ) 
     240            zc0 = zz0 * EXP( -gdepw(ji,jj,jk  ,Kmm)*xsi0r ) + zz1 * EXP( -gdepw(ji,jj,jk  ,Kmm)*xsi1r ) 
     241            zc1 = zz0 * EXP( -gdepw(ji,jj,jk+1,Kmm)*xsi0r ) + zz1 * EXP( -gdepw(ji,jj,jk+1,Kmm)*xsi1r ) 
     242            qsr_hc(ji,jj,jk) = qsr(ji,jj) * ( zc0 * wmask(ji,jj,jk) - zc1 * wmask(ji,jj,jk+1) )  
     243         END_3D 
    256244         ! 
    257245      END SELECT 
    258246      ! 
    259247      !                          !-----------------------------! 
    260       DO jk = 1, nksr            !  update to the temp. trend  ! 
    261          DO jj = 2, jpjm1        !-----------------------------! 
    262             DO ji = fs_2, fs_jpim1   ! vector opt. 
    263                tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem)   & 
    264                   &                 + z1_2 * ( qsr_hc_b(ji,jj,jk) + qsr_hc(ji,jj,jk) ) / e3t_n(ji,jj,jk) 
    265             END DO 
    266          END DO 
    267       END DO 
     248      DO_3D_00_00( 1, nksr ) 
     249         pts(ji,jj,jk,jp_tem,Krhs) = pts(ji,jj,jk,jp_tem,Krhs)   & 
     250            &                      + z1_2 * ( qsr_hc_b(ji,jj,jk) + qsr_hc(ji,jj,jk) ) / e3t(ji,jj,jk,Kmm) 
     251      END_3D 
    268252      ! 
    269253      ! sea-ice: store the 1st ocean level attenuation coefficient 
    270       DO jj = 2, jpjm1  
    271          DO ji = fs_2, fs_jpim1   ! vector opt. 
    272             IF( qsr(ji,jj) /= 0._wp ) THEN   ;   fraqsr_1lev(ji,jj) = qsr_hc(ji,jj,1) / ( r1_rau0_rcp * qsr(ji,jj) ) 
    273             ELSE                             ;   fraqsr_1lev(ji,jj) = 1._wp 
    274             ENDIF 
    275          END DO 
    276       END DO 
     254      DO_2D_00_00 
     255         IF( qsr(ji,jj) /= 0._wp ) THEN   ;   fraqsr_1lev(ji,jj) = qsr_hc(ji,jj,1) / ( r1_rau0_rcp * qsr(ji,jj) ) 
     256         ELSE                             ;   fraqsr_1lev(ji,jj) = 1._wp 
     257         ENDIF 
     258      END_2D 
    277259      CALL lbc_lnk( 'traqsr', fraqsr_1lev(:,:), 'T', 1._wp ) 
    278260      ! 
    … …  
    295277      ! 
    296278      IF( l_trdtra ) THEN     ! qsr tracers trends saved for diagnostics 
    297          ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) 
    298          CALL trd_tra( kt, 'TRA', jp_tem, jptra_qsr, ztrdt ) 
     279         ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) - ztrdt(:,:,:) 
     280         CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_qsr, ztrdt ) 
    299281         DEALLOCATE( ztrdt )  
    300282      ENDIF 
    301283      !                       ! print mean trends (used for debugging) 
    302       IF(ln_ctl)   CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' qsr  - Ta: ', mask1=tmask, clinfo3='tra-ta' ) 
     284      IF(sn_cfctl%l_prtctl)   CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' qsr  - Ta: ', mask1=tmask, clinfo3='tra-ta' ) 
    303285      ! 
    304286      IF( ln_timing )   CALL timing_stop('tra_qsr') 
    … …  
    336318      !!---------------------------------------------------------------------- 
    337319      ! 
    338       REWIND( numnam_ref )              ! Namelist namtra_qsr in reference     namelist 
    339320      READ  ( numnam_ref, namtra_qsr, IOSTAT = ios, ERR = 901) 
    340321901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namtra_qsr in reference namelist' ) 
    341322      ! 
    342       REWIND( numnam_cfg )              ! Namelist namtra_qsr in configuration namelist 
    343323      READ  ( numnam_cfg, namtra_qsr, IOSTAT = ios, ERR = 902 ) 
    344324902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namtra_qsr in configuration namelist' ) 

  • NEMO/trunk/src/OCE/TRA/trasbc.F90

    r10499 r12377  
    1010   !!             -   !  2010-09  (C. Ethe, G. Madec) Merge TRA-TRC 
    1111   !!            3.6  !  2014-11  (P. Mathiot) isf melting forcing  
     12   !!            4.1  !  2019-09  (P. Mathiot) isf moved in traisf 
    1213   !!---------------------------------------------------------------------- 
    1314 
    … …  
    2223   USE sbcmod         ! ln_rnf   
    2324   USE sbcrnf         ! River runoff   
    24    USE sbcisf         ! Ice shelf    
    25    USE iscplini       ! Ice sheet coupling 
    2625   USE traqsr         ! solar radiation penetration 
    2726   USE trd_oce        ! trends: ocean variables 
    … …  
    4342 
    4443   !! * Substitutions 
    45 #  include "vectopt_loop_substitute.h90" 
     44#  include "do_loop_substitute.h90" 
    4645   !!---------------------------------------------------------------------- 
    4746   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    5150CONTAINS 
    5251 
    53    SUBROUTINE tra_sbc ( kt ) 
     52   SUBROUTINE tra_sbc ( kt, Kmm, pts, Krhs ) 
    5453      !!---------------------------------------------------------------------- 
    5554      !!                  ***  ROUTINE tra_sbc  *** 
    … …  
    6261      !!      (1) Fext, external forcing (i.e. flux through the (air+ice)-sea interface);  
    6362      !!      (2) Fwe , tracer carried with the water that is exchanged with air+ice.  
    64       !!               The input forcing fields (emp, rnf, sfx, isf) contain Fext+Fwe, 
    65       !!             they are simply added to the tracer trend (tsa). 
     63      !!               The input forcing fields (emp, rnf, sfx) contain Fext+Fwe, 
     64      !!             they are simply added to the tracer trend (ts(Krhs)). 
    6665      !!               In linear free surface case (ln_linssh=T), the volume of the 
    6766      !!             ocean does not change with the water exchanges at the (air+ice)-sea 
    … …  
    6968      !!             concentration/dilution effect associated with water exchanges. 
    7069      !! 
    71       !! ** Action  : - Update tsa with the surface boundary condition trend  
     70      !! ** Action  : - Update ts(Krhs) with the surface boundary condition trend  
    7271      !!              - send trends to trdtra module for further diagnostics(l_trdtra=T) 
    7372      !!---------------------------------------------------------------------- 
    74       INTEGER, INTENT(in) ::   kt   ! ocean time-step index 
     73      INTEGER,                                   INTENT(in   ) :: kt         ! ocean time-step index 
     74      INTEGER,                                   INTENT(in   ) :: Kmm, Krhs  ! time level indices 
     75      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts        ! active tracers and RHS of tracer equation 
    7576      ! 
    7677      INTEGER  ::   ji, jj, jk, jn              ! dummy loop indices   
    … …  
    9091      IF( l_trdtra ) THEN                    !* Save ta and sa trends 
    9192         ALLOCATE( ztrdt(jpi,jpj,jpk) , ztrds(jpi,jpj,jpk) )  
    92          ztrdt(:,:,:) = tsa(:,:,:,jp_tem) 
    93          ztrds(:,:,:) = tsa(:,:,:,jp_sal) 
     93         ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) 
     94         ztrds(:,:,:) = pts(:,:,:,jp_sal,Krhs) 
    9495      ENDIF 
    9596      ! 
    … …  
    122123      ENDIF 
    123124      !                             !==  Now sbc tracer content fields  ==! 
    124       DO jj = 2, jpj 
    125          DO ji = fs_2, fs_jpim1   ! vector opt. 
    126             sbc_tsc(ji,jj,jp_tem) = r1_rau0_rcp * qns(ji,jj)   ! non solar heat flux 
    127             sbc_tsc(ji,jj,jp_sal) = r1_rau0     * sfx(ji,jj)   ! salt flux due to freezing/melting 
    128          END DO 
    129       END DO 
     125      DO_2D_01_00 
     126         sbc_tsc(ji,jj,jp_tem) = r1_rau0_rcp * qns(ji,jj)   ! non solar heat flux 
     127         sbc_tsc(ji,jj,jp_sal) = r1_rau0     * sfx(ji,jj)   ! salt flux due to freezing/melting 
     128      END_2D 
    130129      IF( ln_linssh ) THEN                !* linear free surface   
    131          DO jj = 2, jpj                         !==>> add concentration/dilution effect due to constant volume cell 
    132             DO ji = fs_2, fs_jpim1   ! vector opt. 
    133                sbc_tsc(ji,jj,jp_tem) = sbc_tsc(ji,jj,jp_tem) + r1_rau0 * emp(ji,jj) * tsn(ji,jj,1,jp_tem) 
    134                sbc_tsc(ji,jj,jp_sal) = sbc_tsc(ji,jj,jp_sal) + r1_rau0 * emp(ji,jj) * tsn(ji,jj,1,jp_sal) 
    135             END DO 
    136          END DO                                 !==>> output c./d. term 
    137          IF( iom_use('emp_x_sst') )   CALL iom_put( "emp_x_sst", emp (:,:) * tsn(:,:,1,jp_tem) ) 
    138          IF( iom_use('emp_x_sss') )   CALL iom_put( "emp_x_sss", emp (:,:) * tsn(:,:,1,jp_sal) ) 
     130         DO_2D_01_00 
     131            sbc_tsc(ji,jj,jp_tem) = sbc_tsc(ji,jj,jp_tem) + r1_rau0 * emp(ji,jj) * pts(ji,jj,1,jp_tem,Kmm) 
     132            sbc_tsc(ji,jj,jp_sal) = sbc_tsc(ji,jj,jp_sal) + r1_rau0 * emp(ji,jj) * pts(ji,jj,1,jp_sal,Kmm) 
     133         END_2D 
     134         IF( iom_use('emp_x_sst') )   CALL iom_put( "emp_x_sst", emp (:,:) * pts(:,:,1,jp_tem,Kmm) ) 
     135         IF( iom_use('emp_x_sss') )   CALL iom_put( "emp_x_sss", emp (:,:) * pts(:,:,1,jp_sal,Kmm) ) 
    139136      ENDIF 
    140137      ! 
    141138      DO jn = 1, jpts               !==  update tracer trend  ==! 
    142          DO jj = 2, jpj 
    143             DO ji = fs_2, fs_jpim1   ! vector opt.   
    144                tsa(ji,jj,1,jn) = tsa(ji,jj,1,jn) + zfact * ( sbc_tsc_b(ji,jj,jn) + sbc_tsc(ji,jj,jn) ) / e3t_n(ji,jj,1) 
    145             END DO 
    146          END DO 
     139         DO_2D_01_00 
     140            pts(ji,jj,1,jn,Krhs) = pts(ji,jj,1,jn,Krhs) + zfact * ( sbc_tsc_b(ji,jj,jn) + sbc_tsc(ji,jj,jn) ) / e3t(ji,jj,1,Kmm) 
     141         END_2D 
    147142      END DO 
    148143      !                   
    … …  
    155150      ! 
    156151      !---------------------------------------- 
    157       !       Ice Shelf effects (ISF) 
    158       !     tbl treated as in Losh (2008) JGR 
    159       !---------------------------------------- 
    160       ! 
    161 !!gm BUG ?   Why no differences between non-linear and linear free surface ? 
    162 !!gm         probably taken into account in r1_hisf_tbl : to be verified 
    163       IF( ln_isf ) THEN 
    164          zfact = 0.5_wp 
    165          DO jj = 2, jpj 
    166             DO ji = fs_2, fs_jpim1 
    167                ! 
    168                ikt = misfkt(ji,jj) 
    169                ikb = misfkb(ji,jj) 
    170                ! 
    171                ! level fully include in the ice shelf boundary layer 
    172                ! sign - because fwf sign of evapo (rnf sign of precip) 
    173                DO jk = ikt, ikb - 1 
    174                ! compute trend 
    175                   tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem)                                                & 
    176                      &           + zfact * ( risf_tsc_b(ji,jj,jp_tem) + risf_tsc(ji,jj,jp_tem) )             & 
    177                      &           * r1_hisf_tbl(ji,jj) 
    178                END DO 
    179     
    180                ! level partially include in ice shelf boundary layer  
    181                ! compute trend 
    182                tsa(ji,jj,ikb,jp_tem) = tsa(ji,jj,ikb,jp_tem)                                                 & 
    183                   &              + zfact * ( risf_tsc_b(ji,jj,jp_tem) + risf_tsc(ji,jj,jp_tem) )             & 
    184                   &              * r1_hisf_tbl(ji,jj) * ralpha(ji,jj) 
    185  
    186             END DO 
    187          END DO 
    188       END IF 
    189       ! 
    190       !---------------------------------------- 
    191152      !        River Runoff effects 
    192153      !---------------------------------------- 
    … …  
    194155      IF( ln_rnf ) THEN         ! input of heat and salt due to river runoff  
    195156         zfact = 0.5_wp 
    196          DO jj = 2, jpj  
    197             DO ji = fs_2, fs_jpim1 
    198                IF( rnf(ji,jj) /= 0._wp ) THEN 
    199                   zdep = zfact / h_rnf(ji,jj) 
    200                   DO jk = 1, nk_rnf(ji,jj) 
    201                                         tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem)                                 & 
    202                                            &                 +  ( rnf_tsc_b(ji,jj,jp_tem) + rnf_tsc(ji,jj,jp_tem) ) * zdep 
    203                      IF( ln_rnf_sal )   tsa(ji,jj,jk,jp_sal) = tsa(ji,jj,jk,jp_sal)                                 & 
    204                                            &                 +  ( rnf_tsc_b(ji,jj,jp_sal) + rnf_tsc(ji,jj,jp_sal) ) * zdep  
    205                   END DO 
    206                ENDIF 
    207             END DO   
    208          END DO   
    209       ENDIF 
    210  
    211       IF( iom_use('rnf_x_sst') )   CALL iom_put( "rnf_x_sst", rnf*tsn(:,:,1,jp_tem) )   ! runoff term on sst 
    212       IF( iom_use('rnf_x_sss') )   CALL iom_put( "rnf_x_sss", rnf*tsn(:,:,1,jp_sal) )   ! runoff term on sss 
     157         DO_2D_01_00 
     158            IF( rnf(ji,jj) /= 0._wp ) THEN 
     159               zdep = zfact / h_rnf(ji,jj) 
     160               DO jk = 1, nk_rnf(ji,jj) 
     161                                     pts(ji,jj,jk,jp_tem,Krhs) = pts(ji,jj,jk,jp_tem,Krhs)                                  & 
     162                                        &                      +  ( rnf_tsc_b(ji,jj,jp_tem) + rnf_tsc(ji,jj,jp_tem) ) * zdep 
     163                  IF( ln_rnf_sal )   pts(ji,jj,jk,jp_sal,Krhs) = pts(ji,jj,jk,jp_sal,Krhs)                                  & 
     164                                        &                      +  ( rnf_tsc_b(ji,jj,jp_sal) + rnf_tsc(ji,jj,jp_sal) ) * zdep  
     165               END DO 
     166            ENDIF 
     167         END_2D 
     168      ENDIF 
     169 
     170      IF( iom_use('rnf_x_sst') )   CALL iom_put( "rnf_x_sst", rnf*pts(:,:,1,jp_tem,Kmm) )   ! runoff term on sst 
     171      IF( iom_use('rnf_x_sss') )   CALL iom_put( "rnf_x_sss", rnf*pts(:,:,1,jp_sal,Kmm) )   ! runoff term on sss 
    213172 
    214173#if defined key_asminc 
    … …  
    221180          ! 
    222181         IF( ln_linssh ) THEN  
    223             DO jj = 2, jpj  
    224                DO ji = fs_2, fs_jpim1 
    225                   ztim = ssh_iau(ji,jj) / e3t_n(ji,jj,1) 
    226                   tsa(ji,jj,1,jp_tem) = tsa(ji,jj,1,jp_tem) + tsn(ji,jj,1,jp_tem) * ztim 
    227                   tsa(ji,jj,1,jp_sal) = tsa(ji,jj,1,jp_sal) + tsn(ji,jj,1,jp_sal) * ztim 
    228                END DO 
    229             END DO 
     182            DO_2D_01_00 
     183               ztim = ssh_iau(ji,jj) / e3t(ji,jj,1,Kmm) 
     184               pts(ji,jj,1,jp_tem,Krhs) = pts(ji,jj,1,jp_tem,Krhs) + pts(ji,jj,1,jp_tem,Kmm) * ztim 
     185               pts(ji,jj,1,jp_sal,Krhs) = pts(ji,jj,1,jp_sal,Krhs) + pts(ji,jj,1,jp_sal,Kmm) * ztim 
     186            END_2D 
    230187         ELSE 
    231             DO jj = 2, jpj  
    232                DO ji = fs_2, fs_jpim1 
    233                   ztim = ssh_iau(ji,jj) / ( ht_n(ji,jj) + 1. - ssmask(ji, jj) ) 
    234                   tsa(ji,jj,:,jp_tem) = tsa(ji,jj,:,jp_tem) + tsn(ji,jj,:,jp_tem) * ztim 
    235                   tsa(ji,jj,:,jp_sal) = tsa(ji,jj,:,jp_sal) + tsn(ji,jj,:,jp_sal) * ztim 
    236                END DO   
    237             END DO   
     188            DO_2D_01_00 
     189               ztim = ssh_iau(ji,jj) / ( ht(ji,jj) + 1. - ssmask(ji, jj) ) 
     190               pts(ji,jj,:,jp_tem,Krhs) = pts(ji,jj,:,jp_tem,Krhs) + pts(ji,jj,:,jp_tem,Kmm) * ztim 
     191               pts(ji,jj,:,jp_sal,Krhs) = pts(ji,jj,:,jp_sal,Krhs) + pts(ji,jj,:,jp_sal,Kmm) * ztim 
     192            END_2D 
    238193         ENDIF 
    239194         ! 
    … …  
    242197#endif 
    243198      ! 
    244       !---------------------------------------- 
    245       !        Ice Sheet coupling imbalance correction to have conservation 
    246       !---------------------------------------- 
    247       ! 
    248       IF( ln_iscpl .AND. ln_hsb) THEN         ! input of heat and salt due to river runoff  
    249          DO jk = 1,jpk 
    250             DO jj = 2, jpj  
    251                DO ji = fs_2, fs_jpim1 
    252                   zdep = 1._wp / e3t_n(ji,jj,jk)  
    253                   tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem) - htsc_iscpl(ji,jj,jk,jp_tem) * zdep 
    254                   tsa(ji,jj,jk,jp_sal) = tsa(ji,jj,jk,jp_sal) - htsc_iscpl(ji,jj,jk,jp_sal) * zdep   
    255                END DO   
    256             END DO   
    257          END DO 
    258       ENDIF 
    259  
    260199      IF( l_trdtra )   THEN                      ! save the horizontal diffusive trends for further diagnostics 
    261          ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) 
    262          ztrds(:,:,:) = tsa(:,:,:,jp_sal) - ztrds(:,:,:) 
    263          CALL trd_tra( kt, 'TRA', jp_tem, jptra_nsr, ztrdt ) 
    264          CALL trd_tra( kt, 'TRA', jp_sal, jptra_nsr, ztrds ) 
     200         ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) - ztrdt(:,:,:) 
     201         ztrds(:,:,:) = pts(:,:,:,jp_sal,Krhs) - ztrds(:,:,:) 
     202         CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_nsr, ztrdt ) 
     203         CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_sal, jptra_nsr, ztrds ) 
    265204         DEALLOCATE( ztrdt , ztrds )  
    266205      ENDIF 
    267206      ! 
    268       IF(ln_ctl)   CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' sbc  - Ta: ', mask1=tmask,   & 
    269          &                       tab3d_2=tsa(:,:,:,jp_sal), clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
     207      IF(sn_cfctl%l_prtctl)   CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' sbc  - Ta: ', mask1=tmask,   & 
     208         &                                  tab3d_2=pts(:,:,:,jp_sal,Krhs), clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
    270209      ! 
    271210      IF( ln_timing )   CALL timing_stop('tra_sbc') 

  • NEMO/trunk/src/OCE/TRA/trazdf.F90

    r10425 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 tra_zdf( kt ) 
     46   SUBROUTINE tra_zdf( kt, Kbb, Kmm, Krhs, pts, Kaa ) 
    4747      !!---------------------------------------------------------------------- 
    4848      !!                  ***  ROUTINE tra_zdf  *** 
    … …  
    5050      !! ** Purpose :   compute the vertical ocean tracer physics. 
    5151      !!--------------------------------------------------------------------- 
    52       INTEGER, INTENT(in) ::   kt   ! ocean time-step index 
     52      INTEGER                                  , INTENT(in)    :: kt                  ! ocean time-step index 
     53      INTEGER                                  , INTENT(in)    :: Kbb, Kmm, Krhs, Kaa ! time level indices 
     54      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts                 ! active tracers and RHS of tracer equation 
    5355      ! 
    5456      INTEGER  ::   jk   ! Dummy loop indices 
    … …  
    7072      IF( l_trdtra )   THEN                  !* Save ta and sa trends 
    7173         ALLOCATE( ztrdt(jpi,jpj,jpk) , ztrds(jpi,jpj,jpk) ) 
    72          ztrdt(:,:,:) = tsa(:,:,:,jp_tem) 
    73          ztrds(:,:,:) = tsa(:,:,:,jp_sal) 
     74         ztrdt(:,:,:) = pts(:,:,:,jp_tem,Kaa) 
     75         ztrds(:,:,:) = pts(:,:,:,jp_sal,Kaa) 
    7476      ENDIF 
    7577      ! 
    7678      !                                      !* compute lateral mixing trend and add it to the general trend 
    77       CALL tra_zdf_imp( kt, nit000, 'TRA', r2dt, tsb, tsa, jpts )  
     79      CALL tra_zdf_imp( kt, nit000, 'TRA', r2dt, Kbb, Kmm, Krhs, pts, Kaa, jpts )  
    7880 
    7981!!gm WHY here !   and I don't like that ! 
    … …  
    8183      ! JMM avoid negative salinities near river outlet ! Ugly fix 
    8284      ! JMM : restore negative salinities to small salinities: 
    83       WHERE( tsa(:,:,:,jp_sal) < 0._wp )   tsa(:,:,:,jp_sal) = 0.1_wp 
     85      WHERE( pts(:,:,:,jp_sal,Kaa) < 0._wp )   pts(:,:,:,jp_sal,Kaa) = 0.1_wp 
    8486!!gm 
    8587 
    8688      IF( l_trdtra )   THEN                      ! save the vertical diffusive trends for further diagnostics 
    8789         DO jk = 1, jpkm1 
    88             ztrdt(:,:,jk) = ( ( tsa(:,:,jk,jp_tem)*e3t_a(:,:,jk) - tsb(:,:,jk,jp_tem)*e3t_b(:,:,jk) ) & 
    89                &          / (e3t_n(:,:,jk)*r2dt) ) - ztrdt(:,:,jk) 
    90             ztrds(:,:,jk) = ( ( tsa(:,:,jk,jp_sal)*e3t_a(:,:,jk) - tsb(:,:,jk,jp_sal)*e3t_b(:,:,jk) ) & 
    91               &           / (e3t_n(:,:,jk)*r2dt) ) - ztrds(:,:,jk) 
     90            ztrdt(:,:,jk) = ( ( pts(:,:,jk,jp_tem,Kaa)*e3t(:,:,jk,Kaa) - pts(:,:,jk,jp_tem,Kbb)*e3t(:,:,jk,Kbb) ) & 
     91               &          / (e3t(:,:,jk,Kmm)*r2dt) ) - ztrdt(:,:,jk) 
     92            ztrds(:,:,jk) = ( ( pts(:,:,jk,jp_sal,Kaa)*e3t(:,:,jk,Kaa) - pts(:,:,jk,jp_sal,Kbb)*e3t(:,:,jk,Kbb) ) & 
     93              &           / (e3t(:,:,jk,Kmm)*r2dt) ) - ztrds(:,:,jk) 
    9294         END DO 
    9395!!gm this should be moved in trdtra.F90 and done on all trends 
    9496         CALL lbc_lnk_multi( 'trazdf', ztrdt, 'T', 1. , ztrds, 'T', 1. ) 
    9597!!gm 
    96          CALL trd_tra( kt, 'TRA', jp_tem, jptra_zdf, ztrdt ) 
    97          CALL trd_tra( kt, 'TRA', jp_sal, jptra_zdf, ztrds ) 
     98         CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_zdf, ztrdt ) 
     99         CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_sal, jptra_zdf, ztrds ) 
    98100         DEALLOCATE( ztrdt , ztrds ) 
    99101      ENDIF 
    100102      !                                          ! print mean trends (used for debugging) 
    101       IF(ln_ctl)   CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' zdf  - Ta: ', mask1=tmask,               & 
    102          &                       tab3d_2=tsa(:,:,:,jp_sal), clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
     103      IF(sn_cfctl%l_prtctl)   CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Kaa), clinfo1=' zdf  - Ta: ', mask1=tmask,               & 
     104         &                                  tab3d_2=pts(:,:,:,jp_sal,Kaa), clinfo2=       ' Sa: ', mask2=tmask, clinfo3='tra' ) 
    103105      ! 
    104106      IF( ln_timing )   CALL timing_stop('tra_zdf') 
    … …  
    107109 
    108110  
    109    SUBROUTINE tra_zdf_imp( kt, kit000, cdtype, p2dt, ptb, pta, kjpt )  
     111   SUBROUTINE tra_zdf_imp( kt, kit000, cdtype, p2dt, Kbb, Kmm, Krhs, pt, Kaa, kjpt )  
    110112      !!---------------------------------------------------------------------- 
    111113      !!                  ***  ROUTINE tra_zdf_imp  *** 
    … …  
    125127      !!      If iso-neutral mixing, add to avt the contribution due to lateral mixing. 
    126128      !! 
    127       !! ** Action  : - pta  becomes the after tracer 
    128       !!--------------------------------------------------------------------- 
    129       INTEGER                              , INTENT(in   ) ::   kt       ! ocean time-step index 
    130       INTEGER                              , INTENT(in   ) ::   kit000   ! first time step index 
    131       CHARACTER(len=3)                     , INTENT(in   ) ::   cdtype   ! =TRA or TRC (tracer indicator) 
    132       INTEGER                              , INTENT(in   ) ::   kjpt     ! number of tracers 
    133       REAL(wp)                             , INTENT(in   ) ::   p2dt     ! tracer time-step 
    134       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb      ! before and now tracer fields 
    135       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta      ! in: tracer trend ; out: after tracer field 
     129      !! ** Action  : - pt(:,:,:,:,Kaa)  becomes the after tracer 
     130      !!--------------------------------------------------------------------- 
     131      INTEGER                                  , INTENT(in   ) ::   kt       ! ocean time-step index 
     132      INTEGER                                  , INTENT(in   ) ::   Kbb, Kmm, Krhs, Kaa  ! ocean time level indices 
     133      INTEGER                                  , INTENT(in   ) ::   kit000   ! first time step index 
     134      CHARACTER(len=3)                         , INTENT(in   ) ::   cdtype   ! =TRA or TRC (tracer indicator) 
     135      INTEGER                                  , INTENT(in   ) ::   kjpt     ! number of tracers 
     136      REAL(wp)                                 , INTENT(in   ) ::   p2dt     ! tracer time-step 
     137      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt,jpt), INTENT(inout) ::   pt       ! tracers and RHS of tracer equation 
    136138      ! 
    137139      INTEGER  ::  ji, jj, jk, jn   ! dummy loop indices 
    … …  
    158160            IF( l_ldfslp ) THEN            ! isoneutral diffusion: add the contribution  
    159161               IF( ln_traldf_msc  ) THEN     ! MSC iso-neutral operator  
    160                   DO jk = 2, jpkm1 
    161                      DO jj = 2, jpjm1 
    162                         DO ji = fs_2, fs_jpim1   ! vector opt. 
    163                            zwt(ji,jj,jk) = zwt(ji,jj,jk) + akz(ji,jj,jk)   
    164                         END DO 
    165                      END DO 
    166                   END DO 
     162                  DO_3D_00_00( 2, jpkm1 ) 
     163                     zwt(ji,jj,jk) = zwt(ji,jj,jk) + akz(ji,jj,jk)   
     164                  END_3D 
    167165               ELSE                          ! standard or triad iso-neutral operator 
    168                   DO jk = 2, jpkm1 
    169                      DO jj = 2, jpjm1 
    170                         DO ji = fs_2, fs_jpim1   ! vector opt. 
    171                            zwt(ji,jj,jk) = zwt(ji,jj,jk) + ah_wslp2(ji,jj,jk) 
    172                         END DO 
    173                      END DO 
    174                   END DO 
     166                  DO_3D_00_00( 2, jpkm1 ) 
     167                     zwt(ji,jj,jk) = zwt(ji,jj,jk) + ah_wslp2(ji,jj,jk) 
     168                  END_3D 
    175169               ENDIF 
    176170            ENDIF 
    … …  
    178172            ! Diagonal, lower (i), upper (s)  (including the bottom boundary condition since avt is masked) 
    179173            IF( ln_zad_Aimp ) THEN         ! Adaptive implicit vertical advection 
    180                DO jk = 1, jpkm1 
    181                   DO jj = 2, jpjm1 
    182                      DO ji = fs_2, fs_jpim1   ! vector opt. (ensure same order of calculation as below if wi=0.) 
    183                         zzwi = - p2dt * zwt(ji,jj,jk  ) / e3w_n(ji,jj,jk  ) 
    184                         zzws = - p2dt * zwt(ji,jj,jk+1) / e3w_n(ji,jj,jk+1) 
    185                         zwd(ji,jj,jk) = e3t_a(ji,jj,jk) - zzwi - zzws   & 
    186                            &                 + p2dt * ( MAX( wi(ji,jj,jk  ) , 0._wp ) - MIN( wi(ji,jj,jk+1) , 0._wp ) ) 
    187                         zwi(ji,jj,jk) = zzwi + p2dt *   MIN( wi(ji,jj,jk  ) , 0._wp ) 
    188                         zws(ji,jj,jk) = zzws - p2dt *   MAX( wi(ji,jj,jk+1) , 0._wp ) 
    189                     END DO 
    190                   END DO 
    191                END DO 
     174               DO_3D_00_00( 1, jpkm1 ) 
     175                  zzwi = - p2dt * zwt(ji,jj,jk  ) / e3w(ji,jj,jk  ,Kmm) 
     176                  zzws = - p2dt * zwt(ji,jj,jk+1) / e3w(ji,jj,jk+1,Kmm) 
     177                  zwd(ji,jj,jk) = e3t(ji,jj,jk,Kaa) - zzwi - zzws   & 
     178                     &                 + p2dt * ( MAX( wi(ji,jj,jk  ) , 0._wp ) - MIN( wi(ji,jj,jk+1) , 0._wp ) ) 
     179                  zwi(ji,jj,jk) = zzwi + p2dt *   MIN( wi(ji,jj,jk  ) , 0._wp ) 
     180                  zws(ji,jj,jk) = zzws - p2dt *   MAX( wi(ji,jj,jk+1) , 0._wp ) 
     181               END_3D 
    192182            ELSE 
    193                DO jk = 1, jpkm1 
    194                   DO jj = 2, jpjm1 
    195                      DO ji = fs_2, fs_jpim1   ! vector opt. 
    196                         zwi(ji,jj,jk) = - p2dt * zwt(ji,jj,jk  ) / e3w_n(ji,jj,jk) 
    197                         zws(ji,jj,jk) = - p2dt * zwt(ji,jj,jk+1) / e3w_n(ji,jj,jk+1) 
    198                         zwd(ji,jj,jk) = e3t_a(ji,jj,jk) - zwi(ji,jj,jk) - zws(ji,jj,jk) 
    199                     END DO 
    200                   END DO 
    201                END DO 
     183               DO_3D_00_00( 1, jpkm1 ) 
     184                  zwi(ji,jj,jk) = - p2dt * zwt(ji,jj,jk  ) / e3w(ji,jj,jk,Kmm) 
     185                  zws(ji,jj,jk) = - p2dt * zwt(ji,jj,jk+1) / e3w(ji,jj,jk+1,Kmm) 
     186                  zwd(ji,jj,jk) = e3t(ji,jj,jk,Kaa) - zwi(ji,jj,jk) - zws(ji,jj,jk) 
     187               END_3D 
    202188            ENDIF 
    203189            ! 
    … …  
    218204            !   The solution will be in the 4d array pta. 
    219205            !   The 3d array zwt is used as a work space array. 
    220             !   En route to the solution pta is used a to evaluate the rhs and then  
     206            !   En route to the solution pt(:,:,:,:,Kaa) is used a to evaluate the rhs and then  
    221207            !   used as a work space array: its value is modified. 
    222208            ! 
    223             DO jj = 2, jpjm1        !* 1st recurrence:   Tk = Dk - Ik Sk-1 / Tk-1   (increasing k) 
    224                DO ji = fs_2, fs_jpim1            ! done one for all passive tracers (so included in the IF instruction) 
    225                   zwt(ji,jj,1) = zwd(ji,jj,1) 
    226                END DO 
    227             END DO 
    228             DO jk = 2, jpkm1 
    229                DO jj = 2, jpjm1 
    230                   DO ji = fs_2, fs_jpim1 
    231                      zwt(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) / zwt(ji,jj,jk-1) 
    232                   END DO 
    233                END DO 
    234             END DO 
     209            DO_2D_00_00 
     210               zwt(ji,jj,1) = zwd(ji,jj,1) 
     211            END_2D 
     212            DO_3D_00_00( 2, jpkm1 ) 
     213               zwt(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) / zwt(ji,jj,jk-1) 
     214            END_3D 
    235215            ! 
    236216         ENDIF  
    237217         !          
    238          DO jj = 2, jpjm1           !* 2nd recurrence:    Zk = Yk - Ik / Tk-1  Zk-1 
    239             DO ji = fs_2, fs_jpim1 
    240                pta(ji,jj,1,jn) = e3t_b(ji,jj,1) * ptb(ji,jj,1,jn) + p2dt * e3t_n(ji,jj,1) * pta(ji,jj,1,jn) 
    241             END DO 
    242          END DO 
    243          DO jk = 2, jpkm1 
    244             DO jj = 2, jpjm1 
    245                DO ji = fs_2, fs_jpim1 
    246                   zrhs = e3t_b(ji,jj,jk) * ptb(ji,jj,jk,jn) + p2dt * e3t_n(ji,jj,jk) * pta(ji,jj,jk,jn)   ! zrhs=right hand side 
    247                   pta(ji,jj,jk,jn) = zrhs - zwi(ji,jj,jk) / zwt(ji,jj,jk-1) * pta(ji,jj,jk-1,jn) 
    248                END DO 
    249             END DO 
    250          END DO 
     218         DO_2D_00_00 
     219            pt(ji,jj,1,jn,Kaa) = e3t(ji,jj,1,Kbb) * pt(ji,jj,1,jn,Kbb) + p2dt * e3t(ji,jj,1,Kmm) * pt(ji,jj,1,jn,Krhs) 
     220         END_2D 
     221         DO_3D_00_00( 2, jpkm1 ) 
     222            zrhs = e3t(ji,jj,jk,Kbb) * pt(ji,jj,jk,jn,Kbb) + p2dt * e3t(ji,jj,jk,Kmm) * pt(ji,jj,jk,jn,Krhs)   ! zrhs=right hand side 
     223            pt(ji,jj,jk,jn,Kaa) = zrhs - zwi(ji,jj,jk) / zwt(ji,jj,jk-1) * pt(ji,jj,jk-1,jn,Kaa) 
     224         END_3D 
    251225         ! 
    252          DO jj = 2, jpjm1           !* 3d recurrence:    Xk = (Zk - Sk Xk+1 ) / Tk   (result is the after tracer) 
    253             DO ji = fs_2, fs_jpim1 
    254                pta(ji,jj,jpkm1,jn) = pta(ji,jj,jpkm1,jn) / zwt(ji,jj,jpkm1) * tmask(ji,jj,jpkm1) 
    255             END DO 
    256          END DO 
    257          DO jk = jpk-2, 1, -1 
    258             DO jj = 2, jpjm1 
    259                DO ji = fs_2, fs_jpim1 
    260                   pta(ji,jj,jk,jn) = ( pta(ji,jj,jk,jn) - zws(ji,jj,jk) * pta(ji,jj,jk+1,jn) )   & 
    261                      &             / zwt(ji,jj,jk) * tmask(ji,jj,jk) 
    262                END DO 
    263             END DO 
    264          END DO 
     226         DO_2D_00_00 
     227            pt(ji,jj,jpkm1,jn,Kaa) = pt(ji,jj,jpkm1,jn,Kaa) / zwt(ji,jj,jpkm1) * tmask(ji,jj,jpkm1) 
     228         END_2D 
     229         DO_3DS_00_00( jpk-2, 1, -1 ) 
     230            pt(ji,jj,jk,jn,Kaa) = ( pt(ji,jj,jk,jn,Kaa) - zws(ji,jj,jk) * pt(ji,jj,jk+1,jn,Kaa) )   & 
     231               &             / zwt(ji,jj,jk) * tmask(ji,jj,jk) 
     232         END_3D 
    265233         !                                            ! ================= ! 
    266234      END DO                                          !  end tracer loop  ! 

  • NEMO/trunk/src/OCE/TRA/zpshde.F90

    r10425 r12377  
    3131 
    3232   !! * Substitutions 
    33 #  include "vectopt_loop_substitute.h90" 
     33#  include "do_loop_substitute.h90" 
    3434   !!---------------------------------------------------------------------- 
    3535   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    3939CONTAINS 
    4040 
    41    SUBROUTINE zps_hde( kt, kjpt, pta, pgtu, pgtv,   & 
     41   SUBROUTINE zps_hde( kt, Kmm, kjpt, pta, pgtu, pgtv,   & 
    4242      &                          prd, pgru, pgrv    ) 
    4343      !!---------------------------------------------------------------------- 
    … …  
    8585      !!---------------------------------------------------------------------- 
    8686      INTEGER                              , INTENT(in   )           ::  kt          ! ocean time-step index 
     87      INTEGER                              , INTENT(in   )           ::  Kmm         ! ocean time level index 
    8788      INTEGER                              , INTENT(in   )           ::  kjpt        ! number of tracers 
    8889      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   )           ::  pta         ! 4D tracers fields 
    … …  
    105106      DO jn = 1, kjpt      !==   Interpolation of tracers at the last ocean level   ==! 
    106107         ! 
    107          DO jj = 1, jpjm1 
    108             DO ji = 1, jpim1 
    109                iku = mbku(ji,jj)   ;   ikum1 = MAX( iku - 1 , 1 )    ! last and before last ocean level at u- & v-points 
    110                ikv = mbkv(ji,jj)   ;   ikvm1 = MAX( ikv - 1 , 1 )    ! if level first is a p-step, ik.m1=1 
    111 !!gm BUG ? when applied to before fields, e3w_b should be used.... 
    112                ze3wu = e3w_n(ji+1,jj  ,iku) - e3w_n(ji,jj,iku) 
    113                ze3wv = e3w_n(ji  ,jj+1,ikv) - e3w_n(ji,jj,ikv) 
    114                ! 
    115                ! i- direction 
    116                IF( ze3wu >= 0._wp ) THEN      ! case 1 
    117                   zmaxu =  ze3wu / e3w_n(ji+1,jj,iku) 
    118                   ! interpolated values of tracers 
    119                   zti (ji,jj,jn) = pta(ji+1,jj,iku,jn) + zmaxu * ( pta(ji+1,jj,ikum1,jn) - pta(ji+1,jj,iku,jn) ) 
    120                   ! gradient of  tracers 
    121                   pgtu(ji,jj,jn) = umask(ji,jj,1) * ( zti(ji,jj,jn) - pta(ji,jj,iku,jn) ) 
    122                ELSE                           ! case 2 
    123                   zmaxu = -ze3wu / e3w_n(ji,jj,iku) 
    124                   ! interpolated values of tracers 
    125                   zti (ji,jj,jn) = pta(ji,jj,iku,jn) + zmaxu * ( pta(ji,jj,ikum1,jn) - pta(ji,jj,iku,jn) ) 
    126                   ! gradient of tracers 
    127                   pgtu(ji,jj,jn) = umask(ji,jj,1) * ( pta(ji+1,jj,iku,jn) - zti(ji,jj,jn) ) 
    128                ENDIF 
    129                ! 
    130                ! j- direction 
    131                IF( ze3wv >= 0._wp ) THEN      ! case 1 
    132                   zmaxv =  ze3wv / e3w_n(ji,jj+1,ikv) 
    133                   ! interpolated values of tracers 
    134                   ztj (ji,jj,jn) = pta(ji,jj+1,ikv,jn) + zmaxv * ( pta(ji,jj+1,ikvm1,jn) - pta(ji,jj+1,ikv,jn) ) 
    135                   ! gradient of tracers 
    136                   pgtv(ji,jj,jn) = vmask(ji,jj,1) * ( ztj(ji,jj,jn) - pta(ji,jj,ikv,jn) ) 
    137                ELSE                           ! case 2 
    138                   zmaxv =  -ze3wv / e3w_n(ji,jj,ikv) 
    139                   ! interpolated values of tracers 
    140                   ztj (ji,jj,jn) = pta(ji,jj,ikv,jn) + zmaxv * ( pta(ji,jj,ikvm1,jn) - pta(ji,jj,ikv,jn) ) 
    141                   ! gradient of tracers 
    142                   pgtv(ji,jj,jn) = vmask(ji,jj,1) * ( pta(ji,jj+1,ikv,jn) - ztj(ji,jj,jn) ) 
    143                ENDIF 
    144             END DO 
    145          END DO 
     108         DO_2D_10_10 
     109            iku = mbku(ji,jj)   ;   ikum1 = MAX( iku - 1 , 1 )    ! last and before last ocean level at u- & v-points 
     110            ikv = mbkv(ji,jj)   ;   ikvm1 = MAX( ikv - 1 , 1 )    ! if level first is a p-step, ik.m1=1 
     111!!gm BUG ? when applied to before fields, e3w(:,:,:,Kbb) should be used.... 
     112            ze3wu = e3w(ji+1,jj  ,iku,Kmm) - e3w(ji,jj,iku,Kmm) 
     113            ze3wv = e3w(ji  ,jj+1,ikv,Kmm) - e3w(ji,jj,ikv,Kmm) 
     114            ! 
     115            ! i- direction 
     116            IF( ze3wu >= 0._wp ) THEN      ! case 1 
     117               zmaxu =  ze3wu / e3w(ji+1,jj,iku,Kmm) 
     118               ! interpolated values of tracers 
     119               zti (ji,jj,jn) = pta(ji+1,jj,iku,jn) + zmaxu * ( pta(ji+1,jj,ikum1,jn) - pta(ji+1,jj,iku,jn) ) 
     120               ! gradient of  tracers 
     121               pgtu(ji,jj,jn) = umask(ji,jj,1) * ( zti(ji,jj,jn) - pta(ji,jj,iku,jn) ) 
     122            ELSE                           ! case 2 
     123               zmaxu = -ze3wu / e3w(ji,jj,iku,Kmm) 
     124               ! interpolated values of tracers 
     125               zti (ji,jj,jn) = pta(ji,jj,iku,jn) + zmaxu * ( pta(ji,jj,ikum1,jn) - pta(ji,jj,iku,jn) ) 
     126               ! gradient of tracers 
     127               pgtu(ji,jj,jn) = umask(ji,jj,1) * ( pta(ji+1,jj,iku,jn) - zti(ji,jj,jn) ) 
     128            ENDIF 
     129            ! 
     130            ! j- direction 
     131            IF( ze3wv >= 0._wp ) THEN      ! case 1 
     132               zmaxv =  ze3wv / e3w(ji,jj+1,ikv,Kmm) 
     133               ! interpolated values of tracers 
     134               ztj (ji,jj,jn) = pta(ji,jj+1,ikv,jn) + zmaxv * ( pta(ji,jj+1,ikvm1,jn) - pta(ji,jj+1,ikv,jn) ) 
     135               ! gradient of tracers 
     136               pgtv(ji,jj,jn) = vmask(ji,jj,1) * ( ztj(ji,jj,jn) - pta(ji,jj,ikv,jn) ) 
     137            ELSE                           ! case 2 
     138               zmaxv =  -ze3wv / e3w(ji,jj,ikv,Kmm) 
     139               ! interpolated values of tracers 
     140               ztj (ji,jj,jn) = pta(ji,jj,ikv,jn) + zmaxv * ( pta(ji,jj,ikvm1,jn) - pta(ji,jj,ikv,jn) ) 
     141               ! gradient of tracers 
     142               pgtv(ji,jj,jn) = vmask(ji,jj,1) * ( pta(ji,jj+1,ikv,jn) - ztj(ji,jj,jn) ) 
     143            ENDIF 
     144         END_2D 
    146145      END DO 
    147146      ! 
    … …  
    151150         pgru(:,:) = 0._wp 
    152151         pgrv(:,:) = 0._wp                ! depth of the partial step level 
    153          DO jj = 1, jpjm1 
    154             DO ji = 1, jpim1 
    155                iku = mbku(ji,jj) 
    156                ikv = mbkv(ji,jj) 
    157                ze3wu  = e3w_n(ji+1,jj  ,iku) - e3w_n(ji,jj,iku) 
    158                ze3wv  = e3w_n(ji  ,jj+1,ikv) - e3w_n(ji,jj,ikv) 
    159                IF( ze3wu >= 0._wp ) THEN   ;   zhi(ji,jj) = gdept_n(ji  ,jj,iku)     ! i-direction: case 1 
    160                ELSE                        ;   zhi(ji,jj) = gdept_n(ji+1,jj,iku)     ! -     -      case 2 
    161                ENDIF 
    162                IF( ze3wv >= 0._wp ) THEN   ;   zhj(ji,jj) = gdept_n(ji,jj  ,ikv)     ! j-direction: case 1 
    163                ELSE                        ;   zhj(ji,jj) = gdept_n(ji,jj+1,ikv)     ! -     -      case 2 
    164                ENDIF 
    165             END DO 
    166          END DO 
     152         DO_2D_10_10 
     153            iku = mbku(ji,jj) 
     154            ikv = mbkv(ji,jj) 
     155            ze3wu  = e3w(ji+1,jj  ,iku,Kmm) - e3w(ji,jj,iku,Kmm) 
     156            ze3wv  = e3w(ji  ,jj+1,ikv,Kmm) - e3w(ji,jj,ikv,Kmm) 
     157            IF( ze3wu >= 0._wp ) THEN   ;   zhi(ji,jj) = gdept(ji  ,jj,iku,Kmm)     ! i-direction: case 1 
     158            ELSE                        ;   zhi(ji,jj) = gdept(ji+1,jj,iku,Kmm)     ! -     -      case 2 
     159            ENDIF 
     160            IF( ze3wv >= 0._wp ) THEN   ;   zhj(ji,jj) = gdept(ji,jj  ,ikv,Kmm)     ! j-direction: case 1 
     161            ELSE                        ;   zhj(ji,jj) = gdept(ji,jj+1,ikv,Kmm)     ! -     -      case 2 
     162            ENDIF 
     163         END_2D 
    167164         ! 
    168165         CALL eos( zti, zhi, zri )        ! interpolated density from zti, ztj  
    169166         CALL eos( ztj, zhj, zrj )        ! at the partial step depth output in  zri, zrj  
    170167         ! 
    171          DO jj = 1, jpjm1                 ! Gradient of density at the last level  
    172             DO ji = 1, jpim1 
    173                iku = mbku(ji,jj) 
    174                ikv = mbkv(ji,jj) 
    175                ze3wu  = e3w_n(ji+1,jj  ,iku) - e3w_n(ji,jj,iku) 
    176                ze3wv  = e3w_n(ji  ,jj+1,ikv) - e3w_n(ji,jj,ikv) 
    177                IF( ze3wu >= 0._wp ) THEN   ;   pgru(ji,jj) = umask(ji,jj,1) * ( zri(ji  ,jj    ) - prd(ji,jj,iku) )   ! i: 1 
    178                ELSE                        ;   pgru(ji,jj) = umask(ji,jj,1) * ( prd(ji+1,jj,iku) - zri(ji,jj    ) )   ! i: 2 
    179                ENDIF 
    180                IF( ze3wv >= 0._wp ) THEN   ;   pgrv(ji,jj) = vmask(ji,jj,1) * ( zrj(ji,jj      ) - prd(ji,jj,ikv) )   ! j: 1 
    181                ELSE                        ;   pgrv(ji,jj) = vmask(ji,jj,1) * ( prd(ji,jj+1,ikv) - zrj(ji,jj    ) )   ! j: 2 
    182                ENDIF 
    183             END DO 
    184          END DO 
     168         DO_2D_10_10 
     169            iku = mbku(ji,jj) 
     170            ikv = mbkv(ji,jj) 
     171            ze3wu  = e3w(ji+1,jj  ,iku,Kmm) - e3w(ji,jj,iku,Kmm) 
     172            ze3wv  = e3w(ji  ,jj+1,ikv,Kmm) - e3w(ji,jj,ikv,Kmm) 
     173            IF( ze3wu >= 0._wp ) THEN   ;   pgru(ji,jj) = umask(ji,jj,1) * ( zri(ji  ,jj    ) - prd(ji,jj,iku) )   ! i: 1 
     174            ELSE                        ;   pgru(ji,jj) = umask(ji,jj,1) * ( prd(ji+1,jj,iku) - zri(ji,jj    ) )   ! i: 2 
     175            ENDIF 
     176            IF( ze3wv >= 0._wp ) THEN   ;   pgrv(ji,jj) = vmask(ji,jj,1) * ( zrj(ji,jj      ) - prd(ji,jj,ikv) )   ! j: 1 
     177            ELSE                        ;   pgrv(ji,jj) = vmask(ji,jj,1) * ( prd(ji,jj+1,ikv) - zrj(ji,jj    ) )   ! j: 2 
     178            ENDIF 
     179         END_2D 
    185180         CALL lbc_lnk_multi( 'zpshde', pgru , 'U', -1. , pgrv , 'V', -1. )   ! Lateral boundary conditions 
    186181         ! 
    … …  
    192187 
    193188 
    194    SUBROUTINE zps_hde_isf( kt, kjpt, pta, pgtu, pgtv, pgtui, pgtvi,  & 
     189   SUBROUTINE zps_hde_isf( kt, Kmm, kjpt, pta, pgtu, pgtv, pgtui, pgtvi,  & 
    195190      &                          prd, pgru, pgrv, pgrui, pgrvi ) 
    196191      !!---------------------------------------------------------------------- 
    … …  
    241236      !!---------------------------------------------------------------------- 
    242237      INTEGER                              , INTENT(in   )           ::  kt           ! ocean time-step index 
     238      INTEGER                              , INTENT(in   )           ::  Kmm          ! ocean time level index 
    243239      INTEGER                              , INTENT(in   )           ::  kjpt         ! number of tracers 
    244240      REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   )           ::  pta          ! 4D tracers fields 
    … …  
    265261      DO jn = 1, kjpt      !==   Interpolation of tracers at the last ocean level   ==! 
    266262         ! 
    267          DO jj = 1, jpjm1 
    268             DO ji = 1, jpim1 
    269  
    270                iku = mbku(ji,jj); ikum1 = MAX( iku - 1 , 1 )    ! last and before last ocean level at u- & v-points 
    271                ikv = mbkv(ji,jj); ikvm1 = MAX( ikv - 1 , 1 )    ! if level first is a p-step, ik.m1=1 
    272                ze3wu = gdept_n(ji+1,jj,iku) - gdept_n(ji,jj,iku) 
    273                ze3wv = gdept_n(ji,jj+1,ikv) - gdept_n(ji,jj,ikv) 
    274                ! 
    275                ! i- direction 
    276                IF( ze3wu >= 0._wp ) THEN      ! case 1 
    277                   zmaxu =  ze3wu / e3w_n(ji+1,jj,iku) 
    278                   ! interpolated values of tracers 
    279                   zti (ji,jj,jn) = pta(ji+1,jj,iku,jn) + zmaxu * ( pta(ji+1,jj,ikum1,jn) - pta(ji+1,jj,iku,jn) ) 
    280                   ! gradient of  tracers 
    281                   pgtu(ji,jj,jn) = ssumask(ji,jj) * ( zti(ji,jj,jn) - pta(ji,jj,iku,jn) ) 
    282                ELSE                           ! case 2 
    283                   zmaxu = -ze3wu / e3w_n(ji,jj,iku) 
    284                   ! interpolated values of tracers 
    285                   zti (ji,jj,jn) = pta(ji,jj,iku,jn) + zmaxu * ( pta(ji,jj,ikum1,jn) - pta(ji,jj,iku,jn) ) 
    286                   ! gradient of tracers 
    287                   pgtu(ji,jj,jn) = ssumask(ji,jj) * ( pta(ji+1,jj,iku,jn) - zti(ji,jj,jn) ) 
    288                ENDIF 
    289                ! 
    290                ! j- direction 
    291                IF( ze3wv >= 0._wp ) THEN      ! case 1 
    292                   zmaxv =  ze3wv / e3w_n(ji,jj+1,ikv) 
    293                   ! interpolated values of tracers 
    294                   ztj (ji,jj,jn) = pta(ji,jj+1,ikv,jn) + zmaxv * ( pta(ji,jj+1,ikvm1,jn) - pta(ji,jj+1,ikv,jn) ) 
    295                   ! gradient of tracers 
    296                   pgtv(ji,jj,jn) = ssvmask(ji,jj) * ( ztj(ji,jj,jn) - pta(ji,jj,ikv,jn) ) 
    297                ELSE                           ! case 2 
    298                   zmaxv =  -ze3wv / e3w_n(ji,jj,ikv) 
    299                   ! interpolated values of tracers 
    300                   ztj (ji,jj,jn) = pta(ji,jj,ikv,jn) + zmaxv * ( pta(ji,jj,ikvm1,jn) - pta(ji,jj,ikv,jn) ) 
    301                   ! gradient of tracers 
    302                   pgtv(ji,jj,jn) = ssvmask(ji,jj) * ( pta(ji,jj+1,ikv,jn) - ztj(ji,jj,jn) ) 
    303                ENDIF 
    304  
    305             END DO 
    306          END DO 
     263         DO_2D_10_10 
     264 
     265            iku = mbku(ji,jj); ikum1 = MAX( iku - 1 , 1 )    ! last and before last ocean level at u- & v-points 
     266            ikv = mbkv(ji,jj); ikvm1 = MAX( ikv - 1 , 1 )    ! if level first is a p-step, ik.m1=1 
     267            ze3wu = gdept(ji+1,jj,iku,Kmm) - gdept(ji,jj,iku,Kmm) 
     268            ze3wv = gdept(ji,jj+1,ikv,Kmm) - gdept(ji,jj,ikv,Kmm) 
     269            ! 
     270            ! i- direction 
     271            IF( ze3wu >= 0._wp ) THEN      ! case 1 
     272               zmaxu =  ze3wu / e3w(ji+1,jj,iku,Kmm) 
     273               ! interpolated values of tracers 
     274               zti (ji,jj,jn) = pta(ji+1,jj,iku,jn) + zmaxu * ( pta(ji+1,jj,ikum1,jn) - pta(ji+1,jj,iku,jn) ) 
     275               ! gradient of  tracers 
     276               pgtu(ji,jj,jn) = ssumask(ji,jj) * ( zti(ji,jj,jn) - pta(ji,jj,iku,jn) ) 
     277            ELSE                           ! case 2 
     278               zmaxu = -ze3wu / e3w(ji,jj,iku,Kmm) 
     279               ! interpolated values of tracers 
     280               zti (ji,jj,jn) = pta(ji,jj,iku,jn) + zmaxu * ( pta(ji,jj,ikum1,jn) - pta(ji,jj,iku,jn) ) 
     281               ! gradient of tracers 
     282               pgtu(ji,jj,jn) = ssumask(ji,jj) * ( pta(ji+1,jj,iku,jn) - zti(ji,jj,jn) ) 
     283            ENDIF 
     284            ! 
     285            ! j- direction 
     286            IF( ze3wv >= 0._wp ) THEN      ! case 1 
     287               zmaxv =  ze3wv / e3w(ji,jj+1,ikv,Kmm) 
     288               ! interpolated values of tracers 
     289               ztj (ji,jj,jn) = pta(ji,jj+1,ikv,jn) + zmaxv * ( pta(ji,jj+1,ikvm1,jn) - pta(ji,jj+1,ikv,jn) ) 
     290               ! gradient of tracers 
     291               pgtv(ji,jj,jn) = ssvmask(ji,jj) * ( ztj(ji,jj,jn) - pta(ji,jj,ikv,jn) ) 
     292            ELSE                           ! case 2 
     293               zmaxv =  -ze3wv / e3w(ji,jj,ikv,Kmm) 
     294               ! interpolated values of tracers 
     295               ztj (ji,jj,jn) = pta(ji,jj,ikv,jn) + zmaxv * ( pta(ji,jj,ikvm1,jn) - pta(ji,jj,ikv,jn) ) 
     296               ! gradient of tracers 
     297               pgtv(ji,jj,jn) = ssvmask(ji,jj) * ( pta(ji,jj+1,ikv,jn) - ztj(ji,jj,jn) ) 
     298            ENDIF 
     299 
     300         END_2D 
    307301      END DO 
    308302      ! 
    … …  
    313307         pgru(:,:)=0.0_wp   ; pgrv(:,:)=0.0_wp ;  
    314308         ! 
    315          DO jj = 1, jpjm1 
    316             DO ji = 1, jpim1 
    317  
    318                iku = mbku(ji,jj) 
    319                ikv = mbkv(ji,jj) 
    320                ze3wu = gdept_n(ji+1,jj,iku) - gdept_n(ji,jj,iku) 
    321                ze3wv = gdept_n(ji,jj+1,ikv) - gdept_n(ji,jj,ikv) 
    322                ! 
    323                IF( ze3wu >= 0._wp ) THEN   ;   zhi(ji,jj) = gdept_n(ji  ,jj,iku)    ! i-direction: case 1 
    324                ELSE                        ;   zhi(ji,jj) = gdept_n(ji+1,jj,iku)    ! -     -      case 2 
    325                ENDIF 
    326                IF( ze3wv >= 0._wp ) THEN   ;   zhj(ji,jj) = gdept_n(ji,jj  ,ikv)    ! j-direction: case 1 
    327                ELSE                        ;   zhj(ji,jj) = gdept_n(ji,jj+1,ikv)    ! -     -      case 2 
    328                ENDIF 
    329  
    330             END DO 
    331          END DO 
     309         DO_2D_10_10 
     310 
     311            iku = mbku(ji,jj) 
     312            ikv = mbkv(ji,jj) 
     313            ze3wu = gdept(ji+1,jj,iku,Kmm) - gdept(ji,jj,iku,Kmm) 
     314            ze3wv = gdept(ji,jj+1,ikv,Kmm) - gdept(ji,jj,ikv,Kmm) 
     315            ! 
     316            IF( ze3wu >= 0._wp ) THEN   ;   zhi(ji,jj) = gdept(ji  ,jj,iku,Kmm)    ! i-direction: case 1 
     317            ELSE                        ;   zhi(ji,jj) = gdept(ji+1,jj,iku,Kmm)    ! -     -      case 2 
     318            ENDIF 
     319            IF( ze3wv >= 0._wp ) THEN   ;   zhj(ji,jj) = gdept(ji,jj  ,ikv,Kmm)    ! j-direction: case 1 
     320            ELSE                        ;   zhj(ji,jj) = gdept(ji,jj+1,ikv,Kmm)    ! -     -      case 2 
     321            ENDIF 
     322 
     323         END_2D 
    332324 
    333325         ! Compute interpolated rd from zti, ztj for the 2 cases at the depth of the partial 
    … …  
    336328         CALL eos( ztj, zhj, zrj ) 
    337329 
    338          DO jj = 1, jpjm1                 ! Gradient of density at the last level  
    339             DO ji = 1, jpim1 
    340                iku = mbku(ji,jj) 
    341                ikv = mbkv(ji,jj) 
    342                ze3wu = gdept_n(ji+1,jj,iku) - gdept_n(ji,jj,iku) 
    343                ze3wv = gdept_n(ji,jj+1,ikv) - gdept_n(ji,jj,ikv) 
    344  
    345                IF( ze3wu >= 0._wp ) THEN   ;   pgru(ji,jj) = ssumask(ji,jj) * ( zri(ji  ,jj    ) - prd(ji,jj,iku) )   ! i: 1 
    346                ELSE                        ;   pgru(ji,jj) = ssumask(ji,jj) * ( prd(ji+1,jj,iku) - zri(ji,jj    ) )   ! i: 2 
    347                ENDIF 
    348                IF( ze3wv >= 0._wp ) THEN   ;   pgrv(ji,jj) = ssvmask(ji,jj) * ( zrj(ji,jj      ) - prd(ji,jj,ikv) )   ! j: 1 
    349                ELSE                        ;   pgrv(ji,jj) = ssvmask(ji,jj) * ( prd(ji,jj+1,ikv) - zrj(ji,jj    ) )   ! j: 2 
    350                ENDIF 
    351  
    352             END DO 
    353          END DO 
     330         DO_2D_10_10 
     331            iku = mbku(ji,jj) 
     332            ikv = mbkv(ji,jj) 
     333            ze3wu = gdept(ji+1,jj,iku,Kmm) - gdept(ji,jj,iku,Kmm) 
     334            ze3wv = gdept(ji,jj+1,ikv,Kmm) - gdept(ji,jj,ikv,Kmm) 
     335 
     336            IF( ze3wu >= 0._wp ) THEN   ;   pgru(ji,jj) = ssumask(ji,jj) * ( zri(ji  ,jj    ) - prd(ji,jj,iku) )   ! i: 1 
     337            ELSE                        ;   pgru(ji,jj) = ssumask(ji,jj) * ( prd(ji+1,jj,iku) - zri(ji,jj    ) )   ! i: 2 
     338            ENDIF 
     339            IF( ze3wv >= 0._wp ) THEN   ;   pgrv(ji,jj) = ssvmask(ji,jj) * ( zrj(ji,jj      ) - prd(ji,jj,ikv) )   ! j: 1 
     340            ELSE                        ;   pgrv(ji,jj) = ssvmask(ji,jj) * ( prd(ji,jj+1,ikv) - zrj(ji,jj    ) )   ! j: 2 
     341            ENDIF 
     342 
     343         END_2D 
    354344 
    355345         CALL lbc_lnk_multi( 'zpshde', pgru , 'U', -1. , pgrv , 'V', -1. )   ! Lateral boundary conditions 
    … …  
    360350      ! 
    361351      DO jn = 1, kjpt      !==   Interpolation of tracers at the last ocean level   ==!            ! 
    362          DO jj = 1, jpjm1 
    363             DO ji = 1, jpim1 
    364                iku = miku(ji,jj); ikup1 = miku(ji,jj) + 1 
    365                ikv = mikv(ji,jj); ikvp1 = mikv(ji,jj) + 1 
    366                ! 
    367                ! (ISF) case partial step top and bottom in adjacent cell in vertical 
    368                ! cannot used e3w because if 2 cell water column, we have ps at top and bottom 
    369                ! in this case e3w(i,j) - e3w(i,j+1) is not the distance between Tj~ and Tj 
    370                ! the only common depth between cells (i,j) and (i,j+1) is gdepw_0 
    371                ze3wu  =  gdept_n(ji,jj,iku) - gdept_n(ji+1,jj,iku) 
    372                ze3wv  =  gdept_n(ji,jj,ikv) - gdept_n(ji,jj+1,ikv)  
    373  
    374                ! i- direction 
    375                IF( ze3wu >= 0._wp ) THEN      ! case 1 
    376                   zmaxu = ze3wu / e3w_n(ji+1,jj,ikup1) 
    377                   ! interpolated values of tracers 
    378                   zti(ji,jj,jn) = pta(ji+1,jj,iku,jn) + zmaxu * ( pta(ji+1,jj,ikup1,jn) - pta(ji+1,jj,iku,jn) ) 
    379                   ! gradient of tracers 
    380                   pgtui(ji,jj,jn) = ssumask(ji,jj) * ( zti(ji,jj,jn) - pta(ji,jj,iku,jn) ) 
    381                ELSE                           ! case 2 
    382                   zmaxu = - ze3wu / e3w_n(ji,jj,ikup1) 
    383                   ! interpolated values of tracers 
    384                   zti(ji,jj,jn) = pta(ji,jj,iku,jn) + zmaxu * ( pta(ji,jj,ikup1,jn) - pta(ji,jj,iku,jn) ) 
    385                   ! gradient of  tracers 
    386                   pgtui(ji,jj,jn) = ssumask(ji,jj) * ( pta(ji+1,jj,iku,jn) - zti(ji,jj,jn) ) 
    387                ENDIF 
    388                ! 
    389                ! j- direction 
    390                IF( ze3wv >= 0._wp ) THEN      ! case 1 
    391                   zmaxv =  ze3wv / e3w_n(ji,jj+1,ikvp1) 
    392                   ! interpolated values of tracers 
    393                   ztj(ji,jj,jn) = pta(ji,jj+1,ikv,jn) + zmaxv * ( pta(ji,jj+1,ikvp1,jn) - pta(ji,jj+1,ikv,jn) ) 
    394                   ! gradient of tracers 
    395                   pgtvi(ji,jj,jn) = ssvmask(ji,jj) * ( ztj(ji,jj,jn) - pta(ji,jj,ikv,jn) ) 
    396                ELSE                           ! case 2 
    397                   zmaxv =  - ze3wv / e3w_n(ji,jj,ikvp1) 
    398                   ! interpolated values of tracers 
    399                   ztj(ji,jj,jn) = pta(ji,jj,ikv,jn) + zmaxv * ( pta(ji,jj,ikvp1,jn) - pta(ji,jj,ikv,jn) ) 
    400                   ! gradient of tracers 
    401                   pgtvi(ji,jj,jn) = ssvmask(ji,jj) * ( pta(ji,jj+1,ikv,jn) - ztj(ji,jj,jn) ) 
    402                ENDIF 
    403  
    404             END DO 
    405          END DO 
     352         DO_2D_10_10 
     353            iku = miku(ji,jj); ikup1 = miku(ji,jj) + 1 
     354            ikv = mikv(ji,jj); ikvp1 = mikv(ji,jj) + 1 
     355            ! 
     356            ! (ISF) case partial step top and bottom in adjacent cell in vertical 
     357            ! cannot used e3w because if 2 cell water column, we have ps at top and bottom 
     358            ! in this case e3w(i,j) - e3w(i,j+1) is not the distance between Tj~ and Tj 
     359            ! the only common depth between cells (i,j) and (i,j+1) is gdepw_0 
     360            ze3wu  =  gdept(ji,jj,iku,Kmm) - gdept(ji+1,jj,iku,Kmm) 
     361            ze3wv  =  gdept(ji,jj,ikv,Kmm) - gdept(ji,jj+1,ikv,Kmm)  
     362 
     363            ! i- direction 
     364            IF( ze3wu >= 0._wp ) THEN      ! case 1 
     365               zmaxu = ze3wu / e3w(ji+1,jj,ikup1,Kmm) 
     366               ! interpolated values of tracers 
     367               zti(ji,jj,jn) = pta(ji+1,jj,iku,jn) + zmaxu * ( pta(ji+1,jj,ikup1,jn) - pta(ji+1,jj,iku,jn) ) 
     368               ! gradient of tracers 
     369               pgtui(ji,jj,jn) = ssumask(ji,jj) * ( zti(ji,jj,jn) - pta(ji,jj,iku,jn) ) 
     370            ELSE                           ! case 2 
     371               zmaxu = - ze3wu / e3w(ji,jj,ikup1,Kmm) 
     372               ! interpolated values of tracers 
     373               zti(ji,jj,jn) = pta(ji,jj,iku,jn) + zmaxu * ( pta(ji,jj,ikup1,jn) - pta(ji,jj,iku,jn) ) 
     374               ! gradient of  tracers 
     375               pgtui(ji,jj,jn) = ssumask(ji,jj) * ( pta(ji+1,jj,iku,jn) - zti(ji,jj,jn) ) 
     376            ENDIF 
     377            ! 
     378            ! j- direction 
     379            IF( ze3wv >= 0._wp ) THEN      ! case 1 
     380               zmaxv =  ze3wv / e3w(ji,jj+1,ikvp1,Kmm) 
     381               ! interpolated values of tracers 
     382               ztj(ji,jj,jn) = pta(ji,jj+1,ikv,jn) + zmaxv * ( pta(ji,jj+1,ikvp1,jn) - pta(ji,jj+1,ikv,jn) ) 
     383               ! gradient of tracers 
     384               pgtvi(ji,jj,jn) = ssvmask(ji,jj) * ( ztj(ji,jj,jn) - pta(ji,jj,ikv,jn) ) 
     385            ELSE                           ! case 2 
     386               zmaxv =  - ze3wv / e3w(ji,jj,ikvp1,Kmm) 
     387               ! interpolated values of tracers 
     388               ztj(ji,jj,jn) = pta(ji,jj,ikv,jn) + zmaxv * ( pta(ji,jj,ikvp1,jn) - pta(ji,jj,ikv,jn) ) 
     389               ! gradient of tracers 
     390               pgtvi(ji,jj,jn) = ssvmask(ji,jj) * ( pta(ji,jj+1,ikv,jn) - ztj(ji,jj,jn) ) 
     391            ENDIF 
     392 
     393         END_2D 
    406394         ! 
    407395      END DO 
    … …  
    411399         ! 
    412400         pgrui(:,:)  =0.0_wp; pgrvi(:,:)  =0.0_wp; 
    413          DO jj = 1, jpjm1 
    414             DO ji = 1, jpim1 
    415  
    416                iku = miku(ji,jj) 
    417                ikv = mikv(ji,jj) 
    418                ze3wu  =  gdept_n(ji,jj,iku) - gdept_n(ji+1,jj,iku) 
    419                ze3wv  =  gdept_n(ji,jj,ikv) - gdept_n(ji,jj+1,ikv)  
    420                ! 
    421                IF( ze3wu >= 0._wp ) THEN   ;   zhi(ji,jj) = gdept_n(ji  ,jj,iku)    ! i-direction: case 1 
    422                ELSE                        ;   zhi(ji,jj) = gdept_n(ji+1,jj,iku)    ! -     -      case 2 
    423                ENDIF 
    424  
    425                IF( ze3wv >= 0._wp ) THEN   ;   zhj(ji,jj) = gdept_n(ji,jj  ,ikv)    ! j-direction: case 1 
    426                ELSE                        ;   zhj(ji,jj) = gdept_n(ji,jj+1,ikv)    ! -     -      case 2 
    427                ENDIF 
    428  
    429             END DO 
    430          END DO 
     401         DO_2D_10_10 
     402 
     403            iku = miku(ji,jj) 
     404            ikv = mikv(ji,jj) 
     405            ze3wu  =  gdept(ji,jj,iku,Kmm) - gdept(ji+1,jj,iku,Kmm) 
     406            ze3wv  =  gdept(ji,jj,ikv,Kmm) - gdept(ji,jj+1,ikv,Kmm)  
     407            ! 
     408            IF( ze3wu >= 0._wp ) THEN   ;   zhi(ji,jj) = gdept(ji  ,jj,iku,Kmm)    ! i-direction: case 1 
     409            ELSE                        ;   zhi(ji,jj) = gdept(ji+1,jj,iku,Kmm)    ! -     -      case 2 
     410            ENDIF 
     411 
     412            IF( ze3wv >= 0._wp ) THEN   ;   zhj(ji,jj) = gdept(ji,jj  ,ikv,Kmm)    ! j-direction: case 1 
     413            ELSE                        ;   zhj(ji,jj) = gdept(ji,jj+1,ikv,Kmm)    ! -     -      case 2 
     414            ENDIF 
     415 
     416         END_2D 
    431417         ! 
    432418         CALL eos( zti, zhi, zri )        ! interpolated density from zti, ztj  
    433419         CALL eos( ztj, zhj, zrj )        ! at the partial step depth output in  zri, zrj  
    434420         ! 
    435          DO jj = 1, jpjm1                 ! Gradient of density at the last level  
    436             DO ji = 1, jpim1 
    437                iku = miku(ji,jj)  
    438                ikv = mikv(ji,jj)  
    439                ze3wu  =  gdept_n(ji,jj,iku) - gdept_n(ji+1,jj,iku) 
    440                ze3wv  =  gdept_n(ji,jj,ikv) - gdept_n(ji,jj+1,ikv)  
    441  
    442                IF( ze3wu >= 0._wp ) THEN ; pgrui(ji,jj) = ssumask(ji,jj) * ( zri(ji  ,jj      ) - prd(ji,jj,iku) ) ! i: 1 
    443                ELSE                      ; pgrui(ji,jj) = ssumask(ji,jj) * ( prd(ji+1,jj  ,iku) - zri(ji,jj    ) ) ! i: 2 
    444                ENDIF 
    445                IF( ze3wv >= 0._wp ) THEN ; pgrvi(ji,jj) = ssvmask(ji,jj) * ( zrj(ji  ,jj      ) - prd(ji,jj,ikv) ) ! j: 1 
    446                ELSE                      ; pgrvi(ji,jj) = ssvmask(ji,jj) * ( prd(ji  ,jj+1,ikv) - zrj(ji,jj    ) ) ! j: 2 
    447                ENDIF 
    448  
    449             END DO 
    450          END DO 
     421         DO_2D_10_10 
     422            iku = miku(ji,jj)  
     423            ikv = mikv(ji,jj)  
     424            ze3wu  =  gdept(ji,jj,iku,Kmm) - gdept(ji+1,jj,iku,Kmm) 
     425            ze3wv  =  gdept(ji,jj,ikv,Kmm) - gdept(ji,jj+1,ikv,Kmm)  
     426 
     427            IF( ze3wu >= 0._wp ) THEN ; pgrui(ji,jj) = ssumask(ji,jj) * ( zri(ji  ,jj      ) - prd(ji,jj,iku) ) ! i: 1 
     428            ELSE                      ; pgrui(ji,jj) = ssumask(ji,jj) * ( prd(ji+1,jj  ,iku) - zri(ji,jj    ) ) ! i: 2 
     429            ENDIF 
     430            IF( ze3wv >= 0._wp ) THEN ; pgrvi(ji,jj) = ssvmask(ji,jj) * ( zrj(ji  ,jj      ) - prd(ji,jj,ikv) ) ! j: 1 
     431            ELSE                      ; pgrvi(ji,jj) = ssvmask(ji,jj) * ( prd(ji  ,jj+1,ikv) - zrj(ji,jj    ) ) ! j: 2 
     432            ENDIF 
     433 
     434         END_2D 
    451435         CALL lbc_lnk_multi( 'zpshde', pgrui, 'U', -1. , pgrvi, 'V', -1. )   ! Lateral boundary conditions 
    452436         ! 
Note: See TracChangeset for help on using the changeset viewer.