New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
Changeset 12377 for NEMO/trunk/src/ICE – NEMO

Changeset 12377 for NEMO/trunk/src/ICE


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

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

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

svn merge --ignore-ancestry \

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

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

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

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

Location:
NEMO/trunk
Files:
26 edited

Legend:

Unmodified
Added
Removed

  • NEMO/trunk

    • Property svn:externals

      •  

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

  • NEMO/trunk/src/ICE/icealb.F90

    r11536 r12377  
    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      ! 
    … …  
    190190      !!---------------------------------------------------------------------- 
    191191      ! 
    192       REWIND( numnam_ice_ref )              ! Namelist namalb in reference namelist : Albedo parameters 
    193192      READ  ( numnam_ice_ref, namalb, IOSTAT = ios, ERR = 901) 
    194193901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namalb in reference namelist' ) 
    195       REWIND( numnam_ice_cfg )              ! Namelist namalb in configuration namelist : Albedo parameters 
    196194      READ  ( numnam_ice_cfg, namalb, IOSTAT = ios, ERR = 902 ) 
    197195902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namalb in configuration namelist' ) 

  • NEMO/trunk/src/ICE/icecor.F90

    r11536 r12377  
    3535 
    3636   !! * Substitutions 
    37 #  include "vectopt_loop_substitute.h90" 
     37#  include "do_loop_substitute.h90" 
    3838   !!---------------------------------------------------------------------- 
    3939   !! NEMO/ICE 4.0 , NEMO Consortium (2018) 
    … …  
    8888         zzc = rhoi * r1_rdtice 
    8989         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 
     90            DO_2D_11_11 
     91               zsal = sv_i(ji,jj,jl) 
     92               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)  ) 
     93               sfx_res(ji,jj) = sfx_res(ji,jj) - ( sv_i(ji,jj,jl) - zsal ) * zzc   ! associated salt flux 
     94            END_2D 
    9795         END DO 
    9896      ENDIF 
    … …  
    108106      !                             !----------------------------------------------------- 
    109107      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 
     108         DO_2D_00_00 
     109            IF ( at_i(ji,jj) == 0._wp ) THEN    ! what to do if there is no ice 
     110               IF ( at_i(ji+1,jj) == 0._wp )   u_ice(ji  ,jj) = 0._wp   ! right side 
     111               IF ( at_i(ji-1,jj) == 0._wp )   u_ice(ji-1,jj) = 0._wp   ! left side 
     112               IF ( at_i(ji,jj+1) == 0._wp )   v_ice(ji,jj  ) = 0._wp   ! upper side 
     113               IF ( at_i(ji,jj-1) == 0._wp )   v_ice(ji,jj-1) = 0._wp   ! bottom side 
     114            ENDIF 
     115         END_2D 
    120116         CALL lbc_lnk_multi( 'icecor', u_ice, 'U', -1., v_ice, 'V', -1. ) 
    121117      ENDIF 
    … …  
    165161      ! 
    166162      ! controls 
    167       IF( ln_ctl       )   CALL ice_prt3D   ('icecor')                                                             ! prints 
     163      IF( sn_cfctl%l_prtctl ) & 
     164         &                 CALL ice_prt3D   ('icecor')                                                             ! prints 
    168165      IF( ln_icectl .AND. kn == 2 ) & 
    169166         &                 CALL ice_prt     ( kt, iiceprt, jiceprt, 2, ' - Final state - ' )                       ! prints 

  • NEMO/trunk/src/ICE/icectl.F90

    r11612 r12377  
    5151    
    5252   !! * Substitutions 
    53 #  include "vectopt_loop_substitute.h90" 
     53#  include "do_loop_substitute.h90" 
    5454   !!---------------------------------------------------------------------- 
    5555   !! NEMO/ICE 4.0 , NEMO Consortium (2018) 
    … …  
    368368      cl_alname(ialert_id) = ' Incompat vol and con         '    ! name of the alert 
    369369      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 
     370         DO_2D_11_11 
     371            IF(  v_i(ji,jj,jl) /= 0._wp   .AND.   a_i(ji,jj,jl) == 0._wp   ) THEN 
     372               WRITE(numout,*) ' ALERTE 2 :   Incompatible volume and concentration ' 
     373               inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
     374            ENDIF 
     375         END_2D 
    378376      END DO 
    379377 
    … …  
    382380      cl_alname(ialert_id) = ' Very thick ice               ' ! name of the alert 
    383381      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 
     382      DO_2D_11_11 
     383         IF(   h_i(ji,jj,jl)  >  50._wp   ) THEN 
     384            WRITE(numout,*) ' ALERTE 3 :   Very thick ice' 
     385            !CALL ice_prt( kt, ji, jj, 2, ' ALERTE 3 :   Very thick ice ' ) 
     386            inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
     387         ENDIF 
     388      END_2D 
    393389 
    394390      ! Alert if very fast ice 
    395391      ialert_id = 4 ! reference number of this alert 
    396392      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 
     393      DO_2D_11_11 
     394         IF(   MAX( ABS( u_ice(ji,jj) ), ABS( v_ice(ji,jj) ) ) > 2.  .AND.  & 
     395            &  at_i(ji,jj) > 0._wp   ) THEN 
     396            WRITE(numout,*) ' ALERTE 4 :   Very fast ice' 
     397            !CALL ice_prt( kt, ji, jj, 1, ' ALERTE 4 :   Very fast ice ' ) 
     398            inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
     399         ENDIF 
     400      END_2D 
    407401 
    408402      ! Alert on salt flux 
    409403      ialert_id = 5 ! reference number of this alert 
    410404      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 
     405      DO_2D_11_11 
     406         IF( ABS( sfx (ji,jj) ) > 1.0e-2 ) THEN  ! = 1 psu/day for 1m ocean depth 
     407            WRITE(numout,*) ' ALERTE 5 :   High salt flux' 
     408            !CALL ice_prt( kt, ji, jj, 3, ' ALERTE 5 :   High salt flux ' ) 
     409            inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
     410         ENDIF 
     411      END_2D 
    420412 
    421413      ! Alert if there is ice on continents 
    422414      ialert_id = 6 ! reference number of this alert 
    423415      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 
     416      DO_2D_11_11 
     417         IF(   tmask(ji,jj,1) <= 0._wp   .AND.   at_i(ji,jj) > 0._wp   ) THEN  
     418            WRITE(numout,*) ' ALERTE 6 :   Ice on continents' 
     419            !CALL ice_prt( kt, ji, jj, 1, ' ALERTE 6 :   Ice on continents ' ) 
     420            inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
     421         ENDIF 
     422      END_2D 
    433423 
    434424! 
    … …  
    437427      cl_alname(ialert_id) = ' Very fresh ice               ' ! name of the alert 
    438428      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' 
     429         DO_2D_11_11 
     430            IF( s_i(ji,jj,jl) < 0.1 .AND. a_i(ji,jj,jl) > 0._wp ) THEN 
     431               WRITE(numout,*) ' ALERTE 7 :   Very fresh ice' 
    443432!                 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 
     433               inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
     434            ENDIF 
     435         END_2D 
    448436      END DO 
    449437! 
    … …  
    451439      ialert_id = 8 ! reference number of this alert 
    452440      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 
     441      DO_2D_11_11 
     442         IF( ABS( qns(ji,jj) ) > 1500._wp .AND. at_i(ji,jj) > 0._wp ) THEN 
     443            ! 
     444            WRITE(numout,*) ' ALERTE 8 :   Very high non-solar heat flux' 
     445            !CALL ice_prt( kt, ji, jj, 2, '   ') 
     446            inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
     447            ! 
     448         ENDIF 
     449      END_2D 
    464450      !+++++ 
    465451 
    … …  
    468454      cl_alname(ialert_id) = ' Very old   ice               ' ! name of the alert 
    469455      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 
     456         DO_2D_11_11 
     457            IF ( ( ( ABS( o_i(ji,jj,jl) ) > rdt_ice ) .OR. & 
     458                   ( ABS( o_i(ji,jj,jl) ) < 0._wp) ) .AND. & 
     459                          ( a_i(ji,jj,jl) > 0._wp ) ) THEN 
     460               WRITE(numout,*) ' ALERTE 9 :   Wrong ice age' 
     461               !CALL ice_prt( kt, ji, jj, 1, ' ALERTE 9 :   Wrong ice age ') 
     462               inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
     463            ENDIF 
     464         END_2D 
    481465      END DO 
    482466   
    … …  
    486470      inb_alp(ialert_id) = 0 
    487471      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 
     472         DO_3D_11_11( 1, nlay_i ) 
     473            ztmelts    =  -rTmlt * sz_i(ji,jj,jk,jl) + rt0 
     474            IF( t_i(ji,jj,jk,jl) > ztmelts  .AND.  v_i(ji,jj,jl) > 1.e-10   & 
     475               &                            .AND.  a_i(ji,jj,jl) > 0._wp   ) THEN 
     476               WRITE(numout,*) ' ALERTE 10 :   Very warm ice' 
     477              inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
     478            ENDIF 
     479         END_3D 
    500480      END DO 
    501481 
    … …  
    695675      !!                  ***  ROUTINE ice_prt3D *** 
    696676      !! 
    697       !! ** Purpose : CTL prints of ice arrays in case ln_ctl is activated  
     677      !! ** Purpose : CTL prints of ice arrays in case sn_cfctl%prtctl is activated  
    698678      !! 
    699679      !!------------------------------------------------------------------- 

  • NEMO/trunk/src/ICE/icedia.F90

    r11536 r12377  
    3838   REAL(wp)                              ::   frc_sal, frc_voltop, frc_volbot, frc_temtop, frc_tembot  ! global forcing trends 
    3939    
    40    !! * Substitutions 
    41 #  include "vectopt_loop_substitute.h90" 
    4240   !!---------------------------------------------------------------------- 
    4341   !! NEMO/ICE 4.0 , NEMO Consortium (2018) 
    … …  
    178176      !!---------------------------------------------------------------------- 
    179177      ! 
    180       REWIND( numnam_ice_ref )      ! Namelist namdia in reference namelist : Parameters for ice 
    181178      READ  ( numnam_ice_ref, namdia, IOSTAT = ios, ERR = 901) 
    182179901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namdia in reference namelist' ) 
    183       REWIND( numnam_ice_cfg )      ! Namelist namdia in configuration namelist : Parameters for ice 
    184180      READ  ( numnam_ice_cfg, namdia, IOSTAT = ios, ERR = 902 ) 
    185181902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namdia in configuration namelist' ) 

  • NEMO/trunk/src/ICE/icedyn.F90

    r11536 r12377  
    5252    
    5353   !! * Substitutions 
    54 #  include "vectopt_loop_substitute.h90" 
     54#  include "do_loop_substitute.h90" 
    5555   !!---------------------------------------------------------------------- 
    5656   !! NEMO/ICE 4.0 , NEMO Consortium (2018) 
    … …  
    6060CONTAINS 
    6161 
    62    SUBROUTINE ice_dyn( kt ) 
     62   SUBROUTINE ice_dyn( kt, Kmm ) 
    6363      !!------------------------------------------------------------------- 
    6464      !!               ***  ROUTINE ice_dyn  *** 
    … …  
    7373      !!-------------------------------------------------------------------- 
    7474      INTEGER, INTENT(in) ::   kt     ! ice time step 
     75      INTEGER, INTENT(in) ::   Kmm    ! ocean time level index 
    7576      !! 
    7677      INTEGER  ::   ji, jj        ! dummy loop indices 
    … …  
    108109      CASE ( np_dynALL )           !==  all dynamical processes  ==! 
    109110         ! 
    110          CALL ice_dyn_rhg   ( kt )                                          ! -- rheology   
     111         CALL ice_dyn_rhg   ( kt, Kmm )                                     ! -- rheology   
    111112         CALL ice_dyn_adv   ( kt )                                          ! -- advection of ice 
    112113         CALL ice_dyn_rdgrft( kt )                                          ! -- ridging/rafting  
    … …  
    115116      CASE ( np_dynRHGADV  )       !==  no ridge/raft & no corrections ==! 
    116117         ! 
    117          CALL ice_dyn_rhg   ( kt )                                          ! -- rheology   
     118         CALL ice_dyn_rhg   ( kt, Kmm )                                     ! -- rheology   
    118119         CALL ice_dyn_adv   ( kt )                                          ! -- advection of ice 
    119120         CALL Hpiling                                                       ! -- simple pile-up (replaces ridging/rafting) 
    … …  
    125126         ! CFL = 0.5 at a distance from the bound of 1/6 of the basin length 
    126127         ! Then for dx = 2m and dt = 1s => rn_uice = u (1/6th) = 1m/s  
    127          DO jj = 1, jpj 
    128             DO ji = 1, jpi 
    129                zcoefu = ( REAL(jpiglo+1)*0.5 - REAL(ji+nimpp-1) ) / ( REAL(jpiglo+1)*0.5 - 1. ) 
    130                zcoefv = ( REAL(jpjglo+1)*0.5 - REAL(jj+njmpp-1) ) / ( REAL(jpjglo+1)*0.5 - 1. ) 
    131                u_ice(ji,jj) = rn_uice * 1.5 * SIGN( 1., zcoefu ) * ABS( zcoefu ) * umask(ji,jj,1) 
    132                v_ice(ji,jj) = rn_vice * 1.5 * SIGN( 1., zcoefv ) * ABS( zcoefv ) * vmask(ji,jj,1) 
    133             END DO 
    134          END DO 
     128         DO_2D_11_11 
     129            zcoefu = ( REAL(jpiglo+1)*0.5 - REAL(ji+nimpp-1) ) / ( REAL(jpiglo+1)*0.5 - 1. ) 
     130            zcoefv = ( REAL(jpjglo+1)*0.5 - REAL(jj+njmpp-1) ) / ( REAL(jpjglo+1)*0.5 - 1. ) 
     131            u_ice(ji,jj) = rn_uice * 1.5 * SIGN( 1., zcoefu ) * ABS( zcoefu ) * umask(ji,jj,1) 
     132            v_ice(ji,jj) = rn_vice * 1.5 * SIGN( 1., zcoefv ) * ABS( zcoefv ) * vmask(ji,jj,1) 
     133         END_2D 
    135134         ! --- 
    136135         CALL ice_dyn_adv   ( kt )                                          ! -- advection of ice 
    … …  
    156155 
    157156            ALLOCATE( zdivu_i(jpi,jpj) ) 
    158             DO jj = 2, jpjm1 
    159                DO ji = 2, jpim1 
    160                   zdivu_i(ji,jj) = ( e2u(ji,jj) * u_ice(ji,jj) - e2u(ji-1,jj) * u_ice(ji-1,jj)   & 
    161                      &             + e1v(ji,jj) * v_ice(ji,jj) - e1v(ji,jj-1) * v_ice(ji,jj-1) ) * r1_e1e2t(ji,jj) 
    162                END DO 
    163             END DO 
     157            DO_2D_00_00 
     158               zdivu_i(ji,jj) = ( e2u(ji,jj) * u_ice(ji,jj) - e2u(ji-1,jj) * u_ice(ji-1,jj)   & 
     159                  &             + e1v(ji,jj) * v_ice(ji,jj) - e1v(ji,jj-1) * v_ice(ji,jj-1) ) * r1_e1e2t(ji,jj) 
     160            END_2D 
    164161            CALL lbc_lnk( 'icedyn', zdivu_i, 'T', 1. ) 
    165162            ! output 
    … …  
    224221      !!------------------------------------------------------------------- 
    225222      ! 
    226       REWIND( numnam_ice_ref )         ! Namelist namdyn in reference namelist : Ice dynamics 
    227223      READ  ( numnam_ice_ref, namdyn, IOSTAT = ios, ERR = 901) 
    228224901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namdyn in reference namelist' ) 
    229       REWIND( numnam_ice_cfg )         ! Namelist namdyn in configuration namelist : Ice dynamics 
    230225      READ  ( numnam_ice_cfg, namdyn, IOSTAT = ios, ERR = 902 ) 
    231226902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namdyn in configuration namelist' ) 

  • NEMO/trunk/src/ICE/icedyn_adv.F90

    r12197 r12377  
    4242   INTEGER         ::   nn_UMx       ! order of the UMx advection scheme    
    4343   ! 
    44    !! * Substitution 
    45 #  include "vectopt_loop_substitute.h90" 
    4644   !!---------------------------------------------------------------------- 
    4745   !! NEMO/ICE 4.0 , NEMO Consortium (2018) 
    … …  
    131129      !!------------------------------------------------------------------- 
    132130      ! 
    133       REWIND( numnam_ice_ref )         ! Namelist namdyn_adv in reference namelist : Ice dynamics 
    134131      READ  ( numnam_ice_ref, namdyn_adv, IOSTAT = ios, ERR = 901) 
    135132901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namdyn_adv in reference namelist' ) 
    136       REWIND( numnam_ice_cfg )         ! Namelist namdyn_adv in configuration namelist : Ice dynamics 
    137133      READ  ( numnam_ice_cfg, namdyn_adv, IOSTAT = ios, ERR = 902 ) 
    138134902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namdyn_adv in configuration namelist' ) 

  • NEMO/trunk/src/ICE/icedyn_adv_pra.F90

    r12197 r12377  
    4646 
    4747   !! * Substitutions 
    48 #  include "vectopt_loop_substitute.h90" 
     48#  include "do_loop_substitute.h90" 
    4949   !!---------------------------------------------------------------------- 
    5050   !! NEMO/ICE 4.0 , NEMO Consortium (2018) 
    … …  
    102102      ! --- Record max of the surrounding 9-pts ice thick. (for call Hbig) --- ! 
    103103      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 
     104         DO_2D_00_00 
     105            zhip_max(ji,jj,jl) = MAX( epsi20, ph_ip(ji,jj,jl), ph_ip(ji+1,jj  ,jl), ph_ip(ji  ,jj+1,jl), & 
     106               &                                               ph_ip(ji-1,jj  ,jl), ph_ip(ji  ,jj-1,jl), & 
     107               &                                               ph_ip(ji+1,jj+1,jl), ph_ip(ji-1,jj-1,jl), & 
     108               &                                               ph_ip(ji+1,jj-1,jl), ph_ip(ji-1,jj+1,jl) ) 
     109            zhi_max (ji,jj,jl) = MAX( epsi20, ph_i (ji,jj,jl), ph_i (ji+1,jj  ,jl), ph_i (ji  ,jj+1,jl), & 
     110               &                                               ph_i (ji-1,jj  ,jl), ph_i (ji  ,jj-1,jl), & 
     111               &                                               ph_i (ji+1,jj+1,jl), ph_i (ji-1,jj-1,jl), & 
     112               &                                               ph_i (ji+1,jj-1,jl), ph_i (ji-1,jj+1,jl) ) 
     113            zhs_max (ji,jj,jl) = MAX( epsi20, ph_s (ji,jj,jl), ph_s (ji+1,jj  ,jl), ph_s (ji  ,jj+1,jl), & 
     114               &                                               ph_s (ji-1,jj  ,jl), ph_s (ji  ,jj-1,jl), & 
     115               &                                               ph_s (ji+1,jj+1,jl), ph_s (ji-1,jj-1,jl), & 
     116               &                                               ph_s (ji+1,jj-1,jl), ph_s (ji-1,jj+1,jl) ) 
     117         END_2D 
    120118      END DO 
    121119      CALL lbc_lnk_multi( 'icedyn_adv_pra', zhi_max, 'T', 1., zhs_max, 'T', 1., zhip_max, 'T', 1. ) 
    … …  
    252250         ! derive open water from ice concentration 
    253251         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 
     252         DO_2D_00_00 
     253            pato_i(ji,jj) = pato_i(ji,jj) - ( zati2(ji,jj) - zati1(ji,jj) ) &                        !--- open water 
     254               &                          - ( zudy(ji,jj) - zudy(ji-1,jj) + zvdx(ji,jj) - zvdx(ji,jj-1) ) * r1_e1e2t(ji,jj) * zdt 
     255         END_2D 
    260256         CALL lbc_lnk( 'icedyn_adv_pra', pato_i, 'T',  1. ) 
    261257         ! 
    … …  
    309305         ! 
    310306         ! 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 
     307         DO_2D_00_11 
     308            !  Initialize volumes of boxes  (=area if adv_x first called, =psm otherwise)                                      
     309            psm (ji,jj,jl) = MAX( pcrh * e1e2t(ji,jj) + ( 1.0 - pcrh ) * psm(ji,jj,jl) , epsi20 ) 
     310            ! 
     311            zslpmax = MAX( 0._wp, ps0(ji,jj,jl) ) 
     312            zs1max  = 1.5 * zslpmax 
     313            zs1new  = MIN( zs1max, MAX( -zs1max, psx(ji,jj,jl) ) ) 
     314            zs2new  = MIN(  2.0 * zslpmax - 0.3334 * ABS( zs1new ),      & 
     315               &            MAX( ABS( zs1new ) - zslpmax, psxx(ji,jj,jl) )  ) 
     316            rswitch = ( 1.0 - MAX( 0._wp, SIGN( 1._wp, -zslpmax) ) ) * tmask(ji,jj,1)   ! Case of empty boxes & Apply mask 
     317 
     318            ps0 (ji,jj,jl) = zslpmax   
     319            psx (ji,jj,jl) = zs1new         * rswitch 
     320            psxx(ji,jj,jl) = zs2new         * rswitch 
     321            psy (ji,jj,jl) = psy (ji,jj,jl) * rswitch 
     322            psyy(ji,jj,jl) = psyy(ji,jj,jl) * rswitch 
     323            psxy(ji,jj,jl) = MIN( zslpmax, MAX( -zslpmax, psxy(ji,jj,jl) ) ) * rswitch 
     324         END_2D 
    331325 
    332326         !  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 
     327         DO_2D_00_11 
     328            zbet(ji,jj)  =  MAX( 0._wp, SIGN( 1._wp, put(ji,jj) ) ) 
     329            zalf         =  MAX( 0._wp, put(ji,jj) ) * pdt / psm(ji,jj,jl) 
     330            zalfq        =  zalf * zalf 
     331            zalf1        =  1.0 - zalf 
     332            zalf1q       =  zalf1 * zalf1 
     333            ! 
     334            zfm (ji,jj)  =  zalf  *   psm (ji,jj,jl) 
     335            zf0 (ji,jj)  =  zalf  * ( ps0 (ji,jj,jl) + zalf1 * ( psx(ji,jj,jl) + (zalf1 - zalf) * psxx(ji,jj,jl) ) ) 
     336            zfx (ji,jj)  =  zalfq * ( psx (ji,jj,jl) + 3.0 * zalf1 * psxx(ji,jj,jl) ) 
     337            zfxx(ji,jj)  =  zalf  *   psxx(ji,jj,jl) * zalfq 
     338            zfy (ji,jj)  =  zalf  * ( psy (ji,jj,jl) + zalf1 * psxy(ji,jj,jl) ) 
     339            zfxy(ji,jj)  =  zalfq *   psxy(ji,jj,jl) 
     340            zfyy(ji,jj)  =  zalf  *   psyy(ji,jj,jl) 
     341 
     342            !  Readjust moments remaining in the box. 
     343            psm (ji,jj,jl)  =  psm (ji,jj,jl) - zfm(ji,jj) 
     344            ps0 (ji,jj,jl)  =  ps0 (ji,jj,jl) - zf0(ji,jj) 
     345            psx (ji,jj,jl)  =  zalf1q * ( psx(ji,jj,jl) - 3.0 * zalf * psxx(ji,jj,jl) ) 
     346            psxx(ji,jj,jl)  =  zalf1  * zalf1q * psxx(ji,jj,jl) 
     347            psy (ji,jj,jl)  =  psy (ji,jj,jl) - zfy(ji,jj) 
     348            psyy(ji,jj,jl)  =  psyy(ji,jj,jl) - zfyy(ji,jj) 
     349            psxy(ji,jj,jl)  =  zalf1q * psxy(ji,jj,jl) 
     350         END_2D 
     351 
     352         DO_2D_00_10 
     353            zalf          = MAX( 0._wp, -put(ji,jj) ) * pdt / psm(ji+1,jj,jl)  
     354            zalg  (ji,jj) = zalf 
     355            zalfq         = zalf * zalf 
     356            zalf1         = 1.0 - zalf 
     357            zalg1 (ji,jj) = zalf1 
     358            zalf1q        = zalf1 * zalf1 
     359            zalg1q(ji,jj) = zalf1q 
     360            ! 
     361            zfm   (ji,jj) = zfm (ji,jj) + zalf  *    psm (ji+1,jj,jl) 
     362            zf0   (ji,jj) = zf0 (ji,jj) + zalf  * (  ps0 (ji+1,jj,jl) & 
     363               &                                   - zalf1 * ( psx(ji+1,jj,jl) - (zalf1 - zalf ) * psxx(ji+1,jj,jl) ) ) 
     364            zfx   (ji,jj) = zfx (ji,jj) + zalfq * (  psx (ji+1,jj,jl) - 3.0 * zalf1 * psxx(ji+1,jj,jl) ) 
     365            zfxx  (ji,jj) = zfxx(ji,jj) + zalf  *    psxx(ji+1,jj,jl) * zalfq 
     366            zfy   (ji,jj) = zfy (ji,jj) + zalf  * (  psy (ji+1,jj,jl) - zalf1 * psxy(ji+1,jj,jl) ) 
     367            zfxy  (ji,jj) = zfxy(ji,jj) + zalfq *    psxy(ji+1,jj,jl) 
     368            zfyy  (ji,jj) = zfyy(ji,jj) + zalf  *    psyy(ji+1,jj,jl) 
     369         END_2D 
     370 
     371         DO_2D_00_00 
     372            zbt  =       zbet(ji-1,jj) 
     373            zbt1 = 1.0 - zbet(ji-1,jj) 
     374            ! 
     375            psm (ji,jj,jl) = zbt * psm(ji,jj,jl) + zbt1 * ( psm(ji,jj,jl) - zfm(ji-1,jj) ) 
     376            ps0 (ji,jj,jl) = zbt * ps0(ji,jj,jl) + zbt1 * ( ps0(ji,jj,jl) - zf0(ji-1,jj) ) 
     377            psx (ji,jj,jl) = zalg1q(ji-1,jj) * ( psx(ji,jj,jl) + 3.0 * zalg(ji-1,jj) * psxx(ji,jj,jl) ) 
     378            psxx(ji,jj,jl) = zalg1 (ji-1,jj) * zalg1q(ji-1,jj) * psxx(ji,jj,jl) 
     379            psy (ji,jj,jl) = zbt * psy (ji,jj,jl) + zbt1 * ( psy (ji,jj,jl) - zfy (ji-1,jj) ) 
     380            psyy(ji,jj,jl) = zbt * psyy(ji,jj,jl) + zbt1 * ( psyy(ji,jj,jl) - zfyy(ji-1,jj) ) 
     381            psxy(ji,jj,jl) = zalg1q(ji-1,jj) * psxy(ji,jj,jl) 
     382         END_2D 
    395383 
    396384         !   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 
     385         DO_2D_00_00 
     386            zbt  =       zbet(ji-1,jj) 
     387            zbt1 = 1.0 - zbet(ji-1,jj) 
     388            psm(ji,jj,jl) = zbt * ( psm(ji,jj,jl) + zfm(ji-1,jj) ) + zbt1 * psm(ji,jj,jl) 
     389            zalf          = zbt * zfm(ji-1,jj) / psm(ji,jj,jl) 
     390            zalf1         = 1.0 - zalf 
     391            ztemp         = zalf * ps0(ji,jj,jl) - zalf1 * zf0(ji-1,jj) 
     392            ! 
     393            ps0 (ji,jj,jl) =  zbt  * ( ps0(ji,jj,jl) + zf0(ji-1,jj) ) + zbt1 * ps0(ji,jj,jl) 
     394            psx (ji,jj,jl) =  zbt  * ( zalf * zfx(ji-1,jj) + zalf1 * psx(ji,jj,jl) + 3.0 * ztemp ) + zbt1 * psx(ji,jj,jl) 
     395            psxx(ji,jj,jl) =  zbt  * ( zalf * zalf * zfxx(ji-1,jj) + zalf1 * zalf1 * psxx(ji,jj,jl)                             & 
     396               &                     + 5.0 * ( zalf * zalf1 * ( psx (ji,jj,jl) - zfx(ji-1,jj) ) - ( zalf1 - zalf ) * ztemp )  ) & 
     397               &            + zbt1 * psxx(ji,jj,jl) 
     398            psxy(ji,jj,jl) =  zbt  * ( zalf * zfxy(ji-1,jj) + zalf1 * psxy(ji,jj,jl)             & 
     399               &                     + 3.0 * (- zalf1*zfy(ji-1,jj)  + zalf * psy(ji,jj,jl) ) )   & 
     400               &            + zbt1 * psxy(ji,jj,jl) 
     401            psy (ji,jj,jl) =  zbt  * ( psy (ji,jj,jl) + zfy (ji-1,jj) ) + zbt1 * psy (ji,jj,jl) 
     402            psyy(ji,jj,jl) =  zbt  * ( psyy(ji,jj,jl) + zfyy(ji-1,jj) ) + zbt1 * psyy(ji,jj,jl) 
     403         END_2D 
     404 
     405         DO_2D_00_00 
     406            zbt  =       zbet(ji,jj) 
     407            zbt1 = 1.0 - zbet(ji,jj) 
     408            psm(ji,jj,jl) = zbt * psm(ji,jj,jl) + zbt1 * ( psm(ji,jj,jl) + zfm(ji,jj) ) 
     409            zalf          = zbt1 * zfm(ji,jj) / psm(ji,jj,jl) 
     410            zalf1         = 1.0 - zalf 
     411            ztemp         = - zalf * ps0(ji,jj,jl) + zalf1 * zf0(ji,jj) 
     412            ! 
     413            ps0 (ji,jj,jl) = zbt * ps0 (ji,jj,jl) + zbt1 * ( ps0(ji,jj,jl) + zf0(ji,jj) ) 
     414            psx (ji,jj,jl) = zbt * psx (ji,jj,jl) + zbt1 * ( zalf * zfx(ji,jj) + zalf1 * psx(ji,jj,jl) + 3.0 * ztemp ) 
     415            psxx(ji,jj,jl) = zbt * psxx(ji,jj,jl) + zbt1 * ( zalf * zalf * zfxx(ji,jj) + zalf1 * zalf1 * psxx(ji,jj,jl) & 
     416               &                                           + 5.0 * ( zalf * zalf1 * ( - psx(ji,jj,jl) + zfx(ji,jj) )    & 
     417               &                                           + ( zalf1 - zalf ) * ztemp ) ) 
     418            psxy(ji,jj,jl) = zbt * psxy(ji,jj,jl) + zbt1 * ( zalf * zfxy(ji,jj) + zalf1 * psxy(ji,jj,jl)  & 
     419               &                                           + 3.0 * ( zalf1 * zfy(ji,jj) - zalf * psy(ji,jj,jl) ) ) 
     420            psy (ji,jj,jl) = zbt * psy (ji,jj,jl) + zbt1 * ( psy (ji,jj,jl) + zfy (ji,jj) ) 
     421            psyy(ji,jj,jl) = zbt * psyy(ji,jj,jl) + zbt1 * ( psyy(ji,jj,jl) + zfyy(ji,jj) ) 
     422         END_2D 
    439423 
    440424      END DO 
    … …  
    478462         ! 
    479463         ! 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 
     464         DO_2D_11_00 
     465            !  Initialize volumes of boxes (=area if adv_x first called, =psm otherwise) 
     466            psm(ji,jj,jl) = MAX(  pcrh * e1e2t(ji,jj) + ( 1.0 - pcrh ) * psm(ji,jj,jl) , epsi20  ) 
     467            ! 
     468            zslpmax = MAX( 0._wp, ps0(ji,jj,jl) ) 
     469            zs1max  = 1.5 * zslpmax 
     470            zs1new  = MIN( zs1max, MAX( -zs1max, psy(ji,jj,jl) ) ) 
     471            zs2new  = MIN(  ( 2.0 * zslpmax - 0.3334 * ABS( zs1new ) ),   & 
     472               &             MAX( ABS( zs1new )-zslpmax, psyy(ji,jj,jl) )  ) 
     473            rswitch = ( 1.0 - MAX( 0._wp, SIGN( 1._wp, -zslpmax) ) ) * tmask(ji,jj,1)   ! Case of empty boxes & Apply mask 
     474            ! 
     475            ps0 (ji,jj,jl) = zslpmax   
     476            psx (ji,jj,jl) = psx (ji,jj,jl) * rswitch 
     477            psxx(ji,jj,jl) = psxx(ji,jj,jl) * rswitch 
     478            psy (ji,jj,jl) = zs1new         * rswitch 
     479            psyy(ji,jj,jl) = zs2new         * rswitch 
     480            psxy(ji,jj,jl) = MIN( zslpmax, MAX( -zslpmax, psxy(ji,jj,jl) ) ) * rswitch 
     481         END_2D 
    500482  
    501483         !  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 
     484         DO_2D_11_00 
     485            zbet(ji,jj)  =  MAX( 0._wp, SIGN( 1._wp, pvt(ji,jj) ) ) 
     486            zalf         =  MAX( 0._wp, pvt(ji,jj) ) * pdt / psm(ji,jj,jl) 
     487            zalfq        =  zalf * zalf 
     488            zalf1        =  1.0 - zalf 
     489            zalf1q       =  zalf1 * zalf1 
     490            ! 
     491            zfm (ji,jj)  =  zalf  * psm(ji,jj,jl) 
     492            zf0 (ji,jj)  =  zalf  * ( ps0(ji,jj,jl) + zalf1 * ( psy(ji,jj,jl)  + (zalf1-zalf) * psyy(ji,jj,jl) ) )  
     493            zfy (ji,jj)  =  zalfq *( psy(ji,jj,jl) + 3.0*zalf1*psyy(ji,jj,jl) ) 
     494            zfyy(ji,jj)  =  zalf  * zalfq * psyy(ji,jj,jl) 
     495            zfx (ji,jj)  =  zalf  * ( psx(ji,jj,jl) + zalf1 * psxy(ji,jj,jl) ) 
     496            zfxy(ji,jj)  =  zalfq * psxy(ji,jj,jl) 
     497            zfxx(ji,jj)  =  zalf  * psxx(ji,jj,jl) 
     498            ! 
     499            !  Readjust moments remaining in the box. 
     500            psm (ji,jj,jl)  =  psm (ji,jj,jl) - zfm(ji,jj) 
     501            ps0 (ji,jj,jl)  =  ps0 (ji,jj,jl) - zf0(ji,jj) 
     502            psy (ji,jj,jl)  =  zalf1q * ( psy(ji,jj,jl) -3.0 * zalf * psyy(ji,jj,jl) ) 
     503            psyy(ji,jj,jl)  =  zalf1 * zalf1q * psyy(ji,jj,jl) 
     504            psx (ji,jj,jl)  =  psx (ji,jj,jl) - zfx(ji,jj) 
     505            psxx(ji,jj,jl)  =  psxx(ji,jj,jl) - zfxx(ji,jj) 
     506            psxy(ji,jj,jl)  =  zalf1q * psxy(ji,jj,jl) 
     507         END_2D 
     508         ! 
     509         DO_2D_10_00 
     510            zalf          = MAX( 0._wp, -pvt(ji,jj) ) * pdt / psm(ji,jj+1,jl)  
     511            zalg  (ji,jj) = zalf 
     512            zalfq         = zalf * zalf 
     513            zalf1         = 1.0 - zalf 
     514            zalg1 (ji,jj) = zalf1 
     515            zalf1q        = zalf1 * zalf1 
     516            zalg1q(ji,jj) = zalf1q 
     517            ! 
     518            zfm   (ji,jj) = zfm (ji,jj) + zalf  *    psm (ji,jj+1,jl) 
     519            zf0   (ji,jj) = zf0 (ji,jj) + zalf  * (  ps0 (ji,jj+1,jl) & 
     520               &                                   - zalf1 * (psy(ji,jj+1,jl) - (zalf1 - zalf ) * psyy(ji,jj+1,jl) ) ) 
     521            zfy   (ji,jj) = zfy (ji,jj) + zalfq * (  psy (ji,jj+1,jl) - 3.0 * zalf1 * psyy(ji,jj+1,jl) ) 
     522            zfyy  (ji,jj) = zfyy(ji,jj) + zalf  *    psyy(ji,jj+1,jl) * zalfq 
     523            zfx   (ji,jj) = zfx (ji,jj) + zalf  * (  psx (ji,jj+1,jl) - zalf1 * psxy(ji,jj+1,jl) ) 
     524            zfxy  (ji,jj) = zfxy(ji,jj) + zalfq *    psxy(ji,jj+1,jl) 
     525            zfxx  (ji,jj) = zfxx(ji,jj) + zalf  *    psxx(ji,jj+1,jl) 
     526         END_2D 
    549527 
    550528         !  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 
     529         DO_2D_00_00 
     530            zbt  =         zbet(ji,jj-1) 
     531            zbt1 = ( 1.0 - zbet(ji,jj-1) ) 
     532            ! 
     533            psm (ji,jj,jl) = zbt * psm(ji,jj,jl) + zbt1 * ( psm(ji,jj,jl) - zfm(ji,jj-1) ) 
     534            ps0 (ji,jj,jl) = zbt * ps0(ji,jj,jl) + zbt1 * ( ps0(ji,jj,jl) - zf0(ji,jj-1) ) 
     535            psy (ji,jj,jl) = zalg1q(ji,jj-1) * ( psy(ji,jj,jl) + 3.0 * zalg(ji,jj-1) * psyy(ji,jj,jl) ) 
     536            psyy(ji,jj,jl) = zalg1 (ji,jj-1) * zalg1q(ji,jj-1) * psyy(ji,jj,jl) 
     537            psx (ji,jj,jl) = zbt * psx (ji,jj,jl) + zbt1 * ( psx (ji,jj,jl) - zfx (ji,jj-1) ) 
     538            psxx(ji,jj,jl) = zbt * psxx(ji,jj,jl) + zbt1 * ( psxx(ji,jj,jl) - zfxx(ji,jj-1) ) 
     539            psxy(ji,jj,jl) = zalg1q(ji,jj-1) * psxy(ji,jj,jl) 
     540         END_2D 
    565541 
    566542         !   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 
     543         DO_2D_00_00 
     544            zbt  =       zbet(ji,jj-1) 
     545            zbt1 = 1.0 - zbet(ji,jj-1) 
     546            psm(ji,jj,jl) = zbt * ( psm(ji,jj,jl) + zfm(ji,jj-1) ) + zbt1 * psm(ji,jj,jl)  
     547            zalf          = zbt * zfm(ji,jj-1) / psm(ji,jj,jl)  
     548            zalf1         = 1.0 - zalf 
     549            ztemp         = zalf * ps0(ji,jj,jl) - zalf1 * zf0(ji,jj-1) 
     550            ! 
     551            ps0(ji,jj,jl)  =   zbt  * ( ps0(ji,jj,jl) + zf0(ji,jj-1) ) + zbt1 * ps0(ji,jj,jl) 
     552            psy(ji,jj,jl)  =   zbt  * ( zalf * zfy(ji,jj-1) + zalf1 * psy(ji,jj,jl) + 3.0 * ztemp )  & 
     553               &             + zbt1 * psy(ji,jj,jl)   
     554            psyy(ji,jj,jl) =   zbt  * ( zalf * zalf * zfyy(ji,jj-1) + zalf1 * zalf1 * psyy(ji,jj,jl)                           & 
     555               &                      + 5.0 * ( zalf * zalf1 * ( psy(ji,jj,jl) - zfy(ji,jj-1) ) - ( zalf1 - zalf ) * ztemp ) ) &  
     556               &             + zbt1 * psyy(ji,jj,jl) 
     557            psxy(ji,jj,jl) =   zbt  * (  zalf * zfxy(ji,jj-1) + zalf1 * psxy(ji,jj,jl)            & 
     558               &                      + 3.0 * (- zalf1 * zfx(ji,jj-1) + zalf * psx(ji,jj,jl) ) )  & 
     559               &             + zbt1 * psxy(ji,jj,jl) 
     560            psx (ji,jj,jl) =   zbt * ( psx (ji,jj,jl) + zfx (ji,jj-1) ) + zbt1 * psx (ji,jj,jl) 
     561            psxx(ji,jj,jl) =   zbt * ( psxx(ji,jj,jl) + zfxx(ji,jj-1) ) + zbt1 * psxx(ji,jj,jl) 
     562         END_2D 
     563 
     564         DO_2D_00_00 
     565            zbt  =       zbet(ji,jj) 
     566            zbt1 = 1.0 - zbet(ji,jj) 
     567            psm(ji,jj,jl) = zbt * psm(ji,jj,jl) + zbt1 * ( psm(ji,jj,jl) + zfm(ji,jj) ) 
     568            zalf          = zbt1 * zfm(ji,jj) / psm(ji,jj,jl) 
     569            zalf1         = 1.0 - zalf 
     570            ztemp         = - zalf * ps0(ji,jj,jl) + zalf1 * zf0(ji,jj) 
     571            ! 
     572            ps0 (ji,jj,jl) = zbt * ps0 (ji,jj,jl) + zbt1 * (  ps0(ji,jj,jl) + zf0(ji,jj) ) 
     573            psy (ji,jj,jl) = zbt * psy (ji,jj,jl) + zbt1 * (  zalf * zfy(ji,jj) + zalf1 * psy(ji,jj,jl) + 3.0 * ztemp ) 
     574            psyy(ji,jj,jl) = zbt * psyy(ji,jj,jl) + zbt1 * (  zalf * zalf * zfyy(ji,jj) + zalf1 * zalf1 * psyy(ji,jj,jl) & 
     575               &                                            + 5.0 * ( zalf * zalf1 * ( - psy(ji,jj,jl) + zfy(ji,jj) )    & 
     576               &                                            + ( zalf1 - zalf ) * ztemp ) ) 
     577            psxy(ji,jj,jl) = zbt * psxy(ji,jj,jl) + zbt1 * (  zalf * zfxy(ji,jj) + zalf1 * psxy(ji,jj,jl)  & 
     578               &                                            + 3.0 * ( zalf1 * zfx(ji,jj) - zalf * psx(ji,jj,jl) ) ) 
     579            psx (ji,jj,jl) = zbt * psx (ji,jj,jl) + zbt1 * ( psx (ji,jj,jl) + zfx (ji,jj) ) 
     580            psxx(ji,jj,jl) = zbt * psxx(ji,jj,jl) + zbt1 * ( psxx(ji,jj,jl) + zfxx(ji,jj) ) 
     581         END_2D 
    610582 
    611583      END DO 
    … …  
    646618      DO jl = 1, jpl 
    647619 
    648          DO jj = 1, jpj 
    649             DO ji = 1, jpi 
    650                IF ( pv_i(ji,jj,jl) > 0._wp ) THEN 
     620         DO_2D_11_11 
     621            IF ( pv_i(ji,jj,jl) > 0._wp ) THEN 
     622               ! 
     623               !                               ! -- check h_ip -- ! 
     624               ! if h_ip is larger than the surrounding 9 pts => reduce h_ip and increase a_ip 
     625               IF( ln_pnd_H12 .AND. pv_ip(ji,jj,jl) > 0._wp ) THEN 
     626                  zhip = pv_ip(ji,jj,jl) / MAX( epsi20, pa_ip(ji,jj,jl) ) 
     627                  IF( zhip > phip_max(ji,jj,jl) .AND. pa_ip(ji,jj,jl) < 0.15 ) THEN 
     628                     pa_ip(ji,jj,jl) = pv_ip(ji,jj,jl) / phip_max(ji,jj,jl) 
     629                  ENDIF 
     630               ENDIF 
     631               ! 
     632               !                               ! -- check h_i -- ! 
     633               ! if h_i is larger than the surrounding 9 pts => reduce h_i and increase a_i 
     634               zhi = pv_i(ji,jj,jl) / pa_i(ji,jj,jl) 
     635               IF( zhi > phi_max(ji,jj,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 
     636                  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) 
     637               ENDIF 
     638               ! 
     639               !                               ! -- check h_s -- ! 
     640               ! if h_s is larger than the surrounding 9 pts => put the snow excess in the ocean 
     641               zhs = pv_s(ji,jj,jl) / pa_i(ji,jj,jl) 
     642               IF( pv_s(ji,jj,jl) > 0._wp .AND. zhs > phs_max(ji,jj,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 
     643                  zfra = phs_max(ji,jj,jl) / MAX( zhs, epsi20 ) 
    651644                  ! 
    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 
     645                  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 
     646                  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 
    660647                  ! 
    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 
     648                  pe_s(ji,jj,1:nlay_s,jl) = pe_s(ji,jj,1:nlay_s,jl) * zfra 
     649                  pv_s(ji,jj,jl)          = pa_i(ji,jj,jl) * phs_max(ji,jj,jl) 
     650               ENDIF            
     651               !                   
     652            ENDIF 
     653         END_2D 
    684654      END DO  
    685655      ! 
    … …  
    714684      ! -- check snow load -- ! 
    715685      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                   ! 
     686         DO_2D_11_11 
     687            IF ( pv_i(ji,jj,jl) > 0._wp ) THEN 
     688               ! 
     689               zvs_excess = MAX( 0._wp, pv_s(ji,jj,jl) - pv_i(ji,jj,jl) * (rau0-rhoi) * r1_rhos ) 
     690               ! 
     691               IF( zvs_excess > 0._wp ) THEN   ! snow-ice interface deplets below the ocean surface 
     692                  ! put snow excess in the ocean 
     693                  zfra = ( pv_s(ji,jj,jl) - zvs_excess ) / MAX( pv_s(ji,jj,jl), epsi20 ) 
     694                  wfx_res(ji,jj) = wfx_res(ji,jj) + zvs_excess * rhos * z1_dt 
     695                  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 
     696                  ! correct snow volume and heat content 
     697                  pe_s(ji,jj,1:nlay_s,jl) = pe_s(ji,jj,1:nlay_s,jl) * zfra 
     698                  pv_s(ji,jj,jl)          = pv_s(ji,jj,jl) - zvs_excess 
    732699               ENDIF 
    733             END DO 
    734          END DO 
     700               ! 
     701            ENDIF 
     702         END_2D 
    735703      END DO 
    736704      ! 

  • NEMO/trunk/src/ICE/icedyn_adv_umx.F90

    r12197 r12377  
    5151   ! 
    5252   !! * Substitutions 
    53 #  include "vectopt_loop_substitute.h90" 
     53#  include "do_loop_substitute.h90" 
    5454   !!---------------------------------------------------------------------- 
    5555   !! NEMO/ICE 4.0 , NEMO Consortium (2018) 
    … …  
    107107      ! --- Record max of the surrounding 9-pts ice thick. (for call Hbig) --- ! 
    108108      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 
     109         DO_2D_00_00 
     110            zhip_max(ji,jj,jl) = MAX( epsi20, ph_ip(ji,jj,jl), ph_ip(ji+1,jj  ,jl), ph_ip(ji  ,jj+1,jl), & 
     111               &                                               ph_ip(ji-1,jj  ,jl), ph_ip(ji  ,jj-1,jl), & 
     112               &                                               ph_ip(ji+1,jj+1,jl), ph_ip(ji-1,jj-1,jl), & 
     113               &                                               ph_ip(ji+1,jj-1,jl), ph_ip(ji-1,jj+1,jl) ) 
     114            zhi_max (ji,jj,jl) = MAX( epsi20, ph_i (ji,jj,jl), ph_i (ji+1,jj  ,jl), ph_i (ji  ,jj+1,jl), & 
     115               &                                               ph_i (ji-1,jj  ,jl), ph_i (ji  ,jj-1,jl), & 
     116               &                                               ph_i (ji+1,jj+1,jl), ph_i (ji-1,jj-1,jl), & 
     117               &                                               ph_i (ji+1,jj-1,jl), ph_i (ji-1,jj+1,jl) ) 
     118            zhs_max (ji,jj,jl) = MAX( epsi20, ph_s (ji,jj,jl), ph_s (ji+1,jj  ,jl), ph_s (ji  ,jj+1,jl), & 
     119               &                                               ph_s (ji-1,jj  ,jl), ph_s (ji  ,jj-1,jl), & 
     120               &                                               ph_s (ji+1,jj+1,jl), ph_s (ji-1,jj-1,jl), & 
     121               &                                               ph_s (ji+1,jj-1,jl), ph_s (ji-1,jj+1,jl) ) 
     122         END_2D 
    125123      END DO 
    126124      CALL lbc_lnk_multi( 'icedyn_adv_umx', zhi_max, 'T', 1., zhs_max, 'T', 1., zhip_max, 'T', 1. ) 
    … …  
    152150      ! 
    153151      ! --- 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 
     152      DO_2D_00_00 
     153         IF    ( pu_ice(ji,jj) * pu_ice(ji-1,jj) <= 0._wp ) THEN   ;   zcu_box(ji,jj) = 0._wp 
     154         ELSEIF( pu_ice(ji,jj)                   >  0._wp ) THEN   ;   zcu_box(ji,jj) = pu_ice(ji-1,jj) 
     155         ELSE                                                      ;   zcu_box(ji,jj) = pu_ice(ji  ,jj) 
     156         ENDIF 
     157 
     158         IF    ( pv_ice(ji,jj) * pv_ice(ji,jj-1) <= 0._wp ) THEN   ;   zcv_box(ji,jj) = 0._wp 
     159         ELSEIF( pv_ice(ji,jj)                   >  0._wp ) THEN   ;   zcv_box(ji,jj) = pv_ice(ji,jj-1) 
     160         ELSE                                                      ;   zcv_box(ji,jj) = pv_ice(ji,jj  ) 
     161         ENDIF 
     162      END_2D 
    167163 
    168164      !---------------! 
    … …  
    187183            IF( .NOT. ALLOCATED(jmsk_small) )   ALLOCATE( jmsk_small(jpi,jpj,jpl) )  
    188184            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 
     185               DO_2D_10_10 
     186                  zvi_cen = 0.5_wp * ( pv_i(ji+1,jj,jl) + pv_i(ji,jj,jl) ) 
     187                  IF( zvi_cen < epsi06) THEN   ;   imsk_small(ji,jj,jl) = 0 
     188                  ELSE                         ;   imsk_small(ji,jj,jl) = 1   ;   ENDIF 
     189                  zvi_cen = 0.5_wp * ( pv_i(ji,jj+1,jl) + pv_i(ji,jj,jl) ) 
     190                  IF( zvi_cen < epsi06) THEN   ;   jmsk_small(ji,jj,jl) = 0 
     191                  ELSE                         ;   jmsk_small(ji,jj,jl) = 1   ;   ENDIF 
     192               END_2D 
    199193            END DO 
    200194         ENDIF 
    … …  
    338332         !== Open water area ==! 
    339333         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 
     334         DO_2D_00_00 
     335            pato_i(ji,jj) = pato_i(ji,jj) - ( zati2(ji,jj) - zati1(ji,jj) ) &  
     336               &                          - ( zudy(ji,jj) - zudy(ji-1,jj) + zvdx(ji,jj) - zvdx(ji,jj-1) ) * r1_e1e2t(ji,jj) * zdt 
     337         END_2D 
    346338         CALL lbc_lnk( 'icedyn_adv_umx', pato_i, 'T',  1. ) 
    347339         ! 
    … …  
    449441      IF( pamsk == 0._wp ) THEN 
    450442         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 
     443            DO_2D_10_10 
     444               IF( ABS( pu(ji,jj) ) > epsi10 ) THEN 
     445                  zfu_ho (ji,jj,jl) = zfu_ho (ji,jj,jl) * puc    (ji,jj,jl) / pu(ji,jj) 
     446                  zfu_ups(ji,jj,jl) = zfu_ups(ji,jj,jl) * pua_ups(ji,jj,jl) / pu(ji,jj) 
     447               ELSE 
     448                  zfu_ho (ji,jj,jl) = 0._wp 
     449                  zfu_ups(ji,jj,jl) = 0._wp 
     450               ENDIF 
     451               ! 
     452               IF( ABS( pv(ji,jj) ) > epsi10 ) THEN 
     453                  zfv_ho (ji,jj,jl) = zfv_ho (ji,jj,jl) * pvc    (ji,jj,jl) / pv(ji,jj) 
     454                  zfv_ups(ji,jj,jl) = zfv_ups(ji,jj,jl) * pva_ups(ji,jj,jl) / pv(ji,jj) 
     455               ELSE 
     456                  zfv_ho (ji,jj,jl) = 0._wp   
     457                  zfv_ups(ji,jj,jl) = 0._wp   
     458               ENDIF 
     459            END_2D 
    470460         END DO 
    471461 
    … …  
    473463         ! thus we calculate the upstream solution and apply a limiter again 
    474464         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 
     465            DO_2D_00_00 
     466               ztra = - ( zfu_ups(ji,jj,jl) - zfu_ups(ji-1,jj,jl) + zfv_ups(ji,jj,jl) - zfv_ups(ji,jj-1,jl) ) 
     467               ! 
     468               zt_ups(ji,jj,jl) = ( ptc(ji,jj,jl) + ztra * r1_e1e2t(ji,jj) * pdt ) * tmask(ji,jj,1) 
     469            END_2D 
    482470         END DO 
    483471         CALL lbc_lnk( 'icedyn_adv_umx', zt_ups, 'T',  1. ) 
    … …  
    496484      IF( PRESENT( pua_ho ) ) THEN 
    497485         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 
     486            DO_2D_10_10 
     487               pua_ho (ji,jj,jl) = zfu_ho (ji,jj,jl) ; pva_ho (ji,jj,jl) = zfv_ho (ji,jj,jl) 
     488               pua_ups(ji,jj,jl) = zfu_ups(ji,jj,jl) ; pva_ups(ji,jj,jl) = zfv_ups(ji,jj,jl) 
     489            END_2D 
    504490         END DO 
    505491      ENDIF 
    … …  
    508494      ! --------------------------------- 
    509495      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 
     496         DO_2D_00_00 
     497            ztra = - ( zfu_ho(ji,jj,jl) - zfu_ho(ji-1,jj,jl) + zfv_ho(ji,jj,jl) - zfv_ho(ji,jj-1,jl) )   
     498            ! 
     499            ptc(ji,jj,jl) = ( ptc(ji,jj,jl) + ztra * r1_e1e2t(ji,jj) * pdt ) * tmask(ji,jj,1)                
     500         END_2D 
    517501      END DO 
    518502      CALL lbc_lnk( 'icedyn_adv_umx', ptc, 'T',  1. ) 
    … …  
    544528         ! 
    545529         DO jl = 1, jpl 
    546             DO jj = 1, jpjm1 
    547                DO ji = 1, fs_jpim1 
     530            DO_2D_10_10 
     531               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) 
     532               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) 
     533            END_2D 
     534         END DO 
     535         ! 
     536      ELSE                              !** alternate directions **! 
     537         ! 
     538         IF( MOD( (kt - 1) / nn_fsbc , 2 ) ==  MOD( (jt - 1) , 2 ) ) THEN   !==  odd ice time step:  adv_x then adv_y  ==! 
     539            ! 
     540            DO jl = 1, jpl              !-- flux in x-direction 
     541               DO_2D_10_10 
    548542                  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) 
     543               END_2D 
     544            END DO 
     545            ! 
     546            DO jl = 1, jpl              !-- first guess of tracer from u-flux 
     547               DO_2D_00_00 
     548                  ztra = - ( pfu_ups(ji,jj,jl) - pfu_ups(ji-1,jj,jl) )              & 
     549                     &   + ( pu     (ji,jj   ) - pu     (ji-1,jj   ) ) * pt(ji,jj,jl) * (1.-pamsk) 
     550                  ! 
     551                  zpt(ji,jj,jl) = ( pt(ji,jj,jl) + ztra * pdt * r1_e1e2t(ji,jj) ) * tmask(ji,jj,1) 
     552               END_2D 
     553            END DO 
     554            CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1. ) 
     555            ! 
     556            DO jl = 1, jpl              !-- flux in y-direction 
     557               DO_2D_10_10 
     558                  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) 
     559               END_2D 
     560            END DO 
     561            ! 
     562         ELSE                                                               !==  even ice time step:  adv_y then adv_x  ==! 
     563            ! 
     564            DO jl = 1, jpl              !-- flux in y-direction 
     565               DO_2D_10_10 
    549566                  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  ==! 
     567               END_2D 
     568            END DO 
     569            ! 
     570            DO jl = 1, jpl              !-- first guess of tracer from v-flux 
     571               DO_2D_00_00 
     572                  ztra = - ( pfv_ups(ji,jj,jl) - pfv_ups(ji,jj-1,jl) )  & 
     573                     &   + ( pv     (ji,jj   ) - pv     (ji,jj-1   ) ) * pt(ji,jj,jl) * (1.-pamsk) 
     574                  ! 
     575                  zpt(ji,jj,jl) = ( pt(ji,jj,jl) + ztra * pdt * r1_e1e2t(ji,jj) ) * tmask(ji,jj,1) 
     576               END_2D 
     577            END DO 
     578            CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1. ) 
    557579            ! 
    558580            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 
     581               DO_2D_10_10 
     582                  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) 
     583               END_2D 
    614584            END DO 
    615585            ! 
    … …  
    619589      ! 
    620590      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 
     591         DO_2D_00_00 
     592            ztra = - (   pfu_ups(ji,jj,jl) - pfu_ups(ji-1,jj  ,jl)   & 
     593               &       + pfv_ups(ji,jj,jl) - pfv_ups(ji  ,jj-1,jl) ) & 
     594               &   + (   pu     (ji,jj   ) - pu     (ji-1,jj     )   & 
     595               &       + pv     (ji,jj   ) - pv     (ji  ,jj-1   ) ) * pt(ji,jj,jl) * (1.-pamsk) 
     596            ! 
     597            pt_ups(ji,jj,jl) = ( pt(ji,jj,jl) + ztra * pdt * r1_e1e2t(ji,jj) ) * tmask(ji,jj,1) 
     598         END_2D 
    631599      END DO 
    632600      CALL lbc_lnk( 'icedyn_adv_umx', pt_ups, 'T', 1. ) 
    … …  
    660628         ! 
    661629         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 
     630            DO_2D_10_10 
     631               pfu_ho(ji,jj,jl) = 0.5_wp * pu(ji,jj) * ( pt(ji,jj,jl) + pt(ji+1,jj  ,jl) ) 
     632               pfv_ho(ji,jj,jl) = 0.5_wp * pv(ji,jj) * ( pt(ji,jj,jl) + pt(ji  ,jj+1,jl) ) 
     633            END_2D 
    668634         END DO 
    669635         ! 
    … …  
    680646            ! 
    681647            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 
     648               DO_2D_10_10 
     649                  pfu_ho(ji,jj,jl) = 0.5_wp * pu(ji,jj) * ( pt(ji,jj,jl) + pt(ji+1,jj,jl) ) 
     650               END_2D 
    687651            END DO 
    688652            IF( np_limiter == 2 .OR. np_limiter == 3 )   CALL limiter_x( pdt, pu, pt, pfu_ups, pfu_ho ) 
    689653 
    690654            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 
     655               DO_2D_00_00 
     656                  ztra = - ( pfu_ho(ji,jj,jl) - pfu_ho(ji-1,jj,jl) )              & 
     657                     &   + ( pu    (ji,jj   ) - pu    (ji-1,jj   ) ) * pt(ji,jj,jl) * (1.-pamsk) 
     658                  ! 
     659                  zpt(ji,jj,jl) = ( pt(ji,jj,jl) + ztra * pdt * r1_e1e2t(ji,jj) ) * tmask(ji,jj,1) 
     660               END_2D 
    699661            END DO 
    700662            CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1. ) 
    701663 
    702664            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 
     665               DO_2D_10_10 
     666                  pfv_ho(ji,jj,jl) = 0.5_wp * pv(ji,jj) * ( zpt(ji,jj,jl) + zpt(ji,jj+1,jl) ) 
     667               END_2D 
    708668            END DO 
    709669            IF( np_limiter == 2 .OR. np_limiter == 3 )   CALL limiter_y( pdt, pv, pt, pfv_ups, pfv_ho ) 
    … …  
    712672            ! 
    713673            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 
     674               DO_2D_10_10 
     675                  pfv_ho(ji,jj,jl) = 0.5_wp * pv(ji,jj) * ( pt(ji,jj,jl) + pt(ji,jj+1,jl) ) 
     676               END_2D 
    719677            END DO 
    720678            IF( np_limiter == 2 .OR. np_limiter == 3 )   CALL limiter_y( pdt, pv, pt, pfv_ups, pfv_ho ) 
    721679            ! 
    722680            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 
     681               DO_2D_00_00 
     682                  ztra = - ( pfv_ho(ji,jj,jl) - pfv_ho(ji,jj-1,jl) )  & 
     683                     &   + ( pv    (ji,jj   ) - pv    (ji,jj-1   ) ) * pt(ji,jj,jl) * (1.-pamsk) 
     684                  ! 
     685                  zpt(ji,jj,jl) = ( pt(ji,jj,jl) + ztra * pdt * r1_e1e2t(ji,jj) ) * tmask(ji,jj,1) 
     686               END_2D 
    731687            END DO 
    732688            CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1. ) 
    733689            ! 
    734690            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 
     691               DO_2D_10_10 
     692                  pfu_ho(ji,jj,jl) = 0.5_wp * pu(ji,jj) * ( zpt(ji,jj,jl) + zpt(ji+1,jj,jl) ) 
     693               END_2D 
    740694            END DO 
    741695            IF( np_limiter == 2 .OR. np_limiter == 3 )   CALL limiter_x( pdt, pu, pt, pfu_ups, pfu_ho ) 
    … …  
    783737         !                                                        !--  advective form update in zpt  --! 
    784738         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 
     739            DO_2D_00_00 
     740               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) & 
     741                  &                              + pt   (ji,jj,jl) * ( pu  (ji,jj   ) - pu  (ji-1,jj   ) ) * r1_e1e2t(ji,jj) & 
     742                  &                                                                                        * pamsk           & 
     743                  &                             ) * pdt ) * tmask(ji,jj,1) 
     744            END_2D 
    793745         END DO 
    794746         CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1. ) 
    … …  
    812764         !                                                        !--  advective form update in zpt  --! 
    813765         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 
     766            DO_2D_00_00 
     767               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) & 
     768                  &                              + pt   (ji,jj,jl) * ( pv  (ji,jj   ) - pv  (ji,jj-1   ) ) * r1_e1e2t(ji,jj) & 
     769                  &                                                                                        * pamsk           & 
     770                  &                             ) * pdt ) * tmask(ji,jj,1)  
     771            END_2D 
    822772         END DO 
    823773         CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1. ) 
    … …  
    865815      DO jl = 1, jpl 
    866816         DO jj = 2, jpjm1         ! First derivative (gradient) 
    867             DO ji = 1, fs_jpim1 
     817            DO ji = 1, jpim1 
    868818               ztu1(ji,jj,jl) = ( pt(ji+1,jj,jl) - pt(ji,jj,jl) ) * r1_e1u(ji,jj) * umask(ji,jj,1) 
    869819            END DO 
    870820            !                     ! Second derivative (Laplacian) 
    871             DO ji = fs_2, fs_jpim1 
     821            DO ji = 2, jpim1 
    872822               ztu2(ji,jj,jl) = ( ztu1(ji,jj,jl) - ztu1(ji-1,jj,jl) ) * r1_e1t(ji,jj) 
    873823            END DO 
    … …  
    879829      DO jl = 1, jpl 
    880830         DO jj = 2, jpjm1         ! Third derivative 
    881             DO ji = 1, fs_jpim1 
     831            DO ji = 1, jpim1 
    882832               ztu3(ji,jj,jl) = ( ztu2(ji+1,jj,jl) - ztu2(ji,jj,jl) ) * r1_e1u(ji,jj) * umask(ji,jj,1) 
    883833            END DO 
    884834            !                     ! Fourth derivative 
    885             DO ji = fs_2, fs_jpim1 
     835            DO ji = 2, jpim1 
    886836               ztu4(ji,jj,jl) = ( ztu3(ji,jj,jl) - ztu3(ji-1,jj,jl) ) * r1_e1t(ji,jj) 
    887837            END DO 
    … …  
    896846         !         
    897847         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 
     848            DO_2D_10_10 
     849               pt_u(ji,jj,jl) = 0.5_wp * umask(ji,jj,1) * (                                pt(ji+1,jj,jl) + pt(ji,jj,jl)   & 
     850                  &                                         - SIGN( 1._wp, pu(ji,jj) ) * ( pt(ji+1,jj,jl) - pt(ji,jj,jl) ) ) 
     851            END_2D 
    904852         END DO 
    905853         ! 
    … …  
    907855         ! 
    908856         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 
     857            DO_2D_10_10 
     858               zcu  = pu(ji,jj) * r1_e2u(ji,jj) * pdt * r1_e1u(ji,jj) 
     859               pt_u(ji,jj,jl) = 0.5_wp * umask(ji,jj,1) * (                                pt(ji+1,jj,jl) + pt(ji,jj,jl)   & 
     860                  &                                                            - zcu   * ( pt(ji+1,jj,jl) - pt(ji,jj,jl) ) )  
     861            END_2D 
    916862         END DO 
    917863         !   
    … …  
    919865         ! 
    920866         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) 
     867            DO_2D_10_10 
     868               zcu  = pu(ji,jj) * r1_e2u(ji,jj) * pdt * r1_e1u(ji,jj) 
     869               zdx2 = e1u(ji,jj) * e1u(ji,jj) 
    925870!!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 
     871               pt_u(ji,jj,jl) = 0.5_wp * umask(ji,jj,1) * (         (                      pt  (ji+1,jj,jl) + pt  (ji,jj,jl)     & 
     872                  &                                                            - zcu   * ( pt  (ji+1,jj,jl) - pt  (ji,jj,jl) ) ) & 
     873                  &        + z1_6 * zdx2 * ( zcu*zcu - 1._wp ) *    (                      ztu2(ji+1,jj,jl) + ztu2(ji,jj,jl)     & 
     874                  &                                               - SIGN( 1._wp, zcu ) * ( ztu2(ji+1,jj,jl) - ztu2(ji,jj,jl) ) ) ) 
     875            END_2D 
    932876         END DO 
    933877         ! 
    … …  
    935879         ! 
    936880         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) 
     881            DO_2D_10_10 
     882               zcu  = pu(ji,jj) * r1_e2u(ji,jj) * pdt * r1_e1u(ji,jj) 
     883               zdx2 = e1u(ji,jj) * e1u(ji,jj) 
    941884!!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 
     885               pt_u(ji,jj,jl) = 0.5_wp * umask(ji,jj,1) * (         (                      pt  (ji+1,jj,jl) + pt  (ji,jj,jl)     & 
     886                  &                                                            - zcu   * ( pt  (ji+1,jj,jl) - pt  (ji,jj,jl) ) ) & 
     887                  &        + z1_6 * zdx2 * ( zcu*zcu - 1._wp ) *    (                      ztu2(ji+1,jj,jl) + ztu2(ji,jj,jl)     & 
     888                  &                                                   - 0.5_wp * zcu   * ( ztu2(ji+1,jj,jl) - ztu2(ji,jj,jl) ) ) ) 
     889            END_2D 
    948890         END DO 
    949891         ! 
    … …  
    951893         ! 
    952894         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) 
     895            DO_2D_10_10 
     896               zcu  = pu(ji,jj) * r1_e2u(ji,jj) * pdt * r1_e1u(ji,jj) 
     897               zdx2 = e1u(ji,jj) * e1u(ji,jj) 
    957898!!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 
     899               zdx4 = zdx2 * zdx2 
     900               pt_u(ji,jj,jl) = 0.5_wp * umask(ji,jj,1) * (        (                       pt  (ji+1,jj,jl) + pt  (ji,jj,jl)     & 
     901                  &                                                            - zcu   * ( pt  (ji+1,jj,jl) - pt  (ji,jj,jl) ) ) & 
     902                  &        + z1_6   * zdx2 * ( zcu*zcu - 1._wp ) * (                       ztu2(ji+1,jj,jl) + ztu2(ji,jj,jl)     & 
     903                  &                                                   - 0.5_wp * zcu   * ( ztu2(ji+1,jj,jl) - ztu2(ji,jj,jl) ) ) & 
     904                  &        + z1_120 * zdx4 * ( zcu*zcu - 1._wp ) * ( zcu*zcu - 4._wp ) * ( ztu4(ji+1,jj,jl) + ztu4(ji,jj,jl)     & 
     905                  &                                               - SIGN( 1._wp, zcu ) * ( ztu4(ji+1,jj,jl) - ztu4(ji,jj,jl) ) ) ) 
     906            END_2D 
    967907         END DO 
    968908         ! 
    … …  
    974914      IF( ll_neg ) THEN 
    975915         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 
     916            DO_2D_10_10 
     917               IF( pt_u(ji,jj,jl) < 0._wp .OR. ( imsk_small(ji,jj,jl) == 0 .AND. pamsk == 0. ) ) THEN 
     918                  pt_u(ji,jj,jl) = 0.5_wp * umask(ji,jj,1) * (                                pt(ji+1,jj,jl) + pt(ji,jj,jl)   & 
     919                     &                                         - SIGN( 1._wp, pu(ji,jj) ) * ( pt(ji+1,jj,jl) - pt(ji,jj,jl) ) ) 
     920               ENDIF 
     921            END_2D 
    984922         END DO 
    985923      ENDIF 
    986924      !                                                     !-- High order flux in i-direction  --! 
    987925      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 
     926         DO_2D_10_10 
     927            pfu_ho(ji,jj,jl) = pu(ji,jj) * pt_u(ji,jj,jl) 
     928         END_2D 
    993929      END DO 
    994930      ! 
    … …  
    1021957      !                                                     !--  Laplacian in j-direction  --! 
    1022958      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 
     959         DO_2D_10_00 
     960            ztv1(ji,jj,jl) = ( pt(ji,jj+1,jl) - pt(ji,jj,jl) ) * r1_e2v(ji,jj) * vmask(ji,jj,1) 
     961         END_2D 
     962         DO_2D_00_00 
     963            ztv2(ji,jj,jl) = ( ztv1(ji,jj,jl) - ztv1(ji,jj-1,jl) ) * r1_e2t(ji,jj) 
     964         END_2D 
    1033965      END DO 
    1034966      CALL lbc_lnk( 'icedyn_adv_umx', ztv2, 'T', 1. ) 
    … …  
    1036968      !                                                     !--  BiLaplacian in j-direction  --! 
    1037969      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 
     970         DO_2D_10_00 
     971            ztv3(ji,jj,jl) = ( ztv2(ji,jj+1,jl) - ztv2(ji,jj,jl) ) * r1_e2v(ji,jj) * vmask(ji,jj,1) 
     972         END_2D 
     973         DO_2D_00_00 
     974            ztv4(ji,jj,jl) = ( ztv3(ji,jj,jl) - ztv3(ji,jj-1,jl) ) * r1_e2t(ji,jj) 
     975         END_2D 
    1048976      END DO 
    1049977      CALL lbc_lnk( 'icedyn_adv_umx', ztv4, 'T', 1. ) 
    … …  
    1054982      CASE( 1 )                                                !==  1st order central TIM  ==! (Eq. 21) 
    1055983         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 
     984            DO_2D_10_10 
     985               pt_v(ji,jj,jl) = 0.5_wp * vmask(ji,jj,1) * (                                pt(ji,jj+1,jl) + pt(ji,jj,jl)   & 
     986                  &                                         - SIGN( 1._wp, pv(ji,jj) ) * ( pt(ji,jj+1,jl) - pt(ji,jj,jl) ) ) 
     987            END_2D 
    1062988         END DO 
    1063989         ! 
    1064990      CASE( 2 )                                                !==  2nd order central TIM  ==! (Eq. 23) 
    1065991         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 
     992            DO_2D_10_10 
     993               zcv  = pv(ji,jj) * r1_e1v(ji,jj) * pdt * r1_e2v(ji,jj) 
     994               pt_v(ji,jj,jl) = 0.5_wp * vmask(ji,jj,1) * (                                pt(ji,jj+1,jl) + pt(ji,jj,jl)   & 
     995                  &                                                            - zcv *   ( pt(ji,jj+1,jl) - pt(ji,jj,jl) ) ) 
     996            END_2D 
    1073997         END DO 
    1074998         ! 
    1075999      CASE( 3 )                                                !==  3rd order central TIM  ==! (Eq. 24) 
    10761000         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) 
     1001            DO_2D_10_10 
     1002               zcv  = pv(ji,jj) * r1_e1v(ji,jj) * pdt * r1_e2v(ji,jj) 
     1003               zdy2 = e2v(ji,jj) * e2v(ji,jj) 
    10811004!!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 
     1005               pt_v(ji,jj,jl) = 0.5_wp * vmask(ji,jj,1) * (      (                         pt  (ji,jj+1,jl) + pt  (ji,jj,jl)     & 
     1006                  &                                                            - zcv   * ( pt  (ji,jj+1,jl) - pt  (ji,jj,jl) ) ) & 
     1007                  &        + z1_6 * zdy2 * ( zcv*zcv - 1._wp ) * (                         ztv2(ji,jj+1,jl) + ztv2(ji,jj,jl)     & 
     1008                  &                                               - SIGN( 1._wp, zcv ) * ( ztv2(ji,jj+1,jl) - ztv2(ji,jj,jl) ) ) ) 
     1009            END_2D 
    10881010         END DO 
    10891011         ! 
    10901012      CASE( 4 )                                                !==  4th order central TIM  ==! (Eq. 27) 
    10911013         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) 
     1014            DO_2D_10_10 
     1015               zcv  = pv(ji,jj) * r1_e1v(ji,jj) * pdt * r1_e2v(ji,jj) 
     1016               zdy2 = e2v(ji,jj) * e2v(ji,jj) 
    10961017!!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 
     1018               pt_v(ji,jj,jl) = 0.5_wp * vmask(ji,jj,1) * (      (                         pt  (ji,jj+1,jl) + pt  (ji,jj,jl)     & 
     1019                  &                                                            - zcv   * ( pt  (ji,jj+1,jl) - pt  (ji,jj,jl) ) ) & 
     1020                  &        + z1_6 * zdy2 * ( zcv*zcv - 1._wp ) * (                         ztv2(ji,jj+1,jl) + ztv2(ji,jj,jl)     & 
     1021                  &                                                   - 0.5_wp * zcv   * ( ztv2(ji,jj+1,jl) - ztv2(ji,jj,jl) ) ) ) 
     1022            END_2D 
    11031023         END DO 
    11041024         ! 
    11051025      CASE( 5 )                                                !==  5th order central TIM  ==! (Eq. 29) 
    11061026         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) 
     1027            DO_2D_10_10 
     1028               zcv  = pv(ji,jj) * r1_e1v(ji,jj) * pdt * r1_e2v(ji,jj) 
     1029               zdy2 = e2v(ji,jj) * e2v(ji,jj) 
    11111030!!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 
     1031               zdy4 = zdy2 * zdy2 
     1032               pt_v(ji,jj,jl) = 0.5_wp * vmask(ji,jj,1) * (                              ( pt  (ji,jj+1,jl) + pt  (ji,jj,jl)     & 
     1033                  &                                                            - zcv   * ( pt  (ji,jj+1,jl) - pt  (ji,jj,jl) ) ) & 
     1034                  &        + z1_6   * zdy2 * ( zcv*zcv - 1._wp ) * (                       ztv2(ji,jj+1,jl) + ztv2(ji,jj,jl)     & 
     1035                  &                                                   - 0.5_wp * zcv   * ( ztv2(ji,jj+1,jl) - ztv2(ji,jj,jl) ) ) & 
     1036                  &        + z1_120 * zdy4 * ( zcv*zcv - 1._wp ) * ( zcv*zcv - 4._wp ) * ( ztv4(ji,jj+1,jl) + ztv4(ji,jj,jl)     & 
     1037                  &                                               - SIGN( 1._wp, zcv ) * ( ztv4(ji,jj+1,jl) - ztv4(ji,jj,jl) ) ) ) 
     1038            END_2D 
    11211039         END DO 
    11221040         ! 
    … …  
    11281046      IF( ll_neg ) THEN 
    11291047         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 
     1048            DO_2D_10_10 
     1049               IF( pt_v(ji,jj,jl) < 0._wp .OR. ( jmsk_small(ji,jj,jl) == 0 .AND. pamsk == 0. ) ) THEN 
     1050                  pt_v(ji,jj,jl) = 0.5_wp * vmask(ji,jj,1) * (                              ( pt(ji,jj+1,jl) + pt(ji,jj,jl) )  & 
     1051                     &                                         - SIGN( 1._wp, pv(ji,jj) ) * ( pt(ji,jj+1,jl) - pt(ji,jj,jl) ) ) 
     1052               ENDIF 
     1053            END_2D 
    11381054         END DO 
    11391055      ENDIF 
    11401056      !                                                     !-- High order flux in j-direction  --! 
    11411057      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 
     1058         DO_2D_10_10 
     1059            pfv_ho(ji,jj,jl) = pv(ji,jj) * pt_v(ji,jj,jl) 
     1060         END_2D 
    11471061      END DO 
    11481062      ! 
    … …  
    11781092      ! -------------------------------------------------- 
    11791093      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 
     1094         DO_2D_10_10 
     1095            pfu_ho(ji,jj,jl) = pfu_ho(ji,jj,jl) - pfu_ups(ji,jj,jl) 
     1096            pfv_ho(ji,jj,jl) = pfv_ho(ji,jj,jl) - pfv_ups(ji,jj,jl) 
     1097         END_2D 
    11861098      END DO 
    11871099 
    … …  
    11971109          
    11981110         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 
     1111            DO_2D_00_00 
     1112               zti_ups(ji,jj,jl)= pt_ups(ji+1,jj  ,jl) 
     1113               ztj_ups(ji,jj,jl)= pt_ups(ji  ,jj+1,jl) 
     1114            END_2D 
    12051115         END DO 
    12061116         CALL lbc_lnk_multi( 'icedyn_adv_umx', zti_ups, 'T', 1., ztj_ups, 'T', 1. ) 
    12071117 
    12081118         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                      ! 
     1119            DO_2D_00_00 
     1120               IF ( pfu_ho(ji,jj,jl) * ( pt_ups(ji+1,jj  ,jl) - pt_ups(ji,jj,jl) ) <= 0._wp .AND.  & 
     1121                  & pfv_ho(ji,jj,jl) * ( pt_ups(ji  ,jj+1,jl) - pt_ups(ji,jj,jl) ) <= 0._wp ) THEN 
     1122                  ! 
     1123                  IF(  pfu_ho(ji,jj,jl) * ( zti_ups(ji+1,jj  ,jl) - zti_ups(ji,jj,jl) ) <= 0._wp .AND.  & 
     1124                     & pfv_ho(ji,jj,jl) * ( ztj_ups(ji  ,jj+1,jl) - ztj_ups(ji,jj,jl) ) <= 0._wp ) THEN 
     1125                     pfu_ho(ji,jj,jl)=0._wp 
     1126                     pfv_ho(ji,jj,jl)=0._wp 
    12261127                  ENDIF 
    1227                END DO 
    1228             END DO 
     1128                  ! 
     1129                  IF(  pfu_ho(ji,jj,jl) * ( pt_ups(ji,jj,jl) - pt_ups(ji-1,jj  ,jl) ) <= 0._wp .AND.  & 
     1130                     & pfv_ho(ji,jj,jl) * ( pt_ups(ji,jj,jl) - pt_ups(ji  ,jj-1,jl) ) <= 0._wp ) THEN 
     1131                     pfu_ho(ji,jj,jl)=0._wp 
     1132                     pfv_ho(ji,jj,jl)=0._wp 
     1133                  ENDIF 
     1134                  ! 
     1135               ENDIF 
     1136            END_2D 
    12291137         END DO 
    12301138         CALL lbc_lnk_multi( 'icedyn_adv_umx', pfu_ho, 'U', -1., pfv_ho, 'V', -1. )   ! lateral boundary cond. 
    … …  
    12381146      DO jl = 1, jpl 
    12391147          
    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 
     1148         DO_2D_11_11 
     1149            IF    ( pt(ji,jj,jl) <= 0._wp .AND. pt_ups(ji,jj,jl) <= 0._wp ) THEN 
     1150               zbup(ji,jj) = -zbig 
     1151               zbdo(ji,jj) =  zbig 
     1152            ELSEIF( pt(ji,jj,jl) <= 0._wp .AND. pt_ups(ji,jj,jl) > 0._wp ) THEN 
     1153               zbup(ji,jj) = pt_ups(ji,jj,jl) 
     1154               zbdo(ji,jj) = pt_ups(ji,jj,jl) 
     1155            ELSEIF( pt(ji,jj,jl) > 0._wp .AND. pt_ups(ji,jj,jl) <= 0._wp ) THEN 
     1156               zbup(ji,jj) = pt(ji,jj,jl) 
     1157               zbdo(ji,jj) = pt(ji,jj,jl) 
     1158            ELSE 
     1159               zbup(ji,jj) = MAX( pt(ji,jj,jl) , pt_ups(ji,jj,jl) ) 
     1160               zbdo(ji,jj) = MIN( pt(ji,jj,jl) , pt_ups(ji,jj,jl) ) 
     1161            ENDIF 
     1162         END_2D 
     1163 
     1164         DO_2D_00_00 
     1165            ! 
     1166            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 
     1167            zdo  = MIN( zbdo(ji,jj), zbdo(ji-1,jj), zbdo(ji+1,jj), zbdo(ji,jj-1), zbdo(ji,jj+1) ) 
     1168            ! 
     1169            zpos = MAX( 0._wp, pfu_ho(ji-1,jj  ,jl) ) - MIN( 0._wp, pfu_ho(ji  ,jj  ,jl) ) &  ! positive/negative part of the flux 
     1170               & + MAX( 0._wp, pfv_ho(ji  ,jj-1,jl) ) - MIN( 0._wp, pfv_ho(ji  ,jj  ,jl) ) 
     1171            zneg = MAX( 0._wp, pfu_ho(ji  ,jj  ,jl) ) - MIN( 0._wp, pfu_ho(ji-1,jj  ,jl) ) & 
     1172               & + MAX( 0._wp, pfv_ho(ji  ,jj  ,jl) ) - MIN( 0._wp, pfv_ho(ji  ,jj-1,jl) ) 
     1173            ! 
     1174            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) ) & 
     1175               &          ) * ( 1. - pamsk ) 
     1176            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) ) & 
     1177               &          ) * ( 1. - pamsk ) 
     1178            ! 
     1179            !                                  ! up & down beta terms 
     1180            ! 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 !!!) 
     1181            IF( zpos > epsi10 ) THEN ; zbetup(ji,jj,jl) = MAX( 0._wp, zup - pt_ups(ji,jj,jl) ) / zpos * e1e2t(ji,jj) * z1_dt 
     1182            ELSE                     ; zbetup(ji,jj,jl) = 0._wp ! zbig 
     1183            ENDIF 
     1184            ! 
     1185            IF( zneg > epsi10 ) THEN ; zbetdo(ji,jj,jl) = MAX( 0._wp, pt_ups(ji,jj,jl) - zdo ) / zneg * e1e2t(ji,jj) * z1_dt 
     1186            ELSE                     ; zbetdo(ji,jj,jl) = 0._wp ! zbig 
     1187            ENDIF 
     1188            ! 
     1189            ! if all the points are outside ice cover 
     1190            IF( zup == -zbig )   zbetup(ji,jj,jl) = 0._wp ! zbig 
     1191            IF( zdo ==  zbig )   zbetdo(ji,jj,jl) = 0._wp ! zbig             
     1192            ! 
     1193         END_2D 
    12901194      END DO 
    12911195      CALL lbc_lnk_multi( 'icedyn_adv_umx', zbetup, 'T', 1., zbetdo, 'T', 1. )   ! lateral boundary cond. (unchanged sign) 
    … …  
    12951199      ! --------------------------------- 
    12961200      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 
     1201         DO_2D_10_10 
     1202            zau = MIN( 1._wp , zbetdo(ji,jj,jl) , zbetup(ji+1,jj,jl) ) 
     1203            zbu = MIN( 1._wp , zbetup(ji,jj,jl) , zbetdo(ji+1,jj,jl) ) 
     1204            zcu = 0.5_wp + SIGN( 0.5_wp , pfu_ho(ji,jj,jl) ) 
     1205            ! 
     1206            zcoef = ( zcu * zau + ( 1._wp - zcu ) * zbu ) 
     1207            ! 
     1208            pfu_ho(ji,jj,jl) = pfu_ho(ji,jj,jl) * zcoef + pfu_ups(ji,jj,jl) 
     1209            ! 
     1210         END_2D 
     1211 
     1212         DO_2D_10_10 
     1213            zav = MIN( 1._wp , zbetdo(ji,jj,jl) , zbetup(ji,jj+1,jl) ) 
     1214            zbv = MIN( 1._wp , zbetup(ji,jj,jl) , zbetdo(ji,jj+1,jl) ) 
     1215            zcv = 0.5_wp + SIGN( 0.5_wp , pfv_ho(ji,jj,jl) ) 
     1216            ! 
     1217            zcoef = ( zcv * zav + ( 1._wp - zcv ) * zbv ) 
     1218            ! 
     1219            pfv_ho(ji,jj,jl) = pfv_ho(ji,jj,jl) * zcoef + pfv_ups(ji,jj,jl) 
     1220            ! 
     1221         END_2D 
    13221222 
    13231223      END DO 
    … …  
    13441244      ! 
    13451245      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 
     1246         DO_2D_00_00 
     1247            zslpx(ji,jj,jl) = ( pt(ji+1,jj,jl) - pt(ji,jj,jl) ) * umask(ji,jj,1) 
     1248         END_2D 
    13511249      END DO 
    13521250      CALL lbc_lnk( 'icedyn_adv_umx', zslpx, 'U', -1.)   ! lateral boundary cond. 
    13531251       
    13541252      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 
     1253         DO_2D_00_00 
     1254            uCFL = pdt * ABS( pu(ji,jj) ) * r1_e1e2t(ji,jj) 
     1255             
     1256            Rjm = zslpx(ji-1,jj,jl) 
     1257            Rj  = zslpx(ji  ,jj,jl) 
     1258            Rjp = zslpx(ji+1,jj,jl) 
     1259 
     1260            IF( np_limiter == 3 ) THEN 
     1261 
     1262               IF( pu(ji,jj) > 0. ) THEN   ;   Rr = Rjm 
     1263               ELSE                        ;   Rr = Rjp 
     1264               ENDIF 
     1265 
     1266               zh3 = pfu_ho(ji,jj,jl) - pfu_ups(ji,jj,jl)      
     1267               IF( Rj > 0. ) THEN 
     1268                  zlimiter =  MAX( 0., MIN( zh3, MAX(-Rr * 0.5 * ABS(pu(ji,jj)),  & 
     1269                     &        MIN( 2. * Rr * 0.5 * ABS(pu(ji,jj)),  zh3,  1.5 * Rj * 0.5 * ABS(pu(ji,jj)) ) ) ) ) 
     1270               ELSE 
     1271                  zlimiter = -MAX( 0., MIN(-zh3, MAX( Rr * 0.5 * ABS(pu(ji,jj)),  & 
     1272                     &        MIN(-2. * Rr * 0.5 * ABS(pu(ji,jj)), -zh3, -1.5 * Rj * 0.5 * ABS(pu(ji,jj)) ) ) ) ) 
     1273               ENDIF 
     1274               pfu_ho(ji,jj,jl) = pfu_ups(ji,jj,jl) + zlimiter 
     1275 
     1276            ELSEIF( np_limiter == 2 ) THEN 
     1277               IF( Rj /= 0. ) THEN 
     1278                  IF( pu(ji,jj) > 0. ) THEN   ;   Cr = Rjm / Rj 
     1279                  ELSE                        ;   Cr = Rjp / Rj 
    13671280                  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  
     1281               ELSE 
     1282                  Cr = 0. 
    14141283               ENDIF 
    1415             END DO 
    1416          END DO 
     1284 
     1285               ! -- superbee -- 
     1286               zpsi = MAX( 0., MAX( MIN(1.,2.*Cr), MIN(2.,Cr) ) ) 
     1287               ! -- van albada 2 -- 
     1288               !!zpsi = 2.*Cr / (Cr*Cr+1.) 
     1289               ! -- sweby (with beta=1) -- 
     1290               !!zpsi = MAX( 0., MAX( MIN(1.,1.*Cr), MIN(1.,Cr) ) ) 
     1291               ! -- van Leer -- 
     1292               !!zpsi = ( Cr + ABS(Cr) ) / ( 1. + ABS(Cr) ) 
     1293               ! -- ospre -- 
     1294               !!zpsi = 1.5 * ( Cr*Cr + Cr ) / ( Cr*Cr + Cr + 1. ) 
     1295               ! -- koren -- 
     1296               !!zpsi = MAX( 0., MIN( 2.*Cr, MIN( (1.+2*Cr)/3., 2. ) ) ) 
     1297               ! -- charm -- 
     1298               !IF( Cr > 0. ) THEN   ;   zpsi = Cr * (3.*Cr + 1.) / ( (Cr + 1.) * (Cr + 1.) ) 
     1299               !ELSE                 ;   zpsi = 0. 
     1300               !ENDIF 
     1301               ! -- van albada 1 -- 
     1302               !!zpsi = (Cr*Cr + Cr) / (Cr*Cr +1) 
     1303               ! -- smart -- 
     1304               !!zpsi = MAX( 0., MIN( 2.*Cr, MIN( 0.25+0.75*Cr, 4. ) ) ) 
     1305               ! -- umist -- 
     1306               !!zpsi = MAX( 0., MIN( 2.*Cr, MIN( 0.25+0.75*Cr, MIN(0.75+0.25*Cr, 2. ) ) ) ) 
     1307 
     1308               ! high order flux corrected by the limiter 
     1309               pfu_ho(ji,jj,jl) = pfu_ho(ji,jj,jl) - ABS( pu(ji,jj) ) * ( (1.-zpsi) + uCFL*zpsi ) * Rj * 0.5 
     1310 
     1311            ENDIF 
     1312         END_2D 
    14171313      END DO 
    14181314      CALL lbc_lnk( 'icedyn_adv_umx', pfu_ho, 'U', -1.)   ! lateral boundary cond. 
    … …  
    14391335      ! 
    14401336      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 
     1337         DO_2D_00_00 
     1338            zslpy(ji,jj,jl) = ( pt(ji,jj+1,jl) - pt(ji,jj,jl) ) * vmask(ji,jj,1) 
     1339         END_2D 
    14461340      END DO 
    14471341      CALL lbc_lnk( 'icedyn_adv_umx', zslpy, 'V', -1.)   ! lateral boundary cond. 
    14481342 
    14491343      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 
     1344         DO_2D_00_00 
     1345            vCFL = pdt * ABS( pv(ji,jj) ) * r1_e1e2t(ji,jj) 
     1346 
     1347            Rjm = zslpy(ji,jj-1,jl) 
     1348            Rj  = zslpy(ji,jj  ,jl) 
     1349            Rjp = zslpy(ji,jj+1,jl) 
     1350 
     1351            IF( np_limiter == 3 ) THEN 
     1352 
     1353               IF( pv(ji,jj) > 0. ) THEN   ;   Rr = Rjm 
     1354               ELSE                        ;   Rr = Rjp 
     1355               ENDIF 
     1356 
     1357               zh3 = pfv_ho(ji,jj,jl) - pfv_ups(ji,jj,jl)      
     1358               IF( Rj > 0. ) THEN 
     1359                  zlimiter =  MAX( 0., MIN( zh3, MAX(-Rr * 0.5 * ABS(pv(ji,jj)),  & 
     1360                     &        MIN( 2. * Rr * 0.5 * ABS(pv(ji,jj)),  zh3,  1.5 * Rj * 0.5 * ABS(pv(ji,jj)) ) ) ) ) 
     1361               ELSE 
     1362                  zlimiter = -MAX( 0., MIN(-zh3, MAX( Rr * 0.5 * ABS(pv(ji,jj)),  & 
     1363                     &        MIN(-2. * Rr * 0.5 * ABS(pv(ji,jj)), -zh3, -1.5 * Rj * 0.5 * ABS(pv(ji,jj)) ) ) ) ) 
     1364               ENDIF 
     1365               pfv_ho(ji,jj,jl) = pfv_ups(ji,jj,jl) + zlimiter 
     1366 
     1367            ELSEIF( np_limiter == 2 ) THEN 
     1368 
     1369               IF( Rj /= 0. ) THEN 
     1370                  IF( pv(ji,jj) > 0. ) THEN   ;   Cr = Rjm / Rj 
     1371                  ELSE                        ;   Cr = Rjp / Rj 
    14621372                  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  
     1373               ELSE 
     1374                  Cr = 0. 
    15101375               ENDIF 
    1511             END DO 
    1512          END DO 
     1376 
     1377               ! -- superbee -- 
     1378               zpsi = MAX( 0., MAX( MIN(1.,2.*Cr), MIN(2.,Cr) ) ) 
     1379               ! -- van albada 2 -- 
     1380               !!zpsi = 2.*Cr / (Cr*Cr+1.) 
     1381               ! -- sweby (with beta=1) -- 
     1382               !!zpsi = MAX( 0., MAX( MIN(1.,1.*Cr), MIN(1.,Cr) ) ) 
     1383               ! -- van Leer -- 
     1384               !!zpsi = ( Cr + ABS(Cr) ) / ( 1. + ABS(Cr) ) 
     1385               ! -- ospre -- 
     1386               !!zpsi = 1.5 * ( Cr*Cr + Cr ) / ( Cr*Cr + Cr + 1. ) 
     1387               ! -- koren -- 
     1388               !!zpsi = MAX( 0., MIN( 2.*Cr, MIN( (1.+2*Cr)/3., 2. ) ) ) 
     1389               ! -- charm -- 
     1390               !IF( Cr > 0. ) THEN   ;   zpsi = Cr * (3.*Cr + 1.) / ( (Cr + 1.) * (Cr + 1.) ) 
     1391               !ELSE                 ;   zpsi = 0. 
     1392               !ENDIF 
     1393               ! -- van albada 1 -- 
     1394               !!zpsi = (Cr*Cr + Cr) / (Cr*Cr +1) 
     1395               ! -- smart -- 
     1396               !!zpsi = MAX( 0., MIN( 2.*Cr, MIN( 0.25+0.75*Cr, 4. ) ) ) 
     1397               ! -- umist -- 
     1398               !!zpsi = MAX( 0., MIN( 2.*Cr, MIN( 0.25+0.75*Cr, MIN(0.75+0.25*Cr, 2. ) ) ) ) 
     1399 
     1400               ! high order flux corrected by the limiter 
     1401               pfv_ho(ji,jj,jl) = pfv_ho(ji,jj,jl) - ABS( pv(ji,jj) ) * ( (1.-zpsi) + vCFL*zpsi ) * Rj * 0.5 
     1402 
     1403            ENDIF 
     1404         END_2D 
    15131405      END DO 
    15141406      CALL lbc_lnk( 'icedyn_adv_umx', pfv_ho, 'V', -1.)   ! lateral boundary cond. 
    … …  
    15441436      DO jl = 1, jpl 
    15451437 
    1546          DO jj = 1, jpj 
    1547             DO ji = 1, jpi 
    1548                IF ( pv_i(ji,jj,jl) > 0._wp ) THEN 
     1438         DO_2D_11_11 
     1439            IF ( pv_i(ji,jj,jl) > 0._wp ) THEN 
     1440               ! 
     1441               !                               ! -- check h_ip -- ! 
     1442               ! if h_ip is larger than the surrounding 9 pts => reduce h_ip and increase a_ip 
     1443               IF( ln_pnd_H12 .AND. pv_ip(ji,jj,jl) > 0._wp ) THEN 
     1444                  zhip = pv_ip(ji,jj,jl) / MAX( epsi20, pa_ip(ji,jj,jl) ) 
     1445                  IF( zhip > phip_max(ji,jj,jl) .AND. pa_ip(ji,jj,jl) < 0.15 ) THEN 
     1446                     pa_ip(ji,jj,jl) = pv_ip(ji,jj,jl) / phip_max(ji,jj,jl) 
     1447                  ENDIF 
     1448               ENDIF 
     1449               ! 
     1450               !                               ! -- check h_i -- ! 
     1451               ! if h_i is larger than the surrounding 9 pts => reduce h_i and increase a_i 
     1452               zhi = pv_i(ji,jj,jl) / pa_i(ji,jj,jl) 
     1453               IF( zhi > phi_max(ji,jj,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 
     1454                  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) 
     1455               ENDIF 
     1456               ! 
     1457               !                               ! -- check h_s -- ! 
     1458               ! if h_s is larger than the surrounding 9 pts => put the snow excess in the ocean 
     1459               zhs = pv_s(ji,jj,jl) / pa_i(ji,jj,jl) 
     1460               IF( pv_s(ji,jj,jl) > 0._wp .AND. zhs > phs_max(ji,jj,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 
     1461                  zfra = phs_max(ji,jj,jl) / MAX( zhs, epsi20 ) 
    15491462                  ! 
    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 
     1463                  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 
     1464                  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 
    15581465                  ! 
    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 
     1466                  pe_s(ji,jj,1:nlay_s,jl) = pe_s(ji,jj,1:nlay_s,jl) * zfra 
     1467                  pv_s(ji,jj,jl)          = pa_i(ji,jj,jl) * phs_max(ji,jj,jl) 
     1468               ENDIF            
     1469               !                   
     1470            ENDIF 
     1471         END_2D 
    15821472      END DO  
    15831473      ! 
    … …  
    16121502      ! -- check snow load -- ! 
    16131503      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                   ! 
     1504         DO_2D_11_11 
     1505            IF ( pv_i(ji,jj,jl) > 0._wp ) THEN 
     1506               ! 
     1507               zvs_excess = MAX( 0._wp, pv_s(ji,jj,jl) - pv_i(ji,jj,jl) * (rau0-rhoi) * r1_rhos ) 
     1508               ! 
     1509               IF( zvs_excess > 0._wp ) THEN   ! snow-ice interface deplets below the ocean surface 
     1510                  ! put snow excess in the ocean 
     1511                  zfra = ( pv_s(ji,jj,jl) - zvs_excess ) / MAX( pv_s(ji,jj,jl), epsi20 ) 
     1512                  wfx_res(ji,jj) = wfx_res(ji,jj) + zvs_excess * rhos * z1_dt 
     1513                  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 
     1514                  ! correct snow volume and heat content 
     1515                  pe_s(ji,jj,1:nlay_s,jl) = pe_s(ji,jj,1:nlay_s,jl) * zfra 
     1516                  pv_s(ji,jj,jl)          = pv_s(ji,jj,jl) - zvs_excess 
    16301517               ENDIF 
    1631             END DO 
    1632          END DO 
     1518               ! 
     1519            ENDIF 
     1520         END_2D 
    16331521      END DO 
    16341522      ! 

  • NEMO/trunk/src/ICE/icedyn_rdgrft.F90

    r11732 r12377  
    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      !-------------------------------------------------------- 
    … …  
    268268 
    269269      ! controls 
    270       IF( ln_ctl       )   CALL ice_prt3D   ('icedyn_rdgrft')                                                             ! prints 
     270      IF( sn_cfctl%l_prtctl )   CALL ice_prt3D   ('icedyn_rdgrft')                                                        ! prints 
    271271      IF( ln_icectl    )   CALL ice_prt     (kt, iiceprt, jiceprt,-1, ' - ice dyn rdgrft - ')                             ! prints 
    272272      IF( ln_icediachk )   CALL ice_cons_hsm(1, 'icedyn_rdgrft', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft) ! conservation 
    … …  
    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         ! 
    … …  
    908902      !!------------------------------------------------------------------- 
    909903      ! 
    910       REWIND( numnam_ice_ref )              ! Namelist namicetdme in reference namelist : Ice mechanical ice redistribution 
    911904      READ  ( numnam_ice_ref, namdyn_rdgrft, IOSTAT = ios, ERR = 901) 
    912905901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namdyn_rdgrft in reference namelist' ) 
    913       REWIND( numnam_ice_cfg )              ! Namelist namdyn_rdgrft in configuration namelist : Ice mechanical ice redistribution 
    914906      READ  ( numnam_ice_cfg, namdyn_rdgrft, IOSTAT = ios, ERR = 902 ) 
    915907902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namdyn_rdgrft in configuration namelist' ) 

  • NEMO/trunk/src/ICE/icedyn_rhg.F90

    r11536 r12377  
    3838   LOGICAL ::   ln_rhg_EVP       ! EVP rheology 
    3939   ! 
    40    !! * Substitutions 
    41 #  include "vectopt_loop_substitute.h90" 
    4240   !!---------------------------------------------------------------------- 
    4341   !! NEMO/ICE 4.0 , NEMO Consortium (2018) 
    … …  
    4745CONTAINS 
    4846 
    49    SUBROUTINE ice_dyn_rhg( kt ) 
     47   SUBROUTINE ice_dyn_rhg( kt, Kmm ) 
    5048      !!------------------------------------------------------------------- 
    5149      !!               ***  ROUTINE ice_dyn_rhg  *** 
    … …  
    5856      !!-------------------------------------------------------------------- 
    5957      INTEGER, INTENT(in) ::   kt     ! ice time step 
    60       ! 
    61       INTEGER  ::   jl   ! dummy loop indices 
     58      INTEGER, INTENT(in) ::   Kmm    ! ocean time level index 
    6259      !!-------------------------------------------------------------------- 
    6360      ! controls 
    … …  
    7976      CASE( np_rhgEVP )                ! Elasto-Viscous-Plastic ! 
    8077         !                             !------------------------! 
    81          CALL ice_dyn_rhg_evp( kt, stress1_i, stress2_i, stress12_i, shear_i, divu_i, delta_i ) 
     78         CALL ice_dyn_rhg_evp( kt, Kmm, stress1_i, stress2_i, stress12_i, shear_i, divu_i, delta_i ) 
    8279         !          
    8380      END SELECT 
    … …  
    8885      ! 
    8986      ! controls 
    90       IF( ln_ctl       )   CALL ice_prt3D   ('icedyn_rhg')                                                             ! prints 
     87      IF( sn_cfctl%l_prtctl ) & 
     88         &                 CALL ice_prt3D   ('icedyn_rhg')                                                             ! prints 
    9189      IF( ln_icediachk )   CALL ice_cons_hsm(1, 'icedyn_rhg', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft) ! conservation 
    9290      IF( ln_icediachk )   CALL ice_cons2D  (1, 'icedyn_rhg',  diag_v,  diag_s,  diag_t,  diag_fv,  diag_fs,  diag_ft) ! conservation 
    … …  
    113111      !!------------------------------------------------------------------- 
    114112      ! 
    115       REWIND( numnam_ice_ref )         ! Namelist namdyn_rhg in reference namelist : Ice dynamics 
    116113      READ  ( numnam_ice_ref, namdyn_rhg, IOSTAT = ios, ERR = 901) 
    117114901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdyn_rhg in reference namelist' ) 
    118       REWIND( numnam_ice_cfg )         ! Namelist namdyn_rhg in configuration namelist : Ice dynamics 
    119115      READ  ( numnam_ice_cfg, namdyn_rhg, IOSTAT = ios, ERR = 902 ) 
    120116902   IF( ios >  0 ) CALL ctl_nam ( ios , 'namdyn_rhg in configuration namelist' ) 

  • NEMO/trunk/src/ICE/icedyn_rhg_evp.F90

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

  • NEMO/trunk/src/ICE/iceistate.F90

    r11536 r12377  
    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) 
    … …  
    6870CONTAINS 
    6971 
    70    SUBROUTINE ice_istate( kt ) 
     72   SUBROUTINE ice_istate( kt, Kbb, Kmm, Kaa ) 
    7173      !!------------------------------------------------------------------- 
    7274      !!                    ***  ROUTINE ice_istate  *** 
    … …  
    8991      !!              where there is no ice 
    9092      !!-------------------------------------------------------------------- 
    91       INTEGER, INTENT(in) ::   kt   ! time step  
    92       !! 
     93      INTEGER, INTENT(in) :: kt            ! time step  
     94      INTEGER, INTENT(in) :: Kbb, Kmm, Kaa ! ocean time level indices 
     95      ! 
    9396      INTEGER  ::   ji, jj, jk, jl         ! dummy loop indices 
    9497      REAL(wp) ::   ztmelts 
    … …  
    268271         ! select ice covered grid points 
    269272         npti = 0 ; nptidx(:) = 0 
    270          DO jj = 1, jpj 
    271             DO ji = 1, jpi 
    272                IF ( zht_i_ini(ji,jj) > 0._wp ) THEN 
    273                   npti         = npti  + 1 
    274                   nptidx(npti) = (jj - 1) * jpi + ji 
    275                ENDIF 
    276             END DO 
    277          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 
    278279 
    279280         ! move to 1D arrays: (jpi,jpj) -> (jpi*jpj) 
    … …  
    320321         CALL ice_var_salprof ! for sz_i 
    321322         DO jl = 1, jpl 
    322             DO jj = 1, jpj 
    323                DO ji = 1, jpi 
    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 DO 
    328             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 
    329328         END DO 
    330329         ! 
    331330         DO jl = 1, jpl 
    332             DO jk = 1, nlay_s 
    333                DO jj = 1, jpj 
    334                   DO ji = 1, jpi 
    335                      t_s(ji,jj,jk,jl) = zts_3d(ji,jj,jl) 
    336                      e_s(ji,jj,jk,jl) = zswitch(ji,jj) * v_s(ji,jj,jl) * r1_nlay_s * & 
    337                         &               rhos * ( rcpi * ( rt0 - t_s(ji,jj,jk,jl) ) + rLfus ) 
    338                   END DO 
    339                END DO 
    340             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 
    341336         END DO 
    342337         ! 
    343338         DO jl = 1, jpl 
    344             DO jk = 1, nlay_i 
    345                DO jj = 1, jpj 
    346                   DO ji = 1, jpi 
    347                      t_i (ji,jj,jk,jl) = zti_3d(ji,jj,jl)  
    348                      ztmelts          = - rTmlt * sz_i(ji,jj,jk,jl) + rt0 ! melting temperature in K 
    349                      e_i(ji,jj,jk,jl) = zswitch(ji,jj) * v_i(ji,jj,jl) * r1_nlay_i * & 
    350                         &               rhoi * (  rcpi  * ( ztmelts - t_i(ji,jj,jk,jl) ) + & 
    351                         &                         rLfus * ( 1._wp - (ztmelts-rt0) / MIN( (t_i(ji,jj,jk,jl)-rt0), -epsi20 ) ) & 
    352                         &                       - rcp   * ( ztmelts - rt0 ) ) 
    353                   END DO 
    354                END DO 
    355             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 
    356347         END DO 
    357348 
    … …  
    380371      IF( ln_ice_embd ) THEN            ! embedded sea-ice: deplete the initial ssh below sea-ice area 
    381372         ! 
    382          sshn(:,:) = sshn(:,:) - snwice_mass(:,:) * r1_rau0 
    383          sshb(:,:) = sshb(:,:) - snwice_mass(:,:) * r1_rau0 
     373         ssh(:,:,Kmm) = ssh(:,:,Kmm) - snwice_mass(:,:) * r1_rau0 
     374         ssh(:,:,Kbb) = ssh(:,:,Kbb) - snwice_mass(:,:) * r1_rau0 
    384375         ! 
    385376         IF( .NOT.ln_linssh ) THEN 
    386377            ! 
    387             WHERE( ht_0(:,:) > 0 )   ;   z2d(:,:) = 1._wp + sshn(:,:)*tmask(:,:,1) / ht_0(:,:) 
     378            WHERE( ht_0(:,:) > 0 )   ;   z2d(:,:) = 1._wp + ssh(:,:,Kmm)*tmask(:,:,1) / ht_0(:,:) 
    388379            ELSEWHERE                ;   z2d(:,:) = 1._wp   ;   END WHERE 
    389380            ! 
    390381            DO jk = 1,jpkm1                     ! adjust initial vertical scale factors                 
    391                e3t_n(:,:,jk) = e3t_0(:,:,jk) * z2d(:,:) 
    392                e3t_b(:,:,jk) = e3t_n(:,:,jk) 
    393                e3t_a(:,:,jk) = e3t_n(:,:,jk) 
     382               e3t(:,:,jk,Kmm) = e3t_0(:,:,jk) * z2d(:,:) 
     383               e3t(:,:,jk,Kbb) = e3t(:,:,jk,Kmm) 
     384               e3t(:,:,jk,Kaa) = e3t(:,:,jk,Kmm) 
    394385            END DO 
    395386            ! 
    … …  
    398389            ! Horizontal scale factor interpolations 
    399390            ! -------------------------------------- 
    400             CALL dom_vvl_interpol( e3t_b(:,:,:), e3u_b(:,:,:), 'U' ) 
    401             CALL dom_vvl_interpol( e3t_b(:,:,:), e3v_b(:,:,:), 'V' ) 
    402             CALL dom_vvl_interpol( e3t_n(:,:,:), e3u_n(:,:,:), 'U' ) 
    403             CALL dom_vvl_interpol( e3t_n(:,:,:), e3v_n(:,:,:), 'V' ) 
    404             CALL dom_vvl_interpol( e3u_n(:,:,:), e3f_n(:,:,:), 'F' ) 
     391            CALL dom_vvl_interpol( e3t(:,:,:,Kbb), e3u(:,:,:,Kbb), 'U' ) 
     392            CALL dom_vvl_interpol( e3t(:,:,:,Kbb), e3v(:,:,:,Kbb), 'V' ) 
     393            CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3u(:,:,:,Kmm), 'U' ) 
     394            CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3v(:,:,:,Kmm), 'V' ) 
     395            CALL dom_vvl_interpol( e3u(:,:,:,Kmm), e3f(:,:,:), 'F' ) 
    405396            ! Vertical scale factor interpolations 
    406397            ! ------------------------------------ 
    407             CALL dom_vvl_interpol( e3t_n(:,:,:), e3w_n (:,:,:), 'W'  ) 
    408             CALL dom_vvl_interpol( e3u_n(:,:,:), e3uw_n(:,:,:), 'UW' ) 
    409             CALL dom_vvl_interpol( e3v_n(:,:,:), e3vw_n(:,:,:), 'VW' ) 
    410             CALL dom_vvl_interpol( e3u_b(:,:,:), e3uw_b(:,:,:), 'UW' ) 
    411             CALL dom_vvl_interpol( e3v_b(:,:,:), e3vw_b(:,:,:), 'VW' ) 
     398            CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3w (:,:,:,Kmm), 'W'  ) 
     399            CALL dom_vvl_interpol( e3u(:,:,:,Kmm), e3uw(:,:,:,Kmm), 'UW' ) 
     400            CALL dom_vvl_interpol( e3v(:,:,:,Kmm), e3vw(:,:,:,Kmm), 'VW' ) 
     401            CALL dom_vvl_interpol( e3u(:,:,:,Kbb), e3uw(:,:,:,Kbb), 'UW' ) 
     402            CALL dom_vvl_interpol( e3v(:,:,:,Kbb), e3vw(:,:,:,Kbb), 'VW' ) 
    412403            ! t- and w- points depth 
    413404            ! ---------------------- 
    414405            !!gm not sure of that.... 
    415             gdept_n(:,:,1) = 0.5_wp * e3w_n(:,:,1) 
    416             gdepw_n(:,:,1) = 0.0_wp 
    417             gde3w_n(:,:,1) = gdept_n(:,:,1) - sshn(:,:) 
     406            gdept(:,:,1,Kmm) = 0.5_wp * e3w(:,:,1,Kmm) 
     407            gdepw(:,:,1,Kmm) = 0.0_wp 
     408            gde3w(:,:,1) = gdept(:,:,1,Kmm) - ssh(:,:,Kmm) 
    418409            DO jk = 2, jpk 
    419                gdept_n(:,:,jk) = gdept_n(:,:,jk-1) + e3w_n(:,:,jk  ) 
    420                gdepw_n(:,:,jk) = gdepw_n(:,:,jk-1) + e3t_n(:,:,jk-1) 
    421                gde3w_n(:,:,jk) = gdept_n(:,:,jk  ) - sshn (:,:) 
     410               gdept(:,:,jk,Kmm) = gdept(:,:,jk-1,Kmm) + e3w(:,:,jk  ,Kmm) 
     411               gdepw(:,:,jk,Kmm) = gdepw(:,:,jk-1,Kmm) + e3t(:,:,jk-1,Kmm) 
     412               gde3w(:,:,jk) = gdept(:,:,jk  ,Kmm) - ssh (:,:,Kmm) 
    422413            END DO 
    423414         ENDIF 
    … …  
    474465      !!----------------------------------------------------------------------------- 
    475466      ! 
    476       REWIND( numnam_ice_ref )              ! Namelist namini in reference namelist : Ice initial state 
    477467      READ  ( numnam_ice_ref, namini, IOSTAT = ios, ERR = 901) 
    478468901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namini in reference namelist' ) 
    479       REWIND( numnam_ice_cfg )              ! Namelist namini in configuration namelist : Ice initial state 
    480469      READ  ( numnam_ice_cfg, namini, IOSTAT = ios, ERR = 902 ) 
    481470902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namini in configuration namelist' ) 

  • NEMO/trunk/src/ICE/iceitd.F90

    r11732 r12377  
    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 
    … …  
    686682      !!------------------------------------------------------------------ 
    687683      ! 
    688       REWIND( numnam_ice_ref )      ! Namelist namitd in reference namelist : Parameters for ice 
    689684      READ  ( numnam_ice_ref, namitd, IOSTAT = ios, ERR = 901) 
    690685901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namitd in reference namelist' ) 
    691       REWIND( numnam_ice_cfg )      ! Namelist namitd in configuration namelist : Parameters for ice 
    692686      READ  ( numnam_ice_cfg, namitd, IOSTAT = ios, ERR = 902 ) 
    693687902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namitd in configuration namelist' ) 

  • NEMO/trunk/src/ICE/icerst.F90

    r11536 r12377  
    163163 
    164164 
    165    SUBROUTINE ice_rst_read 
     165   SUBROUTINE ice_rst_read( Kbb, Kmm, Kaa ) 
    166166      !!---------------------------------------------------------------------- 
    167167      !!                    ***  ice_rst_read  *** 
    … …  
    169169      !! ** purpose  :   read restart file 
    170170      !!---------------------------------------------------------------------- 
     171      INTEGER, INTENT(in) :: Kbb, Kmm, Kaa ! ocean time level indices 
    171172      INTEGER           ::   jk 
    172173      LOGICAL           ::   llok 
    … …  
    272273         ! 
    273274         CALL ice_istate_init 
    274          CALL ice_istate( nit000 ) 
     275         CALL ice_istate( nit000, Kbb, Kmm, Kaa ) 
    275276         ! 
    276277         IF( .NOT.ln_iceini .OR. .NOT.ln_iceini_file ) & 

  • NEMO/trunk/src/ICE/icesbc.F90

    r11575 r12377  
    2727   USE lbclnk         ! lateral boundary conditions (or mpp links) 
    2828   USE timing         ! Timing 
     29   USE fldread        !!GS: needed by agrif 
    2930 
    3031   IMPLICIT NONE 
    … …  
    3637 
    3738   !! * Substitutions 
    38 #  include "vectopt_loop_substitute.h90" 
     39#  include "do_loop_substitute.h90" 
    3940   !!---------------------------------------------------------------------- 
    4041   !! NEMO/ICE 4.0 , NEMO Consortium (2018) 
    … …  
    7172      SELECT CASE( ksbc ) 
    7273         CASE( jp_usr     )   ;    CALL usrdef_sbc_ice_tau( kt )                 ! user defined formulation 
    73          CASE( jp_blk     )   ;    CALL blk_ice_tau                              ! Bulk         formulation 
     74         CASE( jp_blk     )   ;    CALL blk_ice_1( sf(jp_wndi)%fnow(:,:,1), sf(jp_wndj)%fnow(:,:,1),   & 
     75            &                                      sf(jp_tair)%fnow(:,:,1), sf(jp_humi)%fnow(:,:,1),   & 
     76            &                                      sf(jp_slp )%fnow(:,:,1), u_ice, v_ice, tm_su    ,   &   ! inputs 
     77            &                                      putaui = utau_ice, pvtaui = vtau_ice            )       ! outputs                              
     78 !        CASE( jp_abl     )    utau_ice & vtau_ice are computed in ablmod 
    7479         CASE( jp_purecpl )   ;    CALL sbc_cpl_ice_tau( utau_ice , vtau_ice )   ! Coupled      formulation 
    7580      END SELECT 
    … …  
    7782      IF( ln_mixcpl) THEN                                                        ! Case of a mixed Bulk/Coupled formulation 
    7883                                   CALL sbc_cpl_ice_tau( zutau_ice , zvtau_ice ) 
    79          DO jj = 2, jpjm1 
    80             DO ji = 2, jpim1 
    81                utau_ice(ji,jj) = utau_ice(ji,jj) * xcplmask(ji,jj,0) + zutau_ice(ji,jj) * ( 1. - xcplmask(ji,jj,0) ) 
    82                vtau_ice(ji,jj) = vtau_ice(ji,jj) * xcplmask(ji,jj,0) + zvtau_ice(ji,jj) * ( 1. - xcplmask(ji,jj,0) ) 
    83             END DO 
    84          END DO 
     84         DO_2D_00_00 
     85            utau_ice(ji,jj) = utau_ice(ji,jj) * xcplmask(ji,jj,0) + zutau_ice(ji,jj) * ( 1. - xcplmask(ji,jj,0) ) 
     86            vtau_ice(ji,jj) = vtau_ice(ji,jj) * xcplmask(ji,jj,0) + zvtau_ice(ji,jj) * ( 1. - xcplmask(ji,jj,0) ) 
     87         END_2D 
    8588         CALL lbc_lnk_multi( 'icesbc', utau_ice, 'U', -1., vtau_ice, 'V', -1. ) 
    8689      ENDIF 
    … …  
    143146      CASE( jp_usr )              !--- user defined formulation 
    144147                                  CALL usrdef_sbc_ice_flx( kt, h_s, h_i ) 
    145       CASE( jp_blk )              !--- bulk formulation 
    146                                   CALL blk_ice_flx    ( t_su, h_s, h_i, alb_ice )    !  
     148      CASE( jp_blk, jp_abl )  !--- bulk formulation & ABL formulation 
     149                                  CALL blk_ice_2    ( t_su, h_s, h_i, alb_ice, sf(jp_tair)%fnow(:,:,1), sf(jp_humi)%fnow(:,:,1),    & 
     150            &                                           sf(jp_slp)%fnow(:,:,1), sf(jp_qlw)%fnow(:,:,1), sf(jp_prec)%fnow(:,:,1), sf(jp_snow)%fnow(:,:,1) )    !  
    147151         IF( ln_mixcpl        )   CALL sbc_cpl_ice_flx( picefr=at_i_b, palbi=alb_ice, psst=sst_m, pist=t_su, phs=h_s, phi=h_i ) 
    148152         IF( nn_flxdist /= -1 )   CALL ice_flx_dist   ( t_su, alb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_flxdist ) 
    … …  
    284288      !!------------------------------------------------------------------- 
    285289      ! 
    286       REWIND( numnam_ice_ref )         ! Namelist namsbc in reference namelist : Ice dynamics 
    287290      READ  ( numnam_ice_ref, namsbc, IOSTAT = ios, ERR = 901) 
    288291901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namsbc in reference namelist' ) 
    289       REWIND( numnam_ice_cfg )         ! Namelist namsbc in configuration namelist : Ice dynamics 
    290292      READ  ( numnam_ice_cfg, namsbc, IOSTAT = ios, ERR = 902 ) 
    291293902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namsbc in configuration namelist' ) 

  • NEMO/trunk/src/ICE/icestp.F90

    r11536 r12377  
    8686   PUBLIC   ice_init   ! called by sbcmod.F90 
    8787 
    88    !! * Substitutions 
    89 #  include "vectopt_loop_substitute.h90" 
    9088   !!---------------------------------------------------------------------- 
    9189   !! NEMO/ICE 4.0 , NEMO Consortium (2018) 
    … …  
    9593CONTAINS 
    9694 
    97    SUBROUTINE ice_stp( kt, ksbc ) 
     95   SUBROUTINE ice_stp( kt, Kbb, Kmm, ksbc ) 
    9896      !!--------------------------------------------------------------------- 
    9997      !!                  ***  ROUTINE ice_stp  *** 
    … …  
    115113      !!                utau, vtau, taum, wndm, qns , qsr, emp , sfx 
    116114      !!--------------------------------------------------------------------- 
    117       INTEGER, INTENT(in) ::   kt      ! ocean time step 
    118       INTEGER, INTENT(in) ::   ksbc    ! flux formulation (user defined, bulk, or Pure Coupled) 
     115      INTEGER, INTENT(in) ::   kt       ! ocean time step 
     116      INTEGER, INTENT(in) ::   Kbb, Kmm ! ocean time level indices 
     117      INTEGER, INTENT(in) ::   ksbc     ! flux formulation (user defined, bulk, or Pure Coupled) 
    119118      ! 
    120119      INTEGER ::   jl   ! dummy loop index 
    … …  
    160159         ! 
    161160         IF( ln_icedyn .AND. .NOT.lk_c1d )   & 
    162             &                           CALL ice_dyn( kt )            ! -- Ice dynamics 
     161            &                           CALL ice_dyn( kt, Kmm )       ! -- Ice dynamics 
    163162         ! 
    164163         !                          !==  lateral boundary conditions  ==! 
    … …  
    209208      ! --- Ocean time step --- ! 
    210209      !-------------------------! 
    211       IF( ln_icedyn )                   CALL ice_update_tau( kt, ub(:,:,1), vb(:,:,1) )   ! -- update surface ocean stresses 
     210      IF( ln_icedyn )                   CALL ice_update_tau( kt, uu(:,:,1,Kbb), vv(:,:,1,Kbb) )   ! -- update surface ocean stresses 
    212211!!gm   remark, the ocean-ice stress is not saved in ice diag call above .....  find a solution!!! 
    213212      ! 
    … …  
    217216 
    218217 
    219    SUBROUTINE ice_init 
     218   SUBROUTINE ice_init( Kbb, Kmm, Kaa ) 
    220219      !!---------------------------------------------------------------------- 
    221220      !!                  ***  ROUTINE ice_init  *** 
    … …  
    223222      !! ** purpose :   Initialize sea-ice parameters 
    224223      !!---------------------------------------------------------------------- 
     224      INTEGER, INTENT(in) :: Kbb, Kmm, Kaa 
     225      ! 
    225226      INTEGER :: ji, jj, ierr 
    226227      !!---------------------------------------------------------------------- 
    … …  
    232233      IF(lwp) WRITE(numout,*) '~~~~~~~~' 
    233234      ! 
    234       !                                ! Open the reference and configuration namelist files and namelist output file 
    235       CALL ctl_opn( numnam_ice_ref, 'namelist_ice_ref',    'OLD',     'FORMATTED', 'SEQUENTIAL', -1, numout, lwp ) 
    236       CALL ctl_opn( numnam_ice_cfg, 'namelist_ice_cfg',    'OLD',     'FORMATTED', 'SEQUENTIAL', -1, numout, lwp ) 
    237       IF(lwm) CALL ctl_opn( numoni, 'output.namelist.ice', 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, 1 ) 
     235      !                                ! Load the reference and configuration namelist files and open namelist output file 
     236      CALL load_nml( numnam_ice_ref, 'namelist_ice_ref',    numout, lwm ) 
     237      CALL load_nml( numnam_ice_cfg, 'namelist_ice_cfg',    numout, lwm ) 
     238      IF(lwm) CALL ctl_opn( numoni , 'output.namelist.ice', 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, 1 ) 
    238239      ! 
    239240      CALL par_init                ! set some ice run parameters 
    … …  
    254255      IF( .NOT. ln_rstart ) THEN              ! start from rest: sea-ice deduced from sst 
    255256         CALL ice_istate_init 
    256          CALL ice_istate( nit000 ) 
     257         CALL ice_istate( nit000, Kbb, Kmm, Kaa ) 
    257258      ELSE                                    ! start from a restart file 
    258          CALL ice_rst_read 
     259         CALL ice_rst_read( Kbb, Kmm, Kaa ) 
    259260      ENDIF 
    260261      CALL ice_var_glo2eqv 
    … …  
    301302      !!------------------------------------------------------------------- 
    302303      ! 
    303       REWIND( numnam_ice_ref )      ! Namelist nampar in reference namelist : Parameters for ice 
    304304      READ  ( numnam_ice_ref, nampar, IOSTAT = ios, ERR = 901) 
    305305901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nampar in reference namelist' ) 
    306       REWIND( numnam_ice_cfg )      ! Namelist nampar in configuration namelist : Parameters for ice 
    307306      READ  ( numnam_ice_cfg, nampar, IOSTAT = ios, ERR = 902 ) 
    308307902   IF( ios > 0 )   CALL ctl_nam ( ios , 'nampar in configuration namelist' ) 

  • NEMO/trunk/src/ICE/icethd.F90

    r11536 r12377  
    5353 
    5454   !! * Substitutions 
    55 #  include "vectopt_loop_substitute.h90" 
     55#  include "do_loop_substitute.h90" 
    5656   !!---------------------------------------------------------------------- 
    5757   !! NEMO/ICE 4.0 , NEMO Consortium (2018) 
    … …  
    109109         zu_io(:,:) = u_ice(:,:) - ssu_m(:,:) 
    110110         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 
     111         DO_2D_00_00 
     112            zfric(ji,jj) = rn_cio * ( 0.5_wp *  & 
     113               &                    (  zu_io(ji,jj) * zu_io(ji,jj) + zu_io(ji-1,jj) * zu_io(ji-1,jj)   & 
     114               &                     + zv_io(ji,jj) * zv_io(ji,jj) + zv_io(ji,jj-1) * zv_io(ji,jj-1) ) ) * tmask(ji,jj,1) 
     115         END_2D 
    118116      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 
     117         DO_2D_00_00 
     118            zfric(ji,jj) = r1_rau0 * SQRT( 0.5_wp *  & 
     119               &                         (  utau(ji,jj) * utau(ji,jj) + utau(ji-1,jj) * utau(ji-1,jj)   & 
     120               &                          + vtau(ji,jj) * vtau(ji,jj) + vtau(ji,jj-1) * vtau(ji,jj-1) ) ) * tmask(ji,jj,1) 
     121         END_2D 
    126122      ENDIF 
    127123      CALL lbc_lnk( 'icethd', zfric, 'T',  1. ) 
    … …  
    130126      ! Partial computation of forcing for the thermodynamic sea ice model 
    131127      !--------------------------------------------------------------------! 
    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 
     128      DO_2D_11_11 
     129         rswitch  = tmask(ji,jj,1) * MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi10 ) ) ! 0 if no ice 
     130         ! 
     131         !           !  solar irradiance transmission at the mixed layer bottom and used in the lead heat budget 
     132         !           !  practically no "direct lateral ablation" 
     133         !            
     134         !           !  net downward heat flux from the ice to the ocean, expressed as a function of ocean  
     135         !           !  temperature and turbulent mixing (McPhee, 1992) 
     136         ! 
     137         ! --- Energy received in the lead from atm-oce exchanges, zqld is defined everywhere (J.m-2) --- ! 
     138         zqld =  tmask(ji,jj,1) * rdt_ice *  & 
     139            &    ( ( 1._wp - at_i_b(ji,jj) ) * qsr_oce(ji,jj) * frq_m(ji,jj) +  & 
     140            &      ( 1._wp - at_i_b(ji,jj) ) * qns_oce(ji,jj) + qemp_oce(ji,jj) ) 
     141 
     142         ! --- Energy needed to bring ocean surface layer until its freezing (mostly<0 but >0 if supercooling, J.m-2) --- ! 
     143         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) 
     144         zqfr_neg = MIN( zqfr , 0._wp )                                                                    ! only < 0 
     145 
     146         ! --- Sensible ocean-to-ice heat flux (mostly>0 but <0 if supercooling, W/m2) 
     147         zfric_u            = MAX( SQRT( zfric(ji,jj) ), zfric_umin )  
     148         qsb_ice_bot(ji,jj) = rswitch * rau0 * rcp * zch * zfric_u * ( ( sst_m(ji,jj) + rt0 ) - t_bo(ji,jj) ) ! W.m-2 
     149 
     150         qsb_ice_bot(ji,jj) = rswitch * MIN( qsb_ice_bot(ji,jj), - zqfr_neg * r1_rdtice / MAX( at_i(ji,jj), epsi10 ) ) 
     151         ! upper bound for qsb_ice_bot: the heat retrieved from the ocean must be smaller than the heat necessary to reach  
     152         !                              the freezing point, so that we do not have SST < T_freeze 
     153         !                              This implies: - ( qsb_ice_bot(ji,jj) * at_i(ji,jj) * rtdice ) - zqfr >= 0 
     154 
     155         !-- Energy Budget of the leads (J.m-2), source of ice growth in open water. Must be < 0 to form ice 
     156         qlead(ji,jj) = MIN( 0._wp , zqld - ( qsb_ice_bot(ji,jj) * at_i(ji,jj) * rdt_ice ) - zqfr ) 
     157 
     158         ! If there is ice and leads are warming => transfer energy from the lead budget and use it for bottom melting  
     159         ! If the grid cell is fully covered by ice (no leads) => transfer energy from the lead budget to the ice bottom budget 
     160         IF( ( zqld >= 0._wp .AND. at_i(ji,jj) > 0._wp ) .OR. at_i(ji,jj) >= (1._wp - epsi10) ) THEN 
     161            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 
     162            qlead(ji,jj) = 0._wp 
     163         ELSE 
     164            fhld (ji,jj) = 0._wp 
     165         ENDIF 
     166         ! 
     167         ! Net heat flux on top of the ice-ocean [W.m-2] 
     168         ! --------------------------------------------- 
     169         qt_atm_oi(ji,jj) = qns_tot(ji,jj) + qsr_tot(ji,jj)  
     170      END_2D 
    177171       
    178172      ! In case we bypass open-water ice formation 
    … …  
    202196         ! select ice covered grid points 
    203197         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 
     198         DO_2D_11_11 
     199            IF ( a_i(ji,jj,jl) > epsi10 ) THEN      
     200               npti         = npti  + 1 
     201               nptidx(npti) = (jj - 1) * jpi + ji 
     202            ENDIF 
     203         END_2D 
    212204 
    213205         IF( npti > 0 ) THEN  ! If there is no ice, do nothing. 
    … …  
    252244      ! controls 
    253245      IF( ln_icectl )   CALL ice_prt    (kt, iiceprt, jiceprt, 1, ' - ice thermodyn. - ') ! prints 
    254       IF( ln_ctl    )   CALL ice_prt3D  ('icethd')                                        ! prints 
     246      IF( sn_cfctl%l_prtctl )   & 
     247        &               CALL ice_prt3D  ('icethd')                                        ! prints 
    255248      IF( ln_timing )   CALL timing_stop('icethd')                                        ! timing 
    256249      ! 
    … …  
    539532      !!------------------------------------------------------------------- 
    540533      ! 
    541       REWIND( numnam_ice_ref )              ! Namelist namthd in reference namelist : Ice thermodynamics 
    542534      READ  ( numnam_ice_ref, namthd, IOSTAT = ios, ERR = 901) 
    543535901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namthd in reference namelist' ) 
    544       REWIND( numnam_ice_cfg )              ! Namelist namthd in configuration namelist : Ice thermodynamics 
    545536      READ  ( numnam_ice_cfg, namthd, IOSTAT = ios, ERR = 902 ) 
    546537902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namthd in configuration namelist' ) 

  • NEMO/trunk/src/ICE/icethd_da.F90

    r11536 r12377  
    177177      !!------------------------------------------------------------------- 
    178178      ! 
    179       REWIND( numnam_ice_ref )              ! Namelist namthd_da in reference namelist : Ice thermodynamics 
    180179      READ  ( numnam_ice_ref, namthd_da, IOSTAT = ios, ERR = 901) 
    181180901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namthd_da in reference namelist' ) 
    182       REWIND( numnam_ice_cfg )              ! Namelist namthd_da in configuration namelist : Ice thermodynamics 
    183181      READ  ( numnam_ice_cfg, namthd_da, IOSTAT = ios, ERR = 902 ) 
    184182902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namthd_da in configuration namelist' ) 

  • NEMO/trunk/src/ICE/icethd_do.F90

    r11536 r12377  
    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 
    151                   ztauy         = ( vtau_ice(ji  ,jj-1) * vmask(ji  ,jj-1,1)   & 
    152                      &          +   vtau_ice(ji  ,jj  ) * vmask(ji  ,jj  ,1) ) * 0.5_wp 
    153                   ! Square root of wind stress 
    154                   ztenagm       =  SQRT( SQRT( ztaux * ztaux + ztauy * ztauy ) ) 
    155  
    156                   ! -- Frazil ice velocity -- ! 
    157                   rswitch = MAX( 0._wp, SIGN( 1._wp , ztenagm - epsi10 ) ) 
    158                   zvfrx   = rswitch * zgamafr * zsqcd * ztaux / MAX( ztenagm, epsi10 ) 
    159                   zvfry   = rswitch * zgamafr * zsqcd * ztauy / MAX( ztenagm, epsi10 ) 
    160  
    161                   ! -- Pack ice velocity -- ! 
    162                   zvgx    = ( u_ice(ji-1,jj  ) * umask(ji-1,jj  ,1)  + u_ice(ji,jj) * umask(ji,jj,1) ) * 0.5_wp 
    163                   zvgy    = ( v_ice(ji  ,jj-1) * vmask(ji  ,jj-1,1)  + v_ice(ji,jj) * vmask(ji,jj,1) ) * 0.5_wp 
    164  
    165                   ! -- Relative frazil/pack ice velocity -- ! 
    166                   rswitch      = MAX( 0._wp, SIGN( 1._wp , at_i(ji,jj) - epsi10 ) ) 
    167                   zvrel2       = MAX(  ( zvfrx - zvgx ) * ( zvfrx - zvgx )   & 
    168                      &               + ( zvfry - zvgy ) * ( zvfry - zvgy ) , 0.15 * 0.15 ) * rswitch 
    169                   zvrel(ji,jj) = SQRT( zvrel2 ) 
    170  
    171                   ! -- new ice thickness (iterative loop) -- ! 
    172                   ht_i_new(ji,jj) = zhicrit +   ( zhicrit + 0.1 )    & 
    173                      &                   / ( ( zhicrit + 0.1 ) * ( zhicrit + 0.1 ) -  zhicrit * zhicrit ) * ztwogp * zvrel2 
    174  
    175                   iter = 1 
    176                   DO WHILE ( iter < 20 )  
    177                      zf  = ( ht_i_new(ji,jj) - zhicrit ) * ( ht_i_new(ji,jj) * ht_i_new(ji,jj) - zhicrit * zhicrit ) -   & 
    178                         &    ht_i_new(ji,jj) * zhicrit * ztwogp * zvrel2 
    179                      zfp = ( ht_i_new(ji,jj) - zhicrit ) * ( 3.0 * ht_i_new(ji,jj) + zhicrit ) - zhicrit * ztwogp * zvrel2 
    180  
    181                      ht_i_new(ji,jj) = ht_i_new(ji,jj) - zf / MAX( zfp, epsi20 ) 
    182                      iter = iter + 1 
    183                   END DO 
    184                   ! 
    185                   ! bound ht_i_new (though I don't see why it should be necessary) 
    186                   ht_i_new(ji,jj) = MAX( 0.01_wp, MIN( ht_i_new(ji,jj), hi_max(jpl) ) ) 
    187                   ! 
    188                ENDIF 
     147         DO_2D_00_00 
     148            IF ( qlead(ji,jj) < 0._wp .AND. tau_icebfr(ji,jj) == 0._wp ) THEN ! activated if cooling and no landfast 
     149               ! -- Wind stress -- ! 
     150               ztaux         = ( utau_ice(ji-1,jj  ) * umask(ji-1,jj  ,1)   & 
     151                  &          +   utau_ice(ji  ,jj  ) * umask(ji  ,jj  ,1) ) * 0.5_wp 
     152               ztauy         = ( vtau_ice(ji  ,jj-1) * vmask(ji  ,jj-1,1)   & 
     153                  &          +   vtau_ice(ji  ,jj  ) * vmask(ji  ,jj  ,1) ) * 0.5_wp 
     154               ! Square root of wind stress 
     155               ztenagm       =  SQRT( SQRT( ztaux * ztaux + ztauy * ztauy ) ) 
     156 
     157               ! -- Frazil ice velocity -- ! 
     158               rswitch = MAX( 0._wp, SIGN( 1._wp , ztenagm - epsi10 ) ) 
     159               zvfrx   = rswitch * zgamafr * zsqcd * ztaux / MAX( ztenagm, epsi10 ) 
     160               zvfry   = rswitch * zgamafr * zsqcd * ztauy / MAX( ztenagm, epsi10 ) 
     161 
     162               ! -- Pack ice velocity -- ! 
     163               zvgx    = ( u_ice(ji-1,jj  ) * umask(ji-1,jj  ,1)  + u_ice(ji,jj) * umask(ji,jj,1) ) * 0.5_wp 
     164               zvgy    = ( v_ice(ji  ,jj-1) * vmask(ji  ,jj-1,1)  + v_ice(ji,jj) * vmask(ji,jj,1) ) * 0.5_wp 
     165 
     166               ! -- Relative frazil/pack ice velocity -- ! 
     167               rswitch      = MAX( 0._wp, SIGN( 1._wp , at_i(ji,jj) - epsi10 ) ) 
     168               zvrel2       = MAX(  ( zvfrx - zvgx ) * ( zvfrx - zvgx )   & 
     169                  &               + ( zvfry - zvgy ) * ( zvfry - zvgy ) , 0.15 * 0.15 ) * rswitch 
     170               zvrel(ji,jj) = SQRT( zvrel2 ) 
     171 
     172               ! -- new ice thickness (iterative loop) -- ! 
     173               ht_i_new(ji,jj) = zhicrit +   ( zhicrit + 0.1 )    & 
     174                  &                   / ( ( zhicrit + 0.1 ) * ( zhicrit + 0.1 ) -  zhicrit * zhicrit ) * ztwogp * zvrel2 
     175 
     176               iter = 1 
     177               DO WHILE ( iter < 20 )  
     178                  zf  = ( ht_i_new(ji,jj) - zhicrit ) * ( ht_i_new(ji,jj) * ht_i_new(ji,jj) - zhicrit * zhicrit ) -   & 
     179                     &    ht_i_new(ji,jj) * zhicrit * ztwogp * zvrel2 
     180                  zfp = ( ht_i_new(ji,jj) - zhicrit ) * ( 3.0 * ht_i_new(ji,jj) + zhicrit ) - zhicrit * ztwogp * zvrel2 
     181 
     182                  ht_i_new(ji,jj) = ht_i_new(ji,jj) - zf / MAX( zfp, epsi20 ) 
     183                  iter = iter + 1 
     184               END DO 
    189185               ! 
    190             END DO  
    191          END DO  
     186               ! bound ht_i_new (though I don't see why it should be necessary) 
     187               ht_i_new(ji,jj) = MAX( 0.01_wp, MIN( ht_i_new(ji,jj), hi_max(jpl) ) ) 
     188               ! 
     189            ENDIF 
     190            ! 
     191         END_2D 
    192192         !  
    193193         CALL lbc_lnk_multi( 'icethd_do', zvrel, 'T', 1., ht_i_new, 'T', 1.  ) 
    … …  
    202202      ! Identify grid points where new ice forms 
    203203      npti = 0   ;   nptidx(:) = 0 
    204       DO jj = 1, jpj 
    205          DO ji = 1, jpi 
    206             IF ( qlead(ji,jj)  <  0._wp .AND. tau_icebfr(ji,jj) == 0._wp ) THEN 
    207                npti = npti + 1 
    208                nptidx( npti ) = (jj - 1) * jpi + ji 
    209             ENDIF 
    210          END DO 
    211       END DO 
     204      DO_2D_11_11 
     205         IF ( qlead(ji,jj)  <  0._wp .AND. tau_icebfr(ji,jj) == 0._wp ) THEN 
     206            npti = npti + 1 
     207            nptidx( npti ) = (jj - 1) * jpi + ji 
     208         ENDIF 
     209      END_2D 
    212210 
    213211      ! Move from 2-D to 1-D vectors 
    … …  
    443441      !!------------------------------------------------------------------- 
    444442      ! 
    445       REWIND( numnam_ice_ref )              ! Namelist namthd_do in reference namelist : Ice thermodynamics 
    446443      READ  ( numnam_ice_ref, namthd_do, IOSTAT = ios, ERR = 901) 
    447444901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namthd_do in reference namelist' ) 
    448       REWIND( numnam_ice_cfg )              ! Namelist namthd_do in configuration namelist : Ice thermodynamics 
    449445      READ  ( numnam_ice_cfg, namthd_do, IOSTAT = ios, ERR = 902 ) 
    450446902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namthd_do in configuration namelist' ) 

  • NEMO/trunk/src/ICE/icethd_pnd.F90

    r11536 r12377  
    3838   INTEGER, PARAMETER ::   np_pndH12 = 2   ! Evolutive pond scheme (Holland et al. 2012) 
    3939 
    40    !! * Substitutions 
    41 #  include "vectopt_loop_substitute.h90" 
    4240   !!---------------------------------------------------------------------- 
    4341   !! NEMO/ICE 4.0 , NEMO Consortium (2018) 
    … …  
    208206      !!------------------------------------------------------------------- 
    209207      ! 
    210       REWIND( numnam_ice_ref )              ! Namelist namthd_pnd  in reference namelist : Melt Ponds   
    211208      READ  ( numnam_ice_ref, namthd_pnd, IOSTAT = ios, ERR = 901) 
    212209901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namthd_pnd  in reference namelist' ) 
    213       REWIND( numnam_ice_cfg )              ! Namelist namthd_pnd  in configuration namelist : Melt Ponds 
    214210      READ  ( numnam_ice_cfg, namthd_pnd, IOSTAT = ios, ERR = 902 ) 
    215211902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namthd_pnd in configuration namelist' ) 

  • NEMO/trunk/src/ICE/icethd_sal.F90

    r11536 r12377  
    132132      !!------------------------------------------------------------------- 
    133133      ! 
    134       REWIND( numnam_ice_ref )              ! Namelist namthd_sal in reference namelist : Ice salinity 
    135134      READ  ( numnam_ice_ref, namthd_sal, IOSTAT = ios, ERR = 901) 
    136135901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namthd_sal in reference namelist' ) 
    137       REWIND( numnam_ice_cfg )              ! Namelist namthd_sal in configuration namelist : Ice salinity 
    138136      READ  ( numnam_ice_cfg, namthd_sal, IOSTAT = ios, ERR = 902 ) 
    139137902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namthd_sal in configuration namelist' ) 

  • NEMO/trunk/src/ICE/icethd_zdf.F90

    r11536 r12377  
    8888      !!------------------------------------------------------------------- 
    8989      ! 
    90       REWIND( numnam_ice_ref )              ! Namelist namthd_zdf in reference namelist : Ice thermodynamics 
    9190      READ  ( numnam_ice_ref, namthd_zdf, IOSTAT = ios, ERR = 901) 
    9291901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'namthd_zdf in reference namelist' ) 
    93       REWIND( numnam_ice_cfg )              ! Namelist namthd_zdf in configuration namelist : Ice thermodynamics 
    9492      READ  ( numnam_ice_cfg, namthd_zdf, IOSTAT = ios, ERR = 902 ) 
    9593902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namthd_zdf in configuration namelist' ) 

  • NEMO/trunk/src/ICE/iceupdate.F90

    r11536 r12377  
    1515   !!   ice_update_tau   : update i- and j-stresses, and its modulus at the ocean surface 
    1616   !!---------------------------------------------------------------------- 
    17    USE oce     , ONLY : sshn, sshb 
    1817   USE phycst         ! physical constants 
    1918   USE dom_oce        ! ocean domain 
    … …  
    4544 
    4645   !! * Substitutions 
    47 #  include "vectopt_loop_substitute.h90" 
     46#  include "do_loop_substitute.h90" 
    4847   !!---------------------------------------------------------------------- 
    4948   !! NEMO/ICE 4.0 , NEMO Consortium (2018) 
    … …  
    114113      ENDIF 
    115114       
    116       DO jj = 1, jpj 
    117          DO ji = 1, jpi 
    118  
    119             ! Solar heat flux reaching the ocean = zqsr (W.m-2)  
    120             !--------------------------------------------------- 
    121             zqsr = qsr_tot(ji,jj) - SUM( a_i_b(ji,jj,:) * ( qsr_ice(ji,jj,:) - qtr_ice_bot(ji,jj,:) ) ) 
    122  
    123             ! Total heat flux reaching the ocean = qt_oce_ai (W.m-2)  
    124             !--------------------------------------------------- 
    125             zqmass           = hfx_thd(ji,jj) + hfx_dyn(ji,jj) + hfx_res(ji,jj) ! heat flux from snow is 0 (T=0 degC) 
    126             qt_oce_ai(ji,jj) = qt_oce_ai(ji,jj) + zqmass + zqsr 
    127  
    128             ! Add the residual from heat diffusion equation and sublimation (W.m-2) 
    129             !---------------------------------------------------------------------- 
    130             qt_oce_ai(ji,jj) = qt_oce_ai(ji,jj) + hfx_err_dif(ji,jj) +   & 
    131                &             ( hfx_sub(ji,jj) - SUM( qevap_ice(ji,jj,:) * a_i_b(ji,jj,:) ) ) 
    132  
    133             ! New qsr and qns used to compute the oceanic heat flux at the next time step 
    134             !---------------------------------------------------------------------------- 
    135             qsr(ji,jj) = zqsr                                       
    136             qns(ji,jj) = qt_oce_ai(ji,jj) - zqsr               
    137  
    138             ! Mass flux at the atm. surface        
    139             !----------------------------------- 
    140             wfx_sub(ji,jj) = wfx_snw_sub(ji,jj) + wfx_ice_sub(ji,jj) 
    141  
    142             ! Mass flux at the ocean surface       
    143             !------------------------------------ 
    144             !  case of realistic freshwater flux (Tartinville et al., 2001) (presently ACTIVATED) 
    145             !  -------------------------------------------------------------------------------------  
    146             !  The idea of this approach is that the system that we consider is the ICE-OCEAN system 
    147             !  Thus  FW  flux  =  External ( E-P+snow melt) 
    148             !       Salt flux  =  Exchanges in the ice-ocean system then converted into FW 
    149             !                     Associated to Ice formation AND Ice melting 
    150             !                     Even if i see Ice melting as a FW and SALT flux 
    151             !         
    152             ! mass flux from ice/ocean 
    153             wfx_ice(ji,jj) = wfx_bog(ji,jj) + wfx_bom(ji,jj) + wfx_sum(ji,jj) + wfx_sni(ji,jj)   & 
    154                &           + wfx_opw(ji,jj) + wfx_dyn(ji,jj) + wfx_res(ji,jj) + wfx_lam(ji,jj) + wfx_pnd(ji,jj) 
    155  
    156             ! add the snow melt water to snow mass flux to the ocean 
    157             wfx_snw(ji,jj) = wfx_snw_sni(ji,jj) + wfx_snw_dyn(ji,jj) + wfx_snw_sum(ji,jj) 
    158  
    159             ! mass flux at the ocean/ice interface 
    160             fmmflx(ji,jj) = - ( wfx_ice(ji,jj) + wfx_snw(ji,jj) + wfx_err_sub(ji,jj) )              ! F/M mass flux save at least for biogeochemical model 
    161             emp(ji,jj)    = emp_oce(ji,jj) - wfx_ice(ji,jj) - wfx_snw(ji,jj) - wfx_err_sub(ji,jj)   ! mass flux + F/M mass flux (always ice/ocean mass exchange) 
    162  
    163  
    164             ! Salt flux at the ocean surface       
    165             !------------------------------------------ 
    166             sfx(ji,jj) = sfx_bog(ji,jj) + sfx_bom(ji,jj) + sfx_sum(ji,jj) + sfx_sni(ji,jj) + sfx_opw(ji,jj)   & 
    167                &       + sfx_res(ji,jj) + sfx_dyn(ji,jj) + sfx_bri(ji,jj) + sfx_sub(ji,jj) + sfx_lam(ji,jj) 
    168              
    169             ! Mass of snow and ice per unit area    
    170             !---------------------------------------- 
    171             snwice_mass_b(ji,jj) = snwice_mass(ji,jj)       ! save mass from the previous ice time step 
    172             !                                               ! new mass per unit area 
    173             snwice_mass  (ji,jj) = tmask(ji,jj,1) * ( rhos * vt_s(ji,jj) + rhoi * vt_i(ji,jj)  )  
    174             !                                               ! time evolution of snow+ice mass 
    175             snwice_fmass (ji,jj) = ( snwice_mass(ji,jj) - snwice_mass_b(ji,jj) ) * r1_rdtice 
    176              
    177          END DO 
    178       END DO 
     115      DO_2D_11_11 
     116 
     117         ! Solar heat flux reaching the ocean = zqsr (W.m-2)  
     118         !--------------------------------------------------- 
     119         zqsr = qsr_tot(ji,jj) - SUM( a_i_b(ji,jj,:) * ( qsr_ice(ji,jj,:) - qtr_ice_bot(ji,jj,:) ) ) 
     120 
     121         ! Total heat flux reaching the ocean = qt_oce_ai (W.m-2)  
     122         !--------------------------------------------------- 
     123         zqmass           = hfx_thd(ji,jj) + hfx_dyn(ji,jj) + hfx_res(ji,jj) ! heat flux from snow is 0 (T=0 degC) 
     124         qt_oce_ai(ji,jj) = qt_oce_ai(ji,jj) + zqmass + zqsr 
     125 
     126         ! Add the residual from heat diffusion equation and sublimation (W.m-2) 
     127         !---------------------------------------------------------------------- 
     128         qt_oce_ai(ji,jj) = qt_oce_ai(ji,jj) + hfx_err_dif(ji,jj) +   & 
     129            &             ( hfx_sub(ji,jj) - SUM( qevap_ice(ji,jj,:) * a_i_b(ji,jj,:) ) ) 
     130 
     131         ! New qsr and qns used to compute the oceanic heat flux at the next time step 
     132         !---------------------------------------------------------------------------- 
     133         qsr(ji,jj) = zqsr                                       
     134         qns(ji,jj) = qt_oce_ai(ji,jj) - zqsr               
     135 
     136         ! Mass flux at the atm. surface        
     137         !----------------------------------- 
     138         wfx_sub(ji,jj) = wfx_snw_sub(ji,jj) + wfx_ice_sub(ji,jj) 
     139 
     140         ! Mass flux at the ocean surface       
     141         !------------------------------------ 
     142         !  case of realistic freshwater flux (Tartinville et al., 2001) (presently ACTIVATED) 
     143         !  -------------------------------------------------------------------------------------  
     144         !  The idea of this approach is that the system that we consider is the ICE-OCEAN system 
     145         !  Thus  FW  flux  =  External ( E-P+snow melt) 
     146         !       Salt flux  =  Exchanges in the ice-ocean system then converted into FW 
     147         !                     Associated to Ice formation AND Ice melting 
     148         !                     Even if i see Ice melting as a FW and SALT flux 
     149         !         
     150         ! mass flux from ice/ocean 
     151         wfx_ice(ji,jj) = wfx_bog(ji,jj) + wfx_bom(ji,jj) + wfx_sum(ji,jj) + wfx_sni(ji,jj)   & 
     152            &           + wfx_opw(ji,jj) + wfx_dyn(ji,jj) + wfx_res(ji,jj) + wfx_lam(ji,jj) + wfx_pnd(ji,jj) 
     153 
     154         ! add the snow melt water to snow mass flux to the ocean 
     155         wfx_snw(ji,jj) = wfx_snw_sni(ji,jj) + wfx_snw_dyn(ji,jj) + wfx_snw_sum(ji,jj) 
     156 
     157         ! mass flux at the ocean/ice interface 
     158         fmmflx(ji,jj) = - ( wfx_ice(ji,jj) + wfx_snw(ji,jj) + wfx_err_sub(ji,jj) )              ! F/M mass flux save at least for biogeochemical model 
     159         emp(ji,jj)    = emp_oce(ji,jj) - wfx_ice(ji,jj) - wfx_snw(ji,jj) - wfx_err_sub(ji,jj)   ! mass flux + F/M mass flux (always ice/ocean mass exchange) 
     160 
     161 
     162         ! Salt flux at the ocean surface       
     163         !------------------------------------------ 
     164         sfx(ji,jj) = sfx_bog(ji,jj) + sfx_bom(ji,jj) + sfx_sum(ji,jj) + sfx_sni(ji,jj) + sfx_opw(ji,jj)   & 
     165            &       + sfx_res(ji,jj) + sfx_dyn(ji,jj) + sfx_bri(ji,jj) + sfx_sub(ji,jj) + sfx_lam(ji,jj) 
     166          
     167         ! Mass of snow and ice per unit area    
     168         !---------------------------------------- 
     169         snwice_mass_b(ji,jj) = snwice_mass(ji,jj)       ! save mass from the previous ice time step 
     170         !                                               ! new mass per unit area 
     171         snwice_mass  (ji,jj) = tmask(ji,jj,1) * ( rhos * vt_s(ji,jj) + rhoi * vt_i(ji,jj)  )  
     172         !                                               ! time evolution of snow+ice mass 
     173         snwice_fmass (ji,jj) = ( snwice_mass(ji,jj) - snwice_mass_b(ji,jj) ) * r1_rdtice 
     174          
     175      END_2D 
    179176 
    180177      ! Storing the transmitted variables 
    … …  
    286283#endif 
    287284      IF( ln_icectl                      )   CALL ice_prt       (kt, iiceprt, jiceprt, 3, 'Final state ice_update') ! prints 
    288       IF( ln_ctl                         )   CALL ice_prt3D     ('iceupdate')                                       ! prints 
     285      IF( sn_cfctl%l_prtctl              )   CALL ice_prt3D     ('iceupdate')                                       ! prints 
    289286      IF( ln_timing                      )   CALL timing_stop   ('ice_update')                                      ! timing 
    290287      ! 
    … …  
    335332      ! 
    336333      IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN     !==  Ice time-step only  ==!   (i.e. surface module time-step) 
    337          DO jj = 2, jpjm1                             !* update the modulus of stress at ocean surface (T-point) 
    338             DO ji = fs_2, fs_jpim1 
    339                !                                               ! 2*(U_ice-U_oce) at T-point 
    340                zu_t = u_ice(ji,jj) + u_ice(ji-1,jj) - u_oce(ji,jj) - u_oce(ji-1,jj)    
    341                zv_t = v_ice(ji,jj) + v_ice(ji,jj-1) - v_oce(ji,jj) - v_oce(ji,jj-1)  
    342                !                                              ! |U_ice-U_oce|^2 
    343                zmodt =  0.25_wp * (  zu_t * zu_t + zv_t * zv_t  ) 
    344                !                                               ! update the ocean stress modulus 
    345                taum(ji,jj) = ( 1._wp - at_i(ji,jj) ) * taum(ji,jj) + at_i(ji,jj) * zrhoco * zmodt 
    346                tmod_io(ji,jj) = zrhoco * SQRT( zmodt )          ! rhoco * |U_ice-U_oce| at T-point 
    347             END DO 
    348          END DO 
     334         DO_2D_00_00 
     335            !                                               ! 2*(U_ice-U_oce) at T-point 
     336            zu_t = u_ice(ji,jj) + u_ice(ji-1,jj) - u_oce(ji,jj) - u_oce(ji-1,jj)    
     337            zv_t = v_ice(ji,jj) + v_ice(ji,jj-1) - v_oce(ji,jj) - v_oce(ji,jj-1)  
     338            !                                              ! |U_ice-U_oce|^2 
     339            zmodt =  0.25_wp * (  zu_t * zu_t + zv_t * zv_t  ) 
     340            !                                               ! update the ocean stress modulus 
     341            taum(ji,jj) = ( 1._wp - at_i(ji,jj) ) * taum(ji,jj) + at_i(ji,jj) * zrhoco * zmodt 
     342            tmod_io(ji,jj) = zrhoco * SQRT( zmodt )          ! rhoco * |U_ice-U_oce| at T-point 
     343         END_2D 
    349344         CALL lbc_lnk_multi( 'iceupdate', taum, 'T', 1., tmod_io, 'T', 1. ) 
    350345         ! 
    … …  
    356351      !                                      !==  every ocean time-step  ==! 
    357352      ! 
    358       DO jj = 2, jpjm1                                !* update the stress WITHOUT an ice-ocean rotation angle 
    359          DO ji = fs_2, fs_jpim1   ! Vect. Opt.    
    360             ! ice area at u and v-points  
    361             zat_u  = ( at_i(ji,jj) * tmask(ji,jj,1) + at_i (ji+1,jj    ) * tmask(ji+1,jj  ,1) )  & 
    362                &     / MAX( 1.0_wp , tmask(ji,jj,1) + tmask(ji+1,jj  ,1) ) 
    363             zat_v  = ( at_i(ji,jj) * tmask(ji,jj,1) + at_i (ji  ,jj+1  ) * tmask(ji  ,jj+1,1) )  & 
    364                &     / MAX( 1.0_wp , tmask(ji,jj,1) + tmask(ji  ,jj+1,1) ) 
    365             !                                                   ! linearized quadratic drag formulation 
    366             zutau_ice   = 0.5_wp * ( tmod_io(ji,jj) + tmod_io(ji+1,jj) ) * ( u_ice(ji,jj) - pu_oce(ji,jj) ) 
    367             zvtau_ice   = 0.5_wp * ( tmod_io(ji,jj) + tmod_io(ji,jj+1) ) * ( v_ice(ji,jj) - pv_oce(ji,jj) ) 
    368             !                                                   ! stresses at the ocean surface 
    369             utau(ji,jj) = ( 1._wp - zat_u ) * utau_oce(ji,jj) + zat_u * zutau_ice 
    370             vtau(ji,jj) = ( 1._wp - zat_v ) * vtau_oce(ji,jj) + zat_v * zvtau_ice 
    371          END DO 
    372       END DO 
     353      DO_2D_00_00 
     354         ! ice area at u and v-points  
     355         zat_u  = ( at_i(ji,jj) * tmask(ji,jj,1) + at_i (ji+1,jj    ) * tmask(ji+1,jj  ,1) )  & 
     356            &     / MAX( 1.0_wp , tmask(ji,jj,1) + tmask(ji+1,jj  ,1) ) 
     357         zat_v  = ( at_i(ji,jj) * tmask(ji,jj,1) + at_i (ji  ,jj+1  ) * tmask(ji  ,jj+1,1) )  & 
     358            &     / MAX( 1.0_wp , tmask(ji,jj,1) + tmask(ji  ,jj+1,1) ) 
     359         !                                                   ! linearized quadratic drag formulation 
     360         zutau_ice   = 0.5_wp * ( tmod_io(ji,jj) + tmod_io(ji+1,jj) ) * ( u_ice(ji,jj) - pu_oce(ji,jj) ) 
     361         zvtau_ice   = 0.5_wp * ( tmod_io(ji,jj) + tmod_io(ji,jj+1) ) * ( v_ice(ji,jj) - pv_oce(ji,jj) ) 
     362         !                                                   ! stresses at the ocean surface 
     363         utau(ji,jj) = ( 1._wp - zat_u ) * utau_oce(ji,jj) + zat_u * zutau_ice 
     364         vtau(ji,jj) = ( 1._wp - zat_v ) * vtau_oce(ji,jj) + zat_v * zvtau_ice 
     365      END_2D 
    373366      CALL lbc_lnk_multi( 'iceupdate', utau, 'U', -1., vtau, 'V', -1. )   ! lateral boundary condition 
    374367      ! 

  • NEMO/trunk/src/ICE/icevar.F90

    r11732 r12377  
    8282   END INTERFACE 
    8383 
     84   !! * Substitutions 
     85#  include "do_loop_substitute.h90" 
    8486   !!---------------------------------------------------------------------- 
    8587   !! NEMO/ICE 4.0 , NEMO Consortium (2018) 
    … …  
    115117      ! 
    116118      ato_i(:,:) = 1._wp - at_i(:,:)         ! open water fraction   
    117  
     119      ! 
     120      !!GS: tm_su always needed by ABL over sea-ice 
     121      ALLOCATE( z1_at_i(jpi,jpj) ) 
     122      WHERE( at_i(:,:) > epsi20 )   ;   z1_at_i(:,:) = 1._wp / at_i(:,:) 
     123      ELSEWHERE                     ;   z1_at_i(:,:) = 0._wp 
     124      END WHERE 
     125      tm_su(:,:) = SUM( t_su(:,:,:) * a_i(:,:,:) , dim=3 ) * z1_at_i(:,:) 
     126      WHERE( at_i(:,:)<=epsi20 ) tm_su(:,:) = rt0 
     127      ! 
    118128      ! The following fields are calculated for diagnostics and outputs only 
    119129      ! ==> Do not use them for other purposes 
    120130      IF( kn > 1 ) THEN 
    121131         ! 
    122          ALLOCATE( z1_at_i(jpi,jpj) , z1_vt_i(jpi,jpj) , z1_vt_s(jpi,jpj) ) 
    123          WHERE( at_i(:,:) > epsi20 )   ;   z1_at_i(:,:) = 1._wp / at_i(:,:) 
    124          ELSEWHERE                     ;   z1_at_i(:,:) = 0._wp 
    125          END WHERE 
     132         ALLOCATE( z1_vt_i(jpi,jpj) , z1_vt_s(jpi,jpj) ) 
    126133         WHERE( vt_i(:,:) > epsi20 )   ;   z1_vt_i(:,:) = 1._wp / vt_i(:,:) 
    127134         ELSEWHERE                     ;   z1_vt_i(:,:) = 0._wp 
    … …  
    136143         !          
    137144         !                          ! mean temperature (K), salinity and age 
    138          tm_su(:,:) = SUM( t_su(:,:,:) * a_i(:,:,:) , dim=3 ) * z1_at_i(:,:) 
    139145         tm_si(:,:) = SUM( t_si(:,:,:) * a_i(:,:,:) , dim=3 ) * z1_at_i(:,:) 
    140146         om_i (:,:) = SUM( oa_i(:,:,:)              , dim=3 ) * z1_at_i(:,:) 
    … …  
    154160         !                           ! put rt0 where there is no ice 
    155161         WHERE( at_i(:,:)<=epsi20 ) 
    156             tm_su(:,:) = rt0 
    157162            tm_si(:,:) = rt0 
    158163            tm_i (:,:) = rt0 
    … …  
    165170         END WHERE          
    166171         ! 
    167          DEALLOCATE( z1_at_i , z1_vt_i , z1_vt_s ) 
     172         DEALLOCATE( z1_vt_i , z1_vt_s ) 
    168173         ! 
    169174      ENDIF 
     175      ! 
     176      DEALLOCATE( z1_at_i ) 
    170177      ! 
    171178   END SUBROUTINE ice_var_agg 
    … …  
    236243      zlay_i   = REAL( nlay_i , wp )    ! number of layers 
    237244      DO jl = 1, jpl 
    238          DO jk = 1, nlay_i 
    239             DO jj = 1, jpj 
    240                DO ji = 1, jpi 
    241                   IF ( v_i(ji,jj,jl) > epsi20 ) THEN     !--- icy area  
    242                      ! 
    243                      ze_i             =   e_i (ji,jj,jk,jl) * z1_v_i(ji,jj,jl) * zlay_i             ! Energy of melting e(S,T) [J.m-3] 
    244                      ztmelts          = - sz_i(ji,jj,jk,jl) * rTmlt                                 ! Ice layer melt temperature [C] 
    245                      ! Conversion q(S,T) -> T (second order equation) 
    246                      zbbb             = ( rcp - rcpi ) * ztmelts + ze_i * r1_rhoi - rLfus 
    247                      zccc             = SQRT( MAX( zbbb * zbbb - 4._wp * rcpi * rLfus * ztmelts , 0._wp) ) 
    248                      t_i(ji,jj,jk,jl) = MAX( -100._wp , MIN( -( zbbb + zccc ) * 0.5_wp * r1_rcpi , ztmelts ) ) + rt0   ! [K] with bounds: -100 < t_i < ztmelts 
    249                      ! 
    250                   ELSE                                   !--- no ice 
    251                      t_i(ji,jj,jk,jl) = rt0 
    252                   ENDIF 
    253                END DO 
    254             END DO 
    255          END DO 
     245         DO_3D_11_11( 1, nlay_i ) 
     246            IF ( v_i(ji,jj,jl) > epsi20 ) THEN     !--- icy area  
     247               ! 
     248               ze_i             =   e_i (ji,jj,jk,jl) * z1_v_i(ji,jj,jl) * zlay_i             ! Energy of melting e(S,T) [J.m-3] 
     249               ztmelts          = - sz_i(ji,jj,jk,jl) * rTmlt                                 ! Ice layer melt temperature [C] 
     250               ! Conversion q(S,T) -> T (second order equation) 
     251               zbbb             = ( rcp - rcpi ) * ztmelts + ze_i * r1_rhoi - rLfus 
     252               zccc             = SQRT( MAX( zbbb * zbbb - 4._wp * rcpi * rLfus * ztmelts , 0._wp) ) 
     253               t_i(ji,jj,jk,jl) = MAX( -100._wp , MIN( -( zbbb + zccc ) * 0.5_wp * r1_rcpi , ztmelts ) ) + rt0   ! [K] with bounds: -100 < t_i < ztmelts 
     254               ! 
     255            ELSE                                   !--- no ice 
     256               t_i(ji,jj,jk,jl) = rt0 
     257            ENDIF 
     258         END_3D 
    256259      END DO 
    257260 
    … …  
    344347         z1_dS = 1._wp / ( zsi1 - zsi0 ) 
    345348         DO jl = 1, jpl 
    346             DO jj = 1, jpj 
    347                DO ji = 1, jpi 
    348                   zalpha(ji,jj,jl) = MAX(  0._wp , MIN( ( zsi1 - s_i(ji,jj,jl) ) * z1_dS , 1._wp )  ) 
    349                   !                             ! force a constant profile when SSS too low (Baltic Sea) 
    350                   IF( 2._wp * s_i(ji,jj,jl) >= sss_m(ji,jj) )   zalpha(ji,jj,jl) = 0._wp   
    351                END DO 
    352             END DO 
     349            DO_2D_11_11 
     350               zalpha(ji,jj,jl) = MAX(  0._wp , MIN( ( zsi1 - s_i(ji,jj,jl) ) * z1_dS , 1._wp )  ) 
     351               !                             ! force a constant profile when SSS too low (Baltic Sea) 
     352               IF( 2._wp * s_i(ji,jj,jl) >= sss_m(ji,jj) )   zalpha(ji,jj,jl) = 0._wp   
     353            END_2D 
    353354         END DO 
    354355         ! 
    355356         ! Computation of the profile 
    356357         DO jl = 1, jpl 
    357             DO jk = 1, nlay_i 
    358                DO jj = 1, jpj 
    359                   DO ji = 1, jpi 
    360                      !                          ! linear profile with 0 surface value 
    361                      zs0 = z_slope_s(ji,jj,jl) * ( REAL(jk,wp) - 0.5_wp ) * h_i(ji,jj,jl) * r1_nlay_i 
    362                      zs  = zalpha(ji,jj,jl) * zs0 + ( 1._wp - zalpha(ji,jj,jl) ) * s_i(ji,jj,jl)     ! weighting the profile 
    363                      sz_i(ji,jj,jk,jl) = MIN( rn_simax, MAX( zs, rn_simin ) ) 
    364                   END DO 
    365                END DO 
    366             END DO 
     358            DO_3D_11_11( 1, nlay_i ) 
     359               !                          ! linear profile with 0 surface value 
     360               zs0 = z_slope_s(ji,jj,jl) * ( REAL(jk,wp) - 0.5_wp ) * h_i(ji,jj,jl) * r1_nlay_i 
     361               zs  = zalpha(ji,jj,jl) * zs0 + ( 1._wp - zalpha(ji,jj,jl) ) * s_i(ji,jj,jl)     ! weighting the profile 
     362               sz_i(ji,jj,jk,jl) = MIN( rn_simax, MAX( zs, rn_simin ) ) 
     363            END_3D 
    367364         END DO 
    368365         ! 
    … …  
    489486         ! Zap ice energy and use ocean heat to melt ice 
    490487         !----------------------------------------------------------------- 
    491          DO jk = 1, nlay_i 
    492             DO jj = 1 , jpj 
    493                DO ji = 1 , jpi 
    494                   ! update exchanges with ocean 
    495                   hfx_res(ji,jj)   = hfx_res(ji,jj) - (1._wp - zswitch(ji,jj) ) * e_i(ji,jj,jk,jl) * r1_rdtice ! W.m-2 <0 
    496                   e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) * zswitch(ji,jj) 
    497                   t_i(ji,jj,jk,jl) = t_i(ji,jj,jk,jl) * zswitch(ji,jj) + rt0 * ( 1._wp - zswitch(ji,jj) ) 
    498                END DO 
    499             END DO 
    500          END DO 
    501          ! 
    502          DO jk = 1, nlay_s 
    503             DO jj = 1 , jpj 
    504                DO ji = 1 , jpi 
    505                   ! update exchanges with ocean 
    506                   hfx_res(ji,jj)   = hfx_res(ji,jj) - (1._wp - zswitch(ji,jj) ) * e_s(ji,jj,jk,jl) * r1_rdtice ! W.m-2 <0 
    507                   e_s(ji,jj,jk,jl) = e_s(ji,jj,jk,jl) * zswitch(ji,jj) 
    508                   t_s(ji,jj,jk,jl) = t_s(ji,jj,jk,jl) * zswitch(ji,jj) + rt0 * ( 1._wp - zswitch(ji,jj) ) 
    509                END DO 
    510             END DO 
    511          END DO 
     488         DO_3D_11_11( 1, nlay_i ) 
     489            ! update exchanges with ocean 
     490            hfx_res(ji,jj)   = hfx_res(ji,jj) - (1._wp - zswitch(ji,jj) ) * e_i(ji,jj,jk,jl) * r1_rdtice ! W.m-2 <0 
     491            e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) * zswitch(ji,jj) 
     492            t_i(ji,jj,jk,jl) = t_i(ji,jj,jk,jl) * zswitch(ji,jj) + rt0 * ( 1._wp - zswitch(ji,jj) ) 
     493         END_3D 
     494         ! 
     495         DO_3D_11_11( 1, nlay_s ) 
     496            ! update exchanges with ocean 
     497            hfx_res(ji,jj)   = hfx_res(ji,jj) - (1._wp - zswitch(ji,jj) ) * e_s(ji,jj,jk,jl) * r1_rdtice ! W.m-2 <0 
     498            e_s(ji,jj,jk,jl) = e_s(ji,jj,jk,jl) * zswitch(ji,jj) 
     499            t_s(ji,jj,jk,jl) = t_s(ji,jj,jk,jl) * zswitch(ji,jj) + rt0 * ( 1._wp - zswitch(ji,jj) ) 
     500         END_3D 
    512501         ! 
    513502         !----------------------------------------------------------------- 
    514503         ! zap ice and snow volume, add water and salt to ocean 
    515504         !----------------------------------------------------------------- 
    516          DO jj = 1 , jpj 
    517             DO ji = 1 , jpi 
    518                ! update exchanges with ocean 
    519                sfx_res(ji,jj)  = sfx_res(ji,jj) + (1._wp - zswitch(ji,jj) ) * sv_i(ji,jj,jl)   * rhoi * r1_rdtice 
    520                wfx_res(ji,jj)  = wfx_res(ji,jj) + (1._wp - zswitch(ji,jj) ) * v_i (ji,jj,jl)   * rhoi * r1_rdtice 
    521                wfx_res(ji,jj)  = wfx_res(ji,jj) + (1._wp - zswitch(ji,jj) ) * v_s (ji,jj,jl)   * rhos * r1_rdtice 
    522                ! 
    523                a_i  (ji,jj,jl) = a_i (ji,jj,jl) * zswitch(ji,jj) 
    524                v_i  (ji,jj,jl) = v_i (ji,jj,jl) * zswitch(ji,jj) 
    525                v_s  (ji,jj,jl) = v_s (ji,jj,jl) * zswitch(ji,jj) 
    526                t_su (ji,jj,jl) = t_su(ji,jj,jl) * zswitch(ji,jj) + t_bo(ji,jj) * ( 1._wp - zswitch(ji,jj) ) 
    527                oa_i (ji,jj,jl) = oa_i(ji,jj,jl) * zswitch(ji,jj) 
    528                sv_i (ji,jj,jl) = sv_i(ji,jj,jl) * zswitch(ji,jj) 
    529                ! 
    530                h_i (ji,jj,jl) = h_i (ji,jj,jl) * zswitch(ji,jj) 
    531                h_s (ji,jj,jl) = h_s (ji,jj,jl) * zswitch(ji,jj) 
    532                ! 
    533                a_ip (ji,jj,jl) = a_ip (ji,jj,jl) * zswitch(ji,jj) 
    534                v_ip (ji,jj,jl) = v_ip (ji,jj,jl) * zswitch(ji,jj) 
    535                ! 
    536             END DO 
    537          END DO 
     505         DO_2D_11_11 
     506            ! update exchanges with ocean 
     507            sfx_res(ji,jj)  = sfx_res(ji,jj) + (1._wp - zswitch(ji,jj) ) * sv_i(ji,jj,jl)   * rhoi * r1_rdtice 
     508            wfx_res(ji,jj)  = wfx_res(ji,jj) + (1._wp - zswitch(ji,jj) ) * v_i (ji,jj,jl)   * rhoi * r1_rdtice 
     509            wfx_res(ji,jj)  = wfx_res(ji,jj) + (1._wp - zswitch(ji,jj) ) * v_s (ji,jj,jl)   * rhos * r1_rdtice 
     510            ! 
     511            a_i  (ji,jj,jl) = a_i (ji,jj,jl) * zswitch(ji,jj) 
     512            v_i  (ji,jj,jl) = v_i (ji,jj,jl) * zswitch(ji,jj) 
     513            v_s  (ji,jj,jl) = v_s (ji,jj,jl) * zswitch(ji,jj) 
     514            t_su (ji,jj,jl) = t_su(ji,jj,jl) * zswitch(ji,jj) + t_bo(ji,jj) * ( 1._wp - zswitch(ji,jj) ) 
     515            oa_i (ji,jj,jl) = oa_i(ji,jj,jl) * zswitch(ji,jj) 
     516            sv_i (ji,jj,jl) = sv_i(ji,jj,jl) * zswitch(ji,jj) 
     517            ! 
     518            h_i (ji,jj,jl) = h_i (ji,jj,jl) * zswitch(ji,jj) 
     519            h_s (ji,jj,jl) = h_s (ji,jj,jl) * zswitch(ji,jj) 
     520            ! 
     521            a_ip (ji,jj,jl) = a_ip (ji,jj,jl) * zswitch(ji,jj) 
     522            v_ip (ji,jj,jl) = v_ip (ji,jj,jl) * zswitch(ji,jj) 
     523            ! 
     524         END_2D 
    538525         ! 
    539526      END DO  
    … …  
    587574         ! zap ice energy and send it to the ocean 
    588575         !---------------------------------------- 
    589          DO jk = 1, nlay_i 
    590             DO jj = 1 , jpj 
    591                DO ji = 1 , jpi 
    592                   IF( pe_i(ji,jj,jk,jl) < 0._wp .OR. pa_i(ji,jj,jl) <= 0._wp ) THEN 
    593                      hfx_res(ji,jj)   = hfx_res(ji,jj) - pe_i(ji,jj,jk,jl) * z1_dt ! W.m-2 >0 
    594                      pe_i(ji,jj,jk,jl) = 0._wp 
    595                   ENDIF 
    596                END DO 
    597             END DO 
    598          END DO 
    599          ! 
    600          DO jk = 1, nlay_s 
    601             DO jj = 1 , jpj 
    602                DO ji = 1 , jpi 
    603                   IF( pe_s(ji,jj,jk,jl) < 0._wp .OR. pa_i(ji,jj,jl) <= 0._wp ) THEN 
    604                      hfx_res(ji,jj)   = hfx_res(ji,jj) - pe_s(ji,jj,jk,jl) * z1_dt ! W.m-2 <0 
    605                      pe_s(ji,jj,jk,jl) = 0._wp 
    606                   ENDIF 
    607                END DO 
    608             END DO 
    609          END DO 
     576         DO_3D_11_11( 1, nlay_i ) 
     577            IF( pe_i(ji,jj,jk,jl) < 0._wp .OR. pa_i(ji,jj,jl) <= 0._wp ) THEN 
     578               hfx_res(ji,jj)   = hfx_res(ji,jj) - pe_i(ji,jj,jk,jl) * z1_dt ! W.m-2 >0 
     579               pe_i(ji,jj,jk,jl) = 0._wp 
     580            ENDIF 
     581         END_3D 
     582         ! 
     583         DO_3D_11_11( 1, nlay_s ) 
     584            IF( pe_s(ji,jj,jk,jl) < 0._wp .OR. pa_i(ji,jj,jl) <= 0._wp ) THEN 
     585               hfx_res(ji,jj)   = hfx_res(ji,jj) - pe_s(ji,jj,jk,jl) * z1_dt ! W.m-2 <0 
     586               pe_s(ji,jj,jk,jl) = 0._wp 
     587            ENDIF 
     588         END_3D 
    610589         ! 
    611590         !----------------------------------------------------- 
    612591         ! zap ice and snow volume, add water and salt to ocean 
    613592         !----------------------------------------------------- 
    614          DO jj = 1 , jpj 
    615             DO ji = 1 , jpi 
    616                IF( pv_i(ji,jj,jl) < 0._wp .OR. pa_i(ji,jj,jl) <= 0._wp ) THEN 
    617                   wfx_res(ji,jj)    = wfx_res(ji,jj) + pv_i (ji,jj,jl) * rhoi * z1_dt 
    618                   pv_i   (ji,jj,jl) = 0._wp 
    619                ENDIF 
    620                IF( pv_s(ji,jj,jl) < 0._wp .OR. pa_i(ji,jj,jl) <= 0._wp ) THEN 
    621                   wfx_res(ji,jj)    = wfx_res(ji,jj) + pv_s (ji,jj,jl) * rhos * z1_dt 
    622                   pv_s   (ji,jj,jl) = 0._wp 
    623                ENDIF 
    624                IF( psv_i(ji,jj,jl) < 0._wp .OR. pa_i(ji,jj,jl) <= 0._wp .OR. pv_i(ji,jj,jl) <= 0._wp ) THEN 
    625                   sfx_res(ji,jj)    = sfx_res(ji,jj) + psv_i(ji,jj,jl) * rhoi * z1_dt 
    626                   psv_i  (ji,jj,jl) = 0._wp 
    627                ENDIF 
    628             END DO 
    629          END DO 
     593         DO_2D_11_11 
     594            IF( pv_i(ji,jj,jl) < 0._wp .OR. pa_i(ji,jj,jl) <= 0._wp ) THEN 
     595               wfx_res(ji,jj)    = wfx_res(ji,jj) + pv_i (ji,jj,jl) * rhoi * z1_dt 
     596               pv_i   (ji,jj,jl) = 0._wp 
     597            ENDIF 
     598            IF( pv_s(ji,jj,jl) < 0._wp .OR. pa_i(ji,jj,jl) <= 0._wp ) THEN 
     599               wfx_res(ji,jj)    = wfx_res(ji,jj) + pv_s (ji,jj,jl) * rhos * z1_dt 
     600               pv_s   (ji,jj,jl) = 0._wp 
     601            ENDIF 
     602            IF( psv_i(ji,jj,jl) < 0._wp .OR. pa_i(ji,jj,jl) <= 0._wp .OR. pv_i(ji,jj,jl) <= 0._wp ) THEN 
     603               sfx_res(ji,jj)    = sfx_res(ji,jj) + psv_i(ji,jj,jl) * rhoi * z1_dt 
     604               psv_i  (ji,jj,jl) = 0._wp 
     605            ENDIF 
     606         END_2D 
    630607         ! 
    631608      END DO  

  • NEMO/trunk/src/ICE/icewri.F90

    r11575 r12377  
    3535   PUBLIC ice_wri_state  ! called by dia_wri_state  
    3636 
     37   !! * Substitutions 
     38#  include "do_loop_substitute.h90" 
    3739   !!---------------------------------------------------------------------- 
    3840   !! NEMO/ICE 4.0 , NEMO Consortium (2018) 
    … …  
    6971 
    7072      ! tresholds for outputs 
    71       DO jj = 1, jpj 
    72          DO ji = 1, jpi 
    73             zmsk00(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi06  ) ) ! 1 if ice    , 0 if no ice 
    74             zmsk05(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - 0.05_wp ) ) ! 1 if 5% ice , 0 if less 
    75             zmsk15(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - 0.15_wp ) ) ! 1 if 15% ice, 0 if less 
    76             zmsksn(ji,jj) = MAX( 0._wp , SIGN( 1._wp , vt_s(ji,jj) - epsi06  ) ) ! 1 if snow   , 0 if no snow 
    77          END DO 
    78       END DO 
     73      DO_2D_11_11 
     74         zmsk00(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi06  ) ) ! 1 if ice    , 0 if no ice 
     75         zmsk05(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - 0.05_wp ) ) ! 1 if 5% ice , 0 if less 
     76         zmsk15(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - 0.15_wp ) ) ! 1 if 15% ice, 0 if less 
     77         zmsksn(ji,jj) = MAX( 0._wp , SIGN( 1._wp , vt_s(ji,jj) - epsi06  ) ) ! 1 if snow   , 0 if no snow 
     78      END_2D 
    7979      DO jl = 1, jpl 
    80          DO jj = 1, jpj 
    81             DO ji = 1, jpi 
    82                zmsk00l(ji,jj,jl)  = MAX( 0._wp , SIGN( 1._wp , a_i(ji,jj,jl) - epsi06 ) ) 
    83                zmsksnl(ji,jj,jl)  = MAX( 0._wp , SIGN( 1._wp , v_s(ji,jj,jl) - epsi06 ) ) 
    84             END DO 
    85          END DO 
     80         DO_2D_11_11 
     81            zmsk00l(ji,jj,jl)  = MAX( 0._wp , SIGN( 1._wp , a_i(ji,jj,jl) - epsi06 ) ) 
     82            zmsksnl(ji,jj,jl)  = MAX( 0._wp , SIGN( 1._wp , v_s(ji,jj,jl) - epsi06 ) ) 
     83         END_2D 
    8684      END DO 
    8785 
    … …  
    132130      ! 
    133131      IF( iom_use('icevel') .OR. iom_use('fasticepres') ) THEN                                                              ! module of ice velocity 
    134          DO jj = 2 , jpjm1 
    135             DO ji = 2 , jpim1 
    136                z2da  = u_ice(ji,jj) + u_ice(ji-1,jj) 
    137                z2db  = v_ice(ji,jj) + v_ice(ji,jj-1) 
    138                z2d(ji,jj) = 0.5_wp * SQRT( z2da * z2da + z2db * z2db ) 
    139            END DO 
    140          END DO 
     132         DO_2D_00_00 
     133            z2da  = u_ice(ji,jj) + u_ice(ji-1,jj) 
     134            z2db  = v_ice(ji,jj) + v_ice(ji,jj-1) 
     135            z2d(ji,jj) = 0.5_wp * SQRT( z2da * z2da + z2db * z2db ) 
     136         END_2D 
    141137         CALL lbc_lnk( 'icewri', z2d, 'T', 1. ) 
    142138         CALL iom_put( 'icevel', z2d ) 
Note: See TracChangeset for help on using the changeset viewer.