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 – NEMO

Changeset 12340


Ignore:
Timestamp:
2020-01-27T15:31:53+01:00 (5 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
Files:
1 added
194 edited

Legend:

Unmodified
Added
Removed
  • NEMO/branches/2019/dev_r11943_MERGE_2019/src/ABL/ablmod.F90

    r12236 r12340  
    3333   !! * Substitutions 
    3434#  include "vectopt_loop_substitute.h90" 
     35#  include "do_loop_substitute.h90" 
    3536 
    3637CONTAINS 
     
    126127      !! needed for surface boundary condition of TKE  
    127128      !! pwndm contains | U10m - U_oce | (see blk_oce_1 in sbcblk) 
    128       DO jj = 1,jpj 
    129          DO ji = 1,jpi 
    130             zzoce         = pCd_du    (ji,jj) * pwndm    (ji,jj) 
     129      DO_2D_11_11 
     130         zzoce         = pCd_du    (ji,jj) * pwndm    (ji,jj) 
    131131#if defined key_si3 
    132             zzice         = pCd_du_ice(ji,jj) * pwndm_ice(ji,jj)  
    133             ustar2(ji,jj) = zzoce * pfrac_oce(ji,jj) + (1._wp - pfrac_oce(ji,jj)) * zzice  
     132         zzice         = pCd_du_ice(ji,jj) * pwndm_ice(ji,jj)  
     133         ustar2(ji,jj) = zzoce * pfrac_oce(ji,jj) + (1._wp - pfrac_oce(ji,jj)) * zzice  
    134134#else 
    135             ustar2(ji,jj) = zzoce    
     135         ustar2(ji,jj) = zzoce    
    136136#endif 
    137          END DO 
    138       END DO   
     137      END_2D 
    139138      ! 
    140139      !                            !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
     
    243242         !              
    244243         ! Advance u_abl & v_abl to time n+1 
    245          DO jj = 1, jpj 
    246             DO ji = 1, jpi            
    247                zcff = ( fft_abl(ji,jj) * rdt_abl )*( fft_abl(ji,jj) * rdt_abl )  ! (f dt)**2 
    248        
    249                u_abl( ji, jj, jk, nt_a ) = e3t_abl(jk) *(  & 
    250                   &        (1._wp-gamma_Cor*(1._wp-gamma_Cor)*zcff)*u_abl( ji, jj, jk, nt_n )    & 
    251                   &                 +  rdt_abl * fft_abl(ji, jj) * v_abl ( ji , jj  , jk, nt_n ) )  & 
    252                   &                               / (1._wp + gamma_Cor*gamma_Cor*zcff) 
    253                    
    254                v_abl( ji, jj, jk, nt_a ) =  e3t_abl(jk) *(  & 
    255                   &        (1._wp-gamma_Cor*(1._wp-gamma_Cor)*zcff)*v_abl( ji, jj, jk, nt_n )   & 
    256                   &                 -  rdt_abl * fft_abl(ji, jj) * u_abl ( ji   , jj, jk, nt_n )  ) & 
    257                   &                                / (1._wp + gamma_Cor*gamma_Cor*zcff)                 
    258             END DO 
    259          END DO  
     244         DO_2D_11_11 
     245            zcff = ( fft_abl(ji,jj) * rdt_abl )*( fft_abl(ji,jj) * rdt_abl )  ! (f dt)**2 
     246    
     247            u_abl( ji, jj, jk, nt_a ) = e3t_abl(jk) *(  & 
     248               &        (1._wp-gamma_Cor*(1._wp-gamma_Cor)*zcff)*u_abl( ji, jj, jk, nt_n )    & 
     249               &                 +  rdt_abl * fft_abl(ji, jj) * v_abl ( ji , jj  , jk, nt_n ) )  & 
     250               &                               / (1._wp + gamma_Cor*gamma_Cor*zcff) 
     251                
     252            v_abl( ji, jj, jk, nt_a ) =  e3t_abl(jk) *(  & 
     253               &        (1._wp-gamma_Cor*(1._wp-gamma_Cor)*zcff)*v_abl( ji, jj, jk, nt_n )   & 
     254               &                 -  rdt_abl * fft_abl(ji, jj) * u_abl ( ji   , jj, jk, nt_n )  ) & 
     255               &                                / (1._wp + gamma_Cor*gamma_Cor*zcff)                 
     256         END_2D 
    260257         !                                    
    261258      !------------- 
     
    433430         DO jk = 2, jpka    ! outer loop 
    434431         !-------------        
    435             DO jj = 2, jpj 
    436                DO ji = 2, jpi 
    437                   zcff1 = pblh( ji, jj ) 
    438                   zsig  = ght_abl(jk) / MAX( jp_pblh_min,  MIN(  jp_pblh_max, zcff1  ) )                         
    439                   zsig  =               MIN( jp_bmax    ,  MAX(         zsig, jp_bmin) )  
    440                   zmsk  = msk_abl(ji,jj) 
    441                   zcff2 = jp_alp3_dyn * zsig**3 + jp_alp2_dyn * zsig**2   & 
    442                      &  + jp_alp1_dyn * zsig    + jp_alp0_dyn 
    443                   zcff  = (1._wp-zmsk) + zmsk * zcff2 * rdt   ! zcff = 1 for masked points 
    444                                                               ! rdt = rdt_abl / nn_fsbc                           
    445                   zcff  = zcff * rest_eq(ji,jj) 
    446                   z_cft( ji, jj, jk ) = zcff 
    447                   u_abl( ji, jj, jk, nt_a ) = (1._wp - zcff ) *  u_abl( ji, jj, jk, nt_a )   & 
    448                      &                               + zcff   * pu_dta( ji, jj, jk       )                       
    449                   v_abl( ji, jj, jk, nt_a ) = (1._wp - zcff ) *  v_abl( ji, jj, jk, nt_a )   & 
    450                      &                               + zcff   * pv_dta( ji, jj, jk       ) 
    451                END DO 
    452             END DO    
     432            DO_2D_01_01 
     433               zcff1 = pblh( ji, jj ) 
     434               zsig  = ght_abl(jk) / MAX( jp_pblh_min,  MIN(  jp_pblh_max, zcff1  ) )                         
     435               zsig  =               MIN( jp_bmax    ,  MAX(         zsig, jp_bmin) )  
     436               zmsk  = msk_abl(ji,jj) 
     437               zcff2 = jp_alp3_dyn * zsig**3 + jp_alp2_dyn * zsig**2   & 
     438                  &  + jp_alp1_dyn * zsig    + jp_alp0_dyn 
     439               zcff  = (1._wp-zmsk) + zmsk * zcff2 * rdt   ! zcff = 1 for masked points 
     440                                                           ! rdt = rdt_abl / nn_fsbc                           
     441               zcff  = zcff * rest_eq(ji,jj) 
     442               z_cft( ji, jj, jk ) = zcff 
     443               u_abl( ji, jj, jk, nt_a ) = (1._wp - zcff ) *  u_abl( ji, jj, jk, nt_a )   & 
     444                  &                               + zcff   * pu_dta( ji, jj, jk       )                       
     445               v_abl( ji, jj, jk, nt_a ) = (1._wp - zcff ) *  v_abl( ji, jj, jk, nt_a )   & 
     446                  &                               + zcff   * pv_dta( ji, jj, jk       ) 
     447            END_2D 
    453448         !------------- 
    454449         END DO             ! end outer loop 
     
    459454      DO jk = 2, jpka    ! outer loop 
    460455      !-------------        
    461          DO jj = 1,jpj 
    462             DO ji = 1,jpi  
    463                zcff1 = pblh( ji, jj ) 
    464                zsig  = ght_abl(jk) / MAX( jp_pblh_min,  MIN(  jp_pblh_max, zcff1  ) ) 
    465                zsig  =               MIN( jp_bmax    ,  MAX(         zsig, jp_bmin) )  
    466                zmsk  = msk_abl(ji,jj) 
    467                zcff2 = jp_alp3_tra * zsig**3 + jp_alp2_tra * zsig**2   & 
    468                   &  + jp_alp1_tra * zsig    + jp_alp0_tra 
    469                zcff  = (1._wp-zmsk) + zmsk * zcff2 * rdt   ! zcff = 1 for masked points 
    470                                                            ! rdt = rdt_abl / nn_fsbc                           
    471                !z_cft( ji, jj, jk ) = zcff 
    472                tq_abl( ji, jj, jk, nt_a, jp_ta ) = (1._wp - zcff ) * tq_abl( ji, jj, jk, nt_a, jp_ta )   & 
    473                   &                                       + zcff   * pt_dta( ji, jj, jk ) 
    474                 
    475                tq_abl( ji, jj, jk, nt_a, jp_qa ) = (1._wp - zcff ) * tq_abl( ji, jj, jk, nt_a, jp_qa )   & 
    476                   &                                       + zcff   * pq_dta( ji, jj, jk ) 
    477                 
    478             END DO 
    479          END DO 
     456         DO_2D_11_11 
     457            zcff1 = pblh( ji, jj ) 
     458            zsig  = ght_abl(jk) / MAX( jp_pblh_min,  MIN(  jp_pblh_max, zcff1  ) ) 
     459            zsig  =               MIN( jp_bmax    ,  MAX(         zsig, jp_bmin) )  
     460            zmsk  = msk_abl(ji,jj) 
     461            zcff2 = jp_alp3_tra * zsig**3 + jp_alp2_tra * zsig**2   & 
     462               &  + jp_alp1_tra * zsig    + jp_alp0_tra 
     463            zcff  = (1._wp-zmsk) + zmsk * zcff2 * rdt   ! zcff = 1 for masked points 
     464                                                        ! rdt = rdt_abl / nn_fsbc                           
     465            !z_cft( ji, jj, jk ) = zcff 
     466            tq_abl( ji, jj, jk, nt_a, jp_ta ) = (1._wp - zcff ) * tq_abl( ji, jj, jk, nt_a, jp_ta )   & 
     467               &                                       + zcff   * pt_dta( ji, jj, jk ) 
     468             
     469            tq_abl( ji, jj, jk, nt_a, jp_qa ) = (1._wp - zcff ) * tq_abl( ji, jj, jk, nt_a, jp_qa )   & 
     470               &                                       + zcff   * pq_dta( ji, jj, jk ) 
     471             
     472         END_2D 
    480473      !------------- 
    481474      END DO             ! end outer loop 
     
    526519      !                            !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<  
    527520 
    528       DO jj = 1, jpj 
    529          DO ji = 1, jpi 
    530             ztemp             = tq_abl  ( ji, jj, 2, nt_a, jp_ta )  
    531             zhumi             = tq_abl  ( ji, jj, 2, nt_a, jp_qa )  
    532             !zcff              = pslp_dta( ji, jj ) /   &              !<-- At this point ztemp and zhumi should not be zero ... 
    533             !   &                        (  R_dry*ztemp * ( 1._wp + rctv0*zhumi )  ) 
    534             zcff              = rho_air( ztemp, zhumi, pslp_dta( ji, jj ) ) 
    535             psen ( ji, jj )   =      cp_air(zhumi) * zcff * psen(ji,jj) * ( psst(ji,jj) + rt0 - ztemp ) 
    536             pevp ( ji, jj )   = rn_efac*MAX( 0._wp,  zcff * pevp(ji,jj) * ( pssq(ji,jj)       - zhumi ) ) 
    537             rhoa( ji, jj )   = zcff               
    538          END DO 
    539       END DO 
     521      DO_2D_11_11 
     522         ztemp             = tq_abl  ( ji, jj, 2, nt_a, jp_ta )  
     523         zhumi             = tq_abl  ( ji, jj, 2, nt_a, jp_qa )  
     524         !zcff              = pslp_dta( ji, jj ) /   &              !<-- At this point ztemp and zhumi should not be zero ... 
     525         !   &                        (  R_dry*ztemp * ( 1._wp + rctv0*zhumi )  ) 
     526         zcff              = rho_air( ztemp, zhumi, pslp_dta( ji, jj ) ) 
     527         psen ( ji, jj )   =      cp_air(zhumi) * zcff * psen(ji,jj) * ( psst(ji,jj) + rt0 - ztemp ) 
     528         pevp ( ji, jj )   = rn_efac*MAX( 0._wp,  zcff * pevp(ji,jj) * ( pssq(ji,jj)       - zhumi ) ) 
     529         rhoa( ji, jj )   = zcff               
     530      END_2D 
    540531       
    541       DO jj = 2, jpj 
    542          DO ji = 2, jpi   ! vect. opt. 
    543             zwnd_i(ji,jj) = u_abl(ji  ,jj,2,nt_a) - 0.5_wp * rn_vfac * ( pssu(ji  ,jj) + pssu(ji-1,jj) )   
    544             zwnd_j(ji,jj) = v_abl(ji,jj  ,2,nt_a) - 0.5_wp * rn_vfac * ( pssv(ji,jj  ) + pssv(ji,jj-1) )  
    545          END DO 
    546       END DO 
     532      DO_2D_01_01 
     533         zwnd_i(ji,jj) = u_abl(ji  ,jj,2,nt_a) - 0.5_wp * rn_vfac * ( pssu(ji  ,jj) + pssu(ji-1,jj) )   
     534         zwnd_j(ji,jj) = v_abl(ji,jj  ,2,nt_a) - 0.5_wp * rn_vfac * ( pssv(ji,jj  ) + pssv(ji,jj-1) )  
     535      END_2D 
    547536      !  
    548537      CALL lbc_lnk_multi( 'ablmod', zwnd_i(:,:) , 'T', -1., zwnd_j(:,:) , 'T', -1. ) 
    549538      ! 
    550539      ! ... scalar wind ( = | U10m - U_oce | ) at T-point (masked) 
    551       DO jj = 1, jpj 
    552          DO ji = 1, jpi       
    553             zcff          = SQRT(  zwnd_i(ji,jj) * zwnd_i(ji,jj)   & 
    554                &                 + zwnd_j(ji,jj) * zwnd_j(ji,jj)  )  ! * msk_abl(ji,jj) 
    555             zztmp         = rhoa(ji,jj) * pcd_du(ji,jj) 
    556              
    557             pwndm (ji,jj) =         zcff 
    558             ptaum (ji,jj) = zztmp * zcff 
    559             zwnd_i(ji,jj) = zztmp * zwnd_i(ji,jj) 
    560             zwnd_j(ji,jj) = zztmp * zwnd_j(ji,jj) 
    561          END DO 
    562       END DO    
     540      DO_2D_11_11 
     541         zcff          = SQRT(  zwnd_i(ji,jj) * zwnd_i(ji,jj)   & 
     542            &                 + zwnd_j(ji,jj) * zwnd_j(ji,jj)  )  ! * msk_abl(ji,jj) 
     543         zztmp         = rhoa(ji,jj) * pcd_du(ji,jj) 
     544          
     545         pwndm (ji,jj) =         zcff 
     546         ptaum (ji,jj) = zztmp * zcff 
     547         zwnd_i(ji,jj) = zztmp * zwnd_i(ji,jj) 
     548         zwnd_j(ji,jj) = zztmp * zwnd_j(ji,jj) 
     549      END_2D 
    563550      ! ... utau, vtau at U- and V_points, resp. 
    564551      !     Note the use of 0.5*(2-umask) in order to unmask the stress along coastlines 
    565552      !     Note the use of MAX(tmask(i,j),tmask(i+1,j) is to mask tau over ice shelves 
    566       DO jj = 2, jpjm1 
    567          DO ji = 2, jpim1 
    568             zcff  = 0.5_wp * ( 2._wp - msk_abl(ji,jj)*msk_abl(ji+1,jj) ) 
    569             zztmp = MAX(msk_abl(ji,jj),msk_abl(ji+1,jj)) 
    570             ptaui(ji,jj) = zcff * zztmp * ( zwnd_i(ji,jj) + zwnd_i(ji+1,jj  ) ) 
    571             zcff  = 0.5_wp * ( 2._wp - msk_abl(ji,jj)*msk_abl(ji,jj+1) ) 
    572             zztmp = MAX(msk_abl(ji,jj),msk_abl(ji,jj+1)) 
    573             ptauj(ji,jj) = zcff * zztmp * ( zwnd_j(ji,jj) + zwnd_j(ji  ,jj+1) ) 
    574          END DO 
    575       END DO 
     553      DO_2D_00_00 
     554         zcff  = 0.5_wp * ( 2._wp - msk_abl(ji,jj)*msk_abl(ji+1,jj) ) 
     555         zztmp = MAX(msk_abl(ji,jj),msk_abl(ji+1,jj)) 
     556         ptaui(ji,jj) = zcff * zztmp * ( zwnd_i(ji,jj) + zwnd_i(ji+1,jj  ) ) 
     557         zcff  = 0.5_wp * ( 2._wp - msk_abl(ji,jj)*msk_abl(ji,jj+1) ) 
     558         zztmp = MAX(msk_abl(ji,jj),msk_abl(ji,jj+1)) 
     559         ptauj(ji,jj) = zcff * zztmp * ( zwnd_j(ji,jj) + zwnd_j(ji  ,jj+1) ) 
     560      END_2D 
    576561      ! 
    577562      CALL lbc_lnk_multi( 'ablmod', ptaui(:,:), 'U', -1., ptauj(:,:), 'V', -1. ) 
     
    589574         !    Wind stress relative to the moving ice ( U10m - U_ice )   ! 
    590575         ! ------------------------------------------------------------ ! 
    591          DO jj = 2, jpjm1 
    592             DO ji = 2, jpim1   
    593                 
    594                zztmp1 = 0.5_wp * ( u_abl(ji+1,jj,2,nt_a) + u_abl(ji,jj,2,nt_a) ) 
    595                zztmp2 = 0.5_wp * ( v_abl(ji,jj+1,2,nt_a) + v_abl(ji,jj,2,nt_a) ) 
    596              
    597                ptaui_ice(ji,jj) = 0.5_wp * (  rhoa(ji+1,jj) * pCd_du_ice(ji+1,jj)             & 
    598                   &                      +    rhoa(ji  ,jj) * pCd_du_ice(ji  ,jj)  )          & 
    599                   &         * ( zztmp1 - rn_vfac * pssu_ice(ji,jj) ) 
    600                ptauj_ice(ji,jj) = 0.5_wp * (  rhoa(ji,jj+1) * pCd_du_ice(ji,jj+1)             & 
    601                   &                      +    rhoa(ji,jj  ) * pCd_du_ice(ji,jj  )  )          & 
    602                   &         * ( zztmp2 - rn_vfac * pssv_ice(ji,jj) ) 
    603             END DO 
    604          END DO 
     576         DO_2D_00_00 
     577             
     578            zztmp1 = 0.5_wp * ( u_abl(ji+1,jj,2,nt_a) + u_abl(ji,jj,2,nt_a) ) 
     579            zztmp2 = 0.5_wp * ( v_abl(ji,jj+1,2,nt_a) + v_abl(ji,jj,2,nt_a) ) 
     580    
     581            ptaui_ice(ji,jj) = 0.5_wp * (  rhoa(ji+1,jj) * pCd_du_ice(ji+1,jj)             & 
     582               &                      +    rhoa(ji  ,jj) * pCd_du_ice(ji  ,jj)  )          & 
     583               &         * ( zztmp1 - rn_vfac * pssu_ice(ji,jj) ) 
     584            ptauj_ice(ji,jj) = 0.5_wp * (  rhoa(ji,jj+1) * pCd_du_ice(ji,jj+1)             & 
     585               &                      +    rhoa(ji,jj  ) * pCd_du_ice(ji,jj  )  )          & 
     586               &         * ( zztmp2 - rn_vfac * pssv_ice(ji,jj) ) 
     587         END_2D 
    605588         CALL lbc_lnk_multi( 'ablmod', ptaui_ice, 'U', -1., ptauj_ice, 'V', -1. ) 
    606589         ! 
  • NEMO/branches/2019/dev_r11943_MERGE_2019/src/ICE/icealb.F90

    r11960 r12340  
    3838   REAL(wp) ::   rn_alb_dpnd      ! ponded ice albedo 
    3939 
     40   !! * Substitutions 
     41#  include "do_loop_substitute.h90" 
    4042   !!---------------------------------------------------------------------- 
    4143   !! NEMO/ICE 4.0 , NEMO Consortium (2018) 
     
    117119      ! 
    118120      DO jl = 1, jpl 
    119          DO jj = 1, jpj 
    120             DO ji = 1, jpi 
    121                !                       !--- Specific snow, ice and pond fractions (for now, we prevent melt ponds and snow at the same time) 
    122                IF( ph_snw(ji,jj,jl) == 0._wp ) THEN 
    123                   zafrac_snw = 0._wp 
    124                   IF( ld_pnd_alb ) THEN 
    125                      zafrac_pnd = pafrac_pnd(ji,jj,jl) 
    126                   ELSE 
    127                      zafrac_pnd = 0._wp 
    128                   ENDIF 
    129                   zafrac_ice = 1._wp - zafrac_pnd 
     121         DO_2D_11_11 
     122            !                       !--- Specific snow, ice and pond fractions (for now, we prevent melt ponds and snow at the same time) 
     123            IF( ph_snw(ji,jj,jl) == 0._wp ) THEN 
     124               zafrac_snw = 0._wp 
     125               IF( ld_pnd_alb ) THEN 
     126                  zafrac_pnd = pafrac_pnd(ji,jj,jl) 
    130127               ELSE 
    131                   zafrac_snw = 1._wp      ! Snow fully "shades" melt ponds and ice 
    132128                  zafrac_pnd = 0._wp 
    133                   zafrac_ice = 0._wp 
    134129               ENDIF 
    135                ! 
    136                !                       !--- Bare ice albedo (for hi > 150cm) 
    137                IF( ld_pnd_alb ) THEN 
    138                   zalb_ice = rn_alb_idry 
    139                ELSE 
    140                   IF( ph_snw(ji,jj,jl) == 0._wp .AND. pt_su(ji,jj,jl) >= rt0 ) THEN  ;   zalb_ice = rn_alb_imlt 
    141                   ELSE                                                               ;   zalb_ice = rn_alb_idry   ;   ENDIF 
    142                ENDIF 
    143                !                       !--- Bare ice albedo (for hi < 150cm) 
    144                IF( 0.05 < ph_ice(ji,jj,jl) .AND. ph_ice(ji,jj,jl) <= 1.5 ) THEN      ! 5cm < hi < 150cm 
    145                   zalb_ice = zalb_ice    + ( 0.18 - zalb_ice   ) * z1_c1 * ( LOG(1.5) - LOG(ph_ice(ji,jj,jl)) ) 
    146                ELSEIF( ph_ice(ji,jj,jl) <= 0.05 ) THEN                               ! 0cm < hi < 5cm 
    147                   zalb_ice = rn_alb_oce  + ( 0.18 - rn_alb_oce ) * z1_c2 * ph_ice(ji,jj,jl) 
    148                ENDIF 
    149                ! 
    150                !                       !--- Snow-covered ice albedo (freezing, melting cases) 
    151                IF( pt_su(ji,jj,jl) < rt0 ) THEN 
    152                   zalb_snw = rn_alb_sdry - ( rn_alb_sdry - zalb_ice ) * EXP( - ph_snw(ji,jj,jl) * z1_c3 ) 
    153                ELSE 
    154                   zalb_snw = rn_alb_smlt - ( rn_alb_smlt - zalb_ice ) * EXP( - ph_snw(ji,jj,jl) * z1_c4 ) 
    155                ENDIF 
    156                !                       !--- Ponded ice albedo 
    157                IF( ld_pnd_alb ) THEN 
    158                   zalb_pnd = rn_alb_dpnd - ( rn_alb_dpnd - zalb_ice ) * EXP( - ph_pnd(ji,jj,jl) * z1_href_pnd )  
    159                ELSE 
    160                   zalb_pnd = rn_alb_dpnd 
    161                ENDIF 
    162                !                       !--- Surface albedo is weighted mean of snow, ponds and bare ice contributions 
    163                palb_os(ji,jj,jl) = ( zafrac_snw * zalb_snw + zafrac_pnd * zalb_pnd + zafrac_ice * zalb_ice ) * tmask(ji,jj,1) 
    164                ! 
    165                palb_cs(ji,jj,jl) = palb_os(ji,jj,jl)  & 
    166                   &                - ( - 0.1010 * palb_os(ji,jj,jl) * palb_os(ji,jj,jl)  & 
    167                   &                    + 0.1933 * palb_os(ji,jj,jl) - 0.0148 ) * tmask(ji,jj,1) 
    168                ! 
    169             END DO 
    170          END DO 
     130               zafrac_ice = 1._wp - zafrac_pnd 
     131            ELSE 
     132               zafrac_snw = 1._wp      ! Snow fully "shades" melt ponds and ice 
     133               zafrac_pnd = 0._wp 
     134               zafrac_ice = 0._wp 
     135            ENDIF 
     136            ! 
     137            !                       !--- Bare ice albedo (for hi > 150cm) 
     138            IF( ld_pnd_alb ) THEN 
     139               zalb_ice = rn_alb_idry 
     140            ELSE 
     141               IF( ph_snw(ji,jj,jl) == 0._wp .AND. pt_su(ji,jj,jl) >= rt0 ) THEN  ;   zalb_ice = rn_alb_imlt 
     142               ELSE                                                               ;   zalb_ice = rn_alb_idry   ;   ENDIF 
     143            ENDIF 
     144            !                       !--- Bare ice albedo (for hi < 150cm) 
     145            IF( 0.05 < ph_ice(ji,jj,jl) .AND. ph_ice(ji,jj,jl) <= 1.5 ) THEN      ! 5cm < hi < 150cm 
     146               zalb_ice = zalb_ice    + ( 0.18 - zalb_ice   ) * z1_c1 * ( LOG(1.5) - LOG(ph_ice(ji,jj,jl)) ) 
     147            ELSEIF( ph_ice(ji,jj,jl) <= 0.05 ) THEN                               ! 0cm < hi < 5cm 
     148               zalb_ice = rn_alb_oce  + ( 0.18 - rn_alb_oce ) * z1_c2 * ph_ice(ji,jj,jl) 
     149            ENDIF 
     150            ! 
     151            !                       !--- Snow-covered ice albedo (freezing, melting cases) 
     152            IF( pt_su(ji,jj,jl) < rt0 ) THEN 
     153               zalb_snw = rn_alb_sdry - ( rn_alb_sdry - zalb_ice ) * EXP( - ph_snw(ji,jj,jl) * z1_c3 ) 
     154            ELSE 
     155               zalb_snw = rn_alb_smlt - ( rn_alb_smlt - zalb_ice ) * EXP( - ph_snw(ji,jj,jl) * z1_c4 ) 
     156            ENDIF 
     157            !                       !--- Ponded ice albedo 
     158            IF( ld_pnd_alb ) THEN 
     159               zalb_pnd = rn_alb_dpnd - ( rn_alb_dpnd - zalb_ice ) * EXP( - ph_pnd(ji,jj,jl) * z1_href_pnd )  
     160            ELSE 
     161               zalb_pnd = rn_alb_dpnd 
     162            ENDIF 
     163            !                       !--- Surface albedo is weighted mean of snow, ponds and bare ice contributions 
     164            palb_os(ji,jj,jl) = ( zafrac_snw * zalb_snw + zafrac_pnd * zalb_pnd + zafrac_ice * zalb_ice ) * tmask(ji,jj,1) 
     165            ! 
     166            palb_cs(ji,jj,jl) = palb_os(ji,jj,jl)  & 
     167               &                - ( - 0.1010 * palb_os(ji,jj,jl) * palb_os(ji,jj,jl)  & 
     168               &                    + 0.1933 * palb_os(ji,jj,jl) - 0.0148 ) * tmask(ji,jj,1) 
     169            ! 
     170         END_2D 
    171171      END DO 
    172172      ! 
  • NEMO/branches/2019/dev_r11943_MERGE_2019/src/ICE/icecor.F90

    r12236 r12340  
    3636   !! * Substitutions 
    3737#  include "vectopt_loop_substitute.h90" 
     38#  include "do_loop_substitute.h90" 
    3839   !!---------------------------------------------------------------------- 
    3940   !! NEMO/ICE 4.0 , NEMO Consortium (2018) 
     
    8889         zzc = rhoi * r1_rdtice 
    8990         DO jl = 1, jpl 
    90             DO jj = 1, jpj  
    91                DO ji = 1, jpi 
    92                   zsal = sv_i(ji,jj,jl) 
    93                   sv_i(ji,jj,jl) = MIN(  MAX( rn_simin*v_i(ji,jj,jl) , sv_i(ji,jj,jl) ) , rn_simax*v_i(ji,jj,jl)  ) 
    94                   sfx_res(ji,jj) = sfx_res(ji,jj) - ( sv_i(ji,jj,jl) - zsal ) * zzc   ! associated salt flux 
    95                END DO 
    96             END DO 
     91            DO_2D_11_11 
     92               zsal = sv_i(ji,jj,jl) 
     93               sv_i(ji,jj,jl) = MIN(  MAX( rn_simin*v_i(ji,jj,jl) , sv_i(ji,jj,jl) ) , rn_simax*v_i(ji,jj,jl)  ) 
     94               sfx_res(ji,jj) = sfx_res(ji,jj) - ( sv_i(ji,jj,jl) - zsal ) * zzc   ! associated salt flux 
     95            END_2D 
    9796         END DO 
    9897      ENDIF 
     
    108107      !                             !----------------------------------------------------- 
    109108      IF( kn == 2 ) THEN            !  Ice drift case: Corrections to avoid wrong values ! 
    110          DO jj = 2, jpjm1           !----------------------------------------------------- 
    111             DO ji = 2, jpim1 
    112                IF ( at_i(ji,jj) == 0._wp ) THEN    ! what to do if there is no ice 
    113                   IF ( at_i(ji+1,jj) == 0._wp )   u_ice(ji  ,jj) = 0._wp   ! right side 
    114                   IF ( at_i(ji-1,jj) == 0._wp )   u_ice(ji-1,jj) = 0._wp   ! left side 
    115                   IF ( at_i(ji,jj+1) == 0._wp )   v_ice(ji,jj  ) = 0._wp   ! upper side 
    116                   IF ( at_i(ji,jj-1) == 0._wp )   v_ice(ji,jj-1) = 0._wp   ! bottom side 
    117                ENDIF 
    118             END DO 
    119          END DO 
     109         DO_2D_00_00 
     110            IF ( at_i(ji,jj) == 0._wp ) THEN    ! what to do if there is no ice 
     111               IF ( at_i(ji+1,jj) == 0._wp )   u_ice(ji  ,jj) = 0._wp   ! right side 
     112               IF ( at_i(ji-1,jj) == 0._wp )   u_ice(ji-1,jj) = 0._wp   ! left side 
     113               IF ( at_i(ji,jj+1) == 0._wp )   v_ice(ji,jj  ) = 0._wp   ! upper side 
     114               IF ( at_i(ji,jj-1) == 0._wp )   v_ice(ji,jj-1) = 0._wp   ! bottom side 
     115            ENDIF 
     116         END_2D 
    120117         CALL lbc_lnk_multi( 'icecor', u_ice, 'U', -1., v_ice, 'V', -1. ) 
    121118      ENDIF 
  • NEMO/branches/2019/dev_r11943_MERGE_2019/src/ICE/icectl.F90

    r12236 r12340  
    5252   !! * Substitutions 
    5353#  include "vectopt_loop_substitute.h90" 
     54#  include "do_loop_substitute.h90" 
    5455   !!---------------------------------------------------------------------- 
    5556   !! NEMO/ICE 4.0 , NEMO Consortium (2018) 
     
    368369      cl_alname(ialert_id) = ' Incompat vol and con         '    ! name of the alert 
    369370      DO jl = 1, jpl 
    370          DO jj = 1, jpj 
    371             DO ji = 1, jpi 
    372                IF(  v_i(ji,jj,jl) /= 0._wp   .AND.   a_i(ji,jj,jl) == 0._wp   ) THEN 
    373                   WRITE(numout,*) ' ALERTE 2 :   Incompatible volume and concentration ' 
    374                   inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
    375                ENDIF 
    376             END DO 
    377          END DO 
     371         DO_2D_11_11 
     372            IF(  v_i(ji,jj,jl) /= 0._wp   .AND.   a_i(ji,jj,jl) == 0._wp   ) THEN 
     373               WRITE(numout,*) ' ALERTE 2 :   Incompatible volume and concentration ' 
     374               inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
     375            ENDIF 
     376         END_2D 
    378377      END DO 
    379378 
     
    382381      cl_alname(ialert_id) = ' Very thick ice               ' ! name of the alert 
    383382      jl = jpl  
    384       DO jj = 1, jpj 
    385          DO ji = 1, jpi 
    386             IF(   h_i(ji,jj,jl)  >  50._wp   ) THEN 
    387                WRITE(numout,*) ' ALERTE 3 :   Very thick ice' 
    388                !CALL ice_prt( kt, ji, jj, 2, ' ALERTE 3 :   Very thick ice ' ) 
    389                inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
    390             ENDIF 
    391          END DO 
    392       END DO 
     383      DO_2D_11_11 
     384         IF(   h_i(ji,jj,jl)  >  50._wp   ) THEN 
     385            WRITE(numout,*) ' ALERTE 3 :   Very thick ice' 
     386            !CALL ice_prt( kt, ji, jj, 2, ' ALERTE 3 :   Very thick ice ' ) 
     387            inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
     388         ENDIF 
     389      END_2D 
    393390 
    394391      ! Alert if very fast ice 
    395392      ialert_id = 4 ! reference number of this alert 
    396393      cl_alname(ialert_id) = ' Very fast ice               ' ! name of the alert 
    397       DO jj = 1, jpj 
    398          DO ji = 1, jpi 
    399             IF(   MAX( ABS( u_ice(ji,jj) ), ABS( v_ice(ji,jj) ) ) > 2.  .AND.  & 
    400                &  at_i(ji,jj) > 0._wp   ) THEN 
    401                WRITE(numout,*) ' ALERTE 4 :   Very fast ice' 
    402                !CALL ice_prt( kt, ji, jj, 1, ' ALERTE 4 :   Very fast ice ' ) 
    403                inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
    404             ENDIF 
    405          END DO 
    406       END DO 
     394      DO_2D_11_11 
     395         IF(   MAX( ABS( u_ice(ji,jj) ), ABS( v_ice(ji,jj) ) ) > 2.  .AND.  & 
     396            &  at_i(ji,jj) > 0._wp   ) THEN 
     397            WRITE(numout,*) ' ALERTE 4 :   Very fast ice' 
     398            !CALL ice_prt( kt, ji, jj, 1, ' ALERTE 4 :   Very fast ice ' ) 
     399            inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
     400         ENDIF 
     401      END_2D 
    407402 
    408403      ! Alert on salt flux 
    409404      ialert_id = 5 ! reference number of this alert 
    410405      cl_alname(ialert_id) = ' High salt flux               ' ! name of the alert 
    411       DO jj = 1, jpj 
    412          DO ji = 1, jpi 
    413             IF( ABS( sfx (ji,jj) ) > 1.0e-2 ) THEN  ! = 1 psu/day for 1m ocean depth 
    414                WRITE(numout,*) ' ALERTE 5 :   High salt flux' 
    415                !CALL ice_prt( kt, ji, jj, 3, ' ALERTE 5 :   High salt flux ' ) 
    416                inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
    417             ENDIF 
    418          END DO 
    419       END DO 
     406      DO_2D_11_11 
     407         IF( ABS( sfx (ji,jj) ) > 1.0e-2 ) THEN  ! = 1 psu/day for 1m ocean depth 
     408            WRITE(numout,*) ' ALERTE 5 :   High salt flux' 
     409            !CALL ice_prt( kt, ji, jj, 3, ' ALERTE 5 :   High salt flux ' ) 
     410            inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
     411         ENDIF 
     412      END_2D 
    420413 
    421414      ! Alert if there is ice on continents 
    422415      ialert_id = 6 ! reference number of this alert 
    423416      cl_alname(ialert_id) = ' Ice on continents           ' ! name of the alert 
    424       DO jj = 1, jpj 
    425          DO ji = 1, jpi 
    426             IF(   tmask(ji,jj,1) <= 0._wp   .AND.   at_i(ji,jj) > 0._wp   ) THEN  
    427                WRITE(numout,*) ' ALERTE 6 :   Ice on continents' 
    428                !CALL ice_prt( kt, ji, jj, 1, ' ALERTE 6 :   Ice on continents ' ) 
    429                inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
    430             ENDIF 
    431          END DO 
    432       END DO 
     417      DO_2D_11_11 
     418         IF(   tmask(ji,jj,1) <= 0._wp   .AND.   at_i(ji,jj) > 0._wp   ) THEN  
     419            WRITE(numout,*) ' ALERTE 6 :   Ice on continents' 
     420            !CALL ice_prt( kt, ji, jj, 1, ' ALERTE 6 :   Ice on continents ' ) 
     421            inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
     422         ENDIF 
     423      END_2D 
    433424 
    434425! 
     
    437428      cl_alname(ialert_id) = ' Very fresh ice               ' ! name of the alert 
    438429      DO jl = 1, jpl 
    439          DO jj = 1, jpj 
    440             DO ji = 1, jpi 
    441                IF( s_i(ji,jj,jl) < 0.1 .AND. a_i(ji,jj,jl) > 0._wp ) THEN 
    442                   WRITE(numout,*) ' ALERTE 7 :   Very fresh ice' 
     430         DO_2D_11_11 
     431            IF( s_i(ji,jj,jl) < 0.1 .AND. a_i(ji,jj,jl) > 0._wp ) THEN 
     432               WRITE(numout,*) ' ALERTE 7 :   Very fresh ice' 
    443433!                 CALL ice_prt(kt,ji,jj,1, ' ALERTE 7 :   Very fresh ice ' ) 
    444                   inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
    445                ENDIF 
    446             END DO 
    447          END DO 
     434               inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
     435            ENDIF 
     436         END_2D 
    448437      END DO 
    449438! 
     
    451440      ialert_id = 8 ! reference number of this alert 
    452441      cl_alname(ialert_id) = ' fnsolar very big             ' ! name of the alert 
    453       DO jj = 1, jpj 
    454          DO ji = 1, jpi 
    455             IF( ABS( qns(ji,jj) ) > 1500._wp .AND. at_i(ji,jj) > 0._wp ) THEN 
    456                ! 
    457                WRITE(numout,*) ' ALERTE 8 :   Very high non-solar heat flux' 
    458                !CALL ice_prt( kt, ji, jj, 2, '   ') 
    459                inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
    460                ! 
    461             ENDIF 
    462          END DO 
    463       END DO 
     442      DO_2D_11_11 
     443         IF( ABS( qns(ji,jj) ) > 1500._wp .AND. at_i(ji,jj) > 0._wp ) THEN 
     444            ! 
     445            WRITE(numout,*) ' ALERTE 8 :   Very high non-solar heat flux' 
     446            !CALL ice_prt( kt, ji, jj, 2, '   ') 
     447            inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
     448            ! 
     449         ENDIF 
     450      END_2D 
    464451      !+++++ 
    465452 
     
    468455      cl_alname(ialert_id) = ' Very old   ice               ' ! name of the alert 
    469456      DO jl = 1, jpl 
    470          DO jj = 1, jpj 
    471             DO ji = 1, jpi 
    472                IF ( ( ( ABS( o_i(ji,jj,jl) ) > rdt_ice ) .OR. & 
    473                       ( ABS( o_i(ji,jj,jl) ) < 0._wp) ) .AND. & 
    474                              ( a_i(ji,jj,jl) > 0._wp ) ) THEN 
    475                   WRITE(numout,*) ' ALERTE 9 :   Wrong ice age' 
    476                   !CALL ice_prt( kt, ji, jj, 1, ' ALERTE 9 :   Wrong ice age ') 
    477                   inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
    478                ENDIF 
    479             END DO 
    480          END DO 
     457         DO_2D_11_11 
     458            IF ( ( ( ABS( o_i(ji,jj,jl) ) > rdt_ice ) .OR. & 
     459                   ( ABS( o_i(ji,jj,jl) ) < 0._wp) ) .AND. & 
     460                          ( a_i(ji,jj,jl) > 0._wp ) ) THEN 
     461               WRITE(numout,*) ' ALERTE 9 :   Wrong ice age' 
     462               !CALL ice_prt( kt, ji, jj, 1, ' ALERTE 9 :   Wrong ice age ') 
     463               inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
     464            ENDIF 
     465         END_2D 
    481466      END DO 
    482467   
     
    486471      inb_alp(ialert_id) = 0 
    487472      DO jl = 1, jpl 
    488          DO jk = 1, nlay_i 
    489             DO jj = 1, jpj 
    490                DO ji = 1, jpi 
    491                   ztmelts    =  -rTmlt * sz_i(ji,jj,jk,jl) + rt0 
    492                   IF( t_i(ji,jj,jk,jl) > ztmelts  .AND.  v_i(ji,jj,jl) > 1.e-10   & 
    493                      &                            .AND.  a_i(ji,jj,jl) > 0._wp   ) THEN 
    494                      WRITE(numout,*) ' ALERTE 10 :   Very warm ice' 
    495                     inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
    496                   ENDIF 
    497                END DO 
    498             END DO 
    499          END DO 
     473         DO_3D_11_11( 1, nlay_i ) 
     474            ztmelts    =  -rTmlt * sz_i(ji,jj,jk,jl) + rt0 
     475            IF( t_i(ji,jj,jk,jl) > ztmelts  .AND.  v_i(ji,jj,jl) > 1.e-10   & 
     476               &                            .AND.  a_i(ji,jj,jl) > 0._wp   ) THEN 
     477               WRITE(numout,*) ' ALERTE 10 :   Very warm ice' 
     478              inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
     479            ENDIF 
     480         END_3D 
    500481      END DO 
    501482 
  • NEMO/branches/2019/dev_r11943_MERGE_2019/src/ICE/icedyn.F90

    r11960 r12340  
    5353   !! * Substitutions 
    5454#  include "vectopt_loop_substitute.h90" 
     55#  include "do_loop_substitute.h90" 
    5556   !!---------------------------------------------------------------------- 
    5657   !! NEMO/ICE 4.0 , NEMO Consortium (2018) 
     
    126127         ! CFL = 0.5 at a distance from the bound of 1/6 of the basin length 
    127128         ! Then for dx = 2m and dt = 1s => rn_uice = u (1/6th) = 1m/s  
    128          DO jj = 1, jpj 
    129             DO ji = 1, jpi 
    130                zcoefu = ( REAL(jpiglo+1)*0.5 - REAL(ji+nimpp-1) ) / ( REAL(jpiglo+1)*0.5 - 1. ) 
    131                zcoefv = ( REAL(jpjglo+1)*0.5 - REAL(jj+njmpp-1) ) / ( REAL(jpjglo+1)*0.5 - 1. ) 
    132                u_ice(ji,jj) = rn_uice * 1.5 * SIGN( 1., zcoefu ) * ABS( zcoefu ) * umask(ji,jj,1) 
    133                v_ice(ji,jj) = rn_vice * 1.5 * SIGN( 1., zcoefv ) * ABS( zcoefv ) * vmask(ji,jj,1) 
    134             END DO 
    135          END DO 
     129         DO_2D_11_11 
     130            zcoefu = ( REAL(jpiglo+1)*0.5 - REAL(ji+nimpp-1) ) / ( REAL(jpiglo+1)*0.5 - 1. ) 
     131            zcoefv = ( REAL(jpjglo+1)*0.5 - REAL(jj+njmpp-1) ) / ( REAL(jpjglo+1)*0.5 - 1. ) 
     132            u_ice(ji,jj) = rn_uice * 1.5 * SIGN( 1., zcoefu ) * ABS( zcoefu ) * umask(ji,jj,1) 
     133            v_ice(ji,jj) = rn_vice * 1.5 * SIGN( 1., zcoefv ) * ABS( zcoefv ) * vmask(ji,jj,1) 
     134         END_2D 
    136135         ! --- 
    137136         CALL ice_dyn_adv   ( kt )                                          ! -- advection of ice 
     
    157156 
    158157            ALLOCATE( zdivu_i(jpi,jpj) ) 
    159             DO jj = 2, jpjm1 
    160                DO ji = 2, jpim1 
    161                   zdivu_i(ji,jj) = ( e2u(ji,jj) * u_ice(ji,jj) - e2u(ji-1,jj) * u_ice(ji-1,jj)   & 
    162                      &             + e1v(ji,jj) * v_ice(ji,jj) - e1v(ji,jj-1) * v_ice(ji,jj-1) ) * r1_e1e2t(ji,jj) 
    163                END DO 
    164             END DO 
     158            DO_2D_00_00 
     159               zdivu_i(ji,jj) = ( e2u(ji,jj) * u_ice(ji,jj) - e2u(ji-1,jj) * u_ice(ji-1,jj)   & 
     160                  &             + e1v(ji,jj) * v_ice(ji,jj) - e1v(ji,jj-1) * v_ice(ji,jj-1) ) * r1_e1e2t(ji,jj) 
     161            END_2D 
    165162            CALL lbc_lnk( 'icedyn', zdivu_i, 'T', 1. ) 
    166163            ! output 
  • NEMO/branches/2019/dev_r11943_MERGE_2019/src/ICE/icedyn_adv_pra.F90

    r12252 r12340  
    4747   !! * Substitutions 
    4848#  include "vectopt_loop_substitute.h90" 
     49#  include "do_loop_substitute.h90" 
    4950   !!---------------------------------------------------------------------- 
    5051   !! NEMO/ICE 4.0 , NEMO Consortium (2018) 
     
    102103      ! --- Record max of the surrounding 9-pts ice thick. (for call Hbig) --- ! 
    103104      DO jl = 1, jpl 
    104          DO jj = 2, jpjm1 
    105             DO ji = fs_2, fs_jpim1 
    106                zhip_max(ji,jj,jl) = MAX( epsi20, ph_ip(ji,jj,jl), ph_ip(ji+1,jj  ,jl), ph_ip(ji  ,jj+1,jl), & 
    107                   &                                               ph_ip(ji-1,jj  ,jl), ph_ip(ji  ,jj-1,jl), & 
    108                   &                                               ph_ip(ji+1,jj+1,jl), ph_ip(ji-1,jj-1,jl), & 
    109                   &                                               ph_ip(ji+1,jj-1,jl), ph_ip(ji-1,jj+1,jl) ) 
    110                zhi_max (ji,jj,jl) = MAX( epsi20, ph_i (ji,jj,jl), ph_i (ji+1,jj  ,jl), ph_i (ji  ,jj+1,jl), & 
    111                   &                                               ph_i (ji-1,jj  ,jl), ph_i (ji  ,jj-1,jl), & 
    112                   &                                               ph_i (ji+1,jj+1,jl), ph_i (ji-1,jj-1,jl), & 
    113                   &                                               ph_i (ji+1,jj-1,jl), ph_i (ji-1,jj+1,jl) ) 
    114                zhs_max (ji,jj,jl) = MAX( epsi20, ph_s (ji,jj,jl), ph_s (ji+1,jj  ,jl), ph_s (ji  ,jj+1,jl), & 
    115                   &                                               ph_s (ji-1,jj  ,jl), ph_s (ji  ,jj-1,jl), & 
    116                   &                                               ph_s (ji+1,jj+1,jl), ph_s (ji-1,jj-1,jl), & 
    117                   &                                               ph_s (ji+1,jj-1,jl), ph_s (ji-1,jj+1,jl) ) 
    118             END DO 
    119          END DO 
     105         DO_2D_00_00 
     106            zhip_max(ji,jj,jl) = MAX( epsi20, ph_ip(ji,jj,jl), ph_ip(ji+1,jj  ,jl), ph_ip(ji  ,jj+1,jl), & 
     107               &                                               ph_ip(ji-1,jj  ,jl), ph_ip(ji  ,jj-1,jl), & 
     108               &                                               ph_ip(ji+1,jj+1,jl), ph_ip(ji-1,jj-1,jl), & 
     109               &                                               ph_ip(ji+1,jj-1,jl), ph_ip(ji-1,jj+1,jl) ) 
     110            zhi_max (ji,jj,jl) = MAX( epsi20, ph_i (ji,jj,jl), ph_i (ji+1,jj  ,jl), ph_i (ji  ,jj+1,jl), & 
     111               &                                               ph_i (ji-1,jj  ,jl), ph_i (ji  ,jj-1,jl), & 
     112               &                                               ph_i (ji+1,jj+1,jl), ph_i (ji-1,jj-1,jl), & 
     113               &                                               ph_i (ji+1,jj-1,jl), ph_i (ji-1,jj+1,jl) ) 
     114            zhs_max (ji,jj,jl) = MAX( epsi20, ph_s (ji,jj,jl), ph_s (ji+1,jj  ,jl), ph_s (ji  ,jj+1,jl), & 
     115               &                                               ph_s (ji-1,jj  ,jl), ph_s (ji  ,jj-1,jl), & 
     116               &                                               ph_s (ji+1,jj+1,jl), ph_s (ji-1,jj-1,jl), & 
     117               &                                               ph_s (ji+1,jj-1,jl), ph_s (ji-1,jj+1,jl) ) 
     118         END_2D 
    120119      END DO 
    121120      CALL lbc_lnk_multi( 'icedyn_adv_pra', zhi_max, 'T', 1., zhs_max, 'T', 1., zhip_max, 'T', 1. ) 
     
    252251         ! derive open water from ice concentration 
    253252         zati2(:,:) = SUM( pa_i(:,:,:), dim=3 ) 
    254          DO jj = 2, jpjm1 
    255             DO ji = fs_2, fs_jpim1 
    256                pato_i(ji,jj) = pato_i(ji,jj) - ( zati2(ji,jj) - zati1(ji,jj) ) &                        !--- open water 
    257                   &                          - ( zudy(ji,jj) - zudy(ji-1,jj) + zvdx(ji,jj) - zvdx(ji,jj-1) ) * r1_e1e2t(ji,jj) * zdt 
    258             END DO 
    259          END DO 
     253         DO_2D_00_00 
     254            pato_i(ji,jj) = pato_i(ji,jj) - ( zati2(ji,jj) - zati1(ji,jj) ) &                        !--- open water 
     255               &                          - ( zudy(ji,jj) - zudy(ji-1,jj) + zvdx(ji,jj) - zvdx(ji,jj-1) ) * r1_e1e2t(ji,jj) * zdt 
     256         END_2D 
    260257         CALL lbc_lnk( 'icedyn_adv_pra', pato_i, 'T',  1. ) 
    261258         ! 
     
    309306         ! 
    310307         ! Limitation of moments.                                            
    311          DO jj = 2, jpjm1 
    312             DO ji = 1, jpi 
    313                !  Initialize volumes of boxes  (=area if adv_x first called, =psm otherwise)                                      
    314                psm (ji,jj,jl) = MAX( pcrh * e1e2t(ji,jj) + ( 1.0 - pcrh ) * psm(ji,jj,jl) , epsi20 ) 
    315                ! 
    316                zslpmax = MAX( 0._wp, ps0(ji,jj,jl) ) 
    317                zs1max  = 1.5 * zslpmax 
    318                zs1new  = MIN( zs1max, MAX( -zs1max, psx(ji,jj,jl) ) ) 
    319                zs2new  = MIN(  2.0 * zslpmax - 0.3334 * ABS( zs1new ),      & 
    320                   &            MAX( ABS( zs1new ) - zslpmax, psxx(ji,jj,jl) )  ) 
    321                rswitch = ( 1.0 - MAX( 0._wp, SIGN( 1._wp, -zslpmax) ) ) * tmask(ji,jj,1)   ! Case of empty boxes & Apply mask 
    322  
    323                ps0 (ji,jj,jl) = zslpmax   
    324                psx (ji,jj,jl) = zs1new         * rswitch 
    325                psxx(ji,jj,jl) = zs2new         * rswitch 
    326                psy (ji,jj,jl) = psy (ji,jj,jl) * rswitch 
    327                psyy(ji,jj,jl) = psyy(ji,jj,jl) * rswitch 
    328                psxy(ji,jj,jl) = MIN( zslpmax, MAX( -zslpmax, psxy(ji,jj,jl) ) ) * rswitch 
    329             END DO 
    330          END DO 
     308         DO_2D_00_11 
     309            !  Initialize volumes of boxes  (=area if adv_x first called, =psm otherwise)                                      
     310            psm (ji,jj,jl) = MAX( pcrh * e1e2t(ji,jj) + ( 1.0 - pcrh ) * psm(ji,jj,jl) , epsi20 ) 
     311            ! 
     312            zslpmax = MAX( 0._wp, ps0(ji,jj,jl) ) 
     313            zs1max  = 1.5 * zslpmax 
     314            zs1new  = MIN( zs1max, MAX( -zs1max, psx(ji,jj,jl) ) ) 
     315            zs2new  = MIN(  2.0 * zslpmax - 0.3334 * ABS( zs1new ),      & 
     316               &            MAX( ABS( zs1new ) - zslpmax, psxx(ji,jj,jl) )  ) 
     317            rswitch = ( 1.0 - MAX( 0._wp, SIGN( 1._wp, -zslpmax) ) ) * tmask(ji,jj,1)   ! Case of empty boxes & Apply mask 
     318 
     319            ps0 (ji,jj,jl) = zslpmax   
     320            psx (ji,jj,jl) = zs1new         * rswitch 
     321            psxx(ji,jj,jl) = zs2new         * rswitch 
     322            psy (ji,jj,jl) = psy (ji,jj,jl) * rswitch 
     323            psyy(ji,jj,jl) = psyy(ji,jj,jl) * rswitch 
     324            psxy(ji,jj,jl) = MIN( zslpmax, MAX( -zslpmax, psxy(ji,jj,jl) ) ) * rswitch 
     325         END_2D 
    331326 
    332327         !  Calculate fluxes and moments between boxes i<-->i+1               
    333          DO jj = 2, jpjm1                      !  Flux from i to i+1 WHEN u GT 0  
    334             DO ji = 1, jpi 
    335                zbet(ji,jj)  =  MAX( 0._wp, SIGN( 1._wp, put(ji,jj) ) ) 
    336                zalf         =  MAX( 0._wp, put(ji,jj) ) * pdt / psm(ji,jj,jl) 
    337                zalfq        =  zalf * zalf 
    338                zalf1        =  1.0 - zalf 
    339                zalf1q       =  zalf1 * zalf1 
    340                ! 
    341                zfm (ji,jj)  =  zalf  *   psm (ji,jj,jl) 
    342                zf0 (ji,jj)  =  zalf  * ( ps0 (ji,jj,jl) + zalf1 * ( psx(ji,jj,jl) + (zalf1 - zalf) * psxx(ji,jj,jl) ) ) 
    343                zfx (ji,jj)  =  zalfq * ( psx (ji,jj,jl) + 3.0 * zalf1 * psxx(ji,jj,jl) ) 
    344                zfxx(ji,jj)  =  zalf  *   psxx(ji,jj,jl) * zalfq 
    345                zfy (ji,jj)  =  zalf  * ( psy (ji,jj,jl) + zalf1 * psxy(ji,jj,jl) ) 
    346                zfxy(ji,jj)  =  zalfq *   psxy(ji,jj,jl) 
    347                zfyy(ji,jj)  =  zalf  *   psyy(ji,jj,jl) 
    348  
    349                !  Readjust moments remaining in the box. 
    350                psm (ji,jj,jl)  =  psm (ji,jj,jl) - zfm(ji,jj) 
    351                ps0 (ji,jj,jl)  =  ps0 (ji,jj,jl) - zf0(ji,jj) 
    352                psx (ji,jj,jl)  =  zalf1q * ( psx(ji,jj,jl) - 3.0 * zalf * psxx(ji,jj,jl) ) 
    353                psxx(ji,jj,jl)  =  zalf1  * zalf1q * psxx(ji,jj,jl) 
    354                psy (ji,jj,jl)  =  psy (ji,jj,jl) - zfy(ji,jj) 
    355                psyy(ji,jj,jl)  =  psyy(ji,jj,jl) - zfyy(ji,jj) 
    356                psxy(ji,jj,jl)  =  zalf1q * psxy(ji,jj,jl) 
    357             END DO 
    358          END DO 
    359  
    360          DO jj = 2, jpjm1                      !  Flux from i+1 to i when u LT 0. 
    361             DO ji = 1, fs_jpim1 
    362                zalf          = MAX( 0._wp, -put(ji,jj) ) * pdt / psm(ji+1,jj,jl)  
    363                zalg  (ji,jj) = zalf 
    364                zalfq         = zalf * zalf 
    365                zalf1         = 1.0 - zalf 
    366                zalg1 (ji,jj) = zalf1 
    367                zalf1q        = zalf1 * zalf1 
    368                zalg1q(ji,jj) = zalf1q 
    369                ! 
    370                zfm   (ji,jj) = zfm (ji,jj) + zalf  *    psm (ji+1,jj,jl) 
    371                zf0   (ji,jj) = zf0 (ji,jj) + zalf  * (  ps0 (ji+1,jj,jl) & 
    372                   &                                   - zalf1 * ( psx(ji+1,jj,jl) - (zalf1 - zalf ) * psxx(ji+1,jj,jl) ) ) 
    373                zfx   (ji,jj) = zfx (ji,jj) + zalfq * (  psx (ji+1,jj,jl) - 3.0 * zalf1 * psxx(ji+1,jj,jl) ) 
    374                zfxx  (ji,jj) = zfxx(ji,jj) + zalf  *    psxx(ji+1,jj,jl) * zalfq 
    375                zfy   (ji,jj) = zfy (ji,jj) + zalf  * (  psy (ji+1,jj,jl) - zalf1 * psxy(ji+1,jj,jl) ) 
    376                zfxy  (ji,jj) = zfxy(ji,jj) + zalfq *    psxy(ji+1,jj,jl) 
    377                zfyy  (ji,jj) = zfyy(ji,jj) + zalf  *    psyy(ji+1,jj,jl) 
    378             END DO 
    379          END DO 
    380  
    381          DO jj = 2, jpjm1                     !  Readjust moments remaining in the box.  
    382             DO ji = fs_2, fs_jpim1 
    383                zbt  =       zbet(ji-1,jj) 
    384                zbt1 = 1.0 - zbet(ji-1,jj) 
    385                ! 
    386                psm (ji,jj,jl) = zbt * psm(ji,jj,jl) + zbt1 * ( psm(ji,jj,jl) - zfm(ji-1,jj) ) 
    387                ps0 (ji,jj,jl) = zbt * ps0(ji,jj,jl) + zbt1 * ( ps0(ji,jj,jl) - zf0(ji-1,jj) ) 
    388                psx (ji,jj,jl) = zalg1q(ji-1,jj) * ( psx(ji,jj,jl) + 3.0 * zalg(ji-1,jj) * psxx(ji,jj,jl) ) 
    389                psxx(ji,jj,jl) = zalg1 (ji-1,jj) * zalg1q(ji-1,jj) * psxx(ji,jj,jl) 
    390                psy (ji,jj,jl) = zbt * psy (ji,jj,jl) + zbt1 * ( psy (ji,jj,jl) - zfy (ji-1,jj) ) 
    391                psyy(ji,jj,jl) = zbt * psyy(ji,jj,jl) + zbt1 * ( psyy(ji,jj,jl) - zfyy(ji-1,jj) ) 
    392                psxy(ji,jj,jl) = zalg1q(ji-1,jj) * psxy(ji,jj,jl) 
    393             END DO 
    394          END DO 
     328         DO_2D_00_11 
     329            zbet(ji,jj)  =  MAX( 0._wp, SIGN( 1._wp, put(ji,jj) ) ) 
     330            zalf         =  MAX( 0._wp, put(ji,jj) ) * pdt / psm(ji,jj,jl) 
     331            zalfq        =  zalf * zalf 
     332            zalf1        =  1.0 - zalf 
     333            zalf1q       =  zalf1 * zalf1 
     334            ! 
     335            zfm (ji,jj)  =  zalf  *   psm (ji,jj,jl) 
     336            zf0 (ji,jj)  =  zalf  * ( ps0 (ji,jj,jl) + zalf1 * ( psx(ji,jj,jl) + (zalf1 - zalf) * psxx(ji,jj,jl) ) ) 
     337            zfx (ji,jj)  =  zalfq * ( psx (ji,jj,jl) + 3.0 * zalf1 * psxx(ji,jj,jl) ) 
     338            zfxx(ji,jj)  =  zalf  *   psxx(ji,jj,jl) * zalfq 
     339            zfy (ji,jj)  =  zalf  * ( psy (ji,jj,jl) + zalf1 * psxy(ji,jj,jl) ) 
     340            zfxy(ji,jj)  =  zalfq *   psxy(ji,jj,jl) 
     341            zfyy(ji,jj)  =  zalf  *   psyy(ji,jj,jl) 
     342 
     343            !  Readjust moments remaining in the box. 
     344            psm (ji,jj,jl)  =  psm (ji,jj,jl) - zfm(ji,jj) 
     345            ps0 (ji,jj,jl)  =  ps0 (ji,jj,jl) - zf0(ji,jj) 
     346            psx (ji,jj,jl)  =  zalf1q * ( psx(ji,jj,jl) - 3.0 * zalf * psxx(ji,jj,jl) ) 
     347            psxx(ji,jj,jl)  =  zalf1  * zalf1q * psxx(ji,jj,jl) 
     348            psy (ji,jj,jl)  =  psy (ji,jj,jl) - zfy(ji,jj) 
     349            psyy(ji,jj,jl)  =  psyy(ji,jj,jl) - zfyy(ji,jj) 
     350            psxy(ji,jj,jl)  =  zalf1q * psxy(ji,jj,jl) 
     351         END_2D 
     352 
     353         DO_2D_00_10 
     354            zalf          = MAX( 0._wp, -put(ji,jj) ) * pdt / psm(ji+1,jj,jl)  
     355            zalg  (ji,jj) = zalf 
     356            zalfq         = zalf * zalf 
     357            zalf1         = 1.0 - zalf 
     358            zalg1 (ji,jj) = zalf1 
     359            zalf1q        = zalf1 * zalf1 
     360            zalg1q(ji,jj) = zalf1q 
     361            ! 
     362            zfm   (ji,jj) = zfm (ji,jj) + zalf  *    psm (ji+1,jj,jl) 
     363            zf0   (ji,jj) = zf0 (ji,jj) + zalf  * (  ps0 (ji+1,jj,jl) & 
     364               &                                   - zalf1 * ( psx(ji+1,jj,jl) - (zalf1 - zalf ) * psxx(ji+1,jj,jl) ) ) 
     365            zfx   (ji,jj) = zfx (ji,jj) + zalfq * (  psx (ji+1,jj,jl) - 3.0 * zalf1 * psxx(ji+1,jj,jl) ) 
     366            zfxx  (ji,jj) = zfxx(ji,jj) + zalf  *    psxx(ji+1,jj,jl) * zalfq 
     367            zfy   (ji,jj) = zfy (ji,jj) + zalf  * (  psy (ji+1,jj,jl) - zalf1 * psxy(ji+1,jj,jl) ) 
     368            zfxy  (ji,jj) = zfxy(ji,jj) + zalfq *    psxy(ji+1,jj,jl) 
     369            zfyy  (ji,jj) = zfyy(ji,jj) + zalf  *    psyy(ji+1,jj,jl) 
     370         END_2D 
     371 
     372         DO_2D_00_00 
     373            zbt  =       zbet(ji-1,jj) 
     374            zbt1 = 1.0 - zbet(ji-1,jj) 
     375            ! 
     376            psm (ji,jj,jl) = zbt * psm(ji,jj,jl) + zbt1 * ( psm(ji,jj,jl) - zfm(ji-1,jj) ) 
     377            ps0 (ji,jj,jl) = zbt * ps0(ji,jj,jl) + zbt1 * ( ps0(ji,jj,jl) - zf0(ji-1,jj) ) 
     378            psx (ji,jj,jl) = zalg1q(ji-1,jj) * ( psx(ji,jj,jl) + 3.0 * zalg(ji-1,jj) * psxx(ji,jj,jl) ) 
     379            psxx(ji,jj,jl) = zalg1 (ji-1,jj) * zalg1q(ji-1,jj) * psxx(ji,jj,jl) 
     380            psy (ji,jj,jl) = zbt * psy (ji,jj,jl) + zbt1 * ( psy (ji,jj,jl) - zfy (ji-1,jj) ) 
     381            psyy(ji,jj,jl) = zbt * psyy(ji,jj,jl) + zbt1 * ( psyy(ji,jj,jl) - zfyy(ji-1,jj) ) 
     382            psxy(ji,jj,jl) = zalg1q(ji-1,jj) * psxy(ji,jj,jl) 
     383         END_2D 
    395384 
    396385         !   Put the temporary moments into appropriate neighboring boxes.     
    397          DO jj = 2, jpjm1                     !   Flux from i to i+1 IF u GT 0. 
    398             DO ji = fs_2, fs_jpim1 
    399                zbt  =       zbet(ji-1,jj) 
    400                zbt1 = 1.0 - zbet(ji-1,jj) 
    401                psm(ji,jj,jl) = zbt * ( psm(ji,jj,jl) + zfm(ji-1,jj) ) + zbt1 * psm(ji,jj,jl) 
    402                zalf          = zbt * zfm(ji-1,jj) / psm(ji,jj,jl) 
    403                zalf1         = 1.0 - zalf 
    404                ztemp         = zalf * ps0(ji,jj,jl) - zalf1 * zf0(ji-1,jj) 
    405                ! 
    406                ps0 (ji,jj,jl) =  zbt  * ( ps0(ji,jj,jl) + zf0(ji-1,jj) ) + zbt1 * ps0(ji,jj,jl) 
    407                psx (ji,jj,jl) =  zbt  * ( zalf * zfx(ji-1,jj) + zalf1 * psx(ji,jj,jl) + 3.0 * ztemp ) + zbt1 * psx(ji,jj,jl) 
    408                psxx(ji,jj,jl) =  zbt  * ( zalf * zalf * zfxx(ji-1,jj) + zalf1 * zalf1 * psxx(ji,jj,jl)                             & 
    409                   &                     + 5.0 * ( zalf * zalf1 * ( psx (ji,jj,jl) - zfx(ji-1,jj) ) - ( zalf1 - zalf ) * ztemp )  ) & 
    410                   &            + zbt1 * psxx(ji,jj,jl) 
    411                psxy(ji,jj,jl) =  zbt  * ( zalf * zfxy(ji-1,jj) + zalf1 * psxy(ji,jj,jl)             & 
    412                   &                     + 3.0 * (- zalf1*zfy(ji-1,jj)  + zalf * psy(ji,jj,jl) ) )   & 
    413                   &            + zbt1 * psxy(ji,jj,jl) 
    414                psy (ji,jj,jl) =  zbt  * ( psy (ji,jj,jl) + zfy (ji-1,jj) ) + zbt1 * psy (ji,jj,jl) 
    415                psyy(ji,jj,jl) =  zbt  * ( psyy(ji,jj,jl) + zfyy(ji-1,jj) ) + zbt1 * psyy(ji,jj,jl) 
    416             END DO 
    417          END DO 
    418  
    419          DO jj = 2, jpjm1                      !  Flux from i+1 to i IF u LT 0. 
    420             DO ji = fs_2, fs_jpim1 
    421                zbt  =       zbet(ji,jj) 
    422                zbt1 = 1.0 - zbet(ji,jj) 
    423                psm(ji,jj,jl) = zbt * psm(ji,jj,jl) + zbt1 * ( psm(ji,jj,jl) + zfm(ji,jj) ) 
    424                zalf          = zbt1 * zfm(ji,jj) / psm(ji,jj,jl) 
    425                zalf1         = 1.0 - zalf 
    426                ztemp         = - zalf * ps0(ji,jj,jl) + zalf1 * zf0(ji,jj) 
    427                ! 
    428                ps0 (ji,jj,jl) = zbt * ps0 (ji,jj,jl) + zbt1 * ( ps0(ji,jj,jl) + zf0(ji,jj) ) 
    429                psx (ji,jj,jl) = zbt * psx (ji,jj,jl) + zbt1 * ( zalf * zfx(ji,jj) + zalf1 * psx(ji,jj,jl) + 3.0 * ztemp ) 
    430                psxx(ji,jj,jl) = zbt * psxx(ji,jj,jl) + zbt1 * ( zalf * zalf * zfxx(ji,jj) + zalf1 * zalf1 * psxx(ji,jj,jl) & 
    431                   &                                           + 5.0 * ( zalf * zalf1 * ( - psx(ji,jj,jl) + zfx(ji,jj) )    & 
    432                   &                                           + ( zalf1 - zalf ) * ztemp ) ) 
    433                psxy(ji,jj,jl) = zbt * psxy(ji,jj,jl) + zbt1 * ( zalf * zfxy(ji,jj) + zalf1 * psxy(ji,jj,jl)  & 
    434                   &                                           + 3.0 * ( zalf1 * zfy(ji,jj) - zalf * psy(ji,jj,jl) ) ) 
    435                psy (ji,jj,jl) = zbt * psy (ji,jj,jl) + zbt1 * ( psy (ji,jj,jl) + zfy (ji,jj) ) 
    436                psyy(ji,jj,jl) = zbt * psyy(ji,jj,jl) + zbt1 * ( psyy(ji,jj,jl) + zfyy(ji,jj) ) 
    437             END DO 
    438          END DO 
     386         DO_2D_00_00 
     387            zbt  =       zbet(ji-1,jj) 
     388            zbt1 = 1.0 - zbet(ji-1,jj) 
     389            psm(ji,jj,jl) = zbt * ( psm(ji,jj,jl) + zfm(ji-1,jj) ) + zbt1 * psm(ji,jj,jl) 
     390            zalf          = zbt * zfm(ji-1,jj) / psm(ji,jj,jl) 
     391            zalf1         = 1.0 - zalf 
     392            ztemp         = zalf * ps0(ji,jj,jl) - zalf1 * zf0(ji-1,jj) 
     393            ! 
     394            ps0 (ji,jj,jl) =  zbt  * ( ps0(ji,jj,jl) + zf0(ji-1,jj) ) + zbt1 * ps0(ji,jj,jl) 
     395            psx (ji,jj,jl) =  zbt  * ( zalf * zfx(ji-1,jj) + zalf1 * psx(ji,jj,jl) + 3.0 * ztemp ) + zbt1 * psx(ji,jj,jl) 
     396            psxx(ji,jj,jl) =  zbt  * ( zalf * zalf * zfxx(ji-1,jj) + zalf1 * zalf1 * psxx(ji,jj,jl)                             & 
     397               &                     + 5.0 * ( zalf * zalf1 * ( psx (ji,jj,jl) - zfx(ji-1,jj) ) - ( zalf1 - zalf ) * ztemp )  ) & 
     398               &            + zbt1 * psxx(ji,jj,jl) 
     399            psxy(ji,jj,jl) =  zbt  * ( zalf * zfxy(ji-1,jj) + zalf1 * psxy(ji,jj,jl)             & 
     400               &                     + 3.0 * (- zalf1*zfy(ji-1,jj)  + zalf * psy(ji,jj,jl) ) )   & 
     401               &            + zbt1 * psxy(ji,jj,jl) 
     402            psy (ji,jj,jl) =  zbt  * ( psy (ji,jj,jl) + zfy (ji-1,jj) ) + zbt1 * psy (ji,jj,jl) 
     403            psyy(ji,jj,jl) =  zbt  * ( psyy(ji,jj,jl) + zfyy(ji-1,jj) ) + zbt1 * psyy(ji,jj,jl) 
     404         END_2D 
     405 
     406         DO_2D_00_00 
     407            zbt  =       zbet(ji,jj) 
     408            zbt1 = 1.0 - zbet(ji,jj) 
     409            psm(ji,jj,jl) = zbt * psm(ji,jj,jl) + zbt1 * ( psm(ji,jj,jl) + zfm(ji,jj) ) 
     410            zalf          = zbt1 * zfm(ji,jj) / psm(ji,jj,jl) 
     411            zalf1         = 1.0 - zalf 
     412            ztemp         = - zalf * ps0(ji,jj,jl) + zalf1 * zf0(ji,jj) 
     413            ! 
     414            ps0 (ji,jj,jl) = zbt * ps0 (ji,jj,jl) + zbt1 * ( ps0(ji,jj,jl) + zf0(ji,jj) ) 
     415            psx (ji,jj,jl) = zbt * psx (ji,jj,jl) + zbt1 * ( zalf * zfx(ji,jj) + zalf1 * psx(ji,jj,jl) + 3.0 * ztemp ) 
     416            psxx(ji,jj,jl) = zbt * psxx(ji,jj,jl) + zbt1 * ( zalf * zalf * zfxx(ji,jj) + zalf1 * zalf1 * psxx(ji,jj,jl) & 
     417               &                                           + 5.0 * ( zalf * zalf1 * ( - psx(ji,jj,jl) + zfx(ji,jj) )    & 
     418               &                                           + ( zalf1 - zalf ) * ztemp ) ) 
     419            psxy(ji,jj,jl) = zbt * psxy(ji,jj,jl) + zbt1 * ( zalf * zfxy(ji,jj) + zalf1 * psxy(ji,jj,jl)  & 
     420               &                                           + 3.0 * ( zalf1 * zfy(ji,jj) - zalf * psy(ji,jj,jl) ) ) 
     421            psy (ji,jj,jl) = zbt * psy (ji,jj,jl) + zbt1 * ( psy (ji,jj,jl) + zfy (ji,jj) ) 
     422            psyy(ji,jj,jl) = zbt * psyy(ji,jj,jl) + zbt1 * ( psyy(ji,jj,jl) + zfyy(ji,jj) ) 
     423         END_2D 
    439424 
    440425      END DO 
     
    478463         ! 
    479464         ! Limitation of moments. 
    480          DO jj = 1, jpj 
    481             DO ji = fs_2, fs_jpim1 
    482                !  Initialize volumes of boxes (=area if adv_x first called, =psm otherwise) 
    483                psm(ji,jj,jl) = MAX(  pcrh * e1e2t(ji,jj) + ( 1.0 - pcrh ) * psm(ji,jj,jl) , epsi20  ) 
    484                ! 
    485                zslpmax = MAX( 0._wp, ps0(ji,jj,jl) ) 
    486                zs1max  = 1.5 * zslpmax 
    487                zs1new  = MIN( zs1max, MAX( -zs1max, psy(ji,jj,jl) ) ) 
    488                zs2new  = MIN(  ( 2.0 * zslpmax - 0.3334 * ABS( zs1new ) ),   & 
    489                   &             MAX( ABS( zs1new )-zslpmax, psyy(ji,jj,jl) )  ) 
    490                rswitch = ( 1.0 - MAX( 0._wp, SIGN( 1._wp, -zslpmax) ) ) * tmask(ji,jj,1)   ! Case of empty boxes & Apply mask 
    491                ! 
    492                ps0 (ji,jj,jl) = zslpmax   
    493                psx (ji,jj,jl) = psx (ji,jj,jl) * rswitch 
    494                psxx(ji,jj,jl) = psxx(ji,jj,jl) * rswitch 
    495                psy (ji,jj,jl) = zs1new         * rswitch 
    496                psyy(ji,jj,jl) = zs2new         * rswitch 
    497                psxy(ji,jj,jl) = MIN( zslpmax, MAX( -zslpmax, psxy(ji,jj,jl) ) ) * rswitch 
    498             END DO 
    499          END DO 
     465         DO_2D_11_00 
     466            !  Initialize volumes of boxes (=area if adv_x first called, =psm otherwise) 
     467            psm(ji,jj,jl) = MAX(  pcrh * e1e2t(ji,jj) + ( 1.0 - pcrh ) * psm(ji,jj,jl) , epsi20  ) 
     468            ! 
     469            zslpmax = MAX( 0._wp, ps0(ji,jj,jl) ) 
     470            zs1max  = 1.5 * zslpmax 
     471            zs1new  = MIN( zs1max, MAX( -zs1max, psy(ji,jj,jl) ) ) 
     472            zs2new  = MIN(  ( 2.0 * zslpmax - 0.3334 * ABS( zs1new ) ),   & 
     473               &             MAX( ABS( zs1new )-zslpmax, psyy(ji,jj,jl) )  ) 
     474            rswitch = ( 1.0 - MAX( 0._wp, SIGN( 1._wp, -zslpmax) ) ) * tmask(ji,jj,1)   ! Case of empty boxes & Apply mask 
     475            ! 
     476            ps0 (ji,jj,jl) = zslpmax   
     477            psx (ji,jj,jl) = psx (ji,jj,jl) * rswitch 
     478            psxx(ji,jj,jl) = psxx(ji,jj,jl) * rswitch 
     479            psy (ji,jj,jl) = zs1new         * rswitch 
     480            psyy(ji,jj,jl) = zs2new         * rswitch 
     481            psxy(ji,jj,jl) = MIN( zslpmax, MAX( -zslpmax, psxy(ji,jj,jl) ) ) * rswitch 
     482         END_2D 
    500483  
    501484         !  Calculate fluxes and moments between boxes j<-->j+1               
    502          DO jj = 1, jpj                     !  Flux from j to j+1 WHEN v GT 0    
    503             DO ji = fs_2, fs_jpim1 
    504                zbet(ji,jj)  =  MAX( 0._wp, SIGN( 1._wp, pvt(ji,jj) ) ) 
    505                zalf         =  MAX( 0._wp, pvt(ji,jj) ) * pdt / psm(ji,jj,jl) 
    506                zalfq        =  zalf * zalf 
    507                zalf1        =  1.0 - zalf 
    508                zalf1q       =  zalf1 * zalf1 
    509                ! 
    510                zfm (ji,jj)  =  zalf  * psm(ji,jj,jl) 
    511                zf0 (ji,jj)  =  zalf  * ( ps0(ji,jj,jl) + zalf1 * ( psy(ji,jj,jl)  + (zalf1-zalf) * psyy(ji,jj,jl) ) )  
    512                zfy (ji,jj)  =  zalfq *( psy(ji,jj,jl) + 3.0*zalf1*psyy(ji,jj,jl) ) 
    513                zfyy(ji,jj)  =  zalf  * zalfq * psyy(ji,jj,jl) 
    514                zfx (ji,jj)  =  zalf  * ( psx(ji,jj,jl) + zalf1 * psxy(ji,jj,jl) ) 
    515                zfxy(ji,jj)  =  zalfq * psxy(ji,jj,jl) 
    516                zfxx(ji,jj)  =  zalf  * psxx(ji,jj,jl) 
    517                ! 
    518                !  Readjust moments remaining in the box. 
    519                psm (ji,jj,jl)  =  psm (ji,jj,jl) - zfm(ji,jj) 
    520                ps0 (ji,jj,jl)  =  ps0 (ji,jj,jl) - zf0(ji,jj) 
    521                psy (ji,jj,jl)  =  zalf1q * ( psy(ji,jj,jl) -3.0 * zalf * psyy(ji,jj,jl) ) 
    522                psyy(ji,jj,jl)  =  zalf1 * zalf1q * psyy(ji,jj,jl) 
    523                psx (ji,jj,jl)  =  psx (ji,jj,jl) - zfx(ji,jj) 
    524                psxx(ji,jj,jl)  =  psxx(ji,jj,jl) - zfxx(ji,jj) 
    525                psxy(ji,jj,jl)  =  zalf1q * psxy(ji,jj,jl) 
    526             END DO 
    527          END DO 
    528          ! 
    529          DO jj = 1, jpjm1                   !  Flux from j+1 to j when v LT 0. 
    530             DO ji = fs_2, fs_jpim1 
    531                zalf          = MAX( 0._wp, -pvt(ji,jj) ) * pdt / psm(ji,jj+1,jl)  
    532                zalg  (ji,jj) = zalf 
    533                zalfq         = zalf * zalf 
    534                zalf1         = 1.0 - zalf 
    535                zalg1 (ji,jj) = zalf1 
    536                zalf1q        = zalf1 * zalf1 
    537                zalg1q(ji,jj) = zalf1q 
    538                ! 
    539                zfm   (ji,jj) = zfm (ji,jj) + zalf  *    psm (ji,jj+1,jl) 
    540                zf0   (ji,jj) = zf0 (ji,jj) + zalf  * (  ps0 (ji,jj+1,jl) & 
    541                   &                                   - zalf1 * (psy(ji,jj+1,jl) - (zalf1 - zalf ) * psyy(ji,jj+1,jl) ) ) 
    542                zfy   (ji,jj) = zfy (ji,jj) + zalfq * (  psy (ji,jj+1,jl) - 3.0 * zalf1 * psyy(ji,jj+1,jl) ) 
    543                zfyy  (ji,jj) = zfyy(ji,jj) + zalf  *    psyy(ji,jj+1,jl) * zalfq 
    544                zfx   (ji,jj) = zfx (ji,jj) + zalf  * (  psx (ji,jj+1,jl) - zalf1 * psxy(ji,jj+1,jl) ) 
    545                zfxy  (ji,jj) = zfxy(ji,jj) + zalfq *    psxy(ji,jj+1,jl) 
    546                zfxx  (ji,jj) = zfxx(ji,jj) + zalf  *    psxx(ji,jj+1,jl) 
    547             END DO 
    548          END DO 
     485         DO_2D_11_00 
     486            zbet(ji,jj)  =  MAX( 0._wp, SIGN( 1._wp, pvt(ji,jj) ) ) 
     487            zalf         =  MAX( 0._wp, pvt(ji,jj) ) * pdt / psm(ji,jj,jl) 
     488            zalfq        =  zalf * zalf 
     489            zalf1        =  1.0 - zalf 
     490            zalf1q       =  zalf1 * zalf1 
     491            ! 
     492            zfm (ji,jj)  =  zalf  * psm(ji,jj,jl) 
     493            zf0 (ji,jj)  =  zalf  * ( ps0(ji,jj,jl) + zalf1 * ( psy(ji,jj,jl)  + (zalf1-zalf) * psyy(ji,jj,jl) ) )  
     494            zfy (ji,jj)  =  zalfq *( psy(ji,jj,jl) + 3.0*zalf1*psyy(ji,jj,jl) ) 
     495            zfyy(ji,jj)  =  zalf  * zalfq * psyy(ji,jj,jl) 
     496            zfx (ji,jj)  =  zalf  * ( psx(ji,jj,jl) + zalf1 * psxy(ji,jj,jl) ) 
     497            zfxy(ji,jj)  =  zalfq * psxy(ji,jj,jl) 
     498            zfxx(ji,jj)  =  zalf  * psxx(ji,jj,jl) 
     499            ! 
     500            !  Readjust moments remaining in the box. 
     501            psm (ji,jj,jl)  =  psm (ji,jj,jl) - zfm(ji,jj) 
     502            ps0 (ji,jj,jl)  =  ps0 (ji,jj,jl) - zf0(ji,jj) 
     503            psy (ji,jj,jl)  =  zalf1q * ( psy(ji,jj,jl) -3.0 * zalf * psyy(ji,jj,jl) ) 
     504            psyy(ji,jj,jl)  =  zalf1 * zalf1q * psyy(ji,jj,jl) 
     505            psx (ji,jj,jl)  =  psx (ji,jj,jl) - zfx(ji,jj) 
     506            psxx(ji,jj,jl)  =  psxx(ji,jj,jl) - zfxx(ji,jj) 
     507            psxy(ji,jj,jl)  =  zalf1q * psxy(ji,jj,jl) 
     508         END_2D 
     509         ! 
     510         DO_2D_10_00 
     511            zalf          = MAX( 0._wp, -pvt(ji,jj) ) * pdt / psm(ji,jj+1,jl)  
     512            zalg  (ji,jj) = zalf 
     513            zalfq         = zalf * zalf 
     514            zalf1         = 1.0 - zalf 
     515            zalg1 (ji,jj) = zalf1 
     516            zalf1q        = zalf1 * zalf1 
     517            zalg1q(ji,jj) = zalf1q 
     518            ! 
     519            zfm   (ji,jj) = zfm (ji,jj) + zalf  *    psm (ji,jj+1,jl) 
     520            zf0   (ji,jj) = zf0 (ji,jj) + zalf  * (  ps0 (ji,jj+1,jl) & 
     521               &                                   - zalf1 * (psy(ji,jj+1,jl) - (zalf1 - zalf ) * psyy(ji,jj+1,jl) ) ) 
     522            zfy   (ji,jj) = zfy (ji,jj) + zalfq * (  psy (ji,jj+1,jl) - 3.0 * zalf1 * psyy(ji,jj+1,jl) ) 
     523            zfyy  (ji,jj) = zfyy(ji,jj) + zalf  *    psyy(ji,jj+1,jl) * zalfq 
     524            zfx   (ji,jj) = zfx (ji,jj) + zalf  * (  psx (ji,jj+1,jl) - zalf1 * psxy(ji,jj+1,jl) ) 
     525            zfxy  (ji,jj) = zfxy(ji,jj) + zalfq *    psxy(ji,jj+1,jl) 
     526            zfxx  (ji,jj) = zfxx(ji,jj) + zalf  *    psxx(ji,jj+1,jl) 
     527         END_2D 
    549528 
    550529         !  Readjust moments remaining in the box.  
    551          DO jj = 2, jpjm1 
    552             DO ji = fs_2, fs_jpim1 
    553                zbt  =         zbet(ji,jj-1) 
    554                zbt1 = ( 1.0 - zbet(ji,jj-1) ) 
    555                ! 
    556                psm (ji,jj,jl) = zbt * psm(ji,jj,jl) + zbt1 * ( psm(ji,jj,jl) - zfm(ji,jj-1) ) 
    557                ps0 (ji,jj,jl) = zbt * ps0(ji,jj,jl) + zbt1 * ( ps0(ji,jj,jl) - zf0(ji,jj-1) ) 
    558                psy (ji,jj,jl) = zalg1q(ji,jj-1) * ( psy(ji,jj,jl) + 3.0 * zalg(ji,jj-1) * psyy(ji,jj,jl) ) 
    559                psyy(ji,jj,jl) = zalg1 (ji,jj-1) * zalg1q(ji,jj-1) * psyy(ji,jj,jl) 
    560                psx (ji,jj,jl) = zbt * psx (ji,jj,jl) + zbt1 * ( psx (ji,jj,jl) - zfx (ji,jj-1) ) 
    561                psxx(ji,jj,jl) = zbt * psxx(ji,jj,jl) + zbt1 * ( psxx(ji,jj,jl) - zfxx(ji,jj-1) ) 
    562                psxy(ji,jj,jl) = zalg1q(ji,jj-1) * psxy(ji,jj,jl) 
    563             END DO 
    564          END DO 
     530         DO_2D_00_00 
     531            zbt  =         zbet(ji,jj-1) 
     532            zbt1 = ( 1.0 - zbet(ji,jj-1) ) 
     533            ! 
     534            psm (ji,jj,jl) = zbt * psm(ji,jj,jl) + zbt1 * ( psm(ji,jj,jl) - zfm(ji,jj-1) ) 
     535            ps0 (ji,jj,jl) = zbt * ps0(ji,jj,jl) + zbt1 * ( ps0(ji,jj,jl) - zf0(ji,jj-1) ) 
     536            psy (ji,jj,jl) = zalg1q(ji,jj-1) * ( psy(ji,jj,jl) + 3.0 * zalg(ji,jj-1) * psyy(ji,jj,jl) ) 
     537            psyy(ji,jj,jl) = zalg1 (ji,jj-1) * zalg1q(ji,jj-1) * psyy(ji,jj,jl) 
     538            psx (ji,jj,jl) = zbt * psx (ji,jj,jl) + zbt1 * ( psx (ji,jj,jl) - zfx (ji,jj-1) ) 
     539            psxx(ji,jj,jl) = zbt * psxx(ji,jj,jl) + zbt1 * ( psxx(ji,jj,jl) - zfxx(ji,jj-1) ) 
     540            psxy(ji,jj,jl) = zalg1q(ji,jj-1) * psxy(ji,jj,jl) 
     541         END_2D 
    565542 
    566543         !   Put the temporary moments into appropriate neighboring boxes.     
    567          DO jj = 2, jpjm1                    !   Flux from j to j+1 IF v GT 0. 
    568             DO ji = fs_2, fs_jpim1 
    569                zbt  =       zbet(ji,jj-1) 
    570                zbt1 = 1.0 - zbet(ji,jj-1) 
    571                psm(ji,jj,jl) = zbt * ( psm(ji,jj,jl) + zfm(ji,jj-1) ) + zbt1 * psm(ji,jj,jl)  
    572                zalf          = zbt * zfm(ji,jj-1) / psm(ji,jj,jl)  
    573                zalf1         = 1.0 - zalf 
    574                ztemp         = zalf * ps0(ji,jj,jl) - zalf1 * zf0(ji,jj-1) 
    575                ! 
    576                ps0(ji,jj,jl)  =   zbt  * ( ps0(ji,jj,jl) + zf0(ji,jj-1) ) + zbt1 * ps0(ji,jj,jl) 
    577                psy(ji,jj,jl)  =   zbt  * ( zalf * zfy(ji,jj-1) + zalf1 * psy(ji,jj,jl) + 3.0 * ztemp )  & 
    578                   &             + zbt1 * psy(ji,jj,jl)   
    579                psyy(ji,jj,jl) =   zbt  * ( zalf * zalf * zfyy(ji,jj-1) + zalf1 * zalf1 * psyy(ji,jj,jl)                           & 
    580                   &                      + 5.0 * ( zalf * zalf1 * ( psy(ji,jj,jl) - zfy(ji,jj-1) ) - ( zalf1 - zalf ) * ztemp ) ) &  
    581                   &             + zbt1 * psyy(ji,jj,jl) 
    582                psxy(ji,jj,jl) =   zbt  * (  zalf * zfxy(ji,jj-1) + zalf1 * psxy(ji,jj,jl)            & 
    583                   &                      + 3.0 * (- zalf1 * zfx(ji,jj-1) + zalf * psx(ji,jj,jl) ) )  & 
    584                   &             + zbt1 * psxy(ji,jj,jl) 
    585                psx (ji,jj,jl) =   zbt * ( psx (ji,jj,jl) + zfx (ji,jj-1) ) + zbt1 * psx (ji,jj,jl) 
    586                psxx(ji,jj,jl) =   zbt * ( psxx(ji,jj,jl) + zfxx(ji,jj-1) ) + zbt1 * psxx(ji,jj,jl) 
    587             END DO 
    588          END DO 
    589  
    590          DO jj = 2, jpjm1                      !  Flux from j+1 to j IF v LT 0. 
    591             DO ji = fs_2, fs_jpim1 
    592                zbt  =       zbet(ji,jj) 
    593                zbt1 = 1.0 - zbet(ji,jj) 
    594                psm(ji,jj,jl) = zbt * psm(ji,jj,jl) + zbt1 * ( psm(ji,jj,jl) + zfm(ji,jj) ) 
    595                zalf          = zbt1 * zfm(ji,jj) / psm(ji,jj,jl) 
    596                zalf1         = 1.0 - zalf 
    597                ztemp         = - zalf * ps0(ji,jj,jl) + zalf1 * zf0(ji,jj) 
    598                ! 
    599                ps0 (ji,jj,jl) = zbt * ps0 (ji,jj,jl) + zbt1 * (  ps0(ji,jj,jl) + zf0(ji,jj) ) 
    600                psy (ji,jj,jl) = zbt * psy (ji,jj,jl) + zbt1 * (  zalf * zfy(ji,jj) + zalf1 * psy(ji,jj,jl) + 3.0 * ztemp ) 
    601                psyy(ji,jj,jl) = zbt * psyy(ji,jj,jl) + zbt1 * (  zalf * zalf * zfyy(ji,jj) + zalf1 * zalf1 * psyy(ji,jj,jl) & 
    602                   &                                            + 5.0 * ( zalf * zalf1 * ( - psy(ji,jj,jl) + zfy(ji,jj) )    & 
    603                   &                                            + ( zalf1 - zalf ) * ztemp ) ) 
    604                psxy(ji,jj,jl) = zbt * psxy(ji,jj,jl) + zbt1 * (  zalf * zfxy(ji,jj) + zalf1 * psxy(ji,jj,jl)  & 
    605                   &                                            + 3.0 * ( zalf1 * zfx(ji,jj) - zalf * psx(ji,jj,jl) ) ) 
    606                psx (ji,jj,jl) = zbt * psx (ji,jj,jl) + zbt1 * ( psx (ji,jj,jl) + zfx (ji,jj) ) 
    607                psxx(ji,jj,jl) = zbt * psxx(ji,jj,jl) + zbt1 * ( psxx(ji,jj,jl) + zfxx(ji,jj) ) 
    608             END DO 
    609          END DO 
     544         DO_2D_00_00 
     545            zbt  =       zbet(ji,jj-1) 
     546            zbt1 = 1.0 - zbet(ji,jj-1) 
     547            psm(ji,jj,jl) = zbt * ( psm(ji,jj,jl) + zfm(ji,jj-1) ) + zbt1 * psm(ji,jj,jl)  
     548            zalf          = zbt * zfm(ji,jj-1) / psm(ji,jj,jl)  
     549            zalf1         = 1.0 - zalf 
     550            ztemp         = zalf * ps0(ji,jj,jl) - zalf1 * zf0(ji,jj-1) 
     551            ! 
     552            ps0(ji,jj,jl)  =   zbt  * ( ps0(ji,jj,jl) + zf0(ji,jj-1) ) + zbt1 * ps0(ji,jj,jl) 
     553            psy(ji,jj,jl)  =   zbt  * ( zalf * zfy(ji,jj-1) + zalf1 * psy(ji,jj,jl) + 3.0 * ztemp )  & 
     554               &             + zbt1 * psy(ji,jj,jl)   
     555            psyy(ji,jj,jl) =   zbt  * ( zalf * zalf * zfyy(ji,jj-1) + zalf1 * zalf1 * psyy(ji,jj,jl)                           & 
     556               &                      + 5.0 * ( zalf * zalf1 * ( psy(ji,jj,jl) - zfy(ji,jj-1) ) - ( zalf1 - zalf ) * ztemp ) ) &  
     557               &             + zbt1 * psyy(ji,jj,jl) 
     558            psxy(ji,jj,jl) =   zbt  * (  zalf * zfxy(ji,jj-1) + zalf1 * psxy(ji,jj,jl)            & 
     559               &                      + 3.0 * (- zalf1 * zfx(ji,jj-1) + zalf * psx(ji,jj,jl) ) )  & 
     560               &             + zbt1 * psxy(ji,jj,jl) 
     561            psx (ji,jj,jl) =   zbt * ( psx (ji,jj,jl) + zfx (ji,jj-1) ) + zbt1 * psx (ji,jj,jl) 
     562            psxx(ji,jj,jl) =   zbt * ( psxx(ji,jj,jl) + zfxx(ji,jj-1) ) + zbt1 * psxx(ji,jj,jl) 
     563         END_2D 
     564 
     565         DO_2D_00_00 
     566            zbt  =       zbet(ji,jj) 
     567            zbt1 = 1.0 - zbet(ji,jj) 
     568            psm(ji,jj,jl) = zbt * psm(ji,jj,jl) + zbt1 * ( psm(ji,jj,jl) + zfm(ji,jj) ) 
     569            zalf          = zbt1 * zfm(ji,jj) / psm(ji,jj,jl) 
     570            zalf1         = 1.0 - zalf 
     571            ztemp         = - zalf * ps0(ji,jj,jl) + zalf1 * zf0(ji,jj) 
     572            ! 
     573            ps0 (ji,jj,jl) = zbt * ps0 (ji,jj,jl) + zbt1 * (  ps0(ji,jj,jl) + zf0(ji,jj) ) 
     574            psy (ji,jj,jl) = zbt * psy (ji,jj,jl) + zbt1 * (  zalf * zfy(ji,jj) + zalf1 * psy(ji,jj,jl) + 3.0 * ztemp ) 
     575            psyy(ji,jj,jl) = zbt * psyy(ji,jj,jl) + zbt1 * (  zalf * zalf * zfyy(ji,jj) + zalf1 * zalf1 * psyy(ji,jj,jl) & 
     576               &                                            + 5.0 * ( zalf * zalf1 * ( - psy(ji,jj,jl) + zfy(ji,jj) )    & 
     577               &                                            + ( zalf1 - zalf ) * ztemp ) ) 
     578            psxy(ji,jj,jl) = zbt * psxy(ji,jj,jl) + zbt1 * (  zalf * zfxy(ji,jj) + zalf1 * psxy(ji,jj,jl)  & 
     579               &                                            + 3.0 * ( zalf1 * zfx(ji,jj) - zalf * psx(ji,jj,jl) ) ) 
     580            psx (ji,jj,jl) = zbt * psx (ji,jj,jl) + zbt1 * ( psx (ji,jj,jl) + zfx (ji,jj) ) 
     581            psxx(ji,jj,jl) = zbt * psxx(ji,jj,jl) + zbt1 * ( psxx(ji,jj,jl) + zfxx(ji,jj) ) 
     582         END_2D 
    610583 
    611584      END DO 
     
    646619      DO jl = 1, jpl 
    647620 
    648          DO jj = 1, jpj 
    649             DO ji = 1, jpi 
    650                IF ( pv_i(ji,jj,jl) > 0._wp ) THEN 
     621         DO_2D_11_11 
     622            IF ( pv_i(ji,jj,jl) > 0._wp ) THEN 
     623               ! 
     624               !                               ! -- check h_ip -- ! 
     625               ! if h_ip is larger than the surrounding 9 pts => reduce h_ip and increase a_ip 
     626               IF( ln_pnd_H12 .AND. pv_ip(ji,jj,jl) > 0._wp ) THEN 
     627                  zhip = pv_ip(ji,jj,jl) / MAX( epsi20, pa_ip(ji,jj,jl) ) 
     628                  IF( zhip > phip_max(ji,jj,jl) .AND. pa_ip(ji,jj,jl) < 0.15 ) THEN 
     629                     pa_ip(ji,jj,jl) = pv_ip(ji,jj,jl) / phip_max(ji,jj,jl) 
     630                  ENDIF 
     631               ENDIF 
     632               ! 
     633               !                               ! -- check h_i -- ! 
     634               ! if h_i is larger than the surrounding 9 pts => reduce h_i and increase a_i 
     635               zhi = pv_i(ji,jj,jl) / pa_i(ji,jj,jl) 
     636               IF( zhi > phi_max(ji,jj,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 
     637                  pa_i(ji,jj,jl) = pv_i(ji,jj,jl) / MIN( phi_max(ji,jj,jl), hi_max(jpl) )   !-- bound h_i to hi_max (99 m) 
     638               ENDIF 
     639               ! 
     640               !                               ! -- check h_s -- ! 
     641               ! if h_s is larger than the surrounding 9 pts => put the snow excess in the ocean 
     642               zhs = pv_s(ji,jj,jl) / pa_i(ji,jj,jl) 
     643               IF( pv_s(ji,jj,jl) > 0._wp .AND. zhs > phs_max(ji,jj,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 
     644                  zfra = phs_max(ji,jj,jl) / MAX( zhs, epsi20 ) 
    651645                  ! 
    652                   !                               ! -- check h_ip -- ! 
    653                   ! if h_ip is larger than the surrounding 9 pts => reduce h_ip and increase a_ip 
    654                   IF( ln_pnd_H12 .AND. pv_ip(ji,jj,jl) > 0._wp ) THEN 
    655                      zhip = pv_ip(ji,jj,jl) / MAX( epsi20, pa_ip(ji,jj,jl) ) 
    656                      IF( zhip > phip_max(ji,jj,jl) .AND. pa_ip(ji,jj,jl) < 0.15 ) THEN 
    657                         pa_ip(ji,jj,jl) = pv_ip(ji,jj,jl) / phip_max(ji,jj,jl) 
    658                      ENDIF 
    659                   ENDIF 
     646                  wfx_res(ji,jj) = wfx_res(ji,jj) + ( pv_s(ji,jj,jl) - pa_i(ji,jj,jl) * phs_max(ji,jj,jl) ) * rhos * z1_dt 
     647                  hfx_res(ji,jj) = hfx_res(ji,jj) - SUM( pe_s(ji,jj,1:nlay_s,jl) ) * ( 1._wp - zfra ) * z1_dt ! W.m-2 <0 
    660648                  ! 
    661                   !                               ! -- check h_i -- ! 
    662                   ! if h_i is larger than the surrounding 9 pts => reduce h_i and increase a_i 
    663                   zhi = pv_i(ji,jj,jl) / pa_i(ji,jj,jl) 
    664                   IF( zhi > phi_max(ji,jj,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 
    665                      pa_i(ji,jj,jl) = pv_i(ji,jj,jl) / MIN( phi_max(ji,jj,jl), hi_max(jpl) )   !-- bound h_i to hi_max (99 m) 
    666                   ENDIF 
    667                   ! 
    668                   !                               ! -- check h_s -- ! 
    669                   ! if h_s is larger than the surrounding 9 pts => put the snow excess in the ocean 
    670                   zhs = pv_s(ji,jj,jl) / pa_i(ji,jj,jl) 
    671                   IF( pv_s(ji,jj,jl) > 0._wp .AND. zhs > phs_max(ji,jj,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 
    672                      zfra = phs_max(ji,jj,jl) / MAX( zhs, epsi20 ) 
    673                      ! 
    674                      wfx_res(ji,jj) = wfx_res(ji,jj) + ( pv_s(ji,jj,jl) - pa_i(ji,jj,jl) * phs_max(ji,jj,jl) ) * rhos * z1_dt 
    675                      hfx_res(ji,jj) = hfx_res(ji,jj) - SUM( pe_s(ji,jj,1:nlay_s,jl) ) * ( 1._wp - zfra ) * z1_dt ! W.m-2 <0 
    676                      ! 
    677                      pe_s(ji,jj,1:nlay_s,jl) = pe_s(ji,jj,1:nlay_s,jl) * zfra 
    678                      pv_s(ji,jj,jl)          = pa_i(ji,jj,jl) * phs_max(ji,jj,jl) 
    679                   ENDIF            
    680                   !                   
    681                ENDIF 
    682             END DO 
    683          END DO 
     649                  pe_s(ji,jj,1:nlay_s,jl) = pe_s(ji,jj,1:nlay_s,jl) * zfra 
     650                  pv_s(ji,jj,jl)          = pa_i(ji,jj,jl) * phs_max(ji,jj,jl) 
     651               ENDIF            
     652               !                   
     653            ENDIF 
     654         END_2D 
    684655      END DO  
    685656      ! 
     
    714685      ! -- check snow load -- ! 
    715686      DO jl = 1, jpl 
    716          DO jj = 1, jpj 
    717             DO ji = 1, jpi 
    718                IF ( pv_i(ji,jj,jl) > 0._wp ) THEN 
    719                   ! 
    720                   zvs_excess = MAX( 0._wp, pv_s(ji,jj,jl) - pv_i(ji,jj,jl) * (rau0-rhoi) * r1_rhos ) 
    721                   ! 
    722                   IF( zvs_excess > 0._wp ) THEN   ! snow-ice interface deplets below the ocean surface 
    723                      ! put snow excess in the ocean 
    724                      zfra = ( pv_s(ji,jj,jl) - zvs_excess ) / MAX( pv_s(ji,jj,jl), epsi20 ) 
    725                      wfx_res(ji,jj) = wfx_res(ji,jj) + zvs_excess * rhos * z1_dt 
    726                      hfx_res(ji,jj) = hfx_res(ji,jj) - SUM( pe_s(ji,jj,1:nlay_s,jl) ) * ( 1._wp - zfra ) * z1_dt ! W.m-2 <0 
    727                      ! correct snow volume and heat content 
    728                      pe_s(ji,jj,1:nlay_s,jl) = pe_s(ji,jj,1:nlay_s,jl) * zfra 
    729                      pv_s(ji,jj,jl)          = pv_s(ji,jj,jl) - zvs_excess 
    730                   ENDIF 
    731                   ! 
     687         DO_2D_11_11 
     688            IF ( pv_i(ji,jj,jl) > 0._wp ) THEN 
     689               ! 
     690               zvs_excess = MAX( 0._wp, pv_s(ji,jj,jl) - pv_i(ji,jj,jl) * (rau0-rhoi) * r1_rhos ) 
     691               ! 
     692               IF( zvs_excess > 0._wp ) THEN   ! snow-ice interface deplets below the ocean surface 
     693                  ! put snow excess in the ocean 
     694                  zfra = ( pv_s(ji,jj,jl) - zvs_excess ) / MAX( pv_s(ji,jj,jl), epsi20 ) 
     695                  wfx_res(ji,jj) = wfx_res(ji,jj) + zvs_excess * rhos * z1_dt 
     696                  hfx_res(ji,jj) = hfx_res(ji,jj) - SUM( pe_s(ji,jj,1:nlay_s,jl) ) * ( 1._wp - zfra ) * z1_dt ! W.m-2 <0 
     697                  ! correct snow volume and heat content 
     698                  pe_s(ji,jj,1:nlay_s,jl) = pe_s(ji,jj,1:nlay_s,jl) * zfra 
     699                  pv_s(ji,jj,jl)          = pv_s(ji,jj,jl) - zvs_excess 
    732700               ENDIF 
    733             END DO 
    734          END DO 
     701               ! 
     702            ENDIF 
     703         END_2D 
    735704      END DO 
    736705      ! 
  • NEMO/branches/2019/dev_r11943_MERGE_2019/src/ICE/icedyn_adv_umx.F90

    r12252 r12340  
    5252   !! * Substitutions 
    5353#  include "vectopt_loop_substitute.h90" 
     54#  include "do_loop_substitute.h90" 
    5455   !!---------------------------------------------------------------------- 
    5556   !! NEMO/ICE 4.0 , NEMO Consortium (2018) 
     
    107108      ! --- Record max of the surrounding 9-pts ice thick. (for call Hbig) --- ! 
    108109      DO jl = 1, jpl 
    109          DO jj = 2, jpjm1 
    110             DO ji = fs_2, fs_jpim1 
    111                zhip_max(ji,jj,jl) = MAX( epsi20, ph_ip(ji,jj,jl), ph_ip(ji+1,jj  ,jl), ph_ip(ji  ,jj+1,jl), & 
    112                   &                                               ph_ip(ji-1,jj  ,jl), ph_ip(ji  ,jj-1,jl), & 
    113                   &                                               ph_ip(ji+1,jj+1,jl), ph_ip(ji-1,jj-1,jl), & 
    114                   &                                               ph_ip(ji+1,jj-1,jl), ph_ip(ji-1,jj+1,jl) ) 
    115                zhi_max (ji,jj,jl) = MAX( epsi20, ph_i (ji,jj,jl), ph_i (ji+1,jj  ,jl), ph_i (ji  ,jj+1,jl), & 
    116                   &                                               ph_i (ji-1,jj  ,jl), ph_i (ji  ,jj-1,jl), & 
    117                   &                                               ph_i (ji+1,jj+1,jl), ph_i (ji-1,jj-1,jl), & 
    118                   &                                               ph_i (ji+1,jj-1,jl), ph_i (ji-1,jj+1,jl) ) 
    119                zhs_max (ji,jj,jl) = MAX( epsi20, ph_s (ji,jj,jl), ph_s (ji+1,jj  ,jl), ph_s (ji  ,jj+1,jl), & 
    120                   &                                               ph_s (ji-1,jj  ,jl), ph_s (ji  ,jj-1,jl), & 
    121                   &                                               ph_s (ji+1,jj+1,jl), ph_s (ji-1,jj-1,jl), & 
    122                   &                                               ph_s (ji+1,jj-1,jl), ph_s (ji-1,jj+1,jl) ) 
    123             END DO 
    124          END DO 
     110         DO_2D_00_00 
     111            zhip_max(ji,jj,jl) = MAX( epsi20, ph_ip(ji,jj,jl), ph_ip(ji+1,jj  ,jl), ph_ip(ji  ,jj+1,jl), & 
     112               &                                               ph_ip(ji-1,jj  ,jl), ph_ip(ji  ,jj-1,jl), & 
     113               &                                               ph_ip(ji+1,jj+1,jl), ph_ip(ji-1,jj-1,jl), & 
     114               &                                               ph_ip(ji+1,jj-1,jl), ph_ip(ji-1,jj+1,jl) ) 
     115            zhi_max (ji,jj,jl) = MAX( epsi20, ph_i (ji,jj,jl), ph_i (ji+1,jj  ,jl), ph_i (ji  ,jj+1,jl), & 
     116               &                                               ph_i (ji-1,jj  ,jl), ph_i (ji  ,jj-1,jl), & 
     117               &                                               ph_i (ji+1,jj+1,jl), ph_i (ji-1,jj-1,jl), & 
     118               &                                               ph_i (ji+1,jj-1,jl), ph_i (ji-1,jj+1,jl) ) 
     119            zhs_max (ji,jj,jl) = MAX( epsi20, ph_s (ji,jj,jl), ph_s (ji+1,jj  ,jl), ph_s (ji  ,jj+1,jl), & 
     120               &                                               ph_s (ji-1,jj  ,jl), ph_s (ji  ,jj-1,jl), & 
     121               &                                               ph_s (ji+1,jj+1,jl), ph_s (ji-1,jj-1,jl), & 
     122               &                                               ph_s (ji+1,jj-1,jl), ph_s (ji-1,jj+1,jl) ) 
     123         END_2D 
    125124      END DO 
    126125      CALL lbc_lnk_multi( 'icedyn_adv_umx', zhi_max, 'T', 1., zhs_max, 'T', 1., zhip_max, 'T', 1. ) 
     
    152151      ! 
    153152      ! --- define velocity for advection: u*grad(H) --- ! 
    154       DO jj = 2, jpjm1 
    155          DO ji = fs_2, fs_jpim1 
    156             IF    ( pu_ice(ji,jj) * pu_ice(ji-1,jj) <= 0._wp ) THEN   ;   zcu_box(ji,jj) = 0._wp 
    157             ELSEIF( pu_ice(ji,jj)                   >  0._wp ) THEN   ;   zcu_box(ji,jj) = pu_ice(ji-1,jj) 
    158             ELSE                                                      ;   zcu_box(ji,jj) = pu_ice(ji  ,jj) 
    159             ENDIF 
    160  
    161             IF    ( pv_ice(ji,jj) * pv_ice(ji,jj-1) <= 0._wp ) THEN   ;   zcv_box(ji,jj) = 0._wp 
    162             ELSEIF( pv_ice(ji,jj)                   >  0._wp ) THEN   ;   zcv_box(ji,jj) = pv_ice(ji,jj-1) 
    163             ELSE                                                      ;   zcv_box(ji,jj) = pv_ice(ji,jj  ) 
    164             ENDIF 
    165          END DO 
    166       END DO 
     153      DO_2D_00_00 
     154         IF    ( pu_ice(ji,jj) * pu_ice(ji-1,jj) <= 0._wp ) THEN   ;   zcu_box(ji,jj) = 0._wp 
     155         ELSEIF( pu_ice(ji,jj)                   >  0._wp ) THEN   ;   zcu_box(ji,jj) = pu_ice(ji-1,jj) 
     156         ELSE                                                      ;   zcu_box(ji,jj) = pu_ice(ji  ,jj) 
     157         ENDIF 
     158 
     159         IF    ( pv_ice(ji,jj) * pv_ice(ji,jj-1) <= 0._wp ) THEN   ;   zcv_box(ji,jj) = 0._wp 
     160         ELSEIF( pv_ice(ji,jj)                   >  0._wp ) THEN   ;   zcv_box(ji,jj) = pv_ice(ji,jj-1) 
     161         ELSE                                                      ;   zcv_box(ji,jj) = pv_ice(ji,jj  ) 
     162         ENDIF 
     163      END_2D 
    167164 
    168165      !---------------! 
     
    187184            IF( .NOT. ALLOCATED(jmsk_small) )   ALLOCATE( jmsk_small(jpi,jpj,jpl) )  
    188185            DO jl = 1, jpl 
    189                DO jj = 1, jpjm1 
    190                   DO ji = 1, jpim1 
    191                      zvi_cen = 0.5_wp * ( pv_i(ji+1,jj,jl) + pv_i(ji,jj,jl) ) 
    192                      IF( zvi_cen < epsi06) THEN   ;   imsk_small(ji,jj,jl) = 0 
    193                      ELSE                         ;   imsk_small(ji,jj,jl) = 1   ;   ENDIF 
    194                      zvi_cen = 0.5_wp * ( pv_i(ji,jj+1,jl) + pv_i(ji,jj,jl) ) 
    195                      IF( zvi_cen < epsi06) THEN   ;   jmsk_small(ji,jj,jl) = 0 
    196                      ELSE                         ;   jmsk_small(ji,jj,jl) = 1   ;   ENDIF 
    197                   END DO 
    198                END DO 
     186               DO_2D_10_10 
     187                  zvi_cen = 0.5_wp * ( pv_i(ji+1,jj,jl) + pv_i(ji,jj,jl) ) 
     188                  IF( zvi_cen < epsi06) THEN   ;   imsk_small(ji,jj,jl) = 0 
     189                  ELSE                         ;   imsk_small(ji,jj,jl) = 1   ;   ENDIF 
     190                  zvi_cen = 0.5_wp * ( pv_i(ji,jj+1,jl) + pv_i(ji,jj,jl) ) 
     191                  IF( zvi_cen < epsi06) THEN   ;   jmsk_small(ji,jj,jl) = 0 
     192                  ELSE                         ;   jmsk_small(ji,jj,jl) = 1   ;   ENDIF 
     193               END_2D 
    199194            END DO 
    200195         ENDIF 
     
    338333         !== Open water area ==! 
    339334         zati2(:,:) = SUM( pa_i(:,:,:), dim=3 ) 
    340          DO jj = 2, jpjm1 
    341             DO ji = fs_2, fs_jpim1 
    342                pato_i(ji,jj) = pato_i(ji,jj) - ( zati2(ji,jj) - zati1(ji,jj) ) &  
    343                   &                          - ( zudy(ji,jj) - zudy(ji-1,jj) + zvdx(ji,jj) - zvdx(ji,jj-1) ) * r1_e1e2t(ji,jj) * zdt 
    344             END DO 
    345          END DO 
     335         DO_2D_00_00 
     336            pato_i(ji,jj) = pato_i(ji,jj) - ( zati2(ji,jj) - zati1(ji,jj) ) &  
     337               &                          - ( zudy(ji,jj) - zudy(ji-1,jj) + zvdx(ji,jj) - zvdx(ji,jj-1) ) * r1_e1e2t(ji,jj) * zdt 
     338         END_2D 
    346339         CALL lbc_lnk( 'icedyn_adv_umx', pato_i, 'T',  1. ) 
    347340         ! 
     
    449442      IF( pamsk == 0._wp ) THEN 
    450443         DO jl = 1, jpl 
    451             DO jj = 1, jpjm1 
    452                DO ji = 1, fs_jpim1 
    453                   IF( ABS( pu(ji,jj) ) > epsi10 ) THEN 
    454                      zfu_ho (ji,jj,jl) = zfu_ho (ji,jj,jl) * puc    (ji,jj,jl) / pu(ji,jj) 
    455                      zfu_ups(ji,jj,jl) = zfu_ups(ji,jj,jl) * pua_ups(ji,jj,jl) / pu(ji,jj) 
    456                   ELSE 
    457                      zfu_ho (ji,jj,jl) = 0._wp 
    458                      zfu_ups(ji,jj,jl) = 0._wp 
    459                   ENDIF 
    460                   ! 
    461                   IF( ABS( pv(ji,jj) ) > epsi10 ) THEN 
    462                      zfv_ho (ji,jj,jl) = zfv_ho (ji,jj,jl) * pvc    (ji,jj,jl) / pv(ji,jj) 
    463                      zfv_ups(ji,jj,jl) = zfv_ups(ji,jj,jl) * pva_ups(ji,jj,jl) / pv(ji,jj) 
    464                   ELSE 
    465                      zfv_ho (ji,jj,jl) = 0._wp   
    466                      zfv_ups(ji,jj,jl) = 0._wp   
    467                   ENDIF 
    468                END DO 
    469             END DO 
     444            DO_2D_10_10 
     445               IF( ABS( pu(ji,jj) ) > epsi10 ) THEN 
     446                  zfu_ho (ji,jj,jl) = zfu_ho (ji,jj,jl) * puc    (ji,jj,jl) / pu(ji,jj) 
     447                  zfu_ups(ji,jj,jl) = zfu_ups(ji,jj,jl) * pua_ups(ji,jj,jl) / pu(ji,jj) 
     448               ELSE 
     449                  zfu_ho (ji,jj,jl) = 0._wp 
     450                  zfu_ups(ji,jj,jl) = 0._wp 
     451               ENDIF 
     452               ! 
     453               IF( ABS( pv(ji,jj) ) > epsi10 ) THEN 
     454                  zfv_ho (ji,jj,jl) = zfv_ho (ji,jj,jl) * pvc    (ji,jj,jl) / pv(ji,jj) 
     455                  zfv_ups(ji,jj,jl) = zfv_ups(ji,jj,jl) * pva_ups(ji,jj,jl) / pv(ji,jj) 
     456               ELSE 
     457                  zfv_ho (ji,jj,jl) = 0._wp   
     458                  zfv_ups(ji,jj,jl) = 0._wp   
     459               ENDIF 
     460            END_2D 
    470461         END DO 
    471462 
     
    473464         ! thus we calculate the upstream solution and apply a limiter again 
    474465         DO jl = 1, jpl 
    475             DO jj = 2, jpjm1 
    476                DO ji = fs_2, fs_jpim1 
    477                   ztra = - ( zfu_ups(ji,jj,jl) - zfu_ups(ji-1,jj,jl) + zfv_ups(ji,jj,jl) - zfv_ups(ji,jj-1,jl) ) 
    478                   ! 
    479                   zt_ups(ji,jj,jl) = ( ptc(ji,jj,jl) + ztra * r1_e1e2t(ji,jj) * pdt ) * tmask(ji,jj,1) 
    480                END DO 
    481             END DO 
     466            DO_2D_00_00 
     467               ztra = - ( zfu_ups(ji,jj,jl) - zfu_ups(ji-1,jj,jl) + zfv_ups(ji,jj,jl) - zfv_ups(ji,jj-1,jl) ) 
     468               ! 
     469               zt_ups(ji,jj,jl) = ( ptc(ji,jj,jl) + ztra * r1_e1e2t(ji,jj) * pdt ) * tmask(ji,jj,1) 
     470            END_2D 
    482471         END DO 
    483472         CALL lbc_lnk( 'icedyn_adv_umx', zt_ups, 'T',  1. ) 
     
    496485      IF( PRESENT( pua_ho ) ) THEN 
    497486         DO jl = 1, jpl 
    498             DO jj = 1, jpjm1 
    499                DO ji = 1, fs_jpim1 
    500                   pua_ho (ji,jj,jl) = zfu_ho (ji,jj,jl) ; pva_ho (ji,jj,jl) = zfv_ho (ji,jj,jl) 
    501                   pua_ups(ji,jj,jl) = zfu_ups(ji,jj,jl) ; pva_ups(ji,jj,jl) = zfv_ups(ji,jj,jl) 
    502               END DO 
    503             END DO 
     487            DO_2D_10_10 
     488               pua_ho (ji,jj,jl) = zfu_ho (ji,jj,jl) ; pva_ho (ji,jj,jl) = zfv_ho (ji,jj,jl) 
     489               pua_ups(ji,jj,jl) = zfu_ups(ji,jj,jl) ; pva_ups(ji,jj,jl) = zfv_ups(ji,jj,jl) 
     490            END_2D 
    504491         END DO 
    505492      ENDIF 
     
    508495      ! --------------------------------- 
    509496      DO jl = 1, jpl 
    510          DO jj = 2, jpjm1 
    511             DO ji = fs_2, fs_jpim1  
    512                ztra = - ( zfu_ho(ji,jj,jl) - zfu_ho(ji-1,jj,jl) + zfv_ho(ji,jj,jl) - zfv_ho(ji,jj-1,jl) )   
    513                ! 
    514                ptc(ji,jj,jl) = ( ptc(ji,jj,jl) + ztra * r1_e1e2t(ji,jj) * pdt ) * tmask(ji,jj,1)                
    515             END DO 
    516          END DO 
     497         DO_2D_00_00 
     498            ztra = - ( zfu_ho(ji,jj,jl) - zfu_ho(ji-1,jj,jl) + zfv_ho(ji,jj,jl) - zfv_ho(ji,jj-1,jl) )   
     499            ! 
     500            ptc(ji,jj,jl) = ( ptc(ji,jj,jl) + ztra * r1_e1e2t(ji,jj) * pdt ) * tmask(ji,jj,1)                
     501         END_2D 
    517502      END DO 
    518503      CALL lbc_lnk( 'icedyn_adv_umx', ptc, 'T',  1. ) 
     
    544529         ! 
    545530         DO jl = 1, jpl 
    546             DO jj = 1, jpjm1 
    547                DO ji = 1, fs_jpim1 
     531            DO_2D_10_10 
     532               pfu_ups(ji,jj,jl) = MAX( pu(ji,jj), 0._wp ) * pt(ji,jj,jl) + MIN( pu(ji,jj), 0._wp ) * pt(ji+1,jj,jl) 
     533               pfv_ups(ji,jj,jl) = MAX( pv(ji,jj), 0._wp ) * pt(ji,jj,jl) + MIN( pv(ji,jj), 0._wp ) * pt(ji,jj+1,jl) 
     534            END_2D 
     535         END DO 
     536         ! 
     537      ELSE                              !** alternate directions **! 
     538         ! 
     539         IF( MOD( (kt - 1) / nn_fsbc , 2 ) ==  MOD( (jt - 1) , 2 ) ) THEN   !==  odd ice time step:  adv_x then adv_y  ==! 
     540            ! 
     541            DO jl = 1, jpl              !-- flux in x-direction 
     542               DO_2D_10_10 
    548543                  pfu_ups(ji,jj,jl) = MAX( pu(ji,jj), 0._wp ) * pt(ji,jj,jl) + MIN( pu(ji,jj), 0._wp ) * pt(ji+1,jj,jl) 
     544               END_2D 
     545            END DO 
     546            ! 
     547            DO jl = 1, jpl              !-- first guess of tracer from u-flux 
     548               DO_2D_00_00 
     549                  ztra = - ( pfu_ups(ji,jj,jl) - pfu_ups(ji-1,jj,jl) )              & 
     550                     &   + ( pu     (ji,jj   ) - pu     (ji-1,jj   ) ) * pt(ji,jj,jl) * (1.-pamsk) 
     551                  ! 
     552                  zpt(ji,jj,jl) = ( pt(ji,jj,jl) + ztra * pdt * r1_e1e2t(ji,jj) ) * tmask(ji,jj,1) 
     553               END_2D 
     554            END DO 
     555            CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1. ) 
     556            ! 
     557            DO jl = 1, jpl              !-- flux in y-direction 
     558               DO_2D_10_10 
     559                  pfv_ups(ji,jj,jl) = MAX( pv(ji,jj), 0._wp ) * zpt(ji,jj,jl) + MIN( pv(ji,jj), 0._wp ) * zpt(ji,jj+1,jl) 
     560               END_2D 
     561            END DO 
     562            ! 
     563         ELSE                                                               !==  even ice time step:  adv_y then adv_x  ==! 
     564            ! 
     565            DO jl = 1, jpl              !-- flux in y-direction 
     566               DO_2D_10_10 
    549567                  pfv_ups(ji,jj,jl) = MAX( pv(ji,jj), 0._wp ) * pt(ji,jj,jl) + MIN( pv(ji,jj), 0._wp ) * pt(ji,jj+1,jl) 
    550                END DO 
    551             END DO 
    552          END DO 
    553          ! 
    554       ELSE                              !** alternate directions **! 
    555          ! 
    556          IF( MOD( (kt - 1) / nn_fsbc , 2 ) ==  MOD( (jt - 1) , 2 ) ) THEN   !==  odd ice time step:  adv_x then adv_y  ==! 
     568               END_2D 
     569            END DO 
     570            ! 
     571            DO jl = 1, jpl              !-- first guess of tracer from v-flux 
     572               DO_2D_00_00 
     573                  ztra = - ( pfv_ups(ji,jj,jl) - pfv_ups(ji,jj-1,jl) )  & 
     574                     &   + ( pv     (ji,jj   ) - pv     (ji,jj-1   ) ) * pt(ji,jj,jl) * (1.-pamsk) 
     575                  ! 
     576                  zpt(ji,jj,jl) = ( pt(ji,jj,jl) + ztra * pdt * r1_e1e2t(ji,jj) ) * tmask(ji,jj,1) 
     577               END_2D 
     578            END DO 
     579            CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1. ) 
    557580            ! 
    558581            DO jl = 1, jpl              !-- flux in x-direction 
    559                DO jj = 1, jpjm1 
    560                   DO ji = 1, fs_jpim1 
    561                      pfu_ups(ji,jj,jl) = MAX( pu(ji,jj), 0._wp ) * pt(ji,jj,jl) + MIN( pu(ji,jj), 0._wp ) * pt(ji+1,jj,jl) 
    562                   END DO 
    563                END DO 
    564             END DO 
    565             ! 
    566             DO jl = 1, jpl              !-- first guess of tracer from u-flux 
    567                DO jj = 2, jpjm1 
    568                   DO ji = fs_2, fs_jpim1 
    569                      ztra = - ( pfu_ups(ji,jj,jl) - pfu_ups(ji-1,jj,jl) )              & 
    570                         &   + ( pu     (ji,jj   ) - pu     (ji-1,jj   ) ) * pt(ji,jj,jl) * (1.-pamsk) 
    571                      ! 
    572                      zpt(ji,jj,jl) = ( pt(ji,jj,jl) + ztra * pdt * r1_e1e2t(ji,jj) ) * tmask(ji,jj,1) 
    573                   END DO 
    574                END DO 
    575             END DO 
    576             CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1. ) 
    577             ! 
    578             DO jl = 1, jpl              !-- flux in y-direction 
    579                DO jj = 1, jpjm1 
    580                   DO ji = 1, fs_jpim1 
    581                      pfv_ups(ji,jj,jl) = MAX( pv(ji,jj), 0._wp ) * zpt(ji,jj,jl) + MIN( pv(ji,jj), 0._wp ) * zpt(ji,jj+1,jl) 
    582                   END DO 
    583                END DO 
    584             END DO 
    585             ! 
    586          ELSE                                                               !==  even ice time step:  adv_y then adv_x  ==! 
    587             ! 
    588             DO jl = 1, jpl              !-- flux in y-direction 
    589                DO jj = 1, jpjm1 
    590                   DO ji = 1, fs_jpim1 
    591                      pfv_ups(ji,jj,jl) = MAX( pv(ji,jj), 0._wp ) * pt(ji,jj,jl) + MIN( pv(ji,jj), 0._wp ) * pt(ji,jj+1,jl) 
    592                   END DO 
    593                END DO 
    594             END DO 
    595             ! 
    596             DO jl = 1, jpl              !-- first guess of tracer from v-flux 
    597                DO jj = 2, jpjm1 
    598                   DO ji = fs_2, fs_jpim1 
    599                      ztra = - ( pfv_ups(ji,jj,jl) - pfv_ups(ji,jj-1,jl) )  & 
    600                         &   + ( pv     (ji,jj   ) - pv     (ji,jj-1   ) ) * pt(ji,jj,jl) * (1.-pamsk) 
    601                      ! 
    602                      zpt(ji,jj,jl) = ( pt(ji,jj,jl) + ztra * pdt * r1_e1e2t(ji,jj) ) * tmask(ji,jj,1) 
    603                   END DO 
    604                END DO 
    605             END DO 
    606             CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1. ) 
    607             ! 
    608             DO jl = 1, jpl              !-- flux in x-direction 
    609                DO jj = 1, jpjm1 
    610                   DO ji = 1, fs_jpim1 
    611                      pfu_ups(ji,jj,jl) = MAX( pu(ji,jj), 0._wp ) * zpt(ji,jj,jl) + MIN( pu(ji,jj), 0._wp ) * zpt(ji+1,jj,jl) 
    612                   END DO 
    613                END DO 
     582               DO_2D_10_10 
     583                  pfu_ups(ji,jj,jl) = MAX( pu(ji,jj), 0._wp ) * zpt(ji,jj,jl) + MIN( pu(ji,jj), 0._wp ) * zpt(ji+1,jj,jl) 
     584               END_2D 
    614585            END DO 
    615586            ! 
     
    619590      ! 
    620591      DO jl = 1, jpl                    !-- after tracer with upstream scheme 
    621          DO jj = 2, jpjm1 
    622             DO ji = fs_2, fs_jpim1 
    623                ztra = - (   pfu_ups(ji,jj,jl) - pfu_ups(ji-1,jj  ,jl)   & 
    624                   &       + pfv_ups(ji,jj,jl) - pfv_ups(ji  ,jj-1,jl) ) & 
    625                   &   + (   pu     (ji,jj   ) - pu     (ji-1,jj     )   & 
    626                   &       + pv     (ji,jj   ) - pv     (ji  ,jj-1   ) ) * pt(ji,jj,jl) * (1.-pamsk) 
    627                ! 
    628                pt_ups(ji,jj,jl) = ( pt(ji,jj,jl) + ztra * pdt * r1_e1e2t(ji,jj) ) * tmask(ji,jj,1) 
    629             END DO 
    630          END DO 
     592         DO_2D_00_00 
     593            ztra = - (   pfu_ups(ji,jj,jl) - pfu_ups(ji-1,jj  ,jl)   & 
     594               &       + pfv_ups(ji,jj,jl) - pfv_ups(ji  ,jj-1,jl) ) & 
     595               &   + (   pu     (ji,jj   ) - pu     (ji-1,jj     )   & 
     596               &       + pv     (ji,jj   ) - pv     (ji  ,jj-1   ) ) * pt(ji,jj,jl) * (1.-pamsk) 
     597            ! 
     598            pt_ups(ji,jj,jl) = ( pt(ji,jj,jl) + ztra * pdt * r1_e1e2t(ji,jj) ) * tmask(ji,jj,1) 
     599         END_2D 
    631600      END DO 
    632601      CALL lbc_lnk( 'icedyn_adv_umx', pt_ups, 'T', 1. ) 
     
    660629         ! 
    661630         DO jl = 1, jpl 
    662             DO jj = 1, jpjm1 
    663                DO ji = 1, fs_jpim1 
    664                   pfu_ho(ji,jj,jl) = 0.5_wp * pu(ji,jj) * ( pt(ji,jj,jl) + pt(ji+1,jj  ,jl) ) 
    665                   pfv_ho(ji,jj,jl) = 0.5_wp * pv(ji,jj) * ( pt(ji,jj,jl) + pt(ji  ,jj+1,jl) ) 
    666                END DO 
    667             END DO 
     631            DO_2D_10_10 
     632               pfu_ho(ji,jj,jl) = 0.5_wp * pu(ji,jj) * ( pt(ji,jj,jl) + pt(ji+1,jj  ,jl) ) 
     633               pfv_ho(ji,jj,jl) = 0.5_wp * pv(ji,jj) * ( pt(ji,jj,jl) + pt(ji  ,jj+1,jl) ) 
     634            END_2D 
    668635         END DO 
    669636         ! 
     
    680647            ! 
    681648            DO jl = 1, jpl              !-- flux in x-direction 
    682                DO jj = 1, jpjm1 
    683                   DO ji = 1, fs_jpim1 
    684                      pfu_ho(ji,jj,jl) = 0.5_wp * pu(ji,jj) * ( pt(ji,jj,jl) + pt(ji+1,jj,jl) ) 
    685                   END DO 
    686                END DO 
     649               DO_2D_10_10 
     650                  pfu_ho(ji,jj,jl) = 0.5_wp * pu(ji,jj) * ( pt(ji,jj,jl) + pt(ji+1,jj,jl) ) 
     651               END_2D 
    687652            END DO 
    688653            IF( np_limiter == 2 .OR. np_limiter == 3 )   CALL limiter_x( pdt, pu, pt, pfu_ups, pfu_ho ) 
    689654 
    690655            DO jl = 1, jpl              !-- first guess of tracer from u-flux 
    691                DO jj = 2, jpjm1 
    692                   DO ji = fs_2, fs_jpim1 
    693                      ztra = - ( pfu_ho(ji,jj,jl) - pfu_ho(ji-1,jj,jl) )              & 
    694                         &   + ( pu    (ji,jj   ) - pu    (ji-1,jj   ) ) * pt(ji,jj,jl) * (1.-pamsk) 
    695                      ! 
    696                      zpt(ji,jj,jl) = ( pt(ji,jj,jl) + ztra * pdt * r1_e1e2t(ji,jj) ) * tmask(ji,jj,1) 
    697                   END DO 
    698                END DO 
     656               DO_2D_00_00 
     657                  ztra = - ( pfu_ho(ji,jj,jl) - pfu_ho(ji-1,jj,jl) )              & 
     658                     &   + ( pu    (ji,jj   ) - pu    (ji-1,jj   ) ) * pt(ji,jj,jl) * (1.-pamsk) 
     659                  ! 
     660                  zpt(ji,jj,jl) = ( pt(ji,jj,jl) + ztra * pdt * r1_e1e2t(ji,jj) ) * tmask(ji,jj,1) 
     661               END_2D 
    699662            END DO 
    700663            CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1. ) 
    701664 
    702665            DO jl = 1, jpl              !-- flux in y-direction 
    703                DO jj = 1, jpjm1 
    704                   DO ji = 1, fs_jpim1 
    705                      pfv_ho(ji,jj,jl) = 0.5_wp * pv(ji,jj) * ( zpt(ji,jj,jl) + zpt(ji,jj+1,jl) ) 
    706                   END DO 
    707                END DO 
     666               DO_2D_10_10 
     667                  pfv_ho(ji,jj,jl) = 0.5_wp * pv(ji,jj) * ( zpt(ji,jj,jl) + zpt(ji,jj+1,jl) ) 
     668               END_2D 
    708669            END DO 
    709670            IF( np_limiter == 2 .OR. np_limiter == 3 )   CALL limiter_y( pdt, pv, pt, pfv_ups, pfv_ho ) 
     
    712673            ! 
    713674            DO jl = 1, jpl              !-- flux in y-direction 
    714                DO jj = 1, jpjm1 
    715                   DO ji = 1, fs_jpim1 
    716                      pfv_ho(ji,jj,jl) = 0.5_wp * pv(ji,jj) * ( pt(ji,jj,jl) + pt(ji,jj+1,jl) ) 
    717                   END DO 
    718                END DO 
     675               DO_2D_10_10 
     676                  pfv_ho(ji,jj,jl) = 0.5_wp * pv(ji,jj) * ( pt(ji,jj,jl) + pt(ji,jj+1,jl) ) 
     677               END_2D 
    719678            END DO 
    720679            IF( np_limiter == 2 .OR. np_limiter == 3 )   CALL limiter_y( pdt, pv, pt, pfv_ups, pfv_ho ) 
    721680            ! 
    722681            DO jl = 1, jpl              !-- first guess of tracer from v-flux 
    723                DO jj = 2, jpjm1 
    724                   DO ji = fs_2, fs_jpim1 
    725                      ztra = - ( pfv_ho(ji,jj,jl) - pfv_ho(ji,jj-1,jl) )  & 
    726                         &   + ( pv    (ji,jj   ) - pv    (ji,jj-1   ) ) * pt(ji,jj,jl) * (1.-pamsk) 
    727                      ! 
    728                      zpt(ji,jj,jl) = ( pt(ji,jj,jl) + ztra * pdt * r1_e1e2t(ji,jj) ) * tmask(ji,jj,1) 
    729                   END DO 
    730                END DO 
     682               DO_2D_00_00 
     683                  ztra = - ( pfv_ho(ji,jj,jl) - pfv_ho(ji,jj-1,jl) )  & 
     684                     &   + ( pv    (ji,jj   ) - pv    (ji,jj-1   ) ) * pt(ji,jj,jl) * (1.-pamsk) 
     685                  ! 
     686                  zpt(ji,jj,jl) = ( pt(ji,jj,jl) + ztra * pdt * r1_e1e2t(ji,jj) ) * tmask(ji,jj,1) 
     687               END_2D 
    731688            END DO 
    732689            CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1. ) 
    733690            ! 
    734691            DO jl = 1, jpl              !-- flux in x-direction 
    735                DO jj = 1, jpjm1 
    736                   DO ji = 1, fs_jpim1 
    737                      pfu_ho(ji,jj,jl) = 0.5_wp * pu(ji,jj) * ( zpt(ji,jj,jl) + zpt(ji+1,jj,jl) ) 
    738                   END DO 
    739                END DO 
     692               DO_2D_10_10 
     693                  pfu_ho(ji,jj,jl) = 0.5_wp * pu(ji,jj) * ( zpt(ji,jj,jl) + zpt(ji+1,jj,jl) ) 
     694               END_2D 
    740695            END DO 
    741696            IF( np_limiter == 2 .OR. np_limiter == 3 )   CALL limiter_x( pdt, pu, pt, pfu_ups, pfu_ho ) 
     
    783738         !                                                        !--  advective form update in zpt  --! 
    784739         DO jl = 1, jpl 
    785             DO jj = 2, jpjm1 
    786                DO ji = fs_2, fs_jpim1 
    787                   zpt(ji,jj,jl) = ( pt(ji,jj,jl) - (  pubox(ji,jj   ) * ( zt_u(ji,jj,jl) - zt_u(ji-1,jj,jl) ) * r1_e1t  (ji,jj) & 
    788                      &                              + pt   (ji,jj,jl) * ( pu  (ji,jj   ) - pu  (ji-1,jj   ) ) * r1_e1e2t(ji,jj) & 
    789                      &                                                                                        * pamsk           & 
    790                      &                             ) * pdt ) * tmask(ji,jj,1) 
    791                END DO 
    792             END DO 
     740            DO_2D_00_00 
     741               zpt(ji,jj,jl) = ( pt(ji,jj,jl) - (  pubox(ji,jj   ) * ( zt_u(ji,jj,jl) - zt_u(ji-1,jj,jl) ) * r1_e1t  (ji,jj) & 
     742                  &                              + pt   (ji,jj,jl) * ( pu  (ji,jj   ) - pu  (ji-1,jj   ) ) * r1_e1e2t(ji,jj) & 
     743                  &                                                                                        * pamsk           & 
     744                  &                             ) * pdt ) * tmask(ji,jj,1) 
     745            END_2D 
    793746         END DO 
    794747         CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1. ) 
     
    812765         !                                                        !--  advective form update in zpt  --! 
    813766         DO jl = 1, jpl 
    814             DO jj = 2, jpjm1 
    815                DO ji = fs_2, fs_jpim1 
    816                   zpt(ji,jj,jl) = ( pt(ji,jj,jl) - (  pvbox(ji,jj   ) * ( zt_v(ji,jj,jl) - zt_v(ji,jj-1,jl) ) * r1_e2t  (ji,jj) & 
    817                      &                              + pt   (ji,jj,jl) * ( pv  (ji,jj   ) - pv  (ji,jj-1   ) ) * r1_e1e2t(ji,jj) & 
    818                      &                                                                                        * pamsk           & 
    819                      &                             ) * pdt ) * tmask(ji,jj,1)  
    820                END DO 
    821             END DO 
     767            DO_2D_00_00 
     768               zpt(ji,jj,jl) = ( pt(ji,jj,jl) - (  pvbox(ji,jj   ) * ( zt_v(ji,jj,jl) - zt_v(ji,jj-1,jl) ) * r1_e2t  (ji,jj) & 
     769                  &                              + pt   (ji,jj,jl) * ( pv  (ji,jj   ) - pv  (ji,jj-1   ) ) * r1_e1e2t(ji,jj) & 
     770                  &                                                                                        * pamsk           & 
     771                  &                             ) * pdt ) * tmask(ji,jj,1)  
     772            END_2D 
    822773         END DO 
    823774         CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1. ) 
     
    896847         !         
    897848         DO jl = 1, jpl 
    898             DO jj = 1, jpjm1 
    899                DO ji = 1, fs_jpim1   ! vector opt. 
    900                   pt_u(ji,jj,jl) = 0.5_wp * umask(ji,jj,1) * (                                pt(ji+1,jj,jl) + pt(ji,jj,jl)   & 
    901                      &                                         - SIGN( 1._wp, pu(ji,jj) ) * ( pt(ji+1,jj,jl) - pt(ji,jj,jl) ) ) 
    902                END DO 
    903             END DO 
     849            DO_2D_10_10 
     850               pt_u(ji,jj,jl) = 0.5_wp * umask(ji,jj,1) * (                                pt(ji+1,jj,jl) + pt(ji,jj,jl)   & 
     851                  &                                         - SIGN( 1._wp, pu(ji,jj) ) * ( pt(ji+1,jj,jl) - pt(ji,jj,jl) ) ) 
     852            END_2D 
    904853         END DO 
    905854         ! 
     
    907856         ! 
    908857         DO jl = 1, jpl 
    909             DO jj = 1, jpjm1 
    910                DO ji = 1, fs_jpim1   ! vector opt. 
    911                   zcu  = pu(ji,jj) * r1_e2u(ji,jj) * pdt * r1_e1u(ji,jj) 
    912                   pt_u(ji,jj,jl) = 0.5_wp * umask(ji,jj,1) * (                                pt(ji+1,jj,jl) + pt(ji,jj,jl)   & 
    913                      &                                                            - zcu   * ( pt(ji+1,jj,jl) - pt(ji,jj,jl) ) )  
    914                END DO 
    915             END DO 
     858            DO_2D_10_10 
     859               zcu  = pu(ji,jj) * r1_e2u(ji,jj) * pdt * r1_e1u(ji,jj) 
     860               pt_u(ji,jj,jl) = 0.5_wp * umask(ji,jj,1) * (                                pt(ji+1,jj,jl) + pt(ji,jj,jl)   & 
     861                  &                                                            - zcu   * ( pt(ji+1,jj,jl) - pt(ji,jj,jl) ) )  
     862            END_2D 
    916863         END DO 
    917864         !   
     
    919866         ! 
    920867         DO jl = 1, jpl 
    921             DO jj = 1, jpjm1 
    922                DO ji = 1, fs_jpim1   ! vector opt. 
    923                   zcu  = pu(ji,jj) * r1_e2u(ji,jj) * pdt * r1_e1u(ji,jj) 
    924                   zdx2 = e1u(ji,jj) * e1u(ji,jj) 
     868            DO_2D_10_10 
     869               zcu  = pu(ji,jj) * r1_e2u(ji,jj) * pdt * r1_e1u(ji,jj) 
     870               zdx2 = e1u(ji,jj) * e1u(ji,jj) 
    925871!!rachid          zdx2 = e1u(ji,jj) * e1t(ji,jj) 
    926                   pt_u(ji,jj,jl) = 0.5_wp * umask(ji,jj,1) * (         (                      pt  (ji+1,jj,jl) + pt  (ji,jj,jl)     & 
    927                      &                                                            - zcu   * ( pt  (ji+1,jj,jl) - pt  (ji,jj,jl) ) ) & 
    928                      &        + z1_6 * zdx2 * ( zcu*zcu - 1._wp ) *    (                      ztu2(ji+1,jj,jl) + ztu2(ji,jj,jl)     & 
    929                      &                                               - SIGN( 1._wp, zcu ) * ( ztu2(ji+1,jj,jl) - ztu2(ji,jj,jl) ) ) ) 
    930                END DO 
    931             END DO 
     872               pt_u(ji,jj,jl) = 0.5_wp * umask(ji,jj,1) * (         (                      pt  (ji+1,jj,jl) + pt  (ji,jj,jl)     & 
     873                  &                                                            - zcu   * ( pt  (ji+1,jj,jl) - pt  (ji,jj,jl) ) ) & 
     874                  &        + z1_6 * zdx2 * ( zcu*zcu - 1._wp ) *    (                      ztu2(ji+1,jj,jl) + ztu2(ji,jj,jl)     & 
     875                  &                                               - SIGN( 1._wp, zcu ) * ( ztu2(ji+1,jj,jl) - ztu2(ji,jj,jl) ) ) ) 
     876            END_2D 
    932877         END DO 
    933878         ! 
     
    935880         ! 
    936881         DO jl = 1, jpl 
    937             DO jj = 1, jpjm1 
    938                DO ji = 1, fs_jpim1   ! vector opt. 
    939                   zcu  = pu(ji,jj) * r1_e2u(ji,jj) * pdt * r1_e1u(ji,jj) 
    940                   zdx2 = e1u(ji,jj) * e1u(ji,jj) 
     882            DO_2D_10_10 
     883               zcu  = pu(ji,jj) * r1_e2u(ji,jj) * pdt * r1_e1u(ji,jj) 
     884               zdx2 = e1u(ji,jj) * e1u(ji,jj) 
    941885!!rachid          zdx2 = e1u(ji,jj) * e1t(ji,jj) 
    942                   pt_u(ji,jj,jl) = 0.5_wp * umask(ji,jj,1) * (         (                      pt  (ji+1,jj,jl) + pt  (ji,jj,jl)     & 
    943                      &                                                            - zcu   * ( pt  (ji+1,jj,jl) - pt  (ji,jj,jl) ) ) & 
    944                      &        + z1_6 * zdx2 * ( zcu*zcu - 1._wp ) *    (                      ztu2(ji+1,jj,jl) + ztu2(ji,jj,jl)     & 
    945                      &                                                   - 0.5_wp * zcu   * ( ztu2(ji+1,jj,jl) - ztu2(ji,jj,jl) ) ) ) 
    946                END DO 
    947             END DO 
     886               pt_u(ji,jj,jl) = 0.5_wp * umask(ji,jj,1) * (         (                      pt  (ji+1,jj,jl) + pt  (ji,jj,jl)     & 
     887                  &                                                            - zcu   * ( pt  (ji+1,jj,jl) - pt  (ji,jj,jl) ) ) & 
     888                  &        + z1_6 * zdx2 * ( zcu*zcu - 1._wp ) *    (                      ztu2(ji+1,jj,jl) + ztu2(ji,jj,jl)     & 
     889                  &                                                   - 0.5_wp * zcu   * ( ztu2(ji+1,jj,jl) - ztu2(ji,jj,jl) ) ) ) 
     890            END_2D 
    948891         END DO 
    949892         ! 
     
    951894         ! 
    952895         DO jl = 1, jpl 
    953             DO jj = 1, jpjm1 
    954                DO ji = 1, fs_jpim1   ! vector opt. 
    955                   zcu  = pu(ji,jj) * r1_e2u(ji,jj) * pdt * r1_e1u(ji,jj) 
    956                   zdx2 = e1u(ji,jj) * e1u(ji,jj) 
     896            DO_2D_10_10 
     897               zcu  = pu(ji,jj) * r1_e2u(ji,jj) * pdt * r1_e1u(ji,jj) 
     898               zdx2 = e1u(ji,jj) * e1u(ji,jj) 
    957899!!rachid          zdx2 = e1u(ji,jj) * e1t(ji,jj) 
    958                   zdx4 = zdx2 * zdx2 
    959                   pt_u(ji,jj,jl) = 0.5_wp * umask(ji,jj,1) * (        (                       pt  (ji+1,jj,jl) + pt  (ji,jj,jl)     & 
    960                      &                                                            - zcu   * ( pt  (ji+1,jj,jl) - pt  (ji,jj,jl) ) ) & 
    961                      &        + z1_6   * zdx2 * ( zcu*zcu - 1._wp ) * (                       ztu2(ji+1,jj,jl) + ztu2(ji,jj,jl)     & 
    962                      &                                                   - 0.5_wp * zcu   * ( ztu2(ji+1,jj,jl) - ztu2(ji,jj,jl) ) ) & 
    963                      &        + z1_120 * zdx4 * ( zcu*zcu - 1._wp ) * ( zcu*zcu - 4._wp ) * ( ztu4(ji+1,jj,jl) + ztu4(ji,jj,jl)     & 
    964                      &                                               - SIGN( 1._wp, zcu ) * ( ztu4(ji+1,jj,jl) - ztu4(ji,jj,jl) ) ) ) 
    965                END DO 
    966             END DO 
     900               zdx4 = zdx2 * zdx2 
     901               pt_u(ji,jj,jl) = 0.5_wp * umask(ji,jj,1) * (        (                       pt  (ji+1,jj,jl) + pt  (ji,jj,jl)     & 
     902                  &                                                            - zcu   * ( pt  (ji+1,jj,jl) - pt  (ji,jj,jl) ) ) & 
     903                  &        + z1_6   * zdx2 * ( zcu*zcu - 1._wp ) * (                       ztu2(ji+1,jj,jl) + ztu2(ji,jj,jl)     & 
     904                  &                                                   - 0.5_wp * zcu   * ( ztu2(ji+1,jj,jl) - ztu2(ji,jj,jl) ) ) & 
     905                  &        + z1_120 * zdx4 * ( zcu*zcu - 1._wp ) * ( zcu*zcu - 4._wp ) * ( ztu4(ji+1,jj,jl) + ztu4(ji,jj,jl)     & 
     906                  &                                               - SIGN( 1._wp, zcu ) * ( ztu4(ji+1,jj,jl) - ztu4(ji,jj,jl) ) ) ) 
     907            END_2D 
    967908         END DO 
    968909         ! 
     
    974915      IF( ll_neg ) THEN 
    975916         DO jl = 1, jpl 
    976             DO jj = 1, jpjm1 
    977                DO ji = 1, fs_jpim1 
    978                   IF( pt_u(ji,jj,jl) < 0._wp .OR. ( imsk_small(ji,jj,jl) == 0 .AND. pamsk == 0. ) ) THEN 
    979                      pt_u(ji,jj,jl) = 0.5_wp * umask(ji,jj,1) * (                                pt(ji+1,jj,jl) + pt(ji,jj,jl)   & 
    980                         &                                         - SIGN( 1._wp, pu(ji,jj) ) * ( pt(ji+1,jj,jl) - pt(ji,jj,jl) ) ) 
    981                   ENDIF 
    982                END DO 
    983             END DO 
     917            DO_2D_10_10 
     918               IF( pt_u(ji,jj,jl) < 0._wp .OR. ( imsk_small(ji,jj,jl) == 0 .AND. pamsk == 0. ) ) THEN 
     919                  pt_u(ji,jj,jl) = 0.5_wp * umask(ji,jj,1) * (                                pt(ji+1,jj,jl) + pt(ji,jj,jl)   & 
     920                     &                                         - SIGN( 1._wp, pu(ji,jj) ) * ( pt(ji+1,jj,jl) - pt(ji,jj,jl) ) ) 
     921               ENDIF 
     922            END_2D 
    984923         END DO 
    985924      ENDIF 
    986925      !                                                     !-- High order flux in i-direction  --! 
    987926      DO jl = 1, jpl 
    988          DO jj = 1, jpjm1 
    989             DO ji = 1, fs_jpim1   ! vector opt. 
    990                pfu_ho(ji,jj,jl) = pu(ji,jj) * pt_u(ji,jj,jl) 
    991             END DO 
    992          END DO 
     927         DO_2D_10_10 
     928            pfu_ho(ji,jj,jl) = pu(ji,jj) * pt_u(ji,jj,jl) 
     929         END_2D 
    993930      END DO 
    994931      ! 
     
    1021958      !                                                     !--  Laplacian in j-direction  --! 
    1022959      DO jl = 1, jpl 
    1023          DO jj = 1, jpjm1         ! First derivative (gradient) 
    1024             DO ji = fs_2, fs_jpim1 
    1025                ztv1(ji,jj,jl) = ( pt(ji,jj+1,jl) - pt(ji,jj,jl) ) * r1_e2v(ji,jj) * vmask(ji,jj,1) 
    1026             END DO 
    1027          END DO 
    1028          DO jj = 2, jpjm1         ! Second derivative (Laplacian) 
    1029             DO ji = fs_2, fs_jpim1 
    1030                ztv2(ji,jj,jl) = ( ztv1(ji,jj,jl) - ztv1(ji,jj-1,jl) ) * r1_e2t(ji,jj) 
    1031             END DO 
    1032          END DO 
     960         DO_2D_10_00 
     961            ztv1(ji,jj,jl) = ( pt(ji,jj+1,jl) - pt(ji,jj,jl) ) * r1_e2v(ji,jj) * vmask(ji,jj,1) 
     962         END_2D 
     963         DO_2D_00_00 
     964            ztv2(ji,jj,jl) = ( ztv1(ji,jj,jl) - ztv1(ji,jj-1,jl) ) * r1_e2t(ji,jj) 
     965         END_2D 
    1033966      END DO 
    1034967      CALL lbc_lnk( 'icedyn_adv_umx', ztv2, 'T', 1. ) 
     
    1036969      !                                                     !--  BiLaplacian in j-direction  --! 
    1037970      DO jl = 1, jpl 
    1038          DO jj = 1, jpjm1         ! First derivative 
    1039             DO ji = fs_2, fs_jpim1 
    1040                ztv3(ji,jj,jl) = ( ztv2(ji,jj+1,jl) - ztv2(ji,jj,jl) ) * r1_e2v(ji,jj) * vmask(ji,jj,1) 
    1041             END DO 
    1042          END DO 
    1043          DO jj = 2, jpjm1         ! Second derivative 
    1044             DO ji = fs_2, fs_jpim1 
    1045                ztv4(ji,jj,jl) = ( ztv3(ji,jj,jl) - ztv3(ji,jj-1,jl) ) * r1_e2t(ji,jj) 
    1046             END DO 
    1047          END DO 
     971         DO_2D_10_00 
     972            ztv3(ji,jj,jl) = ( ztv2(ji,jj+1,jl) - ztv2(ji,jj,jl) ) * r1_e2v(ji,jj) * vmask(ji,jj,1) 
     973         END_2D 
     974         DO_2D_00_00 
     975            ztv4(ji,jj,jl) = ( ztv3(ji,jj,jl) - ztv3(ji,jj-1,jl) ) * r1_e2t(ji,jj) 
     976         END_2D 
    1048977      END DO 
    1049978      CALL lbc_lnk( 'icedyn_adv_umx', ztv4, 'T', 1. ) 
     
    1054983      CASE( 1 )                                                !==  1st order central TIM  ==! (Eq. 21) 
    1055984         DO jl = 1, jpl 
    1056             DO jj = 1, jpjm1 
    1057                DO ji = 1, fs_jpim1 
    1058                   pt_v(ji,jj,jl) = 0.5_wp * vmask(ji,jj,1) * (                                pt(ji,jj+1,jl) + pt(ji,jj,jl)   & 
    1059                      &                                         - SIGN( 1._wp, pv(ji,jj) ) * ( pt(ji,jj+1,jl) - pt(ji,jj,jl) ) ) 
    1060                END DO 
    1061             END DO 
     985            DO_2D_10_10 
     986               pt_v(ji,jj,jl) = 0.5_wp * vmask(ji,jj,1) * (                                pt(ji,jj+1,jl) + pt(ji,jj,jl)   & 
     987                  &                                         - SIGN( 1._wp, pv(ji,jj) ) * ( pt(ji,jj+1,jl) - pt(ji,jj,jl) ) ) 
     988            END_2D 
    1062989         END DO 
    1063990         ! 
    1064991      CASE( 2 )                                                !==  2nd order central TIM  ==! (Eq. 23) 
    1065992         DO jl = 1, jpl 
    1066             DO jj = 1, jpjm1 
    1067                DO ji = 1, fs_jpim1 
    1068                   zcv  = pv(ji,jj) * r1_e1v(ji,jj) * pdt * r1_e2v(ji,jj) 
    1069                   pt_v(ji,jj,jl) = 0.5_wp * vmask(ji,jj,1) * (                                pt(ji,jj+1,jl) + pt(ji,jj,jl)   & 
    1070                      &                                                            - zcv *   ( pt(ji,jj+1,jl) - pt(ji,jj,jl) ) ) 
    1071                END DO 
    1072             END DO 
     993            DO_2D_10_10 
     994               zcv  = pv(ji,jj) * r1_e1v(ji,jj) * pdt * r1_e2v(ji,jj) 
     995               pt_v(ji,jj,jl) = 0.5_wp * vmask(ji,jj,1) * (                                pt(ji,jj+1,jl) + pt(ji,jj,jl)   & 
     996                  &                                                            - zcv *   ( pt(ji,jj+1,jl) - pt(ji,jj,jl) ) ) 
     997            END_2D 
    1073998         END DO 
    1074999         ! 
    10751000      CASE( 3 )                                                !==  3rd order central TIM  ==! (Eq. 24) 
    10761001         DO jl = 1, jpl 
    1077             DO jj = 1, jpjm1 
    1078                DO ji = 1, fs_jpim1 
    1079                   zcv  = pv(ji,jj) * r1_e1v(ji,jj) * pdt * r1_e2v(ji,jj) 
    1080                   zdy2 = e2v(ji,jj) * e2v(ji,jj) 
     1002            DO_2D_10_10 
     1003               zcv  = pv(ji,jj) * r1_e1v(ji,jj) * pdt * r1_e2v(ji,jj) 
     1004               zdy2 = e2v(ji,jj) * e2v(ji,jj) 
    10811005!!rachid          zdy2 = e2v(ji,jj) * e2t(ji,jj) 
    1082                   pt_v(ji,jj,jl) = 0.5_wp * vmask(ji,jj,1) * (      (                         pt  (ji,jj+1,jl) + pt  (ji,jj,jl)     & 
    1083                      &                                                            - zcv   * ( pt  (ji,jj+1,jl) - pt  (ji,jj,jl) ) ) & 
    1084                      &        + z1_6 * zdy2 * ( zcv*zcv - 1._wp ) * (                         ztv2(ji,jj+1,jl) + ztv2(ji,jj,jl)     & 
    1085                      &                                               - SIGN( 1._wp, zcv ) * ( ztv2(ji,jj+1,jl) - ztv2(ji,jj,jl) ) ) ) 
    1086                END DO 
    1087             END DO 
     1006               pt_v(ji,jj,jl) = 0.5_wp * vmask(ji,jj,1) * (      (                         pt  (ji,jj+1,jl) + pt  (ji,jj,jl)     & 
     1007                  &                                                            - zcv   * ( pt  (ji,jj+1,jl) - pt  (ji,jj,jl) ) ) & 
     1008                  &        + z1_6 * zdy2 * ( zcv*zcv - 1._wp ) * (                         ztv2(ji,jj+1,jl) + ztv2(ji,jj,jl)     & 
     1009                  &                                               - SIGN( 1._wp, zcv ) * ( ztv2(ji,jj+1,jl) - ztv2(ji,jj,jl) ) ) ) 
     1010            END_2D 
    10881011         END DO 
    10891012         ! 
    10901013      CASE( 4 )                                                !==  4th order central TIM  ==! (Eq. 27) 
    10911014         DO jl = 1, jpl 
    1092             DO jj = 1, jpjm1 
    1093                DO ji = 1, fs_jpim1 
    1094                   zcv  = pv(ji,jj) * r1_e1v(ji,jj) * pdt * r1_e2v(ji,jj) 
    1095                   zdy2 = e2v(ji,jj) * e2v(ji,jj) 
     1015            DO_2D_10_10 
     1016               zcv  = pv(ji,jj) * r1_e1v(ji,jj) * pdt * r1_e2v(ji,jj) 
     1017               zdy2 = e2v(ji,jj) * e2v(ji,jj) 
    10961018!!rachid          zdy2 = e2v(ji,jj) * e2t(ji,jj) 
    1097                   pt_v(ji,jj,jl) = 0.5_wp * vmask(ji,jj,1) * (      (                         pt  (ji,jj+1,jl) + pt  (ji,jj,jl)     & 
    1098                      &                                                            - zcv   * ( pt  (ji,jj+1,jl) - pt  (ji,jj,jl) ) ) & 
    1099                      &        + z1_6 * zdy2 * ( zcv*zcv - 1._wp ) * (                         ztv2(ji,jj+1,jl) + ztv2(ji,jj,jl)     & 
    1100                      &                                                   - 0.5_wp * zcv   * ( ztv2(ji,jj+1,jl) - ztv2(ji,jj,jl) ) ) ) 
    1101                END DO 
    1102             END DO 
     1019               pt_v(ji,jj,jl) = 0.5_wp * vmask(ji,jj,1) * (      (                         pt  (ji,jj+1,jl) + pt  (ji,jj,jl)     & 
     1020                  &                                                            - zcv   * ( pt  (ji,jj+1,jl) - pt  (ji,jj,jl) ) ) & 
     1021                  &        + z1_6 * zdy2 * ( zcv*zcv - 1._wp ) * (                         ztv2(ji,jj+1,jl) + ztv2(ji,jj,jl)     & 
     1022                  &                                                   - 0.5_wp * zcv   * ( ztv2(ji,jj+1,jl) - ztv2(ji,jj,jl) ) ) ) 
     1023            END_2D 
    11031024         END DO 
    11041025         ! 
    11051026      CASE( 5 )                                                !==  5th order central TIM  ==! (Eq. 29) 
    11061027         DO jl = 1, jpl 
    1107             DO jj = 1, jpjm1 
    1108                DO ji = 1, fs_jpim1 
    1109                   zcv  = pv(ji,jj) * r1_e1v(ji,jj) * pdt * r1_e2v(ji,jj) 
    1110                   zdy2 = e2v(ji,jj) * e2v(ji,jj) 
     1028            DO_2D_10_10 
     1029               zcv  = pv(ji,jj) * r1_e1v(ji,jj) * pdt * r1_e2v(ji,jj) 
     1030               zdy2 = e2v(ji,jj) * e2v(ji,jj) 
    11111031!!rachid          zdy2 = e2v(ji,jj) * e2t(ji,jj) 
    1112                   zdy4 = zdy2 * zdy2 
    1113                   pt_v(ji,jj,jl) = 0.5_wp * vmask(ji,jj,1) * (                              ( pt  (ji,jj+1,jl) + pt  (ji,jj,jl)     & 
    1114                      &                                                            - zcv   * ( pt  (ji,jj+1,jl) - pt  (ji,jj,jl) ) ) & 
    1115                      &        + z1_6   * zdy2 * ( zcv*zcv - 1._wp ) * (                       ztv2(ji,jj+1,jl) + ztv2(ji,jj,jl)     & 
    1116                      &                                                   - 0.5_wp * zcv   * ( ztv2(ji,jj+1,jl) - ztv2(ji,jj,jl) ) ) & 
    1117                      &        + z1_120 * zdy4 * ( zcv*zcv - 1._wp ) * ( zcv*zcv - 4._wp ) * ( ztv4(ji,jj+1,jl) + ztv4(ji,jj,jl)     & 
    1118                      &                                               - SIGN( 1._wp, zcv ) * ( ztv4(ji,jj+1,jl) - ztv4(ji,jj,jl) ) ) ) 
    1119                END DO 
    1120             END DO 
     1032               zdy4 = zdy2 * zdy2 
     1033               pt_v(ji,jj,jl) = 0.5_wp * vmask(ji,jj,1) * (                              ( pt  (ji,jj+1,jl) + pt  (ji,jj,jl)     & 
     1034                  &                                                            - zcv   * ( pt  (ji,jj+1,jl) - pt  (ji,jj,jl) ) ) & 
     1035                  &        + z1_6   * zdy2 * ( zcv*zcv - 1._wp ) * (                       ztv2(ji,jj+1,jl) + ztv2(ji,jj,jl)     & 
     1036                  &                                                   - 0.5_wp * zcv   * ( ztv2(ji,jj+1,jl) - ztv2(ji,jj,jl) ) ) & 
     1037                  &        + z1_120 * zdy4 * ( zcv*zcv - 1._wp ) * ( zcv*zcv - 4._wp ) * ( ztv4(ji,jj+1,jl) + ztv4(ji,jj,jl)     & 
     1038                  &                                               - SIGN( 1._wp, zcv ) * ( ztv4(ji,jj+1,jl) - ztv4(ji,jj,jl) ) ) ) 
     1039            END_2D 
    11211040         END DO 
    11221041         ! 
     
    11281047      IF( ll_neg ) THEN 
    11291048         DO jl = 1, jpl 
    1130             DO jj = 1, jpjm1 
    1131                DO ji = 1, fs_jpim1 
    1132                   IF( pt_v(ji,jj,jl) < 0._wp .OR. ( jmsk_small(ji,jj,jl) == 0 .AND. pamsk == 0. ) ) THEN 
    1133                      pt_v(ji,jj,jl) = 0.5_wp * vmask(ji,jj,1) * (                              ( pt(ji,jj+1,jl) + pt(ji,jj,jl) )  & 
    1134                         &                                         - SIGN( 1._wp, pv(ji,jj) ) * ( pt(ji,jj+1,jl) - pt(ji,jj,jl) ) ) 
    1135                   ENDIF 
    1136                END DO 
    1137             END DO 
     1049            DO_2D_10_10 
     1050               IF( pt_v(ji,jj,jl) < 0._wp .OR. ( jmsk_small(ji,jj,jl) == 0 .AND. pamsk == 0. ) ) THEN 
     1051                  pt_v(ji,jj,jl) = 0.5_wp * vmask(ji,jj,1) * (                              ( pt(ji,jj+1,jl) + pt(ji,jj,jl) )  & 
     1052                     &                                         - SIGN( 1._wp, pv(ji,jj) ) * ( pt(ji,jj+1,jl) - pt(ji,jj,jl) ) ) 
     1053               ENDIF 
     1054            END_2D 
    11381055         END DO 
    11391056      ENDIF 
    11401057      !                                                     !-- High order flux in j-direction  --! 
    11411058      DO jl = 1, jpl 
    1142          DO jj = 1, jpjm1 
    1143             DO ji = 1, fs_jpim1   ! vector opt. 
    1144                pfv_ho(ji,jj,jl) = pv(ji,jj) * pt_v(ji,jj,jl) 
    1145             END DO 
    1146          END DO 
     1059         DO_2D_10_10 
     1060            pfv_ho(ji,jj,jl) = pv(ji,jj) * pt_v(ji,jj,jl) 
     1061         END_2D 
    11471062      END DO 
    11481063      ! 
     
    11781093      ! -------------------------------------------------- 
    11791094      DO jl = 1, jpl 
    1180          DO jj = 1, jpjm1 
    1181             DO ji = 1, fs_jpim1   ! vector opt. 
    1182                pfu_ho(ji,jj,jl) = pfu_ho(ji,jj,jl) - pfu_ups(ji,jj,jl) 
    1183                pfv_ho(ji,jj,jl) = pfv_ho(ji,jj,jl) - pfv_ups(ji,jj,jl) 
    1184             END DO 
    1185          END DO 
     1095         DO_2D_10_10 
     1096            pfu_ho(ji,jj,jl) = pfu_ho(ji,jj,jl) - pfu_ups(ji,jj,jl) 
     1097            pfv_ho(ji,jj,jl) = pfv_ho(ji,jj,jl) - pfv_ups(ji,jj,jl) 
     1098         END_2D 
    11861099      END DO 
    11871100 
     
    11971110          
    11981111         DO jl = 1, jpl 
    1199             DO jj = 2, jpjm1 
    1200                DO ji = fs_2, fs_jpim1  
    1201                   zti_ups(ji,jj,jl)= pt_ups(ji+1,jj  ,jl) 
    1202                   ztj_ups(ji,jj,jl)= pt_ups(ji  ,jj+1,jl) 
    1203                END DO 
    1204             END DO 
     1112            DO_2D_00_00 
     1113               zti_ups(ji,jj,jl)= pt_ups(ji+1,jj  ,jl) 
     1114               ztj_ups(ji,jj,jl)= pt_ups(ji  ,jj+1,jl) 
     1115            END_2D 
    12051116         END DO 
    12061117         CALL lbc_lnk_multi( 'icedyn_adv_umx', zti_ups, 'T', 1., ztj_ups, 'T', 1. ) 
    12071118 
    12081119         DO jl = 1, jpl 
    1209             DO jj = 2, jpjm1 
    1210                DO ji = fs_2, fs_jpim1 
    1211                   IF ( pfu_ho(ji,jj,jl) * ( pt_ups(ji+1,jj  ,jl) - pt_ups(ji,jj,jl) ) <= 0._wp .AND.  & 
    1212                      & pfv_ho(ji,jj,jl) * ( pt_ups(ji  ,jj+1,jl) - pt_ups(ji,jj,jl) ) <= 0._wp ) THEN 
    1213                      ! 
    1214                      IF(  pfu_ho(ji,jj,jl) * ( zti_ups(ji+1,jj  ,jl) - zti_ups(ji,jj,jl) ) <= 0._wp .AND.  & 
    1215                         & pfv_ho(ji,jj,jl) * ( ztj_ups(ji  ,jj+1,jl) - ztj_ups(ji,jj,jl) ) <= 0._wp ) THEN 
    1216                         pfu_ho(ji,jj,jl)=0._wp 
    1217                         pfv_ho(ji,jj,jl)=0._wp 
    1218                      ENDIF 
    1219                      ! 
    1220                      IF(  pfu_ho(ji,jj,jl) * ( pt_ups(ji,jj,jl) - pt_ups(ji-1,jj  ,jl) ) <= 0._wp .AND.  & 
    1221                         & pfv_ho(ji,jj,jl) * ( pt_ups(ji,jj,jl) - pt_ups(ji  ,jj-1,jl) ) <= 0._wp ) THEN 
    1222                         pfu_ho(ji,jj,jl)=0._wp 
    1223                         pfv_ho(ji,jj,jl)=0._wp 
    1224                      ENDIF 
    1225                      ! 
     1120            DO_2D_00_00 
     1121               IF ( pfu_ho(ji,jj,jl) * ( pt_ups(ji+1,jj  ,jl) - pt_ups(ji,jj,jl) ) <= 0._wp .AND.  & 
     1122                  & pfv_ho(ji,jj,jl) * ( pt_ups(ji  ,jj+1,jl) - pt_ups(ji,jj,jl) ) <= 0._wp ) THEN 
     1123                  ! 
     1124                  IF(  pfu_ho(ji,jj,jl) * ( zti_ups(ji+1,jj  ,jl) - zti_ups(ji,jj,jl) ) <= 0._wp .AND.  & 
     1125                     & pfv_ho(ji,jj,jl) * ( ztj_ups(ji  ,jj+1,jl) - ztj_ups(ji,jj,jl) ) <= 0._wp ) THEN 
     1126                     pfu_ho(ji,jj,jl)=0._wp 
     1127                     pfv_ho(ji,jj,jl)=0._wp 
    12261128                  ENDIF 
    1227                END DO 
    1228             END DO 
     1129                  ! 
     1130                  IF(  pfu_ho(ji,jj,jl) * ( pt_ups(ji,jj,jl) - pt_ups(ji-1,jj  ,jl) ) <= 0._wp .AND.  & 
     1131                     & pfv_ho(ji,jj,jl) * ( pt_ups(ji,jj,jl) - pt_ups(ji  ,jj-1,jl) ) <= 0._wp ) THEN 
     1132                     pfu_ho(ji,jj,jl)=0._wp 
     1133                     pfv_ho(ji,jj,jl)=0._wp 
     1134                  ENDIF 
     1135                  ! 
     1136               ENDIF 
     1137            END_2D 
    12291138         END DO 
    12301139         CALL lbc_lnk_multi( 'icedyn_adv_umx', pfu_ho, 'U', -1., pfv_ho, 'V', -1. )   ! lateral boundary cond. 
     
    12381147      DO jl = 1, jpl 
    12391148          
    1240          DO jj = 1, jpj 
    1241             DO ji = 1, jpi 
    1242                IF    ( pt(ji,jj,jl) <= 0._wp .AND. pt_ups(ji,jj,jl) <= 0._wp ) THEN 
    1243                   zbup(ji,jj) = -zbig 
    1244                   zbdo(ji,jj) =  zbig 
    1245                ELSEIF( pt(ji,jj,jl) <= 0._wp .AND. pt_ups(ji,jj,jl) > 0._wp ) THEN 
    1246                   zbup(ji,jj) = pt_ups(ji,jj,jl) 
    1247                   zbdo(ji,jj) = pt_ups(ji,jj,jl) 
    1248                ELSEIF( pt(ji,jj,jl) > 0._wp .AND. pt_ups(ji,jj,jl) <= 0._wp ) THEN 
    1249                   zbup(ji,jj) = pt(ji,jj,jl) 
    1250                   zbdo(ji,jj) = pt(ji,jj,jl) 
    1251                ELSE 
    1252                   zbup(ji,jj) = MAX( pt(ji,jj,jl) , pt_ups(ji,jj,jl) ) 
    1253                   zbdo(ji,jj) = MIN( pt(ji,jj,jl) , pt_ups(ji,jj,jl) ) 
    1254                ENDIF 
    1255             END DO 
    1256          END DO 
    1257  
    1258          DO jj = 2, jpjm1 
    1259             DO ji = fs_2, fs_jpim1   ! vector opt. 
    1260                ! 
    1261                zup  = MAX( zbup(ji,jj), zbup(ji-1,jj), zbup(ji+1,jj), zbup(ji,jj-1), zbup(ji,jj+1) )  ! search max/min in neighbourhood 
    1262                zdo  = MIN( zbdo(ji,jj), zbdo(ji-1,jj), zbdo(ji+1,jj), zbdo(ji,jj-1), zbdo(ji,jj+1) ) 
    1263                ! 
    1264                zpos = MAX( 0._wp, pfu_ho(ji-1,jj  ,jl) ) - MIN( 0._wp, pfu_ho(ji  ,jj  ,jl) ) &  ! positive/negative part of the flux 
    1265                   & + MAX( 0._wp, pfv_ho(ji  ,jj-1,jl) ) - MIN( 0._wp, pfv_ho(ji  ,jj  ,jl) ) 
    1266                zneg = MAX( 0._wp, pfu_ho(ji  ,jj  ,jl) ) - MIN( 0._wp, pfu_ho(ji-1,jj  ,jl) ) & 
    1267                   & + MAX( 0._wp, pfv_ho(ji  ,jj  ,jl) ) - MIN( 0._wp, pfv_ho(ji  ,jj-1,jl) ) 
    1268                ! 
    1269                zpos = zpos - (pt(ji,jj,jl) * MIN( 0., pu(ji,jj) - pu(ji-1,jj) ) + pt(ji,jj,jl) * MIN( 0., pv(ji,jj) - pv(ji,jj-1) ) & 
    1270                   &          ) * ( 1. - pamsk ) 
    1271                zneg = zneg + (pt(ji,jj,jl) * MAX( 0., pu(ji,jj) - pu(ji-1,jj) ) + pt(ji,jj,jl) * MAX( 0., pv(ji,jj) - pv(ji,jj-1) ) & 
    1272                   &          ) * ( 1. - pamsk ) 
    1273                ! 
    1274                !                                  ! up & down beta terms 
    1275                ! clem: zbetup and zbetdo must be 0 for zpos>1.e-10 & zneg>1.e-10 (do not put 0 instead of 1.e-10 !!!) 
    1276                IF( zpos > epsi10 ) THEN ; zbetup(ji,jj,jl) = MAX( 0._wp, zup - pt_ups(ji,jj,jl) ) / zpos * e1e2t(ji,jj) * z1_dt 
    1277                ELSE                     ; zbetup(ji,jj,jl) = 0._wp ! zbig 
    1278                ENDIF 
    1279                ! 
    1280                IF( zneg > epsi10 ) THEN ; zbetdo(ji,jj,jl) = MAX( 0._wp, pt_ups(ji,jj,jl) - zdo ) / zneg * e1e2t(ji,jj) * z1_dt 
    1281                ELSE                     ; zbetdo(ji,jj,jl) = 0._wp ! zbig 
    1282                ENDIF 
    1283                ! 
    1284                ! if all the points are outside ice cover 
    1285                IF( zup == -zbig )   zbetup(ji,jj,jl) = 0._wp ! zbig 
    1286                IF( zdo ==  zbig )   zbetdo(ji,jj,jl) = 0._wp ! zbig             
    1287                ! 
    1288             END DO 
    1289          END DO 
     1149         DO_2D_11_11 
     1150            IF    ( pt(ji,jj,jl) <= 0._wp .AND. pt_ups(ji,jj,jl) <= 0._wp ) THEN 
     1151               zbup(ji,jj) = -zbig 
     1152               zbdo(ji,jj) =  zbig 
     1153            ELSEIF( pt(ji,jj,jl) <= 0._wp .AND. pt_ups(ji,jj,jl) > 0._wp ) THEN 
     1154               zbup(ji,jj) = pt_ups(ji,jj,jl) 
     1155               zbdo(ji,jj) = pt_ups(ji,jj,jl) 
     1156            ELSEIF( pt(ji,jj,jl) > 0._wp .AND. pt_ups(ji,jj,jl) <= 0._wp ) THEN 
     1157               zbup(ji,jj) = pt(ji,jj,jl) 
     1158               zbdo(ji,jj) = pt(ji,jj,jl) 
     1159            ELSE 
     1160               zbup(ji,jj) = MAX( pt(ji,jj,jl) , pt_ups(ji,jj,jl) ) 
     1161               zbdo(ji,jj) = MIN( pt(ji,jj,jl) , pt_ups(ji,jj,jl) ) 
     1162            ENDIF 
     1163         END_2D 
     1164 
     1165         DO_2D_00_00 
     1166            ! 
     1167            zup  = MAX( zbup(ji,jj), zbup(ji-1,jj), zbup(ji+1,jj), zbup(ji,jj-1), zbup(ji,jj+1) )  ! search max/min in neighbourhood 
     1168            zdo  = MIN( zbdo(ji,jj), zbdo(ji-1,jj), zbdo(ji+1,jj), zbdo(ji,jj-1), zbdo(ji,jj+1) ) 
     1169            ! 
     1170            zpos = MAX( 0._wp, pfu_ho(ji-1,jj  ,jl) ) - MIN( 0._wp, pfu_ho(ji  ,jj  ,jl) ) &  ! positive/negative part of the flux 
     1171               & + MAX( 0._wp, pfv_ho(ji  ,jj-1,jl) ) - MIN( 0._wp, pfv_ho(ji  ,jj  ,jl) ) 
     1172            zneg = MAX( 0._wp, pfu_ho(ji  ,jj  ,jl) ) - MIN( 0._wp, pfu_ho(ji-1,jj  ,jl) ) & 
     1173               & + MAX( 0._wp, pfv_ho(ji  ,jj  ,jl) ) - MIN( 0._wp, pfv_ho(ji  ,jj-1,jl) ) 
     1174            ! 
     1175            zpos = zpos - (pt(ji,jj,jl) * MIN( 0., pu(ji,jj) - pu(ji-1,jj) ) + pt(ji,jj,jl) * MIN( 0., pv(ji,jj) - pv(ji,jj-1) ) & 
     1176               &          ) * ( 1. - pamsk ) 
     1177            zneg = zneg + (pt(ji,jj,jl) * MAX( 0., pu(ji,jj) - pu(ji-1,jj) ) + pt(ji,jj,jl) * MAX( 0., pv(ji,jj) - pv(ji,jj-1) ) & 
     1178               &          ) * ( 1. - pamsk ) 
     1179            ! 
     1180            !                                  ! up & down beta terms 
     1181            ! clem: zbetup and zbetdo must be 0 for zpos>1.e-10 & zneg>1.e-10 (do not put 0 instead of 1.e-10 !!!) 
     1182            IF( zpos > epsi10 ) THEN ; zbetup(ji,jj,jl) = MAX( 0._wp, zup - pt_ups(ji,jj,jl) ) / zpos * e1e2t(ji,jj) * z1_dt 
     1183            ELSE                     ; zbetup(ji,jj,jl) = 0._wp ! zbig 
     1184            ENDIF 
     1185            ! 
     1186            IF( zneg > epsi10 ) THEN ; zbetdo(ji,jj,jl) = MAX( 0._wp, pt_ups(ji,jj,jl) - zdo ) / zneg * e1e2t(ji,jj) * z1_dt 
     1187            ELSE                     ; zbetdo(ji,jj,jl) = 0._wp ! zbig 
     1188            ENDIF 
     1189            ! 
     1190            ! if all the points are outside ice cover 
     1191            IF( zup == -zbig )   zbetup(ji,jj,jl) = 0._wp ! zbig 
     1192            IF( zdo ==  zbig )   zbetdo(ji,jj,jl) = 0._wp ! zbig             
     1193            ! 
     1194         END_2D 
    12901195      END DO 
    12911196      CALL lbc_lnk_multi( 'icedyn_adv_umx', zbetup, 'T', 1., zbetdo, 'T', 1. )   ! lateral boundary cond. (unchanged sign) 
     
    12951200      ! --------------------------------- 
    12961201      DO jl = 1, jpl 
    1297          DO jj = 1, jpjm1 
    1298             DO ji = 1, fs_jpim1   ! vector opt. 
    1299                zau = MIN( 1._wp , zbetdo(ji,jj,jl) , zbetup(ji+1,jj,jl) ) 
    1300                zbu = MIN( 1._wp , zbetup(ji,jj,jl) , zbetdo(ji+1,jj,jl) ) 
    1301                zcu = 0.5_wp + SIGN( 0.5_wp , pfu_ho(ji,jj,jl) ) 
    1302                ! 
    1303                zcoef = ( zcu * zau + ( 1._wp - zcu ) * zbu ) 
    1304                ! 
    1305                pfu_ho(ji,jj,jl) = pfu_ho(ji,jj,jl) * zcoef + pfu_ups(ji,jj,jl) 
    1306                ! 
    1307             END DO 
    1308          END DO 
    1309  
    1310          DO jj = 1, jpjm1 
    1311             DO ji = 1, fs_jpim1   ! vector opt. 
    1312                zav = MIN( 1._wp , zbetdo(ji,jj,jl) , zbetup(ji,jj+1,jl) ) 
    1313                zbv = MIN( 1._wp , zbetup(ji,jj,jl) , zbetdo(ji,jj+1,jl) ) 
    1314                zcv = 0.5_wp + SIGN( 0.5_wp , pfv_ho(ji,jj,jl) ) 
    1315                ! 
    1316                zcoef = ( zcv * zav + ( 1._wp - zcv ) * zbv ) 
    1317                ! 
    1318                pfv_ho(ji,jj,jl) = pfv_ho(ji,jj,jl) * zcoef + pfv_ups(ji,jj,jl) 
    1319                ! 
    1320             END DO 
    1321          END DO 
     1202         DO_2D_10_10 
     1203            zau = MIN( 1._wp , zbetdo(ji,jj,jl) , zbetup(ji+1,jj,jl) ) 
     1204            zbu = MIN( 1._wp , zbetup(ji,jj,jl) , zbetdo(ji+1,jj,jl) ) 
     1205            zcu = 0.5_wp + SIGN( 0.5_wp , pfu_ho(ji,jj,jl) ) 
     1206            ! 
     1207            zcoef = ( zcu * zau + ( 1._wp - zcu ) * zbu ) 
     1208            ! 
     1209            pfu_ho(ji,jj,jl) = pfu_ho(ji,jj,jl) * zcoef + pfu_ups(ji,jj,jl) 
     1210            ! 
     1211         END_2D 
     1212 
     1213         DO_2D_10_10 
     1214            zav = MIN( 1._wp , zbetdo(ji,jj,jl) , zbetup(ji,jj+1,jl) ) 
     1215            zbv = MIN( 1._wp , zbetup(ji,jj,jl) , zbetdo(ji,jj+1,jl) ) 
     1216            zcv = 0.5_wp + SIGN( 0.5_wp , pfv_ho(ji,jj,jl) ) 
     1217            ! 
     1218            zcoef = ( zcv * zav + ( 1._wp - zcv ) * zbv ) 
     1219            ! 
     1220            pfv_ho(ji,jj,jl) = pfv_ho(ji,jj,jl) * zcoef + pfv_ups(ji,jj,jl) 
     1221            ! 
     1222         END_2D 
    13221223 
    13231224      END DO 
     
    13441245      ! 
    13451246      DO jl = 1, jpl 
    1346          DO jj = 2, jpjm1 
    1347             DO ji = fs_2, fs_jpim1   ! vector opt. 
    1348                zslpx(ji,jj,jl) = ( pt(ji+1,jj,jl) - pt(ji,jj,jl) ) * umask(ji,jj,1) 
    1349             END DO 
    1350          END DO 
     1247         DO_2D_00_00 
     1248            zslpx(ji,jj,jl) = ( pt(ji+1,jj,jl) - pt(ji,jj,jl) ) * umask(ji,jj,1) 
     1249         END_2D 
    13511250      END DO 
    13521251      CALL lbc_lnk( 'icedyn_adv_umx', zslpx, 'U', -1.)   ! lateral boundary cond. 
    13531252       
    13541253      DO jl = 1, jpl 
    1355          DO jj = 2, jpjm1 
    1356             DO ji = fs_2, fs_jpim1   ! vector opt. 
    1357                uCFL = pdt * ABS( pu(ji,jj) ) * r1_e1e2t(ji,jj) 
    1358                 
    1359                Rjm = zslpx(ji-1,jj,jl) 
    1360                Rj  = zslpx(ji  ,jj,jl) 
    1361                Rjp = zslpx(ji+1,jj,jl) 
    1362  
    1363                IF( np_limiter == 3 ) THEN 
    1364  
    1365                   IF( pu(ji,jj) > 0. ) THEN   ;   Rr = Rjm 
    1366                   ELSE                        ;   Rr = Rjp 
     1254         DO_2D_00_00 
     1255            uCFL = pdt * ABS( pu(ji,jj) ) * r1_e1e2t(ji,jj) 
     1256             
     1257            Rjm = zslpx(ji-1,jj,jl) 
     1258            Rj  = zslpx(ji  ,jj,jl) 
     1259            Rjp = zslpx(ji+1,jj,jl) 
     1260 
     1261            IF( np_limiter == 3 ) THEN 
     1262 
     1263               IF( pu(ji,jj) > 0. ) THEN   ;   Rr = Rjm 
     1264               ELSE                        ;   Rr = Rjp 
     1265               ENDIF 
     1266 
     1267               zh3 = pfu_ho(ji,jj,jl) - pfu_ups(ji,jj,jl)      
     1268               IF( Rj > 0. ) THEN 
     1269                  zlimiter =  MAX( 0., MIN( zh3, MAX(-Rr * 0.5 * ABS(pu(ji,jj)),  & 
     1270                     &        MIN( 2. * Rr * 0.5 * ABS(pu(ji,jj)),  zh3,  1.5 * Rj * 0.5 * ABS(pu(ji,jj)) ) ) ) ) 
     1271               ELSE 
     1272                  zlimiter = -MAX( 0., MIN(-zh3, MAX( Rr * 0.5 * ABS(pu(ji,jj)),  & 
     1273                     &        MIN(-2. * Rr * 0.5 * ABS(pu(ji,jj)), -zh3, -1.5 * Rj * 0.5 * ABS(pu(ji,jj)) ) ) ) ) 
     1274               ENDIF 
     1275               pfu_ho(ji,jj,jl) = pfu_ups(ji,jj,jl) + zlimiter 
     1276 
     1277            ELSEIF( np_limiter == 2 ) THEN 
     1278               IF( Rj /= 0. ) THEN 
     1279                  IF( pu(ji,jj) > 0. ) THEN   ;   Cr = Rjm / Rj 
     1280                  ELSE                        ;   Cr = Rjp / Rj 
    13671281                  ENDIF 
    1368  
    1369                   zh3 = pfu_ho(ji,jj,jl) - pfu_ups(ji,jj,jl)      
    1370                   IF( Rj > 0. ) THEN 
    1371                      zlimiter =  MAX( 0., MIN( zh3, MAX(-Rr * 0.5 * ABS(pu(ji,jj)),  & 
    1372                         &        MIN( 2. * Rr * 0.5 * ABS(pu(ji,jj)),  zh3,  1.5 * Rj * 0.5 * ABS(pu(ji,jj)) ) ) ) ) 
    1373                   ELSE 
    1374                      zlimiter = -MAX( 0., MIN(-zh3, MAX( Rr * 0.5 * ABS(pu(ji,jj)),  & 
    1375                         &        MIN(-2. * Rr * 0.5 * ABS(pu(ji,jj)), -zh3, -1.5 * Rj * 0.5 * ABS(pu(ji,jj)) ) ) ) ) 
    1376                   ENDIF 
    1377                   pfu_ho(ji,jj,jl) = pfu_ups(ji,jj,jl) + zlimiter 
    1378  
    1379                ELSEIF( np_limiter == 2 ) THEN 
    1380                   IF( Rj /= 0. ) THEN 
    1381                      IF( pu(ji,jj) > 0. ) THEN   ;   Cr = Rjm / Rj 
    1382                      ELSE                        ;   Cr = Rjp / Rj 
    1383                      ENDIF 
    1384                   ELSE 
    1385                      Cr = 0. 
    1386                   ENDIF 
    1387  
    1388                   ! -- superbee -- 
    1389                   zpsi = MAX( 0., MAX( MIN(1.,2.*Cr), MIN(2.,Cr) ) ) 
    1390                   ! -- van albada 2 -- 
    1391                   !!zpsi = 2.*Cr / (Cr*Cr+1.) 
    1392                   ! -- sweby (with beta=1) -- 
    1393                   !!zpsi = MAX( 0., MAX( MIN(1.,1.*Cr), MIN(1.,Cr) ) ) 
    1394                   ! -- van Leer -- 
    1395                   !!zpsi = ( Cr + ABS(Cr) ) / ( 1. + ABS(Cr) ) 
    1396                   ! -- ospre -- 
    1397                   !!zpsi = 1.5 * ( Cr*Cr + Cr ) / ( Cr*Cr + Cr + 1. ) 
    1398                   ! -- koren -- 
    1399                   !!zpsi = MAX( 0., MIN( 2.*Cr, MIN( (1.+2*Cr)/3., 2. ) ) ) 
    1400                   ! -- charm -- 
    1401                   !IF( Cr > 0. ) THEN   ;   zpsi = Cr * (3.*Cr + 1.) / ( (Cr + 1.) * (Cr + 1.) ) 
    1402                   !ELSE                 ;   zpsi = 0. 
    1403                   !ENDIF 
    1404                   ! -- van albada 1 -- 
    1405                   !!zpsi = (Cr*Cr + Cr) / (Cr*Cr +1) 
    1406                   ! -- smart -- 
    1407                   !!zpsi = MAX( 0., MIN( 2.*Cr, MIN( 0.25+0.75*Cr, 4. ) ) ) 
    1408                   ! -- umist -- 
    1409                   !!zpsi = MAX( 0., MIN( 2.*Cr, MIN( 0.25+0.75*Cr, MIN(0.75+0.25*Cr, 2. ) ) ) ) 
    1410  
    1411                   ! high order flux corrected by the limiter 
    1412                   pfu_ho(ji,jj,jl) = pfu_ho(ji,jj,jl) - ABS( pu(ji,jj) ) * ( (1.-zpsi) + uCFL*zpsi ) * Rj * 0.5 
    1413  
     1282               ELSE 
     1283                  Cr = 0. 
    14141284               ENDIF 
    1415             END DO 
    1416          END DO 
     1285 
     1286               ! -- superbee -- 
     1287               zpsi = MAX( 0., MAX( MIN(1.,2.*Cr), MIN(2.,Cr) ) ) 
     1288               ! -- van albada 2 -- 
     1289               !!zpsi = 2.*Cr / (Cr*Cr+1.) 
     1290               ! -- sweby (with beta=1) -- 
     1291               !!zpsi = MAX( 0., MAX( MIN(1.,1.*Cr), MIN(1.,Cr) ) ) 
     1292               ! -- van Leer -- 
     1293               !!zpsi = ( Cr + ABS(Cr) ) / ( 1. + ABS(Cr) ) 
     1294               ! -- ospre -- 
     1295               !!zpsi = 1.5 * ( Cr*Cr + Cr ) / ( Cr*Cr + Cr + 1. ) 
     1296               ! -- koren -- 
     1297               !!zpsi = MAX( 0., MIN( 2.*Cr, MIN( (1.+2*Cr)/3., 2. ) ) ) 
     1298               ! -- charm -- 
     1299               !IF( Cr > 0. ) THEN   ;   zpsi = Cr * (3.*Cr + 1.) / ( (Cr + 1.) * (Cr + 1.) ) 
     1300               !ELSE                 ;   zpsi = 0. 
     1301               !ENDIF 
     1302               ! -- van albada 1 -- 
     1303               !!zpsi = (Cr*Cr + Cr) / (Cr*Cr +1) 
     1304               ! -- smart -- 
     1305               !!zpsi = MAX( 0., MIN( 2.*Cr, MIN( 0.25+0.75*Cr, 4. ) ) ) 
     1306               ! -- umist -- 
     1307               !!zpsi = MAX( 0., MIN( 2.*Cr, MIN( 0.25+0.75*Cr, MIN(0.75+0.25*Cr, 2. ) ) ) ) 
     1308 
     1309               ! high order flux corrected by the limiter 
     1310               pfu_ho(ji,jj,jl) = pfu_ho(ji,jj,jl) - ABS( pu(ji,jj) ) * ( (1.-zpsi) + uCFL*zpsi ) * Rj * 0.5 
     1311 
     1312            ENDIF 
     1313         END_2D 
    14171314      END DO 
    14181315      CALL lbc_lnk( 'icedyn_adv_umx', pfu_ho, 'U', -1.)   ! lateral boundary cond. 
     
    14391336      ! 
    14401337      DO jl = 1, jpl 
    1441          DO jj = 2, jpjm1 
    1442             DO ji = fs_2, fs_jpim1   ! vector opt. 
    1443                zslpy(ji,jj,jl) = ( pt(ji,jj+1,jl) - pt(ji,jj,jl) ) * vmask(ji,jj,1) 
    1444             END DO 
    1445          END DO 
     1338         DO_2D_00_00 
     1339            zslpy(ji,jj,jl) = ( pt(ji,jj+1,jl) - pt(ji,jj,jl) ) * vmask(ji,jj,1) 
     1340         END_2D 
    14461341      END DO 
    14471342      CALL lbc_lnk( 'icedyn_adv_umx', zslpy, 'V', -1.)   ! lateral boundary cond. 
    14481343 
    14491344      DO jl = 1, jpl 
    1450          DO jj = 2, jpjm1 
    1451             DO ji = fs_2, fs_jpim1   ! vector opt. 
    1452                vCFL = pdt * ABS( pv(ji,jj) ) * r1_e1e2t(ji,jj) 
    1453  
    1454                Rjm = zslpy(ji,jj-1,jl) 
    1455                Rj  = zslpy(ji,jj  ,jl) 
    1456                Rjp = zslpy(ji,jj+1,jl) 
    1457  
    1458                IF( np_limiter == 3 ) THEN 
    1459  
    1460                   IF( pv(ji,jj) > 0. ) THEN   ;   Rr = Rjm 
    1461                   ELSE                        ;   Rr = Rjp 
     1345         DO_2D_00_00 
     1346            vCFL = pdt * ABS( pv(ji,jj) ) * r1_e1e2t(ji,jj) 
     1347 
     1348            Rjm = zslpy(ji,jj-1,jl) 
     1349            Rj  = zslpy(ji,jj  ,jl) 
     1350            Rjp = zslpy(ji,jj+1,jl) 
     1351 
     1352            IF( np_limiter == 3 ) THEN 
     1353 
     1354               IF( pv(ji,jj) > 0. ) THEN   ;   Rr = Rjm 
     1355               ELSE                        ;   Rr = Rjp 
     1356               ENDIF 
     1357 
     1358               zh3 = pfv_ho(ji,jj,jl) - pfv_ups(ji,jj,jl)      
     1359               IF( Rj > 0. ) THEN 
     1360                  zlimiter =  MAX( 0., MIN( zh3, MAX(-Rr * 0.5 * ABS(pv(ji,jj)),  & 
     1361                     &        MIN( 2. * Rr * 0.5 * ABS(pv(ji,jj)),  zh3,  1.5 * Rj * 0.5 * ABS(pv(ji,jj)) ) ) ) ) 
     1362               ELSE 
     1363                  zlimiter = -MAX( 0., MIN(-zh3, MAX( Rr * 0.5 * ABS(pv(ji,jj)),  & 
     1364                     &        MIN(-2. * Rr * 0.5 * ABS(pv(ji,jj)), -zh3, -1.5 * Rj * 0.5 * ABS(pv(ji,jj)) ) ) ) ) 
     1365               ENDIF 
     1366               pfv_ho(ji,jj,jl) = pfv_ups(ji,jj,jl) + zlimiter 
     1367 
     1368            ELSEIF( np_limiter == 2 ) THEN 
     1369 
     1370               IF( Rj /= 0. ) THEN 
     1371                  IF( pv(ji,jj) > 0. ) THEN   ;   Cr = Rjm / Rj 
     1372                  ELSE                        ;   Cr = Rjp / Rj 
    14621373                  ENDIF 
    1463  
    1464                   zh3 = pfv_ho(ji,jj,jl) - pfv_ups(ji,jj,jl)      
    1465                   IF( Rj > 0. ) THEN 
    1466                      zlimiter =  MAX( 0., MIN( zh3, MAX(-Rr * 0.5 * ABS(pv(ji,jj)),  & 
    1467                         &        MIN( 2. * Rr * 0.5 * ABS(pv(ji,jj)),  zh3,  1.5 * Rj * 0.5 * ABS(pv(ji,jj)) ) ) ) ) 
    1468                   ELSE 
    1469                      zlimiter = -MAX( 0., MIN(-zh3, MAX( Rr * 0.5 * ABS(pv(ji,jj)),  & 
    1470                         &        MIN(-2. * Rr * 0.5 * ABS(pv(ji,jj)), -zh3, -1.5 * Rj * 0.5 * ABS(pv(ji,jj)) ) ) ) ) 
    1471                   ENDIF 
    1472                   pfv_ho(ji,jj,jl) = pfv_ups(ji,jj,jl) + zlimiter 
    1473  
    1474                ELSEIF( np_limiter == 2 ) THEN 
    1475  
    1476                   IF( Rj /= 0. ) THEN 
    1477                      IF( pv(ji,jj) > 0. ) THEN   ;   Cr = Rjm / Rj 
    1478                      ELSE                        ;   Cr = Rjp / Rj 
    1479                      ENDIF 
    1480                   ELSE 
    1481                      Cr = 0. 
    1482                   ENDIF 
    1483  
    1484                   ! -- superbee -- 
    1485                   zpsi = MAX( 0., MAX( MIN(1.,2.*Cr), MIN(2.,Cr) ) ) 
    1486                   ! -- van albada 2 -- 
    1487                   !!zpsi = 2.*Cr / (Cr*Cr+1.) 
    1488                   ! -- sweby (with beta=1) -- 
    1489                   !!zpsi = MAX( 0., MAX( MIN(1.,1.*Cr), MIN(1.,Cr) ) ) 
    1490                   ! -- van Leer -- 
    1491                   !!zpsi = ( Cr + ABS(Cr) ) / ( 1. + ABS(Cr) ) 
    1492                   ! -- ospre -- 
    1493                   !!zpsi = 1.5 * ( Cr*Cr + Cr ) / ( Cr*Cr + Cr + 1. ) 
    1494                   ! -- koren -- 
    1495                   !!zpsi = MAX( 0., MIN( 2.*Cr, MIN( (1.+2*Cr)/3., 2. ) ) ) 
    1496                   ! -- charm -- 
    1497                   !IF( Cr > 0. ) THEN   ;   zpsi = Cr * (3.*Cr + 1.) / ( (Cr + 1.) * (Cr + 1.) ) 
    1498                   !ELSE                 ;   zpsi = 0. 
    1499                   !ENDIF 
    1500                   ! -- van albada 1 -- 
    1501                   !!zpsi = (Cr*Cr + Cr) / (Cr*Cr +1) 
    1502                   ! -- smart -- 
    1503                   !!zpsi = MAX( 0., MIN( 2.*Cr, MIN( 0.25+0.75*Cr, 4. ) ) ) 
    1504                   ! -- umist -- 
    1505                   !!zpsi = MAX( 0., MIN( 2.*Cr, MIN( 0.25+0.75*Cr, MIN(0.75+0.25*Cr, 2. ) ) ) ) 
    1506  
    1507                   ! high order flux corrected by the limiter 
    1508                   pfv_ho(ji,jj,jl) = pfv_ho(ji,jj,jl) - ABS( pv(ji,jj) ) * ( (1.-zpsi) + vCFL*zpsi ) * Rj * 0.5 
    1509  
     1374               ELSE 
     1375                  Cr = 0. 
    15101376               ENDIF 
    1511             END DO 
    1512          END DO 
     1377 
     1378               ! -- superbee -- 
     1379               zpsi = MAX( 0., MAX( MIN(1.,2.*Cr), MIN(2.,Cr) ) ) 
     1380               ! -- van albada 2 -- 
     1381               !!zpsi = 2.*Cr / (Cr*Cr+1.) 
     1382               ! -- sweby (with beta=1) -- 
     1383               !!zpsi = MAX( 0., MAX( MIN(1.,1.*Cr), MIN(1.,Cr) ) ) 
     1384               ! -- van Leer -- 
     1385               !!zpsi = ( Cr + ABS(Cr) ) / ( 1. + ABS(Cr) ) 
     1386               ! -- ospre -- 
     1387               !!zpsi = 1.5 * ( Cr*Cr + Cr ) / ( Cr*Cr + Cr + 1. ) 
     1388               ! -- koren -- 
     1389               !!zpsi = MAX( 0., MIN( 2.*Cr, MIN( (1.+2*Cr)/3., 2. ) ) ) 
     1390               ! -- charm -- 
     1391               !IF( Cr > 0. ) THEN   ;   zpsi = Cr * (3.*Cr + 1.) / ( (Cr + 1.) * (Cr + 1.) ) 
     1392               !ELSE                 ;   zpsi = 0. 
     1393               !ENDIF 
     1394               ! -- van albada 1 -- 
     1395               !!zpsi = (Cr*Cr + Cr) / (Cr*Cr +1) 
     1396               ! -- smart -- 
     1397               !!zpsi = MAX( 0., MIN( 2.*Cr, MIN( 0.25+0.75*Cr, 4. ) ) ) 
     1398               ! -- umist -- 
     1399               !!zpsi = MAX( 0., MIN( 2.*Cr, MIN( 0.25+0.75*Cr, MIN(0.75+0.25*Cr, 2. ) ) ) ) 
     1400 
     1401               ! high order flux corrected by the limiter 
     1402               pfv_ho(ji,jj,jl) = pfv_ho(ji,jj,jl) - ABS( pv(ji,jj) ) * ( (1.-zpsi) + vCFL*zpsi ) * Rj * 0.5 
     1403 
     1404            ENDIF 
     1405         END_2D 
    15131406      END DO 
    15141407      CALL lbc_lnk( 'icedyn_adv_umx', pfv_ho, 'V', -1.)   ! lateral boundary cond. 
     
    15441437      DO jl = 1, jpl 
    15451438 
    1546          DO jj = 1, jpj 
    1547             DO ji = 1, jpi 
    1548                IF ( pv_i(ji,jj,jl) > 0._wp ) THEN 
     1439         DO_2D_11_11 
     1440            IF ( pv_i(ji,jj,jl) > 0._wp ) THEN 
     1441               ! 
     1442               !                               ! -- check h_ip -- ! 
     1443               ! if h_ip is larger than the surrounding 9 pts => reduce h_ip and increase a_ip 
     1444               IF( ln_pnd_H12 .AND. pv_ip(ji,jj,jl) > 0._wp ) THEN 
     1445                  zhip = pv_ip(ji,jj,jl) / MAX( epsi20, pa_ip(ji,jj,jl) ) 
     1446                  IF( zhip > phip_max(ji,jj,jl) .AND. pa_ip(ji,jj,jl) < 0.15 ) THEN 
     1447                     pa_ip(ji,jj,jl) = pv_ip(ji,jj,jl) / phip_max(ji,jj,jl) 
     1448                  ENDIF 
     1449               ENDIF 
     1450               ! 
     1451               !                               ! -- check h_i -- ! 
     1452               ! if h_i is larger than the surrounding 9 pts => reduce h_i and increase a_i 
     1453               zhi = pv_i(ji,jj,jl) / pa_i(ji,jj,jl) 
     1454               IF( zhi > phi_max(ji,jj,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 
     1455                  pa_i(ji,jj,jl) = pv_i(ji,jj,jl) / MIN( phi_max(ji,jj,jl), hi_max(jpl) )   !-- bound h_i to hi_max (99 m) 
     1456               ENDIF 
     1457               ! 
     1458               !                               ! -- check h_s -- ! 
     1459               ! if h_s is larger than the surrounding 9 pts => put the snow excess in the ocean 
     1460               zhs = pv_s(ji,jj,jl) / pa_i(ji,jj,jl) 
     1461               IF( pv_s(ji,jj,jl) > 0._wp .AND. zhs > phs_max(ji,jj,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 
     1462                  zfra = phs_max(ji,jj,jl) / MAX( zhs, epsi20 ) 
    15491463                  ! 
    1550                   !                               ! -- check h_ip -- ! 
    1551                   ! if h_ip is larger than the surrounding 9 pts => reduce h_ip and increase a_ip 
    1552                   IF( ln_pnd_H12 .AND. pv_ip(ji,jj,jl) > 0._wp ) THEN 
    1553                      zhip = pv_ip(ji,jj,jl) / MAX( epsi20, pa_ip(ji,jj,jl) ) 
    1554                      IF( zhip > phip_max(ji,jj,jl) .AND. pa_ip(ji,jj,jl) < 0.15 ) THEN 
    1555                         pa_ip(ji,jj,jl) = pv_ip(ji,jj,jl) / phip_max(ji,jj,jl) 
    1556                      ENDIF 
    1557                   ENDIF 
     1464                  wfx_res(ji,jj) = wfx_res(ji,jj) + ( pv_s(ji,jj,jl) - pa_i(ji,jj,jl) * phs_max(ji,jj,jl) ) * rhos * z1_dt 
     1465                  hfx_res(ji,jj) = hfx_res(ji,jj) - SUM( pe_s(ji,jj,1:nlay_s,jl) ) * ( 1._wp - zfra ) * z1_dt ! W.m-2 <0 
    15581466                  ! 
    1559                   !                               ! -- check h_i -- ! 
    1560                   ! if h_i is larger than the surrounding 9 pts => reduce h_i and increase a_i 
    1561                   zhi = pv_i(ji,jj,jl) / pa_i(ji,jj,jl) 
    1562                   IF( zhi > phi_max(ji,jj,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 
    1563                      pa_i(ji,jj,jl) = pv_i(ji,jj,jl) / MIN( phi_max(ji,jj,jl), hi_max(jpl) )   !-- bound h_i to hi_max (99 m) 
    1564                   ENDIF 
    1565                   ! 
    1566                   !                               ! -- check h_s -- ! 
    1567                   ! if h_s is larger than the surrounding 9 pts => put the snow excess in the ocean 
    1568                   zhs = pv_s(ji,jj,jl) / pa_i(ji,jj,jl) 
    1569                   IF( pv_s(ji,jj,jl) > 0._wp .AND. zhs > phs_max(ji,jj,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 
    1570                      zfra = phs_max(ji,jj,jl) / MAX( zhs, epsi20 ) 
    1571                      ! 
    1572                      wfx_res(ji,jj) = wfx_res(ji,jj) + ( pv_s(ji,jj,jl) - pa_i(ji,jj,jl) * phs_max(ji,jj,jl) ) * rhos * z1_dt 
    1573                      hfx_res(ji,jj) = hfx_res(ji,jj) - SUM( pe_s(ji,jj,1:nlay_s,jl) ) * ( 1._wp - zfra ) * z1_dt ! W.m-2 <0 
    1574                      ! 
    1575                      pe_s(ji,jj,1:nlay_s,jl) = pe_s(ji,jj,1:nlay_s,jl) * zfra 
    1576                      pv_s(ji,jj,jl)          = pa_i(ji,jj,jl) * phs_max(ji,jj,jl) 
    1577                   ENDIF            
    1578                   !                   
    1579                ENDIF 
    1580             END DO 
    1581          END DO 
     1467                  pe_s(ji,jj,1:nlay_s,jl) = pe_s(ji,jj,1:nlay_s,jl) * zfra 
     1468                  pv_s(ji,jj,jl)          = pa_i(ji,jj,jl) * phs_max(ji,jj,jl) 
     1469               ENDIF            
     1470               !                   
     1471            ENDIF 
     1472         END_2D 
    15821473      END DO  
    15831474      ! 
     
    16121503      ! -- check snow load -- ! 
    16131504      DO jl = 1, jpl 
    1614          DO jj = 1, jpj 
    1615             DO ji = 1, jpi 
    1616                IF ( pv_i(ji,jj,jl) > 0._wp ) THEN 
    1617                   ! 
    1618                   zvs_excess = MAX( 0._wp, pv_s(ji,jj,jl) - pv_i(ji,jj,jl) * (rau0-rhoi) * r1_rhos ) 
    1619                   ! 
    1620                   IF( zvs_excess > 0._wp ) THEN   ! snow-ice interface deplets below the ocean surface 
    1621                      ! put snow excess in the ocean 
    1622                      zfra = ( pv_s(ji,jj,jl) - zvs_excess ) / MAX( pv_s(ji,jj,jl), epsi20 ) 
    1623                      wfx_res(ji,jj) = wfx_res(ji,jj) + zvs_excess * rhos * z1_dt 
    1624                      hfx_res(ji,jj) = hfx_res(ji,jj) - SUM( pe_s(ji,jj,1:nlay_s,jl) ) * ( 1._wp - zfra ) * z1_dt ! W.m-2 <0 
    1625                      ! correct snow volume and heat content 
    1626                      pe_s(ji,jj,1:nlay_s,jl) = pe_s(ji,jj,1:nlay_s,jl) * zfra 
    1627                      pv_s(ji,jj,jl)          = pv_s(ji,jj,jl) - zvs_excess 
    1628                   ENDIF 
    1629                   ! 
     1505         DO_2D_11_11 
     1506            IF ( pv_i(ji,jj,jl) > 0._wp ) THEN 
     1507               ! 
     1508               zvs_excess = MAX( 0._wp, pv_s(ji,jj,jl) - pv_i(ji,jj,jl) * (rau0-rhoi) * r1_rhos ) 
     1509               ! 
     1510               IF( zvs_excess > 0._wp ) THEN   ! snow-ice interface deplets below the ocean surface 
     1511                  ! put snow excess in the ocean 
     1512                  zfra = ( pv_s(ji,jj,jl) - zvs_excess ) / MAX( pv_s(ji,jj,jl), epsi20 ) 
     1513                  wfx_res(ji,jj) = wfx_res(ji,jj) + zvs_excess * rhos * z1_dt 
     1514                  hfx_res(ji,jj) = hfx_res(ji,jj) - SUM( pe_s(ji,jj,1:nlay_s,jl) ) * ( 1._wp - zfra ) * z1_dt ! W.m-2 <0 
     1515                  ! correct snow volume and heat content 
     1516                  pe_s(ji,jj,1:nlay_s,jl) = pe_s(ji,jj,1:nlay_s,jl) * zfra 
     1517                  pv_s(ji,jj,jl)          = pv_s(ji,jj,jl) - zvs_excess 
    16301518               ENDIF 
    1631             END DO 
    1632          END DO 
     1519               ! 
     1520            ENDIF 
     1521         END_2D 
    16331522      END DO 
    16341523      ! 
  • NEMO/branches/2019/dev_r11943_MERGE_2019/src/ICE/icedyn_rdgrft.F90

    r12236 r12340  
    7575   REAL(wp) ::   rn_fpndrft       !    fractional pond loss to the ocean during rafting 
    7676   ! 
     77   !! * Substitutions 
     78#  include "do_loop_substitute.h90" 
    7779   !!---------------------------------------------------------------------- 
    7880   !! NEMO/ICE 4.0 , NEMO Consortium (2018) 
     
    159161      npti = 0   ;   nptidx(:) = 0 
    160162      ipti = 0   ;   iptidx(:) = 0 
    161       DO jj = 1, jpj 
    162          DO ji = 1, jpi 
    163             IF ( at_i(ji,jj) > epsi10 ) THEN 
    164                npti           = npti + 1 
    165                nptidx( npti ) = (jj - 1) * jpi + ji 
    166             ENDIF 
    167          END DO 
    168       END DO 
     163      DO_2D_11_11 
     164         IF ( at_i(ji,jj) > epsi10 ) THEN 
     165            npti           = npti + 1 
     166            nptidx( npti ) = (jj - 1) * jpi + ji 
     167         ENDIF 
     168      END_2D 
    169169       
    170170      !-------------------------------------------------------- 
     
    766766      !                              !--------------------------------------------------! 
    767767      CASE( 1 )               !--- Spatial smoothing 
    768          DO jj = 2, jpjm1 
    769             DO ji = 2, jpim1 
    770                IF ( SUM( a_i(ji,jj,:) ) > 0._wp ) THEN  
    771                   zworka(ji,jj) = ( 4.0 * strength(ji,jj)              & 
    772                      &                  + strength(ji-1,jj) * tmask(ji-1,jj,1) + strength(ji+1,jj) * tmask(ji+1,jj,1) &   
    773                      &                  + strength(ji,jj-1) * tmask(ji,jj-1,1) + strength(ji,jj+1) * tmask(ji,jj+1,1) & 
    774                      &            ) / ( 4.0 + tmask(ji-1,jj,1) + tmask(ji+1,jj,1) + tmask(ji,jj-1,1) + tmask(ji,jj+1,1) ) 
    775                ELSE 
    776                   zworka(ji,jj) = 0._wp 
    777                ENDIF 
    778             END DO 
    779          END DO 
     768         DO_2D_00_00 
     769            IF ( SUM( a_i(ji,jj,:) ) > 0._wp ) THEN  
     770               zworka(ji,jj) = ( 4.0 * strength(ji,jj)              & 
     771                  &                  + strength(ji-1,jj) * tmask(ji-1,jj,1) + strength(ji+1,jj) * tmask(ji+1,jj,1) &   
     772                  &                  + strength(ji,jj-1) * tmask(ji,jj-1,1) + strength(ji,jj+1) * tmask(ji,jj+1,1) & 
     773                  &            ) / ( 4.0 + tmask(ji-1,jj,1) + tmask(ji+1,jj,1) + tmask(ji,jj-1,1) + tmask(ji,jj+1,1) ) 
     774            ELSE 
     775               zworka(ji,jj) = 0._wp 
     776            ENDIF 
     777         END_2D 
    780778          
    781          DO jj = 2, jpjm1 
    782             DO ji = 2, jpim1 
    783                strength(ji,jj) = zworka(ji,jj) 
    784             END DO 
    785          END DO 
     779         DO_2D_00_00 
     780            strength(ji,jj) = zworka(ji,jj) 
     781         END_2D 
    786782         CALL lbc_lnk( 'icedyn_rdgrft', strength, 'T', 1. ) 
    787783         ! 
     
    792788         ENDIF 
    793789         ! 
    794          DO jj = 2, jpjm1 
    795             DO ji = 2, jpim1 
    796                IF ( SUM( a_i(ji,jj,:) ) > 0._wp ) THEN  
    797                   itframe = 1 ! number of time steps for the running mean 
    798                   IF ( zstrp1(ji,jj) > 0._wp ) itframe = itframe + 1 
    799                   IF ( zstrp2(ji,jj) > 0._wp ) itframe = itframe + 1 
    800                   zp = ( strength(ji,jj) + zstrp1(ji,jj) + zstrp2(ji,jj) ) / itframe 
    801                   zstrp2  (ji,jj) = zstrp1  (ji,jj) 
    802                   zstrp1  (ji,jj) = strength(ji,jj) 
    803                   strength(ji,jj) = zp 
    804                ENDIF 
    805             END DO 
    806          END DO 
     790         DO_2D_00_00 
     791            IF ( SUM( a_i(ji,jj,:) ) > 0._wp ) THEN  
     792               itframe = 1 ! number of time steps for the running mean 
     793               IF ( zstrp1(ji,jj) > 0._wp ) itframe = itframe + 1 
     794               IF ( zstrp2(ji,jj) > 0._wp ) itframe = itframe + 1 
     795               zp = ( strength(ji,jj) + zstrp1(ji,jj) + zstrp2(ji,jj) ) / itframe 
     796               zstrp2  (ji,jj) = zstrp1  (ji,jj) 
     797               zstrp1  (ji,jj) = strength(ji,jj) 
     798               strength(ji,jj) = zp 
     799            ENDIF 
     800         END_2D 
    807801         CALL lbc_lnk( 'icedyn_rdgrft', strength, 'T', 1. ) 
    808802         ! 
  • NEMO/branches/2019/dev_r11943_MERGE_2019/src/ICE/icedyn_rhg_evp.F90

    r12236 r12340  
    4949   !! * Substitutions 
    5050#  include "vectopt_loop_substitute.h90" 
     51#  include "do_loop_substitute.h90" 
    5152   !!---------------------------------------------------------------------- 
    5253   !! NEMO/ICE 4.0 , NEMO Consortium (2018) 
     
    180181      !------------------------------------------------------------------------------! 
    181182      ! ocean/land mask 
    182       DO jj = 1, jpjm1 
    183          DO ji = 1, jpim1      ! NO vector opt. 
    184             zfmask(ji,jj) = tmask(ji,jj,1) * tmask(ji+1,jj,1) * tmask(ji,jj+1,1) * tmask(ji+1,jj+1,1) 
    185          END DO 
    186       END DO 
     183      DO_2D_10_10 
     184         zfmask(ji,jj) = tmask(ji,jj,1) * tmask(ji+1,jj,1) * tmask(ji,jj+1,1) * tmask(ji+1,jj+1,1) 
     185      END_2D 
    187186      CALL lbc_lnk( 'icedyn_rhg_evp', zfmask, 'F', 1._wp ) 
    188187 
    189188      ! Lateral boundary conditions on velocity (modify zfmask) 
    190189      zwf(:,:) = zfmask(:,:) 
    191       DO jj = 2, jpjm1 
    192          DO ji = fs_2, fs_jpim1   ! vector opt. 
    193             IF( zfmask(ji,jj) == 0._wp ) THEN 
    194                zfmask(ji,jj) = rn_ishlat * MIN( 1._wp , MAX( zwf(ji+1,jj), zwf(ji,jj+1), zwf(ji-1,jj), zwf(ji,jj-1) ) ) 
    195             ENDIF 
    196          END DO 
    197       END DO 
     190      DO_2D_00_00 
     191         IF( zfmask(ji,jj) == 0._wp ) THEN 
     192            zfmask(ji,jj) = rn_ishlat * MIN( 1._wp , MAX( zwf(ji+1,jj), zwf(ji,jj+1), zwf(ji-1,jj), zwf(ji,jj-1) ) ) 
     193         ENDIF 
     194      END_2D 
    198195      DO jj = 2, jpjm1 
    199196         IF( zfmask(1,jj) == 0._wp ) THEN 
     
    257254      zsshdyn(:,:) = ice_var_sshdyn( ssh_m, snwice_mass, snwice_mass_b) 
    258255 
    259       DO jj = 2, jpjm1 
    260          DO ji = fs_2, fs_jpim1 
    261  
    262             ! ice fraction at U-V points 
    263             zaU(ji,jj) = 0.5_wp * ( at_i(ji,jj) * e1e2t(ji,jj) + at_i(ji+1,jj) * e1e2t(ji+1,jj) ) * r1_e1e2u(ji,jj) * umask(ji,jj,1) 
    264             zaV(ji,jj) = 0.5_wp * ( at_i(ji,jj) * e1e2t(ji,jj) + at_i(ji,jj+1) * e1e2t(ji,jj+1) ) * r1_e1e2v(ji,jj) * vmask(ji,jj,1) 
    265  
    266             ! Ice/snow mass at U-V points 
    267             zm1 = ( rhos * vt_s(ji  ,jj  ) + rhoi * vt_i(ji  ,jj  ) ) 
    268             zm2 = ( rhos * vt_s(ji+1,jj  ) + rhoi * vt_i(ji+1,jj  ) ) 
    269             zm3 = ( rhos * vt_s(ji  ,jj+1) + rhoi * vt_i(ji  ,jj+1) ) 
    270             zmassU = 0.5_wp * ( zm1 * e1e2t(ji,jj) + zm2 * e1e2t(ji+1,jj) ) * r1_e1e2u(ji,jj) * umask(ji,jj,1) 
    271             zmassV = 0.5_wp * ( zm1 * e1e2t(ji,jj) + zm3 * e1e2t(ji,jj+1) ) * r1_e1e2v(ji,jj) * vmask(ji,jj,1) 
    272  
    273             ! Ocean currents at U-V points 
    274             v_oceU(ji,jj)   = 0.25_wp * ( v_oce(ji,jj) + v_oce(ji,jj-1) + v_oce(ji+1,jj) + v_oce(ji+1,jj-1) ) * umask(ji,jj,1) 
    275             u_oceV(ji,jj)   = 0.25_wp * ( u_oce(ji,jj) + u_oce(ji-1,jj) + u_oce(ji,jj+1) + u_oce(ji-1,jj+1) ) * vmask(ji,jj,1) 
    276  
    277             ! Coriolis at T points (m*f) 
    278             zmf(ji,jj)      = zm1 * ff_t(ji,jj) 
    279  
    280             ! dt/m at T points (for alpha and beta coefficients) 
    281             zdt_m(ji,jj)    = zdtevp / MAX( zm1, zmmin ) 
    282              
    283             ! m/dt 
    284             zmU_t(ji,jj)    = zmassU * z1_dtevp 
    285             zmV_t(ji,jj)    = zmassV * z1_dtevp 
    286              
    287             ! Drag ice-atm. 
    288             ztaux_ai(ji,jj) = zaU(ji,jj) * utau_ice(ji,jj) 
    289             ztauy_ai(ji,jj) = zaV(ji,jj) * vtau_ice(ji,jj) 
    290  
    291             ! Surface pressure gradient (- m*g*GRAD(ssh)) at U-V points 
    292             zspgU(ji,jj)    = - zmassU * grav * ( zsshdyn(ji+1,jj) - zsshdyn(ji,jj) ) * r1_e1u(ji,jj) 
    293             zspgV(ji,jj)    = - zmassV * grav * ( zsshdyn(ji,jj+1) - zsshdyn(ji,jj) ) * r1_e2v(ji,jj) 
    294  
    295             ! masks 
    296             zmsk00x(ji,jj) = 1._wp - MAX( 0._wp, SIGN( 1._wp, -zmassU ) )  ! 0 if no ice 
    297             zmsk00y(ji,jj) = 1._wp - MAX( 0._wp, SIGN( 1._wp, -zmassV ) )  ! 0 if no ice 
    298  
    299             ! switches 
    300             IF( zmassU <= zmmin .AND. zaU(ji,jj) <= zamin ) THEN   ;   zmsk01x(ji,jj) = 0._wp 
    301             ELSE                                                   ;   zmsk01x(ji,jj) = 1._wp   ;   ENDIF 
    302             IF( zmassV <= zmmin .AND. zaV(ji,jj) <= zamin ) THEN   ;   zmsk01y(ji,jj) = 0._wp 
    303             ELSE                                                   ;   zmsk01y(ji,jj) = 1._wp   ;   ENDIF 
    304  
    305          END DO 
    306       END DO 
     256      DO_2D_00_00 
     257 
     258         ! ice fraction at U-V points 
     259         zaU(ji,jj) = 0.5_wp * ( at_i(ji,jj) * e1e2t(ji,jj) + at_i(ji+1,jj) * e1e2t(ji+1,jj) ) * r1_e1e2u(ji,jj) * umask(ji,jj,1) 
     260         zaV(ji,jj) = 0.5_wp * ( at_i(ji,jj) * e1e2t(ji,jj) + at_i(ji,jj+1) * e1e2t(ji,jj+1) ) * r1_e1e2v(ji,jj) * vmask(ji,jj,1) 
     261 
     262         ! Ice/snow mass at U-V points 
     263         zm1 = ( rhos * vt_s(ji  ,jj  ) + rhoi * vt_i(ji  ,jj  ) ) 
     264         zm2 = ( rhos * vt_s(ji+1,jj  ) + rhoi * vt_i(ji+1,jj  ) ) 
     265         zm3 = ( rhos * vt_s(ji  ,jj+1) + rhoi * vt_i(ji  ,jj+1) ) 
     266         zmassU = 0.5_wp * ( zm1 * e1e2t(ji,jj) + zm2 * e1e2t(ji+1,jj) ) * r1_e1e2u(ji,jj) * umask(ji,jj,1) 
     267         zmassV = 0.5_wp * ( zm1 * e1e2t(ji,jj) + zm3 * e1e2t(ji,jj+1) ) * r1_e1e2v(ji,jj) * vmask(ji,jj,1) 
     268 
     269         ! Ocean currents at U-V points 
     270         v_oceU(ji,jj)   = 0.25_wp * ( v_oce(ji,jj) + v_oce(ji,jj-1) + v_oce(ji+1,jj) + v_oce(ji+1,jj-1) ) * umask(ji,jj,1) 
     271         u_oceV(ji,jj)   = 0.25_wp * ( u_oce(ji,jj) + u_oce(ji-1,jj) + u_oce(ji,jj+1) + u_oce(ji-1,jj+1) ) * vmask(ji,jj,1) 
     272 
     273         ! Coriolis at T points (m*f) 
     274         zmf(ji,jj)      = zm1 * ff_t(ji,jj) 
     275 
     276         ! dt/m at T points (for alpha and beta coefficients) 
     277         zdt_m(ji,jj)    = zdtevp / MAX( zm1, zmmin ) 
     278          
     279         ! m/dt 
     280         zmU_t(ji,jj)    = zmassU * z1_dtevp 
     281         zmV_t(ji,jj)    = zmassV * z1_dtevp 
     282          
     283         ! Drag ice-atm. 
     284         ztaux_ai(ji,jj) = zaU(ji,jj) * utau_ice(ji,jj) 
     285         ztauy_ai(ji,jj) = zaV(ji,jj) * vtau_ice(ji,jj) 
     286 
     287         ! Surface pressure gradient (- m*g*GRAD(ssh)) at U-V points 
     288         zspgU(ji,jj)    = - zmassU * grav * ( zsshdyn(ji+1,jj) - zsshdyn(ji,jj) ) * r1_e1u(ji,jj) 
     289         zspgV(ji,jj)    = - zmassV * grav * ( zsshdyn(ji,jj+1) - zsshdyn(ji,jj) ) * r1_e2v(ji,jj) 
     290 
     291         ! masks 
     292         zmsk00x(ji,jj) = 1._wp - MAX( 0._wp, SIGN( 1._wp, -zmassU ) )  ! 0 if no ice 
     293         zmsk00y(ji,jj) = 1._wp - MAX( 0._wp, SIGN( 1._wp, -zmassV ) )  ! 0 if no ice 
     294 
     295         ! switches 
     296         IF( zmassU <= zmmin .AND. zaU(ji,jj) <= zamin ) THEN   ;   zmsk01x(ji,jj) = 0._wp 
     297         ELSE                                                   ;   zmsk01x(ji,jj) = 1._wp   ;   ENDIF 
     298         IF( zmassV <= zmmin .AND. zaV(ji,jj) <= zamin ) THEN   ;   zmsk01y(ji,jj) = 0._wp 
     299         ELSE                                                   ;   zmsk01y(ji,jj) = 1._wp   ;   ENDIF 
     300 
     301      END_2D 
    307302      CALL lbc_lnk_multi( 'icedyn_rhg_evp', zmf, 'T', 1., zdt_m, 'T', 1. ) 
    308303      ! 
     
    310305      ! 
    311306      IF( ln_landfast_L16 ) THEN         !-- Lemieux 2016 
    312          DO jj = 2, jpjm1 
    313             DO ji = fs_2, fs_jpim1 
    314                ! ice thickness at U-V points 
    315                zvU = 0.5_wp * ( vt_i(ji,jj) * e1e2t(ji,jj) + vt_i(ji+1,jj) * e1e2t(ji+1,jj) ) * r1_e1e2u(ji,jj) * umask(ji,jj,1) 
    316                zvV = 0.5_wp * ( vt_i(ji,jj) * e1e2t(ji,jj) + vt_i(ji,jj+1) * e1e2t(ji,jj+1) ) * r1_e1e2v(ji,jj) * vmask(ji,jj,1) 
    317                ! ice-bottom stress at U points 
    318                zvCr = zaU(ji,jj) * rn_depfra * hu(ji,jj,Kmm) 
    319                ztaux_base(ji,jj) = - rn_icebfr * MAX( 0._wp, zvU - zvCr ) * EXP( -rn_crhg * ( 1._wp - zaU(ji,jj) ) ) 
    320                ! ice-bottom stress at V points 
    321                zvCr = zaV(ji,jj) * rn_depfra * hv(ji,jj,Kmm) 
    322                ztauy_base(ji,jj) = - rn_icebfr * MAX( 0._wp, zvV - zvCr ) * EXP( -rn_crhg * ( 1._wp - zaV(ji,jj) ) ) 
    323                ! ice_bottom stress at T points 
    324                zvCr = at_i(ji,jj) * rn_depfra * ht(ji,jj) 
    325                tau_icebfr(ji,jj) = - rn_icebfr * MAX( 0._wp, vt_i(ji,jj) - zvCr ) * EXP( -rn_crhg * ( 1._wp - at_i(ji,jj) ) ) 
    326             END DO 
    327          END DO 
     307         DO_2D_00_00 
     308            ! ice thickness at U-V points 
     309            zvU = 0.5_wp * ( vt_i(ji,jj) * e1e2t(ji,jj) + vt_i(ji+1,jj) * e1e2t(ji+1,jj) ) * r1_e1e2u(ji,jj) * umask(ji,jj,1) 
     310            zvV = 0.5_wp * ( vt_i(ji,jj) * e1e2t(ji,jj) + vt_i(ji,jj+1) * e1e2t(ji,jj+1) ) * r1_e1e2v(ji,jj) * vmask(ji,jj,1) 
     311            ! ice-bottom stress at U points 
     312            zvCr = zaU(ji,jj) * rn_depfra * hu(ji,jj,Kmm) 
     313            ztaux_base(ji,jj) = - rn_icebfr * MAX( 0._wp, zvU - zvCr ) * EXP( -rn_crhg * ( 1._wp - zaU(ji,jj) ) ) 
     314            ! ice-bottom stress at V points 
     315            zvCr = zaV(ji,jj) * rn_depfra * hv(ji,jj,Kmm) 
     316            ztauy_base(ji,jj) = - rn_icebfr * MAX( 0._wp, zvV - zvCr ) * EXP( -rn_crhg * ( 1._wp - zaV(ji,jj) ) ) 
     317            ! ice_bottom stress at T points 
     318            zvCr = at_i(ji,jj) * rn_depfra * ht(ji,jj) 
     319            tau_icebfr(ji,jj) = - rn_icebfr * MAX( 0._wp, vt_i(ji,jj) - zvCr ) * EXP( -rn_crhg * ( 1._wp - at_i(ji,jj) ) ) 
     320         END_2D 
    328321         CALL lbc_lnk( 'icedyn_rhg_evp', tau_icebfr(:,:), 'T', 1. ) 
    329322         ! 
    330323      ELSE                               !-- no landfast 
    331          DO jj = 2, jpjm1 
    332             DO ji = fs_2, fs_jpim1 
    333                ztaux_base(ji,jj) = 0._wp 
    334                ztauy_base(ji,jj) = 0._wp 
    335             END DO 
    336          END DO 
     324         DO_2D_00_00 
     325            ztaux_base(ji,jj) = 0._wp 
     326            ztauy_base(ji,jj) = 0._wp 
     327         END_2D 
    337328      ENDIF 
    338329 
     
    354345 
    355346         ! --- divergence, tension & shear (Appendix B of Hunke & Dukowicz, 2002) --- ! 
    356          DO jj = 1, jpjm1         ! loops start at 1 since there is no boundary condition (lbc_lnk) at i=1 and j=1 for F points 
    357             DO ji = 1, jpim1 
    358  
    359                ! shear at F points 
    360                zds(ji,jj) = ( ( u_ice(ji,jj+1) * r1_e1u(ji,jj+1) - u_ice(ji,jj) * r1_e1u(ji,jj) ) * e1f(ji,jj) * e1f(ji,jj)   & 
    361                   &         + ( v_ice(ji+1,jj) * r1_e2v(ji+1,jj) - v_ice(ji,jj) * r1_e2v(ji,jj) ) * e2f(ji,jj) * e2f(ji,jj)   & 
    362                   &         ) * r1_e1e2f(ji,jj) * zfmask(ji,jj) 
    363  
    364             END DO 
    365          END DO 
     347         DO_2D_10_10 
     348 
     349            ! shear at F points 
     350            zds(ji,jj) = ( ( u_ice(ji,jj+1) * r1_e1u(ji,jj+1) - u_ice(ji,jj) * r1_e1u(ji,jj) ) * e1f(ji,jj) * e1f(ji,jj)   & 
     351               &         + ( v_ice(ji+1,jj) * r1_e2v(ji+1,jj) - v_ice(ji,jj) * r1_e2v(ji,jj) ) * e2f(ji,jj) * e2f(ji,jj)   & 
     352               &         ) * r1_e1e2f(ji,jj) * zfmask(ji,jj) 
     353 
     354         END_2D 
    366355         CALL lbc_lnk( 'icedyn_rhg_evp', zds, 'F', 1. ) 
    367356 
    368          DO jj = 2, jpj    ! loop to jpi,jpj to avoid making a communication for zs1,zs2,zs12 
    369             DO ji = 2, jpi ! no vector loop 
    370  
    371                ! shear**2 at T points (doc eq. A16) 
    372                zds2 = ( zds(ji,jj  ) * zds(ji,jj  ) * e1e2f(ji,jj  ) + zds(ji-1,jj  ) * zds(ji-1,jj  ) * e1e2f(ji-1,jj  )  & 
    373                   &   + zds(ji,jj-1) * zds(ji,jj-1) * e1e2f(ji,jj-1) + zds(ji-1,jj-1) * zds(ji-1,jj-1) * e1e2f(ji-1,jj-1)  & 
    374                   &   ) * 0.25_wp * r1_e1e2t(ji,jj) 
    375                
    376                ! divergence at T points 
    377                zdiv  = ( e2u(ji,jj) * u_ice(ji,jj) - e2u(ji-1,jj) * u_ice(ji-1,jj)   & 
    378                   &    + e1v(ji,jj) * v_ice(ji,jj) - e1v(ji,jj-1) * v_ice(ji,jj-1)   & 
    379                   &    ) * r1_e1e2t(ji,jj) 
    380                zdiv2 = zdiv * zdiv 
    381                 
    382                ! tension at T points 
    383                zdt  = ( ( u_ice(ji,jj) * r1_e2u(ji,jj) - u_ice(ji-1,jj) * r1_e2u(ji-1,jj) ) * e2t(ji,jj) * e2t(ji,jj)   & 
    384                   &   - ( v_ice(ji,jj) * r1_e1v(ji,jj) - v_ice(ji,jj-1) * r1_e1v(ji,jj-1) ) * e1t(ji,jj) * e1t(ji,jj)   & 
    385                   &   ) * r1_e1e2t(ji,jj) 
    386                zdt2 = zdt * zdt 
    387                 
    388                ! delta at T points 
    389                zdelta = SQRT( zdiv2 + ( zdt2 + zds2 ) * z1_ecc2 )   
    390  
    391                ! P/delta at T points 
    392                zp_delt(ji,jj) = strength(ji,jj) / ( zdelta + rn_creepl ) 
    393  
    394                ! alpha & beta for aEVP 
    395                !   gamma = 0.5*P/(delta+creepl) * (c*pi)**2/Area * dt/m 
    396                !   alpha = beta = sqrt(4*gamma) 
    397                IF( ln_aEVP ) THEN 
    398                   zalph1   = MAX( 50._wp, rpi * SQRT( 0.5_wp * zp_delt(ji,jj) * r1_e1e2t(ji,jj) * zdt_m(ji,jj) ) ) 
    399                   z1_alph1 = 1._wp / ( zalph1 + 1._wp ) 
    400                   zalph2   = zalph1 
    401                   z1_alph2 = z1_alph1 
    402                ENDIF 
    403                 
    404                ! stress at T points (zkt/=0 if landfast) 
    405                zs1(ji,jj) = ( zs1(ji,jj) * zalph1 + zp_delt(ji,jj) * ( zdiv * (1._wp + zkt) - zdelta * (1._wp - zkt) ) ) * z1_alph1 
    406                zs2(ji,jj) = ( zs2(ji,jj) * zalph2 + zp_delt(ji,jj) * ( zdt * z1_ecc2 * (1._wp + zkt) ) ) * z1_alph2 
    407               
    408             END DO 
    409          END DO 
     357         DO_2D_01_01 
     358 
     359            ! shear**2 at T points (doc eq. A16) 
     360            zds2 = ( zds(ji,jj  ) * zds(ji,jj  ) * e1e2f(ji,jj  ) + zds(ji-1,jj  ) * zds(ji-1,jj  ) * e1e2f(ji-1,jj  )  & 
     361               &   + zds(ji,jj-1) * zds(ji,jj-1) * e1e2f(ji,jj-1) + zds(ji-1,jj-1) * zds(ji-1,jj-1) * e1e2f(ji-1,jj-1)  & 
     362               &   ) * 0.25_wp * r1_e1e2t(ji,jj) 
     363            
     364            ! divergence at T points 
     365            zdiv  = ( e2u(ji,jj) * u_ice(ji,jj) - e2u(ji-1,jj) * u_ice(ji-1,jj)   & 
     366               &    + e1v(ji,jj) * v_ice(ji,jj) - e1v(ji,jj-1) * v_ice(ji,jj-1)   & 
     367               &    ) * r1_e1e2t(ji,jj) 
     368            zdiv2 = zdiv * zdiv 
     369             
     370            ! tension at T points 
     371            zdt  = ( ( u_ice(ji,jj) * r1_e2u(ji,jj) - u_ice(ji-1,jj) * r1_e2u(ji-1,jj) ) * e2t(ji,jj) * e2t(ji,jj)   & 
     372               &   - ( v_ice(ji,jj) * r1_e1v(ji,jj) - v_ice(ji,jj-1) * r1_e1v(ji,jj-1) ) * e1t(ji,jj) * e1t(ji,jj)   & 
     373               &   ) * r1_e1e2t(ji,jj) 
     374            zdt2 = zdt * zdt 
     375             
     376            ! delta at T points 
     377            zdelta = SQRT( zdiv2 + ( zdt2 + zds2 ) * z1_ecc2 )   
     378 
     379            ! P/delta at T points 
     380            zp_delt(ji,jj) = strength(ji,jj) / ( zdelta + rn_creepl ) 
     381 
     382            ! alpha & beta for aEVP 
     383            !   gamma = 0.5*P/(delta+creepl) * (c*pi)**2/Area * dt/m 
     384            !   alpha = beta = sqrt(4*gamma) 
     385            IF( ln_aEVP ) THEN 
     386               zalph1   = MAX( 50._wp, rpi * SQRT( 0.5_wp * zp_delt(ji,jj) * r1_e1e2t(ji,jj) * zdt_m(ji,jj) ) ) 
     387               z1_alph1 = 1._wp / ( zalph1 + 1._wp ) 
     388               zalph2   = zalph1 
     389               z1_alph2 = z1_alph1 
     390            ENDIF 
     391             
     392            ! stress at T points (zkt/=0 if landfast) 
     393            zs1(ji,jj) = ( zs1(ji,jj) * zalph1 + zp_delt(ji,jj) * ( zdiv * (1._wp + zkt) - zdelta * (1._wp - zkt) ) ) * z1_alph1 
     394            zs2(ji,jj) = ( zs2(ji,jj) * zalph2 + zp_delt(ji,jj) * ( zdt * z1_ecc2 * (1._wp + zkt) ) ) * z1_alph2 
     395           
     396         END_2D 
    410397         CALL lbc_lnk( 'icedyn_rhg_evp', zp_delt, 'T', 1. ) 
    411398 
    412          DO jj = 1, jpjm1 
    413             DO ji = 1, jpim1 
    414  
    415                ! alpha & beta for aEVP 
    416                IF( ln_aEVP ) THEN 
    417                   zalph2   = MAX( 50._wp, rpi * SQRT( 0.5_wp * zp_delt(ji,jj) * r1_e1e2t(ji,jj) * zdt_m(ji,jj) ) ) 
    418                   z1_alph2 = 1._wp / ( zalph2 + 1._wp ) 
    419                   zbeta(ji,jj) = zalph2 
    420                ENDIF 
    421                 
    422                ! P/delta at F points 
    423                zp_delf = 0.25_wp * ( zp_delt(ji,jj) + zp_delt(ji+1,jj) + zp_delt(ji,jj+1) + zp_delt(ji+1,jj+1) ) 
    424                 
    425                ! stress at F points (zkt/=0 if landfast) 
    426                zs12(ji,jj)= ( zs12(ji,jj) * zalph2 + zp_delf * ( zds(ji,jj) * z1_ecc2 * (1._wp + zkt) ) * 0.5_wp ) * z1_alph2 
    427  
    428             END DO 
    429          END DO 
     399         DO_2D_10_10 
     400 
     401            ! alpha & beta for aEVP 
     402            IF( ln_aEVP ) THEN 
     403               zalph2   = MAX( 50._wp, rpi * SQRT( 0.5_wp * zp_delt(ji,jj) * r1_e1e2t(ji,jj) * zdt_m(ji,jj) ) ) 
     404               z1_alph2 = 1._wp / ( zalph2 + 1._wp ) 
     405               zbeta(ji,jj) = zalph2 
     406            ENDIF 
     407             
     408            ! P/delta at F points 
     409            zp_delf = 0.25_wp * ( zp_delt(ji,jj) + zp_delt(ji+1,jj) + zp_delt(ji,jj+1) + zp_delt(ji+1,jj+1) ) 
     410             
     411            ! stress at F points (zkt/=0 if landfast) 
     412            zs12(ji,jj)= ( zs12(ji,jj) * zalph2 + zp_delf * ( zds(ji,jj) * z1_ecc2 * (1._wp + zkt) ) * 0.5_wp ) * z1_alph2 
     413 
     414         END_2D 
    430415 
    431416         ! --- Ice internal stresses (Appendix C of Hunke and Dukowicz, 2002) --- ! 
    432          DO jj = 2, jpjm1 
    433             DO ji = fs_2, fs_jpim1                
    434                !                   !--- U points 
    435                zfU(ji,jj) = 0.5_wp * ( ( zs1(ji+1,jj) - zs1(ji,jj) ) * e2u(ji,jj)                                             & 
    436                   &                  + ( zs2(ji+1,jj) * e2t(ji+1,jj) * e2t(ji+1,jj) - zs2(ji,jj) * e2t(ji,jj) * e2t(ji,jj)    & 
    437                   &                    ) * r1_e2u(ji,jj)                                                                      & 
    438                   &                  + ( zs12(ji,jj) * e1f(ji,jj) * e1f(ji,jj) - zs12(ji,jj-1) * e1f(ji,jj-1) * e1f(ji,jj-1)  & 
    439                   &                    ) * 2._wp * r1_e1u(ji,jj)                                                              & 
    440                   &                  ) * r1_e1e2u(ji,jj) 
    441                ! 
    442                !                !--- V points 
    443                zfV(ji,jj) = 0.5_wp * ( ( zs1(ji,jj+1) - zs1(ji,jj) ) * e1v(ji,jj)                                             & 
    444                   &                  - ( zs2(ji,jj+1) * e1t(ji,jj+1) * e1t(ji,jj+1) - zs2(ji,jj) * e1t(ji,jj) * e1t(ji,jj)    & 
    445                   &                    ) * r1_e1v(ji,jj)                                                                      & 
    446                   &                  + ( zs12(ji,jj) * e2f(ji,jj) * e2f(ji,jj) - zs12(ji-1,jj) * e2f(ji-1,jj) * e2f(ji-1,jj)  & 
    447                   &                    ) * 2._wp * r1_e2v(ji,jj)                                                              & 
    448                   &                  ) * r1_e1e2v(ji,jj) 
    449                ! 
    450                !                !--- ice currents at U-V point 
    451                v_iceU(ji,jj) = 0.25_wp * ( v_ice(ji,jj) + v_ice(ji,jj-1) + v_ice(ji+1,jj) + v_ice(ji+1,jj-1) ) * umask(ji,jj,1) 
    452                u_iceV(ji,jj) = 0.25_wp * ( u_ice(ji,jj) + u_ice(ji-1,jj) + u_ice(ji,jj+1) + u_ice(ji-1,jj+1) ) * vmask(ji,jj,1) 
    453                ! 
    454             END DO 
    455          END DO 
     417         DO_2D_00_00 
     418            !                   !--- U points 
     419            zfU(ji,jj) = 0.5_wp * ( ( zs1(ji+1,jj) - zs1(ji,jj) ) * e2u(ji,jj)                                             & 
     420               &                  + ( zs2(ji+1,jj) * e2t(ji+1,jj) * e2t(ji+1,jj) - zs2(ji,jj) * e2t(ji,jj) * e2t(ji,jj)    & 
     421               &                    ) * r1_e2u(ji,jj)                                                                      & 
     422               &                  + ( zs12(ji,jj) * e1f(ji,jj) * e1f(ji,jj) - zs12(ji,jj-1) * e1f(ji,jj-1) * e1f(ji,jj-1)  & 
     423               &                    ) * 2._wp * r1_e1u(ji,jj)                                                              & 
     424               &                  ) * r1_e1e2u(ji,jj) 
     425            ! 
     426            !                !--- V points 
     427            zfV(ji,jj) = 0.5_wp * ( ( zs1(ji,jj+1) - zs1(ji,jj) ) * e1v(ji,jj)                                             & 
     428               &                  - ( zs2(ji,jj+1) * e1t(ji,jj+1) * e1t(ji,jj+1) - zs2(ji,jj) * e1t(ji,jj) * e1t(ji,jj)    & 
     429               &                    ) * r1_e1v(ji,jj)                                                                      & 
     430               &                  + ( zs12(ji,jj) * e2f(ji,jj) * e2f(ji,jj) - zs12(ji-1,jj) * e2f(ji-1,jj) * e2f(ji-1,jj)  & 
     431               &                    ) * 2._wp * r1_e2v(ji,jj)                                                              & 
     432               &                  ) * r1_e1e2v(ji,jj) 
     433            ! 
     434            !                !--- ice currents at U-V point 
     435            v_iceU(ji,jj) = 0.25_wp * ( v_ice(ji,jj) + v_ice(ji,jj-1) + v_ice(ji+1,jj) + v_ice(ji+1,jj-1) ) * umask(ji,jj,1) 
     436            u_iceV(ji,jj) = 0.25_wp * ( u_ice(ji,jj) + u_ice(ji-1,jj) + u_ice(ji,jj+1) + u_ice(ji-1,jj+1) ) * vmask(ji,jj,1) 
     437            ! 
     438         END_2D 
    456439         ! 
    457440         ! --- Computation of ice velocity --- ! 
     
    460443         IF( MOD(jter,2) == 0 ) THEN ! even iterations 
    461444            ! 
    462             DO jj = 2, jpjm1 
    463                DO ji = fs_2, fs_jpim1 
    464                   !                 !--- tau_io/(v_oce - v_ice) 
    465                   zTauO = zaV(ji,jj) * zrhoco * SQRT( ( v_ice (ji,jj) - v_oce (ji,jj) ) * ( v_ice (ji,jj) - v_oce (ji,jj) )  & 
    466                      &                              + ( u_iceV(ji,jj) - u_oceV(ji,jj) ) * ( u_iceV(ji,jj) - u_oceV(ji,jj) ) ) 
    467                   !                 !--- Ocean-to-Ice stress 
    468                   ztauy_oi(ji,jj) = zTauO * ( v_oce(ji,jj) - v_ice(ji,jj) ) 
    469                   ! 
    470                   !                 !--- tau_bottom/v_ice 
    471                   zvel  = 5.e-05_wp + SQRT( v_ice(ji,jj) * v_ice(ji,jj) + u_iceV(ji,jj) * u_iceV(ji,jj) ) 
    472                   zTauB = ztauy_base(ji,jj) / zvel 
    473                   !                 !--- OceanBottom-to-Ice stress 
    474                   ztauy_bi(ji,jj) = zTauB * v_ice(ji,jj) 
    475                   ! 
    476                   !                 !--- Coriolis at V-points (energy conserving formulation) 
    477                   zCorV(ji,jj)  = - 0.25_wp * r1_e2v(ji,jj) *  & 
    478                      &    ( zmf(ji,jj  ) * ( e2u(ji,jj  ) * u_ice(ji,jj  ) + e2u(ji-1,jj  ) * u_ice(ji-1,jj  ) )  & 
    479                      &    + zmf(ji,jj+1) * ( e2u(ji,jj+1) * u_ice(ji,jj+1) + e2u(ji-1,jj+1) * u_ice(ji-1,jj+1) ) ) 
    480                   ! 
    481                   !                 !--- Sum of external forces (explicit solution) = F + tau_ia + Coriolis + spg + tau_io 
    482                   zRHS = zfV(ji,jj) + ztauy_ai(ji,jj) + zCorV(ji,jj) + zspgV(ji,jj) + ztauy_oi(ji,jj) 
    483                   ! 
    484                   !                 !--- landfast switch => 0 = static  friction : TauB > RHS & sign(TauB) /= sign(RHS) 
    485                   !                                         1 = sliding friction : TauB < RHS 
    486                   rswitch = 1._wp - MIN( 1._wp, ABS( SIGN( 1._wp, zRHS + ztauy_base(ji,jj) ) - SIGN( 1._wp, zRHS ) ) ) 
    487                   ! 
    488                   IF( ln_aEVP ) THEN !--- ice velocity using aEVP (Kimmritz et al 2016 & 2017) 
    489                      v_ice(ji,jj) = ( (          rswitch * ( zmV_t(ji,jj) * ( zbeta(ji,jj) * v_ice(ji,jj) + v_ice_b(ji,jj) )       & ! previous velocity 
    490                         &                                  + zRHS + zTauO * v_ice(ji,jj) )                                         & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 
    491                         &                                  / MAX( zepsi, zmV_t(ji,jj) * ( zbeta(ji,jj) + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast 
    492                         &               + ( 1._wp - rswitch ) * v_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lfrelax )           & ! static friction => slow decrease to v=0 
    493                         &             ) * zmsk01y(ji,jj) + v_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01y(ji,jj) )                     & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin 
    494                         &           )   * zmsk00y(ji,jj) 
    495                   ELSE               !--- ice velocity using EVP implicit formulation (cf Madec doc & Bouillon 2009) 
    496                      v_ice(ji,jj) = ( (           rswitch   * ( zmV_t(ji,jj)  * v_ice(ji,jj)                                       & ! previous velocity 
    497                         &                                     + zRHS + zTauO * v_ice(ji,jj) )                                      & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 
    498                         &                                     / MAX( zepsi, zmV_t(ji,jj) + zTauO - zTauB )                         & ! m/dt + tau_io(only ice part) + landfast 
    499                         &                + ( 1._wp - rswitch ) * v_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lfrelax )          & ! static friction => slow decrease to v=0 
    500                         &              ) * zmsk01y(ji,jj) + v_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01y(ji,jj) )                    & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin 
    501                         &            )   * zmsk00y(ji,jj) 
    502                   ENDIF 
    503                END DO 
    504             END DO 
     445            DO_2D_00_00 
     446               !                 !--- tau_io/(v_oce - v_ice) 
     447               zTauO = zaV(ji,jj) * zrhoco * SQRT( ( v_ice (ji,jj) - v_oce (ji,jj) ) * ( v_ice (ji,jj) - v_oce (ji,jj) )  & 
     448                  &                              + ( u_iceV(ji,jj) - u_oceV(ji,jj) ) * ( u_iceV(ji,jj) - u_oceV(ji,jj) ) ) 
     449               !                 !--- Ocean-to-Ice stress 
     450               ztauy_oi(ji,jj) = zTauO * ( v_oce(ji,jj) - v_ice(ji,jj) ) 
     451               ! 
     452               !                 !--- tau_bottom/v_ice 
     453               zvel  = 5.e-05_wp + SQRT( v_ice(ji,jj) * v_ice(ji,jj) + u_iceV(ji,jj) * u_iceV(ji,jj) ) 
     454               zTauB = ztauy_base(ji,jj) / zvel 
     455               !                 !--- OceanBottom-to-Ice stress 
     456               ztauy_bi(ji,jj) = zTauB * v_ice(ji,jj) 
     457               ! 
     458               !                 !--- Coriolis at V-points (energy conserving formulation) 
     459               zCorV(ji,jj)  = - 0.25_wp * r1_e2v(ji,jj) *  & 
     460                  &    ( zmf(ji,jj  ) * ( e2u(ji,jj  ) * u_ice(ji,jj  ) + e2u(ji-1,jj  ) * u_ice(ji-1,jj  ) )  & 
     461                  &    + zmf(ji,jj+1) * ( e2u(ji,jj+1) * u_ice(ji,jj+1) + e2u(ji-1,jj+1) * u_ice(ji-1,jj+1) ) ) 
     462               ! 
     463               !                 !--- Sum of external forces (explicit solution) = F + tau_ia + Coriolis + spg + tau_io 
     464               zRHS = zfV(ji,jj) + ztauy_ai(ji,jj) + zCorV(ji,jj) + zspgV(ji,jj) + ztauy_oi(ji,jj) 
     465               ! 
     466               !                 !--- landfast switch => 0 = static  friction : TauB > RHS & sign(TauB) /= sign(RHS) 
     467               !                                         1 = sliding friction : TauB < RHS 
     468               rswitch = 1._wp - MIN( 1._wp, ABS( SIGN( 1._wp, zRHS + ztauy_base(ji,jj) ) - SIGN( 1._wp, zRHS ) ) ) 
     469               ! 
     470               IF( ln_aEVP ) THEN !--- ice velocity using aEVP (Kimmritz et al 2016 & 2017) 
     471                  v_ice(ji,jj) = ( (          rswitch * ( zmV_t(ji,jj) * ( zbeta(ji,jj) * v_ice(ji,jj) + v_ice_b(ji,jj) )       & ! previous velocity 
     472                     &                                  + zRHS + zTauO * v_ice(ji,jj) )                                         & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 
     473                     &                                  / MAX( zepsi, zmV_t(ji,jj) * ( zbeta(ji,jj) + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast 
     474                     &               + ( 1._wp - rswitch ) * v_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lfrelax )           & ! static friction => slow decrease to v=0 
     475                     &             ) * zmsk01y(ji,jj) + v_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01y(ji,jj) )                     & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin 
     476                     &           )   * zmsk00y(ji,jj) 
     477               ELSE               !--- ice velocity using EVP implicit formulation (cf Madec doc & Bouillon 2009) 
     478                  v_ice(ji,jj) = ( (           rswitch   * ( zmV_t(ji,jj)  * v_ice(ji,jj)                                       & ! previous velocity 
     479                     &                                     + zRHS + zTauO * v_ice(ji,jj) )                                      & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 
     480                     &                                     / MAX( zepsi, zmV_t(ji,jj) + zTauO - zTauB )                         & ! m/dt + tau_io(only ice part) + landfast 
     481                     &                + ( 1._wp - rswitch ) * v_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lfrelax )          & ! static friction => slow decrease to v=0 
     482                     &              ) * zmsk01y(ji,jj) + v_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01y(ji,jj) )                    & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin 
     483                     &            )   * zmsk00y(ji,jj) 
     484               ENDIF 
     485            END_2D 
    505486            CALL lbc_lnk( 'icedyn_rhg_evp', v_ice, 'V', -1. ) 
    506487            ! 
     
    511492            IF( ln_bdy )   CALL bdy_ice_dyn( 'V' ) 
    512493            ! 
    513             DO jj = 2, jpjm1 
    514                DO ji = fs_2, fs_jpim1           
    515                   !                 !--- tau_io/(u_oce - u_ice) 
    516                   zTauO = zaU(ji,jj) * zrhoco * SQRT( ( u_ice (ji,jj) - u_oce (ji,jj) ) * ( u_ice (ji,jj) - u_oce (ji,jj) )  & 
    517                      &                              + ( v_iceU(ji,jj) - v_oceU(ji,jj) ) * ( v_iceU(ji,jj) - v_oceU(ji,jj) ) ) 
    518                   !                 !--- Ocean-to-Ice stress 
    519                   ztaux_oi(ji,jj) = zTauO * ( u_oce(ji,jj) - u_ice(ji,jj) ) 
    520                   ! 
    521                   !                 !--- tau_bottom/u_ice 
    522                   zvel  = 5.e-05_wp + SQRT( v_iceU(ji,jj) * v_iceU(ji,jj) + u_ice(ji,jj) * u_ice(ji,jj) ) 
    523                   zTauB = ztaux_base(ji,jj) / zvel 
    524                   !                 !--- OceanBottom-to-Ice stress 
    525                   ztaux_bi(ji,jj) = zTauB * u_ice(ji,jj) 
    526                   ! 
    527                   !                 !--- Coriolis at U-points (energy conserving formulation) 
    528                   zCorU(ji,jj)  =   0.25_wp * r1_e1u(ji,jj) *  & 
    529                      &    ( zmf(ji  ,jj) * ( e1v(ji  ,jj) * v_ice(ji  ,jj) + e1v(ji  ,jj-1) * v_ice(ji  ,jj-1) )  & 
    530                      &    + zmf(ji+1,jj) * ( e1v(ji+1,jj) * v_ice(ji+1,jj) + e1v(ji+1,jj-1) * v_ice(ji+1,jj-1) ) ) 
    531                   ! 
    532                   !                 !--- Sum of external forces (explicit solution) = F + tau_ia + Coriolis + spg + tau_io 
    533                   zRHS = zfU(ji,jj) + ztaux_ai(ji,jj) + zCorU(ji,jj) + zspgU(ji,jj) + ztaux_oi(ji,jj) 
    534                   ! 
    535                   !                 !--- landfast switch => 0 = static  friction : TauB > RHS & sign(TauB) /= sign(RHS) 
    536                   !                                         1 = sliding friction : TauB < RHS 
    537                   rswitch = 1._wp - MIN( 1._wp, ABS( SIGN( 1._wp, zRHS + ztaux_base(ji,jj) ) - SIGN( 1._wp, zRHS ) ) ) 
    538                   ! 
    539                   IF( ln_aEVP ) THEN !--- ice velocity using aEVP (Kimmritz et al 2016 & 2017) 
    540                      u_ice(ji,jj) = ( (          rswitch * ( zmU_t(ji,jj) * ( zbeta(ji,jj) * u_ice(ji,jj) + u_ice_b(ji,jj) )       & ! previous velocity 
    541                         &                                  + zRHS + zTauO * u_ice(ji,jj) )                                         & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 
    542                         &                                  / MAX( zepsi, zmU_t(ji,jj) * ( zbeta(ji,jj) + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast 
    543                         &               + ( 1._wp - rswitch ) * u_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lfrelax )           & ! static friction => slow decrease to v=0 
    544                         &             ) * zmsk01x(ji,jj) + u_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01x(ji,jj) )                     & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin  
    545                         &           )   * zmsk00x(ji,jj) 
    546                   ELSE               !--- ice velocity using EVP implicit formulation (cf Madec doc & Bouillon 2009) 
    547                      u_ice(ji,jj) = ( (           rswitch   * ( zmU_t(ji,jj)  * u_ice(ji,jj)                                       & ! previous velocity 
    548                         &                                     + zRHS + zTauO * u_ice(ji,jj) )                                      & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 
    549                         &                                     / MAX( zepsi, zmU_t(ji,jj) + zTauO - zTauB )                         & ! m/dt + tau_io(only ice part) + landfast 
    550                         &                + ( 1._wp - rswitch ) * u_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lfrelax )          & ! static friction => slow decrease to v=0 
    551                         &              ) * zmsk01x(ji,jj) + u_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01x(ji,jj) )                    & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin  
    552                         &            )   * zmsk00x(ji,jj) 
    553                   ENDIF 
    554                END DO 
    555             END DO 
     494            DO_2D_00_00 
     495               !                 !--- tau_io/(u_oce - u_ice) 
     496               zTauO = zaU(ji,jj) * zrhoco * SQRT( ( u_ice (ji,jj) - u_oce (ji,jj) ) * ( u_ice (ji,jj) - u_oce (ji,jj) )  & 
     497                  &                              + ( v_iceU(ji,jj) - v_oceU(ji,jj) ) * ( v_iceU(ji,jj) - v_oceU(ji,jj) ) ) 
     498               !                 !--- Ocean-to-Ice stress 
     499               ztaux_oi(ji,jj) = zTauO * ( u_oce(ji,jj) - u_ice(ji,jj) ) 
     500               ! 
     501               !                 !--- tau_bottom/u_ice 
     502               zvel  = 5.e-05_wp + SQRT( v_iceU(ji,jj) * v_iceU(ji,jj) + u_ice(ji,jj) * u_ice(ji,jj) ) 
     503               zTauB = ztaux_base(ji,jj) / zvel 
     504               !                 !--- OceanBottom-to-Ice stress 
     505               ztaux_bi(ji,jj) = zTauB * u_ice(ji,jj) 
     506               ! 
     507               !                 !--- Coriolis at U-points (energy conserving formulation) 
     508               zCorU(ji,jj)  =   0.25_wp * r1_e1u(ji,jj) *  & 
     509                  &    ( zmf(ji  ,jj) * ( e1v(ji  ,jj) * v_ice(ji  ,jj) + e1v(ji  ,jj-1) * v_ice(ji  ,jj-1) )  & 
     510                  &    + zmf(ji+1,jj) * ( e1v(ji+1,jj) * v_ice(ji+1,jj) + e1v(ji+1,jj-1) * v_ice(ji+1,jj-1) ) ) 
     511               ! 
     512               !                 !--- Sum of external forces (explicit solution) = F + tau_ia + Coriolis + spg + tau_io 
     513               zRHS = zfU(ji,jj) + ztaux_ai(ji,jj) + zCorU(ji,jj) + zspgU(ji,jj) + ztaux_oi(ji,jj) 
     514               ! 
     515               !                 !--- landfast switch => 0 = static  friction : TauB > RHS & sign(TauB) /= sign(RHS) 
     516               !                                         1 = sliding friction : TauB < RHS 
     517               rswitch = 1._wp - MIN( 1._wp, ABS( SIGN( 1._wp, zRHS + ztaux_base(ji,jj) ) - SIGN( 1._wp, zRHS ) ) ) 
     518               ! 
     519               IF( ln_aEVP ) THEN !--- ice velocity using aEVP (Kimmritz et al 2016 & 2017) 
     520                  u_ice(ji,jj) = ( (          rswitch * ( zmU_t(ji,jj) * ( zbeta(ji,jj) * u_ice(ji,jj) + u_ice_b(ji,jj) )       & ! previous velocity 
     521                     &                                  + zRHS + zTauO * u_ice(ji,jj) )                                         & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 
     522                     &                                  / MAX( zepsi, zmU_t(ji,jj) * ( zbeta(ji,jj) + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast 
     523                     &               + ( 1._wp - rswitch ) * u_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lfrelax )           & ! static friction => slow decrease to v=0 
     524                     &             ) * zmsk01x(ji,jj) + u_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01x(ji,jj) )                     & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin  
     525                     &           )   * zmsk00x(ji,jj) 
     526               ELSE               !--- ice velocity using EVP implicit formulation (cf Madec doc & Bouillon 2009) 
     527                  u_ice(ji,jj) = ( (           rswitch   * ( zmU_t(ji,jj)  * u_ice(ji,jj)                                       & ! previous velocity 
     528                     &                                     + zRHS + zTauO * u_ice(ji,jj) )                                      & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 
     529                     &                                     / MAX( zepsi, zmU_t(ji,jj) + zTauO - zTauB )                         & ! m/dt + tau_io(only ice part) + landfast 
     530                     &                + ( 1._wp - rswitch ) * u_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lfrelax )          & ! static friction => slow decrease to v=0 
     531                     &              ) * zmsk01x(ji,jj) + u_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01x(ji,jj) )                    & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin  
     532                     &            )   * zmsk00x(ji,jj) 
     533               ENDIF 
     534            END_2D 
    556535            CALL lbc_lnk( 'icedyn_rhg_evp', u_ice, 'U', -1. ) 
    557536            ! 
     
    564543         ELSE ! odd iterations 
    565544            ! 
    566             DO jj = 2, jpjm1 
    567                DO ji = fs_2, fs_jpim1 
    568                   !                 !--- tau_io/(u_oce - u_ice) 
    569                   zTauO = zaU(ji,jj) * zrhoco * SQRT( ( u_ice (ji,jj) - u_oce (ji,jj) ) * ( u_ice (ji,jj) - u_oce (ji,jj) )  & 
    570                      &                              + ( v_iceU(ji,jj) - v_oceU(ji,jj) ) * ( v_iceU(ji,jj) - v_oceU(ji,jj) ) ) 
    571                   !                 !--- Ocean-to-Ice stress 
    572                   ztaux_oi(ji,jj) = zTauO * ( u_oce(ji,jj) - u_ice(ji,jj) ) 
    573                   ! 
    574                   !                 !--- tau_bottom/u_ice 
    575                   zvel  = 5.e-05_wp + SQRT( v_iceU(ji,jj) * v_iceU(ji,jj) + u_ice(ji,jj) * u_ice(ji,jj) ) 
    576                   zTauB = ztaux_base(ji,jj) / zvel 
    577                   !                 !--- OceanBottom-to-Ice stress 
    578                   ztaux_bi(ji,jj) = zTauB * u_ice(ji,jj) 
    579                   ! 
    580                   !                 !--- Coriolis at U-points (energy conserving formulation) 
    581                   zCorU(ji,jj)  =   0.25_wp * r1_e1u(ji,jj) *  & 
    582                      &    ( zmf(ji  ,jj) * ( e1v(ji  ,jj) * v_ice(ji  ,jj) + e1v(ji  ,jj-1) * v_ice(ji  ,jj-1) )  & 
    583                      &    + zmf(ji+1,jj) * ( e1v(ji+1,jj) * v_ice(ji+1,jj) + e1v(ji+1,jj-1) * v_ice(ji+1,jj-1) ) ) 
    584                   ! 
    585                   !                 !--- Sum of external forces (explicit solution) = F + tau_ia + Coriolis + spg + tau_io 
    586                   zRHS = zfU(ji,jj) + ztaux_ai(ji,jj) + zCorU(ji,jj) + zspgU(ji,jj) + ztaux_oi(ji,jj) 
    587                   ! 
    588                   !                 !--- landfast switch => 0 = static  friction : TauB > RHS & sign(TauB) /= sign(RHS) 
    589                   !                                         1 = sliding friction : TauB < RHS 
    590                   rswitch = 1._wp - MIN( 1._wp, ABS( SIGN( 1._wp, zRHS + ztaux_base(ji,jj) ) - SIGN( 1._wp, zRHS ) ) ) 
    591                   ! 
    592                   IF( ln_aEVP ) THEN !--- ice velocity using aEVP (Kimmritz et al 2016 & 2017) 
    593                      u_ice(ji,jj) = ( (          rswitch * ( zmU_t(ji,jj) * ( zbeta(ji,jj) * u_ice(ji,jj) + u_ice_b(ji,jj) )       & ! previous velocity 
    594                         &                                  + zRHS + zTauO * u_ice(ji,jj) )                                         & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 
    595                         &                                  / MAX( zepsi, zmU_t(ji,jj) * ( zbeta(ji,jj) + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast 
    596                         &               + ( 1._wp - rswitch ) * u_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lfrelax )           & ! static friction => slow decrease to v=0 
    597                         &             ) * zmsk01x(ji,jj) + u_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01x(ji,jj) )                     & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin  
    598                         &           )   * zmsk00x(ji,jj) 
    599                   ELSE               !--- ice velocity using EVP implicit formulation (cf Madec doc & Bouillon 2009) 
    600                      u_ice(ji,jj) = ( (           rswitch   * ( zmU_t(ji,jj)  * u_ice(ji,jj)                                       & ! previous velocity 
    601                         &                                     + zRHS + zTauO * u_ice(ji,jj) )                                      & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 
    602                         &                                     / MAX( zepsi, zmU_t(ji,jj) + zTauO - zTauB )                         & ! m/dt + tau_io(only ice part) + landfast 
    603                         &                + ( 1._wp - rswitch ) * u_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lfrelax )          & ! static friction => slow decrease to v=0 
    604                         &              ) * zmsk01x(ji,jj) + u_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01x(ji,jj) )                    & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin 
    605                         &            )   * zmsk00x(ji,jj) 
    606                   ENDIF 
    607                END DO 
    608             END DO 
     545            DO_2D_00_00 
     546               !                 !--- tau_io/(u_oce - u_ice) 
     547               zTauO = zaU(ji,jj) * zrhoco * SQRT( ( u_ice (ji,jj) - u_oce (ji,jj) ) * ( u_ice (ji,jj) - u_oce (ji,jj) )  & 
     548                  &                              + ( v_iceU(ji,jj) - v_oceU(ji,jj) ) * ( v_iceU(ji,jj) - v_oceU(ji,jj) ) ) 
     549               !                 !--- Ocean-to-Ice stress 
     550               ztaux_oi(ji,jj) = zTauO * ( u_oce(ji,jj) - u_ice(ji,jj) ) 
     551               ! 
     552               !                 !--- tau_bottom/u_ice 
     553               zvel  = 5.e-05_wp + SQRT( v_iceU(ji,jj) * v_iceU(ji,jj) + u_ice(ji,jj) * u_ice(ji,jj) ) 
     554               zTauB = ztaux_base(ji,jj) / zvel 
     555               !                 !--- OceanBottom-to-Ice stress 
     556               ztaux_bi(ji,jj) = zTauB * u_ice(ji,jj) 
     557               ! 
     558               !                 !--- Coriolis at U-points (energy conserving formulation) 
     559               zCorU(ji,jj)  =   0.25_wp * r1_e1u(ji,jj) *  & 
     560                  &    ( zmf(ji  ,jj) * ( e1v(ji  ,jj) * v_ice(ji  ,jj) + e1v(ji  ,jj-1) * v_ice(ji  ,jj-1) )  & 
     561                  &    + zmf(ji+1,jj) * ( e1v(ji+1,jj) * v_ice(ji+1,jj) + e1v(ji+1,jj-1) * v_ice(ji+1,jj-1) ) ) 
     562               ! 
     563               !                 !--- Sum of external forces (explicit solution) = F + tau_ia + Coriolis + spg + tau_io 
     564               zRHS = zfU(ji,jj) + ztaux_ai(ji,jj) + zCorU(ji,jj) + zspgU(ji,jj) + ztaux_oi(ji,jj) 
     565               ! 
     566               !                 !--- landfast switch => 0 = static  friction : TauB > RHS & sign(TauB) /= sign(RHS) 
     567               !                                         1 = sliding friction : TauB < RHS 
     568               rswitch = 1._wp - MIN( 1._wp, ABS( SIGN( 1._wp, zRHS + ztaux_base(ji,jj) ) - SIGN( 1._wp, zRHS ) ) ) 
     569               ! 
     570               IF( ln_aEVP ) THEN !--- ice velocity using aEVP (Kimmritz et al 2016 & 2017) 
     571                  u_ice(ji,jj) = ( (          rswitch * ( zmU_t(ji,jj) * ( zbeta(ji,jj) * u_ice(ji,jj) + u_ice_b(ji,jj) )       & ! previous velocity 
     572                     &                                  + zRHS + zTauO * u_ice(ji,jj) )                                         & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 
     573                     &                                  / MAX( zepsi, zmU_t(ji,jj) * ( zbeta(ji,jj) + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast 
     574                     &               + ( 1._wp - rswitch ) * u_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lfrelax )           & ! static friction => slow decrease to v=0 
     575                     &             ) * zmsk01x(ji,jj) + u_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01x(ji,jj) )                     & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin  
     576                     &           )   * zmsk00x(ji,jj) 
     577               ELSE               !--- ice velocity using EVP implicit formulation (cf Madec doc & Bouillon 2009) 
     578                  u_ice(ji,jj) = ( (           rswitch   * ( zmU_t(ji,jj)  * u_ice(ji,jj)                                       & ! previous velocity 
     579                     &                                     + zRHS + zTauO * u_ice(ji,jj) )                                      & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 
     580                     &                                     / MAX( zepsi, zmU_t(ji,jj) + zTauO - zTauB )                         & ! m/dt + tau_io(only ice part) + landfast 
     581                     &                + ( 1._wp - rswitch ) * u_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lfrelax )          & ! static friction => slow decrease to v=0 
     582                     &              ) * zmsk01x(ji,jj) + u_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01x(ji,jj) )                    & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin 
     583                     &            )   * zmsk00x(ji,jj) 
     584               ENDIF 
     585            END_2D 
    609586            CALL lbc_lnk( 'icedyn_rhg_evp', u_ice, 'U', -1. ) 
    610587            ! 
     
    615592            IF( ln_bdy )   CALL bdy_ice_dyn( 'U' ) 
    616593            ! 
    617             DO jj = 2, jpjm1 
    618                DO ji = fs_2, fs_jpim1 
    619                   !                 !--- tau_io/(v_oce - v_ice) 
    620                   zTauO = zaV(ji,jj) * zrhoco * SQRT( ( v_ice (ji,jj) - v_oce (ji,jj) ) * ( v_ice (ji,jj) - v_oce (ji,jj) )  & 
    621                      &                              + ( u_iceV(ji,jj) - u_oceV(ji,jj) ) * ( u_iceV(ji,jj) - u_oceV(ji,jj) ) ) 
    622                   !                 !--- Ocean-to-Ice stress 
    623                   ztauy_oi(ji,jj) = zTauO * ( v_oce(ji,jj) - v_ice(ji,jj) ) 
    624                   ! 
    625                   !                 !--- tau_bottom/v_ice 
    626                   zvel  = 5.e-05_wp + SQRT( v_ice(ji,jj) * v_ice(ji,jj) + u_iceV(ji,jj) * u_iceV(ji,jj) ) 
    627                   zTauB = ztauy_base(ji,jj) / zvel 
    628                   !                 !--- OceanBottom-to-Ice stress 
    629                   ztauy_bi(ji,jj) = zTauB * v_ice(ji,jj) 
    630                   ! 
    631                   !                 !--- Coriolis at v-points (energy conserving formulation) 
    632                   zCorV(ji,jj)  = - 0.25_wp * r1_e2v(ji,jj) *  & 
    633                      &    ( zmf(ji,jj  ) * ( e2u(ji,jj  ) * u_ice(ji,jj  ) + e2u(ji-1,jj  ) * u_ice(ji-1,jj  ) )  & 
    634                      &    + zmf(ji,jj+1) * ( e2u(ji,jj+1) * u_ice(ji,jj+1) + e2u(ji-1,jj+1) * u_ice(ji-1,jj+1) ) ) 
    635                   ! 
    636                   !                 !--- Sum of external forces (explicit solution) = F + tau_ia + Coriolis + spg + tau_io 
    637                   zRHS = zfV(ji,jj) + ztauy_ai(ji,jj) + zCorV(ji,jj) + zspgV(ji,jj) + ztauy_oi(ji,jj) 
    638                   ! 
    639                   !                 !--- landfast switch => 0 = static  friction : TauB > RHS & sign(TauB) /= sign(RHS) 
    640                   !                                         1 = sliding friction : TauB < RHS 
    641                   rswitch = 1._wp - MIN( 1._wp, ABS( SIGN( 1._wp, zRHS + ztauy_base(ji,jj) ) - SIGN( 1._wp, zRHS ) ) ) 
    642                   ! 
    643                   IF( ln_aEVP ) THEN !--- ice velocity using aEVP (Kimmritz et al 2016 & 2017) 
    644                      v_ice(ji,jj) = ( (          rswitch * ( zmV_t(ji,jj) * ( zbeta(ji,jj) * v_ice(ji,jj) + v_ice_b(ji,jj) )       & ! previous velocity 
    645                         &                                  + zRHS + zTauO * v_ice(ji,jj) )                                         & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 
    646                         &                                  / MAX( zepsi, zmV_t(ji,jj) * ( zbeta(ji,jj) + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast 
    647                         &               + ( 1._wp - rswitch ) * v_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lfrelax )           & ! static friction => slow decrease to v=0 
    648                         &             ) * zmsk01y(ji,jj) + v_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01y(ji,jj) )                     & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin 
    649                         &           )   * zmsk00y(ji,jj) 
    650                   ELSE               !--- ice velocity using EVP implicit formulation (cf Madec doc & Bouillon 2009) 
    651                      v_ice(ji,jj) = ( (           rswitch   * ( zmV_t(ji,jj)  * v_ice(ji,jj)                                       & ! previous velocity 
    652                         &                                     + zRHS + zTauO * v_ice(ji,jj) )                                      & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 
    653                         &                                     / MAX( zepsi, zmV_t(ji,jj) + zTauO - zTauB )                         & ! m/dt + tau_io(only ice part) + landfast 
    654                         &                + ( 1._wp - rswitch ) * v_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lfrelax )          & ! static friction => slow decrease to v=0 
    655                         &              ) * zmsk01y(ji,jj) + v_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01y(ji,jj) )                    & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin 
    656                         &            )   * zmsk00y(ji,jj) 
    657                   ENDIF 
    658                END DO 
    659             END DO 
     594            DO_2D_00_00 
     595               !                 !--- tau_io/(v_oce - v_ice) 
     596               zTauO = zaV(ji,jj) * zrhoco * SQRT( ( v_ice (ji,jj) - v_oce (ji,jj) ) * ( v_ice (ji,jj) - v_oce (ji,jj) )  & 
     597                  &                              + ( u_iceV(ji,jj) - u_oceV(ji,jj) ) * ( u_iceV(ji,jj) - u_oceV(ji,jj) ) ) 
     598               !                 !--- Ocean-to-Ice stress 
     599               ztauy_oi(ji,jj) = zTauO * ( v_oce(ji,jj) - v_ice(ji,jj) ) 
     600               ! 
     601               !                 !--- tau_bottom/v_ice 
     602               zvel  = 5.e-05_wp + SQRT( v_ice(ji,jj) * v_ice(ji,jj) + u_iceV(ji,jj) * u_iceV(ji,jj) ) 
     603               zTauB = ztauy_base(ji,jj) / zvel 
     604               !                 !--- OceanBottom-to-Ice stress 
     605               ztauy_bi(ji,jj) = zTauB * v_ice(ji,jj) 
     606               ! 
     607               !                 !--- Coriolis at v-points (energy conserving formulation) 
     608               zCorV(ji,jj)  = - 0.25_wp * r1_e2v(ji,jj) *  & 
     609                  &    ( zmf(ji,jj  ) * ( e2u(ji,jj  ) * u_ice(ji,jj  ) + e2u(ji-1,jj  ) * u_ice(ji-1,jj  ) )  & 
     610                  &    + zmf(ji,jj+1) * ( e2u(ji,jj+1) * u_ice(ji,jj+1) + e2u(ji-1,jj+1) * u_ice(ji-1,jj+1) ) ) 
     611               ! 
     612               !                 !--- Sum of external forces (explicit solution) = F + tau_ia + Coriolis + spg + tau_io 
     613               zRHS = zfV(ji,jj) + ztauy_ai(ji,jj) + zCorV(ji,jj) + zspgV(ji,jj) + ztauy_oi(ji,jj) 
     614               ! 
     615               !                 !--- landfast switch => 0 = static  friction : TauB > RHS & sign(TauB) /= sign(RHS) 
     616               !                                         1 = sliding friction : TauB < RHS 
     617               rswitch = 1._wp - MIN( 1._wp, ABS( SIGN( 1._wp, zRHS + ztauy_base(ji,jj) ) - SIGN( 1._wp, zRHS ) ) ) 
     618               ! 
     619               IF( ln_aEVP ) THEN !--- ice velocity using aEVP (Kimmritz et al 2016 & 2017) 
     620                  v_ice(ji,jj) = ( (          rswitch * ( zmV_t(ji,jj) * ( zbeta(ji,jj) * v_ice(ji,jj) + v_ice_b(ji,jj) )       & ! previous velocity 
     621                     &                                  + zRHS + zTauO * v_ice(ji,jj) )                                         & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 
     622                     &                                  / MAX( zepsi, zmV_t(ji,jj) * ( zbeta(ji,jj) + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast 
     623                     &               + ( 1._wp - rswitch ) * v_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lfrelax )           & ! static friction => slow decrease to v=0 
     624                     &             ) * zmsk01y(ji,jj) + v_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01y(ji,jj) )                     & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin 
     625                     &           )   * zmsk00y(ji,jj) 
     626               ELSE               !--- ice velocity using EVP implicit formulation (cf Madec doc & Bouillon 2009) 
     627                  v_ice(ji,jj) = ( (           rswitch   * ( zmV_t(ji,jj)  * v_ice(ji,jj)                                       & ! previous velocity 
     628                     &                                     + zRHS + zTauO * v_ice(ji,jj) )                                      & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 
     629                     &                                     / MAX( zepsi, zmV_t(ji,jj) + zTauO - zTauB )                         & ! m/dt + tau_io(only ice part) + landfast 
     630                     &                + ( 1._wp - rswitch ) * v_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lfrelax )          & ! static friction => slow decrease to v=0 
     631                     &              ) * zmsk01y(ji,jj) + v_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01y(ji,jj) )                    & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin 
     632                     &            )   * zmsk00y(ji,jj) 
     633               ENDIF 
     634            END_2D 
    660635            CALL lbc_lnk( 'icedyn_rhg_evp', v_ice, 'V', -1. ) 
    661636            ! 
     
    683658      ! 4) Recompute delta, shear and div (inputs for mechanical redistribution)  
    684659      !------------------------------------------------------------------------------! 
    685       DO jj = 1, jpjm1 
    686          DO ji = 1, jpim1 
    687  
    688             ! shear at F points 
    689             zds(ji,jj) = ( ( u_ice(ji,jj+1) * r1_e1u(ji,jj+1) - u_ice(ji,jj) * r1_e1u(ji,jj) ) * e1f(ji,jj) * e1f(ji,jj)   & 
    690                &         + ( v_ice(ji+1,jj) * r1_e2v(ji+1,jj) - v_ice(ji,jj) * r1_e2v(ji,jj) ) * e2f(ji,jj) * e2f(ji,jj)   & 
    691                &         ) * r1_e1e2f(ji,jj) * zfmask(ji,jj) 
    692  
    693          END DO 
    694       END DO            
     660      DO_2D_10_10 
     661 
     662         ! shear at F points 
     663         zds(ji,jj) = ( ( u_ice(ji,jj+1) * r1_e1u(ji,jj+1) - u_ice(ji,jj) * r1_e1u(ji,jj) ) * e1f(ji,jj) * e1f(ji,jj)   & 
     664            &         + ( v_ice(ji+1,jj) * r1_e2v(ji+1,jj) - v_ice(ji,jj) * r1_e2v(ji,jj) ) * e2f(ji,jj) * e2f(ji,jj)   & 
     665            &         ) * r1_e1e2f(ji,jj) * zfmask(ji,jj) 
     666 
     667      END_2D 
    695668       
    696       DO jj = 2, jpjm1 
    697          DO ji = 2, jpim1 ! no vector loop 
    698              
    699             ! tension**2 at T points 
    700             zdt  = ( ( u_ice(ji,jj) * r1_e2u(ji,jj) - u_ice(ji-1,jj) * r1_e2u(ji-1,jj) ) * e2t(ji,jj) * e2t(ji,jj)   & 
    701                &   - ( v_ice(ji,jj) * r1_e1v(ji,jj) - v_ice(ji,jj-1) * r1_e1v(ji,jj-1) ) * e1t(ji,jj) * e1t(ji,jj)   & 
    702                &   ) * r1_e1e2t(ji,jj) 
    703             zdt2 = zdt * zdt 
    704              
    705             ! shear**2 at T points (doc eq. A16) 
    706             zds2 = ( zds(ji,jj  ) * zds(ji,jj  ) * e1e2f(ji,jj  ) + zds(ji-1,jj  ) * zds(ji-1,jj  ) * e1e2f(ji-1,jj  )  & 
    707                &   + zds(ji,jj-1) * zds(ji,jj-1) * e1e2f(ji,jj-1) + zds(ji-1,jj-1) * zds(ji-1,jj-1) * e1e2f(ji-1,jj-1)  & 
    708                &   ) * 0.25_wp * r1_e1e2t(ji,jj) 
    709              
    710             ! shear at T points 
    711             pshear_i(ji,jj) = SQRT( zdt2 + zds2 ) 
    712  
    713             ! divergence at T points 
    714             pdivu_i(ji,jj) = ( e2u(ji,jj) * u_ice(ji,jj) - e2u(ji-1,jj) * u_ice(ji-1,jj)   & 
    715                &             + e1v(ji,jj) * v_ice(ji,jj) - e1v(ji,jj-1) * v_ice(ji,jj-1)   & 
    716                &             ) * r1_e1e2t(ji,jj) 
    717              
    718             ! delta at T points 
    719             zdelta         = SQRT( pdivu_i(ji,jj) * pdivu_i(ji,jj) + ( zdt2 + zds2 ) * z1_ecc2 )   
    720             rswitch        = 1._wp - MAX( 0._wp, SIGN( 1._wp, -zdelta ) ) ! 0 if delta=0 
    721             pdelta_i(ji,jj) = zdelta + rn_creepl * rswitch 
    722  
    723          END DO 
    724       END DO 
     669      DO_2D_00_00 
     670          
     671         ! tension**2 at T points 
     672         zdt  = ( ( u_ice(ji,jj) * r1_e2u(ji,jj) - u_ice(ji-1,jj) * r1_e2u(ji-1,jj) ) * e2t(ji,jj) * e2t(ji,jj)   & 
     673            &   - ( v_ice(ji,jj) * r1_e1v(ji,jj) - v_ice(ji,jj-1) * r1_e1v(ji,jj-1) ) * e1t(ji,jj) * e1t(ji,jj)   & 
     674            &   ) * r1_e1e2t(ji,jj) 
     675         zdt2 = zdt * zdt 
     676          
     677         ! shear**2 at T points (doc eq. A16) 
     678         zds2 = ( zds(ji,jj  ) * zds(ji,jj  ) * e1e2f(ji,jj  ) + zds(ji-1,jj  ) * zds(ji-1,jj  ) * e1e2f(ji-1,jj  )  & 
     679            &   + zds(ji,jj-1) * zds(ji,jj-1) * e1e2f(ji,jj-1) + zds(ji-1,jj-1) * zds(ji-1,jj-1) * e1e2f(ji-1,jj-1)  & 
     680            &   ) * 0.25_wp * r1_e1e2t(ji,jj) 
     681          
     682         ! shear at T points 
     683         pshear_i(ji,jj) = SQRT( zdt2 + zds2 ) 
     684 
     685         ! divergence at T points 
     686         pdivu_i(ji,jj) = ( e2u(ji,jj) * u_ice(ji,jj) - e2u(ji-1,jj) * u_ice(ji-1,jj)   & 
     687            &             + e1v(ji,jj) * v_ice(ji,jj) - e1v(ji,jj-1) * v_ice(ji,jj-1)   & 
     688            &             ) * r1_e1e2t(ji,jj) 
     689          
     690         ! delta at T points 
     691         zdelta         = SQRT( pdivu_i(ji,jj) * pdivu_i(ji,jj) + ( zdt2 + zds2 ) * z1_ecc2 )   
     692         rswitch        = 1._wp - MAX( 0._wp, SIGN( 1._wp, -zdelta ) ) ! 0 if delta=0 
     693         pdelta_i(ji,jj) = zdelta + rn_creepl * rswitch 
     694 
     695      END_2D 
    725696      CALL lbc_lnk_multi( 'icedyn_rhg_evp', pshear_i, 'T', 1., pdivu_i, 'T', 1., pdelta_i, 'T', 1. ) 
    726697       
     
    735706      ! 5) diagnostics 
    736707      !------------------------------------------------------------------------------! 
    737       DO jj = 1, jpj 
    738          DO ji = 1, jpi 
    739             zmsk00(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi06 ) ) ! 1 if ice, 0 if no ice 
    740          END DO 
    741       END DO 
     708      DO_2D_11_11 
     709         zmsk00(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi06 ) ) ! 1 if ice, 0 if no ice 
     710      END_2D 
    742711 
    743712      ! --- ice-ocean, ice-atm. & ice-oceanbottom(landfast) stresses --- ! 
     
    766735         ALLOCATE( zsig1(jpi,jpj) , zsig2(jpi,jpj) , zsig3(jpi,jpj) ) 
    767736         !          
    768          DO jj = 2, jpjm1 
    769             DO ji = 2, jpim1 
    770                zdum1 = ( zmsk00(ji-1,jj) * pstress12_i(ji-1,jj) + zmsk00(ji  ,jj-1) * pstress12_i(ji  ,jj-1) +  &  ! stress12_i at T-point 
    771                   &      zmsk00(ji  ,jj) * pstress12_i(ji  ,jj) + zmsk00(ji-1,jj-1) * pstress12_i(ji-1,jj-1) )  & 
    772                   &    / MAX( 1._wp, zmsk00(ji-1,jj) + zmsk00(ji,jj-1) + zmsk00(ji,jj) + zmsk00(ji-1,jj-1) ) 
    773  
    774                zshear = SQRT( pstress2_i(ji,jj) * pstress2_i(ji,jj) + 4._wp * zdum1 * zdum1 ) ! shear stress   
    775  
    776                zdum2 = zmsk00(ji,jj) / MAX( 1._wp, strength(ji,jj) ) 
     737         DO_2D_00_00 
     738            zdum1 = ( zmsk00(ji-1,jj) * pstress12_i(ji-1,jj) + zmsk00(ji  ,jj-1) * pstress12_i(ji  ,jj-1) +  &  ! stress12_i at T-point 
     739               &      zmsk00(ji  ,jj) * pstress12_i(ji  ,jj) + zmsk00(ji-1,jj-1) * pstress12_i(ji-1,jj-1) )  & 
     740               &    / MAX( 1._wp, zmsk00(ji-1,jj) + zmsk00(ji,jj-1) + zmsk00(ji,jj) + zmsk00(ji-1,jj-1) ) 
     741 
     742            zshear = SQRT( pstress2_i(ji,jj) * pstress2_i(ji,jj) + 4._wp * zdum1 * zdum1 ) ! shear stress   
     743 
     744            zdum2 = zmsk00(ji,jj) / MAX( 1._wp, strength(ji,jj) ) 
    777745 
    778746!!               zsig1(ji,jj) = 0.5_wp * zdum2 * ( pstress1_i(ji,jj) + zshear ) ! principal stress (y-direction, see Hunke & Dukowicz 2002) 
     
    780748!!               zsig3(ji,jj) = zdum2**2 * ( ( pstress1_i(ji,jj) + strength(ji,jj) )**2 + ( rn_ecc * zshear )**2 ) ! quadratic relation linking compressive stress to shear stress 
    781749!!                                                                                                               ! (scheme converges if this value is ~1, see Bouillon et al 2009 (eq. 11)) 
    782                zsig1(ji,jj) = 0.5_wp * zdum2 * ( pstress1_i(ji,jj) )          ! compressive stress, see Bouillon et al. 2015 
    783                zsig2(ji,jj) = 0.5_wp * zdum2 * ( zshear )                     ! shear stress 
    784                zsig3(ji,jj) = zdum2**2 * ( ( pstress1_i(ji,jj) + strength(ji,jj) )**2 + ( rn_ecc * zshear )**2 ) 
    785             END DO 
    786          END DO 
     750            zsig1(ji,jj) = 0.5_wp * zdum2 * ( pstress1_i(ji,jj) )          ! compressive stress, see Bouillon et al. 2015 
     751            zsig2(ji,jj) = 0.5_wp * zdum2 * ( zshear )                     ! shear stress 
     752            zsig3(ji,jj) = zdum2**2 * ( ( pstress1_i(ji,jj) + strength(ji,jj) )**2 + ( rn_ecc * zshear )**2 ) 
     753         END_2D 
    787754         CALL lbc_lnk_multi( 'icedyn_rhg_evp', zsig1, 'T', 1., zsig2, 'T', 1., zsig3, 'T', 1. ) 
    788755         ! 
     
    819786            &      zdiag_xmtrp_snw(jpi,jpj) , zdiag_ymtrp_snw(jpi,jpj) , zdiag_xatrp(jpi,jpj) , zdiag_yatrp(jpi,jpj) ) 
    820787         ! 
    821          DO jj = 2, jpjm1 
    822             DO ji = 2, jpim1 
    823                ! 2D ice mass, snow mass, area transport arrays (X, Y) 
    824                zfac_x = 0.5 * u_ice(ji,jj) * e2u(ji,jj) * zmsk00(ji,jj) 
    825                zfac_y = 0.5 * v_ice(ji,jj) * e1v(ji,jj) * zmsk00(ji,jj) 
    826  
    827                zdiag_xmtrp_ice(ji,jj) = rhoi * zfac_x * ( vt_i(ji+1,jj) + vt_i(ji,jj) ) ! ice mass transport, X-component 
    828                zdiag_ymtrp_ice(ji,jj) = rhoi * zfac_y * ( vt_i(ji,jj+1) + vt_i(ji,jj) ) !        ''           Y-   '' 
    829  
    830                zdiag_xmtrp_snw(ji,jj) = rhos * zfac_x * ( vt_s(ji+1,jj) + vt_s(ji,jj) ) ! snow mass transport, X-component 
    831                zdiag_ymtrp_snw(ji,jj) = rhos * zfac_y * ( vt_s(ji,jj+1) + vt_s(ji,jj) ) !          ''          Y-   '' 
    832  
    833                zdiag_xatrp(ji,jj)     = zfac_x * ( at_i(ji+1,jj) + at_i(ji,jj) )        ! area transport,      X-component 
    834                zdiag_yatrp(ji,jj)     = zfac_y * ( at_i(ji,jj+1) + at_i(ji,jj) )        !        ''            Y-   '' 
    835  
    836             END DO 
    837          END DO 
     788         DO_2D_00_00 
     789            ! 2D ice mass, snow mass, area transport arrays (X, Y) 
     790            zfac_x = 0.5 * u_ice(ji,jj) * e2u(ji,jj) * zmsk00(ji,jj) 
     791            zfac_y = 0.5 * v_ice(ji,jj) * e1v(ji,jj) * zmsk00(ji,jj) 
     792 
     793            zdiag_xmtrp_ice(ji,jj) = rhoi * zfac_x * ( vt_i(ji+1,jj) + vt_i(ji,jj) ) ! ice mass transport, X-component 
     794            zdiag_ymtrp_ice(ji,jj) = rhoi * zfac_y * ( vt_i(ji,jj+1) + vt_i(ji,jj) ) !        ''           Y-   '' 
     795 
     796            zdiag_xmtrp_snw(ji,jj) = rhos * zfac_x * ( vt_s(ji+1,jj) + vt_s(ji,jj) ) ! snow mass transport, X-component 
     797            zdiag_ymtrp_snw(ji,jj) = rhos * zfac_y * ( vt_s(ji,jj+1) + vt_s(ji,jj) ) !          ''          Y-   '' 
     798 
     799            zdiag_xatrp(ji,jj)     = zfac_x * ( at_i(ji+1,jj) + at_i(ji,jj) )        ! area transport,      X-component 
     800            zdiag_yatrp(ji,jj)     = zfac_y * ( at_i(ji,jj+1) + at_i(ji,jj) )        !        ''            Y-   '' 
     801 
     802         END_2D 
    838803 
    839804         CALL lbc_lnk_multi( 'icedyn_rhg_evp', zdiag_xmtrp_ice, 'U', -1., zdiag_ymtrp_ice, 'V', -1., & 
  • NEMO/branches/2019/dev_r11943_MERGE_2019/src/ICE/iceistate.F90

    r11960 r12340  
    6161   TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   si  ! structure of input fields (file informations, fields read) 
    6262   !    
     63   !! * Substitutions 
     64#  include "do_loop_substitute.h90" 
    6365   !!---------------------------------------------------------------------- 
    6466   !! NEMO/ICE 4.0 , NEMO Consortium (2018) 
     
    269271         ! select ice covered grid points 
    270272         npti = 0 ; nptidx(:) = 0 
    271          DO jj = 1, jpj 
    272             DO ji = 1, jpi 
    273                IF ( zht_i_ini(ji,jj) > 0._wp ) THEN 
    274                   npti         = npti  + 1 
    275                   nptidx(npti) = (jj - 1) * jpi + ji 
    276                ENDIF 
    277             END DO 
    278          END DO 
     273         DO_2D_11_11 
     274            IF ( zht_i_ini(ji,jj) > 0._wp ) THEN 
     275               npti         = npti  + 1 
     276               nptidx(npti) = (jj - 1) * jpi + ji 
     277            ENDIF 
     278         END_2D 
    279279 
    280280         ! move to 1D arrays: (jpi,jpj) -> (jpi*jpj) 
     
    321321         CALL ice_var_salprof ! for sz_i 
    322322         DO jl = 1, jpl 
    323             DO jj = 1, jpj 
    324                DO ji = 1, jpi 
    325                   v_i (ji,jj,jl) = h_i(ji,jj,jl) * a_i(ji,jj,jl) 
    326                   v_s (ji,jj,jl) = h_s(ji,jj,jl) * a_i(ji,jj,jl) 
    327                   sv_i(ji,jj,jl) = MIN( MAX( rn_simin , s_i(ji,jj,jl) ) , rn_simax ) * v_i(ji,jj,jl) 
    328                END DO 
    329             END DO 
     323            DO_2D_11_11 
     324               v_i (ji,jj,jl) = h_i(ji,jj,jl) * a_i(ji,jj,jl) 
     325               v_s (ji,jj,jl) = h_s(ji,jj,jl) * a_i(ji,jj,jl) 
     326               sv_i(ji,jj,jl) = MIN( MAX( rn_simin , s_i(ji,jj,jl) ) , rn_simax ) * v_i(ji,jj,jl) 
     327            END_2D 
    330328         END DO 
    331329         ! 
    332330         DO jl = 1, jpl 
    333             DO jk = 1, nlay_s 
    334                DO jj = 1, jpj 
    335                   DO ji = 1, jpi 
    336                      t_s(ji,jj,jk,jl) = zts_3d(ji,jj,jl) 
    337                      e_s(ji,jj,jk,jl) = zswitch(ji,jj) * v_s(ji,jj,jl) * r1_nlay_s * & 
    338                         &               rhos * ( rcpi * ( rt0 - t_s(ji,jj,jk,jl) ) + rLfus ) 
    339                   END DO 
    340                END DO 
    341             END DO 
     331            DO_3D_11_11( 1, nlay_s ) 
     332               t_s(ji,jj,jk,jl) = zts_3d(ji,jj,jl) 
     333               e_s(ji,jj,jk,jl) = zswitch(ji,jj) * v_s(ji,jj,jl) * r1_nlay_s * & 
     334                  &               rhos * ( rcpi * ( rt0 - t_s(ji,jj,jk,jl) ) + rLfus ) 
     335            END_3D 
    342336         END DO 
    343337         ! 
    344338         DO jl = 1, jpl 
    345             DO jk = 1, nlay_i 
    346                DO jj = 1, jpj 
    347                   DO ji = 1, jpi 
    348                      t_i (ji,jj,jk,jl) = zti_3d(ji,jj,jl)  
    349                      ztmelts          = - rTmlt * sz_i(ji,jj,jk,jl) + rt0 ! melting temperature in K 
    350                      e_i(ji,jj,jk,jl) = zswitch(ji,jj) * v_i(ji,jj,jl) * r1_nlay_i * & 
    351                         &               rhoi * (  rcpi  * ( ztmelts - t_i(ji,jj,jk,jl) ) + & 
    352                         &                         rLfus * ( 1._wp - (ztmelts-rt0) / MIN( (t_i(ji,jj,jk,jl)-rt0), -epsi20 ) ) & 
    353                         &                       - rcp   * ( ztmelts - rt0 ) ) 
    354                   END DO 
    355                END DO 
    356             END DO 
     339            DO_3D_11_11( 1, nlay_i ) 
     340               t_i (ji,jj,jk,jl) = zti_3d(ji,jj,jl)  
     341               ztmelts          = - rTmlt * sz_i(ji,jj,jk,jl) + rt0 ! melting temperature in K 
     342               e_i(ji,jj,jk,jl) = zswitch(ji,jj) * v_i(ji,jj,jl) * r1_nlay_i * & 
     343                  &               rhoi * (  rcpi  * ( ztmelts - t_i(ji,jj,jk,jl) ) + & 
     344                  &                         rLfus * ( 1._wp - (ztmelts-rt0) / MIN( (t_i(ji,jj,jk,jl)-rt0), -epsi20 ) ) & 
     345                  &                       - rcp   * ( ztmelts - rt0 ) ) 
     346            END_3D 
    357347         END DO 
    358348 
  • NEMO/branches/2019/dev_r11943_MERGE_2019/src/ICE/iceitd.F90

    r11960 r12340  
    4848   REAL(wp), DIMENSION(0:100) ::   rn_catbnd    ! ice categories bounds 
    4949   ! 
     50   !! * Substitutions 
     51#  include "do_loop_substitute.h90" 
    5052   !!---------------------------------------------------------------------- 
    5153   !! NEMO/ICE 4.0 , NEMO Consortium (2018) 
     
    9698      ! 
    9799      npti = 0   ;   nptidx(:) = 0 
    98       DO jj = 1, jpj 
    99          DO ji = 1, jpi 
    100             IF ( at_i(ji,jj) > epsi10 ) THEN 
    101                npti = npti + 1 
    102                nptidx( npti ) = (jj - 1) * jpi + ji 
    103             ENDIF 
    104          END DO 
    105       END DO 
     100      DO_2D_11_11 
     101         IF ( at_i(ji,jj) > epsi10 ) THEN 
     102            npti = npti + 1 
     103            nptidx( npti ) = (jj - 1) * jpi + ji 
     104         ENDIF 
     105      END_2D 
    106106       
    107107      !----------------------------------------------------------------------------------------------- 
     
    597597         !                    !--------------------------------------- 
    598598         npti = 0   ;   nptidx(:) = 0 
    599          DO jj = 1, jpj 
    600             DO ji = 1, jpi 
    601                IF( a_i(ji,jj,jl) > 0._wp .AND. v_i(ji,jj,jl) > (a_i(ji,jj,jl) * hi_max(jl)) ) THEN 
    602                   npti = npti + 1 
    603                   nptidx( npti ) = (jj - 1) * jpi + ji                   
    604                ENDIF 
    605             END DO 
    606          END DO 
     599         DO_2D_11_11 
     600            IF( a_i(ji,jj,jl) > 0._wp .AND. v_i(ji,jj,jl) > (a_i(ji,jj,jl) * hi_max(jl)) ) THEN 
     601               npti = npti + 1 
     602               nptidx( npti ) = (jj - 1) * jpi + ji                   
     603            ENDIF 
     604         END_2D 
    607605         ! 
    608606!!clem   CALL tab_2d_1d( npti, nptidx(1:npti), h_i_1d(1:npti), h_i(:,:,jl) ) 
     
    638636         !                    !----------------------------------------- 
    639637         npti = 0 ; nptidx(:) = 0 
    640          DO jj = 1, jpj 
    641             DO ji = 1, jpi 
    642                IF( a_i(ji,jj,jl+1) > 0._wp .AND. v_i(ji,jj,jl+1) <= (a_i(ji,jj,jl+1) * hi_max(jl)) ) THEN 
    643                   npti = npti + 1 
    644                   nptidx( npti ) = (jj - 1) * jpi + ji                   
    645                ENDIF 
    646             END DO 
    647          END DO 
     638         DO_2D_11_11 
     639            IF( a_i(ji,jj,jl+1) > 0._wp .AND. v_i(ji,jj,jl+1) <= (a_i(ji,jj,jl+1) * hi_max(jl)) ) THEN 
     640               npti = npti + 1 
     641               nptidx( npti ) = (jj - 1) * jpi + ji                   
     642            ENDIF 
     643         END_2D 
    648644         ! 
    649645         CALL tab_2d_1d( npti, nptidx(1:npti), a_i_1d(1:npti), a_i(:,:,jl+1) ) ! jl+1 is ok 
  • NEMO/branches/2019/dev_r11943_MERGE_2019/src/ICE/icesbc.F90

    r12182 r12340  
    3838   !! * Substitutions 
    3939#  include "vectopt_loop_substitute.h90" 
     40#  include "do_loop_substitute.h90" 
    4041   !!---------------------------------------------------------------------- 
    4142   !! NEMO/ICE 4.0 , NEMO Consortium (2018) 
     
    8283      IF( ln_mixcpl) THEN                                                        ! Case of a mixed Bulk/Coupled formulation 
    8384                                   CALL sbc_cpl_ice_tau( zutau_ice , zvtau_ice ) 
    84          DO jj = 2, jpjm1 
    85             DO ji = 2, jpim1 
    86                utau_ice(ji,jj) = utau_ice(ji,jj) * xcplmask(ji,jj,0) + zutau_ice(ji,jj) * ( 1. - xcplmask(ji,jj,0) ) 
    87                vtau_ice(ji,jj) = vtau_ice(ji,jj) * xcplmask(ji,jj,0) + zvtau_ice(ji,jj) * ( 1. - xcplmask(ji,jj,0) ) 
    88             END DO 
    89          END DO 
     85         DO_2D_00_00 
     86            utau_ice(ji,jj) = utau_ice(ji,jj) * xcplmask(ji,jj,0) + zutau_ice(ji,jj) * ( 1. - xcplmask(ji,jj,0) ) 
     87            vtau_ice(ji,jj) = vtau_ice(ji,jj) * xcplmask(ji,jj,0) + zvtau_ice(ji,jj) * ( 1. - xcplmask(ji,jj,0) ) 
     88         END_2D 
    9089         CALL lbc_lnk_multi( 'icesbc', utau_ice, 'U', -1., vtau_ice, 'V', -1. ) 
    9190      ENDIF 
  • NEMO/branches/2019/dev_r11943_MERGE_2019/src/ICE/icethd.F90

    r12236 r12340  
    5454   !! * Substitutions 
    5555#  include "vectopt_loop_substitute.h90" 
     56#  include "do_loop_substitute.h90" 
    5657   !!---------------------------------------------------------------------- 
    5758   !! NEMO/ICE 4.0 , NEMO Consortium (2018) 
     
    109110         zu_io(:,:) = u_ice(:,:) - ssu_m(:,:) 
    110111         zv_io(:,:) = v_ice(:,:) - ssv_m(:,:) 
    111          DO jj = 2, jpjm1  
    112             DO ji = fs_2, fs_jpim1 
    113                zfric(ji,jj) = rn_cio * ( 0.5_wp *  & 
    114                   &                    (  zu_io(ji,jj) * zu_io(ji,jj) + zu_io(ji-1,jj) * zu_io(ji-1,jj)   & 
    115                   &                     + zv_io(ji,jj) * zv_io(ji,jj) + zv_io(ji,jj-1) * zv_io(ji,jj-1) ) ) * tmask(ji,jj,1) 
    116             END DO 
    117          END DO 
     112         DO_2D_00_00 
     113            zfric(ji,jj) = rn_cio * ( 0.5_wp *  & 
     114               &                    (  zu_io(ji,jj) * zu_io(ji,jj) + zu_io(ji-1,jj) * zu_io(ji-1,jj)   & 
     115               &                     + zv_io(ji,jj) * zv_io(ji,jj) + zv_io(ji,jj-1) * zv_io(ji,jj-1) ) ) * tmask(ji,jj,1) 
     116         END_2D 
    118117      ELSE      !  if no ice dynamics => transmit directly the atmospheric stress to the ocean 
    119          DO jj = 2, jpjm1 
    120             DO ji = fs_2, fs_jpim1 
    121                zfric(ji,jj) = r1_rau0 * SQRT( 0.5_wp *  & 
    122                   &                         (  utau(ji,jj) * utau(ji,jj) + utau(ji-1,jj) * utau(ji-1,jj)   & 
    123                   &                          + vtau(ji,jj) * vtau(ji,jj) + vtau(ji,jj-1) * vtau(ji,jj-1) ) ) * tmask(ji,jj,1) 
    124             END DO 
    125          END DO 
     118         DO_2D_00_00 
     119            zfric(ji,jj) = r1_rau0 * SQRT( 0.5_wp *  & 
     120               &                         (  utau(ji,jj) * utau(ji,jj) + utau(ji-1,jj) * utau(ji-1,jj)   & 
     121               &                          + vtau(ji,jj) * vtau(ji,jj) + vtau(ji,jj-1) * vtau(ji,jj-1) ) ) * tmask(ji,jj,1) 
     122         END_2D 
    126123      ENDIF 
    127124      CALL lbc_lnk( 'icethd', zfric, 'T',  1. ) 
     
    130127      ! Partial computation of forcing for the thermodynamic sea ice model 
    131128      !--------------------------------------------------------------------! 
    132       DO jj = 1, jpj 
    133          DO ji = 1, jpi 
    134             rswitch  = tmask(ji,jj,1) * MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi10 ) ) ! 0 if no ice 
    135             ! 
    136             !           !  solar irradiance transmission at the mixed layer bottom and used in the lead heat budget 
    137             !           !  practically no "direct lateral ablation" 
    138             !            
    139             !           !  net downward heat flux from the ice to the ocean, expressed as a function of ocean  
    140             !           !  temperature and turbulent mixing (McPhee, 1992) 
    141             ! 
    142             ! --- Energy received in the lead from atm-oce exchanges, zqld is defined everywhere (J.m-2) --- ! 
    143             zqld =  tmask(ji,jj,1) * rdt_ice *  & 
    144                &    ( ( 1._wp - at_i_b(ji,jj) ) * qsr_oce(ji,jj) * frq_m(ji,jj) +  & 
    145                &      ( 1._wp - at_i_b(ji,jj) ) * qns_oce(ji,jj) + qemp_oce(ji,jj) ) 
    146  
    147             ! --- Energy needed to bring ocean surface layer until its freezing (mostly<0 but >0 if supercooling, J.m-2) --- ! 
    148             zqfr     = rau0 * rcp * e3t_m(ji,jj) * ( t_bo(ji,jj) - ( sst_m(ji,jj) + rt0 ) ) * tmask(ji,jj,1)  ! both < 0 (t_bo < sst) and > 0 (t_bo > sst) 
    149             zqfr_neg = MIN( zqfr , 0._wp )                                                                    ! only < 0 
    150  
    151             ! --- Sensible ocean-to-ice heat flux (mostly>0 but <0 if supercooling, W/m2) 
    152             zfric_u            = MAX( SQRT( zfric(ji,jj) ), zfric_umin )  
    153             qsb_ice_bot(ji,jj) = rswitch * rau0 * rcp * zch * zfric_u * ( ( sst_m(ji,jj) + rt0 ) - t_bo(ji,jj) ) ! W.m-2 
    154  
    155             qsb_ice_bot(ji,jj) = rswitch * MIN( qsb_ice_bot(ji,jj), - zqfr_neg * r1_rdtice / MAX( at_i(ji,jj), epsi10 ) ) 
    156             ! upper bound for qsb_ice_bot: the heat retrieved from the ocean must be smaller than the heat necessary to reach  
    157             !                              the freezing point, so that we do not have SST < T_freeze 
    158             !                              This implies: - ( qsb_ice_bot(ji,jj) * at_i(ji,jj) * rtdice ) - zqfr >= 0 
    159  
    160             !-- Energy Budget of the leads (J.m-2), source of ice growth in open water. Must be < 0 to form ice 
    161             qlead(ji,jj) = MIN( 0._wp , zqld - ( qsb_ice_bot(ji,jj) * at_i(ji,jj) * rdt_ice ) - zqfr ) 
    162  
    163             ! If there is ice and leads are warming => transfer energy from the lead budget and use it for bottom melting  
    164             ! If the grid cell is fully covered by ice (no leads) => transfer energy from the lead budget to the ice bottom budget 
    165             IF( ( zqld >= 0._wp .AND. at_i(ji,jj) > 0._wp ) .OR. at_i(ji,jj) >= (1._wp - epsi10) ) THEN 
    166                fhld (ji,jj) = rswitch * zqld * r1_rdtice / MAX( at_i(ji,jj), epsi10 ) ! divided by at_i since this is (re)multiplied by a_i in icethd_dh.F90 
    167                qlead(ji,jj) = 0._wp 
    168             ELSE 
    169                fhld (ji,jj) = 0._wp 
    170             ENDIF 
    171             ! 
    172             ! Net heat flux on top of the ice-ocean [W.m-2] 
    173             ! --------------------------------------------- 
    174             qt_atm_oi(ji,jj) = qns_tot(ji,jj) + qsr_tot(ji,jj)  
    175          END DO 
    176       END DO 
     129      DO_2D_11_11 
     130         rswitch  = tmask(ji,jj,1) * MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi10 ) ) ! 0 if no ice 
     131         ! 
     132         !           !  solar irradiance transmission at the mixed layer bottom and used in the lead heat budget 
     133         !           !  practically no "direct lateral ablation" 
     134         !            
     135         !           !  net downward heat flux from the ice to the ocean, expressed as a function of ocean  
     136         !           !  temperature and turbulent mixing (McPhee, 1992) 
     137         ! 
     138         ! --- Energy received in the lead from atm-oce exchanges, zqld is defined everywhere (J.m-2) --- ! 
     139         zqld =  tmask(ji,jj,1) * rdt_ice *  & 
     140            &    ( ( 1._wp - at_i_b(ji,jj) ) * qsr_oce(ji,jj) * frq_m(ji,jj) +  & 
     141            &      ( 1._wp - at_i_b(ji,jj) ) * qns_oce(ji,jj) + qemp_oce(ji,jj) ) 
     142 
     143         ! --- Energy needed to bring ocean surface layer until its freezing (mostly<0 but >0 if supercooling, J.m-2) --- ! 
     144         zqfr     = rau0 * rcp * e3t_m(ji,jj) * ( t_bo(ji,jj) - ( sst_m(ji,jj) + rt0 ) ) * tmask(ji,jj,1)  ! both < 0 (t_bo < sst) and > 0 (t_bo > sst) 
     145         zqfr_neg = MIN( zqfr , 0._wp )                                                                    ! only < 0 
     146 
     147         ! --- Sensible ocean-to-ice heat flux (mostly>0 but <0 if supercooling, W/m2) 
     148         zfric_u            = MAX( SQRT( zfric(ji,jj) ), zfric_umin )  
     149         qsb_ice_bot(ji,jj) = rswitch * rau0 * rcp * zch * zfric_u * ( ( sst_m(ji,jj) + rt0 ) - t_bo(ji,jj) ) ! W.m-2 
     150 
     151         qsb_ice_bot(ji,jj) = rswitch * MIN( qsb_ice_bot(ji,jj), - zqfr_neg * r1_rdtice / MAX( at_i(ji,jj), epsi10 ) ) 
     152         ! upper bound for qsb_ice_bot: the heat retrieved from the ocean must be smaller than the heat necessary to reach  
     153         !                              the freezing point, so that we do not have SST < T_freeze 
     154         !                              This implies: - ( qsb_ice_bot(ji,jj) * at_i(ji,jj) * rtdice ) - zqfr >= 0 
     155 
     156         !-- Energy Budget of the leads (J.m-2), source of ice growth in open water. Must be < 0 to form ice 
     157         qlead(ji,jj) = MIN( 0._wp , zqld - ( qsb_ice_bot(ji,jj) * at_i(ji,jj) * rdt_ice ) - zqfr ) 
     158 
     159         ! If there is ice and leads are warming => transfer energy from the lead budget and use it for bottom melting  
     160         ! If the grid cell is fully covered by ice (no leads) => transfer energy from the lead budget to the ice bottom budget 
     161         IF( ( zqld >= 0._wp .AND. at_i(ji,jj) > 0._wp ) .OR. at_i(ji,jj) >= (1._wp - epsi10) ) THEN 
     162            fhld (ji,jj) = rswitch * zqld * r1_rdtice / MAX( at_i(ji,jj), epsi10 ) ! divided by at_i since this is (re)multiplied by a_i in icethd_dh.F90 
     163            qlead(ji,jj) = 0._wp 
     164         ELSE 
     165            fhld (ji,jj) = 0._wp 
     166         ENDIF 
     167         ! 
     168         ! Net heat flux on top of the ice-ocean [W.m-2] 
     169         ! --------------------------------------------- 
     170         qt_atm_oi(ji,jj) = qns_tot(ji,jj) + qsr_tot(ji,jj)  
     171      END_2D 
    177172       
    178173      ! In case we bypass open-water ice formation 
     
    202197         ! select ice covered grid points 
    203198         npti = 0 ; nptidx(:) = 0 
    204          DO jj = 1, jpj 
    205             DO ji = 1, jpi 
    206                IF ( a_i(ji,jj,jl) > epsi10 ) THEN      
    207                   npti         = npti  + 1 
    208                   nptidx(npti) = (jj - 1) * jpi + ji 
    209                ENDIF 
    210             END DO 
    211          END DO 
     199         DO_2D_11_11 
     200            IF ( a_i(ji,jj,jl) > epsi10 ) THEN      
     201               npti         = npti  + 1 
     202               nptidx(npti) = (jj - 1) * jpi + ji 
     203            ENDIF 
     204         END_2D 
    212205 
    213206         IF( npti > 0 ) THEN  ! If there is no ice, do nothing. 
  • NEMO/branches/2019/dev_r11943_MERGE_2019/src/ICE/icethd_do.F90

    r11960 r12340  
    4444   REAL(wp) ::   rn_Cfraz      ! squeezing coefficient for collection of bottom frazil ice 
    4545 
     46   !! * Substitutions 
     47#  include "do_loop_substitute.h90" 
    4648   !!---------------------------------------------------------------------- 
    4749   !! NEMO/ICE 4.0 , NEMO Consortium (2018) 
     
    143145         zgamafr = 0.03 
    144146         ! 
    145          DO jj = 2, jpjm1 
    146             DO ji = 2, jpim1 
    147                IF ( qlead(ji,jj) < 0._wp .AND. tau_icebfr(ji,jj) == 0._wp ) THEN ! activated if cooling and no landfast 
    148                   ! -- Wind stress -- ! 
    149                   ztaux         = ( utau_ice(ji-1,jj  ) * umask(ji-1,jj  ,1)   & 
    150                      &          +   utau_ice(ji  ,jj  ) * umask(ji  ,jj  ,1) ) * 0.5_wp