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

Changeset 13469


Ignore:
Timestamp:
2020-09-15T12:49:18+02:00 (4 years ago)
Author:
smasson
Message:

r4_trunk: first change of DO loops for routines to be merged, see #2523

Location:
NEMO/branches/2020/temporary_r4_trunk
Files:
32 edited

Legend:

Unmodified
Added
Removed

  • NEMO/branches/2020/temporary_r4_trunk/src/ICE/icealb.F90

    r13466 r13469  
    122122      ! 
    123123      DO jl = 1, jpl 
    124          DO jj = 1, jpj 
    125             DO ji = 1, jpi 
    126                ! 
    127                !---------------------------------------------! 
    128                !--- Specific snow, ice and pond fractions ---! 
    129                !---------------------------------------------!                
    130                zafrac_snw = za_s_fra(ji,jj,jl) 
    131                IF( ld_pnd_alb ) THEN 
    132                   zafrac_pnd = MIN( pafrac_pnd(ji,jj,jl), 1._wp - zafrac_snw ) ! make sure (a_ip_eff + a_s_fra) <= 1 
    133                ELSE 
    134                   zafrac_pnd = 0._wp 
    135                ENDIF 
    136                zafrac_ice = MAX( 0._wp, 1._wp - zafrac_pnd - zafrac_snw ) ! max for roundoff errors 
    137                ! 
    138                !---------------! 
    139                !--- Albedos ---! 
    140                !---------------!                
    141                !                       !--- Bare ice albedo (for hi > 150cm) 
    142                IF( ld_pnd_alb ) THEN 
    143                   zalb_ice = rn_alb_idry 
    144                ELSE 
    145                   IF( ph_snw(ji,jj,jl) == 0._wp .AND. pt_su(ji,jj,jl) >= rt0 ) THEN   ;   zalb_ice = rn_alb_imlt 
    146                   ELSE                                                                ;   zalb_ice = rn_alb_idry   ;   ENDIF 
    147                ENDIF 
    148                !                       !--- Bare ice albedo (for hi < 150cm) 
    149                IF( 0.05 < ph_ice(ji,jj,jl) .AND. ph_ice(ji,jj,jl) <= 1.5 ) THEN      ! 5cm < hi < 150cm 
    150                   zalb_ice = zalb_ice    + ( 0.18 - zalb_ice   ) * z1_c1 * ( LOG(1.5) - LOG(ph_ice(ji,jj,jl)) ) 
    151                ELSEIF( ph_ice(ji,jj,jl) <= 0.05 ) THEN                               ! 0cm < hi < 5cm 
    152                   zalb_ice = rn_alb_oce  + ( 0.18 - rn_alb_oce ) * z1_c2 * ph_ice(ji,jj,jl) 
    153                ENDIF 
    154                ! 
    155                !                       !--- Snow-covered ice albedo (freezing, melting cases) 
    156                IF( pt_su(ji,jj,jl) < rt0 ) THEN 
    157                   zalb_snw = rn_alb_sdry - ( rn_alb_sdry - zalb_ice ) * EXP( - ph_snw(ji,jj,jl) * z1_c3 ) 
    158                ELSE 
    159                   zalb_snw = rn_alb_smlt - ( rn_alb_smlt - zalb_ice ) * EXP( - ph_snw(ji,jj,jl) * z1_c4 ) 
    160                ENDIF 
    161                !                       !--- Ponded ice albedo 
    162                zalb_pnd = rn_alb_dpnd - ( rn_alb_dpnd - zalb_ice ) * EXP( - ph_pnd(ji,jj,jl) * z1_href_pnd )  
    163                ! 
    164                !                       !--- Surface albedo is weighted mean of snow, ponds and bare ice contributions 
    165                zalb_os = ( zafrac_snw * zalb_snw + zafrac_pnd * zalb_pnd + zafrac_ice * zalb_ice ) * tmask(ji,jj,1) 
    166                ! 
    167                zalb_cs = zalb_os - ( - 0.1010 * zalb_os * zalb_os  & 
    168                   &                  + 0.1933 * zalb_os - 0.0148 ) * tmask(ji,jj,1) 
    169                ! 
    170                ! albedo depends on cloud fraction because of non-linear spectral effects 
    171                palb_ice(ji,jj,jl) = ( 1._wp - pcloud_fra(ji,jj) ) * zalb_cs + pcloud_fra(ji,jj) * zalb_os 
    172  
    173             END DO 
    174          END DO 
     124         DO_2D_11_11 
     125            ! 
     126            !---------------------------------------------! 
     127            !--- Specific snow, ice and pond fractions ---! 
     128            !---------------------------------------------!                
     129            zafrac_snw = za_s_fra(ji,jj,jl) 
     130            IF( ld_pnd_alb ) THEN 
     131               zafrac_pnd = MIN( pafrac_pnd(ji,jj,jl), 1._wp - zafrac_snw ) ! make sure (a_ip_eff + a_s_fra) <= 1 
     132            ELSE 
     133               zafrac_pnd = 0._wp 
     134            ENDIF 
     135            zafrac_ice = MAX( 0._wp, 1._wp - zafrac_pnd - zafrac_snw ) ! max for roundoff errors 
     136            ! 
     137            !---------------! 
     138            !--- Albedos ---! 
     139            !---------------!                
     140            !                       !--- Bare ice albedo (for hi > 150cm) 
     141            IF( ld_pnd_alb ) THEN 
     142               zalb_ice = rn_alb_idry 
     143            ELSE 
     144               IF( ph_snw(ji,jj,jl) == 0._wp .AND. pt_su(ji,jj,jl) >= rt0 ) THEN   ;   zalb_ice = rn_alb_imlt 
     145               ELSE                                                                ;   zalb_ice = rn_alb_idry   ;   ENDIF 
     146            ENDIF 
     147            !                       !--- Bare ice albedo (for hi < 150cm) 
     148            IF( 0.05 < ph_ice(ji,jj,jl) .AND. ph_ice(ji,jj,jl) <= 1.5 ) THEN      ! 5cm < hi < 150cm 
     149               zalb_ice = zalb_ice    + ( 0.18 - zalb_ice   ) * z1_c1 * ( LOG(1.5) - LOG(ph_ice(ji,jj,jl)) ) 
     150            ELSEIF( ph_ice(ji,jj,jl) <= 0.05 ) THEN                               ! 0cm < hi < 5cm 
     151               zalb_ice = rn_alb_oce  + ( 0.18 - rn_alb_oce ) * z1_c2 * ph_ice(ji,jj,jl) 
     152            ENDIF 
     153            ! 
     154            !                       !--- Snow-covered ice albedo (freezing, melting cases) 
     155            IF( pt_su(ji,jj,jl) < rt0 ) THEN 
     156               zalb_snw = rn_alb_sdry - ( rn_alb_sdry - zalb_ice ) * EXP( - ph_snw(ji,jj,jl) * z1_c3 ) 
     157            ELSE 
     158               zalb_snw = rn_alb_smlt - ( rn_alb_smlt - zalb_ice ) * EXP( - ph_snw(ji,jj,jl) * z1_c4 ) 
     159            ENDIF 
     160            !                       !--- Ponded ice albedo 
     161            zalb_pnd = rn_alb_dpnd - ( rn_alb_dpnd - zalb_ice ) * EXP( - ph_pnd(ji,jj,jl) * z1_href_pnd )  
     162            ! 
     163            !                       !--- Surface albedo is weighted mean of snow, ponds and bare ice contributions 
     164            zalb_os = ( zafrac_snw * zalb_snw + zafrac_pnd * zalb_pnd + zafrac_ice * zalb_ice ) * tmask(ji,jj,1) 
     165            ! 
     166            zalb_cs = zalb_os - ( - 0.1010 * zalb_os * zalb_os  & 
     167               &                  + 0.1933 * zalb_os - 0.0148 ) * tmask(ji,jj,1) 
     168            ! 
     169            ! albedo depends on cloud fraction because of non-linear spectral effects 
     170            palb_ice(ji,jj,jl) = ( 1._wp - pcloud_fra(ji,jj) ) * zalb_cs + pcloud_fra(ji,jj) * zalb_os 
     171 
     172         END_2D 
    175173      END DO 
    176174      ! 

  • NEMO/branches/2020/temporary_r4_trunk/src/ICE/icecor.F90

    r13466 r13469  
    9292         zzc = rhoi * r1_rdtice 
    9393         DO jl = 1, jpl 
    94             DO jj = 1, jpj  
    95                DO ji = 1, jpi 
    96                   zsal = sv_i(ji,jj,jl) 
    97                   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)  ) 
    98                   sfx_res(ji,jj) = sfx_res(ji,jj) - ( sv_i(ji,jj,jl) - zsal ) * zzc   ! associated salt flux 
    99                END DO 
    100             END DO 
     94            DO_2D_11_11 
     95               zsal = sv_i(ji,jj,jl) 
     96               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)  ) 
     97               sfx_res(ji,jj) = sfx_res(ji,jj) - ( sv_i(ji,jj,jl) - zsal ) * zzc   ! associated salt flux 
     98            END_2D 
    10199         END DO 
    102100      ENDIF 
    … …  
    107105      !                             !----------------------------------------------------- 
    108106      IF( kn == 2 ) THEN            !  Ice drift case: Corrections to avoid wrong values ! 
    109          DO jj = 2, jpjm1           !----------------------------------------------------- 
    110             DO ji = 2, jpim1 
    111                IF ( at_i(ji,jj) == 0._wp ) THEN    ! what to do if there is no ice 
    112                   IF ( at_i(ji+1,jj) == 0._wp )   u_ice(ji  ,jj) = 0._wp   ! right side 
    113                   IF ( at_i(ji-1,jj) == 0._wp )   u_ice(ji-1,jj) = 0._wp   ! left side 
    114                   IF ( at_i(ji,jj+1) == 0._wp )   v_ice(ji,jj  ) = 0._wp   ! upper side 
    115                   IF ( at_i(ji,jj-1) == 0._wp )   v_ice(ji,jj-1) = 0._wp   ! bottom side 
    116                ENDIF 
    117             END DO 
    118          END DO 
     107         DO_2D_00_00 
     108            IF ( at_i(ji,jj) == 0._wp ) THEN    ! what to do if there is no ice 
     109               IF ( at_i(ji+1,jj) == 0._wp )   u_ice(ji  ,jj) = 0._wp   ! right side 
     110               IF ( at_i(ji-1,jj) == 0._wp )   u_ice(ji-1,jj) = 0._wp   ! left side 
     111               IF ( at_i(ji,jj+1) == 0._wp )   v_ice(ji,jj  ) = 0._wp   ! upper side 
     112               IF ( at_i(ji,jj-1) == 0._wp )   v_ice(ji,jj-1) = 0._wp   ! bottom side 
     113            ENDIF 
     114         END_2D 
    119115         CALL lbc_lnk_multi( 'icecor', u_ice, 'U', -1., v_ice, 'V', -1. ) 
    120116      ENDIF 

  • NEMO/branches/2020/temporary_r4_trunk/src/ICE/icectl.F90

    r13466 r13469  
    366366      cl_alname(ialert_id) = ' Very high salinity ' ! name of the alert 
    367367      DO jl = 1, jpl 
    368          DO jj = 1, jpj 
    369             DO ji = 1, jpi 
    370                IF( v_i(ji,jj,jl) > epsi10  ) THEN 
    371                   IF( sv_i(ji,jj,jl) / v_i(ji,jj,jl) > rn_simax ) THEN 
    372                      WRITE(numout,*) ' ALERTE :   Very high salinity ',sv_i(ji,jj,jl)/v_i(ji,jj,jl) 
    373                      WRITE(numout,*) ' at i,j,l = ',ji,jj,jl 
    374                      inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
    375                   ENDIF 
     368         DO_2D_11_11 
     369            IF( v_i(ji,jj,jl) > epsi10  ) THEN 
     370               IF( sv_i(ji,jj,jl) / v_i(ji,jj,jl) > rn_simax ) THEN 
     371                  WRITE(numout,*) ' ALERTE :   Very high salinity ',sv_i(ji,jj,jl)/v_i(ji,jj,jl) 
     372                  WRITE(numout,*) ' at i,j,l = ',ji,jj,jl 
     373                  inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
    376374               ENDIF 
    377             END DO 
    378          END DO 
     375            ENDIF 
     376         END_2D 
    379377      END DO 
    380378 
    … …  
    383381      cl_alname(ialert_id) = ' Very low salinity ' ! name of the alert 
    384382      DO jl = 1, jpl 
    385          DO jj = 1, jpj 
    386             DO ji = 1, jpi 
    387                IF( v_i(ji,jj,jl) > epsi10  ) THEN 
    388                   IF( sv_i(ji,jj,jl) / v_i(ji,jj,jl) < rn_simin ) THEN 
    389                      WRITE(numout,*) ' ALERTE :   Very low salinity ',sv_i(ji,jj,jl),v_i(ji,jj,jl) 
    390                      WRITE(numout,*) ' at i,j,l = ',ji,jj,jl 
    391                      inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
    392                   ENDIF 
     383         DO_2D_11_11 
     384            IF( v_i(ji,jj,jl) > epsi10  ) THEN 
     385               IF( sv_i(ji,jj,jl) / v_i(ji,jj,jl) < rn_simin ) THEN 
     386                  WRITE(numout,*) ' ALERTE :   Very low salinity ',sv_i(ji,jj,jl),v_i(ji,jj,jl) 
     387                  WRITE(numout,*) ' at i,j,l = ',ji,jj,jl 
     388                  inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
    393389               ENDIF 
    394             END DO 
    395          END DO 
     390            ENDIF 
     391         END_2D 
    396392      END DO 
    397393 
    … …  
    400396      cl_alname(ialert_id) = ' Very cold ice ' ! name of the alert 
    401397      DO jl = 1, jpl 
    402          DO jk = 1, nlay_i 
    403             DO jj = 1, jpj 
    404                DO ji = 1, jpi 
    405                   ztmelts    =  -rTmlt * sz_i(ji,jj,jk,jl) + rt0 
    406                   IF( t_i(ji,jj,jk,jl) < -50.+rt0  .AND.  v_i(ji,jj,jl) > epsi10 ) THEN 
    407                      WRITE(numout,*) ' ALERTE :   Very cold ice ',(t_i(ji,jj,jk,jl)-rt0) 
    408                      WRITE(numout,*) ' at i,j,k,l = ',ji,jj,jk,jl 
    409                     inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
    410                   ENDIF 
    411                END DO 
    412             END DO 
    413          END DO 
     398         DO_3D_11_11( 1, nlay_i ) 
     399            ztmelts    =  -rTmlt * sz_i(ji,jj,jk,jl) + rt0 
     400            IF( t_i(ji,jj,jk,jl) < -50.+rt0  .AND.  v_i(ji,jj,jl) > epsi10 ) THEN 
     401               WRITE(numout,*) ' ALERTE :   Very cold ice ',(t_i(ji,jj,jk,jl)-rt0) 
     402               WRITE(numout,*) ' at i,j,k,l = ',ji,jj,jk,jl 
     403              inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
     404            ENDIF 
     405         END_3D 
    414406      END DO 
    415407   
    … …  
    418410      cl_alname(ialert_id) = ' Very warm ice ' ! name of the alert 
    419411      DO jl = 1, jpl 
    420          DO jk = 1, nlay_i 
    421             DO jj = 1, jpj 
    422                DO ji = 1, jpi 
    423                   ztmelts    =  -rTmlt * sz_i(ji,jj,jk,jl) + rt0 
    424                   IF( t_i(ji,jj,jk,jl) > ztmelts  .AND.  v_i(ji,jj,jl) > epsi10 ) THEN 
    425                      WRITE(numout,*) ' ALERTE :   Very warm ice',(t_i(ji,jj,jk,jl)-rt0) 
    426                      WRITE(numout,*) ' at i,j,k,l = ',ji,jj,jk,jl 
    427                     inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
    428                   ENDIF 
    429                END DO 
    430             END DO 
    431          END DO 
     412         DO_3D_11_11( 1, nlay_i ) 
     413            ztmelts    =  -rTmlt * sz_i(ji,jj,jk,jl) + rt0 
     414            IF( t_i(ji,jj,jk,jl) > ztmelts  .AND.  v_i(ji,jj,jl) > epsi10 ) THEN 
     415               WRITE(numout,*) ' ALERTE :   Very warm ice',(t_i(ji,jj,jk,jl)-rt0) 
     416               WRITE(numout,*) ' at i,j,k,l = ',ji,jj,jk,jl 
     417              inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
     418            ENDIF 
     419         END_3D 
    432420      END DO 
    433421       
    … …  
    436424      cl_alname(ialert_id) = ' Very thick ice ' ! name of the alert 
    437425      jl = jpl  
    438       DO jj = 1, jpj 
    439          DO ji = 1, jpi 
    440             IF( h_i(ji,jj,jl) > 50._wp ) THEN 
    441                WRITE(numout,*) ' ALERTE :   Very thick ice ',h_i(ji,jj,jl) 
    442                WRITE(numout,*) ' at i,j,l = ',ji,jj,jl 
    443                inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
    444             ENDIF 
    445          END DO 
    446       END DO 
     426      DO_2D_11_11 
     427         IF( h_i(ji,jj,jl) > 50._wp ) THEN 
     428            WRITE(numout,*) ' ALERTE :   Very thick ice ',h_i(ji,jj,jl) 
     429            WRITE(numout,*) ' at i,j,l = ',ji,jj,jl 
     430            inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
     431         ENDIF 
     432      END_2D 
    447433 
    448434      ! Alerte if very thin ice 
    … …  
    450436      cl_alname(ialert_id) = ' Very thin ice ' ! name of the alert 
    451437      jl = 1  
    452       DO jj = 1, jpj 
    453          DO ji = 1, jpi 
    454             IF( h_i(ji,jj,jl) < rn_himin ) THEN 
    455                WRITE(numout,*) ' ALERTE :   Very thin ice ',h_i(ji,jj,jl) 
    456                WRITE(numout,*) ' at i,j,l = ',ji,jj,jl 
    457                inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
    458             ENDIF 
    459          END DO 
    460       END DO 
     438      DO_2D_11_11 
     439         IF( h_i(ji,jj,jl) < rn_himin ) THEN 
     440            WRITE(numout,*) ' ALERTE :   Very thin ice ',h_i(ji,jj,jl) 
     441            WRITE(numout,*) ' at i,j,l = ',ji,jj,jl 
     442            inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
     443         ENDIF 
     444      END_2D 
    461445 
    462446      ! Alert if very fast ice 
    463447      ialert_id = ialert_id + 1 ! reference number of this alert 
    464448      cl_alname(ialert_id) = ' Very fast ice ' ! name of the alert 
    465       DO jj = 1, jpj 
    466          DO ji = 1, jpi 
    467             IF( MAX( ABS( u_ice(ji,jj) ), ABS( v_ice(ji,jj) ) ) > 2. ) THEN 
    468                WRITE(numout,*) ' ALERTE :   Very fast ice ',MAX( ABS( u_ice(ji,jj) ), ABS( v_ice(ji,jj) ) ) 
    469                WRITE(numout,*) ' at i,j = ',ji,jj 
    470                inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
    471             ENDIF 
    472          END DO 
    473       END DO 
     449      DO_2D_11_11 
     450         IF( MAX( ABS( u_ice(ji,jj) ), ABS( v_ice(ji,jj) ) ) > 2. ) THEN 
     451            WRITE(numout,*) ' ALERTE :   Very fast ice ',MAX( ABS( u_ice(ji,jj) ), ABS( v_ice(ji,jj) ) ) 
     452            WRITE(numout,*) ' at i,j = ',ji,jj 
     453            inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
     454         ENDIF 
     455      END_2D 
    474456 
    475457      ! Alert if there is ice on continents 
    476458      ialert_id = ialert_id + 1 ! reference number of this alert 
    477459      cl_alname(ialert_id) = ' Ice on continents ' ! name of the alert 
    478       DO jj = 1, jpj 
    479          DO ji = 1, jpi 
    480             IF( tmask(ji,jj,1) == 0._wp .AND. ( at_i(ji,jj) > 0._wp .OR. vt_i(ji,jj) > 0._wp ) ) THEN  
    481                WRITE(numout,*) ' ALERTE :   Ice on continents ',at_i(ji,jj),vt_i(ji,jj) 
    482                WRITE(numout,*) ' at i,j = ',ji,jj 
    483                inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
    484             ENDIF 
    485          END DO 
    486       END DO 
     460      DO_2D_11_11 
     461         IF( tmask(ji,jj,1) == 0._wp .AND. ( at_i(ji,jj) > 0._wp .OR. vt_i(ji,jj) > 0._wp ) ) THEN  
     462            WRITE(numout,*) ' ALERTE :   Ice on continents ',at_i(ji,jj),vt_i(ji,jj) 
     463            WRITE(numout,*) ' at i,j = ',ji,jj 
     464            inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
     465         ENDIF 
     466      END_2D 
    487467 
    488468      ! Alert if incompatible ice concentration and volume 
    489469      ialert_id = ialert_id + 1 ! reference number of this alert 
    490470      cl_alname(ialert_id) = ' Incompatible ice conc and vol ' ! name of the alert 
    491       DO jj = 1, jpj 
    492          DO ji = 1, jpi 
    493             IF(  ( vt_i(ji,jj) == 0._wp .AND. at_i(ji,jj) >  0._wp ) .OR. & 
    494                & ( vt_i(ji,jj) >  0._wp .AND. at_i(ji,jj) == 0._wp ) ) THEN  
    495                WRITE(numout,*) ' ALERTE :   Incompatible ice conc and vol ',at_i(ji,jj),vt_i(ji,jj) 
    496                WRITE(numout,*) ' at i,j = ',ji,jj 
    497                inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
    498             ENDIF 
    499          END DO 
    500       END DO 
     471      DO_2D_11_11 
     472         IF(  ( vt_i(ji,jj) == 0._wp .AND. at_i(ji,jj) >  0._wp ) .OR. & 
     473            & ( vt_i(ji,jj) >  0._wp .AND. at_i(ji,jj) == 0._wp ) ) THEN  
     474            WRITE(numout,*) ' ALERTE :   Incompatible ice conc and vol ',at_i(ji,jj),vt_i(ji,jj) 
     475            WRITE(numout,*) ' at i,j = ',ji,jj 
     476            inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
     477         ENDIF 
     478      END_2D 
    501479 
    502480      ! sum of the alerts on all processors 

  • NEMO/branches/2020/temporary_r4_trunk/src/ICE/icedyn.F90

    r13466 r13469  
    127127         ! CFL = 0.5 at a distance from the bound of 1/6 of the basin length 
    128128         ! Then for dx = 2m and dt = 1s => rn_uice = u (1/6th) = 1m/s  
    129          DO jj = 1, jpj 
    130             DO ji = 1, jpi 
    131                zcoefu = ( REAL(jpiglo+1)*0.5 - REAL(ji+nimpp-1) ) / ( REAL(jpiglo+1)*0.5 - 1. ) 
    132                zcoefv = ( REAL(jpjglo+1)*0.5 - REAL(jj+njmpp-1) ) / ( REAL(jpjglo+1)*0.5 - 1. ) 
    133                u_ice(ji,jj) = rn_uice * 1.5 * SIGN( 1., zcoefu ) * ABS( zcoefu ) * umask(ji,jj,1) 
    134                v_ice(ji,jj) = rn_vice * 1.5 * SIGN( 1., zcoefv ) * ABS( zcoefv ) * vmask(ji,jj,1) 
    135             END DO 
    136          END DO 
     129         DO_2D_11_11 
     130            zcoefu = ( REAL(jpiglo+1)*0.5 - REAL(ji+nimpp-1) ) / ( REAL(jpiglo+1)*0.5 - 1. ) 
     131            zcoefv = ( REAL(jpjglo+1)*0.5 - REAL(jj+njmpp-1) ) / ( REAL(jpjglo+1)*0.5 - 1. ) 
     132            u_ice(ji,jj) = rn_uice * 1.5 * SIGN( 1., zcoefu ) * ABS( zcoefu ) * umask(ji,jj,1) 
     133            v_ice(ji,jj) = rn_vice * 1.5 * SIGN( 1., zcoefv ) * ABS( zcoefv ) * vmask(ji,jj,1) 
     134         END_2D 
    137135         ! --- 
    138136         CALL ice_dyn_adv   ( kt )                                          ! -- advection of ice 
    … …  
    158156 
    159157            ALLOCATE( zdivu_i(jpi,jpj) ) 
    160             DO jj = 2, jpjm1 
    161                DO ji = 2, jpim1 
    162                   zdivu_i(ji,jj) = ( e2u(ji,jj) * u_ice(ji,jj) - e2u(ji-1,jj) * u_ice(ji-1,jj)   & 
    163                      &             + e1v(ji,jj) * v_ice(ji,jj) - e1v(ji,jj-1) * v_ice(ji,jj-1) ) * r1_e1e2t(ji,jj) 
    164                END DO 
    165             END DO 
     158            DO_2D_00_00 
     159               zdivu_i(ji,jj) = ( e2u(ji,jj) * u_ice(ji,jj) - e2u(ji-1,jj) * u_ice(ji-1,jj)   & 
     160                  &             + e1v(ji,jj) * v_ice(ji,jj) - e1v(ji,jj-1) * v_ice(ji,jj-1) ) * r1_e1e2t(ji,jj) 
     161            END_2D 
    166162            CALL lbc_lnk( 'icedyn', zdivu_i, 'T', 1. ) 
    167163            ! output 

  • NEMO/branches/2020/temporary_r4_trunk/src/ICE/icedyn_adv_pra.F90

    r13466 r13469  
    110110      END WHERE 
    111111      DO jl = 1, jpl 
    112          DO jj = 2, jpjm1 
    113             DO ji = fs_2, fs_jpim1 
    114                zhip_max(ji,jj,jl) = MAX( epsi20, ph_ip(ji,jj,jl), ph_ip(ji+1,jj  ,jl), ph_ip(ji  ,jj+1,jl), & 
    115                   &                                               ph_ip(ji-1,jj  ,jl), ph_ip(ji  ,jj-1,jl), & 
    116                   &                                               ph_ip(ji+1,jj+1,jl), ph_ip(ji-1,jj-1,jl), & 
    117                   &                                               ph_ip(ji+1,jj-1,jl), ph_ip(ji-1,jj+1,jl) ) 
    118                zhi_max (ji,jj,jl) = MAX( epsi20, ph_i (ji,jj,jl), ph_i (ji+1,jj  ,jl), ph_i (ji  ,jj+1,jl), & 
    119                   &                                               ph_i (ji-1,jj  ,jl), ph_i (ji  ,jj-1,jl), & 
    120                   &                                               ph_i (ji+1,jj+1,jl), ph_i (ji-1,jj-1,jl), & 
    121                   &                                               ph_i (ji+1,jj-1,jl), ph_i (ji-1,jj+1,jl) ) 
    122                zhs_max (ji,jj,jl) = MAX( epsi20, ph_s (ji,jj,jl), ph_s (ji+1,jj  ,jl), ph_s (ji  ,jj+1,jl), & 
    123                   &                                               ph_s (ji-1,jj  ,jl), ph_s (ji  ,jj-1,jl), & 
    124                   &                                               ph_s (ji+1,jj+1,jl), ph_s (ji-1,jj-1,jl), & 
    125                   &                                               ph_s (ji+1,jj-1,jl), ph_s (ji-1,jj+1,jl) ) 
    126                zsi_max (ji,jj,jl) = MAX( epsi20, zs_i (ji,jj,jl), zs_i (ji+1,jj  ,jl), zs_i (ji  ,jj+1,jl), & 
    127                   &                                               zs_i (ji-1,jj  ,jl), zs_i (ji  ,jj-1,jl), & 
    128                   &                                               zs_i (ji+1,jj+1,jl), zs_i (ji-1,jj-1,jl), & 
    129                   &                                               zs_i (ji+1,jj-1,jl), zs_i (ji-1,jj+1,jl) ) 
    130             END DO 
    131          END DO 
     112         DO_2D_00_00 
     113            zhip_max(ji,jj,jl) = MAX( epsi20, ph_ip(ji,jj,jl), ph_ip(ji+1,jj  ,jl), ph_ip(ji  ,jj+1,jl), & 
     114               &                                               ph_ip(ji-1,jj  ,jl), ph_ip(ji  ,jj-1,jl), & 
     115               &                                               ph_ip(ji+1,jj+1,jl), ph_ip(ji-1,jj-1,jl), & 
     116               &                                               ph_ip(ji+1,jj-1,jl), ph_ip(ji-1,jj+1,jl) ) 
     117            zhi_max (ji,jj,jl) = MAX( epsi20, ph_i (ji,jj,jl), ph_i (ji+1,jj  ,jl), ph_i (ji  ,jj+1,jl), & 
     118               &                                               ph_i (ji-1,jj  ,jl), ph_i (ji  ,jj-1,jl), & 
     119               &                                               ph_i (ji+1,jj+1,jl), ph_i (ji-1,jj-1,jl), & 
     120               &                                               ph_i (ji+1,jj-1,jl), ph_i (ji-1,jj+1,jl) ) 
     121            zhs_max (ji,jj,jl) = MAX( epsi20, ph_s (ji,jj,jl), ph_s (ji+1,jj  ,jl), ph_s (ji  ,jj+1,jl), & 
     122               &                                               ph_s (ji-1,jj  ,jl), ph_s (ji  ,jj-1,jl), & 
     123               &                                               ph_s (ji+1,jj+1,jl), ph_s (ji-1,jj-1,jl), & 
     124               &                                               ph_s (ji+1,jj-1,jl), ph_s (ji-1,jj+1,jl) ) 
     125            zsi_max (ji,jj,jl) = MAX( epsi20, zs_i (ji,jj,jl), zs_i (ji+1,jj  ,jl), zs_i (ji  ,jj+1,jl), & 
     126               &                                               zs_i (ji-1,jj  ,jl), zs_i (ji  ,jj-1,jl), & 
     127               &                                               zs_i (ji+1,jj+1,jl), zs_i (ji-1,jj-1,jl), & 
     128               &                                               zs_i (ji+1,jj-1,jl), zs_i (ji-1,jj+1,jl) ) 
     129         END_2D 
    132130      END DO 
    133131      CALL lbc_lnk_multi( 'icedyn_adv_pra', zhi_max, 'T', 1., zhs_max, 'T', 1., zhip_max, 'T', 1., zsi_max, 'T', 1. ) 
    … …  
    145143      END DO 
    146144      DO jl = 1, jpl 
    147          DO jk = 1, nlay_i 
    148             DO jj = 2, jpjm1 
    149                DO ji = fs_2, fs_jpim1 
    150                   zei_max(ji,jj,jk,jl) = MAX( epsi20, ze_i(ji,jj,jk,jl), ze_i(ji+1,jj  ,jk,jl), ze_i(ji  ,jj+1,jk,jl), & 
    151                      &                                                   ze_i(ji-1,jj  ,jk,jl), ze_i(ji  ,jj-1,jk,jl), & 
    152                      &                                                   ze_i(ji+1,jj+1,jk,jl), ze_i(ji-1,jj-1,jk,jl), & 
    153                      &                                                   ze_i(ji+1,jj-1,jk,jl), ze_i(ji-1,jj+1,jk,jl) ) 
    154                END DO 
    155             END DO 
    156          END DO 
     145         DO_3D_00_00( 1, nlay_i ) 
     146            zei_max(ji,jj,jk,jl) = MAX( epsi20, ze_i(ji,jj,jk,jl), ze_i(ji+1,jj  ,jk,jl), ze_i(ji  ,jj+1,jk,jl), & 
     147               &                                                   ze_i(ji-1,jj  ,jk,jl), ze_i(ji  ,jj-1,jk,jl), & 
     148               &                                                   ze_i(ji+1,jj+1,jk,jl), ze_i(ji-1,jj-1,jk,jl), & 
     149               &                                                   ze_i(ji+1,jj-1,jk,jl), ze_i(ji-1,jj+1,jk,jl) ) 
     150         END_3D 
    157151      END DO 
    158152      DO jl = 1, jpl 
    159          DO jk = 1, nlay_s 
    160             DO jj = 2, jpjm1 
    161                DO ji = fs_2, fs_jpim1 
    162                   zes_max(ji,jj,jk,jl) = MAX( epsi20, ze_s(ji,jj,jk,jl), ze_s(ji+1,jj  ,jk,jl), ze_s(ji  ,jj+1,jk,jl), & 
    163                      &                                                   ze_s(ji-1,jj  ,jk,jl), ze_s(ji  ,jj-1,jk,jl), & 
    164                      &                                                   ze_s(ji+1,jj+1,jk,jl), ze_s(ji-1,jj-1,jk,jl), & 
    165                      &                                                   ze_s(ji+1,jj-1,jk,jl), ze_s(ji-1,jj+1,jk,jl) ) 
    166                END DO 
    167             END DO 
    168          END DO 
     153         DO_3D_00_00( 1, nlay_s ) 
     154            zes_max(ji,jj,jk,jl) = MAX( epsi20, ze_s(ji,jj,jk,jl), ze_s(ji+1,jj  ,jk,jl), ze_s(ji  ,jj+1,jk,jl), & 
     155               &                                                   ze_s(ji-1,jj  ,jk,jl), ze_s(ji  ,jj-1,jk,jl), & 
     156               &                                                   ze_s(ji+1,jj+1,jk,jl), ze_s(ji-1,jj-1,jk,jl), & 
     157               &                                                   ze_s(ji+1,jj-1,jk,jl), ze_s(ji-1,jj+1,jk,jl) ) 
     158         END_3D 
    169159      END DO 
    170160      CALL lbc_lnk( 'icedyn_adv_pra', zei_max, 'T', 1. ) 
    … …  
    317307         ! derive open water from ice concentration 
    318308         zati2(:,:) = SUM( pa_i(:,:,:), dim=3 ) 
    319          DO jj = 2, jpjm1 
    320             DO ji = fs_2, fs_jpim1 
    321                pato_i(ji,jj) = pato_i(ji,jj) - ( zati2(ji,jj) - zati1(ji,jj) ) &                        !--- open water 
    322                   &                          - ( zudy(ji,jj) - zudy(ji-1,jj) + zvdx(ji,jj) - zvdx(ji,jj-1) ) * r1_e1e2t(ji,jj) * zdt 
    323             END DO 
    324          END DO 
     309         DO_2D_00_00 
     310            pato_i(ji,jj) = pato_i(ji,jj) - ( zati2(ji,jj) - zati1(ji,jj) ) &                        !--- open water 
     311               &                          - ( zudy(ji,jj) - zudy(ji-1,jj) + zvdx(ji,jj) - zvdx(ji,jj-1) ) * r1_e1e2t(ji,jj) * zdt 
     312         END_2D 
    325313         CALL lbc_lnk( 'icedyn_adv_pra', pato_i, 'T',  1. ) 
    326314         ! 
    … …  
    375363         ! 
    376364         ! Limitation of moments.                                            
    377          DO jj = 2, jpjm1 
    378             DO ji = 1, jpi 
    379                !  Initialize volumes of boxes  (=area if adv_x first called, =psm otherwise)                                      
    380                psm (ji,jj,jl) = MAX( pcrh * e1e2t(ji,jj) + ( 1.0 - pcrh ) * psm(ji,jj,jl) , epsi20 ) 
    381                ! 
    382                zslpmax = MAX( 0._wp, ps0(ji,jj,jl) ) 
    383                zs1max  = 1.5 * zslpmax 
    384                zs1new  = MIN( zs1max, MAX( -zs1max, psx(ji,jj,jl) ) ) 
    385                zs2new  = MIN(  2.0 * zslpmax - 0.3334 * ABS( zs1new ),      & 
    386                   &            MAX( ABS( zs1new ) - zslpmax, psxx(ji,jj,jl) )  ) 
    387                rswitch = ( 1.0 - MAX( 0._wp, SIGN( 1._wp, -zslpmax) ) ) * tmask(ji,jj,1)   ! Case of empty boxes & Apply mask 
    388  
    389                ps0 (ji,jj,jl) = zslpmax   
    390                psx (ji,jj,jl) = zs1new         * rswitch 
    391                psxx(ji,jj,jl) = zs2new         * rswitch 
    392                psy (ji,jj,jl) = psy (ji,jj,jl) * rswitch 
    393                psyy(ji,jj,jl) = psyy(ji,jj,jl) * rswitch 
    394                psxy(ji,jj,jl) = MIN( zslpmax, MAX( -zslpmax, psxy(ji,jj,jl) ) ) * rswitch 
    395             END DO 
    396          END DO 
     365         DO_2D_00_11 
     366            !  Initialize volumes of boxes  (=area if adv_x first called, =psm otherwise)                                      
     367            psm (ji,jj,jl) = MAX( pcrh * e1e2t(ji,jj) + ( 1.0 - pcrh ) * psm(ji,jj,jl) , epsi20 ) 
     368            ! 
     369            zslpmax = MAX( 0._wp, ps0(ji,jj,jl) ) 
     370            zs1max  = 1.5 * zslpmax 
     371            zs1new  = MIN( zs1max, MAX( -zs1max, psx(ji,jj,jl) ) ) 
     372            zs2new  = MIN(  2.0 * zslpmax - 0.3334 * ABS( zs1new ),      & 
     373               &            MAX( ABS( zs1new ) - zslpmax, psxx(ji,jj,jl) )  ) 
     374            rswitch = ( 1.0 - MAX( 0._wp, SIGN( 1._wp, -zslpmax) ) ) * tmask(ji,jj,1)   ! Case of empty boxes & Apply mask 
     375 
     376            ps0 (ji,jj,jl) = zslpmax   
     377            psx (ji,jj,jl) = zs1new         * rswitch 
     378            psxx(ji,jj,jl) = zs2new         * rswitch 
     379            psy (ji,jj,jl) = psy (ji,jj,jl) * rswitch 
     380            psyy(ji,jj,jl) = psyy(ji,jj,jl) * rswitch 
     381            psxy(ji,jj,jl) = MIN( zslpmax, MAX( -zslpmax, psxy(ji,jj,jl) ) ) * rswitch 
     382         END_2D 
    397383 
    398384         !  Calculate fluxes and moments between boxes i<-->i+1               
    399          DO jj = 2, jpjm1                      !  Flux from i to i+1 WHEN u GT 0  
    400             DO ji = 1, jpi 
    401                zbet(ji,jj)  =  MAX( 0._wp, SIGN( 1._wp, put(ji,jj) ) ) 
    402                zalf         =  MAX( 0._wp, put(ji,jj) ) * pdt / psm(ji,jj,jl) 
    403                zalfq        =  zalf * zalf 
    404                zalf1        =  1.0 - zalf 
    405                zalf1q       =  zalf1 * zalf1 
    406                ! 
    407                zfm (ji,jj)  =  zalf  *   psm (ji,jj,jl) 
    408                zf0 (ji,jj)  =  zalf  * ( ps0 (ji,jj,jl) + zalf1 * ( psx(ji,jj,jl) + (zalf1 - zalf) * psxx(ji,jj,jl) ) ) 
    409                zfx (ji,jj)  =  zalfq * ( psx (ji,jj,jl) + 3.0 * zalf1 * psxx(ji,jj,jl) ) 
    410                zfxx(ji,jj)  =  zalf  *   psxx(ji,jj,jl) * zalfq 
    411                zfy (ji,jj)  =  zalf  * ( psy (ji,jj,jl) + zalf1 * psxy(ji,jj,jl) ) 
    412                zfxy(ji,jj)  =  zalfq *   psxy(ji,jj,jl) 
    413                zfyy(ji,jj)  =  zalf  *   psyy(ji,jj,jl) 
    414  
    415                !  Readjust moments remaining in the box. 
    416                psm (ji,jj,jl)  =  psm (ji,jj,jl) - zfm(ji,jj) 
    417                ps0 (ji,jj,jl)  =  ps0 (ji,jj,jl) - zf0(ji,jj) 
    418                psx (ji,jj,jl)  =  zalf1q * ( psx(ji,jj,jl) - 3.0 * zalf * psxx(ji,jj,jl) ) 
    419                psxx(ji,jj,jl)  =  zalf1  * zalf1q * psxx(ji,jj,jl) 
    420                psy (ji,jj,jl)  =  psy (ji,jj,jl) - zfy(ji,jj) 
    421                psyy(ji,jj,jl)  =  psyy(ji,jj,jl) - zfyy(ji,jj) 
    422                psxy(ji,jj,jl)  =  zalf1q * psxy(ji,jj,jl) 
    423             END DO 
    424          END DO 
    425  
    426          DO jj = 2, jpjm1                      !  Flux from i+1 to i when u LT 0. 
    427             DO ji = 1, fs_jpim1 
    428                zalf          = MAX( 0._wp, -put(ji,jj) ) * pdt / psm(ji+1,jj,jl)  
    429                zalg  (ji,jj) = zalf 
    430                zalfq         = zalf * zalf 
    431                zalf1         = 1.0 - zalf 
    432                zalg1 (ji,jj) = zalf1 
    433                zalf1q        = zalf1 * zalf1 
    434                zalg1q(ji,jj) = zalf1q 
    435                ! 
    436                zfm   (ji,jj) = zfm (ji,jj) + zalf  *    psm (ji+1,jj,jl) 
    437                zf0   (ji,jj) = zf0 (ji,jj) + zalf  * (  ps0 (ji+1,jj,jl) & 
    438                   &                                   - zalf1 * ( psx(ji+1,jj,jl) - (zalf1 - zalf ) * psxx(ji+1,jj,jl) ) ) 
    439                zfx   (ji,jj) = zfx (ji,jj) + zalfq * (  psx (ji+1,jj,jl) - 3.0 * zalf1 * psxx(ji+1,jj,jl) ) 
    440                zfxx  (ji,jj) = zfxx(ji,jj) + zalf  *    psxx(ji+1,jj,jl) * zalfq 
    441                zfy   (ji,jj) = zfy (ji,jj) + zalf  * (  psy (ji+1,jj,jl) - zalf1 * psxy(ji+1,jj,jl) ) 
    442                zfxy  (ji,jj) = zfxy(ji,jj) + zalfq *    psxy(ji+1,jj,jl) 
    443                zfyy  (ji,jj) = zfyy(ji,jj) + zalf  *    psyy(ji+1,jj,jl) 
    444             END DO 
    445          END DO 
    446  
    447          DO jj = 2, jpjm1                     !  Readjust moments remaining in the box.  
    448             DO ji = fs_2, fs_jpim1 
    449                zbt  =       zbet(ji-1,jj) 
    450                zbt1 = 1.0 - zbet(ji-1,jj) 
    451                ! 
    452                psm (ji,jj,jl) = zbt * psm(ji,jj,jl) + zbt1 * ( psm(ji,jj,jl) - zfm(ji-1,jj) ) 
    453                ps0 (ji,jj,jl) = zbt * ps0(ji,jj,jl) + zbt1 * ( ps0(ji,jj,jl) - zf0(ji-1,jj) ) 
    454                psx (ji,jj,jl) = zalg1q(ji-1,jj) * ( psx(ji,jj,jl) + 3.0 * zalg(ji-1,jj) * psxx(ji,jj,jl) ) 
    455                psxx(ji,jj,jl) = zalg1 (ji-1,jj) * zalg1q(ji-1,jj) * psxx(ji,jj,jl) 
    456                psy (ji,jj,jl) = zbt * psy (ji,jj,jl) + zbt1 * ( psy (ji,jj,jl) - zfy (ji-1,jj) ) 
    457                psyy(ji,jj,jl) = zbt * psyy(ji,jj,jl) + zbt1 * ( psyy(ji,jj,jl) - zfyy(ji-1,jj) ) 
    458                psxy(ji,jj,jl) = zalg1q(ji-1,jj) * psxy(ji,jj,jl) 
    459             END DO 
    460          END DO 
     385         DO_2D_00_11 
     386            zbet(ji,jj)  =  MAX( 0._wp, SIGN( 1._wp, put(ji,jj) ) ) 
     387            zalf         =  MAX( 0._wp, put(ji,jj) ) * pdt / psm(ji,jj,jl) 
     388            zalfq        =  zalf * zalf 
     389            zalf1        =  1.0 - zalf 
     390            zalf1q       =  zalf1 * zalf1 
     391            ! 
     392            zfm (ji,jj)  =  zalf  *   psm (ji,jj,jl) 
     393            zf0 (ji,jj)  =  zalf  * ( ps0 (ji,jj,jl) + zalf1 * ( psx(ji,jj,jl) + (zalf1 - zalf) * psxx(ji,jj,jl) ) ) 
     394            zfx (ji,jj)  =  zalfq * ( psx (ji,jj,jl) + 3.0 * zalf1 * psxx(ji,jj,jl) ) 
     395            zfxx(ji,jj)  =  zalf  *   psxx(ji,jj,jl) * zalfq 
     396            zfy (ji,jj)  =  zalf  * ( psy (ji,jj,jl) + zalf1 * psxy(ji,jj,jl) ) 
     397            zfxy(ji,jj)  =  zalfq *   psxy(ji,jj,jl) 
     398            zfyy(ji,jj)  =  zalf  *   psyy(ji,jj,jl) 
     399 
     400            !  Readjust moments remaining in the box. 
     401            psm (ji,jj,jl)  =  psm (ji,jj,jl) - zfm(ji,jj) 
     402            ps0 (ji,jj,jl)  =  ps0 (ji,jj,jl) - zf0(ji,jj) 
     403            psx (ji,jj,jl)  =  zalf1q * ( psx(ji,jj,jl) - 3.0 * zalf * psxx(ji,jj,jl) ) 
     404            psxx(ji,jj,jl)  =  zalf1  * zalf1q * psxx(ji,jj,jl) 
     405            psy (ji,jj,jl)  =  psy (ji,jj,jl) - zfy(ji,jj) 
     406            psyy(ji,jj,jl)  =  psyy(ji,jj,jl) - zfyy(ji,jj) 
     407            psxy(ji,jj,jl)  =  zalf1q * psxy(ji,jj,jl) 
     408         END_2D 
     409 
     410         DO_2D_00_10 
     411            zalf          = MAX( 0._wp, -put(ji,jj) ) * pdt / psm(ji+1,jj,jl)  
     412            zalg  (ji,jj) = zalf 
     413            zalfq         = zalf * zalf 
     414            zalf1         = 1.0 - zalf 
     415            zalg1 (ji,jj) = zalf1 
     416            zalf1q        = zalf1 * zalf1 
     417            zalg1q(ji,jj) = zalf1q 
     418            ! 
     419            zfm   (ji,jj) = zfm (ji,jj) + zalf  *    psm (ji+1,jj,jl) 
     420            zf0   (ji,jj) = zf0 (ji,jj) + zalf  * (  ps0 (ji+1,jj,jl) & 
     421               &                                   - zalf1 * ( psx(ji+1,jj,jl) - (zalf1 - zalf ) * psxx(ji+1,jj,jl) ) ) 
     422            zfx   (ji,jj) = zfx (ji,jj) + zalfq * (  psx (ji+1,jj,jl) - 3.0 * zalf1 * psxx(ji+1,jj,jl) ) 
     423            zfxx  (ji,jj) = zfxx(ji,jj) + zalf  *    psxx(ji+1,jj,jl) * zalfq 
     424            zfy   (ji,jj) = zfy (ji,jj) + zalf  * (  psy (ji+1,jj,jl) - zalf1 * psxy(ji+1,jj,jl) ) 
     425            zfxy  (ji,jj) = zfxy(ji,jj) + zalfq *    psxy(ji+1,jj,jl) 
     426            zfyy  (ji,jj) = zfyy(ji,jj) + zalf  *    psyy(ji+1,jj,jl) 
     427         END_2D 
     428 
     429         DO_2D_00_00 
     430            zbt  =       zbet(ji-1,jj) 
     431            zbt1 = 1.0 - zbet(ji-1,jj) 
     432            ! 
     433            psm (ji,jj,jl) = zbt * psm(ji,jj,jl) + zbt1 * ( psm(ji,jj,jl) - zfm(ji-1,jj) ) 
     434            ps0 (ji,jj,jl) = zbt * ps0(ji,jj,jl) + zbt1 * ( ps0(ji,jj,jl) - zf0(ji-1,jj) ) 
     435            psx (ji,jj,jl) = zalg1q(ji-1,jj) * ( psx(ji,jj,jl) + 3.0 * zalg(ji-1,jj) * psxx(ji,jj,jl) ) 
     436            psxx(ji,jj,jl) = zalg1 (ji-1,jj) * zalg1q(ji-1,jj) * psxx(ji,jj,jl) 
     437            psy (ji,jj,jl) = zbt * psy (ji,jj,jl) + zbt1 * ( psy (ji,jj,jl) - zfy (ji-1,jj) ) 
     438            psyy(ji,jj,jl) = zbt * psyy(ji,jj,jl) + zbt1 * ( psyy(ji,jj,jl) - zfyy(ji-1,jj) ) 
     439            psxy(ji,jj,jl) = zalg1q(ji-1,jj) * psxy(ji,jj,jl) 
     440         END_2D 
    461441 
    462442         !   Put the temporary moments into appropriate neighboring boxes.     
    463          DO jj = 2, jpjm1                     !   Flux from i to i+1 IF u GT 0. 
    464             DO ji = fs_2, fs_jpim1 
    465                zbt  =       zbet(ji-1,jj) 
    466                zbt1 = 1.0 - zbet(ji-1,jj) 
    467                psm(ji,jj,jl) = zbt * ( psm(ji,jj,jl) + zfm(ji-1,jj) ) + zbt1 * psm(ji,jj,jl) 
    468                zalf          = zbt * zfm(ji-1,jj) / psm(ji,jj,jl) 
    469                zalf1         = 1.0 - zalf 
    470                ztemp         = zalf * ps0(ji,jj,jl) - zalf1 * zf0(ji-1,jj) 
    471                ! 
    472                ps0 (ji,jj,jl) =  zbt  * ( ps0(ji,jj,jl) + zf0(ji-1,jj) ) + zbt1 * ps0(ji,jj,jl) 
    473                psx (ji,jj,jl) =  zbt  * ( zalf * zfx(ji-1,jj) + zalf1 * psx(ji,jj,jl) + 3.0 * ztemp ) + zbt1 * psx(ji,jj,jl) 
    474                psxx(ji,jj,jl) =  zbt  * ( zalf * zalf * zfxx(ji-1,jj) + zalf1 * zalf1 * psxx(ji,jj,jl)                             & 
    475                   &                     + 5.0 * ( zalf * zalf1 * ( psx (ji,jj,jl) - zfx(ji-1,jj) ) - ( zalf1 - zalf ) * ztemp )  ) & 
    476                   &            + zbt1 * psxx(ji,jj,jl) 
    477                psxy(ji,jj,jl) =  zbt  * ( zalf * zfxy(ji-1,jj) + zalf1 * psxy(ji,jj,jl)             & 
    478                   &                     + 3.0 * (- zalf1*zfy(ji-1,jj)  + zalf * psy(ji,jj,jl) ) )   & 
    479                   &            + zbt1 * psxy(ji,jj,jl) 
    480                psy (ji,jj,jl) =  zbt  * ( psy (ji,jj,jl) + zfy (ji-1,jj) ) + zbt1 * psy (ji,jj,jl) 
    481                psyy(ji,jj,jl) =  zbt  * ( psyy(ji,jj,jl) + zfyy(ji-1,jj) ) + zbt1 * psyy(ji,jj,jl) 
    482             END DO 
    483          END DO 
    484  
    485          DO jj = 2, jpjm1                      !  Flux from i+1 to i IF u LT 0. 
    486             DO ji = fs_2, fs_jpim1 
    487                zbt  =       zbet(ji,jj) 
    488                zbt1 = 1.0 - zbet(ji,jj) 
    489                psm(ji,jj,jl) = zbt * psm(ji,jj,jl) + zbt1 * ( psm(ji,jj,jl) + zfm(ji,jj) ) 
    490                zalf          = zbt1 * zfm(ji,jj) / psm(ji,jj,jl) 
    491                zalf1         = 1.0 - zalf 
    492                ztemp         = - zalf * ps0(ji,jj,jl) + zalf1 * zf0(ji,jj) 
    493                ! 
    494                ps0 (ji,jj,jl) = zbt * ps0 (ji,jj,jl) + zbt1 * ( ps0(ji,jj,jl) + zf0(ji,jj) ) 
    495                psx (ji,jj,jl) = zbt * psx (ji,jj,jl) + zbt1 * ( zalf * zfx(ji,jj) + zalf1 * psx(ji,jj,jl) + 3.0 * ztemp ) 
    496                psxx(ji,jj,jl) = zbt * psxx(ji,jj,jl) + zbt1 * ( zalf * zalf * zfxx(ji,jj) + zalf1 * zalf1 * psxx(ji,jj,jl) & 
    497                   &                                           + 5.0 * ( zalf * zalf1 * ( - psx(ji,jj,jl) + zfx(ji,jj) )    & 
    498                   &                                           + ( zalf1 - zalf ) * ztemp ) ) 
    499                psxy(ji,jj,jl) = zbt * psxy(ji,jj,jl) + zbt1 * ( zalf * zfxy(ji,jj) + zalf1 * psxy(ji,jj,jl)  & 
    500                   &                                           + 3.0 * ( zalf1 * zfy(ji,jj) - zalf * psy(ji,jj,jl) ) ) 
    501                psy (ji,jj,jl) = zbt * psy (ji,jj,jl) + zbt1 * ( psy (ji,jj,jl) + zfy (ji,jj) ) 
    502                psyy(ji,jj,jl) = zbt * psyy(ji,jj,jl) + zbt1 * ( psyy(ji,jj,jl) + zfyy(ji,jj) ) 
    503             END DO 
    504          END DO 
     443         DO_2D_00_00 
     444            zbt  =       zbet(ji-1,jj) 
     445            zbt1 = 1.0 - zbet(ji-1,jj) 
     446            psm(ji,jj,jl) = zbt * ( psm(ji,jj,jl) + zfm(ji-1,jj) ) + zbt1 * psm(ji,jj,jl) 
     447            zalf          = zbt * zfm(ji-1,jj) / psm(ji,jj,jl) 
     448            zalf1         = 1.0 - zalf 
     449            ztemp         = zalf * ps0(ji,jj,jl) - zalf1 * zf0(ji-1,jj) 
     450            ! 
     451            ps0 (ji,jj,jl) =  zbt  * ( ps0(ji,jj,jl) + zf0(ji-1,jj) ) + zbt1 * ps0(ji,jj,jl) 
     452            psx (ji,jj,jl) =  zbt  * ( zalf * zfx(ji-1,jj) + zalf1 * psx(ji,jj,jl) + 3.0 * ztemp ) + zbt1 * psx(ji,jj,jl) 
     453            psxx(ji,jj,jl) =  zbt  * ( zalf * zalf * zfxx(ji-1,jj) + zalf1 * zalf1 * psxx(ji,jj,jl)                             & 
     454               &                     + 5.0 * ( zalf * zalf1 * ( psx (ji,jj,jl) - zfx(ji-1,jj) ) - ( zalf1 - zalf ) * ztemp )  ) & 
     455               &            + zbt1 * psxx(ji,jj,jl) 
     456            psxy(ji,jj,jl) =  zbt  * ( zalf * zfxy(ji-1,jj) + zalf1 * psxy(ji,jj,jl)             & 
     457               &                     + 3.0 * (- zalf1*zfy(ji-1,jj)  + zalf * psy(ji,jj,jl) ) )   & 
     458               &            + zbt1 * psxy(ji,jj,jl) 
     459            psy (ji,jj,jl) =  zbt  * ( psy (ji,jj,jl) + zfy (ji-1,jj) ) + zbt1 * psy (ji,jj,jl) 
     460            psyy(ji,jj,jl) =  zbt  * ( psyy(ji,jj,jl) + zfyy(ji-1,jj) ) + zbt1 * psyy(ji,jj,jl) 
     461         END_2D 
     462 
     463         DO_2D_00_00 
     464            zbt  =       zbet(ji,jj) 
     465            zbt1 = 1.0 - zbet(ji,jj) 
     466            psm(ji,jj,jl) = zbt * psm(ji,jj,jl) + zbt1 * ( psm(ji,jj,jl) + zfm(ji,jj) ) 
     467            zalf          = zbt1 * zfm(ji,jj) / psm(ji,jj,jl) 
     468            zalf1         = 1.0 - zalf 
     469            ztemp         = - zalf * ps0(ji,jj,jl) + zalf1 * zf0(ji,jj) 
     470            ! 
     471            ps0 (ji,jj,jl) = zbt * ps0 (ji,jj,jl) + zbt1 * ( ps0(ji,jj,jl) + zf0(ji,jj) ) 
     472            psx (ji,jj,jl) = zbt * psx (ji,jj,jl) + zbt1 * ( zalf * zfx(ji,jj) + zalf1 * psx(ji,jj,jl) + 3.0 * ztemp ) 
     473            psxx(ji,jj,jl) = zbt * psxx(ji,jj,jl) + zbt1 * ( zalf * zalf * zfxx(ji,jj) + zalf1 * zalf1 * psxx(ji,jj,jl) & 
     474               &                                           + 5.0 * ( zalf * zalf1 * ( - psx(ji,jj,jl) + zfx(ji,jj) )    & 
     475               &                                           + ( zalf1 - zalf ) * ztemp ) ) 
     476            psxy(ji,jj,jl) = zbt * psxy(ji,jj,jl) + zbt1 * ( zalf * zfxy(ji,jj) + zalf1 * psxy(ji,jj,jl)  & 
     477               &                                           + 3.0 * ( zalf1 * zfy(ji,jj) - zalf * psy(ji,jj,jl) ) ) 
     478            psy (ji,jj,jl) = zbt * psy (ji,jj,jl) + zbt1 * ( psy (ji,jj,jl) + zfy (ji,jj) ) 
     479            psyy(ji,jj,jl) = zbt * psyy(ji,jj,jl) + zbt1 * ( psyy(ji,jj,jl) + zfyy(ji,jj) ) 
     480         END_2D 
    505481 
    506482      END DO 
    … …  
    544520         ! 
    545521         ! Limitation of moments. 
    546          DO jj = 1, jpj 
    547             DO ji = fs_2, fs_jpim1 
    548                !  Initialize volumes of boxes (=area if adv_x first called, =psm otherwise) 
    549                psm(ji,jj,jl) = MAX(  pcrh * e1e2t(ji,jj) + ( 1.0 - pcrh ) * psm(ji,jj,jl) , epsi20  ) 
    550                ! 
    551                zslpmax = MAX( 0._wp, ps0(ji,jj,jl) ) 
    552                zs1max  = 1.5 * zslpmax 
    553                zs1new  = MIN( zs1max, MAX( -zs1max, psy(ji,jj,jl) ) ) 
    554                zs2new  = MIN(  ( 2.0 * zslpmax - 0.3334 * ABS( zs1new ) ),   & 
    555                   &             MAX( ABS( zs1new )-zslpmax, psyy(ji,jj,jl) )  ) 
    556                rswitch = ( 1.0 - MAX( 0._wp, SIGN( 1._wp, -zslpmax) ) ) * tmask(ji,jj,1)   ! Case of empty boxes & Apply mask 
    557                ! 
    558                ps0 (ji,jj,jl) = zslpmax   
    559                psx (ji,jj,jl) = psx (ji,jj,jl) * rswitch 
    560                psxx(ji,jj,jl) = psxx(ji,jj,jl) * rswitch 
    561                psy (ji,jj,jl) = zs1new         * rswitch 
    562                psyy(ji,jj,jl) = zs2new         * rswitch 
    563                psxy(ji,jj,jl) = MIN( zslpmax, MAX( -zslpmax, psxy(ji,jj,jl) ) ) * rswitch 
    564             END DO 
    565          END DO 
     522         DO_2D_11_00 
     523            !  Initialize volumes of boxes (=area if adv_x first called, =psm otherwise) 
     524            psm(ji,jj,jl) = MAX(  pcrh * e1e2t(ji,jj) + ( 1.0 - pcrh ) * psm(ji,jj,jl) , epsi20  ) 
     525            ! 
     526            zslpmax = MAX( 0._wp, ps0(ji,jj,jl) ) 
     527            zs1max  = 1.5 * zslpmax 
     528            zs1new  = MIN( zs1max, MAX( -zs1max, psy(ji,jj,jl) ) ) 
     529            zs2new  = MIN(  ( 2.0 * zslpmax - 0.3334 * ABS( zs1new ) ),   & 
     530               &             MAX( ABS( zs1new )-zslpmax, psyy(ji,jj,jl) )  ) 
     531            rswitch = ( 1.0 - MAX( 0._wp, SIGN( 1._wp, -zslpmax) ) ) * tmask(ji,jj,1)   ! Case of empty boxes & Apply mask 
     532            ! 
     533            ps0 (ji,jj,jl) = zslpmax   
     534            psx (ji,jj,jl) = psx (ji,jj,jl) * rswitch 
     535            psxx(ji,jj,jl) = psxx(ji,jj,jl) * rswitch 
     536            psy (ji,jj,jl) = zs1new         * rswitch 
     537            psyy(ji,jj,jl) = zs2new         * rswitch 
     538            psxy(ji,jj,jl) = MIN( zslpmax, MAX( -zslpmax, psxy(ji,jj,jl) ) ) * rswitch 
     539         END_2D 
    566540  
    567541         !  Calculate fluxes and moments between boxes j<-->j+1               
    568          DO jj = 1, jpj                     !  Flux from j to j+1 WHEN v GT 0    
    569             DO ji = fs_2, fs_jpim1 
    570                zbet(ji,jj)  =  MAX( 0._wp, SIGN( 1._wp, pvt(ji,jj) ) ) 
    571                zalf         =  MAX( 0._wp, pvt(ji,jj) ) * pdt / psm(ji,jj,jl) 
    572                zalfq        =  zalf * zalf 
    573                zalf1        =  1.0 - zalf 
    574                zalf1q       =  zalf1 * zalf1 
    575                ! 
    576                zfm (ji,jj)  =  zalf  * psm(ji,jj,jl) 
    577                zf0 (ji,jj)  =  zalf  * ( ps0(ji,jj,jl) + zalf1 * ( psy(ji,jj,jl)  + (zalf1-zalf) * psyy(ji,jj,jl) ) )  
    578                zfy (ji,jj)  =  zalfq *( psy(ji,jj,jl) + 3.0*zalf1*psyy(ji,jj,jl) ) 
    579                zfyy(ji,jj)  =  zalf  * zalfq * psyy(ji,jj,jl) 
    580                zfx (ji,jj)  =  zalf  * ( psx(ji,jj,jl) + zalf1 * psxy(ji,jj,jl) ) 
    581                zfxy(ji,jj)  =  zalfq * psxy(ji,jj,jl) 
    582                zfxx(ji,jj)  =  zalf  * psxx(ji,jj,jl) 
    583                ! 
    584                !  Readjust moments remaining in the box. 
    585                psm (ji,jj,jl)  =  psm (ji,jj,jl) - zfm(ji,jj) 
    586                ps0 (ji,jj,jl)  =  ps0 (ji,jj,jl) - zf0(ji,jj) 
    587                psy (ji,jj,jl)  =  zalf1q * ( psy(ji,jj,jl) -3.0 * zalf * psyy(ji,jj,jl) ) 
    588                psyy(ji,jj,jl)  =  zalf1 * zalf1q * psyy(ji,jj,jl) 
    589                psx (ji,jj,jl)  =  psx (ji,jj,jl) - zfx(ji,jj) 
    590                psxx(ji,jj,jl)  =  psxx(ji,jj,jl) - zfxx(ji,jj) 
    591                psxy(ji,jj,jl)  =  zalf1q * psxy(ji,jj,jl) 
    592             END DO 
    593          END DO 
    594          ! 
    595          DO jj = 1, jpjm1                   !  Flux from j+1 to j when v LT 0. 
    596             DO ji = fs_2, fs_jpim1 
    597                zalf          = MAX( 0._wp, -pvt(ji,jj) ) * pdt / psm(ji,jj+1,jl)  
    598                zalg  (ji,jj) = zalf 
    599                zalfq         = zalf * zalf 
    600                zalf1         = 1.0 - zalf 
    601                zalg1 (ji,jj) = zalf1 
    602                zalf1q        = zalf1 * zalf1 
    603                zalg1q(ji,jj) = zalf1q 
    604                ! 
    605                zfm   (ji,jj) = zfm (ji,jj) + zalf  *    psm (ji,jj+1,jl) 
    606                zf0   (ji,jj) = zf0 (ji,jj) + zalf  * (  ps0 (ji,jj+1,jl) & 
    607                   &                                   - zalf1 * (psy(ji,jj+1,jl) - (zalf1 - zalf ) * psyy(ji,jj+1,jl) ) ) 
    608                zfy   (ji,jj) = zfy (ji,jj) + zalfq * (  psy (ji,jj+1,jl) - 3.0 * zalf1 * psyy(ji,jj+1,jl) ) 
    609                zfyy  (ji,jj) = zfyy(ji,jj) + zalf  *    psyy(ji,jj+1,jl) * zalfq 
    610                zfx   (ji,jj) = zfx (ji,jj) + zalf  * (  psx (ji,jj+1,jl) - zalf1 * psxy(ji,jj+1,jl) ) 
    611                zfxy  (ji,jj) = zfxy(ji,jj) + zalfq *    psxy(ji,jj+1,jl) 
    612                zfxx  (ji,jj) = zfxx(ji,jj) + zalf  *    psxx(ji,jj+1,jl) 
    613             END DO 
    614          END DO 
     542         DO_2D_11_00 
     543            zbet(ji,jj)  =  MAX( 0._wp, SIGN( 1._wp, pvt(ji,jj) ) ) 
     544            zalf         =  MAX( 0._wp, pvt(ji,jj) ) * pdt / psm(ji,jj,jl) 
     545            zalfq        =  zalf * zalf 
     546            zalf1        =  1.0 - zalf 
     547            zalf1q       =  zalf1 * zalf1 
     548            ! 
     549            zfm (ji,jj)  =  zalf  * psm(ji,jj,jl) 
     550            zf0 (ji,jj)  =  zalf  * ( ps0(ji,jj,jl) + zalf1 * ( psy(ji,jj,jl)  + (zalf1-zalf) * psyy(ji,jj,jl) ) )  
     551            zfy (ji,jj)  =  zalfq *( psy(ji,jj,jl) + 3.0*zalf1*psyy(ji,jj,jl) ) 
     552            zfyy(ji,jj)  =  zalf  * zalfq * psyy(ji,jj,jl) 
     553            zfx (ji,jj)  =  zalf  * ( psx(ji,jj,jl) + zalf1 * psxy(ji,jj,jl) ) 
     554            zfxy(ji,jj)  =  zalfq * psxy(ji,jj,jl) 
     555            zfxx(ji,jj)  =  zalf  * psxx(ji,jj,jl) 
     556            ! 
     557            !  Readjust moments remaining in the box. 
     558            psm (ji,jj,jl)  =  psm (ji,jj,jl) - zfm(ji,jj) 
     559            ps0 (ji,jj,jl)  =  ps0 (ji,jj,jl) - zf0(ji,jj) 
     560            psy (ji,jj,jl)  =  zalf1q * ( psy(ji,jj,jl) -3.0 * zalf * psyy(ji,jj,jl) ) 
     561            psyy(ji,jj,jl)  =  zalf1 * zalf1q * psyy(ji,jj,jl) 
     562            psx (ji,jj,jl)  =  psx (ji,jj,jl) - zfx(ji,jj) 
     563            psxx(ji,jj,jl)  =  psxx(ji,jj,jl) - zfxx(ji,jj) 
     564            psxy(ji,jj,jl)  =  zalf1q * psxy(ji,jj,jl) 
     565         END_2D 
     566         ! 
     567         DO_2D_10_00 
     568            zalf          = MAX( 0._wp, -pvt(ji,jj) ) * pdt / psm(ji,jj+1,jl)  
     569            zalg  (ji,jj) = zalf 
     570            zalfq         = zalf * zalf 
     571            zalf1         = 1.0 - zalf 
     572            zalg1 (ji,jj) = zalf1 
     573            zalf1q        = zalf1 * zalf1 
     574            zalg1q(ji,jj) = zalf1q 
     575            ! 
     576            zfm   (ji,jj) = zfm (ji,jj) + zalf  *    psm (ji,jj+1,jl) 
     577            zf0   (ji,jj) = zf0 (ji,jj) + zalf  * (  ps0 (ji,jj+1,jl) & 
     578               &                                   - zalf1 * (psy(ji,jj+1,jl) - (zalf1 - zalf ) * psyy(ji,jj+1,jl) ) ) 
     579            zfy   (ji,jj) = zfy (ji,jj) + zalfq * (  psy (ji,jj+1,jl) - 3.0 * zalf1 * psyy(ji,jj+1,jl) ) 
     580            zfyy  (ji,jj) = zfyy(ji,jj) + zalf  *    psyy(ji,jj+1,jl) * zalfq 
     581            zfx   (ji,jj) = zfx (ji,jj) + zalf  * (  psx (ji,jj+1,jl) - zalf1 * psxy(ji,jj+1,jl) ) 
     582            zfxy  (ji,jj) = zfxy(ji,jj) + zalfq *    psxy(ji,jj+1,jl) 
     583            zfxx  (ji,jj) = zfxx(ji,jj) + zalf  *    psxx(ji,jj+1,jl) 
     584         END_2D 
    615585 
    616586         !  Readjust moments remaining in the box.  
    617          DO jj = 2, jpjm1 
    618             DO ji = fs_2, fs_jpim1 
    619                zbt  =         zbet(ji,jj-1) 
    620                zbt1 = ( 1.0 - zbet(ji,jj-1) ) 
    621                ! 
    622                psm (ji,jj,jl) = zbt * psm(ji,jj,jl) + zbt1 * ( psm(ji,jj,jl) - zfm(ji,jj-1) ) 
    623                ps0 (ji,jj,jl) = zbt * ps0(ji,jj,jl) + zbt1 * ( ps0(ji,jj,jl) - zf0(ji,jj-1) ) 
    624                psy (ji,jj,jl) = zalg1q(ji,jj-1) * ( psy(ji,jj,jl) + 3.0 * zalg(ji,jj-1) * psyy(ji,jj,jl) ) 
    625                psyy(ji,jj,jl) = zalg1 (ji,jj-1) * zalg1q(ji,jj-1) * psyy(ji,jj,jl) 
    626                psx (ji,jj,jl) = zbt * psx (ji,jj,jl) + zbt1 * ( psx (ji,jj,jl) - zfx (ji,jj-1) ) 
    627                psxx(ji,jj,jl) = zbt * psxx(ji,jj,jl) + zbt1 * ( psxx(ji,jj,jl) - zfxx(ji,jj-1) ) 
    628                psxy(ji,jj,jl) = zalg1q(ji,jj-1) * psxy(ji,jj,jl) 
    629             END DO 
    630          END DO 
     587         DO_2D_00_00 
     588            zbt  =         zbet(ji,jj-1) 
     589            zbt1 = ( 1.0 - zbet(ji,jj-1) ) 
     590            ! 
     591            psm (ji,jj,jl) = zbt * psm(ji,jj,jl) + zbt1 * ( psm(ji,jj,jl) - zfm(ji,jj-1) ) 
     592            ps0 (ji,jj,jl) = zbt * ps0(ji,jj,jl) + zbt1 * ( ps0(ji,jj,jl) - zf0(ji,jj-1) ) 
     593            psy (ji,jj,jl) = zalg1q(ji,jj-1) * ( psy(ji,jj,jl) + 3.0 * zalg(ji,jj-1) * psyy(ji,jj,jl) ) 
     594            psyy(ji,jj,jl) = zalg1 (ji,jj-1) * zalg1q(ji,jj-1) * psyy(ji,jj,jl) 
     595            psx (ji,jj,jl) = zbt * psx (ji,jj,jl) + zbt1 * ( psx (ji,jj,jl) - zfx (ji,jj-1) ) 
     596            psxx(ji,jj,jl) = zbt * psxx(ji,jj,jl) + zbt1 * ( psxx(ji,jj,jl) - zfxx(ji,jj-1) ) 
     597            psxy(ji,jj,jl) = zalg1q(ji,jj-1) * psxy(ji,jj,jl) 
     598         END_2D 
    631599 
    632600         !   Put the temporary moments into appropriate neighboring boxes.     
    633          DO jj = 2, jpjm1                    !   Flux from j to j+1 IF v GT 0. 
    634             DO ji = fs_2, fs_jpim1 
    635                zbt  =       zbet(ji,jj-1) 
    636                zbt1 = 1.0 - zbet(ji,jj-1) 
    637                psm(ji,jj,jl) = zbt * ( psm(ji,jj,jl) + zfm(ji,jj-1) ) + zbt1 * psm(ji,jj,jl)  
    638                zalf          = zbt * zfm(ji,jj-1) / psm(ji,jj,jl)  
    639                zalf1         = 1.0 - zalf 
    640                ztemp         = zalf * ps0(ji,jj,jl) - zalf1 * zf0(ji,jj-1) 
    641                ! 
    642                ps0(ji,jj,jl)  =   zbt  * ( ps0(ji,jj,jl) + zf0(ji,jj-1) ) + zbt1 * ps0(ji,jj,jl) 
    643                psy(ji,jj,jl)  =   zbt  * ( zalf * zfy(ji,jj-1) + zalf1 * psy(ji,jj,jl) + 3.0 * ztemp )  & 
    644                   &             + zbt1 * psy(ji,jj,jl)   
    645                psyy(ji,jj,jl) =   zbt  * ( zalf * zalf * zfyy(ji,jj-1) + zalf1 * zalf1 * psyy(ji,jj,jl)                           & 
    646                   &                      + 5.0 * ( zalf * zalf1 * ( psy(ji,jj,jl) - zfy(ji,jj-1) ) - ( zalf1 - zalf ) * ztemp ) ) &  
    647                   &             + zbt1 * psyy(ji,jj,jl) 
    648                psxy(ji,jj,jl) =   zbt  * (  zalf * zfxy(ji,jj-1) + zalf1 * psxy(ji,jj,jl)            & 
    649                   &                      + 3.0 * (- zalf1 * zfx(ji,jj-1) + zalf * psx(ji,jj,jl) ) )  & 
    650                   &             + zbt1 * psxy(ji,jj,jl) 
    651                psx (ji,jj,jl) =   zbt * ( psx (ji,jj,jl) + zfx (ji,jj-1) ) + zbt1 * psx (ji,jj,jl) 
    652                psxx(ji,jj,jl) =   zbt * ( psxx(ji,jj,jl) + zfxx(ji,jj-1) ) + zbt1 * psxx(ji,jj,jl) 
    653             END DO 
    654          END DO 
    655  
    656          DO jj = 2, jpjm1                      !  Flux from j+1 to j IF v LT 0. 
    657             DO ji = fs_2, fs_jpim1 
    658                zbt  =       zbet(ji,jj) 
    659                zbt1 = 1.0 - zbet(ji,jj) 
    660                psm(ji,jj,jl) = zbt * psm(ji,jj,jl) + zbt1 * ( psm(ji,jj,jl) + zfm(ji,jj) ) 
    661                zalf          = zbt1 * zfm(ji,jj) / psm(ji,jj,jl) 
    662                zalf1         = 1.0 - zalf 
    663                ztemp         = - zalf * ps0(ji,jj,jl) + zalf1 * zf0(ji,jj) 
    664                ! 
    665                ps0 (ji,jj,jl) = zbt * ps0 (ji,jj,jl) + zbt1 * (  ps0(ji,jj,jl) + zf0(ji,jj) ) 
    666                psy (ji,jj,jl) = zbt * psy (ji,jj,jl) + zbt1 * (  zalf * zfy(ji,jj) + zalf1 * psy(ji,jj,jl) + 3.0 * ztemp ) 
    667                psyy(ji,jj,jl) = zbt * psyy(ji,jj,jl) + zbt1 * (  zalf * zalf * zfyy(ji,jj) + zalf1 * zalf1 * psyy(ji,jj,jl) & 
    668                   &                                            + 5.0 * ( zalf * zalf1 * ( - psy(ji,jj,jl) + zfy(ji,jj) )    & 
    669                   &                                            + ( zalf1 - zalf ) * ztemp ) ) 
    670                psxy(ji,jj,jl) = zbt * psxy(ji,jj,jl) + zbt1 * (  zalf * zfxy(ji,jj) + zalf1 * psxy(ji,jj,jl)  & 
    671                   &                                            + 3.0 * ( zalf1 * zfx(ji,jj) - zalf * psx(ji,jj,jl) ) ) 
    672                psx (ji,jj,jl) = zbt * psx (ji,jj,jl) + zbt1 * ( psx (ji,jj,jl) + zfx (ji,jj) ) 
    673                psxx(ji,jj,jl) = zbt * psxx(ji,jj,jl) + zbt1 * ( psxx(ji,jj,jl) + zfxx(ji,jj) ) 
    674             END DO 
    675          END DO 
     601         DO_2D_00_00 
     602            zbt  =       zbet(ji,jj-1) 
     603            zbt1 = 1.0 - zbet(ji,jj-1) 
     604            psm(ji,jj,jl) = zbt * ( psm(ji,jj,jl) + zfm(ji,jj-1) ) + zbt1 * psm(ji,jj,jl)  
     605            zalf          = zbt * zfm(ji,jj-1) / psm(ji,jj,jl)  
     606            zalf1         = 1.0 - zalf 
     607            ztemp         = zalf * ps0(ji,jj,jl) - zalf1 * zf0(ji,jj-1) 
     608            ! 
     609            ps0(ji,jj,jl)  =   zbt  * ( ps0(ji,jj,jl) + zf0(ji,jj-1) ) + zbt1 * ps0(ji,jj,jl) 
     610            psy(ji,jj,jl)  =   zbt  * ( zalf * zfy(ji,jj-1) + zalf1 * psy(ji,jj,jl) + 3.0 * ztemp )  & 
     611               &             + zbt1 * psy(ji,jj,jl)   
     612            psyy(ji,jj,jl) =   zbt  * ( zalf * zalf * zfyy(ji,jj-1) + zalf1 * zalf1 * psyy(ji,jj,jl)                           & 
     613               &                      + 5.0 * ( zalf * zalf1 * ( psy(ji,jj,jl) - zfy(ji,jj-1) ) - ( zalf1 - zalf ) * ztemp ) ) &  
     614               &             + zbt1 * psyy(ji,jj,jl) 
     615            psxy(ji,jj,jl) =   zbt  * (  zalf * zfxy(ji,jj-1) + zalf1 * psxy(ji,jj,jl)            & 
     616               &                      + 3.0 * (- zalf1 * zfx(ji,jj-1) + zalf * psx(ji,jj,jl) ) )  & 
     617               &             + zbt1 * psxy(ji,jj,jl) 
     618            psx (ji,jj,jl) =   zbt * ( psx (ji,jj,jl) + zfx (ji,jj-1) ) + zbt1 * psx (ji,jj,jl) 
     619            psxx(ji,jj,jl) =   zbt * ( psxx(ji,jj,jl) + zfxx(ji,jj-1) ) + zbt1 * psxx(ji,jj,jl) 
     620         END_2D 
     621 
     622         DO_2D_00_00 
     623            zbt  =       zbet(ji,jj) 
     624            zbt1 = 1.0 - zbet(ji,jj) 
     625            psm(ji,jj,jl) = zbt * psm(ji,jj,jl) + zbt1 * ( psm(ji,jj,jl) + zfm(ji,jj) ) 
     626            zalf          = zbt1 * zfm(ji,jj) / psm(ji,jj,jl) 
     627            zalf1         = 1.0 - zalf 
     628            ztemp         = - zalf * ps0(ji,jj,jl) + zalf1 * zf0(ji,jj) 
     629            ! 
     630            ps0 (ji,jj,jl) = zbt * ps0 (ji,jj,jl) + zbt1 * (  ps0(ji,jj,jl) + zf0(ji,jj) ) 
     631            psy (ji,jj,jl) = zbt * psy (ji,jj,jl) + zbt1 * (  zalf * zfy(ji,jj) + zalf1 * psy(ji,jj,jl) + 3.0 * ztemp ) 
     632            psyy(ji,jj,jl) = zbt * psyy(ji,jj,jl) + zbt1 * (  zalf * zalf * zfyy(ji,jj) + zalf1 * zalf1 * psyy(ji,jj,jl) & 
     633               &                                            + 5.0 * ( zalf * zalf1 * ( - psy(ji,jj,jl) + zfy(ji,jj) )    & 
     634               &                                            + ( zalf1 - zalf ) * ztemp ) ) 
     635            psxy(ji,jj,jl) = zbt * psxy(ji,jj,jl) + zbt1 * (  zalf * zfxy(ji,jj) + zalf1 * psxy(ji,jj,jl)  & 
     636               &                                            + 3.0 * ( zalf1 * zfx(ji,jj) - zalf * psx(ji,jj,jl) ) ) 
     637            psx (ji,jj,jl) = zbt * psx (ji,jj,jl) + zbt1 * ( psx (ji,jj,jl) + zfx (ji,jj) ) 
     638            psxx(ji,jj,jl) = zbt * psxx(ji,jj,jl) + zbt1 * ( psxx(ji,jj,jl) + zfxx(ji,jj) ) 
     639         END_2D 
    676640 
    677641      END DO 
    … …  
    715679      ! 
    716680      DO jl = 1, jpl 
    717          DO jj = 1, jpj 
    718             DO ji = 1, jpi 
    719                IF ( pv_i(ji,jj,jl) > 0._wp ) THEN 
     681         DO_2D_11_11 
     682            IF ( pv_i(ji,jj,jl) > 0._wp ) THEN 
     683               ! 
     684               !                               ! -- check h_ip -- ! 
     685               ! if h_ip is larger than the surrounding 9 pts => reduce h_ip and increase a_ip 
     686               IF( ln_pnd_LEV .AND. pv_ip(ji,jj,jl) > 0._wp ) THEN 
     687                  zhip = pv_ip(ji,jj,jl) / MAX( epsi20, pa_ip(ji,jj,jl) ) 
     688                  IF( zhip > phip_max(ji,jj,jl) .AND. pa_ip(ji,jj,jl) < 0.15 ) THEN 
     689                     pa_ip(ji,jj,jl) = pv_ip(ji,jj,jl) / phip_max(ji,jj,jl) 
     690                  ENDIF 
     691               ENDIF 
     692               ! 
     693               !                               ! -- check h_i -- ! 
     694               ! if h_i is larger than the surrounding 9 pts => reduce h_i and increase a_i 
     695               zhi = pv_i(ji,jj,jl) / pa_i(ji,jj,jl) 
     696               IF( zhi > phi_max(ji,jj,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 
     697                  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) 
     698               ENDIF 
     699               ! 
     700               !                               ! -- check h_s -- ! 
     701               ! if h_s is larger than the surrounding 9 pts => put the snow excess in the ocean 
     702               zhs = pv_s(ji,jj,jl) / pa_i(ji,jj,jl) 
     703               IF( pv_s(ji,jj,jl) > 0._wp .AND. zhs > phs_max(ji,jj,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 
     704                  zfra = phs_max(ji,jj,jl) / MAX( zhs, epsi20 ) 
    720705                  ! 
    721                   !                               ! -- check h_ip -- ! 
    722                   ! if h_ip is larger than the surrounding 9 pts => reduce h_ip and increase a_ip 
    723                   IF( ln_pnd_LEV .AND. pv_ip(ji,jj,jl) > 0._wp ) THEN 
    724                      zhip = pv_ip(ji,jj,jl) / MAX( epsi20, pa_ip(ji,jj,jl) ) 
    725                      IF( zhip > phip_max(ji,jj,jl) .AND. pa_ip(ji,jj,jl) < 0.15 ) THEN 
    726                         pa_ip(ji,jj,jl) = pv_ip(ji,jj,jl) / phip_max(ji,jj,jl) 
    727                      ENDIF 
    728                   ENDIF 
     706                  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 
     707                  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 
    729708                  ! 
    730                   !                               ! -- check h_i -- ! 
    731                   ! if h_i is larger than the surrounding 9 pts => reduce h_i and increase a_i 
    732                   zhi = pv_i(ji,jj,jl) / pa_i(ji,jj,jl) 
    733                   IF( zhi > phi_max(ji,jj,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 
    734                      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) 
    735                   ENDIF 
    736                   ! 
    737                   !                               ! -- check h_s -- ! 
    738                   ! if h_s is larger than the surrounding 9 pts => put the snow excess in the ocean 
    739                   zhs = pv_s(ji,jj,jl) / pa_i(ji,jj,jl) 
    740                   IF( pv_s(ji,jj,jl) > 0._wp .AND. zhs > phs_max(ji,jj,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 
    741                      zfra = phs_max(ji,jj,jl) / MAX( zhs, epsi20 ) 
    742                      ! 
    743                      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 
    744                      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 
    745                      ! 
    746                      pe_s(ji,jj,1:nlay_s,jl) = pe_s(ji,jj,1:nlay_s,jl) * zfra 
    747                      pv_s(ji,jj,jl)          = pa_i(ji,jj,jl) * phs_max(ji,jj,jl) 
    748                   ENDIF            
    749                   !                   
    750                   !                               ! -- check s_i -- ! 
    751                   ! if s_i is larger than the surrounding 9 pts => put salt excess in the ocean 
    752                   zsi = psv_i(ji,jj,jl) / pv_i(ji,jj,jl) 
    753                   IF( zsi > psi_max(ji,jj,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 
    754                      zfra = psi_max(ji,jj,jl) / zsi 
    755                      sfx_res(ji,jj) = sfx_res(ji,jj) + psv_i(ji,jj,jl) * ( 1._wp - zfra ) * rhoi * z1_dt 
    756                      psv_i(ji,jj,jl) = psv_i(ji,jj,jl) * zfra 
    757                   ENDIF 
    758                   ! 
    759                ENDIF 
    760             END DO 
    761          END DO 
     709                  pe_s(ji,jj,1:nlay_s,jl) = pe_s(ji,jj,1:nlay_s,jl) * zfra 
     710                  pv_s(ji,jj,jl)          = pa_i(ji,jj,jl) * phs_max(ji,jj,jl) 
     711               ENDIF            
     712               !                   
     713               !                               ! -- check s_i -- ! 
     714               ! if s_i is larger than the surrounding 9 pts => put salt excess in the ocean 
     715               zsi = psv_i(ji,jj,jl) / pv_i(ji,jj,jl) 
     716               IF( zsi > psi_max(ji,jj,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 
     717                  zfra = psi_max(ji,jj,jl) / zsi 
     718                  sfx_res(ji,jj) = sfx_res(ji,jj) + psv_i(ji,jj,jl) * ( 1._wp - zfra ) * rhoi * z1_dt 
     719                  psv_i(ji,jj,jl) = psv_i(ji,jj,jl) * zfra 
     720               ENDIF 
     721               ! 
     722            ENDIF 
     723         END_2D 
    762724      END DO  
    763725      ! 
    764726      !                                           ! -- check e_i/v_i -- ! 
    765727      DO jl = 1, jpl 
    766          DO jk = 1, nlay_i 
    767             DO jj = 1, jpj 
    768                DO ji = 1, jpi 
    769                   IF ( pv_i(ji,jj,jl) > 0._wp ) THEN 
    770                      ! if e_i/v_i is larger than the surrounding 9 pts => put the heat excess in the ocean 
    771                      zei = pe_i(ji,jj,jk,jl) / pv_i(ji,jj,jl) 
    772                      IF( zei > pei_max(ji,jj,jk,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 
    773                         zfra = pei_max(ji,jj,jk,jl) / zei 
    774                         hfx_res(ji,jj) = hfx_res(ji,jj) - pe_i(ji,jj,jk,jl) * ( 1._wp - zfra ) * z1_dt ! W.m-2 <0 
    775                         pe_i(ji,jj,jk,jl) = pe_i(ji,jj,jk,jl) * zfra 
    776                      ENDIF 
    777                   ENDIF 
    778                END DO 
    779             END DO 
    780          END DO 
     728         DO_3D_11_11( 1, nlay_i ) 
     729            IF ( pv_i(ji,jj,jl) > 0._wp ) THEN 
     730               ! if e_i/v_i is larger than the surrounding 9 pts => put the heat excess in the ocean 
     731               zei = pe_i(ji,jj,jk,jl) / pv_i(ji,jj,jl) 
     732               IF( zei > pei_max(ji,jj,jk,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 
     733                  zfra = pei_max(ji,jj,jk,jl) / zei 
     734                  hfx_res(ji,jj) = hfx_res(ji,jj) - pe_i(ji,jj,jk,jl) * ( 1._wp - zfra ) * z1_dt ! W.m-2 <0 
     735                  pe_i(ji,jj,jk,jl) = pe_i(ji,jj,jk,jl) * zfra 
     736               ENDIF 
     737            ENDIF 
     738         END_3D 
    781739      END DO 
    782740      !                                           ! -- check e_s/v_s -- ! 
    783741      DO jl = 1, jpl 
    784          DO jk = 1, nlay_s 
    785             DO jj = 1, jpj 
    786                DO ji = 1, jpi 
    787                   IF ( pv_s(ji,jj,jl) > 0._wp ) THEN 
    788                      ! if e_s/v_s is larger than the surrounding 9 pts => put the heat excess in the ocean 
    789                      zes = pe_s(ji,jj,jk,jl) / pv_s(ji,jj,jl) 
    790                      IF( zes > pes_max(ji,jj,jk,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 
    791                         zfra = pes_max(ji,jj,jk,jl) / zes 
    792                         hfx_res(ji,jj) = hfx_res(ji,jj) - pe_s(ji,jj,jk,jl) * ( 1._wp - zfra ) * z1_dt ! W.m-2 <0 
    793                         pe_s(ji,jj,jk,jl) = pe_s(ji,jj,jk,jl) * zfra 
    794                      ENDIF 
    795                   ENDIF 
    796                END DO 
    797             END DO 
    798          END DO 
     742         DO_3D_11_11( 1, nlay_s ) 
     743            IF ( pv_s(ji,jj,jl) > 0._wp ) THEN 
     744               ! if e_s/v_s is larger than the surrounding 9 pts => put the heat excess in the ocean 
     745               zes = pe_s(ji,jj,jk,jl) / pv_s(ji,jj,jl) 
     746               IF( zes > pes_max(ji,jj,jk,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 
     747                  zfra = pes_max(ji,jj,jk,jl) / zes 
     748                  hfx_res(ji,jj) = hfx_res(ji,jj) - pe_s(ji,jj,jk,jl) * ( 1._wp - zfra ) * z1_dt ! W.m-2 <0 
     749                  pe_s(ji,jj,jk,jl) = pe_s(ji,jj,jk,jl) * zfra 
     750               ENDIF 
     751            ENDIF 
     752         END_3D 
    799753      END DO 
    800754      ! 
    … …  
    829783      ! -- check snow load -- ! 
    830784      DO jl = 1, jpl 
    831          DO jj = 1, jpj 
    832             DO ji = 1, jpi 
    833                IF ( pv_i(ji,jj,jl) > 0._wp ) THEN 
    834                   ! 
    835                   zvs_excess = MAX( 0._wp, pv_s(ji,jj,jl) - pv_i(ji,jj,jl) * (rau0-rhoi) * r1_rhos ) 
    836                   ! 
    837                   IF( zvs_excess > 0._wp ) THEN   ! snow-ice interface deplets below the ocean surface 
    838                      ! put snow excess in the ocean 
    839                      zfra = ( pv_s(ji,jj,jl) - zvs_excess ) / MAX( pv_s(ji,jj,jl), epsi20 ) 
    840                      wfx_res(ji,jj) = wfx_res(ji,jj) + zvs_excess * rhos * z1_dt 
    841                      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 
    842                      ! correct snow volume and heat content 
    843                      pe_s(ji,jj,1:nlay_s,jl) = pe_s(ji,jj,1:nlay_s,jl) * zfra 
    844                      pv_s(ji,jj,jl)          = pv_s(ji,jj,jl) - zvs_excess 
    845                   ENDIF 
    846                   ! 
    847                ENDIF 
    848             END DO 
    849          END DO 
     785         DO_2D_11_11 
     786            IF ( pv_i(ji,jj,jl) > 0._wp ) THEN 
     787               ! 
     788               zvs_excess = MAX( 0._wp, pv_s(ji,jj,jl) - pv_i(ji,jj,jl) * (rau0-rhoi) * r1_rhos ) 
     789               ! 
     790               IF( zvs_excess > 0._wp ) THEN   ! snow-ice interface deplets below the ocean surface 
     791                  ! put snow excess in the ocean 
     792                  zfra = ( pv_s(ji,jj,jl) - zvs_excess ) / MAX( pv_s(ji,jj,jl), epsi20 ) 
     793                  wfx_res(ji,jj) = wfx_res(ji,jj) + zvs_excess * rhos * z1_dt 
     794                  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 
     795                  ! correct snow volume and heat content 
     796                  pe_s(ji,jj,1:nlay_s,jl) = pe_s(ji,jj,1:nlay_s,jl) * zfra 
     797                  pv_s(ji,jj,jl)          = pv_s(ji,jj,jl) - zvs_excess 
     798               ENDIF 
     799               ! 
     800            ENDIF 
     801         END_2D 
    850802      END DO 
    851803      ! 

  • NEMO/branches/2020/temporary_r4_trunk/src/ICE/icedyn_adv_umx.F90

    r13466 r13469  
    114114      END WHERE 
    115115      DO jl = 1, jpl 
    116          DO jj = 2, jpjm1 
    117             DO ji = fs_2, fs_jpim1 
    118                zhip_max(ji,jj,jl) = MAX( epsi20, ph_ip(ji,jj,jl), ph_ip(ji+1,jj  ,jl), ph_ip(ji  ,jj+1,jl), & 
    119                   &                                               ph_ip(ji-1,jj  ,jl), ph_ip(ji  ,jj-1,jl), & 
    120                   &                                               ph_ip(ji+1,jj+1,jl), ph_ip(ji-1,jj-1,jl), & 
    121                   &                                               ph_ip(ji+1,jj-1,jl), ph_ip(ji-1,jj+1,jl) ) 
    122                zhi_max (ji,jj,jl) = MAX( epsi20, ph_i (ji,jj,jl), ph_i (ji+1,jj  ,jl), ph_i (ji  ,jj+1,jl), & 
    123                   &                                               ph_i (ji-1,jj  ,jl), ph_i (ji  ,jj-1,jl), & 
    124                   &                                               ph_i (ji+1,jj+1,jl), ph_i (ji-1,jj-1,jl), & 
    125                   &                                               ph_i (ji+1,jj-1,jl), ph_i (ji-1,jj+1,jl) ) 
    126                zhs_max (ji,jj,jl) = MAX( epsi20, ph_s (ji,jj,jl), ph_s (ji+1,jj  ,jl), ph_s (ji  ,jj+1,jl), & 
    127                   &                                               ph_s (ji-1,jj  ,jl), ph_s (ji  ,jj-1,jl), & 
    128                   &                                               ph_s (ji+1,jj+1,jl), ph_s (ji-1,jj-1,jl), & 
    129                   &                                               ph_s (ji+1,jj-1,jl), ph_s (ji-1,jj+1,jl) ) 
    130                zsi_max (ji,jj,jl) = MAX( epsi20, zs_i (ji,jj,jl), zs_i (ji+1,jj  ,jl), zs_i (ji  ,jj+1,jl), & 
    131                   &                                               zs_i (ji-1,jj  ,jl), zs_i (ji  ,jj-1,jl), & 
    132                   &                                               zs_i (ji+1,jj+1,jl), zs_i (ji-1,jj-1,jl), & 
    133                   &                                               zs_i (ji+1,jj-1,jl), zs_i (ji-1,jj+1,jl) ) 
    134             END DO 
    135          END DO 
     116         DO_2D_00_00 
     117            zhip_max(ji,jj,jl) = MAX( epsi20, ph_ip(ji,jj,jl), ph_ip(ji+1,jj  ,jl), ph_ip(ji  ,jj+1,jl), & 
     118               &                                               ph_ip(ji-1,jj  ,jl), ph_ip(ji  ,jj-1,jl), & 
     119               &                                               ph_ip(ji+1,jj+1,jl), ph_ip(ji-1,jj-1,jl), & 
     120               &                                               ph_ip(ji+1,jj-1,jl), ph_ip(ji-1,jj+1,jl) ) 
     121            zhi_max (ji,jj,jl) = MAX( epsi20, ph_i (ji,jj,jl), ph_i (ji+1,jj  ,jl), ph_i (ji  ,jj+1,jl), & 
     122               &                                               ph_i (ji-1,jj  ,jl), ph_i (ji  ,jj-1,jl), & 
     123               &                                               ph_i (ji+1,jj+1,jl), ph_i (ji-1,jj-1,jl), & 
     124               &                                               ph_i (ji+1,jj-1,jl), ph_i (ji-1,jj+1,jl) ) 
     125            zhs_max (ji,jj,jl) = MAX( epsi20, ph_s (ji,jj,jl), ph_s (ji+1,jj  ,jl), ph_s (ji  ,jj+1,jl), & 
     126               &                                               ph_s (ji-1,jj  ,jl), ph_s (ji  ,jj-1,jl), & 
     127               &                                               ph_s (ji+1,jj+1,jl), ph_s (ji-1,jj-1,jl), & 
     128               &                                               ph_s (ji+1,jj-1,jl), ph_s (ji-1,jj+1,jl) ) 
     129            zsi_max (ji,jj,jl) = MAX( epsi20, zs_i (ji,jj,jl), zs_i (ji+1,jj  ,jl), zs_i (ji  ,jj+1,jl), & 
     130               &                                               zs_i (ji-1,jj  ,jl), zs_i (ji  ,jj-1,jl), & 
     131               &                                               zs_i (ji+1,jj+1,jl), zs_i (ji-1,jj-1,jl), & 
     132               &                                               zs_i (ji+1,jj-1,jl), zs_i (ji-1,jj+1,jl) ) 
     133         END_2D 
    136134      END DO 
    137135      CALL lbc_lnk_multi( 'icedyn_adv_umx', zhi_max, 'T', 1., zhs_max, 'T', 1., zhip_max, 'T', 1., zsi_max, 'T', 1. ) 
    … …  
    149147      END DO 
    150148      DO jl = 1, jpl 
    151          DO jk = 1, nlay_i 
    152             DO jj = 2, jpjm1 
    153                DO ji = fs_2, fs_jpim1 
    154                   zei_max(ji,jj,jk,jl) = MAX( epsi20, ze_i(ji,jj,jk,jl), ze_i(ji+1,jj  ,jk,jl), ze_i(ji  ,jj+1,jk,jl), & 
    155                      &                                                   ze_i(ji-1,jj  ,jk,jl), ze_i(ji  ,jj-1,jk,jl), & 
    156                      &                                                   ze_i(ji+1,jj+1,jk,jl), ze_i(ji-1,jj-1,jk,jl), & 
    157                      &                                                   ze_i(ji+1,jj-1,jk,jl), ze_i(ji-1,jj+1,jk,jl) ) 
    158                END DO 
    159             END DO 
    160          END DO 
    161       END DO 
    162       DO jl = 1, jpl 
    163          DO jk = 1, nlay_s 
    164             DO jj = 2, jpjm1 
    165                DO ji = fs_2, fs_jpim1 
    166                   zes_max(ji,jj,jk,jl) = MAX( epsi20, ze_s(ji,jj,jk,jl), ze_s(ji+1,jj  ,jk,jl), ze_s(ji  ,jj+1,jk,jl), & 
    167                      &                                                   ze_s(ji-1,jj  ,jk,jl), ze_s(ji  ,jj-1,jk,jl), & 
    168                      &                                                   ze_s(ji+1,jj+1,jk,jl), ze_s(ji-1,jj-1,jk,jl), & 
    169                      &                                                   ze_s(ji+1,jj-1,jk,jl), ze_s(ji-1,jj+1,jk,jl) ) 
    170                END DO 
    171             END DO 
    172          END DO 
     149         DO_3D_00_00( 1, nlay_i ) 
     150            zei_max(ji,jj,jk,jl) = MAX( epsi20, ze_i(ji,jj,jk,jl), ze_i(ji+1,jj  ,jk,jl), ze_i(ji  ,jj+1,jk,jl), & 
     151               &                                                   ze_i(ji-1,jj  ,jk,jl), ze_i(ji  ,jj-1,jk,jl), & 
     152               &                                                   ze_i(ji+1,jj+1,jk,jl), ze_i(ji-1,jj-1,jk,jl), & 
     153               &                                                   ze_i(ji+1,jj-1,jk,jl), ze_i(ji-1,jj+1,jk,jl) ) 
     154         END_3D 
     155      END DO 
     156      DO jl = 1, jpl 
     157         DO_3D_00_00( 1, nlay_s ) 
     158            zes_max(ji,jj,jk,jl) = MAX( epsi20, ze_s(ji,jj,jk,jl), ze_s(ji+1,jj  ,jk,jl), ze_s(ji  ,jj+1,jk,jl), & 
     159               &                                                   ze_s(ji-1,jj  ,jk,jl), ze_s(ji  ,jj-1,jk,jl), & 
     160               &                                                   ze_s(ji+1,jj+1,jk,jl), ze_s(ji-1,jj-1,jk,jl), & 
     161               &                                                   ze_s(ji+1,jj-1,jk,jl), ze_s(ji-1,jj+1,jk,jl) ) 
     162         END_3D 
    173163      END DO 
    174164      CALL lbc_lnk( 'icedyn_adv_pra', zei_max, 'T', 1. ) 
    … …  
    201191      ! 
    202192      ! --- define velocity for advection: u*grad(H) --- ! 
    203       DO jj = 2, jpjm1 
    204          DO ji = fs_2, fs_jpim1 
    205             IF    ( pu_ice(ji,jj) * pu_ice(ji-1,jj) <= 0._wp ) THEN   ;   zcu_box(ji,jj) = 0._wp 
    206             ELSEIF( pu_ice(ji,jj)                   >  0._wp ) THEN   ;   zcu_box(ji,jj) = pu_ice(ji-1,jj) 
    207             ELSE                                                      ;   zcu_box(ji,jj) = pu_ice(ji  ,jj) 
    208             ENDIF 
    209  
    210             IF    ( pv_ice(ji,jj) * pv_ice(ji,jj-1) <= 0._wp ) THEN   ;   zcv_box(ji,jj) = 0._wp 
    211             ELSEIF( pv_ice(ji,jj)                   >  0._wp ) THEN   ;   zcv_box(ji,jj) = pv_ice(ji,jj-1) 
    212             ELSE                                                      ;   zcv_box(ji,jj) = pv_ice(ji,jj  ) 
    213             ENDIF 
    214          END DO 
    215       END DO 
     193      DO_2D_00_00 
     194         IF    ( pu_ice(ji,jj) * pu_ice(ji-1,jj) <= 0._wp ) THEN   ;   zcu_box(ji,jj) = 0._wp 
     195         ELSEIF( pu_ice(ji,jj)                   >  0._wp ) THEN   ;   zcu_box(ji,jj) = pu_ice(ji-1,jj) 
     196         ELSE                                                      ;   zcu_box(ji,jj) = pu_ice(ji  ,jj) 
     197         ENDIF 
     198 
     199         IF    ( pv_ice(ji,jj) * pv_ice(ji,jj-1) <= 0._wp ) THEN   ;   zcv_box(ji,jj) = 0._wp 
     200         ELSEIF( pv_ice(ji,jj)                   >  0._wp ) THEN   ;   zcv_box(ji,jj) = pv_ice(ji,jj-1) 
     201         ELSE                                                      ;   zcv_box(ji,jj) = pv_ice(ji,jj  ) 
     202         ENDIF 
     203      END_2D 
    216204 
    217205      !---------------! 
    … …  
    236224            IF( .NOT. ALLOCATED(jmsk_small) )   ALLOCATE( jmsk_small(jpi,jpj,jpl) )  
    237225            DO jl = 1, jpl 
    238                DO jj = 1, jpjm1 
    239                   DO ji = 1, jpim1 
    240                      zvi_cen = 0.5_wp * ( pv_i(ji+1,jj,jl) + pv_i(ji,jj,jl) ) 
    241                      IF( zvi_cen < epsi06) THEN   ;   imsk_small(ji,jj,jl) = 0 
    242                      ELSE                         ;   imsk_small(ji,jj,jl) = 1   ;   ENDIF 
    243                      zvi_cen = 0.5_wp * ( pv_i(ji,jj+1,jl) + pv_i(ji,jj,jl) ) 
    244                      IF( zvi_cen < epsi06) THEN   ;   jmsk_small(ji,jj,jl) = 0 
    245                      ELSE                         ;   jmsk_small(ji,jj,jl) = 1   ;   ENDIF 
    246                   END DO 
    247                END DO 
     226               DO_2D_10_10 
     227                  zvi_cen = 0.5_wp * ( pv_i(ji+1,jj,jl) + pv_i(ji,jj,jl) ) 
     228                  IF( zvi_cen < epsi06) THEN   ;   imsk_small(ji,jj,jl) = 0 
     229                  ELSE                         ;   imsk_small(ji,jj,jl) = 1   ;   ENDIF 
     230                  zvi_cen = 0.5_wp * ( pv_i(ji,jj+1,jl) + pv_i(ji,jj,jl) ) 
     231                  IF( zvi_cen < epsi06) THEN   ;   jmsk_small(ji,jj,jl) = 0 
     232                  ELSE                         ;   jmsk_small(ji,jj,jl) = 1   ;   ENDIF 
     233               END_2D 
    248234            END DO 
    249235         ENDIF 
    … …  
    394380         !== Open water area ==! 
    395381         zati2(:,:) = SUM( pa_i(:,:,:), dim=3 ) 
    396          DO jj = 2, jpjm1 
    397             DO ji = fs_2, fs_jpim1 
    398                pato_i(ji,jj) = pato_i(ji,jj) - ( zati2(ji,jj) - zati1(ji,jj) ) &  
    399                   &                          - ( zudy(ji,jj) - zudy(ji-1,jj) + zvdx(ji,jj) - zvdx(ji,jj-1) ) * r1_e1e2t(ji,jj) * zdt 
    400             END DO 
    401          END DO 
     382         DO_2D_00_00 
     383            pato_i(ji,jj) = pato_i(ji,jj) - ( zati2(ji,jj) - zati1(ji,jj) ) &  
     384               &                          - ( zudy(ji,jj) - zudy(ji-1,jj) + zvdx(ji,jj) - zvdx(ji,jj-1) ) * r1_e1e2t(ji,jj) * zdt 
     385         END_2D 
    402386         CALL lbc_lnk( 'icedyn_adv_umx', pato_i, 'T',  1. ) 
    403387         ! 
    … …  
    506490      IF( pamsk == 0._wp ) THEN 
    507491         DO jl = 1, jpl 
    508             DO jj = 1, jpjm1 
    509                DO ji = 1, fs_jpim1 
    510                   IF( ABS( pu(ji,jj) ) > epsi10 ) THEN 
    511                      zfu_ho (ji,jj,jl) = zfu_ho (ji,jj,jl) * puc    (ji,jj,jl) / pu(ji,jj) 
    512                      zfu_ups(ji,jj,jl) = zfu_ups(ji,jj,jl) * pua_ups(ji,jj,jl) / pu(ji,jj) 
    513                   ELSE 
    514                      zfu_ho (ji,jj,jl) = 0._wp 
    515                      zfu_ups(ji,jj,jl) = 0._wp 
    516                   ENDIF 
    517                   ! 
    518                   IF( ABS( pv(ji,jj) ) > epsi10 ) THEN 
    519                      zfv_ho (ji,jj,jl) = zfv_ho (ji,jj,jl) * pvc    (ji,jj,jl) / pv(ji,jj) 
    520                      zfv_ups(ji,jj,jl) = zfv_ups(ji,jj,jl) * pva_ups(ji,jj,jl) / pv(ji,jj) 
    521                   ELSE 
    522                      zfv_ho (ji,jj,jl) = 0._wp   
    523                      zfv_ups(ji,jj,jl) = 0._wp   
    524                   ENDIF 
    525                END DO 
    526             END DO 
     492            DO_2D_10_10 
     493               IF( ABS( pu(ji,jj) ) > epsi10 ) THEN 
     494                  zfu_ho (ji,jj,jl) = zfu_ho (ji,jj,jl) * puc    (ji,jj,jl) / pu(ji,jj) 
     495                  zfu_ups(ji,jj,jl) = zfu_ups(ji,jj,jl) * pua_ups(ji,jj,jl) / pu(ji,jj) 
     496               ELSE 
     497                  zfu_ho (ji,jj,jl) = 0._wp 
     498                  zfu_ups(ji,jj,jl) = 0._wp 
     499               ENDIF 
     500               ! 
     501               IF( ABS( pv(ji,jj) ) > epsi10 ) THEN 
     502                  zfv_ho (ji,jj,jl) = zfv_ho (ji,jj,jl) * pvc    (ji,jj,jl) / pv(ji,jj) 
     503                  zfv_ups(ji,jj,jl) = zfv_ups(ji,jj,jl) * pva_ups(ji,jj,jl) / pv(ji,jj) 
     504               ELSE 
     505                  zfv_ho (ji,jj,jl) = 0._wp   
     506                  zfv_ups(ji,jj,jl) = 0._wp   
     507               ENDIF 
     508            END_2D 
    527509         END DO 
    528510 
    … …  
    530512         ! thus we calculate the upstream solution and apply a limiter again 
    531513         DO jl = 1, jpl 
    532             DO jj = 2, jpjm1 
    533                DO ji = fs_2, fs_jpim1 
    534                   ztra = - ( zfu_ups(ji,jj,jl) - zfu_ups(ji-1,jj,jl) + zfv_ups(ji,jj,jl) - zfv_ups(ji,jj-1,jl) ) 
    535                   ! 
    536                   zt_ups(ji,jj,jl) = ( ptc(ji,jj,jl) + ztra * r1_e1e2t(ji,jj) * pdt ) * tmask(ji,jj,1) 
    537                END DO 
    538             END DO 
     514            DO_2D_00_00 
     515               ztra = - ( zfu_ups(ji,jj,jl) - zfu_ups(ji-1,jj,jl) + zfv_ups(ji,jj,jl) - zfv_ups(ji,jj-1,jl) ) 
     516               ! 
     517               zt_ups(ji,jj,jl) = ( ptc(ji,jj,jl) + ztra * r1_e1e2t(ji,jj) * pdt ) * tmask(ji,jj,1) 
     518            END_2D 
    539519         END DO 
    540520         CALL lbc_lnk( 'icedyn_adv_umx', zt_ups, 'T',  1. ) 
    … …  
    553533      IF( PRESENT( pua_ho ) ) THEN 
    554534         DO jl = 1, jpl 
    555             DO jj = 1, jpjm1 
    556                DO ji = 1, fs_jpim1 
    557                   pua_ho (ji,jj,jl) = zfu_ho (ji,jj,jl) ; pva_ho (ji,jj,jl) = zfv_ho (ji,jj,jl) 
    558                   pua_ups(ji,jj,jl) = zfu_ups(ji,jj,jl) ; pva_ups(ji,jj,jl) = zfv_ups(ji,jj,jl) 
    559               END DO 
    560             END DO 
     535            DO_2D_10_10 
     536               pua_ho (ji,jj,jl) = zfu_ho (ji,jj,jl) ; pva_ho (ji,jj,jl) = zfv_ho (ji,jj,jl) 
     537               pua_ups(ji,jj,jl) = zfu_ups(ji,jj,jl) ; pva_ups(ji,jj,jl) = zfv_ups(ji,jj,jl) 
     538            END_2D 
    561539         END DO 
    562540      ENDIF 
    … …  
    565543      ! --------------------------------- 
    566544      DO jl = 1, jpl 
    567          DO jj = 2, jpjm1 
    568             DO ji = fs_2, fs_jpim1  
    569                ztra = - ( zfu_ho(ji,jj,jl) - zfu_ho(ji-1,jj,jl) + zfv_ho(ji,jj,jl) - zfv_ho(ji,jj-1,jl) )   
    570                ! 
    571                ptc(ji,jj,jl) = ( ptc(ji,jj,jl) + ztra * r1_e1e2t(ji,jj) * pdt ) * tmask(ji,jj,1)                
    572             END DO 
    573          END DO 
     545         DO_2D_00_00 
     546            ztra = - ( zfu_ho(ji,jj,jl) - zfu_ho(ji-1,jj,jl) + zfv_ho(ji,jj,jl) - zfv_ho(ji,jj-1,jl) )   
     547            ! 
     548            ptc(ji,jj,jl) = ( ptc(ji,jj,jl) + ztra * r1_e1e2t(ji,jj) * pdt ) * tmask(ji,jj,1)                
     549         END_2D 
    574550      END DO 
    575551      CALL lbc_lnk( 'icedyn_adv_umx', ptc, 'T',  1. ) 
    … …  
    601577         ! 
    602578         DO jl = 1, jpl 
    603             DO jj = 1, jpjm1 
    604                DO ji = 1, fs_jpim1 
     579            DO_2D_10_10 
     580               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) 
     581               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) 
     582            END_2D 
     583         END DO 
     584         ! 
     585      ELSE                              !** alternate directions **! 
     586         ! 
     587         IF( MOD( (kt - 1) / nn_fsbc , 2 ) ==  MOD( (jt - 1) , 2 ) ) THEN   !==  odd ice time step:  adv_x then adv_y  ==! 
     588            ! 
     589            DO jl = 1, jpl              !-- flux in x-direction 
     590               DO_2D_10_10 
    605591                  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) 
     592               END_2D 
     593            END DO 
     594            ! 
     595            DO jl = 1, jpl              !-- first guess of tracer from u-flux 
     596               DO_2D_00_00 
     597                  ztra = - ( pfu_ups(ji,jj,jl) - pfu_ups(ji-1,jj,jl) )              & 
     598                     &   + ( pu     (ji,jj   ) - pu     (ji-1,jj   ) ) * pt(ji,jj,jl) * (1.-pamsk) 
     599                  ! 
     600                  zpt(ji,jj,jl) = ( pt(ji,jj,jl) + ztra * pdt * r1_e1e2t(ji,jj) ) * tmask(ji,jj,1) 
     601               END_2D 
     602            END DO 
     603            CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1. ) 
     604            ! 
     605            DO jl = 1, jpl              !-- flux in y-direction 
     606               DO_2D_10_10 
     607                  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) 
     608               END_2D 
     609            END DO 
     610            ! 
     611         ELSE                                                               !==  even ice time step:  adv_y then adv_x  ==! 
     612            ! 
     613            DO jl = 1, jpl              !-- flux in y-direction 
     614               DO_2D_10_10 
    606615                  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) 
    607                END DO 
    608             END DO 
    609          END DO 
    610          ! 
    611       ELSE                              !** alternate directions **! 
    612          ! 
    613          IF( MOD( (kt - 1) / nn_fsbc , 2 ) ==  MOD( (jt - 1) , 2 ) ) THEN   !==  odd ice time step:  adv_x then adv_y  ==! 
     616               END_2D 
     617            END DO 
     618            ! 
     619            DO jl = 1, jpl              !-- first guess of tracer from v-flux 
     620               DO_2D_00_00 
     621                  ztra = - ( pfv_ups(ji,jj,jl) - pfv_ups(ji,jj-1,jl) )  & 
     622                     &   + ( pv     (ji,jj   ) - pv     (ji,jj-1   ) ) * pt(ji,jj,jl) * (1.-pamsk) 
     623                  ! 
     624                  zpt(ji,jj,jl) = ( pt(ji,jj,jl) + ztra * pdt * r1_e1e2t(ji,jj) ) * tmask(ji,jj,1) 
     625               END_2D 
     626            END DO 
     627            CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1. ) 
    614628            ! 
    615629            DO jl = 1, jpl              !-- flux in x-direction 
    616                DO jj = 1, jpjm1 
    617                   DO ji = 1, fs_jpim1 
    618                      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) 
    619                   END DO 
    620                END DO 
    621             END DO 
    622             ! 
    623             DO jl = 1, jpl              !-- first guess of tracer from u-flux 
    624                DO jj = 2, jpjm1 
    625                   DO ji = fs_2, fs_jpim1 
    626                      ztra = - ( pfu_ups(ji,jj,jl) - pfu_ups(ji-1,jj,jl) )              & 
    627                         &   + ( pu     (ji,jj   ) - pu     (ji-1,jj   ) ) * pt(ji,jj,jl) * (1.-pamsk) 
    628                      ! 
    629                      zpt(ji,jj,jl) = ( pt(ji,jj,jl) + ztra * pdt * r1_e1e2t(ji,jj) ) * tmask(ji,jj,1) 
    630                   END DO 
    631                END DO 
    632             END DO 
    633             CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1. ) 
    634             ! 
    635             DO jl = 1, jpl              !-- flux in y-direction 
    636                DO jj = 1, jpjm1 
    637                   DO ji = 1, fs_jpim1 
    638                      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) 
    639                   END DO 
    640                END DO 
    641             END DO 
    642             ! 
    643          ELSE                                                               !==  even ice time step:  adv_y then adv_x  ==! 
    644             ! 
    645             DO jl = 1, jpl              !-- flux in y-direction 
    646                DO jj = 1, jpjm1 
    647                   DO ji = 1, fs_jpim1 
    648                      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) 
    649                   END DO 
    650                END DO 
    651             END DO 
    652             ! 
    653             DO jl = 1, jpl              !-- first guess of tracer from v-flux 
    654                DO jj = 2, jpjm1 
    655                   DO ji = fs_2, fs_jpim1 
    656                      ztra = - ( pfv_ups(ji,jj,jl) - pfv_ups(ji,jj-1,jl) )  & 
    657                         &   + ( pv     (ji,jj   ) - pv     (ji,jj-1   ) ) * 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 DO 
    661                END DO 
    662             END DO 
    663             CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1. ) 
    664             ! 
    665             DO jl = 1, jpl              !-- flux in x-direction 
    666                DO jj = 1, jpjm1 
    667                   DO ji = 1, fs_jpim1 
    668                      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) 
    669                   END DO 
    670                END DO 
     630               DO_2D_10_10 
     631                  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) 
     632               END_2D 
    671633            END DO 
    672634            ! 
    … …  
    676638      ! 
    677639      DO jl = 1, jpl                    !-- after tracer with upstream scheme 
    678          DO jj = 2, jpjm1 
    679             DO ji = fs_2, fs_jpim1 
    680                ztra = - (   pfu_ups(ji,jj,jl) - pfu_ups(ji-1,jj  ,jl)   & 
    681                   &       + pfv_ups(ji,jj,jl) - pfv_ups(ji  ,jj-1,jl) ) & 
    682                   &   + (   pu     (ji,jj   ) - pu     (ji-1,jj     )   & 
    683                   &       + pv     (ji,jj   ) - pv     (ji  ,jj-1   ) ) * pt(ji,jj,jl) * (1.-pamsk) 
    684                ! 
    685                pt_ups(ji,jj,jl) = ( pt(ji,jj,jl) + ztra * pdt * r1_e1e2t(ji,jj) ) * tmask(ji,jj,1) 
    686             END DO 
    687          END DO 
     640         DO_2D_00_00 
     641            ztra = - (   pfu_ups(ji,jj,jl) - pfu_ups(ji-1,jj  ,jl)   & 
     642               &       + pfv_ups(ji,jj,jl) - pfv_ups(ji  ,jj-1,jl) ) & 
     643               &   + (   pu     (ji,jj   ) - pu     (ji-1,jj     )   & 
     644               &       + pv     (ji,jj   ) - pv     (ji  ,jj-1   ) ) * pt(ji,jj,jl) * (1.-pamsk) 
     645            ! 
     646            pt_ups(ji,jj,jl) = ( pt(ji,jj,jl) + ztra * pdt * r1_e1e2t(ji,jj) ) * tmask(ji,jj,1) 
     647         END_2D 
    688648      END DO 
    689649      CALL lbc_lnk( 'icedyn_adv_umx', pt_ups, 'T', 1. ) 
    … …  
    717677         ! 
    718678         DO jl = 1, jpl 
    719             DO jj = 1, jpjm1 
    720                DO ji = 1, fs_jpim1 
    721                   pfu_ho(ji,jj,jl) = 0.5_wp * pu(ji,jj) * ( pt(ji,jj,jl) + pt(ji+1,jj  ,jl) ) 
    722                   pfv_ho(ji,jj,jl) = 0.5_wp * pv(ji,jj) * ( pt(ji,jj,jl) + pt(ji  ,jj+1,jl) ) 
    723                END DO 
    724             END DO 
     679            DO_2D_10_10 
     680               pfu_ho(ji,jj,jl) = 0.5_wp * pu(ji,jj) * ( pt(ji,jj,jl) + pt(ji+1,jj  ,jl) ) 
     681               pfv_ho(ji,jj,jl) = 0.5_wp * pv(ji,jj) * ( pt(ji,jj,jl) + pt(ji  ,jj+1,jl) ) 
     682            END_2D 
    725683         END DO 
    726684         ! 
    … …  
    737695            ! 
    738696            DO jl = 1, jpl              !-- flux in x-direction 
    739                DO jj = 1, jpjm1 
    740                   DO ji = 1, fs_jpim1 
    741                      pfu_ho(ji,jj,jl) = 0.5_wp * pu(ji,jj) * ( pt(ji,jj,jl) + pt(ji+1,jj,jl) ) 
    742                   END DO 
    743                END DO 
     697               DO_2D_10_10 
     698                  pfu_ho(ji,jj,jl) = 0.5_wp * pu(ji,jj) * ( pt(ji,jj,jl) + pt(ji+1,jj,jl) ) 
     699               END_2D 
    744700            END DO 
    745701            IF( np_limiter == 2 .OR. np_limiter == 3 )   CALL limiter_x( pdt, pu, pt, pfu_ups, pfu_ho ) 
    746702 
    747703            DO jl = 1, jpl              !-- first guess of tracer from u-flux 
    748                DO jj = 2, jpjm1 
    749                   DO ji = fs_2, fs_jpim1 
    750                      ztra = - ( pfu_ho(ji,jj,jl) - pfu_ho(ji-1,jj,jl) )              & 
    751                         &   + ( pu    (ji,jj   ) - pu    (ji-1,jj   ) ) * pt(ji,jj,jl) * (1.-pamsk) 
    752                      ! 
    753                      zpt(ji,jj,jl) = ( pt(ji,jj,jl) + ztra * pdt * r1_e1e2t(ji,jj) ) * tmask(ji,jj,1) 
    754                   END DO 
    755                END DO 
     704               DO_2D_00_00 
     705                  ztra = - ( pfu_ho(ji,jj,jl) - pfu_ho(ji-1,jj,jl) )              & 
     706                     &   + ( pu    (ji,jj   ) - pu    (ji-1,jj   ) ) * pt(ji,jj,jl) * (1.-pamsk) 
     707                  ! 
     708                  zpt(ji,jj,jl) = ( pt(ji,jj,jl) + ztra * pdt * r1_e1e2t(ji,jj) ) * tmask(ji,jj,1) 
     709               END_2D 
    756710            END DO 
    757711            CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1. ) 
    758712 
    759713            DO jl = 1, jpl              !-- flux in y-direction 
    760                DO jj = 1, jpjm1 
    761                   DO ji = 1, fs_jpim1 
    762                      pfv_ho(ji,jj,jl) = 0.5_wp * pv(ji,jj) * ( zpt(ji,jj,jl) + zpt(ji,jj+1,jl) ) 
    763                   END DO 
    764                END DO 
     714               DO_2D_10_10 
     715                  pfv_ho(ji,jj,jl) = 0.5_wp * pv(ji,jj) * ( zpt(ji,jj,jl) + zpt(ji,jj+1,jl) ) 
     716               END_2D 
    765717            END DO 
    766718            IF( np_limiter == 2 .OR. np_limiter == 3 )   CALL limiter_y( pdt, pv, pt, pfv_ups, pfv_ho ) 
    … …  
    769721            ! 
    770722            DO jl = 1, jpl              !-- flux in y-direction 
    771                DO jj = 1, jpjm1 
    772                   DO ji = 1, fs_jpim1 
    773                      pfv_ho(ji,jj,jl) = 0.5_wp * pv(ji,jj) * ( pt(ji,jj,jl) + pt(ji,jj+1,jl) ) 
    774                   END DO 
    775                END DO 
     723               DO_2D_10_10 
     724                  pfv_ho(ji,jj,jl) = 0.5_wp * pv(ji,jj) * ( pt(ji,jj,jl) + pt(ji,jj+1,jl) ) 
     725               END_2D 
    776726            END DO 
    777727            IF( np_limiter == 2 .OR. np_limiter == 3 )   CALL limiter_y( pdt, pv, pt, pfv_ups, pfv_ho ) 
    778728            ! 
    779729            DO jl = 1, jpl              !-- first guess of tracer from v-flux 
    780                DO jj = 2, jpjm1 
    781                   DO ji = fs_2, fs_jpim1 
    782                      ztra = - ( pfv_ho(ji,jj,jl) - pfv_ho(ji,jj-1,jl) )  & 
    783                         &   + ( pv    (ji,jj   ) - pv    (ji,jj-1   ) ) * pt(ji,jj,jl) * (1.-pamsk) 
    784                      ! 
    785                      zpt(ji,jj,jl) = ( pt(ji,jj,jl) + ztra * pdt * r1_e1e2t(ji,jj) ) * tmask(ji,jj,1) 
    786                   END DO 
    787                END DO 
     730               DO_2D_00_00 
     731                  ztra = - ( pfv_ho(ji,jj,jl) - pfv_ho(ji,jj-1,jl) )  & 
     732                     &   + ( pv    (ji,jj   ) - pv    (ji,jj-1   ) ) * pt(ji,jj,jl) * (1.-pamsk) 
     733                  ! 
     734                  zpt(ji,jj,jl) = ( pt(ji,jj,jl) + ztra * pdt * r1_e1e2t(ji,jj) ) * tmask(ji,jj,1) 
     735               END_2D 
    788736            END DO 
    789737            CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1. ) 
    790738            ! 
    791739            DO jl = 1, jpl              !-- flux in x-direction 
    792                DO jj = 1, jpjm1 
    793                   DO ji = 1, fs_jpim1 
    794                      pfu_ho(ji,jj,jl) = 0.5_wp * pu(ji,jj) * ( zpt(ji,jj,jl) + zpt(ji+1,jj,jl) ) 
    795                   END DO 
    796                END DO 
     740               DO_2D_10_10 
     741                  pfu_ho(ji,jj,jl) = 0.5_wp * pu(ji,jj) * ( zpt(ji,jj,jl) + zpt(ji+1,jj,jl) ) 
     742               END_2D 
    797743            END DO 
    798744            IF( np_limiter == 2 .OR. np_limiter == 3 )   CALL limiter_x( pdt, pu, pt, pfu_ups, pfu_ho ) 
    … …  
    840786         !                                                        !--  advective form update in zpt  --! 
    841787         DO jl = 1, jpl 
    842             DO jj = 2, jpjm1 
    843                DO ji = fs_2, fs_jpim1 
    844                   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) & 
    845                      &                              + pt   (ji,jj,jl) * ( pu  (ji,jj   ) - pu  (ji-1,jj   ) ) * r1_e1e2t(ji,jj) & 
    846                      &                                                                                        * pamsk           & 
    847                      &                             ) * pdt ) * tmask(ji,jj,1) 
    848                END DO 
    849             END DO 
     788            DO_2D_00_00 
     789               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) & 
     790                  &                              + pt   (ji,jj,jl) * ( pu  (ji,jj   ) - pu  (ji-1,jj   ) ) * r1_e1e2t(ji,jj) & 
     791                  &                                                                                        * pamsk           & 
     792                  &                             ) * pdt ) * tmask(ji,jj,1) 
     793            END_2D 
    850794         END DO 
    851795         CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1. ) 
    … …  
    869813         !                                                        !--  advective form update in zpt  --! 
    870814         DO jl = 1, jpl 
    871             DO jj = 2, jpjm1 
    872                DO ji = fs_2, fs_jpim1 
    873                   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) & 
    874                      &                              + pt   (ji,jj,jl) * ( pv  (ji,jj   ) - pv  (ji,jj-1   ) ) * r1_e1e2t(ji,jj) & 
    875                      &                                                                                        * pamsk           & 
    876                      &                             ) * pdt ) * tmask(ji,jj,1)  
    877                END DO 
    878             END DO 
     815            DO_2D_00_00 
     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_2D 
    879821         END DO 
    880822         CALL lbc_lnk( 'icedyn_adv_umx', zpt, 'T', 1. ) 
    … …  
    953895         !         
    954896         DO jl = 1, jpl 
    955             DO jj = 1, jpjm1 
    956                DO ji = 1, fs_jpim1   ! vector opt. 
    957                   pt_u(ji,jj,jl) = 0.5_wp * umask(ji,jj,1) * (                                pt(ji+1,jj,jl) + pt(ji,jj,jl)   & 
    958                      &                                         - SIGN( 1._wp, pu(ji,jj) ) * ( pt(ji+1,jj,jl) - pt(ji,jj,jl) ) ) 
    959                END DO 
    960             END DO 
     897            DO_2D_10_10 
     898               pt_u(ji,jj,jl) = 0.5_wp * umask(ji,jj,1) * (                                pt(ji+1,jj,jl) + pt(ji,jj,jl)   & 
     899                  &                                         - SIGN( 1._wp, pu(ji,jj) ) * ( pt(ji+1,jj,jl) - pt(ji,jj,jl) ) ) 
     900            END_2D 
    961901         END DO 
    962902         ! 
    … …  
    964904         ! 
    965905         DO jl = 1, jpl 
    966             DO jj = 1, jpjm1 
    967                DO ji = 1, fs_jpim1   ! vector opt. 
    968                   zcu  = pu(ji,jj) * r1_e2u(ji,jj) * pdt * r1_e1u(ji,jj) 
    969                   pt_u(ji,jj,jl) = 0.5_wp * umask(ji,jj,1) * (                                pt(ji+1,jj,jl) + pt(ji,jj,jl)   & 
    970                      &                                                            - zcu   * ( pt(ji+1,jj,jl) - pt(ji,jj,jl) ) )  
    971                END DO 
    972             END DO 
     906            DO_2D_10_10 
     907               zcu  = pu(ji,jj) * r1_e2u(ji,jj) * pdt * r1_e1u(ji,jj) 
     908               pt_u(ji,jj,jl) = 0.5_wp * umask(ji,jj,1) * (                                pt(ji+1,jj,jl) + pt(ji,jj,jl)   & 
     909                  &                                                            - zcu   * ( pt(ji+1,jj,jl) - pt(ji,jj,jl) ) )  
     910            END_2D 
    973911         END DO 
    974912         !   
    … …  
    976914         ! 
    977915         DO jl = 1, jpl 
    978             DO jj = 1, jpjm1 
    979                DO ji = 1, fs_jpim1   ! vector opt. 
    980                   zcu  = pu(ji,jj) * r1_e2u(ji,jj) * pdt * r1_e1u(ji,jj) 
    981                   zdx2 = e1u(ji,jj) * e1u(ji,jj) 
     916            DO_2D_10_10 
     917               zcu  = pu(ji,jj) * r1_e2u(ji,jj) * pdt * r1_e1u(ji,jj) 
     918               zdx2 = e1u(ji,jj) * e1u(ji,jj) 
    982919!!rachid          zdx2 = e1u(ji,jj) * e1t(ji,jj) 
    983                   pt_u(ji,jj,jl) = 0.5_wp * umask(ji,jj,1) * (         (                      pt  (ji+1,jj,jl) + pt  (ji,jj,jl)     & 
    984                      &                                                            - zcu   * ( pt  (ji+1,jj,jl) - pt  (ji,jj,jl) ) ) & 
    985                      &        + z1_6 * zdx2 * ( zcu*zcu - 1._wp ) *    (                      ztu2(ji+1,jj,jl) + ztu2(ji,jj,jl)     & 
    986                      &                                               - SIGN( 1._wp, zcu ) * ( ztu2(ji+1,jj,jl) - ztu2(ji,jj,jl) ) ) ) 
    987                END DO 
    988             END DO 
     920               pt_u(ji,jj,jl) = 0.5_wp * umask(ji,jj,1) * (         (                      pt  (ji+1,jj,jl) + pt  (ji,jj,jl)     & 
     921                  &                                                            - zcu   * ( pt  (ji+1,jj,jl) - pt  (ji,jj,jl) ) ) & 
     922                  &        + z1_6 * zdx2 * ( zcu*zcu - 1._wp ) *    (                      ztu2(ji+1,jj,jl) + ztu2(ji,jj,jl)     & 
     923                  &                                               - SIGN( 1._wp, zcu ) * ( ztu2(ji+1,jj,jl) - ztu2(ji,jj,jl) ) ) ) 
     924            END_2D 
    989925         END DO 
    990926         ! 
    … …  
    992928         ! 
    993929         DO jl = 1, jpl 
    994             DO jj = 1, jpjm1 
    995                DO ji = 1, fs_jpim1   ! vector opt. 
    996                   zcu  = pu(ji,jj) * r1_e2u(ji,jj) * pdt * r1_e1u(ji,jj) 
    997                   zdx2 = e1u(ji,jj) * e1u(ji,jj) 
     930            DO_2D_10_10 
     931               zcu  = pu(ji,jj) * r1_e2u(ji,jj) * pdt * r1_e1u(ji,jj) 
     932               zdx2 = e1u(ji,jj) * e1u(ji,jj) 
    998933!!rachid          zdx2 = e1u(ji,jj) * e1t(ji,jj) 
    999                   pt_u(ji,jj,jl) = 0.5_wp * umask(ji,jj,1) * (         (                      pt  (ji+1,jj,jl) + pt  (ji,jj,jl)     & 
    1000                      &                                                            - zcu   * ( pt  (ji+1,jj,jl) - pt  (ji,jj,jl) ) ) & 
    1001                      &        + z1_6 * zdx2 * ( zcu*zcu - 1._wp ) *    (                      ztu2(ji+1,jj,jl) + ztu2(ji,jj,jl)     & 
    1002                      &                                                   - 0.5_wp * zcu   * ( ztu2(ji+1,jj,jl) - ztu2(ji,jj,jl) ) ) ) 
    1003                END DO 
    1004             END DO 
     934               pt_u(ji,jj,jl) = 0.5_wp * umask(ji,jj,1) * (         (                      pt  (ji+1,jj,jl) + pt  (ji,jj,jl)     & 
     935                  &                                                            - zcu   * ( pt  (ji+1,jj,jl) - pt  (ji,jj,jl) ) ) & 
     936                  &        + z1_6 * zdx2 * ( zcu*zcu - 1._wp ) *    (                      ztu2(ji+1,jj,jl) + ztu2(ji,jj,jl)     & 
     937                  &                                                   - 0.5_wp * zcu   * ( ztu2(ji+1,jj,jl) - ztu2(ji,jj,jl) ) ) ) 
     938            END_2D 
    1005939         END DO 
    1006940         ! 
    … …  
    1008942         ! 
    1009943         DO jl = 1, jpl 
    1010             DO jj = 1, jpjm1 
    1011                DO ji = 1, fs_jpim1   ! vector opt. 
    1012                   zcu  = pu(ji,jj) * r1_e2u(ji,jj) * pdt * r1_e1u(ji,jj) 
    1013                   zdx2 = e1u(ji,jj) * e1u(ji,jj) 
     944            DO_2D_10_10 
     945               zcu  = pu(ji,jj) * r1_e2u(ji,jj) * pdt * r1_e1u(ji,jj) 
     946               zdx2 = e1u(ji,jj) * e1u(ji,jj) 
    1014947!!rachid          zdx2 = e1u(ji,jj) * e1t(ji,jj) 
    1015                   zdx4 = zdx2 * zdx2 
    1016                   pt_u(ji,jj,jl) = 0.5_wp * umask(ji,jj,1) * (        (                       pt  (ji+1,jj,jl) + pt  (ji,jj,jl)     & 
    1017                      &                                                            - zcu   * ( pt  (ji+1,jj,jl) - pt  (ji,jj,jl) ) ) & 
    1018                      &        + z1_6   * zdx2 * ( zcu*zcu - 1._wp ) * (                       ztu2(ji+1,jj,jl) + ztu2(ji,jj,jl)     & 
    1019                      &                                                   - 0.5_wp * zcu   * ( ztu2(ji+1,jj,jl) - ztu2(ji,jj,jl) ) ) & 
    1020                      &        + z1_120 * zdx4 * ( zcu*zcu - 1._wp ) * ( zcu*zcu - 4._wp ) * ( ztu4(ji+1,jj,jl) + ztu4(ji,jj,jl)     & 
    1021                      &                                               - SIGN( 1._wp, zcu ) * ( ztu4(ji+1,jj,jl) - ztu4(ji,jj,jl) ) ) ) 
    1022                END DO 
    1023             END DO 
     948               zdx4 = zdx2 * zdx2 
     949               pt_u(ji,jj,jl) = 0.5_wp * umask(ji,jj,1) * (        (                       pt  (ji+1,jj,jl) + pt  (ji,jj,jl)     & 
     950                  &                                                            - zcu   * ( pt  (ji+1,jj,jl) - pt  (ji,jj,jl) ) ) & 
     951                  &        + z1_6   * zdx2 * ( zcu*zcu - 1._wp ) * (                       ztu2(ji+1,jj,jl) + ztu2(ji,jj,jl)     & 
     952                  &                                                   - 0.5_wp * zcu   * ( ztu2(ji+1,jj,jl) - ztu2(ji,jj,jl) ) ) & 
     953                  &        + z1_120 * zdx4 * ( zcu*zcu - 1._wp ) * ( zcu*zcu - 4._wp ) * ( ztu4(ji+1,jj,jl) + ztu4(ji,jj,jl)     & 
     954                  &                                               - SIGN( 1._wp, zcu ) * ( ztu4(ji+1,jj,jl) - ztu4(ji,jj,jl) ) ) ) 
     955            END_2D 
    1024956         END DO 
    1025957         ! 
    … …  
    1031963      IF( ll_neg ) THEN 
    1032964         DO jl = 1, jpl 
    1033             DO jj = 1, jpjm1 
    1034                DO ji = 1, fs_jpim1 
    1035                   IF( pt_u(ji,jj,jl) < 0._wp .OR. ( imsk_small(ji,jj,jl) == 0 .AND. pamsk == 0. ) ) THEN 
    1036                      pt_u(ji,jj,jl) = 0.5_wp * umask(ji,jj,1) * (                                pt(ji+1,jj,jl) + pt(ji,jj,jl)   & 
    1037                         &                                         - SIGN( 1._wp, pu(ji,jj) ) * ( pt(ji+1,jj,jl) - pt(ji,jj,jl) ) ) 
    1038                   ENDIF 
    1039                END DO 
    1040             END DO 
     965            DO_2D_10_10 
     966               IF( pt_u(ji,jj,jl) < 0._wp .OR. ( imsk_small(ji,jj,jl) == 0 .AND. pamsk == 0. ) ) THEN 
     967                  pt_u(ji,jj,jl) = 0.5_wp * umask(ji,jj,1) * (                                pt(ji+1,jj,jl) + pt(ji,jj,jl)   & 
     968                     &                                         - SIGN( 1._wp, pu(ji,jj) ) * ( pt(ji+1,jj,jl) - pt(ji,jj,jl) ) ) 
     969               ENDIF 
     970            END_2D 
    1041971         END DO 
    1042972      ENDIF 
    1043973      !                                                     !-- High order flux in i-direction  --! 
    1044974      DO jl = 1, jpl 
    1045          DO jj = 1, jpjm1 
    1046             DO ji = 1, fs_jpim1   ! vector opt. 
    1047                pfu_ho(ji,jj,jl) = pu(ji,jj) * pt_u(ji,jj,jl) 
    1048             END DO 
    1049          END DO 
     975         DO_2D_10_10 
     976            pfu_ho(ji,jj,jl) = pu(ji,jj) * pt_u(ji,jj,jl) 
     977         END_2D 
    1050978      END DO 
    1051979      ! 
    … …  
    10781006      !                                                     !--  Laplacian in j-direction  --! 
    10791007      DO jl = 1, jpl 
    1080          DO jj = 1, jpjm1         ! First derivative (gradient) 
    1081             DO ji = fs_2, fs_jpim1 
    1082                ztv1(ji,jj,jl) = ( pt(ji,jj+1,jl) - pt(ji,jj,jl) ) * r1_e2v(ji,jj) * vmask(ji,jj,1) 
    1083             END DO 
    1084          END DO 
    1085          DO jj = 2, jpjm1         ! Second derivative (Laplacian) 
    1086             DO ji = fs_2, fs_jpim1 
    1087                ztv2(ji,jj,jl) = ( ztv1(ji,jj,jl) - ztv1(ji,jj-1,jl) ) * r1_e2t(ji,jj) 
    1088             END DO 
    1089          END DO 
     1008         DO_2D_10_00 
     1009            ztv1(ji,jj,jl) = ( pt(ji,jj+1,jl) - pt(ji,jj,jl) ) * r1_e2v(ji,jj) * vmask(ji,jj,1) 
     1010         END_2D 
     1011         DO_2D_00_00 
     1012            ztv2(ji,jj,jl) = ( ztv1(ji,jj,jl) - ztv1(ji,jj-1,jl) ) * r1_e2t(ji,jj) 
     1013         END_2D 
    10901014      END DO 
    10911015      CALL lbc_lnk( 'icedyn_adv_umx', ztv2, 'T', 1. ) 
    … …  
    10931017      !                                                     !--  BiLaplacian in j-direction  --! 
    10941018      DO jl = 1, jpl 
    1095          DO jj = 1, jpjm1         ! First derivative 
    1096             DO ji = fs_2, fs_jpim1 
    1097                ztv3(ji,jj,jl) = ( ztv2(ji,jj+1,jl) - ztv2(ji,jj,jl) ) * r1_e2v(ji,jj) * vmask(ji,jj,1) 
    1098             END DO 
    1099          END DO 
    1100          DO jj = 2, jpjm1         ! Second derivative 
    1101             DO ji = fs_2, fs_jpim1 
    1102                ztv4(ji,jj,jl) = ( ztv3(ji,jj,jl) - ztv3(ji,jj-1,jl) ) * r1_e2t(ji,jj) 
    1103             END DO 
    1104          END DO 
     1019         DO_2D_10_00 
     1020            ztv3(ji,jj,jl) = ( ztv2(ji,jj+1,jl) - ztv2(ji,jj,jl) ) * r1_e2v(ji,jj) * vmask(ji,jj,1) 
     1021         END_2D 
     1022         DO_2D_00_00 
     1023            ztv4(ji,jj,jl) = ( ztv3(ji,jj,jl) - ztv3(ji,jj-1,jl) ) * r1_e2t(ji,jj) 
     1024         END_2D 
    11051025      END DO 
    11061026      CALL lbc_lnk( 'icedyn_adv_umx', ztv4, 'T', 1. ) 
    … …  
    11111031      CASE( 1 )                                                !==  1st order central TIM  ==! (Eq. 21) 
    11121032         DO jl = 1, jpl 
    1113             DO jj = 1, jpjm1 
    1114                DO ji = 1, fs_jpim1 
    1115                   pt_v(ji,jj,jl) = 0.5_wp * vmask(ji,jj,1) * (                                pt(ji,jj+1,jl) + pt(ji,jj,jl)   & 
    1116                      &                                         - SIGN( 1._wp, pv(ji,jj) ) * ( pt(ji,jj+1,jl) - pt(ji,jj,jl) ) ) 
    1117                END DO 
    1118             END DO 
     1033            DO_2D_10_10 
     1034               pt_v(ji,jj,jl) = 0.5_wp * vmask(ji,jj,1) * (                                pt(ji,jj+1,jl) + pt(ji,jj,jl)   & 
     1035                  &                                         - SIGN( 1._wp, pv(ji,jj) ) * ( pt(ji,jj+1,jl) - pt(ji,jj,jl) ) ) 
     1036            END_2D 
    11191037         END DO 
    11201038         ! 
    11211039      CASE( 2 )                                                !==  2nd order central TIM  ==! (Eq. 23) 
    11221040         DO jl = 1, jpl 
    1123             DO jj = 1, jpjm1 
    1124                DO ji = 1, fs_jpim1 
    1125                   zcv  = pv(ji,jj) * r1_e1v(ji,jj) * pdt * r1_e2v(ji,jj) 
    1126                   pt_v(ji,jj,jl) = 0.5_wp * vmask(ji,jj,1) * (                                pt(ji,jj+1,jl) + pt(ji,jj,jl)   & 
    1127                      &                                                            - zcv *   ( pt(ji,jj+1,jl) - pt(ji,jj,jl) ) ) 
    1128                END DO 
    1129             END DO 
     1041            DO_2D_10_10 
     1042               zcv  = pv(ji,jj) * r1_e1v(ji,jj) * pdt * r1_e2v(ji,jj) 
     1043               pt_v(ji,jj,jl) = 0.5_wp * vmask(ji,jj,1) * (                                pt(ji,jj+1,jl) + pt(ji,jj,jl)   & 
     1044                  &                                                            - zcv *   ( pt(ji,jj+1,jl) - pt(ji,jj,jl) ) ) 
     1045            END_2D 
    11301046         END DO 
    11311047         ! 
    11321048      CASE( 3 )                                                !==  3rd order central TIM  ==! (Eq. 24) 
    11331049         DO jl = 1, jpl 
    1134             DO jj = 1, jpjm1 
    1135                DO ji = 1, fs_jpim1 
    1136                   zcv  = pv(ji,jj) * r1_e1v(ji,jj) * pdt * r1_e2v(ji,jj) 
    1137                   zdy2 = e2v(ji,jj) * e2v(ji,jj) 
     1050            DO_2D_10_10 
     1051               zcv  = pv(ji,jj) * r1_e1v(ji,jj) * pdt * r1_e2v(ji,jj) 
     1052               zdy2 = e2v(ji,jj) * e2v(ji,jj) 
    11381053!!rachid          zdy2 = e2v(ji,jj) * e2t(ji,jj) 
    1139                   pt_v(ji,jj,jl) = 0.5_wp * vmask(ji,jj,1) * (      (                         pt  (ji,jj+1,jl) + pt  (ji,jj,jl)     & 
    1140                      &                                                            - zcv   * ( pt  (ji,jj+1,jl) - pt  (ji,jj,jl) ) ) & 
    1141                      &        + z1_6 * zdy2 * ( zcv*zcv - 1._wp ) * (                         ztv2(ji,jj+1,jl) + ztv2(ji,jj,jl)     & 
    1142                      &                                               - SIGN( 1._wp, zcv ) * ( ztv2(ji,jj+1,jl) - ztv2(ji,jj,jl) ) ) ) 
    1143                END DO 
    1144             END DO 
     1054               pt_v(ji,jj,jl) = 0.5_wp * vmask(ji,jj,1) * (      (                         pt  (ji,jj+1,jl) + pt  (ji,jj,jl)     & 
     1055                  &                                                            - zcv   * ( pt  (ji,jj+1,jl) - pt  (ji,jj,jl) ) ) & 
     1056                  &        + z1_6 * zdy2 * ( zcv*zcv - 1._wp ) * (                         ztv2(ji,jj+1,jl) + ztv2(ji,jj,jl)     & 
     1057                  &                                               - SIGN( 1._wp, zcv ) * ( ztv2(ji,jj+1,jl) - ztv2(ji,jj,jl) ) ) ) 
     1058            END_2D 
    11451059         END DO 
    11461060         ! 
    11471061      CASE( 4 )                                                !==  4th order central TIM  ==! (Eq. 27) 
    11481062         DO jl = 1, jpl 
    1149             DO jj = 1, jpjm1 
    1150                DO ji = 1, fs_jpim1 
    1151                   zcv  = pv(ji,jj) * r1_e1v(ji,jj) * pdt * r1_e2v(ji,jj) 
    1152                   zdy2 = e2v(ji,jj) * e2v(ji,jj) 
     1063            DO_2D_10_10 
     1064               zcv  = pv(ji,jj) * r1_e1v(ji,jj) * pdt * r1_e2v(ji,jj) 
     1065               zdy2 = e2v(ji,jj) * e2v(ji,jj) 
    11531066!!rachid          zdy2 = e2v(ji,jj) * e2t(ji,jj) 
    1154                   pt_v(ji,jj,jl) = 0.5_wp * vmask(ji,jj,1) * (      (                         pt  (ji,jj+1,jl) + pt  (ji,jj,jl)     & 
    1155                      &                                                            - zcv   * ( pt  (ji,jj+1,jl) - pt  (ji,jj,jl) ) ) & 
    1156                      &        + z1_6 * zdy2 * ( zcv*zcv - 1._wp ) * (                         ztv2(ji,jj+1,jl) + ztv2(ji,jj,jl)     & 
    1157                      &                                                   - 0.5_wp * zcv   * ( ztv2(ji,jj+1,jl) - ztv2(ji,jj,jl) ) ) ) 
    1158                END DO 
    1159             END DO 
     1067               pt_v(ji,jj,jl) = 0.5_wp * vmask(ji,jj,1) * (      (                         pt  (ji,jj+1,jl) + pt  (ji,jj,jl)     & 
     1068                  &                                                            - zcv   * ( pt  (ji,jj+1,jl) - pt  (ji,jj,jl) ) ) & 
     1069                  &        + z1_6 * zdy2 * ( zcv*zcv - 1._wp ) * (                         ztv2(ji,jj+1,jl) + ztv2(ji,jj,jl)     & 
     1070                  &                                                   - 0.5_wp * zcv   * ( ztv2(ji,jj+1,jl) - ztv2(ji,jj,jl) ) ) ) 
     1071            END_2D 
    11601072         END DO 
    11611073         ! 
    11621074      CASE( 5 )                                                !==  5th order central TIM  ==! (Eq. 29) 
    11631075         DO jl = 1, jpl 
    1164             DO jj = 1, jpjm1 
    1165                DO ji = 1, fs_jpim1 
    1166                   zcv  = pv(ji,jj) * r1_e1v(ji,jj) * pdt * r1_e2v(ji,jj) 
    1167                   zdy2 = e2v(ji,jj) * e2v(ji,jj) 
     1076            DO_2D_10_10 
     1077               zcv  = pv(ji,jj) * r1_e1v(ji,jj) * pdt * r1_e2v(ji,jj) 
     1078               zdy2 = e2v(ji,jj) * e2v(ji,jj) 
    11681079!!rachid          zdy2 = e2v(ji,jj) * e2t(ji,jj) 
    1169                   zdy4 = zdy2 * zdy2 
    1170                   pt_v(ji,jj,jl) = 0.5_wp * vmask(ji,jj,1) * (                              ( pt  (ji,jj+1,jl) + pt  (ji,jj,jl)     & 
    1171                      &                                                            - zcv   * ( pt  (ji,jj+1,jl) - pt  (ji,jj,jl) ) ) & 
    1172                      &        + z1_6   * zdy2 * ( zcv*zcv - 1._wp ) * (                       ztv2(ji,jj+1,jl) + ztv2(ji,jj,jl)     & 
    1173                      &                                                   - 0.5_wp * zcv   * ( ztv2(ji,jj+1,jl) - ztv2(ji,jj,jl) ) ) & 
    1174                      &        + z1_120 * zdy4 * ( zcv*zcv - 1._wp ) * ( zcv*zcv - 4._wp ) * ( ztv4(ji,jj+1,jl) + ztv4(ji,jj,jl)     & 
    1175                      &                                               - SIGN( 1._wp, zcv ) * ( ztv4(ji,jj+1,jl) - ztv4(ji,jj,jl) ) ) ) 
    1176                END DO 
    1177             END DO 
     1080               zdy4 = zdy2 * zdy2 
     1081               pt_v(ji,jj,jl) = 0.5_wp * vmask(ji,jj,1) * (                              ( pt  (ji,jj+1,jl) + pt  (ji,jj,jl)     & 
     1082                  &                                                            - zcv   * ( pt  (ji,jj+1,jl) - pt  (ji,jj,jl) ) ) & 
     1083                  &        + z1_6   * zdy2 * ( zcv*zcv - 1._wp ) * (                       ztv2(ji,jj+1,jl) + ztv2(ji,jj,jl)     & 
     1084                  &                                                   - 0.5_wp * zcv   * ( ztv2(ji,jj+1,jl) - ztv2(ji,jj,jl) ) ) & 
     1085                  &        + z1_120 * zdy4 * ( zcv*zcv - 1._wp ) * ( zcv*zcv - 4._wp ) * ( ztv4(ji,jj+1,jl) + ztv4(ji,jj,jl)     & 
     1086                  &                                               - SIGN( 1._wp, zcv ) * ( ztv4(ji,jj+1,jl) - ztv4(ji,jj,jl) ) ) ) 
     1087            END_2D 
    11781088         END DO 
    11791089         ! 
    … …  
    11851095      IF( ll_neg ) THEN 
    11861096         DO jl = 1, jpl 
    1187             DO jj = 1, jpjm1 
    1188                DO ji = 1, fs_jpim1 
    1189                   IF( pt_v(ji,jj,jl) < 0._wp .OR. ( jmsk_small(ji,jj,jl) == 0 .AND. pamsk == 0. ) ) THEN 
    1190                      pt_v(ji,jj,jl) = 0.5_wp * vmask(ji,jj,1) * (                              ( pt(ji,jj+1,jl) + pt(ji,jj,jl) )  & 
    1191                         &                                         - SIGN( 1._wp, pv(ji,jj) ) * ( pt(ji,jj+1,jl) - pt(ji,jj,jl) ) ) 
    1192                   ENDIF 
    1193                END DO 
    1194             END DO 
     1097            DO_2D_10_10 
     1098               IF( pt_v(ji,jj,jl) < 0._wp .OR. ( jmsk_small(ji,jj,jl) == 0 .AND. pamsk == 0. ) ) THEN 
     1099                  pt_v(ji,jj,jl) = 0.5_wp * vmask(ji,jj,1) * (                              ( pt(ji,jj+1,jl) + pt(ji,jj,jl) )  & 
     1100                     &                                         - SIGN( 1._wp, pv(ji,jj) ) * ( pt(ji,jj+1,jl) - pt(ji,jj,jl) ) ) 
     1101               ENDIF 
     1102            END_2D 
    11951103         END DO 
    11961104      ENDIF 
    11971105      !                                                     !-- High order flux in j-direction  --! 
    11981106      DO jl = 1, jpl 
    1199          DO jj = 1, jpjm1 
    1200             DO ji = 1, fs_jpim1   ! vector opt. 
    1201                pfv_ho(ji,jj,jl) = pv(ji,jj) * pt_v(ji,jj,jl) 
    1202             END DO 
    1203          END DO 
     1107         DO_2D_10_10 
     1108            pfv_ho(ji,jj,jl) = pv(ji,jj) * pt_v(ji,jj,jl) 
     1109         END_2D 
    12041110      END DO 
    12051111      ! 
    … …  
    12351141      ! -------------------------------------------------- 
    12361142      DO jl = 1, jpl 
    1237          DO jj = 1, jpjm1 
    1238             DO ji = 1, fs_jpim1   ! vector opt. 
    1239                pfu_ho(ji,jj,jl) = pfu_ho(ji,jj,jl) - pfu_ups(ji,jj,jl) 
    1240                pfv_ho(ji,jj,jl) = pfv_ho(ji,jj,jl) - pfv_ups(ji,jj,jl) 
    1241             END DO 
    1242          END DO 
     1143         DO_2D_10_10 
     1144            pfu_ho(ji,jj,jl) = pfu_ho(ji,jj,jl) - pfu_ups(ji,jj,jl) 
     1145            pfv_ho(ji,jj,jl) = pfv_ho(ji,jj,jl) - pfv_ups(ji,jj,jl) 
     1146         END_2D 
    12431147      END DO 
    12441148 
    … …  
    12541158          
    12551159         DO jl = 1, jpl 
    1256             DO jj = 2, jpjm1 
    1257                DO ji = fs_2, fs_jpim1  
    1258                   zti_ups(ji,jj,jl)= pt_ups(ji+1,jj  ,jl) 
    1259                   ztj_ups(ji,jj,jl)= pt_ups(ji  ,jj+1,jl) 
    1260                END DO 
    1261             END DO 
     1160            DO_2D_00_00 
     1161               zti_ups(ji,jj,jl)= pt_ups(ji+1,jj  ,jl) 
     1162               ztj_ups(ji,jj,jl)= pt_ups(ji  ,jj+1,jl) 
     1163            END_2D 
    12621164         END DO 
    12631165         CALL lbc_lnk_multi( 'icedyn_adv_umx', zti_ups, 'T', 1., ztj_ups, 'T', 1. ) 
    12641166 
    12651167         DO jl = 1, jpl 
    1266             DO jj = 2, jpjm1 
    1267                DO ji = fs_2, fs_jpim1 
    1268                   IF ( pfu_ho(ji,jj,jl) * ( pt_ups(ji+1,jj  ,jl) - pt_ups(ji,jj,jl) ) <= 0._wp .AND.  & 
    1269                      & pfv_ho(ji,jj,jl) * ( pt_ups(ji  ,jj+1,jl) - pt_ups(ji,jj,jl) ) <= 0._wp ) THEN 
    1270                      ! 
    1271                      IF(  pfu_ho(ji,jj,jl) * ( zti_ups(ji+1,jj  ,jl) - zti_ups(ji,jj,jl) ) <= 0._wp .AND.  & 
    1272                         & pfv_ho(ji,jj,jl) * ( ztj_ups(ji  ,jj+1,jl) - ztj_ups(ji,jj,jl) ) <= 0._wp ) THEN 
    1273                         pfu_ho(ji,jj,jl)=0._wp 
    1274                         pfv_ho(ji,jj,jl)=0._wp 
    1275                      ENDIF 
    1276                      ! 
    1277                      IF(  pfu_ho(ji,jj,jl) * ( pt_ups(ji,jj,jl) - pt_ups(ji-1,jj  ,jl) ) <= 0._wp .AND.  & 
    1278                         & pfv_ho(ji,jj,jl) * ( pt_ups(ji,jj,jl) - pt_ups(ji  ,jj-1,jl) ) <= 0._wp ) THEN 
    1279                         pfu_ho(ji,jj,jl)=0._wp 
    1280                         pfv_ho(ji,jj,jl)=0._wp 
    1281                      ENDIF 
    1282                      ! 
     1168            DO_2D_00_00 
     1169               IF ( pfu_ho(ji,jj,jl) * ( pt_ups(ji+1,jj  ,jl) - pt_ups(ji,jj,jl) ) <= 0._wp .AND.  & 
     1170                  & pfv_ho(ji,jj,jl) * ( pt_ups(ji  ,jj+1,jl) - pt_ups(ji,jj,jl) ) <= 0._wp ) THEN 
     1171                  ! 
     1172                  IF(  pfu_ho(ji,jj,jl) * ( zti_ups(ji+1,jj  ,jl) - zti_ups(ji,jj,jl) ) <= 0._wp .AND.  & 
     1173                     & pfv_ho(ji,jj,jl) * ( ztj_ups(ji  ,jj+1,jl) - ztj_ups(ji,jj,jl) ) <= 0._wp ) THEN 
     1174                     pfu_ho(ji,jj,jl)=0._wp 
     1175                     pfv_ho(ji,jj,jl)=0._wp 
    12831176                  ENDIF 
    1284                END DO 
    1285             END DO 
     1177                  ! 
     1178                  IF(  pfu_ho(ji,jj,jl) * ( pt_ups(ji,jj,jl) - pt_ups(ji-1,jj  ,jl) ) <= 0._wp .AND.  & 
     1179                     & pfv_ho(ji,jj,jl) * ( pt_ups(ji,jj,jl) - pt_ups(ji  ,jj-1,jl) ) <= 0._wp ) THEN 
     1180                     pfu_ho(ji,jj,jl)=0._wp 
     1181                     pfv_ho(ji,jj,jl)=0._wp 
     1182                  ENDIF 
     1183                  ! 
     1184               ENDIF 
     1185            END_2D 
    12861186         END DO 
    12871187         CALL lbc_lnk_multi( 'icedyn_adv_umx', pfu_ho, 'U', -1., pfv_ho, 'V', -1. )   ! lateral boundary cond. 
    … …  
    12951195      DO jl = 1, jpl 
    12961196          
    1297          DO jj = 1, jpj 
    1298             DO ji = 1, jpi 
    1299                IF    ( pt(ji,jj,jl) <= 0._wp .AND. pt_ups(ji,jj,jl) <= 0._wp ) THEN 
    1300                   zbup(ji,jj) = -zbig 
    1301                   zbdo(ji,jj) =  zbig 
    1302                ELSEIF( pt(ji,jj,jl) <= 0._wp .AND. pt_ups(ji,jj,jl) > 0._wp ) THEN 
    1303                   zbup(ji,jj) = pt_ups(ji,jj,jl) 
    1304                   zbdo(ji,jj) = pt_ups(ji,jj,jl) 
    1305                ELSEIF( pt(ji,jj,jl) > 0._wp .AND. pt_ups(ji,jj,jl) <= 0._wp ) THEN 
    1306                   zbup(ji,jj) = pt(ji,jj,jl) 
    1307                   zbdo(ji,jj) = pt(ji,jj,jl) 
    1308                ELSE 
    1309                   zbup(ji,jj) = MAX( pt(ji,jj,jl) , pt_ups(ji,jj,jl) ) 
    1310                   zbdo(ji,jj) = MIN( pt(ji,jj,jl) , pt_ups(ji,jj,jl) ) 
    1311                ENDIF 
    1312             END DO 
    1313          END DO 
    1314  
    1315          DO jj = 2, jpjm1 
    1316             DO ji = fs_2, fs_jpim1   ! vector opt. 
    1317                ! 
    1318                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 
    1319                zdo  = MIN( zbdo(ji,jj), zbdo(ji-1,jj), zbdo(ji+1,jj), zbdo(ji,jj-1), zbdo(ji,jj+1) ) 
    1320                ! 
    1321                zpos = MAX( 0._wp, pfu_ho(ji-1,jj  ,jl) ) - MIN( 0._wp, pfu_ho(ji  ,jj  ,jl) ) &  ! positive/negative part of the flux 
    1322                   & + MAX( 0._wp, pfv_ho(ji  ,jj-1,jl) ) - MIN( 0._wp, pfv_ho(ji  ,jj  ,jl) ) 
    1323                zneg = MAX( 0._wp, pfu_ho(ji  ,jj  ,jl) ) - MIN( 0._wp, pfu_ho(ji-1,jj  ,jl) ) & 
    1324                   & + MAX( 0._wp, pfv_ho(ji  ,jj  ,jl) ) - MIN( 0._wp, pfv_ho(ji  ,jj-1,jl) ) 
    1325                ! 
    1326                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) ) & 
    1327                   &          ) * ( 1. - pamsk ) 
    1328                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) ) & 
    1329                   &          ) * ( 1. - pamsk ) 
    1330                ! 
    1331                !                                  ! up & down beta terms 
    1332                ! 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 !!!) 
    1333                IF( zpos > epsi10 ) THEN ; zbetup(ji,jj,jl) = MAX( 0._wp, zup - pt_ups(ji,jj,jl) ) / zpos * e1e2t(ji,jj) * z1_dt 
    1334                ELSE                     ; zbetup(ji,jj,jl) = 0._wp ! zbig 
    1335                ENDIF 
    1336                ! 
    1337                IF( zneg > epsi10 ) THEN ; zbetdo(ji,jj,jl) = MAX( 0._wp, pt_ups(ji,jj,jl) - zdo ) / zneg * e1e2t(ji,jj) * z1_dt 
    1338                ELSE                     ; zbetdo(ji,jj,jl) = 0._wp ! zbig 
    1339                ENDIF 
    1340                ! 
    1341                ! if all the points are outside ice cover 
    1342                IF( zup == -zbig )   zbetup(ji,jj,jl) = 0._wp ! zbig 
    1343                IF( zdo ==  zbig )   zbetdo(ji,jj,jl) = 0._wp ! zbig             
    1344                ! 
    1345             END DO 
    1346          END DO 
     1197         DO_2D_11_11 
     1198            IF    ( pt(ji,jj,jl) <= 0._wp .AND. pt_ups(ji,jj,jl) <= 0._wp ) THEN 
     1199               zbup(ji,jj) = -zbig 
     1200               zbdo(ji,jj) =  zbig 
     1201            ELSEIF( pt(ji,jj,jl) <= 0._wp .AND. pt_ups(ji,jj,jl) > 0._wp ) THEN 
     1202               zbup(ji,jj) = pt_ups(ji,jj,jl) 
     1203               zbdo(ji,jj) = pt_ups(ji,jj,jl) 
     1204            ELSEIF( pt(ji,jj,jl) > 0._wp .AND. pt_ups(ji,jj,jl) <= 0._wp ) THEN 
     1205               zbup(ji,jj) = pt(ji,jj,jl) 
     1206               zbdo(ji,jj) = pt(ji,jj,jl) 
     1207            ELSE 
     1208               zbup(ji,jj) = MAX( pt(ji,jj,jl) , pt_ups(ji,jj,jl) ) 
     1209               zbdo(ji,jj) = MIN( pt(ji,jj,jl) , pt_ups(ji,jj,jl) ) 
     1210            ENDIF 
     1211         END_2D 
     1212 
     1213         DO_2D_00_00 
     1214            ! 
     1215            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 
     1216            zdo  = MIN( zbdo(ji,jj), zbdo(ji-1,jj), zbdo(ji+1,jj), zbdo(ji,jj-1), zbdo(ji,jj+1) ) 
     1217            ! 
     1218            zpos = MAX( 0._wp, pfu_ho(ji-1,jj  ,jl) ) - MIN( 0._wp, pfu_ho(ji  ,jj  ,jl) ) &  ! positive/negative part of the flux 
     1219               & + MAX( 0._wp, pfv_ho(ji  ,jj-1,jl) ) - MIN( 0._wp, pfv_ho(ji  ,jj  ,jl) ) 
     1220            zneg = MAX( 0._wp, pfu_ho(ji  ,jj  ,jl) ) - MIN( 0._wp, pfu_ho(ji-1,jj  ,jl) ) & 
     1221               & + MAX( 0._wp, pfv_ho(ji  ,jj  ,jl) ) - MIN( 0._wp, pfv_ho(ji  ,jj-1,jl) ) 
     1222            ! 
     1223            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) ) & 
     1224               &          ) * ( 1. - pamsk ) 
     1225            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) ) & 
     1226               &          ) * ( 1. - pamsk ) 
     1227            ! 
     1228            !                                  ! up & down beta terms 
     1229            ! 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 !!!) 
     1230            IF( zpos > epsi10 ) THEN ; zbetup(ji,jj,jl) = MAX( 0._wp, zup - pt_ups(ji,jj,jl) ) / zpos * e1e2t(ji,jj) * z1_dt 
     1231            ELSE                     ; zbetup(ji,jj,jl) = 0._wp ! zbig 
     1232            ENDIF 
     1233            ! 
     1234            IF( zneg > epsi10 ) THEN ; zbetdo(ji,jj,jl) = MAX( 0._wp, pt_ups(ji,jj,jl) - zdo ) / zneg * e1e2t(ji,jj) * z1_dt 
     1235            ELSE                     ; zbetdo(ji,jj,jl) = 0._wp ! zbig 
     1236            ENDIF 
     1237            ! 
     1238            ! if all the points are outside ice cover 
     1239            IF( zup == -zbig )   zbetup(ji,jj,jl) = 0._wp ! zbig 
     1240            IF( zdo ==  zbig )   zbetdo(ji,jj,jl) = 0._wp ! zbig             
     1241            ! 
     1242         END_2D 
    13471243      END DO 
    13481244      CALL lbc_lnk_multi( 'icedyn_adv_umx', zbetup, 'T', 1., zbetdo, 'T', 1. )   ! lateral boundary cond. (unchanged sign) 
    … …  
    13521248      ! --------------------------------- 
    13531249      DO jl = 1, jpl 
    1354          DO jj = 1, jpjm1 
    1355             DO ji = 1, fs_jpim1   ! vector opt. 
    1356                zau = MIN( 1._wp , zbetdo(ji,jj,jl) , zbetup(ji+1,jj,jl) ) 
    1357                zbu = MIN( 1._wp , zbetup(ji,jj,jl) , zbetdo(ji+1,jj,jl) ) 
    1358                zcu = 0.5_wp + SIGN( 0.5_wp , pfu_ho(ji,jj,jl) ) 
    1359                ! 
    1360                zcoef = ( zcu * zau + ( 1._wp - zcu ) * zbu ) 
    1361                ! 
    1362                pfu_ho(ji,jj,jl) = pfu_ho(ji,jj,jl) * zcoef + pfu_ups(ji,jj,jl) 
    1363                ! 
    1364             END DO 
    1365          END DO 
    1366  
    1367          DO jj = 1, jpjm1 
    1368             DO ji = 1, fs_jpim1   ! vector opt. 
    1369                zav = MIN( 1._wp , zbetdo(ji,jj,jl) , zbetup(ji,jj+1,jl) ) 
    1370                zbv = MIN( 1._wp , zbetup(ji,jj,jl) , zbetdo(ji,jj+1,jl) ) 
    1371                zcv = 0.5_wp + SIGN( 0.5_wp , pfv_ho(ji,jj,jl) ) 
    1372                ! 
    1373                zcoef = ( zcv * zav + ( 1._wp - zcv ) * zbv ) 
    1374                ! 
    1375                pfv_ho(ji,jj,jl) = pfv_ho(ji,jj,jl) * zcoef + pfv_ups(ji,jj,jl) 
    1376                ! 
    1377             END DO 
    1378          END DO 
     1250         DO_2D_10_10 
     1251            zau = MIN( 1._wp , zbetdo(ji,jj,jl) , zbetup(ji+1,jj,jl) ) 
     1252            zbu = MIN( 1._wp , zbetup(ji,jj,jl) , zbetdo(ji+1,jj,jl) ) 
     1253            zcu = 0.5_wp + SIGN( 0.5_wp , pfu_ho(ji,jj,jl) ) 
     1254            ! 
     1255            zcoef = ( zcu * zau + ( 1._wp - zcu ) * zbu ) 
     1256            ! 
     1257            pfu_ho(ji,jj,jl) = pfu_ho(ji,jj,jl) * zcoef + pfu_ups(ji,jj,jl) 
     1258            ! 
     1259         END_2D 
     1260 
     1261         DO_2D_10_10 
     1262            zav = MIN( 1._wp , zbetdo(ji,jj,jl) , zbetup(ji,jj+1,jl) ) 
     1263            zbv = MIN( 1._wp , zbetup(ji,jj,jl) , zbetdo(ji,jj+1,jl) ) 
     1264            zcv = 0.5_wp + SIGN( 0.5_wp , pfv_ho(ji,jj,jl) ) 
     1265            ! 
     1266            zcoef = ( zcv * zav + ( 1._wp - zcv ) * zbv ) 
     1267            ! 
     1268            pfv_ho(ji,jj,jl) = pfv_ho(ji,jj,jl) * zcoef + pfv_ups(ji,jj,jl) 
     1269            ! 
     1270         END_2D 
    13791271 
    13801272      END DO 
    … …  
    14011293      ! 
    14021294      DO jl = 1, jpl 
    1403          DO jj = 2, jpjm1 
    1404             DO ji = fs_2, fs_jpim1   ! vector opt. 
    1405                zslpx(ji,jj,jl) = ( pt(ji+1,jj,jl) - pt(ji,jj,jl) ) * umask(ji,jj,1) 
    1406             END DO 
    1407          END DO 
     1295         DO_2D_00_00 
     1296            zslpx(ji,jj,jl) = ( pt(ji+1,jj,jl) - pt(ji,jj,jl) ) * umask(ji,jj,1) 
     1297         END_2D 
    14081298      END DO 
    14091299      CALL lbc_lnk( 'icedyn_adv_umx', zslpx, 'U', -1.)   ! lateral boundary cond. 
    14101300       
    14111301      DO jl = 1, jpl 
    1412          DO jj = 2, jpjm1 
    1413             DO ji = fs_2, fs_jpim1   ! vector opt. 
    1414                uCFL = pdt * ABS( pu(ji,jj) ) * r1_e1e2t(ji,jj) 
    1415                 
    1416                Rjm = zslpx(ji-1,jj,jl) 
    1417                Rj  = zslpx(ji  ,jj,jl) 
    1418                Rjp = zslpx(ji+1,jj,jl) 
    1419  
    1420                IF( np_limiter == 3 ) THEN 
    1421  
    1422                   IF( pu(ji,jj) > 0. ) THEN   ;   Rr = Rjm 
    1423                   ELSE                        ;   Rr = Rjp 
     1302         DO_2D_00_00 
     1303            uCFL = pdt * ABS( pu(ji,jj) ) * r1_e1e2t(ji,jj) 
     1304             
     1305            Rjm = zslpx(ji-1,jj,jl) 
     1306            Rj  = zslpx(ji  ,jj,jl) 
     1307            Rjp = zslpx(ji+1,jj,jl) 
     1308 
     1309            IF( np_limiter == 3 ) THEN 
     1310 
     1311               IF( pu(ji,jj) > 0. ) THEN   ;   Rr = Rjm 
     1312               ELSE                        ;   Rr = Rjp 
     1313               ENDIF 
     1314 
     1315               zh3 = pfu_ho(ji,jj,jl) - pfu_ups(ji,jj,jl)      
     1316               IF( Rj > 0. ) THEN 
     1317                  zlimiter =  MAX( 0., MIN( zh3, MAX(-Rr * 0.5 * ABS(pu(ji,jj)),  & 
     1318                     &        MIN( 2. * Rr * 0.5 * ABS(pu(ji,jj)),  zh3,  1.5 * Rj * 0.5 * ABS(pu(ji,jj)) ) ) ) ) 
     1319               ELSE 
     1320                  zlimiter = -MAX( 0., MIN(-zh3, MAX( Rr * 0.5 * ABS(pu(ji,jj)),  & 
     1321                     &        MIN(-2. * Rr * 0.5 * ABS(pu(ji,jj)), -zh3, -1.5 * Rj * 0.5 * ABS(pu(ji,jj)) ) ) ) ) 
     1322               ENDIF 
     1323               pfu_ho(ji,jj,jl) = pfu_ups(ji,jj,jl) + zlimiter 
     1324 
     1325            ELSEIF( np_limiter == 2 ) THEN 
     1326               IF( Rj /= 0. ) THEN 
     1327                  IF( pu(ji,jj) > 0. ) THEN   ;   Cr = Rjm / Rj 
     1328                  ELSE                        ;   Cr = Rjp / Rj 
    14241329                  ENDIF 
    1425  
    1426                   zh3 = pfu_ho(ji,jj,jl) - pfu_ups(ji,jj,jl)      
    1427                   IF( Rj > 0. ) THEN 
    1428                      zlimiter =  MAX( 0., MIN( zh3, MAX(-Rr * 0.5 * ABS(pu(ji,jj)),  & 
    1429                         &        MIN( 2. * Rr * 0.5 * ABS(pu(ji,jj)),  zh3,  1.5 * Rj * 0.5 * ABS(pu(ji,jj)) ) ) ) ) 
    1430                   ELSE 
    1431                      zlimiter = -MAX( 0., MIN(-zh3, MAX( Rr * 0.5 * ABS(pu(ji,jj)),  & 
    1432                         &        MIN(-2. * Rr * 0.5 * ABS(pu(ji,jj)), -zh3, -1.5 * Rj * 0.5 * ABS(pu(ji,jj)) ) ) ) ) 
    1433                   ENDIF 
    1434                   pfu_ho(ji,jj,jl) = pfu_ups(ji,jj,jl) + zlimiter 
    1435  
    1436                ELSEIF( np_limiter == 2 ) THEN 
    1437                   IF( Rj /= 0. ) THEN 
    1438                      IF( pu(ji,jj) > 0. ) THEN   ;   Cr = Rjm / Rj 
    1439                      ELSE                        ;   Cr = Rjp / Rj 
    1440                      ENDIF 
    1441                   ELSE 
    1442                      Cr = 0. 
    1443                   ENDIF 
    1444  
    1445                   ! -- superbee -- 
    1446                   zpsi = MAX( 0., MAX( MIN(1.,2.*Cr), MIN(2.,Cr) ) ) 
    1447                   ! -- van albada 2 -- 
    1448                   !!zpsi = 2.*Cr / (Cr*Cr+1.) 
    1449                   ! -- sweby (with beta=1) -- 
    1450                   !!zpsi = MAX( 0., MAX( MIN(1.,1.*Cr), MIN(1.,Cr) ) ) 
    1451                   ! -- van Leer -- 
    1452                   !!zpsi = ( Cr + ABS(Cr) ) / ( 1. + ABS(Cr) ) 
    1453                   ! -- ospre -- 
    1454                   !!zpsi = 1.5 * ( Cr*Cr + Cr ) / ( Cr*Cr + Cr + 1. ) 
    1455                   ! -- koren -- 
    1456                   !!zpsi = MAX( 0., MIN( 2.*Cr, MIN( (1.+2*Cr)/3., 2. ) ) ) 
    1457                   ! -- charm -- 
    1458                   !IF( Cr > 0. ) THEN   ;   zpsi = Cr * (3.*Cr + 1.) / ( (Cr + 1.) * (Cr + 1.) ) 
    1459                   !ELSE                 ;   zpsi = 0. 
    1460                   !ENDIF 
    1461                   ! -- van albada 1 -- 
    1462                   !!zpsi = (Cr*Cr + Cr) / (Cr*Cr +1) 
    1463                   ! -- smart -- 
    1464                   !!zpsi = MAX( 0., MIN( 2.*Cr, MIN( 0.25+0.75*Cr, 4. ) ) ) 
    1465                   ! -- umist -- 
    1466                   !!zpsi = MAX( 0., MIN( 2.*Cr, MIN( 0.25+0.75*Cr, MIN(0.75+0.25*Cr, 2. ) ) ) ) 
    1467  
    1468                   ! high order flux corrected by the limiter 
    1469                   pfu_ho(ji,jj,jl) = pfu_ho(ji,jj,jl) - ABS( pu(ji,jj) ) * ( (1.-zpsi) + uCFL*zpsi ) * Rj * 0.5 
    1470  
     1330               ELSE 
     1331                  Cr = 0. 
    14711332               ENDIF 
    1472             END DO 
    1473          END DO 
     1333 
     1334               ! -- superbee -- 
     1335               zpsi = MAX( 0., MAX( MIN(1.,2.*Cr), MIN(2.,Cr) ) ) 
     1336               ! -- van albada 2 -- 
     1337               !!zpsi = 2.*Cr / (Cr*Cr+1.) 
     1338               ! -- sweby (with beta=1) -- 
     1339               !!zpsi = MAX( 0., MAX( MIN(1.,1.*Cr), MIN(1.,Cr) ) ) 
     1340               ! -- van Leer -- 
     1341               !!zpsi = ( Cr + ABS(Cr) ) / ( 1. + ABS(Cr) ) 
     1342               ! -- ospre -- 
     1343               !!zpsi = 1.5 * ( Cr*Cr + Cr ) / ( Cr*Cr + Cr + 1. ) 
     1344               ! -- koren -- 
     1345               !!zpsi = MAX( 0., MIN( 2.*Cr, MIN( (1.+2*Cr)/3., 2. ) ) ) 
     1346               ! -- charm -- 
     1347               !IF( Cr > 0. ) THEN   ;   zpsi = Cr * (3.*Cr + 1.) / ( (Cr + 1.) * (Cr + 1.) ) 
     1348               !ELSE                 ;   zpsi = 0. 
     1349               !ENDIF 
     1350               ! -- van albada 1 -- 
     1351               !!zpsi = (Cr*Cr + Cr) / (Cr*Cr +1) 
     1352               ! -- smart -- 
     1353               !!zpsi = MAX( 0., MIN( 2.*Cr, MIN( 0.25+0.75*Cr, 4. ) ) ) 
     1354               ! -- umist -- 
     1355               !!zpsi = MAX( 0., MIN( 2.*Cr, MIN( 0.25+0.75*Cr, MIN(0.75+0.25*Cr, 2. ) ) ) ) 
     1356 
     1357               ! high order flux corrected by the limiter 
     1358               pfu_ho(ji,jj,jl) = pfu_ho(ji,jj,jl) - ABS( pu(ji,jj) ) * ( (1.-zpsi) + uCFL*zpsi ) * Rj * 0.5 
     1359 
     1360            ENDIF 
     1361         END_2D 
    14741362      END DO 
    14751363      CALL lbc_lnk( 'icedyn_adv_umx', pfu_ho, 'U', -1.)   ! lateral boundary cond. 
    … …  
    14961384      ! 
    14971385      DO jl = 1, jpl 
    1498          DO jj = 2, jpjm1 
    1499             DO ji = fs_2, fs_jpim1   ! vector opt. 
    1500                zslpy(ji,jj,jl) = ( pt(ji,jj+1,jl) - pt(ji,jj,jl) ) * vmask(ji,jj,1) 
    1501             END DO 
    1502          END DO 
     1386         DO_2D_00_00 
     1387            zslpy(ji,jj,jl) = ( pt(ji,jj+1,jl) - pt(ji,jj,jl) ) * vmask(ji,jj,1) 
     1388         END_2D 
    15031389      END DO 
    15041390      CALL lbc_lnk( 'icedyn_adv_umx', zslpy, 'V', -1.)   ! lateral boundary cond. 
    15051391 
    15061392      DO jl = 1, jpl 
    1507          DO jj = 2, jpjm1 
    1508             DO ji = fs_2, fs_jpim1   ! vector opt. 
    1509                vCFL = pdt * ABS( pv(ji,jj) ) * r1_e1e2t(ji,jj) 
    1510  
    1511                Rjm = zslpy(ji,jj-1,jl) 
    1512                Rj  = zslpy(ji,jj  ,jl) 
    1513                Rjp = zslpy(ji,jj+1,jl) 
    1514  
    1515                IF( np_limiter == 3 ) THEN 
    1516  
    1517                   IF( pv(ji,jj) > 0. ) THEN   ;   Rr = Rjm 
    1518                   ELSE                        ;   Rr = Rjp 
     1393         DO_2D_00_00 
     1394            vCFL = pdt * ABS( pv(ji,jj) ) * r1_e1e2t(ji,jj) 
     1395 
     1396            Rjm = zslpy(ji,jj-1,jl) 
     1397            Rj  = zslpy(ji,jj  ,jl) 
     1398            Rjp = zslpy(ji,jj+1,jl) 
     1399 
     1400            IF( np_limiter == 3 ) THEN 
     1401 
     1402               IF( pv(ji,jj) > 0. ) THEN   ;   Rr = Rjm 
     1403               ELSE                        ;   Rr = Rjp 
     1404               ENDIF 
     1405 
     1406               zh3 = pfv_ho(ji,jj,jl) - pfv_ups(ji,jj,jl)      
     1407               IF( Rj > 0. ) THEN 
     1408                  zlimiter =  MAX( 0., MIN( zh3, MAX(-Rr * 0.5 * ABS(pv(ji,jj)),  & 
     1409                     &        MIN( 2. * Rr * 0.5 * ABS(pv(ji,jj)),  zh3,  1.5 * Rj * 0.5 * ABS(pv(ji,jj)) ) ) ) ) 
     1410               ELSE 
     1411                  zlimiter = -MAX( 0., MIN(-zh3, MAX( Rr * 0.5 * ABS(pv(ji,jj)),  & 
     1412                     &        MIN(-2. * Rr * 0.5 * ABS(pv(ji,jj)), -zh3, -1.5 * Rj * 0.5 * ABS(pv(ji,jj)) ) ) ) ) 
     1413               ENDIF 
     1414               pfv_ho(ji,jj,jl) = pfv_ups(ji,jj,jl) + zlimiter 
     1415 
     1416            ELSEIF( np_limiter == 2 ) THEN 
     1417 
     1418               IF( Rj /= 0. ) THEN 
     1419                  IF( pv(ji,jj) > 0. ) THEN   ;   Cr = Rjm / Rj 
     1420                  ELSE                        ;   Cr = Rjp / Rj 
    15191421                  ENDIF 
    1520  
    1521                   zh3 = pfv_ho(ji,jj,jl) - pfv_ups(ji,jj,jl)      
    1522                   IF( Rj > 0. ) THEN 
    1523                      zlimiter =  MAX( 0., MIN( zh3, MAX(-Rr * 0.5 * ABS(pv(ji,jj)),  & 
    1524                         &        MIN( 2. * Rr * 0.5 * ABS(pv(ji,jj)),  zh3,  1.5 * Rj * 0.5 * ABS(pv(ji,jj)) ) ) ) ) 
    1525                   ELSE 
    1526                      zlimiter = -MAX( 0., MIN(-zh3, MAX( Rr * 0.5 * ABS(pv(ji,jj)),  & 
    1527                         &        MIN(-2. * Rr * 0.5 * ABS(pv(ji,jj)), -zh3, -1.5 * Rj * 0.5 * ABS(pv(ji,jj)) ) ) ) ) 
    1528                   ENDIF 
    1529                   pfv_ho(ji,jj,jl) = pfv_ups(ji,jj,jl) + zlimiter 
    1530  
    1531                ELSEIF( np_limiter == 2 ) THEN 
    1532  
    1533                   IF( Rj /= 0. ) THEN 
    1534                      IF( pv(ji,jj) > 0. ) THEN   ;   Cr = Rjm / Rj 
    1535                      ELSE                        ;   Cr = Rjp / Rj 
    1536                      ENDIF 
    1537                   ELSE 
    1538                      Cr = 0. 
    1539                   ENDIF 
    1540  
    1541                   ! -- superbee -- 
    1542                   zpsi = MAX( 0., MAX( MIN(1.,2.*Cr), MIN(2.,Cr) ) ) 
    1543                   ! -- van albada 2 -- 
    1544                   !!zpsi = 2.*Cr / (Cr*Cr+1.) 
    1545                   ! -- sweby (with beta=1) -- 
    1546                   !!zpsi = MAX( 0., MAX( MIN(1.,1.*Cr), MIN(1.,Cr) ) ) 
    1547                   ! -- van Leer -- 
    1548                   !!zpsi = ( Cr + ABS(Cr) ) / ( 1. + ABS(Cr) ) 
    1549                   ! -- ospre -- 
    1550                   !!zpsi = 1.5 * ( Cr*Cr + Cr ) / ( Cr*Cr + Cr + 1. ) 
    1551                   ! -- koren -- 
    1552                   !!zpsi = MAX( 0., MIN( 2.*Cr, MIN( (1.+2*Cr)/3., 2. ) ) ) 
    1553                   ! -- charm -- 
    1554                   !IF( Cr > 0. ) THEN   ;   zpsi = Cr * (3.*Cr + 1.) / ( (Cr + 1.) * (Cr + 1.) ) 
    1555                   !ELSE                 ;   zpsi = 0. 
    1556                   !ENDIF 
    1557                   ! -- van albada 1 -- 
    1558                   !!zpsi = (Cr*Cr + Cr) / (Cr*Cr +1) 
    1559                   ! -- smart -- 
    1560                   !!zpsi = MAX( 0., MIN( 2.*Cr, MIN( 0.25+0.75*Cr, 4. ) ) ) 
    1561                   ! -- umist -- 
    1562                   !!zpsi = MAX( 0., MIN( 2.*Cr, MIN( 0.25+0.75*Cr, MIN(0.75+0.25*Cr, 2. ) ) ) ) 
    1563  
    1564                   ! high order flux corrected by the limiter 
    1565                   pfv_ho(ji,jj,jl) = pfv_ho(ji,jj,jl) - ABS( pv(ji,jj) ) * ( (1.-zpsi) + vCFL*zpsi ) * Rj * 0.5 
    1566  
     1422               ELSE 
     1423                  Cr = 0. 
    15671424               ENDIF 
    1568             END DO 
    1569          END DO 
     1425 
     1426               ! -- superbee -- 
     1427               zpsi = MAX( 0., MAX( MIN(1.,2.*Cr), MIN(2.,Cr) ) ) 
     1428               ! -- van albada 2 -- 
     1429               !!zpsi = 2.*Cr / (Cr*Cr+1.) 
     1430               ! -- sweby (with beta=1) -- 
     1431               !!zpsi = MAX( 0., MAX( MIN(1.,1.*Cr), MIN(1.,Cr) ) ) 
     1432               ! -- van Leer -- 
     1433               !!zpsi = ( Cr + ABS(Cr) ) / ( 1. + ABS(Cr) ) 
     1434               ! -- ospre -- 
     1435               !!zpsi = 1.5 * ( Cr*Cr + Cr ) / ( Cr*Cr + Cr + 1. ) 
     1436               ! -- koren -- 
     1437               !!zpsi = MAX( 0., MIN( 2.*Cr, MIN( (1.+2*Cr)/3., 2. ) ) ) 
     1438               ! -- charm -- 
     1439               !IF( Cr > 0. ) THEN   ;   zpsi = Cr * (3.*Cr + 1.) / ( (Cr + 1.) * (Cr + 1.) ) 
     1440               !ELSE                 ;   zpsi = 0. 
     1441               !ENDIF 
     1442               ! -- van albada 1 -- 
     1443               !!zpsi = (Cr*Cr + Cr) / (Cr*Cr +1) 
     1444               ! -- smart -- 
     1445               !!zpsi = MAX( 0., MIN( 2.*Cr, MIN( 0.25+0.75*Cr, 4. ) ) ) 
     1446               ! -- umist -- 
     1447               !!zpsi = MAX( 0., MIN( 2.*Cr, MIN( 0.25+0.75*Cr, MIN(0.75+0.25*Cr, 2. ) ) ) ) 
     1448 
     1449               ! high order flux corrected by the limiter 
     1450               pfv_ho(ji,jj,jl) = pfv_ho(ji,jj,jl) - ABS( pv(ji,jj) ) * ( (1.-zpsi) + vCFL*zpsi ) * Rj * 0.5 
     1451 
     1452            ENDIF 
     1453         END_2D 
    15701454      END DO 
    15711455      CALL lbc_lnk( 'icedyn_adv_umx', pfv_ho, 'V', -1.)   ! lateral boundary cond. 
    … …  
    16041488      ! 
    16051489      DO jl = 1, jpl 
    1606          DO jj = 1, jpj 
    1607             DO ji = 1, jpi 
    1608                IF ( pv_i(ji,jj,jl) > 0._wp ) THEN 
     1490         DO_2D_11_11 
     1491            IF ( pv_i(ji,jj,jl) > 0._wp ) THEN 
     1492               ! 
     1493               !                               ! -- check h_ip -- ! 
     1494               ! if h_ip is larger than the surrounding 9 pts => reduce h_ip and increase a_ip 
     1495               IF( ln_pnd_LEV .AND. pv_ip(ji,jj,jl) > 0._wp ) THEN 
     1496                  zhip = pv_ip(ji,jj,jl) / MAX( epsi20, pa_ip(ji,jj,jl) ) 
     1497                  IF( zhip > phip_max(ji,jj,jl) .AND. pa_ip(ji,jj,jl) < 0.15 ) THEN 
     1498                     pa_ip(ji,jj,jl) = pv_ip(ji,jj,jl) / phip_max(ji,jj,jl) 
     1499                  ENDIF 
     1500               ENDIF 
     1501               ! 
     1502               !                               ! -- check h_i -- ! 
     1503               ! if h_i is larger than the surrounding 9 pts => reduce h_i and increase a_i 
     1504               zhi = pv_i(ji,jj,jl) / pa_i(ji,jj,jl) 
     1505               IF( zhi > phi_max(ji,jj,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 
     1506                  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) 
     1507               ENDIF 
     1508               ! 
     1509               !                               ! -- check h_s -- ! 
     1510               ! if h_s is larger than the surrounding 9 pts => put the snow excess in the ocean 
     1511               zhs = pv_s(ji,jj,jl) / pa_i(ji,jj,jl) 
     1512               IF( pv_s(ji,jj,jl) > 0._wp .AND. zhs > phs_max(ji,jj,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 
     1513                  zfra = phs_max(ji,jj,jl) / MAX( zhs, epsi20 ) 
    16091514                  ! 
    1610                   !                               ! -- check h_ip -- ! 
    1611                   ! if h_ip is larger than the surrounding 9 pts => reduce h_ip and increase a_ip 
    1612                   IF( ln_pnd_LEV .AND. pv_ip(ji,jj,jl) > 0._wp ) THEN 
    1613                      zhip = pv_ip(ji,jj,jl) / MAX( epsi20, pa_ip(ji,jj,jl) ) 
    1614                      IF( zhip > phip_max(ji,jj,jl) .AND. pa_ip(ji,jj,jl) < 0.15 ) THEN 
    1615                         pa_ip(ji,jj,jl) = pv_ip(ji,jj,jl) / phip_max(ji,jj,jl) 
    1616                      ENDIF 
    1617                   ENDIF 
     1515                  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 
     1516                  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 
    16181517                  ! 
    1619                   !                               ! -- check h_i -- ! 
    1620                   ! if h_i is larger than the surrounding 9 pts => reduce h_i and increase a_i 
    1621                   zhi = pv_i(ji,jj,jl) / pa_i(ji,jj,jl) 
    1622                   IF( zhi > phi_max(ji,jj,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 
    1623                      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) 
    1624                   ENDIF 
    1625                   ! 
    1626                   !                               ! -- check h_s -- ! 
    1627                   ! if h_s is larger than the surrounding 9 pts => put the snow excess in the ocean 
    1628                   zhs = pv_s(ji,jj,jl) / pa_i(ji,jj,jl) 
    1629                   IF( pv_s(ji,jj,jl) > 0._wp .AND. zhs > phs_max(ji,jj,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 
    1630                      zfra = phs_max(ji,jj,jl) / MAX( zhs, epsi20 ) 
    1631                      ! 
    1632                      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 
    1633                      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 
    1634                      ! 
    1635                      pe_s(ji,jj,1:nlay_s,jl) = pe_s(ji,jj,1:nlay_s,jl) * zfra 
    1636                      pv_s(ji,jj,jl)          = pa_i(ji,jj,jl) * phs_max(ji,jj,jl) 
    1637                   ENDIF            
    1638                   !                   
    1639                   !                               ! -- check s_i -- ! 
    1640                   ! if s_i is larger than the surrounding 9 pts => put salt excess in the ocean 
    1641                   zsi = psv_i(ji,jj,jl) / pv_i(ji,jj,jl) 
    1642                   IF( zsi > psi_max(ji,jj,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 
    1643                      zfra = psi_max(ji,jj,jl) / zsi 
    1644                      sfx_res(ji,jj) = sfx_res(ji,jj) + psv_i(ji,jj,jl) * ( 1._wp - zfra ) * rhoi * z1_dt 
    1645                      psv_i(ji,jj,jl) = psv_i(ji,jj,jl) * zfra 
    1646                   ENDIF 
    1647                   ! 
     1518                  pe_s(ji,jj,1:nlay_s,jl) = pe_s(ji,jj,1:nlay_s,jl) * zfra 
     1519                  pv_s(ji,jj,jl)          = pa_i(ji,jj,jl) * phs_max(ji,jj,jl) 
     1520               ENDIF            
     1521               !                   
     1522               !                               ! -- check s_i -- ! 
     1523               ! if s_i is larger than the surrounding 9 pts => put salt excess in the ocean 
     1524               zsi = psv_i(ji,jj,jl) / pv_i(ji,jj,jl) 
     1525               IF( zsi > psi_max(ji,jj,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 
     1526                  zfra = psi_max(ji,jj,jl) / zsi 
     1527                  sfx_res(ji,jj) = sfx_res(ji,jj) + psv_i(ji,jj,jl) * ( 1._wp - zfra ) * rhoi * z1_dt 
     1528                  psv_i(ji,jj,jl) = psv_i(ji,jj,jl) * zfra 
    16481529               ENDIF 
    1649             END DO 
    1650          END DO 
     1530               ! 
     1531            ENDIF 
     1532         END_2D 
    16511533      END DO  
    16521534      ! 
    16531535      !                                           ! -- check e_i/v_i -- ! 
    16541536      DO jl = 1, jpl 
    1655          DO jk = 1, nlay_i 
    1656             DO jj = 1, jpj 
    1657                DO ji = 1, jpi 
    1658                   IF ( pv_i(ji,jj,jl) > 0._wp ) THEN 
    1659                      ! if e_i/v_i is larger than the surrounding 9 pts => put the heat excess in the ocean 
    1660                      zei = pe_i(ji,jj,jk,jl) / pv_i(ji,jj,jl) 
    1661                      IF( zei > pei_max(ji,jj,jk,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 
    1662                         zfra = pei_max(ji,jj,jk,jl) / zei 
    1663                         hfx_res(ji,jj) = hfx_res(ji,jj) - pe_i(ji,jj,jk,jl) * ( 1._wp - zfra ) * z1_dt ! W.m-2 <0 
    1664                         pe_i(ji,jj,jk,jl) = pe_i(ji,jj,jk,jl) * zfra 
    1665                      ENDIF 
    1666                   ENDIF 
    1667                END DO 
    1668             END DO 
    1669          END DO 
     1537         DO_3D_11_11( 1, nlay_i ) 
     1538            IF ( pv_i(ji,jj,jl) > 0._wp ) THEN 
     1539               ! if e_i/v_i is larger than the surrounding 9 pts => put the heat excess in the ocean 
     1540               zei = pe_i(ji,jj,jk,jl) / pv_i(ji,jj,jl) 
     1541               IF( zei > pei_max(ji,jj,jk,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 
     1542                  zfra = pei_max(ji,jj,jk,jl) / zei 
     1543                  hfx_res(ji,jj) = hfx_res(ji,jj) - pe_i(ji,jj,jk,jl) * ( 1._wp - zfra ) * z1_dt ! W.m-2 <0 
     1544                  pe_i(ji,jj,jk,jl) = pe_i(ji,jj,jk,jl) * zfra 
     1545               ENDIF 
     1546            ENDIF 
     1547         END_3D 
    16701548      END DO 
    16711549      !                                           ! -- check e_s/v_s -- ! 
    16721550      DO jl = 1, jpl 
    1673          DO jk = 1, nlay_s 
    1674             DO jj = 1, jpj 
    1675                DO ji = 1, jpi 
    1676                   IF ( pv_s(ji,jj,jl) > 0._wp ) THEN 
    1677                      ! if e_s/v_s is larger than the surrounding 9 pts => put the heat excess in the ocean 
    1678                      zes = pe_s(ji,jj,jk,jl) / pv_s(ji,jj,jl) 
    1679                      IF( zes > pes_max(ji,jj,jk,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 
    1680                         zfra = pes_max(ji,jj,jk,jl) / zes 
    1681                         hfx_res(ji,jj) = hfx_res(ji,jj) - pe_s(ji,jj,jk,jl) * ( 1._wp - zfra ) * z1_dt ! W.m-2 <0 
    1682                         pe_s(ji,jj,jk,jl) = pe_s(ji,jj,jk,jl) * zfra 
    1683                      ENDIF 
    1684                   ENDIF 
    1685                END DO 
    1686             END DO 
    1687          END DO 
     1551         DO_3D_11_11( 1, nlay_s ) 
     1552            IF ( pv_s(ji,jj,jl) > 0._wp ) THEN 
     1553               ! if e_s/v_s is larger than the surrounding 9 pts => put the heat excess in the ocean 
     1554               zes = pe_s(ji,jj,jk,jl) / pv_s(ji,jj,jl) 
     1555               IF( zes > pes_max(ji,jj,jk,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 
     1556                  zfra = pes_max(ji,jj,jk,jl) / zes 
     1557                  hfx_res(ji,jj) = hfx_res(ji,jj) - pe_s(ji,jj,jk,jl) * ( 1._wp - zfra ) * z1_dt ! W.m-2 <0 
     1558                  pe_s(ji,jj,jk,jl) = pe_s(ji,jj,jk,jl) * zfra 
     1559               ENDIF 
     1560            ENDIF 
     1561         END_3D 
    16881562      END DO 
    16891563      ! 
    … …  
    17181592      ! -- check snow load -- ! 
    17191593      DO jl = 1, jpl 
    1720          DO jj = 1, jpj 
    1721             DO ji = 1, jpi 
    1722                IF ( pv_i(ji,jj,jl) > 0._wp ) THEN 
    1723                   ! 
    1724                   zvs_excess = MAX( 0._wp, pv_s(ji,jj,jl) - pv_i(ji,jj,jl) * (rau0-rhoi) * r1_rhos ) 
    1725                   ! 
    1726                   IF( zvs_excess > 0._wp ) THEN   ! snow-ice interface deplets below the ocean surface 
    1727                      ! put snow excess in the ocean 
    1728                      zfra = ( pv_s(ji,jj,jl) - zvs_excess ) / MAX( pv_s(ji,jj,jl), epsi20 ) 
    1729                      wfx_res(ji,jj) = wfx_res(ji,jj) + zvs_excess * rhos * z1_dt 
    1730                      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 
    1731                      ! correct snow volume and heat content 
    1732                      pe_s(ji,jj,1:nlay_s,jl) = pe_s(ji,jj,1:nlay_s,jl) * zfra 
    1733                      pv_s(ji,jj,jl)          = pv_s(ji,jj,jl) - zvs_excess 
    1734                   ENDIF 
    1735                   ! 
     1594         DO_2D_11_11 
     1595            IF ( pv_i(ji,jj,jl) > 0._wp ) THEN 
     1596               ! 
     1597               zvs_excess = MAX( 0._wp, pv_s(ji,jj,jl) - pv_i(ji,jj,jl) * (rau0-rhoi) * r1_rhos ) 
     1598               ! 
     1599               IF( zvs_excess > 0._wp ) THEN   ! snow-ice interface deplets below the ocean surface 
     1600                  ! put snow excess in the ocean 
     1601                  zfra = ( pv_s(ji,jj,jl) - zvs_excess ) / MAX( pv_s(ji,jj,jl), epsi20 ) 
     1602                  wfx_res(ji,jj) = wfx_res(ji,jj) + zvs_excess * rhos * z1_dt 
     1603                  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 
     1604                  ! correct snow volume and heat content 
     1605                  pe_s(ji,jj,1:nlay_s,jl) = pe_s(ji,jj,1:nlay_s,jl) * zfra 
     1606                  pv_s(ji,jj,jl)          = pv_s(ji,jj,jl) - zvs_excess 
    17361607               ENDIF 
    1737             END DO 
    1738          END DO 
     1608               ! 
     1609            ENDIF 
     1610         END_2D 
    17391611      END DO 
    17401612      ! 

  • NEMO/branches/2020/temporary_r4_trunk/src/ICE/icedyn_rdgrft.F90

    r13466 r13469  
    159159      npti = 0   ;   nptidx(:) = 0 
    160160      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 
     161      DO_2D_11_11 
     162         IF ( at_i(ji,jj) > epsi10 ) THEN 
     163            npti           = npti + 1 
     164            nptidx( npti ) = (jj - 1) * jpi + ji 
     165         ENDIF 
     166      END_2D 
    169167       
    170168      !-------------------------------------------------------- 
    … …  
    777775      !                              !--------------------------------------------------! 
    778776      CASE( 1 )               !--- Spatial smoothing 
    779          DO jj = 2, jpjm1 
    780             DO ji = 2, jpim1 
    781                IF ( SUM( a_i(ji,jj,:) ) > 0._wp ) THEN  
    782                   zworka(ji,jj) = ( 4.0 * strength(ji,jj)              & 
    783                      &                  + strength(ji-1,jj) * tmask(ji-1,jj,1) + strength(ji+1,jj) * tmask(ji+1,jj,1) &   
    784                      &                  + strength(ji,jj-1) * tmask(ji,jj-1,1) + strength(ji,jj+1) * tmask(ji,jj+1,1) & 
    785                      &            ) / ( 4.0 + tmask(ji-1,jj,1) + tmask(ji+1,jj,1) + tmask(ji,jj-1,1) + tmask(ji,jj+1,1) ) 
    786                ELSE 
    787                   zworka(ji,jj) = 0._wp 
    788                ENDIF 
    789             END DO 
    790          END DO 
     777         DO_2D_00_00 
     778            IF ( SUM( a_i(ji,jj,:) ) > 0._wp ) THEN  
     779               zworka(ji,jj) = ( 4.0 * strength(ji,jj)              & 
     780                  &                  + strength(ji-1,jj) * tmask(ji-1,jj,1) + strength(ji+1,jj) * tmask(ji+1,jj,1) &   
     781                  &                  + strength(ji,jj-1) * tmask(ji,jj-1,1) + strength(ji,jj+1) * tmask(ji,jj+1,1) & 
     782                  &            ) / ( 4.0 + tmask(ji-1,jj,1) + tmask(ji+1,jj,1) + tmask(ji,jj-1,1) + tmask(ji,jj+1,1) ) 
     783            ELSE 
     784               zworka(ji,jj) = 0._wp 
     785            ENDIF 
     786         END_2D 
    791787          
    792          DO jj = 2, jpjm1 
    793             DO ji = 2, jpim1 
    794                strength(ji,jj) = zworka(ji,jj) 
    795             END DO 
    796          END DO 
     788         DO_2D_00_00 
     789            strength(ji,jj) = zworka(ji,jj) 
     790         END_2D 
    797791         CALL lbc_lnk( 'icedyn_rdgrft', strength, 'T', 1. ) 
    798792         ! 
    … …  
    803797         ENDIF 
    804798         ! 
    805          DO jj = 2, jpjm1 
    806             DO ji = 2, jpim1 
    807                IF ( SUM( a_i(ji,jj,:) ) > 0._wp ) THEN  
    808                   itframe = 1 ! number of time steps for the running mean 
    809                   IF ( zstrp1(ji,jj) > 0._wp ) itframe = itframe + 1 
    810                   IF ( zstrp2(ji,jj) > 0._wp ) itframe = itframe + 1 
    811                   zp = ( strength(ji,jj) + zstrp1(ji,jj) + zstrp2(ji,jj) ) / itframe 
    812                   zstrp2  (ji,jj) = zstrp1  (ji,jj) 
    813                   zstrp1  (ji,jj) = strength(ji,jj) 
    814                   strength(ji,jj) = zp 
    815                ENDIF 
    816             END DO 
    817          END DO 
     799         DO_2D_00_00 
     800            IF ( SUM( a_i(ji,jj,:) ) > 0._wp ) THEN  
     801               itframe = 1 ! number of time steps for the running mean 
     802               IF ( zstrp1(ji,jj) > 0._wp ) itframe = itframe + 1 
     803               IF ( zstrp2(ji,jj) > 0._wp ) itframe = itframe + 1 
     804               zp = ( strength(ji,jj) + zstrp1(ji,jj) + zstrp2(ji,jj) ) / itframe 
     805               zstrp2  (ji,jj) = zstrp1  (ji,jj) 
     806               zstrp1  (ji,jj) = strength(ji,jj) 
     807               strength(ji,jj) = zp 
     808            ENDIF 
     809         END_2D 
    818810         CALL lbc_lnk( 'icedyn_rdgrft', strength, 'T', 1. ) 
    819811         ! 

  • NEMO/branches/2020/temporary_r4_trunk/src/ICE/icedyn_rhg_evp.F90

    r13467 r13469  
    182182      ! for diagnostics and convergence tests 
    183183      ALLOCATE( zmsk00(jpi,jpj), zmsk15(jpi,jpj) ) 
    184       DO jj = 1, jpj 
    185          DO ji = 1, jpi 
    186             zmsk00(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi06  ) ) ! 1 if ice    , 0 if no ice 
    187             zmsk15(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - 0.15_wp ) ) ! 1 if 15% ice, 0 if less 
    188          END DO 
    189       END DO 
     184      DO_2D_11_11 
     185         zmsk00(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi06  ) ) ! 1 if ice    , 0 if no ice 
     186         zmsk15(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - 0.15_wp ) ) ! 1 if 15% ice, 0 if less 
     187      END_2D 
    190188      ! 
    191189      !!gm for Clem:  OPTIMIZATION:  I think zfmask can be computed one for all at the initialization.... 
    … …  
    194192      !------------------------------------------------------------------------------! 
    195193      ! ocean/land mask 
    196       DO jj = 1, jpjm1 
    197          DO ji = 1, jpim1      ! NO vector opt. 
    198             zfmask(ji,jj) = tmask(ji,jj,1) * tmask(ji+1,jj,1) * tmask(ji,jj+1,1) * tmask(ji+1,jj+1,1) 
    199          END DO 
    200       END DO 
     194      DO_2D_10_10 
     195         zfmask(ji,jj) = tmask(ji,jj,1) * tmask(ji+1,jj,1) * tmask(ji,jj+1,1) * tmask(ji+1,jj+1,1) 
     196      END_2D 
    201197      CALL lbc_lnk( 'icedyn_rhg_evp', zfmask, 'F', 1._wp ) 
    202198 
    203199      ! Lateral boundary conditions on velocity (modify zfmask) 
    204       DO jj = 2, jpjm1 
    205          DO ji = fs_2, fs_jpim1   ! vector opt. 
    206             IF( zfmask(ji,jj) == 0._wp ) THEN 
    207                zfmask(ji,jj) = rn_ishlat * MIN( 1._wp , MAX( umask(ji,jj,1), umask(ji,jj+1,1), & 
    208                   &                                          vmask(ji,jj,1), vmask(ji+1,jj,1) ) ) 
    209             ENDIF 
    210          END DO 
    211       END DO 
     200      DO_2D_00_00 
     201         IF( zfmask(ji,jj) == 0._wp ) THEN 
     202            zfmask(ji,jj) = rn_ishlat * MIN( 1._wp , MAX( umask(ji,jj,1), umask(ji,jj+1,1), & 
     203               &                                          vmask(ji,jj,1), vmask(ji+1,jj,1) ) ) 
     204         ENDIF 
     205      END_2D 
    212206      DO jj = 2, jpjm1 
    213207         IF( zfmask(1,jj) == 0._wp ) THEN 
    … …  
    272266      zsshdyn(:,:) = ice_var_sshdyn( ssh_m, snwice_mass, snwice_mass_b) 
    273267 
    274       DO jj = 2, jpjm1 
    275          DO ji = fs_2, fs_jpim1 
    276  
    277             ! ice fraction at U-V points 
    278             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) 
    279             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) 
    280  
    281             ! Ice/snow mass at U-V points 
    282             zm1 = ( rhos * vt_s(ji  ,jj  ) + rhoi * vt_i(ji  ,jj  ) ) 
    283             zm2 = ( rhos * vt_s(ji+1,jj  ) + rhoi * vt_i(ji+1,jj  ) ) 
    284             zm3 = ( rhos * vt_s(ji  ,jj+1) + rhoi * vt_i(ji  ,jj+1) ) 
    285             zmassU = 0.5_wp * ( zm1 * e1e2t(ji,jj) + zm2 * e1e2t(ji+1,jj) ) * r1_e1e2u(ji,jj) * umask(ji,jj,1) 
    286             zmassV = 0.5_wp * ( zm1 * e1e2t(ji,jj) + zm3 * e1e2t(ji,jj+1) ) * r1_e1e2v(ji,jj) * vmask(ji,jj,1) 
    287  
    288             ! Ocean currents at U-V points 
    289             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) 
    290             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) 
    291  
    292             ! Coriolis at T points (m*f) 
    293             zmf(ji,jj)      = zm1 * ff_t(ji,jj) 
    294  
    295             ! dt/m at T points (for alpha and beta coefficients) 
    296             zdt_m(ji,jj)    = zdtevp / MAX( zm1, zmmin ) 
    297              
    298             ! m/dt 
    299             zmU_t(ji,jj)    = zmassU * z1_dtevp 
    300             zmV_t(ji,jj)    = zmassV * z1_dtevp 
    301              
    302             ! Drag ice-atm. 
    303             ztaux_ai(ji,jj) = zaU(ji,jj) * utau_ice(ji,jj) 
    304             ztauy_ai(ji,jj) = zaV(ji,jj) * vtau_ice(ji,jj) 
    305  
    306             ! Surface pressure gradient (- m*g*GRAD(ssh)) at U-V points 
    307             zspgU(ji,jj)    = - zmassU * grav * ( zsshdyn(ji+1,jj) - zsshdyn(ji,jj) ) * r1_e1u(ji,jj) 
    308             zspgV(ji,jj)    = - zmassV * grav * ( zsshdyn(ji,jj+1) - zsshdyn(ji,jj) ) * r1_e2v(ji,jj) 
    309  
    310             ! masks 
    311             zmsk00x(ji,jj) = 1._wp - MAX( 0._wp, SIGN( 1._wp, -zmassU ) )  ! 0 if no ice 
    312             zmsk00y(ji,jj) = 1._wp - MAX( 0._wp, SIGN( 1._wp, -zmassV ) )  ! 0 if no ice 
    313  
    314             ! switches 
    315             IF( zmassU <= zmmin .AND. zaU(ji,jj) <= zamin ) THEN   ;   zmsk01x(ji,jj) = 0._wp 
    316             ELSE                                                   ;   zmsk01x(ji,jj) = 1._wp   ;   ENDIF 
    317             IF( zmassV <= zmmin .AND. zaV(ji,jj) <= zamin ) THEN   ;   zmsk01y(ji,jj) = 0._wp 
    318             ELSE                                                   ;   zmsk01y(ji,jj) = 1._wp   ;   ENDIF 
    319  
    320          END DO 
    321       END DO 
     268      DO_2D_00_00 
     269 
     270         ! ice fraction at U-V points 
     271         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) 
     272         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) 
     273 
     274         ! Ice/snow mass at U-V points 
     275         zm1 = ( rhos * vt_s(ji  ,jj  ) + rhoi * vt_i(ji  ,jj  ) ) 
     276         zm2 = ( rhos * vt_s(ji+1,jj  ) + rhoi * vt_i(ji+1,jj  ) ) 
     277         zm3 = ( rhos * vt_s(ji  ,jj+1) + rhoi * vt_i(ji  ,jj+1) ) 
     278         zmassU = 0.5_wp * ( zm1 * e1e2t(ji,jj) + zm2 * e1e2t(ji+1,jj) ) * r1_e1e2u(ji,jj) * umask(ji,jj,1) 
     279         zmassV = 0.5_wp * ( zm1 * e1e2t(ji,jj) + zm3 * e1e2t(ji,jj+1) ) * r1_e1e2v(ji,jj) * vmask(ji,jj,1) 
     280 
     281         ! Ocean currents at U-V points 
     282         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) 
     283         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) 
     284 
     285         ! Coriolis at T points (m*f) 
     286         zmf(ji,jj)      = zm1 * ff_t(ji,jj) 
     287 
     288         ! dt/m at T points (for alpha and beta coefficients) 
     289         zdt_m(ji,jj)    = zdtevp / MAX( zm1, zmmin ) 
     290          
     291         ! m/dt 
     292         zmU_t(ji,jj)    = zmassU * z1_dtevp 
     293         zmV_t(ji,jj)    = zmassV * z1_dtevp 
     294          
     295         ! Drag ice-atm. 
     296         ztaux_ai(ji,jj) = zaU(ji,jj) * utau_ice(ji,jj) 
     297         ztauy_ai(ji,jj) = zaV(ji,jj) * vtau_ice(ji,jj) 
     298 
     299         ! Surface pressure gradient (- m*g*GRAD(ssh)) at U-V points 
     300         zspgU(ji,jj)    = - zmassU * grav * ( zsshdyn(ji+1,jj) - zsshdyn(ji,jj) ) * r1_e1u(ji,jj) 
     301         zspgV(ji,jj)    = - zmassV * grav * ( zsshdyn(ji,jj+1) - zsshdyn(ji,jj) ) * r1_e2v(ji,jj) 
     302 
     303         ! masks 
     304         zmsk00x(ji,jj) = 1._wp - MAX( 0._wp, SIGN( 1._wp, -zmassU ) )  ! 0 if no ice 
     305         zmsk00y(ji,jj) = 1._wp - MAX( 0._wp, SIGN( 1._wp, -zmassV ) )  ! 0 if no ice 
     306 
     307         ! switches 
     308         IF( zmassU <= zmmin .AND. zaU(ji,jj) <= zamin ) THEN   ;   zmsk01x(ji,jj) = 0._wp 
     309         ELSE                                                   ;   zmsk01x(ji,jj) = 1._wp   ;   ENDIF 
     310         IF( zmassV <= zmmin .AND. zaV(ji,jj) <= zamin ) THEN   ;   zmsk01y(ji,jj) = 0._wp 
     311         ELSE                                                   ;   zmsk01y(ji,jj) = 1._wp   ;   ENDIF 
     312 
     313      END_2D 
    322314      CALL lbc_lnk_multi( 'icedyn_rhg_evp', zmf, 'T', 1., zdt_m, 'T', 1. ) 
    323315      ! 
    … …  
    325317      ! 
    326318      IF( ln_landfast_L16 ) THEN         !-- Lemieux 2016 
    327          DO jj = 2, jpjm1 
    328             DO ji = fs_2, fs_jpim1 
    329                ! ice thickness at U-V points 
    330                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) 
    331                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) 
    332                ! ice-bottom stress at U points 
    333                zvCr = zaU(ji,jj) * rn_lf_depfra * hu_n(ji,jj) 
    334                ztaux_base(ji,jj) = - rn_lf_bfr * MAX( 0._wp, zvU - zvCr ) * EXP( -rn_crhg * ( 1._wp - zaU(ji,jj) ) ) 
    335                ! ice-bottom stress at V points 
    336                zvCr = zaV(ji,jj) * rn_lf_depfra * hv_n(ji,jj) 
    337                ztauy_base(ji,jj) = - rn_lf_bfr * MAX( 0._wp, zvV - zvCr ) * EXP( -rn_crhg * ( 1._wp - zaV(ji,jj) ) ) 
    338                ! ice_bottom stress at T points 
    339                zvCr = at_i(ji,jj) * rn_lf_depfra * ht_n(ji,jj) 
    340                tau_icebfr(ji,jj) = - rn_lf_bfr * MAX( 0._wp, vt_i(ji,jj) - zvCr ) * EXP( -rn_crhg * ( 1._wp - at_i(ji,jj) ) ) 
    341             END DO 
    342          END DO 
     319         DO_2D_00_00 
     320            ! ice thickness at U-V points 
     321            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) 
     322            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) 
     323            ! ice-bottom stress at U points 
     324            zvCr = zaU(ji,jj) * rn_lf_depfra * hu_n(ji,jj) 
     325            ztaux_base(ji,jj) = - rn_lf_bfr * MAX( 0._wp, zvU - zvCr ) * EXP( -rn_crhg * ( 1._wp - zaU(ji,jj) ) ) 
     326            ! ice-bottom stress at V points 
     327            zvCr = zaV(ji,jj) * rn_lf_depfra * hv_n(ji,jj) 
     328            ztauy_base(ji,jj) = - rn_lf_bfr * MAX( 0._wp, zvV - zvCr ) * EXP( -rn_crhg * ( 1._wp - zaV(ji,jj) ) ) 
     329            ! ice_bottom stress at T points 
     330            zvCr = at_i(ji,jj) * rn_lf_depfra * ht_n(ji,jj) 
     331            tau_icebfr(ji,jj) = - rn_lf_bfr * MAX( 0._wp, vt_i(ji,jj) - zvCr ) * EXP( -rn_crhg * ( 1._wp - at_i(ji,jj) ) ) 
     332         END_2D 
    343333         CALL lbc_lnk( 'icedyn_rhg_evp', tau_icebfr(:,:), 'T', 1. ) 
    344334         ! 
    345335      ELSE                               !-- no landfast 
    346          DO jj = 2, jpjm1 
    347             DO ji = fs_2, fs_jpim1 
    348                ztaux_base(ji,jj) = 0._wp 
    349                ztauy_base(ji,jj) = 0._wp 
    350             END DO 
    351          END DO 
     336         DO_2D_00_00 
     337            ztaux_base(ji,jj) = 0._wp 
     338            ztauy_base(ji,jj) = 0._wp 
     339         END_2D 
    352340      ENDIF 
    353341 
    … …  
    363351         ! convergence test 
    364352         IF( nn_rhg_chkcvg == 1 .OR. nn_rhg_chkcvg == 2  ) THEN 
    365             DO jj = 1, jpj 
    366                DO ji = 1, jpi 
    367                   zu_ice(ji,jj) = u_ice(ji,jj) * umask(ji,jj,1) ! velocity at previous time step 
    368                   zv_ice(ji,jj) = v_ice(ji,jj) * vmask(ji,jj,1) 
    369                END DO 
    370             END DO 
     353            DO_2D_11_11 
     354               zu_ice(ji,jj) = u_ice(ji,jj) * umask(ji,jj,1) ! velocity at previous time step 
     355               zv_ice(ji,jj) = v_ice(ji,jj) * vmask(ji,jj,1) 
     356            END_2D 
    371357         ENDIF 
    372358 
    373359         ! --- divergence, tension & shear (Appendix B of Hunke & Dukowicz, 2002) --- ! 
    374          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 
    375             DO ji = 1, jpim1 
    376  
    377                ! shear at F points 
    378                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)   & 
    379                   &         + ( v_ice(ji+1,jj) * r1_e2v(ji+1,jj) - v_ice(ji,jj) * r1_e2v(ji,jj) ) * e2f(ji,jj) * e2f(ji,jj)   & 
    380                   &         ) * r1_e1e2f(ji,jj) * zfmask(ji,jj) 
    381  
    382             END DO 
    383          END DO 
     360         DO_2D_10_10 
     361 
     362            ! shear at F points 
     363            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)   & 
     364               &         + ( v_ice(ji+1,jj) * r1_e2v(ji+1,jj) - v_ice(ji,jj) * r1_e2v(ji,jj) ) * e2f(ji,jj) * e2f(ji,jj)   & 
     365               &         ) * r1_e1e2f(ji,jj) * zfmask(ji,jj) 
     366 
     367         END_2D 
    384368         CALL lbc_lnk( 'icedyn_rhg_evp', zds, 'F', 1. ) 
    385369 
    386          DO jj = 2, jpj    ! loop to jpi,jpj to avoid making a communication for zs1,zs2,zs12 
    387             DO ji = 2, jpi ! no vector loop 
    388  
    389                ! shear**2 at T points (doc eq. A16) 
    390                zds2 = ( zds(ji,jj  ) * zds(ji,jj  ) * e1e2f(ji,jj  ) + zds(ji-1,jj  ) * zds(ji-1,jj  ) * e1e2f(ji-1,jj  )  & 
    391                   &   + 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)  & 
    392                   &   ) * 0.25_wp * r1_e1e2t(ji,jj) 
    393                
    394                ! divergence at T points 
    395                zdiv  = ( e2u(ji,jj) * u_ice(ji,jj) - e2u(ji-1,jj) * u_ice(ji-1,jj)   & 
    396                   &    + e1v(ji,jj) * v_ice(ji,jj) - e1v(ji,jj-1) * v_ice(ji,jj-1)   & 
    397                   &    ) * r1_e1e2t(ji,jj) 
    398                zdiv2 = zdiv * zdiv 
    399                 
    400                ! tension at T points 
    401                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)   & 
    402                   &   - ( v_ice(ji,jj) * r1_e1v(ji,jj) - v_ice(ji,jj-1) * r1_e1v(ji,jj-1) ) * e1t(ji,jj) * e1t(ji,jj)   & 
    403                   &   ) * r1_e1e2t(ji,jj) 
    404                zdt2 = zdt * zdt 
    405                 
    406                ! delta at T points 
    407                zdelta = SQRT( zdiv2 + ( zdt2 + zds2 ) * z1_ecc2 )   
    408  
    409                ! P/delta at T points 
    410                zp_delt(ji,jj) = strength(ji,jj) / ( zdelta + rn_creepl ) 
    411  
    412                ! alpha for aEVP 
    413                !   gamma = 0.5*P/(delta+creepl) * (c*pi)**2/Area * dt/m 
    414                !   alpha = beta = sqrt(4*gamma) 
    415                IF( ln_aEVP ) THEN 
    416                   zalph1   = MAX( 50._wp, rpi * SQRT( 0.5_wp * zp_delt(ji,jj) * r1_e1e2t(ji,jj) * zdt_m(ji,jj) ) ) 
    417                   z1_alph1 = 1._wp / ( zalph1 + 1._wp ) 
    418                   zalph2   = zalph1 
    419                   z1_alph2 = z1_alph1 
    420                   ! explicit: 
    421                   ! z1_alph1 = 1._wp / zalph1 
    422                   ! z1_alph2 = 1._wp / zalph1 
    423                   ! zalph1 = zalph1 - 1._wp 
    424                   ! zalph2 = zalph1 
    425                ENDIF 
    426                 
    427                ! stress at T points (zkt/=0 if landfast) 
    428                zs1(ji,jj) = ( zs1(ji,jj) * zalph1 + zp_delt(ji,jj) * ( zdiv * (1._wp + zkt) - zdelta * (1._wp - zkt) ) ) * z1_alph1 
    429                zs2(ji,jj) = ( zs2(ji,jj) * zalph2 + zp_delt(ji,jj) * ( zdt * z1_ecc2 * (1._wp + zkt) ) ) * z1_alph2 
    430               
    431             END DO 
    432          END DO 
     370         DO_2D_01_01 
     371 
     372            ! shear**2 at T points (doc eq. A16) 
     373            zds2 = ( zds(ji,jj  ) * zds(ji,jj  ) * e1e2f(ji,jj  ) + zds(ji-1,jj  ) * zds(ji-1,jj  ) * e1e2f(ji-1,jj  )  & 
     374               &   + 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)  & 
     375               &   ) * 0.25_wp * r1_e1e2t(ji,jj) 
     376            
     377            ! divergence at T points 
     378            zdiv  = ( e2u(ji,jj) * u_ice(ji,jj) - e2u(ji-1,jj) * u_ice(ji-1,jj)   & 
     379               &    + e1v(ji,jj) * v_ice(ji,jj) - e1v(ji,jj-1) * v_ice(ji,jj-1)   & 
     380               &    ) * r1_e1e2t(ji,jj) 
     381            zdiv2 = zdiv * zdiv 
     382             
     383            ! tension at T points 
     384            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)   & 
     385               &   - ( v_ice(ji,jj) * r1_e1v(ji,jj) - v_ice(ji,jj-1) * r1_e1v(ji,jj-1) ) * e1t(ji,jj) * e1t(ji,jj)   & 
     386               &   ) * r1_e1e2t(ji,jj) 
     387            zdt2 = zdt * zdt 
     388             
     389            ! delta at T points 
     390            zdelta = SQRT( zdiv2 + ( zdt2 + zds2 ) * z1_ecc2 )   
     391 
     392            ! P/delta at T points 
     393            zp_delt(ji,jj) = strength(ji,jj) / ( zdelta + rn_creepl ) 
     394 
     395            ! alpha for aEVP 
     396            !   gamma = 0.5*P/(delta+creepl) * (c*pi)**2/Area * dt/m 
     397            !   alpha = beta = sqrt(4*gamma) 
     398            IF( ln_aEVP ) THEN 
     399               zalph1   = MAX( 50._wp, rpi * SQRT( 0.5_wp * zp_delt(ji,jj) * r1_e1e2t(ji,jj) * zdt_m(ji,jj) ) ) 
     400               z1_alph1 = 1._wp / ( zalph1 + 1._wp ) 
     401               zalph2   = zalph1 
     402               z1_alph2 = z1_alph1 
     403               ! explicit: 
     404               ! z1_alph1 = 1._wp / zalph1 
     405               ! z1_alph2 = 1._wp / zalph1 
     406               ! zalph1 = zalph1 - 1._wp 
     407               ! zalph2 = zalph1 
     408            ENDIF 
     409             
     410            ! stress at T points (zkt/=0 if landfast) 
     411            zs1(ji,jj) = ( zs1(ji,jj) * zalph1 + zp_delt(ji,jj) * ( zdiv * (1._wp + zkt) - zdelta * (1._wp - zkt) ) ) * z1_alph1 
     412            zs2(ji,jj) = ( zs2(ji,jj) * zalph2 + zp_delt(ji,jj) * ( zdt * z1_ecc2 * (1._wp + zkt) ) ) * z1_alph2 
     413           
     414         END_2D 
    433415         CALL lbc_lnk( 'icedyn_rhg_evp', zp_delt, 'T', 1. ) 
    434416 
    435417         ! Save beta at T-points for further computations 
    436418         IF( ln_aEVP ) THEN 
    437             DO jj = 1, jpj 
    438                DO ji = 1, jpi 
    439                   zbeta(ji,jj) = MAX( 50._wp, rpi * SQRT( 0.5_wp * zp_delt(ji,jj) * r1_e1e2t(ji,jj) * zdt_m(ji,jj) ) ) 
    440                END DO 
    441             END DO 
     419            DO_2D_11_11 
     420               zbeta(ji,jj) = MAX( 50._wp, rpi * SQRT( 0.5_wp * zp_delt(ji,jj) * r1_e1e2t(ji,jj) * zdt_m(ji,jj) ) ) 
     421            END_2D 
    442422         ENDIF 
    443423          
    444          DO jj = 1, jpjm1 
    445             DO ji = 1, jpim1 
    446  
    447                ! alpha for aEVP 
    448                IF( ln_aEVP ) THEN 
    449                   zalph2   = MAX( zbeta(ji,jj), zbeta(ji+1,jj), zbeta(ji,jj+1), zbeta(ji+1,jj+1) ) 
    450                   z1_alph2 = 1._wp / ( zalph2 + 1._wp ) 
    451                   ! explicit: 
    452                   ! z1_alph2 = 1._wp / zalph2 
    453                   ! zalph2 = zalph2 - 1._wp 
    454                ENDIF 
    455                 
    456                ! P/delta at F points 
    457                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) ) 
    458                 
    459                ! stress at F points (zkt/=0 if landfast) 
    460                zs12(ji,jj)= ( zs12(ji,jj) * zalph2 + zp_delf * ( zds(ji,jj) * z1_ecc2 * (1._wp + zkt) ) * 0.5_wp ) * z1_alph2 
    461  
    462             END DO 
    463          END DO 
     424         DO_2D_10_10 
     425 
     426            ! alpha for aEVP 
     427            IF( ln_aEVP ) THEN 
     428               zalph2   = MAX( zbeta(ji,jj), zbeta(ji+1,jj), zbeta(ji,jj+1), zbeta(ji+1,jj+1) ) 
     429               z1_alph2 = 1._wp / ( zalph2 + 1._wp ) 
     430               ! explicit: 
     431               ! z1_alph2 = 1._wp / zalph2 
     432               ! zalph2 = zalph2 - 1._wp 
     433            ENDIF 
     434             
     435            ! P/delta at F points 
     436            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) ) 
     437             
     438            ! stress at F points (zkt/=0 if landfast) 
     439            zs12(ji,jj)= ( zs12(ji,jj) * zalph2 + zp_delf * ( zds(ji,jj) * z1_ecc2 * (1._wp + zkt) ) * 0.5_wp ) * z1_alph2 
     440 
     441         END_2D 
    464442 
    465443         ! --- Ice internal stresses (Appendix C of Hunke and Dukowicz, 2002) --- ! 
    466          DO jj = 2, jpjm1 
    467             DO ji = fs_2, fs_jpim1                
    468                !                   !--- U points 
    469                zfU(ji,jj) = 0.5_wp * ( ( zs1(ji+1,jj) - zs1(ji,jj) ) * e2u(ji,jj)                                             & 
    470                   &                  + ( zs2(ji+1,jj) * e2t(ji+1,jj) * e2t(ji+1,jj) - zs2(ji,jj) * e2t(ji,jj) * e2t(ji,jj)    & 
    471                   &                    ) * r1_e2u(ji,jj)                                                                      & 
    472                   &                  + ( zs12(ji,jj) * e1f(ji,jj) * e1f(ji,jj) - zs12(ji,jj-1) * e1f(ji,jj-1) * e1f(ji,jj-1)  & 
    473                   &                    ) * 2._wp * r1_e1u(ji,jj)                                                              & 
    474                   &                  ) * r1_e1e2u(ji,jj) 
    475                ! 
    476                !                !--- V points 
    477                zfV(ji,jj) = 0.5_wp * ( ( zs1(ji,jj+1) - zs1(ji,jj) ) * e1v(ji,jj)                                             & 
    478                   &                  - ( zs2(ji,jj+1) * e1t(ji,jj+1) * e1t(ji,jj+1) - zs2(ji,jj) * e1t(ji,jj) * e1t(ji,jj)    & 
    479                   &                    ) * r1_e1v(ji,jj)                                                                      & 
    480                   &                  + ( zs12(ji,jj) * e2f(ji,jj) * e2f(ji,jj) - zs12(ji-1,jj) * e2f(ji-1,jj) * e2f(ji-1,jj)  & 
    481                   &                    ) * 2._wp * r1_e2v(ji,jj)                                                              & 
    482                   &                  ) * r1_e1e2v(ji,jj) 
    483                ! 
    484                !                !--- ice currents at U-V point 
    485                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) 
    486                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) 
    487                ! 
    488             END DO 
    489          END DO 
     444         DO_2D_00_00 
     445            !                   !--- U points 
     446            zfU(ji,jj) = 0.5_wp * ( ( zs1(ji+1,jj) - zs1(ji,jj) ) * e2u(ji,jj)                                             & 
     447               &                  + ( zs2(ji+1,jj) * e2t(ji+1,jj) * e2t(ji+1,jj) - zs2(ji,jj) * e2t(ji,jj) * e2t(ji,jj)    & 
     448               &                    ) * r1_e2u(ji,jj)                                                                      & 
     449               &                  + ( zs12(ji,jj) * e1f(ji,jj) * e1f(ji,jj) - zs12(ji,jj-1) * e1f(ji,jj-1) * e1f(ji,jj-1)  & 
     450               &                    ) * 2._wp * r1_e1u(ji,jj)                                                              & 
     451               &                  ) * r1_e1e2u(ji,jj) 
     452            ! 
     453            !                !--- V points 
     454            zfV(ji,jj) = 0.5_wp * ( ( zs1(ji,jj+1) - zs1(ji,jj) ) * e1v(ji,jj)                                             & 
     455               &                  - ( zs2(ji,jj+1) * e1t(ji,jj+1) * e1t(ji,jj+1) - zs2(ji,jj) * e1t(ji,jj) * e1t(ji,jj)    & 
     456               &                    ) * r1_e1v(ji,jj)                                                                      & 
     457               &                  + ( zs12(ji,jj) * e2f(ji,jj) * e2f(ji,jj) - zs12(ji-1,jj) * e2f(ji-1,jj) * e2f(ji-1,jj)  & 
     458               &                    ) * 2._wp * r1_e2v(ji,jj)                                                              & 
     459               &                  ) * r1_e1e2v(ji,jj) 
     460            ! 
     461            !                !--- ice currents at U-V point 
     462            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) 
     463            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) 
     464            ! 
     465         END_2D 
    490466         ! 
    491467         ! --- Computation of ice velocity --- ! 
    … …  
    494470         IF( MOD(jter,2) == 0 ) THEN ! even iterations 
    495471            ! 
    496             DO jj = 2, jpjm1 
    497                DO ji = fs_2, fs_jpim1 
    498                   !                 !--- tau_io/(v_oce - v_ice) 
    499                   zTauO = zaV(ji,jj) * zrhoco * SQRT( ( v_ice (ji,jj) - v_oce (ji,jj) ) * ( v_ice (ji,jj) - v_oce (ji,jj) )  & 
    500                      &                              + ( u_iceV(ji,jj) - u_oceV(ji,jj) ) * ( u_iceV(ji,jj) - u_oceV(ji,jj) ) ) 
    501                   !                 !--- Ocean-to-Ice stress 
    502                   ztauy_oi(ji,jj) = zTauO * ( v_oce(ji,jj) - v_ice(ji,jj) ) 
    503                   ! 
    504                   !                 !--- tau_bottom/v_ice 
    505                   zvel  = 5.e-05_wp + SQRT( v_ice(ji,jj) * v_ice(ji,jj) + u_iceV(ji,jj) * u_iceV(ji,jj) ) 
    506                   zTauB = ztauy_base(ji,jj) / zvel 
    507                   !                 !--- OceanBottom-to-Ice stress 
    508                   ztauy_bi(ji,jj) = zTauB * v_ice(ji,jj) 
    509                   ! 
    510                   !                 !--- Coriolis at V-points (energy conserving formulation) 
    511                   zCorV(ji,jj)  = - 0.25_wp * r1_e2v(ji,jj) *  & 
    512                      &    ( zmf(ji,jj  ) * ( e2u(ji,jj  ) * u_ice(ji,jj  ) + e2u(ji-1,jj  ) * u_ice(ji-1,jj  ) )  & 
    513                      &    + zmf(ji,jj+1) * ( e2u(ji,jj+1) * u_ice(ji,jj+1) + e2u(ji-1,jj+1) * u_ice(ji-1,jj+1) ) ) 
    514                   ! 
    515                   !                 !--- Sum of external forces (explicit solution) = F + tau_ia + Coriolis + spg + tau_io 
    516                   zRHS = zfV(ji,jj) + ztauy_ai(ji,jj) + zCorV(ji,jj) + zspgV(ji,jj) + ztauy_oi(ji,jj) 
    517                   ! 
    518                   !                 !--- landfast switch => 0 = static  friction : TauB > RHS & sign(TauB) /= sign(RHS) 
    519                   !                                         1 = sliding friction : TauB < RHS 
    520                   rswitch = 1._wp - MIN( 1._wp, ABS( SIGN( 1._wp, zRHS + ztauy_base(ji,jj) ) - SIGN( 1._wp, zRHS ) ) ) 
    521                   ! 
    522                   IF( ln_aEVP ) THEN !--- ice velocity using aEVP (Kimmritz et al 2016 & 2017) 
    523                      zbetav = MAX( zbeta(ji,jj), zbeta(ji,jj+1) ) 
    524                      v_ice(ji,jj) = ( (          rswitch   * ( zmV_t(ji,jj) * ( zbetav * v_ice(ji,jj) + v_ice_b(ji,jj) )         & ! previous velocity 
    525                         &                                    + zRHS + zTauO * v_ice(ji,jj)                                       & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 
    526                         &                                    ) / MAX( zepsi, zmV_t(ji,jj) * ( zbetav + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast 
    527                         &            + ( 1._wp - rswitch ) * (  v_ice_b(ji,jj)                                                   &  
    528                         &                                     + v_ice  (ji,jj) * MAX( 0._wp, zbetav - zdtevp * rn_lf_relax )     & ! static friction => slow decrease to v=0 
    529                         &                                    ) / ( zbetav + 1._wp )                                              & 
    530                         &             ) * 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 
    531                         &           )   * zmsk00y(ji,jj) 
    532                   ELSE               !--- ice velocity using EVP implicit formulation (cf Madec doc & Bouillon 2009) 
    533                      v_ice(ji,jj) = ( (          rswitch   * ( zmV_t(ji,jj) * v_ice(ji,jj)                                       & ! previous velocity 
    534                         &                                    + zRHS + zTauO * v_ice(ji,jj)                                       & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 
    535                         &                                    ) / MAX( zepsi, zmV_t(ji,jj) + zTauO - zTauB )                      & ! m/dt + tau_io(only ice part) + landfast 
    536                         &            + ( 1._wp - rswitch ) *   v_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lf_relax )         & ! static friction => slow decrease to v=0 
    537                         &             ) * 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 
    538                         &            )  * zmsk00y(ji,jj) 
    539                   ENDIF 
    540                END DO 
    541             END DO 
     472            DO_2D_00_00 
     473               !                 !--- tau_io/(v_oce - v_ice) 
     474               zTauO = zaV(ji,jj) * zrhoco * SQRT( ( v_ice (ji,jj) - v_oce (ji,jj) ) * ( v_ice (ji,jj) - v_oce (ji,jj) )  & 
     475                  &                              + ( u_iceV(ji,jj) - u_oceV(ji,jj) ) * ( u_iceV(ji,jj) - u_oceV(ji,jj) ) ) 
     476               !                 !--- Ocean-to-Ice stress 
     477               ztauy_oi(ji,jj) = zTauO * ( v_oce(ji,jj) - v_ice(ji,jj) ) 
     478               ! 
     479               !                 !--- tau_bottom/v_ice 
     480               zvel  = 5.e-05_wp + SQRT( v_ice(ji,jj) * v_ice(ji,jj) + u_iceV(ji,jj) * u_iceV(ji,jj) ) 
     481               zTauB = ztauy_base(ji,jj) / zvel 
     482               !                 !--- OceanBottom-to-Ice stress 
     483               ztauy_bi(ji,jj) = zTauB * v_ice(ji,jj) 
     484               ! 
     485               !                 !--- Coriolis at V-points (energy conserving formulation) 
     486               zCorV(ji,jj)  = - 0.25_wp * r1_e2v(ji,jj) *  & 
     487                  &    ( zmf(ji,jj  ) * ( e2u(ji,jj  ) * u_ice(ji,jj  ) + e2u(ji-1,jj  ) * u_ice(ji-1,jj  ) )  & 
     488                  &    + zmf(ji,jj+1) * ( e2u(ji,jj+1) * u_ice(ji,jj+1) + e2u(ji-1,jj+1) * u_ice(ji-1,jj+1) ) ) 
     489               ! 
     490               !                 !--- Sum of external forces (explicit solution) = F + tau_ia + Coriolis + spg + tau_io 
     491               zRHS = zfV(ji,jj) + ztauy_ai(ji,jj) + zCorV(ji,jj) + zspgV(ji,jj) + ztauy_oi(ji,jj) 
     492               ! 
     493               !                 !--- landfast switch => 0 = static  friction : TauB > RHS & sign(TauB) /= sign(RHS) 
     494               !                                         1 = sliding friction : TauB < RHS 
     495               rswitch = 1._wp - MIN( 1._wp, ABS( SIGN( 1._wp, zRHS + ztauy_base(ji,jj) ) - SIGN( 1._wp, zRHS ) ) ) 
     496               ! 
     497               IF( ln_aEVP ) THEN !--- ice velocity using aEVP (Kimmritz et al 2016 & 2017) 
     498                  zbetav = MAX( zbeta(ji,jj), zbeta(ji,jj+1) ) 
     499                  v_ice(ji,jj) = ( (          rswitch   * ( zmV_t(ji,jj) * ( zbetav * v_ice(ji,jj) + v_ice_b(ji,jj) )         & ! previous velocity 
     500                     &                                    + zRHS + zTauO * v_ice(ji,jj)                                       & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 
     501                     &                                    ) / MAX( zepsi, zmV_t(ji,jj) * ( zbetav + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast 
     502                     &            + ( 1._wp - rswitch ) * (  v_ice_b(ji,jj)                                                   &  
     503                     &                                     + v_ice  (ji,jj) * MAX( 0._wp, zbetav - zdtevp * rn_lf_relax )     & ! static friction => slow decrease to v=0 
     504                     &                                    ) / ( zbetav + 1._wp )                                              & 
     505                     &             ) * 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 
     506                     &           )   * zmsk00y(ji,jj) 
     507               ELSE               !--- ice velocity using EVP implicit formulation (cf Madec doc & Bouillon 2009) 
     508                  v_ice(ji,jj) = ( (          rswitch   * ( zmV_t(ji,jj) * v_ice(ji,jj)                                       & ! previous velocity 
     509                     &                                    + zRHS + zTauO * v_ice(ji,jj)                                       & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 
     510                     &                                    ) / MAX( zepsi, zmV_t(ji,jj) + zTauO - zTauB )                      & ! m/dt + tau_io(only ice part) + landfast 
     511                     &            + ( 1._wp - rswitch ) *   v_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lf_relax )         & ! static friction => slow decrease to v=0 
     512                     &             ) * 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 
     513                     &            )  * zmsk00y(ji,jj) 
     514               ENDIF 
     515            END_2D 
    542516            CALL lbc_lnk( 'icedyn_rhg_evp', v_ice, 'V', -1. ) 
    543517            ! 
    … …  
    548522            IF( ln_bdy )   CALL bdy_ice_dyn( 'V' ) 
    549523            ! 
    550             DO jj = 2, jpjm1 
    551                DO ji = fs_2, fs_jpim1           
    552                   !                 !--- tau_io/(u_oce - u_ice) 
    553                   zTauO = zaU(ji,jj) * zrhoco * SQRT( ( u_ice (ji,jj) - u_oce (ji,jj) ) * ( u_ice (ji,jj) - u_oce (ji,jj) )  & 
    554                      &                              + ( v_iceU(ji,jj) - v_oceU(ji,jj) ) * ( v_iceU(ji,jj) - v_oceU(ji,jj) ) ) 
    555                   !                 !--- Ocean-to-Ice stress 
    556                   ztaux_oi(ji,jj) = zTauO * ( u_oce(ji,jj) - u_ice(ji,jj) ) 
    557                   ! 
    558                   !                 !--- tau_bottom/u_ice 
    559                   zvel  = 5.e-05_wp + SQRT( v_iceU(ji,jj) * v_iceU(ji,jj) + u_ice(ji,jj) * u_ice(ji,jj) ) 
    560                   zTauB = ztaux_base(ji,jj) / zvel 
    561                   !                 !--- OceanBottom-to-Ice stress 
    562                   ztaux_bi(ji,jj) = zTauB * u_ice(ji,jj) 
    563                   ! 
    564                   !                 !--- Coriolis at U-points (energy conserving formulation) 
    565                   zCorU(ji,jj)  =   0.25_wp * r1_e1u(ji,jj) *  & 
    566                      &    ( zmf(ji  ,jj) * ( e1v(ji  ,jj) * v_ice(ji  ,jj) + e1v(ji  ,jj-1) * v_ice(ji  ,jj-1) )  & 
    567                      &    + zmf(ji+1,jj) * ( e1v(ji+1,jj) * v_ice(ji+1,jj) + e1v(ji+1,jj-1) * v_ice(ji+1,jj-1) ) ) 
    568                   ! 
    569                   !                 !--- Sum of external forces (explicit solution) = F + tau_ia + Coriolis + spg + tau_io 
    570                   zRHS = zfU(ji,jj) + ztaux_ai(ji,jj) + zCorU(ji,jj) + zspgU(ji,jj) + ztaux_oi(ji,jj) 
    571                   ! 
    572                   !                 !--- landfast switch => 0 = static  friction : TauB > RHS & sign(TauB) /= sign(RHS) 
    573                   !                                         1 = sliding friction : TauB < RHS 
    574                   rswitch = 1._wp - MIN( 1._wp, ABS( SIGN( 1._wp, zRHS + ztaux_base(ji,jj) ) - SIGN( 1._wp, zRHS ) ) ) 
    575                   ! 
    576                   IF( ln_aEVP ) THEN !--- ice velocity using aEVP (Kimmritz et al 2016 & 2017) 
    577                      zbetau = MAX( zbeta(ji,jj), zbeta(ji+1,jj) ) 
    578                      u_ice(ji,jj) = ( (          rswitch   * ( zmU_t(ji,jj) * ( zbetau * u_ice(ji,jj) + u_ice_b(ji,jj) )         & ! previous velocity 
    579                         &                                    + zRHS + zTauO * u_ice(ji,jj)                                       & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 
    580                         &                                    ) / MAX( zepsi, zmU_t(ji,jj) * ( zbetau + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast 
    581                         &            + ( 1._wp - rswitch ) * (  u_ice_b(ji,jj)                                                   & 
    582                         &                                     + u_ice  (ji,jj) * MAX( 0._wp, zbetau - zdtevp * rn_lf_relax )     & ! static friction => slow decrease to v=0 
    583                         &                                    ) / ( zbetau + 1._wp )                                              & 
    584                         &             ) * 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  
    585                         &           )   * zmsk00x(ji,jj) 
    586                   ELSE               !--- ice velocity using EVP implicit formulation (cf Madec doc & Bouillon 2009) 
    587                      u_ice(ji,jj) = ( (          rswitch   * ( zmU_t(ji,jj) * u_ice(ji,jj)                                       & ! previous velocity 
    588                         &                                    + zRHS + zTauO * u_ice(ji,jj)                                       & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 
    589                         &                                    ) / MAX( zepsi, zmU_t(ji,jj) + zTauO - zTauB )                      & ! m/dt + tau_io(only ice part) + landfast 
    590                         &            + ( 1._wp - rswitch ) *   u_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lf_relax )         & ! static friction => slow decrease to v=0 
    591                         &             ) * 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  
    592                         &           )   * zmsk00x(ji,jj) 
    593                   ENDIF 
    594                END DO 
    595             END DO 
     524            DO_2D_00_00 
     525               !                 !--- tau_io/(u_oce - u_ice) 
     526               zTauO = zaU(ji,jj) * zrhoco * SQRT( ( u_ice (ji,jj) - u_oce (ji,jj) ) * ( u_ice (ji,jj) - u_oce (ji,jj) )  & 
     527                  &                              + ( v_iceU(ji,jj) - v_oceU(ji,jj) ) * ( v_iceU(ji,jj) - v_oceU(ji,jj) ) ) 
     528               !                 !--- Ocean-to-Ice stress 
     529               ztaux_oi(ji,jj) = zTauO * ( u_oce(ji,jj) - u_ice(ji,jj) ) 
     530               ! 
     531               !                 !--- tau_bottom/u_ice 
     532               zvel  = 5.e-05_wp + SQRT( v_iceU(ji,jj) * v_iceU(ji,jj) + u_ice(ji,jj) * u_ice(ji,jj) ) 
     533               zTauB = ztaux_base(ji,jj) / zvel 
     534               !                 !--- OceanBottom-to-Ice stress 
     535               ztaux_bi(ji,jj) = zTauB * u_ice(ji,jj) 
     536               ! 
     537               !                 !--- Coriolis at U-points (energy conserving formulation) 
     538               zCorU(ji,jj)  =   0.25_wp * r1_e1u(ji,jj) *  & 
     539                  &    ( zmf(ji  ,jj) * ( e1v(ji  ,jj) * v_ice(ji  ,jj) + e1v(ji  ,jj-1) * v_ice(ji  ,jj-1) )  & 
     540                  &    + zmf(ji+1,jj) * ( e1v(ji+1,jj) * v_ice(ji+1,jj) + e1v(ji+1,jj-1) * v_ice(ji+1,jj-1) ) ) 
     541               ! 
     542               !                 !--- Sum of external forces (explicit solution) = F + tau_ia + Coriolis + spg + tau_io 
     543               zRHS = zfU(ji,jj) + ztaux_ai(ji,jj) + zCorU(ji,jj) + zspgU(ji,jj) + ztaux_oi(ji,jj) 
     544               ! 
     545               !                 !--- landfast switch => 0 = static  friction : TauB > RHS & sign(TauB) /= sign(RHS) 
     546               !                                         1 = sliding friction : TauB < RHS 
     547               rswitch = 1._wp - MIN( 1._wp, ABS( SIGN( 1._wp, zRHS + ztaux_base(ji,jj) ) - SIGN( 1._wp, zRHS ) ) ) 
     548               ! 
     549               IF( ln_aEVP ) THEN !--- ice velocity using aEVP (Kimmritz et al 2016 & 2017) 
     550                  zbetau = MAX( zbeta(ji,jj), zbeta(ji+1,jj) ) 
     551                  u_ice(ji,jj) = ( (          rswitch   * ( zmU_t(ji,jj) * ( zbetau * u_ice(ji,jj) + u_ice_b(ji,jj) )         & ! previous velocity 
     552                     &                                    + zRHS + zTauO * u_ice(ji,jj)                                       & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 
     553                     &                                    ) / MAX( zepsi, zmU_t(ji,jj) * ( zbetau + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast 
     554                     &            + ( 1._wp - rswitch ) * (  u_ice_b(ji,jj)                                                   & 
     555                     &                                     + u_ice  (ji,jj) * MAX( 0._wp, zbetau - zdtevp * rn_lf_relax )     & ! static friction => slow decrease to v=0 
     556                     &                                    ) / ( zbetau + 1._wp )                                              & 
     557                     &             ) * 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  
     558                     &           )   * zmsk00x(ji,jj) 
     559               ELSE               !--- ice velocity using EVP implicit formulation (cf Madec doc & Bouillon 2009) 
     560                  u_ice(ji,jj) = ( (          rswitch   * ( zmU_t(ji,jj) * u_ice(ji,jj)                                       & ! previous velocity 
     561                     &                                    + zRHS + zTauO * u_ice(ji,jj)                                       & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 
     562                     &                                    ) / MAX( zepsi, zmU_t(ji,jj) + zTauO - zTauB )                      & ! m/dt + tau_io(only ice part) + landfast 
     563                     &            + ( 1._wp - rswitch ) *   u_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lf_relax )         & ! static friction => slow decrease to v=0 
     564                     &             ) * 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  
     565                     &           )   * zmsk00x(ji,jj) 
     566               ENDIF 
     567            END_2D 
    596568            CALL lbc_lnk( 'icedyn_rhg_evp', u_ice, 'U', -1. ) 
    597569            ! 
    … …  
    604576         ELSE ! odd iterations 
    605577            ! 
    606             DO jj = 2, jpjm1 
    607                DO ji = fs_2, fs_jpim1 
    608                   !                 !--- tau_io/(u_oce - u_ice) 
    609                   zTauO = zaU(ji,jj) * zrhoco * SQRT( ( u_ice (ji,jj) - u_oce (ji,jj) ) * ( u_ice (ji,jj) - u_oce (ji,jj) )  & 
    610                      &                              + ( v_iceU(ji,jj) - v_oceU(ji,jj) ) * ( v_iceU(ji,jj) - v_oceU(ji,jj) ) ) 
    611                   !                 !--- Ocean-to-Ice stress 
    612                   ztaux_oi(ji,jj) = zTauO * ( u_oce(ji,jj) - u_ice(ji,jj) ) 
    613                   ! 
    614                   !                 !--- tau_bottom/u_ice 
    615                   zvel  = 5.e-05_wp + SQRT( v_iceU(ji,jj) * v_iceU(ji,jj) + u_ice(ji,jj) * u_ice(ji,jj) ) 
    616                   zTauB = ztaux_base(ji,jj) / zvel 
    617                   !                 !--- OceanBottom-to-Ice stress 
    618                   ztaux_bi(ji,jj) = zTauB * u_ice(ji,jj) 
    619                   ! 
    620                   !                 !--- Coriolis at U-points (energy conserving formulation) 
    621                   zCorU(ji,jj)  =   0.25_wp * r1_e1u(ji,jj) *  & 
    622                      &    ( zmf(ji  ,jj) * ( e1v(ji  ,jj) * v_ice(ji  ,jj) + e1v(ji  ,jj-1) * v_ice(ji  ,jj-1) )  & 
    623                      &    + zmf(ji+1,jj) * ( e1v(ji+1,jj) * v_ice(ji+1,jj) + e1v(ji+1,jj-1) * v_ice(ji+1,jj-1) ) ) 
    624                   ! 
    625                   !                 !--- Sum of external forces (explicit solution) = F + tau_ia + Coriolis + spg + tau_io 
    626                   zRHS = zfU(ji,jj) + ztaux_ai(ji,jj) + zCorU(ji,jj) + zspgU(ji,jj) + ztaux_oi(ji,jj) 
    627                   ! 
    628                   !                 !--- landfast switch => 0 = static  friction : TauB > RHS & sign(TauB) /= sign(RHS) 
    629                   !                                         1 = sliding friction : TauB < RHS 
    630                   rswitch = 1._wp - MIN( 1._wp, ABS( SIGN( 1._wp, zRHS + ztaux_base(ji,jj) ) - SIGN( 1._wp, zRHS ) ) ) 
    631                   ! 
    632                   IF( ln_aEVP ) THEN !--- ice velocity using aEVP (Kimmritz et al 2016 & 2017) 
    633                      zbetau = MAX( zbeta(ji,jj), zbeta(ji+1,jj) ) 
    634                      u_ice(ji,jj) = ( (          rswitch   * ( zmU_t(ji,jj) * ( zbetau * u_ice(ji,jj) + u_ice_b(ji,jj) )         & ! previous velocity 
    635                         &                                    + zRHS + zTauO * u_ice(ji,jj)                                       & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 
    636                         &                                    ) / MAX( zepsi, zmU_t(ji,jj) * ( zbetau + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast 
    637                         &            + ( 1._wp - rswitch ) * (  u_ice_b(ji,jj)                                                   & 
    638                         &                                     + u_ice  (ji,jj) * MAX( 0._wp, zbetau - zdtevp * rn_lf_relax )     & ! static friction => slow decrease to v=0 
    639                         &                                    ) / ( zbetau + 1._wp )                                              & 
    640                         &             ) * 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  
    641                         &           )   * zmsk00x(ji,jj) 
    642                   ELSE               !--- ice velocity using EVP implicit formulation (cf Madec doc & Bouillon 2009) 
    643                      u_ice(ji,jj) = ( (          rswitch   * ( zmU_t(ji,jj) * u_ice(ji,jj)                                       & ! previous velocity 
    644                         &                                    + zRHS + zTauO * u_ice(ji,jj)                                       & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 
    645                         &                                    ) / MAX( zepsi, zmU_t(ji,jj) + zTauO - zTauB )                      & ! m/dt + tau_io(only ice part) + landfast 
    646                         &            + ( 1._wp - rswitch ) *   u_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lf_relax )         & ! static friction => slow decrease to v=0 
    647                         &             ) * 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 
    648                         &           )   * zmsk00x(ji,jj) 
    649                   ENDIF 
    650                END DO 
    651             END DO 
     578            DO_2D_00_00 
     579               !                 !--- tau_io/(u_oce - u_ice) 
     580               zTauO = zaU(ji,jj) * zrhoco * SQRT( ( u_ice (ji,jj) - u_oce (ji,jj) ) * ( u_ice (ji,jj) - u_oce (ji,jj) )  & 
     581                  &                              + ( v_iceU(ji,jj) - v_oceU(ji,jj) ) * ( v_iceU(ji,jj) - v_oceU(ji,jj) ) ) 
     582               !                 !--- Ocean-to-Ice stress 
     583               ztaux_oi(ji,jj) = zTauO * ( u_oce(ji,jj) - u_ice(ji,jj) ) 
     584               ! 
     585               !                 !--- tau_bottom/u_ice 
     586               zvel  = 5.e-05_wp + SQRT( v_iceU(ji,jj) * v_iceU(ji,jj) + u_ice(ji,jj) * u_ice(ji,jj) ) 
     587               zTauB = ztaux_base(ji,jj) / zvel 
     588               !                 !--- OceanBottom-to-Ice stress 
     589               ztaux_bi(ji,jj) = zTauB * u_ice(ji,jj) 
     590               ! 
     591               !                 !--- Coriolis at U-points (energy conserving formulation) 
     592               zCorU(ji,jj)  =   0.25_wp * r1_e1u(ji,jj) *  & 
     593                  &    ( zmf(ji  ,jj) * ( e1v(ji  ,jj) * v_ice(ji  ,jj) + e1v(ji  ,jj-1) * v_ice(ji  ,jj-1) )  & 
     594                  &    + zmf(ji+1,jj) * ( e1v(ji+1,jj) * v_ice(ji+1,jj) + e1v(ji+1,jj-1) * v_ice(ji+1,jj-1) ) ) 
     595               ! 
     596               !                 !--- Sum of external forces (explicit solution) = F + tau_ia + Coriolis + spg + tau_io 
     597               zRHS = zfU(ji,jj) + ztaux_ai(ji,jj) + zCorU(ji,jj) + zspgU(ji,jj) + ztaux_oi(ji,jj) 
     598               ! 
     599               !                 !--- landfast switch => 0 = static  friction : TauB > RHS & sign(TauB) /= sign(RHS) 
     600               !                                         1 = sliding friction : TauB < RHS 
     601               rswitch = 1._wp - MIN( 1._wp, ABS( SIGN( 1._wp, zRHS + ztaux_base(ji,jj) ) - SIGN( 1._wp, zRHS ) ) ) 
     602               ! 
     603               IF( ln_aEVP ) THEN !--- ice velocity using aEVP (Kimmritz et al 2016 & 2017) 
     604                  zbetau = MAX( zbeta(ji,jj), zbeta(ji+1,jj) ) 
     605                  u_ice(ji,jj) = ( (          rswitch   * ( zmU_t(ji,jj) * ( zbetau * u_ice(ji,jj) + u_ice_b(ji,jj) )         & ! previous velocity 
     606                     &                                    + zRHS + zTauO * u_ice(ji,jj)                                       & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 
     607                     &                                    ) / MAX( zepsi, zmU_t(ji,jj) * ( zbetau + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast 
     608                     &            + ( 1._wp - rswitch ) * (  u_ice_b(ji,jj)                                                   & 
     609                     &                                     + u_ice  (ji,jj) * MAX( 0._wp, zbetau - zdtevp * rn_lf_relax )     & ! static friction => slow decrease to v=0 
     610                     &                                    ) / ( zbetau + 1._wp )                                              & 
     611                     &             ) * 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  
     612                     &           )   * zmsk00x(ji,jj) 
     613               ELSE               !--- ice velocity using EVP implicit formulation (cf Madec doc & Bouillon 2009) 
     614                  u_ice(ji,jj) = ( (          rswitch   * ( zmU_t(ji,jj) * u_ice(ji,jj)                                       & ! previous velocity 
     615                     &                                    + zRHS + zTauO * u_ice(ji,jj)                                       & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 
     616                     &                                    ) / MAX( zepsi, zmU_t(ji,jj) + zTauO - zTauB )                      & ! m/dt + tau_io(only ice part) + landfast 
     617                     &            + ( 1._wp - rswitch ) *   u_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lf_relax )         & ! static friction => slow decrease to v=0 
     618                     &             ) * 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 
     619                     &           )   * zmsk00x(ji,jj) 
     620               ENDIF 
     621            END_2D 
    652622            CALL lbc_lnk( 'icedyn_rhg_evp', u_ice, 'U', -1. ) 
    653623            ! 
    … …  
    658628            IF( ln_bdy )   CALL bdy_ice_dyn( 'U' ) 
    659629            ! 
    660             DO jj = 2, jpjm1 
    661                DO ji = fs_2, fs_jpim1 
    662                   !                 !--- tau_io/(v_oce - v_ice) 
    663                   zTauO = zaV(ji,jj) * zrhoco * SQRT( ( v_ice (ji,jj) - v_oce (ji,jj) ) * ( v_ice (ji,jj) - v_oce (ji,jj) )  & 
    664                      &                              + ( u_iceV(ji,jj) - u_oceV(ji,jj) ) * ( u_iceV(ji,jj) - u_oceV(ji,jj) ) ) 
    665                   !                 !--- Ocean-to-Ice stress 
    666                   ztauy_oi(ji,jj) = zTauO * ( v_oce(ji,jj) - v_ice(ji,jj) ) 
    667                   ! 
    668                   !                 !--- tau_bottom/v_ice 
    669                   zvel  = 5.e-05_wp + SQRT( v_ice(ji,jj) * v_ice(ji,jj) + u_iceV(ji,jj) * u_iceV(ji,jj) ) 
    670                   zTauB = ztauy_base(ji,jj) / zvel 
    671                   !                 !--- OceanBottom-to-Ice stress 
    672                   ztauy_bi(ji,jj) = zTauB * v_ice(ji,jj) 
    673                   ! 
    674                   !                 !--- Coriolis at v-points (energy conserving formulation) 
    675                   zCorV(ji,jj)  = - 0.25_wp * r1_e2v(ji,jj) *  & 
    676                      &    ( zmf(ji,jj  ) * ( e2u(ji,jj  ) * u_ice(ji,jj  ) + e2u(ji-1,jj  ) * u_ice(ji-1,jj  ) )  & 
    677                      &    + zmf(ji,jj+1) * ( e2u(ji,jj+1) * u_ice(ji,jj+1) + e2u(ji-1,jj+1) * u_ice(ji-1,jj+1) ) ) 
    678                   ! 
    679                   !                 !--- Sum of external forces (explicit solution) = F + tau_ia + Coriolis + spg + tau_io 
    680                   zRHS = zfV(ji,jj) + ztauy_ai(ji,jj) + zCorV(ji,jj) + zspgV(ji,jj) + ztauy_oi(ji,jj) 
    681                   ! 
    682                   !                 !--- landfast switch => 0 = static  friction : TauB > RHS & sign(TauB) /= sign(RHS) 
    683                   !                                         1 = sliding friction : TauB < RHS 
    684                   rswitch = 1._wp - MIN( 1._wp, ABS( SIGN( 1._wp, zRHS + ztauy_base(ji,jj) ) - SIGN( 1._wp, zRHS ) ) ) 
    685                   ! 
    686                   IF( ln_aEVP ) THEN !--- ice velocity using aEVP (Kimmritz et al 2016 & 2017) 
    687                      zbetav = MAX( zbeta(ji,jj), zbeta(ji,jj+1) ) 
    688                      v_ice(ji,jj) = ( (          rswitch   * ( zmV_t(ji,jj) * ( zbetav * v_ice(ji,jj) + v_ice_b(ji,jj) )         & ! previous velocity 
    689                         &                                    + zRHS + zTauO * v_ice(ji,jj)                                       & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 
    690                         &                                    ) / MAX( zepsi, zmV_t(ji,jj) * ( zbetav + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast 
    691                         &            + ( 1._wp - rswitch ) * (  v_ice_b(ji,jj)                                                   & 
    692                         &                                     + v_ice  (ji,jj) * MAX( 0._wp, zbetav - zdtevp * rn_lf_relax )     & ! static friction => slow decrease to v=0 
    693                         &                                    ) / ( zbetav + 1._wp )                                              &  
    694                         &             ) * 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 
    695                         &           )   * zmsk00y(ji,jj) 
    696                   ELSE               !--- ice velocity using EVP implicit formulation (cf Madec doc & Bouillon 2009) 
    697                      v_ice(ji,jj) = ( (          rswitch   * ( zmV_t(ji,jj) * v_ice(ji,jj)                                       & ! previous velocity 
    698                         &                                    + zRHS + zTauO * v_ice(ji,jj)                                       & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 
    699                         &                                    ) / MAX( zepsi, zmV_t(ji,jj) + zTauO - zTauB )                      & ! m/dt + tau_io(only ice part) + landfast 
    700                         &            + ( 1._wp - rswitch ) *   v_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lf_relax )         & ! static friction => slow decrease to v=0 
    701                         &             ) * 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 
    702                         &           )   * zmsk00y(ji,jj) 
    703                   ENDIF 
    704                END DO 
    705             END DO 
     630            DO_2D_00_00 
     631               !                 !--- tau_io/(v_oce - v_ice) 
     632               zTauO = zaV(ji,jj) * zrhoco * SQRT( ( v_ice (ji,jj) - v_oce (ji,jj) ) * ( v_ice (ji,jj) - v_oce (ji,jj) )  & 
     633                  &                              + ( u_iceV(ji,jj) - u_oceV(ji,jj) ) * ( u_iceV(ji,jj) - u_oceV(ji,jj) ) ) 
     634               !                 !--- Ocean-to-Ice stress 
     635               ztauy_oi(ji,jj) = zTauO * ( v_oce(ji,jj) - v_ice(ji,jj) ) 
     636               ! 
     637               !                 !--- tau_bottom/v_ice 
     638               zvel  = 5.e-05_wp + SQRT( v_ice(ji,jj) * v_ice(ji,jj) + u_iceV(ji,jj) * u_iceV(ji,jj) ) 
     639               zTauB = ztauy_base(ji,jj) / zvel 
     640               !                 !--- OceanBottom-to-Ice stress 
     641               ztauy_bi(ji,jj) = zTauB * v_ice(ji,jj) 
     642               ! 
     643               !                 !--- Coriolis at v-points (energy conserving formulation) 
     644               zCorV(ji,jj)  = - 0.25_wp * r1_e2v(ji,jj) *  & 
     645                  &    ( zmf(ji,jj  ) * ( e2u(ji,jj  ) * u_ice(ji,jj  ) + e2u(ji-1,jj  ) * u_ice(ji-1,jj  ) )  & 
     646                  &    + zmf(ji,jj+1) * ( e2u(ji,jj+1) * u_ice(ji,jj+1) + e2u(ji-1,jj+1) * u_ice(ji-1,jj+1) ) ) 
     647               ! 
     648               !                 !--- Sum of external forces (explicit solution) = F + tau_ia + Coriolis + spg + tau_io 
     649               zRHS = zfV(ji,jj) + ztauy_ai(ji,jj) + zCorV(ji,jj) + zspgV(ji,jj) + ztauy_oi(ji,jj) 
     650               ! 
     651               !                 !--- landfast switch => 0 = static  friction : TauB > RHS & sign(TauB) /= sign(RHS) 
     652               !                                         1 = sliding friction : TauB < RHS 
     653               rswitch = 1._wp - MIN( 1._wp, ABS( SIGN( 1._wp, zRHS + ztauy_base(ji,jj) ) - SIGN( 1._wp, zRHS ) ) ) 
     654               ! 
     655               IF( ln_aEVP ) THEN !--- ice velocity using aEVP (Kimmritz et al 2016 & 2017) 
     656                  zbetav = MAX( zbeta(ji,jj), zbeta(ji,jj+1) ) 
     657                  v_ice(ji,jj) = ( (          rswitch   * ( zmV_t(ji,jj) * ( zbetav * v_ice(ji,jj) + v_ice_b(ji,jj) )         & ! previous velocity 
     658                     &                                    + zRHS + zTauO * v_ice(ji,jj)                                       & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 
     659                     &                                    ) / MAX( zepsi, zmV_t(ji,jj) * ( zbetav + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast 
     660                     &            + ( 1._wp - rswitch ) * (  v_ice_b(ji,jj)                                                   & 
     661                     &                                     + v_ice  (ji,jj) * MAX( 0._wp, zbetav - zdtevp * rn_lf_relax )     & ! static friction => slow decrease to v=0 
     662                     &                                    ) / ( zbetav + 1._wp )                                              &  
     663                     &             ) * 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 
     664                     &           )   * zmsk00y(ji,jj) 
     665               ELSE               !--- ice velocity using EVP implicit formulation (cf Madec doc & Bouillon 2009) 
     666                  v_ice(ji,jj) = ( (          rswitch   * ( zmV_t(ji,jj) * v_ice(ji,jj)                                       & ! previous velocity 
     667                     &                                    + zRHS + zTauO * v_ice(ji,jj)                                       & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 
     668                     &                                    ) / MAX( zepsi, zmV_t(ji,jj) + zTauO - zTauB )                      & ! m/dt + tau_io(only ice part) + landfast 
     669                     &            + ( 1._wp - rswitch ) *   v_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lf_relax )         & ! static friction => slow decrease to v=0 
     670                     &             ) * 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 
     671                     &           )   * zmsk00y(ji,jj) 
     672               ENDIF 
     673            END_2D 
    706674            CALL lbc_lnk( 'icedyn_rhg_evp', v_ice, 'V', -1. ) 
    707675            ! 
    … …  
    725693      ! 4) Recompute delta, shear and div (inputs for mechanical redistribution)  
    726694      !------------------------------------------------------------------------------! 
    727       DO jj = 1, jpjm1 
    728          DO ji = 1, jpim1 
    729  
    730             ! shear at F points 
    731             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)   & 
    732                &         + ( v_ice(ji+1,jj) * r1_e2v(ji+1,jj) - v_ice(ji,jj) * r1_e2v(ji,jj) ) * e2f(ji,jj) * e2f(ji,jj)   & 
    733                &         ) * r1_e1e2f(ji,jj) * zfmask(ji,jj) 
    734  
    735          END DO 
    736       END DO            
     695      DO_2D_10_10 
     696 
     697         ! shear at F points 
     698         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)   & 
     699            &         + ( v_ice(ji+1,jj) * r1_e2v(ji+1,jj) - v_ice(ji,jj) * r1_e2v(ji,jj) ) * e2f(ji,jj) * e2f(ji,jj)   & 
     700            &         ) * r1_e1e2f(ji,jj) * zfmask(ji,jj) 
     701 
     702      END_2D 
    737703       
    738       DO jj = 2, jpjm1 
    739          DO ji = 2, jpim1 ! no vector loop 
    740              
    741             ! tension**2 at T points 
    742             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)   & 
    743                &   - ( v_ice(ji,jj) * r1_e1v(ji,jj) - v_ice(ji,jj-1) * r1_e1v(ji,jj-1) ) * e1t(ji,jj) * e1t(ji,jj)   & 
    744                &   ) * r1_e1e2t(ji,jj) 
    745             zdt2 = zdt * zdt 
    746              
    747             ! shear**2 at T points (doc eq. A16) 
    748             zds2 = ( zds(ji,jj  ) * zds(ji,jj  ) * e1e2f(ji,jj  ) + zds(ji-1,jj  ) * zds(ji-1,jj  ) * e1e2f(ji-1,jj  )  & 
    749                &   + 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)  & 
    750                &   ) * 0.25_wp * r1_e1e2t(ji,jj) 
    751              
    752             ! shear at T points 
    753             pshear_i(ji,jj) = SQRT( zdt2 + zds2 ) 
    754  
    755             ! divergence at T points 
    756             pdivu_i(ji,jj) = ( e2u(ji,jj) * u_ice(ji,jj) - e2u(ji-1,jj) * u_ice(ji-1,jj)   & 
    757                &             + e1v(ji,jj) * v_ice(ji,jj) - e1v(ji,jj-1) * v_ice(ji,jj-1)   & 
    758                &             ) * r1_e1e2t(ji,jj) 
    759              
    760             ! delta at T points 
    761             zdelta         = SQRT( pdivu_i(ji,jj) * pdivu_i(ji,jj) + ( zdt2 + zds2 ) * z1_ecc2 )   
    762             rswitch        = 1._wp - MAX( 0._wp, SIGN( 1._wp, -zdelta ) ) ! 0 if delta=0 
    763             pdelta_i(ji,jj) = zdelta + rn_creepl * rswitch 
    764  
    765          END DO 
    766       END DO 
     704      DO_2D_00_00 
     705          
     706         ! tension**2 at T points 
     707         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)   & 
     708            &   - ( v_ice(ji,jj) * r1_e1v(ji,jj) - v_ice(ji,jj-1) * r1_e1v(ji,jj-1) ) * e1t(ji,jj) * e1t(ji,jj)   & 
     709            &   ) * r1_e1e2t(ji,jj) 
     710         zdt2 = zdt * zdt 
     711          
     712         ! shear**2 at T points (doc eq. A16) 
     713         zds2 = ( zds(ji,jj  ) * zds(ji,jj  ) * e1e2f(ji,jj  ) + zds(ji-1,jj  ) * zds(ji-1,jj  ) * e1e2f(ji-1,jj  )  & 
     714            &   + 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)  & 
     715            &   ) * 0.25_wp * r1_e1e2t(ji,jj) 
     716          
     717         ! shear at T points 
     718         pshear_i(ji,jj) = SQRT( zdt2 + zds2 ) 
     719 
     720         ! divergence at T points 
     721         pdivu_i(ji,jj) = ( e2u(ji,jj) * u_ice(ji,jj) - e2u(ji-1,jj) * u_ice(ji-1,jj)   & 
     722            &             + e1v(ji,jj) * v_ice(ji,jj) - e1v(ji,jj-1) * v_ice(ji,jj-1)   & 
     723            &             ) * r1_e1e2t(ji,jj) 
     724          
     725         ! delta at T points 
     726         zdelta         = SQRT( pdivu_i(ji,jj) * pdivu_i(ji,jj) + ( zdt2 + zds2 ) * z1_ecc2 )   
     727         rswitch        = 1._wp - MAX( 0._wp, SIGN( 1._wp, -zdelta ) ) ! 0 if delta=0 
     728         pdelta_i(ji,jj) = zdelta + rn_creepl * rswitch 
     729 
     730      END_2D 
    767731      CALL lbc_lnk_multi( 'icedyn_rhg_evp', pshear_i, 'T', 1., pdivu_i, 'T', 1., pdelta_i, 'T', 1. ) 
    768732       
    … …  
    802766         ALLOCATE( zsig1(jpi,jpj) , zsig2(jpi,jpj) , zsig3(jpi,jpj) ) 
    803767         !          
    804          DO jj = 2, jpjm1 
    805             DO ji = 2, jpim1 
    806                zdum1 = ( zmsk00(ji-1,jj) * pstress12_i(ji-1,jj) + zmsk00(ji  ,jj-1) * pstress12_i(ji  ,jj-1) +  &  ! stress12_i at T-point 
    807                   &      zmsk00(ji  ,jj) * pstress12_i(ji  ,jj) + zmsk00(ji-1,jj-1) * pstress12_i(ji-1,jj-1) )  & 
    808                   &    / MAX( 1._wp, zmsk00(ji-1,jj) + zmsk00(ji,jj-1) + zmsk00(ji,jj) + zmsk00(ji-1,jj-1) ) 
    809  
    810                zshear = SQRT( pstress2_i(ji,jj) * pstress2_i(ji,jj) + 4._wp * zdum1 * zdum1 ) ! shear stress   
    811  
    812                zdum2 = zmsk00(ji,jj) / MAX( 1._wp, strength(ji,jj) ) 
     768         DO_2D_00_00 
     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) ) 
    813776 
    814777!!               zsig1(ji,jj) = 0.5_wp * zdum2 * ( pstress1_i(ji,jj) + zshear ) ! principal stress (y-direction, see Hunke & Dukowicz 2002) 
    … …  
    816779!!               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 
    817780!!                                                                                                               ! (scheme converges if this value is ~1, see Bouillon et al 2009 (eq. 11)) 
    818                zsig1(ji,jj) = 0.5_wp * zdum2 * ( pstress1_i(ji,jj) )          ! compressive stress, see Bouillon et al. 2015 
    819                zsig2(ji,jj) = 0.5_wp * zdum2 * ( zshear )                     ! shear stress 
    820                zsig3(ji,jj) = zdum2**2 * ( ( pstress1_i(ji,jj) + strength(ji,jj) )**2 + ( rn_ecc * zshear )**2 ) 
    821             END DO 
    822          END DO 
     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_2D 
    823785         CALL lbc_lnk_multi( 'icedyn_rhg_evp', zsig1, 'T', 1., zsig2, 'T', 1., zsig3, 'T', 1. ) 
    824786         ! 
    … …  
    855817            &      zdiag_xmtrp_snw(jpi,jpj) , zdiag_ymtrp_snw(jpi,jpj) , zdiag_xatrp(jpi,jpj) , zdiag_yatrp(jpi,jpj) ) 
    856818         ! 
    857          DO jj = 2, jpjm1 
    858             DO ji = 2, jpim1 
    859                ! 2D ice mass, snow mass, area transport arrays (X, Y) 
    860                zfac_x = 0.5 * u_ice(ji,jj) * e2u(ji,jj) * zmsk00(ji,jj) 
    861                zfac_y = 0.5 * v_ice(ji,jj) * e1v(ji,jj) * zmsk00(ji,jj) 
    862  
    863                zdiag_xmtrp_ice(ji,jj) = rhoi * zfac_x * ( vt_i(ji+1,jj) + vt_i(ji,jj) ) ! ice mass transport, X-component 
    864                zdiag_ymtrp_ice(ji,jj) = rhoi * zfac_y * ( vt_i(ji,jj+1) + vt_i(ji,jj) ) !        ''           Y-   '' 
    865  
    866                zdiag_xmtrp_snw(ji,jj) = rhos * zfac_x * ( vt_s(ji+1,jj) + vt_s(ji,jj) ) ! snow mass transport, X-component 
    867                zdiag_ymtrp_snw(ji,jj) = rhos * zfac_y * ( vt_s(ji,jj+1) + vt_s(ji,jj) ) !          ''          Y-   '' 
    868  
    869                zdiag_xatrp(ji,jj)     = zfac_x * ( at_i(ji+1,jj) + at_i(ji,jj) )        ! area transport,      X-component 
    870                zdiag_yatrp(ji,jj)     = zfac_y * ( at_i(ji,jj+1) + at_i(ji,jj) )        !        ''            Y-   '' 
    871  
    872             END DO 
    873          END DO 
     819         DO_2D_00_00 
     820            ! 2D ice mass, snow mass, area transport arrays (X, Y) 
     821            zfac_x = 0.5 * u_ice(ji,jj) * e2u(ji,jj) * zmsk00(ji,jj) 
     822            zfac_y = 0.5 * v_ice(ji,jj) * e1v(ji,jj) * zmsk00(ji,jj) 
     823 
     824            zdiag_xmtrp_ice(ji,jj) = rhoi * zfac_x * ( vt_i(ji+1,jj) + vt_i(ji,jj) ) ! ice mass transport, X-component 
     825            zdiag_ymtrp_ice(ji,jj) = rhoi * zfac_y * ( vt_i(ji,jj+1) + vt_i(ji,jj) ) !        ''           Y-   '' 
     826 
     827            zdiag_xmtrp_snw(ji,jj) = rhos * zfac_x * ( vt_s(ji+1,jj) + vt_s(ji,jj) ) ! snow mass transport, X-component 
     828            zdiag_ymtrp_snw(ji,jj) = rhos * zfac_y * ( vt_s(ji,jj+1) + vt_s(ji,jj) ) !          ''          Y-   '' 
     829 
     830            zdiag_xatrp(ji,jj)     = zfac_x * ( at_i(ji+1,jj) + at_i(ji,jj) )        ! area transport,      X-component 
     831            zdiag_yatrp(ji,jj)     = zfac_y * ( at_i(ji,jj+1) + at_i(ji,jj) )        !        ''            Y-   '' 
     832 
     833         END_2D 
    874834 
    875835         CALL lbc_lnk_multi( 'icedyn_rhg_evp', zdiag_xmtrp_ice, 'U', -1., zdiag_ymtrp_ice, 'V', -1., & 
    … …  
    957917         zresm = 0._wp 
    958918      ELSE 
    959          DO jj = 1, jpj 
    960             DO ji = 1, jpi 
    961                zres(ji,jj) = MAX( ABS( pu(ji,jj) - pub(ji,jj) ) * umask(ji,jj,1), & 
    962                   &               ABS( pv(ji,jj) - pvb(ji,jj) ) * vmask(ji,jj,1) ) * zmsk15(ji,jj) 
    963             END DO 
    964          END DO 
     919         DO_2D_11_11 
     920            zres(ji,jj) = MAX( ABS( pu(ji,jj) - pub(ji,jj) ) * umask(ji,jj,1), & 
     921               &               ABS( pv(ji,jj) - pvb(ji,jj) ) * vmask(ji,jj,1) ) * zmsk15(ji,jj) 
     922         END_2D 
    965923         zresm = MAXVAL( zres ) 
    966924         CALL mpp_max( 'icedyn_rhg_evp', zresm )   ! max over the global domain 

  • NEMO/branches/2020/temporary_r4_trunk/src/ICE/iceistate.F90

    r13466 r13469  
    287287         ! select ice covered grid points 
    288288         npti = 0 ; nptidx(:) = 0 
    289          DO jj = 1, jpj 
    290             DO ji = 1, jpi 
    291                IF ( zht_i_ini(ji,jj) > 0._wp ) THEN 
    292                   npti         = npti  + 1 
    293                   nptidx(npti) = (jj - 1) * jpi + ji 
    294                ENDIF 
    295             END DO 
    296          END DO 
     289         DO_2D_11_11 
     290            IF ( zht_i_ini(ji,jj) > 0._wp ) THEN 
     291               npti         = npti  + 1 
     292               nptidx(npti) = (jj - 1) * jpi + ji 
     293            ENDIF 
     294         END_2D 
    297295 
    298296         ! move to 1D arrays: (jpi,jpj) -> (jpi*jpj) 
    … …  
    344342         CALL ice_var_salprof ! for sz_i 
    345343         DO jl = 1, jpl 
    346             DO jj = 1, jpj 
    347                DO ji = 1, jpi 
    348                   v_i (ji,jj,jl) = h_i(ji,jj,jl) * a_i(ji,jj,jl) 
    349                   v_s (ji,jj,jl) = h_s(ji,jj,jl) * a_i(ji,jj,jl) 
    350                   sv_i(ji,jj,jl) = MIN( MAX( rn_simin , s_i(ji,jj,jl) ) , rn_simax ) * v_i(ji,jj,jl) 
    351                END DO 
    352             END DO 
     344            DO_2D_11_11 
     345               v_i (ji,jj,jl) = h_i(ji,jj,jl) * a_i(ji,jj,jl) 
     346               v_s (ji,jj,jl) = h_s(ji,jj,jl) * a_i(ji,jj,jl) 
     347               sv_i(ji,jj,jl) = MIN( MAX( rn_simin , s_i(ji,jj,jl) ) , rn_simax ) * v_i(ji,jj,jl) 
     348            END_2D 
    353349         END DO 
    354350         ! 
    355351         DO jl = 1, jpl 
    356             DO jk = 1, nlay_s 
    357                DO jj = 1, jpj 
    358                   DO ji = 1, jpi 
    359                      t_s(ji,jj,jk,jl) = zts_3d(ji,jj,jl) 
    360                      e_s(ji,jj,jk,jl) = zswitch(ji,jj) * v_s(ji,jj,jl) * r1_nlay_s * & 
    361                         &               rhos * ( rcpi * ( rt0 - t_s(ji,jj,jk,jl) ) + rLfus ) 
    362                   END DO 
    363                END DO 
    364             END DO 
     352            DO_3D_11_11( 1, nlay_s ) 
     353               t_s(ji,jj,jk,jl) = zts_3d(ji,jj,jl) 
     354               e_s(ji,jj,jk,jl) = zswitch(ji,jj) * v_s(ji,jj,jl) * r1_nlay_s * & 
     355                  &               rhos * ( rcpi * ( rt0 - t_s(ji,jj,jk,jl) ) + rLfus ) 
     356            END_3D 
    365357         END DO 
    366358         ! 
    367359         DO jl = 1, jpl 
    368             DO jk = 1, nlay_i 
    369                DO jj = 1, jpj 
    370                   DO ji = 1, jpi 
    371                      t_i (ji,jj,jk,jl) = zti_3d(ji,jj,jl)  
    372                      ztmelts          = - rTmlt * sz_i(ji,jj,jk,jl) + rt0 ! melting temperature in K 
    373                      e_i(ji,jj,jk,jl) = zswitch(ji,jj) * v_i(ji,jj,jl) * r1_nlay_i * & 
    374                         &               rhoi * (  rcpi  * ( ztmelts - t_i(ji,jj,jk,jl) ) + & 
    375                         &                         rLfus * ( 1._wp - (ztmelts-rt0) / MIN( (t_i(ji,jj,jk,jl)-rt0), -epsi20 ) ) & 
    376                         &                       - rcp   * ( ztmelts - rt0 ) ) 
    377                   END DO 
    378                END DO 
    379             END DO 
     360            DO_3D_11_11( 1, nlay_i ) 
     361               t_i (ji,jj,jk,jl) = zti_3d(ji,jj,jl)  
     362               ztmelts          = - rTmlt * sz_i(ji,jj,jk,jl) + rt0 ! melting temperature in K 
     363               e_i(ji,jj,jk,jl) = zswitch(ji,jj) * v_i(ji,jj,jl) * r1_nlay_i * & 
     364                  &               rhoi * (  rcpi  * ( ztmelts - t_i(ji,jj,jk,jl) ) + & 
     365                  &                         rLfus * ( 1._wp - (ztmelts-rt0) / MIN( (t_i(ji,jj,jk,jl)-rt0), -epsi20 ) ) & 
     366                  &                       - rcp   * ( ztmelts - rt0 ) ) 
     367            END_3D 
    380368         END DO 
    381369 

  • NEMO/branches/2020/temporary_r4_trunk/src/ICE/iceitd.F90

    r13466 r13469  
    9797      ! 
    9898      npti = 0   ;   nptidx(:) = 0 
    99       DO jj = 1, jpj 
    100          DO ji = 1, jpi 
    101             IF ( at_i(ji,jj) > epsi10 ) THEN 
    102                npti = npti + 1 
    103                nptidx( npti ) = (jj - 1) * jpi + ji 
    104             ENDIF 
    105          END DO 
    106       END DO 
     99      DO_2D_11_11 
     100         IF ( at_i(ji,jj) > epsi10 ) THEN 
     101            npti = npti + 1 
     102            nptidx( npti ) = (jj - 1) * jpi + ji 
     103         ENDIF 
     104      END_2D 
    107105       
    108106      !----------------------------------------------------------------------------------------------- 
    … …  
    606604         !                    !--------------------------------------- 
    607605         npti = 0   ;   nptidx(:) = 0 
    608          DO jj = 1, jpj 
    609             DO ji = 1, jpi 
    610                IF( a_i(ji,jj,jl) > 0._wp .AND. v_i(ji,jj,jl) > (a_i(ji,jj,jl) * hi_max(jl)) ) THEN 
    611                   npti = npti + 1 
    612                   nptidx( npti ) = (jj - 1) * jpi + ji                   
    613                ENDIF 
    614             END DO 
    615          END DO 
     606         DO_2D_11_11 
     607            IF( a_i(ji,jj,jl) > 0._wp .AND. v_i(ji,jj,jl) > (a_i(ji,jj,jl) * hi_max(jl)) ) THEN 
     608               npti = npti + 1 
     609               nptidx( npti ) = (jj - 1) * jpi + ji                   
     610            ENDIF 
     611         END_2D 
    616612         ! 
    617613!!clem   CALL tab_2d_1d( npti, nptidx(1:npti), h_i_1d(1:npti), h_i(:,:,jl) ) 
    … …  
    647643         !                    !----------------------------------------- 
    648644         npti = 0 ; nptidx(:) = 0 
    649          DO jj = 1, jpj 
    650             DO ji = 1, jpi 
    651                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 
    652                   npti = npti + 1 
    653                   nptidx( npti ) = (jj - 1) * jpi + ji                   
    654                ENDIF 
    655             END DO 
    656          END DO 
     645         DO_2D_11_11 
     646            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 
     647               npti = npti + 1 
     648               nptidx( npti ) = (jj - 1) * jpi + ji                   
     649            ENDIF 
     650         END_2D 
    657651         ! 
    658652         CALL tab_2d_1d( npti, nptidx(1:npti), a_i_1d(1:npti), a_i(:,:,jl+1) ) ! jl+1 is ok 

  • NEMO/branches/2020/temporary_r4_trunk/src/ICE/icesbc.F90

    r13466 r13469  
    7777      IF( ln_mixcpl) THEN                                                        ! Case of a mixed Bulk/Coupled formulation 
    7878                                   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 
     79         DO_2D_00_00 
     80            utau_ice(ji,jj) = utau_ice(ji,jj) * xcplmask(ji,jj,0) + zutau_ice(ji,jj) * ( 1. - xcplmask(ji,jj,0) ) 
     81            vtau_ice(ji,jj) = vtau_ice(ji,jj) * xcplmask(ji,jj,0) + zvtau_ice(ji,jj) * ( 1. - xcplmask(ji,jj,0) ) 
     82         END_2D 
    8583         CALL lbc_lnk_multi( 'icesbc', utau_ice, 'U', -1., vtau_ice, 'V', -1. ) 
    8684      ENDIF 

  • NEMO/branches/2020/temporary_r4_trunk/src/ICE/icestp.F90

    r13467 r13469  
    209209      ! --- Ocean time step --- ! 
    210210      !-------------------------! 
    211       IF( ln_icedyn )                   CALL ice_update_tau( kt, ub(:,:,1), vb(:,:,1) )   ! -- update surface ocean stresses 
     211      IF( ln_icedyn )                   CALL ice_update_tau( kt, uu(:,:,1,Nnn), vv(:,:,1,Nnn) )   ! -- update surface ocean stresses 
    212212!!gm   remark, the ocean-ice stress is not saved in ice diag call above .....  find a solution!!! 
    213213      ! 

  • NEMO/branches/2020/temporary_r4_trunk/src/ICE/icethd.F90

    r13466 r13469  
    120120         zu_io(:,:) = u_ice(:,:) - ssu_m(:,:) 
    121121         zv_io(:,:) = v_ice(:,:) - ssv_m(:,:) 
    122          DO jj = 2, jpjm1  
    123             DO ji = fs_2, fs_jpim1 
    124                zfric(ji,jj) = rn_cio * ( 0.5_wp *  & 
    125                   &                    (  zu_io(ji,jj) * zu_io(ji,jj) + zu_io(ji-1,jj) * zu_io(ji-1,jj)   & 
    126                   &                     + zv_io(ji,jj) * zv_io(ji,jj) + zv_io(ji,jj-1) * zv_io(ji,jj-1) ) ) * tmask(ji,jj,1) 
    127             END DO 
    128          END DO 
     122         DO_2D_00_00 
     123            zfric(ji,jj) = rn_cio * ( 0.5_wp *  & 
     124               &                    (  zu_io(ji,jj) * zu_io(ji,jj) + zu_io(ji-1,jj) * zu_io(ji-1,jj)   & 
     125               &                     + zv_io(ji,jj) * zv_io(ji,jj) + zv_io(ji,jj-1) * zv_io(ji,jj-1) ) ) * tmask(ji,jj,1) 
     126         END_2D 
    129127      ELSE      !  if no ice dynamics => transmit directly the atmospheric stress to the ocean 
    130          DO jj = 2, jpjm1 
    131             DO ji = fs_2, fs_jpim1 
    132                zfric(ji,jj) = r1_rau0 * SQRT( 0.5_wp *  & 
    133                   &                         (  utau(ji,jj) * utau(ji,jj) + utau(ji-1,jj) * utau(ji-1,jj)   & 
    134                   &                          + vtau(ji,jj) * vtau(ji,jj) + vtau(ji,jj-1) * vtau(ji,jj-1) ) ) * tmask(ji,jj,1) 
    135             END DO 
    136          END DO 
     128         DO_2D_00_00 
     129            zfric(ji,jj) = r1_rau0 * SQRT( 0.5_wp *  & 
     130               &                         (  utau(ji,jj) * utau(ji,jj) + utau(ji-1,jj) * utau(ji-1,jj)   & 
     131               &                          + vtau(ji,jj) * vtau(ji,jj) + vtau(ji,jj-1) * vtau(ji,jj-1) ) ) * tmask(ji,jj,1) 
     132         END_2D 
    137133      ENDIF 
    138134      CALL lbc_lnk( 'icethd', zfric, 'T',  1. ) 
    … …  
    141137      ! Partial computation of forcing for the thermodynamic sea ice model 
    142138      !--------------------------------------------------------------------! 
    143       DO jj = 1, jpj 
    144          DO ji = 1, jpi 
    145             rswitch  = tmask(ji,jj,1) * MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi10 ) ) ! 0 if no ice 
    146             ! 
    147             !           !  solar irradiance transmission at the mixed layer bottom and used in the lead heat budget 
    148             !           !  practically no "direct lateral ablation" 
    149             !            
    150             !           !  net downward heat flux from the ice to the ocean, expressed as a function of ocean  
    151             !           !  temperature and turbulent mixing (McPhee, 1992) 
    152             ! 
    153             ! --- Energy received in the lead from atm-oce exchanges, zqld is defined everywhere (J.m-2) --- ! 
    154             zqld =  tmask(ji,jj,1) * rdt_ice *  & 
    155                &    ( ( 1._wp - at_i_b(ji,jj) ) * qsr_oce(ji,jj) * frq_m(ji,jj) +  & 
    156                &      ( 1._wp - at_i_b(ji,jj) ) * qns_oce(ji,jj) + qemp_oce(ji,jj) ) 
    157  
    158             ! --- Energy needed to bring ocean surface layer until its freezing (mostly<0 but >0 if supercooling, J.m-2) --- ! 
    159             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) 
    160             zqfr_neg = MIN( zqfr , 0._wp )                                                                    ! only < 0 
    161  
    162             ! --- Sensible ocean-to-ice heat flux (mostly>0 but <0 if supercooling, W/m2) 
    163             zfric_u            = MAX( SQRT( zfric(ji,jj) ), zfric_umin )  
    164             qsb_ice_bot(ji,jj) = rswitch * rau0 * rcp * zch * zfric_u * ( ( sst_m(ji,jj) + rt0 ) - t_bo(ji,jj) ) ! W.m-2 
    165  
    166             qsb_ice_bot(ji,jj) = rswitch * MIN( qsb_ice_bot(ji,jj), - zqfr_neg * r1_rdtice / MAX( at_i(ji,jj), epsi10 ) ) 
    167             ! upper bound for qsb_ice_bot: the heat retrieved from the ocean must be smaller than the heat necessary to reach  
    168             !                              the freezing point, so that we do not have SST < T_freeze 
    169             !                              This implies: - ( qsb_ice_bot(ji,jj) * at_i(ji,jj) * rtdice ) - zqfr >= 0 
    170  
    171             !-- Energy Budget of the leads (J.m-2), source of ice growth in open water. Must be < 0 to form ice 
    172             qlead(ji,jj) = MIN( 0._wp , zqld - ( qsb_ice_bot(ji,jj) * at_i(ji,jj) * rdt_ice ) - zqfr ) 
    173  
    174             ! If there is ice and leads are warming => transfer energy from the lead budget and use it for bottom melting  
    175             ! If the grid cell is fully covered by ice (no leads) => transfer energy from the lead budget to the ice bottom budget 
    176             IF( ( zqld >= 0._wp .AND. at_i(ji,jj) > 0._wp ) .OR. at_i(ji,jj) >= (1._wp - epsi10) ) THEN 
    177                IF( ln_leadhfx ) THEN   ;   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 
    178                ELSE                    ;   fhld(ji,jj) = 0._wp 
    179                ENDIF 
    180                qlead(ji,jj) = 0._wp 
    181             ELSE 
    182                fhld (ji,jj) = 0._wp 
     139      DO_2D_11_11 
     140         rswitch  = tmask(ji,jj,1) * MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi10 ) ) ! 0 if no ice 
     141         ! 
     142         !           !  solar irradiance transmission at the mixed layer bottom and used in the lead heat budget 
     143         !           !  practically no "direct lateral ablation" 
     144         !            
     145         !           !  net downward heat flux from the ice to the ocean, expressed as a function of ocean  
     146         !           !  temperature and turbulent mixing (McPhee, 1992) 
     147         ! 
     148         ! --- Energy received in the lead from atm-oce exchanges, zqld is defined everywhere (J.m-2) --- ! 
     149         zqld =  tmask(ji,jj,1) * rdt_ice *  & 
     150            &    ( ( 1._wp - at_i_b(ji,jj) ) * qsr_oce(ji,jj) * frq_m(ji,jj) +  & 
     151            &      ( 1._wp - at_i_b(ji,jj) ) * qns_oce(ji,jj) + qemp_oce(ji,jj) ) 
     152 
     153         ! --- Energy needed to bring ocean surface layer until its freezing (mostly<0 but >0 if supercooling, J.m-2) --- ! 
     154         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) 
     155         zqfr_neg = MIN( zqfr , 0._wp )                                                                    ! only < 0 
     156 
     157         ! --- Sensible ocean-to-ice heat flux (mostly>0 but <0 if supercooling, W/m2) 
     158         zfric_u            = MAX( SQRT( zfric(ji,jj) ), zfric_umin )  
     159         qsb_ice_bot(ji,jj) = rswitch * rau0 * rcp * zch * zfric_u * ( ( sst_m(ji,jj) + rt0 ) - t_bo(ji,jj) ) ! W.m-2 
     160 
     161         qsb_ice_bot(ji,jj) = rswitch * MIN( qsb_ice_bot(ji,jj), - zqfr_neg * r1_rdtice / MAX( at_i(ji,jj), epsi10 ) ) 
     162         ! upper bound for qsb_ice_bot: the heat retrieved from the ocean must be smaller than the heat necessary to reach  
     163         !                              the freezing point, so that we do not have SST < T_freeze 
     164         !                              This implies: - ( qsb_ice_bot(ji,jj) * at_i(ji,jj) * rtdice ) - zqfr >= 0 
     165 
     166         !-- Energy Budget of the leads (J.m-2), source of ice growth in open water. Must be < 0 to form ice 
     167         qlead(ji,jj) = MIN( 0._wp , zqld - ( qsb_ice_bot(ji,jj) * at_i(ji,jj) * rdt_ice ) - zqfr ) 
     168 
     169         ! If there is ice and leads are warming => transfer energy from the lead budget and use it for bottom melting  
     170         ! If the grid cell is fully covered by ice (no leads) => transfer energy from the lead budget to the ice bottom budget 
     171         IF( ( zqld >= 0._wp .AND. at_i(ji,jj) > 0._wp ) .OR. at_i(ji,jj) >= (1._wp - epsi10) ) THEN 
     172            IF( ln_leadhfx ) THEN   ;   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 
     173            ELSE                    ;   fhld(ji,jj) = 0._wp 
    183174            ENDIF 
    184             ! 
    185             ! Net heat flux on top of the ice-ocean [W.m-2] 
    186             ! --------------------------------------------- 
    187             qt_atm_oi(ji,jj) = qns_tot(ji,jj) + qsr_tot(ji,jj)  
    188          END DO 
    189       END DO 
     175            qlead(ji,jj) = 0._wp 
     176         ELSE 
     177            fhld (ji,jj) = 0._wp 
     178         ENDIF 
     179         ! 
     180         ! Net heat flux on top of the ice-ocean [W.m-2] 
     181         ! --------------------------------------------- 
     182         qt_atm_oi(ji,jj) = qns_tot(ji,jj) + qsr_tot(ji,jj)  
     183      END_2D 
    190184       
    191185      ! In case we bypass open-water ice formation 
    … …  
    215209         ! select ice covered grid points 
    216210         npti = 0 ; nptidx(:) = 0 
    217          DO jj = 1, jpj 
    218             DO ji = 1, jpi 
    219                IF ( a_i(ji,jj,jl) > epsi10 ) THEN      
    220                   npti         = npti  + 1 
    221                   nptidx(npti) = (jj - 1) * jpi + ji 
    222                ENDIF 
    223             END DO 
    224          END DO 
     211         DO_2D_11_11 
     212            IF ( a_i(ji,jj,jl) > epsi10 ) THEN      
     213               npti         = npti  + 1 
     214               nptidx(npti) = (jj - 1) * jpi + ji 
     215            ENDIF 
     216         END_2D 
    225217 
    226218         IF( npti > 0 ) THEN  ! If there is no ice, do nothing. 

  • NEMO/branches/2020/temporary_r4_trunk/src/ICE/iceupdate.F90

    r13466 r13469  
    114114      ENDIF 
    115115       
    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 
     116      DO_2D_11_11 
     117 
     118         ! Solar heat flux reaching the ocean = zqsr (W.m-2)  
     119         !--------------------------------------------------- 
     120         zqsr = qsr_tot(ji,jj) - SUM( a_i_b(ji,jj,:) * ( qsr_ice(ji,jj,:) - qtr_ice_bot(ji,jj,:) ) ) 
     121 
     122         ! Total heat flux reaching the ocean = qt_oce_ai (W.m-2)  
     123         !--------------------------------------------------- 
     124         zqmass           = hfx_thd(ji,jj) + hfx_dyn(ji,jj) + hfx_res(ji,jj) ! heat flux from snow is 0 (T=0 degC) 
     125         qt_oce_ai(ji,jj) = qt_oce_ai(ji,jj) + zqmass + zqsr 
     126 
     127         ! Add the residual from heat diffusion equation and sublimation (W.m-2) 
     128         !---------------------------------------------------------------------- 
     129         qt_oce_ai(ji,jj) = qt_oce_ai(ji,jj) + hfx_err_dif(ji,jj) +   & 
     130            &             ( hfx_sub(ji,jj) - SUM( qevap_ice(ji,jj,:) * a_i_b(ji,jj,:) ) ) 
     131 
     132         ! New qsr and qns used to compute the oceanic heat flux at the next time step 
     133         !---------------------------------------------------------------------------- 
     134         qsr(ji,jj) = zqsr                                       
     135         qns(ji,jj) = qt_oce_ai(ji,jj) - zqsr               
     136 
     137         ! Mass flux at the atm. surface        
     138         !----------------------------------- 
     139         wfx_sub(ji,jj) = wfx_snw_sub(ji,jj) + wfx_ice_sub(ji,jj) 
     140 
     141         ! Mass flux at the ocean surface       
     142         !------------------------------------ 
     143         !  case of realistic freshwater flux (Tartinville et al., 2001) (presently ACTIVATED) 
     144         !  -------------------------------------------------------------------------------------  
     145         !  The idea of this approach is that the system that we consider is the ICE-OCEAN system 
     146         !  Thus  FW  flux  =  External ( E-P+snow melt) 
     147         !       Salt flux  =  Exchanges in the ice-ocean system then converted into FW 
     148         !                     Associated to Ice formation AND Ice melting 
     149         !                     Even if i see Ice melting as a FW and SALT flux 
     150         !         
     151         ! mass flux from ice/ocean 
     152         wfx_ice(ji,jj) = wfx_bog(ji,jj) + wfx_bom(ji,jj) + wfx_sum(ji,jj) + wfx_sni(ji,jj)   & 
     153            &           + wfx_opw(ji,jj) + wfx_dyn(ji,jj) + wfx_res(ji,jj) + wfx_lam(ji,jj) + wfx_pnd(ji,jj) 
     154 
     155         ! add the snow melt water to snow mass flux to the ocean 
     156         wfx_snw(ji,jj) = wfx_snw_sni(ji,jj) + wfx_snw_dyn(ji,jj) + wfx_snw_sum(ji,jj) 
     157 
     158         ! mass flux at the ocean/ice interface 
     159         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 
     160         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) 
     161 
     162 
     163         ! Salt flux at the ocean surface       
     164         !------------------------------------------ 
     165         sfx(ji,jj) = sfx_bog(ji,jj) + sfx_bom(ji,jj) + sfx_sum(ji,jj) + sfx_sni(ji,jj) + sfx_opw(ji,jj)   & 
     166            &       + sfx_res(ji,jj) + sfx_dyn(ji,jj) + sfx_bri(ji,jj) + sfx_sub(ji,jj) + sfx_lam(ji,jj) 
     167          
     168         ! Mass of snow and ice per unit area    
     169         !---------------------------------------- 
     170         snwice_mass_b(ji,jj) = snwice_mass(ji,jj)       ! save mass from the previous ice time step 
     171         !                                               ! new mass per unit area 
     172         snwice_mass  (ji,jj) = tmask(ji,jj,1) * ( rhos * vt_s(ji,jj) + rhoi * vt_i(ji,jj)  )  
     173         !                                               ! time evolution of snow+ice mass 
     174         snwice_fmass (ji,jj) = ( snwice_mass(ji,jj) - snwice_mass_b(ji,jj) ) * r1_rdtice 
     175          
     176      END_2D 
    179177 
    180178      ! Storing the transmitted variables 
    … …  
    335333      ! 
    336334      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 
     335         DO_2D_00_00 
     336            !                                               ! 2*(U_ice-U_oce) at T-point 
     337            zu_t = u_ice(ji,jj) + u_ice(ji-1,jj) - u_oce(ji,jj) - u_oce(ji-1,jj)    
     338            zv_t = v_ice(ji,jj) + v_ice(ji,jj-1) - v_oce(ji,jj) - v_oce(ji,jj-1)  
     339            !                                              ! |U_ice-U_oce|^2 
     340            zmodt =  0.25_wp * (  zu_t * zu_t + zv_t * zv_t  ) 
     341            !                                               ! update the ocean stress modulus 
     342            taum(ji,jj) = ( 1._wp - at_i(ji,jj) ) * taum(ji,jj) + at_i(ji,jj) * zrhoco * zmodt 
     343            tmod_io(ji,jj) = zrhoco * SQRT( zmodt )          ! rhoco * |U_ice-U_oce| at T-point 
     344         END_2D 
    349345         CALL lbc_lnk_multi( 'iceupdate', taum, 'T', 1., tmod_io, 'T', 1. ) 
    350346         ! 
    … …  
    363359      ENDIF 
    364360      ! 
    365       DO jj = 2, jpjm1                                !* update the stress WITHOUT an ice-ocean rotation angle 
    366          DO ji = fs_2, fs_jpim1   ! Vect. Opt.    
    367             ! ice area at u and v-points  
    368             zat_u  = ( at_i(ji,jj) * tmask(ji,jj,1) + at_i (ji+1,jj    ) * tmask(ji+1,jj  ,1) )  & 
    369                &     / MAX( 1.0_wp , tmask(ji,jj,1) + tmask(ji+1,jj  ,1) ) 
    370             zat_v  = ( at_i(ji,jj) * tmask(ji,jj,1) + at_i (ji  ,jj+1  ) * tmask(ji  ,jj+1,1) )  & 
    371                &     / MAX( 1.0_wp , tmask(ji,jj,1) + tmask(ji  ,jj+1,1) ) 
    372             !                                                   ! linearized quadratic drag formulation 
    373             zutau_ice   = 0.5_wp * ( tmod_io(ji,jj) + tmod_io(ji+1,jj) ) * ( u_ice(ji,jj) - zflagi * pu_oce(ji,jj) ) 
    374             zvtau_ice   = 0.5_wp * ( tmod_io(ji,jj) + tmod_io(ji,jj+1) ) * ( v_ice(ji,jj) - zflagi * pv_oce(ji,jj) ) 
    375             !                                                   ! stresses at the ocean surface 
    376             utau(ji,jj) = ( 1._wp - zat_u ) * utau_oce(ji,jj) + zat_u * zutau_ice 
    377             vtau(ji,jj) = ( 1._wp - zat_v ) * vtau_oce(ji,jj) + zat_v * zvtau_ice 
    378          END DO 
    379       END DO 
     361      DO_2D_00_00 
     362         ! ice area at u and v-points  
     363         zat_u  = ( at_i(ji,jj) * tmask(ji,jj,1) + at_i (ji+1,jj    ) * tmask(ji+1,jj  ,1) )  & 
     364            &     / MAX( 1.0_wp , tmask(ji,jj,1) + tmask(ji+1,jj  ,1) ) 
     365         zat_v  = ( at_i(ji,jj) * tmask(ji,jj,1) + at_i (ji  ,jj+1  ) * tmask(ji  ,jj+1,1) )  & 
     366            &     / MAX( 1.0_wp , tmask(ji,jj,1) + tmask(ji  ,jj+1,1) ) 
     367         !                                                   ! linearized quadratic drag formulation 
     368         zutau_ice   = 0.5_wp * ( tmod_io(ji,jj) + tmod_io(ji+1,jj) ) * ( u_ice(ji,jj) - zflagi * pu_oce(ji,jj) ) 
     369         zvtau_ice   = 0.5_wp * ( tmod_io(ji,jj) + tmod_io(ji,jj+1) ) * ( v_ice(ji,jj) - zflagi * pv_oce(ji,jj) ) 
     370         !                                                   ! stresses at the ocean surface 
     371         utau(ji,jj) = ( 1._wp - zat_u ) * utau_oce(ji,jj) + zat_u * zutau_ice 
     372         vtau(ji,jj) = ( 1._wp - zat_v ) * vtau_oce(ji,jj) + zat_v * zvtau_ice 
     373      END_2D 
    380374      CALL lbc_lnk_multi( 'iceupdate', utau, 'U', -1., vtau, 'V', -1. )   ! lateral boundary condition 
    381375      ! 

  • NEMO/branches/2020/temporary_r4_trunk/src/ICE/icevar.F90

    r13466 r13469  
    263263      zlay_i   = REAL( nlay_i , wp )    ! number of layers 
    264264      DO jl = 1, jpl 
    265          DO jk = 1, nlay_i 
    266             DO jj = 1, jpj 
    267                DO ji = 1, jpi 
    268                   IF ( v_i(ji,jj,jl) > epsi20 ) THEN     !--- icy area  
    269                      ! 
    270                      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] 
    271                      ztmelts          = - sz_i(ji,jj,jk,jl) * rTmlt                                 ! Ice layer melt temperature [C] 
    272                      ! Conversion q(S,T) -> T (second order equation) 
    273                      zbbb             = ( rcp - rcpi ) * ztmelts + ze_i * r1_rhoi - rLfus 
    274                      zccc             = SQRT( MAX( zbbb * zbbb - 4._wp * rcpi * rLfus * ztmelts , 0._wp) ) 
    275                      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 
    276                      ! 
    277                   ELSE                                   !--- no ice 
    278                      t_i(ji,jj,jk,jl) = rt0 
    279                   ENDIF 
    280                END DO 
    281             END DO 
    282          END DO 
     265         DO_3D_11_11( 1, nlay_i ) 
     266            IF ( v_i(ji,jj,jl) > epsi20 ) THEN     !--- icy area  
     267               ! 
     268               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] 
     269               ztmelts          = - sz_i(ji,jj,jk,jl) * rTmlt                                 ! Ice layer melt temperature [C] 
     270               ! Conversion q(S,T) -> T (second order equation) 
     271               zbbb             = ( rcp - rcpi ) * ztmelts + ze_i * r1_rhoi - rLfus 
     272               zccc             = SQRT( MAX( zbbb * zbbb - 4._wp * rcpi * rLfus * ztmelts , 0._wp) ) 
     273               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 
     274               ! 
     275            ELSE                                   !--- no ice 
     276               t_i(ji,jj,jk,jl) = rt0 
     277            ENDIF 
     278         END_3D 
    283279      END DO 
    284280 
    … …  
    372368         z1_dS = 1._wp / ( zsi1 - zsi0 ) 
    373369         DO jl = 1, jpl 
    374             DO jj = 1, jpj 
    375                DO ji = 1, jpi 
    376                   zalpha(ji,jj,jl) = MAX(  0._wp , MIN( ( zsi1 - s_i(ji,jj,jl) ) * z1_dS , 1._wp )  ) 
    377                   !                             ! force a constant profile when SSS too low (Baltic Sea) 
    378                   IF( 2._wp * s_i(ji,jj,jl) >= sss_m(ji,jj) )   zalpha(ji,jj,jl) = 0._wp   
    379                END DO 
    380             END DO 
     370            DO_2D_11_11 
     371               zalpha(ji,jj,jl) = MAX(  0._wp , MIN( ( zsi1 - s_i(ji,jj,jl) ) * z1_dS , 1._wp )  ) 
     372               !                             ! force a constant profile when SSS too low (Baltic Sea) 
     373               IF( 2._wp * s_i(ji,jj,jl) >= sss_m(ji,jj) )   zalpha(ji,jj,jl) = 0._wp   
     374            END_2D 
    381375         END DO 
    382376         ! 
    383377         ! Computation of the profile 
    384378         DO jl = 1, jpl 
    385             DO jk = 1, nlay_i 
    386                DO jj = 1, jpj 
    387                   DO ji = 1, jpi 
    388                      !                          ! linear profile with 0 surface value 
    389                      zs0 = z_slope_s(ji,jj,jl) * ( REAL(jk,wp) - 0.5_wp ) * h_i(ji,jj,jl) * r1_nlay_i 
    390                      zs  = zalpha(ji,jj,jl) * zs0 + ( 1._wp - zalpha(ji,jj,jl) ) * s_i(ji,jj,jl)     ! weighting the profile 
    391                      sz_i(ji,jj,jk,jl) = MIN( rn_simax, MAX( zs, rn_simin ) ) 
    392                   END DO 
    393                END DO 
    394             END DO 
     379            DO_3D_11_11( 1, nlay_i ) 
     380               !                          ! linear profile with 0 surface value 
     381               zs0 = z_slope_s(ji,jj,jl) * ( REAL(jk,wp) - 0.5_wp ) * h_i(ji,jj,jl) * r1_nlay_i 
     382               zs  = zalpha(ji,jj,jl) * zs0 + ( 1._wp - zalpha(ji,jj,jl) ) * s_i(ji,jj,jl)     ! weighting the profile 
     383               sz_i(ji,jj,jk,jl) = MIN( rn_simax, MAX( zs, rn_simin ) ) 
     384            END_3D 
    395385         END DO 
    396386         ! 
    … …  
    517507         ! Zap ice energy and use ocean heat to melt ice 
    518508         !----------------------------------------------------------------- 
    519          DO jk = 1, nlay_i 
    520             DO jj = 1 , jpj 
    521                DO ji = 1 , jpi 
    522                   ! update exchanges with ocean 
    523                   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 
    524                   e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) * zswitch(ji,jj) 
    525                   t_i(ji,jj,jk,jl) = t_i(ji,jj,jk,jl) * zswitch(ji,jj) + rt0 * ( 1._wp - zswitch(ji,jj) ) 
    526                END DO 
    527             END DO 
    528          END DO 
    529          ! 
    530          DO jk = 1, nlay_s 
    531             DO jj = 1 , jpj 
    532                DO ji = 1 , jpi 
    533                   ! update exchanges with ocean 
    534                   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 
    535                   e_s(ji,jj,jk,jl) = e_s(ji,jj,jk,jl) * zswitch(ji,jj) 
    536                   t_s(ji,jj,jk,jl) = t_s(ji,jj,jk,jl) * zswitch(ji,jj) + rt0 * ( 1._wp - zswitch(ji,jj) ) 
    537                END DO 
    538             END DO 
    539          END DO 
     509         DO_3D_11_11( 1, nlay_i ) 
     510            ! update exchanges with ocean 
     511            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 
     512            e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) * zswitch(ji,jj) 
     513            t_i(ji,jj,jk,jl) = t_i(ji,jj,jk,jl) * zswitch(ji,jj) + rt0 * ( 1._wp - zswitch(ji,jj) ) 
     514         END_3D 
     515         ! 
     516         DO_3D_11_11( 1, nlay_s ) 
     517            ! update exchanges with ocean 
     518            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 
     519            e_s(ji,jj,jk,jl) = e_s(ji,jj,jk,jl) * zswitch(ji,jj) 
     520            t_s(ji,jj,jk,jl) = t_s(ji,jj,jk,jl) * zswitch(ji,jj) + rt0 * ( 1._wp - zswitch(ji,jj) ) 
     521         END_3D 
    540522         ! 
    541523         !----------------------------------------------------------------- 
    542524         ! zap ice and snow volume, add water and salt to ocean 
    543525         !----------------------------------------------------------------- 
    544          DO jj = 1 , jpj 
    545             DO ji = 1 , jpi 
    546                ! update exchanges with ocean 
    547                sfx_res(ji,jj)  = sfx_res(ji,jj) + (1._wp - zswitch(ji,jj) ) * sv_i(ji,jj,jl)   * rhoi * r1_rdtice 
    548                wfx_res(ji,jj)  = wfx_res(ji,jj) + (1._wp - zswitch(ji,jj) ) * v_i (ji,jj,jl)   * rhoi * r1_rdtice 
    549                wfx_res(ji,jj)  = wfx_res(ji,jj) + (1._wp - zswitch(ji,jj) ) * v_s (ji,jj,jl)   * rhos * r1_rdtice 
    550                ! 
    551                a_i  (ji,jj,jl) = a_i (ji,jj,jl) * zswitch(ji,jj) 
    552                v_i  (ji,jj,jl) = v_i (ji,jj,jl) * zswitch(ji,jj) 
    553                v_s  (ji,jj,jl) = v_s (ji,jj,jl) * zswitch(ji,jj) 
    554                t_su (ji,jj,jl) = t_su(ji,jj,jl) * zswitch(ji,jj) + t_bo(ji,jj) * ( 1._wp - zswitch(ji,jj) ) 
    555                oa_i (ji,jj,jl) = oa_i(ji,jj,jl) * zswitch(ji,jj) 
    556                sv_i (ji,jj,jl) = sv_i(ji,jj,jl) * zswitch(ji,jj) 
    557                ! 
    558                h_i (ji,jj,jl) = h_i (ji,jj,jl) * zswitch(ji,jj) 
    559                h_s (ji,jj,jl) = h_s (ji,jj,jl) * zswitch(ji,jj) 
    560                ! 
    561                a_ip (ji,jj,jl) = a_ip (ji,jj,jl) * zswitch(ji,jj) 
    562                v_ip (ji,jj,jl) = v_ip (ji,jj,jl) * zswitch(ji,jj) 
    563                v_il (ji,jj,jl) = v_il (ji,jj,jl) * zswitch(ji,jj) 
    564                ! 
    565             END DO 
    566          END DO 
     526         DO_2D_11_11 
     527            ! update exchanges with ocean 
     528            sfx_res(ji,jj)  = sfx_res(ji,jj) + (1._wp - zswitch(ji,jj) ) * sv_i(ji,jj,jl)   * rhoi * r1_rdtice 
     529            wfx_res(ji,jj)  = wfx_res(ji,jj) + (1._wp - zswitch(ji,jj) ) * v_i (ji,jj,jl)   * rhoi * r1_rdtice 
     530            wfx_res(ji,jj)  = wfx_res(ji,jj) + (1._wp - zswitch(ji,jj) ) * v_s (ji,jj,jl)   * rhos * r1_rdtice 
     531            ! 
     532            a_i  (ji,jj,jl) = a_i (ji,jj,jl) * zswitch(ji,jj) 
     533            v_i  (ji,jj,jl) = v_i (ji,jj,jl) * zswitch(ji,jj) 
     534            v_s  (ji,jj,jl) = v_s (ji,jj,jl) * zswitch(ji,jj) 
     535            t_su (ji,jj,jl) = t_su(ji,jj,jl) * zswitch(ji,jj) + t_bo(ji,jj) * ( 1._wp - zswitch(ji,jj) ) 
     536            oa_i (ji,jj,jl) = oa_i(ji,jj,jl) * zswitch(ji,jj) 
     537            sv_i (ji,jj,jl) = sv_i(ji,jj,jl) * zswitch(ji,jj) 
     538            ! 
     539            h_i (ji,jj,jl) = h_i (ji,jj,jl) * zswitch(ji,jj) 
     540            h_s (ji,jj,jl) = h_s (ji,jj,jl) * zswitch(ji,jj) 
     541            ! 
     542            a_ip (ji,jj,jl) = a_ip (ji,jj,jl) * zswitch(ji,jj) 
     543            v_ip (ji,jj,jl) = v_ip (ji,jj,jl) * zswitch(ji,jj) 
     544            v_il (ji,jj,jl) = v_il (ji,jj,jl) * zswitch(ji,jj) 
     545            ! 
     546         END_2D 
    567547         ! 
    568548      END DO  
    … …  
    617597         ! zap ice energy and send it to the ocean 
    618598         !---------------------------------------- 
    619          DO jk = 1, nlay_i 
    620             DO jj = 1 , jpj 
    621                DO ji = 1 , jpi 
    622                   IF( pe_i(ji,jj,jk,jl) < 0._wp .OR. pa_i(ji,jj,jl) <= 0._wp ) THEN 
    623                      hfx_res(ji,jj)   = hfx_res(ji,jj) - pe_i(ji,jj,jk,jl) * z1_dt ! W.m-2 >0 
    624                      pe_i(ji,jj,jk,jl) = 0._wp 
    625                   ENDIF 
    626                END DO 
    627             END DO 
    628          END DO 
    629          ! 
    630          DO jk = 1, nlay_s 
    631             DO jj = 1 , jpj 
    632                DO ji = 1 , jpi 
    633                   IF( pe_s(ji,jj,jk,jl) < 0._wp .OR. pa_i(ji,jj,jl) <= 0._wp ) THEN 
    634                      hfx_res(ji,jj)   = hfx_res(ji,jj) - pe_s(ji,jj,jk,jl) * z1_dt ! W.m-2 <0 
    635                      pe_s(ji,jj,jk,jl) = 0._wp 
    636                   ENDIF 
    637                END DO 
    638             END DO 
    639          END DO 
     599         DO_3D_11_11( 1, nlay_i ) 
     600            IF( pe_i(ji,jj,jk,jl) < 0._wp .OR. pa_i(ji,jj,jl) <= 0._wp ) THEN 
     601               hfx_res(ji,jj)   = hfx_res(ji,jj) - pe_i(ji,jj,jk,jl) * z1_dt ! W.m-2 >0 
     602               pe_i(ji,jj,jk,jl) = 0._wp 
     603            ENDIF 
     604         END_3D 
     605         ! 
     606         DO_3D_11_11( 1, nlay_s ) 
     607            IF( pe_s(ji,jj,jk,jl) < 0._wp .OR. pa_i(ji,jj,jl) <= 0._wp ) THEN 
     608               hfx_res(ji,jj)   = hfx_res(ji,jj) - pe_s(ji,jj,jk,jl) * z1_dt ! W.m-2 <0 
     609               pe_s(ji,jj,jk,jl) = 0._wp 
     610            ENDIF 
     611         END_3D 
    640612         ! 
    641613         !----------------------------------------------------- 
    642614         ! zap ice and snow volume, add water and salt to ocean 
    643615         !----------------------------------------------------- 
    644          DO jj = 1 , jpj 
    645             DO ji = 1 , jpi 
    646                IF( pv_i(ji,jj,jl) < 0._wp .OR. pa_i(ji,jj,jl) <= 0._wp ) THEN 
    647                   wfx_res(ji,jj)    = wfx_res(ji,jj) + pv_i (ji,jj,jl) * rhoi * z1_dt 
    648                   pv_i   (ji,jj,jl) = 0._wp 
    649                ENDIF 
    650                IF( pv_s(ji,jj,jl) < 0._wp .OR. pa_i(ji,jj,jl) <= 0._wp ) THEN 
    651                   wfx_res(ji,jj)    = wfx_res(ji,jj) + pv_s (ji,jj,jl) * rhos * z1_dt 
    652                   pv_s   (ji,jj,jl) = 0._wp 
    653                ENDIF 
    654                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 
    655                   sfx_res(ji,jj)    = sfx_res(ji,jj) + psv_i(ji,jj,jl) * rhoi * z1_dt 
    656                   psv_i  (ji,jj,jl) = 0._wp 
    657                ENDIF 
    658             END DO 
    659          END DO 
     616         DO_2D_11_11 
     617            IF( pv_i(ji,jj,jl) < 0._wp .OR. pa_i(ji,jj,jl) <= 0._wp ) THEN 
     618               wfx_res(ji,jj)    = wfx_res(ji,jj) + pv_i (ji,jj,jl) * rhoi * z1_dt 
     619               pv_i   (ji,jj,jl) = 0._wp 
     620            ENDIF 
     621            IF( pv_s(ji,jj,jl) < 0._wp .OR. pa_i(ji,jj,jl) <= 0._wp ) THEN 
     622               wfx_res(ji,jj)    = wfx_res(ji,jj) + pv_s (ji,jj,jl) * rhos * z1_dt 
     623               pv_s   (ji,jj,jl) = 0._wp 
     624            ENDIF 
     625            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 
     626               sfx_res(ji,jj)    = sfx_res(ji,jj) + psv_i(ji,jj,jl) * rhoi * z1_dt 
     627               psv_i  (ji,jj,jl) = 0._wp 
     628            ENDIF 
     629         END_2D 
    660630         ! 
    661631      END DO  

  • NEMO/branches/2020/temporary_r4_trunk/src/ICE/icewri.F90

    r13466 r13469  
    6969 
    7070      ! 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 
     71      DO_2D_11_11 
     72         zmsk00(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi06  ) ) ! 1 if ice    , 0 if no ice 
     73         zmsk05(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - 0.05_wp ) ) ! 1 if 5% ice , 0 if less 
     74         zmsk15(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - 0.15_wp ) ) ! 1 if 15% ice, 0 if less 
     75         zmsksn(ji,jj) = MAX( 0._wp , SIGN( 1._wp , vt_s(ji,jj) - epsi06  ) ) ! 1 if snow   , 0 if no snow 
     76      END_2D 
    7977      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 
     78         DO_2D_11_11 
     79            zmsk00l(ji,jj,jl)  = MAX( 0._wp , SIGN( 1._wp , a_i(ji,jj,jl) - epsi06 ) ) 
     80            zmsksnl(ji,jj,jl)  = MAX( 0._wp , SIGN( 1._wp , v_s(ji,jj,jl) - epsi06 ) ) 
     81         END_2D 
    8682      END DO 
    8783 
    … …  
    134130      ! 
    135131      IF( iom_use('icevel') .OR. iom_use('fasticepres') ) THEN                                                              ! module of ice velocity 
    136          DO jj = 2 , jpjm1 
    137             DO ji = 2 , jpim1 
    138                z2da  = u_ice(ji,jj) + u_ice(ji-1,jj) 
    139                z2db  = v_ice(ji,jj) + v_ice(ji,jj-1) 
    140                z2d(ji,jj) = 0.5_wp * SQRT( z2da * z2da + z2db * z2db ) 
    141            END DO 
    142          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 
    143137         CALL lbc_lnk( 'icewri', z2d, 'T', 1. ) 
    144138         CALL iom_put( 'icevel', z2d ) 

  • NEMO/branches/2020/temporary_r4_trunk/src/OCE/BDY/bdydta.F90

    r13466 r13469  
    145145                        ii = idx_bdy(jbdy)%nbi(ib,igrd) 
    146146                        ij = idx_bdy(jbdy)%nbj(ib,igrd) 
    147                         dta_bdy(jbdy)%u3d(ib,ik) =  ( un(ii,ij,ik) - un_b(ii,ij) ) * umask(ii,ij,ik)          
     147                        dta_bdy(jbdy)%u3d(ib,ik) =  ( uu(ii,ij,ik,Nii) - un_b(ii,ij) ) * umask(ii,ij,ik)          
    148148                     END DO 
    149149                  END DO 
    … …  
    153153                        ii = idx_bdy(jbdy)%nbi(ib,igrd) 
    154154                        ij = idx_bdy(jbdy)%nbj(ib,igrd) 
    155                         dta_bdy(jbdy)%v3d(ib,ik) =  ( vn(ii,ij,ik) - vn_b(ii,ij) ) * vmask(ii,ij,ik)          
     155                        dta_bdy(jbdy)%v3d(ib,ik) =  ( vv(ii,ij,ik,Nii) - vn_b(ii,ij) ) * vmask(ii,ij,ik)          
    156156                     END DO 
    157157                  END DO 

  • NEMO/branches/2020/temporary_r4_trunk/src/OCE/DOM/domain.F90

    r13466 r13469  
    140140                                       ! Read in masks to define closed seas and lakes  
    141141      ! 
    142       DO jj = 1, jpj                   ! depth of the iceshelves 
    143          DO ji = 1, jpi 
    144             ik = mikt(ji,jj) 
    145             risfdep(ji,jj) = gdepw_0(ji,jj,ik) 
    146          END DO 
    147       END DO 
     142      DO_2D_11_11 
     143         ik = mikt(ji,jj) 
     144         risfdep(ji,jj) = gdepw_0(ji,jj,ik) 
     145      END_2D 
    148146      ! 
    149147      ht_0(:,:) = 0._wp  ! Reference ocean thickness 

  • NEMO/branches/2020/temporary_r4_trunk/src/OCE/DYN/dynspg_ts.F90

    r13466 r13469  
    253253         IF( ln_wd_il ) THEN                       ! W/D : limiter applied to spgspg 
    254254            CALL wad_spg( sshn, zcpx, zcpy )          ! Calculating W/D gravity filters, zcpx and zcpy 
    255             DO jj = 2, jpjm1 
    256                DO ji = 2, jpim1                ! SPG with the application of W/D gravity filters 
    257                   zu_trd(ji,jj) = zu_trd(ji,jj) - grav * ( sshn(ji+1,jj  ) - sshn(ji  ,jj ) )   & 
    258                      &                          * r1_e1u(ji,jj) * zcpx(ji,jj)  * wdrampu(ji,jj)  !jth 
    259                   zv_trd(ji,jj) = zv_trd(ji,jj) - grav * ( sshn(ji  ,jj+1) - sshn(ji  ,jj ) )   & 
    260                      &                          * r1_e2v(ji,jj) * zcpy(ji,jj)  * wdrampv(ji,jj)  !jth 
    261                END DO 
    262             END DO 
     255            DO_2D_00_00 
     256               zu_trd(ji,jj) = zu_trd(ji,jj) - grav * ( sshn(ji+1,jj  ) - sshn(ji  ,jj ) )   & 
     257                  &                          * r1_e1u(ji,jj) * zcpx(ji,jj)  * wdrampu(ji,jj)  !jth 
     258               zv_trd(ji,jj) = zv_trd(ji,jj) - grav * ( sshn(ji  ,jj+1) - sshn(ji  ,jj ) )   & 
     259                  &                          * r1_e2v(ji,jj) * zcpy(ji,jj)  * wdrampv(ji,jj)  !jth 
     260            END_2D 
    263261         ELSE                                      ! now suface pressure gradient 
    264             DO jj = 2, jpjm1 
    265                DO ji = fs_2, fs_jpim1   ! vector opt. 
    266                   zu_trd(ji,jj) = zu_trd(ji,jj) - grav * (  sshn(ji+1,jj  ) - sshn(ji  ,jj  )  ) * r1_e1u(ji,jj) 
    267                   zv_trd(ji,jj) = zv_trd(ji,jj) - grav * (  sshn(ji  ,jj+1) - sshn(ji  ,jj  )  ) * r1_e2v(ji,jj)  
    268                END DO 
    269             END DO 
    270          ENDIF 
    271          ! 
    272       ENDIF 
    273       ! 
    274       DO jj = 2, jpjm1                          ! Remove coriolis term (and possibly spg) from barotropic trend 
    275          DO ji = fs_2, fs_jpim1 
    276              zu_frc(ji,jj) = zu_frc(ji,jj) - zu_trd(ji,jj) * ssumask(ji,jj) 
    277              zv_frc(ji,jj) = zv_frc(ji,jj) - zv_trd(ji,jj) * ssvmask(ji,jj) 
    278           END DO 
    279       END DO  
     262            DO_2D_00_00 
     263               zu_trd(ji,jj) = zu_trd(ji,jj) - grav * (  sshn(ji+1,jj  ) - sshn(ji  ,jj  )  ) * r1_e1u(ji,jj) 
     264               zv_trd(ji,jj) = zv_trd(ji,jj) - grav * (  sshn(ji  ,jj+1) - sshn(ji  ,jj  )  ) * r1_e2v(ji,jj)  
     265            END_2D 
     266         ENDIF 
     267         ! 
     268      ENDIF 
     269      ! 
     270      DO_2D_00_00 
     271          zu_frc(ji,jj) = zu_frc(ji,jj) - zu_trd(ji,jj) * ssumask(ji,jj) 
     272          zv_frc(ji,jj) = zv_frc(ji,jj) - zv_trd(ji,jj) * ssvmask(ji,jj) 
     273      END_2D 
    280274      ! 
    281275      !                                   !=  Add bottom stress contribution from baroclinic velocities  =! 
    … …  
    287281      IF( ln_apr_dyn ) THEN 
    288282         IF( ln_bt_fw ) THEN                          ! FORWARD integration: use kt+1/2 pressure (NOW+1/2) 
    289             DO jj = 2, jpjm1               
    290                DO ji = fs_2, fs_jpim1   ! vector opt. 
    291                   zu_frc(ji,jj) = zu_frc(ji,jj) + grav * (  ssh_ib (ji+1,jj  ) - ssh_ib (ji,jj) ) * r1_e1u(ji,jj) 
    292                   zv_frc(ji,jj) = zv_frc(ji,jj) + grav * (  ssh_ib (ji  ,jj+1) - ssh_ib (ji,jj) ) * r1_e2v(ji,jj) 
    293                END DO 
    294             END DO 
     283            DO_2D_00_00 
     284               zu_frc(ji,jj) = zu_frc(ji,jj) + grav * (  ssh_ib (ji+1,jj  ) - ssh_ib (ji,jj) ) * r1_e1u(ji,jj) 
     285               zv_frc(ji,jj) = zv_frc(ji,jj) + grav * (  ssh_ib (ji  ,jj+1) - ssh_ib (ji,jj) ) * r1_e2v(ji,jj) 
     286            END_2D 
    295287         ELSE                                         ! CENTRED integration: use kt-1/2 + kt+1/2 pressure (NOW) 
    296288            zztmp = grav * r1_2 
    297             DO jj = 2, jpjm1               
    298                DO ji = fs_2, fs_jpim1   ! vector opt. 
    299                   zu_frc(ji,jj) = zu_frc(ji,jj) + zztmp * (  ssh_ib (ji+1,jj  ) - ssh_ib (ji,jj)  & 
    300                        &                                   + ssh_ibb(ji+1,jj  ) - ssh_ibb(ji,jj)  ) * r1_e1u(ji,jj) 
    301                   zv_frc(ji,jj) = zv_frc(ji,jj) + zztmp * (  ssh_ib (ji  ,jj+1) - ssh_ib (ji,jj)  & 
    302                        &                                   + ssh_ibb(ji  ,jj+1) - ssh_ibb(ji,jj)  ) * r1_e2v(ji,jj) 
    303                END DO 
    304             END DO 
     289            DO_2D_00_00 
     290               zu_frc(ji,jj) = zu_frc(ji,jj) + zztmp * (  ssh_ib (ji+1,jj  ) - ssh_ib (ji,jj)  & 
     291                    &                                   + ssh_ibb(ji+1,jj  ) - ssh_ibb(ji,jj)  ) * r1_e1u(ji,jj) 
     292               zv_frc(ji,jj) = zv_frc(ji,jj) + zztmp * (  ssh_ib (ji  ,jj+1) - ssh_ib (ji,jj)  & 
     293                    &                                   + ssh_ibb(ji  ,jj+1) - ssh_ibb(ji,jj)  ) * r1_e2v(ji,jj) 
     294            END_2D 
    305295         ENDIF  
    306296      ENDIF 
    … …  
    309299      !                                   !  ----------------------------------  ! 
    310300      IF( ln_bt_fw ) THEN                        ! Add wind forcing 
    311          DO jj = 2, jpjm1 
    312             DO ji = fs_2, fs_jpim1   ! vector opt. 
    313                zu_frc(ji,jj) =  zu_frc(ji,jj) + r1_rau0 * utau(ji,jj) * r1_hu_n(ji,jj) 
    314                zv_frc(ji,jj) =  zv_frc(ji,jj) + r1_rau0 * vtau(ji,jj) * r1_hv_n(ji,jj) 
    315             END DO 
    316          END DO 
     301         DO_2D_00_00 
     302            zu_frc(ji,jj) =  zu_frc(ji,jj) + r1_rau0 * utau(ji,jj) * r1_hu_n(ji,jj) 
     303            zv_frc(ji,jj) =  zv_frc(ji,jj) + r1_rau0 * vtau(ji,jj) * r1_hv_n(ji,jj) 
     304         END_2D 
    317305      ELSE 
    318306         zztmp = r1_rau0 * r1_2 
    319          DO jj = 2, jpjm1 
    320             DO ji = fs_2, fs_jpim1   ! vector opt. 
    321                zu_frc(ji,jj) =  zu_frc(ji,jj) + zztmp * ( utau_b(ji,jj) + utau(ji,jj) ) * r1_hu_n(ji,jj) 
    322                zv_frc(ji,jj) =  zv_frc(ji,jj) + zztmp * ( vtau_b(ji,jj) + vtau(ji,jj) ) * r1_hv_n(ji,jj) 
    323             END DO 
    324          END DO 
     307         DO_2D_00_00 
     308            zu_frc(ji,jj) =  zu_frc(ji,jj) + zztmp * ( utau_b(ji,jj) + utau(ji,jj) ) * r1_hu_n(ji,jj) 
     309            zv_frc(ji,jj) =  zv_frc(ji,jj) + zztmp * ( vtau_b(ji,jj) + vtau(ji,jj) ) * r1_hv_n(ji,jj) 
     310         END_2D 
    325311      ENDIF   
    326312      ! 
    … …  
    457443            ! 
    458444            !                          ! ocean u- and v-depth at mid-step   (separate DO-loops remove the need of a lbc_lnk) 
    459             DO jj = 1, jpj 
    460                DO ji = 1, jpim1   ! not jpi-column 
    461                   zhup2_e(ji,jj) = hu_0(ji,jj) + r1_2 * r1_e1e2u(ji,jj)                        & 
    462                        &                              * (  e1e2t(ji  ,jj) * zsshp2_e(ji  ,jj)  & 
    463                        &                                 + e1e2t(ji+1,jj) * zsshp2_e(ji+1,jj)  ) * ssumask(ji,jj) 
    464                END DO 
    465             END DO 
    466             DO jj = 1, jpjm1        ! not jpj-row 
    467                DO ji = 1, jpi 
    468                   zhvp2_e(ji,jj) = hv_0(ji,jj) + r1_2 * r1_e1e2v(ji,jj)                        & 
    469                        &                              * (  e1e2t(ji,jj  ) * zsshp2_e(ji,jj  )  & 
    470                        &                                 + e1e2t(ji,jj+1) * zsshp2_e(ji,jj+1)  ) * ssvmask(ji,jj) 
    471                END DO 
    472             END DO 
     445            DO_2D_11_10 
     446               zhup2_e(ji,jj) = hu_0(ji,jj) + r1_2 * r1_e1e2u(ji,jj)                        & 
     447                    &                              * (  e1e2t(ji  ,jj) * zsshp2_e(ji  ,jj)  & 
     448                    &                                 + e1e2t(ji+1,jj) * zsshp2_e(ji+1,jj)  ) * ssumask(ji,jj) 
     449            END_2D 
     450            DO_2D_10_11 
     451               zhvp2_e(ji,jj) = hv_0(ji,jj) + r1_2 * r1_e1e2v(ji,jj)                        & 
     452                    &                              * (  e1e2t(ji,jj  ) * zsshp2_e(ji,jj  )  & 
     453                    &                                 + e1e2t(ji,jj+1) * zsshp2_e(ji,jj+1)  ) * ssvmask(ji,jj) 
     454            END_2D 
    473455            ! 
    474456         ENDIF 
    … …  
    526508         !--        ssh    =  ssh   - delta_t' * [ frc + div( flux      ) ]      --! 
    527509         !-------------------------------------------------------------------------! 
    528          DO jj = 2, jpjm1        ! INNER domain                              
    529             DO ji = 2, jpim1 
    530                zhdiv = (   zhU(ji,jj) - zhU(ji-1,jj) + zhV(ji,jj) - zhV(ji,jj-1)   ) * r1_e1e2t(ji,jj) 
    531                ssha_e(ji,jj) = (  sshn_e(ji,jj) - rdtbt * ( zssh_frc(ji,jj) + zhdiv )  ) * ssmask(ji,jj) 
    532             END DO 
    533          END DO 
     510         DO_2D_00_00 
     511            zhdiv = (   zhU(ji,jj) - zhU(ji-1,jj) + zhV(ji,jj) - zhV(ji,jj-1)   ) * r1_e1e2t(ji,jj) 
     512            ssha_e(ji,jj) = (  sshn_e(ji,jj) - rdtbt * ( zssh_frc(ji,jj) + zhdiv )  ) * ssmask(ji,jj) 
     513         END_2D 
    534514         ! 
    535515         CALL lbc_lnk_multi( 'dynspg_ts', ssha_e, 'T', 1._wp,  zhU, 'U', -1._wp,  zhV, 'V', -1._wp ) 
    … …  
    553533         ! Sea Surface Height at u-,v-points (vvl case only) 
    554534         IF( .NOT.ln_linssh ) THEN                                 
    555             DO jj = 2, jpjm1   ! INNER domain, will be extended to whole domain later 
    556                DO ji = 2, jpim1      ! NO Vector Opt. 
    557                   zsshu_a(ji,jj) = r1_2 * ssumask(ji,jj) * r1_e1e2u(ji,jj)    & 
    558                      &              * ( e1e2t(ji  ,jj  )  * ssha_e(ji  ,jj  ) & 
    559                      &              +   e1e2t(ji+1,jj  )  * ssha_e(ji+1,jj  ) ) 
    560                   zsshv_a(ji,jj) = r1_2 * ssvmask(ji,jj) * r1_e1e2v(ji,jj)    & 
    561                      &              * ( e1e2t(ji  ,jj  )  * ssha_e(ji  ,jj  ) & 
    562                      &              +   e1e2t(ji  ,jj+1)  * ssha_e(ji  ,jj+1) ) 
    563                END DO 
    564             END DO 
     535            DO_2D_00_00 
     536               zsshu_a(ji,jj) = r1_2 * ssumask(ji,jj) * r1_e1e2u(ji,jj)    & 
     537                  &              * ( e1e2t(ji  ,jj  )  * ssha_e(ji  ,jj  ) & 
     538                  &              +   e1e2t(ji+1,jj  )  * ssha_e(ji+1,jj  ) ) 
     539               zsshv_a(ji,jj) = r1_2 * ssvmask(ji,jj) * r1_e1e2v(ji,jj)    & 
     540                  &              * ( e1e2t(ji  ,jj  )  * ssha_e(ji  ,jj  ) & 
     541                  &              +   e1e2t(ji  ,jj+1)  * ssha_e(ji  ,jj+1) ) 
     542            END_2D 
    565543         ENDIF    
    566544         !          
    … …  
    575553         !                             ! Surface pressure gradient 
    576554         zldg = ( 1._wp - rn_scal_load ) * grav    ! local factor 
    577          DO jj = 2, jpjm1                             
    578             DO ji = 2, jpim1 
    579                zu_spg(ji,jj) = - zldg * ( zsshp2_e(ji+1,jj) - zsshp2_e(ji,jj) ) * r1_e1u(ji,jj) 
    580                zv_spg(ji,jj) = - zldg * ( zsshp2_e(ji,jj+1) - zsshp2_e(ji,jj) ) * r1_e2v(ji,jj) 
    581             END DO 
    582          END DO 
     555         DO_2D_00_00 
     556            zu_spg(ji,jj) = - zldg * ( zsshp2_e(ji+1,jj) - zsshp2_e(ji,jj) ) * r1_e1u(ji,jj) 
     557            zv_spg(ji,jj) = - zldg * ( zsshp2_e(ji,jj+1) - zsshp2_e(ji,jj) ) * r1_e2v(ji,jj) 
     558         END_2D 
    583559         IF( ln_wd_il ) THEN        ! W/D : gravity filters applied on pressure gradient 
    584560            CALL wad_spg( zsshp2_e, zcpx, zcpy )   ! Calculating W/D gravity filters 
    … …  
    595571         ! Add tidal astronomical forcing if defined 
    596572         IF ( ln_tide .AND. ln_tide_pot ) THEN 
    597             DO jj = 2, jpjm1 
    598                DO ji = fs_2, fs_jpim1   ! vector opt. 
    599                   zu_trd(ji,jj) = zu_trd(ji,jj) + grav * ( pot_astro(ji+1,jj) - pot_astro(ji,jj) ) * r1_e1u(ji,jj) 
    600                   zv_trd(ji,jj) = zv_trd(ji,jj) + grav * ( pot_astro(ji,jj+1) - pot_astro(ji,jj) ) * r1_e2v(ji,jj) 
    601                END DO 
    602             END DO 
     573            DO_2D_00_00 
     574               zu_trd(ji,jj) = zu_trd(ji,jj) + grav * ( pot_astro(ji+1,jj) - pot_astro(ji,jj) ) * r1_e1u(ji,jj) 
     575               zv_trd(ji,jj) = zv_trd(ji,jj) + grav * ( pot_astro(ji,jj+1) - pot_astro(ji,jj) ) * r1_e2v(ji,jj) 
     576            END_2D 
    603577         ENDIF 
    604578         ! 
    … …  
    606580!jth do implicitly instead 
    607581         IF ( .NOT. ll_wd ) THEN ! Revert to explicit for bit comparison tests in non wad runs 
    608             DO jj = 2, jpjm1 
    609                DO ji = fs_2, fs_jpim1   ! vector opt. 
    610                   zu_trd(ji,jj) = zu_trd(ji,jj) + zCdU_u(ji,jj) * un_e(ji,jj) * hur_e(ji,jj) 
    611                   zv_trd(ji,jj) = zv_trd(ji,jj) + zCdU_v(ji,jj) * vn_e(ji,jj) * hvr_e(ji,jj) 
    612                END DO 
    613             END DO 
     582            DO_2D_00_00 
     583               zu_trd(ji,jj) = zu_trd(ji,jj) + zCdU_u(ji,jj) * un_e(ji,jj) * hur_e(ji,jj) 
     584               zv_trd(ji,jj) = zv_trd(ji,jj) + zCdU_v(ji,jj) * vn_e(ji,jj) * hvr_e(ji,jj) 
     585            END_2D 
    614586         ENDIF 
    615587         ! 
    … …  
    626598         !------------------------------------------------------------------------------------------------------------------------! 
    627599         IF( ln_dynadv_vec .OR. ln_linssh ) THEN      !* Vector form 
    628             DO jj = 2, jpjm1 
    629                DO ji = fs_2, fs_jpim1   ! vector opt. 
    630                   ua_e(ji,jj) = (                                 un_e(ji,jj)   &  
    631                             &     + rdtbt * (                   zu_spg(ji,jj)   & 
    632                             &                                 + zu_trd(ji,jj)   & 
    633                             &                                 + zu_frc(ji,jj) ) &  
    634                             &   ) * ssumask(ji,jj) 
    635  
    636                   va_e(ji,jj) = (                                 vn_e(ji,jj)   & 
    637                             &     + rdtbt * (                   zv_spg(ji,jj)   & 
    638                             &                                 + zv_trd(ji,jj)   & 
    639                             &                                 + zv_frc(ji,jj) ) & 
    640                             &   ) * ssvmask(ji,jj) 
    641                END DO 
    642             END DO 
     600            DO_2D_00_00 
     601               ua_e(ji,jj) = (                                 un_e(ji,jj)   &  
     602                         &     + rdtbt * (                   zu_spg(ji,jj)   & 
     603                         &                                 + zu_trd(ji,jj)   & 
     604                         &                                 + zu_frc(ji,jj) ) &  
     605                         &   ) * ssumask(ji,jj) 
     606 
     607               va_e(ji,jj) = (                                 vn_e(ji,jj)   & 
     608                         &     + rdtbt * (                   zv_spg(ji,jj)   & 
     609                         &                                 + zv_trd(ji,jj)   & 
     610                         &                                 + zv_frc(ji,jj) ) & 
     611                         &   ) * ssvmask(ji,jj) 
     612            END_2D 
    643613            ! 
    644614         ELSE                           !* Flux form 
    645             DO jj = 2, jpjm1 
    646                DO ji = 2, jpim1 
    647                   !                    ! hu_e, hv_e hold depth at jn,  zhup2_e, zhvp2_e hold extrapolated depth at jn+1/2 
    648                   !                    ! backward interpolated depth used in spg terms at jn+1/2 
    649                   zhu_bck = hu_0(ji,jj) + r1_2*r1_e1e2u(ji,jj) * (  e1e2t(ji  ,jj) * zsshp2_e(ji  ,jj)    & 
    650                        &                                          + e1e2t(ji+1,jj) * zsshp2_e(ji+1,jj)  ) * ssumask(ji,jj) 
    651                   zhv_bck = hv_0(ji,jj) + r1_2*r1_e1e2v(ji,jj) * (  e1e2t(ji,jj  ) * zsshp2_e(ji,jj  )    & 
    652                        &                                          + e1e2t(ji,jj+1) * zsshp2_e(ji,jj+1)  ) * ssvmask(ji,jj) 
    653                   !                    ! inverse depth at jn+1 
    654                   z1_hu = ssumask(ji,jj) / ( hu_0(ji,jj) + zsshu_a(ji,jj) + 1._wp - ssumask(ji,jj) ) 
    655                   z1_hv = ssvmask(ji,jj) / ( hv_0(ji,jj) + zsshv_a(ji,jj) + 1._wp - ssvmask(ji,jj) ) 
    656                   ! 
    657                   ua_e(ji,jj) = (               hu_e  (ji,jj) *   un_e (ji,jj)      &  
    658                        &            + rdtbt * (  zhu_bck        * zu_spg (ji,jj)  &   ! 
    659                        &                       + zhup2_e(ji,jj) * zu_trd (ji,jj)  &   ! 
    660                        &                       +  hu_n  (ji,jj) * zu_frc (ji,jj)  )   ) * z1_hu 
    661                   ! 
    662                   va_e(ji,jj) = (               hv_e  (ji,jj) *   vn_e (ji,jj)      & 
    663                        &            + rdtbt * (  zhv_bck        * zv_spg (ji,jj)  &   ! 
    664                        &                       + zhvp2_e(ji,jj) * zv_trd (ji,jj)  &   ! 
    665                        &                       +  hv_n  (ji,jj) * zv_frc (ji,jj)  )   ) * z1_hv 
    666                END DO 
    667             END DO 
     615            DO_2D_00_00 
     616               !                    ! hu_e, hv_e hold depth at jn,  zhup2_e, zhvp2_e hold extrapolated depth at jn+1/2 
     617               !                    ! backward interpolated depth used in spg terms at jn+1/2 
     618               zhu_bck = hu_0(ji,jj) + r1_2*r1_e1e2u(ji,jj) * (  e1e2t(ji  ,jj) * zsshp2_e(ji  ,jj)    & 
     619                    &                                          + e1e2t(ji+1,jj) * zsshp2_e(ji+1,jj)  ) * ssumask(ji,jj) 
     620               zhv_bck = hv_0(ji,jj) + r1_2*r1_e1e2v(ji,jj) * (  e1e2t(ji,jj  ) * zsshp2_e(ji,jj  )    & 
     621                    &                                          + e1e2t(ji,jj+1) * zsshp2_e(ji,jj+1)  ) * ssvmask(ji,jj) 
     622               !                    ! inverse depth at jn+1 
     623               z1_hu = ssumask(ji,jj) / ( hu_0(ji,jj) + zsshu_a(ji,jj) + 1._wp - ssumask(ji,jj) ) 
     624               z1_hv = ssvmask(ji,jj) / ( hv_0(ji,jj) + zsshv_a(ji,jj) + 1._wp - ssvmask(ji,jj) ) 
     625               ! 
     626               ua_e(ji,jj) = (               hu_e  (ji,jj) *   un_e (ji,jj)      &  
     627                    &            + rdtbt * (  zhu_bck        * zu_spg (ji,jj)  &   ! 
     628                    &                       + zhup2_e(ji,jj) * zu_trd (ji,jj)  &   ! 
     629                    &                       +  hu_n  (ji,jj) * zu_frc (ji,jj)  )   ) * z1_hu 
     630               ! 
     631               va_e(ji,jj) = (               hv_e  (ji,jj) *   vn_e (ji,jj)      & 
     632                    &            + rdtbt * (  zhv_bck        * zv_spg (ji,jj)  &   ! 
     633                    &                       + zhvp2_e(ji,jj) * zv_trd (ji,jj)  &   ! 
     634                    &                       +  hv_n  (ji,jj) * zv_frc (ji,jj)  )   ) * z1_hv 
     635            END_2D 
    668636         ENDIF 
    669637!jth implicit bottom friction: 
    670638         IF ( ll_wd ) THEN ! revert to explicit for bit comparison tests in non wad runs 
    671             DO jj = 2, jpjm1 
    672                DO ji = fs_2, fs_jpim1   ! vector opt. 
    673                      ua_e(ji,jj) =  ua_e(ji,jj) /(1.0 -   rdtbt * zCdU_u(ji,jj) * hur_e(ji,jj)) 
    674                      va_e(ji,jj) =  va_e(ji,jj) /(1.0 -   rdtbt * zCdU_v(ji,jj) * hvr_e(ji,jj)) 
    675                END DO 
    676             END DO 
     639            DO_2D_00_00 
     640                  ua_e(ji,jj) =  ua_e(ji,jj) /(1.0 -   rdtbt * zCdU_u(ji,jj) * hur_e(ji,jj)) 
     641                  va_e(ji,jj) =  va_e(ji,jj) /(1.0 -   rdtbt * zCdU_v(ji,jj) * hvr_e(ji,jj)) 
     642            END_2D 
    677643         ENDIF 
    678644        
    … …  
    737703      IF (ln_bt_fw) THEN 
    738704         IF( .NOT.( kt == nit000 .AND. neuler==0 ) ) THEN 
    739             DO jj = 1, jpj 
    740                DO ji = 1, jpi 
    741                   zun_save = un_adv(ji,jj) 
    742                   zvn_save = vn_adv(ji,jj) 
    743                   !                          ! apply the previously computed correction  
    744                   un_adv(ji,jj) = r1_2 * ( ub2_b(ji,jj) + zun_save - atfp * un_bf(ji,jj) ) 
    745                   vn_adv(ji,jj) = r1_2 * ( vb2_b(ji,jj) + zvn_save - atfp * vn_bf(ji,jj) ) 
    746                   !                          ! Update corrective fluxes for next time step 
    747                   un_bf(ji,jj)  = atfp * un_bf(ji,jj) + ( zun_save - ub2_b(ji,jj) ) 
    748                   vn_bf(ji,jj)  = atfp * vn_bf(ji,jj) + ( zvn_save - vb2_b(ji,jj) ) 
    749                   !                          ! Save integrated transport for next computation 
    750                   ub2_b(ji,jj) = zun_save 
    751                   vb2_b(ji,jj) = zvn_save 
    752                END DO 
    753             END DO 
     705            DO_2D_11_11 
     706               zun_save = un_adv(ji,jj) 
     707               zvn_save = vn_adv(ji,jj) 
     708               !                          ! apply the previously computed correction  
     709               un_adv(ji,jj) = r1_2 * ( ub2_b(ji,jj) + zun_save - atfp * un_bf(ji,jj) ) 
     710               vn_adv(ji,jj) = r1_2 * ( vb2_b(ji,jj) + zvn_save - atfp * vn_bf(ji,jj) ) 
     711               !                          ! Update corrective fluxes for next time step 
     712               un_bf(ji,jj)  = atfp * un_bf(ji,jj) + ( zun_save - ub2_b(ji,jj) ) 
     713               vn_bf(ji,jj)  = atfp * vn_bf(ji,jj) + ( zvn_save - vb2_b(ji,jj) ) 
     714               !                          ! Save integrated transport for next computation 
     715               ub2_b(ji,jj) = zun_save 
     716               vb2_b(ji,jj) = zvn_save 
     717            END_2D 
    754718         ELSE 
    755719            un_bf(:,:) = 0._wp            ! corrective fluxes for next time step set to zero 
    … …  
    770734      ELSE 
    771735         ! At this stage, ssha has been corrected: compute new depths at velocity points 
    772          DO jj = 1, jpjm1 
    773             DO ji = 1, jpim1      ! NO Vector Opt. 
    774                zsshu_a(ji,jj) = r1_2 * ssumask(ji,jj)  * r1_e1e2u(ji,jj) & 
    775                   &              * ( e1e2t(ji  ,jj) * ssha(ji  ,jj)      & 
    776                   &              +   e1e2t(ji+1,jj) * ssha(ji+1,jj) ) 
    777                zsshv_a(ji,jj) = r1_2 * ssvmask(ji,jj)  * r1_e1e2v(ji,jj) & 
    778                   &              * ( e1e2t(ji,jj  ) * ssha(ji,jj  )      & 
    779                   &              +   e1e2t(ji,jj+1) * ssha(ji,jj+1) ) 
    780             END DO 
    781          END DO 
     736         DO_2D_10_10 
     737            zsshu_a(ji,jj) = r1_2 * ssumask(ji,jj)  * r1_e1e2u(ji,jj) & 
     738               &              * ( e1e2t(ji  ,jj) * ssha(ji  ,jj)      & 
     739               &              +   e1e2t(ji+1,jj) * ssha(ji+1,jj) ) 
     740            zsshv_a(ji,jj) = r1_2 * ssvmask(ji,jj)  * r1_e1e2v(ji,jj) & 
     741               &              * ( e1e2t(ji,jj  ) * ssha(ji,jj  )      & 
     742               &              +   e1e2t(ji,jj+1) * ssha(ji,jj+1) ) 
     743         END_2D 
    782744         CALL lbc_lnk_multi( 'dynspg_ts', zsshu_a, 'U', 1._wp, zsshv_a, 'V', 1._wp ) ! Boundary conditions 
    783745         ! 
    … …  
    794756      ! Correct velocities so that the barotropic velocity equals (un_adv, vn_adv) (in all cases)   
    795757      DO jk = 1, jpkm1 
    796          un(:,:,jk) = ( un(:,:,jk) + un_adv(:,:)*r1_hu_n(:,:) - un_b(:,:) ) * umask(:,:,jk) 
    797          vn(:,:,jk) = ( vn(:,:,jk) + vn_adv(:,:)*r1_hv_n(:,:) - vn_b(:,:) ) * vmask(:,:,jk) 
     758         uu(:,:,jk,Nii) = ( uu(:,:,jk,Nii) + un_adv(:,:)*r1_hu_n(:,:) - un_b(:,:) ) * umask(:,:,jk) 
     759         vv(:,:,jk,Nii) = ( vv(:,:,jk,Nii) + vn_adv(:,:)*r1_hv_n(:,:) - vn_b(:,:) ) * vmask(:,:,jk) 
    798760      END DO 
    799761 
    … …  
    802764         CALL lbc_lnk_multi( 'dynspg_ts', zuwdav2, 'U', 1._wp, zvwdav2, 'V', 1._wp) 
    803765         DO jk = 1, jpkm1 
    804             un(:,:,jk) = ( un_adv(:,:)*r1_hu_n(:,:) & 
    805                        & + zuwdav2(:,:)*(un(:,:,jk) - un_adv(:,:)*r1_hu_n(:,:)) ) * umask(:,:,jk)  
    806             vn(:,:,jk) = ( vn_adv(:,:)*r1_hv_n(:,:) &  
    807                        & + zvwdav2(:,:)*(vn(:,:,jk) - vn_adv(:,:)*r1_hv_n(:,:)) ) * vmask(:,:,jk)   
     766            uu(:,:,jk,Nii) = ( un_adv(:,:)*r1_hu_n(:,:) & 
     767                       & + zuwdav2(:,:)*(uu(:,:,jk,Nii) - un_adv(:,:)*r1_hu_n(:,:)) ) * umask(:,:,jk)  
     768            vv(:,:,jk,Nii) = ( vn_adv(:,:)*r1_hv_n(:,:) &  
     769                       & + zvwdav2(:,:)*(vv(:,:,jk,Nii) - vn_adv(:,:)*r1_hv_n(:,:)) ) * vmask(:,:,jk)   
    808770         END DO 
    809771      END IF  
    … …  
    1007969      ! Max courant number for ext. grav. waves 
    1008970      ! 
    1009       DO jj = 1, jpj 
    1010          DO ji =1, jpi 
    1011             zxr2 = r1_e1t(ji,jj) * r1_e1t(ji,jj) 
    1012             zyr2 = r1_e2t(ji,jj) * r1_e2t(ji,jj) 
    1013             zcu(ji,jj) = SQRT( grav * MAX(ht_0(ji,jj),0._wp) * (zxr2 + zyr2) ) 
    1014          END DO 
    1015       END DO 
     971      DO_2D_11_11 
     972         zxr2 = r1_e1t(ji,jj) * r1_e1t(ji,jj) 
     973         zyr2 = r1_e2t(ji,jj) * r1_e2t(ji,jj) 
     974         zcu(ji,jj) = SQRT( grav * MAX(ht_0(ji,jj),0._wp) * (zxr2 + zyr2) ) 
     975      END_2D 
    1016976      ! 
    1017977      zcmax = MAXVAL( zcu(:,:) ) 
    … …  
    11331093         SELECT CASE( nn_een_e3f )              !* ff_f/e3 at F-point 
    11341094         CASE ( 0 )                                   ! original formulation  (masked averaging of e3t divided by 4) 
    1135             DO jj = 1, jpjm1 
    1136                DO ji = 1, jpim1 
    1137                   zwz(ji,jj) =   ( ht_n(ji  ,jj+1) + ht_n(ji+1,jj+1) +                    & 
    1138                        &             ht_n(ji  ,jj  ) + ht_n(ji+1,jj  )   ) * 0.25_wp   
    1139                   IF( zwz(ji,jj) /= 0._wp )   zwz(ji,jj) = ff_f(ji,jj) / zwz(ji,jj) 
    1140                END DO 
    1141             END DO 
     1095            DO_2D_10_10 
     1096               zwz(ji,jj) =   ( ht_n(ji  ,jj+1) + ht_n(ji+1,jj+1) +                    & 
     1097                    &             ht_n(ji  ,jj  ) + ht_n(ji+1,jj  )   ) * 0.25_wp   
     1098               IF( zwz(ji,jj) /= 0._wp )   zwz(ji,jj) = ff_f(ji,jj) / zwz(ji,jj) 
     1099            END_2D 
    11421100         CASE ( 1 )                                   ! new formulation  (masked averaging of e3t divided by the sum of mask) 
    1143             DO jj = 1, jpjm1 
    1144                DO ji = 1, jpim1 
    1145                   zwz(ji,jj) =             (  ht_n  (ji  ,jj+1) + ht_n  (ji+1,jj+1)      & 
    1146                        &                      + ht_n  (ji  ,jj  ) + ht_n  (ji+1,jj  )  )   & 
    1147                        &       / ( MAX( 1._wp,  ssmask(ji  ,jj+1) + ssmask(ji+1,jj+1)      & 
    1148                        &                      + ssmask(ji  ,jj  ) + ssmask(ji+1,jj  )  )   ) 
    1149                   IF( zwz(ji,jj) /= 0._wp )   zwz(ji,jj) = ff_f(ji,jj) / zwz(ji,jj) 
    1150                END DO 
    1151             END DO 
     1101            DO_2D_10_10 
     1102               zwz(ji,jj) =             (  ht_n  (ji  ,jj+1) + ht_n  (ji+1,jj+1)      & 
     1103                    &                      + ht_n  (ji  ,jj  ) + ht_n  (ji+1,jj  )  )   & 
     1104                    &       / ( MAX( 1._wp,  ssmask(ji  ,jj+1) + ssmask(ji+1,jj+1)      & 
     1105                    &                      + ssmask(ji  ,jj  ) + ssmask(ji+1,jj  )  )   ) 
     1106               IF( zwz(ji,jj) /= 0._wp )   zwz(ji,jj) = ff_f(ji,jj) / zwz(ji,jj) 
     1107            END_2D 
    11521108         END SELECT 
    11531109         CALL lbc_lnk( 'dynspg_ts', zwz, 'F', 1._wp ) 
    11541110         ! 
    11551111         ftne(1,:) = 0._wp ; ftnw(1,:) = 0._wp ; ftse(1,:) = 0._wp ; ftsw(1,:) = 0._wp 
    1156          DO jj = 2, jpj 
    1157             DO ji = 2, jpi 
    1158                ftne(ji,jj) = zwz(ji-1,jj  ) + zwz(ji  ,jj  ) + zwz(ji  ,jj-1) 
    1159                ftnw(ji,jj) = zwz(ji-1,jj-1) + zwz(ji-1,jj  ) + zwz(ji  ,jj  ) 
    1160                ftse(ji,jj) = zwz(ji  ,jj  ) + zwz(ji  ,jj-1) + zwz(ji-1,jj-1) 
    1161                ftsw(ji,jj) = zwz(ji  ,jj-1) + zwz(ji-1,jj-1) + zwz(ji-1,jj  ) 
    1162             END DO 
    1163          END DO 
     1112         DO_2D_01_01 
     1113            ftne(ji,jj) = zwz(ji-1,jj  ) + zwz(ji  ,jj  ) + zwz(ji  ,jj-1) 
     1114            ftnw(ji,jj) = zwz(ji-1,jj-1) + zwz(ji-1,jj  ) + zwz(ji  ,jj  ) 
     1115            ftse(ji,jj) = zwz(ji  ,jj  ) + zwz(ji  ,jj-1) + zwz(ji-1,jj-1) 
     1116            ftsw(ji,jj) = zwz(ji  ,jj-1) + zwz(ji-1,jj-1) + zwz(ji-1,jj  ) 
     1117         END_2D 
    11641118         ! 
    11651119      CASE( np_EET )                  != EEN scheme using e3t (energy conserving scheme) 
    11661120         ftne(1,:) = 0._wp ; ftnw(1,:) = 0._wp ; ftse(1,:) = 0._wp ; ftsw(1,:) = 0._wp 
    1167          DO jj = 2, jpj 
    1168             DO ji = 2, jpi 
    1169                z1_ht = ssmask(ji,jj) / ( ht_n(ji,jj) + 1._wp - ssmask(ji,jj) ) 
    1170                ftne(ji,jj) = ( ff_f(ji-1,jj  ) + ff_f(ji  ,jj  ) + ff_f(ji  ,jj-1) ) * z1_ht 
    1171                ftnw(ji,jj) = ( ff_f(ji-1,jj-1) + ff_f(ji-1,jj  ) + ff_f(ji  ,jj  ) ) * z1_ht 
    1172                ftse(ji,jj) = ( ff_f(ji  ,jj  ) + ff_f(ji  ,jj-1) + ff_f(ji-1,jj-1) ) * z1_ht 
    1173                ftsw(ji,jj) = ( ff_f(ji  ,jj-1) + ff_f(ji-1,jj-1) + ff_f(ji-1,jj  ) ) * z1_ht 
    1174             END DO 
    1175          END DO 
     1121         DO_2D_01_01 
     1122            z1_ht = ssmask(ji,jj) / ( ht_n(ji,jj) + 1._wp - ssmask(ji,jj) ) 
     1123            ftne(ji,jj) = ( ff_f(ji-1,jj  ) + ff_f(ji  ,jj  ) + ff_f(ji  ,jj-1) ) * z1_ht 
     1124            ftnw(ji,jj) = ( ff_f(ji-1,jj-1) + ff_f(ji-1,jj  ) + ff_f(ji  ,jj  ) ) * z1_ht 
     1125            ftse(ji,jj) = ( ff_f(ji  ,jj  ) + ff_f(ji  ,jj-1) + ff_f(ji-1,jj-1) ) * z1_ht 
     1126            ftsw(ji,jj) = ( ff_f(ji  ,jj-1) + ff_f(ji-1,jj-1) + ff_f(ji-1,jj  ) ) * z1_ht 
     1127         END_2D 
    11761128         ! 
    11771129      CASE( np_ENE, np_ENS , np_MIX )  != all other schemes (ENE, ENS, MIX) except ENT ! 
    … …  
    12001152            ! 
    12011153            !zhf(:,:) = hbatf(:,:) 
    1202             DO jj = 1, jpjm1 
    1203                DO ji = 1, jpim1 
    1204                   zhf(ji,jj) =    (   ht_0  (ji,jj  ) + ht_0  (ji+1,jj  )          & 
    1205                        &            + ht_0  (ji,jj+1) + ht_0  (ji+1,jj+1)   )      & 
    1206                        &     / MAX(   ssmask(ji,jj  ) + ssmask(ji+1,jj  )          & 
    1207                        &            + ssmask(ji,jj+1) + ssmask(ji+1,jj+1) , 1._wp  ) 
    1208                END DO 
    1209             END DO 
     1154            DO_2D_10_10 
     1155               zhf(ji,jj) =    (   ht_0  (ji,jj  ) + ht_0  (ji+1,jj  )          & 
     1156                    &            + ht_0  (ji,jj+1) + ht_0  (ji+1,jj+1)   )      & 
     1157                    &     / MAX(   ssmask(ji,jj  ) + ssmask(ji+1,jj  )          & 
     1158                    &            + ssmask(ji,jj+1) + ssmask(ji+1,jj+1) , 1._wp  ) 
     1159            END_2D 
    12101160         ENDIF 
    12111161         ! 
    … …  
    12211171         CALL lbc_lnk( 'dynspg_ts', zhf, 'F', 1._wp ) 
    12221172         ! JC: TBC. hf should be greater than 0  
    1223          DO jj = 1, jpj 
    1224             DO ji = 1, jpi 
    1225                IF( zhf(ji,jj) /= 0._wp )   zwz(ji,jj) = 1._wp / zhf(ji,jj) 
    1226             END DO 
    1227          END DO 
     1173         DO_2D_11_11 
     1174            IF( zhf(ji,jj) /= 0._wp )   zwz(ji,jj) = 1._wp / zhf(ji,jj) 
     1175         END_2D 
    12281176         zwz(:,:) = ff_f(:,:) * zwz(:,:) 
    12291177      END SELECT 
    … …  
    12461194      SELECT CASE( nvor_scheme ) 
    12471195      CASE( np_ENT )                ! enstrophy conserving scheme (f-point) 
    1248          DO jj = 2, jpjm1 
    1249             DO ji = 2, jpim1 
    1250                z1_hu = ssumask(ji,jj) / ( hu_n(ji,jj) + 1._wp - ssumask(ji,jj) ) 
    1251                z1_hv = ssvmask(ji,jj) / ( hv_n(ji,jj) + 1._wp - ssvmask(ji,jj) ) 
    1252                zu_trd(ji,jj) = + r1_4 * r1_e1e2u(ji,jj) * z1_hu                    & 
    1253                   &               * (  e1e2t(ji+1,jj)*ht_n(ji+1,jj)*ff_t(ji+1,jj) * ( vn_b(ji+1,jj) + vn_b(ji+1,jj-1) )   & 
    1254                   &                  + e1e2t(ji  ,jj)*ht_n(ji  ,jj)*ff_t(ji  ,jj) * ( vn_b(ji  ,jj) + vn_b(ji  ,jj-1) )   ) 
    1255                   ! 
    1256                zv_trd(ji,jj) = - r1_4 * r1_e1e2v(ji,jj) * z1_hv                    & 
    1257                   &               * (  e1e2t(ji,jj+1)*ht_n(ji,jj+1)*ff_t(ji,jj+1) * ( un_b(ji,jj+1) + un_b(ji-1,jj+1) )   &  
    1258                   &                  + e1e2t(ji,jj  )*ht_n(ji,jj  )*ff_t(ji,jj  ) * ( un_b(ji,jj  ) + un_b(ji-1,jj  ) )   )  
    1259             END DO   
    1260          END DO   
     1196         DO_2D_00_00 
     1197            z1_hu = ssumask(ji,jj) / ( hu_n(ji,jj) + 1._wp - ssumask(ji,jj) ) 
     1198            z1_hv = ssvmask(ji,jj) / ( hv_n(ji,jj) + 1._wp - ssvmask(ji,jj) ) 
     1199            zu_trd(ji,jj) = + r1_4 * r1_e1e2u(ji,jj) * z1_hu                    & 
     1200               &               * (  e1e2t(ji+1,jj)*ht_n(ji+1,jj)*ff_t(ji+1,jj) * ( vn_b(ji+1,jj) + vn_b(ji+1,jj-1) )   & 
     1201               &                  + e1e2t(ji  ,jj)*ht_n(ji  ,jj)*ff_t(ji  ,jj) * ( vn_b(ji  ,jj) + vn_b(ji  ,jj-1) )   ) 
     1202               ! 
     1203            zv_trd(ji,jj) = - r1_4 * r1_e1e2v(ji,jj) * z1_hv                    & 
     1204               &               * (  e1e2t(ji,jj+1)*ht_n(ji,jj+1)*ff_t(ji,jj+1) * ( un_b(ji,jj+1) + un_b(ji-1,jj+1) )   &  
     1205               &                  + e1e2t(ji,jj  )*ht_n(ji,jj  )*ff_t(ji,jj  ) * ( un_b(ji,jj  ) + un_b(ji-1,jj  ) )   )  
     1206         END_2D 
    12611207         !          
    12621208      CASE( np_ENE , np_MIX )        ! energy conserving scheme (t-point) ENE or MIX 
    1263          DO jj = 2, jpjm1 
    1264             DO ji = fs_2, fs_jpim1   ! vector opt. 
    1265                zy1 = ( zhV(ji,jj-1) + zhV(ji+1,jj-1) ) * r1_e1u(ji,jj) 
    1266                zy2 = ( zhV(ji,jj  ) + zhV(ji+1,jj  ) ) * r1_e1u(ji,jj) 
    1267                zx1 = ( zhU(ji-1,jj) + zhU(ji-1,jj+1) ) * r1_e2v(ji,jj) 
    1268                zx2 = ( zhU(ji  ,jj) + zhU(ji  ,jj+1) ) * r1_e2v(ji,jj) 
    1269                ! energy conserving formulation for planetary vorticity term 
    1270                zu_trd(ji,jj) =   r1_4 * ( zwz(ji  ,jj-1) * zy1 + zwz(ji,jj) * zy2 ) 
    1271                zv_trd(ji,jj) = - r1_4 * ( zwz(ji-1,jj  ) * zx1 + zwz(ji,jj) * zx2 ) 
    1272             END DO 
    1273          END DO 
     1209         DO_2D_00_00 
     1210            zy1 = ( zhV(ji,jj-1) + zhV(ji+1,jj-1) ) * r1_e1u(ji,jj) 
     1211            zy2 = ( zhV(ji,jj  ) + zhV(ji+1,jj  ) ) * r1_e1u(ji,jj) 
     1212            zx1 = ( zhU(ji-1,jj) + zhU(ji-1,jj+1) ) * r1_e2v(ji,jj) 
     1213            zx2 = ( zhU(ji  ,jj) + zhU(ji  ,jj+1) ) * r1_e2v(ji,jj) 
     1214            ! energy conserving formulation for planetary vorticity term 
     1215            zu_trd(ji,jj) =   r1_4 * ( zwz(ji  ,jj-1) * zy1 + zwz(ji,jj) * zy2 ) 
     1216            zv_trd(ji,jj) = - r1_4 * ( zwz(ji-1,jj  ) * zx1 + zwz(ji,jj) * zx2 ) 
     1217         END_2D 
    12741218         ! 
    12751219      CASE( np_ENS )                ! enstrophy conserving scheme (f-point) 
    1276          DO jj = 2, jpjm1 
    1277             DO ji = fs_2, fs_jpim1   ! vector opt. 
    1278                zy1 =   r1_8 * ( zhV(ji  ,jj-1) + zhV(ji+1,jj-1) & 
    1279                  &            + zhV(ji  ,jj  ) + zhV(ji+1,jj  ) ) * r1_e1u(ji,jj) 
    1280                zx1 = - r1_8 * ( zhU(ji-1,jj  ) + zhU(ji-1,jj+1) & 
    1281                  &            + zhU(ji  ,jj  ) + zhU(ji  ,jj+1) ) * r1_e2v(ji,jj) 
    1282                zu_trd(ji,jj)  = zy1 * ( zwz(ji  ,jj-1) + zwz(ji,jj) ) 
    1283                zv_trd(ji,jj)  = zx1 * ( zwz(ji-1,jj  ) + zwz(ji,jj) ) 
    1284             END DO 
    1285          END DO 
     1220         DO_2D_00_00 
     1221            zy1 =   r1_8 * ( zhV(ji  ,jj-1) + zhV(ji+1,jj-1) & 
     1222              &            + zhV(ji  ,jj  ) + zhV(ji+1,jj  ) ) * r1_e1u(ji,jj) 
     1223            zx1 = - r1_8 * ( zhU(ji-1,jj  ) + zhU(ji-1,jj+1) & 
     1224              &            + zhU(ji  ,jj  ) + zhU(ji  ,jj+1) ) * r1_e2v(ji,jj) 
     1225            zu_trd(ji,jj)  = zy1 * ( zwz(ji  ,jj-1) + zwz(ji,jj) ) 
     1226            zv_trd(ji,jj)  = zx1 * ( zwz(ji-1,jj  ) + zwz(ji,jj) ) 
     1227         END_2D 
    12861228         ! 
    12871229      CASE( np_EET , np_EEN )      ! energy & enstrophy scheme (using e3t or e3f)          
    1288          DO jj = 2, jpjm1 
    1289             DO ji = fs_2, fs_jpim1   ! vector opt. 
    1290                zu_trd(ji,jj) = + r1_12 * r1_e1u(ji,jj) * (  ftne(ji,jj  ) * zhV(ji  ,jj  ) & 
    1291                 &                                         + ftnw(ji+1,jj) * zhV(ji+1,jj  ) & 
    1292                 &                                         + ftse(ji,jj  ) * zhV(ji  ,jj-1) & 
    1293                 &                                         + ftsw(ji+1,jj) * zhV(ji+1,jj-1) ) 
    1294                zv_trd(ji,jj) = - r1_12 * r1_e2v(ji,jj) * (  ftsw(ji,jj+1) * zhU(ji-1,jj+1) & 
    1295                 &                                         + ftse(ji,jj+1) * zhU(ji  ,jj+1) & 
    1296                 &                                         + ftnw(ji,jj  ) * zhU(ji-1,jj  ) & 
    1297                 &                                         + ftne(ji,jj  ) * zhU(ji  ,jj  ) ) 
    1298             END DO 
    1299          END DO 
     1230         DO_2D_00_00 
     1231            zu_trd(ji,jj) = + r1_12 * r1_e1u(ji,jj) * (  ftne(ji,jj  ) * zhV(ji  ,jj  ) & 
     1232             &                                         + ftnw(ji+1,jj) * zhV(ji+1,jj  ) & 
     1233             &                                         + ftse(ji,jj  ) * zhV(ji  ,jj-1) & 
     1234             &                                         + ftsw(ji+1,jj) * zhV(ji+1,jj-1) ) 
     1235            zv_trd(ji,jj) = - r1_12 * r1_e2v(ji,jj) * (  ftsw(ji,jj+1) * zhU(ji-1,jj+1) & 
     1236             &                                         + ftse(ji,jj+1) * zhU(ji  ,jj+1) & 
     1237             &                                         + ftnw(ji,jj  ) * zhU(ji-1,jj  ) & 
     1238             &                                         + ftne(ji,jj  ) * zhU(ji  ,jj  ) ) 
     1239         END_2D 
    13001240         ! 
    13011241      END SELECT 
    … …  
    13221262      ! 
    13231263      IF( ln_wd_dl_rmp ) THEN      
    1324          DO jj = 1, jpj 
    1325             DO ji = 1, jpi                     
    1326                IF    ( pssh(ji,jj) + ht_0(ji,jj) >  2._wp * rn_wdmin1 ) THEN  
    1327                   !           IF    ( pssh(ji,jj) + ht_0(ji,jj) >          rn_wdmin2 ) THEN  
    1328                   ptmsk(ji,jj) = 1._wp 
    1329                ELSEIF( pssh(ji,jj) + ht_0(ji,jj) >          rn_wdmin1 ) THEN 
    1330                   ptmsk(ji,jj) = TANH( 50._wp*( ( pssh(ji,jj) + ht_0(ji,jj) -  rn_wdmin1 )*r_rn_wdmin1) ) 
    1331                ELSE  
    1332                   ptmsk(ji,jj) = 0._wp 
    1333                ENDIF 
    1334             END DO 
    1335          END DO 
     1264         DO_2D_11_11 
     1265            IF    ( pssh(ji,jj) + ht_0(ji,jj) >  2._wp * rn_wdmin1 ) THEN  
     1266               !           IF    ( pssh(ji,jj) + ht_0(ji,jj) >          rn_wdmin2 ) THEN  
     1267               ptmsk(ji,jj) = 1._wp 
     1268            ELSEIF( pssh(ji,jj) + ht_0(ji,jj) >          rn_wdmin1 ) THEN 
     1269               ptmsk(ji,jj) = TANH( 50._wp*( ( pssh(ji,jj) + ht_0(ji,jj) -  rn_wdmin1 )*r_rn_wdmin1) ) 
     1270            ELSE  
     1271               ptmsk(ji,jj) = 0._wp 
     1272            ENDIF 
     1273         END_2D 
    13361274      ELSE   
    1337          DO jj = 1, jpj 
    1338             DO ji = 1, jpi                               
    1339                IF ( pssh(ji,jj) + ht_0(ji,jj) >  rn_wdmin1 ) THEN   ;   ptmsk(ji,jj) = 1._wp 
    1340                ELSE                                                 ;   ptmsk(ji,jj) = 0._wp 
    1341                ENDIF 
    1342             END DO 
    1343          END DO 
     1275         DO_2D_11_11 
     1276            IF ( pssh(ji,jj) + ht_0(ji,jj) >  rn_wdmin1 ) THEN   ;   ptmsk(ji,jj) = 1._wp 
     1277            ELSE                                                 ;   ptmsk(ji,jj) = 0._wp 
     1278            ENDIF 
     1279         END_2D 
    13441280      ENDIF 
    13451281      ! 
    … …  
    13651301      !!---------------------------------------------------------------------- 
    13661302      ! 
    1367       DO jj = 1, jpj 
    1368          DO ji = 1, jpim1   ! not jpi-column 
    1369             IF ( phU(ji,jj) > 0._wp ) THEN   ;   pUmsk(ji,jj) = pTmsk(ji  ,jj)  
    1370             ELSE                             ;   pUmsk(ji,jj) = pTmsk(ji+1,jj)   
    1371             ENDIF 
    1372             phU(ji,jj) = pUmsk(ji,jj)*phU(ji,jj) 
    1373             pu (ji,jj) = pUmsk(ji,jj)*pu (ji,jj) 
    1374          END DO 
    1375       END DO 
    1376       ! 
    1377       DO jj = 1, jpjm1   ! not jpj-row 
    1378          DO ji = 1, jpi 
    1379             IF ( phV(ji,jj) > 0._wp ) THEN   ;   pVmsk(ji,jj) = pTmsk(ji,jj  ) 
    1380             ELSE                             ;   pVmsk(ji,jj) = pTmsk(ji,jj+1)   
    1381             ENDIF 
    1382             phV(ji,jj) = pVmsk(ji,jj)*phV(ji,jj)  
    1383             pv (ji,jj) = pVmsk(ji,jj)*pv (ji,jj) 
    1384          END DO 
    1385       END DO 
     1303      DO_2D_11_10 
     1304         IF ( phU(ji,jj) > 0._wp ) THEN   ;   pUmsk(ji,jj) = pTmsk(ji  ,jj)  
     1305         ELSE                             ;   pUmsk(ji,jj) = pTmsk(ji+1,jj)   
     1306         ENDIF 
     1307         phU(ji,jj) = pUmsk(ji,jj)*phU(ji,jj) 
     1308         pu (ji,jj) = pUmsk(ji,jj)*pu (ji,jj) 
     1309      END_2D 
     1310      ! 
     1311      DO_2D_10_11 
     1312         IF ( phV(ji,jj) > 0._wp ) THEN   ;   pVmsk(ji,jj) = pTmsk(ji,jj  ) 
     1313         ELSE                             ;   pVmsk(ji,jj) = pTmsk(ji,jj+1)   
     1314         ENDIF 
     1315         phV(ji,jj) = pVmsk(ji,jj)*phV(ji,jj)  
     1316         pv (ji,jj) = pVmsk(ji,jj)*pv (ji,jj) 
     1317      END_2D 
    13861318      ! 
    13871319   END SUBROUTINE wad_Umsk 
    … …  
    13991331      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: zcpx, zcpy 
    14001332      !!---------------------------------------------------------------------- 
    1401       DO jj = 2, jpjm1 
    1402          DO ji = 2, jpim1  
    1403             ll_tmp1 = MIN(  sshn(ji,jj)               ,  sshn(ji+1,jj) ) >                & 
    1404                  &      MAX( -ht_0(ji,jj)               , -ht_0(ji+1,jj) ) .AND.            & 
    1405                  &      MAX(  sshn(ji,jj) + ht_0(ji,jj) ,  sshn(ji+1,jj) + ht_0(ji+1,jj) )  & 
    1406                  &                                                         > rn_wdmin1 + rn_wdmin2 
    1407             ll_tmp2 = ( ABS( sshn(ji+1,jj)            -  sshn(ji  ,jj))  > 1.E-12 ).AND.( & 
    1408                  &      MAX(   sshn(ji,jj)              ,  sshn(ji+1,jj) ) >                & 
    1409                  &      MAX(  -ht_0(ji,jj)              , -ht_0(ji+1,jj) ) + rn_wdmin1 + rn_wdmin2 ) 
    1410             IF(ll_tmp1) THEN 
    1411                zcpx(ji,jj) = 1.0_wp 
    1412             ELSEIF(ll_tmp2) THEN 
    1413                ! no worries about  sshn(ji+1,jj) -  sshn(ji  ,jj) = 0, it won't happen ! here 
    1414                zcpx(ji,jj) = ABS( (sshn(ji+1,jj) + ht_0(ji+1,jj) - sshn(ji,jj) - ht_0(ji,jj)) & 
    1415                     &    / (sshn(ji+1,jj) - sshn(ji  ,jj)) ) 
    1416                zcpx(ji,jj) = max(min( zcpx(ji,jj) , 1.0_wp),0.0_wp) 
    1417             ELSE 
    1418                zcpx(ji,jj) = 0._wp 
    1419             ENDIF 
    1420             ! 
    1421             ll_tmp1 = MIN(  sshn(ji,jj)               ,  sshn(ji,jj+1) ) >                & 
    1422                  &      MAX( -ht_0(ji,jj)               , -ht_0(ji,jj+1) ) .AND.            & 
    1423                  &      MAX(  sshn(ji,jj) + ht_0(ji,jj) ,  sshn(ji,jj+1) + ht_0(ji,jj+1) )  & 
    1424                  &                                                       > rn_wdmin1 + rn_wdmin2 
    1425             ll_tmp2 = ( ABS( sshn(ji,jj)              -  sshn(ji,jj+1))  > 1.E-12 ).AND.( & 
    1426                  &      MAX(   sshn(ji,jj)              ,  sshn(ji,jj+1) ) >                & 
    1427                  &      MAX(  -ht_0(ji,jj)              , -ht_0(ji,jj+1) ) + rn_wdmin1 + rn_wdmin2 ) 
    1428              
    1429             IF(ll_tmp1) THEN 
    1430                zcpy(ji,jj) = 1.0_wp 
    1431             ELSE IF(ll_tmp2) THEN 
    1432                ! no worries about  sshn(ji,jj+1) -  sshn(ji,jj  ) = 0, it won't happen ! here 
    1433                zcpy(ji,jj) = ABS( (sshn(ji,jj+1) + ht_0(ji,jj+1) - sshn(ji,jj) - ht_0(ji,jj)) & 
    1434                     &             / (sshn(ji,jj+1) - sshn(ji,jj  )) ) 
    1435                zcpy(ji,jj) = MAX(  0._wp , MIN( zcpy(ji,jj) , 1.0_wp )  ) 
    1436             ELSE 
    1437                zcpy(ji,jj) = 0._wp 
    1438             ENDIF 
    1439          END DO 
    1440       END DO 
     1333      DO_2D_00_00 
     1334         ll_tmp1 = MIN(  sshn(ji,jj)               ,  sshn(ji+1,jj) ) >                & 
     1335              &      MAX( -ht_0(ji,jj)               , -ht_0(ji+1,jj) ) .AND.            & 
     1336              &      MAX(  sshn(ji,jj) + ht_0(ji,jj) ,  sshn(ji+1,jj) + ht_0(ji+1,jj) )  & 
     1337              &                                                         > rn_wdmin1 + rn_wdmin2 
     1338         ll_tmp2 = ( ABS( sshn(ji+1,jj)            -  sshn(ji  ,jj))  > 1.E-12 ).AND.( & 
     1339              &      MAX(   sshn(ji,jj)              ,  sshn(ji+1,jj) ) >                & 
     1340              &      MAX(  -ht_0(ji,jj)              , -ht_0(ji+1,jj) ) + rn_wdmin1 + rn_wdmin2 ) 
     1341         IF(ll_tmp1) THEN 
     1342            zcpx(ji,jj) = 1.0_wp 
     1343         ELSEIF(ll_tmp2) THEN 
     1344            ! no worries about  sshn(ji+1,jj) -  sshn(ji  ,jj) = 0, it won't happen ! here 
     1345            zcpx(ji,jj) = ABS( (sshn(ji+1,jj) + ht_0(ji+1,jj) - sshn(ji,jj) - ht_0(ji,jj)) & 
     1346                 &    / (sshn(ji+1,jj) - sshn(ji  ,jj)) ) 
     1347            zcpx(ji,jj) = max(min( zcpx(ji,jj) , 1.0_wp),0.0_wp) 
     1348         ELSE 
     1349            zcpx(ji,jj) = 0._wp 
     1350         ENDIF 
     1351         ! 
     1352         ll_tmp1 = MIN(  sshn(ji,jj)               ,  sshn(ji,jj+1) ) >                & 
     1353              &      MAX( -ht_0(ji,jj)               , -ht_0(ji,jj+1) ) .AND.            & 
     1354              &      MAX(  sshn(ji,jj) + ht_0(ji,jj) ,  sshn(ji,jj+1) + ht_0(ji,jj+1) )  & 
     1355              &                                                       > rn_wdmin1 + rn_wdmin2 
     1356         ll_tmp2 = ( ABS( sshn(ji,jj)              -  sshn(ji,jj+1))  > 1.E-12 ).AND.( & 
     1357              &      MAX(   sshn(ji,jj)              ,  sshn(ji,jj+1) ) >                & 
     1358              &      MAX(  -ht_0(ji,jj)              , -ht_0(ji,jj+1) ) + rn_wdmin1 + rn_wdmin2 ) 
     1359          
     1360         IF(ll_tmp1) THEN 
     1361            zcpy(ji,jj) = 1.0_wp 
     1362         ELSE IF(ll_tmp2) THEN 
     1363            ! no worries about  sshn(ji,jj+1) -  sshn(ji,jj  ) = 0, it won't happen ! here 
     1364            zcpy(ji,jj) = ABS( (sshn(ji,jj+1) + ht_0(ji,jj+1) - sshn(ji,jj) - ht_0(ji,jj)) & 
     1365                 &             / (sshn(ji,jj+1) - sshn(ji,jj  )) ) 
     1366            zcpy(ji,jj) = MAX(  0._wp , MIN( zcpy(ji,jj) , 1.0_wp )  ) 
     1367         ELSE 
     1368            zcpy(ji,jj) = 0._wp 
     1369         ENDIF 
     1370      END_2D 
    14411371             
    14421372   END SUBROUTINE wad_spg 
    … …  
    14671397      IF( ln_isfcav.OR.ln_drgice_imp ) THEN          ! top+bottom friction (ocean cavities) 
    14681398          
    1469          DO jj = 2, jpjm1 
    1470             DO ji = 2, jpim1     ! INNER domain 
    1471                pCdU_u(ji,jj) = r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) + rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) 
    1472                pCdU_v(ji,jj) = r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) + rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) 
    1473             END DO 
    1474          END DO 
     1399         DO_2D_00_00 
     1400            pCdU_u(ji,jj) = r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) + rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) 
     1401            pCdU_v(ji,jj) = r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) + rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) 
     1402         END_2D 
    14751403      ELSE                          ! bottom friction only 
    1476          DO jj = 2, jpjm1 
    1477             DO ji = 2, jpim1  ! INNER domain 
    1478                pCdU_u(ji,jj) = r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) 
    1479                pCdU_v(ji,jj) = r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) 
    1480             END DO 
    1481          END DO 
     1404         DO_2D_00_00 
     1405            pCdU_u(ji,jj) = r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) 
     1406            pCdU_v(ji,jj) = r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) 
     1407         END_2D 
    14821408      ENDIF 
    14831409      ! 
    … …  
    14861412      IF( ln_bt_fw ) THEN                 ! FORWARD integration: use NOW bottom baroclinic velocities 
    14871413          
    1488          DO jj = 2, jpjm1 
    1489             DO ji = 2, jpim1  ! INNER domain 
    1490                ikbu = mbku(ji,jj)        
    1491                ikbv = mbkv(ji,jj)     
    1492                zu_i(ji,jj) = un(ji,jj,ikbu) - un_b(ji,jj) 
    1493                zv_i(ji,jj) = vn(ji,jj,ikbv) - vn_b(ji,jj) 
    1494             END DO 
    1495          END DO 
     1414         DO_2D_00_00 
     1415            ikbu = mbku(ji,jj)        
     1416            ikbv = mbkv(ji,jj)     
     1417            zu_i(ji,jj) = uu(ji,jj,ikbu,Nii) - un_b(ji,jj) 
     1418            zv_i(ji,jj) = vv(ji,jj,ikbv,Nii) - vn_b(ji,jj) 
     1419         END_2D 
    14961420      ELSE                                ! CENTRED integration: use BEFORE bottom baroclinic velocities 
    14971421          
    1498          DO jj = 2, jpjm1 
    1499             DO ji = 2, jpim1   ! INNER domain 
    1500                ikbu = mbku(ji,jj)        
    1501                ikbv = mbkv(ji,jj)     
    1502                zu_i(ji,jj) = ub(ji,jj,ikbu) - ub_b(ji,jj) 
    1503                zv_i(ji,jj) = vb(ji,jj,ikbv) - vb_b(ji,jj) 
    1504             END DO 
    1505          END DO 
     1422         DO_2D_00_00 
     1423            ikbu = mbku(ji,jj)        
     1424            ikbv = mbkv(ji,jj)     
     1425            zu_i(ji,jj) = uu(ji,jj,ikbu,Nnn) - ub_b(ji,jj) 
     1426            zv_i(ji,jj) = vv(ji,jj,ikbv,Nnn) - vb_b(ji,jj) 
     1427         END_2D 
    15061428      ENDIF 
    15071429      ! 
    15081430      IF( ln_wd_il ) THEN      ! W/D : use the "clipped" bottom friction   !!gm   explain WHY, please ! 
    15091431         zztmp = -1._wp / rdtbt 
    1510          DO jj = 2, jpjm1 
    1511             DO ji = 2, jpim1    ! INNER domain 
    1512                pu_RHSi(ji,jj) = pu_RHSi(ji,jj) + zu_i(ji,jj) *  wdrampu(ji,jj) * MAX(                                 &  
    1513                     &                              r1_hu_n(ji,jj) * r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) , zztmp  ) 
    1514                pv_RHSi(ji,jj) = pv_RHSi(ji,jj) + zv_i(ji,jj) *  wdrampv(ji,jj) * MAX(                                 &  
    1515                     &                              r1_hv_n(ji,jj) * r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) , zztmp  ) 
    1516             END DO 
    1517          END DO 
     1432         DO_2D_00_00 
     1433            pu_RHSi(ji,jj) = pu_RHSi(ji,jj) + zu_i(ji,jj) *  wdrampu(ji,jj) * MAX(                                 &  
     1434                 &                              r1_hu_n(ji,jj) * r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) , zztmp  ) 
     1435            pv_RHSi(ji,jj) = pv_RHSi(ji,jj) + zv_i(ji,jj) *  wdrampv(ji,jj) * MAX(                                 &  
     1436                 &                              r1_hv_n(ji,jj) * r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) , zztmp  ) 
     1437         END_2D 
    15181438      ELSE                    ! use "unclipped" drag (even if explicit friction is used in 3D calculation) 
    15191439          
    1520          DO jj = 2, jpjm1 
    1521             DO ji = 2, jpim1    ! INNER domain 
    1522                pu_RHSi(ji,jj) = pu_RHSi(ji,jj) + r1_hu_n(ji,jj) * r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) * zu_i(ji,jj) 
    1523                pv_RHSi(ji,jj) = pv_RHSi(ji,jj) + r1_hv_n(ji,jj) * r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) * zv_i(ji,jj) 
    1524             END DO 
    1525          END DO 
     1440         DO_2D_00_00 
     1441            pu_RHSi(ji,jj) = pu_RHSi(ji,jj) + r1_hu_n(ji,jj) * r1_2*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) * zu_i(ji,jj) 
     1442            pv_RHSi(ji,jj) = pv_RHSi(ji,jj) + r1_hv_n(ji,jj) * r1_2*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) * zv_i(ji,jj) 
     1443         END_2D 
    15261444      END IF 
    15271445      ! 
    … …  
    15321450         IF( ln_bt_fw ) THEN                ! FORWARD integration: use NOW top baroclinic velocity 
    15331451             
    1534             DO jj = 2, jpjm1 
    1535                DO ji = 2, jpim1   ! INNER domain 
    1536                   iktu = miku(ji,jj) 
    1537                   iktv = mikv(ji,jj) 
    1538                   zu_i(ji,jj) = un(ji,jj,iktu) - un_b(ji,jj) 
    1539                   zv_i(ji,jj) = vn(ji,jj,iktv) - vn_b(ji,jj) 
    1540                END DO 
    1541             END DO 
     1452            DO_2D_00_00 
     1453               iktu = miku(ji,jj) 
     1454               iktv = mikv(ji,jj) 
     1455               zu_i(ji,jj) = uu(ji,jj,iktu,Nii) - un_b(ji,jj) 
     1456               zv_i(ji,jj) = vv(ji,jj,iktv,Nii) - vn_b(ji,jj) 
     1457            END_2D 
    15421458         ELSE                                ! CENTRED integration: use BEFORE top baroclinic velocity 
    15431459             
    1544             DO jj = 2, jpjm1 
    1545                DO ji = 2, jpim1      ! INNER domain 
    1546                   iktu = miku(ji,jj) 
    1547                   iktv = mikv(ji,jj) 
    1548                   zu_i(ji,jj) = ub(ji,jj,iktu) - ub_b(ji,jj) 
    1549                   zv_i(ji,jj) = vb(ji,jj,iktv) - vb_b(ji,jj) 
    1550                END DO 
    1551             END DO 
     1460            DO_2D_00_00 
     1461               iktu = miku(ji,jj) 
     1462               iktv = mikv(ji,jj) 
     1463               zu_i(ji,jj) = uu(ji,jj,iktu,Nnn) - ub_b(ji,jj) 
     1464               zv_i(ji,jj) = vv(ji,jj,iktv,Nnn) - vb_b(ji,jj) 
     1465            END_2D 
    15521466         ENDIF 
    15531467         ! 
    15541468         !                    ! use "unclipped" top drag (even if explicit friction is used in 3D calculation) 
    15551469          
    1556          DO jj = 2, jpjm1 
    1557             DO ji = 2, jpim1    ! INNER domain 
    1558                pu_RHSi(ji,jj) = pu_RHSi(ji,jj) + r1_hu_n(ji,jj) * r1_2*( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) * zu_i(ji,jj) 
    1559                pv_RHSi(ji,jj) = pv_RHSi(ji,jj) + r1_hv_n(ji,jj) * r1_2*( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) * zv_i(ji,jj) 
    1560             END DO 
    1561          END DO 
     1470         DO_2D_00_00 
     1471            pu_RHSi(ji,jj) = pu_RHSi(ji,jj) + r1_hu_n(ji,jj) * r1_2*( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) * zu_i(ji,jj) 
     1472            pv_RHSi(ji,jj) = pv_RHSi(ji,jj) + r1_hv_n(ji,jj) * r1_2*( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) * zv_i(ji,jj) 
     1473         END_2D 
    15621474         ! 
    15631475      ENDIF 

  • NEMO/branches/2020/temporary_r4_trunk/src/OCE/DYN/dynzdf.F90

    r13466 r13469  
    110110      IF( ln_dynadv_vec .OR. ln_linssh ) THEN   ! applied on velocity 
    111111         DO jk = 1, jpkm1 
    112             ua(:,:,jk) = ( ub(:,:,jk) + r2dt * ua(:,:,jk) ) * umask(:,:,jk) 
    113             va(:,:,jk) = ( vb(:,:,jk) + r2dt * va(:,:,jk) ) * vmask(:,:,jk) 
     112            ua(:,:,jk) = ( uu(:,:,jk,Nnn) + r2dt * ua(:,:,jk) ) * umask(:,:,jk) 
     113            va(:,:,jk) = ( vv(:,:,jk,Nnn) + r2dt * va(:,:,jk) ) * vmask(:,:,jk) 
    114114         END DO 
    115115      ELSE                                      ! applied on thickness weighted velocity 
    116116         DO jk = 1, jpkm1 
    117             ua(:,:,jk) = (         e3u_b(:,:,jk) * ub(:,:,jk)  & 
     117            ua(:,:,jk) = (         e3u_b(:,:,jk) * uu(:,:,jk,Nnn)  & 
    118118               &          + r2dt * e3u_n(:,:,jk) * ua(:,:,jk)  ) / e3u_a(:,:,jk) * umask(:,:,jk) 
    119             va(:,:,jk) = (         e3v_b(:,:,jk) * vb(:,:,jk)  & 
     119            va(:,:,jk) = (         e3v_b(:,:,jk) * vv(:,:,jk,Nnn)  & 
    120120               &          + r2dt * e3v_n(:,:,jk) * va(:,:,jk)  ) / e3v_a(:,:,jk) * vmask(:,:,jk) 
    121121         END DO 
    … …  
    131131            va(:,:,jk) = ( va(:,:,jk) - va_b(:,:) ) * vmask(:,:,jk) 
    132132         END DO 
    133          DO jj = 2, jpjm1        ! Add bottom/top stress due to barotropic component only 
    134             DO ji = fs_2, fs_jpim1   ! vector opt. 
    135                iku = mbku(ji,jj)         ! ocean bottom level at u- and v-points  
    136                ikv = mbkv(ji,jj)         ! (deepest ocean u- and v-points) 
     133         DO_2D_00_00 
     134            iku = mbku(ji,jj)         ! ocean bottom level at u- and v-points  
     135            ikv = mbkv(ji,jj)         ! (deepest ocean u- and v-points) 
     136            ze3ua =  ( 1._wp - r_vvl ) * e3u_n(ji,jj,iku) + r_vvl * e3u_a(ji,jj,iku) 
     137            ze3va =  ( 1._wp - r_vvl ) * e3v_n(ji,jj,ikv) + r_vvl * e3v_a(ji,jj,ikv) 
     138            ua(ji,jj,iku) = ua(ji,jj,iku) + r2dt * 0.5*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) * ua_b(ji,jj) / ze3ua 
     139            va(ji,jj,ikv) = va(ji,jj,ikv) + r2dt * 0.5*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) * va_b(ji,jj) / ze3va 
     140         END_2D 
     141         IF( ln_isfcav.OR.ln_drgice_imp ) THEN    ! Ocean cavities (ISF) 
     142            DO_2D_00_00 
     143               iku = miku(ji,jj)         ! top ocean level at u- and v-points  
     144               ikv = mikv(ji,jj)         ! (first wet ocean u- and v-points) 
    137145               ze3ua =  ( 1._wp - r_vvl ) * e3u_n(ji,jj,iku) + r_vvl * e3u_a(ji,jj,iku) 
    138146               ze3va =  ( 1._wp - r_vvl ) * e3v_n(ji,jj,ikv) + r_vvl * e3v_a(ji,jj,ikv) 
    139                ua(ji,jj,iku) = ua(ji,jj,iku) + r2dt * 0.5*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) * ua_b(ji,jj) / ze3ua 
    140                va(ji,jj,ikv) = va(ji,jj,ikv) + r2dt * 0.5*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) * va_b(ji,jj) / ze3va 
    141             END DO 
    142          END DO 
    143          IF( ln_isfcav.OR.ln_drgice_imp ) THEN    ! Ocean cavities (ISF) 
    144             DO jj = 2, jpjm1         
    145                DO ji = fs_2, fs_jpim1   ! vector opt. 
    146                   iku = miku(ji,jj)         ! top ocean level at u- and v-points  
    147                   ikv = mikv(ji,jj)         ! (first wet ocean u- and v-points) 
    148                   ze3ua =  ( 1._wp - r_vvl ) * e3u_n(ji,jj,iku) + r_vvl * e3u_a(ji,jj,iku) 
    149                   ze3va =  ( 1._wp - r_vvl ) * e3v_n(ji,jj,ikv) + r_vvl * e3v_a(ji,jj,ikv) 
    150                   ua(ji,jj,iku) = ua(ji,jj,iku) + r2dt * 0.5*( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) * ua_b(ji,jj) / ze3ua 
    151                   va(ji,jj,ikv) = va(ji,jj,ikv) + r2dt * 0.5*( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) * va_b(ji,jj) / ze3va 
    152                END DO 
    153             END DO 
     147               ua(ji,jj,iku) = ua(ji,jj,iku) + r2dt * 0.5*( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) * ua_b(ji,jj) / ze3ua 
     148               va(ji,jj,ikv) = va(ji,jj,ikv) + r2dt * 0.5*( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) * va_b(ji,jj) / ze3va 
     149            END_2D 
    154150         END IF 
    155151      ENDIF 
    … …  
    162158         SELECT CASE( nldf_dyn ) 
    163159         CASE( np_lap_i )           ! rotated lateral mixing: add its vertical mixing (akzu) 
    164             DO jk = 1, jpkm1 
    165                DO jj = 2, jpjm1  
    166                   DO ji = fs_2, fs_jpim1   ! vector opt. 
    167                      ze3ua =  ( 1._wp - r_vvl ) * e3u_n(ji,jj,jk) + r_vvl * e3u_a(ji,jj,jk)   ! after scale factor at U-point 
    168                      zzwi = - zdt * ( avm(ji+1,jj,jk  ) + avm(ji,jj,jk  ) + akzu(ji,jj,jk  ) )   & 
    169                         &         / ( ze3ua * e3uw_n(ji,jj,jk  ) ) * wumask(ji,jj,jk  ) 
    170                      zzws = - zdt * ( avm(ji+1,jj,jk+1) + avm(ji,jj,jk+1) + akzu(ji,jj,jk+1) )   & 
    171                         &         / ( ze3ua * e3uw_n(ji,jj,jk+1) ) * wumask(ji,jj,jk+1) 
    172                      zWui = ( wi(ji,jj,jk  ) + wi(ji+1,jj,jk  ) ) / ze3ua 
    173                      zWus = ( wi(ji,jj,jk+1) + wi(ji+1,jj,jk+1) ) / ze3ua 
    174                      zwi(ji,jj,jk) = zzwi + zdt * MIN( zWui, 0._wp )  
    175                      zws(ji,jj,jk) = zzws - zdt * MAX( zWus, 0._wp ) 
    176                      zwd(ji,jj,jk) = 1._wp - zzwi - zzws + zdt * ( MAX( zWui, 0._wp ) - MIN( zWus, 0._wp ) ) 
    177                   END DO 
    178                END DO 
    179             END DO 
     160            DO_3D_00_00( 1, jpkm1 ) 
     161               ze3ua =  ( 1._wp - r_vvl ) * e3u_n(ji,jj,jk) + r_vvl * e3u_a(ji,jj,jk)   ! after scale factor at U-point 
     162               zzwi = - zdt * ( avm(ji+1,jj,jk  ) + avm(ji,jj,jk  ) + akzu(ji,jj,jk  ) )   & 
     163                  &         / ( ze3ua * e3uw_n(ji,jj,jk  ) ) * wumask(ji,jj,jk  ) 
     164               zzws = - zdt * ( avm(ji+1,jj,jk+1) + avm(ji,jj,jk+1) + akzu(ji,jj,jk+1) )   & 
     165                  &         / ( ze3ua * e3uw_n(ji,jj,jk+1) ) * wumask(ji,jj,jk+1) 
     166               zWui = ( wi(ji,jj,jk  ) + wi(ji+1,jj,jk  ) ) / ze3ua 
     167               zWus = ( wi(ji,jj,jk+1) + wi(ji+1,jj,jk+1) ) / ze3ua 
     168               zwi(ji,jj,jk) = zzwi + zdt * MIN( zWui, 0._wp )  
     169               zws(ji,jj,jk) = zzws - zdt * MAX( zWus, 0._wp ) 
     170               zwd(ji,jj,jk) = 1._wp - zzwi - zzws + zdt * ( MAX( zWui, 0._wp ) - MIN( zWus, 0._wp ) ) 
     171            END_3D 
    180172         CASE DEFAULT               ! iso-level lateral mixing 
    181             DO jk = 1, jpkm1 
    182                DO jj = 2, jpjm1  
    183                   DO ji = fs_2, fs_jpim1   ! vector opt. 
    184                      ze3ua =  ( 1._wp - r_vvl ) * e3u_n(ji,jj,jk) + r_vvl * e3u_a(ji,jj,jk)   ! after scale factor at U-point 
    185                      zzwi = - zdt * ( avm(ji+1,jj,jk  ) + avm(ji,jj,jk  ) ) / ( ze3ua * e3uw_n(ji,jj,jk  ) ) * wumask(ji,jj,jk  ) 
    186                      zzws = - zdt * ( avm(ji+1,jj,jk+1) + avm(ji,jj,jk+1) ) / ( ze3ua * e3uw_n(ji,jj,jk+1) ) * wumask(ji,jj,jk+1) 
    187                      zWui = ( wi(ji,jj,jk  ) + wi(ji+1,jj,jk  ) ) / ze3ua 
    188                      zWus = ( wi(ji,jj,jk+1) + wi(ji+1,jj,jk+1) ) / ze3ua 
    189                      zwi(ji,jj,jk) = zzwi + zdt * MIN( zWui, 0._wp ) 
    190                      zws(ji,jj,jk) = zzws - zdt * MAX( zWus, 0._wp ) 
    191                      zwd(ji,jj,jk) = 1._wp - zzwi - zzws + zdt * ( MAX( zWui, 0._wp ) - MIN( zWus, 0._wp ) ) 
    192                   END DO 
    193                END DO 
    194             END DO 
     173            DO_3D_00_00( 1, jpkm1 ) 
     174               ze3ua =  ( 1._wp - r_vvl ) * e3u_n(ji,jj,jk) + r_vvl * e3u_a(ji,jj,jk)   ! after scale factor at U-point 
     175               zzwi = - zdt * ( avm(ji+1,jj,jk  ) + avm(ji,jj,jk  ) ) / ( ze3ua * e3uw_n(ji,jj,jk  ) ) * wumask(ji,jj,jk  ) 
     176               zzws = - zdt * ( avm(ji+1,jj,jk+1) + avm(ji,jj,jk+1) ) / ( ze3ua * e3uw_n(ji,jj,jk+1) ) * wumask(ji,jj,jk+1) 
     177               zWui = ( wi(ji,jj,jk  ) + wi(ji+1,jj,jk  ) ) / ze3ua 
     178               zWus = ( wi(ji,jj,jk+1) + wi(ji+1,jj,jk+1) ) / ze3ua 
     179               zwi(ji,jj,jk) = zzwi + zdt * MIN( zWui, 0._wp ) 
     180               zws(ji,jj,jk) = zzws - zdt * MAX( zWus, 0._wp ) 
     181               zwd(ji,jj,jk) = 1._wp - zzwi - zzws + zdt * ( MAX( zWui, 0._wp ) - MIN( zWus, 0._wp ) ) 
     182            END_3D 
    195183         END SELECT 
    196          DO jj = 2, jpjm1     !* Surface boundary conditions 
    197             DO ji = fs_2, fs_jpim1   ! vector opt. 
    198                zwi(ji,jj,1) = 0._wp 
    199                ze3ua =  ( 1._wp - r_vvl ) * e3u_n(ji,jj,1) + r_vvl * e3u_a(ji,jj,1) 
    200                zzws = - zdt * ( avm(ji+1,jj,2) + avm(ji  ,jj,2) ) / ( ze3ua * e3uw_n(ji,jj,2) ) * wumask(ji,jj,2) 
    201                zWus = ( wi(ji  ,jj,2) +  wi(ji+1,jj,2) ) / ze3ua 
    202                zws(ji,jj,1 ) = zzws - zdt * MAX( zWus, 0._wp ) 
    203                zwd(ji,jj,1 ) = 1._wp - zzws - zdt * ( MIN( zWus, 0._wp ) ) 
    204             END DO 
    205          END DO 
     184         DO_2D_00_00 
     185            zwi(ji,jj,1) = 0._wp 
     186            ze3ua =  ( 1._wp - r_vvl ) * e3u_n(ji,jj,1) + r_vvl * e3u_a(ji,jj,1) 
     187            zzws = - zdt * ( avm(ji+1,jj,2) + avm(ji  ,jj,2) ) / ( ze3ua * e3uw_n(ji,jj,2) ) * wumask(ji,jj,2) 
     188            zWus = ( wi(ji  ,jj,2) +  wi(ji+1,jj,2) ) / ze3ua 
     189            zws(ji,jj,1 ) = zzws - zdt * MAX( zWus, 0._wp ) 
     190            zwd(ji,jj,1 ) = 1._wp - zzws - zdt * ( MIN( zWus, 0._wp ) ) 
     191         END_2D 
    206192      ELSE 
    207193         SELECT CASE( nldf_dyn ) 
    208194         CASE( np_lap_i )           ! rotated lateral mixing: add its vertical mixing (akzu) 
    209             DO jk = 1, jpkm1 
    210                DO jj = 2, jpjm1  
    211                   DO ji = fs_2, fs_jpim1   ! vector opt. 
    212                      ze3ua =  ( 1._wp - r_vvl ) * e3u_n(ji,jj,jk) + r_vvl * e3u_a(ji,jj,jk)   ! after scale factor at U-point 
    213                      zzwi = - zdt * ( avm(ji+1,jj,jk  ) + avm(ji,jj,jk  ) + akzu(ji,jj,jk  ) )   & 
    214                         &         / ( ze3ua * e3uw_n(ji,jj,jk  ) ) * wumask(ji,jj,jk  ) 
    215                      zzws = - zdt * ( avm(ji+1,jj,jk+1) + avm(ji,jj,jk+1) + akzu(ji,jj,jk+1) )   & 
    216                         &         / ( ze3ua * e3uw_n(ji,jj,jk+1) ) * wumask(ji,jj,jk+1) 
    217                      zwi(ji,jj,jk) = zzwi 
    218                      zws(ji,jj,jk) = zzws 
    219                      zwd(ji,jj,jk) = 1._wp - zzwi - zzws 
    220                   END DO 
    221                END DO 
    222             END DO 
     195            DO_3D_00_00( 1, jpkm1 ) 
     196               ze3ua =  ( 1._wp - r_vvl ) * e3u_n(ji,jj,jk) + r_vvl * e3u_a(ji,jj,jk)   ! after scale factor at U-point 
     197               zzwi = - zdt * ( avm(ji+1,jj,jk  ) + avm(ji,jj,jk  ) + akzu(ji,jj,jk  ) )   & 
     198                  &         / ( ze3ua * e3uw_n(ji,jj,jk  ) ) * wumask(ji,jj,jk  ) 
     199               zzws = - zdt * ( avm(ji+1,jj,jk+1) + avm(ji,jj,jk+1) + akzu(ji,jj,jk+1) )   & 
     200                  &         / ( ze3ua * e3uw_n(ji,jj,jk+1) ) * wumask(ji,jj,jk+1) 
     201               zwi(ji,jj,jk) = zzwi 
     202               zws(ji,jj,jk) = zzws 
     203               zwd(ji,jj,jk) = 1._wp - zzwi - zzws 
     204            END_3D 
    223205         CASE DEFAULT               ! iso-level lateral mixing 
    224             DO jk = 1, jpkm1 
    225                DO jj = 2, jpjm1  
    226                   DO ji = fs_2, fs_jpim1   ! vector opt. 
    227                      ze3ua =  ( 1._wp - r_vvl ) * e3u_n(ji,jj,jk) + r_vvl * e3u_a(ji,jj,jk)   ! after scale factor at U-point 
    228                      zzwi = - zdt * ( avm(ji+1,jj,jk  ) + avm(ji,jj,jk  ) ) / ( ze3ua * e3uw_n(ji,jj,jk  ) ) * wumask(ji,jj,jk  ) 
    229                      zzws = - zdt * ( avm(ji+1,jj,jk+1) + avm(ji,jj,jk+1) ) / ( ze3ua * e3uw_n(ji,jj,jk+1) ) * wumask(ji,jj,jk+1) 
    230                      zwi(ji,jj,jk) = zzwi 
    231                      zws(ji,jj,jk) = zzws 
    232                      zwd(ji,jj,jk) = 1._wp - zzwi - zzws 
    233                   END DO 
    234                END DO 
    235             END DO 
     206            DO_3D_00_00( 1, jpkm1 ) 
     207               ze3ua =  ( 1._wp - r_vvl ) * e3u_n(ji,jj,jk) + r_vvl * e3u_a(ji,jj,jk)   ! after scale factor at U-point 
     208               zzwi = - zdt * ( avm(ji+1,jj,jk  ) + avm(ji,jj,jk  ) ) / ( ze3ua * e3uw_n(ji,jj,jk  ) ) * wumask(ji,jj,jk  ) 
     209               zzws = - zdt * ( avm(ji+1,jj,jk+1) + avm(ji,jj,jk+1) ) / ( ze3ua * e3uw_n(ji,jj,jk+1) ) * wumask(ji,jj,jk+1) 
     210               zwi(ji,jj,jk) = zzwi 
     211               zws(ji,jj,jk) = zzws 
     212               zwd(ji,jj,jk) = 1._wp - zzwi - zzws 
     213            END_3D 
    236214         END SELECT 
    237          DO jj = 2, jpjm1     !* Surface boundary conditions 
    238             DO ji = fs_2, fs_jpim1   ! vector opt. 
    239                zwi(ji,jj,1) = 0._wp 
    240                zwd(ji,jj,1) = 1._wp - zws(ji,jj,1) 
    241             END DO 
    242          END DO 
     215         DO_2D_00_00 
     216            zwi(ji,jj,1) = 0._wp 
     217            zwd(ji,jj,1) = 1._wp - zws(ji,jj,1) 
     218         END_2D 
    243219      ENDIF 
    244220      ! 
    … …  
    251227      ! 
    252228      IF ( ln_drgimp ) THEN      ! implicit bottom friction 
    253          DO jj = 2, jpjm1 
    254             DO ji = 2, jpim1 
    255                iku = mbku(ji,jj)       ! ocean bottom level at u- and v-points 
     229         DO_2D_00_00 
     230            iku = mbku(ji,jj)       ! ocean bottom level at u- and v-points 
     231            ze3ua =  ( 1._wp - r_vvl ) * e3u_n(ji,jj,iku) + r_vvl * e3u_a(ji,jj,iku)   ! after scale factor at T-point 
     232            zwd(ji,jj,iku) = zwd(ji,jj,iku) - r2dt * 0.5*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) / ze3ua 
     233         END_2D 
     234         IF ( ln_isfcav.OR.ln_drgice_imp ) THEN   ! top friction (always implicit) 
     235            DO_2D_00_00 
     236               !!gm   top Cd is masked (=0 outside cavities) no need of test on mik>=2  ==>> it has been suppressed 
     237               iku = miku(ji,jj)       ! ocean top level at u- and v-points  
    256238               ze3ua =  ( 1._wp - r_vvl ) * e3u_n(ji,jj,iku) + r_vvl * e3u_a(ji,jj,iku)   ! after scale factor at T-point 
    257                zwd(ji,jj,iku) = zwd(ji,jj,iku) - r2dt * 0.5*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) / ze3ua 
    258             END DO 
    259          END DO 
    260          IF ( ln_isfcav.OR.ln_drgice_imp ) THEN   ! top friction (always implicit) 
    261             DO jj = 2, jpjm1 
    262                DO ji = 2, jpim1 
    263                   !!gm   top Cd is masked (=0 outside cavities) no need of test on mik>=2  ==>> it has been suppressed 
    264                   iku = miku(ji,jj)       ! ocean top level at u- and v-points  
    265                   ze3ua =  ( 1._wp - r_vvl ) * e3u_n(ji,jj,iku) + r_vvl * e3u_a(ji,jj,iku)   ! after scale factor at T-point 
    266                   zwd(ji,jj,iku) = zwd(ji,jj,iku) - r2dt * 0.5*( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) / ze3ua 
    267                END DO 
    268             END DO 
     239               zwd(ji,jj,iku) = zwd(ji,jj,iku) - r2dt * 0.5*( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) / ze3ua 
     240            END_2D 
    269241         END IF 
    270242      ENDIF 
    … …  
    285257      !----------------------------------------------------------------------- 
    286258      ! 
    287       DO jk = 2, jpkm1        !==  First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1   (increasing k)  == 
    288          DO jj = 2, jpjm1    
    289             DO ji = fs_2, fs_jpim1   ! vector opt. 
    290                zwd(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) / zwd(ji,jj,jk-1) 
    291             END DO 
    292          END DO 
    293       END DO 
    294       ! 
    295       DO jj = 2, jpjm1        !==  second recurrence:    SOLk = RHSk - Lk / Dk-1  Lk-1  ==! 
    296          DO ji = fs_2, fs_jpim1   ! vector opt. 
    297             ze3ua =  ( 1._wp - r_vvl ) * e3u_n(ji,jj,1) + r_vvl * e3u_a(ji,jj,1)  
    298             ua(ji,jj,1) = ua(ji,jj,1) + r2dt * 0.5_wp * ( utau_b(ji,jj) + utau(ji,jj) )   & 
    299                &                                      / ( ze3ua * rau0 ) * umask(ji,jj,1)  
    300          END DO 
    301       END DO 
    302       DO jk = 2, jpkm1 
    303          DO jj = 2, jpjm1 
    304             DO ji = fs_2, fs_jpim1 
    305                ua(ji,jj,jk) = ua(ji,jj,jk) - zwi(ji,jj,jk) / zwd(ji,jj,jk-1) * ua(ji,jj,jk-1) 
    306             END DO 
    307          END DO 
    308       END DO 
    309       ! 
    310       DO jj = 2, jpjm1        !==  thrid recurrence : SOLk = ( Lk - Uk * Ek+1 ) / Dk  ==! 
    311          DO ji = fs_2, fs_jpim1   ! vector opt. 
    312             ua(ji,jj,jpkm1) = ua(ji,jj,jpkm1) / zwd(ji,jj,jpkm1) 
    313          END DO 
    314       END DO 
    315       DO jk = jpk-2, 1, -1 
    316          DO jj = 2, jpjm1 
    317             DO ji = fs_2, fs_jpim1 
    318                ua(ji,jj,jk) = ( ua(ji,jj,jk) - zws(ji,jj,jk) * ua(ji,jj,jk+1) ) / zwd(ji,jj,jk) 
    319             END DO 
    320          END DO 
    321       END DO 
     259      DO_3D_00_00( 2, jpkm1 ) 
     260         zwd(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) / zwd(ji,jj,jk-1) 
     261      END_3D 
     262      ! 
     263      DO_2D_00_00 
     264         ze3ua =  ( 1._wp - r_vvl ) * e3u_n(ji,jj,1) + r_vvl * e3u_a(ji,jj,1)  
     265         ua(ji,jj,1) = ua(ji,jj,1) + r2dt * 0.5_wp * ( utau_b(ji,jj) + utau(ji,jj) )   & 
     266            &                                      / ( ze3ua * rau0 ) * umask(ji,jj,1)  
     267      END_2D 
     268      DO_3D_00_00( 2, jpkm1 ) 
     269         ua(ji,jj,jk) = ua(ji,jj,jk) - zwi(ji,jj,jk) / zwd(ji,jj,jk-1) * ua(ji,jj,jk-1) 
     270      END_3D 
     271      ! 
     272      DO_2D_00_00 
     273         ua(ji,jj,jpkm1) = ua(ji,jj,jpkm1) / zwd(ji,jj,jpkm1) 
     274      END_2D 
     275      DO_3D_00_00( jpk-2, 1, -1 ) 
     276         ua(ji,jj,jk) = ( ua(ji,jj,jk) - zws(ji,jj,jk) * ua(ji,jj,jk+1) ) / zwd(ji,jj,jk) 
     277      END_3D 
    322278      ! 
    323279      !              !==  Vertical diffusion on v  ==! 
    … …  
    328284         SELECT CASE( nldf_dyn ) 
    329285         CASE( np_lap_i )           ! rotated lateral mixing: add its vertical mixing (akzv) 
    330             DO jk = 1, jpkm1 
    331                DO jj = 2, jpjm1  
    332                   DO ji = fs_2, fs_jpim1   ! vector opt. 
    333                      ze3va =  ( 1._wp - r_vvl ) * e3v_n(ji,jj,jk) + r_vvl * e3v_a(ji,jj,jk)   ! after scale factor at V-point 
    334                      zzwi = - zdt * ( avm(ji,jj+1,jk  ) + avm(ji,jj,jk  ) + akzv(ji,jj,jk  ) )   & 
    335                         &         / ( ze3va * e3vw_n(ji,jj,jk  ) ) * wvmask(ji,jj,jk  ) 
    336                      zzws = - zdt * ( avm(ji,jj+1,jk+1) + avm(ji,jj,jk+1) + akzv(ji,jj,jk+1) )   & 
    337                         &         / ( ze3va * e3vw_n(ji,jj,jk+1) ) * wvmask(ji,jj,jk+1) 
    338                      zWvi = ( wi(ji,jj,jk  ) + wi(ji,jj+1,jk  ) ) / ze3va 
    339                      zWvs = ( wi(ji,jj,jk+1) + wi(ji,jj+1,jk+1) ) / ze3va 
    340                      zwi(ji,jj,jk) = zzwi + zdt * MIN( zWvi, 0._wp ) 
    341                      zws(ji,jj,jk) = zzws - zdt * MAX( zWvs, 0._wp ) 
    342                      zwd(ji,jj,jk) = 1._wp - zzwi - zzws - zdt * ( - MAX( zWvi, 0._wp ) + MIN( zWvs, 0._wp ) ) 
    343                   END DO 
    344                END DO 
    345             END DO 
     286            DO_3D_00_00( 1, jpkm1 ) 
     287               ze3va =  ( 1._wp - r_vvl ) * e3v_n(ji,jj,jk) + r_vvl * e3v_a(ji,jj,jk)   ! after scale factor at V-point 
     288               zzwi = - zdt * ( avm(ji,jj+1,jk  ) + avm(ji,jj,jk  ) + akzv(ji,jj,jk  ) )   & 
     289                  &         / ( ze3va * e3vw_n(ji,jj,jk  ) ) * wvmask(ji,jj,jk  ) 
     290               zzws = - zdt * ( avm(ji,jj+1,jk+1) + avm(ji,jj,jk+1) + akzv(ji,jj,jk+1) )   & 
     291                  &         / ( ze3va * e3vw_n(ji,jj,jk+1) ) * wvmask(ji,jj,jk+1) 
     292               zWvi = ( wi(ji,jj,jk  ) + wi(ji,jj+1,jk  ) ) / ze3va 
     293               zWvs = ( wi(ji,jj,jk+1) + wi(ji,jj+1,jk+1) ) / ze3va 
     294               zwi(ji,jj,jk) = zzwi + zdt * MIN( zWvi, 0._wp ) 
     295               zws(ji,jj,jk) = zzws - zdt * MAX( zWvs, 0._wp ) 
     296               zwd(ji,jj,jk) = 1._wp - zzwi - zzws - zdt * ( - MAX( zWvi, 0._wp ) + MIN( zWvs, 0._wp ) ) 
     297            END_3D 
    346298         CASE DEFAULT               ! iso-level lateral mixing 
    347             DO jk = 1, jpkm1 
    348                DO jj = 2, jpjm1  
    349                   DO ji = fs_2, fs_jpim1   ! vector opt. 
    350                      ze3va =  ( 1._wp - r_vvl ) * e3v_n(ji,jj,jk) + r_vvl * e3v_a(ji,jj,jk)   ! after scale factor at V-point 
    351                      zzwi = - zdt * ( avm(ji,jj+1,jk  ) + avm(ji,jj,jk  ) ) / ( ze3va * e3vw_n(ji,jj,jk  ) ) * wvmask(ji,jj,jk  ) 
    352                      zzws = - zdt * ( avm(ji,jj+1,jk+1) + avm(ji,jj,jk+1) ) / ( ze3va * e3vw_n(ji,jj,jk+1) ) * wvmask(ji,jj,jk+1) 
    353                      zWvi = ( wi(ji,jj,jk  ) + wi(ji,jj+1,jk  ) ) / ze3va 
    354                      zWvs = ( wi(ji,jj,jk+1) + wi(ji,jj+1,jk+1) ) / ze3va 
    355                      zwi(ji,jj,jk) = zzwi  + zdt * MIN( zWvi, 0._wp ) 
    356                      zws(ji,jj,jk) = zzws  - zdt * MAX( zWvs, 0._wp ) 
    357                      zwd(ji,jj,jk) = 1._wp - zzwi - zzws - zdt * ( - MAX( zWvi, 0._wp ) + MIN( zWvs, 0._wp ) ) 
    358                   END DO 
    359                END DO 
    360             END DO 
     299            DO_3D_00_00( 1, jpkm1 ) 
     300               ze3va =  ( 1._wp - r_vvl ) * e3v_n(ji,jj,jk) + r_vvl * e3v_a(ji,jj,jk)   ! after scale factor at V-point 
     301               zzwi = - zdt * ( avm(ji,jj+1,jk  ) + avm(ji,jj,jk  ) ) / ( ze3va * e3vw_n(ji,jj,jk  ) ) * wvmask(ji,jj,jk  ) 
     302               zzws = - zdt * ( avm(ji,jj+1,jk+1) + avm(ji,jj,jk+1) ) / ( ze3va * e3vw_n(ji,jj,jk+1) ) * wvmask(ji,jj,jk+1) 
     303               zWvi = ( wi(ji,jj,jk  ) + wi(ji,jj+1,jk  ) ) / ze3va 
     304               zWvs = ( wi(ji,jj,jk+1) + wi(ji,jj+1,jk+1) ) / ze3va 
     305               zwi(ji,jj,jk) = zzwi  + zdt * MIN( zWvi, 0._wp ) 
     306               zws(ji,jj,jk) = zzws  - zdt * MAX( zWvs, 0._wp ) 
     307               zwd(ji,jj,jk) = 1._wp - zzwi - zzws - zdt * ( - MAX( zWvi, 0._wp ) + MIN( zWvs, 0._wp ) ) 
     308            END_3D 
    361309         END SELECT 
    362          DO jj = 2, jpjm1     !* Surface boundary conditions 
    363             DO ji = fs_2, fs_jpim1   ! vector opt. 
    364                zwi(ji,jj,1) = 0._wp 
    365                ze3va =  ( 1._wp - r_vvl ) * e3v_n(ji,jj,1) + r_vvl * e3v_a(ji,jj,1) 
    366                zzws = - zdt * ( avm(ji,jj+1,2) + avm(ji,jj,2) ) / ( ze3va * e3vw_n(ji,jj,2) ) * wvmask(ji,jj,2) 
    367                zWvs = ( wi(ji,jj  ,2) +  wi(ji,jj+1,2) ) / ze3va 
    368                zws(ji,jj,1 ) = zzws - zdt * MAX( zWvs, 0._wp ) 
    369                zwd(ji,jj,1 ) = 1._wp - zzws - zdt * ( MIN( zWvs, 0._wp ) ) 
    370             END DO 
    371          END DO 
     310         DO_2D_00_00 
     311            zwi(ji,jj,1) = 0._wp 
     312            ze3va =  ( 1._wp - r_vvl ) * e3v_n(ji,jj,1) + r_vvl * e3v_a(ji,jj,1) 
     313            zzws = - zdt * ( avm(ji,jj+1,2) + avm(ji,jj,2) ) / ( ze3va * e3vw_n(ji,jj,2) ) * wvmask(ji,jj,2) 
     314            zWvs = ( wi(ji,jj  ,2) +  wi(ji,jj+1,2) ) / ze3va 
     315            zws(ji,jj,1 ) = zzws - zdt * MAX( zWvs, 0._wp ) 
     316            zwd(ji,jj,1 ) = 1._wp - zzws - zdt * ( MIN( zWvs, 0._wp ) ) 
     317         END_2D 
    372318      ELSE 
    373319         SELECT CASE( nldf_dyn ) 
    374320         CASE( np_lap_i )           ! rotated lateral mixing: add its vertical mixing (akzu) 
    375             DO jk = 1, jpkm1 
    376                DO jj = 2, jpjm1    
    377                   DO ji = fs_2, fs_jpim1   ! vector opt. 
    378                      ze3va =  ( 1._wp - r_vvl ) * e3v_n(ji,jj,jk) + r_vvl * e3v_a(ji,jj,jk)   ! after scale factor at V-point 
    379                      zzwi = - zdt * ( avm(ji,jj+1,jk  ) + avm(ji,jj,jk  ) + akzv(ji,jj,jk  ) )   & 
    380                         &         / ( ze3va * e3vw_n(ji,jj,jk  ) ) * wvmask(ji,jj,jk  ) 
    381                      zzws = - zdt * ( avm(ji,jj+1,jk+1) + avm(ji,jj,jk+1) + akzv(ji,jj,jk+1) )   & 
    382                         &         / ( ze3va * e3vw_n(ji,jj,jk+1) ) * wvmask(ji,jj,jk+1) 
    383                      zwi(ji,jj,jk) = zzwi 
    384                      zws(ji,jj,jk) = zzws 
    385                      zwd(ji,jj,jk) = 1._wp - zzwi - zzws 
    386                   END DO 
    387                END DO 
    388             END DO 
     321            DO_3D_00_00( 1, jpkm1 ) 
     322               ze3va =  ( 1._wp - r_vvl ) * e3v_n(ji,jj,jk) + r_vvl * e3v_a(ji,jj,jk)   ! after scale factor at V-point 
     323               zzwi = - zdt * ( avm(ji,jj+1,jk  ) + avm(ji,jj,jk  ) + akzv(ji,jj,jk  ) )   & 
     324                  &         / ( ze3va * e3vw_n(ji,jj,jk  ) ) * wvmask(ji,jj,jk  ) 
     325               zzws = - zdt * ( avm(ji,jj+1,jk+1) + avm(ji,jj,jk+1) + akzv(ji,jj,jk+1) )   & 
     326                  &         / ( ze3va * e3vw_n(ji,jj,jk+1) ) * wvmask(ji,jj,jk+1) 
     327               zwi(ji,jj,jk) = zzwi 
     328               zws(ji,jj,jk) = zzws 
     329               zwd(ji,jj,jk) = 1._wp - zzwi - zzws 
     330            END_3D 
    389331         CASE DEFAULT               ! iso-level lateral mixing 
    390             DO jk = 1, jpkm1 
    391                DO jj = 2, jpjm1    
    392                   DO ji = fs_2, fs_jpim1   ! vector opt. 
    393                      ze3va =  ( 1._wp - r_vvl ) * e3v_n(ji,jj,jk) + r_vvl * e3v_a(ji,jj,jk)   ! after scale factor at V-point 
    394                      zzwi = - zdt * ( avm(ji,jj+1,jk  ) + avm(ji,jj,jk  ) ) / ( ze3va * e3vw_n(ji,jj,jk  ) ) * wvmask(ji,jj,jk  ) 
    395                      zzws = - zdt * ( avm(ji,jj+1,jk+1) + avm(ji,jj,jk+1) ) / ( ze3va * e3vw_n(ji,jj,jk+1) ) * wvmask(ji,jj,jk+1) 
    396                      zwi(ji,jj,jk) = zzwi 
    397                      zws(ji,jj,jk) = zzws 
    398                      zwd(ji,jj,jk) = 1._wp - zzwi - zzws 
    399                   END DO 
    400                END DO 
    401             END DO 
     332            DO_3D_00_00( 1, jpkm1 ) 
     333               ze3va =  ( 1._wp - r_vvl ) * e3v_n(ji,jj,jk) + r_vvl * e3v_a(ji,jj,jk)   ! after scale factor at V-point 
     334               zzwi = - zdt * ( avm(ji,jj+1,jk  ) + avm(ji,jj,jk  ) ) / ( ze3va * e3vw_n(ji,jj,jk  ) ) * wvmask(ji,jj,jk  ) 
     335               zzws = - zdt * ( avm(ji,jj+1,jk+1) + avm(ji,jj,jk+1) ) / ( ze3va * e3vw_n(ji,jj,jk+1) ) * wvmask(ji,jj,jk+1) 
     336               zwi(ji,jj,jk) = zzwi 
     337               zws(ji,jj,jk) = zzws 
     338               zwd(ji,jj,jk) = 1._wp - zzwi - zzws 
     339            END_3D 
    402340         END SELECT 
    403          DO jj = 2, jpjm1        !* Surface boundary conditions 
    404             DO ji = fs_2, fs_jpim1   ! vector opt. 
    405                zwi(ji,jj,1) = 0._wp 
    406                zwd(ji,jj,1) = 1._wp - zws(ji,jj,1) 
    407             END DO 
    408          END DO 
     341         DO_2D_00_00 
     342            zwi(ji,jj,1) = 0._wp 
     343            zwd(ji,jj,1) = 1._wp - zws(ji,jj,1) 
     344         END_2D 
    409345      ENDIF 
    410346      ! 
    … …  
    416352      ! 
    417353      IF( ln_drgimp ) THEN 
    418          DO jj = 2, jpjm1 
    419             DO ji = 2, jpim1 
    420                ikv = mbkv(ji,jj)       ! (deepest ocean u- and v-points) 
     354         DO_2D_00_00 
     355            ikv = mbkv(ji,jj)       ! (deepest ocean u- and v-points) 
     356            ze3va =  ( 1._wp - r_vvl ) * e3v_n(ji,jj,ikv) + r_vvl * e3v_a(ji,jj,ikv)   ! after scale factor at T-point 
     357            zwd(ji,jj,ikv) = zwd(ji,jj,ikv) - r2dt * 0.5*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) / ze3va            
     358         END_2D 
     359         IF ( ln_isfcav.OR.ln_drgice_imp ) THEN 
     360            DO_2D_00_00 
     361               ikv = mikv(ji,jj)       ! (first wet ocean u- and v-points) 
    421362               ze3va =  ( 1._wp - r_vvl ) * e3v_n(ji,jj,ikv) + r_vvl * e3v_a(ji,jj,ikv)   ! after scale factor at T-point 
    422                zwd(ji,jj,ikv) = zwd(ji,jj,ikv) - r2dt * 0.5*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) / ze3va            
    423             END DO 
    424          END DO 
    425          IF ( ln_isfcav.OR.ln_drgice_imp ) THEN 
    426             DO jj = 2, jpjm1 
    427                DO ji = 2, jpim1 
    428                   ikv = mikv(ji,jj)       ! (first wet ocean u- and v-points) 
    429                   ze3va =  ( 1._wp - r_vvl ) * e3v_n(ji,jj,ikv) + r_vvl * e3v_a(ji,jj,ikv)   ! after scale factor at T-point 
    430                   zwd(ji,jj,ikv) = zwd(ji,jj,ikv) - r2dt * 0.5*( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) / ze3va 
    431                END DO 
    432             END DO 
     363               zwd(ji,jj,ikv) = zwd(ji,jj,ikv) - r2dt * 0.5*( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) / ze3va 
     364            END_2D 
    433365         ENDIF 
    434366      ENDIF 
    … …  
    449381      !----------------------------------------------------------------------- 
    450382      ! 
    451       DO jk = 2, jpkm1        !==  First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1   (increasing k)  == 
    452          DO jj = 2, jpjm1    
    453             DO ji = fs_2, fs_jpim1   ! vector opt. 
    454                zwd(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) / zwd(ji,jj,jk-1) 
    455             END DO 
    456          END DO 
    457       END DO 
    458       ! 
    459       DO jj = 2, jpjm1        !==  second recurrence:    SOLk = RHSk - Lk / Dk-1  Lk-1  ==! 
    460          DO ji = fs_2, fs_jpim1   ! vector opt.           
    461             ze3va =  ( 1._wp - r_vvl ) * e3v_n(ji,jj,1) + r_vvl * e3v_a(ji,jj,1)  
    462             va(ji,jj,1) = va(ji,jj,1) + r2dt * 0.5_wp * ( vtau_b(ji,jj) + vtau(ji,jj) )   & 
    463                &                                      / ( ze3va * rau0 ) * vmask(ji,jj,1)  
    464          END DO 
    465       END DO 
    466       DO jk = 2, jpkm1 
    467          DO jj = 2, jpjm1 
    468             DO ji = fs_2, fs_jpim1   ! vector opt. 
    469                va(ji,jj,jk) = va(ji,jj,jk) - zwi(ji,jj,jk) / zwd(ji,jj,jk-1) * va(ji,jj,jk-1) 
    470             END DO 
    471          END DO 
    472       END DO 
    473       ! 
    474       DO jj = 2, jpjm1        !==  third recurrence : SOLk = ( Lk - Uk * SOLk+1 ) / Dk  ==! 
    475          DO ji = fs_2, fs_jpim1   ! vector opt. 
    476             va(ji,jj,jpkm1) = va(ji,jj,jpkm1) / zwd(ji,jj,jpkm1) 
    477          END DO 
    478       END DO 
    479       DO jk = jpk-2, 1, -1 
    480          DO jj = 2, jpjm1 
    481             DO ji = fs_2, fs_jpim1 
    482                va(ji,jj,jk) = ( va(ji,jj,jk) - zws(ji,jj,jk) * va(ji,jj,jk+1) ) / zwd(ji,jj,jk) 
    483             END DO 
    484          END DO 
    485       END DO 
     383      DO_3D_00_00( 2, jpkm1 ) 
     384         zwd(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) / zwd(ji,jj,jk-1) 
     385      END_3D 
     386      ! 
     387      DO_2D_00_00 
     388         ze3va =  ( 1._wp - r_vvl ) * e3v_n(ji,jj,1) + r_vvl * e3v_a(ji,jj,1)  
     389         va(ji,jj,1) = va(ji,jj,1) + r2dt * 0.5_wp * ( vtau_b(ji,jj) + vtau(ji,jj) )   & 
     390            &                                      / ( ze3va * rau0 ) * vmask(ji,jj,1)  
     391      END_2D 
     392      DO_3D_00_00( 2, jpkm1 ) 
     393         va(ji,jj,jk) = va(ji,jj,jk) - zwi(ji,jj,jk) / zwd(ji,jj,jk-1) * va(ji,jj,jk-1) 
     394      END_3D 
     395      ! 
     396      DO_2D_00_00 
     397         va(ji,jj,jpkm1) = va(ji,jj,jpkm1) / zwd(ji,jj,jpkm1) 
     398      END_2D 
     399      DO_3D_00_00( jpk-2, 1, -1 ) 
     400         va(ji,jj,jk) = ( va(ji,jj,jk) - zws(ji,jj,jk) * va(ji,jj,jk+1) ) / zwd(ji,jj,jk) 
     401      END_3D 
    486402      ! 
    487403      IF( l_trddyn )   THEN                      ! save the vertical diffusive trends for further diagnostics 
    488          ztrdu(:,:,:) = ( ua(:,:,:) - ub(:,:,:) ) / r2dt - ztrdu(:,:,:) 
    489          ztrdv(:,:,:) = ( va(:,:,:) - vb(:,:,:) ) / r2dt - ztrdv(:,:,:) 
     404         ztrdu(:,:,:) = ( ua(:,:,:) - uu(:,:,:,Nnn) ) / r2dt - ztrdu(:,:,:) 
     405         ztrdv(:,:,:) = ( va(:,:,:) - vv(:,:,:,Nnn) ) / r2dt - ztrdv(:,:,:) 
    490406         CALL trd_dyn( ztrdu, ztrdv, jpdyn_zdf, kt ) 
    491407         DEALLOCATE( ztrdu, ztrdv )  

  • NEMO/branches/2020/temporary_r4_trunk/src/OCE/SBC/sbc_oce.F90

    r13466 r13469  
    209209      !!--------------------------------------------------------------------- 
    210210      zcoef = 0.5 / ( zrhoa * zcdrag )  
    211       DO jj = 2, jpjm1 
    212          DO ji = fs_2, fs_jpim1   ! vect. opt. 
    213             ztx = utau(ji-1,jj  ) + utau(ji,jj)  
    214             zty = vtau(ji  ,jj-1) + vtau(ji,jj)  
    215             ztau = SQRT( ztx * ztx + zty * zty ) 
    216             wndm(ji,jj) = SQRT ( ztau * zcoef ) * tmask(ji,jj,1) 
    217          END DO 
    218       END DO 
     211      DO_2D_00_00 
     212         ztx = utau(ji-1,jj  ) + utau(ji,jj)  
     213         zty = vtau(ji  ,jj-1) + vtau(ji,jj)  
     214         ztau = SQRT( ztx * ztx + zty * zty ) 
     215         wndm(ji,jj) = SQRT ( ztau * zcoef ) * tmask(ji,jj,1) 
     216      END_2D 
    219217      CALL lbc_lnk( 'sbc_oce', wndm(:,:) , 'T', 1. ) 
    220218      ! 

  • NEMO/branches/2020/temporary_r4_trunk/src/OCE/SBC/sbcblk.F90

    r13467 r13469  
    408408#if defined key_cyclone 
    409409      CALL wnd_cyc( kt, zwnd_i, zwnd_j )    ! add analytical tropical cyclone (Vincent et al. JGR 2012) 
    410       DO jj = 2, jpjm1 
    411          DO ji = fs_2, fs_jpim1   ! vect. opt. 
    412             sf(jp_wndi)%fnow(ji,jj,1) = sf(jp_wndi)%fnow(ji,jj,1) + zwnd_i(ji,jj) 
    413             sf(jp_wndj)%fnow(ji,jj,1) = sf(jp_wndj)%fnow(ji,jj,1) + zwnd_j(ji,jj) 
    414          END DO 
    415       END DO 
     410      DO_2D_00_00 
     411         sf(jp_wndi)%fnow(ji,jj,1) = sf(jp_wndi)%fnow(ji,jj,1) + zwnd_i(ji,jj) 
     412         sf(jp_wndj)%fnow(ji,jj,1) = sf(jp_wndj)%fnow(ji,jj,1) + zwnd_j(ji,jj) 
     413      END_2D 
    416414#endif 
    417       DO jj = 2, jpjm1 
    418          DO ji = fs_2, fs_jpim1   ! vect. opt. 
    419             zwnd_i(ji,jj) = (  sf(jp_wndi)%fnow(ji,jj,1) - rn_vfac * 0.5 * ( pu(ji-1,jj  ) + pu(ji,jj) )  ) 
    420             zwnd_j(ji,jj) = (  sf(jp_wndj)%fnow(ji,jj,1) - rn_vfac * 0.5 * ( pv(ji  ,jj-1) + pv(ji,jj) )  ) 
    421          END DO 
    422       END DO 
     415      DO_2D_00_00 
     416         zwnd_i(ji,jj) = (  sf(jp_wndi)%fnow(ji,jj,1) - rn_vfac * 0.5 * ( pu(ji-1,jj  ) + pu(ji,jj) )  ) 
     417         zwnd_j(ji,jj) = (  sf(jp_wndj)%fnow(ji,jj,1) - rn_vfac * 0.5 * ( pv(ji  ,jj-1) + pv(ji,jj) )  ) 
     418      END_2D 
    423419      CALL lbc_lnk_multi( 'sbcblk', zwnd_i, 'T', -1., zwnd_j, 'T', -1. ) 
    424420      ! ... scalar wind ( = | U10m - U_oce | ) at T-point (masked) 
    … …  
    474470!!      CALL iom_put( "Ch_oce", Ch_atm)  ! output value of pure ocean-atm. transfer coef. 
    475471 
    476       DO jj = 1, jpj             ! tau module, i and j component 
    477          DO ji = 1, jpi 
    478             zztmp = zrhoa(ji,jj)  * zU_zu(ji,jj) * Cd_atm(ji,jj)   ! using bulk wind speed 
    479             taum  (ji,jj) = zztmp * wndm  (ji,jj) 
    480             zwnd_i(ji,jj) = zztmp * zwnd_i(ji,jj) 
    481             zwnd_j(ji,jj) = zztmp * zwnd_j(ji,jj) 
    482          END DO 
    483       END DO 
     472      DO_2D_11_11 
     473         zztmp = zrhoa(ji,jj)  * zU_zu(ji,jj) * Cd_atm(ji,jj)   ! using bulk wind speed 
     474         taum  (ji,jj) = zztmp * wndm  (ji,jj) 
     475         zwnd_i(ji,jj) = zztmp * zwnd_i(ji,jj) 
     476         zwnd_j(ji,jj) = zztmp * zwnd_j(ji,jj) 
     477      END_2D 
    484478 
    485479      !                          ! add the HF tau contribution to the wind stress module 
    … …  
    491485      !     Note the use of 0.5*(2-umask) in order to unmask the stress along coastlines 
    492486      !     Note the use of MAX(tmask(i,j),tmask(i+1,j) is to mask tau over ice shelves 
    493       DO jj = 1, jpjm1 
    494          DO ji = 1, fs_jpim1 
    495             utau(ji,jj) = 0.5 * ( 2. - umask(ji,jj,1) ) * ( zwnd_i(ji,jj) + zwnd_i(ji+1,jj  ) ) & 
    496                &          * MAX(tmask(ji,jj,1),tmask(ji+1,jj,1)) 
    497             vtau(ji,jj) = 0.5 * ( 2. - vmask(ji,jj,1) ) * ( zwnd_j(ji,jj) + zwnd_j(ji  ,jj+1) ) & 
    498                &          * MAX(tmask(ji,jj,1),tmask(ji,jj+1,1)) 
    499          END DO 
    500       END DO 
     487      DO_2D_10_10 
     488         utau(ji,jj) = 0.5 * ( 2. - umask(ji,jj,1) ) * ( zwnd_i(ji,jj) + zwnd_i(ji+1,jj  ) ) & 
     489            &          * MAX(tmask(ji,jj,1),tmask(ji+1,jj,1)) 
     490         vtau(ji,jj) = 0.5 * ( 2. - vmask(ji,jj,1) ) * ( zwnd_j(ji,jj) + zwnd_j(ji  ,jj+1) ) & 
     491            &          * MAX(tmask(ji,jj,1),tmask(ji,jj+1,1)) 
     492      END_2D 
    501493      CALL lbc_lnk_multi( 'sbcblk', utau, 'U', -1., vtau, 'V', -1. ) 
    502494 
    … …  
    633625      !!---------------------------------------------------------------------------------- 
    634626      ! 
    635       DO jj = 1, jpj 
    636          DO ji = 1, jpi 
     627      DO_2D_11_11 
     628         ! 
     629         ztmp = rt0 / ptak(ji,jj) 
     630         ! 
     631         ! Vapour pressure at saturation [hPa] : WMO, (Goff, 1957) 
     632         ze_sat = 10.**( 10.79574*(1. - ztmp) - 5.028*LOG10(ptak(ji,jj)/rt0)        & 
     633            &    + 1.50475*10.**(-4)*(1. - 10.**(-8.2969*(ptak(ji,jj)/rt0 - 1.)) )  & 
     634            &    + 0.42873*10.**(-3)*(10.**(4.76955*(1. - ztmp)) - 1.) + 0.78614  ) 
    637635            ! 
    638             ztmp = rt0 / ptak(ji,jj) 
    639             ! 
    640             ! Vapour pressure at saturation [hPa] : WMO, (Goff, 1957) 
    641             ze_sat = 10.**( 10.79574*(1. - ztmp) - 5.028*LOG10(ptak(ji,jj)/rt0)        & 
    642                &    + 1.50475*10.**(-4)*(1. - 10.**(-8.2969*(ptak(ji,jj)/rt0 - 1.)) )  & 
    643                &    + 0.42873*10.**(-3)*(10.**(4.76955*(1. - ztmp)) - 1.) + 0.78614  ) 
    644                ! 
    645             q_sat(ji,jj) = reps0 * ze_sat/( 0.01_wp*pslp(ji,jj) - (1._wp - reps0)*ze_sat )   ! 0.01 because SLP is in [Pa] 
    646             ! 
    647          END DO 
    648       END DO 
     636         q_sat(ji,jj) = reps0 * ze_sat/( 0.01_wp*pslp(ji,jj) - (1._wp - reps0)*ze_sat )   ! 0.01 because SLP is in [Pa] 
     637         ! 
     638      END_2D 
    649639      ! 
    650640   END FUNCTION q_sat 
    … …  
    669659      !!---------------------------------------------------------------------------------- 
    670660      ! 
    671       DO jj = 1, jpj 
    672          DO ji = 1, jpi 
    673             zrv = pqa(ji,jj) / (1. - pqa(ji,jj)) 
    674             ziRT = 1. / (R_dry*ptak(ji,jj))    ! 1/RT 
    675             gamma_moist(ji,jj) = grav * ( 1. + rLevap*zrv*ziRT ) / ( Cp_dry + rLevap*rLevap*zrv*reps0*ziRT/ptak(ji,jj) ) 
    676          END DO 
    677       END DO 
     661      DO_2D_11_11 
     662         zrv = pqa(ji,jj) / (1. - pqa(ji,jj)) 
     663         ziRT = 1. / (R_dry*ptak(ji,jj))    ! 1/RT 
     664         gamma_moist(ji,jj) = grav * ( 1. + rLevap*zrv*ziRT ) / ( Cp_dry + rLevap*rLevap*zrv*reps0*ziRT/ptak(ji,jj) ) 
     665      END_2D 
    678666      ! 
    679667   END FUNCTION gamma_moist 
    … …  
    735723      ! ------------------------------------------------------------ ! 
    736724      ! C-grid ice dynamics :   U & V-points (same as ocean) 
    737       DO jj = 2, jpjm1 
    738          DO ji = fs_2, fs_jpim1   ! vect. opt. 
    739             zwndi_t = (  sf(jp_wndi)%fnow(ji,jj,1) - rn_vfac * 0.5 * ( u_ice(ji-1,jj  ) + u_ice(ji,jj) )  ) 
    740             zwndj_t = (  sf(jp_wndj)%fnow(ji,jj,1) - rn_vfac * 0.5 * ( v_ice(ji  ,jj-1) + v_ice(ji,jj) )  ) 
    741             wndm_ice(ji,jj) = SQRT( zwndi_t * zwndi_t + zwndj_t * zwndj_t ) * tmask(ji,jj,1) 
    742          END DO 
    743       END DO 
     725      DO_2D_00_00 
     726         zwndi_t = (  sf(jp_wndi)%fnow(ji,jj,1) - rn_vfac * 0.5 * ( u_ice(ji-1,jj  ) + u_ice(ji,jj) )  ) 
     727         zwndj_t = (  sf(jp_wndj)%fnow(ji,jj,1) - rn_vfac * 0.5 * ( v_ice(ji  ,jj-1) + v_ice(ji,jj) )  ) 
     728         wndm_ice(ji,jj) = SQRT( zwndi_t * zwndi_t + zwndj_t * zwndj_t ) * tmask(ji,jj,1) 
     729      END_2D 
    744730      CALL lbc_lnk( 'sbcblk', wndm_ice, 'T',  1. ) 
    745731      ! 
    … …  
    763749      ! ------------------------------------------------------------ ! 
    764750      zztmp1 = rn_vfac * 0.5_wp 
    765       DO jj = 2, jpj    ! at T point 
    766          DO ji = 2, jpi 
    767             zztmp2 = zrhoa(ji,jj) * Cd_atm(ji,jj) * wndm_ice(ji,jj) 
    768             utau_ice(ji,jj) = zztmp2 * ( sf(jp_wndi)%fnow(ji,jj,1) - zztmp1 * ( u_ice(ji-1,jj  ) + u_ice(ji,jj) ) ) 
    769             vtau_ice(ji,jj) = zztmp2 * ( sf(jp_wndj)%fnow(ji,jj,1) - zztmp1 * ( v_ice(ji  ,jj-1) + v_ice(ji,jj) ) ) 
    770          END DO 
    771       END DO 
    772       ! 
    773       DO jj = 2, jpjm1  ! U & V-points (same as ocean). 
    774          DO ji = fs_2, fs_jpim1   ! vect. opt. 
    775             ! take care of the land-sea mask to avoid "pollution" of coastal stress. p[uv]taui used in frazil and  rheology  
    776             zztmp1 = 0.5_wp * ( 2. - umask(ji,jj,1) ) * MAX( tmask(ji,jj,1),tmask(ji+1,jj  ,1) ) 
    777             zztmp2 = 0.5_wp * ( 2. - vmask(ji,jj,1) ) * MAX( tmask(ji,jj,1),tmask(ji  ,jj+1,1) ) 
    778             utau_ice(ji,jj) = zztmp1 * ( utau_ice(ji,jj) + utau_ice(ji+1,jj  ) ) 
    779             vtau_ice(ji,jj) = zztmp2 * ( vtau_ice(ji,jj) + vtau_ice(ji  ,jj+1) ) 
    780          END DO 
    781       END DO 
     751      DO_2D_01_01 
     752         zztmp2 = zrhoa(ji,jj) * Cd_atm(ji,jj) * wndm_ice(ji,jj) 
     753         utau_ice(ji,jj) = zztmp2 * ( sf(jp_wndi)%fnow(ji,jj,1) - zztmp1 * ( u_ice(ji-1,jj  ) + u_ice(ji,jj) ) ) 
     754         vtau_ice(ji,jj) = zztmp2 * ( sf(jp_wndj)%fnow(ji,jj,1) - zztmp1 * ( v_ice(ji  ,jj-1) + v_ice(ji,jj) ) ) 
     755      END_2D 
     756      ! 
     757      DO_2D_00_00 
     758         ! take care of the land-sea mask to avoid "pollution" of coastal stress. p[uv]taui used in frazil and  rheology  
     759         zztmp1 = 0.5_wp * ( 2. - umask(ji,jj,1) ) * MAX( tmask(ji,jj,1),tmask(ji+1,jj  ,1) ) 
     760         zztmp2 = 0.5_wp * ( 2. - vmask(ji,jj,1) ) * MAX( tmask(ji,jj,1),tmask(ji  ,jj+1,1) ) 
     761         utau_ice(ji,jj) = zztmp1 * ( utau_ice(ji,jj) + utau_ice(ji+1,jj  ) ) 
     762         vtau_ice(ji,jj) = zztmp2 * ( vtau_ice(ji,jj) + vtau_ice(ji  ,jj+1) ) 
     763      END_2D 
    782764      CALL lbc_lnk_multi( 'sbcblk', utau_ice, 'U', -1., vtau_ice, 'V', -1. ) 
    783765      ! 
    … …  
    10251007         !    
    10261008         DO jl = 1, jpl                 
    1027             DO jj = 1 , jpj 
    1028                DO ji = 1, jpi 
    1029                   zhe = ( rn_cnd_s * phi(ji,jj,jl) + rcnd_i * phs(ji,jj,jl) ) * zfac                            ! Effective thickness 
    1030                   IF( zhe >=  zfac2 )   zgfac(ji,jj,jl) = MIN( 2._wp, 0.5_wp * ( 1._wp + LOG( zhe * zfac3 ) ) ) ! Enhanced conduction factor 
    1031                END DO 
    1032             END DO 
     1009            DO_2D_11_11 
     1010               zhe = ( rn_cnd_s * phi(ji,jj,jl) + rcnd_i * phs(ji,jj,jl) ) * zfac                            ! Effective thickness 
     1011               IF( zhe >=  zfac2 )   zgfac(ji,jj,jl) = MIN( 2._wp, 0.5_wp * ( 1._wp + LOG( zhe * zfac3 ) ) ) ! Enhanced conduction factor 
     1012            END_2D 
    10331013         END DO 
    10341014         !       
    … …  
    10421022      ! 
    10431023      DO jl = 1, jpl 
    1044          DO jj = 1 , jpj 
    1045             DO ji = 1, jpi 
    1046                !                     
    1047                zkeff_h = zfac * zgfac(ji,jj,jl) / &                                    ! Effective conductivity of the snow-ice system divided by thickness 
    1048                   &      ( rcnd_i * phs(ji,jj,jl) + rn_cnd_s * MAX( 0.01, phi(ji,jj,jl) ) ) 
    1049                ztsu    = ptsu(ji,jj,jl)                                                ! Store current iteration temperature 
    1050                ztsu0   = ptsu(ji,jj,jl)                                                ! Store initial surface temperature 
    1051                zqa0    = qsr_ice(ji,jj,jl) - qtr_ice_top(ji,jj,jl) + qns_ice(ji,jj,jl) ! Net initial atmospheric heat flux 
    1052                ! 
    1053                DO iter = 1, nit     ! --- Iterative loop 
    1054                   zqc   = zkeff_h * ( ztsu - ptb(ji,jj) )                              ! Conduction heat flux through snow-ice system (>0 downwards) 
    1055                   zqnet = zqa0 + dqns_ice(ji,jj,jl) * ( ztsu - ptsu(ji,jj,jl) ) - zqc  ! Surface energy budget 
    1056                   ztsu  = ztsu - zqnet / ( dqns_ice(ji,jj,jl) - zkeff_h )              ! Temperature update 
    1057                END DO 
    1058                ! 
    1059                ptsu   (ji,jj,jl) = MIN( rt0, ztsu ) 
    1060                qcn_ice(ji,jj,jl) = zkeff_h * ( ptsu(ji,jj,jl) - ptb(ji,jj) ) 
    1061                qns_ice(ji,jj,jl) = qns_ice(ji,jj,jl) + dqns_ice(ji,jj,jl) * ( ptsu(ji,jj,jl) - ztsu0 ) 
    1062                qml_ice(ji,jj,jl) = ( qsr_ice(ji,jj,jl) - qtr_ice_top(ji,jj,jl) + qns_ice(ji,jj,jl) - qcn_ice(ji,jj,jl) )  & 
    1063                              &   * MAX( 0._wp , SIGN( 1._wp, ptsu(ji,jj,jl) - rt0 ) ) 
    1064  
    1065                ! --- Diagnose the heat loss due to changing non-solar flux (as in icethd_zdf_bl99) --- ! 
    1066                hfx_err_dif(ji,jj) = hfx_err_dif(ji,jj) - ( dqns_ice(ji,jj,jl) * ( ptsu(ji,jj,jl) - ztsu0 ) ) * a_i_b(ji,jj,jl)  
    1067  
     1024         DO_2D_11_11 
     1025            !                     
     1026            zkeff_h = zfac * zgfac(ji,jj,jl) / &                                    ! Effective conductivity of the snow-ice system divided by thickness 
     1027               &      ( rcnd_i * phs(ji,jj,jl) + rn_cnd_s * MAX( 0.01, phi(ji,jj,jl) ) ) 
     1028            ztsu    = ptsu(ji,jj,jl)                                                ! Store current iteration temperature 
     1029            ztsu0   = ptsu(ji,jj,jl)                                                ! Store initial surface temperature 
     1030            zqa0    = qsr_ice(ji,jj,jl) - qtr_ice_top(ji,jj,jl) + qns_ice(ji,jj,jl) ! Net initial atmospheric heat flux 
     1031            ! 
     1032            DO iter = 1, nit     ! --- Iterative loop 
     1033               zqc   = zkeff_h * ( ztsu - ptb(ji,jj) )                              ! Conduction heat flux through snow-ice system (>0 downwards) 
     1034               zqnet = zqa0 + dqns_ice(ji,jj,jl) * ( ztsu - ptsu(ji,jj,jl) ) - zqc  ! Surface energy budget 
     1035               ztsu  = ztsu - zqnet / ( dqns_ice(ji,jj,jl) - zkeff_h )              ! Temperature update 
    10681036            END DO 
    1069          END DO 
     1037            ! 
     1038            ptsu   (ji,jj,jl) = MIN( rt0, ztsu ) 
     1039            qcn_ice(ji,jj,jl) = zkeff_h * ( ptsu(ji,jj,jl) - ptb(ji,jj) ) 
     1040            qns_ice(ji,jj,jl) = qns_ice(ji,jj,jl) + dqns_ice(ji,jj,jl) * ( ptsu(ji,jj,jl) - ztsu0 ) 
     1041            qml_ice(ji,jj,jl) = ( qsr_ice(ji,jj,jl) - qtr_ice_top(ji,jj,jl) + qns_ice(ji,jj,jl) - qcn_ice(ji,jj,jl) )  & 
     1042                          &   * MAX( 0._wp , SIGN( 1._wp, ptsu(ji,jj,jl) - rt0 ) ) 
     1043 
     1044            ! --- Diagnose the heat loss due to changing non-solar flux (as in icethd_zdf_bl99) --- ! 
     1045            hfx_err_dif(ji,jj) = hfx_err_dif(ji,jj) - ( dqns_ice(ji,jj,jl) * ( ptsu(ji,jj,jl) - ztsu0 ) ) * a_i_b(ji,jj,jl)  
     1046 
     1047         END_2D 
    10701048         ! 
    10711049      END DO  
    … …  
    11951173      zqi_sat(:,:) = 0.98_wp * q_sat( ztm_su(:,:), sf(jp_slp)%fnow(:,:,1) )  ! saturation humidity over ice   [kg/kg] 
    11961174      ! 
    1197       DO jj = 2, jpjm1           ! reduced loop is necessary for reproducibility 
    1198          DO ji = fs_2, fs_jpim1 
    1199             ! Virtual potential temperature [K] 
    1200             zthetav_os = zst(ji,jj)    * ( 1._wp + rctv0 * zqo_sat(ji,jj) )   ! over ocean 
    1201             zthetav_is = ztm_su(ji,jj) * ( 1._wp + rctv0 * zqi_sat(ji,jj) )   ! ocean ice 
    1202             zthetav_zu = t_zu (ji,jj)  * ( 1._wp + rctv0 * q_zu(ji,jj)    )   ! at zu 
    1203              
    1204             ! Bulk Richardson Number (could use Ri_bulk function from aerobulk instead) 
    1205             zrib_o = grav / zthetav_os * ( zthetav_zu - zthetav_os ) * rn_zu / MAX( 0.5, wndm(ji,jj)     )**2   ! over ocean 
    1206             zrib_i = grav / zthetav_is * ( zthetav_zu - zthetav_is ) * rn_zu / MAX( 0.5, wndm_ice(ji,jj) )**2   ! over ice 
    1207              
    1208             ! Momentum and Heat Neutral Transfert Coefficients 
    1209             zCdn_form_ice = zCdn_form_tmp * at_i_b(ji,jj) * ( 1._wp - at_i_b(ji,jj) )**zbeta  ! Eq. 40 
    1210             zChn_form_ice = zCdn_form_ice / ( 1._wp + ( LOG( z1_alphaf ) / vkarmn ) * SQRT( zCdn_form_ice ) )               ! Eq. 53  
    1211                         
    1212             ! Momentum and Heat Stability functions (possibility to use psi_m_ecmwf instead) 
    1213             z0w = rn_zu * EXP( -1._wp * vkarmn / SQRT( Cdn_oce(ji,jj) ) ) ! over water 
    1214             z0i = z0_skin_ice                                             ! over ice (cf Lupkes email for details) 
    1215             IF( zrib_o <= 0._wp ) THEN 
    1216                zfmw = 1._wp - zam * zrib_o / ( 1._wp + 3._wp * zc2 * Cdn_oce(ji,jj) * SQRT( -zrib_o * ( rn_zu / z0w + 1._wp ) ) )  ! Eq. 10 
    1217                zfhw = ( 1._wp + ( zbetah * ( zthetav_os - zthetav_zu )**r1_3 / ( Chn_oce(ji,jj) * MAX(0.01, wndm(ji,jj)) )   &     ! Eq. 26 
    1218                   &             )**zgamma )**z1_gamma 
    1219             ELSE 
    1220                zfmw = 1._wp / ( 1._wp + zam * zrib_o / SQRT( 1._wp + zrib_o ) )   ! Eq. 12 
    1221                zfhw = 1._wp / ( 1._wp + zah * zrib_o / SQRT( 1._wp + zrib_o ) )   ! Eq. 28 
    1222             ENDIF 
    1223              
    1224             IF( zrib_i <= 0._wp ) THEN 
    1225                zfmi = 1._wp - zam * zrib_i / (1._wp + 3._wp * zc2 * zCdn_ice * SQRT( -zrib_i * ( rn_zu / z0i + 1._wp)))   ! Eq.  9 
    1226                zfhi = 1._wp - zah * zrib_i / (1._wp + 3._wp * zc2 * zCdn_ice * SQRT( -zrib_i * ( rn_zu / z0i + 1._wp)))   ! Eq. 25 
    1227             ELSE 
    1228                zfmi = 1._wp / ( 1._wp + zam * zrib_i / SQRT( 1._wp + zrib_i ) )   ! Eq. 11 
    1229                zfhi = 1._wp / ( 1._wp + zah * zrib_i / SQRT( 1._wp + zrib_i ) )   ! Eq. 27 
    1230             ENDIF 
    1231              
    1232             ! Momentum Transfert Coefficients (Eq. 38) 
    1233             Cd(ji,jj) = zCdn_skin_ice *   zfmi +  & 
    1234                &        zCdn_form_ice * ( zfmi * at_i_b(ji,jj) + zfmw * ( 1._wp - at_i_b(ji,jj) ) ) / MAX( 1.e-06, at_i_b(ji,jj) ) 
    1235              
    1236             ! Heat Transfert Coefficients (Eq. 49) 
    1237             Ch(ji,jj) = zChn_skin_ice *   zfhi +  & 
    1238                &        zChn_form_ice * ( zfhi * at_i_b(ji,jj) + zfhw * ( 1._wp - at_i_b(ji,jj) ) ) / MAX( 1.e-06, at_i_b(ji,jj) ) 
    1239             ! 
    1240          END DO 
    1241       END DO 
     1175      DO_2D_00_00 
     1176         ! Virtual potential temperature [K] 
     1177         zthetav_os = zst(ji,jj)    * ( 1._wp + rctv0 * zqo_sat(ji,jj) )   ! over ocean 
     1178         zthetav_is = ztm_su(ji,jj) * ( 1._wp + rctv0 * zqi_sat(ji,jj) )   ! ocean ice 
     1179         zthetav_zu = t_zu (ji,jj)  * ( 1._wp + rctv0 * q_zu(ji,jj)    )   ! at zu 
     1180          
     1181         ! Bulk Richardson Number (could use Ri_bulk function from aerobulk instead) 
     1182         zrib_o = grav / zthetav_os * ( zthetav_zu - zthetav_os ) * rn_zu / MAX( 0.5, wndm(ji,jj)     )**2   ! over ocean 
     1183         zrib_i = grav / zthetav_is * ( zthetav_zu - zthetav_is ) * rn_zu / MAX( 0.5, wndm_ice(ji,jj) )**2   ! over ice 
     1184          
     1185         ! Momentum and Heat Neutral Transfert Coefficients 
     1186         zCdn_form_ice = zCdn_form_tmp * at_i_b(ji,jj) * ( 1._wp - at_i_b(ji,jj) )**zbeta  ! Eq. 40 
     1187         zChn_form_ice = zCdn_form_ice / ( 1._wp + ( LOG( z1_alphaf ) / vkarmn ) * SQRT( zCdn_form_ice ) )               ! Eq. 53  
     1188                     
     1189         ! Momentum and Heat Stability functions (possibility to use psi_m_ecmwf instead) 
     1190         z0w = rn_zu * EXP( -1._wp * vkarmn / SQRT( Cdn_oce(ji,jj) ) ) ! over water 
     1191         z0i = z0_skin_ice                                             ! over ice (cf Lupkes email for details) 
     1192         IF( zrib_o <= 0._wp ) THEN 
     1193            zfmw = 1._wp - zam * zrib_o / ( 1._wp + 3._wp * zc2 * Cdn_oce(ji,jj) * SQRT( -zrib_o * ( rn_zu / z0w + 1._wp ) ) )  ! Eq. 10 
     1194            zfhw = ( 1._wp + ( zbetah * ( zthetav_os - zthetav_zu )**r1_3 / ( Chn_oce(ji,jj) * MAX(0.01, wndm(ji,jj)) )   &     ! Eq. 26 
     1195               &             )**zgamma )**z1_gamma 
     1196         ELSE 
     1197            zfmw = 1._wp / ( 1._wp + zam * zrib_o / SQRT( 1._wp + zrib_o ) )   ! Eq. 12 
     1198            zfhw = 1._wp / ( 1._wp + zah * zrib_o / SQRT( 1._wp + zrib_o ) )   ! Eq. 28 
     1199         ENDIF 
     1200          
     1201         IF( zrib_i <= 0._wp ) THEN 
     1202            zfmi = 1._wp - zam * zrib_i / (1._wp + 3._wp * zc2 * zCdn_ice * SQRT( -zrib_i * ( rn_zu / z0i + 1._wp)))   ! Eq.  9 
     1203            zfhi = 1._wp - zah * zrib_i / (1._wp + 3._wp * zc2 * zCdn_ice * SQRT( -zrib_i * ( rn_zu / z0i + 1._wp)))   ! Eq. 25 
     1204         ELSE 
     1205            zfmi = 1._wp / ( 1._wp + zam * zrib_i / SQRT( 1._wp + zrib_i ) )   ! Eq. 11 
     1206            zfhi = 1._wp / ( 1._wp + zah * zrib_i / SQRT( 1._wp + zrib_i ) )   ! Eq. 27 
     1207         ENDIF 
     1208          
     1209         ! Momentum Transfert Coefficients (Eq. 38) 
     1210         Cd(ji,jj) = zCdn_skin_ice *   zfmi +  & 
     1211            &        zCdn_form_ice * ( zfmi * at_i_b(ji,jj) + zfmw * ( 1._wp - at_i_b(ji,jj) ) ) / MAX( 1.e-06, at_i_b(ji,jj) ) 
     1212          
     1213         ! Heat Transfert Coefficients (Eq. 49) 
     1214         Ch(ji,jj) = zChn_skin_ice *   zfhi +  & 
     1215            &        zChn_form_ice * ( zfhi * at_i_b(ji,jj) + zfhw * ( 1._wp - at_i_b(ji,jj) ) ) / MAX( 1.e-06, at_i_b(ji,jj) ) 
     1216         ! 
     1217      END_2D 
    12421218      CALL lbc_lnk_multi( 'sbcblk', Cd, 'T',  1., Ch, 'T', 1. ) 
    12431219      ! 

  • NEMO/branches/2020/temporary_r4_trunk/src/OCE/SBC/sbcblk_algo_ncar.F90

    r13466 r13469  
    214214      !!---------------------------------------------------------------------------------- 
    215215      ! 
    216       DO jj = 1, jpj 
    217          DO ji = 1, jpi 
    218             ! 
    219             zw  = pw10(ji,jj) 
    220             zw6 = zw*zw*zw 
    221             zw6 = zw6*zw6 
    222             ! 
    223             ! When wind speed > 33 m/s => Cyclone conditions => special treatment 
    224             zgt33 = 0.5_wp + SIGN( 0.5_wp, (zw - 33._wp) )   ! If pw10 < 33. => 0, else => 1 
    225             ! 
    226             CD_N10_NCAR(ji,jj) = 1.e-3_wp * ( & 
    227                &       (1._wp - zgt33)*( 2.7_wp/zw + 0.142_wp + zw/13.09_wp - 3.14807E-10_wp*zw6) & ! wind <  33 m/s 
    228                &      +    zgt33   *      2.34_wp )                                                 ! wind >= 33 m/s 
    229             ! 
    230             CD_N10_NCAR(ji,jj) = MAX( CD_N10_NCAR(ji,jj), 0.1E-3_wp ) 
    231             ! 
    232          END DO 
    233       END DO 
     216      DO_2D_11_11 
     217         ! 
     218         zw  = pw10(ji,jj) 
     219         zw6 = zw*zw*zw 
     220         zw6 = zw6*zw6 
     221         ! 
     222         ! When wind speed > 33 m/s => Cyclone conditions => special treatment 
     223         zgt33 = 0.5_wp + SIGN( 0.5_wp, (zw - 33._wp) )   ! If pw10 < 33. => 0, else => 1 
     224         ! 
     225         CD_N10_NCAR(ji,jj) = 1.e-3_wp * ( & 
     226            &       (1._wp - zgt33)*( 2.7_wp/zw + 0.142_wp + zw/13.09_wp - 3.14807E-10_wp*zw6) & ! wind <  33 m/s 
     227            &      +    zgt33   *      2.34_wp )                                                 ! wind >= 33 m/s 
     228         ! 
     229         CD_N10_NCAR(ji,jj) = MAX( CD_N10_NCAR(ji,jj), 0.1E-3_wp ) 
     230         ! 
     231      END_2D 
    234232      ! 
    235233   END FUNCTION CD_N10_NCAR 
    … …  
    281279      REAL(wp) :: zzeta, zx2, zx, zpsi_unst, zpsi_stab,  zstab   ! local scalars 
    282280      !!---------------------------------------------------------------------------------- 
    283       DO jj = 1, jpj 
    284          DO ji = 1, jpi 
    285  
    286             zzeta = pzeta(ji,jj) 
    287             ! 
    288             zx2 = SQRT( ABS(1._wp - 16._wp*zzeta) )  ! (1 - 16z)^0.5 
    289             zx2 = MAX( zx2 , 1._wp ) 
    290             zx  = SQRT(zx2)                          ! (1 - 16z)^0.25 
    291             zpsi_unst = 2._wp*LOG( (1._wp + zx )*0.5_wp )   & 
    292                &            + LOG( (1._wp + zx2)*0.5_wp )   & 
    293                &          - 2._wp*ATAN(zx) + rpi*0.5_wp 
    294             ! 
    295             zpsi_stab = -5._wp*zzeta 
    296             ! 
    297             zstab = 0.5_wp + SIGN(0.5_wp, zzeta) ! zzeta > 0 => zstab = 1 
    298             ! 
    299             psi_m_ncar(ji,jj) =          zstab  * zpsi_stab &  ! (zzeta > 0) Stable 
    300                &              + (1._wp - zstab) * zpsi_unst    ! (zzeta < 0) Unstable 
    301             ! 
    302          END DO 
    303       END DO 
     281      DO_2D_11_11 
     282 
     283         zzeta = pzeta(ji,jj) 
     284         ! 
     285         zx2 = SQRT( ABS(1._wp - 16._wp*zzeta) )  ! (1 - 16z)^0.5 
     286         zx2 = MAX( zx2 , 1._wp ) 
     287         zx  = SQRT(zx2)                          ! (1 - 16z)^0.25 
     288         zpsi_unst = 2._wp*LOG( (1._wp + zx )*0.5_wp )   & 
     289            &            + LOG( (1._wp + zx2)*0.5_wp )   & 
     290            &          - 2._wp*ATAN(zx) + rpi*0.5_wp 
     291         ! 
     292         zpsi_stab = -5._wp*zzeta 
     293         ! 
     294         zstab = 0.5_wp + SIGN(0.5_wp, zzeta) ! zzeta > 0 => zstab = 1 
     295         ! 
     296         psi_m_ncar(ji,jj) =          zstab  * zpsi_stab &  ! (zzeta > 0) Stable 
     297            &              + (1._wp - zstab) * zpsi_unst    ! (zzeta < 0) Unstable 
     298         ! 
     299      END_2D 
    304300   END FUNCTION psi_m_ncar 
    305301 
    … …  
    322318      !!---------------------------------------------------------------------------------- 
    323319      ! 
    324       DO jj = 1, jpj 
    325          DO ji = 1, jpi 
    326             ! 
    327             zzeta = pzeta(ji,jj) 
    328             ! 
    329             zx2 = SQRT( ABS(1._wp - 16._wp*zzeta) )  ! (1 -16z)^0.5 
    330             zx2 = MAX( zx2 , 1._wp ) 
    331             zpsi_unst = 2._wp*LOG( 0.5_wp*(1._wp + zx2) ) 
    332             ! 
    333             zpsi_stab = -5._wp*zzeta 
    334             ! 
    335             zstab = 0.5_wp + SIGN(0.5_wp, zzeta) ! zzeta > 0 => zstab = 1 
    336             ! 
    337             psi_h_ncar(ji,jj) =          zstab  * zpsi_stab &  ! (zzeta > 0) Stable 
    338                &              + (1._wp - zstab) * zpsi_unst    ! (zzeta < 0) Unstable 
    339             ! 
    340          END DO 
    341       END DO 
     320      DO_2D_11_11 
     321         ! 
     322         zzeta = pzeta(ji,jj) 
     323         ! 
     324         zx2 = SQRT( ABS(1._wp - 16._wp*zzeta) )  ! (1 -16z)^0.5 
     325         zx2 = MAX( zx2 , 1._wp ) 
     326         zpsi_unst = 2._wp*LOG( 0.5_wp*(1._wp + zx2) ) 
     327         ! 
     328         zpsi_stab = -5._wp*zzeta 
     329         ! 
     330         zstab = 0.5_wp + SIGN(0.5_wp, zzeta) ! zzeta > 0 => zstab = 1 
     331         ! 
     332         psi_h_ncar(ji,jj) =          zstab  * zpsi_stab &  ! (zzeta > 0) Stable 
     333            &              + (1._wp - zstab) * zpsi_unst    ! (zzeta < 0) Unstable 
     334         ! 
     335      END_2D 
    342336   END FUNCTION psi_h_ncar 
    343337 
    … …  
    382376      !!------------------------------------------------------------------- 
    383377      ! 
    384       DO jj = 1, jpj 
    385          DO ji = 1, jpi 
    386             ! 
    387             zqa = (1._wp + rctv0*pqa(ji,jj)) 
    388             ! 
    389             ! The main concern is to know whether, the vertical turbulent flux of virtual temperature, < u' theta_v' > is estimated with: 
    390             !  a/  -u* [ theta* (1 + 0.61 q) + 0.61 theta q* ] => this is the one that seems correct! chose this one! 
    391             !                      or 
    392             !  b/  -u* [ theta*              + 0.61 theta q* ] 
    393             ! 
    394             One_on_L(ji,jj) = grav*vkarmn*( pts(ji,jj)*zqa + rctv0*ptha(ji,jj)*pqs(ji,jj) ) & 
    395                &               / MAX( pus(ji,jj)*pus(ji,jj)*ptha(ji,jj)*zqa , 1.E-9_wp ) 
    396             ! 
    397          END DO 
    398       END DO 
     378      DO_2D_11_11 
     379         ! 
     380         zqa = (1._wp + rctv0*pqa(ji,jj)) 
     381         ! 
     382         ! The main concern is to know whether, the vertical turbulent flux of virtual temperature, < u' theta_v' > is estimated with: 
     383         !  a/  -u* [ theta* (1 + 0.61 q) + 0.61 theta q* ] => this is the one that seems correct! chose this one! 
     384         !                      or 
     385         !  b/  -u* [ theta*              + 0.61 theta q* ] 
     386         ! 
     387         One_on_L(ji,jj) = grav*vkarmn*( pts(ji,jj)*zqa + rctv0*ptha(ji,jj)*pqs(ji,jj) ) & 
     388            &               / MAX( pus(ji,jj)*pus(ji,jj)*ptha(ji,jj)*zqa , 1.E-9_wp ) 
     389         ! 
     390      END_2D 
    399391      ! 
    400392      One_on_L = SIGN( MIN(ABS(One_on_L),200._wp), One_on_L ) ! (prevent FPE from stupid values over masked regions...) 

  • NEMO/branches/2020/temporary_r4_trunk/src/OCE/SBC/sbccpl.F90

    r13467 r13469  
    11931193            !                               
    11941194            IF( srcv(jpr_otx1)%clgrid == 'T' ) THEN 
    1195                DO jj = 2, jpjm1                                          ! T ==> (U,V) 
    1196                   DO ji = fs_2, fs_jpim1   ! vector opt. 
    1197                      frcv(jpr_otx1)%z3(ji,jj,1) = 0.5 * ( frcv(jpr_otx1)%z3(ji+1,jj  ,1) + frcv(jpr_otx1)%z3(ji,jj,1) ) 
    1198                      frcv(jpr_oty1)%z3(ji,jj,1) = 0.5 * ( frcv(jpr_oty1)%z3(ji  ,jj+1,1) + frcv(jpr_oty1)%z3(ji,jj,1) ) 
    1199                   END DO 
    1200                END DO 
     1195               DO_2D_00_00 
     1196                  frcv(jpr_otx1)%z3(ji,jj,1) = 0.5 * ( frcv(jpr_otx1)%z3(ji+1,jj  ,1) + frcv(jpr_otx1)%z3(ji,jj,1) ) 
     1197                  frcv(jpr_oty1)%z3(ji,jj,1) = 0.5 * ( frcv(jpr_oty1)%z3(ji  ,jj+1,1) + frcv(jpr_oty1)%z3(ji,jj,1) ) 
     1198               END_2D 
    12011199               CALL lbc_lnk_multi( 'sbccpl', frcv(jpr_otx1)%z3(:,:,1), 'U',  -1., frcv(jpr_oty1)%z3(:,:,1), 'V',  -1. ) 
    12021200            ENDIF 
    … …  
    12191217         ! => need to be done only when otx1 was changed 
    12201218         IF( llnewtx ) THEN 
    1221             DO jj = 2, jpjm1 
    1222                DO ji = fs_2, fs_jpim1   ! vect. opt. 
    1223                   zzx = frcv(jpr_otx1)%z3(ji-1,jj  ,1) + frcv(jpr_otx1)%z3(ji,jj,1) 
    1224                   zzy = frcv(jpr_oty1)%z3(ji  ,jj-1,1) + frcv(jpr_oty1)%z3(ji,jj,1) 
    1225                   frcv(jpr_taum)%z3(ji,jj,1) = 0.5 * SQRT( zzx * zzx + zzy * zzy ) 
    1226                END DO 
    1227             END DO 
     1219            DO_2D_00_00 
     1220               zzx = frcv(jpr_otx1)%z3(ji-1,jj  ,1) + frcv(jpr_otx1)%z3(ji,jj,1) 
     1221               zzy = frcv(jpr_oty1)%z3(ji  ,jj-1,1) + frcv(jpr_oty1)%z3(ji,jj,1) 
     1222               frcv(jpr_taum)%z3(ji,jj,1) = 0.5 * SQRT( zzx * zzx + zzy * zzy ) 
     1223            END_2D 
    12281224            CALL lbc_lnk( 'sbccpl', frcv(jpr_taum)%z3(:,:,1), 'T', 1. ) 
    12291225            llnewtau = .TRUE. 
    … …  
    12461242         IF( llnewtau ) THEN  
    12471243            zcoef = 1. / ( zrhoa * zcdrag )  
    1248             DO jj = 1, jpj 
    1249                DO ji = 1, jpi  
    1250                   frcv(jpr_w10m)%z3(ji,jj,1) = SQRT( frcv(jpr_taum)%z3(ji,jj,1) * zcoef ) 
    1251                END DO 
    1252             END DO 
     1244            DO_2D_11_11 
     1245               frcv(jpr_w10m)%z3(ji,jj,1) = SQRT( frcv(jpr_taum)%z3(ji,jj,1) * zcoef ) 
     1246            END_2D 
    12531247         ENDIF 
    12541248      ENDIF 
    … …  
    13891383      IF( srcv(jpr_ocx1)%laction ) THEN                      ! received by sas in case of opa <-> sas coupling 
    13901384         ssu_m(:,:) = frcv(jpr_ocx1)%z3(:,:,1) 
    1391          ub (:,:,1) = ssu_m(:,:)                             ! will be used in icestp in the call of ice_forcing_tau 
    1392          un (:,:,1) = ssu_m(:,:)                             ! will be used in sbc_cpl_snd if atmosphere coupling 
     1385         uu (:,:,1,Nnn) = ssu_m(:,:)                             ! will be used in icestp in the call of ice_forcing_tau 
     1386         uu (:,:,1,Nii) = ssu_m(:,:)                             ! will be used in sbc_cpl_snd if atmosphere coupling 
    13931387         CALL iom_put( 'ssu_m', ssu_m ) 
    13941388      ENDIF 
    13951389      IF( srcv(jpr_ocy1)%laction ) THEN 
    13961390         ssv_m(:,:) = frcv(jpr_ocy1)%z3(:,:,1) 
    1397          vb (:,:,1) = ssv_m(:,:)                             ! will be used in icestp in the call of ice_forcing_tau 
    1398          vn (:,:,1) = ssv_m(:,:)                             ! will be used in sbc_cpl_snd if atmosphere coupling 
     1391         vv (:,:,1,Nnn) = ssv_m(:,:)                             ! will be used in icestp in the call of ice_forcing_tau 
     1392         vv (:,:,1,Nii) = ssv_m(:,:)                             ! will be used in sbc_cpl_snd if atmosphere coupling 
    13991393         CALL iom_put( 'ssv_m', ssv_m ) 
    14001394      ENDIF 
    … …  
    15861580            p_tauj(:,:) = frcv(jpr_ity1)%z3(:,:,1) 
    15871581         CASE( 'T' ) 
    1588             DO jj = 2, jpjm1                                   ! T ==> (U,V) 
    1589                DO ji = fs_2, fs_jpim1   ! vector opt. 
    1590                   ! take care of the land-sea mask to avoid "pollution" of coastal stress. p[uv]taui used in frazil and  rheology  
    1591                   zztmp1 = 0.5_wp * ( 2. - umask(ji,jj,1) ) * MAX( tmask(ji,jj,1),tmask(ji+1,jj  ,1) ) 
    1592                   zztmp2 = 0.5_wp * ( 2. - vmask(ji,jj,1) ) * MAX( tmask(ji,jj,1),tmask(ji  ,jj+1,1) ) 
    1593                   p_taui(ji,jj) = zztmp1 * ( frcv(jpr_itx1)%z3(ji+1,jj  ,1) + frcv(jpr_itx1)%z3(ji,jj,1) ) 
    1594                   p_tauj(ji,jj) = zztmp2 * ( frcv(jpr_ity1)%z3(ji  ,jj+1,1) + frcv(jpr_ity1)%z3(ji,jj,1) ) 
    1595                END DO 
    1596             END DO 
     1582            DO_2D_00_00 
     1583               ! take care of the land-sea mask to avoid "pollution" of coastal stress. p[uv]taui used in frazil and  rheology  
     1584               zztmp1 = 0.5_wp * ( 2. - umask(ji,jj,1) ) * MAX( tmask(ji,jj,1),tmask(ji+1,jj  ,1) ) 
     1585               zztmp2 = 0.5_wp * ( 2. - vmask(ji,jj,1) ) * MAX( tmask(ji,jj,1),tmask(ji  ,jj+1,1) ) 
     1586               p_taui(ji,jj) = zztmp1 * ( frcv(jpr_itx1)%z3(ji+1,jj  ,1) + frcv(jpr_itx1)%z3(ji,jj,1) ) 
     1587               p_tauj(ji,jj) = zztmp2 * ( frcv(jpr_ity1)%z3(ji  ,jj+1,1) + frcv(jpr_ity1)%z3(ji,jj,1) ) 
     1588            END_2D 
    15971589            CALL lbc_lnk_multi( 'sbccpl', p_taui, 'U',  -1., p_tauj, 'V',  -1. ) 
    15981590         END SELECT 
    … …  
    24662458         !                                                               i      i+1 (for I) 
    24672459         IF( nn_components == jp_iam_opa ) THEN 
    2468             zotx1(:,:) = un(:,:,1)   
    2469             zoty1(:,:) = vn(:,:,1)   
     2460            zotx1(:,:) = uu(:,:,1,Nii)   
     2461            zoty1(:,:) = vv(:,:,1,Nii)   
    24702462         ELSE         
    24712463            SELECT CASE( TRIM( sn_snd_crt%cldes ) ) 
    24722464            CASE( 'oce only'             )      ! C-grid ==> T 
    2473                DO jj = 2, jpjm1 
    2474                   DO ji = fs_2, fs_jpim1   ! vector opt. 
    2475                      zotx1(ji,jj) = 0.5 * ( un(ji,jj,1) + un(ji-1,jj  ,1) ) 
    2476                      zoty1(ji,jj) = 0.5 * ( vn(ji,jj,1) + vn(ji  ,jj-1,1) )  
    2477                   END DO 
    2478                END DO 
     2465               DO_2D_00_00 
     2466                  zotx1(ji,jj) = 0.5 * ( uu(ji,jj,1,Nii) + uu(ji-1,jj  ,1,Nii) ) 
     2467                  zoty1(ji,jj) = 0.5 * ( vv(ji,jj,1,Nii) + vv(ji  ,jj-1,1,Nii) )  
     2468               END_2D 
    24792469            CASE( 'weighted oce and ice' )      ! Ocean and Ice on C-grid ==> T   
    2480                DO jj = 2, jpjm1 
    2481                   DO ji = fs_2, fs_jpim1   ! vector opt. 
    2482                      zotx1(ji,jj) = 0.5 * ( un   (ji,jj,1) + un   (ji-1,jj  ,1) ) * zfr_l(ji,jj)   
    2483                      zoty1(ji,jj) = 0.5 * ( vn   (ji,jj,1) + vn   (ji  ,jj-1,1) ) * zfr_l(ji,jj) 
    2484                      zitx1(ji,jj) = 0.5 * ( u_ice(ji,jj  ) + u_ice(ji-1,jj    ) ) *  fr_i(ji,jj) 
    2485                      zity1(ji,jj) = 0.5 * ( v_ice(ji,jj  ) + v_ice(ji  ,jj-1  ) ) *  fr_i(ji,jj) 
    2486                   END DO 
    2487                END DO 
     2470               DO_2D_00_00 
     2471                  zotx1(ji,jj) = 0.5 * ( uu   (ji,jj,1,Nii) + uu   (ji-1,jj  ,1,Nii) ) * zfr_l(ji,jj)   
     2472                  zoty1(ji,jj) = 0.5 * ( vv   (ji,jj,1,Nii) + vv   (ji  ,jj-1,1,Nii) ) * zfr_l(ji,jj) 
     2473                  zitx1(ji,jj) = 0.5 * ( u_ice(ji,jj  ) + u_ice(ji-1,jj    ) ) *  fr_i(ji,jj) 
     2474                  zity1(ji,jj) = 0.5 * ( v_ice(ji,jj  ) + v_ice(ji  ,jj-1  ) ) *  fr_i(ji,jj) 
     2475               END_2D 
    24882476               CALL lbc_lnk_multi( 'sbccpl', zitx1, 'T', -1., zity1, 'T', -1. ) 
    24892477            CASE( 'mixed oce-ice'        )      ! Ocean and Ice on C-grid ==> T 
    2490                DO jj = 2, jpjm1 
    2491                   DO ji = fs_2, fs_jpim1   ! vector opt. 
    2492                      zotx1(ji,jj) = 0.5 * ( un   (ji,jj,1) + un   (ji-1,jj  ,1) ) * zfr_l(ji,jj)   & 
    2493                         &         + 0.5 * ( u_ice(ji,jj  ) + u_ice(ji-1,jj    ) ) *  fr_i(ji,jj) 
    2494                      zoty1(ji,jj) = 0.5 * ( vn   (ji,jj,1) + vn   (ji  ,jj-1,1) ) * zfr_l(ji,jj)   & 
    2495                         &         + 0.5 * ( v_ice(ji,jj  ) + v_ice(ji  ,jj-1  ) ) *  fr_i(ji,jj) 
    2496                   END DO 
    2497                END DO 
     2478               DO_2D_00_00 
     2479                  zotx1(ji,jj) = 0.5 * ( uu   (ji,jj,1,Nii) + uu   (ji-1,jj  ,1,Nii) ) * zfr_l(ji,jj)   & 
     2480                     &         + 0.5 * ( u_ice(ji,jj  ) + u_ice(ji-1,jj    ) ) *  fr_i(ji,jj) 
     2481                  zoty1(ji,jj) = 0.5 * ( vv   (ji,jj,1,Nii) + vv   (ji  ,jj-1,1,Nii) ) * zfr_l(ji,jj)   & 
     2482                     &         + 0.5 * ( v_ice(ji,jj  ) + v_ice(ji  ,jj-1  ) ) *  fr_i(ji,jj) 
     2483               END_2D 
    24982484            END SELECT 
    24992485            CALL lbc_lnk_multi( 'sbccpl', zotx1, ssnd(jps_ocx1)%clgrid, -1.,  zoty1, ssnd(jps_ocy1)%clgrid, -1. ) 
    … …  
    25542540          SELECT CASE( TRIM( sn_snd_crtw%cldes ) )  
    25552541          CASE( 'oce only'             )      ! C-grid ==> T  
    2556              DO jj = 2, jpjm1  
    2557                 DO ji = fs_2, fs_jpim1   ! vector opt.  
    2558                    zotx1(ji,jj) = 0.5 * ( un(ji,jj,1) + un(ji-1,jj  ,1) )  
    2559                    zoty1(ji,jj) = 0.5 * ( vn(ji,jj,1) + vn(ji , jj-1,1) )   
    2560                 END DO  
    2561              END DO  
     2542             DO_2D_00_00 
     2543                zotx1(ji,jj) = 0.5 * ( uu(ji,jj,1,Nii) + uu(ji-1,jj  ,1,Nii) )  
     2544                zoty1(ji,jj) = 0.5 * ( vv(ji,jj,1,Nii) + vv(ji , jj-1,1,Nii) )   
     2545             END_2D 
    25622546          CASE( 'weighted oce and ice' )      ! Ocean and Ice on C-grid ==> T    
    2563              DO jj = 2, jpjm1  
    2564                 DO ji = fs_2, fs_jpim1   ! vector opt.  
    2565                    zotx1(ji,jj) = 0.5 * ( un   (ji,jj,1) + un   (ji-1,jj  ,1) ) * zfr_l(ji,jj)    
    2566                    zoty1(ji,jj) = 0.5 * ( vn   (ji,jj,1) + vn   (ji  ,jj-1,1) ) * zfr_l(ji,jj)  
    2567                    zitx1(ji,jj) = 0.5 * ( u_ice(ji,jj  ) + u_ice(ji-1,jj    ) ) *  fr_i(ji,jj)  
    2568                    zity1(ji,jj) = 0.5 * ( v_ice(ji,jj  ) + v_ice(ji  ,jj-1  ) ) *  fr_i(ji,jj)  
    2569                 END DO 
    2570              END DO 
     2547             DO_2D_00_00 
     2548                zotx1(ji,jj) = 0.5 * ( uu   (ji,jj,1,Nii) + uu   (ji-1,jj  ,1,Nii) ) * zfr_l(ji,jj)    
     2549                zoty1(ji,jj) = 0.5 * ( vv   (ji,jj,1,Nii) + vv   (ji  ,jj-1,1,Nii) ) * zfr_l(ji,jj)  
     2550                zitx1(ji,jj) = 0.5 * ( u_ice(ji,jj  ) + u_ice(ji-1,jj    ) ) *  fr_i(ji,jj)  
     2551                zity1(ji,jj) = 0.5 * ( v_ice(ji,jj  ) + v_ice(ji  ,jj-1  ) ) *  fr_i(ji,jj)  
     2552             END_2D 
    25712553             CALL lbc_lnk_multi( 'sbccpl', zitx1, 'T', -1.,  zity1, 'T', -1. )  
    25722554          CASE( 'mixed oce-ice'        )      ! Ocean and Ice on C-grid ==> T   
    2573              DO jj = 2, jpjm1  
    2574                 DO ji = fs_2, fs_jpim1   ! vector opt.  
    2575                    zotx1(ji,jj) = 0.5 * ( un   (ji,jj,1) + un   (ji-1,jj  ,1) ) * zfr_l(ji,jj)   &  
    2576                       &         + 0.5 * ( u_ice(ji,jj  ) + u_ice(ji-1,jj    ) ) *  fr_i(ji,jj)  
    2577                    zoty1(ji,jj) = 0.5 * ( vn   (ji,jj,1) + vn   (ji  ,jj-1,1) ) * zfr_l(ji,jj)   &  
    2578                       &         + 0.5 * ( v_ice(ji,jj  ) + v_ice(ji  ,jj-1  ) ) *  fr_i(ji,jj)  
    2579                 END DO 
    2580              END DO 
     2555             DO_2D_00_00 
     2556                zotx1(ji,jj) = 0.5 * ( uu   (ji,jj,1,Nii) + uu   (ji-1,jj  ,1,Nii) ) * zfr_l(ji,jj)   &  
     2557                   &         + 0.5 * ( u_ice(ji,jj  ) + u_ice(ji-1,jj    ) ) *  fr_i(ji,jj)  
     2558                zoty1(ji,jj) = 0.5 * ( vv   (ji,jj,1,Nii) + vv   (ji  ,jj-1,1,Nii) ) * zfr_l(ji,jj)   &  
     2559                   &         + 0.5 * ( v_ice(ji,jj  ) + v_ice(ji  ,jj-1  ) ) *  fr_i(ji,jj)  
     2560             END_2D 
    25812561          END SELECT 
    25822562         CALL lbc_lnk_multi( 'sbccpl', zotx1, ssnd(jps_ocxw)%clgrid, -1., zoty1, ssnd(jps_ocyw)%clgrid, -1. )  

  • NEMO/branches/2020/temporary_r4_trunk/src/OCE/ZDF/zdfdrg.F90

    r13466 r13469  
    115115      ! 
    116116      IF( l_log_not_linssh ) THEN     !==  "log layer"  ==!   compute Cd and -Cd*|U| 
    117          DO jj = 2, jpjm1 
    118             DO ji = 2, jpim1 
    119                imk = k_mk(ji,jj)          ! ocean bottom level at t-points 
    120                zut = un(ji,jj,imk) + un(ji-1,jj,imk)     ! 2 x velocity at t-point 
    121                zvt = vn(ji,jj,imk) + vn(ji,jj-1,imk) 
    122                zzz = 0.5_wp * e3t_n(ji,jj,imk)           ! altitude below/above (top/bottom) the boundary 
    123                ! 
     117         DO_2D_00_00 
     118            imk = k_mk(ji,jj)          ! ocean bottom level at t-points 
     119            zut = uu(ji,jj,imk,Nii) + uu(ji-1,jj,imk,Nii)     ! 2 x velocity at t-point 
     120            zvt = vv(ji,jj,imk,Nii) + vv(ji,jj-1,imk,Nii) 
     121            zzz = 0.5_wp * e3t_n(ji,jj,imk)           ! altitude below/above (top/bottom) the boundary 
     122            ! 
    124123!!JC: possible WAD implementation should modify line below if layers vanish 
    125                zcd = (  vkarmn / LOG( zzz / pz0 )  )**2 
    126                zcd = pCd0(ji,jj) * MIN(  MAX( pCdmin , zcd ) , pCdmax  )   ! here pCd0 = mask*boost 
    127                pCdU(ji,jj) = - zcd * SQRT(  0.25 * ( zut*zut + zvt*zvt ) + pke0  ) 
    128             END DO 
    129          END DO 
     124            zcd = (  vkarmn / LOG( zzz / pz0 )  )**2 
     125            zcd = pCd0(ji,jj) * MIN(  MAX( pCdmin , zcd ) , pCdmax  )   ! here pCd0 = mask*boost 
     126            pCdU(ji,jj) = - zcd * SQRT(  0.25 * ( zut*zut + zvt*zvt ) + pke0  ) 
     127         END_2D 
    130128      ELSE                                            !==  standard Cd  ==! 
    131          DO jj = 2, jpjm1 
    132             DO ji = 2, jpim1 
    133                imk = k_mk(ji,jj)    ! ocean bottom level at t-points 
    134                zut = un(ji,jj,imk) + un(ji-1,jj,imk)     ! 2 x velocity at t-point 
    135                zvt = vn(ji,jj,imk) + vn(ji,jj-1,imk) 
    136                !                                                           ! here pCd0 = mask*boost * drag 
    137                pCdU(ji,jj) = - pCd0(ji,jj) * SQRT(  0.25 * ( zut*zut + zvt*zvt ) + pke0  ) 
    138             END DO 
    139          END DO 
     129         DO_2D_00_00 
     130            imk = k_mk(ji,jj)    ! ocean bottom level at t-points 
     131            zut = uu(ji,jj,imk,Nii) + uu(ji-1,jj,imk,Nii)     ! 2 x velocity at t-point 
     132            zvt = vv(ji,jj,imk,Nii) + vv(ji,jj-1,imk,Nii) 
     133            !                                                           ! here pCd0 = mask*boost * drag 
     134            pCdU(ji,jj) = - pCd0(ji,jj) * SQRT(  0.25 * ( zut*zut + zvt*zvt ) + pke0  ) 
     135         END_2D 
    140136      ENDIF 
    141137      ! 
    … …  
    177173      ENDIF 
    178174 
    179       DO jj = 2, jpjm1 
    180          DO ji = 2, jpim1 
    181             ikbu = mbku(ji,jj)          ! deepest wet ocean u- & v-levels 
    182             ikbv = mbkv(ji,jj) 
     175      DO_2D_00_00 
     176         ikbu = mbku(ji,jj)          ! deepest wet ocean u- & v-levels 
     177         ikbv = mbkv(ji,jj) 
     178         ! 
     179         ! Apply stability criteria on absolute value  : abs(bfr/e3) < 1/(2dt) => bfr/e3 > -1/(2dt) 
     180         zCdu = 0.5*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) / e3u_n(ji,jj,ikbu) 
     181         zCdv = 0.5*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) / e3v_n(ji,jj,ikbv) 
     182         ! 
     183         pua(ji,jj,ikbu) = pua(ji,jj,ikbu) + MAX(  zCdu , zm1_2dt  ) * pub(ji,jj,ikbu) 
     184         pva(ji,jj,ikbv) = pva(ji,jj,ikbv) + MAX(  zCdv , zm1_2dt  ) * pvb(ji,jj,ikbv) 
     185      END_2D 
     186      ! 
     187      IF( ln_isfcav ) THEN        ! ocean cavities 
     188         DO_2D_00_00 
     189            ikbu = miku(ji,jj)          ! first wet ocean u- & v-levels 
     190            ikbv = mikv(ji,jj) 
    183191            ! 
    184192            ! Apply stability criteria on absolute value  : abs(bfr/e3) < 1/(2dt) => bfr/e3 > -1/(2dt) 
    185             zCdu = 0.5*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) / e3u_n(ji,jj,ikbu) 
    186             zCdv = 0.5*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) / e3v_n(ji,jj,ikbv) 
     193            zCdu = 0.5*( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) / e3u_n(ji,jj,ikbu)    ! NB: Cdtop masked 
     194            zCdv = 0.5*( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) / e3v_n(ji,jj,ikbv) 
    187195            ! 
    188196            pua(ji,jj,ikbu) = pua(ji,jj,ikbu) + MAX(  zCdu , zm1_2dt  ) * pub(ji,jj,ikbu) 
    189197            pva(ji,jj,ikbv) = pva(ji,jj,ikbv) + MAX(  zCdv , zm1_2dt  ) * pvb(ji,jj,ikbv) 
    190          END DO 
    191       END DO 
    192       ! 
    193       IF( ln_isfcav ) THEN        ! ocean cavities 
    194          DO jj = 2, jpjm1 
    195             DO ji = 2, jpim1 
    196                ikbu = miku(ji,jj)          ! first wet ocean u- & v-levels 
    197                ikbv = mikv(ji,jj) 
    198                ! 
    199                ! Apply stability criteria on absolute value  : abs(bfr/e3) < 1/(2dt) => bfr/e3 > -1/(2dt) 
    200                zCdu = 0.5*( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) / e3u_n(ji,jj,ikbu)    ! NB: Cdtop masked 
    201                zCdv = 0.5*( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) / e3v_n(ji,jj,ikbv) 
    202                ! 
    203                pua(ji,jj,ikbu) = pua(ji,jj,ikbu) + MAX(  zCdu , zm1_2dt  ) * pub(ji,jj,ikbu) 
    204                pva(ji,jj,ikbv) = pva(ji,jj,ikbv) + MAX(  zCdv , zm1_2dt  ) * pvb(ji,jj,ikbv) 
    205            END DO 
    206          END DO 
     198         END_2D 
    207199      ENDIF 
    208200      ! 
    … …  
    442434            l_log_not_linssh = .FALSE.    !- don't update Cd at each time step 
    443435            ! 
    444             DO jj = 1, jpj                   ! pCd0 = mask (and boosted) logarithmic drag coef.  
    445                DO ji = 1, jpi 
    446                   zzz =  0.5_wp * e3t_0(ji,jj,k_mk(ji,jj)) 
    447                   zcd = (  vkarmn / LOG( zzz / rn_z0 )  )**2 
    448                   pCd0(ji,jj) = zmsk_boost(ji,jj) * MIN(  MAX( rn_Cd0 , zcd ) , rn_Cdmax  )  ! rn_Cd0 < Cd0 < rn_Cdmax 
    449                END DO 
    450             END DO 
     436            DO_2D_11_11 
     437               zzz =  0.5_wp * e3t_0(ji,jj,k_mk(ji,jj)) 
     438               zcd = (  vkarmn / LOG( zzz / rn_z0 )  )**2 
     439               pCd0(ji,jj) = zmsk_boost(ji,jj) * MIN(  MAX( rn_Cd0 , zcd ) , rn_Cdmax  )  ! rn_Cd0 < Cd0 < rn_Cdmax 
     440            END_2D 
    451441         ELSE                       !* Cd updated at each time-step ==> pCd0 = mask * boost 
    452442            IF(lwp) WRITE(numout,*) 

  • NEMO/branches/2020/temporary_r4_trunk/src/OCE/ZDF/zdfgls.F90

    r13466 r13469  
    177177       
    178178      ! Compute surface, top and bottom friction at T-points 
    179       DO jj = 2, jpjm1              !==  surface ocean friction 
    180          DO ji = fs_2, fs_jpim1           ! vector opt.          
    181             ustar2_surf(ji,jj) = r1_rau0 * taum(ji,jj) * tmask(ji,jj,1) 
    182          END DO 
    183       END DO 
     179      DO_2D_00_00 
     180         ustar2_surf(ji,jj) = r1_rau0 * taum(ji,jj) * tmask(ji,jj,1) 
     181      END_2D 
    184182      !    
    185183!!gm Rq we may add here r_ke0(_top/_bot) ?  ==>> think about that... 
    186184      !     
    187185      IF( .NOT.ln_drg_OFF ) THEN    !== top/bottom friction   (explicit before friction) 
    188          DO jj = 2, jpjm1                      ! bottom friction 
    189             DO ji = fs_2, fs_jpim1   ! vector opt.          
    190                zmsku = ( 2._wp - umask(ji-1,jj,mbkt(ji,jj)) * umask(ji,jj,mbkt(ji,jj)) ) 
    191                zmskv = ( 2._wp - vmask(ji,jj-1,mbkt(ji,jj)) * vmask(ji,jj,mbkt(ji,jj)) )     ! (CAUTION: CdU<0) 
    192                ustar2_bot(ji,jj) = - rCdU_bot(ji,jj) * SQRT(  ( zmsku*( ub(ji,jj,mbkt(ji,jj))+ub(ji-1,jj,mbkt(ji,jj)) ) )**2  & 
    193                   &                                         + ( zmskv*( vb(ji,jj,mbkt(ji,jj))+vb(ji,jj-1,mbkt(ji,jj)) ) )**2  ) 
    194             END DO 
    195          END DO 
     186         DO_2D_00_00 
     187            zmsku = ( 2._wp - umask(ji-1,jj,mbkt(ji,jj)) * umask(ji,jj,mbkt(ji,jj)) ) 
     188            zmskv = ( 2._wp - vmask(ji,jj-1,mbkt(ji,jj)) * vmask(ji,jj,mbkt(ji,jj)) )     ! (CAUTION: CdU<0) 
     189            ustar2_bot(ji,jj) = - rCdU_bot(ji,jj) * SQRT(  ( zmsku*( uu(ji,jj,mbkt(ji,jj),Nnn)+uu(ji-1,jj,mbkt(ji,jj),Nnn) ) )**2  & 
     190               &                                         + ( zmskv*( vv(ji,jj,mbkt(ji,jj),Nnn)+vv(ji,jj-1,mbkt(ji,jj),Nnn) ) )**2  ) 
     191         END_2D 
    196192         IF( ln_isfcav ) THEN       !top friction 
    197             DO jj = 2, jpjm1 
    198                DO ji = fs_2, fs_jpim1   ! vector opt. 
    199                   zmsku = ( 2._wp - umask(ji-1,jj,mikt(ji,jj)) * umask(ji,jj,mikt(ji,jj)) ) 
    200                   zmskv = ( 2._wp - vmask(ji,jj-1,mikt(ji,jj)) * vmask(ji,jj,mikt(ji,jj)) )     ! (CAUTION: CdU<0) 
    201                   ustar2_top(ji,jj) = - rCdU_top(ji,jj) * SQRT(  ( zmsku*( ub(ji,jj,mikt(ji,jj))+ub(ji-1,jj,mikt(ji,jj)) ) )**2  & 
    202                      &                                         + ( zmskv*( vb(ji,jj,mikt(ji,jj))+vb(ji,jj-1,mikt(ji,jj)) ) )**2  ) 
    203                END DO 
    204             END DO 
     193            DO_2D_00_00 
     194               zmsku = ( 2._wp - umask(ji-1,jj,mikt(ji,jj)) * umask(ji,jj,mikt(ji,jj)) ) 
     195               zmskv = ( 2._wp - vmask(ji,jj-1,mikt(ji,jj)) * vmask(ji,jj,mikt(ji,jj)) )     ! (CAUTION: CdU<0) 
     196               ustar2_top(ji,jj) = - rCdU_top(ji,jj) * SQRT(  ( zmsku*( uu(ji,jj,mikt(ji,jj),Nnn)+uu(ji-1,jj,mikt(ji,jj),Nnn) ) )**2  & 
     197                  &                                         + ( zmskv*( vv(ji,jj,mikt(ji,jj),Nnn)+vv(ji,jj-1,mikt(ji,jj),Nnn) ) )**2  ) 
     198            END_2D 
    205199         ENDIF 
    206200      ENDIF 
    … …  
    224218      zhsro(:,:) = ( (1._wp-zice_fra(:,:)) * zhsro(:,:) + zice_fra(:,:) * rn_hsri )*tmask(:,:,1)  + (1._wp - tmask(:,:,1))*rn_hsro 
    225219      ! 
    226       DO jk = 2, jpkm1              !==  Compute dissipation rate  ==! 
    227          DO jj = 1, jpjm1 
    228             DO ji = 1, jpim1 
    229                eps(ji,jj,jk)  = rc03 * en(ji,jj,jk) * SQRT( en(ji,jj,jk) ) / hmxl_n(ji,jj,jk) 
    230             END DO 
    231          END DO 
    232       END DO 
     220      DO_3D_10_10( 2, jpkm1 ) 
     221         eps(ji,jj,jk)  = rc03 * en(ji,jj,jk) * SQRT( en(ji,jj,jk) ) / hmxl_n(ji,jj,jk) 
     222      END_3D 
    233223 
    234224      ! Save tke at before time step 
    … …  
    237227 
    238228      IF( nn_clos == 0 ) THEN    ! Mellor-Yamada 
    239          DO jk = 2, jpkm1 
    240             DO jj = 2, jpjm1  
    241                DO ji = fs_2, fs_jpim1   ! vector opt. 
    242                   zup   = hmxl_n(ji,jj,jk) * gdepw_n(ji,jj,mbkt(ji,jj)+1) 
    243                   zdown = vkarmn * gdepw_n(ji,jj,jk) * ( -gdepw_n(ji,jj,jk) + gdepw_n(ji,jj,mbkt(ji,jj)+1) ) 
    244                   zcoef = ( zup / MAX( zdown, rsmall ) ) 
    245                   zwall (ji,jj,jk) = ( 1._wp + re2 * zcoef*zcoef ) * tmask(ji,jj,jk) 
    246                END DO 
    247             END DO 
    248          END DO 
     229         DO_3D_00_00( 2, jpkm1 ) 
     230            zup   = hmxl_n(ji,jj,jk) * gdepw_n(ji,jj,mbkt(ji,jj)+1) 
     231            zdown = vkarmn * gdepw_n(ji,jj,jk) * ( -gdepw_n(ji,jj,jk) + gdepw_n(ji,jj,mbkt(ji,jj)+1) ) 
     232            zcoef = ( zup / MAX( zdown, rsmall ) ) 
     233            zwall (ji,jj,jk) = ( 1._wp + re2 * zcoef*zcoef ) * tmask(ji,jj,jk) 
     234         END_3D 
    249235      ENDIF 
    250236 
    … …  
    262248      ! Warning : after this step, en : right hand side of the matrix 
    263249 
    264       DO jk = 2, jpkm1 
    265          DO jj = 2, jpjm1 
    266             DO ji = 2, jpim1 
    267                ! 
    268                buoy = - p_avt(ji,jj,jk) * rn2(ji,jj,jk)     ! stratif. destruction 
    269                ! 
    270                diss = eps(ji,jj,jk)                         ! dissipation 
    271                ! 
    272                zdir = 0.5_wp + SIGN( 0.5_wp, p_sh2(ji,jj,jk) + buoy )   ! zdir =1(=0) if shear(ji,jj,jk)+buoy >0(<0) 
    273                ! 
    274                zesh2 = zdir*(p_sh2(ji,jj,jk)+buoy)+(1._wp-zdir)*p_sh2(ji,jj,jk)          ! production term 
    275                zdiss = zdir*(diss/en(ji,jj,jk))   +(1._wp-zdir)*(diss-buoy)/en(ji,jj,jk) ! dissipation term 
     250      DO_3D_00_00( 2, jpkm1 ) 
     251         ! 
     252         buoy = - p_avt(ji,jj,jk) * rn2(ji,jj,jk)     ! stratif. destruction 
     253         ! 
     254         diss = eps(ji,jj,jk)                         ! dissipation 
     255         ! 
     256         zdir = 0.5_wp + SIGN( 0.5_wp, p_sh2(ji,jj,jk) + buoy )   ! zdir =1(=0) if shear(ji,jj,jk)+buoy >0(<0) 
     257         ! 
     258         zesh2 = zdir*(p_sh2(ji,jj,jk)+buoy)+(1._wp-zdir)*p_sh2(ji,jj,jk)          ! production term 
     259         zdiss = zdir*(diss/en(ji,jj,jk))   +(1._wp-zdir)*(diss-buoy)/en(ji,jj,jk) ! dissipation term 
    276260!!gm better coding, identical results 
    277261!               zesh2 =   p_sh2(ji,jj,jk) + zdir*buoy               ! production term 
    278262!               zdiss = ( diss - (1._wp-zdir)*buoy ) / en(ji,jj,jk) ! dissipation term 
    279263!!gm 
    280                ! 
    281                ! Compute a wall function from 1. to rsc_psi*zwall/rsc_psi0 
    282                ! Note that as long that Dirichlet boundary conditions are NOT set at the first and last levels (GOTM style) 
    283                ! there is no need to set a boundary condition for zwall_psi at the top and bottom boundaries. 
    284                ! Otherwise, this should be rsc_psi/rsc_psi0 
    285                IF( ln_sigpsi ) THEN 
    286                   zsigpsi = MIN( 1._wp, zesh2 / eps(ji,jj,jk) )     ! 0. <= zsigpsi <= 1. 
    287                   zwall_psi(ji,jj,jk) = rsc_psi /   &  
    288                      &     (  zsigpsi * rsc_psi + (1._wp-zsigpsi) * rsc_psi0 / MAX( zwall(ji,jj,jk), 1._wp )  ) 
    289                ELSE 
    290                   zwall_psi(ji,jj,jk) = 1._wp 
    291                ENDIF 
    292                ! 
    293                ! building the matrix 
    294                zcof = rfact_tke * tmask(ji,jj,jk) 
    295                !                                        ! lower diagonal, in fact not used for jk = 2 (see surface conditions) 
    296                zd_lw(ji,jj,jk) = zcof * ( p_avm(ji,jj,jk  ) + p_avm(ji,jj,jk-1) ) / ( e3t_n(ji,jj,jk-1) * e3w_n(ji,jj,jk) ) 
    297                !                                        ! upper diagonal, in fact not used for jk = ibotm1 (see bottom conditions) 
    298                zd_up(ji,jj,jk) = zcof * ( p_avm(ji,jj,jk+1) + p_avm(ji,jj,jk  ) ) / ( e3t_n(ji,jj,jk  ) * e3w_n(ji,jj,jk) ) 
    299                !                                        ! diagonal 
    300                zdiag(ji,jj,jk) = 1._wp - zd_lw(ji,jj,jk) - zd_up(ji,jj,jk)  + rdt * zdiss * wmask(ji,jj,jk)  
    301                !                                        ! right hand side in en 
    302                en(ji,jj,jk) = en(ji,jj,jk) + rdt * zesh2 * wmask(ji,jj,jk) 
    303             END DO 
    304          END DO 
    305       END DO 
     264         ! 
     265         ! Compute a wall function from 1. to rsc_psi*zwall/rsc_psi0 
     266         ! Note that as long that Dirichlet boundary conditions are NOT set at the first and last levels (GOTM style) 
     267         ! there is no need to set a boundary condition for zwall_psi at the top and bottom boundaries. 
     268         ! Otherwise, this should be rsc_psi/rsc_psi0 
     269         IF( ln_sigpsi ) THEN 
     270            zsigpsi = MIN( 1._wp, zesh2 / eps(ji,jj,jk) )     ! 0. <= zsigpsi <= 1. 
     271            zwall_psi(ji,jj,jk) = rsc_psi /   &  
     272               &     (  zsigpsi * rsc_psi + (1._wp-zsigpsi) * rsc_psi0 / MAX( zwall(ji,jj,jk), 1._wp )  ) 
     273         ELSE 
     274            zwall_psi(ji,jj,jk) = 1._wp 
     275         ENDIF 
     276         ! 
     277         ! building the matrix 
     278         zcof = rfact_tke * tmask(ji,jj,jk) 
     279         !                                        ! lower diagonal, in fact not used for jk = 2 (see surface conditions) 
     280         zd_lw(ji,jj,jk) = zcof * ( p_avm(ji,jj,jk  ) + p_avm(ji,jj,jk-1) ) / ( e3t_n(ji,jj,jk-1) * e3w_n(ji,jj,jk) ) 
     281         !                                        ! upper diagonal, in fact not used for jk = ibotm1 (see bottom conditions) 
     282         zd_up(ji,jj,jk) = zcof * ( p_avm(ji,jj,jk+1) + p_avm(ji,jj,jk  ) ) / ( e3t_n(ji,jj,jk  ) * e3w_n(ji,jj,jk) ) 
     283         !                                        ! diagonal 
     284         zdiag(ji,jj,jk) = 1._wp - zd_lw(ji,jj,jk) - zd_up(ji,jj,jk)  + rdt * zdiss * wmask(ji,jj,jk)  
     285         !                                        ! right hand side in en 
     286         en(ji,jj,jk) = en(ji,jj,jk) + rdt * zesh2 * wmask(ji,jj,jk) 
     287      END_3D 
    306288      ! 
    307289      zdiag(:,:,jpk) = 1._wp 
    … …  
    360342         !                      ! en(ibot) = u*^2 / Co2 and hmxl_n(ibot) = rn_lmin 
    361343         !                      ! Balance between the production and the dissipation terms 
    362          DO jj = 2, jpjm1 
    363             DO ji = fs_2, fs_jpim1   ! vector opt. 
     344         DO_2D_00_00 
    364345!!gm This means that bottom and ocean w-level above have a specified "en" value.   Sure ???? 
    365346!!   With thick deep ocean level thickness, this may be quite large, no ??? 
    366347!!   in particular in ocean cavities where top stratification can be large... 
    367                ibot   = mbkt(ji,jj) + 1      ! k   bottom level of w-point 
    368                ibotm1 = mbkt(ji,jj)          ! k-1 bottom level of w-point but >=1 
     348            ibot   = mbkt(ji,jj) + 1      ! k   bottom level of w-point 
     349            ibotm1 = mbkt(ji,jj)          ! k-1 bottom level of w-point but >=1 
     350            ! 
     351            z_en =  MAX( rc02r * ustar2_bot(ji,jj), rn_emin ) 
     352            ! 
     353            ! Dirichlet condition applied at:  
     354            !     Bottom level (ibot)      &      Just above it (ibotm1)    
     355            zd_lw(ji,jj,ibot) = 0._wp   ;   zd_lw(ji,jj,ibotm1) = 0._wp 
     356            zd_up(ji,jj,ibot) = 0._wp   ;   zd_up(ji,jj,ibotm1) = 0._wp 
     357            zdiag(ji,jj,ibot) = 1._wp   ;   zdiag(ji,jj,ibotm1) = 1._wp 
     358            en   (ji,jj,ibot) = z_en    ;   en   (ji,jj,ibotm1) = z_en 
     359         END_2D 
     360         ! 
     361         IF( ln_isfcav) THEN     ! top boundary   (ocean cavity) 
     362            DO_2D_00_00 
     363               itop   = mikt(ji,jj)       ! k   top w-point 
     364               itopp1 = mikt(ji,jj) + 1   ! k+1 1st w-point below the top one 
     365               !                                                ! mask at the ocean surface points 
     366               z_en = MAX( rc02r * ustar2_top(ji,jj), rn_emin ) * ( 1._wp - tmask(ji,jj,1) ) 
    369367               ! 
    370                z_en =  MAX( rc02r * ustar2_bot(ji,jj), rn_emin ) 
    371                ! 
     368 !!gm TO BE VERIFIED !!! 
    372369               ! Dirichlet condition applied at:  
    373                !     Bottom level (ibot)      &      Just above it (ibotm1)    
    374                zd_lw(ji,jj,ibot) = 0._wp   ;   zd_lw(ji,jj,ibotm1) = 0._wp 
    375                zd_up(ji,jj,ibot) = 0._wp   ;   zd_up(ji,jj,ibotm1) = 0._wp 
    376                zdiag(ji,jj,ibot) = 1._wp   ;   zdiag(ji,jj,ibotm1) = 1._wp 
    377                en   (ji,jj,ibot) = z_en    ;   en   (ji,jj,ibotm1) = z_en 
    378             END DO 
    379          END DO 
    380          ! 
    381          IF( ln_isfcav) THEN     ! top boundary   (ocean cavity) 
    382             DO jj = 2, jpjm1 
    383                DO ji = fs_2, fs_jpim1   ! vector opt. 
    384                   itop   = mikt(ji,jj)       ! k   top w-point 
    385                   itopp1 = mikt(ji,jj) + 1   ! k+1 1st w-point below the top one 
    386                   !                                                ! mask at the ocean surface points 
    387                   z_en = MAX( rc02r * ustar2_top(ji,jj), rn_emin ) * ( 1._wp - tmask(ji,jj,1) ) 
    388                   ! 
    389  !!gm TO BE VERIFIED !!! 
    390                   ! Dirichlet condition applied at:  
    391                   !     top level (itop)         &      Just below it (itopp1)    
    392                   zd_lw(ji,jj,itop) = 0._wp   ;   zd_lw(ji,jj,itopp1) = 0._wp 
    393                   zd_up(ji,jj,itop) = 0._wp   ;   zd_up(ji,jj,itopp1) = 0._wp 
    394                   zdiag(ji,jj,itop) = 1._wp   ;   zdiag(ji,jj,itopp1) = 1._wp 
    395                   en   (ji,jj,itop) = z_en    ;   en   (ji,jj,itopp1) = z_en 
    396                END DO 
    397             END DO 
     370               !     top level (itop)         &      Just below it (itopp1)    
     371               zd_lw(ji,jj,itop) = 0._wp   ;   zd_lw(ji,jj,itopp1) = 0._wp 
     372               zd_up(ji,jj,itop) = 0._wp   ;   zd_up(ji,jj,itopp1) = 0._wp 
     373               zdiag(ji,jj,itop) = 1._wp   ;   zdiag(ji,jj,itopp1) = 1._wp 
     374               en   (ji,jj,itop) = z_en    ;   en   (ji,jj,itopp1) = z_en 
     375            END_2D 
    398376         ENDIF 
    399377         ! 
    400378      CASE ( 1 )             ! Neumman boundary condition 
    401379         !                       
    402          DO jj = 2, jpjm1 
    403             DO ji = fs_2, fs_jpim1   ! vector opt. 
    404                ibot   = mbkt(ji,jj) + 1      ! k   bottom level of w-point 
    405                ibotm1 = mbkt(ji,jj)          ! k-1 bottom level of w-point but >=1 
    406                ! 
    407                z_en =  MAX( rc02r * ustar2_bot(ji,jj), rn_emin ) 
     380         DO_2D_00_00 
     381            ibot   = mbkt(ji,jj) + 1      ! k   bottom level of w-point 
     382            ibotm1 = mbkt(ji,jj)          ! k-1 bottom level of w-point but >=1 
     383            ! 
     384            z_en =  MAX( rc02r * ustar2_bot(ji,jj), rn_emin ) 
     385            ! 
     386            ! Bottom level Dirichlet condition: 
     387            !     Bottom level (ibot)      &      Just above it (ibotm1)    
     388            !         Dirichlet            !         Neumann 
     389            zd_lw(ji,jj,ibot) = 0._wp   !   ! Remove zd_up from zdiag 
     390            zdiag(ji,jj,ibot) = 1._wp   ;   zdiag(ji,jj,ibotm1) = zdiag(ji,jj,ibotm1) + zd_up(ji,jj,ibotm1) 
     391            zd_up(ji,jj,ibot) = 0._wp   ;   zd_up(ji,jj,ibotm1) = 0._wp 
     392         END_2D 
     393         IF( ln_isfcav) THEN     ! top boundary   (ocean cavity) 
     394            DO_2D_00_00 
     395               itop   = mikt(ji,jj)       ! k   top w-point 
     396               itopp1 = mikt(ji,jj) + 1   ! k+1 1st w-point below the top one 
     397               !                                                ! mask at the ocean surface points 
     398               z_en = MAX( rc02r * ustar2_top(ji,jj), rn_emin ) * ( 1._wp - tmask(ji,jj,1) ) 
    408399               ! 
    409400               ! Bottom level Dirichlet condition: 
    410401               !     Bottom level (ibot)      &      Just above it (ibotm1)    
    411402               !         Dirichlet            !         Neumann 
    412                zd_lw(ji,jj,ibot) = 0._wp   !   ! Remove zd_up from zdiag 
    413                zdiag(ji,jj,ibot) = 1._wp   ;   zdiag(ji,jj,ibotm1) = zdiag(ji,jj,ibotm1) + zd_up(ji,jj,ibotm1) 
    414                zd_up(ji,jj,ibot) = 0._wp   ;   zd_up(ji,jj,ibotm1) = 0._wp 
    415             END DO 
    416          END DO 
    417          IF( ln_isfcav) THEN     ! top boundary   (ocean cavity) 
    418             DO jj = 2, jpjm1 
    419                DO ji = fs_2, fs_jpim1   ! vector opt. 
    420                   itop   = mikt(ji,jj)       ! k   top w-point 
    421                   itopp1 = mikt(ji,jj) + 1   ! k+1 1st w-point below the top one 
    422                   !                                                ! mask at the ocean surface points 
    423                   z_en = MAX( rc02r * ustar2_top(ji,jj), rn_emin ) * ( 1._wp - tmask(ji,jj,1) ) 
    424                   ! 
    425                   ! Bottom level Dirichlet condition: 
    426                   !     Bottom level (ibot)      &      Just above it (ibotm1)    
    427                   !         Dirichlet            !         Neumann 
    428                   zd_lw(ji,jj,itop) = 0._wp   !   ! Remove zd_up from zdiag 
    429                   zdiag(ji,jj,itop) = 1._wp   ;   zdiag(ji,jj,itopp1) = zdiag(ji,jj,itopp1) + zd_up(ji,jj,itopp1) 
    430                   zd_up(ji,jj,itop) = 0._wp   ;   zd_up(ji,jj,itopp1) = 0._wp 
    431                END DO 
    432             END DO 
     403               zd_lw(ji,jj,itop) = 0._wp   !   ! Remove zd_up from zdiag 
     404               zdiag(ji,jj,itop) = 1._wp   ;   zdiag(ji,jj,itopp1) = zdiag(ji,jj,itopp1) + zd_up(ji,jj,itopp1) 
     405               zd_up(ji,jj,itop) = 0._wp   ;   zd_up(ji,jj,itopp1) = 0._wp 
     406            END_2D 
    433407         ENDIF 
    434408         ! 
    … …  
    438412      ! ---------------------------------------------------------- 
    439413      ! 
    440       DO jk = 2, jpkm1                             ! First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 
    441          DO jj = 2, jpjm1 
    442             DO ji = fs_2, fs_jpim1    ! vector opt. 
    443                zdiag(ji,jj,jk) = zdiag(ji,jj,jk) - zd_lw(ji,jj,jk) * zd_up(ji,jj,jk-1) / zdiag(ji,jj,jk-1) 
    444             END DO 
    445          END DO 
    446       END DO 
    447       DO jk = 2, jpk                               ! Second recurrence : Lk = RHSk - Lk / Dk-1 * Lk-1 
    448          DO jj = 2, jpjm1 
    449             DO ji = fs_2, fs_jpim1    ! vector opt. 
    450                zd_lw(ji,jj,jk) = en(ji,jj,jk) - zd_lw(ji,jj,jk) / zdiag(ji,jj,jk-1) * zd_lw(ji,jj,jk-1) 
    451             END DO 
    452          END DO 
    453       END DO 
    454       DO jk = jpk-1, 2, -1                         ! thrid recurrence : Ek = ( Lk - Uk * Ek+1 ) / Dk 
    455          DO jj = 2, jpjm1 
    456             DO ji = fs_2, fs_jpim1    ! vector opt. 
    457                en(ji,jj,jk) = ( zd_lw(ji,jj,jk) - zd_up(ji,jj,jk) * en(ji,jj,jk+1) ) / zdiag(ji,jj,jk) 
    458             END DO 
    459          END DO 
    460       END DO 
     414      DO_3D_00_00( 2, jpkm1 ) 
     415         zdiag(ji,jj,jk) = zdiag(ji,jj,jk) - zd_lw(ji,jj,jk) * zd_up(ji,jj,jk-1) / zdiag(ji,jj,jk-1) 
     416      END_3D 
     417      DO_3D_00_00( 2, jpk ) 
     418         zd_lw(ji,jj,jk) = en(ji,jj,jk) - zd_lw(ji,jj,jk) / zdiag(ji,jj,jk-1) * zd_lw(ji,jj,jk-1) 
     419      END_3D 
     420      DO_3D_00_00( jpk-1, 2, -1 ) 
     421         en(ji,jj,jk) = ( zd_lw(ji,jj,jk) - zd_up(ji,jj,jk) * en(ji,jj,jk+1) ) / zdiag(ji,jj,jk) 
     422      END_3D 
    461423      !                                            ! set the minimum value of tke  
    462424      en(:,:,:) = MAX( en(:,:,:), rn_emin ) 
    … …  
    471433      ! 
    472434      CASE( 0 )               ! k-kl  (Mellor-Yamada) 
    473          DO jk = 2, jpkm1 
    474             DO jj = 2, jpjm1 
    475                DO ji = fs_2, fs_jpim1   ! vector opt. 
    476                   psi(ji,jj,jk)  = eb(ji,jj,jk) * hmxl_b(ji,jj,jk) 
    477                END DO 
    478             END DO 
    479          END DO 
     435         DO_3D_00_00( 2, jpkm1 ) 
     436            psi(ji,jj,jk)  = eb(ji,jj,jk) * hmxl_b(ji,jj,jk) 
     437         END_3D 
    480438         ! 
    481439      CASE( 1 )               ! k-eps 
    482          DO jk = 2, jpkm1 
    483             DO jj = 2, jpjm1 
    484                DO ji = fs_2, fs_jpim1   ! vector opt. 
    485                   psi(ji,jj,jk)  = eps(ji,jj,jk) 
    486                END DO 
    487             END DO 
    488          END DO 
     440         DO_3D_00_00( 2, jpkm1 ) 
     441            psi(ji,jj,jk)  = eps(ji,jj,jk) 
     442         END_3D 
    489443         ! 
    490444      CASE( 2 )               ! k-w 
    491          DO jk = 2, jpkm1 
    492             DO jj = 2, jpjm1 
    493                DO ji = fs_2, fs_jpim1   ! vector opt. 
    494                   psi(ji,jj,jk)  = SQRT( eb(ji,jj,jk) ) / ( rc0 * hmxl_b(ji,jj,jk) ) 
    495                END DO 
    496             END DO 
    497          END DO 
     445         DO_3D_00_00( 2, jpkm1 ) 
     446            psi(ji,jj,jk)  = SQRT( eb(ji,jj,jk) ) / ( rc0 * hmxl_b(ji,jj,jk) ) 
     447         END_3D 
    498448         ! 
    499449      CASE( 3 )               ! generic 
    500          DO jk = 2, jpkm1 
    501             DO jj = 2, jpjm1 
    502                DO ji = fs_2, fs_jpim1   ! vector opt. 
    503                   psi(ji,jj,jk)  = rc02 * eb(ji,jj,jk) * hmxl_b(ji,jj,jk)**rnn  
    504                END DO 
    505             END DO 
    506          END DO 
     450         DO_3D_00_00( 2, jpkm1 ) 
     451            psi(ji,jj,jk)  = rc02 * eb(ji,jj,jk) * hmxl_b(ji,jj,jk)**rnn  
     452         END_3D 
    507453         ! 
    508454      END SELECT 
    … …  
    515461      ! Warning : after this step, en : right hand side of the matrix 
    516462 
    517       DO jk = 2, jpkm1 
    518          DO jj = 2, jpjm1 
    519             DO ji = fs_2, fs_jpim1   ! vector opt. 
    520                ! 
    521                ! psi / k 
    522                zratio = psi(ji,jj,jk) / eb(ji,jj,jk)  
    523                ! 
    524                ! psi3+ : stable : B=-KhN²<0 => N²>0 if rn2>0 zdir = 1 (stable) otherwise zdir = 0 (unstable) 
    525                zdir = 0.5_wp + SIGN( 0.5_wp, rn2(ji,jj,jk) ) 
    526                ! 
    527                rpsi3 = zdir * rpsi3m + ( 1._wp - zdir ) * rpsi3p 
    528                ! 
    529                ! shear prod. - stratif. destruction 
    530                prod = rpsi1 * zratio * p_sh2(ji,jj,jk) 
    531                ! 
    532                ! stratif. destruction 
    533                buoy = rpsi3 * zratio * (- p_avt(ji,jj,jk) * rn2(ji,jj,jk) ) 
    534                ! 
    535                ! shear prod. - stratif. destruction 
    536                diss = rpsi2 * zratio * zwall(ji,jj,jk) * eps(ji,jj,jk) 
    537                ! 
    538                zdir = 0.5_wp + SIGN( 0.5_wp, prod + buoy )     ! zdir =1(=0) if shear(ji,jj,jk)+buoy >0(<0) 
    539                ! 
    540                zesh2 = zdir * ( prod + buoy )          + (1._wp - zdir ) * prod                        ! production term 
    541                zdiss = zdir * ( diss / psi(ji,jj,jk) ) + (1._wp - zdir ) * (diss-buoy) / psi(ji,jj,jk) ! dissipation term 
    542                !                                                         
    543                ! building the matrix 
    544                zcof = rfact_psi * zwall_psi(ji,jj,jk) * tmask(ji,jj,jk) 
    545                !                                               ! lower diagonal 
    546                zd_lw(ji,jj,jk) = zcof * ( p_avm(ji,jj,jk  ) + p_avm(ji,jj,jk-1) ) / ( e3t_n(ji,jj,jk-1) * e3w_n(ji,jj,jk) ) 
    547                !                                               ! upper diagonal 
    548                zd_up(ji,jj,jk) = zcof * ( p_avm(ji,jj,jk+1) + p_avm(ji,jj,jk  ) ) / ( e3t_n(ji,jj,jk  ) * e3w_n(ji,jj,jk) ) 
    549                !                                               ! diagonal 
    550                zdiag(ji,jj,jk) = 1._wp - zd_lw(ji,jj,jk) - zd_up(ji,jj,jk) + rdt * zdiss * wmask(ji,jj,jk) 
    551                !                                               ! right hand side in psi 
    552                psi(ji,jj,jk) = psi(ji,jj,jk) + rdt * zesh2 * wmask(ji,jj,jk) 
    553             END DO 
    554          END DO 
    555       END DO 
     463      DO_3D_00_00( 2, jpkm1 ) 
     464         ! 
     465         ! psi / k 
     466         zratio = psi(ji,jj,jk) / eb(ji,jj,jk)  
     467         ! 
     468         ! psi3+ : stable : B=-KhN²<0 => N²>0 if rn2>0 zdir = 1 (stable) otherwise zdir = 0 (unstable) 
     469         zdir = 0.5_wp + SIGN( 0.5_wp, rn2(ji,jj,jk) ) 
     470         ! 
     471         rpsi3 = zdir * rpsi3m + ( 1._wp - zdir ) * rpsi3p 
     472         ! 
     473         ! shear prod. - stratif. destruction 
     474         prod = rpsi1 * zratio * p_sh2(ji,jj,jk) 
     475         ! 
     476         ! stratif. destruction 
     477         buoy = rpsi3 * zratio * (- p_avt(ji,jj,jk) * rn2(ji,jj,jk) ) 
     478         ! 
     479         ! shear prod. - stratif. destruction 
     480         diss = rpsi2 * zratio * zwall(ji,jj,jk) * eps(ji,jj,jk) 
     481         ! 
     482         zdir = 0.5_wp + SIGN( 0.5_wp, prod + buoy )     ! zdir =1(=0) if shear(ji,jj,jk)+buoy >0(<0) 
     483         ! 
     484         zesh2 = zdir * ( prod + buoy )          + (1._wp - zdir ) * prod                        ! production term 
     485         zdiss = zdir * ( diss / psi(ji,jj,jk) ) + (1._wp - zdir ) * (diss-buoy) / psi(ji,jj,jk) ! dissipation term 
     486         !                                                         
     487         ! building the matrix 
     488         zcof = rfact_psi * zwall_psi(ji,jj,jk) * tmask(ji,jj,jk) 
     489         !                                               ! lower diagonal 
     490         zd_lw(ji,jj,jk) = zcof * ( p_avm(ji,jj,jk  ) + p_avm(ji,jj,jk-1) ) / ( e3t_n(ji,jj,jk-1) * e3w_n(ji,jj,jk) ) 
     491         !                                               ! upper diagonal 
     492         zd_up(ji,jj,jk) = zcof * ( p_avm(ji,jj,jk+1) + p_avm(ji,jj,jk  ) ) / ( e3t_n(ji,jj,jk  ) * e3w_n(ji,jj,jk) ) 
     493         !                                               ! diagonal 
     494         zdiag(ji,jj,jk) = 1._wp - zd_lw(ji,jj,jk) - zd_up(ji,jj,jk) + rdt * zdiss * wmask(ji,jj,jk) 
     495         !                                               ! right hand side in psi 
     496         psi(ji,jj,jk) = psi(ji,jj,jk) + rdt * zesh2 * wmask(ji,jj,jk) 
     497      END_3D 
    556498      ! 
    557499      zdiag(:,:,jpk) = 1._wp 
    … …  
    615557         !                      ! en(ibot) = u*^2 / Co2 and hmxl_n(ibot) = vkarmn * r_z0_bot 
    616558         !                      ! Balance between the production and the dissipation terms 
    617          DO jj = 2, jpjm1 
    618             DO ji = fs_2, fs_jpim1   ! vector opt. 
    619                ibot   = mbkt(ji,jj) + 1      ! k   bottom level of w-point 
    620                ibotm1 = mbkt(ji,jj)          ! k-1 bottom level of w-point but >=1 
    621                zdep(ji,jj) = vkarmn * r_z0_bot 
    622                psi (ji,jj,ibot) = rc0**rpp * en(ji,jj,ibot)**rmm * zdep(ji,jj)**rnn 
    623                zd_lw(ji,jj,ibot) = 0._wp 
    624                zd_up(ji,jj,ibot) = 0._wp 
    625                zdiag(ji,jj,ibot) = 1._wp 
    626                ! 
    627                ! Just above last level, Dirichlet condition again (GOTM like) 
    628                zdep(ji,jj) = vkarmn * ( r_z0_bot + e3t_n(ji,jj,ibotm1) ) 
    629                psi (ji,jj,ibotm1) = rc0**rpp * en(ji,jj,ibot  )**rmm * zdep(ji,jj)**rnn 
    630                zd_lw(ji,jj,ibotm1) = 0._wp 
    631                zd_up(ji,jj,ibotm1) = 0._wp 
    632                zdiag(ji,jj,ibotm1) = 1._wp 
    633             END DO 
    634          END DO 
     559         DO_2D_00_00 
     560            ibot   = mbkt(ji,jj) + 1      ! k   bottom level of w-point 
     561            ibotm1 = mbkt(ji,jj)          ! k-1 bottom level of w-point but >=1 
     562            zdep(ji,jj) = vkarmn * r_z0_bot 
     563            psi (ji,jj,ibot) = rc0**rpp * en(ji,jj,ibot)**rmm * zdep(ji,jj)**rnn 
     564            zd_lw(ji,jj,ibot) = 0._wp 
     565            zd_up(ji,jj,ibot) = 0._wp 
     566            zdiag(ji,jj,ibot) = 1._wp 
     567            ! 
     568            ! Just above last level, Dirichlet condition again (GOTM like) 
     569            zdep(ji,jj) = vkarmn * ( r_z0_bot + e3t_n(ji,jj,ibotm1) ) 
     570            psi (ji,jj,ibotm1) = rc0**rpp * en(ji,jj,ibot  )**rmm * zdep(ji,jj)**rnn 
     571            zd_lw(ji,jj,ibotm1) = 0._wp 
     572            zd_up(ji,jj,ibotm1) = 0._wp 
     573            zdiag(ji,jj,ibotm1) = 1._wp 
     574         END_2D 
    635575         ! 
    636576      CASE ( 1 )             ! Neumman boundary condition 
    637577         !                       
    638          DO jj = 2, jpjm1 
    639             DO ji = fs_2, fs_jpim1   ! vector opt. 
    640                ibot   = mbkt(ji,jj) + 1      ! k   bottom level of w-point 
    641                ibotm1 = mbkt(ji,jj)          ! k-1 bottom level of w-point but >=1 
    642                ! 
    643                ! Bottom level Dirichlet condition: 
    644                zdep(ji,jj) = vkarmn * r_z0_bot 
    645                psi (ji,jj,ibot) = rc0**rpp * en(ji,jj,ibot)**rmm * zdep(ji,jj)**rnn 
    646                ! 
    647                zd_lw(ji,jj,ibot) = 0._wp 
    648                zd_up(ji,jj,ibot) = 0._wp 
    649                zdiag(ji,jj,ibot) = 1._wp 
    650                ! 
    651                ! Just above last level: Neumann condition with flux injection 
    652                zdiag(ji,jj,ibotm1) = zdiag(ji,jj,ibotm1) + zd_up(ji,jj,ibotm1) ! Remove zd_up from zdiag 
    653                zd_up(ji,jj,ibotm1) = 0. 
    654                ! 
    655                ! Set psi vertical flux at the bottom: 
    656                zdep(ji,jj) = r_z0_bot + 0.5_wp*e3t_n(ji,jj,ibotm1) 
    657                zflxb = rsbc_psi2 * ( p_avm(ji,jj,ibot) + p_avm(ji,jj,ibotm1) )   & 
    658                   &  * (0.5_wp*(en(ji,jj,ibot)+en(ji,jj,ibotm1)))**rmm * zdep(ji,jj)**(rnn-1._wp) 
    659                psi(ji,jj,ibotm1) = psi(ji,jj,ibotm1) + zflxb / e3w_n(ji,jj,ibotm1) 
    660             END DO 
    661          END DO 
     578         DO_2D_00_00 
     579            ibot   = mbkt(ji,jj) + 1      ! k   bottom level of w-point 
     580            ibotm1 = mbkt(ji,jj)          ! k-1 bottom level of w-point but >=1 
     581            ! 
     582            ! Bottom level Dirichlet condition: 
     583            zdep(ji,jj) = vkarmn * r_z0_bot 
     584            psi (ji,jj,ibot) = rc0**rpp * en(ji,jj,ibot)**rmm * zdep(ji,jj)**rnn 
     585            ! 
     586            zd_lw(ji,jj,ibot) = 0._wp 
     587            zd_up(ji,jj,ibot) = 0._wp 
     588            zdiag(ji,jj,ibot) = 1._wp 
     589            ! 
     590            ! Just above last level: Neumann condition with flux injection 
     591            zdiag(ji,jj,ibotm1) = zdiag(ji,jj,ibotm1) + zd_up(ji,jj,ibotm1) ! Remove zd_up from zdiag 
     592            zd_up(ji,jj,ibotm1) = 0. 
     593            ! 
     594            ! Set psi vertical flux at the bottom: 
     595            zdep(ji,jj) = r_z0_bot + 0.5_wp*e3t_n(ji,jj,ibotm1) 
     596            zflxb = rsbc_psi2 * ( p_avm(ji,jj,ibot) + p_avm(ji,jj,ibotm1) )   & 
     597               &  * (0.5_wp*(en(ji,jj,ibot)+en(ji,jj,ibotm1)))**rmm * zdep(ji,jj)**(rnn-1._wp) 
     598            psi(ji,jj,ibotm1) = psi(ji,jj,ibotm1) + zflxb / e3w_n(ji,jj,ibotm1) 
     599         END_2D 
    662600         ! 
    663601      END SELECT 
    … …  
    666604      ! ---------------- 
    667605      ! 
    668       DO jk = 2, jpkm1                             ! First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 
    669          DO jj = 2, jpjm1 
    670             DO ji = fs_2, fs_jpim1    ! vector opt. 
    671                zdiag(ji,jj,jk) = zdiag(ji,jj,jk) - zd_lw(ji,jj,jk) * zd_up(ji,jj,jk-1) / zdiag(ji,jj,jk-1) 
    672             END DO 
    673          END DO 
    674       END DO 
    675       DO jk = 2, jpk                               ! Second recurrence : Lk = RHSk - Lk / Dk-1 * Lk-1 
    676          DO jj = 2, jpjm1 
    677             DO ji = fs_2, fs_jpim1    ! vector opt. 
    678                zd_lw(ji,jj,jk) = psi(ji,jj,jk) - zd_lw(ji,jj,jk) / zdiag(ji,jj,jk-1) * zd_lw(ji,jj,jk-1) 
    679             END DO 
    680          END DO 
    681       END DO 
    682       DO jk = jpk-1, 2, -1                         ! Third recurrence : Ek = ( Lk - Uk * Ek+1 ) / Dk 
    683          DO jj = 2, jpjm1 
    684             DO ji = fs_2, fs_jpim1    ! vector opt. 
    685                psi(ji,jj,jk) = ( zd_lw(ji,jj,jk) - zd_up(ji,jj,jk) * psi(ji,jj,jk+1) ) / zdiag(ji,jj,jk) 
    686             END DO 
    687          END DO 
    688       END DO 
     606      DO_3D_00_00( 2, jpkm1 ) 
     607         zdiag(ji,jj,jk) = zdiag(ji,jj,jk) - zd_lw(ji,jj,jk) * zd_up(ji,jj,jk-1) / zdiag(ji,jj,jk-1) 
     608      END_3D 
     609      DO_3D_00_00( 2, jpk ) 
     610         zd_lw(ji,jj,jk) = psi(ji,jj,jk) - zd_lw(ji,jj,jk) / zdiag(ji,jj,jk-1) * zd_lw(ji,jj,jk-1) 
     611      END_3D 
     612      DO_3D_00_00( jpk-1, 2, -1 ) 
     613         psi(ji,jj,jk) = ( zd_lw(ji,jj,jk) - zd_up(ji,jj,jk) * psi(ji,jj,jk+1) ) / zdiag(ji,jj,jk) 
     614      END_3D 
    689615 
    690616      ! Set dissipation 
    … …  
    694620      ! 
    695621      CASE( 0 )               ! k-kl  (Mellor-Yamada) 
    696          DO jk = 1, jpkm1 
    697             DO jj = 2, jpjm1 
    698                DO ji = fs_2, fs_jpim1   ! vector opt. 
    699                   eps(ji,jj,jk) = rc03 * en(ji,jj,jk) * en(ji,jj,jk) * SQRT( en(ji,jj,jk) ) / MAX( psi(ji,jj,jk), rn_epsmin) 
    700                END DO 
    701             END DO 
    702          END DO 
     622         DO_3D_00_00( 1, jpkm1 ) 
     623            eps(ji,jj,jk) = rc03 * en(ji,jj,jk) * en(ji,jj,jk) * SQRT( en(ji,jj,jk) ) / MAX( psi(ji,jj,jk), rn_epsmin) 
     624         END_3D 
    703625         ! 
    704626      CASE( 1 )               ! k-eps 
    705          DO jk = 1, jpkm1 
    706             DO jj = 2, jpjm1 
    707                DO ji = fs_2, fs_jpim1   ! vector opt. 
    708                   eps(ji,jj,jk) = psi(ji,jj,jk) 
    709                END DO 
    710             END DO 
    711          END DO 
     627         DO_3D_00_00( 1, jpkm1 ) 
     628            eps(ji,jj,jk) = psi(ji,jj,jk) 
     629         END_3D 
    712630         ! 
    713631      CASE( 2 )               ! k-w 
    714          DO jk = 1, jpkm1 
    715             DO jj = 2, jpjm1 
    716                DO ji = fs_2, fs_jpim1   ! vector opt. 
    717                   eps(ji,jj,jk) = rc04 * en(ji,jj,jk) * psi(ji,jj,jk)  
    718                END DO 
    719             END DO 
    720          END DO 
     632         DO_3D_00_00( 1, jpkm1 ) 
     633            eps(ji,jj,jk) = rc04 * en(ji,jj,jk) * psi(ji,jj,jk)  
     634         END_3D 
    721635         ! 
    722636      CASE( 3 )               ! generic 
    … …  
    724638         zex1  =      ( 1.5_wp + rmm/rnn ) 
    725639         zex2  = -1._wp / rnn 
    726          DO jk = 1, jpkm1 
    727             DO jj = 2, jpjm1 
    728                DO ji = fs_2, fs_jpim1   ! vector opt. 
    729                   eps(ji,jj,jk) = zcoef * en(ji,jj,jk)**zex1 * psi(ji,jj,jk)**zex2 
    730                END DO 
    731             END DO 
    732          END DO 
     640         DO_3D_00_00( 1, jpkm1 ) 
     641            eps(ji,jj,jk) = zcoef * en(ji,jj,jk)**zex1 * psi(ji,jj,jk)**zex2 
     642         END_3D 
    733643         ! 
    734644      END SELECT 
    … …  
    736646      ! Limit dissipation rate under stable stratification 
    737647      ! -------------------------------------------------- 
    738       DO jk = 1, jpkm1 ! Note that this set boundary conditions on hmxl_n at the same time 
    739          DO jj = 2, jpjm1 
    740             DO ji = fs_2, fs_jpim1    ! vector opt. 
    741                ! limitation 
    742                eps   (ji,jj,jk)  = MAX( eps(ji,jj,jk), rn_epsmin ) 
    743                hmxl_n(ji,jj,jk)  = rc03 * en(ji,jj,jk) * SQRT( en(ji,jj,jk) ) / eps(ji,jj,jk) 
    744                ! Galperin criterium (NOTE : Not required if the proper value of C3 in stable cases is calculated)  
    745                zrn2 = MAX( rn2(ji,jj,jk), rsmall ) 
    746                IF( ln_length_lim )   hmxl_n(ji,jj,jk) = MIN(  rn_clim_galp * SQRT( 2._wp * en(ji,jj,jk) / zrn2 ), hmxl_n(ji,jj,jk) ) 
    747             END DO 
    748          END DO 
    749       END DO  
     648      DO_3D_00_00( 1, jpkm1 ) 
     649         ! limitation 
     650         eps   (ji,jj,jk)  = MAX( eps(ji,jj,jk), rn_epsmin ) 
     651         hmxl_n(ji,jj,jk)  = rc03 * en(ji,jj,jk) * SQRT( en(ji,jj,jk) ) / eps(ji,jj,jk) 
     652         ! Galperin criterium (NOTE : Not required if the proper value of C3 in stable cases is calculated)  
     653         zrn2 = MAX( rn2(ji,jj,jk), rsmall ) 
     654         IF( ln_length_lim )   hmxl_n(ji,jj,jk) = MIN(  rn_clim_galp * SQRT( 2._wp * en(ji,jj,jk) / zrn2 ), hmxl_n(ji,jj,jk) ) 
     655      END_3D 
    750656 
    751657      ! 
    … …  
    756662      ! 
    757663      CASE ( 0 , 1 )             ! Galperin or Kantha-Clayson stability functions 
    758          DO jk = 2, jpkm1 
    759             DO jj = 2, jpjm1 
    760                DO ji = fs_2, fs_jpim1   ! vector opt. 
    761                   ! zcof =  l²/q² 
    762                   zcof = hmxl_b(ji,jj,jk) * hmxl_b(ji,jj,jk) / ( 2._wp*eb(ji,jj,jk) ) 
    763                   ! Gh = -N²l²/q² 
    764                   gh = - rn2(ji,jj,jk) * zcof 
    765                   gh = MIN( gh, rgh0   ) 
    766                   gh = MAX( gh, rghmin ) 
    767                   ! Stability functions from Kantha and Clayson (if C2=C3=0 => Galperin) 
    768                   sh = ra2*( 1._wp-6._wp*ra1/rb1 ) / ( 1.-3.*ra2*gh*(6.*ra1+rb2*( 1._wp-rc3 ) ) ) 
    769                   sm = ( rb1**(-1._wp/3._wp) + ( 18._wp*ra1*ra1 + 9._wp*ra1*ra2*(1._wp-rc2) )*sh*gh ) / (1._wp-9._wp*ra1*ra2*gh) 
    770                   ! 
    771                   ! Store stability function in zstt and zstm 
    772                   zstt(ji,jj,jk) = rc_diff * sh * tmask(ji,jj,jk) 
    773                   zstm(ji,jj,jk) = rc_diff * sm * tmask(ji,jj,jk) 
    774                END DO 
    775             END DO 
    776          END DO 
     664         DO_3D_00_00( 2, jpkm1 ) 
     665            ! zcof =  l²/q² 
     666            zcof = hmxl_b(ji,jj,jk) * hmxl_b(ji,jj,jk) / ( 2._wp*eb(ji,jj,jk) ) 
     667            ! Gh = -N²l²/q² 
     668            gh = - rn2(ji,jj,jk) * zcof 
     669            gh = MIN( gh, rgh0   ) 
     670            gh = MAX( gh, rghmin ) 
     671            ! Stability functions from Kantha and Clayson (if C2=C3=0 => Galperin) 
     672            sh = ra2*( 1._wp-6._wp*ra1/rb1 ) / ( 1.-3.*ra2*gh*(6.*ra1+rb2*( 1._wp-rc3 ) ) ) 
     673            sm = ( rb1**(-1._wp/3._wp) + ( 18._wp*ra1*ra1 + 9._wp*ra1*ra2*(1._wp-rc2) )*sh*gh ) / (1._wp-9._wp*ra1*ra2*gh) 
     674            ! 
     675            ! Store stability function in zstt and zstm 
     676            zstt(ji,jj,jk) = rc_diff * sh * tmask(ji,jj,jk) 
     677            zstm(ji,jj,jk) = rc_diff * sm * tmask(ji,jj,jk) 
     678         END_3D 
    777679         ! 
    778680      CASE ( 2, 3 )               ! Canuto stability functions 
    779          DO jk = 2, jpkm1 
    780             DO jj = 2, jpjm1 
    781                DO ji = fs_2, fs_jpim1   ! vector opt. 
    782                   ! zcof =  l²/q² 
    783                   zcof = hmxl_b(ji,jj,jk)*hmxl_b(ji,jj,jk) / ( 2._wp * eb(ji,jj,jk) ) 
    784                   ! Gh = -N²l²/q² 
    785                   gh = - rn2(ji,jj,jk) * zcof 
    786                   gh = MIN( gh, rgh0   ) 
    787                   gh = MAX( gh, rghmin ) 
    788                   gh = gh * rf6 
    789                   ! Gm =  M²l²/q² Shear number 
    790                   shr = p_sh2(ji,jj,jk) / MAX( p_avm(ji,jj,jk), rsmall ) 
    791                   gm = MAX( shr * zcof , 1.e-10 ) 
    792                   gm = gm * rf6 
    793                   gm = MIN ( (rd0 - rd1*gh + rd3*gh*gh) / (rd2-rd4*gh) , gm ) 
    794                   ! Stability functions from Canuto 
    795                   rcff = rd0 - rd1*gh +rd2*gm + rd3*gh*gh - rd4*gh*gm + rd5*gm*gm 
    796                   sm = (rs0 - rs1*gh + rs2*gm) / rcff 
    797                   sh = (rs4 - rs5*gh + rs6*gm) / rcff 
    798                   ! 
    799                   ! Store stability function in zstt and zstm 
    800                   zstt(ji,jj,jk) = rc_diff * sh * tmask(ji,jj,jk) 
    801                   zstm(ji,jj,jk) = rc_diff * sm * tmask(ji,jj,jk) 
    802                END DO 
    803             END DO 
    804          END DO 
     681         DO_3D_00_00( 2, jpkm1 ) 
     682            ! zcof =  l²/q² 
     683            zcof = hmxl_b(ji,jj,jk)*hmxl_b(ji,jj,jk) / ( 2._wp * eb(ji,jj,jk) ) 
     684            ! Gh = -N²l²/q² 
     685            gh = - rn2(ji,jj,jk) * zcof 
     686            gh = MIN( gh, rgh0   ) 
     687            gh = MAX( gh, rghmin ) 
     688            gh = gh * rf6 
     689            ! Gm =  M²l²/q² Shear number 
     690            shr = p_sh2(ji,jj,jk) / MAX( p_avm(ji,jj,jk), rsmall ) 
     691            gm = MAX( shr * zcof , 1.e-10 ) 
     692            gm = gm * rf6 
     693            gm = MIN ( (rd0 - rd1*gh + rd3*gh*gh) / (rd2-rd4*gh) , gm ) 
     694            ! Stability functions from Canuto 
     695            rcff = rd0 - rd1*gh +rd2*gm + rd3*gh*gh - rd4*gh*gm + rd5*gm*gm 
     696            sm = (rs0 - rs1*gh + rs2*gm) / rcff 
     697            sh = (rs4 - rs5*gh + rs6*gm) / rcff 
     698            ! 
     699            ! Store stability function in zstt and zstm 
     700            zstt(ji,jj,jk) = rc_diff * sh * tmask(ji,jj,jk) 
     701            zstm(ji,jj,jk) = rc_diff * sm * tmask(ji,jj,jk) 
     702         END_3D 
    805703         ! 
    806704      END SELECT 
    … …  
    813711      ! default value, in case jpk > mbkt(ji,jj)+1. Not needed but avoid a bug when looking for undefined values (-fpe0) 
    814712      zstm(:,:,jpk) = 0.   
    815       DO jj = 2, jpjm1                ! update bottom with good values 
    816          DO ji = fs_2, fs_jpim1   ! vector opt. 
    817             zstm(ji,jj,mbkt(ji,jj)+1) = zstm(ji,jj,mbkt(ji,jj)) 
    818          END DO 
    819       END DO 
     713      DO_2D_00_00 
     714         zstm(ji,jj,mbkt(ji,jj)+1) = zstm(ji,jj,mbkt(ji,jj)) 
     715      END_2D 
    820716 
    821717      zstt(:,:,  1) = wmask(:,:,  1)  ! default value not needed but avoid a bug when looking for undefined values (-fpe0) 
    … …  
    830726      !     later overwritten by surface/bottom boundaries conditions, so we don't really care of p_avm(:,:1) and p_avm(:,:jpk) 
    831727      !     for zd_lw and zd_up but they have to be defined to avoid a bug when looking for undefined values (-fpe0) 
    832       DO jk = 1, jpk 
    833          DO jj = 2, jpjm1 
    834             DO ji = fs_2, fs_jpim1   ! vector opt. 
    835                zsqen = SQRT( 2._wp * en(ji,jj,jk) ) * hmxl_n(ji,jj,jk) 
    836                zavt  = zsqen * zstt(ji,jj,jk) 
    837                zavm  = zsqen * zstm(ji,jj,jk) 
    838                p_avt(ji,jj,jk) = MAX( zavt, avtb(jk) ) * wmask(ji,jj,jk) ! apply mask for zdfmxl routine 
    839                p_avm(ji,jj,jk) = MAX( zavm, avmb(jk) )                   ! Note that avm is not masked at the surface and the bottom 
    840             END DO 
    841          END DO 
    842       END DO 
     728      DO_3D_00_00( 1, jpk ) 
     729         zsqen = SQRT( 2._wp * en(ji,jj,jk) ) * hmxl_n(ji,jj,jk) 
     730         zavt  = zsqen * zstt(ji,jj,jk) 
     731         zavm  = zsqen * zstm(ji,jj,jk) 
     732         p_avt(ji,jj,jk) = MAX( zavt, avtb(jk) ) * wmask(ji,jj,jk) ! apply mask for zdfmxl routine 
     733         p_avm(ji,jj,jk) = MAX( zavm, avmb(jk) )                   ! Note that avm is not masked at the surface and the bottom 
     734      END_3D 
    843735      p_avt(:,:,1) = 0._wp 
    844736      ! 

  • NEMO/branches/2020/temporary_r4_trunk/src/OCE/ZDF/zdftke.F90

    r13466 r13469  
    231231      !                     !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
    232232      ! 
    233       DO jj = 2, jpjm1            ! en(1)   = rn_ebb taum / rau0  (min value rn_emin0) 
    234          DO ji = fs_2, fs_jpim1   ! vector opt. 
     233      DO_2D_00_00 
    235234!! clem: this should be the right formulation but it makes the model unstable unless drags are calculated implicitly 
    236235!!       one way around would be to increase zbbirau  
    237236!!          en(ji,jj,1) = MAX( rn_emin0, ( ( 1._wp - fr_i(ji,jj) ) * zbbrau + & 
    238237!!             &                                     fr_i(ji,jj)   * zbbirau ) * taum(ji,jj) ) * tmask(ji,jj,1) 
    239             en(ji,jj,1) = MAX( rn_emin0, zbbrau * taum(ji,jj) ) * tmask(ji,jj,1) 
    240          END DO 
    241       END DO 
     238         en(ji,jj,1) = MAX( rn_emin0, zbbrau * taum(ji,jj) ) * tmask(ji,jj,1) 
     239      END_2D 
    242240      ! 
    243241      !                     !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
    … …  
    251249      IF( .NOT.ln_drg_OFF ) THEN    !== friction used as top/bottom boundary condition on TKE 
    252250         ! 
    253          DO jj = 2, jpjm1              ! bottom friction 
    254             DO ji = fs_2, fs_jpim1     ! vector opt. 
    255                zmsku = ( 2. - umask(ji-1,jj,mbkt(ji,jj)) * umask(ji,jj,mbkt(ji,jj)) ) 
    256                zmskv = ( 2. - vmask(ji,jj-1,mbkt(ji,jj)) * vmask(ji,jj,mbkt(ji,jj)) ) 
    257                !                       ! where 0.001875 = (rn_ebb0/rau0) * 0.5 = 3.75*0.5/1000. (CAUTION CdU<0) 
    258                zebot = - 0.001875_wp * rCdU_bot(ji,jj) * SQRT(  ( zmsku*( ub(ji,jj,mbkt(ji,jj))+ub(ji-1,jj,mbkt(ji,jj)) ) )**2  & 
    259                   &                                           + ( zmskv*( vb(ji,jj,mbkt(ji,jj))+vb(ji,jj-1,mbkt(ji,jj)) ) )**2  ) 
    260                en(ji,jj,mbkt(ji,jj)+1) = MAX( zebot, rn_emin ) * ssmask(ji,jj) 
    261             END DO 
    262          END DO 
     251         DO_2D_00_00 
     252            zmsku = ( 2. - umask(ji-1,jj,mbkt(ji,jj)) * umask(ji,jj,mbkt(ji,jj)) ) 
     253            zmskv = ( 2. - vmask(ji,jj-1,mbkt(ji,jj)) * vmask(ji,jj,mbkt(ji,jj)) ) 
     254            !                       ! where 0.001875 = (rn_ebb0/rau0) * 0.5 = 3.75*0.5/1000. (CAUTION CdU<0) 
     255            zebot = - 0.001875_wp * rCdU_bot(ji,jj) * SQRT(  ( zmsku*( uu(ji,jj,mbkt(ji,jj),Nnn)+uu(ji-1,jj,mbkt(ji,jj),Nnn) ) )**2  & 
     256               &                                           + ( zmskv*( vv(ji,jj,mbkt(ji,jj),Nnn)+vv(ji,jj-1,mbkt(ji,jj),Nnn) ) )**2  ) 
     257            en(ji,jj,mbkt(ji,jj)+1) = MAX( zebot, rn_emin ) * ssmask(ji,jj) 
     258         END_2D 
    263259         IF( ln_isfcav ) THEN       ! top friction 
    264             DO jj = 2, jpjm1 
    265                DO ji = fs_2, fs_jpim1   ! vector opt. 
    266                   zmsku = ( 2. - umask(ji-1,jj,mikt(ji,jj)) * umask(ji,jj,mikt(ji,jj)) ) 
    267                   zmskv = ( 2. - vmask(ji,jj-1,mikt(ji,jj)) * vmask(ji,jj,mikt(ji,jj)) ) 
    268                   !                             ! where 0.001875 = (rn_ebb0/rau0) * 0.5 = 3.75*0.5/1000.  (CAUTION CdU<0) 
    269                   zetop = - 0.001875_wp * rCdU_top(ji,jj) * SQRT(  ( zmsku*( ub(ji,jj,mikt(ji,jj))+ub(ji-1,jj,mikt(ji,jj)) ) )**2  & 
    270                      &                                           + ( zmskv*( vb(ji,jj,mikt(ji,jj))+vb(ji,jj-1,mikt(ji,jj)) ) )**2  ) 
    271                   en(ji,jj,mikt(ji,jj)) = en(ji,jj,1)           * tmask(ji,jj,1) &      
    272                      &                  + MAX( zetop, rn_emin ) * (1._wp - tmask(ji,jj,1)) * ssmask(ji,jj) 
    273                END DO 
    274             END DO 
     260            DO_2D_00_00 
     261               zmsku = ( 2. - umask(ji-1,jj,mikt(ji,jj)) * umask(ji,jj,mikt(ji,jj)) ) 
     262               zmskv = ( 2. - vmask(ji,jj-1,mikt(ji,jj)) * vmask(ji,jj,mikt(ji,jj)) ) 
     263               !                             ! where 0.001875 = (rn_ebb0/rau0) * 0.5 = 3.75*0.5/1000.  (CAUTION CdU<0) 
     264               zetop = - 0.001875_wp * rCdU_top(ji,jj) * SQRT(  ( zmsku*( uu(ji,jj,mikt(ji,jj),Nnn)+uu(ji-1,jj,mikt(ji,jj),Nnn) ) )**2  & 
     265                  &                                           + ( zmskv*( vv(ji,jj,mikt(ji,jj),Nnn)+vv(ji,jj-1,mikt(ji,jj),Nnn) ) )**2  ) 
     266               en(ji,jj,mikt(ji,jj)) = en(ji,jj,1)           * tmask(ji,jj,1) &      
     267                  &                  + MAX( zetop, rn_emin ) * (1._wp - tmask(ji,jj,1)) * ssmask(ji,jj) 
     268            END_2D 
    275269         ENDIF 
    276270         ! 
    … …  
    289283         zcof = 0.5 * 0.016 * 0.016 / ( zrhoa * zcdrag ) 
    290284         imlc(:,:) = mbkt(:,:) + 1       ! Initialization to the number of w ocean point (=2 over land) 
    291          DO jk = jpkm1, 2, -1 
    292             DO jj = 1, jpj               ! Last w-level at which zpelc>=0.5*us*us  
    293                DO ji = 1, jpi            !      with us=0.016*wind(starting from jpk-1) 
    294                   zus  = zcof * taum(ji,jj) 
    295                   IF( zpelc(ji,jj,jk) > zus )   imlc(ji,jj) = jk 
    296                END DO 
    297             END DO 
    298          END DO 
     285         DO_3D_11_11( jpkm1, 2, -1 ) 
     286            zus  = zcof * taum(ji,jj) 
     287            IF( zpelc(ji,jj,jk) > zus )   imlc(ji,jj) = jk 
     288         END_3D 
    299289         !                               ! finite LC depth 
    300          DO jj = 1, jpj  
    301             DO ji = 1, jpi 
    302                zhlc(ji,jj) = pdepw(ji,jj,imlc(ji,jj)) 
    303             END DO 
    304          END DO 
     290         DO_2D_11_11 
     291            zhlc(ji,jj) = pdepw(ji,jj,imlc(ji,jj)) 
     292         END_2D 
    305293         zcof = 0.016 / SQRT( zrhoa * zcdrag ) 
    306          DO jj = 2, jpjm1 
    307             DO ji = fs_2, fs_jpim1   ! vector opt. 
    308                zus  = zcof * SQRT( taum(ji,jj) )           ! Stokes drift 
    309                zus3(ji,jj) = MAX( 0._wp, 1._wp - zice_fra(ji,jj) ) * zus * zus * zus * tmask(ji,jj,1) ! zus > 0. ok 
    310             END DO 
    311          END DO          
    312          DO jk = 2, jpkm1         !* TKE Langmuir circulation source term added to en 
    313             DO jj = 2, jpjm1 
    314                DO ji = fs_2, fs_jpim1   ! vector opt. 
    315                   IF ( zus3(ji,jj) /= 0._wp ) THEN                
    316                      ! vertical velocity due to LC    
    317                      IF ( pdepw(ji,jj,jk) - zhlc(ji,jj) < 0 .AND. wmask(ji,jj,jk) /= 0. ) THEN 
    318                         !                                           ! vertical velocity due to LC 
    319                         zwlc = rn_lc * SIN( rpi * pdepw(ji,jj,jk) / zhlc(ji,jj) ) 
    320                         !                                           ! TKE Langmuir circulation source term 
    321                         en(ji,jj,jk) = en(ji,jj,jk) + rdt * zus3(ji,jj) * ( zwlc * zwlc * zwlc ) / zhlc(ji,jj) 
    322                      ENDIF 
    323                   ENDIF 
    324                END DO 
    325             END DO 
    326          END DO 
     294         DO_2D_00_00 
     295            zus  = zcof * SQRT( taum(ji,jj) )           ! Stokes drift 
     296            zus3(ji,jj) = MAX( 0._wp, 1._wp - zice_fra(ji,jj) ) * zus * zus * zus * tmask(ji,jj,1) ! zus > 0. ok 
     297         END_2D 
     298         DO_3D_00_00( 2, jpkm1 ) 
     299            IF ( zus3(ji,jj) /= 0._wp ) THEN                
     300               ! vertical velocity due to LC    
     301               IF ( pdepw(ji,jj,jk) - zhlc(ji,jj) < 0 .AND. wmask(ji,jj,jk) /= 0. ) THEN 
     302                  !                                           ! vertical velocity due to LC 
     303                  zwlc = rn_lc * SIN( rpi * pdepw(ji,jj,jk) / zhlc(ji,jj) ) 
     304                  !                                           ! TKE Langmuir circulation source term 
     305                  en(ji,jj,jk) = en(ji,jj,jk) + rdt * zus3(ji,jj) * ( zwlc * zwlc * zwlc ) / zhlc(ji,jj) 
     306               ENDIF 
     307            ENDIF 
     308         END_3D 
    327309         ! 
    328310      ENDIF 
    … …  
    336318      ! 
    337319      IF( nn_pdl == 1 ) THEN      !* Prandtl number = F( Ri ) 
    338          DO jk = 2, jpkm1 
    339             DO jj = 2, jpjm1 
    340                DO ji = 2, jpim1 
    341                   !                             ! local Richardson number 
    342                   zri = MAX( rn2b(ji,jj,jk), 0._wp ) * p_avm(ji,jj,jk) / ( p_sh2(ji,jj,jk) + rn_bshear ) 
    343                   !                             ! inverse of Prandtl number 
    344                   apdlr(ji,jj,jk) = MAX(  0.1_wp,  ri_cri / MAX( ri_cri , zri )  ) 
    345                END DO 
    346             END DO 
    347          END DO 
     320         DO_3D_00_00( 2, jpkm1 ) 
     321            !                             ! local Richardson number 
     322            zri = MAX( rn2b(ji,jj,jk), 0._wp ) * p_avm(ji,jj,jk) / ( p_sh2(ji,jj,jk) + rn_bshear ) 
     323            !                             ! inverse of Prandtl number 
     324            apdlr(ji,jj,jk) = MAX(  0.1_wp,  ri_cri / MAX( ri_cri , zri )  ) 
     325         END_3D 
    348326      ENDIF 
    349327      !          
    350       DO jk = 2, jpkm1           !* Matrix and right hand side in en 
    351          DO jj = 2, jpjm1 
    352             DO ji = fs_2, fs_jpim1   ! vector opt. 
    353                zcof   = zfact1 * tmask(ji,jj,jk) 
    354                !                                   ! A minimum of 2.e-5 m2/s is imposed on TKE vertical 
    355                !                                   ! eddy coefficient (ensure numerical stability) 
    356                zzd_up = zcof * MAX(  p_avm(ji,jj,jk+1) + p_avm(ji,jj,jk  ) , 2.e-5_wp  )   &  ! upper diagonal 
    357                   &          /    (  p_e3t(ji,jj,jk  ) * p_e3w(ji,jj,jk  )  ) 
    358                zzd_lw = zcof * MAX(  p_avm(ji,jj,jk  ) + p_avm(ji,jj,jk-1) , 2.e-5_wp  )   &  ! lower diagonal 
    359                   &          /    (  p_e3t(ji,jj,jk-1) * p_e3w(ji,jj,jk  )  ) 
    360                ! 
    361                zd_up(ji,jj,jk) = zzd_up            ! Matrix (zdiag, zd_up, zd_lw) 
    362                zd_lw(ji,jj,jk) = zzd_lw 
    363                zdiag(ji,jj,jk) = 1._wp - zzd_lw - zzd_up + zfact2 * dissl(ji,jj,jk) * wmask(ji,jj,jk) 
    364                ! 
    365                !                                   ! right hand side in en 
    366                en(ji,jj,jk) = en(ji,jj,jk) + rdt * (  p_sh2(ji,jj,jk)                          &   ! shear 
    367                   &                                 - p_avt(ji,jj,jk) * rn2(ji,jj,jk)          &   ! stratification 
    368                   &                                 + zfact3 * dissl(ji,jj,jk) * en(ji,jj,jk)  &   ! dissipation 
    369                   &                                ) * wmask(ji,jj,jk) 
    370             END DO 
    371          END DO 
    372       END DO 
     328      DO_3D_00_00( 2, jpkm1 ) 
     329         zcof   = zfact1 * tmask(ji,jj,jk) 
     330         !                                   ! A minimum of 2.e-5 m2/s is imposed on TKE vertical 
     331         !                                   ! eddy coefficient (ensure numerical stability) 
     332         zzd_up = zcof * MAX(  p_avm(ji,jj,jk+1) + p_avm(ji,jj,jk  ) , 2.e-5_wp  )   &  ! upper diagonal 
     333            &          /    (  p_e3t(ji,jj,jk  ) * p_e3w(ji,jj,jk  )  ) 
     334         zzd_lw = zcof * MAX(  p_avm(ji,jj,jk  ) + p_avm(ji,jj,jk-1) , 2.e-5_wp  )   &  ! lower diagonal 
     335            &          /    (  p_e3t(ji,jj,jk-1) * p_e3w(ji,jj,jk  )  ) 
     336         ! 
     337         zd_up(ji,jj,jk) = zzd_up            ! Matrix (zdiag, zd_up, zd_lw) 
     338         zd_lw(ji,jj,jk) = zzd_lw 
     339         zdiag(ji,jj,jk) = 1._wp - zzd_lw - zzd_up + zfact2 * dissl(ji,jj,jk) * wmask(ji,jj,jk) 
     340         ! 
     341         !                                   ! right hand side in en 
     342         en(ji,jj,jk) = en(ji,jj,jk) + rdt * (  p_sh2(ji,jj,jk)                          &   ! shear 
     343            &                                 - p_avt(ji,jj,jk) * rn2(ji,jj,jk)          &   ! stratification 
     344            &                                 + zfact3 * dissl(ji,jj,jk) * en(ji,jj,jk)  &   ! dissipation 
     345            &                                ) * wmask(ji,jj,jk) 
     346      END_3D 
    373347      !                          !* Matrix inversion from level 2 (tke prescribed at level 1) 
    374       DO jk = 3, jpkm1                             ! First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 
    375          DO jj = 2, jpjm1 
    376             DO ji = fs_2, fs_jpim1    ! vector opt. 
    377                zdiag(ji,jj,jk) = zdiag(ji,jj,jk) - zd_lw(ji,jj,jk) * zd_up(ji,jj,jk-1) / zdiag(ji,jj,jk-1) 
    378             END DO 
    379          END DO 
    380       END DO 
    381       DO jj = 2, jpjm1                             ! Second recurrence : Lk = RHSk - Lk / Dk-1 * Lk-1 
    382          DO ji = fs_2, fs_jpim1   ! vector opt. 
    383             zd_lw(ji,jj,2) = en(ji,jj,2) - zd_lw(ji,jj,2) * en(ji,jj,1)    ! Surface boudary conditions on tke 
    384          END DO 
    385       END DO 
    386       DO jk = 3, jpkm1 
    387          DO jj = 2, jpjm1 
    388             DO ji = fs_2, fs_jpim1    ! vector opt. 
    389                zd_lw(ji,jj,jk) = en(ji,jj,jk) - zd_lw(ji,jj,jk) / zdiag(ji,jj,jk-1) *zd_lw(ji,jj,jk-1) 
    390             END DO 
    391          END DO 
    392       END DO 
    393       DO jj = 2, jpjm1                             ! thrid recurrence : Ek = ( Lk - Uk * Ek+1 ) / Dk 
    394          DO ji = fs_2, fs_jpim1   ! vector opt. 
    395             en(ji,jj,jpkm1) = zd_lw(ji,jj,jpkm1) / zdiag(ji,jj,jpkm1) 
    396          END DO 
    397       END DO 
    398       DO jk = jpk-2, 2, -1 
    399          DO jj = 2, jpjm1 
    400             DO ji = fs_2, fs_jpim1    ! vector opt. 
    401                en(ji,jj,jk) = ( zd_lw(ji,jj,jk) - zd_up(ji,jj,jk) * en(ji,jj,jk+1) ) / zdiag(ji,jj,jk) 
    402             END DO 
    403          END DO 
    404       END DO 
    405       DO jk = 2, jpkm1                             ! set the minimum value of tke 
    406          DO jj = 2, jpjm1 
    407             DO ji = fs_2, fs_jpim1   ! vector opt. 
    408                en(ji,jj,jk) = MAX( en(ji,jj,jk), rn_emin ) * wmask(ji,jj,jk) 
    409             END DO 
    410          END DO 
    411       END DO 
     348      DO_3D_00_00( 3, jpkm1 ) 
     349         zdiag(ji,jj,jk) = zdiag(ji,jj,jk) - zd_lw(ji,jj,jk) * zd_up(ji,jj,jk-1) / zdiag(ji,jj,jk-1) 
     350      END_3D 
     351      DO_2D_00_00 
     352         zd_lw(ji,jj,2) = en(ji,jj,2) - zd_lw(ji,jj,2) * en(ji,jj,1)    ! Surface boudary conditions on tke 
     353      END_2D 
     354      DO_3D_00_00( 3, jpkm1 ) 
     355         zd_lw(ji,jj,jk) = en(ji,jj,jk) - zd_lw(ji,jj,jk) / zdiag(ji,jj,jk-1) *zd_lw(ji,jj,jk-1) 
     356      END_3D 
     357      DO_2D_00_00 
     358         en(ji,jj,jpkm1) = zd_lw(ji,jj,jpkm1) / zdiag(ji,jj,jpkm1) 
     359      END_2D 
     360      DO_3D_00_00( jpk-2, 2, -1 ) 
     361         en(ji,jj,jk) = ( zd_lw(ji,jj,jk) - zd_up(ji,jj,jk) * en(ji,jj,jk+1) ) / zdiag(ji,jj,jk) 
     362      END_3D 
     363      DO_3D_00_00( 2, jpkm1 ) 
     364         en(ji,jj,jk) = MAX( en(ji,jj,jk), rn_emin ) * wmask(ji,jj,jk) 
     365      END_3D 
    412366      ! 
    413367      !                            !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
    … …  
    419373       
    420374      IF( nn_etau == 1 ) THEN           !* penetration below the mixed layer (rn_efr fraction) 
    421          DO jk = 2, jpkm1                       ! nn_eice=0 : ON below sea-ice ; nn_eice>0 : partly OFF 
    422             DO jj = 2, jpjm1 
    423                DO ji = fs_2, fs_jpim1   ! vector opt. 
    424                   en(ji,jj,jk) = en(ji,jj,jk) + rn_efr * en(ji,jj,1) * EXP( -pdepw(ji,jj,jk) / htau(ji,jj) )   & 
    425                      &                                 * MAX( 0._wp, 1._wp - zice_fra(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1) 
    426                END DO 
    427             END DO 
    428          END DO 
     375         DO_3D_00_00( 2, jpkm1 ) 
     376            en(ji,jj,jk) = en(ji,jj,jk) + rn_efr * en(ji,jj,1) * EXP( -pdepw(ji,jj,jk) / htau(ji,jj) )   & 
     377               &                                 * MAX( 0._wp, 1._wp - zice_fra(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1) 
     378         END_3D 
    429379      ELSEIF( nn_etau == 2 ) THEN       !* act only at the base of the mixed layer (jk=nmln)  (rn_efr fraction) 
    430          DO jj = 2, jpjm1 
    431             DO ji = fs_2, fs_jpim1   ! vector opt. 
    432                jk = nmln(ji,jj) 
    433                en(ji,jj,jk) = en(ji,jj,jk) + rn_efr * en(ji,jj,1) * EXP( -pdepw(ji,jj,jk) / htau(ji,jj) )   & 
    434                   &                                 * MAX( 0._wp, 1._wp - zice_fra(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1) 
    435             END DO 
    436          END DO 
     380         DO_2D_00_00 
     381            jk = nmln(ji,jj) 
     382            en(ji,jj,jk) = en(ji,jj,jk) + rn_efr * en(ji,jj,1) * EXP( -pdepw(ji,jj,jk) / htau(ji,jj) )   & 
     383               &                                 * MAX( 0._wp, 1._wp - zice_fra(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1) 
     384         END_2D 
    437385      ELSEIF( nn_etau == 3 ) THEN       !* penetration belox the mixed layer (HF variability) 
    438          DO jk = 2, jpkm1 
    439             DO jj = 2, jpjm1 
    440                DO ji = fs_2, fs_jpim1   ! vector opt. 
    441                   ztx2 = utau(ji-1,jj  ) + utau(ji,jj) 
    442                   zty2 = vtau(ji  ,jj-1) + vtau(ji,jj) 
    443                   ztau = 0.5_wp * SQRT( ztx2 * ztx2 + zty2 * zty2 ) * tmask(ji,jj,1)    ! module of the mean stress  
    444                   zdif = taum(ji,jj) - ztau                            ! mean of modulus - modulus of the mean  
    445                   zdif = rhftau_scl * MAX( 0._wp, zdif + rhftau_add )  ! apply some modifications... 
    446                   en(ji,jj,jk) = en(ji,jj,jk) + zbbrau * zdif * EXP( -pdepw(ji,jj,jk) / htau(ji,jj) )   & 
    447                      &                                 * MAX( 0._wp, 1._wp - zice_fra(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1) 
    448                END DO 
    449             END DO 
    450          END DO 
     386         DO_3D_00_00( 2, jpkm1 ) 
     387            ztx2 = utau(ji-1,jj  ) + utau(ji,jj) 
     388            zty2 = vtau(ji  ,jj-1) + vtau(ji,jj) 
     389            ztau = 0.5_wp * SQRT( ztx2 * ztx2 + zty2 * zty2 ) * tmask(ji,jj,1)    ! module of the mean stress  
     390            zdif = taum(ji,jj) - ztau                            ! mean of modulus - modulus of the mean  
     391            zdif = rhftau_scl * MAX( 0._wp, zdif + rhftau_add )  ! apply some modifications... 
     392            en(ji,jj,jk) = en(ji,jj,jk) + zbbrau * zdif * EXP( -pdepw(ji,jj,jk) / htau(ji,jj) )   & 
     393               &                                 * MAX( 0._wp, 1._wp - zice_fra(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1) 
     394         END_3D 
    451395      ENDIF 
    452396      ! 
    … …  
    515459         zraug = vkarmn * 2.e5_wp / ( rau0 * grav ) 
    516460#if ! defined key_si3 && ! defined key_cice 
    517          DO jj = 2, jpjm1                     ! No sea-ice 
    518             DO ji = fs_2, fs_jpim1 
    519                zmxlm(ji,jj,1) =  zraug * taum(ji,jj) * tmask(ji,jj,1) 
    520             END DO 
    521          END DO 
     461         DO_2D_00_00 
     462            zmxlm(ji,jj,1) =  zraug * taum(ji,jj) * tmask(ji,jj,1) 
     463         END_2D 
    522464#else 
    523465 
    … …  
    525467         ! 
    526468         CASE( 0 )                      ! No scaling under sea-ice 
    527             DO jj = 2, jpjm1 
    528                DO ji = fs_2, fs_jpim1 
    529                   zmxlm(ji,jj,1) = zraug * taum(ji,jj) * tmask(ji,jj,1) 
    530                END DO 
    531             END DO 
     469            DO_2D_00_00 
     470               zmxlm(ji,jj,1) = zraug * taum(ji,jj) * tmask(ji,jj,1) 
     471            END_2D 
    532472            ! 
    533473         CASE( 1 )                      ! scaling with constant sea-ice thickness 
    534             DO jj = 2, jpjm1 
    535                DO ji = fs_2, fs_jpim1 
    536                   zmxlm(ji,jj,1) =  ( ( 1._wp - fr_i(ji,jj) ) * zraug * taum(ji,jj) + & 
    537                      &                          fr_i(ji,jj)   * rn_mxlice           ) * tmask(ji,jj,1) 
    538                END DO 
    539             END DO 
     474            DO_2D_00_00 
     475               zmxlm(ji,jj,1) =  ( ( 1._wp - fr_i(ji,jj) ) * zraug * taum(ji,jj) + & 
     476                  &                          fr_i(ji,jj)   * rn_mxlice           ) * tmask(ji,jj,1) 
     477            END_2D 
    540478            ! 
    541479         CASE( 2 )                      ! scaling with mean sea-ice thickness 
    542             DO jj = 2, jpjm1 
    543                DO ji = fs_2, fs_jpim1 
     480            DO_2D_00_00 
    544481#if defined key_si3 
    545                   zmxlm(ji,jj,1) = ( ( 1._wp - fr_i(ji,jj) ) * zraug * taum(ji,jj) + & 
    546                      &                         fr_i(ji,jj)   * hm_i(ji,jj) * 2._wp ) * tmask(ji,jj,1) 
     482               zmxlm(ji,jj,1) = ( ( 1._wp - fr_i(ji,jj) ) * zraug * taum(ji,jj) + & 
     483                  &                         fr_i(ji,jj)   * hm_i(ji,jj) * 2._wp ) * tmask(ji,jj,1) 
    547484#elif defined key_cice 
    548                   zmaxice = MAXVAL( h_i(ji,jj,:) ) 
    549                   zmxlm(ji,jj,1) = ( ( 1._wp - fr_i(ji,jj) ) * zraug * taum(ji,jj) + & 
    550                      &                         fr_i(ji,jj)   * zmaxice             ) * tmask(ji,jj,1) 
     485               zmaxice = MAXVAL( h_i(ji,jj,:) ) 
     486               zmxlm(ji,jj,1) = ( ( 1._wp - fr_i(ji,jj) ) * zraug * taum(ji,jj) + & 
     487                  &                         fr_i(ji,jj)   * zmaxice             ) * tmask(ji,jj,1) 
    551488#endif 
    552                END DO 
    553             END DO 
     489            END_2D 
    554490            ! 
    555491         CASE( 3 )                      ! scaling with max sea-ice thickness 
    556             DO jj = 2, jpjm1 
    557                DO ji = fs_2, fs_jpim1 
    558                   zmaxice = MAXVAL( h_i(ji,jj,:) ) 
    559                   zmxlm(ji,jj,1) = ( ( 1._wp - fr_i(ji,jj) ) * zraug * taum(ji,jj) + & 
    560                      &                         fr_i(ji,jj)   * zmaxice             ) * tmask(ji,jj,1) 
    561                END DO 
    562             END DO 
     492            DO_2D_00_00 
     493               zmaxice = MAXVAL( h_i(ji,jj,:) ) 
     494               zmxlm(ji,jj,1) = ( ( 1._wp - fr_i(ji,jj) ) * zraug * taum(ji,jj) + & 
     495                  &                         fr_i(ji,jj)   * zmaxice             ) * tmask(ji,jj,1) 
     496            END_2D 
    563497            ! 
    564498         END SELECT 
    565499#endif 
    566500         ! 
    567          DO jj = 2, jpjm1 
    568             DO ji = fs_2, fs_jpim1 
    569                zmxlm(ji,jj,1) = MAX( rn_mxl0, zmxlm(ji,jj,1) ) 
    570             END DO 
    571          END DO 
     501         DO_2D_00_00 
     502            zmxlm(ji,jj,1) = MAX( rn_mxl0, zmxlm(ji,jj,1) ) 
     503         END_2D 
    572504         ! 
    573505      ELSE 
    … …  
    575507      ENDIF 
    576508      ! 
    577       DO jk = 2, jpkm1              ! interior value : l=sqrt(2*e/n^2) 
    578          DO jj = 2, jpjm1 
    579             DO ji = fs_2, fs_jpim1   ! vector opt. 
    580                zrn2 = MAX( rn2(ji,jj,jk), rsmall ) 
    581                zmxlm(ji,jj,jk) = MAX(  rmxl_min,  SQRT( 2._wp * en(ji,jj,jk) / zrn2 )  ) 
    582             END DO 
    583          END DO 
    584       END DO 
     509      DO_3D_00_00( 2, jpkm1 ) 
     510         zrn2 = MAX( rn2(ji,jj,jk), rsmall ) 
     511         zmxlm(ji,jj,jk) = MAX(  rmxl_min,  SQRT( 2._wp * en(ji,jj,jk) / zrn2 )  ) 
     512      END_3D 
    585513      ! 
    586514      !                     !* Physical limits for the mixing length 
    … …  
    594522      ! where wmask = 0 set zmxlm == p_e3w 
    595523      CASE ( 0 )           ! bounded by the distance to surface and bottom 
    596          DO jk = 2, jpkm1 
    597             DO jj = 2, jpjm1 
    598                DO ji = fs_2, fs_jpim1   ! vector opt. 
    599                   zemxl = MIN( pdepw(ji,jj,jk) - pdepw(ji,jj,mikt(ji,jj)), zmxlm(ji,jj,jk),   & 
    600                   &            pdepw(ji,jj,mbkt(ji,jj)+1) - pdepw(ji,jj,jk) ) 
    601                   ! wmask prevent zmxlm = 0 if jk = mikt(ji,jj) 
    602                   zmxlm(ji,jj,jk) = zemxl * wmask(ji,jj,jk) + MIN( zmxlm(ji,jj,jk) , p_e3w(ji,jj,jk) ) * (1 - wmask(ji,jj,jk)) 
    603                   zmxld(ji,jj,jk) = zemxl * wmask(ji,jj,jk) + MIN( zmxlm(ji,jj,jk) , p_e3w(ji,jj,jk) ) * (1 - wmask(ji,jj,jk)) 
    604                END DO 
    605             END DO 
    606          END DO 
     524         DO_3D_00_00( 2, jpkm1 ) 
     525            zemxl = MIN( pdepw(ji,jj,jk) - pdepw(ji,jj,mikt(ji,jj)), zmxlm(ji,jj,jk),   & 
     526            &            pdepw(ji,jj,mbkt(ji,jj)+1) - pdepw(ji,jj,jk) ) 
     527            ! wmask prevent zmxlm = 0 if jk = mikt(ji,jj) 
     528            zmxlm(ji,jj,jk) = zemxl * wmask(ji,jj,jk) + MIN( zmxlm(ji,jj,jk) , p_e3w(ji,jj,jk) ) * (1 - wmask(ji,jj,jk)) 
     529            zmxld(ji,jj,jk) = zemxl * wmask(ji,jj,jk) + MIN( zmxlm(ji,jj,jk) , p_e3w(ji,jj,jk) ) * (1 - wmask(ji,jj,jk)) 
     530         END_3D 
    607531         ! 
    608532      CASE ( 1 )           ! bounded by the vertical scale factor 
    609          DO jk = 2, jpkm1 
    610             DO jj = 2, jpjm1 
    611                DO ji = fs_2, fs_jpim1   ! vector opt. 
    612                   zemxl = MIN( p_e3w(ji,jj,jk), zmxlm(ji,jj,jk) ) 
    613                   zmxlm(ji,jj,jk) = zemxl 
    614                   zmxld(ji,jj,jk) = zemxl 
    615                END DO 
    616             END DO 
    617          END DO 
     533         DO_3D_00_00( 2, jpkm1 ) 
     534            zemxl = MIN( p_e3w(ji,jj,jk), zmxlm(ji,jj,jk) ) 
     535            zmxlm(ji,jj,jk) = zemxl 
     536            zmxld(ji,jj,jk) = zemxl 
     537         END_3D 
    618538         ! 
    619539      CASE ( 2 )           ! |dk[xml]| bounded by e3t : 
    620          DO jk = 2, jpkm1         ! from the surface to the bottom : 
    621             DO jj = 2, jpjm1 
    622                DO ji = fs_2, fs_jpim1   ! vector opt. 
    623                   zmxlm(ji,jj,jk) = MIN( zmxlm(ji,jj,jk-1) + p_e3t(ji,jj,jk-1), zmxlm(ji,jj,jk) ) 
    624                END DO 
    625             END DO 
    626          END DO 
    627          DO jk = jpkm1, 2, -1     ! from the bottom to the surface : 
    628             DO jj = 2, jpjm1 
    629                DO ji = fs_2, fs_jpim1   ! vector opt. 
    630                   zemxl = MIN( zmxlm(ji,jj,jk+1) + p_e3t(ji,jj,jk+1), zmxlm(ji,jj,jk) ) 
    631                   zmxlm(ji,jj,jk) = zemxl 
    632                   zmxld(ji,jj,jk) = zemxl 
    633                END DO 
    634             END DO 
    635          END DO 
     540         DO_3D_00_00( 2, jpkm1 ) 
     541            zmxlm(ji,jj,jk) = MIN( zmxlm(ji,jj,jk-1) + p_e3t(ji,jj,jk-1), zmxlm(ji,jj,jk) ) 
     542         END_3D 
     543         DO_3D_00_00( jpkm1, 2, -1 ) 
     544            zemxl = MIN( zmxlm(ji,jj,jk+1) + p_e3t(ji,jj,jk+1), zmxlm(ji,jj,jk) ) 
     545            zmxlm(ji,jj,jk) = zemxl 
     546            zmxld(ji,jj,jk) = zemxl 
     547         END_3D 
    636548         ! 
    637549      CASE ( 3 )           ! lup and ldown, |dk[xml]| bounded by e3t : 
    638          DO jk = 2, jpkm1         ! from the surface to the bottom : lup 
    639             DO jj = 2, jpjm1 
    640                DO ji = fs_2, fs_jpim1   ! vector opt. 
    641                   zmxld(ji,jj,jk) = MIN( zmxld(ji,jj,jk-1) + p_e3t(ji,jj,jk-1), zmxlm(ji,jj,jk) ) 
    642                END DO 
    643             END DO 
    644          END DO 
    645          DO jk = jpkm1, 2, -1     ! from the bottom to the surface : ldown 
    646             DO jj = 2, jpjm1 
    647                DO ji = fs_2, fs_jpim1   ! vector opt. 
    648                   zmxlm(ji,jj,jk) = MIN( zmxlm(ji,jj,jk+1) + p_e3t(ji,jj,jk+1), zmxlm(ji,jj,jk) ) 
    649                END DO 
    650             END DO 
    651          END DO 
    652          DO jk = 2, jpkm1 
    653             DO jj = 2, jpjm1 
    654                DO ji = fs_2, fs_jpim1   ! vector opt. 
    655                   zemlm = MIN ( zmxld(ji,jj,jk),  zmxlm(ji,jj,jk) ) 
    656                   zemlp = SQRT( zmxld(ji,jj,jk) * zmxlm(ji,jj,jk) ) 
    657                   zmxlm(ji,jj,jk) = zemlm 
    658                   zmxld(ji,jj,jk) = zemlp 
    659                END DO 
    660             END DO 
    661          END DO 
     550         DO_3D_00_00( 2, jpkm1 ) 
     551            zmxld(ji,jj,jk) = MIN( zmxld(ji,jj,jk-1) + p_e3t(ji,jj,jk-1), zmxlm(ji,jj,jk) ) 
     552         END_3D 
     553         DO_3D_00_00( jpkm1, 2, -1 ) 
     554            zmxlm(ji,jj,jk) = MIN( zmxlm(ji,jj,jk+1) + p_e3t(ji,jj,jk+1), zmxlm(ji,jj,jk) ) 
     555         END_3D 
     556         DO_3D_00_00( 2, jpkm1 ) 
     557            zemlm = MIN ( zmxld(ji,jj,jk),  zmxlm(ji,jj,jk) ) 
     558            zemlp = SQRT( zmxld(ji,jj,jk) * zmxlm(ji,jj,jk) ) 
     559            zmxlm(ji,jj,jk) = zemlm 
     560            zmxld(ji,jj,jk) = zemlp 
     561         END_3D 
    662562         ! 
    663563      END SELECT 
    … …  
    666566      !                     !  Vertical eddy viscosity and diffusivity  (avm and avt) 
    667567      !                     !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
    668       DO jk = 1, jpkm1            !* vertical eddy viscosity & diffivity at w-points 
    669          DO jj = 2, jpjm1 
    670             DO ji = fs_2, fs_jpim1   ! vector opt. 
    671                zsqen = SQRT( en(ji,jj,jk) ) 
    672                zav   = rn_ediff * zmxlm(ji,jj,jk) * zsqen 
    673                p_avm(ji,jj,jk) = MAX( zav,                  avmb(jk) ) * wmask(ji,jj,jk) 
    674                p_avt(ji,jj,jk) = MAX( zav, avtb_2d(ji,jj) * avtb(jk) ) * wmask(ji,jj,jk) 
    675                dissl(ji,jj,jk) = zsqen / zmxld(ji,jj,jk) 
    676             END DO 
    677          END DO 
    678       END DO 
     568      DO_3D_00_00( 1, jpkm1 ) 
     569         zsqen = SQRT( en(ji,jj,jk) ) 
     570         zav   = rn_ediff * zmxlm(ji,jj,jk) * zsqen 
     571         p_avm(ji,jj,jk) = MAX( zav,                  avmb(jk) ) * wmask(ji,jj,jk) 
     572         p_avt(ji,jj,jk) = MAX( zav, avtb_2d(ji,jj) * avtb(jk) ) * wmask(ji,jj,jk) 
     573         dissl(ji,jj,jk) = zsqen / zmxld(ji,jj,jk) 
     574      END_3D 
    679575      ! 
    680576      ! 
    681577      IF( nn_pdl == 1 ) THEN      !* Prandtl number case: update avt 
    682          DO jk = 2, jpkm1 
    683             DO jj = 2, jpjm1 
    684                DO ji = fs_2, fs_jpim1   ! vector opt. 
    685                   p_avt(ji,jj,jk)   = MAX( apdlr(ji,jj,jk) * p_avt(ji,jj,jk), avtb_2d(ji,jj) * avtb(jk) ) * wmask(ji,jj,jk) 
    686               END DO 
    687             END DO 
    688          END DO 
     578         DO_3D_00_00( 2, jpkm1 ) 
     579            p_avt(ji,jj,jk)   = MAX( apdlr(ji,jj,jk) * p_avt(ji,jj,jk), avtb_2d(ji,jj) * avtb(jk) ) * wmask(ji,jj,jk) 
     580         END_3D 
    689581      ENDIF 
    690582      ! 

  • NEMO/branches/2020/temporary_r4_trunk/src/TOP/PISCES/P4Z/p4zfechem.F90

    r13466 r13469  
    8989      ! Chemistry is supposed to be fast enough to be at equilibrium 
    9090      ! ------------------------------------------------------------ 
    91       DO jk = 1, jpkm1 
    92          DO jj = 1, jpj 
    93             DO ji = 1, jpi 
    94                zTL1(ji,jj,jk)  = ztotlig(ji,jj,jk) 
    95                zkeq            = fekeq(ji,jj,jk) 
    96                zfesatur        = zTL1(ji,jj,jk) * 1E-9 
    97                ztfe            = trb(ji,jj,jk,jpfer)  
    98                ! Fe' is the root of a 2nd order polynom 
    99                zFe3 (ji,jj,jk) = ( -( 1. + zfesatur * zkeq - zkeq * ztfe )               & 
    100                   &              + SQRT( ( 1. + zfesatur * zkeq - zkeq * ztfe )**2       & 
    101                   &              + 4. * ztfe * zkeq) ) / ( 2. * zkeq ) 
    102                zFe3 (ji,jj,jk) = zFe3(ji,jj,jk) * 1E9 
    103                zFeL1(ji,jj,jk) = MAX( 0., trb(ji,jj,jk,jpfer) * 1E9 - zFe3(ji,jj,jk) ) 
    104            END DO 
    105          END DO 
    106       END DO 
     91      DO_3D_11_11( 1, jpkm1 ) 
     92         zTL1(ji,jj,jk)  = ztotlig(ji,jj,jk) 
     93         zkeq            = fekeq(ji,jj,jk) 
     94         zfesatur        = zTL1(ji,jj,jk) * 1E-9 
     95         ztfe            = trb(ji,jj,jk,jpfer)  
     96         ! Fe' is the root of a 2nd order polynom 
     97         zFe3 (ji,jj,jk) = ( -( 1. + zfesatur * zkeq - zkeq * ztfe )               & 
     98            &              + SQRT( ( 1. + zfesatur * zkeq - zkeq * ztfe )**2       & 
     99            &              + 4. * ztfe * zkeq) ) / ( 2. * zkeq ) 
     100         zFe3 (ji,jj,jk) = zFe3(ji,jj,jk) * 1E9 
     101         zFeL1(ji,jj,jk) = MAX( 0., trb(ji,jj,jk,jpfer) * 1E9 - zFe3(ji,jj,jk) ) 
     102      END_3D 
    107103         ! 
    108104 
    109105      zdust = 0.         ! if no dust available 
    110       DO jk = 1, jpkm1 
    111          DO jj = 1, jpj 
    112             DO ji = 1, jpi 
    113                ! Scavenging rate of iron. This scavenging rate depends on the load of particles of sea water.  
    114                ! This parameterization assumes a simple second order kinetics (k[Particles][Fe]). 
    115                ! Scavenging onto dust is also included as evidenced from the DUNE experiments. 
    116                ! -------------------------------------------------------------------------------------- 
    117                zhplus  = max( rtrn, hi(ji,jj,jk) ) 
    118                fe3sol  = fesol(ji,jj,jk,1) * ( zhplus**3 + fesol(ji,jj,jk,2) * zhplus**2  & 
    119                &         + fesol(ji,jj,jk,3) * zhplus + fesol(ji,jj,jk,4)     & 
    120                &         + fesol(ji,jj,jk,5) / zhplus ) 
    121                ! 
    122                zfeequi = zFe3(ji,jj,jk) * 1E-9 
    123                zfecoll = 0.5 * zFeL1(ji,jj,jk) * 1E-9 
    124                ! precipitation of Fe3+, creation of nanoparticles 
    125                precip(ji,jj,jk) = MAX( 0., ( zFe3(ji,jj,jk) * 1E-9 - fe3sol ) ) * kfep * xstep 
    126                ! 
    127                ztrc   = ( trb(ji,jj,jk,jppoc) + trb(ji,jj,jk,jpgoc) + trb(ji,jj,jk,jpcal) + trb(ji,jj,jk,jpgsi) ) * 1.e6  
    128                IF( ln_dust )  zdust  = dust(ji,jj) / ( wdust / rday ) * tmask(ji,jj,jk) & 
    129                &  * EXP( -gdept_n(ji,jj,jk) / 540. ) 
    130                IF (ln_ligand) THEN 
    131                   zxlam  = xlam1 * MAX( 1.E-3, EXP(-2 * etot(ji,jj,jk) / 10. ) * (1. - EXP(-2 * trb(ji,jj,jk,jpoxy) / 100.E-6 ) )) 
    132                ELSE 
    133                   zxlam  = xlam1 * 1.0 
    134                ENDIF 
    135                zlam1b = 3.e-5 + xlamdust * zdust + zxlam * ztrc 
    136                zscave = zfeequi * zlam1b * xstep 
    137  
    138                ! Compute the different ratios for scavenging of iron 
    139                ! to later allocate scavenged iron to the different organic pools 
    140                ! --------------------------------------------------------- 
    141                zdenom1 = zxlam * trb(ji,jj,jk,jppoc) / zlam1b 
    142                zdenom2 = zxlam * trb(ji,jj,jk,jpgoc) / zlam1b 
    143  
    144                !  Increased scavenging for very high iron concentrations found near the coasts  
    145                !  due to increased lithogenic particles and let say it is unknown processes (precipitation, ...) 
    146                !  ----------------------------------------------------------- 
    147                zlamfac = MAX( 0.e0, ( gphit(ji,jj) + 55.) / 30. ) 
    148                zlamfac = MIN( 1.  , zlamfac ) 
    149                zdep    = MIN( 1., 1000. / gdept_n(ji,jj,jk) ) 
    150                zcoag   = 1E-4 * ( 1. - zlamfac ) * zdep * xstep * trb(ji,jj,jk,jpfer) 
    151  
    152                !  Compute the coagulation of colloidal iron. This parameterization  
    153                !  could be thought as an equivalent of colloidal pumping. 
    154                !  It requires certainly some more work as it is very poorly constrained. 
    155                !  ---------------------------------------------------------------- 
    156                zlam1a   = ( 0.369  * 0.3 * trb(ji,jj,jk,jpdoc) + 102.4  * trb(ji,jj,jk,jppoc) ) * xdiss(ji,jj,jk)    & 
    157                    &      + ( 114.   * 0.3 * trb(ji,jj,jk,jpdoc) ) 
    158                zaggdfea = zlam1a * xstep * zfecoll 
    159                ! 
    160                zlam1b   = 3.53E3 * trb(ji,jj,jk,jpgoc) * xdiss(ji,jj,jk) 
    161                zaggdfeb = zlam1b * xstep * zfecoll 
    162                ! 
    163                tra(ji,jj,jk,jpfer) = tra(ji,jj,jk,jpfer) - zscave - zaggdfea - zaggdfeb & 
    164                &                     - zcoag - precip(ji,jj,jk) 
    165                tra(ji,jj,jk,jpsfe) = tra(ji,jj,jk,jpsfe) + zscave * zdenom1 + zaggdfea 
    166                tra(ji,jj,jk,jpbfe) = tra(ji,jj,jk,jpbfe) + zscave * zdenom2 + zaggdfeb 
    167                zscav3d(ji,jj,jk)   = zscave 
    168                zcoll3d(ji,jj,jk)   = zaggdfea + zaggdfeb 
    169                ! 
    170             END DO 
    171          END DO 
    172       END DO 
     106      DO_3D_11_11( 1, jpkm1 ) 
     107         ! Scavenging rate of iron. This scavenging rate depends on the load of particles of sea water.  
     108         ! This parameterization assumes a simple second order kinetics (k[Particles][Fe]). 
     109         ! Scavenging onto dust is also included as evidenced from the DUNE experiments. 
     110         ! -------------------------------------------------------------------------------------- 
     111         zhplus  = max( rtrn, hi(ji,jj,jk) ) 
     112         fe3sol  = fesol(ji,jj,jk,1) * ( zhplus**3 + fesol(ji,jj,jk,2) * zhplus**2  & 
     113         &         + fesol(ji,jj,jk,3) * zhplus + fesol(ji,jj,jk,4)     & 
     114         &         + fesol(ji,jj,jk,5) / zhplus ) 
     115         ! 
     116         zfeequi = zFe3(ji,jj,jk) * 1E-9 
     117         zfecoll = 0.5 * zFeL1(ji,jj,jk) * 1E-9 
     118         ! precipitation of Fe3+, creation of nanoparticles 
     119         precip(ji,jj,jk) = MAX( 0., ( zFe3(ji,jj,jk) * 1E-9 - fe3sol ) ) * kfep * xstep 
     120         ! 
     121         ztrc   = ( trb(ji,jj,jk,jppoc) + trb(ji,jj,jk,jpgoc) + trb(ji,jj,jk,jpcal) + trb(ji,jj,jk,jpgsi) ) * 1.e6  
     122         IF( ln_dust )  zdust  = dust(ji,jj) / ( wdust / rday ) * tmask(ji,jj,jk) & 
     123         &  * EXP( -gdept_n(ji,jj,jk) / 540. ) 
     124         IF (ln_ligand) THEN 
     125            zxlam  = xlam1 * MAX( 1.E-3, EXP(-2 * etot(ji,jj,jk) / 10. ) * (1. - EXP(-2 * trb(ji,jj,jk,jpoxy) / 100.E-6 ) )) 
     126         ELSE 
     127            zxlam  = xlam1 * 1.0 
     128         ENDIF 
     129         zlam1b = 3.e-5 + xlamdust * zdust + zxlam * ztrc 
     130         zscave = zfeequi * zlam1b * xstep 
     131 
     132         ! Compute the different ratios for scavenging of iron 
     133         ! to later allocate scavenged iron to the different organic pools 
     134         ! --------------------------------------------------------- 
     135         zdenom1 = zxlam * trb(ji,jj,jk,jppoc) / zlam1b 
     136         zdenom2 = zxlam * trb(ji,jj,jk,jpgoc) / zlam1b 
     137 
     138         !  Increased scavenging for very high iron concentrations found near the coasts  
     139         !  due to increased lithogenic particles and let say it is unknown processes (precipitation, ...) 
     140         !  ----------------------------------------------------------- 
     141         zlamfac = MAX( 0.e0, ( gphit(ji,jj) + 55.) / 30. ) 
     142         zlamfac = MIN( 1.  , zlamfac ) 
     143         zdep    = MIN( 1., 1000. / gdept_n(ji,jj,jk) ) 
     144         zcoag   = 1E-4 * ( 1. - zlamfac ) * zdep * xstep * trb(ji,jj,jk,jpfer) 
     145 
     146         !  Compute the coagulation of colloidal iron. This parameterization  
     147         !  could be thought as an equivalent of colloidal pumping. 
     148         !  It requires certainly some more work as it is very poorly constrained. 
     149         !  ---------------------------------------------------------------- 
     150         zlam1a   = ( 0.369  * 0.3 * trb(ji,jj,jk,jpdoc) + 102.4  * trb(ji,jj,jk,jppoc) ) * xdiss(ji,jj,jk)    & 
     151             &      + ( 114.   * 0.3 * trb(ji,jj,jk,jpdoc) ) 
     152         zaggdfea = zlam1a * xstep * zfecoll 
     153         ! 
     154         zlam1b   = 3.53E3 * trb(ji,jj,jk,jpgoc) * xdiss(ji,jj,jk) 
     155         zaggdfeb = zlam1b * xstep * zfecoll 
     156         ! 
     157         tra(ji,jj,jk,jpfer) = tra(ji,jj,jk,jpfer) - zscave - zaggdfea - zaggdfeb & 
     158         &                     - zcoag - precip(ji,jj,jk) 
     159         tra(ji,jj,jk,jpsfe) = tra(ji,jj,jk,jpsfe) + zscave * zdenom1 + zaggdfea 
     160         tra(ji,jj,jk,jpbfe) = tra(ji,jj,jk,jpbfe) + zscave * zdenom2 + zaggdfeb 
     161         zscav3d(ji,jj,jk)   = zscave 
     162         zcoll3d(ji,jj,jk)   = zaggdfea + zaggdfeb 
     163         ! 
     164      END_3D 
    173165      ! 
    174166      !  Define the bioavailable fraction of iron 
    … …  
    178170      IF( ln_ligand ) THEN 
    179171         ! 
    180          DO jk = 1, jpkm1 
    181             DO jj = 1, jpj 
    182                DO ji = 1, jpi 
    183                   zlam1a   = ( 0.369  * 0.3 * trb(ji,jj,jk,jpdoc) + 102.4  * trb(ji,jj,jk,jppoc) ) * xdiss(ji,jj,jk)    & 
    184                       &    + ( 114.   * 0.3 * trb(ji,jj,jk,jpdoc) ) 
    185                   ! 
    186                   zlam1b   = 3.53E3 *   trb(ji,jj,jk,jpgoc) * xdiss(ji,jj,jk) 
    187                   zligco   = 0.5 * trn(ji,jj,jk,jplgw) 
    188                   zaggliga = zlam1a * xstep * zligco 
    189                   zaggligb = zlam1b * xstep * zligco 
    190                   tra(ji,jj,jk,jplgw) = tra(ji,jj,jk,jplgw) - zaggliga - zaggligb 
    191                   zlcoll3d(ji,jj,jk)  = zaggliga + zaggligb 
    192                END DO 
    193             END DO 
    194          END DO 
     172         DO_3D_11_11( 1, jpkm1 ) 
     173            zlam1a   = ( 0.369  * 0.3 * trb(ji,jj,jk,jpdoc) + 102.4  * trb(ji,jj,jk,jppoc) ) * xdiss(ji,jj,jk)    & 
     174                &    + ( 114.   * 0.3 * trb(ji,jj,jk,jpdoc) ) 
     175            ! 
     176            zlam1b   = 3.53E3 *   trb(ji,jj,jk,jpgoc) * xdiss(ji,jj,jk) 
     177            zligco   = 0.5 * trn(ji,jj,jk,jplgw) 
     178            zaggliga = zlam1a * xstep * zligco 
     179            zaggligb = zlam1b * xstep * zligco 
     180            tra(ji,jj,jk,jplgw) = tra(ji,jj,jk,jplgw) - zaggliga - zaggligb 
     181            zlcoll3d(ji,jj,jk)  = zaggliga + zaggligb 
     182         END_3D 
    195183         ! 
    196184         plig(:,:,:) =  MAX( 0., ( ( zFeL1(:,:,:) * 1E-9 ) / ( trb(:,:,:,jpfer) +rtrn ) ) ) 

  • NEMO/branches/2020/temporary_r4_trunk/src/TOP/PISCES/P4Z/p4zsbc.F90

    r13466 r13469  
    126126            CALL fld_read( kt, 1, sf_river ) 
    127127            IF( ln_p4z ) THEN 
    128                DO jj = 1, jpj 
    129                   DO ji = 1, jpi 
    130                      zcoef = ryyss * e1e2t(ji,jj) * h_rnf(ji,jj)  
    131                      rivalk(ji,jj) =   sf_river(jr_dic)%fnow(ji,jj,1)  & 
    132                         &              * 1.E3        / ( 12. * zcoef + rtrn ) 
    133                      rivdic(ji,jj) =   sf_river(jr_dic)%fnow(ji,jj,1)  & 
    134                         &              * 1.E3         / ( 12. * zcoef + rtrn ) 
    135                      rivdin(ji,jj) =   sf_river(jr_din)%fnow(ji,jj,1)  & 
    136                         &              * 1.E3 / rno3 / ( 14. * zcoef + rtrn ) 
    137                      rivdip(ji,jj) =   sf_river(jr_dip)%fnow(ji,jj,1)  & 
    138                         &              * 1.E3 / po4r / ( 31. * zcoef + rtrn ) 
    139                      rivdsi(ji,jj) =   sf_river(jr_dsi)%fnow(ji,jj,1)  & 
    140                         &              * 1.E3        / ( 28.1 * zcoef + rtrn ) 
    141                      rivdoc(ji,jj) =   sf_river(jr_doc)%fnow(ji,jj,1)  & 
    142                         &              * 1.E3        / ( 12. * zcoef + rtrn )  
    143                   END DO 
    144                END DO 
     128               DO_2D_11_11 
     129                  zcoef = ryyss * e1e2t(ji,jj) * h_rnf(ji,jj)  
     130                  rivalk(ji,jj) =   sf_river(jr_dic)%fnow(ji,jj,1)  & 
     131                     &              * 1.E3        / ( 12. * zcoef + rtrn ) 
     132                  rivdic(ji,jj) =   sf_river(jr_dic)%fnow(ji,jj,1)  & 
     133                     &              * 1.E3         / ( 12. * zcoef + rtrn ) 
     134                  rivdin(ji,jj) =   sf_river(jr_din)%fnow(ji,jj,1)  & 
     135                     &              * 1.E3 / rno3 / ( 14. * zcoef + rtrn ) 
     136                  rivdip(ji,jj) =   sf_river(jr_dip)%fnow(ji,jj,1)  & 
     137                     &              * 1.E3 / po4r / ( 31. * zcoef + rtrn ) 
     138                  rivdsi(ji,jj) =   sf_river(jr_dsi)%fnow(ji,jj,1)  & 
     139                     &              * 1.E3        / ( 28.1 * zcoef + rtrn ) 
     140                  rivdoc(ji,jj) =   sf_river(jr_doc)%fnow(ji,jj,1)  & 
     141                     &              * 1.E3        / ( 12. * zcoef + rtrn )  
     142               END_2D 
    145143            ELSE    !  ln_p5z 
    146                DO jj = 1, jpj 
    147                   DO ji = 1, jpi 
    148                      zcoef = ryyss * e1e2t(ji,jj) * h_rnf(ji,jj)  
    149                      rivalk(ji,jj) =   sf_river(jr_dic)%fnow(ji,jj,1)                                    & 
    150                         &              * 1.E3        / ( 12. * zcoef + rtrn ) 
    151                      rivdic(ji,jj) = ( sf_river(jr_dic)%fnow(ji,jj,1) ) & 
    152                         &              * 1.E3 / ( 12. * zcoef + rtrn ) * tmask(ji,jj,1) 
    153                      rivdin(ji,jj) = ( sf_river(jr_din)%fnow(ji,jj,1) ) & 
    154                         &              * 1.E3 / rno3 / ( 14. * zcoef + rtrn ) * tmask(ji,jj,1) 
    155                      rivdip(ji,jj) = ( sf_river(jr_dip)%fnow(ji,jj,1) ) & 
    156                         &              * 1.E3 / po4r / ( 31. * zcoef + rtrn ) * tmask(ji,jj,1) 
    157                      rivdon(ji,jj) = ( sf_river(jr_don)%fnow(ji,jj,1) ) & 
    158                         &              * 1.E3 / rno3 / ( 14. * zcoef + rtrn ) * tmask(ji,jj,1) 
    159                      rivdop(ji,jj) = ( sf_river(jr_dop)%fnow(ji,jj,1) ) & 
    160                         &              * 1.E3 / po4r / ( 31. * zcoef + rtrn ) * tmask(ji,jj,1) 
    161                      rivdsi(ji,jj) =   sf_river(jr_dsi)%fnow(ji,jj,1)  & 
    162                         &              * 1.E3        / ( 28.1 * zcoef + rtrn ) 
    163                      rivdoc(ji,jj) =   sf_river(jr_doc)%fnow(ji,jj,1)  & 
    164                         &              * 1.E3        / ( 12. * zcoef + rtrn ) 
    165                   END DO 
    166                END DO 
     144               DO_2D_11_11 
     145                  zcoef = ryyss * e1e2t(ji,jj) * h_rnf(ji,jj)  
     146                  rivalk(ji,jj) =   sf_river(jr_dic)%fnow(ji,jj,1)                                    & 
     147                     &              * 1.E3        / ( 12. * zcoef + rtrn ) 
     148                  rivdic(ji,jj) = ( sf_river(jr_dic)%fnow(ji,jj,1) ) & 
     149                     &              * 1.E3 / ( 12. * zcoef + rtrn ) * tmask(ji,jj,1) 
     150                  rivdin(ji,jj) = ( sf_river(jr_din)%fnow(ji,jj,1) ) & 
     151                     &              * 1.E3 / rno3 / ( 14. * zcoef + rtrn ) * tmask(ji,jj,1) 
     152                  rivdip(ji,jj) = ( sf_river(jr_dip)%fnow(ji,jj,1) ) & 
     153                     &              * 1.E3 / po4r / ( 31. * zcoef + rtrn ) * tmask(ji,jj,1) 
     154                  rivdon(ji,jj) = ( sf_river(jr_don)%fnow(ji,jj,1) ) & 
     155                     &              * 1.E3 / rno3 / ( 14. * zcoef + rtrn ) * tmask(ji,jj,1) 
     156                  rivdop(ji,jj) = ( sf_river(jr_dop)%fnow(ji,jj,1) ) & 
     157                     &              * 1.E3 / po4r / ( 31. * zcoef + rtrn ) * tmask(ji,jj,1) 
     158                  rivdsi(ji,jj) =   sf_river(jr_dsi)%fnow(ji,jj,1)  & 
     159                     &              * 1.E3        / ( 28.1 * zcoef + rtrn ) 
     160                  rivdoc(ji,jj) =   sf_river(jr_doc)%fnow(ji,jj,1)  & 
     161                     &              * 1.E3        / ( 12. * zcoef + rtrn ) 
     162               END_2D 
    167163            ENDIF 
    168164         ENDIF 
    … …  
    411407         IF(lwp) WRITE(numout,*) 
    412408         IF(lwp) WRITE(numout,*) ' Level corresponding to 50m depth ',  ik50,' ', gdept_1d(ik50+1) 
    413          DO jk = 1, ik50 
    414             DO jj = 2, jpjm1 
    415                DO ji = fs_2, fs_jpim1 
    416                   ze3t   = e3t_0(ji,jj,jk) 
    417                   zsurfc =  e1u(ji,jj) * ( 1. - umask(ji  ,jj  ,jk) )   & 
    418                           + e1u(ji,jj) * ( 1. - umask(ji-1,jj  ,jk) )   & 
    419                           + e2v(ji,jj) * ( 1. - vmask(ji  ,jj  ,jk) )   & 
    420                           + e2v(ji,jj) * ( 1. - vmask(ji  ,jj-1,jk) ) 
    421                   zsurfp = zsurfc * ze3t / e1e2t(ji,jj) 
    422                   ! estimation of the coastal slope : 5 km off the coast 
    423                   ze3t2 = ze3t * ze3t 
    424                   zcslp = SQRT( ( distcoast*distcoast + ze3t2 ) / ze3t2 ) 
    425                   ! 
    426                   zcmask(ji,jj,jk) = zcmask(ji,jj,jk) + zcslp * zsurfp 
    427                END DO 
    428             END DO 
    429          END DO 
     409         DO_3D_00_00( 1, ik50 ) 
     410            ze3t   = e3t_0(ji,jj,jk) 
     411            zsurfc =  e1u(ji,jj) * ( 1. - umask(ji  ,jj  ,jk) )   & 
     412                    + e1u(ji,jj) * ( 1. - umask(ji-1,jj  ,jk) )   & 
     413                    + e2v(ji,jj) * ( 1. - vmask(ji  ,jj  ,jk) )   & 
     414                    + e2v(ji,jj) * ( 1. - vmask(ji  ,jj-1,jk) ) 
     415            zsurfp = zsurfc * ze3t / e1e2t(ji,jj) 
     416            ! estimation of the coastal slope : 5 km off the coast 
     417            ze3t2 = ze3t * ze3t 
     418            zcslp = SQRT( ( distcoast*distcoast + ze3t2 ) / ze3t2 ) 
     419            ! 
     420            zcmask(ji,jj,jk) = zcmask(ji,jj,jk) + zcslp * zsurfp 
     421         END_3D 
    430422         ! 
    431423         CALL lbc_lnk( 'p4zsbc', zcmask , 'T', 1. )      ! lateral boundary conditions on cmask   (sign unchanged) 
    432424         ! 
    433          DO jk = 1, jpk 
    434             DO jj = 1, jpj 
    435                DO ji = 1, jpi 
    436                   zexpide   = MIN( 8.,( gdept_n(ji,jj,jk) / 500. )**(-1.5) ) 
    437                   zdenitide = -0.9543 + 0.7662 * LOG( zexpide ) - 0.235 * LOG( zexpide )**2 
    438                   zcmask(ji,jj,jk) = zcmask(ji,jj,jk) * MIN( 1., EXP( zdenitide ) / 0.5 ) 
    439                END DO 
    440             END DO 
    441          END DO 
     425         DO_3D_11_11( 1, jpk ) 
     426            zexpide   = MIN( 8.,( gdept_n(ji,jj,jk) / 500. )**(-1.5) ) 
     427            zdenitide = -0.9543 + 0.7662 * LOG( zexpide ) - 0.235 * LOG( zexpide )**2 
     428            zcmask(ji,jj,jk) = zcmask(ji,jj,jk) * MIN( 1., EXP( zdenitide ) / 0.5 ) 
     429         END_3D 
    442430         ! Coastal supply of iron 
    443431         ! ------------------------- 

  • NEMO/branches/2020/temporary_r4_trunk/src/TOP/PISCES/P4Z/p4zsms.F90

    r13467 r13469  
    127127         xnegtr(:,:,:) = 1.e0 
    128128         DO jn = jp_pcs0, jp_pcs1 
    129             DO jk = 1, jpk 
    130                DO jj = 1, jpj 
    131                   DO ji = 1, jpi 
    132                      IF( ( trb(ji,jj,jk,jn) + tra(ji,jj,jk,jn) ) < 0.e0 ) THEN 
    133                         ztra             = ABS( trb(ji,jj,jk,jn) ) / ( ABS( tra(ji,jj,jk,jn) ) + rtrn ) 
    134                         xnegtr(ji,jj,jk) = MIN( xnegtr(ji,jj,jk),  ztra ) 
    135                      ENDIF 
    136                  END DO 
    137                END DO 
    138             END DO 
     129            DO_3D_11_11( 1, jpk ) 
     130               IF( ( trb(ji,jj,jk,jn) + tra(ji,jj,jk,jn) ) < 0.e0 ) THEN 
     131                  ztra             = ABS( trb(ji,jj,jk,jn) ) / ( ABS( tra(ji,jj,jk,jn) ) + rtrn ) 
     132                  xnegtr(ji,jj,jk) = MIN( xnegtr(ji,jj,jk),  ztra ) 
     133               ENDIF 
     134            END_3D 
    139135         END DO 
    140136         !                                ! where at least 1 tracer concentration becomes negative 

  • NEMO/branches/2020/temporary_r4_trunk/tests/CANAL/MY_SRC/diawri.F90

    r13466 r13469  
    150150      CALL iom_put(  "sst", tsn(:,:,1,jp_tem) )    ! surface temperature 
    151151      IF ( iom_use("sbt") ) THEN 
    152          DO jj = 1, jpj 
    153             DO ji = 1, jpi 
    154                ikbot = mbkt(ji,jj) 
    155                z2d(ji,jj) = tsn(ji,jj,ikbot,jp_tem) 
    156             END DO 
    157          END DO 
     152         DO_2D_11_11 
     153            ikbot = mbkt(ji,jj) 
     154            z2d(ji,jj) = tsn(ji,jj,ikbot,jp_tem) 
     155         END_2D 
    158156         CALL iom_put( "sbt", z2d )                ! bottom temperature 
    159157      ENDIF 
    … …  
    162160      CALL iom_put(  "sss", tsn(:,:,1,jp_sal) )    ! surface salinity 
    163161      IF ( iom_use("sbs") ) THEN 
    164          DO jj = 1, jpj 
    165             DO ji = 1, jpi 
    166                ikbot = mbkt(ji,jj) 
    167                z2d(ji,jj) = tsn(ji,jj,ikbot,jp_sal) 
    168             END DO 
    169          END DO 
     162         DO_2D_11_11 
     163            ikbot = mbkt(ji,jj) 
     164            z2d(ji,jj) = tsn(ji,jj,ikbot,jp_sal) 
     165         END_2D 
    170166         CALL iom_put( "sbs", z2d )                ! bottom salinity 
    171167      ENDIF 
    … …  
    174170         zztmp = rau0 * 0.25 
    175171         z2d(:,:) = 0._wp 
    176          DO jj = 2, jpjm1 
    177             DO ji = fs_2, fs_jpim1   ! vector opt. 
    178                zztmp2 = (  ( rCdU_bot(ji+1,jj)+rCdU_bot(ji  ,jj) ) * un(ji  ,jj,mbku(ji  ,jj))  )**2   & 
    179                   &   + (  ( rCdU_bot(ji  ,jj)+rCdU_bot(ji-1,jj) ) * un(ji-1,jj,mbku(ji-1,jj))  )**2   & 
    180                   &   + (  ( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj  ) ) * vn(ji,jj  ,mbkv(ji,jj  ))  )**2   & 
    181                   &   + (  ( rCdU_bot(ji,jj  )+rCdU_bot(ji,jj-1) ) * vn(ji,jj-1,mbkv(ji,jj-1))  )**2 
    182                z2d(ji,jj) = zztmp * SQRT( zztmp2 ) * tmask(ji,jj,1)  
    183                ! 
    184             END DO 
    185          END DO 
     172         DO_2D_00_00 
     173            zztmp2 = (  ( rCdU_bot(ji+1,jj)+rCdU_bot(ji  ,jj) ) * uu(ji  ,jj,mbku(ji  ,jj),Nii)  )**2   & 
     174               &   + (  ( rCdU_bot(ji  ,jj)+rCdU_bot(ji-1,jj) ) * uu(ji-1,jj,mbku(ji-1,jj),Nii)  )**2   & 
     175               &   + (  ( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj  ) ) * vv(ji,jj  ,mbkv(ji,jj  ),Nii)  )**2   & 
     176               &   + (  ( rCdU_bot(ji,jj  )+rCdU_bot(ji,jj-1) ) * vv(ji,jj-1,mbkv(ji,jj-1),Nii)  )**2 
     177            z2d(ji,jj) = zztmp * SQRT( zztmp2 ) * tmask(ji,jj,1)  
     178            ! 
     179         END_2D 
    186180         CALL lbc_lnk( 'diawri', z2d, 'T', 1. ) 
    187181         CALL iom_put( "taubot", z2d )            
    188182      ENDIF 
    189183          
    190       CALL iom_put( "uoce", un(:,:,:) )            ! 3D i-current 
    191       CALL iom_put(  "ssu", un(:,:,1) )            ! surface i-current 
     184      CALL iom_put( "uoce", uu(:,:,:,Nii) )            ! 3D i-current 
     185      CALL iom_put(  "ssu", uu(:,:,1,Nii) )            ! surface i-current 
    192186      IF ( iom_use("sbu") ) THEN 
    193          DO jj = 1, jpj 
    194             DO ji = 1, jpi 
    195                ikbot = mbku(ji,jj) 
    196                z2d(ji,jj) = un(ji,jj,ikbot) 
    197             END DO 
    198          END DO 
     187         DO_2D_11_11 
     188            ikbot = mbku(ji,jj) 
     189            z2d(ji,jj) = uu(ji,jj,ikbot,Nii) 
     190         END_2D 
    199191         CALL iom_put( "sbu", z2d )                ! bottom i-current 
    200192      ENDIF 
    201193       
    202       CALL iom_put( "voce", vn(:,:,:) )            ! 3D j-current 
    203       CALL iom_put(  "ssv", vn(:,:,1) )            ! surface j-current 
     194      CALL iom_put( "voce", vv(:,:,:,Nii) )            ! 3D j-current 
     195      CALL iom_put(  "ssv", vv(:,:,1,Nii) )            ! surface j-current 
    204196      IF ( iom_use("sbv") ) THEN 
    205          DO jj = 1, jpj 
    206             DO ji = 1, jpi 
    207                ikbot = mbkv(ji,jj) 
    208                z2d(ji,jj) = vn(ji,jj,ikbot) 
    209             END DO 
    210          END DO 
     197         DO_2D_11_11 
     198            ikbot = mbkv(ji,jj) 
     199            z2d(ji,jj) = vv(ji,jj,ikbot,Nii) 
     200         END_2D 
    211201         CALL iom_put( "sbv", z2d )                ! bottom j-current 
    212202      ENDIF 
    … …  
    217207         z2d(:,:) = rau0 * e1e2t(:,:) 
    218208         DO jk = 1, jpk 
    219             z3d(:,:,jk) = wn(:,:,jk) * z2d(:,:) 
     209            z3d(:,:,jk) = ww(:,:,jk,Nii) * z2d(:,:) 
    220210         END DO 
    221211         CALL iom_put( "w_masstr" , z3d )   
    … …  
    232222      IF ( iom_use("socegrad") .OR. iom_use("socegrad2") ) THEN 
    233223         z3d(:,:,jpk) = 0. 
    234          DO jk = 1, jpkm1 
    235             DO jj = 2, jpjm1                                    ! sal gradient 
    236                DO ji = fs_2, fs_jpim1   ! vector opt. 
    237                   zztmp  = tsn(ji,jj,jk,jp_sal) 
    238                   zztmpx = ( tsn(ji+1,jj,jk,jp_sal) - zztmp ) * r1_e1u(ji,jj) + ( zztmp - tsn(ji-1,jj  ,jk,jp_sal) ) * r1_e1u(ji-1,jj) 
    239                   zztmpy = ( tsn(ji,jj+1,jk,jp_sal) - zztmp ) * r1_e2v(ji,jj) + ( zztmp - tsn(ji  ,jj-1,jk,jp_sal) ) * r1_e2v(ji,jj-1) 
    240                   z3d(ji,jj,jk) = 0.25 * ( zztmpx * zztmpx + zztmpy * zztmpy )   & 
    241                      &                 * umask(ji,jj,jk) * umask(ji-1,jj,jk) * vmask(ji,jj,jk) * umask(ji,jj-1,jk) 
    242                END DO 
    243             END DO 
    244          END DO 
     224         DO_3D_00_00( 1, jpkm1 ) 
     225            zztmp  = tsn(ji,jj,jk,jp_sal) 
     226            zztmpx = ( tsn(ji+1,jj,jk,jp_sal) - zztmp ) * r1_e1u(ji,jj) + ( zztmp - tsn(ji-1,jj  ,jk,jp_sal) ) * r1_e1u(ji-1,jj) 
     227            zztmpy = ( tsn(ji,jj+1,jk,jp_sal) - zztmp ) * r1_e2v(ji,jj) + ( zztmp - tsn(ji  ,jj-1,jk,jp_sal) ) * r1_e2v(ji,jj-1) 
     228            z3d(ji,jj,jk) = 0.25 * ( zztmpx * zztmpx + zztmpy * zztmpy )   & 
     229               &                 * umask(ji,jj,jk) * umask(ji-1,jj,jk) * vmask(ji,jj,jk) * umask(ji,jj-1,jk) 
     230         END_3D 
    245231         CALL lbc_lnk( 'diawri', z3d, 'T', 1. ) 
    246232         CALL iom_put( "socegrad2",  z3d )          ! square of module of sal gradient 
    … …  
    250236          
    251237      IF ( iom_use("sstgrad") .OR. iom_use("sstgrad2") ) THEN 
    252          DO jj = 2, jpjm1                                    ! sst gradient 
    253             DO ji = fs_2, fs_jpim1   ! vector opt. 
    254                zztmp  = tsn(ji,jj,1,jp_tem) 
    255                zztmpx = ( tsn(ji+1,jj,1,jp_tem) - zztmp ) * r1_e1u(ji,jj) + ( zztmp - tsn(ji-1,jj  ,1,jp_tem) ) * r1_e1u(ji-1,jj) 
    256                zztmpy = ( tsn(ji,jj+1,1,jp_tem) - zztmp ) * r1_e2v(ji,jj) + ( zztmp - tsn(ji  ,jj-1,1,jp_tem) ) * r1_e2v(ji,jj-1) 
    257                z2d(ji,jj) = 0.25 * ( zztmpx * zztmpx + zztmpy * zztmpy )   & 
    258                   &              * umask(ji,jj,1) * umask(ji-1,jj,1) * vmask(ji,jj,1) * umask(ji,jj-1,1) 
    259             END DO 
    260          END DO 
     238         DO_2D_00_00 
     239            zztmp  = tsn(ji,jj,1,jp_tem) 
     240            zztmpx = ( tsn(ji+1,jj,1,jp_tem) - zztmp ) * r1_e1u(ji,jj) + ( zztmp - tsn(ji-1,jj  ,1,jp_tem) ) * r1_e1u(ji-1,jj) 
     241            zztmpy = ( tsn(ji,jj+1,1,jp_tem) - zztmp ) * r1_e2v(ji,jj) + ( zztmp - tsn(ji  ,jj-1,1,jp_tem) ) * r1_e2v(ji,jj-1) 
     242            z2d(ji,jj) = 0.25 * ( zztmpx * zztmpx + zztmpy * zztmpy )   & 
     243               &              * umask(ji,jj,1) * umask(ji-1,jj,1) * vmask(ji,jj,1) * umask(ji,jj-1,1) 
     244         END_2D 
    261245         CALL lbc_lnk( 'diawri', z2d, 'T', 1. ) 
    262246         CALL iom_put( "sstgrad2",  z2d )          ! square of module of sst gradient 
    … …  
    268252      IF( iom_use("heatc") ) THEN 
    269253         z2d(:,:)  = 0._wp  
    270          DO jk = 1, jpkm1 
    271             DO jj = 1, jpj 
    272                DO ji = 1, jpi 
    273                   z2d(ji,jj) = z2d(ji,jj) + e3t_n(ji,jj,jk) * tsn(ji,jj,jk,jp_tem) * tmask(ji,jj,jk) 
    274                END DO 
    275             END DO 
    276          END DO 
     254         DO_3D_11_11( 1, jpkm1 ) 
     255            z2d(ji,jj) = z2d(ji,jj) + e3t_n(ji,jj,jk) * tsn(ji,jj,jk,jp_tem) * tmask(ji,jj,jk) 
     256         END_3D 
    277257         CALL iom_put( "heatc", rau0_rcp * z2d )   ! vertically integrated heat content (J/m2) 
    278258      ENDIF 
    … …  
    280260      IF( iom_use("saltc") ) THEN 
    281261         z2d(:,:)  = 0._wp  
    282          DO jk = 1, jpkm1 
    283             DO jj = 1, jpj 
    284                DO ji = 1, jpi 
    285                   z2d(ji,jj) = z2d(ji,jj) + e3t_n(ji,jj,jk) * tsn(ji,jj,jk,jp_sal) * tmask(ji,jj,jk) 
    286                END DO 
    287             END DO 
    288          END DO 
     262         DO_3D_11_11( 1, jpkm1 ) 
     263            z2d(ji,jj) = z2d(ji,jj) + e3t_n(ji,jj,jk) * tsn(ji,jj,jk,jp_sal) * tmask(ji,jj,jk) 
     264         END_3D 
    289265         CALL iom_put( "saltc", rau0 * z2d )          ! vertically integrated salt content (PSU*kg/m2) 
    290266      ENDIF 
    … …  
    292268      IF( iom_use("salt2c") ) THEN 
    293269         z2d(:,:)  = 0._wp  
    294          DO jk = 1, jpkm1 
    295             DO jj = 1, jpj 
    296                DO ji = 1, jpi 
    297                   z2d(ji,jj) = z2d(ji,jj) + e3t_n(ji,jj,jk) * tsn(ji,jj,jk,jp_sal) * tsn(ji,jj,jk,jp_sal) * tmask(ji,jj,jk) 
    298                END DO 
    299             END DO 
    300          END DO 
     270         DO_3D_11_11( 1, jpkm1 ) 
     271            z2d(ji,jj) = z2d(ji,jj) + e3t_n(ji,jj,jk) * tsn(ji,jj,jk,jp_sal) * tsn(ji,jj,jk,jp_sal) * tmask(ji,jj,jk) 
     272         END_3D 
    301273         CALL iom_put( "salt2c", rau0 * z2d )          ! vertically integrated squared salt content (PSU*kg/m2) 
    302274      ENDIF 
    … …  
    304276      IF ( iom_use("eken") .OR. iom_use("eken_int") ) THEN 
    305277         z3d(:,:,jpk) = 0._wp  
    306          DO jk = 1, jpkm1 
    307             DO jj = 2, jpjm1 
    308                DO ji = 2, jpim1 
    309                   zztmpx = 0.5 * ( un(ji-1,jj  ,jk) + un(ji,jj,jk) ) 
    310                   zztmpy = 0.5 * ( vn(ji  ,jj-1,jk) + vn(ji,jj,jk) ) 
    311                   z3d(ji,jj,jk) = 0.5 * ( zztmpx*zztmpx + zztmpy*zztmpy ) 
    312                END DO 
    313             END DO 
    314          END DO 
     278         DO_3D_00_00( 1, jpkm1 ) 
     279            zztmpx = 0.5 * ( uu(ji-1,jj  ,jk,Nii) + uu(ji,jj,jk,Nii) ) 
     280            zztmpy = 0.5 * ( vv(ji  ,jj-1,jk,Nii) + vv(ji,jj,jk,Nii) ) 
     281            z3d(ji,jj,jk) = 0.5 * ( zztmpx*zztmpx + zztmpy*zztmpy ) 
     282         END_3D 
    315283         CALL lbc_lnk( 'diawri', z3d, 'T', 1. ) 
    316284         CALL iom_put( "eken", z3d )                 ! kinetic energy 
    317285 
    318286         z2d(:,:)  = 0._wp  
    319          DO jk = 1, jpkm1 
    320             DO jj = 1, jpj 
    321                DO ji = 1, jpi 
    322                   z2d(ji,jj) = z2d(ji,jj) + e3t_n(ji,jj,jk) * z3d(ji,jj,jk) * e1e2t(ji,jj) * tmask(ji,jj,jk) 
    323                END DO 
    324             END DO 
    325          END DO 
     287         DO_3D_11_11( 1, jpkm1 ) 
     288            z2d(ji,jj) = z2d(ji,jj) + e3t_n(ji,jj,jk) * z3d(ji,jj,jk) * e1e2t(ji,jj) * tmask(ji,jj,jk) 
     289         END_3D 
    326290         CALL iom_put( "eken_int", z2d )   ! vertically integrated kinetic energy 
    327291      ENDIF 
    … …  
    332296          
    333297         z3d(:,:,jpk) = 0._wp  
    334          DO jk = 1, jpkm1 
    335             DO jj = 1, jpjm1 
    336                DO ji = 1, fs_jpim1   ! vector opt. 
    337                   z3d(ji,jj,jk) = (  e2v(ji+1,jj  ) * vn(ji+1,jj  ,jk) - e2v(ji,jj) * vn(ji,jj,jk)    & 
    338                      &             - e1u(ji  ,jj+1) * un(ji  ,jj+1,jk) + e1u(ji,jj) * un(ji,jj,jk)  ) * r1_e1e2f(ji,jj) 
    339                END DO 
    340             END DO 
    341          END DO 
     298         DO_3D_10_10( 1, jpkm1 ) 
     299            z3d(ji,jj,jk) = (  e2v(ji+1,jj  ) * vv(ji+1,jj  ,jk,Nii) - e2v(ji,jj) * vv(ji,jj,jk,Nii)    & 
     300               &             - e1u(ji  ,jj+1) * uu(ji  ,jj+1,jk,Nii) + e1u(ji,jj) * uu(ji,jj,jk,Nii)  ) * r1_e1e2f(ji,jj) 
     301         END_3D 
    342302         CALL lbc_lnk( 'diawri', z3d, 'F', 1. ) 
    343303         CALL iom_put( "relvor", z3d )                  ! relative vorticity 
    344304 
    345          DO jk = 1, jpkm1 
    346             DO jj = 1, jpj 
    347                DO ji = 1, jpi 
    348                   z3d(ji,jj,jk) = ff_f(ji,jj) + z3d(ji,jj,jk)  
    349                END DO 
    350             END DO 
    351          END DO 
     305         DO_3D_11_11( 1, jpkm1 ) 
     306            z3d(ji,jj,jk) = ff_f(ji,jj) + z3d(ji,jj,jk)  
     307         END_3D 
    352308         CALL iom_put( "absvor", z3d )                  ! absolute vorticity 
    353309 
    354          DO jk = 1, jpkm1 
    355             DO jj = 1, jpjm1 
    356                DO ji = 1, fs_jpim1   ! vector opt. 
    357                   ze3  = (  e3t_n(ji,jj+1,jk)*tmask(ji,jj+1,jk) + e3t_n(ji+1,jj+1,jk)*tmask(ji+1,jj+1,jk)   & 
    358                      &    + e3t_n(ji,jj  ,jk)*tmask(ji,jj  ,jk) + e3t_n(ji+1,jj  ,jk)*tmask(ji+1,jj  ,jk)  ) 
    359                   IF( ze3 /= 0._wp ) THEN   ;   ze3 = 4._wp / ze3 
    360                   ELSE                      ;   ze3 = 0._wp 
    361                   ENDIF 
    362                   z3d(ji,jj,jk) = ze3 * z3d(ji,jj,jk)  
    363                END DO 
    364             END DO 
    365          END DO 
     310         DO_3D_10_10( 1, jpkm1 ) 
     311            ze3  = (  e3t_n(ji,jj+1,jk)*tmask(ji,jj+1,jk) + e3t_n(ji+1,jj+1,jk)*tmask(ji+1,jj+1,jk)   & 
     312               &    + e3t_n(ji,jj  ,jk)*tmask(ji,jj  ,jk) + e3t_n(ji+1,jj  ,jk)*tmask(ji+1,jj  ,jk)  ) 
     313            IF( ze3 /= 0._wp ) THEN   ;   ze3 = 4._wp / ze3 
     314            ELSE                      ;   ze3 = 0._wp 
     315            ENDIF 
     316            z3d(ji,jj,jk) = ze3 * z3d(ji,jj,jk)  
     317         END_3D 
    366318         CALL lbc_lnk( 'diawri', z3d, 'F', 1. ) 
    367319         CALL iom_put( "potvor", z3d )                  ! potential vorticity 
    … …  
    374326         z2d(:,:) = 0.e0 
    375327         DO jk = 1, jpkm1 
    376             z3d(:,:,jk) = rau0 * un(:,:,jk) * e2u(:,:) * e3u_n(:,:,jk) * umask(:,:,jk) 
     328            z3d(:,:,jk) = rau0 * uu(:,:,jk,Nii) * e2u(:,:) * e3u_n(:,:,jk) * umask(:,:,jk) 
    377329            z2d(:,:) = z2d(:,:) + z3d(:,:,jk) 
    378330         END DO 
    … …  
    383335      IF( iom_use("u_heattr") ) THEN 
    384336         z2d(:,:) = 0._wp  
    385          DO jk = 1, jpkm1 
    386             DO jj = 2, jpjm1 
    387                DO ji = fs_2, fs_jpim1   ! vector opt. 
    388                   z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) * ( tsn(ji,jj,jk,jp_tem) + tsn(ji+1,jj,jk,jp_tem) ) 
    389                END DO 
    390             END DO 
    391          END DO 
     337         DO_3D_00_00( 1, jpkm1 ) 
     338            z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) * ( tsn(ji,jj,jk,jp_tem) + tsn(ji+1,jj,jk,jp_tem) ) 
     339         END_3D 
    392340         CALL lbc_lnk( 'diawri', z2d, 'U', -1. ) 
    393341         CALL iom_put( "u_heattr", 0.5*rcp * z2d )    ! heat transport in i-direction 
    … …  
    396344      IF( iom_use("u_salttr") ) THEN 
    397345         z2d(:,:) = 0.e0  
    398          DO jk = 1, jpkm1 
    399             DO jj = 2, jpjm1 
    400                DO ji = fs_2, fs_jpim1   ! vector opt. 
    401                   z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) * ( tsn(ji,jj,jk,jp_sal) + tsn(ji+1,jj,jk,jp_sal) ) 
    402                END DO 
    403             END DO 
    404          END DO 
     346         DO_3D_00_00( 1, jpkm1 ) 
     347            z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) * ( tsn(ji,jj,jk,jp_sal) + tsn(ji+1,jj,jk,jp_sal) ) 
     348         END_3D 
    405349         CALL lbc_lnk( 'diawri', z2d, 'U', -1. ) 
    406350         CALL iom_put( "u_salttr", 0.5 * z2d )        ! heat transport in i-direction 
    … …  
    411355         z3d(:,:,jpk) = 0.e0 
    412356         DO jk = 1, jpkm1 
    413             z3d(:,:,jk) = rau0 * vn(:,:,jk) * e1v(:,:) * e3v_n(:,:,jk) * vmask(:,:,jk) 
     357            z3d(:,:,jk) = rau0 * vv(:,:,jk,Nii) * e1v(:,:) * e3v_n(:,:,jk) * vmask(:,:,jk) 
    414358         END DO 
    415359         CALL iom_put( "v_masstr", z3d )              ! mass transport in j-direction 
    … …  
    418362      IF( iom_use("v_heattr") ) THEN 
    419363         z2d(:,:) = 0.e0  
    420          DO jk = 1, jpkm1 
    421             DO jj = 2, jpjm1 
    422                DO ji = fs_2, fs_jpim1   ! vector opt. 
    423                   z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) * ( tsn(ji,jj,jk,jp_tem) + tsn(ji,jj+1,jk,jp_tem) ) 
    424                END DO 
    425             END DO 
    426          END DO 
     364         DO_3D_00_00( 1, jpkm1 ) 
     365            z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) * ( tsn(ji,jj,jk,jp_tem) + tsn(ji,jj+1,jk,jp_tem) ) 
     366         END_3D 
    427367         CALL lbc_lnk( 'diawri', z2d, 'V', -1. ) 
    428368         CALL iom_put( "v_heattr", 0.5*rcp * z2d )    !  heat transport in j-direction 
    … …  
    431371      IF( iom_use("v_salttr") ) THEN 
    432372         z2d(:,:) = 0._wp  
    433          DO jk = 1, jpkm1 
    434             DO jj = 2, jpjm1 
    435                DO ji = fs_2, fs_jpim1   ! vector opt. 
    436                   z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) * ( tsn(ji,jj,jk,jp_sal) + tsn(ji,jj+1,jk,jp_sal) ) 
    437                END DO 
    438             END DO 
    439          END DO 
     373         DO_3D_00_00( 1, jpkm1 ) 
     374            z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) * ( tsn(ji,jj,jk,jp_sal) + tsn(ji,jj+1,jk,jp_sal) ) 
     375         END_3D 
    440376         CALL lbc_lnk( 'diawri', z2d, 'V', -1. ) 
    441377         CALL iom_put( "v_salttr", 0.5 * z2d )        !  heat transport in j-direction 
    … …  
    444380      IF( iom_use("tosmint") ) THEN 
    445381         z2d(:,:) = 0._wp 
    446          DO jk = 1, jpkm1 
    447             DO jj = 2, jpjm1 
    448                DO ji = fs_2, fs_jpim1   ! vector opt. 
    449                   z2d(ji,jj) = z2d(ji,jj) + e3t_n(ji,jj,jk) *  tsn(ji,jj,jk,jp_tem) 
    450                END DO 
    451             END DO 
    452          END DO 
     382         DO_3D_00_00( 1, jpkm1 ) 
     383            z2d(ji,jj) = z2d(ji,jj) + e3t_n(ji,jj,jk) *  tsn(ji,jj,jk,jp_tem) 
     384         END_3D 
    453385         CALL lbc_lnk( 'diawri', z2d, 'T', -1. ) 
    454386         CALL iom_put( "tosmint", rau0 * z2d )        ! Vertical integral of temperature 
    … …  
    456388      IF( iom_use("somint") ) THEN 
    457389         z2d(:,:)=0._wp 
    458          DO jk = 1, jpkm1 
    459             DO jj = 2, jpjm1 
    460                DO ji = fs_2, fs_jpim1   ! vector opt. 
    461                   z2d(ji,jj) = z2d(ji,jj) + e3t_n(ji,jj,jk) * tsn(ji,jj,jk,jp_sal) 
    462                END DO 
    463             END DO 
    464          END DO 
     390         DO_3D_00_00( 1, jpkm1 ) 
     391            z2d(ji,jj) = z2d(ji,jj) + e3t_n(ji,jj,jk) * tsn(ji,jj,jk,jp_sal) 
     392         END_3D 
    465393         CALL lbc_lnk( 'diawri', z2d, 'T', -1. ) 
    466394         CALL iom_put( "somint", rau0 * z2d )         ! Vertical integral of salinity 

  • NEMO/branches/2020/temporary_r4_trunk/tests/CANAL/MY_SRC/usrdef_istate.F90

    r13466 r13469  
    184184         pssh(:,1) = - ff_t(:,1) / grav * pu(:,1,1) * e2t(:,1) 
    185185         DO jl=1, jpnj 
    186             DO jj=nldj, nlej 
    187                DO ji=nldi, nlei 
    188                   pssh(ji,jj) = pssh(ji,jj-1) - ff_t(ji,jj) / grav * pu(ji,jj,1) * e2t(ji,jj) 
    189                END DO 
    190             END DO 
     186            DO_2D_nldj1_nldi1 
     187               pssh(ji,jj) = pssh(ji,jj-1) - ff_t(ji,jj) / grav * pu(ji,jj,1) * e2t(ji,jj) 
     188            END_2D 
    191189            CALL lbc_lnk( 'usrdef_istate', pssh, 'T',  1. ) 
    192190         END DO 
    … …  
    203201      CASE(4)    ! geostrophic zonal pulse 
    204202    
    205          DO jj=1, jpj 
    206             DO ji=1, jpi 
    207                IF ( ABS(glamt(ji,jj)) <= zjetx ) THEN 
    208                   zdu = rn_uzonal 
    209                ELSEIF ( ABS(glamt(ji,jj)) <= zjetx + 100. ) THEN 
    210                   zdu = rn_uzonal * ( ( zjetx-ABS(glamt(ji,jj)) )/100. + 1. ) 
    211                ELSE 
    212                   zdu = 0. 
    213                END IF 
    214                IF ( ABS(gphit(ji,jj)) <= zjety ) THEN 
    215                   pssh(ji,jj) = - ff_t(ji,jj) * zdu * gphit(ji,jj) * 1.e3 / grav 
    216                   pu(ji,jj,:) = zdu 
    217                   pts(ji,jj,:,jp_sal) = zdu / rn_uzonal + 1. 
    218                ELSE 
    219                   pssh(ji,jj) = - ff_t(ji,jj) * zdu * SIGN(zjety,gphit(ji,jj)) * 1.e3 / grav  
    220                   pu(ji,jj,:) = 0. 
    221                   pts(ji,jj,:,jp_sal) = 1. 
    222                END IF 
    223             END DO 
    224          END DO 
     203         DO_2D_11_11 
     204            IF ( ABS(glamt(ji,jj)) <= zjetx ) THEN 
     205               zdu = rn_uzonal 
     206            ELSEIF ( ABS(glamt(ji,jj)) <= zjetx + 100. ) THEN 
     207               zdu = rn_uzonal * ( ( zjetx-ABS(glamt(ji,jj)) )/100. + 1. ) 
     208            ELSE 
     209               zdu = 0. 
     210            END IF 
     211            IF ( ABS(gphit(ji,jj)) <= zjety ) THEN 
     212               pssh(ji,jj) = - ff_t(ji,jj) * zdu * gphit(ji,jj) * 1.e3 / grav 
     213               pu(ji,jj,:) = zdu 
     214               pts(ji,jj,:,jp_sal) = zdu / rn_uzonal + 1. 
     215            ELSE 
     216               pssh(ji,jj) = - ff_t(ji,jj) * zdu * SIGN(zjety,gphit(ji,jj)) * 1.e3 / grav  
     217               pu(ji,jj,:) = 0. 
     218               pts(ji,jj,:,jp_sal) = 1. 
     219            END IF 
     220         END_2D 
    225221          
    226222         ! temperature: 
    … …  
    240236         zP0 = rau0 * zf0 * zumax * zlambda * SQRT(EXP(1._wp)/2._wp) 
    241237         ! 
    242          DO jj=1, jpj 
    243             DO ji=1, jpi 
    244                zx = glamt(ji,jj) * 1.e3 
    245                zy = gphit(ji,jj) * 1.e3 
    246                ! Surface pressure: P(x,y,z) = F(z) * Psurf(x,y) 
    247                zpsurf = zP0 * EXP(-(zx**2+zy**2)*zr_lambda2) - rau0 * ff_t(ji,jj) * rn_uzonal * zy 
    248                ! Sea level: 
    249                pssh(ji,jj) = 0. 
    250                DO jl=1,5 
    251                   zdt = pssh(ji,jj) 
    252                   zdzF = (1._wp - EXP(zdt-zH)) / (zH - 1._wp + EXP(-zH))   ! F'(z) 
    253                   zrho1 = rau0 * (1._wp + zn2*zdt/grav) - zdzF * zpsurf / grav    ! -1/g Dz(P) = -1/g * F'(z) * Psurf(x,y) 
    254                   pssh(ji,jj) = zpsurf / (zrho1*grav) * ptmask(ji,jj,1)   ! ssh = Psurf / (Rho*g) 
    255                END DO 
    256                ! temperature: 
    257                DO jk=1,jpk 
    258                   zdt =  pdept(ji,jj,jk)  
    259                   zrho1 = rau0 * (1._wp + zn2*zdt/grav) 
    260                   IF (zdt < zH) THEN 
    261                      zdzF = (1._wp-EXP(zdt-zH)) / (zH-1._wp + EXP(-zH))   ! F'(z) 
    262                      zrho1 = zrho1 - zdzF * zpsurf / grav    ! -1/g Dz(P) = -1/g * F'(z) * Psurf(x,y) 
    263                   ENDIF 
    264                   !               pts(ji,jj,jk,jp_tem) = (20._wp + (rau0-zrho1) / 0.28_wp) * ptmask(ji,jj,jk) 
    265                   pts(ji,jj,jk,jp_tem) = (10._wp + (rau0-zrho1) / 0.28_wp) * ptmask(ji,jj,jk) 
    266                END DO 
     238         DO_2D_11_11 
     239            zx = glamt(ji,jj) * 1.e3 
     240            zy = gphit(ji,jj) * 1.e3 
     241            ! Surface pressure: P(x,y,z) = F(z) * Psurf(x,y) 
     242            zpsurf = zP0 * EXP(-(zx**2+zy**2)*zr_lambda2) - rau0 * ff_t(ji,jj) * rn_uzonal * zy 
     243            ! Sea level: 
     244            pssh(ji,jj) = 0. 
     245            DO jl=1,5 
     246               zdt = pssh(ji,jj) 
     247               zdzF = (1._wp - EXP(zdt-zH)) / (zH - 1._wp + EXP(-zH))   ! F'(z) 
     248               zrho1 = rau0 * (1._wp + zn2*zdt/grav) - zdzF * zpsurf / grav    ! -1/g Dz(P) = -1/g * F'(z) * Psurf(x,y) 
     249               pssh(ji,jj) = zpsurf / (zrho1*grav) * ptmask(ji,jj,1)   ! ssh = Psurf / (Rho*g) 
    267250            END DO 
    268          END DO 
     251            ! temperature: 
     252            DO jk=1,jpk 
     253               zdt =  pdept(ji,jj,jk)  
     254               zrho1 = rau0 * (1._wp + zn2*zdt/grav) 
     255               IF (zdt < zH) THEN 
     256                  zdzF = (1._wp-EXP(zdt-zH)) / (zH-1._wp + EXP(-zH))   ! F'(z) 
     257                  zrho1 = zrho1 - zdzF * zpsurf / grav    ! -1/g Dz(P) = -1/g * F'(z) * Psurf(x,y) 
     258               ENDIF 
     259               !               pts(ji,jj,jk,jp_tem) = (20._wp + (rau0-zrho1) / 0.28_wp) * ptmask(ji,jj,jk) 
     260               pts(ji,jj,jk,jp_tem) = (10._wp + (rau0-zrho1) / 0.28_wp) * ptmask(ji,jj,jk) 
     261            END DO 
     262         END_2D 
    269263         ! 
    270264         ! salinity:   
    … …  
    273267         ! velocities: 
    274268         za = 2._wp * zP0 / zlambda**2 
    275          DO jj = 2, jpjm1 
    276             DO ji = 2, jpim1 
    277                zx = glamu(ji,jj) * 1.e3 
    278                zy = gphiu(ji,jj) * 1.e3 
    279                DO jk=1, jpk 
    280                   zdu = 0.5_wp * (pdept(ji,jj,jk) + pdept(ji+1,jj,jk)) 
    281                   IF (zdu < zH) THEN 
    282                      zf = (zH-1._wp-zdu+EXP(zdu-zH)) / (zH-1._wp+EXP(-zH)) 
    283                      zdyPs = - za * zy * EXP(-(zx**2+zy**2)*zr_lambda2) - rau0 * ff_t(ji,jj) * rn_uzonal 
    284                      pu(ji,jj,jk) = - zf / ( rau0 * ff_t(ji,jj) ) * zdyPs * ptmask(ji,jj,jk) * ptmask(ji+1,jj,jk) 
    285                   ELSE 
    286                      pu(ji,jj,jk) = 0._wp 
    287                   ENDIF 
    288                END DO 
     269         DO_2D_00_00 
     270            zx = glamu(ji,jj) * 1.e3 
     271            zy = gphiu(ji,jj) * 1.e3 
     272            DO jk=1, jpk 
     273               zdu = 0.5_wp * (pdept(ji,jj,jk) + pdept(ji+1,jj,jk)) 
     274               IF (zdu < zH) THEN 
     275                  zf = (zH-1._wp-zdu+EXP(zdu-zH)) / (zH-1._wp+EXP(-zH)) 
     276                  zdyPs = - za * zy * EXP(-(zx**2+zy**2)*zr_lambda2) - rau0 * ff_t(ji,jj) * rn_uzonal 
     277                  pu(ji,jj,jk) = - zf / ( rau0 * ff_t(ji,jj) ) * zdyPs * ptmask(ji,jj,jk) * ptmask(ji+1,jj,jk) 
     278               ELSE 
     279                  pu(ji,jj,jk) = 0._wp 
     280               ENDIF 
    289281            END DO 
    290          END DO 
    291          ! 
    292          DO jj = 2, jpjm1 
    293             DO ji = 2, jpim1 
    294                zx = glamv(ji,jj) * 1.e3 
    295                zy = gphiv(ji,jj) * 1.e3 
    296                DO jk=1, jpk 
    297                   zdv = 0.5_wp * (pdept(ji,jj,jk) + pdept(ji,jj+1,jk)) 
    298                   IF (zdv < zH) THEN 
    299                      zf = (zH-1._wp-zdv+EXP(zdv-zH)) / (zH-1._wp+EXP(-zH)) 
    300                      zdxPs = - za * zx * EXP(-(zx**2+zy**2)*zr_lambda2) 
    301                      pv(ji,jj,jk) = zf / ( rau0 * ff_f(ji,jj) ) * zdxPs * ptmask(ji,jj,jk) * ptmask(ji,jj+1,jk) 
    302                   ELSE 
    303                      pv(ji,jj,jk) = 0._wp 
    304                   ENDIF 
    305                END DO 
     282         END_2D 
     283         ! 
     284         DO_2D_00_00 
     285            zx = glamv(ji,jj) * 1.e3 
     286            zy = gphiv(ji,jj) * 1.e3 
     287            DO jk=1, jpk 
     288               zdv = 0.5_wp * (pdept(ji,jj,jk) + pdept(ji,jj+1,jk)) 
     289               IF (zdv < zH) THEN 
     290                  zf = (zH-1._wp-zdv+EXP(zdv-zH)) / (zH-1._wp+EXP(-zH)) 
     291                  zdxPs = - za * zx * EXP(-(zx**2+zy**2)*zr_lambda2) 
     292                  pv(ji,jj,jk) = zf / ( rau0 * ff_f(ji,jj) ) * zdxPs * ptmask(ji,jj,jk) * ptmask(ji,jj+1,jk) 
     293               ELSE 
     294                  pv(ji,jj,jk) = 0._wp 
     295               ENDIF 
    306296            END DO 
    307          END DO 
     297         END_2D 
    308298         !             
    309299         CALL lbc_lnk_multi( 'usrdef_istate', pu, 'U', -1., pv, 'V', -1. ) 
Note: See TracChangeset for help on using the changeset viewer.