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 12340 for NEMO/branches/2019/dev_r11943_MERGE_2019/src/OCE/TRA – NEMO

Ignore:
Timestamp:
2020-01-27T15:31:53+01:00 (4 years ago)
Author:
acc
Message:

Branch 2019/dev_r11943_MERGE_2019. This commit introduces basic do loop macro
substitution to the 2019 option 1, merge branch. These changes have been SETTE
tested. The only addition is the do_loop_substitute.h90 file in the OCE directory but
the macros defined therein are used throughout the code to replace identifiable, 2D-
and 3D- nested loop opening and closing statements with single-line alternatives. Code
indents are also adjusted accordingly.

The following explanation is taken from comments in the new header file:

This header file contains preprocessor definitions and macros used in the do-loop
substitutions introduced between version 4.0 and 4.2. The primary aim of these macros
is to assist in future applications of tiling to improve performance. This is expected
to be achieved by alternative versions of these macros in selected locations. The
initial introduction of these macros simply replaces all identifiable nested 2D- and
3D-loops with single line statements (and adjusts indenting accordingly). Do loops
are identifiable if they comform to either:

DO jk = ....

DO jj = .... DO jj = ...

DO ji = .... DO ji = ...
. OR .
. .

END DO END DO

END DO END DO

END DO

and white-space variants thereof.

Additionally, only loops with recognised jj and ji loops limits are treated; these are:
Lower limits of 1, 2 or fs_2
Upper limits of jpi, jpim1 or fs_jpim1 (for ji) or jpj, jpjm1 or fs_jpjm1 (for jj)

The macro naming convention takes the form: DO_2D_BT_LR where:

B is the Bottom offset from the PE's inner domain;
T is the Top offset from the PE's inner domain;
L is the Left offset from the PE's inner domain;
R is the Right offset from the PE's inner domain

So, given an inner domain of 2,jpim1 and 2,jpjm1, a typical example would replace:

DO jj = 2, jpj

DO ji = 1, jpim1
.
.

END DO

END DO

with:

DO_2D_01_10
.
.
END_2D

similar conventions apply to the 3D loops macros. jk loop limits are retained
through macro arguments and are not restricted. This includes the possibility of
strides for which an extra set of DO_3DS macros are defined.

In the example definition below the inner PE domain is defined by start indices of
(kIs, kJs) and end indices of (kIe, KJe)

#define DO_2D_00_00 DO jj = kJs, kJe ; DO ji = kIs, kIe
#define END_2D END DO ; END DO

TO DO:

Only conventional nested loops have been identified and replaced by this step. There are constructs such as:

DO jk = 2, jpkm1

z2d(:,:) = z2d(:,:) + e3w(:,:,jk,Kmm) * z3d(:,:,jk) * wmask(:,:,jk)

END DO

which may need to be considered.

Location:
NEMO/branches/2019/dev_r11943_MERGE_2019/src/OCE/TRA
Files:
20 edited

Legend:

Unmodified
Added
Removed

  • NEMO/branches/2019/dev_r11943_MERGE_2019/src/OCE/TRA/eosbn2.F90

    r12269 r12340  
    180180   !! * Substitutions 
    181181#  include "vectopt_loop_substitute.h90" 
     182#  include "do_loop_substitute.h90" 
    182183   !!---------------------------------------------------------------------- 
    183184   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    237238      CASE( np_teos10, np_eos80 )                !==  polynomial TEOS-10 / EOS-80 ==! 
    238239         ! 
    239          DO jk = 1, jpkm1 
    240             DO jj = 1, jpj 
    241                DO ji = 1, jpi 
    242                   ! 
    243                   zh  = pdep(ji,jj,jk) * r1_Z0                                  ! depth 
    244                   zt  = pts (ji,jj,jk,jp_tem) * r1_T0                           ! temperature 
    245                   zs  = SQRT( ABS( pts(ji,jj,jk,jp_sal) + rdeltaS ) * r1_S0 )   ! square root salinity 
    246                   ztm = tmask(ji,jj,jk)                                         ! tmask 
     240         DO_3D_11_11( 1, jpkm1 ) 
     241            ! 
     242            zh  = pdep(ji,jj,jk) * r1_Z0                                  ! depth 
     243            zt  = pts (ji,jj,jk,jp_tem) * r1_T0                           ! temperature 
     244            zs  = SQRT( ABS( pts(ji,jj,jk,jp_sal) + rdeltaS ) * r1_S0 )   ! square root salinity 
     245            ztm = tmask(ji,jj,jk)                                         ! tmask 
     246            ! 
     247            zn3 = EOS013*zt   & 
     248               &   + EOS103*zs+EOS003 
     249               ! 
     250            zn2 = (EOS022*zt   & 
     251               &   + EOS112*zs+EOS012)*zt   & 
     252               &   + (EOS202*zs+EOS102)*zs+EOS002 
     253               ! 
     254            zn1 = (((EOS041*zt   & 
     255               &   + EOS131*zs+EOS031)*zt   & 
     256               &   + (EOS221*zs+EOS121)*zs+EOS021)*zt   & 
     257               &   + ((EOS311*zs+EOS211)*zs+EOS111)*zs+EOS011)*zt   & 
     258               &   + (((EOS401*zs+EOS301)*zs+EOS201)*zs+EOS101)*zs+EOS001 
     259               ! 
     260            zn0 = (((((EOS060*zt   & 
     261               &   + EOS150*zs+EOS050)*zt   & 
     262               &   + (EOS240*zs+EOS140)*zs+EOS040)*zt   & 
     263               &   + ((EOS330*zs+EOS230)*zs+EOS130)*zs+EOS030)*zt   & 
     264               &   + (((EOS420*zs+EOS320)*zs+EOS220)*zs+EOS120)*zs+EOS020)*zt   & 
     265               &   + ((((EOS510*zs+EOS410)*zs+EOS310)*zs+EOS210)*zs+EOS110)*zs+EOS010)*zt   & 
     266               &   + (((((EOS600*zs+EOS500)*zs+EOS400)*zs+EOS300)*zs+EOS200)*zs+EOS100)*zs+EOS000 
     267               ! 
     268            zn  = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 
     269            ! 
     270            prd(ji,jj,jk) = (  zn * r1_rau0 - 1._wp  ) * ztm  ! density anomaly (masked) 
     271            ! 
     272         END_3D 
     273         ! 
     274      CASE( np_seos )                !==  simplified EOS  ==! 
     275         ! 
     276         DO_3D_11_11( 1, jpkm1 ) 
     277            zt  = pts  (ji,jj,jk,jp_tem) - 10._wp 
     278            zs  = pts  (ji,jj,jk,jp_sal) - 35._wp 
     279            zh  = pdep (ji,jj,jk) 
     280            ztm = tmask(ji,jj,jk) 
     281            ! 
     282            zn =  - rn_a0 * ( 1._wp + 0.5_wp*rn_lambda1*zt + rn_mu1*zh ) * zt   & 
     283               &  + rn_b0 * ( 1._wp - 0.5_wp*rn_lambda2*zs - rn_mu2*zh ) * zs   & 
     284               &  - rn_nu * zt * zs 
     285               !                                  
     286            prd(ji,jj,jk) = zn * r1_rau0 * ztm                ! density anomaly (masked) 
     287         END_3D 
     288         ! 
     289      END SELECT 
     290      ! 
     291      IF(sn_cfctl%l_prtctl)   CALL prt_ctl( tab3d_1=prd, clinfo1=' eos-insitu  : ', kdim=jpk ) 
     292      ! 
     293      IF( ln_timing )   CALL timing_stop('eos-insitu') 
     294      ! 
     295   END SUBROUTINE eos_insitu 
     296 
     297 
     298   SUBROUTINE eos_insitu_pot( pts, prd, prhop, pdep ) 
     299      !!---------------------------------------------------------------------- 
     300      !!                  ***  ROUTINE eos_insitu_pot  *** 
     301      !! 
     302      !! ** Purpose :   Compute the in situ density (ratio rho/rau0) and the 
     303      !!      potential volumic mass (Kg/m3) from potential temperature and 
     304      !!      salinity fields using an equation of state selected in the 
     305      !!     namelist. 
     306      !! 
     307      !! ** Action  : - prd  , the in situ density (no units) 
     308      !!              - prhop, the potential volumic mass (Kg/m3) 
     309      !! 
     310      !!---------------------------------------------------------------------- 
     311      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in   ) ::   pts    ! 1 : potential temperature  [Celsius] 
     312      !                                                                ! 2 : salinity               [psu] 
     313      REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(  out) ::   prd    ! in situ density            [-] 
     314      REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(  out) ::   prhop  ! potential density (surface referenced) 
     315      REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ) ::   pdep   ! depth                      [m] 
     316      ! 
     317      INTEGER  ::   ji, jj, jk, jsmp             ! dummy loop indices 
     318      INTEGER  ::   jdof 
     319      REAL(wp) ::   zt , zh , zstemp, zs , ztm   ! local scalars 
     320      REAL(wp) ::   zn , zn0, zn1, zn2, zn3      !   -      - 
     321      REAL(wp), DIMENSION(:), ALLOCATABLE :: zn0_sto, zn_sto, zsign    ! local vectors 
     322      !!---------------------------------------------------------------------- 
     323      ! 
     324      IF( ln_timing )   CALL timing_start('eos-pot') 
     325      ! 
     326      SELECT CASE ( neos ) 
     327      ! 
     328      CASE( np_teos10, np_eos80 )                !==  polynomial TEOS-10 / EOS-80 ==! 
     329         ! 
     330         ! Stochastic equation of state 
     331         IF ( ln_sto_eos ) THEN 
     332            ALLOCATE(zn0_sto(1:2*nn_sto_eos)) 
     333            ALLOCATE(zn_sto(1:2*nn_sto_eos)) 
     334            ALLOCATE(zsign(1:2*nn_sto_eos)) 
     335            DO jsmp = 1, 2*nn_sto_eos, 2 
     336              zsign(jsmp)   = 1._wp 
     337              zsign(jsmp+1) = -1._wp 
     338            END DO 
     339            ! 
     340            DO_3D_11_11( 1, jpkm1 ) 
     341               ! 
     342               ! compute density (2*nn_sto_eos) times: 
     343               ! (1) for t+dt, s+ds (with the random TS fluctutation computed in sto_pts) 
     344               ! (2) for t-dt, s-ds (with the opposite fluctuation) 
     345               DO jsmp = 1, nn_sto_eos*2 
     346                  jdof   = (jsmp + 1) / 2 
     347                  zh     = pdep(ji,jj,jk) * r1_Z0                                  ! depth 
     348                  zt     = (pts (ji,jj,jk,jp_tem) + pts_ran(ji,jj,jk,jp_tem,jdof) * zsign(jsmp)) * r1_T0    ! temperature 
     349                  zstemp = pts  (ji,jj,jk,jp_sal) + pts_ran(ji,jj,jk,jp_sal,jdof) * zsign(jsmp) 
     350                  zs     = SQRT( ABS( zstemp + rdeltaS ) * r1_S0 )   ! square root salinity 
     351                  ztm    = tmask(ji,jj,jk)                                         ! tmask 
    247352                  ! 
    248353                  zn3 = EOS013*zt   & 
    … …  
    259364                     &   + (((EOS401*zs+EOS301)*zs+EOS201)*zs+EOS101)*zs+EOS001 
    260365                     ! 
    261                   zn0 = (((((EOS060*zt   & 
     366                  zn0_sto(jsmp) = (((((EOS060*zt   & 
    262367                     &   + EOS150*zs+EOS050)*zt   & 
    263368                     &   + (EOS240*zs+EOS140)*zs+EOS040)*zt   & 
    … …  
    267372                     &   + (((((EOS600*zs+EOS500)*zs+EOS400)*zs+EOS300)*zs+EOS200)*zs+EOS100)*zs+EOS000 
    268373                     ! 
    269                   zn  = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 
     374                  zn_sto(jsmp)  = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0_sto(jsmp) 
     375               END DO 
     376               ! 
     377               ! compute stochastic density as the mean of the (2*nn_sto_eos) densities 
     378               prhop(ji,jj,jk) = 0._wp ; prd(ji,jj,jk) = 0._wp 
     379               DO jsmp = 1, nn_sto_eos*2 
     380                  prhop(ji,jj,jk) = prhop(ji,jj,jk) + zn0_sto(jsmp)                      ! potential density referenced at the surface 
    270381                  ! 
    271                   prd(ji,jj,jk) = (  zn * r1_rau0 - 1._wp  ) * ztm  ! density anomaly (masked) 
    272                   ! 
     382                  prd(ji,jj,jk) = prd(ji,jj,jk) + (  zn_sto(jsmp) * r1_rau0 - 1._wp  )   ! density anomaly (masked) 
    273383               END DO 
    274             END DO 
    275          END DO 
    276          ! 
    277       CASE( np_seos )                !==  simplified EOS  ==! 
    278          ! 
    279          DO jk = 1, jpkm1 
    280             DO jj = 1, jpj 
    281                DO ji = 1, jpi 
    282                   zt  = pts  (ji,jj,jk,jp_tem) - 10._wp 
    283                   zs  = pts  (ji,jj,jk,jp_sal) - 35._wp 
    284                   zh  = pdep (ji,jj,jk) 
    285                   ztm = tmask(ji,jj,jk) 
    286                   ! 
    287                   zn =  - rn_a0 * ( 1._wp + 0.5_wp*rn_lambda1*zt + rn_mu1*zh ) * zt   & 
    288                      &  + rn_b0 * ( 1._wp - 0.5_wp*rn_lambda2*zs - rn_mu2*zh ) * zs   & 
    289                      &  - rn_nu * zt * zs 
    290                      !                                  
    291                   prd(ji,jj,jk) = zn * r1_rau0 * ztm                ! density anomaly (masked) 
    292                END DO 
    293             END DO 
    294          END DO 
    295          ! 
    296       END SELECT 
    297       ! 
    298       IF(sn_cfctl%l_prtctl)   CALL prt_ctl( tab3d_1=prd, clinfo1=' eos-insitu  : ', kdim=jpk ) 
    299       ! 
    300       IF( ln_timing )   CALL timing_stop('eos-insitu') 
    301       ! 
    302    END SUBROUTINE eos_insitu 
    303  
    304  
    305    SUBROUTINE eos_insitu_pot( pts, prd, prhop, pdep ) 
    306       !!---------------------------------------------------------------------- 
    307       !!                  ***  ROUTINE eos_insitu_pot  *** 
    308       !! 
    309       !! ** Purpose :   Compute the in situ density (ratio rho/rau0) and the 
    310       !!      potential volumic mass (Kg/m3) from potential temperature and 
    311       !!      salinity fields using an equation of state selected in the 
    312       !!     namelist. 
    313       !! 
    314       !! ** Action  : - prd  , the in situ density (no units) 
    315       !!              - prhop, the potential volumic mass (Kg/m3) 
    316       !! 
    317       !!---------------------------------------------------------------------- 
    318       REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in   ) ::   pts    ! 1 : potential temperature  [Celsius] 
    319       !                                                                ! 2 : salinity               [psu] 
    320       REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(  out) ::   prd    ! in situ density            [-] 
    321       REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(  out) ::   prhop  ! potential density (surface referenced) 
    322       REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ) ::   pdep   ! depth                      [m] 
    323       ! 
    324       INTEGER  ::   ji, jj, jk, jsmp             ! dummy loop indices 
    325       INTEGER  ::   jdof 
    326       REAL(wp) ::   zt , zh , zstemp, zs , ztm   ! local scalars 
    327       REAL(wp) ::   zn , zn0, zn1, zn2, zn3      !   -      - 
    328       REAL(wp), DIMENSION(:), ALLOCATABLE :: zn0_sto, zn_sto, zsign    ! local vectors 
    329       !!---------------------------------------------------------------------- 
    330       ! 
    331       IF( ln_timing )   CALL timing_start('eos-pot') 
    332       ! 
    333       SELECT CASE ( neos ) 
    334       ! 
    335       CASE( np_teos10, np_eos80 )                !==  polynomial TEOS-10 / EOS-80 ==! 
    336          ! 
    337          ! Stochastic equation of state 
    338          IF ( ln_sto_eos ) THEN 
    339             ALLOCATE(zn0_sto(1:2*nn_sto_eos)) 
    340             ALLOCATE(zn_sto(1:2*nn_sto_eos)) 
    341             ALLOCATE(zsign(1:2*nn_sto_eos)) 
    342             DO jsmp = 1, 2*nn_sto_eos, 2 
    343               zsign(jsmp)   = 1._wp 
    344               zsign(jsmp+1) = -1._wp 
    345             END DO 
    346             ! 
    347             DO jk = 1, jpkm1 
    348                DO jj = 1, jpj 
    349                   DO ji = 1, jpi 
    350                      ! 
    351                      ! compute density (2*nn_sto_eos) times: 
    352                      ! (1) for t+dt, s+ds (with the random TS fluctutation computed in sto_pts) 
    353                      ! (2) for t-dt, s-ds (with the opposite fluctuation) 
    354                      DO jsmp = 1, nn_sto_eos*2 
    355                         jdof   = (jsmp + 1) / 2 
    356                         zh     = pdep(ji,jj,jk) * r1_Z0                                  ! depth 
    357                         zt     = (pts (ji,jj,jk,jp_tem) + pts_ran(ji,jj,jk,jp_tem,jdof) * zsign(jsmp)) * r1_T0    ! temperature 
    358                         zstemp = pts  (ji,jj,jk,jp_sal) + pts_ran(ji,jj,jk,jp_sal,jdof) * zsign(jsmp) 
    359                         zs     = SQRT( ABS( zstemp + rdeltaS ) * r1_S0 )   ! square root salinity 
    360                         ztm    = tmask(ji,jj,jk)                                         ! tmask 
    361                         ! 
    362                         zn3 = EOS013*zt   & 
    363                            &   + EOS103*zs+EOS003 
    364                            ! 
    365                         zn2 = (EOS022*zt   & 
    366                            &   + EOS112*zs+EOS012)*zt   & 
    367                            &   + (EOS202*zs+EOS102)*zs+EOS002 
    368                            ! 
    369                         zn1 = (((EOS041*zt   & 
    370                            &   + EOS131*zs+EOS031)*zt   & 
    371                            &   + (EOS221*zs+EOS121)*zs+EOS021)*zt   & 
    372                            &   + ((EOS311*zs+EOS211)*zs+EOS111)*zs+EOS011)*zt   & 
    373                            &   + (((EOS401*zs+EOS301)*zs+EOS201)*zs+EOS101)*zs+EOS001 
    374                            ! 
    375                         zn0_sto(jsmp) = (((((EOS060*zt   & 
    376                            &   + EOS150*zs+EOS050)*zt   & 
    377                            &   + (EOS240*zs+EOS140)*zs+EOS040)*zt   & 
    378                            &   + ((EOS330*zs+EOS230)*zs+EOS130)*zs+EOS030)*zt   & 
    379                            &   + (((EOS420*zs+EOS320)*zs+EOS220)*zs+EOS120)*zs+EOS020)*zt   & 
    380                            &   + ((((EOS510*zs+EOS410)*zs+EOS310)*zs+EOS210)*zs+EOS110)*zs+EOS010)*zt   & 
    381                            &   + (((((EOS600*zs+EOS500)*zs+EOS400)*zs+EOS300)*zs+EOS200)*zs+EOS100)*zs+EOS000 
    382                            ! 
    383                         zn_sto(jsmp)  = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0_sto(jsmp) 
    384                      END DO 
    385                      ! 
    386                      ! compute stochastic density as the mean of the (2*nn_sto_eos) densities 
    387                      prhop(ji,jj,jk) = 0._wp ; prd(ji,jj,jk) = 0._wp 
    388                      DO jsmp = 1, nn_sto_eos*2 
    389                         prhop(ji,jj,jk) = prhop(ji,jj,jk) + zn0_sto(jsmp)                      ! potential density referenced at the surface 
    390                         ! 
    391                         prd(ji,jj,jk) = prd(ji,jj,jk) + (  zn_sto(jsmp) * r1_rau0 - 1._wp  )   ! density anomaly (masked) 
    392                      END DO 
    393                      prhop(ji,jj,jk) = 0.5_wp * prhop(ji,jj,jk) * ztm / nn_sto_eos 
    394                      prd  (ji,jj,jk) = 0.5_wp * prd  (ji,jj,jk) * ztm / nn_sto_eos 
    395                   END DO 
    396                END DO 
    397             END DO 
     384               prhop(ji,jj,jk) = 0.5_wp * prhop(ji,jj,jk) * ztm / nn_sto_eos 
     385               prd  (ji,jj,jk) = 0.5_wp * prd  (ji,jj,jk) * ztm / nn_sto_eos 
     386            END_3D 
    398387            DEALLOCATE(zn0_sto,zn_sto,zsign) 
    399388         ! Non-stochastic equation of state 
    400389         ELSE 
    401             DO jk = 1, jpkm1 
    402                DO jj = 1, jpj 
    403                   DO ji = 1, jpi 
    404                      ! 
    405                      zh  = pdep(ji,jj,jk) * r1_Z0                                  ! depth 
    406                      zt  = pts (ji,jj,jk,jp_tem) * r1_T0                           ! temperature 
    407                      zs  = SQRT( ABS( pts(ji,jj,jk,jp_sal) + rdeltaS ) * r1_S0 )   ! square root salinity 
    408                      ztm = tmask(ji,jj,jk)                                         ! tmask 
    409                      ! 
    410                      zn3 = EOS013*zt   & 
    411                         &   + EOS103*zs+EOS003 
    412                         ! 
    413                      zn2 = (EOS022*zt   & 
    414                         &   + EOS112*zs+EOS012)*zt   & 
    415                         &   + (EOS202*zs+EOS102)*zs+EOS002 
    416                         ! 
    417                      zn1 = (((EOS041*zt   & 
    418                         &   + EOS131*zs+EOS031)*zt   & 
    419                         &   + (EOS221*zs+EOS121)*zs+EOS021)*zt   & 
    420                         &   + ((EOS311*zs+EOS211)*zs+EOS111)*zs+EOS011)*zt   & 
    421                         &   + (((EOS401*zs+EOS301)*zs+EOS201)*zs+EOS101)*zs+EOS001 
    422                         ! 
    423                      zn0 = (((((EOS060*zt   & 
    424                         &   + EOS150*zs+EOS050)*zt   & 
    425                         &   + (EOS240*zs+EOS140)*zs+EOS040)*zt   & 
    426                         &   + ((EOS330*zs+EOS230)*zs+EOS130)*zs+EOS030)*zt   & 
    427                         &   + (((EOS420*zs+EOS320)*zs+EOS220)*zs+EOS120)*zs+EOS020)*zt   & 
    428                         &   + ((((EOS510*zs+EOS410)*zs+EOS310)*zs+EOS210)*zs+EOS110)*zs+EOS010)*zt   & 
    429                         &   + (((((EOS600*zs+EOS500)*zs+EOS400)*zs+EOS300)*zs+EOS200)*zs+EOS100)*zs+EOS000 
    430                         ! 
    431                      zn  = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 
    432                      ! 
    433                      prhop(ji,jj,jk) = zn0 * ztm                           ! potential density referenced at the surface 
    434                      ! 
    435                      prd(ji,jj,jk) = (  zn * r1_rau0 - 1._wp  ) * ztm      ! density anomaly (masked) 
    436                   END DO 
    437                END DO 
    438             END DO 
    439          ENDIF 
    440           
    441       CASE( np_seos )                !==  simplified EOS  ==! 
    442          ! 
    443          DO jk = 1, jpkm1 
    444             DO jj = 1, jpj 
    445                DO ji = 1, jpi 
    446                   zt  = pts  (ji,jj,jk,jp_tem) - 10._wp 
    447                   zs  = pts  (ji,jj,jk,jp_sal) - 35._wp 
    448                   zh  = pdep (ji,jj,jk) 
    449                   ztm = tmask(ji,jj,jk) 
    450                   !                                                     ! potential density referenced at the surface 
    451                   zn =  - rn_a0 * ( 1._wp + 0.5_wp*rn_lambda1*zt ) * zt   & 
    452                      &  + rn_b0 * ( 1._wp - 0.5_wp*rn_lambda2*zs ) * zs   & 
    453                      &  - rn_nu * zt * zs 
    454                   prhop(ji,jj,jk) = ( rau0 + zn ) * ztm 
    455                   !                                                     ! density anomaly (masked) 
    456                   zn = zn - ( rn_a0 * rn_mu1 * zt + rn_b0 * rn_mu2 * zs ) * zh 
    457                   prd(ji,jj,jk) = zn * r1_rau0 * ztm 
    458                   ! 
    459                END DO 
    460             END DO 
    461          END DO 
    462          ! 
    463       END SELECT 
    464       ! 
    465       IF(sn_cfctl%l_prtctl)   CALL prt_ctl( tab3d_1=prd, clinfo1=' eos-pot: ', tab3d_2=prhop, clinfo2=' pot : ', kdim=jpk ) 
    466       ! 
    467       IF( ln_timing )   CALL timing_stop('eos-pot') 
    468       ! 
    469    END SUBROUTINE eos_insitu_pot 
    470  
    471  
    472    SUBROUTINE eos_insitu_2d( pts, pdep, prd ) 
    473       !!---------------------------------------------------------------------- 
    474       !!                  ***  ROUTINE eos_insitu_2d  *** 
    475       !! 
    476       !! ** Purpose :   Compute the in situ density (ratio rho/rau0) from 
    477       !!      potential temperature and salinity using an equation of state 
    478       !!      selected in the nameos namelist. * 2D field case 
    479       !! 
    480       !! ** Action  : - prd , the in situ density (no units) (unmasked) 
    481       !! 
    482       !!---------------------------------------------------------------------- 
    483       REAL(wp), DIMENSION(jpi,jpj,jpts), INTENT(in   ) ::   pts   ! 1 : potential temperature  [Celsius] 
    484       !                                                           ! 2 : salinity               [psu] 
    485       REAL(wp), DIMENSION(jpi,jpj)     , INTENT(in   ) ::   pdep  ! depth                      [m] 
    486       REAL(wp), DIMENSION(jpi,jpj)     , INTENT(  out) ::   prd   ! in situ density 
    487       ! 
    488       INTEGER  ::   ji, jj, jk                ! dummy loop indices 
    489       REAL(wp) ::   zt , zh , zs              ! local scalars 
    490       REAL(wp) ::   zn , zn0, zn1, zn2, zn3   !   -      - 
    491       !!---------------------------------------------------------------------- 
    492       ! 
    493       IF( ln_timing )   CALL timing_start('eos2d') 
    494       ! 
    495       prd(:,:) = 0._wp 
    496       ! 
    497       SELECT CASE( neos ) 
    498       ! 
    499       CASE( np_teos10, np_eos80 )                !==  polynomial TEOS-10 / EOS-80 ==! 
    500          ! 
    501          DO jj = 1, jpj 
    502             DO ji = 1, jpi   ! vector opt. 
    503                ! 
    504                zh  = pdep(ji,jj) * r1_Z0                                  ! depth 
    505                zt  = pts (ji,jj,jp_tem) * r1_T0                           ! temperature 
    506                zs  = SQRT( ABS( pts(ji,jj,jp_sal) + rdeltaS ) * r1_S0 )   ! square root salinity 
     390            DO_3D_11_11( 1, jpkm1 ) 
     391               ! 
     392               zh  = pdep(ji,jj,jk) * r1_Z0                                  ! depth 
     393               zt  = pts (ji,jj,jk,jp_tem) * r1_T0                           ! temperature 
     394               zs  = SQRT( ABS( pts(ji,jj,jk,jp_sal) + rdeltaS ) * r1_S0 )   ! square root salinity 
     395               ztm = tmask(ji,jj,jk)                                         ! tmask 
    507396               ! 
    508397               zn3 = EOS013*zt   & 
    … …  
    529418               zn  = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 
    530419               ! 
    531                prd(ji,jj) = zn * r1_rau0 - 1._wp               ! unmasked in situ density anomaly 
    532                ! 
    533             END DO 
    534          END DO 
    535          ! 
     420               prhop(ji,jj,jk) = zn0 * ztm                           ! potential density referenced at the surface 
     421               ! 
     422               prd(ji,jj,jk) = (  zn * r1_rau0 - 1._wp  ) * ztm      ! density anomaly (masked) 
     423            END_3D 
     424         ENDIF 
     425          
    536426      CASE( np_seos )                !==  simplified EOS  ==! 
    537427         ! 
    538          DO jj = 1, jpj 
    539             DO ji = 1, jpi   ! vector opt. 
    540                ! 
    541                zt    = pts  (ji,jj,jp_tem)  - 10._wp 
    542                zs    = pts  (ji,jj,jp_sal)  - 35._wp 
    543                zh    = pdep (ji,jj)                         ! depth at the partial step level 
    544                ! 
    545                zn =  - rn_a0 * ( 1._wp + 0.5_wp*rn_lambda1*zt + rn_mu1*zh ) * zt   & 
    546                   &  + rn_b0 * ( 1._wp - 0.5_wp*rn_lambda2*zs - rn_mu2*zh ) * zs   & 
    547                   &  - rn_nu * zt * zs 
    548                   ! 
    549                prd(ji,jj) = zn * r1_rau0               ! unmasked in situ density anomaly 
    550                ! 
    551             END DO 
    552          END DO 
     428         DO_3D_11_11( 1, jpkm1 ) 
     429            zt  = pts  (ji,jj,jk,jp_tem) - 10._wp 
     430            zs  = pts  (ji,jj,jk,jp_sal) - 35._wp 
     431            zh  = pdep (ji,jj,jk) 
     432            ztm = tmask(ji,jj,jk) 
     433            !                                                     ! potential density referenced at the surface 
     434            zn =  - rn_a0 * ( 1._wp + 0.5_wp*rn_lambda1*zt ) * zt   & 
     435               &  + rn_b0 * ( 1._wp - 0.5_wp*rn_lambda2*zs ) * zs   & 
     436               &  - rn_nu * zt * zs 
     437            prhop(ji,jj,jk) = ( rau0 + zn ) * ztm 
     438            !                                                     ! density anomaly (masked) 
     439            zn = zn - ( rn_a0 * rn_mu1 * zt + rn_b0 * rn_mu2 * zs ) * zh 
     440            prd(ji,jj,jk) = zn * r1_rau0 * ztm 
     441            ! 
     442         END_3D 
     443         ! 
     444      END SELECT 
     445      ! 
     446      IF(sn_cfctl%l_prtctl)   CALL prt_ctl( tab3d_1=prd, clinfo1=' eos-pot: ', tab3d_2=prhop, clinfo2=' pot : ', kdim=jpk ) 
     447      ! 
     448      IF( ln_timing )   CALL timing_stop('eos-pot') 
     449      ! 
     450   END SUBROUTINE eos_insitu_pot 
     451 
     452 
     453   SUBROUTINE eos_insitu_2d( pts, pdep, prd ) 
     454      !!---------------------------------------------------------------------- 
     455      !!                  ***  ROUTINE eos_insitu_2d  *** 
     456      !! 
     457      !! ** Purpose :   Compute the in situ density (ratio rho/rau0) from 
     458      !!      potential temperature and salinity using an equation of state 
     459      !!      selected in the nameos namelist. * 2D field case 
     460      !! 
     461      !! ** Action  : - prd , the in situ density (no units) (unmasked) 
     462      !! 
     463      !!---------------------------------------------------------------------- 
     464      REAL(wp), DIMENSION(jpi,jpj,jpts), INTENT(in   ) ::   pts   ! 1 : potential temperature  [Celsius] 
     465      !                                                           ! 2 : salinity               [psu] 
     466      REAL(wp), DIMENSION(jpi,jpj)     , INTENT(in   ) ::   pdep  ! depth                      [m] 
     467      REAL(wp), DIMENSION(jpi,jpj)     , INTENT(  out) ::   prd   ! in situ density 
     468      ! 
     469      INTEGER  ::   ji, jj, jk                ! dummy loop indices 
     470      REAL(wp) ::   zt , zh , zs              ! local scalars 
     471      REAL(wp) ::   zn , zn0, zn1, zn2, zn3   !   -      - 
     472      !!---------------------------------------------------------------------- 
     473      ! 
     474      IF( ln_timing )   CALL timing_start('eos2d') 
     475      ! 
     476      prd(:,:) = 0._wp 
     477      ! 
     478      SELECT CASE( neos ) 
     479      ! 
     480      CASE( np_teos10, np_eos80 )                !==  polynomial TEOS-10 / EOS-80 ==! 
     481         ! 
     482         DO_2D_11_11 
     483            ! 
     484            zh  = pdep(ji,jj) * r1_Z0                                  ! depth 
     485            zt  = pts (ji,jj,jp_tem) * r1_T0                           ! temperature 
     486            zs  = SQRT( ABS( pts(ji,jj,jp_sal) + rdeltaS ) * r1_S0 )   ! square root salinity 
     487            ! 
     488            zn3 = EOS013*zt   & 
     489               &   + EOS103*zs+EOS003 
     490               ! 
     491            zn2 = (EOS022*zt   & 
     492               &   + EOS112*zs+EOS012)*zt   & 
     493               &   + (EOS202*zs+EOS102)*zs+EOS002 
     494               ! 
     495            zn1 = (((EOS041*zt   & 
     496               &   + EOS131*zs+EOS031)*zt   & 
     497               &   + (EOS221*zs+EOS121)*zs+EOS021)*zt   & 
     498               &   + ((EOS311*zs+EOS211)*zs+EOS111)*zs+EOS011)*zt   & 
     499               &   + (((EOS401*zs+EOS301)*zs+EOS201)*zs+EOS101)*zs+EOS001 
     500               ! 
     501            zn0 = (((((EOS060*zt   & 
     502               &   + EOS150*zs+EOS050)*zt   & 
     503               &   + (EOS240*zs+EOS140)*zs+EOS040)*zt   & 
     504               &   + ((EOS330*zs+EOS230)*zs+EOS130)*zs+EOS030)*zt   & 
     505               &   + (((EOS420*zs+EOS320)*zs+EOS220)*zs+EOS120)*zs+EOS020)*zt   & 
     506               &   + ((((EOS510*zs+EOS410)*zs+EOS310)*zs+EOS210)*zs+EOS110)*zs+EOS010)*zt   & 
     507               &   + (((((EOS600*zs+EOS500)*zs+EOS400)*zs+EOS300)*zs+EOS200)*zs+EOS100)*zs+EOS000 
     508               ! 
     509            zn  = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 
     510            ! 
     511            prd(ji,jj) = zn * r1_rau0 - 1._wp               ! unmasked in situ density anomaly 
     512            ! 
     513         END_2D 
     514         ! 
     515      CASE( np_seos )                !==  simplified EOS  ==! 
     516         ! 
     517         DO_2D_11_11 
     518            ! 
     519            zt    = pts  (ji,jj,jp_tem)  - 10._wp 
     520            zs    = pts  (ji,jj,jp_sal)  - 35._wp 
     521            zh    = pdep (ji,jj)                         ! depth at the partial step level 
     522            ! 
     523            zn =  - rn_a0 * ( 1._wp + 0.5_wp*rn_lambda1*zt + rn_mu1*zh ) * zt   & 
     524               &  + rn_b0 * ( 1._wp - 0.5_wp*rn_lambda2*zs - rn_mu2*zh ) * zs   & 
     525               &  - rn_nu * zt * zs 
     526               ! 
     527            prd(ji,jj) = zn * r1_rau0               ! unmasked in situ density anomaly 
     528            ! 
     529         END_2D 
    553530         ! 
    554531      END SELECT 
    … …  
    586563      CASE( np_teos10, np_eos80 )                !==  polynomial TEOS-10 / EOS-80 ==! 
    587564         ! 
    588          DO jk = 1, jpkm1 
    589             DO jj = 1, jpj 
    590                DO ji = 1, jpi 
    591                   ! 
    592                   zh  = gdept(ji,jj,jk,Kmm) * r1_Z0                                ! depth 
    593                   zt  = pts (ji,jj,jk,jp_tem) * r1_T0                           ! temperature 
    594                   zs  = SQRT( ABS( pts(ji,jj,jk,jp_sal) + rdeltaS ) * r1_S0 )   ! square root salinity 
    595                   ztm = tmask(ji,jj,jk)                                         ! tmask 
    596                   ! 
    597                   ! alpha 
    598                   zn3 = ALP003 
    599                   ! 
    600                   zn2 = ALP012*zt + ALP102*zs+ALP002 
    601                   ! 
    602                   zn1 = ((ALP031*zt   & 
    603                      &   + ALP121*zs+ALP021)*zt   & 
    604                      &   + (ALP211*zs+ALP111)*zs+ALP011)*zt   & 
    605                      &   + ((ALP301*zs+ALP201)*zs+ALP101)*zs+ALP001 
    606                      ! 
    607                   zn0 = ((((ALP050*zt   & 
    608                      &   + ALP140*zs+ALP040)*zt   & 
    609                      &   + (ALP230*zs+ALP130)*zs+ALP030)*zt   & 
    610                      &   + ((ALP320*zs+ALP220)*zs+ALP120)*zs+ALP020)*zt   & 
    611                      &   + (((ALP410*zs+ALP310)*zs+ALP210)*zs+ALP110)*zs+ALP010)*zt   & 
    612                      &   + ((((ALP500*zs+ALP400)*zs+ALP300)*zs+ALP200)*zs+ALP100)*zs+ALP000 
    613                      ! 
    614                   zn  = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 
    615                   ! 
    616                   pab(ji,jj,jk,jp_tem) = zn * r1_rau0 * ztm 
    617                   ! 
    618                   ! beta 
    619                   zn3 = BET003 
    620                   ! 
    621                   zn2 = BET012*zt + BET102*zs+BET002 
    622                   ! 
    623                   zn1 = ((BET031*zt   & 
    624                      &   + BET121*zs+BET021)*zt   & 
    625                      &   + (BET211*zs+BET111)*zs+BET011)*zt   & 
    626                      &   + ((BET301*zs+BET201)*zs+BET101)*zs+BET001 
    627                      ! 
    628                   zn0 = ((((BET050*zt   & 
    629                      &   + BET140*zs+BET040)*zt   & 
    630                      &   + (BET230*zs+BET130)*zs+BET030)*zt   & 
    631                      &   + ((BET320*zs+BET220)*zs+BET120)*zs+BET020)*zt   & 
    632                      &   + (((BET410*zs+BET310)*zs+BET210)*zs+BET110)*zs+BET010)*zt   & 
    633                      &   + ((((BET500*zs+BET400)*zs+BET300)*zs+BET200)*zs+BET100)*zs+BET000 
    634                      ! 
    635                   zn  = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 
    636                   ! 
    637                   pab(ji,jj,jk,jp_sal) = zn / zs * r1_rau0 * ztm 
    638                   ! 
    639                END DO 
    640             END DO 
    641          END DO 
     565         DO_3D_11_11( 1, jpkm1 ) 
     566            ! 
     567            zh  = gdept(ji,jj,jk,Kmm) * r1_Z0                                ! depth 
     568            zt  = pts (ji,jj,jk,jp_tem) * r1_T0                           ! temperature 
     569            zs  = SQRT( ABS( pts(ji,jj,jk,jp_sal) + rdeltaS ) * r1_S0 )   ! square root salinity 
     570            ztm = tmask(ji,jj,jk)                                         ! tmask 
     571            ! 
     572            ! alpha 
     573            zn3 = ALP003 
     574            ! 
     575            zn2 = ALP012*zt + ALP102*zs+ALP002 
     576            ! 
     577            zn1 = ((ALP031*zt   & 
     578               &   + ALP121*zs+ALP021)*zt   & 
     579               &   + (ALP211*zs+ALP111)*zs+ALP011)*zt   & 
     580               &   + ((ALP301*zs+ALP201)*zs+ALP101)*zs+ALP001 
     581               ! 
     582            zn0 = ((((ALP050*zt   & 
     583               &   + ALP140*zs+ALP040)*zt   & 
     584               &   + (ALP230*zs+ALP130)*zs+ALP030)*zt   & 
     585               &   + ((ALP320*zs+ALP220)*zs+ALP120)*zs+ALP020)*zt   & 
     586               &   + (((ALP410*zs+ALP310)*zs+ALP210)*zs+ALP110)*zs+ALP010)*zt   & 
     587               &   + ((((ALP500*zs+ALP400)*zs+ALP300)*zs+ALP200)*zs+ALP100)*zs+ALP000 
     588               ! 
     589            zn  = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 
     590            ! 
     591            pab(ji,jj,jk,jp_tem) = zn * r1_rau0 * ztm 
     592            ! 
     593            ! beta 
     594            zn3 = BET003 
     595            ! 
     596            zn2 = BET012*zt + BET102*zs+BET002 
     597            ! 
     598            zn1 = ((BET031*zt   & 
     599               &   + BET121*zs+BET021)*zt   & 
     600               &   + (BET211*zs+BET111)*zs+BET011)*zt   & 
     601               &   + ((BET301*zs+BET201)*zs+BET101)*zs+BET001 
     602               ! 
     603            zn0 = ((((BET050*zt   & 
     604               &   + BET140*zs+BET040)*zt   & 
     605               &   + (BET230*zs+BET130)*zs+BET030)*zt   & 
     606               &   + ((BET320*zs+BET220)*zs+BET120)*zs+BET020)*zt   & 
     607               &   + (((BET410*zs+BET310)*zs+BET210)*zs+BET110)*zs+BET010)*zt   & 
     608               &   + ((((BET500*zs+BET400)*zs+BET300)*zs+BET200)*zs+BET100)*zs+BET000 
     609               ! 
     610            zn  = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 
     611            ! 
     612            pab(ji,jj,jk,jp_sal) = zn / zs * r1_rau0 * ztm 
     613            ! 
     614         END_3D 
    642615         ! 
    643616      CASE( np_seos )                  !==  simplified EOS  ==! 
    644617         ! 
    645          DO jk = 1, jpkm1 
    646             DO jj = 1, jpj 
    647                DO ji = 1, jpi 
    648                   zt  = pts (ji,jj,jk,jp_tem) - 10._wp   ! pot. temperature anomaly (t-T0) 
    649                   zs  = pts (ji,jj,jk,jp_sal) - 35._wp   ! abs. salinity anomaly (s-S0) 
    650                   zh  = gdept(ji,jj,jk,Kmm)                ! depth in meters at t-point 
    651                   ztm = tmask(ji,jj,jk)                  ! land/sea bottom mask = surf. mask 
    652                   ! 
    653                   zn  = rn_a0 * ( 1._wp + rn_lambda1*zt + rn_mu1*zh ) + rn_nu*zs 
    654                   pab(ji,jj,jk,jp_tem) = zn * r1_rau0 * ztm   ! alpha 
    655                   ! 
    656                   zn  = rn_b0 * ( 1._wp - rn_lambda2*zs - rn_mu2*zh ) - rn_nu*zt 
    657                   pab(ji,jj,jk,jp_sal) = zn * r1_rau0 * ztm   ! beta 
    658                   ! 
    659                END DO 
    660             END DO 
    661          END DO 
     618         DO_3D_11_11( 1, jpkm1 ) 
     619            zt  = pts (ji,jj,jk,jp_tem) - 10._wp   ! pot. temperature anomaly (t-T0) 
     620            zs  = pts (ji,jj,jk,jp_sal) - 35._wp   ! abs. salinity anomaly (s-S0) 
     621            zh  = gdept(ji,jj,jk,Kmm)                ! depth in meters at t-point 
     622            ztm = tmask(ji,jj,jk)                  ! land/sea bottom mask = surf. mask 
     623            ! 
     624            zn  = rn_a0 * ( 1._wp + rn_lambda1*zt + rn_mu1*zh ) + rn_nu*zs 
     625            pab(ji,jj,jk,jp_tem) = zn * r1_rau0 * ztm   ! alpha 
     626            ! 
     627            zn  = rn_b0 * ( 1._wp - rn_lambda2*zs - rn_mu2*zh ) - rn_nu*zt 
     628            pab(ji,jj,jk,jp_sal) = zn * r1_rau0 * ztm   ! beta 
     629            ! 
     630         END_3D 
    662631         ! 
    663632      CASE DEFAULT 
    … …  
    701670      CASE( np_teos10, np_eos80 )                !==  polynomial TEOS-10 / EOS-80 ==! 
    702671         ! 
    703          DO jj = 1, jpj 
    704             DO ji = 1, jpi   ! vector opt. 
    705                ! 
    706                zh  = pdep(ji,jj) * r1_Z0                                  ! depth 
    707                zt  = pts (ji,jj,jp_tem) * r1_T0                           ! temperature 
    708                zs  = SQRT( ABS( pts(ji,jj,jp_sal) + rdeltaS ) * r1_S0 )   ! square root salinity 
    709                ! 
    710                ! alpha 
    711                zn3 = ALP003 
    712                ! 
    713                zn2 = ALP012*zt + ALP102*zs+ALP002 
    714                ! 
    715                zn1 = ((ALP031*zt   & 
    716                   &   + ALP121*zs+ALP021)*zt   & 
    717                   &   + (ALP211*zs+ALP111)*zs+ALP011)*zt   & 
    718                   &   + ((ALP301*zs+ALP201)*zs+ALP101)*zs+ALP001 
    719                   ! 
    720                zn0 = ((((ALP050*zt   & 
    721                   &   + ALP140*zs+ALP040)*zt   & 
    722                   &   + (ALP230*zs+ALP130)*zs+ALP030)*zt   & 
    723                   &   + ((ALP320*zs+ALP220)*zs+ALP120)*zs+ALP020)*zt   & 
    724                   &   + (((ALP410*zs+ALP310)*zs+ALP210)*zs+ALP110)*zs+ALP010)*zt   & 
    725                   &   + ((((ALP500*zs+ALP400)*zs+ALP300)*zs+ALP200)*zs+ALP100)*zs+ALP000 
    726                   ! 
    727                zn  = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 
    728                ! 
    729                pab(ji,jj,jp_tem) = zn * r1_rau0 
    730                ! 
    731                ! beta 
    732                zn3 = BET003 
    733                ! 
    734                zn2 = BET012*zt + BET102*zs+BET002 
    735                ! 
    736                zn1 = ((BET031*zt   & 
    737                   &   + BET121*zs+BET021)*zt   & 
    738                   &   + (BET211*zs+BET111)*zs+BET011)*zt   & 
    739                   &   + ((BET301*zs+BET201)*zs+BET101)*zs+BET001 
    740                   ! 
    741                zn0 = ((((BET050*zt   & 
    742                   &   + BET140*zs+BET040)*zt   & 
    743                   &   + (BET230*zs+BET130)*zs+BET030)*zt   & 
    744                   &   + ((BET320*zs+BET220)*zs+BET120)*zs+BET020)*zt   & 
    745                   &   + (((BET410*zs+BET310)*zs+BET210)*zs+BET110)*zs+BET010)*zt   & 
    746                   &   + ((((BET500*zs+BET400)*zs+BET300)*zs+BET200)*zs+BET100)*zs+BET000 
    747                   ! 
    748                zn  = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 
    749                ! 
    750                pab(ji,jj,jp_sal) = zn / zs * r1_rau0 
    751                ! 
    752                ! 
    753             END DO 
    754          END DO 
     672         DO_2D_11_11 
     673            ! 
     674            zh  = pdep(ji,jj) * r1_Z0                                  ! depth 
     675            zt  = pts (ji,jj,jp_tem) * r1_T0                           ! temperature 
     676            zs  = SQRT( ABS( pts(ji,jj,jp_sal) + rdeltaS ) * r1_S0 )   ! square root salinity 
     677            ! 
     678            ! alpha 
     679            zn3 = ALP003 
     680            ! 
     681            zn2 = ALP012*zt + ALP102*zs+ALP002 
     682            ! 
     683            zn1 = ((ALP031*zt   & 
     684               &   + ALP121*zs+ALP021)*zt   & 
     685               &   + (ALP211*zs+ALP111)*zs+ALP011)*zt   & 
     686               &   + ((ALP301*zs+ALP201)*zs+ALP101)*zs+ALP001 
     687               ! 
     688            zn0 = ((((ALP050*zt   & 
     689               &   + ALP140*zs+ALP040)*zt   & 
     690               &   + (ALP230*zs+ALP130)*zs+ALP030)*zt   & 
     691               &   + ((ALP320*zs+ALP220)*zs+ALP120)*zs+ALP020)*zt   & 
     692               &   + (((ALP410*zs+ALP310)*zs+ALP210)*zs+ALP110)*zs+ALP010)*zt   & 
     693               &   + ((((ALP500*zs+ALP400)*zs+ALP300)*zs+ALP200)*zs+ALP100)*zs+ALP000 
     694               ! 
     695            zn  = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 
     696            ! 
     697            pab(ji,jj,jp_tem) = zn * r1_rau0 
     698            ! 
     699            ! beta 
     700            zn3 = BET003 
     701            ! 
     702            zn2 = BET012*zt + BET102*zs+BET002 
     703            ! 
     704            zn1 = ((BET031*zt   & 
     705               &   + BET121*zs+BET021)*zt   & 
     706               &   + (BET211*zs+BET111)*zs+BET011)*zt   & 
     707               &   + ((BET301*zs+BET201)*zs+BET101)*zs+BET001 
     708               ! 
     709            zn0 = ((((BET050*zt   & 
     710               &   + BET140*zs+BET040)*zt   & 
     711               &   + (BET230*zs+BET130)*zs+BET030)*zt   & 
     712               &   + ((BET320*zs+BET220)*zs+BET120)*zs+BET020)*zt   & 
     713               &   + (((BET410*zs+BET310)*zs+BET210)*zs+BET110)*zs+BET010)*zt   & 
     714               &   + ((((BET500*zs+BET400)*zs+BET300)*zs+BET200)*zs+BET100)*zs+BET000 
     715               ! 
     716            zn  = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 
     717            ! 
     718            pab(ji,jj,jp_sal) = zn / zs * r1_rau0 
     719            ! 
     720            ! 
     721         END_2D 
    755722         ! 
    756723      CASE( np_seos )                  !==  simplified EOS  ==! 
    757724         ! 
    758          DO jj = 1, jpj 
    759             DO ji = 1, jpi   ! vector opt. 
    760                ! 
    761                zt    = pts  (ji,jj,jp_tem) - 10._wp   ! pot. temperature anomaly (t-T0) 
    762                zs    = pts  (ji,jj,jp_sal) - 35._wp   ! abs. salinity anomaly (s-S0) 
    763                zh    = pdep (ji,jj)                   ! depth at the partial step level 
    764                ! 
    765                zn  = rn_a0 * ( 1._wp + rn_lambda1*zt + rn_mu1*zh ) + rn_nu*zs 
    766                pab(ji,jj,jp_tem) = zn * r1_rau0   ! alpha 
    767                ! 
    768                zn  = rn_b0 * ( 1._wp - rn_lambda2*zs - rn_mu2*zh ) - rn_nu*zt 
    769                pab(ji,jj,jp_sal) = zn * r1_rau0   ! beta 
    770                ! 
    771             END DO 
    772          END DO 
     725         DO_2D_11_11 
     726            ! 
     727            zt    = pts  (ji,jj,jp_tem) - 10._wp   ! pot. temperature anomaly (t-T0) 
     728            zs    = pts  (ji,jj,jp_sal) - 35._wp   ! abs. salinity anomaly (s-S0) 
     729            zh    = pdep (ji,jj)                   ! depth at the partial step level 
     730            ! 
     731            zn  = rn_a0 * ( 1._wp + rn_lambda1*zt + rn_mu1*zh ) + rn_nu*zs 
     732            pab(ji,jj,jp_tem) = zn * r1_rau0   ! alpha 
     733            ! 
     734            zn  = rn_b0 * ( 1._wp - rn_lambda2*zs - rn_mu2*zh ) - rn_nu*zt 
     735            pab(ji,jj,jp_sal) = zn * r1_rau0   ! beta 
     736            ! 
     737         END_2D 
    773738         ! 
    774739      CASE DEFAULT 
    … …  
    908873      IF( ln_timing )   CALL timing_start('bn2') 
    909874      ! 
    910       DO jk = 2, jpkm1           ! interior points only (2=< jk =< jpkm1 ) 
    911          DO jj = 1, jpj          ! surface and bottom value set to zero one for all in istate.F90 
    912             DO ji = 1, jpi 
    913                zrw =   ( gdepw(ji,jj,jk  ,Kmm) - gdept(ji,jj,jk,Kmm) )   & 
    914                   &  / ( gdept(ji,jj,jk-1,Kmm) - gdept(ji,jj,jk,Kmm) )  
    915                   ! 
    916                zaw = pab(ji,jj,jk,jp_tem) * (1. - zrw) + pab(ji,jj,jk-1,jp_tem) * zrw  
    917                zbw = pab(ji,jj,jk,jp_sal) * (1. - zrw) + pab(ji,jj,jk-1,jp_sal) * zrw 
    918                ! 
    919                pn2(ji,jj,jk) = grav * (  zaw * ( pts(ji,jj,jk-1,jp_tem) - pts(ji,jj,jk,jp_tem) )     & 
    920                   &                    - zbw * ( pts(ji,jj,jk-1,jp_sal) - pts(ji,jj,jk,jp_sal) )  )  & 
    921                   &            / e3w(ji,jj,jk,Kmm) * wmask(ji,jj,jk) 
    922             END DO 
    923          END DO 
    924       END DO 
     875      DO_3D_11_11( 2, jpkm1 ) 
     876         zrw =   ( gdepw(ji,jj,jk  ,Kmm) - gdept(ji,jj,jk,Kmm) )   & 
     877            &  / ( gdept(ji,jj,jk-1,Kmm) - gdept(ji,jj,jk,Kmm) )  
     878            ! 
     879         zaw = pab(ji,jj,jk,jp_tem) * (1. - zrw) + pab(ji,jj,jk-1,jp_tem) * zrw  
     880         zbw = pab(ji,jj,jk,jp_sal) * (1. - zrw) + pab(ji,jj,jk-1,jp_sal) * zrw 
     881         ! 
     882         pn2(ji,jj,jk) = grav * (  zaw * ( pts(ji,jj,jk-1,jp_tem) - pts(ji,jj,jk,jp_tem) )     & 
     883            &                    - zbw * ( pts(ji,jj,jk-1,jp_sal) - pts(ji,jj,jk,jp_sal) )  )  & 
     884            &            / e3w(ji,jj,jk,Kmm) * wmask(ji,jj,jk) 
     885      END_3D 
    925886      ! 
    926887      IF(sn_cfctl%l_prtctl)   CALL prt_ctl( tab3d_1=pn2, clinfo1=' bn2  : ', kdim=jpk ) 
    … …  
    960921      z1_T0   = 1._wp/40._wp 
    961922      ! 
    962       DO jj = 1, jpj 
    963          DO ji = 1, jpi 
    964             ! 
    965             zt  = ctmp   (ji,jj) * z1_T0 
    966             zs  = SQRT( ABS( psal(ji,jj) + zdeltaS ) * r1_S0 ) 
    967             ztm = tmask(ji,jj,1) 
    968             ! 
    969             zn = ((((-2.1385727895e-01_wp*zt   & 
    970                &   - 2.7674419971e-01_wp*zs+1.0728094330_wp)*zt   & 
    971                &   + (2.6366564313_wp*zs+3.3546960647_wp)*zs-7.8012209473_wp)*zt   & 
    972                &   + ((1.8835586562_wp*zs+7.3949191679_wp)*zs-3.3937395875_wp)*zs-5.6414948432_wp)*zt   & 
    973                &   + (((3.5737370589_wp*zs-1.5512427389e+01_wp)*zs+2.4625741105e+01_wp)*zs   & 
    974                &      +1.9912291000e+01_wp)*zs-3.2191146312e+01_wp)*zt   & 
    975                &   + ((((5.7153204649e-01_wp*zs-3.0943149543_wp)*zs+9.3052495181_wp)*zs   & 
    976                &      -9.4528934807_wp)*zs+3.1066408996_wp)*zs-4.3504021262e-01_wp 
    977                ! 
    978             zd = (2.0035003456_wp*zt   & 
    979                &   -3.4570358592e-01_wp*zs+5.6471810638_wp)*zt   & 
    980                &   + (1.5393993508_wp*zs-6.9394762624_wp)*zs+1.2750522650e+01_wp 
    981                ! 
    982             ptmp(ji,jj) = ( zt / z1_T0 + zn / zd ) * ztm 
    983                ! 
    984          END DO 
    985       END DO 
     923      DO_2D_11_11 
     924         ! 
     925         zt  = ctmp   (ji,jj) * z1_T0 
     926         zs  = SQRT( ABS( psal(ji,jj) + zdeltaS ) * r1_S0 ) 
     927         ztm = tmask(ji,jj,1) 
     928         ! 
     929         zn = ((((-2.1385727895e-01_wp*zt   & 
     930            &   - 2.7674419971e-01_wp*zs+1.0728094330_wp)*zt   & 
     931            &   + (2.6366564313_wp*zs+3.3546960647_wp)*zs-7.8012209473_wp)*zt   & 
     932            &   + ((1.8835586562_wp*zs+7.3949191679_wp)*zs-3.3937395875_wp)*zs-5.6414948432_wp)*zt   & 
     933            &   + (((3.5737370589_wp*zs-1.5512427389e+01_wp)*zs+2.4625741105e+01_wp)*zs   & 
     934            &      +1.9912291000e+01_wp)*zs-3.2191146312e+01_wp)*zt   & 
     935            &   + ((((5.7153204649e-01_wp*zs-3.0943149543_wp)*zs+9.3052495181_wp)*zs   & 
     936            &      -9.4528934807_wp)*zs+3.1066408996_wp)*zs-4.3504021262e-01_wp 
     937            ! 
     938         zd = (2.0035003456_wp*zt   & 
     939            &   -3.4570358592e-01_wp*zs+5.6471810638_wp)*zt   & 
     940            &   + (1.5393993508_wp*zs-6.9394762624_wp)*zs+1.2750522650e+01_wp 
     941            ! 
     942         ptmp(ji,jj) = ( zt / z1_T0 + zn / zd ) * ztm 
     943            ! 
     944      END_2D 
    986945      ! 
    987946      IF( ln_timing )   CALL timing_stop('eos_pt_from_ct') 
    … …  
    1015974         ! 
    1016975         z1_S0 = 1._wp / 35.16504_wp 
    1017          DO jj = 1, jpj 
    1018             DO ji = 1, jpi 
    1019                zs= SQRT( ABS( psal(ji,jj) ) * z1_S0 )           ! square root salinity 
    1020                ptf(ji,jj) = ((((1.46873e-03_wp*zs-9.64972e-03_wp)*zs+2.28348e-02_wp)*zs & 
    1021                   &          - 3.12775e-02_wp)*zs+2.07679e-02_wp)*zs-5.87701e-02_wp 
    1022             END DO 
    1023          END DO 
     976         DO_2D_11_11 
     977            zs= SQRT( ABS( psal(ji,jj) ) * z1_S0 )           ! square root salinity 
     978            ptf(ji,jj) = ((((1.46873e-03_wp*zs-9.64972e-03_wp)*zs+2.28348e-02_wp)*zs & 
     979               &          - 3.12775e-02_wp)*zs+2.07679e-02_wp)*zs-5.87701e-02_wp 
     980         END_2D 
    1024981         ptf(:,:) = ptf(:,:) * psal(:,:) 
    1025982         ! 
    … …  
    11241081      CASE( np_teos10, np_eos80 )                !==  polynomial TEOS-10 / EOS-80 ==! 
    11251082         ! 
    1126          DO jk = 1, jpkm1 
    1127             DO jj = 1, jpj 
    1128                DO ji = 1, jpi 
    1129                   ! 
    1130                   zh  = gdept(ji,jj,jk,Kmm) * r1_Z0                                ! depth 
    1131                   zt  = pts (ji,jj,jk,jp_tem) * r1_T0                           ! temperature 
    1132                   zs  = SQRT( ABS( pts(ji,jj,jk,jp_sal) + rdeltaS ) * r1_S0 )   ! square root salinity 
    1133                   ztm = tmask(ji,jj,jk)                                         ! tmask 
    1134                   ! 
    1135                   ! potential energy non-linear anomaly 
    1136                   zn2 = (PEN012)*zt   & 
    1137                      &   + PEN102*zs+PEN002 
    1138                      ! 
    1139                   zn1 = ((PEN021)*zt   & 
    1140                      &   + PEN111*zs+PEN011)*zt   & 
    1141                      &   + (PEN201*zs+PEN101)*zs+PEN001 
    1142                      ! 
    1143                   zn0 = ((((PEN040)*zt   & 
    1144                      &   + PEN130*zs+PEN030)*zt   & 
    1145                      &   + (PEN220*zs+PEN120)*zs+PEN020)*zt   & 
    1146                      &   + ((PEN310*zs+PEN210)*zs+PEN110)*zs+PEN010)*zt   & 
    1147                      &   + (((PEN400*zs+PEN300)*zs+PEN200)*zs+PEN100)*zs+PEN000 
    1148                      ! 
    1149                   zn  = ( zn2 * zh + zn1 ) * zh + zn0 
    1150                   ! 
    1151                   ppen(ji,jj,jk)  = zn * zh * r1_rau0 * ztm 
    1152                   ! 
    1153                   ! alphaPE non-linear anomaly 
    1154                   zn2 = APE002 
    1155                   ! 
    1156                   zn1 = (APE011)*zt   & 
    1157                      &   + APE101*zs+APE001 
    1158                      ! 
    1159                   zn0 = (((APE030)*zt   & 
    1160                      &   + APE120*zs+APE020)*zt   & 
    1161                      &   + (APE210*zs+APE110)*zs+APE010)*zt   & 
    1162                      &   + ((APE300*zs+APE200)*zs+APE100)*zs+APE000 
    1163                      ! 
    1164                   zn  = ( zn2 * zh + zn1 ) * zh + zn0 
    1165                   !                               
    1166                   pab_pe(ji,jj,jk,jp_tem) = zn * zh * r1_rau0 * ztm 
    1167                   ! 
    1168                   ! betaPE non-linear anomaly 
    1169                   zn2 = BPE002 
    1170                   ! 
    1171                   zn1 = (BPE011)*zt   & 
    1172                      &   + BPE101*zs+BPE001 
    1173                      ! 
    1174                   zn0 = (((BPE030)*zt   & 
    1175                      &   + BPE120*zs+BPE020)*zt   & 
    1176                      &   + (BPE210*zs+BPE110)*zs+BPE010)*zt   & 
    1177                      &   + ((BPE300*zs+BPE200)*zs+BPE100)*zs+BPE000 
    1178                      ! 
    1179                   zn  = ( zn2 * zh + zn1 ) * zh + zn0 
    1180                   !                               
    1181                   pab_pe(ji,jj,jk,jp_sal) = zn / zs * zh * r1_rau0 * ztm 
    1182                   ! 
    1183                END DO 
    1184             END DO 
    1185          END DO 
     1083         DO_3D_11_11( 1, jpkm1 ) 
     1084            ! 
     1085            zh  = gdept(ji,jj,jk,Kmm) * r1_Z0                                ! depth 
     1086            zt  = pts (ji,jj,jk,jp_tem) * r1_T0                           ! temperature 
     1087            zs  = SQRT( ABS( pts(ji,jj,jk,jp_sal) + rdeltaS ) * r1_S0 )   ! square root salinity 
     1088            ztm = tmask(ji,jj,jk)                                         ! tmask 
     1089            ! 
     1090            ! potential energy non-linear anomaly 
     1091            zn2 = (PEN012)*zt   & 
     1092               &   + PEN102*zs+PEN002 
     1093               ! 
     1094            zn1 = ((PEN021)*zt   & 
     1095               &   + PEN111*zs+PEN011)*zt   & 
     1096               &   + (PEN201*zs+PEN101)*zs+PEN001 
     1097               ! 
     1098            zn0 = ((((PEN040)*zt   & 
     1099               &   + PEN130*zs+PEN030)*zt   & 
     1100               &   + (PEN220*zs+PEN120)*zs+PEN020)*zt   & 
     1101               &   + ((PEN310*zs+PEN210)*zs+PEN110)*zs+PEN010)*zt   & 
     1102               &   + (((PEN400*zs+PEN300)*zs+PEN200)*zs+PEN100)*zs+PEN000 
     1103               ! 
     1104            zn  = ( zn2 * zh + zn1 ) * zh + zn0 
     1105            ! 
     1106            ppen(ji,jj,jk)  = zn * zh * r1_rau0 * ztm 
     1107            ! 
     1108            ! alphaPE non-linear anomaly 
     1109            zn2 = APE002 
     1110            ! 
     1111            zn1 = (APE011)*zt   & 
     1112               &   + APE101*zs+APE001 
     1113               ! 
     1114            zn0 = (((APE030)*zt   & 
     1115               &   + APE120*zs+APE020)*zt   & 
     1116               &   + (APE210*zs+APE110)*zs+APE010)*zt   & 
     1117               &   + ((APE300*zs+APE200)*zs+APE100)*zs+APE000 
     1118               ! 
     1119            zn  = ( zn2 * zh + zn1 ) * zh + zn0 
     1120            !                               
     1121            pab_pe(ji,jj,jk,jp_tem) = zn * zh * r1_rau0 * ztm 
     1122            ! 
     1123            ! betaPE non-linear anomaly 
     1124            zn2 = BPE002 
     1125            ! 
     1126            zn1 = (BPE011)*zt   & 
     1127               &   + BPE101*zs+BPE001 
     1128               ! 
     1129            zn0 = (((BPE030)*zt   & 
     1130               &   + BPE120*zs+BPE020)*zt   & 
     1131               &   + (BPE210*zs+BPE110)*zs+BPE010)*zt   & 
     1132               &   + ((BPE300*zs+BPE200)*zs+BPE100)*zs+BPE000 
     1133               ! 
     1134            zn  = ( zn2 * zh + zn1 ) * zh + zn0 
     1135            !                               
     1136            pab_pe(ji,jj,jk,jp_sal) = zn / zs * zh * r1_rau0 * ztm 
     1137            ! 
     1138         END_3D 
    11861139         ! 
    11871140      CASE( np_seos )                !==  Vallis (2006) simplified EOS  ==! 
    11881141         ! 
    1189          DO jk = 1, jpkm1 
    1190             DO jj = 1, jpj 
    1191                DO ji = 1, jpi 
    1192                   zt  = pts(ji,jj,jk,jp_tem) - 10._wp  ! temperature anomaly (t-T0) 
    1193                   zs = pts (ji,jj,jk,jp_sal) - 35._wp  ! abs. salinity anomaly (s-S0) 
    1194                   zh  = gdept(ji,jj,jk,Kmm)              ! depth in meters  at t-point 
    1195                   ztm = tmask(ji,jj,jk)                ! tmask 
    1196                   zn  = 0.5_wp * zh * r1_rau0 * ztm 
    1197                   !                                    ! Potential Energy 
    1198                   ppen(ji,jj,jk) = ( rn_a0 * rn_mu1 * zt + rn_b0 * rn_mu2 * zs ) * zn 
    1199                   !                                    ! alphaPE 
    1200                   pab_pe(ji,jj,jk,jp_tem) = - rn_a0 * rn_mu1 * zn 
    1201                   pab_pe(ji,jj,jk,jp_sal) =   rn_b0 * rn_mu2 * zn 
    1202                   ! 
    1203                END DO 
    1204             END DO 
    1205          END DO 
     1142         DO_3D_11_11( 1, jpkm1 ) 
     1143            zt  = pts(ji,jj,jk,jp_tem) - 10._wp  ! temperature anomaly (t-T0) 
     1144            zs = pts (ji,jj,jk,jp_sal) - 35._wp  ! abs. salinity anomaly (s-S0) 
     1145            zh  = gdept(ji,jj,jk,Kmm)              ! depth in meters  at t-point 
     1146            ztm = tmask(ji,jj,jk)                ! tmask 
     1147            zn  = 0.5_wp * zh * r1_rau0 * ztm 
     1148            !                                    ! Potential Energy 
     1149            ppen(ji,jj,jk) = ( rn_a0 * rn_mu1 * zt + rn_b0 * rn_mu2 * zs ) * zn 
     1150            !                                    ! alphaPE 
     1151            pab_pe(ji,jj,jk,jp_tem) = - rn_a0 * rn_mu1 * zn 
     1152            pab_pe(ji,jj,jk,jp_sal) =   rn_b0 * rn_mu2 * zn 
     1153            ! 
     1154         END_3D 
    12061155         ! 
    12071156      CASE DEFAULT 

  • NEMO/branches/2019/dev_r11943_MERGE_2019/src/OCE/TRA/traadv_cen.F90

    r12193 r12340  
    3737   !! * Substitutions 
    3838#  include "vectopt_loop_substitute.h90" 
     39#  include "do_loop_substitute.h90" 
    3940   !!---------------------------------------------------------------------- 
    4041   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    103104         ! 
    104105         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 * pU(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj  ,jk,jn,Kmm) ) 
    109                      zwy(ji,jj,jk) = 0.5_wp * pV(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji  ,jj+1,jk,jn,Kmm) ) 
    110                   END DO 
    111                END DO 
    112             END DO 
     106            DO_3D_10_10( 1, jpkm1 ) 
     107               zwx(ji,jj,jk) = 0.5_wp * pU(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj  ,jk,jn,Kmm) ) 
     108               zwy(ji,jj,jk) = 0.5_wp * pV(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji  ,jj+1,jk,jn,Kmm) ) 
     109            END_3D 
    113110            ! 
    114111         CASE(  4  )                         !* 4th order centered 
    115112            ztu(:,:,jpk) = 0._wp                   ! Bottom value : flux set to zero 
    116113            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) = ( pt(ji+1,jj  ,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * umask(ji,jj,jk) 
    121                      ztv(ji,jj,jk) = ( pt(ji  ,jj+1,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * vmask(ji,jj,jk) 
    122                   END DO 
    123                END DO 
    124             END DO 
     114            DO_3D_00_00( 1, jpkm1 ) 
     115               ztu(ji,jj,jk) = ( pt(ji+1,jj  ,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * umask(ji,jj,jk) 
     116               ztv(ji,jj,jk) = ( pt(ji  ,jj+1,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * vmask(ji,jj,jk) 
     117            END_3D 
    125118            CALL lbc_lnk_multi( 'traadv_cen', ztu, 'U', -1. , ztv, 'V', -1. )   ! Lateral boundary cond. 
    126119            ! 
    127             DO jk = 1, jpkm1                       ! Horizontal advective fluxes 
    128                DO jj = 2, jpjm1 
    129                   DO ji = 1, fs_jpim1   ! vector opt. 
    130                      zC2t_u = pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj  ,jk,jn,Kmm)   ! C2 interpolation of T at u- & v-points (x2) 
    131                      zC2t_v = pt(ji,jj,jk,jn,Kmm) + pt(ji  ,jj+1,jk,jn,Kmm) 
    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 * pU(ji,jj,jk) * zC4t_u 
    137                      zwy(ji,jj,jk) =  0.5_wp * pV(ji,jj,jk) * zC4t_v 
    138                   END DO 
    139                END DO 
    140             END DO          
     120            DO_3D_00_10( 1, jpkm1 ) 
     121               zC2t_u = pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj  ,jk,jn,Kmm)   ! C2 interpolation of T at u- & v-points (x2) 
     122               zC2t_v = pt(ji,jj,jk,jn,Kmm) + pt(ji  ,jj+1,jk,jn,Kmm) 
     123               !                                                  ! C4 interpolation of T at u- & v-points (x2) 
     124               zC4t_u =  zC2t_u + r1_6 * ( ztu(ji-1,jj,jk) - ztu(ji+1,jj,jk) ) 
     125               zC4t_v =  zC2t_v + r1_6 * ( ztv(ji,jj-1,jk) - ztv(ji,jj+1,jk) ) 
     126               !                                                  ! C4 fluxes 
     127               zwx(ji,jj,jk) =  0.5_wp * pU(ji,jj,jk) * zC4t_u 
     128               zwy(ji,jj,jk) =  0.5_wp * pV(ji,jj,jk) * zC4t_v 
     129            END_3D 
    141130            ! 
    142131         CASE DEFAULT 
    … …  
    147136         ! 
    148137         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 * pW(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji,jj,jk-1,jn,Kmm) ) * wmask(ji,jj,jk) 
    153                   END DO 
    154                END DO 
    155             END DO 
     138            DO_3D_00_00( 2, jpk ) 
     139               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) 
     140            END_3D 
    156141            ! 
    157142         CASE(  4  )                         !* 4th order compact 
    158143            CALL interp_4th_cpt( pt(:,:,:,jn,Kmm) , 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) = pW(ji,jj,jk) * ztw(ji,jj,jk) * wmask(ji,jj,jk) 
    163                   END DO 
    164                END DO 
    165             END DO 
     144            DO_3D_00_00( 2, jpkm1 ) 
     145               zwz(ji,jj,jk) = pW(ji,jj,jk) * ztw(ji,jj,jk) * wmask(ji,jj,jk) 
     146            END_3D 
    166147            ! 
    167148         END SELECT 
    … …  
    169150         IF( ln_linssh ) THEN                !* top value   (linear free surf. only as zwz is multiplied by wmask) 
    170151            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) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kmm)  
    174                   END DO 
    175                END DO    
     152               DO_2D_11_11 
     153                  zwz(ji,jj, mikt(ji,jj) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kmm)  
     154               END_2D 
    176155            ELSE                                   ! no ice-shelf cavities (only ocean surface) 
    177156               zwz(:,:,1) = pW(:,:,1) * pt(:,:,1,jn,Kmm) 
    … …  
    179158         ENDIF 
    180159         !                
    181          DO jk = 1, jpkm1              !--  Divergence of advective fluxes  --! 
    182             DO jj = 2, jpjm1 
    183                DO ji = fs_2, fs_jpim1   ! vector opt. 
    184                   pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs)    & 
    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(ji,jj,jk,Kmm) 
    188                END DO 
    189             END DO 
    190          END DO 
     160         DO_3D_00_00( 1, jpkm1 ) 
     161            pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs)    & 
     162               &             - (  zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk  )    & 
     163               &                + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk  )    & 
     164               &                + zwz(ji,jj,jk) - zwz(ji  ,jj  ,jk+1)  ) * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
     165         END_3D 
    191166         !                             ! trend diagnostics 
    192167         IF( l_trd ) THEN 

  • NEMO/branches/2019/dev_r11943_MERGE_2019/src/OCE/TRA/traadv_fct.F90

    r12193 r12340  
    4646   !! * Substitutions 
    4747#  include "vectopt_loop_substitute.h90" 
     48#  include "do_loop_substitute.h90" 
    4849   !!---------------------------------------------------------------------- 
    4950   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    128129      IF( ll_zAimp ) THEN 
    129130         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(ji,jj,jk,Krhs) 
    134                   zwinf(ji,jj,jk) =  p2dt * MIN( wi(ji,jj,jk  ) , 0._wp ) / e3t(ji,jj,jk,Krhs) 
    135                   zwsup(ji,jj,jk) = -p2dt * MAX( wi(ji,jj,jk+1) , 0._wp ) / e3t(ji,jj,jk,Krhs) 
    136                END DO 
    137             END DO 
    138          END DO 
     131         DO_3D_00_00( 1, jpkm1 ) 
     132            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) 
     133            zwinf(ji,jj,jk) =  p2dt * MIN( wi(ji,jj,jk  ) , 0._wp ) / e3t(ji,jj,jk,Krhs) 
     134            zwsup(ji,jj,jk) = -p2dt * MAX( wi(ji,jj,jk+1) , 0._wp ) / e3t(ji,jj,jk,Krhs) 
     135         END_3D 
    139136      END IF 
    140137      ! 
    … …  
    143140         !        !==  upstream advection with initial mass fluxes & intermediate update  ==! 
    144141         !                    !* 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 = pU(ji,jj,jk) + ABS( pU(ji,jj,jk) ) 
    150                   zfm_ui = pU(ji,jj,jk) - ABS( pU(ji,jj,jk) ) 
    151                   zfp_vj = pV(ji,jj,jk) + ABS( pV(ji,jj,jk) ) 
    152                   zfm_vj = pV(ji,jj,jk) - ABS( pV(ji,jj,jk) ) 
    153                   zwx(ji,jj,jk) = 0.5 * ( zfp_ui * pt(ji,jj,jk,jn,Kbb) + zfm_ui * pt(ji+1,jj  ,jk,jn,Kbb) ) 
    154                   zwy(ji,jj,jk) = 0.5 * ( zfp_vj * pt(ji,jj,jk,jn,Kbb) + zfm_vj * pt(ji  ,jj+1,jk,jn,Kbb) ) 
    155                END DO 
    156             END DO 
    157          END DO 
     142         DO_3D_10_10( 1, jpkm1 ) 
     143            ! upstream scheme 
     144            zfp_ui = pU(ji,jj,jk) + ABS( pU(ji,jj,jk) ) 
     145            zfm_ui = pU(ji,jj,jk) - ABS( pU(ji,jj,jk) ) 
     146            zfp_vj = pV(ji,jj,jk) + ABS( pV(ji,jj,jk) ) 
     147            zfm_vj = pV(ji,jj,jk) - ABS( pV(ji,jj,jk) ) 
     148            zwx(ji,jj,jk) = 0.5 * ( zfp_ui * pt(ji,jj,jk,jn,Kbb) + zfm_ui * pt(ji+1,jj  ,jk,jn,Kbb) ) 
     149            zwy(ji,jj,jk) = 0.5 * ( zfp_vj * pt(ji,jj,jk,jn,Kbb) + zfm_vj * pt(ji  ,jj+1,jk,jn,Kbb) ) 
     150         END_3D 
    158151         !                    !* 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 = pW(ji,jj,jk) + ABS( pW(ji,jj,jk) ) 
    163                   zfm_wk = pW(ji,jj,jk) - ABS( pW(ji,jj,jk) ) 
    164                   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) 
    165                END DO 
    166             END DO 
    167          END DO 
     152         DO_3D_11_11( 2, jpkm1 ) 
     153            zfp_wk = pW(ji,jj,jk) + ABS( pW(ji,jj,jk) ) 
     154            zfm_wk = pW(ji,jj,jk) - ABS( pW(ji,jj,jk) ) 
     155            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) 
     156         END_3D 
    168157         IF( ln_linssh ) THEN    ! top ocean value (only in linear free surface as zwz has been w-masked) 
    169158            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) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kbb)   ! linear free surface  
    173                   END DO 
    174                END DO    
     159               DO_2D_11_11 
     160                  zwz(ji,jj, mikt(ji,jj) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kbb)   ! linear free surface  
     161               END_2D 
    175162            ELSE                             ! no cavities: only at the ocean surface 
    176163               zwz(:,:,1) = pW(:,:,1) * pt(:,:,1,jn,Kbb) 
    … …  
    178165         ENDIF 
    179166         !                
    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                   pt(ji,jj,jk,jn,Krhs) =                     pt(ji,jj,jk,jn,Krhs) +        ztra   / e3t(ji,jj,jk,Kmm) * tmask(ji,jj,jk) 
    189                   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) 
    190                END DO 
    191             END DO 
    192          END DO 
     167         DO_3D_00_00( 1, jpkm1 ) 
     168            !                             ! total intermediate advective trends 
     169            ztra = - (  zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk  )   & 
     170               &      + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk  )   & 
     171               &      + zwz(ji,jj,jk) - zwz(ji  ,jj  ,jk+1) ) * r1_e1e2t(ji,jj) 
     172            !                             ! update and guess with monotonic sheme 
     173            pt(ji,jj,jk,jn,Krhs) =                     pt(ji,jj,jk,jn,Krhs) +        ztra   / e3t(ji,jj,jk,Kmm) * tmask(ji,jj,jk) 
     174            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) 
     175         END_3D 
    193176          
    194177         IF ( ll_zAimp ) THEN 
    … …  
    196179            ! 
    197180            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                      pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( ztw(ji,jj,jk) - ztw(ji  ,jj  ,jk+1) ) & 
    212                         &                                        * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
    213                   END DO 
    214                END DO 
    215             END DO 
     181            DO_3D_00_00( 2, jpkm1 ) 
     182               zfp_wk = wi(ji,jj,jk) + ABS( wi(ji,jj,jk) ) 
     183               zfm_wk = wi(ji,jj,jk) - ABS( wi(ji,jj,jk) ) 
     184               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) 
     185               zwz(ji,jj,jk) = zwz(ji,jj,jk) + ztw(ji,jj,jk) ! update vertical fluxes 
     186            END_3D 
     187            DO_3D_00_00( 1, jpkm1 ) 
     188               pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( ztw(ji,jj,jk) - ztw(ji  ,jj  ,jk+1) ) & 
     189                  &                                        * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
     190            END_3D 
    216191            ! 
    217192         END IF 
    … …  
    228203         ! 
    229204         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 * pU(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj,jk,jn,Kmm) ) - zwx(ji,jj,jk) 
    234                      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) 
    235                   END DO 
    236                END DO 
    237             END DO 
     205            DO_3D_10_10( 1, jpkm1 ) 
     206               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) 
     207               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) 
     208            END_3D 
    238209            ! 
    239210         CASE(  4  )                   !- 4th order centered 
    … …  
    241212            zltv(:,:,jpk) = 0._wp 
    242213            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) = ( pt(ji+1,jj  ,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * umask(ji,jj,jk) 
    246                      ztv(ji,jj,jk) = ( pt(ji  ,jj+1,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * 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 
     214               DO_2D_10_10 
     215                  ztu(ji,jj,jk) = ( pt(ji+1,jj  ,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * umask(ji,jj,jk) 
     216                  ztv(ji,jj,jk) = ( pt(ji  ,jj+1,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * vmask(ji,jj,jk) 
     217               END_2D 
     218               DO_2D_00_00 
     219                  zltu(ji,jj,jk) = (  ztu(ji,jj,jk) + ztu(ji-1,jj,jk)  ) * r1_6 
     220                  zltv(ji,jj,jk) = (  ztv(ji,jj,jk) + ztv(ji,jj-1,jk)  ) * r1_6 
     221               END_2D 
    255222            END DO 
    256223            CALL lbc_lnk_multi( 'traadv_fct', zltu, 'T', 1. , zltv, 'T', 1. )   ! Lateral boundary cond. (unchanged sgn) 
    257224            ! 
    258             DO jk = 1, jpkm1                 ! Horizontal advective fluxes 
    259                DO jj = 1, jpjm1 
    260                   DO ji = 1, fs_jpim1   ! vector opt. 
    261                      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 
    262                      zC2t_v = pt(ji,jj,jk,jn,Kmm) + pt(ji  ,jj+1,jk,jn,Kmm) 
    263                      !                                                  ! C4 minus upstream advective fluxes  
    264                      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) 
    265                      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) 
    266                   END DO 
    267                END DO 
    268             END DO          
     225            DO_3D_10_10( 1, jpkm1 ) 
     226               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 
     227               zC2t_v = pt(ji,jj,jk,jn,Kmm) + pt(ji  ,jj+1,jk,jn,Kmm) 
     228               !                                                  ! C4 minus upstream advective fluxes  
     229               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) 
     230               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) 
     231            END_3D 
    269232            ! 
    270233         CASE(  41 )                   !- 4th order centered       ==>>   !!gm coding attempt   need to be tested 
    271234            ztu(:,:,jpk) = 0._wp             ! Bottom value : flux set to zero 
    272235            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) = ( pt(ji+1,jj  ,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * umask(ji,jj,jk) 
    277                      ztv(ji,jj,jk) = ( pt(ji  ,jj+1,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * vmask(ji,jj,jk) 
    278                   END DO 
    279                END DO 
    280             END DO 
     236            DO_3D_10_10( 1, jpkm1 ) 
     237               ztu(ji,jj,jk) = ( pt(ji+1,jj  ,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * umask(ji,jj,jk) 
     238               ztv(ji,jj,jk) = ( pt(ji  ,jj+1,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * vmask(ji,jj,jk) 
     239            END_3D 
    281240            CALL lbc_lnk_multi( 'traadv_fct', ztu, 'U', -1. , ztv, 'V', -1. )   ! Lateral boundary cond. (unchanged sgn) 
    282241            ! 
    283             DO jk = 1, jpkm1                 ! Horizontal advective fluxes 
    284                DO jj = 2, jpjm1 
    285                   DO ji = 2, fs_jpim1   ! vector opt. 
    286                      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) 
    287                      zC2t_v = pt(ji,jj,jk,jn,Kmm) + pt(ji  ,jj+1,jk,jn,Kmm) 
    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 * pU(ji,jj,jk) * zC4t_u - zwx(ji,jj,jk) 
    293                      zwy(ji,jj,jk) =  0.5_wp * pV(ji,jj,jk) * zC4t_v - zwy(ji,jj,jk) 
    294                   END DO 
    295                END DO 
    296             END DO 
     242            DO_3D_00_00( 1, jpkm1 ) 
     243               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) 
     244               zC2t_v = pt(ji,jj,jk,jn,Kmm) + pt(ji  ,jj+1,jk,jn,Kmm) 
     245               !                                                  ! C4 interpolation of T at u- & v-points (x2) 
     246               zC4t_u =  zC2t_u + r1_6 * ( ztu(ji-1,jj  ,jk) - ztu(ji+1,jj  ,jk) ) 
     247               zC4t_v =  zC2t_v + r1_6 * ( ztv(ji  ,jj-1,jk) - ztv(ji  ,jj+1,jk) ) 
     248               !                                                  ! C4 minus upstream advective fluxes  
     249               zwx(ji,jj,jk) =  0.5_wp * pU(ji,jj,jk) * zC4t_u - zwx(ji,jj,jk) 
     250               zwy(ji,jj,jk) =  0.5_wp * pV(ji,jj,jk) * zC4t_v - zwy(ji,jj,jk) 
     251            END_3D 
    297252            ! 
    298253         END SELECT 
    … …  
    301256         ! 
    302257         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) =  (  pW(ji,jj,jk) * 0.5_wp * ( pt(ji,jj,jk,jn,Kmm) + pt(ji,jj,jk-1,jn,Kmm) )   & 
    307                         &              - zwz(ji,jj,jk)  ) * wmask(ji,jj,jk) 
    308                   END DO 
    309                END DO 
    310             END DO 
     258            DO_3D_00_00( 2, jpkm1 ) 
     259               zwz(ji,jj,jk) =  (  pW(ji,jj,jk) * 0.5_wp * ( pt(ji,jj,jk,jn,Kmm) + pt(ji,jj,jk-1,jn,Kmm) )   & 
     260                  &              - zwz(ji,jj,jk)  ) * wmask(ji,jj,jk) 
     261            END_3D 
    311262            ! 
    312263         CASE(  4  )                   !- 4th order COMPACT 
    313264            CALL interp_4th_cpt( pt(:,:,:,jn,Kmm) , 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) = ( pW(ji,jj,jk) * ztw(ji,jj,jk) - zwz(ji,jj,jk) ) * wmask(ji,jj,jk) 
    318                   END DO 
    319                END DO 
    320             END DO 
     265            DO_3D_00_00( 2, jpkm1 ) 
     266               zwz(ji,jj,jk) = ( pW(ji,jj,jk) * ztw(ji,jj,jk) - zwz(ji,jj,jk) ) * wmask(ji,jj,jk) 
     267            END_3D 
    321268            ! 
    322269         END SELECT 
    … …  
    326273         !          
    327274         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(ji,jj,jk,Krhs) * tmask(ji,jj,jk) 
    336                   END DO 
    337                END DO 
    338             END DO 
     275            DO_3D_00_00( 1, jpkm1 ) 
     276               !                             ! total intermediate advective trends 
     277               ztra = - (  zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk  )   & 
     278                  &      + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk  )   & 
     279                  &      + zwz(ji,jj,jk) - zwz(ji  ,jj  ,jk+1) ) * r1_e1e2t(ji,jj) 
     280               ztw(ji,jj,jk)  = zwi(ji,jj,jk) + p2dt * ztra / e3t(ji,jj,jk,Krhs) * tmask(ji,jj,jk) 
     281            END_3D 
    339282            ! 
    340283            CALL tridia_solver( zwdia, zwsup, zwinf, ztw, ztw , 0 ) 
    341284            ! 
    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 
     285            DO_3D_00_00( 2, jpkm1 ) 
     286               zfp_wk = wi(ji,jj,jk) + ABS( wi(ji,jj,jk) ) 
     287               zfm_wk = wi(ji,jj,jk) - ABS( wi(ji,jj,jk) ) 
     288               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) 
     289            END_3D 
    351290         END IF 
    352291         ! 
    … …  
    359298         !        !==  final trend with corrected fluxes  ==! 
    360299         ! 
    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                   pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) + ztra / e3t(ji,jj,jk,Kmm) 
    368                   zwi(ji,jj,jk) = zwi(ji,jj,jk) + p2dt * ztra / e3t(ji,jj,jk,Krhs) * tmask(ji,jj,jk) 
    369                END DO 
    370             END DO 
    371          END DO 
     300         DO_3D_00_00( 1, jpkm1 ) 
     301            ztra = - (  zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk  )   & 
     302               &      + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk  )   & 
     303               &      + zwz(ji,jj,jk) - zwz(ji  ,jj  ,jk+1) ) * r1_e1e2t(ji,jj) 
     304            pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) + ztra / e3t(ji,jj,jk,Kmm) 
     305            zwi(ji,jj,jk) = zwi(ji,jj,jk) + p2dt * ztra / e3t(ji,jj,jk,Krhs) * tmask(ji,jj,jk) 
     306         END_3D 
    372307         ! 
    373308         IF ( ll_zAimp ) THEN 
    374309            ! 
    375310            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                      pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( ztw(ji,jj,jk) - ztw(ji  ,jj  ,jk+1) ) & 
    390                         &                                        * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
    391                   END DO 
    392                END DO 
    393             END DO 
     311            DO_3D_00_00( 2, jpkm1 ) 
     312               zfp_wk = wi(ji,jj,jk) + ABS( wi(ji,jj,jk) ) 
     313               zfm_wk = wi(ji,jj,jk) - ABS( wi(ji,jj,jk) ) 
     314               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) 
     315               zwz(ji,jj,jk) = zwz(ji,jj,jk) + ztw(ji,jj,jk) ! Update vertical fluxes for trend diagnostic 
     316            END_3D 
     317            DO_3D_00_00( 1, jpkm1 ) 
     318               pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( ztw(ji,jj,jk) - ztw(ji  ,jj  ,jk+1) ) & 
     319                  &                                        * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
     320            END_3D 
    394321         END IF          
    395322         ! 
    … …  
    467394      DO jk = 1, jpkm1 
    468395         ikm1 = MAX(jk-1,1) 
    469          DO jj = 2, jpjm1 
    470             DO ji = fs_2, fs_jpim1   ! vector opt. 
    471  
    472                ! search maximum in neighbourhood 
    473                zup = MAX(  zbup(ji  ,jj  ,jk  ),   & 
    474                   &        zbup(ji-1,jj  ,jk  ), zbup(ji+1,jj  ,jk  ),   & 
    475                   &        zbup(ji  ,jj-1,jk  ), zbup(ji  ,jj+1,jk  ),   & 
    476                   &        zbup(ji  ,jj  ,ikm1), zbup(ji  ,jj  ,jk+1)  ) 
    477  
    478                ! search minimum in neighbourhood 
    479                zdo = MIN(  zbdo(ji  ,jj  ,jk  ),   & 
    480                   &        zbdo(ji-1,jj  ,jk  ), zbdo(ji+1,jj  ,jk  ),   & 
    481                   &        zbdo(ji  ,jj-1,jk  ), zbdo(ji  ,jj+1,jk  ),   & 
    482                   &        zbdo(ji  ,jj  ,ikm1), zbdo(ji  ,jj  ,jk+1)  ) 
    483  
    484                ! positive part of the flux 
    485                zpos = MAX( 0., paa(ji-1,jj  ,jk  ) ) - MIN( 0., paa(ji  ,jj  ,jk  ) )   & 
    486                   & + MAX( 0., pbb(ji  ,jj-1,jk  ) ) - MIN( 0., pbb(ji  ,jj  ,jk  ) )   & 
    487                   & + MAX( 0., pcc(ji  ,jj  ,jk+1) ) - MIN( 0., pcc(ji  ,jj  ,jk  ) ) 
    488  
    489                ! negative part of the flux 
    490                zneg = MAX( 0., paa(ji  ,jj  ,jk  ) ) - MIN( 0., paa(ji-1,jj  ,jk  ) )   & 
    491                   & + MAX( 0., pbb(ji  ,jj  ,jk  ) ) - MIN( 0., pbb(ji  ,jj-1,jk  ) )   & 
    492                   & + MAX( 0., pcc(ji  ,jj  ,jk  ) ) - MIN( 0., pcc(ji  ,jj  ,jk+1) ) 
    493  
    494                ! up & down beta terms 
    495                zbt = e1e2t(ji,jj) * e3t(ji,jj,jk,Kmm) / p2dt 
    496                zbetup(ji,jj,jk) = ( zup            - paft(ji,jj,jk) ) / ( zpos + zrtrn ) * zbt 
    497                zbetdo(ji,jj,jk) = ( paft(ji,jj,jk) - zdo            ) / ( zneg + zrtrn ) * zbt 
    498             END DO 
    499          END DO 
     396         DO_2D_00_00 
     397 
     398            ! search maximum in neighbourhood 
     399            zup = MAX(  zbup(ji  ,jj  ,jk  ),   & 
     400               &        zbup(ji-1,jj  ,jk  ), zbup(ji+1,jj  ,jk  ),   & 
     401               &        zbup(ji  ,jj-1,jk  ), zbup(ji  ,jj+1,jk  ),   & 
     402               &        zbup(ji  ,jj  ,ikm1), zbup(ji  ,jj  ,jk+1)  ) 
     403 
     404            ! search minimum in neighbourhood 
     405            zdo = MIN(  zbdo(ji  ,jj  ,jk  ),   & 
     406               &        zbdo(ji-1,jj  ,jk  ), zbdo(ji+1,jj  ,jk  ),   & 
     407               &        zbdo(ji  ,jj-1,jk  ), zbdo(ji  ,jj+1,jk  ),   & 
     408               &        zbdo(ji  ,jj  ,ikm1), zbdo(ji  ,jj  ,jk+1)  ) 
     409 
     410            ! positive part of the flux 
     411            zpos = MAX( 0., paa(ji-1,jj  ,jk  ) ) - MIN( 0., paa(ji  ,jj  ,jk  ) )   & 
     412               & + MAX( 0., pbb(ji  ,jj-1,jk  ) ) - MIN( 0., pbb(ji  ,jj  ,jk  ) )   & 
     413               & + MAX( 0., pcc(ji  ,jj  ,jk+1) ) - MIN( 0., pcc(ji  ,jj  ,jk  ) ) 
     414 
     415            ! negative part of the flux 
     416            zneg = MAX( 0., paa(ji  ,jj  ,jk  ) ) - MIN( 0., paa(ji-1,jj  ,jk  ) )   & 
     417               & + MAX( 0., pbb(ji  ,jj  ,jk  ) ) - MIN( 0., pbb(ji  ,jj-1,jk  ) )   & 
     418               & + MAX( 0., pcc(ji  ,jj  ,jk  ) ) - MIN( 0., pcc(ji  ,jj  ,jk+1) ) 
     419 
     420            ! up & down beta terms 
     421            zbt = e1e2t(ji,jj) * e3t(ji,jj,jk,Kmm) / p2dt 
     422            zbetup(ji,jj,jk) = ( zup            - paft(ji,jj,jk) ) / ( zpos + zrtrn ) * zbt 
     423            zbetdo(ji,jj,jk) = ( paft(ji,jj,jk) - zdo            ) / ( zneg + zrtrn ) * zbt 
     424         END_2D 
    500425      END DO 
    501426      CALL lbc_lnk_multi( 'traadv_fct', zbetup, 'T', 1. , zbetdo, 'T', 1. )   ! lateral boundary cond. (unchanged sign) 
    … …  
    503428      ! 3. monotonic flux in the i & j direction (paa & pbb) 
    504429      ! ---------------------------------------- 
    505       DO jk = 1, jpkm1 
    506          DO jj = 2, jpjm1 
    507             DO ji = fs_2, fs_jpim1   ! vector opt. 
    508                zau = MIN( 1._wp, zbetdo(ji,jj,jk), zbetup(ji+1,jj,jk) ) 
    509                zbu = MIN( 1._wp, zbetup(ji,jj,jk), zbetdo(ji+1,jj,jk) ) 
    510                zcu =       ( 0.5  + SIGN( 0.5 , paa(ji,jj,jk) ) ) 
    511                paa(ji,jj,jk) = paa(ji,jj,jk) * ( zcu * zau + ( 1._wp - zcu) * zbu ) 
    512  
    513                zav = MIN( 1._wp, zbetdo(ji,jj,jk), zbetup(ji,jj+1,jk) ) 
    514                zbv = MIN( 1._wp, zbetup(ji,jj,jk), zbetdo(ji,jj+1,jk) ) 
    515                zcv =       ( 0.5  + SIGN( 0.5 , pbb(ji,jj,jk) ) ) 
    516                pbb(ji,jj,jk) = pbb(ji,jj,jk) * ( zcv * zav + ( 1._wp - zcv) * zbv ) 
    517  
    518       ! monotonic flux in the k direction, i.e. pcc 
    519       ! ------------------------------------------- 
    520                za = MIN( 1., zbetdo(ji,jj,jk+1), zbetup(ji,jj,jk) ) 
    521                zb = MIN( 1., zbetup(ji,jj,jk+1), zbetdo(ji,jj,jk) ) 
    522                zc =       ( 0.5  + SIGN( 0.5 , pcc(ji,jj,jk+1) ) ) 
    523                pcc(ji,jj,jk+1) = pcc(ji,jj,jk+1) * ( zc * za + ( 1._wp - zc) * zb ) 
    524             END DO 
    525          END DO 
    526       END DO 
     430      DO_3D_00_00( 1, jpkm1 ) 
     431         zau = MIN( 1._wp, zbetdo(ji,jj,jk), zbetup(ji+1,jj,jk) ) 
     432         zbu = MIN( 1._wp, zbetup(ji,jj,jk), zbetdo(ji+1,jj,jk) ) 
     433         zcu =       ( 0.5  + SIGN( 0.5 , paa(ji,jj,jk) ) ) 
     434         paa(ji,jj,jk) = paa(ji,jj,jk) * ( zcu * zau + ( 1._wp - zcu) * zbu ) 
     435 
     436         zav = MIN( 1._wp, zbetdo(ji,jj,jk), zbetup(ji,jj+1,jk) ) 
     437         zbv = MIN( 1._wp, zbetup(ji,jj,jk), zbetdo(ji,jj+1,jk) ) 
     438         zcv =       ( 0.5  + SIGN( 0.5 , pbb(ji,jj,jk) ) ) 
     439         pbb(ji,jj,jk) = pbb(ji,jj,jk) * ( zcv * zav + ( 1._wp - zcv) * zbv ) 
     440 
     441! monotonic flux in the k direction, i.e. pcc 
     442! ------------------------------------------- 
     443         za = MIN( 1., zbetdo(ji,jj,jk+1), zbetup(ji,jj,jk) ) 
     444         zb = MIN( 1., zbetup(ji,jj,jk+1), zbetdo(ji,jj,jk) ) 
     445         zc =       ( 0.5  + SIGN( 0.5 , pcc(ji,jj,jk+1) ) ) 
     446         pcc(ji,jj,jk+1) = pcc(ji,jj,jk+1) * ( zc * za + ( 1._wp - zc) * zb ) 
     447      END_3D 
    527448      CALL lbc_lnk_multi( 'traadv_fct', paa, 'U', -1. , pbb, 'V', -1. )   ! lateral boundary condition (changed sign) 
    528449      ! 
    … …  
    545466      !!---------------------------------------------------------------------- 
    546467       
    547       DO jk = 3, jpkm1        !==  build the three diagonal matrix  ==! 
    548          DO jj = 1, jpj 
    549             DO ji = 1, jpi 
    550                zwd (ji,jj,jk) = 4._wp 
    551                zwi (ji,jj,jk) = 1._wp 
    552                zws (ji,jj,jk) = 1._wp 
    553                zwrm(ji,jj,jk) = 3._wp * ( pt_in(ji,jj,jk-1) + pt_in(ji,jj,jk) ) 
    554                ! 
    555                IF( tmask(ji,jj,jk+1) == 0._wp) THEN   ! Switch to second order centered at bottom 
    556                   zwd (ji,jj,jk) = 1._wp 
    557                   zwi (ji,jj,jk) = 0._wp 
    558                   zws (ji,jj,jk) = 0._wp 
    559                   zwrm(ji,jj,jk) = 0.5 * ( pt_in(ji,jj,jk-1) + pt_in(ji,jj,jk) )     
    560                ENDIF 
    561             END DO 
    562          END DO 
    563       END DO 
    564       ! 
    565       jk = 2                                          ! Switch to second order centered at top 
    566       DO jj = 1, jpj 
    567          DO ji = 1, jpi 
     468      DO_3D_11_11( 3, jpkm1 ) 
     469         zwd (ji,jj,jk) = 4._wp 
     470         zwi (ji,jj,jk) = 1._wp 
     471         zws (ji,jj,jk) = 1._wp 
     472         zwrm(ji,jj,jk) = 3._wp * ( pt_in(ji,jj,jk-1) + pt_in(ji,jj,jk) ) 
     473         ! 
     474         IF( tmask(ji,jj,jk+1) == 0._wp) THEN   ! Switch to second order centered at bottom 
    568475            zwd (ji,jj,jk) = 1._wp 
    569476            zwi (ji,jj,jk) = 0._wp 
    570477            zws (ji,jj,jk) = 0._wp 
    571             zwrm(ji,jj,jk) = 0.5 * ( pt_in(ji,jj,jk-1) + pt_in(ji,jj,jk) ) 
    572          END DO 
    573       END DO    
     478            zwrm(ji,jj,jk) = 0.5 * ( pt_in(ji,jj,jk-1) + pt_in(ji,jj,jk) )     
     479         ENDIF 
     480      END_3D 
     481      ! 
     482      jk = 2                                          ! Switch to second order centered at top 
     483      DO_2D_11_11 
     484         zwd (ji,jj,jk) = 1._wp 
     485         zwi (ji,jj,jk) = 0._wp 
     486         zws (ji,jj,jk) = 0._wp 
     487         zwrm(ji,jj,jk) = 0.5 * ( pt_in(ji,jj,jk-1) + pt_in(ji,jj,jk) ) 
     488      END_2D 
    574489      ! 
    575490      !                       !==  tridiagonal solve  ==! 
    576       DO jj = 1, jpj                ! first recurrence 
    577          DO ji = 1, jpi 
    578             zwt(ji,jj,2) = zwd(ji,jj,2) 
    579          END DO 
    580       END DO 
    581       DO jk = 3, jpkm1 
    582          DO jj = 1, jpj 
    583             DO ji = 1, jpi 
    584                zwt(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) /zwt(ji,jj,jk-1) 
    585             END DO 
    586          END DO 
    587       END DO 
    588       ! 
    589       DO jj = 1, jpj                ! second recurrence:    Zk = Yk - Ik / Tk-1  Zk-1 
    590          DO ji = 1, jpi 
    591             pt_out(ji,jj,2) = zwrm(ji,jj,2) 
    592          END DO 
    593       END DO 
    594       DO jk = 3, jpkm1 
    595          DO jj = 1, jpj 
    596             DO ji = 1, jpi 
    597                pt_out(ji,jj,jk) = zwrm(ji,jj,jk) - zwi(ji,jj,jk) / zwt(ji,jj,jk-1) *pt_out(ji,jj,jk-1)              
    598             END DO 
    599          END DO 
    600       END DO 
    601  
    602       DO jj = 1, jpj                ! third recurrence: Xk = (Zk - Sk Xk+1 ) / Tk 
    603          DO ji = 1, jpi 
    604             pt_out(ji,jj,jpkm1) = pt_out(ji,jj,jpkm1) / zwt(ji,jj,jpkm1) 
    605          END DO 
    606       END DO 
    607       DO jk = jpk-2, 2, -1 
    608          DO jj = 1, jpj 
    609             DO ji = 1, jpi 
    610                pt_out(ji,jj,jk) = ( pt_out(ji,jj,jk) - zws(ji,jj,jk) * pt_out(ji,jj,jk+1) ) / zwt(ji,jj,jk) 
    611             END DO 
    612          END DO 
    613       END DO 
     491      DO_2D_11_11 
     492         zwt(ji,jj,2) = zwd(ji,jj,2) 
     493      END_2D 
     494      DO_3D_11_11( 3, jpkm1 ) 
     495         zwt(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) /zwt(ji,jj,jk-1) 
     496      END_3D 
     497      ! 
     498      DO_2D_11_11 
     499         pt_out(ji,jj,2) = zwrm(ji,jj,2) 
     500      END_2D 
     501      DO_3D_11_11( 3, jpkm1 ) 
     502         pt_out(ji,jj,jk) = zwrm(ji,jj,jk) - zwi(ji,jj,jk) / zwt(ji,jj,jk-1) *pt_out(ji,jj,jk-1)              
     503      END_3D 
     504 
     505      DO_2D_11_11 
     506         pt_out(ji,jj,jpkm1) = pt_out(ji,jj,jpkm1) / zwt(ji,jj,jpkm1) 
     507      END_2D 
     508      DO_3DS_11_11( jpk-2, 2, -1 ) 
     509         pt_out(ji,jj,jk) = ( pt_out(ji,jj,jk) - zws(ji,jj,jk) * pt_out(ji,jj,jk+1) ) / zwt(ji,jj,jk) 
     510      END_3D 
    614511      !     
    615512   END SUBROUTINE interp_4th_cpt_org 
    … …  
    634531      !                      !==  build the three diagonal matrix & the RHS  ==! 
    635532      ! 
    636       DO jk = 3, jpkm1                 ! interior (from jk=3 to jpk-1) 
    637          DO jj = 2, jpjm1 
    638             DO ji = fs_2, fs_jpim1 
    639                zwd (ji,jj,jk) = 3._wp * wmask(ji,jj,jk) + 1._wp                 !       diagonal 
    640                zwi (ji,jj,jk) =         wmask(ji,jj,jk)                         ! lower diagonal 
    641                zws (ji,jj,jk) =         wmask(ji,jj,jk)                         ! upper diagonal 
    642                zwrm(ji,jj,jk) = 3._wp * wmask(ji,jj,jk)                     &   ! RHS 
    643                   &           *       ( pt_in(ji,jj,jk) + pt_in(ji,jj,jk-1) ) 
    644             END DO 
    645          END DO 
    646       END DO 
     533      DO_3D_00_00( 3, jpkm1 ) 
     534         zwd (ji,jj,jk) = 3._wp * wmask(ji,jj,jk) + 1._wp                 !       diagonal 
     535         zwi (ji,jj,jk) =         wmask(ji,jj,jk)                         ! lower diagonal 
     536         zws (ji,jj,jk) =         wmask(ji,jj,jk)                         ! upper diagonal 
     537         zwrm(ji,jj,jk) = 3._wp * wmask(ji,jj,jk)                     &   ! RHS 
     538            &           *       ( pt_in(ji,jj,jk) + pt_in(ji,jj,jk-1) ) 
     539      END_3D 
    647540      ! 
    648541!!gm 
    … …  
    657550      END IF 
    658551      ! 
    659       DO jj = 2, jpjm1                 ! 2nd order centered at top & bottom 
    660          DO ji = fs_2, fs_jpim1 
    661             ikt = mikt(ji,jj) + 1            ! w-point below the 1st  wet point 
    662             ikb = MAX(mbkt(ji,jj), 2)        !     -   above the last wet point 
    663             ! 
    664             zwd (ji,jj,ikt) = 1._wp          ! top 
    665             zwi (ji,jj,ikt) = 0._wp 
    666             zws (ji,jj,ikt) = 0._wp 
    667             zwrm(ji,jj,ikt) = 0.5_wp * ( pt_in(ji,jj,ikt-1) + pt_in(ji,jj,ikt) ) 
    668             ! 
    669             zwd (ji,jj,ikb) = 1._wp          ! bottom 
    670             zwi (ji,jj,ikb) = 0._wp 
    671             zws (ji,jj,ikb) = 0._wp 
    672             zwrm(ji,jj,ikb) = 0.5_wp * ( pt_in(ji,jj,ikb-1) + pt_in(ji,jj,ikb) )             
    673          END DO 
    674       END DO    
     552      DO_2D_00_00 
     553         ikt = mikt(ji,jj) + 1            ! w-point below the 1st  wet point 
     554         ikb = MAX(mbkt(ji,jj), 2)        !     -   above the last wet point 
     555         ! 
     556         zwd (ji,jj,ikt) = 1._wp          ! top 
     557         zwi (ji,jj,ikt) = 0._wp 
     558         zws (ji,jj,ikt) = 0._wp 
     559         zwrm(ji,jj,ikt) = 0.5_wp * ( pt_in(ji,jj,ikt-1) + pt_in(ji,jj,ikt) ) 
     560         ! 
     561         zwd (ji,jj,ikb) = 1._wp          ! bottom 
     562         zwi (ji,jj,ikb) = 0._wp 
     563         zws (ji,jj,ikb) = 0._wp 
     564         zwrm(ji,jj,ikb) = 0.5_wp * ( pt_in(ji,jj,ikb-1) + pt_in(ji,jj,ikb) )             
     565      END_2D 
    675566      ! 
    676567      !                       !==  tridiagonal solver  ==! 
    677568      ! 
    678       DO jj = 2, jpjm1              !* 1st recurrence:   Tk = Dk - Ik Sk-1 / Tk-1 
    679          DO ji = fs_2, fs_jpim1 
    680             zwt(ji,jj,2) = zwd(ji,jj,2) 
    681          END DO 
    682       END DO 
    683       DO jk = 3, jpkm1 
    684          DO jj = 2, jpjm1 
    685             DO ji = fs_2, fs_jpim1 
    686                zwt(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) /zwt(ji,jj,jk-1) 
    687             END DO 
    688          END DO 
    689       END DO 
    690       ! 
    691       DO jj = 2, jpjm1              !* 2nd recurrence:    Zk = Yk - Ik / Tk-1  Zk-1 
    692          DO ji = fs_2, fs_jpim1 
    693             pt_out(ji,jj,2) = zwrm(ji,jj,2) 
    694          END DO 
    695       END DO 
    696       DO jk = 3, jpkm1 
    697          DO jj = 2, jpjm1 
    698             DO ji = fs_2, fs_jpim1 
    699                pt_out(ji,jj,jk) = zwrm(ji,jj,jk) - zwi(ji,jj,jk) / zwt(ji,jj,jk-1) *pt_out(ji,jj,jk-1)              
    700             END DO 
    701          END DO 
    702       END DO 
    703  
    704       DO jj = 2, jpjm1              !* 3d recurrence:    Xk = (Zk - Sk Xk+1 ) / Tk 
    705          DO ji = fs_2, fs_jpim1 
    706             pt_out(ji,jj,jpkm1) = pt_out(ji,jj,jpkm1) / zwt(ji,jj,jpkm1) 
    707          END DO 
    708       END DO 
    709       DO jk = jpk-2, 2, -1 
    710          DO jj = 2, jpjm1 
    711             DO ji = fs_2, fs_jpim1 
    712                pt_out(ji,jj,jk) = ( pt_out(ji,jj,jk) - zws(ji,jj,jk) * pt_out(ji,jj,jk+1) ) / zwt(ji,jj,jk) 
    713             END DO 
    714          END DO 
    715       END DO 
     569      DO_2D_00_00 
     570         zwt(ji,jj,2) = zwd(ji,jj,2) 
     571      END_2D 
     572      DO_3D_00_00( 3, jpkm1 ) 
     573         zwt(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) /zwt(ji,jj,jk-1) 
     574      END_3D 
     575      ! 
     576      DO_2D_00_00 
     577         pt_out(ji,jj,2) = zwrm(ji,jj,2) 
     578      END_2D 
     579      DO_3D_00_00( 3, jpkm1 ) 
     580         pt_out(ji,jj,jk) = zwrm(ji,jj,jk) - zwi(ji,jj,jk) / zwt(ji,jj,jk-1) *pt_out(ji,jj,jk-1)              
     581      END_3D 
     582 
     583      DO_2D_00_00 
     584         pt_out(ji,jj,jpkm1) = pt_out(ji,jj,jpkm1) / zwt(ji,jj,jpkm1) 
     585      END_2D 
     586      DO_3DS_00_00( jpk-2, 2, -1 ) 
     587         pt_out(ji,jj,jk) = ( pt_out(ji,jj,jk) - zws(ji,jj,jk) * pt_out(ji,jj,jk+1) ) / zwt(ji,jj,jk) 
     588      END_3D 
    716589      !     
    717590   END SUBROUTINE interp_4th_cpt 
    … …  
    750623      kstart =  1  + klev 
    751624      ! 
    752       DO jj = 2, jpjm1              !* 1st recurrence:   Tk = Dk - Ik Sk-1 / Tk-1 
    753          DO ji = fs_2, fs_jpim1 
    754             zwt(ji,jj,kstart) = pD(ji,jj,kstart) 
    755          END DO 
    756       END DO 
    757       DO jk = kstart+1, jpkm1 
    758          DO jj = 2, jpjm1 
    759             DO ji = fs_2, fs_jpim1 
    760                zwt(ji,jj,jk) = pD(ji,jj,jk) - pL(ji,jj,jk) * pU(ji,jj,jk-1) /zwt(ji,jj,jk-1) 
    761             END DO 
    762          END DO 
    763       END DO 
    764       ! 
    765       DO jj = 2, jpjm1              !* 2nd recurrence:    Zk = Yk - Ik / Tk-1  Zk-1 
    766          DO ji = fs_2, fs_jpim1 
    767             pt_out(ji,jj,kstart) = pRHS(ji,jj,kstart) 
    768          END DO 
    769       END DO 
    770       DO jk = kstart+1, jpkm1 
    771          DO jj = 2, jpjm1 
    772             DO ji = fs_2, fs_jpim1 
    773                pt_out(ji,jj,jk) = pRHS(ji,jj,jk) - pL(ji,jj,jk) / zwt(ji,jj,jk-1) *pt_out(ji,jj,jk-1)              
    774             END DO 
    775          END DO 
    776       END DO 
    777  
    778       DO jj = 2, jpjm1              !* 3d recurrence:    Xk = (Zk - Sk Xk+1 ) / Tk 
    779          DO ji = fs_2, fs_jpim1 
    780             pt_out(ji,jj,jpkm1) = pt_out(ji,jj,jpkm1) / zwt(ji,jj,jpkm1) 
    781          END DO 
    782       END DO 
    783       DO jk = jpk-2, kstart, -1 
    784          DO jj = 2, jpjm1 
    785             DO ji = fs_2, fs_jpim1 
    786                pt_out(ji,jj,jk) = ( pt_out(ji,jj,jk) - pU(ji,jj,jk) * pt_out(ji,jj,jk+1) ) / zwt(ji,jj,jk) 
    787             END DO 
    788          END DO 
    789       END DO 
     625      DO_2D_00_00 
     626         zwt(ji,jj,kstart) = pD(ji,jj,kstart) 
     627      END_2D 
     628      DO_3D_00_00( kstart+1, jpkm1 ) 
     629         zwt(ji,jj,jk) = pD(ji,jj,jk) - pL(ji,jj,jk) * pU(ji,jj,jk-1) /zwt(ji,jj,jk-1) 
     630      END_3D 
     631      ! 
     632      DO_2D_00_00 
     633         pt_out(ji,jj,kstart) = pRHS(ji,jj,kstart) 
     634      END_2D 
     635      DO_3D_00_00( kstart+1, jpkm1 ) 
     636         pt_out(ji,jj,jk) = pRHS(ji,jj,jk) - pL(ji,jj,jk) / zwt(ji,jj,jk-1) *pt_out(ji,jj,jk-1)              
     637      END_3D 
     638 
     639      DO_2D_00_00 
     640         pt_out(ji,jj,jpkm1) = pt_out(ji,jj,jpkm1) / zwt(ji,jj,jpkm1) 
     641      END_2D 
     642      DO_3DS_00_00( jpk-2, kstart, -1 ) 
     643         pt_out(ji,jj,jk) = ( pt_out(ji,jj,jk) - pU(ji,jj,jk) * pt_out(ji,jj,jk+1) ) / zwt(ji,jj,jk) 
     644      END_3D 
    790645      ! 
    791646   END SUBROUTINE tridia_solver 

  • NEMO/branches/2019/dev_r11943_MERGE_2019/src/OCE/TRA/traadv_mus.F90

    r12193 r12340  
    4747   !! * Substitutions 
    4848#  include "vectopt_loop_substitute.h90" 
     49#  include "do_loop_substitute.h90" 
    4950   !!---------------------------------------------------------------------- 
    5051   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    131132         zwx(:,:,jpk) = 0._wp                   ! bottom values 
    132133         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) * ( pt(ji+1,jj,jk,jn,Kbb) - pt(ji,jj,jk,jn,Kbb) ) 
    137                   zwy(ji,jj,jk) = vmask(ji,jj,jk) * ( pt(ji,jj+1,jk,jn,Kbb) - pt(ji,jj,jk,jn,Kbb) ) 
    138                END DO 
    139            END DO 
    140          END DO 
     134         DO_3D_10_10( 1, jpkm1 ) 
     135            zwx(ji,jj,jk) = umask(ji,jj,jk) * ( pt(ji+1,jj,jk,jn,Kbb) - pt(ji,jj,jk,jn,Kbb) ) 
     136            zwy(ji,jj,jk) = vmask(ji,jj,jk) * ( pt(ji,jj+1,jk,jn,Kbb) - pt(ji,jj,jk,jn,Kbb) ) 
     137         END_3D 
    141138         ! lateral boundary conditions   (changed sign) 
    142139         CALL lbc_lnk_multi( 'traadv_mus', zwx, 'U', -1. , zwy, 'V', -1. ) 
    … …  
    144141         zslpx(:,:,jpk) = 0._wp                 ! bottom values 
    145142         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, pU(ji,jj,jk) ) 
    175                   zalpha = 0.5 - z0u 
    176                   zu  = z0u - 0.5 * pU(ji,jj,jk) * p2dt * r1_e1e2u(ji,jj) / e3u(ji,jj,jk,Kmm) 
    177                   zzwx = pt(ji+1,jj,jk,jn,Kbb) + xind(ji,jj,jk) * zu * zslpx(ji+1,jj,jk) 
    178                   zzwy = pt(ji  ,jj,jk,jn,Kbb) + xind(ji,jj,jk) * zu * zslpx(ji  ,jj,jk) 
    179                   zwx(ji,jj,jk) = pU(ji,jj,jk) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) 
    180                   ! 
    181                   z0v = SIGN( 0.5, pV(ji,jj,jk) ) 
    182                   zalpha = 0.5 - z0v 
    183                   zv  = z0v - 0.5 * pV(ji,jj,jk) * p2dt * r1_e1e2v(ji,jj) / e3v(ji,jj,jk,Kmm) 
    184                   zzwx = pt(ji,jj+1,jk,jn,Kbb) + xind(ji,jj,jk) * zv * zslpy(ji,jj+1,jk) 
    185                   zzwy = pt(ji,jj  ,jk,jn,Kbb) + xind(ji,jj,jk) * zv * zslpy(ji,jj  ,jk) 
    186                   zwy(ji,jj,jk) = pV(ji,jj,jk) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) 
    187                END DO 
    188             END DO 
    189          END DO 
     143         DO_3D_01_01( 1, jpkm1 ) 
     144            zslpx(ji,jj,jk) =                    ( zwx(ji,jj,jk) + zwx(ji-1,jj  ,jk) )   & 
     145               &            * ( 0.25 + SIGN( 0.25, zwx(ji,jj,jk) * zwx(ji-1,jj  ,jk) ) ) 
     146            zslpy(ji,jj,jk) =                    ( zwy(ji,jj,jk) + zwy(ji  ,jj-1,jk) )   & 
     147               &            * ( 0.25 + SIGN( 0.25, zwy(ji,jj,jk) * zwy(ji  ,jj-1,jk) ) ) 
     148         END_3D 
     149         ! 
     150         DO_3D_01_01( 1, jpkm1 ) 
     151            zslpx(ji,jj,jk) = SIGN( 1., zslpx(ji,jj,jk) ) * MIN(    ABS( zslpx(ji  ,jj,jk) ),   & 
     152               &                                                 2.*ABS( zwx  (ji-1,jj,jk) ),   & 
     153               &                                                 2.*ABS( zwx  (ji  ,jj,jk) ) ) 
     154            zslpy(ji,jj,jk) = SIGN( 1., zslpy(ji,jj,jk) ) * MIN(    ABS( zslpy(ji,jj  ,jk) ),   & 
     155               &                                                 2.*ABS( zwy  (ji,jj-1,jk) ),   & 
     156               &                                                 2.*ABS( zwy  (ji,jj  ,jk) ) ) 
     157         END_3D 
     158         ! 
     159         DO_3D_00_00( 1, jpkm1 ) 
     160            ! MUSCL fluxes 
     161            z0u = SIGN( 0.5, pU(ji,jj,jk) ) 
     162            zalpha = 0.5 - z0u 
     163            zu  = z0u - 0.5 * pU(ji,jj,jk) * p2dt * r1_e1e2u(ji,jj) / e3u(ji,jj,jk,Kmm) 
     164            zzwx = pt(ji+1,jj,jk,jn,Kbb) + xind(ji,jj,jk) * zu * zslpx(ji+1,jj,jk) 
     165            zzwy = pt(ji  ,jj,jk,jn,Kbb) + xind(ji,jj,jk) * zu * zslpx(ji  ,jj,jk) 
     166            zwx(ji,jj,jk) = pU(ji,jj,jk) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) 
     167            ! 
     168            z0v = SIGN( 0.5, pV(ji,jj,jk) ) 
     169            zalpha = 0.5 - z0v 
     170            zv  = z0v - 0.5 * pV(ji,jj,jk) * p2dt * r1_e1e2v(ji,jj) / e3v(ji,jj,jk,Kmm) 
     171            zzwx = pt(ji,jj+1,jk,jn,Kbb) + xind(ji,jj,jk) * zv * zslpy(ji,jj+1,jk) 
     172            zzwy = pt(ji,jj  ,jk,jn,Kbb) + xind(ji,jj,jk) * zv * zslpy(ji,jj  ,jk) 
     173            zwy(ji,jj,jk) = pV(ji,jj,jk) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) 
     174         END_3D 
    190175         CALL lbc_lnk_multi( 'traadv_mus', zwx, 'U', -1. , zwy, 'V', -1. )   ! lateral boundary conditions   (changed sign) 
    191176         ! 
    192          DO jk = 1, jpkm1                 !-- Tracer advective trend 
    193             DO jj = 2, jpjm1       
    194                DO ji = fs_2, fs_jpim1   ! vector opt. 
    195                   pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( 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(ji,jj,jk,Kmm) 
    198                END DO 
    199            END DO 
    200          END DO         
     177         DO_3D_00_00( 1, jpkm1 ) 
     178            pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk  )       & 
     179            &                                     + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk  ) )     & 
     180            &                                   * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
     181         END_3D 
    201182         !                                ! trend diagnostics 
    202183         IF( l_trd )  THEN 
    … …  
    219200         !                                !-- Slopes of tracer 
    220201         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, pW(ji,jj,jk+1) ) 
    242                   zalpha = 0.5 + z0w 
    243                   zw  = z0w - 0.5 * pW(ji,jj,jk+1) * p2dt * r1_e1e2t(ji,jj) / e3w(ji,jj,jk+1,Kmm) 
    244                   zzwx = pt(ji,jj,jk+1,jn,Kbb) + xind(ji,jj,jk) * zw * zslpx(ji,jj,jk+1) 
    245                   zzwy = pt(ji,jj,jk  ,jn,Kbb) + xind(ji,jj,jk) * zw * zslpx(ji,jj,jk  ) 
    246                   zwx(ji,jj,jk+1) = pW(ji,jj,jk+1) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) * wmask(ji,jj,jk) 
    247                END DO  
    248             END DO 
    249          END DO 
     202         DO_3D_11_11( 2, jpkm1 ) 
     203            zslpx(ji,jj,jk) =                     ( zwx(ji,jj,jk) + zwx(ji,jj,jk+1) )  & 
     204               &            * (  0.25 + SIGN( 0.25, zwx(ji,jj,jk) * zwx(ji,jj,jk+1) )  ) 
     205         END_3D 
     206         DO_3D_11_11( 2, jpkm1 ) 
     207            zslpx(ji,jj,jk) = SIGN( 1., zslpx(ji,jj,jk) ) * MIN(    ABS( zslpx(ji,jj,jk  ) ),   & 
     208               &                                                 2.*ABS( zwx  (ji,jj,jk+1) ),   & 
     209               &                                                 2.*ABS( zwx  (ji,jj,jk  ) )  ) 
     210         END_3D 
     211         DO_3D_00_00( 1, jpk-2 ) 
     212            z0w = SIGN( 0.5, pW(ji,jj,jk+1) ) 
     213            zalpha = 0.5 + z0w 
     214            zw  = z0w - 0.5 * pW(ji,jj,jk+1) * p2dt * r1_e1e2t(ji,jj) / e3w(ji,jj,jk+1,Kmm) 
     215            zzwx = pt(ji,jj,jk+1,jn,Kbb) + xind(ji,jj,jk) * zw * zslpx(ji,jj,jk+1) 
     216            zzwy = pt(ji,jj,jk  ,jn,Kbb) + xind(ji,jj,jk) * zw * zslpx(ji,jj,jk  ) 
     217            zwx(ji,jj,jk+1) = pW(ji,jj,jk+1) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) * wmask(ji,jj,jk) 
     218         END_3D 
    250219         IF( ln_linssh ) THEN                   ! top values, linear free surface only 
    251220            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) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kbb) 
    255                   END DO 
    256                END DO    
     221               DO_2D_11_11 
     222                  zwx(ji,jj, mikt(ji,jj) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kbb) 
     223               END_2D 
    257224            ELSE                                      ! no cavities: only at the ocean surface 
    258225               zwx(:,:,1) = pW(:,:,1) * pt(:,:,1,jn,Kbb) 
    … …  
    260227         ENDIF 
    261228         ! 
    262          DO jk = 1, jpkm1                 !-- vertical advective trend 
    263             DO jj = 2, jpjm1       
    264                DO ji = fs_2, fs_jpim1   ! vector opt. 
    265                   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) 
    266                END DO 
    267             END DO 
    268          END DO 
     229         DO_3D_00_00( 1, jpkm1 ) 
     230            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) 
     231         END_3D 
    269232         !                                ! send trends for diagnostic 
    270233         IF( l_trd )  CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_zad, zwx, pW, pt(:,:,:,jn,Kbb) ) 

  • NEMO/branches/2019/dev_r11943_MERGE_2019/src/OCE/TRA/traadv_qck.F90

    r12193 r12340  
    4141   !! * Substitutions 
    4242#  include "vectopt_loop_substitute.h90" 
     43#  include "do_loop_substitute.h90" 
    4344   !!---------------------------------------------------------------------- 
    4445   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    141142         ! 
    142143!!gm why not using a SHIFT instruction... 
    143          DO jk = 1, jpkm1     !--- Computation of the ustream and downstream value of the tracer and the mask 
    144             DO jj = 2, jpjm1 
    145                DO ji = fs_2, fs_jpim1   ! vector opt. 
    146                   zfc(ji,jj,jk) = pt(ji-1,jj,jk,jn,Kbb)        ! Upstream   in the x-direction for the tracer 
    147                   zfd(ji,jj,jk) = pt(ji+1,jj,jk,jn,Kbb)        ! Downstream in the x-direction for the tracer 
    148                END DO 
    149             END DO 
    150          END DO 
     144         DO_3D_00_00( 1, jpkm1 ) 
     145            zfc(ji,jj,jk) = pt(ji-1,jj,jk,jn,Kbb)        ! Upstream   in the x-direction for the tracer 
     146            zfd(ji,jj,jk) = pt(ji+1,jj,jk,jn,Kbb)        ! Downstream in the x-direction for the tracer 
     147         END_3D 
    151148         CALL lbc_lnk_multi( 'traadv_qck', zfc(:,:,:), 'T', 1. , zfd(:,:,:), 'T', 1. )   ! Lateral boundary conditions  
    152149          
    … …  
    154151         ! Horizontal advective fluxes 
    155152         ! --------------------------- 
    156          DO jk = 1, jpkm1                              
    157             DO jj = 2, jpjm1 
    158                DO ji = fs_2, fs_jpim1   ! vector opt.          
    159                   zdir = 0.5 + SIGN( 0.5, pU(ji,jj,jk) )   ! if pU > 0 : zdir = 1 otherwise zdir = 0  
    160                   zfu(ji,jj,jk) = zdir * zfc(ji,jj,jk ) + ( 1. - zdir ) * zfd(ji+1,jj,jk)  ! FU in the x-direction for T  
    161                END DO 
    162             END DO 
    163          END DO 
    164          ! 
    165          DO jk = 1, jpkm1   
    166             DO jj = 2, jpjm1 
    167                DO ji = fs_2, fs_jpim1   ! vector opt.    
    168                   zdir = 0.5 + SIGN( 0.5, pU(ji,jj,jk) )   ! if pU > 0 : zdir = 1 otherwise zdir = 0  
    169                   zdx = ( zdir * e1t(ji,jj) + ( 1. - zdir ) * e1t(ji+1,jj) ) * e2u(ji,jj) * e3u(ji,jj,jk,Kmm) 
    170                   zwx(ji,jj,jk)  = ABS( pU(ji,jj,jk) ) * p2dt / zdx    ! (0<zc_cfl<1 : Courant number on x-direction) 
    171                   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 
    172                   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 
    173                END DO 
    174             END DO 
    175          END DO  
     153         DO_3D_00_00( 1, jpkm1 ) 
     154            zdir = 0.5 + SIGN( 0.5, pU(ji,jj,jk) )   ! if pU > 0 : zdir = 1 otherwise zdir = 0  
     155            zfu(ji,jj,jk) = zdir * zfc(ji,jj,jk ) + ( 1. - zdir ) * zfd(ji+1,jj,jk)  ! FU in the x-direction for T  
     156         END_3D 
     157         ! 
     158         DO_3D_00_00( 1, jpkm1 ) 
     159            zdir = 0.5 + SIGN( 0.5, pU(ji,jj,jk) )   ! if pU > 0 : zdir = 1 otherwise zdir = 0  
     160            zdx = ( zdir * e1t(ji,jj) + ( 1. - zdir ) * e1t(ji+1,jj) ) * e2u(ji,jj) * e3u(ji,jj,jk,Kmm) 
     161            zwx(ji,jj,jk)  = ABS( pU(ji,jj,jk) ) * p2dt / zdx    ! (0<zc_cfl<1 : Courant number on x-direction) 
     162            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 
     163            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 
     164         END_3D 
    176165         !--- Lateral boundary conditions  
    177166         CALL lbc_lnk_multi( 'traadv_qck', zfu(:,:,:), 'T', 1. , zfd(:,:,:), 'T', 1., zfc(:,:,:), 'T', 1.,  zwx(:,:,:), 'T', 1. ) 
    … …  
    181170         ! 
    182171         ! Mask at the T-points in the x-direction (mask=0 or mask=1) 
    183          DO jk = 1, jpkm1   
    184             DO jj = 2, jpjm1 
    185                DO ji = fs_2, fs_jpim1   ! vector opt.                
    186                   zfu(ji,jj,jk) = tmask(ji-1,jj,jk) + tmask(ji,jj,jk) + tmask(ji+1,jj,jk) - 2. 
    187                END DO 
    188             END DO 
    189          END DO 
     172         DO_3D_00_00( 1, jpkm1 ) 
     173            zfu(ji,jj,jk) = tmask(ji-1,jj,jk) + tmask(ji,jj,jk) + tmask(ji+1,jj,jk) - 2. 
     174         END_3D 
    190175         CALL lbc_lnk( 'traadv_qck', zfu(:,:,:), 'T', 1. )      ! Lateral boundary conditions  
    191176 
    … …  
    194179         DO jk = 1, jpkm1   
    195180            ! 
    196             DO jj = 2, jpjm1 
    197                DO ji = fs_2, fs_jpim1   ! vector opt.                
    198                   zdir = 0.5 + SIGN( 0.5, pU(ji,jj,jk) )   ! if pU > 0 : zdir = 1 otherwise zdir = 0  
    199                   !--- If the second ustream point is a land point 
    200                   !--- the flux is computed by the 1st order UPWIND scheme 
    201                   zmsk = zdir * zfu(ji,jj,jk) + ( 1. - zdir ) * zfu(ji+1,jj,jk) 
    202                   zwx(ji,jj,jk) = zmsk * zwx(ji,jj,jk) + ( 1. - zmsk ) * zfc(ji,jj,jk) 
    203                   zwx(ji,jj,jk) = zwx(ji,jj,jk) * pU(ji,jj,jk) 
    204                END DO 
    205             END DO 
     181            DO_2D_00_00 
     182               zdir = 0.5 + SIGN( 0.5, pU(ji,jj,jk) )   ! if pU > 0 : zdir = 1 otherwise zdir = 0  
     183               !--- If the second ustream point is a land point 
     184               !--- the flux is computed by the 1st order UPWIND scheme 
     185               zmsk = zdir * zfu(ji,jj,jk) + ( 1. - zdir ) * zfu(ji+1,jj,jk) 
     186               zwx(ji,jj,jk) = zmsk * zwx(ji,jj,jk) + ( 1. - zmsk ) * zfc(ji,jj,jk) 
     187               zwx(ji,jj,jk) = zwx(ji,jj,jk) * pU(ji,jj,jk) 
     188            END_2D 
    206189         END DO 
    207190         ! 
    … …  
    209192         ! 
    210193         ! Computation of the trend 
    211          DO jk = 1, jpkm1   
    212             DO jj = 2, jpjm1 
    213                DO ji = fs_2, fs_jpim1   ! vector opt.   
    214                   zbtr = r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
    215                   ! horizontal advective trends 
    216                   ztra = - zbtr * ( zwx(ji,jj,jk) - zwx(ji-1,jj,jk) ) 
    217                   !--- add it to the general tracer trends 
    218                   pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) + ztra 
    219                END DO 
    220             END DO 
    221          END DO 
     194         DO_3D_00_00( 1, jpkm1 ) 
     195            zbtr = r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
     196            ! horizontal advective trends 
     197            ztra = - zbtr * ( zwx(ji,jj,jk) - zwx(ji-1,jj,jk) ) 
     198            !--- add it to the general tracer trends 
     199            pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) + ztra 
     200         END_3D 
    222201         !                                 ! trend diagnostics 
    223202         IF( l_trd )   CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_xad, zwx, pU, pt(:,:,:,jn,Kmm) ) 
    … …  
    254233            !                                              
    255234            !--- Computation of the ustream and downstream value of the tracer and the mask 
    256             DO jj = 2, jpjm1 
    257                DO ji = fs_2, fs_jpim1   ! vector opt. 
    258                   ! Upstream in the x-direction for the tracer 
    259                   zfc(ji,jj,jk) = pt(ji,jj-1,jk,jn,Kbb) 
    260                   ! Downstream in the x-direction for the tracer 
    261                   zfd(ji,jj,jk) = pt(ji,jj+1,jk,jn,Kbb) 
    262                END DO 
    263             END DO 
     235            DO_2D_00_00 
     236               ! Upstream in the x-direction for the tracer 
     237               zfc(ji,jj,jk) = pt(ji,jj-1,jk,jn,Kbb) 
     238               ! Downstream in the x-direction for the tracer 
     239               zfd(ji,jj,jk) = pt(ji,jj+1,jk,jn,Kbb) 
     240            END_2D 
    264241         END DO 
    265242         CALL lbc_lnk_multi( 'traadv_qck', zfc(:,:,:), 'T', 1. , zfd(:,:,:), 'T', 1. )   ! Lateral boundary conditions  
    … …  
    270247         ! --------------------------- 
    271248         ! 
    272          DO jk = 1, jpkm1                              
    273             DO jj = 2, jpjm1 
    274                DO ji = fs_2, fs_jpim1   ! vector opt.          
    275                   zdir = 0.5 + SIGN( 0.5, pV(ji,jj,jk) )   ! if pU > 0 : zdir = 1 otherwise zdir = 0  
    276                   zfu(ji,jj,jk) = zdir * zfc(ji,jj,jk ) + ( 1. - zdir ) * zfd(ji,jj+1,jk)  ! FU in the x-direction for T  
    277                END DO 
    278             END DO 
    279          END DO 
    280          ! 
    281          DO jk = 1, jpkm1   
    282             DO jj = 2, jpjm1 
    283                DO ji = fs_2, fs_jpim1   ! vector opt.    
    284                   zdir = 0.5 + SIGN( 0.5, pV(ji,jj,jk) )   ! if pU > 0 : zdir = 1 otherwise zdir = 0  
    285                   zdx = ( zdir * e2t(ji,jj) + ( 1. - zdir ) * e2t(ji,jj+1) ) * e1v(ji,jj) * e3v(ji,jj,jk,Kmm) 
    286                   zwy(ji,jj,jk)  = ABS( pV(ji,jj,jk) ) * p2dt / zdx    ! (0<zc_cfl<1 : Courant number on x-direction) 
    287                   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 
    288                   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 
    289                END DO 
    290             END DO 
    291          END DO 
     249         DO_3D_00_00( 1, jpkm1 ) 
     250            zdir = 0.5 + SIGN( 0.5, pV(ji,jj,jk) )   ! if pU > 0 : zdir = 1 otherwise zdir = 0  
     251            zfu(ji,jj,jk) = zdir * zfc(ji,jj,jk ) + ( 1. - zdir ) * zfd(ji,jj+1,jk)  ! FU in the x-direction for T  
     252         END_3D 
     253         ! 
     254         DO_3D_00_00( 1, jpkm1 ) 
     255            zdir = 0.5 + SIGN( 0.5, pV(ji,jj,jk) )   ! if pU > 0 : zdir = 1 otherwise zdir = 0  
     256            zdx = ( zdir * e2t(ji,jj) + ( 1. - zdir ) * e2t(ji,jj+1) ) * e1v(ji,jj) * e3v(ji,jj,jk,Kmm) 
     257            zwy(ji,jj,jk)  = ABS( pV(ji,jj,jk) ) * p2dt / zdx    ! (0<zc_cfl<1 : Courant number on x-direction) 
     258            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 
     259            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 
     260         END_3D 
    292261 
    293262         !--- Lateral boundary conditions  
    … …  
    298267         ! 
    299268         ! Mask at the T-points in the x-direction (mask=0 or mask=1) 
    300          DO jk = 1, jpkm1   
    301             DO jj = 2, jpjm1 
    302                DO ji = fs_2, fs_jpim1   ! vector opt.                
    303                   zfu(ji,jj,jk) = tmask(ji,jj-1,jk) + tmask(ji,jj,jk) + tmask(ji,jj+1,jk) - 2. 
    304                END DO 
    305             END DO 
    306          END DO 
     269         DO_3D_00_00( 1, jpkm1 ) 
     270            zfu(ji,jj,jk) = tmask(ji,jj-1,jk) + tmask(ji,jj,jk) + tmask(ji,jj+1,jk) - 2. 
     271         END_3D 
    307272         CALL lbc_lnk( 'traadv_qck', zfu(:,:,:), 'T', 1. )    !--- Lateral boundary conditions  
    308273         ! 
    … …  
    310275         DO jk = 1, jpkm1   
    311276            ! 
    312             DO jj = 2, jpjm1 
    313                DO ji = fs_2, fs_jpim1   ! vector opt.                
    314                   zdir = 0.5 + SIGN( 0.5, pV(ji,jj,jk) )   ! if pU > 0 : zdir = 1 otherwise zdir = 0  
    315                   !--- If the second ustream point is a land point 
    316                   !--- the flux is computed by the 1st order UPWIND scheme 
    317                   zmsk = zdir * zfu(ji,jj,jk) + ( 1. - zdir ) * zfu(ji,jj+1,jk) 
    318                   zwy(ji,jj,jk) = zmsk * zwy(ji,jj,jk) + ( 1. - zmsk ) * zfc(ji,jj,jk) 
    319                   zwy(ji,jj,jk) = zwy(ji,jj,jk) * pV(ji,jj,jk) 
    320                END DO 
    321             END DO 
     277            DO_2D_00_00 
     278               zdir = 0.5 + SIGN( 0.5, pV(ji,jj,jk) )   ! if pU > 0 : zdir = 1 otherwise zdir = 0  
     279               !--- If the second ustream point is a land point 
     280               !--- the flux is computed by the 1st order UPWIND scheme 
     281               zmsk = zdir * zfu(ji,jj,jk) + ( 1. - zdir ) * zfu(ji,jj+1,jk) 
     282               zwy(ji,jj,jk) = zmsk * zwy(ji,jj,jk) + ( 1. - zmsk ) * zfc(ji,jj,jk) 
     283               zwy(ji,jj,jk) = zwy(ji,jj,jk) * pV(ji,jj,jk) 
     284            END_2D 
    322285         END DO 
    323286         ! 
    … …  
    325288         ! 
    326289         ! Computation of the trend 
    327          DO jk = 1, jpkm1   
    328             DO jj = 2, jpjm1 
    329                DO ji = fs_2, fs_jpim1   ! vector opt.   
    330                   zbtr = r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
    331                   ! horizontal advective trends 
    332                   ztra = - zbtr * ( zwy(ji,jj,jk) - zwy(ji,jj-1,jk) ) 
    333                   !--- add it to the general tracer trends 
    334                   pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) + ztra 
    335                END DO 
    336             END DO 
    337          END DO 
     290         DO_3D_00_00( 1, jpkm1 ) 
     291            zbtr = r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
     292            ! horizontal advective trends 
     293            ztra = - zbtr * ( zwy(ji,jj,jk) - zwy(ji,jj-1,jk) ) 
     294            !--- add it to the general tracer trends 
     295            pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) + ztra 
     296         END_3D 
    338297         !                                 ! trend diagnostics 
    339298         IF( l_trd )   CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_yad, zwy, pV, pt(:,:,:,jn,Kmm) ) 
    … …  
    368327         !                                                       ! =========== 
    369328         ! 
    370          DO jk = 2, jpkm1                    !* Interior point   (w-masked 2nd order centered flux) 
    371             DO jj = 2, jpjm1 
    372                DO ji = fs_2, fs_jpim1   ! vector opt. 
    373                   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) 
    374                END DO 
    375             END DO 
    376          END DO 
     329         DO_3D_00_00( 2, jpkm1 ) 
     330            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) 
     331         END_3D 
    377332         IF( ln_linssh ) THEN                !* top value   (only in linear free surf. as zwz is multiplied by wmask) 
    378333            IF( ln_isfcav ) THEN                  ! ice-shelf cavities (top of the ocean) 
    379                DO jj = 1, jpj 
    380                   DO ji = 1, jpi 
    381                      zwz(ji,jj, mikt(ji,jj) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kmm)   ! linear free surface  
    382                   END DO 
    383                END DO    
     334               DO_2D_11_11 
     335                  zwz(ji,jj, mikt(ji,jj) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kmm)   ! linear free surface  
     336               END_2D 
    384337            ELSE                                   ! no ocean cavities (only ocean surface) 
    385338               zwz(:,:,1) = pW(:,:,1) * pt(:,:,1,jn,Kmm) 
    … …  
    387340         ENDIF 
    388341         ! 
    389          DO jk = 1, jpkm1          !==  Tracer flux divergence added to the general trend  ==! 
    390             DO jj = 2, jpjm1 
    391                DO ji = fs_2, fs_jpim1   ! vector opt. 
    392                   pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( zwz(ji,jj,jk) - zwz(ji,jj,jk+1) )   & 
    393                      &                                * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
    394                END DO 
    395             END DO 
    396          END DO 
     342         DO_3D_00_00( 1, jpkm1 ) 
     343            pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( zwz(ji,jj,jk) - zwz(ji,jj,jk+1) )   & 
     344               &                                * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
     345         END_3D 
    397346         !                                 ! Send trends for diagnostic 
    398347         IF( l_trd )  CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_zad, zwz, pW, pt(:,:,:,jn,Kmm) ) 
    … …  
    420369      !---------------------------------------------------------------------- 
    421370      ! 
    422       DO jk = 1, jpkm1 
    423          DO jj = 1, jpj 
    424             DO ji = 1, jpi 
    425                zc     = puc(ji,jj,jk)                         ! Courant number 
    426                zcurv  = pfd(ji,jj,jk) + pfu(ji,jj,jk) - 2. * pfc(ji,jj,jk) 
    427                zcoef1 = 0.5 *      ( pfc(ji,jj,jk) + pfd(ji,jj,jk) ) 
    428                zcoef2 = 0.5 * zc * ( pfd(ji,jj,jk) - pfc(ji,jj,jk) ) 
    429                zcoef3 = ( 1. - ( zc * zc ) ) * r1_6 * zcurv 
    430                zfho   = zcoef1 - zcoef2 - zcoef3              !  phi_f QUICKEST  
    431                ! 
    432                zcoef1 = pfd(ji,jj,jk) - pfu(ji,jj,jk) 
    433                zcoef2 = ABS( zcoef1 ) 
    434                zcoef3 = ABS( zcurv ) 
    435                IF( zcoef3 >= zcoef2 ) THEN 
    436                   zfho = pfc(ji,jj,jk)  
    437                ELSE 
    438                   zcoef3 = pfu(ji,jj,jk) + ( ( pfc(ji,jj,jk) - pfu(ji,jj,jk) ) / MAX( zc, 1.e-9 ) )    ! phi_REF 
    439                   IF( zcoef1 >= 0. ) THEN 
    440                      zfho = MAX( pfc(ji,jj,jk), zfho )  
    441                      zfho = MIN( zfho, MIN( zcoef3, pfd(ji,jj,jk) ) )  
    442                   ELSE 
    443                      zfho = MIN( pfc(ji,jj,jk), zfho )  
    444                      zfho = MAX( zfho, MAX( zcoef3, pfd(ji,jj,jk) ) )  
    445                   ENDIF 
    446                ENDIF 
    447                puc(ji,jj,jk) = zfho 
    448             END DO 
    449          END DO 
    450       END DO 
     371      DO_3D_11_11( 1, jpkm1 ) 
     372         zc     = puc(ji,jj,jk)                         ! Courant number 
     373         zcurv  = pfd(ji,jj,jk) + pfu(ji,jj,jk) - 2. * pfc(ji,jj,jk) 
     374         zcoef1 = 0.5 *      ( pfc(ji,jj,jk) + pfd(ji,jj,jk) ) 
     375         zcoef2 = 0.5 * zc * ( pfd(ji,jj,jk) - pfc(ji,jj,jk) ) 
     376         zcoef3 = ( 1. - ( zc * zc ) ) * r1_6 * zcurv 
     377         zfho   = zcoef1 - zcoef2 - zcoef3              !  phi_f QUICKEST  
     378         ! 
     379         zcoef1 = pfd(ji,jj,jk) - pfu(ji,jj,jk) 
     380         zcoef2 = ABS( zcoef1 ) 
     381         zcoef3 = ABS( zcurv ) 
     382         IF( zcoef3 >= zcoef2 ) THEN 
     383            zfho = pfc(ji,jj,jk)  
     384         ELSE 
     385            zcoef3 = pfu(ji,jj,jk) + ( ( pfc(ji,jj,jk) - pfu(ji,jj,jk) ) / MAX( zc, 1.e-9 ) )    ! phi_REF 
     386            IF( zcoef1 >= 0. ) THEN 
     387               zfho = MAX( pfc(ji,jj,jk), zfho )  
     388               zfho = MIN( zfho, MIN( zcoef3, pfd(ji,jj,jk) ) )  
     389            ELSE 
     390               zfho = MIN( pfc(ji,jj,jk), zfho )  
     391               zfho = MAX( zfho, MAX( zcoef3, pfd(ji,jj,jk) ) )  
     392            ENDIF 
     393         ENDIF 
     394         puc(ji,jj,jk) = zfho 
     395      END_3D 
    451396      ! 
    452397   END SUBROUTINE quickest 

  • NEMO/branches/2019/dev_r11943_MERGE_2019/src/OCE/TRA/traadv_ubs.F90

    r12193 r12340  
    3939   !! * Substitutions 
    4040#  include "vectopt_loop_substitute.h90" 
     41#  include "do_loop_substitute.h90" 
    4142   !!---------------------------------------------------------------------- 
    4243   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    124125         !                                               
    125126         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(ji,jj,jk,Kmm) * umask(ji,jj,jk) 
    129                   zeev = e1_e2v(ji,jj) * e3v(ji,jj,jk,Kmm) * vmask(ji,jj,jk) 
    130                   ztu(ji,jj,jk) = zeeu * ( pt(ji+1,jj  ,jk,jn,Kbb) - pt(ji,jj,jk,jn,Kbb) ) 
    131                   ztv(ji,jj,jk) = zeev * ( pt(ji  ,jj+1,jk,jn,Kbb) - pt(ji,jj,jk,jn,Kbb) ) 
    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(ji,jj,jk,Kmm) ) 
    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 
     127            DO_2D_10_10 
     128               zeeu = e2_e1u(ji,jj) * e3u(ji,jj,jk,Kmm) * umask(ji,jj,jk) 
     129               zeev = e1_e2v(ji,jj) * e3v(ji,jj,jk,Kmm) * vmask(ji,jj,jk) 
     130               ztu(ji,jj,jk) = zeeu * ( pt(ji+1,jj  ,jk,jn,Kbb) - pt(ji,jj,jk,jn,Kbb) ) 
     131               ztv(ji,jj,jk) = zeev * ( pt(ji  ,jj+1,jk,jn,Kbb) - pt(ji,jj,jk,jn,Kbb) ) 
     132            END_2D 
     133            DO_2D_00_00 
     134               zcoef = 1._wp / ( 6._wp * e3t(ji,jj,jk,Kmm) ) 
     135               zltu(ji,jj,jk) = (  ztu(ji,jj,jk) - ztu(ji-1,jj,jk)  ) * zcoef 
     136               zltv(ji,jj,jk) = (  ztv(ji,jj,jk) - ztv(ji,jj-1,jk)  ) * zcoef 
     137            END_2D 
    141138            !                                     
    142139         END DO          
    143140         CALL lbc_lnk( 'traadv_ubs', zltu, 'T', 1. )   ;    CALL lbc_lnk( 'traadv_ubs', zltv, 'T', 1. )   ! Lateral boundary cond. (unchanged sgn) 
    144141         !     
    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 = pU(ji,jj,jk) + ABS( pU(ji,jj,jk) )      ! upstream transport (x2) 
    149                   zfm_ui = pU(ji,jj,jk) - ABS( pU(ji,jj,jk) ) 
    150                   zfp_vj = pV(ji,jj,jk) + ABS( pV(ji,jj,jk) ) 
    151                   zfm_vj = pV(ji,jj,jk) - ABS( pV(ji,jj,jk) ) 
    152                   !                                                  ! 2nd order centered advective fluxes (x2) 
    153                   zcenut = pU(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj  ,jk,jn,Kmm) ) 
    154                   zcenvt = pV(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji  ,jj+1,jk,jn,Kmm) ) 
    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          
     142         DO_3D_10_10( 1, jpkm1 ) 
     143            zfp_ui = pU(ji,jj,jk) + ABS( pU(ji,jj,jk) )      ! upstream transport (x2) 
     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            !                                                  ! 2nd order centered advective fluxes (x2) 
     148            zcenut = pU(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj  ,jk,jn,Kmm) ) 
     149            zcenvt = pV(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji  ,jj+1,jk,jn,Kmm) ) 
     150            !                                                  ! UBS advective fluxes 
     151            ztu(ji,jj,jk) = 0.5 * ( zcenut - zfp_ui * zltu(ji,jj,jk) - zfm_ui * zltu(ji+1,jj,jk) ) 
     152            ztv(ji,jj,jk) = 0.5 * ( zcenvt - zfp_vj * zltv(ji,jj,jk) - zfm_vj * zltv(ji,jj+1,jk) ) 
     153         END_3D 
    161154         ! 
    162155         zltu(:,:,:) = pt(:,:,:,jn,Krhs)      ! store the initial trends before its update 
    163156         ! 
    164157         DO jk = 1, jpkm1        !==  add the horizontal advective trend  ==! 
    165             DO jj = 2, jpjm1 
    166                DO ji = fs_2, fs_jpim1   ! vector opt. 
    167                   pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs)                        & 
    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(ji,jj,jk,Kmm) 
    170                END DO 
    171             END DO 
     158            DO_2D_00_00 
     159               pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs)                        & 
     160                  &             - (  ztu(ji,jj,jk) - ztu(ji-1,jj  ,jk)    & 
     161                  &                + ztv(ji,jj,jk) - ztv(ji  ,jj-1,jk)  ) * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
     162            END_2D 
    172163            !                                              
    173164         END DO 
    … …  
    196187            ! 
    197188            !                          !*  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 = pW(ji,jj,jk) + ABS( pW(ji,jj,jk) ) 
    202                      zfm_wk = pW(ji,jj,jk) - ABS( pW(ji,jj,jk) ) 
    203                      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) 
    204                   END DO 
    205                END DO 
    206             END DO  
     189            DO_3D_11_11( 2, jpkm1 ) 
     190               zfp_wk = pW(ji,jj,jk) + ABS( pW(ji,jj,jk) ) 
     191               zfm_wk = pW(ji,jj,jk) - ABS( pW(ji,jj,jk) ) 
     192               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) 
     193            END_3D 
    207194            IF( ln_linssh ) THEN             ! top ocean value (only in linear free surface as ztw has been w-masked) 
    208195               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) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kbb)   ! linear free surface  
    212                      END DO 
    213                   END DO    
     196                  DO_2D_11_11 
     197                     ztw(ji,jj, mikt(ji,jj) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kbb)   ! linear free surface  
     198                  END_2D 
    214199               ELSE                                ! no cavities: only at the ocean surface 
    215200                  ztw(:,:,1) = pW(:,:,1) * pt(:,:,1,jn,Kbb) 
    … …  
    217202            ENDIF 
    218203            ! 
    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(ji,jj,jk,Kmm) 
    223                      pt(ji,jj,jk,jn,Krhs) =   pt(ji,jj,jk,jn,Krhs) +  ztak  
    224                      zti(ji,jj,jk)    = ( pt(ji,jj,jk,jn,Kbb) + p2dt * ( ztak + zltu(ji,jj,jk) ) ) * tmask(ji,jj,jk) 
    225                   END DO 
    226                END DO 
    227             END DO 
     204            DO_3D_00_00( 1, jpkm1 ) 
     205               ztak = - ( ztw(ji,jj,jk) - ztw(ji,jj,jk+1) ) * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
     206               pt(ji,jj,jk,jn,Krhs) =   pt(ji,jj,jk,jn,Krhs) +  ztak  
     207               zti(ji,jj,jk)    = ( pt(ji,jj,jk,jn,Kbb) + p2dt * ( ztak + zltu(ji,jj,jk) ) ) * tmask(ji,jj,jk) 
     208            END_3D 
    228209            CALL lbc_lnk( 'traadv_ubs', zti, 'T', 1. )      ! Lateral boundary conditions on zti, zsi   (unchanged sign) 
    229210            ! 
    230211            !                          !*  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 * pW(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji,jj,jk-1,jn,Kmm) )   & 
    235                         &              - ztw(ji,jj,jk)   ) * wmask(ji,jj,jk) 
    236                   END DO 
    237                END DO 
    238             END DO 
     212            DO_3D_11_11( 2, jpkm1 ) 
     213               ztw(ji,jj,jk) = (   0.5_wp * pW(ji,jj,jk) * ( pt(ji,jj,jk,jn,Kmm) + pt(ji,jj,jk-1,jn,Kmm) )   & 
     214                  &              - ztw(ji,jj,jk)   ) * wmask(ji,jj,jk) 
     215            END_3D 
    239216            !                                            ! top ocean value: high order == upstream  ==>>  zwz=0 
    240217            IF( ln_linssh )   ztw(:,:, 1 ) = 0._wp       ! only ocean surface as interior zwz values have been w-masked 
    … …  
    244221         CASE(  4  )                               ! 4th order COMPACT 
    245222            CALL interp_4th_cpt( pt(:,:,:,jn,Kmm) , 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) = pW(ji,jj,jk) * ztw(ji,jj,jk) * wmask(ji,jj,jk) 
    250                   END DO 
    251                END DO 
    252             END DO 
     223            DO_3D_00_00( 2, jpkm1 ) 
     224               ztw(ji,jj,jk) = pW(ji,jj,jk) * ztw(ji,jj,jk) * wmask(ji,jj,jk) 
     225            END_3D 
    253226            IF( ln_linssh )   ztw(:,:, 1 ) = pW(:,:,1) * pt(:,:,1,jn,Kmm)     !!gm ISF & 4th COMPACT doesn't work 
    254227            ! 
    255228         END SELECT 
    256229         ! 
    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                   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) 
    261                END DO 
    262             END DO 
    263          END DO 
     230         DO_3D_00_00( 1, jpkm1 ) 
     231            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) 
     232         END_3D 
    264233         ! 
    265234         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) = pt(ji,jj,jk,jn,Krhs) - zltv(ji,jj,jk)                          & 
    270                         &           + pt(ji,jj,jk,jn,Kmm) * (  pW(ji,jj,jk) - pW(ji,jj,jk+1)  )   & 
    271                         &                              * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
    272                   END DO 
    273                END DO 
    274             END DO 
     235            DO_3D_00_00( 1, jpkm1 ) 
     236               zltv(ji,jj,jk) = pt(ji,jj,jk,jn,Krhs) - zltv(ji,jj,jk)                          & 
     237                  &           + pt(ji,jj,jk,jn,Kmm) * (  pW(ji,jj,jk) - pW(ji,jj,jk+1)  )   & 
     238                  &                              * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
     239            END_3D 
    275240            CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_zad, zltv ) 
    276241         ENDIF 
    … …  
    318283      DO jk = 1, jpkm1     ! search maximum in neighbourhood 
    319284         ikm1 = MAX(jk-1,1) 
    320          DO jj = 2, jpjm1 
    321             DO ji = fs_2, fs_jpim1   ! vector opt. 
    322                zbetup(ji,jj,jk) = MAX(  pbef(ji  ,jj  ,jk  ), paft(ji  ,jj  ,jk  ),   & 
    323                   &                     pbef(ji  ,jj  ,ikm1), pbef(ji  ,jj  ,jk+1),   & 
    324                   &                     paft(ji  ,jj  ,ikm1), paft(ji  ,jj  ,jk+1)  ) 
    325             END DO 
    326          END DO 
     285         DO_2D_00_00 
     286            zbetup(ji,jj,jk) = MAX(  pbef(ji  ,jj  ,jk  ), paft(ji  ,jj  ,jk  ),   & 
     287               &                     pbef(ji  ,jj  ,ikm1), pbef(ji  ,jj  ,jk+1),   & 
     288               &                     paft(ji  ,jj  ,ikm1), paft(ji  ,jj  ,jk+1)  ) 
     289         END_2D 
    327290      END DO 
    328291      !                    ! large positive value (+zbig) inside land 
    … …  
    332295      DO jk = 1, jpkm1     ! search minimum in neighbourhood 
    333296         ikm1 = MAX(jk-1,1) 
    334          DO jj = 2, jpjm1 
    335             DO ji = fs_2, fs_jpim1   ! vector opt. 
    336                zbetdo(ji,jj,jk) = MIN(  pbef(ji  ,jj  ,jk  ), paft(ji  ,jj  ,jk  ),   & 
    337                   &                     pbef(ji  ,jj  ,ikm1), pbef(ji  ,jj  ,jk+1),   & 
    338                   &                     paft(ji  ,jj  ,ikm1), paft(ji  ,jj  ,jk+1)  ) 
    339             END DO 
    340          END DO 
     297         DO_2D_00_00 
     298            zbetdo(ji,jj,jk) = MIN(  pbef(ji  ,jj  ,jk  ), paft(ji  ,jj  ,jk  ),   & 
     299               &                     pbef(ji  ,jj  ,ikm1), pbef(ji  ,jj  ,jk+1),   & 
     300               &                     paft(ji  ,jj  ,ikm1), paft(ji  ,jj  ,jk+1)  ) 
     301         END_2D 
    341302      END DO 
    342303      !                    ! restore masked values to zero 
    … …  
    346307      ! Positive and negative part of fluxes and beta terms 
    347308      ! --------------------------------------------------- 
    348       DO jk = 1, jpkm1 
    349          DO jj = 2, jpjm1 
    350             DO ji = fs_2, fs_jpim1   ! vector opt. 
    351                ! positive & negative part of the flux 
    352                zpos = MAX( 0., pcc(ji  ,jj  ,jk+1) ) - MIN( 0., pcc(ji  ,jj  ,jk  ) ) 
    353                zneg = MAX( 0., pcc(ji  ,jj  ,jk  ) ) - MIN( 0., pcc(ji  ,jj  ,jk+1) ) 
    354                ! up & down beta terms 
    355                zbt = e1e2t(ji,jj) * e3t(ji,jj,jk,Kmm) / p2dt 
    356                zbetup(ji,jj,jk) = ( zbetup(ji,jj,jk) - paft(ji,jj,jk) ) / (zpos+zrtrn) * zbt 
    357                zbetdo(ji,jj,jk) = ( paft(ji,jj,jk) - zbetdo(ji,jj,jk) ) / (zneg+zrtrn) * zbt 
    358             END DO 
    359          END DO 
    360       END DO 
     309      DO_3D_00_00( 1, jpkm1 ) 
     310         ! positive & negative part of the flux 
     311         zpos = MAX( 0., pcc(ji  ,jj  ,jk+1) ) - MIN( 0., pcc(ji  ,jj  ,jk  ) ) 
     312         zneg = MAX( 0., pcc(ji  ,jj  ,jk  ) ) - MIN( 0., pcc(ji  ,jj  ,jk+1) ) 
     313         ! up & down beta terms 
     314         zbt = e1e2t(ji,jj) * e3t(ji,jj,jk,Kmm) / p2dt 
     315         zbetup(ji,jj,jk) = ( zbetup(ji,jj,jk) - paft(ji,jj,jk) ) / (zpos+zrtrn) * zbt 
     316         zbetdo(ji,jj,jk) = ( paft(ji,jj,jk) - zbetdo(ji,jj,jk) ) / (zneg+zrtrn) * zbt 
     317      END_3D 
    361318      ! 
    362319      ! monotonic flux in the k direction, i.e. pcc 
    363320      ! ------------------------------------------- 
    364       DO jk = 2, jpkm1 
    365          DO jj = 2, jpjm1 
    366             DO ji = fs_2, fs_jpim1   ! vector opt. 
    367                za = MIN( 1., zbetdo(ji,jj,jk), zbetup(ji,jj,jk-1) ) 
    368                zb = MIN( 1., zbetup(ji,jj,jk), zbetdo(ji,jj,jk-1) ) 
    369                zc = 0.5 * ( 1.e0 + SIGN( 1.e0, pcc(ji,jj,jk) ) ) 
    370                pcc(ji,jj,jk) = pcc(ji,jj,jk) * ( zc * za + ( 1.e0 - zc) * zb ) 
    371             END DO 
    372          END DO 
    373       END DO 
     321      DO_3D_00_00( 2, jpkm1 ) 
     322         za = MIN( 1., zbetdo(ji,jj,jk), zbetup(ji,jj,jk-1) ) 
     323         zb = MIN( 1., zbetup(ji,jj,jk), zbetdo(ji,jj,jk-1) ) 
     324         zc = 0.5 * ( 1.e0 + SIGN( 1.e0, pcc(ji,jj,jk) ) ) 
     325         pcc(ji,jj,jk) = pcc(ji,jj,jk) * ( zc * za + ( 1.e0 - zc) * zb ) 
     326      END_3D 
    374327      ! 
    375328   END SUBROUTINE nonosc_z 

  • NEMO/branches/2019/dev_r11943_MERGE_2019/src/OCE/TRA/traatf.F90

    r12236 r12340  
    5858   !! * Substitutions 
    5959#  include "vectopt_loop_substitute.h90" 
     60#  include "do_loop_substitute.h90" 
    6061   !!---------------------------------------------------------------------- 
    6162   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    215216      DO jn = 1, kjpt 
    216217         ! 
    217          DO jk = 1, jpkm1 
    218             DO jj = 2, jpjm1 
    219                DO ji = fs_2, fs_jpim1 
    220                   ztn = pt(ji,jj,jk,jn,Kmm)                                     
    221                   ztd = pt(ji,jj,jk,jn,Kaa) - 2._wp * ztn + pt(ji,jj,jk,jn,Kbb)  ! time laplacian on tracers 
    222                   ! 
    223                   pt(ji,jj,jk,jn,Kmm) = ztn + atfp * ztd                      ! pt <-- filtered pt 
    224                END DO 
    225            END DO 
    226          END DO 
     218         DO_3D_00_00( 1, jpkm1 ) 
     219            ztn = pt(ji,jj,jk,jn,Kmm)                                     
     220            ztd = pt(ji,jj,jk,jn,Kaa) - 2._wp * ztn + pt(ji,jj,jk,jn,Kbb)  ! time laplacian on tracers 
     221            ! 
     222            pt(ji,jj,jk,jn,Kmm) = ztn + atfp * ztd                      ! pt <-- filtered pt 
     223         END_3D 
    227224         ! 
    228225      END DO 
    … …  
    284281      zfact2 = zfact1 * r1_rau0 
    285282      DO jn = 1, kjpt       
    286          DO jk = 1, jpkm1 
    287             DO jj = 2, jpjm1 
    288                DO ji = fs_2, fs_jpim1 
    289                   ze3t_b = e3t(ji,jj,jk,Kbb) 
    290                   ze3t_n = e3t(ji,jj,jk,Kmm) 
    291                   ze3t_a = e3t(ji,jj,jk,Kaa) 
    292                   !                                         ! tracer content at Before, now and after 
    293                   ztc_b  = pt(ji,jj,jk,jn,Kbb) * ze3t_b 
    294                   ztc_n  = pt(ji,jj,jk,jn,Kmm) * ze3t_n 
    295                   ztc_a  = pt(ji,jj,jk,jn,Kaa) * ze3t_a 
     283         DO_3D_00_00( 1, jpkm1 ) 
     284            ze3t_b = e3t(ji,jj,jk,Kbb) 
     285            ze3t_n = e3t(ji,jj,jk,Kmm) 
     286            ze3t_a = e3t(ji,jj,jk,Kaa) 
     287            !                                         ! tracer content at Before, now and after 
     288            ztc_b  = pt(ji,jj,jk,jn,Kbb) * ze3t_b 
     289            ztc_n  = pt(ji,jj,jk,jn,Kmm) * ze3t_n 
     290            ztc_a  = pt(ji,jj,jk,jn,Kaa) * ze3t_a 
     291            ! 
     292            ze3t_d = ze3t_a - 2. * ze3t_n + ze3t_b 
     293            ztc_d  = ztc_a  - 2. * ztc_n  + ztc_b 
     294            ! 
     295            ze3t_f = ze3t_n + atfp * ze3t_d 
     296            ztc_f  = ztc_n  + atfp * ztc_d 
     297            ! 
     298            IF( jk == mikt(ji,jj) ) THEN           ! first level  
     299               ze3t_f = ze3t_f - zfact2 * ( emp_b(ji,jj)    - emp(ji,jj) ) 
     300               ztc_f  = ztc_f  - zfact1 * ( psbc_tc(ji,jj,jn) - psbc_tc_b(ji,jj,jn) ) 
     301            ENDIF 
     302            IF( ln_rnf_depth ) THEN 
     303               ! Rivers are not just at the surface must go down to nk_rnf(ji,jj) 
     304               IF( jk <= nk_rnf(ji,jj)  ) THEN 
     305                  ze3t_f = ze3t_f - zfact2 * ( - (rnf_b(ji,jj) - rnf(ji,jj)   )  ) & 
     306              &                            * ( e3t(ji,jj,jk,Kmm) / h_rnf(ji,jj) )  
     307               ENDIF 
     308            ELSE 
     309               IF( jk == 1 ) THEN           ! first level  
     310                  ze3t_f = ze3t_f - zfact2 * ( - (rnf_b(ji,jj)    - rnf(ji,jj)   ) )  
     311               ENDIF 
     312            ENDIF 
     313            ! 
     314            ! 
     315            ! solar penetration (temperature only) 
     316            IF( ll_traqsr .AND. jn == jp_tem .AND. jk <= nksr )                            &  
     317               &     ztc_f  = ztc_f  - zfact1 * ( qsr_hc(ji,jj,jk) - qsr_hc_b(ji,jj,jk) )  
     318               ! 
     319            ! 
     320            IF( ll_rnf .AND. jk <= nk_rnf(ji,jj) )                                          & 
     321               &     ztc_f  = ztc_f  - zfact1 * ( rnf_tsc(ji,jj,jn) - rnf_tsc_b(ji,jj,jn) ) &  
     322               &                              * e3t(ji,jj,jk,Kmm) / h_rnf(ji,jj) 
     323 
     324            ! 
     325            ! ice shelf 
     326            IF( ll_isf ) THEN 
     327               ! 
     328               ! melt in the cavity 
     329               IF ( ln_isfcav_mlt ) THEN 
     330                  ! level fully include in the Losch_2008 ice shelf boundary layer 
     331                  IF ( jk >= misfkt_cav(ji,jj) .AND. jk < misfkb_cav(ji,jj) ) THEN 
     332                     ztc_f  = ztc_f  - zfact1 * ( risf_cav_tsc(ji,jj,jn) - risf_cav_tsc_b(ji,jj,jn) ) & 
     333                        &                     * e3t(ji,jj,jk,Kmm) / rhisf_tbl_cav(ji,jj) 
     334                     ze3t_f = ze3t_f - zfact2 * ( fwfisf_cav_b(ji,jj) - fwfisf_cav(ji,jj) )           & 
     335                        &                     * e3t(ji,jj,jk,Kmm) / rhisf_tbl_cav(ji,jj) 
     336                  END IF 
     337                  ! level partially include in Losch_2008 ice shelf boundary layer  
     338                  IF ( jk == misfkb_cav(ji,jj) ) THEN 
     339                     ztc_f  = ztc_f  - zfact1 * ( risf_cav_tsc(ji,jj,jn) - risf_cav_tsc_b(ji,jj,jn) )  & 
     340                            &                 * e3t(ji,jj,jk,Kmm) / rhisf_tbl_cav(ji,jj) * rfrac_tbl_cav(ji,jj) 
     341                     ze3t_f = ze3t_f - zfact2 * ( fwfisf_cav_b(ji,jj) - fwfisf_cav(ji,jj) )            & 
     342                        &                     * e3t(ji,jj,jk,Kmm) / rhisf_tbl_cav(ji,jj) * rfrac_tbl_cav(ji,jj) 
     343                  END IF 
     344               END IF 
     345               ! 
     346               ! parametrised melt (cavity closed) 
     347               IF ( ln_isfpar_mlt ) THEN 
     348                  ! level fully include in the Losch_2008 ice shelf boundary layer 
     349                  IF ( jk >= misfkt_par(ji,jj) .AND. jk < misfkb_par(ji,jj) ) THEN 
     350                     ztc_f  = ztc_f  - zfact1 * ( risf_par_tsc(ji,jj,jn) - risf_par_tsc_b(ji,jj,jn) )  & 
     351                            &                 * e3t(ji,jj,jk,Kmm) / rhisf_tbl_par(ji,jj) 
     352                     ze3t_f = ze3t_f - zfact2 * ( fwfisf_par_b(ji,jj) - fwfisf_par(ji,jj) )            & 
     353                        &                     * e3t(ji,jj,jk,Kmm) / rhisf_tbl_par(ji,jj) 
     354                  END IF 
     355                  ! level partially include in Losch_2008 ice shelf boundary layer  
     356                  IF ( jk == misfkb_par(ji,jj) ) THEN 
     357                     ztc_f  = ztc_f  - zfact1 * ( risf_par_tsc(ji,jj,jn) - risf_par_tsc_b(ji,jj,jn) )  & 
     358                            &                 * e3t(ji,jj,jk,Kmm) / rhisf_tbl_par(ji,jj) * rfrac_tbl_par(ji,jj) 
     359                     ze3t_f = ze3t_f - zfact2 * ( fwfisf_par_b(ji,jj) - fwfisf_par(ji,jj) )            & 
     360                        &                     * e3t(ji,jj,jk,Kmm) / rhisf_tbl_par(ji,jj) * rfrac_tbl_par(ji,jj) 
     361                  END IF 
     362               END IF 
     363               ! 
     364               ! ice sheet coupling correction 
     365               IF ( ln_isfcpl ) THEN 
    296366                  ! 
    297                   ze3t_d = ze3t_a - 2. * ze3t_n + ze3t_b 
    298                   ztc_d  = ztc_a  - 2. * ztc_n  + ztc_b 
    299                   ! 
    300                   ze3t_f = ze3t_n + atfp * ze3t_d 
    301                   ztc_f  = ztc_n  + atfp * ztc_d 
    302                   ! 
    303                   IF( jk == mikt(ji,jj) ) THEN           ! first level  
    304                      ze3t_f = ze3t_f - zfact2 * ( emp_b(ji,jj)    - emp(ji,jj) ) 
    305                      ztc_f  = ztc_f  - zfact1 * ( psbc_tc(ji,jj,jn) - psbc_tc_b(ji,jj,jn) ) 
    306                   ENDIF 
    307                   IF( ln_rnf_depth ) THEN 
    308                      ! Rivers are not just at the surface must go down to nk_rnf(ji,jj) 
    309                      IF( jk <= nk_rnf(ji,jj)  ) THEN 
    310                         ze3t_f = ze3t_f - zfact2 * ( - (rnf_b(ji,jj) - rnf(ji,jj)   )  ) & 
    311                     &                            * ( e3t(ji,jj,jk,Kmm) / h_rnf(ji,jj) )  
    312                      ENDIF 
    313                   ELSE 
    314                      IF( jk == 1 ) THEN           ! first level  
    315                         ze3t_f = ze3t_f - zfact2 * ( - (rnf_b(ji,jj)    - rnf(ji,jj)   ) )  
    316                      ENDIF 
    317                   ENDIF 
    318                   ! 
    319                   ! 
    320                   ! solar penetration (temperature only) 
    321                   IF( ll_traqsr .AND. jn == jp_tem .AND. jk <= nksr )                            &  
    322                      &     ztc_f  = ztc_f  - zfact1 * ( qsr_hc(ji,jj,jk) - qsr_hc_b(ji,jj,jk) )  
    323                      ! 
    324                   ! 
    325                   IF( ll_rnf .AND. jk <= nk_rnf(ji,jj) )                                          & 
    326                      &     ztc_f  = ztc_f  - zfact1 * ( rnf_tsc(ji,jj,jn) - rnf_tsc_b(ji,jj,jn) ) &  
    327                      &                              * e3t(ji,jj,jk,Kmm) / h_rnf(ji,jj) 
    328  
    329                   ! 
    330                   ! ice shelf 
    331                   IF( ll_isf ) THEN 
    332                      ! 
    333                      ! melt in the cavity 
    334                      IF ( ln_isfcav_mlt ) THEN 
    335                         ! level fully include in the Losch_2008 ice shelf boundary layer 
    336                         IF ( jk >= misfkt_cav(ji,jj) .AND. jk < misfkb_cav(ji,jj) ) THEN 
    337                            ztc_f  = ztc_f  - zfact1 * ( risf_cav_tsc(ji,jj,jn) - risf_cav_tsc_b(ji,jj,jn) ) & 
    338                               &                     * e3t(ji,jj,jk,Kmm) / rhisf_tbl_cav(ji,jj) 
    339                            ze3t_f = ze3t_f - zfact2 * ( fwfisf_cav_b(ji,jj) - fwfisf_cav(ji,jj) )           & 
    340                               &                     * e3t(ji,jj,jk,Kmm) / rhisf_tbl_cav(ji,jj) 
    341                         END IF 
    342                         ! level partially include in Losch_2008 ice shelf boundary layer  
    343                         IF ( jk == misfkb_cav(ji,jj) ) THEN 
    344                            ztc_f  = ztc_f  - zfact1 * ( risf_cav_tsc(ji,jj,jn) - risf_cav_tsc_b(ji,jj,jn) )  & 
    345                                   &                 * e3t(ji,jj,jk,Kmm) / rhisf_tbl_cav(ji,jj) * rfrac_tbl_cav(ji,jj) 
    346                            ze3t_f = ze3t_f - zfact2 * ( fwfisf_cav_b(ji,jj) - fwfisf_cav(ji,jj) )            & 
    347                               &                     * e3t(ji,jj,jk,Kmm) / rhisf_tbl_cav(ji,jj) * rfrac_tbl_cav(ji,jj) 
    348                         END IF 
    349                      END IF 
    350                      ! 
    351                      ! parametrised melt (cavity closed) 
    352                      IF ( ln_isfpar_mlt ) THEN 
    353                         ! level fully include in the Losch_2008 ice shelf boundary layer 
    354                         IF ( jk >= misfkt_par(ji,jj) .AND. jk < misfkb_par(ji,jj) ) THEN 
    355                            ztc_f  = ztc_f  - zfact1 * ( risf_par_tsc(ji,jj,jn) - risf_par_tsc_b(ji,jj,jn) )  & 
    356                                   &                 * e3t(ji,jj,jk,Kmm) / rhisf_tbl_par(ji,jj) 
    357                            ze3t_f = ze3t_f - zfact2 * ( fwfisf_par_b(ji,jj) - fwfisf_par(ji,jj) )            & 
    358                               &                     * e3t(ji,jj,jk,Kmm) / rhisf_tbl_par(ji,jj) 
    359                         END IF 
    360                         ! level partially include in Losch_2008 ice shelf boundary layer  
    361                         IF ( jk == misfkb_par(ji,jj) ) THEN 
    362                            ztc_f  = ztc_f  - zfact1 * ( risf_par_tsc(ji,jj,jn) - risf_par_tsc_b(ji,jj,jn) )  & 
    363                                   &                 * e3t(ji,jj,jk,Kmm) / rhisf_tbl_par(ji,jj) * rfrac_tbl_par(ji,jj) 
    364                            ze3t_f = ze3t_f - zfact2 * ( fwfisf_par_b(ji,jj) - fwfisf_par(ji,jj) )            & 
    365                               &                     * e3t(ji,jj,jk,Kmm) / rhisf_tbl_par(ji,jj) * rfrac_tbl_par(ji,jj) 
    366                         END IF 
    367                      END IF 
    368                      ! 
    369                      ! ice sheet coupling correction 
    370                      IF ( ln_isfcpl ) THEN 
    371                         ! 
    372                         ! at kt = nit000,  risfcpl_vol_n = 0 and risfcpl_vol_b = risfcpl_vol so contribution nul 
    373                         IF ( ln_rstart .AND. kt == nit000+1 ) THEN 
    374                            ztc_f  = ztc_f  + zfact1 * risfcpl_tsc(ji,jj,jk,jn) * r1_e1e2t(ji,jj) 
    375                            ze3t_f = ze3t_f - zfact1 * risfcpl_vol(ji,jj,jk   ) * r1_e1e2t(ji,jj) 
    376                         END IF 
    377                         ! 
    378                      END IF 
    379                      ! 
     367                  ! at kt = nit000,  risfcpl_vol_n = 0 and risfcpl_vol_b = risfcpl_vol so contribution nul 
     368                  IF ( ln_rstart .AND. kt == nit000+1 ) THEN 
     369                     ztc_f  = ztc_f  + zfact1 * risfcpl_tsc(ji,jj,jk,jn) * r1_e1e2t(ji,jj) 
     370                     ze3t_f = ze3t_f - zfact1 * risfcpl_vol(ji,jj,jk   ) * r1_e1e2t(ji,jj) 
    380371                  END IF 
    381372                  ! 
    382                   ze3t_f = 1.e0 / ze3t_f 
    383                   pt(ji,jj,jk,jn,Kmm) = ztc_f * ze3t_f    ! time filtered "now" field 
    384                   ! 
    385                   IF( ( l_trdtra .and. cdtype == 'TRA' ) .OR. ( l_trdtrc .and. cdtype == 'TRC' ) ) THEN 
    386                      ztrd_atf(ji,jj,jk,jn) = (ztc_f - ztc_n) * zfact/ze3t_n 
    387                   ENDIF 
    388                   ! 
    389                END DO 
    390             END DO 
    391          END DO 
     373               END IF 
     374               ! 
     375            END IF 
     376            ! 
     377            ze3t_f = 1.e0 / ze3t_f 
     378            pt(ji,jj,jk,jn,Kmm) = ztc_f * ze3t_f    ! time filtered "now" field 
     379            ! 
     380            IF( ( l_trdtra .and. cdtype == 'TRA' ) .OR. ( l_trdtrc .and. cdtype == 'TRC' ) ) THEN 
     381               ztrd_atf(ji,jj,jk,jn) = (ztc_f - ztc_n) * zfact/ze3t_n 
     382            ENDIF 
     383            ! 
     384         END_3D 
    392385         !  
    393386      END DO 

  • NEMO/branches/2019/dev_r11943_MERGE_2019/src/OCE/TRA/trabbc.F90

    r12236 r12340  
    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) 
    … …  
    8890      ENDIF 
    8991      !                             !  Add the geothermal trend on temperature 
    90       DO jj = 2, jpjm1 
    91          DO ji = 2, jpim1 
    92             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) 
    93          END DO 
    94       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 
    9595      ! 
    9696      CALL lbc_lnk( 'trabbc', pts(:,:,:,jp_tem,Krhs) , 'T', 1. ) 

  • NEMO/branches/2019/dev_r11943_MERGE_2019/src/OCE/TRA/trabbl.F90

    r12236 r12340  
    6868   !! * Substitutions 
    6969#  include "vectopt_loop_substitute.h90" 
     70#  include "do_loop_substitute.h90" 
    7071   !!---------------------------------------------------------------------- 
    7172   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    191192      DO jn = 1, kjpt                                     ! tracer loop 
    192193         !                                                ! =========== 
    193          DO jj = 1, jpj 
    194             DO ji = 1, jpi 
    195                ik = mbkt(ji,jj)                             ! bottom T-level index 
    196                zptb(ji,jj) = pt(ji,jj,ik,jn)                ! bottom before T and S 
    197             END DO 
    198          END DO 
     194         DO_2D_11_11 
     195            ik = mbkt(ji,jj)                             ! bottom T-level index 
     196            zptb(ji,jj) = pt(ji,jj,ik,jn)                ! bottom before T and S 
     197         END_2D 
    199198         !                
    200          DO jj = 2, jpjm1                                    ! Compute the trend 
    201             DO ji = 2, jpim1 
    202                ik = mbkt(ji,jj)                            ! bottom T-level index 
    203                pt_rhs(ji,jj,ik,jn) = pt_rhs(ji,jj,ik,jn)                                                  & 
    204                   &                + (  ahu_bbl(ji  ,jj  ) * ( zptb(ji+1,jj  ) - zptb(ji  ,jj  ) )     & 
    205                   &                   - ahu_bbl(ji-1,jj  ) * ( zptb(ji  ,jj  ) - zptb(ji-1,jj  ) )     & 
    206                   &                   + ahv_bbl(ji  ,jj  ) * ( zptb(ji  ,jj+1) - zptb(ji  ,jj  ) )     & 
    207                   &                   - ahv_bbl(ji  ,jj-1) * ( zptb(ji  ,jj  ) - zptb(ji  ,jj-1) )  )  & 
    208                   &                * r1_e1e2t(ji,jj) / e3t(ji,jj,ik,Kmm) 
    209             END DO 
    210          END DO 
     199         DO_2D_00_00 
     200            ik = mbkt(ji,jj)                            ! bottom T-level index 
     201            pt_rhs(ji,jj,ik,jn) = pt_rhs(ji,jj,ik,jn)                                                  & 
     202               &                + (  ahu_bbl(ji  ,jj  ) * ( zptb(ji+1,jj  ) - zptb(ji  ,jj  ) )     & 
     203               &                   - ahu_bbl(ji-1,jj  ) * ( zptb(ji  ,jj  ) - zptb(ji-1,jj  ) )     & 
     204               &                   + ahv_bbl(ji  ,jj  ) * ( zptb(ji  ,jj+1) - zptb(ji  ,jj  ) )     & 
     205               &                   - ahv_bbl(ji  ,jj-1) * ( zptb(ji  ,jj  ) - zptb(ji  ,jj-1) )  )  & 
     206               &                * r1_e1e2t(ji,jj) / e3t(ji,jj,ik,Kmm) 
     207         END_2D 
    211208         !                                                  ! =========== 
    212209      END DO                                                ! end tracer 
    … …  
    346343      ENDIF 
    347344      !                                        !* bottom variables (T, S, alpha, beta, depth, velocity) 
    348       DO jj = 1, jpj 
    349          DO ji = 1, jpi 
    350             ik = mbkt(ji,jj)                             ! bottom T-level index 
    351             zts (ji,jj,jp_tem) = ts(ji,jj,ik,jp_tem,Kbb) ! bottom before T and S 
    352             zts (ji,jj,jp_sal) = ts(ji,jj,ik,jp_sal,Kbb) 
    353             ! 
    354             zdep(ji,jj) = gdept(ji,jj,ik,Kmm)            ! bottom T-level reference depth 
    355             zub (ji,jj) = uu(ji,jj,mbku(ji,jj),Kmm)      ! bottom velocity 
    356             zvb (ji,jj) = vv(ji,jj,mbkv(ji,jj),Kmm) 
    357          END DO 
    358       END DO 
     345      DO_2D_11_11 
     346         ik = mbkt(ji,jj)                             ! bottom T-level index 
     347         zts (ji,jj,jp_tem) = ts(ji,jj,ik,jp_tem,Kbb) ! bottom before T and S 
     348         zts (ji,jj,jp_sal) = ts(ji,jj,ik,jp_sal,Kbb) 
     349         ! 
     350         zdep(ji,jj) = gdept(ji,jj,ik,Kmm)            ! bottom T-level reference depth 
     351         zub (ji,jj) = uu(ji,jj,mbku(ji,jj),Kmm)      ! bottom velocity 
     352         zvb (ji,jj) = vv(ji,jj,mbkv(ji,jj),Kmm) 
     353      END_2D 
    359354      ! 
    360355      CALL eos_rab( zts, zdep, zab, Kmm ) 
    … …  
    363358      IF( nn_bbl_ldf == 1 ) THEN          !   diffusive bbl   ! 
    364359         !                                !-------------------! 
    365          DO jj = 1, jpjm1                      ! (criteria for non zero flux: grad(rho).grad(h) < 0 ) 
    366             DO ji = 1, fs_jpim1   ! vector opt. 
    367                !                                                   ! i-direction 
    368                za = zab(ji+1,jj,jp_tem) + zab(ji,jj,jp_tem)              ! 2*(alpha,beta) at u-point 
    369                zb = zab(ji+1,jj,jp_sal) + zab(ji,jj,jp_sal) 
    370                !                                                         ! 2*masked bottom density gradient 
    371                zgdrho = (  za * ( zts(ji+1,jj,jp_tem) - zts(ji,jj,jp_tem) )    & 
    372                   &      - zb * ( zts(ji+1,jj,jp_sal) - zts(ji,jj,jp_sal) )  ) * umask(ji,jj,1) 
    373                ! 
    374                zsign  = SIGN(  0.5, -zgdrho * REAL( mgrhu(ji,jj) )  )    ! sign of ( i-gradient * i-slope ) 
    375                ahu_bbl(ji,jj) = ( 0.5 - zsign ) * ahu_bbl_0(ji,jj)       ! masked diffusive flux coeff. 
    376                ! 
    377                !                                                   ! j-direction 
    378                za = zab(ji,jj+1,jp_tem) + zab(ji,jj,jp_tem)              ! 2*(alpha,beta) at v-point 
    379                zb = zab(ji,jj+1,jp_sal) + zab(ji,jj,jp_sal) 
    380                !                                                         ! 2*masked bottom density gradient 
    381                zgdrho = (  za * ( zts(ji,jj+1,jp_tem) - zts(ji,jj,jp_tem) )    & 
    382                   &      - zb * ( zts(ji,jj+1,jp_sal) - zts(ji,jj,jp_sal) )  ) * vmask(ji,jj,1) 
    383                ! 
    384                zsign = SIGN(  0.5, -zgdrho * REAL( mgrhv(ji,jj) )  )     ! sign of ( j-gradient * j-slope ) 
    385                ahv_bbl(ji,jj) = ( 0.5 - zsign ) * ahv_bbl_0(ji,jj) 
    386             END DO 
    387          END DO 
     360         DO_2D_10_10 
     361            !                                                   ! i-direction 
     362            za = zab(ji+1,jj,jp_tem) + zab(ji,jj,jp_tem)              ! 2*(alpha,beta) at u-point 
     363            zb = zab(ji+1,jj,jp_sal) + zab(ji,jj,jp_sal) 
     364            !                                                         ! 2*masked bottom density gradient 
     365            zgdrho = (  za * ( zts(ji+1,jj,jp_tem) - zts(ji,jj,jp_tem) )    & 
     366               &      - zb * ( zts(ji+1,jj,jp_sal) - zts(ji,jj,jp_sal) )  ) * umask(ji,jj,1) 
     367            ! 
     368            zsign  = SIGN(  0.5, -zgdrho * REAL( mgrhu(ji,jj) )  )    ! sign of ( i-gradient * i-slope ) 
     369            ahu_bbl(ji,jj) = ( 0.5 - zsign ) * ahu_bbl_0(ji,jj)       ! masked diffusive flux coeff. 
     370            ! 
     371            !                                                   ! j-direction 
     372            za = zab(ji,jj+1,jp_tem) + zab(ji,jj,jp_tem)              ! 2*(alpha,beta) at v-point 
     373            zb = zab(ji,jj+1,jp_sal) + zab(ji,jj,jp_sal) 
     374            !                                                         ! 2*masked bottom density gradient 
     375            zgdrho = (  za * ( zts(ji,jj+1,jp_tem) - zts(ji,jj,jp_tem) )    & 
     376               &      - zb * ( zts(ji,jj+1,jp_sal) - zts(ji,jj,jp_sal) )  ) * vmask(ji,jj,1) 
     377            ! 
     378            zsign = SIGN(  0.5, -zgdrho * REAL( mgrhv(ji,jj) )  )     ! sign of ( j-gradient * j-slope ) 
     379            ahv_bbl(ji,jj) = ( 0.5 - zsign ) * ahv_bbl_0(ji,jj) 
     380         END_2D 
    388381         ! 
    389382      ENDIF 
    … …  
    395388         ! 
    396389         CASE( 1 )                                   != use of upper velocity 
    397             DO jj = 1, jpjm1                                 ! criteria: grad(rho).grad(h)<0  and grad(rho).grad(h)<0 
    398                DO ji = 1, fs_jpim1   ! vector opt. 
    399                   !                                                  ! i-direction 
    400                   za = zab(ji+1,jj,jp_tem) + zab(ji,jj,jp_tem)               ! 2*(alpha,beta) at u-point 
    401                   zb = zab(ji+1,jj,jp_sal) + zab(ji,jj,jp_sal) 
    402                   !                                                          ! 2*masked bottom density gradient  
    403                   zgdrho = (  za * ( zts(ji+1,jj,jp_tem) - zts(ji,jj,jp_tem) )    & 
    404                             - zb * ( zts(ji+1,jj,jp_sal) - zts(ji,jj,jp_sal) )  ) * umask(ji,jj,1) 
    405                   ! 
    406                   zsign = SIGN(  0.5, - zgdrho   * REAL( mgrhu(ji,jj) )  )   ! sign of i-gradient * i-slope 
    407                   zsigna= SIGN(  0.5, zub(ji,jj) * REAL( mgrhu(ji,jj) )  )   ! sign of u * i-slope 
    408                   ! 
    409                   !                                                          ! bbl velocity 
    410                   utr_bbl(ji,jj) = ( 0.5 + zsigna ) * ( 0.5 - zsign ) * e2u(ji,jj) * e3u_bbl_0(ji,jj) * zub(ji,jj) 
    411                   ! 
    412                   !                                                  ! j-direction 
    413                   za = zab(ji,jj+1,jp_tem) + zab(ji,jj,jp_tem)               ! 2*(alpha,beta) at v-point 
    414                   zb = zab(ji,jj+1,jp_sal) + zab(ji,jj,jp_sal) 
    415                   !                                                          ! 2*masked bottom density gradient 
    416                   zgdrho = (  za * ( zts(ji,jj+1,jp_tem) - zts(ji,jj,jp_tem) )    & 
    417                      &      - zb * ( zts(ji,jj+1,jp_sal) - zts(ji,jj,jp_sal) )  ) * vmask(ji,jj,1) 
    418                   zsign = SIGN(  0.5, - zgdrho   * REAL( mgrhv(ji,jj) )  )   ! sign of j-gradient * j-slope 
    419                   zsigna= SIGN(  0.5, zvb(ji,jj) * REAL( mgrhv(ji,jj) )  )   ! sign of u * i-slope 
    420                   ! 
    421                   !                                                          ! bbl transport 
    422                   vtr_bbl(ji,jj) = ( 0.5 + zsigna ) * ( 0.5 - zsign ) * e1v(ji,jj) * e3v_bbl_0(ji,jj) * zvb(ji,jj) 
    423                END DO 
    424             END DO 
     390            DO_2D_10_10 
     391               !                                                  ! i-direction 
     392               za = zab(ji+1,jj,jp_tem) + zab(ji,jj,jp_tem)               ! 2*(alpha,beta) at u-point 
     393               zb = zab(ji+1,jj,jp_sal) + zab(ji,jj,jp_sal) 
     394               !                                                          ! 2*masked bottom density gradient  
     395               zgdrho = (  za * ( zts(ji+1,jj,jp_tem) - zts(ji,jj,jp_tem) )    & 
     396                         - zb * ( zts(ji+1,jj,jp_sal) - zts(ji,jj,jp_sal) )  ) * umask(ji,jj,1) 
     397               ! 
     398               zsign = SIGN(  0.5, - zgdrho   * REAL( mgrhu(ji,jj) )  )   ! sign of i-gradient * i-slope 
     399               zsigna= SIGN(  0.5, zub(ji,jj) * REAL( mgrhu(ji,jj) )  )   ! sign of u * i-slope 
     400               ! 
     401               !                                                          ! bbl velocity 
     402               utr_bbl(ji,jj) = ( 0.5 + zsigna ) * ( 0.5 - zsign ) * e2u(ji,jj) * e3u_bbl_0(ji,jj) * zub(ji,jj) 
     403               ! 
     404               !                                                  ! j-direction 
     405               za = zab(ji,jj+1,jp_tem) + zab(ji,jj,jp_tem)               ! 2*(alpha,beta) at v-point 
     406               zb = zab(ji,jj+1,jp_sal) + zab(ji,jj,jp_sal) 
     407               !                                                          ! 2*masked bottom density gradient 
     408               zgdrho = (  za * ( zts(ji,jj+1,jp_tem) - zts(ji,jj,jp_tem) )    & 
     409                  &      - zb * ( zts(ji,jj+1,jp_sal) - zts(ji,jj,jp_sal) )  ) * vmask(ji,jj,1) 
     410               zsign = SIGN(  0.5, - zgdrho   * REAL( mgrhv(ji,jj) )  )   ! sign of j-gradient * j-slope 
     411               zsigna= SIGN(  0.5, zvb(ji,jj) * REAL( mgrhv(ji,jj) )  )   ! sign of u * i-slope 
     412               ! 
     413               !                                                          ! bbl transport 
     414               vtr_bbl(ji,jj) = ( 0.5 + zsigna ) * ( 0.5 - zsign ) * e1v(ji,jj) * e3v_bbl_0(ji,jj) * zvb(ji,jj) 
     415            END_2D 
    425416            ! 
    426417         CASE( 2 )                                 != bbl velocity = F( delta rho ) 
    427418            zgbbl = grav * rn_gambbl 
    428             DO jj = 1, jpjm1                            ! criteria: rho_up > rho_down 
    429                DO ji = 1, fs_jpim1   ! vector opt. 
    430                   !                                                  ! i-direction 
    431                   ! down-slope T-point i/k-index (deep)  &   up-slope T-point i/k-index (shelf) 
    432                   iid  = ji + MAX( 0, mgrhu(ji,jj) ) 
    433                   iis  = ji + 1 - MAX( 0, mgrhu(ji,jj) ) 
    434                   ! 
    435                   ikud = mbku_d(ji,jj) 
    436                   ikus = mbku(ji,jj) 
    437                   ! 
    438                   za = zab(ji+1,jj,jp_tem) + zab(ji,jj,jp_tem)               ! 2*(alpha,beta) at u-point 
    439                   zb = zab(ji+1,jj,jp_sal) + zab(ji,jj,jp_sal) 
    440                   !                                                          !   masked bottom density gradient 
    441                   zgdrho = 0.5 * (  za * ( zts(iid,jj,jp_tem) - zts(iis,jj,jp_tem) )    & 
    442                      &            - zb * ( zts(iid,jj,jp_sal) - zts(iis,jj,jp_sal) )  ) * umask(ji,jj,1) 
    443                   zgdrho = MAX( 0.e0, zgdrho )                               ! only if shelf is denser than deep 
    444                   ! 
    445                   !                                                          ! bbl transport (down-slope direction) 
    446                   utr_bbl(ji,jj) = e2u(ji,jj) * e3u_bbl_0(ji,jj) * zgbbl * zgdrho * REAL( mgrhu(ji,jj) ) 
    447                   ! 
    448                   !                                                  ! j-direction 
    449                   !  down-slope T-point j/k-index (deep)  &   of the up  -slope T-point j/k-index (shelf) 
    450                   ijd  = jj + MAX( 0, mgrhv(ji,jj) ) 
    451                   ijs  = jj + 1 - MAX( 0, mgrhv(ji,jj) ) 
    452                   ! 
    453                   ikvd = mbkv_d(ji,jj) 
    454                   ikvs = mbkv(ji,jj) 
    455                   ! 
    456                   za = zab(ji,jj+1,jp_tem) + zab(ji,jj,jp_tem)               ! 2*(alpha,beta) at v-point 
    457                   zb = zab(ji,jj+1,jp_sal) + zab(ji,jj,jp_sal) 
    458                   !                                                          !   masked bottom density gradient 
    459                   zgdrho = 0.5 * (  za * ( zts(ji,ijd,jp_tem) - zts(ji,ijs,jp_tem) )    & 
    460                      &            - zb * ( zts(ji,ijd,jp_sal) - zts(ji,ijs,jp_sal) )  ) * vmask(ji,jj,1) 
    461                   zgdrho = MAX( 0.e0, zgdrho )                               ! only if shelf is denser than deep 
    462                   ! 
    463                   !                                                          ! bbl transport (down-slope direction) 
    464                   vtr_bbl(ji,jj) = e1v(ji,jj) * e3v_bbl_0(ji,jj) * zgbbl * zgdrho * REAL( mgrhv(ji,jj) ) 
    465                END DO 
    466             END DO 
     419            DO_2D_10_10 
     420               !                                                  ! i-direction 
     421               ! down-slope T-point i/k-index (deep)  &   up-slope T-point i/k-index (shelf) 
     422               iid  = ji + MAX( 0, mgrhu(ji,jj) ) 
     423               iis  = ji + 1 - MAX( 0, mgrhu(ji,jj) ) 
     424               ! 
     425               ikud = mbku_d(ji,jj) 
     426               ikus = mbku(ji,jj) 
     427               ! 
     428               za = zab(ji+1,jj,jp_tem) + zab(ji,jj,jp_tem)               ! 2*(alpha,beta) at u-point 
     429               zb = zab(ji+1,jj,jp_sal) + zab(ji,jj,jp_sal) 
     430               !                                                          !   masked bottom density gradient 
     431               zgdrho = 0.5 * (  za * ( zts(iid,jj,jp_tem) - zts(iis,jj,jp_tem) )    & 
     432                  &            - zb * ( zts(iid,jj,jp_sal) - zts(iis,jj,jp_sal) )  ) * umask(ji,jj,1) 
     433               zgdrho = MAX( 0.e0, zgdrho )                               ! only if shelf is denser than deep 
     434               ! 
     435               !                                                          ! bbl transport (down-slope direction) 
     436               utr_bbl(ji,jj) = e2u(ji,jj) * e3u_bbl_0(ji,jj) * zgbbl * zgdrho * REAL( mgrhu(ji,jj) ) 
     437               ! 
     438               !                                                  ! j-direction 
     439               !  down-slope T-point j/k-index (deep)  &   of the up  -slope T-point j/k-index (shelf) 
     440               ijd  = jj + MAX( 0, mgrhv(ji,jj) ) 
     441               ijs  = jj + 1 - MAX( 0, mgrhv(ji,jj) ) 
     442               ! 
     443               ikvd = mbkv_d(ji,jj) 
     444               ikvs = mbkv(ji,jj) 
     445               ! 
     446               za = zab(ji,jj+1,jp_tem) + zab(ji,jj,jp_tem)               ! 2*(alpha,beta) at v-point 
     447               zb = zab(ji,jj+1,jp_sal) + zab(ji,jj,jp_sal) 
     448               !                                                          !   masked bottom density gradient 
     449               zgdrho = 0.5 * (  za * ( zts(ji,ijd,jp_tem) - zts(ji,ijs,jp_tem) )    & 
     450                  &            - zb * ( zts(ji,ijd,jp_sal) - zts(ji,ijs,jp_sal) )  ) * vmask(ji,jj,1) 
     451               zgdrho = MAX( 0.e0, zgdrho )                               ! only if shelf is denser than deep 
     452               ! 
     453               !                                                          ! bbl transport (down-slope direction) 
     454               vtr_bbl(ji,jj) = e1v(ji,jj) * e3v_bbl_0(ji,jj) * zgbbl * zgdrho * REAL( mgrhv(ji,jj) ) 
     455            END_2D 
    467456         END SELECT 
    468457         ! 
    … …  
    520509      ! 
    521510      !                             !* vertical index of  "deep" bottom u- and v-points 
    522       DO jj = 1, jpjm1                    ! (the "shelf" bottom k-indices are mbku and mbkv) 
    523          DO ji = 1, jpim1 
    524             mbku_d(ji,jj) = MAX(  mbkt(ji+1,jj  ) , mbkt(ji,jj)  )   ! >= 1 as mbkt=1 over land 
    525             mbkv_d(ji,jj) = MAX(  mbkt(ji  ,jj+1) , mbkt(ji,jj)  ) 
    526          END DO 
    527       END DO 
     511      DO_2D_10_10 
     512         mbku_d(ji,jj) = MAX(  mbkt(ji+1,jj  ) , mbkt(ji,jj)  )   ! >= 1 as mbkt=1 over land 
     513         mbkv_d(ji,jj) = MAX(  mbkt(ji  ,jj+1) , mbkt(ji,jj)  ) 
     514      END_2D 
    528515      ! converte into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk 
    529516      zmbku(:,:) = REAL( mbku_d(:,:), wp )   ;     zmbkv(:,:) = REAL( mbkv_d(:,:), wp )   
    … …  
    533520      !                             !* sign of grad(H) at u- and v-points; zero if grad(H) = 0 
    534521      mgrhu(:,:) = 0   ;   mgrhv(:,:) = 0 
    535       DO jj = 1, jpjm1 
    536          DO ji = 1, jpim1 
    537             IF( gdept_0(ji+1,jj,mbkt(ji+1,jj)) - gdept_0(ji,jj,mbkt(ji,jj)) /= 0._wp ) THEN 
    538                mgrhu(ji,jj) = INT(  SIGN( 1.e0, gdept_0(ji+1,jj,mbkt(ji+1,jj)) - gdept_0(ji,jj,mbkt(ji,jj)) )  ) 
    539             ENDIF 
    540             ! 
    541             IF( gdept_0(ji,jj+1,mbkt(ji,jj+1)) - gdept_0(ji,jj,mbkt(ji,jj)) /= 0._wp ) THEN 
    542                mgrhv(ji,jj) = INT(  SIGN( 1.e0, gdept_0(ji,jj+1,mbkt(ji,jj+1)) - gdept_0(ji,jj,mbkt(ji,jj)) )  ) 
    543             ENDIF 
    544          END DO 
    545       END DO 
    546       ! 
    547       DO jj = 1, jpjm1              !* bbl thickness at u- (v-) point 
    548          DO ji = 1, jpim1                 ! minimum of top & bottom e3u_0 (e3v_0) 
    549             e3u_bbl_0(ji,jj) = MIN( e3u_0(ji,jj,mbkt(ji+1,jj  )), e3u_0(ji,jj,mbkt(ji,jj)) ) 
    550             e3v_bbl_0(ji,jj) = MIN( e3v_0(ji,jj,mbkt(ji  ,jj+1)), e3v_0(ji,jj,mbkt(ji,jj)) ) 
    551          END DO 
    552       END DO 
     522      DO_2D_10_10 
     523         IF( gdept_0(ji+1,jj,mbkt(ji+1,jj)) - gdept_0(ji,jj,mbkt(ji,jj)) /= 0._wp ) THEN 
     524            mgrhu(ji,jj) = INT(  SIGN( 1.e0, gdept_0(ji+1,jj,mbkt(ji+1,jj)) - gdept_0(ji,jj,mbkt(ji,jj)) )  ) 
     525         ENDIF 
     526         ! 
     527         IF( gdept_0(ji,jj+1,mbkt(ji,jj+1)) - gdept_0(ji,jj,mbkt(ji,jj)) /= 0._wp ) THEN 
     528            mgrhv(ji,jj) = INT(  SIGN( 1.e0, gdept_0(ji,jj+1,mbkt(ji,jj+1)) - gdept_0(ji,jj,mbkt(ji,jj)) )  ) 
     529         ENDIF 
     530      END_2D 
     531      ! 
     532      DO_2D_10_10 
     533         e3u_bbl_0(ji,jj) = MIN( e3u_0(ji,jj,mbkt(ji+1,jj  )), e3u_0(ji,jj,mbkt(ji,jj)) ) 
     534         e3v_bbl_0(ji,jj) = MIN( e3v_0(ji,jj,mbkt(ji  ,jj+1)), e3v_0(ji,jj,mbkt(ji,jj)) ) 
     535      END_2D 
    553536      CALL lbc_lnk_multi( 'trabbl', e3u_bbl_0, 'U', 1. , e3v_bbl_0, 'V', 1. )      ! lateral boundary conditions 
    554537      ! 

  • NEMO/branches/2019/dev_r11943_MERGE_2019/src/OCE/TRA/tradmp.F90

    r12236 r12340  
    5353   !! * Substitutions 
    5454#  include "vectopt_loop_substitute.h90" 
     55#  include "do_loop_substitute.h90" 
    5556   !!---------------------------------------------------------------------- 
    5657   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    112113      CASE( 0 )                        !*  newtonian damping throughout the water column  *! 
    113114         DO jn = 1, jpts 
    114             DO jk = 1, jpkm1 
    115                DO jj = 2, jpjm1 
    116                   DO ji = fs_2, fs_jpim1   ! vector opt. 
    117                      pts(ji,jj,jk,jn,Krhs) = pts(ji,jj,jk,jn,Krhs)           & 
    118                         &                  + resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jn) - pts(ji,jj,jk,jn,Kbb) ) 
    119                   END DO 
    120                END DO 
    121             END DO 
     115            DO_3D_00_00( 1, jpkm1 ) 
     116               pts(ji,jj,jk,jn,Krhs) = pts(ji,jj,jk,jn,Krhs)           & 
     117                  &                  + resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jn) - pts(ji,jj,jk,jn,Kbb) ) 
     118            END_3D 
    122119         END DO 
    123120         ! 
    124121      CASE ( 1 )                       !*  no damping in the turbocline (avt > 5 cm2/s)  *! 
    125          DO jk = 1, jpkm1 
    126             DO jj = 2, jpjm1 
    127                DO ji = fs_2, fs_jpim1   ! vector opt. 
    128                   IF( avt(ji,jj,jk) <= avt_c ) THEN 
    129                      pts(ji,jj,jk,jp_tem,Krhs) = pts(ji,jj,jk,jp_tem,Krhs)   & 
    130                         &                      + resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jp_tem) - pts(ji,jj,jk,jp_tem,Kbb) ) 
    131                      pts(ji,jj,jk,jp_sal,Krhs) = pts(ji,jj,jk,jp_sal,Krhs)   & 
    132                         &                      + resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jp_sal) - pts(ji,jj,jk,jp_sal,Kbb) ) 
    133                   ENDIF 
    134                END DO 
    135             END DO 
    136          END DO 
     122         DO_3D_00_00( 1, jpkm1 ) 
     123            IF( avt(ji,jj,jk) <= avt_c ) THEN 
     124               pts(ji,jj,jk,jp_tem,Krhs) = pts(ji,jj,jk,jp_tem,Krhs)   & 
     125                  &                      + resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jp_tem) - pts(ji,jj,jk,jp_tem,Kbb) ) 
     126               pts(ji,jj,jk,jp_sal,Krhs) = pts(ji,jj,jk,jp_sal,Krhs)   & 
     127                  &                      + resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jp_sal) - pts(ji,jj,jk,jp_sal,Kbb) ) 
     128            ENDIF 
     129         END_3D 
    137130         ! 
    138131      CASE ( 2 )                       !*  no damping in the mixed layer   *! 
    139          DO jk = 1, jpkm1 
    140             DO jj = 2, jpjm1 
    141                DO ji = fs_2, fs_jpim1   ! vector opt. 
    142                   IF( gdept(ji,jj,jk,Kmm) >= hmlp (ji,jj) ) THEN 
    143                      pts(ji,jj,jk,jp_tem,Krhs) = pts(ji,jj,jk,jp_tem,Krhs)   & 
    144                         &                      + resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jp_tem) - pts(ji,jj,jk,jp_tem,Kbb) ) 
    145                      pts(ji,jj,jk,jp_sal,Krhs) = pts(ji,jj,jk,jp_sal,Krhs)   & 
    146                         &                      + resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jp_sal) - pts(ji,jj,jk,jp_sal,Kbb) ) 
    147                   ENDIF 
    148                END DO 
    149             END DO 
    150          END DO 
     132         DO_3D_00_00( 1, jpkm1 ) 
     133            IF( gdept(ji,jj,jk,Kmm) >= hmlp (ji,jj) ) THEN 
     134               pts(ji,jj,jk,jp_tem,Krhs) = pts(ji,jj,jk,jp_tem,Krhs)   & 
     135                  &                      + resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jp_tem) - pts(ji,jj,jk,jp_tem,Kbb) ) 
     136               pts(ji,jj,jk,jp_sal,Krhs) = pts(ji,jj,jk,jp_sal,Krhs)   & 
     137                  &                      + resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jp_sal) - pts(ji,jj,jk,jp_sal,Kbb) ) 
     138            ENDIF 
     139         END_3D 
    151140         ! 
    152141      END SELECT 

  • NEMO/branches/2019/dev_r11943_MERGE_2019/src/OCE/TRA/traisf.F90

    r12150 r12340  
    2323   !! * Substitutions 
    2424#  include "vectopt_loop_substitute.h90" 
     25#  include "do_loop_substitute.h90" 
    2526   !!---------------------------------------------------------------------- 
    2627   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    107108      ! 
    108109      ! update pts(:,:,:,:,Krhs) 
    109       DO jj = 1,jpj 
    110          DO ji = 1,jpi 
    111             ! 
    112             ikt = ktop(ji,jj) 
    113             ikb = kbot(ji,jj) 
    114             ! 
    115             ! level fully include in the ice shelf boundary layer 
    116             DO jk = ikt, ikb - 1 
    117                pts(ji,jj,jk,jp_tem) = pts(ji,jj,jk,jp_tem) + ztc(ji,jj) 
    118             END DO 
    119             ! 
    120             ! level partially include in ice shelf boundary layer  
    121             pts(ji,jj,ikb,jp_tem) = pts(ji,jj,ikb,jp_tem) + ztc(ji,jj) * pfrac(ji,jj) 
    122             ! 
     110      DO_2D_11_11 
     111         ! 
     112         ikt = ktop(ji,jj) 
     113         ikb = kbot(ji,jj) 
     114         ! 
     115         ! level fully include in the ice shelf boundary layer 
     116         DO jk = ikt, ikb - 1 
     117            pts(ji,jj,jk,jp_tem) = pts(ji,jj,jk,jp_tem) + ztc(ji,jj) 
    123118         END DO 
    124       END DO 
     119         ! 
     120         ! level partially include in ice shelf boundary layer  
     121         pts(ji,jj,ikb,jp_tem) = pts(ji,jj,ikb,jp_tem) + ztc(ji,jj) * pfrac(ji,jj) 
     122         ! 
     123      END_2D 
    125124      ! 
    126125   END SUBROUTINE tra_isf_mlt 

  • NEMO/branches/2019/dev_r11943_MERGE_2019/src/OCE/TRA/traldf_iso.F90

    r12193 r12340  
    4141   !! * Substitutions 
    4242#  include "vectopt_loop_substitute.h90" 
     43#  include "do_loop_substitute.h90" 
    4344   !!---------------------------------------------------------------------- 
    4445   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    145146      IF( kpass == 1 ) THEN                  !==  first pass only  ==! 
    146147         ! 
    147          DO jk = 2, jpkm1 
    148             DO jj = 2, jpjm1 
    149                DO ji = fs_2, fs_jpim1   ! vector opt. 
    150                   ! 
    151                   zmsku = wmask(ji,jj,jk) / MAX(   umask(ji  ,jj,jk-1) + umask(ji-1,jj,jk)          & 
    152                      &                           + umask(ji-1,jj,jk-1) + umask(ji  ,jj,jk) , 1._wp  ) 
    153                   zmskv = wmask(ji,jj,jk) / MAX(   vmask(ji,jj  ,jk-1) + vmask(ji,jj-1,jk)          & 
    154                      &                           + vmask(ji,jj-1,jk-1) + vmask(ji,jj  ,jk) , 1._wp  ) 
    155                      ! 
    156                   zahu_w = (   pahu(ji  ,jj,jk-1) + pahu(ji-1,jj,jk)    & 
    157                      &       + pahu(ji-1,jj,jk-1) + pahu(ji  ,jj,jk)  ) * zmsku 
    158                   zahv_w = (   pahv(ji,jj  ,jk-1) + pahv(ji,jj-1,jk)    & 
    159                      &       + pahv(ji,jj-1,jk-1) + pahv(ji,jj  ,jk)  ) * zmskv 
    160                      ! 
    161                   ah_wslp2(ji,jj,jk) = zahu_w * wslpi(ji,jj,jk) * wslpi(ji,jj,jk)   & 
    162                      &               + zahv_w * wslpj(ji,jj,jk) * wslpj(ji,jj,jk) 
    163                END DO 
    164             END DO 
    165          END DO 
     148         DO_3D_00_00( 2, jpkm1 ) 
     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_3D 
    166163         ! 
    167164         IF( ln_traldf_msc ) THEN                ! stabilizing vertical diffusivity coefficient 
    168             DO jk = 2, jpkm1 
    169                DO jj = 2, jpjm1 
    170                   DO ji = fs_2, fs_jpim1 
    171                      akz(ji,jj,jk) = 0.25_wp * (                                                                     & 
    172                         &              ( pahu(ji  ,jj,jk) + pahu(ji  ,jj,jk-1) ) / ( e1u(ji  ,jj) * e1u(ji  ,jj) )   & 
    173                         &            + ( pahu(ji-1,jj,jk) + pahu(ji-1,jj,jk-1) ) / ( e1u(ji-1,jj) * e1u(ji-1,jj) )   & 
    174                         &            + ( pahv(ji,jj  ,jk) + pahv(ji,jj  ,jk-1) ) / ( e2v(ji,jj  ) * e2v(ji,jj  ) )   & 
    175                         &            + ( pahv(ji,jj-1,jk) + pahv(ji,jj-1,jk-1) ) / ( e2v(ji,jj-1) * e2v(ji,jj-1) )   ) 
    176                   END DO 
    177                END DO 
    178             END DO 
     165            DO_3D_00_00( 2, jpkm1 ) 
     166               akz(ji,jj,jk) = 0.25_wp * (                                                                     & 
     167                  &              ( pahu(ji  ,jj,jk) + pahu(ji  ,jj,jk-1) ) / ( e1u(ji  ,jj) * e1u(ji  ,jj) )   & 
     168                  &            + ( pahu(ji-1,jj,jk) + pahu(ji-1,jj,jk-1) ) / ( e1u(ji-1,jj) * e1u(ji-1,jj) )   & 
     169                  &            + ( pahv(ji,jj  ,jk) + pahv(ji,jj  ,jk-1) ) / ( e2v(ji,jj  ) * e2v(ji,jj  ) )   & 
     170                  &            + ( pahv(ji,jj-1,jk) + pahv(ji,jj-1,jk-1) ) / ( e2v(ji,jj-1) * e2v(ji,jj-1) )   ) 
     171            END_3D 
    179172            ! 
    180173            IF( ln_traldf_blp ) THEN                ! bilaplacian operator 
    181                DO jk = 2, jpkm1 
    182                   DO jj = 1, jpjm1 
    183                      DO ji = 1, fs_jpim1 
    184                         akz(ji,jj,jk) = 16._wp * ah_wslp2(ji,jj,jk)   & 
    185                            &          * (  akz(ji,jj,jk) + ah_wslp2(ji,jj,jk) / ( e3w(ji,jj,jk,Kmm) * e3w(ji,jj,jk,Kmm) )  ) 
    186                      END DO 
    187                   END DO 
    188                END DO 
     174               DO_3D_10_10( 2, jpkm1 ) 
     175                  akz(ji,jj,jk) = 16._wp * ah_wslp2(ji,jj,jk)   & 
     176                     &          * (  akz(ji,jj,jk) + ah_wslp2(ji,jj,jk) / ( e3w(ji,jj,jk,Kmm) * e3w(ji,jj,jk,Kmm) )  ) 
     177               END_3D 
    189178            ELSEIF( ln_traldf_lap ) THEN              ! laplacian operator 
    190                DO jk = 2, jpkm1 
    191                   DO jj = 1, jpjm1 
    192                      DO ji = 1, fs_jpim1 
    193                         ze3w_2 = e3w(ji,jj,jk,Kmm) * e3w(ji,jj,jk,Kmm) 
    194                         zcoef0 = z2dt * (  akz(ji,jj,jk) + ah_wslp2(ji,jj,jk) / ze3w_2  ) 
    195                         akz(ji,jj,jk) = MAX( zcoef0 - 0.5_wp , 0._wp ) * ze3w_2 * z1_2dt 
    196                      END DO 
    197                   END DO 
    198                END DO 
     179               DO_3D_10_10( 2, jpkm1 ) 
     180                  ze3w_2 = e3w(ji,jj,jk,Kmm) * e3w(ji,jj,jk,Kmm) 
     181                  zcoef0 = z2dt * (  akz(ji,jj,jk) + ah_wslp2(ji,jj,jk) / ze3w_2  ) 
     182                  akz(ji,jj,jk) = MAX( zcoef0 - 0.5_wp , 0._wp ) * ze3w_2 * z1_2dt 
     183               END_3D 
    199184           ENDIF 
    200185           ! 
    … …  
    217202 
    218203         ! Horizontal tracer gradient  
    219          DO jk = 1, jpkm1 
    220             DO jj = 1, jpjm1 
    221                DO ji = 1, fs_jpim1   ! vector opt. 
    222                   zdit(ji,jj,jk) = ( pt(ji+1,jj  ,jk,jn) - pt(ji,jj,jk,jn) ) * umask(ji,jj,jk) 
    223                   zdjt(ji,jj,jk) = ( pt(ji  ,jj+1,jk,jn) - pt(ji,jj,jk,jn) ) * vmask(ji,jj,jk) 
    224                END DO 
    225             END DO 
    226          END DO 
     204         DO_3D_10_10( 1, jpkm1 ) 
     205            zdit(ji,jj,jk) = ( pt(ji+1,jj  ,jk,jn) - pt(ji,jj,jk,jn) ) * umask(ji,jj,jk) 
     206            zdjt(ji,jj,jk) = ( pt(ji  ,jj+1,jk,jn) - pt(ji,jj,jk,jn) ) * vmask(ji,jj,jk) 
     207         END_3D 
    227208         IF( ln_zps ) THEN      ! botton and surface ocean correction of the horizontal gradient 
    228             DO jj = 1, jpjm1              ! bottom correction (partial bottom cell) 
    229                DO ji = 1, fs_jpim1   ! vector opt. 
    230                   zdit(ji,jj,mbku(ji,jj)) = pgu(ji,jj,jn)           
    231                   zdjt(ji,jj,mbkv(ji,jj)) = pgv(ji,jj,jn) 
    232                END DO 
    233             END DO 
     209            DO_2D_10_10 
     210               zdit(ji,jj,mbku(ji,jj)) = pgu(ji,jj,jn)           
     211               zdjt(ji,jj,mbkv(ji,jj)) = pgv(ji,jj,jn) 
     212            END_2D 
    234213            IF( ln_isfcav ) THEN      ! first wet level beneath a cavity 
    235                DO jj = 1, jpjm1 
    236                   DO ji = 1, fs_jpim1   ! vector opt. 
    237                      IF( miku(ji,jj) > 1 )   zdit(ji,jj,miku(ji,jj)) = pgui(ji,jj,jn)           
    238                      IF( mikv(ji,jj) > 1 )   zdjt(ji,jj,mikv(ji,jj)) = pgvi(ji,jj,jn)      
    239                   END DO 
    240                END DO 
     214               DO_2D_10_10 
     215                  IF( miku(ji,jj) > 1 )   zdit(ji,jj,miku(ji,jj)) = pgui(ji,jj,jn)           
     216                  IF( mikv(ji,jj) > 1 )   zdjt(ji,jj,mikv(ji,jj)) = pgvi(ji,jj,jn)      
     217               END_2D 
    241218            ENDIF 
    242219         ENDIF 
    … …  
    254231            ELSE                 ;   zdkt(:,:) = ( pt(:,:,jk-1,jn) - pt(:,:,jk,jn) ) * wmask(:,:,jk) 
    255232            ENDIF 
    256             DO jj = 1 , jpjm1            !==  Horizontal fluxes 
    257                DO ji = 1, fs_jpim1   ! vector opt. 
    258                   zabe1 = pahu(ji,jj,jk) * e2_e1u(ji,jj) * e3u(ji,jj,jk,Kmm) 
    259                   zabe2 = pahv(ji,jj,jk) * e1_e2v(ji,jj) * e3v(ji,jj,jk,Kmm) 
    260                   ! 
    261                   zmsku = 1. / MAX(  wmask(ji+1,jj,jk  ) + wmask(ji,jj,jk+1)   & 
    262                      &             + wmask(ji+1,jj,jk+1) + wmask(ji,jj,jk  ), 1. ) 
    263                   ! 
    264                   zmskv = 1. / MAX(  wmask(ji,jj+1,jk  ) + wmask(ji,jj,jk+1)   & 
    265                      &             + wmask(ji,jj+1,jk+1) + wmask(ji,jj,jk  ), 1. ) 
    266                   ! 
    267                   zcof1 = - pahu(ji,jj,jk) * e2u(ji,jj) * uslp(ji,jj,jk) * zmsku 
    268                   zcof2 = - pahv(ji,jj,jk) * e1v(ji,jj) * vslp(ji,jj,jk) * zmskv 
    269                   ! 
    270                   zftu(ji,jj,jk ) = (  zabe1 * zdit(ji,jj,jk)   & 
    271                      &               + zcof1 * (  zdkt (ji+1,jj) + zdk1t(ji,jj)      & 
    272                      &                          + zdk1t(ji+1,jj) + zdkt (ji,jj)  )  ) * umask(ji,jj,jk) 
    273                   zftv(ji,jj,jk) = (  zabe2 * zdjt(ji,jj,jk)   & 
    274                      &               + zcof2 * (  zdkt (ji,jj+1) + zdk1t(ji,jj)      & 
    275                      &                          + zdk1t(ji,jj+1) + zdkt (ji,jj)  )  ) * vmask(ji,jj,jk)                   
    276                END DO 
    277             END DO 
    278             ! 
    279             DO jj = 2 , jpjm1          !== horizontal divergence and add to pt_rhs 
    280                DO ji = fs_2, fs_jpim1   ! vector opt. 
    281                   pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn) + zsign * (  zftu(ji,jj,jk) - zftu(ji-1,jj,jk)      & 
    282                      &                                                 + zftv(ji,jj,jk) - zftv(ji,jj-1,jk)  )   & 
    283                      &                                              * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
    284                END DO 
    285             END DO 
     233            DO_2D_10_10 
     234               zabe1 = pahu(ji,jj,jk) * e2_e1u(ji,jj) * e3u(ji,jj,jk,Kmm) 
     235               zabe2 = pahv(ji,jj,jk) * e1_e2v(ji,jj) * e3v(ji,jj,jk,Kmm) 
     236               ! 
     237               zmsku = 1. / MAX(  wmask(ji+1,jj,jk  ) + wmask(ji,jj,jk+1)   & 
     238                  &             + wmask(ji+1,jj,jk+1) + wmask(ji,jj,jk  ), 1. ) 
     239               ! 
     240               zmskv = 1. / MAX(  wmask(ji,jj+1,jk  ) + wmask(ji,jj,jk+1)   & 
     241                  &             + wmask(ji,jj+1,jk+1) + wmask(ji,jj,jk  ), 1. ) 
     242               ! 
     243               zcof1 = - pahu(ji,jj,jk) * e2u(ji,jj) * uslp(ji,jj,jk) * zmsku 
     244               zcof2 = - pahv(ji,jj,jk) * e1v(ji,jj) * vslp(ji,jj,jk) * zmskv 
     245               ! 
     246               zftu(ji,jj,jk ) = (  zabe1 * zdit(ji,jj,jk)   & 
     247                  &               + zcof1 * (  zdkt (ji+1,jj) + zdk1t(ji,jj)      & 
     248                  &                          + zdk1t(ji+1,jj) + zdkt (ji,jj)  )  ) * umask(ji,jj,jk) 
     249               zftv(ji,jj,jk) = (  zabe2 * zdjt(ji,jj,jk)   & 
     250                  &               + zcof2 * (  zdkt (ji,jj+1) + zdk1t(ji,jj)      & 
     251                  &                          + zdk1t(ji,jj+1) + zdkt (ji,jj)  )  ) * vmask(ji,jj,jk)                   
     252            END_2D 
     253            ! 
     254            DO_2D_00_00 
     255               pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn) + zsign * (  zftu(ji,jj,jk) - zftu(ji-1,jj,jk)      & 
     256                  &                                                 + zftv(ji,jj,jk) - zftv(ji,jj-1,jk)  )   & 
     257                  &                                              * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
     258            END_2D 
    286259         END DO                                        !   End of slab   
    287260 
    … …  
    297270         ztfw(:,:, 1 ) = 0._wp      ;      ztfw(:,:,jpk) = 0._wp 
    298271          
    299          DO jk = 2, jpkm1           ! interior (2=<jk=<jpk-1) 
    300             DO jj = 2, jpjm1 
    301                DO ji = fs_2, fs_jpim1   ! vector opt. 
    302                   ! 
    303                   zmsku = wmask(ji,jj,jk) / MAX(   umask(ji  ,jj,jk-1) + umask(ji-1,jj,jk)          & 
    304                      &                           + umask(ji-1,jj,jk-1) + umask(ji  ,jj,jk) , 1._wp  ) 
    305                   zmskv = wmask(ji,jj,jk) / MAX(   vmask(ji,jj  ,jk-1) + vmask(ji,jj-1,jk)          & 
    306                      &                           + vmask(ji,jj-1,jk-1) + vmask(ji,jj  ,jk) , 1._wp  ) 
    307                      ! 
    308                   zahu_w = (   pahu(ji  ,jj,jk-1) + pahu(ji-1,jj,jk)    & 
    309                      &       + pahu(ji-1,jj,jk-1) + pahu(ji  ,jj,jk)  ) * zmsku 
    310                   zahv_w = (   pahv(ji,jj  ,jk-1) + pahv(ji,jj-1,jk)    & 
    311                      &       + pahv(ji,jj-1,jk-1) + pahv(ji,jj  ,jk)  ) * zmskv 
    312                      ! 
    313                   zcoef3 = - zahu_w * e2t(ji,jj) * zmsku * wslpi (ji,jj,jk)   !wslpi & j are already w-masked 
    314                   zcoef4 = - zahv_w * e1t(ji,jj) * zmskv * wslpj (ji,jj,jk) 
    315                   ! 
    316                   ztfw(ji,jj,jk) = zcoef3 * (   zdit(ji  ,jj  ,jk-1) + zdit(ji-1,jj  ,jk)      & 
    317                      &                        + zdit(ji-1,jj  ,jk-1) + zdit(ji  ,jj  ,jk)  )   & 
    318                      &           + zcoef4 * (   zdjt(ji  ,jj  ,jk-1) + zdjt(ji  ,jj-1,jk)      & 
    319                      &                        + zdjt(ji  ,jj-1,jk-1) + zdjt(ji  ,jj  ,jk)  ) 
    320                END DO 
    321             END DO 
    322          END DO 
     272         DO_3D_00_00( 2, jpkm1 ) 
     273            ! 
     274            zmsku = wmask(ji,jj,jk) / MAX(   umask(ji  ,jj,jk-1) + umask(ji-1,jj,jk)          & 
     275               &                           + umask(ji-1,jj,jk-1) + umask(ji  ,jj,jk) , 1._wp  ) 
     276            zmskv = wmask(ji,jj,jk) / MAX(   vmask(ji,jj  ,jk-1) + vmask(ji,jj-1,jk)          & 
     277               &                           + vmask(ji,jj-1,jk-1) + vmask(ji,jj  ,jk) , 1._wp  ) 
     278               ! 
     279            zahu_w = (   pahu(ji  ,jj,jk-1) + pahu(ji-1,jj,jk)    & 
     280               &       + pahu(ji-1,jj,jk-1) + pahu(ji  ,jj,jk)  ) * zmsku 
     281            zahv_w = (   pahv(ji,jj  ,jk-1) + pahv(ji,jj-1,jk)    & 
     282               &       + pahv(ji,jj-1,jk-1) + pahv(ji,jj  ,jk)  ) * zmskv 
     283               ! 
     284            zcoef3 = - zahu_w * e2t(ji,jj) * zmsku * wslpi (ji,jj,jk)   !wslpi & j are already w-masked 
     285            zcoef4 = - zahv_w * e1t(ji,jj) * zmskv * wslpj (ji,jj,jk) 
     286            ! 
     287            ztfw(ji,jj,jk) = zcoef3 * (   zdit(ji  ,jj  ,jk-1) + zdit(ji-1,jj  ,jk)      & 
     288               &                        + zdit(ji-1,jj  ,jk-1) + zdit(ji  ,jj  ,jk)  )   & 
     289               &           + zcoef4 * (   zdjt(ji  ,jj  ,jk-1) + zdjt(ji  ,jj-1,jk)      & 
     290               &                        + zdjt(ji  ,jj-1,jk-1) + zdjt(ji  ,jj  ,jk)  ) 
     291         END_3D 
    323292         !                                !==  add the vertical 33 flux  ==! 
    324293         IF( ln_traldf_lap ) THEN               ! laplacian case: eddy coef = ah_wslp2 - akz 
    325             DO jk = 2, jpkm1        
    326                DO jj = 2, jpjm1 
    327                   DO ji = fs_2, fs_jpim1 
    328                      ztfw(ji,jj,jk) = ztfw(ji,jj,jk) + e1e2t(ji,jj) / e3w(ji,jj,jk,Kmm) * wmask(ji,jj,jk)   & 
    329                         &                            * ( ah_wslp2(ji,jj,jk) - akz(ji,jj,jk) )               & 
    330                         &                            * (  pt(ji,jj,jk-1,jn) -  pt(ji,jj,jk,jn) ) 
    331                   END DO 
    332                END DO 
    333             END DO 
     294            DO_3D_00_00( 2, jpkm1 ) 
     295               ztfw(ji,jj,jk) = ztfw(ji,jj,jk) + e1e2t(ji,jj) / e3w(ji,jj,jk,Kmm) * wmask(ji,jj,jk)   & 
     296                  &                            * ( ah_wslp2(ji,jj,jk) - akz(ji,jj,jk) )               & 
     297                  &                            * (  pt(ji,jj,jk-1,jn) -  pt(ji,jj,jk,jn) ) 
     298            END_3D 
    334299            ! 
    335300         ELSE                                   ! bilaplacian  
    336301            SELECT CASE( kpass ) 
    337302            CASE(  1  )                            ! 1st pass : eddy coef = ah_wslp2 
    338                DO jk = 2, jpkm1  
    339                   DO jj = 2, jpjm1 
    340                      DO ji = fs_2, fs_jpim1 
    341                         ztfw(ji,jj,jk) = ztfw(ji,jj,jk)                       & 
    342                            &           + ah_wslp2(ji,jj,jk)  * e1e2t(ji,jj)   & 
    343                            &           * ( pt(ji,jj,jk-1,jn) - pt(ji,jj,jk,jn) ) / e3w(ji,jj,jk,Kmm) * wmask(ji,jj,jk) 
    344                      END DO 
    345                   END DO 
    346                END DO  
     303               DO_3D_00_00( 2, jpkm1 ) 
     304                  ztfw(ji,jj,jk) = ztfw(ji,jj,jk)                       & 
     305                     &           + ah_wslp2(ji,jj,jk)  * e1e2t(ji,jj)   & 
     306                     &           * ( pt(ji,jj,jk-1,jn) - pt(ji,jj,jk,jn) ) / e3w(ji,jj,jk,Kmm) * wmask(ji,jj,jk) 
     307               END_3D 
    347308            CASE(  2  )                         ! 2nd pass : eddy flux = ah_wslp2 and akz applied on pt  and pt2 gradients, resp. 
    348                DO jk = 2, jpkm1  
    349                   DO jj = 2, jpjm1 
    350                      DO ji = fs_2, fs_jpim1 
    351                         ztfw(ji,jj,jk) = ztfw(ji,jj,jk) + e1e2t(ji,jj) / e3w(ji,jj,jk,Kmm) * wmask(ji,jj,jk)                  & 
    352                            &                            * (  ah_wslp2(ji,jj,jk) * ( pt (ji,jj,jk-1,jn) - pt (ji,jj,jk,jn) )   & 
    353                            &                            +         akz(ji,jj,jk) * ( pt2(ji,jj,jk-1,jn) - pt2(ji,jj,jk,jn) )   ) 
    354                      END DO 
    355                   END DO 
    356                END DO 
     309               DO_3D_00_00( 2, jpkm1 ) 
     310                  ztfw(ji,jj,jk) = ztfw(ji,jj,jk) + e1e2t(ji,jj) / e3w(ji,jj,jk,Kmm) * wmask(ji,jj,jk)                  & 
     311                     &                            * (  ah_wslp2(ji,jj,jk) * ( pt (ji,jj,jk-1,jn) - pt (ji,jj,jk,jn) )   & 
     312                     &                            +         akz(ji,jj,jk) * ( pt2(ji,jj,jk-1,jn) - pt2(ji,jj,jk,jn) )   ) 
     313               END_3D 
    357314            END SELECT 
    358315         ENDIF 
    359316         !          
    360          DO jk = 1, jpkm1                 !==  Divergence of vertical fluxes added to pt_rhs  ==! 
    361             DO jj = 2, jpjm1 
    362                DO ji = fs_2, fs_jpim1   ! vector opt. 
    363                   pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn) + zsign * (  ztfw (ji,jj,jk) - ztfw(ji,jj,jk+1)  )   & 
    364                      &                                              * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
    365                END DO 
    366             END DO 
    367          END DO 
     317         DO_3D_00_00( 1, jpkm1 ) 
     318            pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn) + zsign * (  ztfw (ji,jj,jk) - ztfw(ji,jj,jk+1)  )   & 
     319               &                                              * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
     320         END_3D 
    368321         ! 
    369322         IF( ( kpass == 1 .AND. ln_traldf_lap ) .OR.  &     !==  first pass only (  laplacian)  ==! 

  • NEMO/branches/2019/dev_r11943_MERGE_2019/src/OCE/TRA/traldf_lap_blp.F90

    r12193 r12340  
    3838   !! * Substitutions 
    3939#  include "vectopt_loop_substitute.h90" 
     40#  include "do_loop_substitute.h90" 
    4041   !!---------------------------------------------------------------------- 
    4142   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    9899      ELSE                    ;   zsign = -1._wp 
    99100      ENDIF 
    100       DO jk = 1, jpkm1 
    101          DO jj = 1, jpjm1 
    102             DO ji = 1, fs_jpim1   ! vector opt. 
    103                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! 
    104                zaheev(ji,jj,jk) = zsign * pahv(ji,jj,jk) * e1_e2v(ji,jj) * e3v(ji,jj,jk,Kmm)   !!gm   * vmask(ji,jj,jk) 
    105             END DO 
    106          END DO 
    107       END DO 
     101      DO_3D_10_10( 1, jpkm1 ) 
     102         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! 
     103         zaheev(ji,jj,jk) = zsign * pahv(ji,jj,jk) * e1_e2v(ji,jj) * e3v(ji,jj,jk,Kmm)   !!gm   * vmask(ji,jj,jk) 
     104      END_3D 
    108105      ! 
    109106      !                             ! =========== ! 
    … …  
    111108         !                          ! =========== !     
    112109         !                                
    113          DO jk = 1, jpkm1              !== First derivative (gradient)  ==! 
    114             DO jj = 1, jpjm1 
    115                DO ji = 1, fs_jpim1 
    116                   ztu(ji,jj,jk) = zaheeu(ji,jj,jk) * ( pt(ji+1,jj  ,jk,jn) - pt(ji,jj,jk,jn) ) 
    117                   ztv(ji,jj,jk) = zaheev(ji,jj,jk) * ( pt(ji  ,jj+1,jk,jn) - pt(ji,jj,jk,jn) ) 
    118                END DO 
    119             END DO 
    120          END DO   
     110         DO_3D_10_10( 1, jpkm1 ) 
     111            ztu(ji,jj,jk) = zaheeu(ji,jj,jk) * ( pt(ji+1,jj  ,jk,jn) - pt(ji,jj,jk,jn) ) 
     112            ztv(ji,jj,jk) = zaheev(ji,jj,jk) * ( pt(ji  ,jj+1,jk,jn) - pt(ji,jj,jk,jn) ) 
     113         END_3D 
    121114         IF( ln_zps ) THEN                ! set gradient at bottom/top ocean level 
    122             DO jj = 1, jpjm1                    ! bottom 
    123                DO ji = 1, fs_jpim1 
    124                   ztu(ji,jj,mbku(ji,jj)) = zaheeu(ji,jj,mbku(ji,jj)) * pgu(ji,jj,jn) 
    125                   ztv(ji,jj,mbkv(ji,jj)) = zaheev(ji,jj,mbkv(ji,jj)) * pgv(ji,jj,jn) 
    126                END DO 
    127             END DO   
     115            DO_2D_10_10 
     116               ztu(ji,jj,mbku(ji,jj)) = zaheeu(ji,jj,mbku(ji,jj)) * pgu(ji,jj,jn) 
     117               ztv(ji,jj,mbkv(ji,jj)) = zaheev(ji,jj,mbkv(ji,jj)) * pgv(ji,jj,jn) 
     118            END_2D 
    128119            IF( ln_isfcav ) THEN                ! top in ocean cavities only 
    129                DO jj = 1, jpjm1 
    130                   DO ji = 1, fs_jpim1   ! vector opt. 
    131                      IF( miku(ji,jj) > 1 )   ztu(ji,jj,miku(ji,jj)) = zaheeu(ji,jj,miku(ji,jj)) * pgui(ji,jj,jn)  
    132                      IF( mikv(ji,jj) > 1 )   ztv(ji,jj,mikv(ji,jj)) = zaheev(ji,jj,mikv(ji,jj)) * pgvi(ji,jj,jn)  
    133                   END DO 
    134                END DO 
     120               DO_2D_10_10 
     121                  IF( miku(ji,jj) > 1 )   ztu(ji,jj,miku(ji,jj)) = zaheeu(ji,jj,miku(ji,jj)) * pgui(ji,jj,jn)  
     122                  IF( mikv(ji,jj) > 1 )   ztv(ji,jj,mikv(ji,jj)) = zaheev(ji,jj,mikv(ji,jj)) * pgvi(ji,jj,jn)  
     123               END_2D 
    135124            ENDIF 
    136125         ENDIF 
    137126         ! 
    138          DO jk = 1, jpkm1              !== Second derivative (divergence) added to the general tracer trends  ==! 
    139             DO jj = 2, jpjm1 
    140                DO ji = fs_2, fs_jpim1 
    141                   pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn) + (  ztu(ji,jj,jk) - ztu(ji-1,jj,jk)     & 
    142                      &                                      +    ztv(ji,jj,jk) - ztv(ji,jj-1,jk) )   & 
    143                      &                                      / ( e1e2t(ji,jj) * e3t(ji,jj,jk,Kmm) ) 
    144                END DO 
    145             END DO 
    146          END DO   
     127         DO_3D_00_00( 1, jpkm1 ) 
     128            pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn) + (  ztu(ji,jj,jk) - ztu(ji-1,jj,jk)     & 
     129               &                                      +    ztv(ji,jj,jk) - ztv(ji,jj-1,jk) )   & 
     130               &                                      / ( e1e2t(ji,jj) * e3t(ji,jj,jk,Kmm) ) 
     131         END_3D 
    147132         ! 
    148133         !                             !== "Poleward" diffusive heat or salt transports  ==! 

  • NEMO/branches/2019/dev_r11943_MERGE_2019/src/OCE/TRA/traldf_triad.F90

    r12193 r12340  
    4141   !! * Substitutions 
    4242#  include "vectopt_loop_substitute.h90" 
     43#  include "do_loop_substitute.h90" 
    4344   !!---------------------------------------------------------------------- 
    4445   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    140141         DO ip = 0, 1                            ! i-k triads 
    141142            DO kp = 0, 1 
    142                DO jk = 1, jpkm1 
    143                   DO jj = 1, jpjm1 
    144                      DO ji = 1, fs_jpim1 
    145                         ze3wr = 1._wp / e3w(ji+ip,jj,jk+kp,Kmm) 
    146                         zbu   = e1e2u(ji,jj) * e3u(ji,jj,jk,Kmm) 
    147                         zah   = 0.25_wp * pahu(ji,jj,jk) 
    148                         zslope_skew = triadi_g(ji+ip,jj,jk,1-ip,kp) 
    149                         ! Subtract s-coordinate slope at t-points to give slope rel to s-surfaces (do this by *adding* gradient of depth) 
    150                         zslope2 = zslope_skew + ( gdept(ji+1,jj,jk,Kmm) - gdept(ji,jj,jk,Kmm) ) * r1_e1u(ji,jj) * umask(ji,jj,jk+kp) 
    151                         zslope2 = zslope2 *zslope2 
    152                         ah_wslp2(ji+ip,jj,jk+kp) = ah_wslp2(ji+ip,jj,jk+kp) + zah * zbu * ze3wr * r1_e1e2t(ji+ip,jj) * zslope2 
    153                         akz     (ji+ip,jj,jk+kp) = akz     (ji+ip,jj,jk+kp) + zah * r1_e1u(ji,jj)       & 
    154                            &                                                      * r1_e1u(ji,jj) * umask(ji,jj,jk+kp) 
    155                            ! 
    156                        IF( ln_ldfeiv_dia )   zpsi_uw(ji,jj,jk+kp) = zpsi_uw(ji,jj,jk+kp)   & 
    157                            &                                       + 0.25_wp * aeiu(ji,jj,jk) * e2u(ji,jj) * zslope_skew 
    158                      END DO 
    159                   END DO 
    160                END DO 
     143               DO_3D_10_10( 1, jpkm1 ) 
     144                  ze3wr = 1._wp / e3w(ji+ip,jj,jk+kp,Kmm) 
     145                  zbu   = e1e2u(ji,jj) * e3u(ji,jj,jk,Kmm) 
     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(ji+1,jj,jk,Kmm) - gdept(ji,jj,jk,Kmm) ) * 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_3D 
    161158            END DO 
    162159         END DO 
    … …  
    164161         DO jp = 0, 1                            ! j-k triads  
    165162            DO kp = 0, 1 
    166                DO jk = 1, jpkm1 
    167                   DO jj = 1, jpjm1 
    168                      DO ji = 1, fs_jpim1 
    169                         ze3wr = 1.0_wp / e3w(ji,jj+jp,jk+kp,Kmm) 
    170                         zbv   = e1e2v(ji,jj) * e3v(ji,jj,jk,Kmm) 
    171                         zah   = 0.25_wp * pahv(ji,jj,jk) 
    172                         zslope_skew = triadj_g(ji,jj+jp,jk,1-jp,kp) 
    173                         ! Subtract s-coordinate slope at t-points to give slope rel to s surfaces 
    174                         !    (do this by *adding* gradient of depth) 
    175                         zslope2 = zslope_skew + ( gdept(ji,jj+1,jk,Kmm) - gdept(ji,jj,jk,Kmm) ) * r1_e2v(ji,jj) * vmask(ji,jj,jk+kp) 
    176                         zslope2 = zslope2 * zslope2 
    177                         ah_wslp2(ji,jj+jp,jk+kp) = ah_wslp2(ji,jj+jp,jk+kp) + zah * zbv * ze3wr * r1_e1e2t(ji,jj+jp) * zslope2 
    178                         akz     (ji,jj+jp,jk+kp) = akz     (ji,jj+jp,jk+kp) + zah * r1_e2v(ji,jj)     & 
    179                            &                                                      * r1_e2v(ji,jj) * vmask(ji,jj,jk+kp) 
    180                         ! 
    181                         IF( ln_ldfeiv_dia )   zpsi_vw(ji,jj,jk+kp) = zpsi_vw(ji,jj,jk+kp)   & 
    182                            &                                       + 0.25 * aeiv(ji,jj,jk) * e1v(ji,jj) * zslope_skew 
    183                      END DO 
    184                   END DO 
    185                END DO 
     163               DO_3D_10_10( 1, jpkm1 ) 
     164                  ze3wr = 1.0_wp / e3w(ji,jj+jp,jk+kp,Kmm) 
     165                  zbv   = e1e2v(ji,jj) * e3v(ji,jj,jk,Kmm) 
     166                  zah   = 0.25_wp * pahv(ji,jj,jk) 
     167                  zslope_skew = triadj_g(ji,jj+jp,jk,1-jp,kp) 
     168                  ! Subtract s-coordinate slope at t-points to give slope rel to s surfaces 
     169                  !    (do this by *adding* gradient of depth) 
     170                  zslope2 = zslope_skew + ( gdept(ji,jj+1,jk,Kmm) - gdept(ji,jj,jk,Kmm) ) * r1_e2v(ji,jj) * vmask(ji,jj,jk+kp) 
     171                  zslope2 = zslope2 * zslope2 
     172                  ah_wslp2(ji,jj+jp,jk+kp) = ah_wslp2(ji,jj+jp,jk+kp) + zah * zbv * ze3wr * r1_e1e2t(ji,jj+jp) * zslope2 
     173                  akz     (ji,jj+jp,jk+kp) = akz     (ji,jj+jp,jk+kp) + zah * r1_e2v(ji,jj)     & 
     174                     &                                                      * r1_e2v(ji,jj) * vmask(ji,jj,jk+kp) 
     175                  ! 
     176                  IF( ln_ldfeiv_dia )   zpsi_vw(ji,jj,jk+kp) = zpsi_vw(ji,jj,jk+kp)   & 
     177                     &                                       + 0.25 * aeiv(ji,jj,jk) * e1v(ji,jj) * zslope_skew 
     178               END_3D 
    186179            END DO 
    187180         END DO 
    … …  
    190183            ! 
    191184            IF( ln_traldf_blp ) THEN                ! bilaplacian operator 
    192                DO jk = 2, jpkm1 
    193                   DO jj = 1, jpjm1 
    194                      DO ji = 1, fs_jpim1 
    195                         akz(ji,jj,jk) = 16._wp * ah_wslp2(ji,jj,jk)   & 
    196                            &          * (  akz(ji,jj,jk) + ah_wslp2(ji,jj,jk) / ( e3w(ji,jj,jk,Kmm) * e3w(ji,jj,jk,Kmm) )  ) 
    197                      END DO 
    198                   END DO 
    199                END DO 
     185               DO_3D_10_10( 2, jpkm1 ) 
     186                  akz(ji,jj,jk) = 16._wp * ah_wslp2(ji,jj,jk)   & 
     187                     &          * (  akz(ji,jj,jk) + ah_wslp2(ji,jj,jk) / ( e3w(ji,jj,jk,Kmm) * e3w(ji,jj,jk,Kmm) )  ) 
     188               END_3D 
    200189            ELSEIF( ln_traldf_lap ) THEN              ! laplacian operator 
    201                DO jk = 2, jpkm1 
    202                   DO jj = 1, jpjm1 
    203                      DO ji = 1, fs_jpim1 
    204                         ze3w_2 = e3w(ji,jj,jk,Kmm) * e3w(ji,jj,jk,Kmm) 
    205                         zcoef0 = z2dt * (  akz(ji,jj,jk) + ah_wslp2(ji,jj,jk) / ze3w_2  ) 
    206                         akz(ji,jj,jk) = MAX( zcoef0 - 0.5_wp , 0._wp ) * ze3w_2 * z1_2dt 
    207                      END DO 
    208                   END DO 
    209                END DO 
     190               DO_3D_10_10( 2, jpkm1 ) 
     191                  ze3w_2 = e3w(ji,jj,jk,Kmm) * e3w(ji,jj,jk,Kmm) 
     192                  zcoef0 = z2dt * (  akz(ji,jj,jk) + ah_wslp2(ji,jj,jk) / ze3w_2  ) 
     193                  akz(ji,jj,jk) = MAX( zcoef0 - 0.5_wp , 0._wp ) * ze3w_2 * z1_2dt 
     194               END_3D 
    210195           ENDIF 
    211196           ! 
    … …  
    227212         zftv(:,:,:) = 0._wp 
    228213         ! 
    229          DO jk = 1, jpkm1        !==  before lateral T & S gradients at T-level jk  ==! 
    230             DO jj = 1, jpjm1 
    231                DO ji = 1, fs_jpim1   ! vector opt. 
    232                   zdit(ji,jj,jk) = ( pt(ji+1,jj  ,jk,jn) - pt(ji,jj,jk,jn) ) * umask(ji,jj,jk) 
    233                   zdjt(ji,jj,jk) = ( pt(ji  ,jj+1,jk,jn) - pt(ji,jj,jk,jn) ) * vmask(ji,jj,jk) 
    234                END DO 
    235             END DO 
    236          END DO 
     214         DO_3D_10_10( 1, jpkm1 ) 
     215            zdit(ji,jj,jk) = ( pt(ji+1,jj  ,jk,jn) - pt(ji,jj,jk,jn) ) * umask(ji,jj,jk) 
     216            zdjt(ji,jj,jk) = ( pt(ji  ,jj+1,jk,jn) - pt(ji,jj,jk,jn) ) * vmask(ji,jj,jk) 
     217         END_3D 
    237218         IF( ln_zps .AND. l_grad_zps ) THEN    ! partial steps: correction at top/bottom ocean level 
    238             DO jj = 1, jpjm1                       ! bottom level 
    239                DO ji = 1, fs_jpim1   ! vector opt. 
    240                   zdit(ji,jj,mbku(ji,jj)) = pgu(ji,jj,jn) 
    241                   zdjt(ji,jj,mbkv(ji,jj)) = pgv(ji,jj,jn) 
    242                END DO 
    243             END DO 
     219            DO_2D_10_10 
     220               zdit(ji,jj,mbku(ji,jj)) = pgu(ji,jj,jn) 
     221               zdjt(ji,jj,mbkv(ji,jj)) = pgv(ji,jj,jn) 
     222            END_2D 
    244223            IF( ln_isfcav ) THEN                   ! top level (ocean cavities only) 
    245                DO jj = 1, jpjm1 
    246                   DO ji = 1, fs_jpim1   ! vector opt. 
    247                      IF( miku(ji,jj)  > 1 )   zdit(ji,jj,miku(ji,jj) ) = pgui(ji,jj,jn)  
    248                      IF( mikv(ji,jj)  > 1 )   zdjt(ji,jj,mikv(ji,jj) ) = pgvi(ji,jj,jn)  
    249                   END DO 
    250                END DO 
     224               DO_2D_10_10 
     225                  IF( miku(ji,jj)  > 1 )   zdit(ji,jj,miku(ji,jj) ) = pgui(ji,jj,jn)  
     226                  IF( mikv(ji,jj)  > 1 )   zdjt(ji,jj,mikv(ji,jj) ) = pgvi(ji,jj,jn)  
     227               END_2D 
    251228            ENDIF 
    252229         ENDIF 
    … …  
    270247               DO ip = 0, 1              !==  Horizontal & vertical fluxes 
    271248                  DO kp = 0, 1 
    272                      DO jj = 1, jpjm1 
    273                         DO ji = 1, fs_jpim1 
    274                            ze1ur = r1_e1u(ji,jj) 
    275                            zdxt  = zdit(ji,jj,jk) * ze1ur 
    276                            ze3wr = 1._wp / e3w(ji+ip,jj,jk+kp,Kmm) 
    277                            zdzt  = zdkt3d(ji+ip,jj,kp) * ze3wr 
    278                            zslope_skew = triadi_g(ji+ip,jj,jk,1-ip,kp) 
    279                            zslope_iso  = triadi  (ji+ip,jj,jk,1-ip,kp) 
    280                            ! 
    281                            zbu = 0.25_wp * e1e2u(ji,jj) * e3u(ji,jj,jk,Kmm) 
    282                            ! ln_botmix_triad is .T. don't mask zah for bottom half cells    !!gm ?????   ahu is masked.... 
    283                            zah = pahu(ji,jj,jk) 
    284                            zah_slp  = zah * zslope_iso 
    285                            IF( ln_ldfeiv )   zaei_slp = aeiu(ji,jj,jk) * zslope_skew 
    286                            zftu(ji   ,jj,jk   ) = zftu(ji   ,jj,jk   ) - ( zah * zdxt + (zah_slp - zaei_slp) * zdzt ) * zbu * ze1ur 
    287                            ztfw(ji+ip,jj,jk+kp) = ztfw(ji+ip,jj,jk+kp) - ( zah_slp + zaei_slp) * zdxt                 * zbu * ze3wr 
    288                         END DO 
    289                      END DO 
     249                     DO_2D_10_10 
     250                        ze1ur = r1_e1u(ji,jj) 
     251                        zdxt  = zdit(ji,jj,jk) * ze1ur 
     252                        ze3wr = 1._wp / e3w(ji+ip,jj,jk+kp,Kmm) 
     253                        zdzt  = zdkt3d(ji+ip,jj,kp) * ze3wr 
     254                        zslope_skew = triadi_g(ji+ip,jj,jk,1-ip,kp) 
     255                        zslope_iso  = triadi  (ji+ip,jj,jk,1-ip,kp) 
     256                        ! 
     257                        zbu = 0.25_wp * e1e2u(ji,jj) * e3u(ji,jj,jk,Kmm) 
     258                        ! ln_botmix_triad is .T. don't mask zah for bottom half cells    !!gm ?????   ahu is masked.... 
     259                        zah = pahu(ji,jj,jk) 
     260                        zah_slp  = zah * zslope_iso 
     261                        IF( ln_ldfeiv )   zaei_slp = aeiu(ji,jj,jk) * zslope_skew 
     262                        zftu(ji   ,jj,jk   ) = zftu(ji   ,jj,jk   ) - ( zah * zdxt + (zah_slp - zaei_slp) * zdzt ) * zbu * ze1ur 
     263                        ztfw(ji+ip,jj,jk+kp) = ztfw(ji+ip,jj,jk+kp) - ( zah_slp + zaei_slp) * zdxt                 * zbu * ze3wr 
     264                     END_2D 
    290265                  END DO 
    291266               END DO 
    … …  
    293268               DO jp = 0, 1 
    294269                  DO kp = 0, 1 
    295                      DO jj = 1, jpjm1 
    296                         DO ji = 1, fs_jpim1 
    297                            ze2vr = r1_e2v(ji,jj) 
    298                            zdyt  = zdjt(ji,jj,jk) * ze2vr 
    299                            ze3wr = 1._wp / e3w(ji,jj+jp,jk+kp,Kmm) 
    300                            zdzt  = zdkt3d(ji,jj+jp,kp) * ze3wr 
    301                            zslope_skew = triadj_g(ji,jj+jp,jk,1-jp,kp) 
    302                            zslope_iso  = triadj(ji,jj+jp,jk,1-jp,kp) 
    303                            zbv = 0.25_wp * e1e2v(ji,jj) * e3v(ji,jj,jk,Kmm) 
    304                            ! ln_botmix_triad is .T. don't mask zah for bottom half cells    !!gm ?????  ahv is masked... 
    305                            zah = pahv(ji,jj,jk) 
    306                            zah_slp = zah * zslope_iso 
    307                            IF( ln_ldfeiv )   zaei_slp = aeiv(ji,jj,jk) * zslope_skew 
    308                            zftv(ji,jj   ,jk   ) = zftv(ji,jj   ,jk   ) - ( zah * zdyt + (zah_slp - zaei_slp) * zdzt ) * zbv * ze2vr 
    309                            ztfw(ji,jj+jp,jk+kp) = ztfw(ji,jj+jp,jk+kp) - ( zah_slp + zaei_slp ) * zdyt                * zbv * ze3wr 
    310                         END DO 
    311                      END DO 
     270                     DO_2D_10_10 
     271                        ze2vr = r1_e2v(ji,jj) 
     272                        zdyt  = zdjt(ji,jj,jk) * ze2vr 
     273                        ze3wr = 1._wp / e3w(ji,jj+jp,jk+kp,Kmm) 
     274                        zdzt  = zdkt3d(ji,jj+jp,kp) * ze3wr 
     275                        zslope_skew = triadj_g(ji,jj+jp,jk,1-jp,kp) 
     276                        zslope_iso  = triadj(ji,jj+jp,jk,1-jp,kp) 
     277                        zbv = 0.25_wp * e1e2v(ji,jj) * e3v(ji,jj,jk,Kmm) 
     278                        ! ln_botmix_triad is .T. don't mask zah for bottom half cells    !!gm ?????  ahv is masked... 
     279                        zah = pahv(ji,jj,jk) 
     280                        zah_slp = zah * zslope_iso 
     281                        IF( ln_ldfeiv )   zaei_slp = aeiv(ji,jj,jk) * zslope_skew 
     282                        zftv(ji,jj   ,jk   ) = zftv(ji,jj   ,jk   ) - ( zah * zdyt + (zah_slp - zaei_slp) * zdzt ) * zbv * ze2vr 
     283                        ztfw(ji,jj+jp,jk+kp) = ztfw(ji,jj+jp,jk+kp) - ( zah_slp + zaei_slp ) * zdyt                * zbv * ze3wr 
     284                     END_2D 
    312285                  END DO 
    313286               END DO 
    … …  
    317290               DO ip = 0, 1               !==  Horizontal & vertical fluxes 
    318291                  DO kp = 0, 1 
    319                      DO jj = 1, jpjm1 
    320                         DO ji = 1, fs_jpim1 
    321                            ze1ur = r1_e1u(ji,jj) 
    322                            zdxt  = zdit(ji,jj,jk) * ze1ur 
    323                            ze3wr = 1._wp / e3w(ji+ip,jj,jk+kp,Kmm) 
    324                            zdzt  = zdkt3d(ji+ip,jj,kp) * ze3wr 
    325                            zslope_skew = triadi_g(ji+ip,jj,jk,1-ip,kp) 
    326                            zslope_iso  = triadi(ji+ip,jj,jk,1-ip,kp) 
    327                            ! 
    328                            zbu = 0.25_wp * e1e2u(ji,jj) * e3u(ji,jj,jk,Kmm) 
    329                            ! ln_botmix_triad is .F. mask zah for bottom half cells 
    330                            zah = pahu(ji,jj,jk) * umask(ji,jj,jk+kp)         ! pahu(ji+ip,jj,jk)   ===>>  ???? 
    331                            zah_slp  = zah * zslope_iso 
    332                            IF( ln_ldfeiv )   zaei_slp = aeiu(ji,jj,jk) * zslope_skew        ! aeit(ji+ip,jj,jk)*zslope_skew 
    333                            zftu(ji   ,jj,jk   ) = zftu(ji   ,jj,jk   ) - ( zah * zdxt + (zah_slp - zaei_slp) * zdzt ) * zbu * ze1ur 
    334                            ztfw(ji+ip,jj,jk+kp) = ztfw(ji+ip,jj,jk+kp) - (zah_slp + zaei_slp) * zdxt * zbu * ze3wr 
    335                         END DO 
    336                      END DO 
     292                     DO_2D_10_10 
     293                        ze1ur = r1_e1u(ji,jj) 
     294                        zdxt  = zdit(ji,jj,jk) * ze1ur 
     295                        ze3wr = 1._wp / e3w(ji+ip,jj,jk+kp,Kmm) 
     296                        zdzt  = zdkt3d(ji+ip,jj,kp) * ze3wr 
     297                        zslope_skew = triadi_g(ji+ip,jj,jk,1-ip,kp) 
     298                        zslope_iso  = triadi(ji+ip,jj,jk,1-ip,kp) 
     299                        ! 
     300                        zbu = 0.25_wp * e1e2u(ji,jj) * e3u(ji,jj,jk,Kmm) 
     301                        ! ln_botmix_triad is .F. mask zah for bottom half cells 
     302                        zah = pahu(ji,jj,jk) * umask(ji,jj,jk+kp)         ! pahu(ji+ip,jj,jk)   ===>>  ???? 
     303                        zah_slp  = zah * zslope_iso 
     304                        IF( ln_ldfeiv )   zaei_slp = aeiu(ji,jj,jk) * zslope_skew        ! aeit(ji+ip,jj,jk)*zslope_skew 
     305                        zftu(ji   ,jj,jk   ) = zftu(ji   ,jj,jk   ) - ( zah * zdxt + (zah_slp - zaei_slp) * zdzt ) * zbu * ze1ur 
     306                        ztfw(ji+ip,jj,jk+kp) = ztfw(ji+ip,jj,jk+kp) - (zah_slp + zaei_slp) * zdxt * zbu * ze3wr 
     307                     END_2D 
    337308                  END DO 
    338309               END DO 
    … …  
    340311               DO jp = 0, 1 
    341312                  DO kp = 0, 1 
    342                      DO jj = 1, jpjm1 
    343                         DO ji = 1, fs_jpim1 
    344                            ze2vr = r1_e2v(ji,jj) 
    345                            zdyt  = zdjt(ji,jj,jk) * ze2vr 
    346                            ze3wr = 1._wp / e3w(ji,jj+jp,jk+kp,Kmm) 
    347                            zdzt  = zdkt3d(ji,jj+jp,kp) * ze3wr 
    348                            zslope_skew = triadj_g(ji,jj+jp,jk,1-jp,kp) 
    349                            zslope_iso  = triadj(ji,jj+jp,jk,1-jp,kp) 
    350                            zbv = 0.25_wp * e1e2v(ji,jj) * e3v(ji,jj,jk,Kmm) 
    351                            ! ln_botmix_triad is .F. mask zah for bottom half cells 
    352                            zah = pahv(ji,jj,jk) * vmask(ji,jj,jk+kp)         ! pahv(ji,jj+jp,jk)  ???? 
    353                            zah_slp = zah * zslope_iso 
    354                            IF( ln_ldfeiv )   zaei_slp = aeiv(ji,jj,jk) * zslope_skew        ! aeit(ji,jj+jp,jk)*zslope_skew 
    355                            zftv(ji,jj,jk) = zftv(ji,jj,jk) - ( zah * zdyt + (zah_slp - zaei_slp) * zdzt ) * zbv * ze2vr 
    356                            ztfw(ji,jj+jp,jk+kp) = ztfw(ji,jj+jp,jk+kp) - (zah_slp + zaei_slp) * zdyt * zbv * ze3wr 
    357                         END DO 
    358                      END DO 
     313                     DO_2D_10_10 
     314                        ze2vr = r1_e2v(ji,jj) 
     315                        zdyt  = zdjt(ji,jj,jk) * ze2vr 
     316                        ze3wr = 1._wp / e3w(ji,jj+jp,jk+kp,Kmm) 
     317                        zdzt  = zdkt3d(ji,jj+jp,kp) * ze3wr 
     318                        zslope_skew = triadj_g(ji,jj+jp,jk,1-jp,kp) 
     319                        zslope_iso  = triadj(ji,jj+jp,jk,1-jp,kp) 
     320                        zbv = 0.25_wp * e1e2v(ji,jj) * e3v(ji,jj,jk,Kmm) 
     321                        ! ln_botmix_triad is .F. mask zah for bottom half cells 
     322                        zah = pahv(ji,jj,jk) * vmask(ji,jj,jk+kp)         ! pahv(ji,jj+jp,jk)  ???? 
     323                        zah_slp = zah * zslope_iso 
     324                        IF( ln_ldfeiv )   zaei_slp = aeiv(ji,jj,jk) * zslope_skew        ! aeit(ji,jj+jp,jk)*zslope_skew 
     325                        zftv(ji,jj,jk) = zftv(ji,jj,jk) - ( zah * zdyt + (zah_slp - zaei_slp) * zdzt ) * zbv * ze2vr 
     326                        ztfw(ji,jj+jp,jk+kp) = ztfw(ji,jj+jp,jk+kp) - (zah_slp + zaei_slp) * zdyt * zbv * ze3wr 
     327                     END_2D 
    359328                  END DO 
    360329               END DO 
    361330            ENDIF 
    362331            !                             !==  horizontal divergence and add to the general trend  ==! 
    363             DO jj = 2 , jpjm1 
    364                DO ji = fs_2, fs_jpim1  ! vector opt. 
    365                   pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn) + zsign * (  zftu(ji-1,jj,jk) - zftu(ji,jj,jk)       & 
    366                      &                                           + zftv(ji,jj-1,jk) - zftv(ji,jj,jk)   )   & 
    367                      &                                        / (  e1e2t(ji,jj) * e3t(ji,jj,jk,Kmm)  ) 
    368                END DO 
    369             END DO 
     332            DO_2D_00_00 
     333               pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn) + zsign * (  zftu(ji-1,jj,jk) - zftu(ji,jj,jk)       & 
     334                  &                                           + zftv(ji,jj-1,jk) - zftv(ji,jj,jk)   )   & 
     335                  &                                        / (  e1e2t(ji,jj) * e3t(ji,jj,jk,Kmm)  ) 
     336            END_2D 
    370337            ! 
    371338         END DO 
    … …  
    373340         !                                !==  add the vertical 33 flux  ==! 
    374341         IF( ln_traldf_lap ) THEN               ! laplacian case: eddy coef = ah_wslp2 - akz 
    375             DO jk = 2, jpkm1        
    376                DO jj = 1, jpjm1 
    377                   DO ji = fs_2, fs_jpim1 
    378                      ztfw(ji,jj,jk) = ztfw(ji,jj,jk) - e1e2t(ji,jj) / e3w(ji,jj,jk,Kmm) * tmask(ji,jj,jk)   & 
    379                         &                            * ( ah_wslp2(ji,jj,jk) - akz(ji,jj,jk) )             & 
    380                         &                            * (  pt(ji,jj,jk-1,jn) - pt(ji,jj,jk,jn) ) 
    381                   END DO 
    382                END DO 
    383             END DO 
     342            DO_3D_10_00( 2, jpkm1 ) 
     343               ztfw(ji,jj,jk) = ztfw(ji,jj,jk) - e1e2t(ji,jj) / e3w(ji,jj,jk,Kmm) * tmask(ji,jj,jk)   & 
     344                  &                            * ( ah_wslp2(ji,jj,jk) - akz(ji,jj,jk) )             & 
     345                  &                            * (  pt(ji,jj,jk-1,jn) - pt(ji,jj,jk,jn) ) 
     346            END_3D 
    384347         ELSE                                   ! bilaplacian  
    385348            SELECT CASE( kpass ) 
    386349            CASE(  1  )                            ! 1st pass : eddy coef = ah_wslp2 
    387                DO jk = 2, jpkm1  
    388                   DO jj = 1, jpjm1 
    389                      DO ji = fs_2, fs_jpim1 
    390                         ztfw(ji,jj,jk) = ztfw(ji,jj,jk) - e1e2t(ji,jj) / e3w(ji,jj,jk,Kmm) * tmask(ji,jj,jk)             & 
    391                            &                            * ah_wslp2(ji,jj,jk) * ( pt(ji,jj,jk-1,jn) - pt(ji,jj,jk,jn) ) 
    392                      END DO 
    393                   END DO 
    394                END DO  
     350               DO_3D_10_00( 2, jpkm1 ) 
     351                  ztfw(ji,jj,jk) = ztfw(ji,jj,jk) - e1e2t(ji,jj) / e3w(ji,jj,jk,Kmm) * tmask(ji,jj,jk)             & 
     352                     &                            * ah_wslp2(ji,jj,jk) * ( pt(ji,jj,jk-1,jn) - pt(ji,jj,jk,jn) ) 
     353               END_3D 
    395354            CASE(  2  )                            ! 2nd pass : eddy flux = ah_wslp2 and akz applied on pt  and pt2 gradients, resp. 
    396                DO jk = 2, jpkm1  
    397                   DO jj = 1, jpjm1 
    398                      DO ji = fs_2, fs_jpim1 
    399                         ztfw(ji,jj,jk) = ztfw(ji,jj,jk) - e1e2t(ji,jj) / e3w(ji,jj,jk,Kmm) * tmask(ji,jj,jk)                      & 
    400                            &                            * (  ah_wslp2(ji,jj,jk) * ( pt (ji,jj,jk-1,jn) - pt (ji,jj,jk,jn) )   & 
    401                            &                               + akz     (ji,jj,jk) * ( pt2(ji,jj,jk-1,jn) - pt2(ji,jj,jk,jn) )   ) 
    402                      END DO 
    403                   END DO 
    404                END DO 
     355               DO_3D_10_00( 2, jpkm1 ) 
     356                  ztfw(ji,jj,jk) = ztfw(ji,jj,jk) - e1e2t(ji,jj) / e3w(ji,jj,jk,Kmm) * tmask(ji,jj,jk)                      & 
     357                     &                            * (  ah_wslp2(ji,jj,jk) * ( pt (ji,jj,jk-1,jn) - pt (ji,jj,jk,jn) )   & 
     358                     &                               + akz     (ji,jj,jk) * ( pt2(ji,jj,jk-1,jn) - pt2(ji,jj,jk,jn) )   ) 
     359               END_3D 
    405360            END SELECT  
    406361         ENDIF 
    407362         ! 
    408          DO jk = 1, jpkm1                 !==  Divergence of vertical fluxes added to pt_rhs  ==! 
    409             DO jj = 2, jpjm1 
    410                DO ji = fs_2, fs_jpim1  ! vector opt. 
    411                   pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn) + zsign * (  ztfw(ji,jj,jk+1) - ztfw(ji,jj,jk)  )   & 
    412                      &                                              / ( e1e2t(ji,jj) * e3t(ji,jj,jk,Kmm) ) 
    413                END DO 
    414             END DO 
    415          END DO 
     363         DO_3D_00_00( 1, jpkm1 ) 
     364            pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn) + zsign * (  ztfw(ji,jj,jk+1) - ztfw(ji,jj,jk)  )   & 
     365               &                                              / ( e1e2t(ji,jj) * e3t(ji,jj,jk,Kmm) ) 
     366         END_3D 
    416367         ! 
    417368         IF( ( kpass == 1 .AND. ln_traldf_lap ) .OR.  &     !==  first pass only (  laplacian)  ==! 

  • NEMO/branches/2019/dev_r11943_MERGE_2019/src/OCE/TRA/tramle.F90

    r11960 r12340  
    4949   !! * Substitutions 
    5050#  include "vectopt_loop_substitute.h90" 
     51#  include "do_loop_substitute.h90" 
    5152   !!---------------------------------------------------------------------- 
    5253   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    99100      inml_mle(:,:) = mbkt(:,:) + 1                    ! init. to number of ocean w-level (T-level + 1) 
    100101      IF ( nla10 > 0 ) THEN                            ! avoid case where first level is thicker than 10m 
    101          DO jk = jpkm1, nlb10, -1                      ! from the bottom to nlb10 (10m) 
    102             DO jj = 1, jpj 
    103                DO ji = 1, jpi                          ! index of the w-level at the ML based 
    104                   IF( rhop(ji,jj,jk) > rhop(ji,jj,nla10) + rn_rho_c_mle )   inml_mle(ji,jj) = jk      ! Mixed layer 
    105                END DO 
    106             END DO 
    107          END DO 
     102         DO_3DS_11_11( jpkm1, nlb10, -1 ) 
     103            IF( rhop(ji,jj,jk) > rhop(ji,jj,nla10) + rn_rho_c_mle )   inml_mle(ji,jj) = jk      ! Mixed layer 
     104         END_3D 
    108105      ENDIF 
    109106      ikmax = MIN( MAXVAL( inml_mle(:,:) ), jpkm1 )                  ! max level of the computation 
    … …  
    113110      zbm (:,:) = 0._wp 
    114111      zn2 (:,:) = 0._wp 
    115       DO jk = 1, ikmax                                 ! MLD and mean buoyancy and N2 over the mixed layer 
    116          DO jj = 1, jpj 
    117             DO ji = 1, jpi 
    118                zc = e3t(ji,jj,jk,Kmm) * REAL( MIN( MAX( 0, inml_mle(ji,jj)-jk ) , 1  )  )    ! zc being 0 outside the ML t-points 
    119                zmld(ji,jj) = zmld(ji,jj) + zc 
    120                zbm (ji,jj) = zbm (ji,jj) + zc * (rau0 - rhop(ji,jj,jk) ) * r1_rau0 
    121                zn2 (ji,jj) = zn2 (ji,jj) + zc * (rn2(ji,jj,jk)+rn2(ji,jj,jk+1))*0.5_wp 
    122             END DO 
    123          END DO 
    124       END DO 
     112      DO_3D_11_11( 1, ikmax ) 
     113         zc = e3t(ji,jj,jk,Kmm) * REAL( MIN( MAX( 0, inml_mle(ji,jj)-jk ) , 1  )  )    ! zc being 0 outside the ML t-points 
     114         zmld(ji,jj) = zmld(ji,jj) + zc 
     115         zbm (ji,jj) = zbm (ji,jj) + zc * (rau0 - rhop(ji,jj,jk) ) * r1_rau0 
     116         zn2 (ji,jj) = zn2 (ji,jj) + zc * (rn2(ji,jj,jk)+rn2(ji,jj,jk+1))*0.5_wp 
     117      END_3D 
    125118 
    126119      SELECT CASE( nn_mld_uv )                         ! MLD at u- & v-pts 
    127120      CASE ( 0 )                                               != min of the 2 neighbour MLDs 
    128          DO jj = 1, jpjm1 
    129             DO ji = 1, fs_jpim1   ! vector opt. 
    130                zhu(ji,jj) = MIN( zmld(ji+1,jj), zmld(ji,jj) ) 
    131                zhv(ji,jj) = MIN( zmld(ji,jj+1), zmld(ji,jj) ) 
    132             END DO 
    133          END DO 
     121         DO_2D_10_10 
     122            zhu(ji,jj) = MIN( zmld(ji+1,jj), zmld(ji,jj) ) 
     123            zhv(ji,jj) = MIN( zmld(ji,jj+1), zmld(ji,jj) ) 
     124         END_2D 
    134125      CASE ( 1 )                                               != average of the 2 neighbour MLDs 
    135          DO jj = 1, jpjm1 
    136             DO ji = 1, fs_jpim1   ! vector opt. 
    137                zhu(ji,jj) = ( zmld(ji+1,jj) + zmld(ji,jj) ) * 0.5_wp 
    138                zhv(ji,jj) = ( zmld(ji,jj+1) + zmld(ji,jj) ) * 0.5_wp 
    139             END DO 
    140          END DO 
     126         DO_2D_10_10 
     127            zhu(ji,jj) = ( zmld(ji+1,jj) + zmld(ji,jj) ) * 0.5_wp 
     128            zhv(ji,jj) = ( zmld(ji,jj+1) + zmld(ji,jj) ) * 0.5_wp 
     129         END_2D 
    141130      CASE ( 2 )                                               != max of the 2 neighbour MLDs 
    142          DO jj = 1, jpjm1 
    143             DO ji = 1, fs_jpim1   ! vector opt. 
    144                zhu(ji,jj) = MAX( zmld(ji+1,jj), zmld(ji,jj) ) 
    145                zhv(ji,jj) = MAX( zmld(ji,jj+1), zmld(ji,jj) ) 
    146             END DO 
    147          END DO 
     131         DO_2D_10_10 
     132            zhu(ji,jj) = MAX( zmld(ji+1,jj), zmld(ji,jj) ) 
     133            zhv(ji,jj) = MAX( zmld(ji,jj+1), zmld(ji,jj) ) 
     134         END_2D 
    148135      END SELECT 
    149136      !                                                ! convert density into buoyancy 
    … …  
    159146      ! 
    160147      IF( nn_mle == 0 ) THEN           ! Fox-Kemper et al. 2010 formulation 
    161          DO jj = 1, jpjm1 
    162             DO ji = 1, fs_jpim1   ! vector opt. 
    163                zpsim_u(ji,jj) = rn_ce * zhu(ji,jj) * zhu(ji,jj)  * e2_e1u(ji,jj)                                            & 
    164                   &           * ( zbm(ji+1,jj) - zbm(ji,jj) ) * MIN( 111.e3_wp , e1u(ji,jj) )   & 
    165                   &           / (  MAX( rn_lf * rfu(ji,jj) , SQRT( rb_c * zhu(ji,jj) ) )   ) 
    166                   ! 
    167                zpsim_v(ji,jj) = rn_ce * zhv(ji,jj) * zhv(ji,jj)  * e1_e2v(ji,jj)                                            & 
    168                   &           * ( zbm(ji,jj+1) - zbm(ji,jj) ) * MIN( 111.e3_wp , e2v(ji,jj) )   & 
    169                   &           / (  MAX( rn_lf * rfv(ji,jj) , SQRT( rb_c * zhv(ji,jj) ) )   ) 
    170             END DO 
    171          END DO 
     148         DO_2D_10_10 
     149            zpsim_u(ji,jj) = rn_ce * zhu(ji,jj) * zhu(ji,jj)  * e2_e1u(ji,jj)                                            & 
     150               &           * ( zbm(ji+1,jj) - zbm(ji,jj) ) * MIN( 111.e3_wp , e1u(ji,jj) )   & 
     151               &           / (  MAX( rn_lf * rfu(ji,jj) , SQRT( rb_c * zhu(ji,jj) ) )   ) 
     152               ! 
     153            zpsim_v(ji,jj) = rn_ce * zhv(ji,jj) * zhv(ji,jj)  * e1_e2v(ji,jj)                                            & 
     154               &           * ( zbm(ji,jj+1) - zbm(ji,jj) ) * MIN( 111.e3_wp , e2v(ji,jj) )   & 
     155               &           / (  MAX( rn_lf * rfv(ji,jj) , SQRT( rb_c * zhv(ji,jj) ) )   ) 
     156         END_2D 
    172157         ! 
    173158      ELSEIF( nn_mle == 1 ) THEN       ! New formulation (Lf = 5km fo/ff with fo=Coriolis parameter at latitude rn_lat) 
    174          DO jj = 1, jpjm1 
    175             DO ji = 1, fs_jpim1   ! vector opt. 
    176                zpsim_u(ji,jj) = rc_f *   zhu(ji,jj)   * zhu(ji,jj)   * e2_e1u(ji,jj)               & 
    177                   &                  * ( zbm(ji+1,jj) - zbm(ji,jj) ) * MIN( 111.e3_wp , e1u(ji,jj) ) 
    178                   ! 
    179                zpsim_v(ji,jj) = rc_f *   zhv(ji,jj)   * zhv(ji,jj)   * e1_e2v(ji,jj)               & 
    180                   &                  * ( zbm(ji,jj+1) - zbm(ji,jj) ) * MIN( 111.e3_wp , e2v(ji,jj) ) 
    181             END DO 
    182          END DO 
     159         DO_2D_10_10 
     160            zpsim_u(ji,jj) = rc_f *   zhu(ji,jj)   * zhu(ji,jj)   * e2_e1u(ji,jj)               & 
     161               &                  * ( zbm(ji+1,jj) - zbm(ji,jj) ) * MIN( 111.e3_wp , e1u(ji,jj) ) 
     162               ! 
     163            zpsim_v(ji,jj) = rc_f *   zhv(ji,jj)   * zhv(ji,jj)   * e1_e2v(ji,jj)               & 
     164               &                  * ( zbm(ji,jj+1) - zbm(ji,jj) ) * MIN( 111.e3_wp , e2v(ji,jj) ) 
     165         END_2D 
    183166      ENDIF 
    184167      ! 
    185168      IF( nn_conv == 1 ) THEN              ! No MLE in case of convection 
    186          DO jj = 1, jpjm1 
    187             DO ji = 1, fs_jpim1   ! vector opt. 
    188                IF( MIN( zn2(ji,jj) , zn2(ji+1,jj) ) < 0._wp )   zpsim_u(ji,jj) = 0._wp 
    189                IF( MIN( zn2(ji,jj) , zn2(ji,jj+1) ) < 0._wp )   zpsim_v(ji,jj) = 0._wp 
    190             END DO 
    191          END DO 
     169         DO_2D_10_10 
     170            IF( MIN( zn2(ji,jj) , zn2(ji+1,jj) ) < 0._wp )   zpsim_u(ji,jj) = 0._wp 
     171            IF( MIN( zn2(ji,jj) , zn2(ji,jj+1) ) < 0._wp )   zpsim_v(ji,jj) = 0._wp 
     172         END_2D 
    192173      ENDIF 
    193174      ! 
    194175      !                                      !==  structure function value at uw- and vw-points  ==! 
    195       DO jj = 1, jpjm1 
    196          DO ji = 1, fs_jpim1   ! vector opt. 
    197             zhu(ji,jj) = 1._wp / zhu(ji,jj)                   ! hu --> 1/hu 
    198             zhv(ji,jj) = 1._wp / zhv(ji,jj) 
    199          END DO 
    200       END DO 
     176      DO_2D_10_10 
     177         zhu(ji,jj) = 1._wp / zhu(ji,jj)                   ! hu --> 1/hu 
     178         zhv(ji,jj) = 1._wp / zhv(ji,jj) 
     179      END_2D 
    201180      ! 
    202181      zpsi_uw(:,:,:) = 0._wp 
    203182      zpsi_vw(:,:,:) = 0._wp 
    204183      ! 
    205       DO jk = 2, ikmax                                ! start from 2 : surface value = 0 
    206          DO jj = 1, jpjm1 
    207             DO ji = 1, fs_jpim1   ! vector opt. 
    208                zcuw = 1._wp - ( gdepw(ji+1,jj,jk,Kmm) + gdepw(ji,jj,jk,Kmm) ) * zhu(ji,jj) 
    209                zcvw = 1._wp - ( gdepw(ji,jj+1,jk,Kmm) + gdepw(ji,jj,jk,Kmm) ) * zhv(ji,jj) 
    210                zcuw = zcuw * zcuw 
    211                zcvw = zcvw * zcvw 
    212                zmuw = MAX(  0._wp , ( 1._wp - zcuw ) * ( 1._wp + r5_21 * zcuw )  ) 
    213                zmvw = MAX(  0._wp , ( 1._wp - zcvw ) * ( 1._wp + r5_21 * zcvw )  ) 
    214                ! 
    215                zpsi_uw(ji,jj,jk) = zpsim_u(ji,jj) * zmuw * umask(ji,jj,jk) 
    216                zpsi_vw(ji,jj,jk) = zpsim_v(ji,jj) * zmvw * vmask(ji,jj,jk) 
    217             END DO 
    218          END DO 
    219       END DO 
     184      DO_3D_10_10( 2, ikmax ) 
     185         zcuw = 1._wp - ( gdepw(ji+1,jj,jk,Kmm) + gdepw(ji,jj,jk,Kmm) ) * zhu(ji,jj) 
     186         zcvw = 1._wp - ( gdepw(ji,jj+1,jk,Kmm) + gdepw(ji,jj,jk,Kmm) ) * zhv(ji,jj) 
     187         zcuw = zcuw * zcuw 
     188         zcvw = zcvw * zcvw 
     189         zmuw = MAX(  0._wp , ( 1._wp - zcuw ) * ( 1._wp + r5_21 * zcuw )  ) 
     190         zmvw = MAX(  0._wp , ( 1._wp - zcvw ) * ( 1._wp + r5_21 * zcvw )  ) 
     191         ! 
     192         zpsi_uw(ji,jj,jk) = zpsim_u(ji,jj) * zmuw * umask(ji,jj,jk) 
     193         zpsi_vw(ji,jj,jk) = zpsim_v(ji,jj) * zmvw * vmask(ji,jj,jk) 
     194      END_3D 
    220195      ! 
    221196      !                                      !==  transport increased by the MLE induced transport ==! 
    222197      DO jk = 1, ikmax 
    223          DO jj = 1, jpjm1                          ! CAUTION pu,pv must be defined at row/column i=1 / j=1 
    224             DO ji = 1, fs_jpim1   ! vector opt. 
    225                pu(ji,jj,jk) = pu(ji,jj,jk) + ( zpsi_uw(ji,jj,jk) - zpsi_uw(ji,jj,jk+1) ) 
    226                pv(ji,jj,jk) = pv(ji,jj,jk) + ( zpsi_vw(ji,jj,jk) - zpsi_vw(ji,jj,jk+1) ) 
    227             END DO 
    228          END DO 
    229          DO jj = 2, jpjm1 
    230             DO ji = fs_2, fs_jpim1   ! vector opt. 
    231                pw(ji,jj,jk) = pw(ji,jj,jk) - ( zpsi_uw(ji,jj,jk) - zpsi_uw(ji-1,jj,jk)   & 
    232                   &                          + zpsi_vw(ji,jj,jk) - zpsi_vw(ji,jj-1,jk) ) 
    233             END DO 
    234          END DO 
     198         DO_2D_10_10 
     199            pu(ji,jj,jk) = pu(ji,jj,jk) + ( zpsi_uw(ji,jj,jk) - zpsi_uw(ji,jj,jk+1) ) 
     200            pv(ji,jj,jk) = pv(ji,jj,jk) + ( zpsi_vw(ji,jj,jk) - zpsi_vw(ji,jj,jk+1) ) 
     201         END_2D 
     202         DO_2D_00_00 
     203            pw(ji,jj,jk) = pw(ji,jj,jk) - ( zpsi_uw(ji,jj,jk) - zpsi_uw(ji-1,jj,jk)   & 
     204               &                          + zpsi_vw(ji,jj,jk) - zpsi_vw(ji,jj-1,jk) ) 
     205         END_2D 
    235206      END DO 
    236207 
    … …  
    312283            IF( ierr /= 0 )   CALL ctl_stop( 'tra_adv_mle_init: failed to allocate arrays' ) 
    313284            z1_t2 = 1._wp / ( rn_time * rn_time ) 
    314             DO jj = 2, jpj                           ! "coriolis+ time^-1" at u- & v-points 
    315                DO ji = fs_2, jpi   ! vector opt. 
    316                   zfu = ( ff_f(ji,jj) + ff_f(ji,jj-1) ) * 0.5_wp 
    317                   zfv = ( ff_f(ji,jj) + ff_f(ji-1,jj) ) * 0.5_wp 
    318                   rfu(ji,jj) = SQRT(  zfu * zfu + z1_t2 ) 
    319                   rfv(ji,jj) = SQRT(  zfv * zfv + z1_t2 ) 
    320                END DO 
    321             END DO 
     285            DO_2D_01_01 
     286               zfu = ( ff_f(ji,jj) + ff_f(ji,jj-1) ) * 0.5_wp 
     287               zfv = ( ff_f(ji,jj) + ff_f(ji-1,jj) ) * 0.5_wp 
     288               rfu(ji,jj) = SQRT(  zfu * zfu + z1_t2 ) 
     289               rfv(ji,jj) = SQRT(  zfv * zfv + z1_t2 ) 
     290            END_2D 
    322291            CALL lbc_lnk_multi( 'tramle', rfu, 'U', 1. , rfv, 'V', 1. ) 
    323292            ! 

  • NEMO/branches/2019/dev_r11943_MERGE_2019/src/OCE/TRA/tranpc.F90

    r11949 r12340  
    3535   !! * Substitutions 
    3636#  include "vectopt_loop_substitute.h90" 
     37#  include "do_loop_substitute.h90" 
    3738   !!---------------------------------------------------------------------- 
    3839   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    102103         inpcc = 0 
    103104         ! 
    104          DO jj = 2, jpjm1                 ! interior column only 
    105             DO ji = fs_2, fs_jpim1 
     105         DO_2D_00_00 
     106            ! 
     107            IF( tmask(ji,jj,2) == 1 ) THEN      ! At least 2 ocean points 
     108               !                                     ! consider one ocean column  
     109               zvts(:,jp_tem) = pts(ji,jj,:,jp_tem,Kaa)      ! temperature 
     110               zvts(:,jp_sal) = pts(ji,jj,:,jp_sal,Kaa)      ! salinity 
    106111               ! 
    107                IF( tmask(ji,jj,2) == 1 ) THEN      ! At least 2 ocean points 
    108                   !                                     ! consider one ocean column  
    109                   zvts(:,jp_tem) = pts(ji,jj,:,jp_tem,Kaa)      ! temperature 
    110                   zvts(:,jp_sal) = pts(ji,jj,:,jp_sal,Kaa)      ! salinity 
    111                   ! 
    112                   zvab(:,jp_tem)  = zab(ji,jj,:,jp_tem)     ! Alpha  
    113                   zvab(:,jp_sal)  = zab(ji,jj,:,jp_sal)     ! Beta   
    114                   zvn2(:)         = zn2(ji,jj,:)            ! N^2  
    115                   ! 
    116                   IF( l_LB_debug ) THEN                  !LB debug: 
    117                      lp_monitor_point = .FALSE. 
    118                      IF( ( ji == ilc1 ).AND.( jj == jlc1 ) ) lp_monitor_point = .TRUE. 
    119                      ! writing only if on CPU domain where conv region is: 
    120                      lp_monitor_point = (narea == nncpu).AND.lp_monitor_point                       
    121                   ENDIF                                  !LB debug  end 
    122                   ! 
    123                   ikbot = mbkt(ji,jj)   ! ikbot: ocean bottom T-level 
    124                   ikp = 1                  ! because N2 is irrelevant at the surface level (will start at ikp=2) 
    125                   ilayer = 0 
    126                   jiter  = 0 
    127                   l_column_treated = .FALSE. 
    128                   ! 
    129                   DO WHILE ( .NOT. l_column_treated ) 
    130                      ! 
    131                      jiter = jiter + 1 
    132                      !  
    133                      IF( jiter >= 400 ) EXIT 
    134                      ! 
    135                      l_bottom_reached = .FALSE. 
    136                      ! 
    137                      DO WHILE ( .NOT. l_bottom_reached ) 
    138                         ! 
    139                         ikp = ikp + 1 
    140                         ! 
    141                         !! Testing level ikp for instability 
    142                         !! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 
    143                         IF( zvn2(ikp) <  -zn2_zero ) THEN ! Instability found! 
    144                            ! 
    145                            ilayer = ilayer + 1    ! yet another instable portion of the water column found.... 
    146                            ! 
    147                            IF( lp_monitor_point ) THEN  
     112               zvab(:,jp_tem)  = zab(ji,jj,:,jp_tem)     ! Alpha  
     113               zvab(:,jp_sal)  = zab(ji,jj,:,jp_sal)     ! Beta   
     114               zvn2(:)         = zn2(ji,jj,:)            ! N^2  
     115               ! 
     116               IF( l_LB_debug ) THEN                  !LB debug: 
     117                  lp_monitor_point = .FALSE. 
     118                  IF( ( ji == ilc1 ).AND.( jj == jlc1 ) ) lp_monitor_point = .TRUE. 
     119                  ! writing only if on CPU domain where conv region is: 
     120                  lp_monitor_point = (narea == nncpu).AND.lp_monitor_point                       
     121               ENDIF                                  !LB debug  end 
     122               ! 
     123               ikbot = mbkt(ji,jj)   ! ikbot: ocean bottom T-level 
     124               ikp = 1                  ! because N2 is irrelevant at the surface level (will start at ikp=2) 
     125               ilayer = 0 
     126               jiter  = 0 
     127               l_column_treated = .FALSE. 
     128               ! 
     129               DO WHILE ( .NOT. l_column_treated ) 
     130                  ! 
     131                  jiter = jiter + 1 
     132                  !  
     133                  IF( jiter >= 400 ) EXIT 
     134                  ! 
     135                  l_bottom_reached = .FALSE. 
     136                  ! 
     137                  DO WHILE ( .NOT. l_bottom_reached ) 
     138                     ! 
     139                     ikp = ikp + 1 
     140                     ! 
     141                     !! Testing level ikp for instability 
     142                     !! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 
     143                     IF( zvn2(ikp) <  -zn2_zero ) THEN ! Instability found! 
     144                        ! 
     145                        ilayer = ilayer + 1    ! yet another instable portion of the water column found.... 
     146                        ! 
     147                        IF( lp_monitor_point ) THEN  
     148                           WRITE(numout,*) 
     149                           IF( ilayer == 1 .AND. jiter == 1 ) THEN   ! first time a column is spoted with an instability 
    148150                              WRITE(numout,*) 
    149                               IF( ilayer == 1 .AND. jiter == 1 ) THEN   ! first time a column is spoted with an instability 
    150                                  WRITE(numout,*) 
    151                                  WRITE(numout,*) 'Time step = ',kt,' !!!' 
    152                               ENDIF 
    153                               WRITE(numout,*)  ' * Iteration #',jiter,': found instable portion #',ilayer,   & 
    154                                  &                                    ' in column! Starting at ikp =', ikp 
    155                               WRITE(numout,*)  ' *** N2 for point (i,j) = ',ji,' , ',jj 
    156                               DO jk = 1, klc1 
    157                                  WRITE(numout,*) jk, zvn2(jk) 
    158                               END DO 
    159                               WRITE(numout,*) 
     151                              WRITE(numout,*) 'Time step = ',kt,' !!!' 
    160152                           ENDIF 
    161                            ! 
    162                            IF( jiter == 1 )   inpcc = inpcc + 1  
    163                            ! 
    164                            IF( lp_monitor_point )   WRITE(numout, *) 'Negative N2 at ikp =',ikp,' for layer #', ilayer 
    165                            ! 
    166                            !! ikup is the uppermost point where mixing will start: 
    167                            ikup = ikp - 1 ! ikup is always "at most at ikp-1", less if neutral levels overlying 
    168                            ! 
    169                            !! If the points above ikp-1 have N2 == 0 they must also be mixed: 
    170                            IF( ikp > 2 ) THEN 
    171                               DO jk = ikp-1, 2, -1 
    172                                  IF( ABS(zvn2(jk)) < zn2_zero ) THEN 
    173                                     ikup = ikup - 1  ! 1 more upper level has N2=0 and must be added for the mixing 
    174                                  ELSE 
    175                                     EXIT 
    176                                  ENDIF 
    177                               END DO 
    178                            ENDIF 
    179                            ! 
    180                            IF( ikup < 1 )   CALL ctl_stop( 'tra_npc :  PROBLEM #1') 
    181                            ! 
    182                            zsum_temp = 0._wp 
    183                            zsum_sali = 0._wp 
    184                            zsum_alfa = 0._wp 
    185                            zsum_beta = 0._wp 
    186                            zsum_z    = 0._wp 
    187                                                      
    188                            DO jk = ikup, ikbot      ! Inside the instable (and overlying neutral) portion of the column 
    189                               ! 
    190                               zdz       = e3t(ji,jj,jk,Kmm) 
    191                               zsum_temp = zsum_temp + zvts(jk,jp_tem)*zdz 
    192                               zsum_sali = zsum_sali + zvts(jk,jp_sal)*zdz 
    193                               zsum_alfa = zsum_alfa + zvab(jk,jp_tem)*zdz 
    194                               zsum_beta = zsum_beta + zvab(jk,jp_sal)*zdz 
    195                               zsum_z    = zsum_z    + zdz 
    196                               !                               
    197                               IF( jk == ikbot ) EXIT ! avoid array-index overshoot in case ikbot = jpk, cause we're calling jk+1 next line 
    198                               !! EXIT when we have reached the last layer that is instable (N2<0) or neutral (N2=0): 
    199                               IF( zvn2(jk+1) > zn2_zero ) EXIT 
    200                            END DO 
    201                            
    202                            ikdown = jk ! for the current unstable layer, ikdown is the deepest point with a negative or neutral N2 
    203                            IF( ikup == ikdown )   CALL ctl_stop( 'tra_npc :  PROBLEM #2') 
    204  
    205                            ! Mixing Temperature, salinity, alpha and beta from ikup to ikdown included: 
    206                            zta   = zsum_temp/zsum_z 
    207                            zsa   = zsum_sali/zsum_z 
    208                            zalfa = zsum_alfa/zsum_z 
    209                            zbeta = zsum_beta/zsum_z 
    210  
    211                            IF( lp_monitor_point ) THEN 
    212                               WRITE(numout,*) 'MIXED T, S, alfa and beta between ikup =',ikup,   & 
    213                                  &            ' and ikdown =',ikdown,', in layer #',ilayer 
    214                               WRITE(numout,*) '  => Mean temp. in that portion =', zta 
    215                               WRITE(numout,*) '  => Mean sali. in that portion =', zsa 
    216                               WRITE(numout,*) '  => Mean Alfa  in that portion =', zalfa 
    217                               WRITE(numout,*) '  => Mean Beta  in that portion =', zbeta 
    218                            ENDIF 
    219  
    220                            !! Homogenaizing the temperature, salinity, alpha and beta in this portion of the column 
    221                            DO jk = ikup, ikdown 
    222                               zvts(jk,jp_tem) = zta 
    223                               zvts(jk,jp_sal) = zsa 
    224                               zvab(jk,jp_tem) = zalfa 
    225                               zvab(jk,jp_sal) = zbeta 
    226                            END DO 
    227                             
    228                             
    229                            !! Updating N2 in the relvant portion of the water column 
    230                            !! Temperature, Salinity, Alpha and Beta have been homogenized in the unstable portion 
    231                            !! => Need to re-compute N2! will use Alpha and Beta! 
    232                             
    233                            ikup   = MAX(2,ikup)         ! ikup can never be 1 ! 
    234                            ik_low = MIN(ikdown+1,ikbot) ! we must go 1 point deeper than ikdown! 
    235                             
    236                            DO jk = ikup, ik_low              ! we must go 1 point deeper than ikdown! 
    237  
    238                               !! Interpolating alfa and beta at W point: 
    239                               zrw =  (gdepw(ji,jj,jk  ,Kmm) - gdept(ji,jj,jk,Kmm)) & 
    240                                  & / (gdept(ji,jj,jk-1,Kmm) - gdept(ji,jj,jk,Kmm)) 
    241                               zaw = zvab(jk,jp_tem) * (1._wp - zrw) + zvab(jk-1,jp_tem) * zrw 
    242                               zbw = zvab(jk,jp_sal) * (1._wp - zrw) + zvab(jk-1,jp_sal) * zrw 
    243  
    244                               !! N2 at W point, doing exactly as in eosbn2.F90: 
    245                               zvn2(jk) = grav*( zaw * ( zvts(jk-1,jp_tem) - zvts(jk,jp_tem) )     & 
    246                                  &            - zbw * ( zvts(jk-1,jp_sal) - zvts(jk,jp_sal) )  )  & 
    247                                  &       / e3w(ji,jj,jk,Kmm) * tmask(ji,jj,jk) 
    248  
    249                               !! OR, faster  => just considering the vertical gradient of density 
    250                               !! as only the signa maters... 
    251                               !zvn2(jk) = (  zaw * ( zvts(jk-1,jp_tem) - zvts(jk,jp_tem) )     & 
    252                               !     &      - zbw * ( zvts(jk-1,jp_sal) - zvts(jk,jp_sal) )  ) 
    253  
    254                            END DO 
    255                          
    256                            ikp = MIN(ikdown+1,ikbot) 
    257                             
    258  
    259                         ENDIF  !IF( zvn2(ikp) < 0. ) 
    260  
    261  
    262                         IF( ikp == ikbot ) l_bottom_reached = .TRUE. 
    263                         ! 
    264                      END DO ! DO WHILE ( .NOT. l_bottom_reached ) 
    265  
    266                      IF( ikp /= ikbot )   CALL ctl_stop( 'tra_npc :  PROBLEM #3') 
    267                      
    268                      ! ******* At this stage ikp == ikbot ! ******* 
    269                      
    270                      IF( ilayer > 0 ) THEN      !! least an unstable layer has been found 
    271                         ! 
    272                         IF( lp_monitor_point ) THEN 
    273                            WRITE(numout,*) 
    274                            WRITE(numout,*) 'After ',jiter,' iteration(s), we neutralized ',ilayer,' instable layer(s)' 
    275                            WRITE(numout,*) '   ==> N2 at i,j=',ji,',',jj,' now looks like this:' 
     153                           WRITE(numout,*)  ' * Iteration #',jiter,': found instable portion #',ilayer,   & 
     154                              &                                    ' in column! Starting at ikp =', ikp 
     155                           WRITE(numout,*)  ' *** N2 for point (i,j) = ',ji,' , ',jj 
    276156                           DO jk = 1, klc1 
    277157                              WRITE(numout,*) jk, zvn2(jk) 
    … …  
    280160                        ENDIF 
    281161                        ! 
    282                         ikp    = 1     ! starting again at the surface for the next iteration 
    283                         ilayer = 0 
     162                        IF( jiter == 1 )   inpcc = inpcc + 1  
     163                        ! 
     164                        IF( lp_monitor_point )   WRITE(numout, *) 'Negative N2 at ikp =',ikp,' for layer #', ilayer 
     165                        ! 
     166                        !! ikup is the uppermost point where mixing will start: 
     167                        ikup = ikp - 1 ! ikup is always "at most at ikp-1", less if neutral levels overlying 
     168                        ! 
     169                        !! If the points above ikp-1 have N2 == 0 they must also be mixed: 
     170                        IF( ikp > 2 ) THEN 
     171                           DO jk = ikp-1, 2, -1 
     172                              IF( ABS(zvn2(jk)) < zn2_zero ) THEN 
     173                                 ikup = ikup - 1  ! 1 more upper level has N2=0 and must be added for the mixing 
     174                              ELSE 
     175                                 EXIT 
     176                              ENDIF 
     177                           END DO 
     178                        ENDIF 
     179                        ! 
     180                        IF( ikup < 1 )   CALL ctl_stop( 'tra_npc :  PROBLEM #1') 
     181                        ! 
     182                        zsum_temp = 0._wp 
     183                        zsum_sali = 0._wp 
     184                        zsum_alfa = 0._wp 
     185                        zsum_beta = 0._wp 
     186                        zsum_z    = 0._wp 
     187                                                  
     188                        DO jk = ikup, ikbot      ! Inside the instable (and overlying neutral) portion of the column 
     189                           ! 
     190                           zdz       = e3t(ji,jj,jk,Kmm) 
     191                           zsum_temp = zsum_temp + zvts(jk,jp_tem)*zdz 
     192                           zsum_sali = zsum_sali + zvts(jk,jp_sal)*zdz 
     193                           zsum_alfa = zsum_alfa + zvab(jk,jp_tem)*zdz 
     194                           zsum_beta = zsum_beta + zvab(jk,jp_sal)*zdz 
     195                           zsum_z    = zsum_z    + zdz 
     196                           !                               
     197                           IF( jk == ikbot ) EXIT ! avoid array-index overshoot in case ikbot = jpk, cause we're calling jk+1 next line 
     198                           !! EXIT when we have reached the last layer that is instable (N2<0) or neutral (N2=0): 
     199                           IF( zvn2(jk+1) > zn2_zero ) EXIT 
     200                        END DO 
     201                        
     202                        ikdown = jk ! for the current unstable layer, ikdown is the deepest point with a negative or neutral N2 
     203                        IF( ikup == ikdown )   CALL ctl_stop( 'tra_npc :  PROBLEM #2') 
     204 
     205                        ! Mixing Temperature, salinity, alpha and beta from ikup to ikdown included: 
     206                        zta   = zsum_temp/zsum_z 
     207                        zsa   = zsum_sali/zsum_z 
     208                        zalfa = zsum_alfa/zsum_z 
     209                        zbeta = zsum_beta/zsum_z 
     210 
     211                        IF( lp_monitor_point ) THEN 
     212                           WRITE(numout,*) 'MIXED T, S, alfa and beta between ikup =',ikup,   & 
     213                              &            ' and ikdown =',ikdown,', in layer #',ilayer 
     214                           WRITE(numout,*) '  => Mean temp. in that portion =', zta 
     215                           WRITE(numout,*) '  => Mean sali. in that portion =', zsa 
     216                           WRITE(numout,*) '  => Mean Alfa  in that portion =', zalfa 
     217                           WRITE(numout,*) '  => Mean Beta  in that portion =', zbeta 
     218                        ENDIF 
     219 
     220                        !! Homogenaizing the temperature, salinity, alpha and beta in this portion of the column 
     221                        DO jk = ikup, ikdown 
     222                           zvts(jk,jp_tem) = zta 
     223                           zvts(jk,jp_sal) = zsa 
     224                           zvab(jk,jp_tem) = zalfa 
     225                           zvab(jk,jp_sal) = zbeta 
     226                        END DO 
     227                         
     228                         
     229                        !! Updating N2 in the relvant portion of the water column 
     230                        !! Temperature, Salinity, Alpha and Beta have been homogenized in the unstable portion 
     231                        !! => Need to re-compute N2! will use Alpha and Beta! 
     232                         
     233                        ikup   = MAX(2,ikup)         ! ikup can never be 1 ! 
     234                        ik_low = MIN(ikdown+1,ikbot) ! we must go 1 point deeper than ikdown! 
     235                         
     236                        DO jk = ikup, ik_low              ! we must go 1 point deeper than ikdown! 
     237 
     238                           !! Interpolating alfa and beta at W point: 
     239                           zrw =  (gdepw(ji,jj,jk  ,Kmm) - gdept(ji,jj,jk,Kmm)) & 
     240                              & / (gdept(ji,jj,jk-1,Kmm) - gdept(ji,jj,jk,Kmm)) 
     241                           zaw = zvab(jk,jp_tem) * (1._wp - zrw) + zvab(jk-1,jp_tem) * zrw 
     242                           zbw = zvab(jk,jp_sal) * (1._wp - zrw) + zvab(jk-1,jp_sal) * zrw 
     243 
     244                           !! N2 at W point, doing exactly as in eosbn2.F90: 
     245                           zvn2(jk) = grav*( zaw * ( zvts(jk-1,jp_tem) - zvts(jk,jp_tem) )     & 
     246                              &            - zbw * ( zvts(jk-1,jp_sal) - zvts(jk,jp_sal) )  )  & 
     247                              &       / e3w(ji,jj,jk,Kmm) * tmask(ji,jj,jk) 
     248 
     249                           !! OR, faster  => just considering the vertical gradient of density 
     250                           !! as only the signa maters... 
     251                           !zvn2(jk) = (  zaw * ( zvts(jk-1,jp_tem) - zvts(jk,jp_tem) )     & 
     252                           !     &      - zbw * ( zvts(jk-1,jp_sal) - zvts(jk,jp_sal) )  ) 
     253 
     254                        END DO 
     255                      
     256                        ikp = MIN(ikdown+1,ikbot) 
     257                         
     258 
     259                     ENDIF  !IF( zvn2(ikp) < 0. ) 
     260 
     261 
     262                     IF( ikp == ikbot ) l_bottom_reached = .TRUE. 
     263                     ! 
     264                  END DO ! DO WHILE ( .NOT. l_bottom_reached ) 
     265 
     266                  IF( ikp /= ikbot )   CALL ctl_stop( 'tra_npc :  PROBLEM #3') 
     267                  
     268                  ! ******* At this stage ikp == ikbot ! ******* 
     269                  
     270                  IF( ilayer > 0 ) THEN      !! least an unstable layer has been found 
     271                     ! 
     272                     IF( lp_monitor_point ) THEN 
     273                        WRITE(numout,*) 
     274                        WRITE(numout,*) 'After ',jiter,' iteration(s), we neutralized ',ilayer,' instable layer(s)' 
     275                        WRITE(numout,*) '   ==> N2 at i,j=',ji,',',jj,' now looks like this:' 
     276                        DO jk = 1, klc1 
     277                           WRITE(numout,*) jk, zvn2(jk) 
     278                        END DO 
     279                        WRITE(numout,*) 
    284280                     ENDIF 
    285281                     ! 
    286                      IF( ikp >= ikbot )   l_column_treated = .TRUE. 
    287                      ! 
    288                   END DO ! DO WHILE ( .NOT. l_column_treated ) 
    289  
    290                   !! Updating pts: 
    291                   pts(ji,jj,:,jp_tem,Kaa) = zvts(:,jp_tem) 
    292                   pts(ji,jj,:,jp_sal,Kaa) = zvts(:,jp_sal) 
    293  
    294                   !! LB:  Potentially some other global variable beside theta and S can be treated here 
    295                   !!      like BGC tracers. 
    296  
    297                   IF( lp_monitor_point )   WRITE(numout,*) 
    298  
    299                ENDIF ! IF( tmask(ji,jj,3) == 1 ) THEN 
    300  
    301             END DO ! ji 
    302          END DO ! jj 
     282                     ikp    = 1     ! starting again at the surface for the next iteration 
     283                     ilayer = 0 
     284                  ENDIF 
     285                  ! 
     286                  IF( ikp >= ikbot )   l_column_treated = .TRUE. 
     287                  ! 
     288               END DO ! DO WHILE ( .NOT. l_column_treated ) 
     289 
     290               !! Updating pts: 
     291               pts(ji,jj,:,jp_tem,Kaa) = zvts(:,jp_tem) 
     292               pts(ji,jj,:,jp_sal,Kaa) = zvts(:,jp_sal) 
     293 
     294               !! LB:  Potentially some other global variable beside theta and S can be treated here 
     295               !!      like BGC tracers. 
     296 
     297               IF( lp_monitor_point )   WRITE(numout,*) 
     298 
     299            ENDIF ! IF( tmask(ji,jj,3) == 1 ) THEN 
     300 
     301         END_2D 
    303302         ! 
    304303         IF( l_trdtra ) THEN         ! send the Non penetrative mixing trends for diagnostic 

  • NEMO/branches/2019/dev_r11943_MERGE_2019/src/OCE/TRA/traqsr.F90

    r12236 r12340  
    6868   !! * Substitutions 
    6969#  include "vectopt_loop_substitute.h90" 
     70#  include "do_loop_substitute.h90" 
    7071   !!---------------------------------------------------------------------- 
    7172   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    197198         ! 
    198199         zcoef  = ( 1. - rn_abs ) / 3._wp    !* surface equi-partition in R-G-B 
    199          DO jj = 2, jpjm1 
    200             DO ji = fs_2, fs_jpim1 
    201                ze0(ji,jj,1) = rn_abs * qsr(ji,jj) 
    202                ze1(ji,jj,1) = zcoef  * qsr(ji,jj) 
    203                ze2(ji,jj,1) = zcoef  * qsr(ji,jj) 
    204                ze3(ji,jj,1) = zcoef  * qsr(ji,jj) 
    205                zea(ji,jj,1) =          qsr(ji,jj) 
    206             END DO 
     200         DO_2D_00_00 
     201            ze0(ji,jj,1) = rn_abs * qsr(ji,jj) 
     202            ze1(ji,jj,1) = zcoef  * qsr(ji,jj) 
     203            ze2(ji,jj,1) = zcoef  * qsr(ji,jj) 
     204            ze3(ji,jj,1) = zcoef  * qsr(ji,jj) 
     205            zea(ji,jj,1) =          qsr(ji,jj) 
     206         END_2D 
     207         ! 
     208         DO jk = 2, nksr+1                   !* interior equi-partition in R-G-B depending of vertical profile of Chl 
     209            DO_2D_00_00 
     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_2D 
     216 
     217            DO_2D_00_00 
     218               zc0 = ze0(ji,jj,jk-1) * EXP( - e3t(ji,jj,jk-1,Kmm) * xsi0r       ) 
     219               zc1 = ze1(ji,jj,jk-1) * EXP( - e3t(ji,jj,jk-1,Kmm) * zekb(ji,jj) ) 
     220               zc2 = ze2(ji,jj,jk-1) * EXP( - e3t(ji,jj,jk-1,Kmm) * zekg(ji,jj) ) 
     221               zc3 = ze3(ji,jj,jk-1) * EXP( - e3t(ji,jj,jk-1,Kmm) * zekr(ji,jj) ) 
     222               ze0(ji,jj,jk) = zc0 
     223               ze1(ji,jj,jk) = zc1 
     224               ze2(ji,jj,jk) = zc2 
     225               ze3(ji,jj,jk) = zc3 
     226               zea(ji,jj,jk) = ( zc0 + zc1 + zc2 + zc3 ) * wmask(ji,jj,jk) 
     227            END_2D 
    207228         END DO 
    208229         ! 
    209          DO jk = 2, nksr+1                   !* interior equi-partition in R-G-B depending of vertical profile of Chl 
    210             DO jj = 2, jpjm1 
    211                DO ji = fs_2, fs_jpim1 
    212                   zchl = MIN( 10. , MAX( 0.03, zchl3d(ji,jj,jk) ) ) 
    213                   irgb = NINT( 41 + 20.*LOG10(zchl) + 1.e-15 ) 
    214                   zekb(ji,jj) = rkrgb(1,irgb) 
    215                   zekg(ji,jj) = rkrgb(2,irgb) 
    216                   zekr(ji,jj) = rkrgb(3,irgb) 
    217                END DO 
    218             END DO 
    219  
    220             DO jj = 2, jpjm1 
    221                DO ji = fs_2, fs_jpim1 
    222                   zc0 = ze0(ji,jj,jk-1) * EXP( - e3t(ji,jj,jk-1,Kmm) * xsi0r       ) 
    223                   zc1 = ze1(ji,jj,jk-1) * EXP( - e3t(ji,jj,jk-1,Kmm) * zekb(ji,jj) ) 
    224                   zc2 = ze2(ji,jj,jk-1) * EXP( - e3t(ji,jj,jk-1,Kmm) * zekg(ji,jj) ) 
    225                   zc3 = ze3(ji,jj,jk-1) * EXP( - e3t(ji,jj,jk-1,Kmm) * zekr(ji,jj) ) 
    226                   ze0(ji,jj,jk) = zc0 
    227                   ze1(ji,jj,jk) = zc1 
    228                   ze2(ji,jj,jk) = zc2 
    229                   ze3(ji,jj,jk) = zc3 
    230                   zea(ji,jj,jk) = ( zc0 + zc1 + zc2 + zc3 ) * wmask(ji,jj,jk) 
    231                END DO 
    232             END DO 
    233          END DO 
    234          ! 
    235          DO jk = 1, nksr                     !* now qsr induced heat content 
    236             DO jj = 2, jpjm1 
    237                DO ji = fs_2, fs_jpim1 
    238                   qsr_hc(ji,jj,jk) = r1_rau0_rcp * ( zea(ji,jj,jk) - zea(ji,jj,jk+1) ) 
    239                END DO 
    240             END DO 
    241          END DO 
     230         DO_3D_00_00( 1, nksr ) 
     231            qsr_hc(ji,jj,jk) = r1_rau0_rcp * ( zea(ji,jj,jk) - zea(ji,jj,jk+1) ) 
     232         END_3D 
    242233         ! 
    243234         DEALLOCATE( zekb , zekg , zekr , ze0 , ze1 , ze2 , ze3 , zea , zchl3d )  
    … …  
    247238         zz0 =        rn_abs   * r1_rau0_rcp      ! surface equi-partition in 2-bands 
    248239         zz1 = ( 1. - rn_abs ) * r1_rau0_rcp 
    249          DO jk = 1, nksr                          ! solar heat absorbed at T-point in the top 400m  
    250             DO jj = 2, jpjm1 
    251                DO ji = fs_2, fs_jpim1 
    252                   zc0 = zz0 * EXP( -gdepw(ji,jj,jk  ,Kmm)*xsi0r ) + zz1 * EXP( -gdepw(ji,jj,jk  ,Kmm)*xsi1r ) 
    253                   zc1 = zz0 * EXP( -gdepw(ji,jj,jk+1,Kmm)*xsi0r ) + zz1 * EXP( -gdepw(ji,jj,jk+1,Kmm)*xsi1r ) 
    254                   qsr_hc(ji,jj,jk) = qsr(ji,jj) * ( zc0 * wmask(ji,jj,jk) - zc1 * wmask(ji,jj,jk+1) )  
    255                END DO 
    256             END DO 
    257          END DO 
     240         DO_3D_00_00( 1, nksr ) 
     241            zc0 = zz0 * EXP( -gdepw(ji,jj,jk  ,Kmm)*xsi0r ) + zz1 * EXP( -gdepw(ji,jj,jk  ,Kmm)*xsi1r ) 
     242            zc1 = zz0 * EXP( -gdepw(ji,jj,jk+1,Kmm)*xsi0r ) + zz1 * EXP( -gdepw(ji,jj,jk+1,Kmm)*xsi1r ) 
     243            qsr_hc(ji,jj,jk) = qsr(ji,jj) * ( zc0 * wmask(ji,jj,jk) - zc1 * wmask(ji,jj,jk+1) )  
     244         END_3D 
    258245         ! 
    259246      END SELECT 
    260247      ! 
    261248      !                          !-----------------------------! 
    262       DO jk = 1, nksr            !  update to the temp. trend  ! 
    263          DO jj = 2, jpjm1        !-----------------------------! 
    264             DO ji = fs_2, fs_jpim1   ! vector opt. 
    265                pts(ji,jj,jk,jp_tem,Krhs) = pts(ji,jj,jk,jp_tem,Krhs)   & 
    266                   &                      + z1_2 * ( qsr_hc_b(ji,jj,jk) + qsr_hc(ji,jj,jk) ) / e3t(ji,jj,jk,Kmm) 
    267             END DO 
    268          END DO 
    269       END DO 
     249      DO_3D_00_00( 1, nksr ) 
     250         pts(ji,jj,jk,jp_tem,Krhs) = pts(ji,jj,jk,jp_tem,Krhs)   & 
     251            &                      + z1_2 * ( qsr_hc_b(ji,jj,jk) + qsr_hc(ji,jj,jk) ) / e3t(ji,jj,jk,Kmm) 
     252      END_3D 
    270253      ! 
    271254      ! sea-ice: store the 1st ocean level attenuation coefficient 
    272       DO jj = 2, jpjm1  
    273          DO ji = fs_2, fs_jpim1   ! vector opt. 
    274             IF( qsr(ji,jj) /= 0._wp ) THEN   ;   fraqsr_1lev(ji,jj) = qsr_hc(ji,jj,1) / ( r1_rau0_rcp * qsr(ji,jj) ) 
    275             ELSE                             ;   fraqsr_1lev(ji,jj) = 1._wp 
    276             ENDIF 
    277          END DO 
    278       END DO 
     255      DO_2D_00_00 
     256         IF( qsr(ji,jj) /= 0._wp ) THEN   ;   fraqsr_1lev(ji,jj) = qsr_hc(ji,jj,1) / ( r1_rau0_rcp * qsr(ji,jj) ) 
     257         ELSE                             ;   fraqsr_1lev(ji,jj) = 1._wp 
     258         ENDIF 
     259      END_2D 
    279260      CALL lbc_lnk( 'traqsr', fraqsr_1lev(:,:), 'T', 1._wp ) 
    280261      ! 

  • NEMO/branches/2019/dev_r11943_MERGE_2019/src/OCE/TRA/trasbc.F90

    r12236 r12340  
    4343   !! * Substitutions 
    4444#  include "vectopt_loop_substitute.h90" 
     45#  include "do_loop_substitute.h90" 
    4546   !!---------------------------------------------------------------------- 
    4647   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    123124      ENDIF 
    124125      !                             !==  Now sbc tracer content fields  ==! 
    125       DO jj = 2, jpj 
    126          DO ji = fs_2, fs_jpim1   ! vector opt. 
    127             sbc_tsc(ji,jj,jp_tem) = r1_rau0_rcp * qns(ji,jj)   ! non solar heat flux 
    128             sbc_tsc(ji,jj,jp_sal) = r1_rau0     * sfx(ji,jj)   ! salt flux due to freezing/melting 
    129          END DO 
    130       END DO 
     126      DO_2D_01_00 
     127         sbc_tsc(ji,jj,jp_tem) = r1_rau0_rcp * qns(ji,jj)   ! non solar heat flux 
     128         sbc_tsc(ji,jj,jp_sal) = r1_rau0     * sfx(ji,jj)   ! salt flux due to freezing/melting 
     129      END_2D 
    131130      IF( ln_linssh ) THEN                !* linear free surface   
    132          DO jj = 2, jpj                         !==>> add concentration/dilution effect due to constant volume cell 
    133             DO ji = fs_2, fs_jpim1   ! vector opt. 
    134                sbc_tsc(ji,jj,jp_tem) = sbc_tsc(ji,jj,jp_tem) + r1_rau0 * emp(ji,jj) * pts(ji,jj,1,jp_tem,Kmm) 
    135                sbc_tsc(ji,jj,jp_sal) = sbc_tsc(ji,jj,jp_sal) + r1_rau0 * emp(ji,jj) * pts(ji,jj,1,jp_sal,Kmm) 
    136             END DO 
    137          END DO                                 !==>> output c./d. term 
     131         DO_2D_01_00 
     132            sbc_tsc(ji,jj,jp_tem) = sbc_tsc(ji,jj,jp_tem) + r1_rau0 * emp(ji,jj) * pts(ji,jj,1,jp_tem,Kmm) 
     133            sbc_tsc(ji,jj,jp_sal) = sbc_tsc(ji,jj,jp_sal) + r1_rau0 * emp(ji,jj) * pts(ji,jj,1,jp_sal,Kmm) 
     134         END_2D 
    138135         IF( iom_use('emp_x_sst') )   CALL iom_put( "emp_x_sst", emp (:,:) * pts(:,:,1,jp_tem,Kmm) ) 
    139136         IF( iom_use('emp_x_sss') )   CALL iom_put( "emp_x_sss", emp (:,:) * pts(:,:,1,jp_sal,Kmm) ) 
    … …  
    141138      ! 
    142139      DO jn = 1, jpts               !==  update tracer trend  ==! 
    143          DO jj = 2, jpj 
    144             DO ji = fs_2, fs_jpim1   ! vector opt.   
    145                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) 
    146             END DO 
    147          END DO 
     140         DO_2D_01_00 
     141            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) 
     142         END_2D 
    148143      END DO 
    149144      !                   
    … …  
    161156      IF( ln_rnf ) THEN         ! input of heat and salt due to river runoff  
    162157         zfact = 0.5_wp 
    163          DO jj = 2, jpj  
    164             DO ji = fs_2, fs_jpim1 
    165                IF( rnf(ji,jj) /= 0._wp ) THEN 
    166                   zdep = zfact / h_rnf(ji,jj) 
    167                   DO jk = 1, nk_rnf(ji,jj) 
    168                                         pts(ji,jj,jk,jp_tem,Krhs) = pts(ji,jj,jk,jp_tem,Krhs)                                  & 
    169                                            &                      +  ( rnf_tsc_b(ji,jj,jp_tem) + rnf_tsc(ji,jj,jp_tem) ) * zdep 
    170                      IF( ln_rnf_sal )   pts(ji,jj,jk,jp_sal,Krhs) = pts(ji,jj,jk,jp_sal,Krhs)                                  & 
    171                                            &                      +  ( rnf_tsc_b(ji,jj,jp_sal) + rnf_tsc(ji,jj,jp_sal) ) * zdep  
    172                   END DO 
    173                ENDIF 
    174             END DO   
    175          END DO   
     158         DO_2D_01_00 
     159            IF( rnf(ji,jj) /= 0._wp ) THEN 
     160               zdep = zfact / h_rnf(ji,jj) 
     161               DO jk = 1, nk_rnf(ji,jj) 
     162                                     pts(ji,jj,jk,jp_tem,Krhs) = pts(ji,jj,jk,jp_tem,Krhs)                                  & 
     163                                        &                      +  ( rnf_tsc_b(ji,jj,jp_tem) + rnf_tsc(ji,jj,jp_tem) ) * zdep 
     164                  IF( ln_rnf_sal )   pts(ji,jj,jk,jp_sal,Krhs) = pts(ji,jj,jk,jp_sal,Krhs)                                  & 
     165                                        &                      +  ( rnf_tsc_b(ji,jj,jp_sal) + rnf_tsc(ji,jj,jp_sal) ) * zdep  
     166               END DO 
     167            ENDIF 
     168         END_2D 
    176169      ENDIF 
    177170 
    … …  
    188181          ! 
    189182         IF( ln_linssh ) THEN  
    190             DO jj = 2, jpj  
    191                DO ji = fs_2, fs_jpim1 
    192                   ztim = ssh_iau(ji,jj) / e3t(ji,jj,1,Kmm) 
    193                   pts(ji,jj,1,jp_tem,Krhs) = pts(ji,jj,1,jp_tem,Krhs) + pts(ji,jj,1,jp_tem,Kmm) * ztim 
    194                   pts(ji,jj,1,jp_sal,Krhs) = pts(ji,jj,1,jp_sal,Krhs) + pts(ji,jj,1,jp_sal,Kmm) * ztim 
    195                END DO 
    196             END DO 
     183            DO_2D_01_00 
     184               ztim = ssh_iau(ji,jj) / e3t(ji,jj,1,Kmm) 
     185               pts(ji,jj,1,jp_tem,Krhs) = pts(ji,jj,1,jp_tem,Krhs) + pts(ji,jj,1,jp_tem,Kmm) * ztim 
     186               pts(ji,jj,1,jp_sal,Krhs) = pts(ji,jj,1,jp_sal,Krhs) + pts(ji,jj,1,jp_sal,Kmm) * ztim 
     187            END_2D 
    197188         ELSE 
    198             DO jj = 2, jpj  
    199                DO ji = fs_2, fs_jpim1 
    200                   ztim = ssh_iau(ji,jj) / ( ht(ji,jj) + 1. - ssmask(ji, jj) ) 
    201                   pts(ji,jj,:,jp_tem,Krhs) = pts(ji,jj,:,jp_tem,Krhs) + pts(ji,jj,:,jp_tem,Kmm) * ztim 
    202                   pts(ji,jj,:,jp_sal,Krhs) = pts(ji,jj,:,jp_sal,Krhs) + pts(ji,jj,:,jp_sal,Kmm) * ztim 
    203                END DO   
    204             END DO   
     189            DO_2D_01_00 
     190               ztim = ssh_iau(ji,jj) / ( ht(ji,jj) + 1. - ssmask(ji, jj) ) 
     191               pts(ji,jj,:,jp_tem,Krhs) = pts(ji,jj,:,jp_tem,Krhs) + pts(ji,jj,:,jp_tem,Kmm) * ztim 
     192               pts(ji,jj,:,jp_sal,Krhs) = pts(ji,jj,:,jp_sal,Krhs) + pts(ji,jj,:,jp_sal,Kmm) * ztim 
     193            END_2D 
    205194         ENDIF 
    206195         ! 

  • NEMO/branches/2019/dev_r11943_MERGE_2019/src/OCE/TRA/trazdf.F90

    r12236 r12340  
    3737   !! * Substitutions 
    3838#  include "vectopt_loop_substitute.h90" 
     39#  include "do_loop_substitute.h90" 
    3940   !!---------------------------------------------------------------------- 
    4041   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    160161            IF( l_ldfslp ) THEN            ! isoneutral diffusion: add the contribution  
    161162               IF( ln_traldf_msc  ) THEN     ! MSC iso-neutral operator  
    162                   DO jk = 2, jpkm1 
    163                      DO jj = 2, jpjm1 
    164                         DO ji = fs_2, fs_jpim1   ! vector opt. 
    165                            zwt(ji,jj,jk) = zwt(ji,jj,jk) + akz(ji,jj,jk)   
    166                         END DO 
    167                      END DO 
    168                   END DO 
     163                  DO_3D_00_00( 2, jpkm1 ) 
     164                     zwt(ji,jj,jk) = zwt(ji,jj,jk) + akz(ji,jj,jk)   
     165                  END_3D 
    169166               ELSE                          ! standard or triad iso-neutral operator 
    170                   DO jk = 2, jpkm1 
    171                      DO jj = 2, jpjm1 
    172                         DO ji = fs_2, fs_jpim1   ! vector opt. 
    173                            zwt(ji,jj,jk) = zwt(ji,jj,jk) + ah_wslp2(ji,jj,jk) 
    174                         END DO 
    175                      END DO 
    176                   END DO 
     167                  DO_3D_00_00( 2, jpkm1 ) 
     168                     zwt(ji,jj,jk) = zwt(ji,jj,jk) + ah_wslp2(ji,jj,jk) 
     169                  END_3D 
    177170               ENDIF 
    178171            ENDIF 
    … …  
    180173            ! Diagonal, lower (i), upper (s)  (including the bottom boundary condition since avt is masked) 
    181174            IF( ln_zad_Aimp ) THEN         ! Adaptive implicit vertical advection 
    182                DO jk = 1, jpkm1 
    183                   DO jj = 2, jpjm1 
    184                      DO ji = fs_2, fs_jpim1   ! vector opt. (ensure same order of calculation as below if wi=0.) 
    185                         zzwi = - p2dt * zwt(ji,jj,jk  ) / e3w(ji,jj,jk  ,Kmm) 
    186                         zzws = - p2dt * zwt(ji,jj,jk+1) / e3w(ji,jj,jk+1,Kmm) 
    187                         zwd(ji,jj,jk) = e3t(ji,jj,jk,Kaa) - zzwi - zzws   & 
    188                            &                 + p2dt * ( MAX( wi(ji,jj,jk  ) , 0._wp ) - MIN( wi(ji,jj,jk+1) , 0._wp ) ) 
    189                         zwi(ji,jj,jk) = zzwi + p2dt *   MIN( wi(ji,jj,jk  ) , 0._wp ) 
    190                         zws(ji,jj,jk) = zzws - p2dt *   MAX( wi(ji,jj,jk+1) , 0._wp ) 
    191                     END DO 
    192                   END DO 
    193                END DO 
     175               DO_3D_00_00( 1, jpkm1 ) 
     176                  zzwi = - p2dt * zwt(ji,jj,jk  ) / e3w(ji,jj,jk  ,Kmm) 
     177                  zzws = - p2dt * zwt(ji,jj,jk+1) / e3w(ji,jj,jk+1,Kmm) 
     178                  zwd(ji,jj,jk) = e3t(ji,jj,jk,Kaa) - zzwi - zzws   & 
     179                     &                 + p2dt * ( MAX( wi(ji,jj,jk  ) , 0._wp ) - MIN( wi(ji,jj,jk+1) , 0._wp ) ) 
     180                  zwi(ji,jj,jk) = zzwi + p2dt *   MIN( wi(ji,jj,jk  ) , 0._wp ) 
     181                  zws(ji,jj,jk) = zzws - p2dt *   MAX( wi(ji,jj,jk+1) , 0._wp ) 
     182               END_3D 
    194183            ELSE 
    195                DO jk = 1, jpkm1 
    196                   DO jj = 2, jpjm1 
    197                      DO ji = fs_2, fs_jpim1   ! vector opt. 
    198                         zwi(ji,jj,jk) = - p2dt * zwt(ji,jj,jk  ) / e3w(ji,jj,jk,Kmm) 
    199                         zws(ji,jj,jk) = - p2dt * zwt(ji,jj,jk+1) / e3w(ji,jj,jk+1,Kmm) 
    200                         zwd(ji,jj,jk) = e3t(ji,jj,jk,Kaa) - zwi(ji,jj,jk) - zws(ji,jj,jk) 
    201                     END DO 
    202                   END DO 
    203                END DO 
     184               DO_3D_00_00( 1, jpkm1 ) 
     185                  zwi(ji,jj,jk) = - p2dt * zwt(ji,jj,jk  ) / e3w(ji,jj,jk,Kmm) 
     186                  zws(ji,jj,jk) = - p2dt * zwt(ji,jj,jk+1) / e3w(ji,jj,jk+1,Kmm) 
     187                  zwd(ji,jj,jk) = e3t(ji,jj,jk,Kaa) - zwi(ji,jj,jk) - zws(ji,jj,jk) 
     188               END_3D 
    204189            ENDIF 
    205190            ! 
    … …  
    223208            !   used as a work space array: its value is modified. 
    224209            ! 
    225             DO jj = 2, jpjm1        !* 1st recurrence:   Tk = Dk - Ik Sk-1 / Tk-1   (increasing k) 
    226                DO ji = fs_2, fs_jpim1            ! done one for all passive tracers (so included in the IF instruction) 
    227                   zwt(ji,jj,1) = zwd(ji,jj,1) 
    228                END DO 
    229             END DO 
    230             DO jk = 2, jpkm1 
    231                DO jj = 2, jpjm1 
    232                   DO ji = fs_2, fs_jpim1 
    233                      zwt(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) / zwt(ji,jj,jk-1) 
    234                   END DO 
    235                END DO 
    236             END DO 
     210            DO_2D_00_00 
     211               zwt(ji,jj,1) = zwd(ji,jj,1) 
     212            END_2D 
     213            DO_3D_00_00( 2, jpkm1 ) 
     214               zwt(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) / zwt(ji,jj,jk-1) 
     215            END_3D 
    237216            ! 
    238217         ENDIF  
    239218         !          
    240          DO jj = 2, jpjm1           !* 2nd recurrence:    Zk = Yk - Ik / Tk-1  Zk-1 
    241             DO ji = fs_2, fs_jpim1 
    242                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) 
    243             END DO 
    244          END DO 
    245          DO jk = 2, jpkm1 
    246             DO jj = 2, jpjm1 
    247                DO ji = fs_2, fs_jpim1 
    248                   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 
    249                   pt(ji,jj,jk,jn,Kaa) = zrhs - zwi(ji,jj,jk) / zwt(ji,jj,jk-1) * pt(ji,jj,jk-1,jn,Kaa) 
    250                END DO 
    251             END DO 
    252          END DO 
     219         DO_2D_00_00 
     220            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) 
     221         END_2D 
     222         DO_3D_00_00( 2, jpkm1 ) 
     223            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 
     224            pt(ji,jj,jk,jn,Kaa) = zrhs - zwi(ji,jj,jk) / zwt(ji,jj,jk-1) * pt(ji,jj,jk-1,jn,Kaa) 
     225         END_3D 
    253226         ! 
    254          DO jj = 2, jpjm1           !* 3d recurrence:    Xk = (Zk - Sk Xk+1 ) / Tk   (result is the after tracer) 
    255             DO ji = fs_2, fs_jpim1 
    256                pt(ji,jj,jpkm1,jn,Kaa) = pt(ji,jj,jpkm1,jn,Kaa) / zwt(ji,jj,jpkm1) * tmask(ji,jj,jpkm1) 
    257             END DO 
    258          END DO 
    259          DO jk = jpk-2, 1, -1 
    260             DO jj = 2, jpjm1 
    261                DO ji = fs_2, fs_jpim1 
    262                   pt(ji,jj,jk,jn,Kaa) = ( pt(ji,jj,jk,jn,Kaa) - zws(ji,jj,jk) * pt(ji,jj,jk+1,jn,Kaa) )   & 
    263                      &             / zwt(ji,jj,jk) * tmask(ji,jj,jk) 
    264                END DO 
    265             END DO 
    266          END DO 
     227         DO_2D_00_00 
     228            pt(ji,jj,jpkm1,jn,Kaa) = pt(ji,jj,jpkm1,jn,Kaa) / zwt(ji,jj,jpkm1) * tmask(ji,jj,jpkm1) 
     229         END_2D 
     230         DO_3DS_00_00( jpk-2, 1, -1 ) 
     231            pt(ji,jj,jk,jn,Kaa) = ( pt(ji,jj,jk,jn,Kaa) - zws(ji,jj,jk) * pt(ji,jj,jk+1,jn,Kaa) )   & 
     232               &             / zwt(ji,jj,jk) * tmask(ji,jj,jk) 
     233         END_3D 
    267234         !                                            ! ================= ! 
    268235      END DO                                          !  end tracer loop  ! 

  • NEMO/branches/2019/dev_r11943_MERGE_2019/src/OCE/TRA/zpshde.F90

    r11949 r12340  
    3232   !! * Substitutions 
    3333#  include "vectopt_loop_substitute.h90" 
     34#  include "do_loop_substitute.h90" 
    3435   !!---------------------------------------------------------------------- 
    3536   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    106107      DO jn = 1, kjpt      !==   Interpolation of tracers at the last ocean level   ==! 
    107108         ! 
    108          DO jj = 1, jpjm1 
    109             DO ji = 1, jpim1 
    110                iku = mbku(ji,jj)   ;   ikum1 = MAX( iku - 1 , 1 )    ! last and before last ocean level at u- & v-points 
    111                ikv = mbkv(ji,jj)   ;   ikvm1 = MAX( ikv - 1 , 1 )    ! if level first is a p-step, ik.m1=1 
     109         DO_2D_10_10 
     110            iku = mbku(ji,jj)   ;   ikum1 = MAX( iku - 1 , 1 )    ! last and before last ocean level at u- & v-points 
     111            ikv = mbkv(ji,jj)   ;   ikvm1 = MAX( ikv - 1 , 1 )    ! if level first is a p-step, ik.m1=1 
    112112!!gm BUG ? when applied to before fields, e3w(:,:,:,Kbb) should be used.... 
    113                ze3wu = e3w(ji+1,jj  ,iku,Kmm) - e3w(ji,jj,iku,Kmm) 
    114                ze3wv = e3w(ji  ,jj+1,ikv,Kmm) - e3w(ji,jj,ikv,Kmm) 
    115                ! 
    116                ! i- direction 
    117                IF( ze3wu >= 0._wp ) THEN      ! case 1 
    118                   zmaxu =  ze3wu / e3w(ji+1,jj,iku,Kmm) 
    119                   ! interpolated values of tracers 
    120                   zti (ji,jj,jn) = pta(ji+1,jj,iku,jn) + zmaxu * ( pta(ji+1,jj,ikum1,jn) - pta(ji+1,jj,iku,jn) ) 
    121                   ! gradient of  tracers 
    122                   pgtu(ji,jj,jn) = umask(ji,jj,1) * ( zti(ji,jj,jn) - pta(ji,jj,iku,jn) ) 
    123                ELSE                           ! case 2 
    124                   zmaxu = -ze3wu / e3w(ji,jj,iku,Kmm) 
    125                   ! interpolated values of tracers 
    126                   zti (ji,jj,jn) = pta(ji,jj,iku,jn) + zmaxu * ( pta(ji,jj,ikum1,jn) - pta(ji,jj,iku,jn) ) 
    127                   ! gradient of tracers 
    128                   pgtu(ji,jj,jn) = umask(ji,jj,1) * ( pta(ji+1,jj,iku,jn) - zti(ji,jj,jn) ) 
    129                ENDIF 
    130                ! 
    131                ! j- direction 
    132                IF( ze3wv >= 0._wp ) THEN      ! case 1 
    133                   zmaxv =  ze3wv / e3w(ji,jj+1,ikv,Kmm) 
    134                   ! interpolated values of tracers 
    135                   ztj (ji,jj,jn) = pta(ji,jj+1,ikv,jn) + zmaxv * ( pta(ji,jj+1,ikvm1,jn) - pta(ji,jj+1,ikv,jn) ) 
    136                   ! gradient of tracers 
    137                   pgtv(ji,jj,jn) = vmask(ji,jj,1) * ( ztj(ji,jj,jn) - pta(ji,jj,ikv,jn) ) 
    138                ELSE                           ! case 2 
    139                   zmaxv =  -ze3wv / e3w(ji,jj,ikv,Kmm) 
    140                   ! interpolated values of tracers 
    141                   ztj (ji,jj,jn) = pta(ji,jj,ikv,jn) + zmaxv * ( pta(ji,jj,ikvm1,jn) - pta(ji,jj,ikv,jn) ) 
    142                   ! gradient of tracers 
    143                   pgtv(ji,jj,jn) = vmask(ji,jj,1) * ( pta(ji,jj+1,ikv,jn) - ztj(ji,jj,jn) ) 
    144                ENDIF 
    145             END DO 
    146          END DO 
     113            ze3wu = e3w(ji+1,jj  ,iku,Kmm) - e3w(ji,jj,iku,Kmm) 
     114            ze3wv = e3w(ji  ,jj+1,ikv,Kmm) - e3w(ji,jj,ikv,Kmm) 
     115            ! 
     116            ! i- direction 
     117            IF( ze3wu >= 0._wp ) THEN      ! case 1 
     118               zmaxu =  ze3wu / e3w(ji+1,jj,iku,Kmm) 
     119               ! interpolated values of tracers 
     120               zti (ji,jj,jn) = pta(ji+1,jj,iku,jn) + zmaxu * ( pta(ji+1,jj,ikum1,jn) - pta(ji+1,jj,iku,jn) ) 
     121               ! gradient of  tracers 
     122               pgtu(ji,jj,jn) = umask(ji,jj,1) * ( zti(ji,jj,jn) - pta(ji,jj,iku,jn) ) 
     123            ELSE                           ! case 2 
     124               zmaxu = -ze3wu / e3w(ji,jj,iku,Kmm) 
     125               ! interpolated values of tracers 
     126               zti (ji,jj,jn) = pta(ji,jj,iku,jn) + zmaxu * ( pta(ji,jj,ikum1,jn) - pta(ji,jj,iku,jn) ) 
     127               ! gradient of tracers 
     128               pgtu(ji,jj,jn) = umask(ji,jj,1) * ( pta(ji+1,jj,iku,jn) - zti(ji,jj,jn) ) 
     129            ENDIF 
     130            ! 
     131            ! j- direction 
     132            IF( ze3wv >= 0._wp ) THEN      ! case 1 
     133               zmaxv =  ze3wv / e3w(ji,jj+1,ikv,Kmm) 
     134               ! interpolated values of tracers 
     135               ztj (ji,jj,jn) = pta(ji,jj+1,ikv,jn) + zmaxv * ( pta(ji,jj+1,ikvm1,jn) - pta(ji,jj+1,ikv,jn) ) 
     136               ! gradient of tracers 
     137               pgtv(ji,jj,jn) = vmask(ji,jj,1) * ( ztj(ji,jj,jn) - pta(ji,jj,ikv,jn) ) 
     138            ELSE                           ! case 2 
     139               zmaxv =  -ze3wv / e3w(ji,jj,ikv,Kmm) 
     140               ! interpolated values of tracers 
     141               ztj (ji,jj,jn) = pta(ji,jj,ikv,jn) + zmaxv * ( pta(ji,jj,ikvm1,jn) - pta(ji,jj,ikv,jn) ) 
     142               ! gradient of tracers 
     143               pgtv(ji,jj,jn) = vmask(ji,jj,1) * ( pta(ji,jj+1,ikv,jn) - ztj(ji,jj,jn) ) 
     144            ENDIF 
     145         END_2D 
    147146      END DO 
    148147      ! 
    … …  
    152151         pgru(:,:) = 0._wp 
    153152         pgrv(:,:) = 0._wp                ! depth of the partial step level 
    154          DO jj = 1, jpjm1 
    155             DO ji = 1, jpim1 
    156                iku = mbku(ji,jj) 
    157                ikv = mbkv(ji,jj) 
    158                ze3wu  = e3w(ji+1,jj  ,iku,Kmm) - e3w(ji,jj,iku,Kmm) 
    159                ze3wv  = e3w(ji  ,jj+1,ikv,Kmm) - e3w(ji,jj,ikv,Kmm) 
    160                IF( ze3wu >= 0._wp ) THEN   ;   zhi(ji,jj) = gdept(ji  ,jj,iku,Kmm)     ! i-direction: case 1 
    161                ELSE                        ;   zhi(ji,jj) = gdept(ji+1,jj,iku,Kmm)     ! -     -      case 2 
    162                ENDIF 
    163                IF( ze3wv >= 0._wp ) THEN   ;   zhj(ji,jj) = gdept(ji,jj  ,ikv,Kmm)     ! j-direction: case 1 
    164                ELSE                        ;   zhj(ji,jj) = gdept(ji,jj+1,ikv,Kmm)     ! -     -      case 2 
    165                ENDIF 
    166             END DO 
    167          END DO 
     153         DO_2D_10_10 
     154            iku = mbku(ji,jj) 
     155            ikv = mbkv(ji,jj) 
     156            ze3wu  = e3w(ji+1,jj  ,iku,Kmm) - e3w(ji,jj,iku,Kmm) 
     157            ze3wv  = e3w(ji  ,jj+1,ikv,Kmm) - e3w(ji,jj,ikv,Kmm) 
     158            IF( ze3wu >= 0._wp ) THEN   ;   zhi(ji,jj) = gdept(ji  ,jj,iku,Kmm)     ! i-direction: case 1 
     159            ELSE                        ;   zhi(ji,jj) = gdept(ji+1,jj,iku,Kmm)     ! -     -      case 2 
     160            ENDIF 
     161            IF( ze3wv >= 0._wp ) THEN   ;   zhj(ji,jj) = gdept(ji,jj  ,ikv,Kmm)     ! j-direction: case 1 
     162            ELSE                        ;   zhj(ji,jj) = gdept(ji,jj+1,ikv,Kmm)     ! -     -      case 2 
     163            ENDIF 
     164         END_2D 
    168165         ! 
    169166         CALL eos( zti, zhi, zri )        ! interpolated density from zti, ztj  
    170167         CALL eos( ztj, zhj, zrj )        ! at the partial step depth output in  zri, zrj  
    171168         ! 
    172          DO jj = 1, jpjm1                 ! Gradient of density at the last level  
    173             DO ji = 1, jpim1 
    174                iku = mbku(ji,jj) 
    175                ikv = mbkv(ji,jj) 
    176                ze3wu  = e3w(ji+1,jj  ,iku,Kmm) - e3w(ji,jj,iku,Kmm) 
    177                ze3wv  = e3w(ji  ,jj+1,ikv,Kmm) - e3w(ji,jj,ikv,Kmm) 
    178                IF( ze3wu >= 0._wp ) THEN   ;   pgru(ji,jj) = umask(ji,jj,1) * ( zri(ji  ,jj    ) - prd(ji,jj,iku) )   ! i: 1 
    179                ELSE                        ;   pgru(ji,jj) = umask(ji,jj,1) * ( prd(ji+1,jj,iku) - zri(ji,jj    ) )   ! i: 2 
    180                ENDIF 
    181                IF( ze3wv >= 0._wp ) THEN   ;   pgrv(ji,jj) = vmask(ji,jj,1) * ( zrj(ji,jj      ) - prd(ji,jj,ikv) )   ! j: 1 
    182                ELSE                        ;   pgrv(ji,jj) = vmask(ji,jj,1) * ( prd(ji,jj+1,ikv) - zrj(ji,jj    ) )   ! j: 2 
    183                ENDIF 
    184             END DO 
    185          END DO 
     169         DO_2D_10_10 
     170            iku = mbku(ji,jj) 
     171            ikv = mbkv(ji,jj) 
     172            ze3wu  = e3w(ji+1,jj  ,iku,Kmm) - e3w(ji,jj,iku,Kmm) 
     173            ze3wv  = e3w(ji  ,jj+1,ikv,Kmm) - e3w(ji,jj,ikv,Kmm) 
     174            IF( ze3wu >= 0._wp ) THEN   ;   pgru(ji,jj) = umask(ji,jj,1) * ( zri(ji  ,jj    ) - prd(ji,jj,iku) )   ! i: 1 
     175            ELSE                        ;   pgru(ji,jj) = umask(ji,jj,1) * ( prd(ji+1,jj,iku) - zri(ji,jj    ) )   ! i: 2 
     176            ENDIF 
     177            IF( ze3wv >= 0._wp ) THEN   ;   pgrv(ji,jj) = vmask(ji,jj,1) * ( zrj(ji,jj      ) - prd(ji,jj,ikv) )   ! j: 1 
     178            ELSE                        ;   pgrv(ji,jj) = vmask(ji,jj,1) * ( prd(ji,jj+1,ikv) - zrj(ji,jj    ) )   ! j: 2 
     179            ENDIF 
     180         END_2D 
    186181         CALL lbc_lnk_multi( 'zpshde', pgru , 'U', -1. , pgrv , 'V', -1. )   ! Lateral boundary conditions 
    187182         ! 
    … …  
    267262      DO jn = 1, kjpt      !==   Interpolation of tracers at the last ocean level   ==! 
    268263         ! 
    269          DO jj = 1, jpjm1 
    270             DO ji = 1, jpim1 
    271  
    272                iku = mbku(ji,jj); ikum1 = MAX( iku - 1 , 1 )    ! last and before last ocean level at u- & v-points 
    273                ikv = mbkv(ji,jj); ikvm1 = MAX( ikv - 1 , 1 )    ! if level first is a p-step, ik.m1=1 
    274                ze3wu = gdept(ji+1,jj,iku,Kmm) - gdept(ji,jj,iku,Kmm) 
    275                ze3wv = gdept(ji,jj+1,ikv,Kmm) - gdept(ji,jj,ikv,Kmm) 
    276                ! 
    277                ! i- direction 
    278                IF( ze3wu >= 0._wp ) THEN      ! case 1 
    279                   zmaxu =  ze3wu / e3w(ji+1,jj,iku,Kmm) 
    280                   ! interpolated values of tracers 
    281                   zti (ji,jj,jn) = pta(ji+1,jj,iku,jn) + zmaxu * ( pta(ji+1,jj,ikum1,jn) - pta(ji+1,jj,iku,jn) ) 
    282                   ! gradient of  tracers 
    283                   pgtu(ji,jj,jn) = ssumask(ji,jj) * ( zti(ji,jj,jn) - pta(ji,jj,iku,jn) ) 
    284                ELSE                           ! case 2 
    285                   zmaxu = -ze3wu / e3w(ji,jj,iku,Kmm) 
    286                   ! interpolated values of tracers 
    287                   zti (ji,jj,jn) = pta(ji,jj,iku,jn) + zmaxu * ( pta(ji,jj,ikum1,jn) - pta(ji,jj,iku,jn) ) 
    288                   ! gradient of tracers 
    289                   pgtu(ji,jj,jn) = ssumask(ji,jj) * ( pta(ji+1,jj,iku,jn) - zti(ji,jj,jn) ) 
    290                ENDIF 
    291                ! 
    292                ! j- direction 
    293                IF( ze3wv >= 0._wp ) THEN      ! case 1 
    294                   zmaxv =  ze3wv / e3w(ji,jj+1,ikv,Kmm) 
    295                   ! interpolated values of tracers 
    296                   ztj (ji,jj,jn) = pta(ji,jj+1,ikv,jn) + zmaxv * ( pta(ji,jj+1,ikvm1,jn) - pta(ji,jj+1,ikv,jn) ) 
    297                   ! gradient of tracers 
    298                   pgtv(ji,jj,jn) = ssvmask(ji,jj) * ( ztj(ji,jj,jn) - pta(ji,jj,ikv,jn) ) 
    299                ELSE                           ! case 2 
    300                   zmaxv =  -ze3wv / e3w(ji,jj,ikv,Kmm) 
    301                   ! interpolated values of tracers 
    302                   ztj (ji,jj,jn) = pta(ji,jj,ikv,jn) + zmaxv * ( pta(ji,jj,ikvm1,jn) - pta(ji,jj,ikv,jn) ) 
    303                   ! gradient of tracers 
    304                   pgtv(ji,jj,jn) = ssvmask(ji,jj) * ( pta(ji,jj+1,ikv,jn) - ztj(ji,jj,jn) ) 
    305                ENDIF 
    306  
    307             END DO 
    308          END DO 
     264         DO_2D_10_10 
     265 
     266            iku = mbku(ji,jj); ikum1 = MAX( iku - 1 , 1 )    ! last and before last ocean level at u- & v-points 
     267            ikv = mbkv(ji,jj); ikvm1 = MAX( ikv - 1 , 1 )    ! if level first is a p-step, ik.m1=1 
     268            ze3wu = gdept(ji+1,jj,iku,Kmm) - gdept(ji,jj,iku,Kmm) 
     269            ze3wv = gdept(ji,jj+1,ikv,Kmm) - gdept(ji,jj,ikv,Kmm) 
     270            ! 
     271            ! i- direction 
     272            IF( ze3wu >= 0._wp ) THEN      ! case 1 
     273               zmaxu =  ze3wu / e3w(ji+1,jj,iku,Kmm) 
     274               ! interpolated values of tracers 
     275               zti (ji,jj,jn) = pta(ji+1,jj,iku,jn) + zmaxu * ( pta(ji+1,jj,ikum1,jn) - pta(ji+1,jj,iku,jn) ) 
     276               ! gradient of  tracers 
     277               pgtu(ji,jj,jn) = ssumask(ji,jj) * ( zti(ji,jj,jn) - pta(ji,jj,iku,jn) ) 
     278            ELSE                           ! case 2 
     279               zmaxu = -ze3wu / e3w(ji,jj,iku,Kmm) 
     280               ! interpolated values of tracers 
     281               zti (ji,jj,jn) = pta(ji,jj,iku,jn) + zmaxu * ( pta(ji,jj,ikum1,jn) - pta(ji,jj,iku,jn) ) 
     282               ! gradient of tracers 
     283               pgtu(ji,jj,jn) = ssumask(ji,jj) * ( pta(ji+1,jj,iku,jn) - zti(ji,jj,jn) ) 
     284            ENDIF 
     285            ! 
     286            ! j- direction 
     287            IF( ze3wv >= 0._wp ) THEN      ! case 1 
     288               zmaxv =  ze3wv / e3w(ji,jj+1,ikv,Kmm) 
     289               ! interpolated values of tracers 
     290               ztj (ji,jj,jn) = pta(ji,jj+1,ikv,jn) + zmaxv * ( pta(ji,jj+1,ikvm1,jn) - pta(ji,jj+1,ikv,jn) ) 
     291               ! gradient of tracers 
     292               pgtv(ji,jj,jn) = ssvmask(ji,jj) * ( ztj(ji,jj,jn) - pta(ji,jj,ikv,jn) ) 
     293            ELSE                           ! case 2 
     294               zmaxv =  -ze3wv / e3w(ji,jj,ikv,Kmm) 
     295               ! interpolated values of tracers 
     296               ztj (ji,jj,jn) = pta(ji,jj,ikv,jn) + zmaxv * ( pta(ji,jj,ikvm1,jn) - pta(ji,jj,ikv,jn) ) 
     297               ! gradient of tracers 
     298               pgtv(ji,jj,jn) = ssvmask(ji,jj) * ( pta(ji,jj+1,ikv,jn) - ztj(ji,jj,jn) ) 
     299            ENDIF 
     300 
     301         END_2D 
    309302      END DO 
    310303      ! 
    … …  
    315308         pgru(:,:)=0.0_wp   ; pgrv(:,:)=0.0_wp ;  
    316309         ! 
    317          DO jj = 1, jpjm1 
    318             DO ji = 1, jpim1 
    319  
    320                iku = mbku(ji,jj) 
    321                ikv = mbkv(ji,jj) 
    322                ze3wu = gdept(ji+1,jj,iku,Kmm) - gdept(ji,jj,iku,Kmm) 
    323                ze3wv = gdept(ji,jj+1,ikv,Kmm) - gdept(ji,jj,ikv,Kmm) 
    324                ! 
    325                IF( ze3wu >= 0._wp ) THEN   ;   zhi(ji,jj) = gdept(ji  ,jj,iku,Kmm)    ! i-direction: case 1 
    326                ELSE                        ;   zhi(ji,jj) = gdept(ji+1,jj,iku,Kmm)    ! -     -      case 2 
    327                ENDIF 
    328                IF( ze3wv >= 0._wp ) THEN   ;   zhj(ji,jj) = gdept(ji,jj  ,ikv,Kmm)    ! j-direction: case 1 
    329                ELSE                        ;   zhj(ji,jj) = gdept(ji,jj+1,ikv,Kmm)    ! -     -      case 2 
    330                ENDIF 
    331  
    332             END DO 
    333          END DO 
     310         DO_2D_10_10 
     311 
     312            iku = mbku(ji,jj) 
     313            ikv = mbkv(ji,jj) 
     314            ze3wu = gdept(ji+1,jj,iku,Kmm) - gdept(ji,jj,iku,Kmm) 
     315            ze3wv = gdept(ji,jj+1,ikv,Kmm) - gdept(ji,jj,ikv,Kmm) 
     316            ! 
     317            IF( ze3wu >= 0._wp ) THEN   ;   zhi(ji,jj) = gdept(ji  ,jj,iku,Kmm)    ! i-direction: case 1 
     318            ELSE                        ;   zhi(ji,jj) = gdept(ji+1,jj,iku,Kmm)    ! -     -      case 2 
     319            ENDIF 
     320            IF( ze3wv >= 0._wp ) THEN   ;   zhj(ji,jj) = gdept(ji,jj  ,ikv,Kmm)    ! j-direction: case 1 
     321            ELSE                        ;   zhj(ji,jj) = gdept(ji,jj+1,ikv,Kmm)    ! -     -      case 2 
     322            ENDIF 
     323 
     324         END_2D 
    334325 
    335326         ! Compute interpolated rd from zti, ztj for the 2 cases at the depth of the partial 
    … …  
    338329         CALL eos( ztj, zhj, zrj ) 
    339330 
    340          DO jj = 1, jpjm1                 ! Gradient of density at the last level  
    341             DO ji = 1, jpim1 
    342                iku = mbku(ji,jj) 
    343                ikv = mbkv(ji,jj) 
    344                ze3wu = gdept(ji+1,jj,iku,Kmm) - gdept(ji,jj,iku,Kmm) 
    345                ze3wv = gdept(ji,jj+1,ikv,Kmm) - gdept(ji,jj,ikv,Kmm) 
    346  
    347                IF( ze3wu >= 0._wp ) THEN   ;   pgru(ji,jj) = ssumask(ji,jj) * ( zri(ji  ,jj    ) - prd(ji,jj,iku) )   ! i: 1 
    348                ELSE                        ;   pgru(ji,jj) = ssumask(ji,jj) * ( prd(ji+1,jj,iku) - zri(ji,jj    ) )   ! i: 2 
    349                ENDIF 
    350                IF( ze3wv >= 0._wp ) THEN   ;   pgrv(ji,jj) = ssvmask(ji,jj) * ( zrj(ji,jj      ) - prd(ji,jj,ikv) )   ! j: 1 
    351                ELSE                        ;   pgrv(ji,jj) = ssvmask(ji,jj) * ( prd(ji,jj+1,ikv) - zrj(ji,jj    ) )   ! j: 2 
    352                ENDIF 
    353  
    354             END DO 
    355          END DO 
     331         DO_2D_10_10 
     332            iku = mbku(ji,jj) 
     333            ikv = mbkv(ji,jj) 
     334            ze3wu = gdept(ji+1,jj,iku,Kmm) - gdept(ji,jj,iku,Kmm) 
     335            ze3wv = gdept(ji,jj+1,ikv,Kmm) - gdept(ji,jj,ikv,Kmm) 
     336 
     337            IF( ze3wu >= 0._wp ) THEN   ;   pgru(ji,jj) = ssumask(ji,jj) * ( zri(ji  ,jj    ) - prd(ji,jj,iku) )   ! i: 1 
     338            ELSE                        ;   pgru(ji,jj) = ssumask(ji,jj) * ( prd(ji+1,jj,iku) - zri(ji,jj    ) )   ! i: 2 
     339            ENDIF 
     340            IF( ze3wv >= 0._wp ) THEN   ;   pgrv(ji,jj) = ssvmask(ji,jj) * ( zrj(ji,jj      ) - prd(ji,jj,ikv) )   ! j: 1 
     341            ELSE                        ;   pgrv(ji,jj) = ssvmask(ji,jj) * ( prd(ji,jj+1,ikv) - zrj(ji,jj    ) )   ! j: 2 
     342            ENDIF 
     343 
     344         END_2D 
    356345 
    357346         CALL lbc_lnk_multi( 'zpshde', pgru , 'U', -1. , pgrv , 'V', -1. )   ! Lateral boundary conditions 
    … …  
    362351      ! 
    363352      DO jn = 1, kjpt      !==   Interpolation of tracers at the last ocean level   ==!            ! 
    364          DO jj = 1, jpjm1 
    365             DO ji = 1, jpim1 
    366                iku = miku(ji,jj); ikup1 = miku(ji,jj) + 1 
    367                ikv = mikv(ji,jj); ikvp1 = mikv(ji,jj) + 1 
    368                ! 
    369                ! (ISF) case partial step top and bottom in adjacent cell in vertical 
    370                ! cannot used e3w because if 2 cell water column, we have ps at top and bottom 
    371                ! in this case e3w(i,j) - e3w(i,j+1) is not the distance between Tj~ and Tj 
    372                ! the only common depth between cells (i,j) and (i,j+1) is gdepw_0 
    373                ze3wu  =  gdept(ji,jj,iku,Kmm) - gdept(ji+1,jj,iku,Kmm) 
    374                ze3wv  =  gdept(ji,jj,ikv,Kmm) - gdept(ji,jj+1,ikv,Kmm)  
    375  
    376                ! i- direction 
    377                IF( ze3wu >= 0._wp ) THEN      ! case 1 
    378                   zmaxu = ze3wu / e3w(ji+1,jj,ikup1,Kmm) 
    379                   ! interpolated values of tracers 
    380                   zti(ji,jj,jn) = pta(ji+1,jj,iku,jn) + zmaxu * ( pta(ji+1,jj,ikup1,jn) - pta(ji+1,jj,iku,jn) ) 
    381                   ! gradient of tracers 
    382                   pgtui(ji,jj,jn) = ssumask(ji,jj) * ( zti(ji,jj,jn) - pta(ji,jj,iku,jn) ) 
    383                ELSE                           ! case 2 
    384                   zmaxu = - ze3wu / e3w(ji,jj,ikup1,Kmm) 
    385                   ! interpolated values of tracers 
    386                   zti(ji,jj,jn) = pta(ji,jj,iku,jn) + zmaxu * ( pta(ji,jj,ikup1,jn) - pta(ji,jj,iku,jn) ) 
    387                   ! gradient of  tracers 
    388                   pgtui(ji,jj,jn) = ssumask(ji,jj) * ( pta(ji+1,jj,iku,jn) - zti(ji,jj,jn) ) 
    389                ENDIF 
    390                ! 
    391                ! j- direction 
    392                IF( ze3wv >= 0._wp ) THEN      ! case 1 
    393                   zmaxv =  ze3wv / e3w(ji,jj+1,ikvp1,Kmm) 
    394                   ! interpolated values of tracers 
    395                   ztj(ji,jj,jn) = pta(ji,jj+1,ikv,jn) + zmaxv * ( pta(ji,jj+1,ikvp1,jn) - pta(ji,jj+1,ikv,jn) ) 
    396                   ! gradient of tracers 
    397                   pgtvi(ji,jj,jn) = ssvmask(ji,jj) * ( ztj(ji,jj,jn) - pta(ji,jj,ikv,jn) ) 
    398                ELSE                           ! case 2 
    399                   zmaxv =  - ze3wv / e3w(ji,jj,ikvp1,Kmm) 
    400                   ! interpolated values of tracers 
    401                   ztj(ji,jj,jn) = pta(ji,jj,ikv,jn) + zmaxv * ( pta(ji,jj,ikvp1,jn) - pta(ji,jj,ikv,jn) ) 
    402                   ! gradient of tracers 
    403                   pgtvi(ji,jj,jn) = ssvmask(ji,jj) * ( pta(ji,jj+1,ikv,jn) - ztj(ji,jj,jn) ) 
    404                ENDIF 
    405  
    406             END DO 
    407          END DO 
     353         DO_2D_10_10 
     354            iku = miku(ji,jj); ikup1 = miku(ji,jj) + 1 
     355            ikv = mikv(ji,jj); ikvp1 = mikv(ji,jj) + 1 
     356            ! 
     357            ! (ISF) case partial step top and bottom in adjacent cell in vertical 
     358            ! cannot used e3w because if 2 cell water column, we have ps at top and bottom 
     359            ! in this case e3w(i,j) - e3w(i,j+1) is not the distance between Tj~ and Tj 
     360            ! the only common depth between cells (i,j) and (i,j+1) is gdepw_0 
     361            ze3wu  =  gdept(ji,jj,iku,Kmm) - gdept(ji+1,jj,iku,Kmm) 
     362            ze3wv  =  gdept(ji,jj,ikv,Kmm) - gdept(ji,jj+1,ikv,Kmm)  
     363 
     364            ! i- direction 
     365            IF( ze3wu >= 0._wp ) THEN      ! case 1 
     366               zmaxu = ze3wu / e3w(ji+1,jj,ikup1,Kmm) 
     367               ! interpolated values of tracers 
     368               zti(ji,jj,jn) = pta(ji+1,jj,iku,jn) + zmaxu * ( pta(ji+1,jj,ikup1,jn) - pta(ji+1,jj,iku,jn) ) 
     369               ! gradient of tracers 
     370               pgtui(ji,jj,jn) = ssumask(ji,jj) * ( zti(ji,jj,jn) - pta(ji,jj,iku,jn) ) 
     371            ELSE                           ! case 2 
     372               zmaxu = - ze3wu / e3w(ji,jj,ikup1,Kmm) 
     373               ! interpolated values of tracers 
     374               zti(ji,jj,jn) = pta(ji,jj,iku,jn) + zmaxu * ( pta(ji,jj,ikup1,jn) - pta(ji,jj,iku,jn) ) 
     375               ! gradient of  tracers 
     376               pgtui(ji,jj,jn) = ssumask(ji,jj) * ( pta(ji+1,jj,iku,jn) - zti(ji,jj,jn) ) 
     377            ENDIF 
     378            ! 
     379            ! j- direction 
     380            IF( ze3wv >= 0._wp ) THEN      ! case 1 
     381               zmaxv =  ze3wv / e3w(ji,jj+1,ikvp1,Kmm) 
     382               ! interpolated values of tracers 
     383               ztj(ji,jj,jn) = pta(ji,jj+1,ikv,jn) + zmaxv * ( pta(ji,jj+1,ikvp1,jn) - pta(ji,jj+1,ikv,jn) ) 
     384               ! gradient of tracers 
     385               pgtvi(ji,jj,jn) = ssvmask(ji,jj) * ( ztj(ji,jj,jn) - pta(ji,jj,ikv,jn) ) 
     386            ELSE                           ! case 2 
     387               zmaxv =  - ze3wv / e3w(ji,jj,ikvp1,Kmm) 
     388               ! interpolated values of tracers 
     389               ztj(ji,jj,jn) = pta(ji,jj,ikv,jn) + zmaxv * ( pta(ji,jj,ikvp1,jn) - pta(ji,jj,ikv,jn) ) 
     390               ! gradient of tracers 
     391               pgtvi(ji,jj,jn) = ssvmask(ji,jj) * ( pta(ji,jj+1,ikv,jn) - ztj(ji,jj,jn) ) 
     392            ENDIF 
     393 
     394         END_2D 
    408395         ! 
    409396      END DO 
    … …  
    413400         ! 
    414401         pgrui(:,:)  =0.0_wp; pgrvi(:,:)  =0.0_wp; 
    415          DO jj = 1, jpjm1 
    416             DO ji = 1, jpim1 
    417  
    418                iku = miku(ji,jj) 
    419                ikv = mikv(ji,jj) 
    420                ze3wu  =  gdept(ji,jj,iku,Kmm) - gdept(ji+1,jj,iku,Kmm) 
    421                ze3wv  =  gdept(ji,jj,ikv,Kmm) - gdept(ji,jj+1,ikv,Kmm)  
    422                ! 
    423                IF( ze3wu >= 0._wp ) THEN   ;   zhi(ji,jj) = gdept(ji  ,jj,iku,Kmm)    ! i-direction: case 1 
    424                ELSE                        ;   zhi(ji,jj) = gdept(ji+1,jj,iku,Kmm)    ! -     -      case 2 
    425                ENDIF 
    426  
    427                IF( ze3wv >= 0._wp ) THEN   ;   zhj(ji,jj) = gdept(ji,jj  ,ikv,Kmm)    ! j-direction: case 1 
    428                ELSE                        ;   zhj(ji,jj) = gdept(ji,jj+1,ikv,Kmm)    ! -     -      case 2 
    429                ENDIF 
    430  
    431             END DO 
    432          END DO 
     402         DO_2D_10_10 
     403 
     404            iku = miku(ji,jj) 
     405            ikv = mikv(ji,jj) 
     406            ze3wu  =  gdept(ji,jj,iku,Kmm) - gdept(ji+1,jj,iku,Kmm) 
     407            ze3wv  =  gdept(ji,jj,ikv,Kmm) - gdept(ji,jj+1,ikv,Kmm)  
     408            ! 
     409            IF( ze3wu >= 0._wp ) THEN   ;   zhi(ji,jj) = gdept(ji  ,jj,iku,Kmm)    ! i-direction: case 1 
     410            ELSE                        ;   zhi(ji,jj) = gdept(ji+1,jj,iku,Kmm)    ! -     -      case 2 
     411            ENDIF 
     412 
     413            IF( ze3wv >= 0._wp ) THEN   ;   zhj(ji,jj) = gdept(ji,jj  ,ikv,Kmm)    ! j-direction: case 1 
     414            ELSE                        ;   zhj(ji,jj) = gdept(ji,jj+1,ikv,Kmm)    ! -     -      case 2 
     415            ENDIF 
     416 
     417         END_2D 
    433418         ! 
    434419         CALL eos( zti, zhi, zri )        ! interpolated density from zti, ztj  
    435420         CALL eos( ztj, zhj, zrj )        ! at the partial step depth output in  zri, zrj  
    436421         ! 
    437          DO jj = 1, jpjm1                 ! Gradient of density at the last level  
    438             DO ji = 1, jpim1 
    439                iku = miku(ji,jj)  
    440                ikv = mikv(ji,jj)  
    441                ze3wu  =  gdept(ji,jj,iku,Kmm) - gdept(ji+1,jj,iku,Kmm) 
    442                ze3wv  =  gdept(ji,jj,ikv,Kmm) - gdept(ji,jj+1,ikv,Kmm)  
    443  
    444                IF( ze3wu >= 0._wp ) THEN ; pgrui(ji,jj) = ssumask(ji,jj) * ( zri(ji  ,jj      ) - prd(ji,jj,iku) ) ! i: 1 
    445                ELSE                      ; pgrui(ji,jj) = ssumask(ji,jj) * ( prd(ji+1,jj  ,iku) - zri(ji,jj    ) ) ! i: 2 
    446                ENDIF 
    447                IF( ze3wv >= 0._wp ) THEN ; pgrvi(ji,jj) = ssvmask(ji,jj) * ( zrj(ji  ,jj      ) - prd(ji,jj,ikv) ) ! j: 1 
    448                ELSE                      ; pgrvi(ji,jj) = ssvmask(ji,jj) * ( prd(ji  ,jj+1,ikv) - zrj(ji,jj    ) ) ! j: 2 
    449                ENDIF 
    450  
    451             END DO 
    452          END DO 
     422         DO_2D_10_10 
     423            iku = miku(ji,jj)  
     424            ikv = mikv(ji,jj)  
     425            ze3wu  =  gdept(ji,jj,iku,Kmm) - gdept(ji+1,jj,iku,Kmm) 
     426            ze3wv  =  gdept(ji,jj,ikv,Kmm) - gdept(ji,jj+1,ikv,Kmm)  
     427 
     428            IF( ze3wu >= 0._wp ) THEN ; pgrui(ji,jj) = ssumask(ji,jj) * ( zri(ji  ,jj      ) - prd(ji,jj,iku) ) ! i: 1 
     429            ELSE                      ; pgrui(ji,jj) = ssumask(ji,jj) * ( prd(ji+1,jj  ,iku) - zri(ji,jj    ) ) ! i: 2 
     430            ENDIF 
     431            IF( ze3wv >= 0._wp ) THEN ; pgrvi(ji,jj) = ssvmask(ji,jj) * ( zrj(ji  ,jj      ) - prd(ji,jj,ikv) ) ! j: 1 
     432            ELSE                      ; pgrvi(ji,jj) = ssvmask(ji,jj) * ( prd(ji  ,jj+1,ikv) - zrj(ji,jj    ) ) ! j: 2 
     433            ENDIF 
     434 
     435         END_2D 
    453436         CALL lbc_lnk_multi( 'zpshde', pgrui, 'U', -1. , pgrvi, 'V', -1. )   ! Lateral boundary conditions 
    454437         ! 
Note: See TracChangeset for help on using the changeset viewer.