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 13998 for NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE – NEMO

Ignore:
Timestamp:
2020-12-02T14:55:21+01:00 (3 years ago)
Author:
techene
Message:

branch updated with trunk 13787

Location:
NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3
Files:
110 edited

Legend:

Unmodified
Added
Removed

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3

    • Property svn:externals

      •  

        old new  
        88 
        99# SETTE 
        10 ^/utils/CI/sette@13292        sette 
         10^/utils/CI/sette@13559        sette 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/BDY/bdy_oce.F90

    r12377 r13998  
    6363      REAL(wp), POINTER, DIMENSION(:,:) ::  aip    !: now ice  pond concentration 
    6464      REAL(wp), POINTER, DIMENSION(:,:) ::  hip    !: now ice  pond depth 
     65      REAL(wp), POINTER, DIMENSION(:,:) ::  hil    !: now ice  pond lid depth 
    6566#if defined key_top 
    6667      CHARACTER(LEN=20)                   :: cn_obc  !: type of boundary condition to apply 
    … …  
    115116   REAL(wp), DIMENSION(jp_bdy) ::   rice_apnd               !: pond conc.  of incoming sea ice 
    116117   REAL(wp), DIMENSION(jp_bdy) ::   rice_hpnd               !: pond thick. of incoming sea ice 
     118   REAL(wp), DIMENSION(jp_bdy) ::   rice_hlid               !: pond lid thick. of incoming sea ice 
    117119   ! 
    118120   !!---------------------------------------------------------------------- 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/BDY/bdydta.F90

    r13237 r13998  
    4343   PUBLIC   bdy_dta_init     ! routine called by nemogcm.F90 
    4444 
    45    INTEGER , PARAMETER ::   jpbdyfld  = 16    ! maximum number of files to read  
     45   INTEGER , PARAMETER ::   jpbdyfld  = 17    ! maximum number of files to read  
    4646   INTEGER , PARAMETER ::   jp_bdyssh = 1     !  
    4747   INTEGER , PARAMETER ::   jp_bdyu2d = 2     !  
    … …  
    6060   INTEGER , PARAMETER ::   jp_bdyaip = 15    !  
    6161   INTEGER , PARAMETER ::   jp_bdyhip = 16    !  
     62   INTEGER , PARAMETER ::   jp_bdyhil = 17    !  
    6263#if ! defined key_si3 
    6364   INTEGER , PARAMETER ::   jpl = 1 
    … …  
    187188                        dta_bdy(jbdy)%aip(ib,jl) =  a_ip(ii,ij,jl) * tmask(ii,ij,1)  
    188189                        dta_bdy(jbdy)%hip(ib,jl) =  h_ip(ii,ij,jl) * tmask(ii,ij,1)  
     190                        dta_bdy(jbdy)%hil(ib,jl) =  h_il(ii,ij,jl) * tmask(ii,ij,1)  
    189191                     END DO 
    190192                  END DO 
    … …  
    289291            IF( TRIM(bf_alias(jp_bdytsu)%clrootname) == 'NOT USED' )   bf_alias(jp_bdytsu)%fnow(:,1,:) = rice_tem (jbdy) 
    290292            IF( TRIM(bf_alias(jp_bdys_i)%clrootname) == 'NOT USED' )   bf_alias(jp_bdys_i)%fnow(:,1,:) = rice_sal (jbdy) 
    291             IF( TRIM(bf_alias(jp_bdyaip)%clrootname) == 'NOT USED' )   bf_alias(jp_bdyaip)%fnow(:,1,:) = rice_apnd(jbdy) * & ! rice_apnd is the pond fraction 
    292                &                                                                         bf_alias(jp_bdya_i)%fnow(:,1,:)     !   ( a_ip = rice_apnd * a_i ) 
     293            IF( TRIM(bf_alias(jp_bdyaip)%clrootname) == 'NOT USED' )   &              ! rice_apnd is the pond fraction 
     294               &   bf_alias(jp_bdyaip)%fnow(:,1,:) = rice_apnd(jbdy) * bf_alias(jp_bdya_i)%fnow(:,1,:)   ! ( a_ip = rice_apnd*a_i ) 
    293295            IF( TRIM(bf_alias(jp_bdyhip)%clrootname) == 'NOT USED' )   bf_alias(jp_bdyhip)%fnow(:,1,:) = rice_hpnd(jbdy) 
    294              
     296            IF( TRIM(bf_alias(jp_bdyhil)%clrootname) == 'NOT USED' )   bf_alias(jp_bdyhil)%fnow(:,1,:) = rice_hlid(jbdy) 
     297 
    295298            ! if T_i is read and not T_su, set T_su = T_i 
    296299            IF( TRIM(bf_alias(jp_bdyt_i)%clrootname) /= 'NOT USED' .AND. TRIM(bf_alias(jp_bdytsu)%clrootname) == 'NOT USED' ) & 
    … …  
    316319               bf_alias(jp_bdyaip)%fnow(:,1,:) = 0._wp 
    317320               bf_alias(jp_bdyhip)%fnow(:,1,:) = 0._wp 
     321               bf_alias(jp_bdyhil)%fnow(:,1,:) = 0._wp 
     322            ENDIF 
     323            IF ( .NOT.ln_pnd_lids ) THEN 
     324               bf_alias(jp_bdyhil)%fnow(:,1,:) = 0._wp 
    318325            ENDIF 
    319326             
    … …  
    321328            ipl = SIZE(bf_alias(jp_bdya_i)%fnow, 3)             
    322329            IF( ipl /= jpl ) THEN      ! ice: convert N-cat fields (input) into jpl-cat (output) 
    323                CALL ice_var_itd( bf_alias(jp_bdyh_i)%fnow(:,1,:), bf_alias(jp_bdyh_s)%fnow(:,1,:), bf_alias(jp_bdya_i)%fnow(:,1,:), & 
    324                   &              dta_alias%h_i                  , dta_alias%h_s                  , dta_alias%a_i                  , & 
    325                   &              bf_alias(jp_bdyt_i)%fnow(:,1,:), bf_alias(jp_bdyt_s)%fnow(:,1,:), & 
    326                   &              bf_alias(jp_bdytsu)%fnow(:,1,:), bf_alias(jp_bdys_i)%fnow(:,1,:), & 
    327                   &              bf_alias(jp_bdyaip)%fnow(:,1,:), bf_alias(jp_bdyhip)%fnow(:,1,:), & 
    328                   &              dta_alias%t_i                  , dta_alias%t_s                  , & 
    329                   &              dta_alias%tsu                  , dta_alias%s_i                  , & 
    330                   &              dta_alias%aip                  , dta_alias%hip ) 
     330               CALL ice_var_itd( bf_alias(jp_bdyh_i)%fnow(:,1,:), bf_alias(jp_bdyh_s)%fnow(:,1,:), bf_alias(jp_bdya_i)%fnow(:,1,:), & ! in 
     331                  &              dta_alias%h_i                  , dta_alias%h_s                  , dta_alias%a_i                  , & ! out 
     332                  &              bf_alias(jp_bdyt_i)%fnow(:,1,:), bf_alias(jp_bdyt_s)%fnow(:,1,:), &                                  ! in (optional) 
     333                  &              bf_alias(jp_bdytsu)%fnow(:,1,:), bf_alias(jp_bdys_i)%fnow(:,1,:), &                                  ! in     - 
     334                  &              bf_alias(jp_bdyaip)%fnow(:,1,:), bf_alias(jp_bdyhip)%fnow(:,1,:), bf_alias(jp_bdyhil)%fnow(:,1,:), & ! in     - 
     335                  &              dta_alias%t_i                  , dta_alias%t_s                  , &                                  ! out    - 
     336                  &              dta_alias%tsu                  , dta_alias%s_i                  , &                                  ! out    - 
     337                  &              dta_alias%aip                  , dta_alias%hip                  , dta_alias%hil )                    ! out    - 
    331338            ENDIF 
    332339         ENDIF 
    … …  
    374381      !                                                         ! =F => baroclinic velocities in 3D boundary data 
    375382      LOGICAL                                ::   ln_zinterp    ! =T => requires a vertical interpolation of the bdydta 
    376       REAL(wp)                               ::   rn_ice_tem, rn_ice_sal, rn_ice_age, rn_ice_apnd, rn_ice_hpnd  
     383      REAL(wp)                               ::   rn_ice_tem, rn_ice_sal, rn_ice_age, rn_ice_apnd, rn_ice_hpnd, rn_ice_hlid 
    377384      INTEGER                                ::   ipk,ipl       ! 
    378385      INTEGER                                ::   idvar         ! variable ID 
    … …  
    387394      TYPE(FLD_N), DIMENSION(1), TARGET  ::   bn_tem, bn_sal, bn_u3d, bn_v3d   ! must be an array to be used with fld_fill 
    388395      TYPE(FLD_N), DIMENSION(1), TARGET  ::   bn_ssh, bn_u2d, bn_v2d           ! informations about the fields to be read 
    389       TYPE(FLD_N), DIMENSION(1), TARGET  ::   bn_a_i, bn_h_i, bn_h_s, bn_t_i, bn_t_s, bn_tsu, bn_s_i, bn_aip, bn_hip        
     396      TYPE(FLD_N), DIMENSION(1), TARGET  ::   bn_a_i, bn_h_i, bn_h_s, bn_t_i, bn_t_s, bn_tsu, bn_s_i, bn_aip, bn_hip, bn_hil        
    390397      TYPE(FLD_N), DIMENSION(:), POINTER ::   bn_alias                        ! must be an array to be used with fld_fill 
    391398      TYPE(FLD  ), DIMENSION(:), POINTER ::   bf_alias 
    392399      ! 
    393       NAMELIST/nambdy_dta/ cn_dir, bn_tem, bn_sal, bn_u3d, bn_v3d, bn_ssh, bn_u2d, bn_v2d  
    394       NAMELIST/nambdy_dta/ bn_a_i, bn_h_i, bn_h_s, bn_t_i, bn_t_s, bn_tsu, bn_s_i, bn_aip, bn_hip 
    395       NAMELIST/nambdy_dta/ rn_ice_tem, rn_ice_sal, rn_ice_age, rn_ice_apnd, rn_ice_hpnd 
    396       NAMELIST/nambdy_dta/ ln_full_vel, ln_zinterp 
     400      NAMELIST/nambdy_dta/ cn_dir, bn_tem, bn_sal, bn_u3d, bn_v3d, bn_ssh, bn_u2d, bn_v2d,                 & 
     401                         & bn_a_i, bn_h_i, bn_h_s, bn_t_i, bn_t_s, bn_tsu, bn_s_i, bn_aip, bn_hip, bn_hil, & 
     402                         & rn_ice_tem, rn_ice_sal, rn_ice_age, rn_ice_apnd, rn_ice_hpnd, rn_ice_hlid,      & 
     403                         & ln_full_vel, ln_zinterp 
    397404      !!--------------------------------------------------------------------------- 
    398405      ! 
    … …  
    464471#if defined key_si3 
    465472         IF( .NOT.ln_pnd ) THEN 
    466             rn_ice_apnd = 0. ; rn_ice_hpnd = 0. 
    467             CALL ctl_warn( 'rn_ice_apnd & rn_ice_hpnd = 0 when no ponds' ) 
     473            rn_ice_apnd = 0. ; rn_ice_hpnd = 0. ; rn_ice_hlid = 0. 
     474            CALL ctl_warn( 'rn_ice_apnd & rn_ice_hpnd = 0 & rn_ice_hlid = 0 when no ponds' ) 
     475         ENDIF 
     476         IF( .NOT.ln_pnd_lids ) THEN 
     477            rn_ice_hlid = 0. 
    468478         ENDIF 
    469479#endif 
    … …  
    475485         rice_apnd(jbdy) = rn_ice_apnd 
    476486         rice_hpnd(jbdy) = rn_ice_hpnd 
    477           
     487         rice_hlid(jbdy) = rn_ice_hlid 
     488 
    478489          
    479490         DO jfld = 1, jpbdyfld 
    … …  
    576587            IF(  jfld == jp_bdya_i .OR. jfld == jp_bdyh_i .OR. jfld == jp_bdyh_s .OR. & 
    577588               & jfld == jp_bdyt_i .OR. jfld == jp_bdyt_s .OR. jfld == jp_bdytsu .OR. & 
    578                & jfld == jp_bdys_i .OR. jfld == jp_bdyaip .OR. jfld == jp_bdyhip     ) THEN 
     589               & jfld == jp_bdys_i .OR. jfld == jp_bdyaip .OR. jfld == jp_bdyhip .OR. jfld == jp_bdyhil ) THEN 
    579590               igrd = 1                                                    ! T point 
    580591               ipk = ipl                                                   ! jpl-cat data 
    … …  
    627638               bf_alias => bf(jp_bdyhip,jbdy:jbdy)                         ! alias for hip structure of bdy number jbdy 
    628639               bn_alias => bn_hip                                          ! alias for hip structure of nambdy_dta  
     640            ENDIF 
     641            IF( jfld == jp_bdyhil ) THEN 
     642               cl3 = 'hil' 
     643               bf_alias => bf(jp_bdyhil,jbdy:jbdy)                         ! alias for hil structure of bdy number jbdy 
     644               bn_alias => bn_hil                                          ! alias for hil structure of nambdy_dta  
    629645            ENDIF 
    630646 
    … …  
    696712                  ENDIF 
    697713               ENDIF 
     714               IF( jfld == jp_bdyhil ) THEN 
     715                  IF( ipk == jpl ) THEN   ;   dta_bdy(jbdy)%hil => bf_alias(1)%fnow(:,1,:) 
     716                  ELSE                    ;   ALLOCATE( dta_bdy(jbdy)%hil(iszdim,jpl) ) 
     717                  ENDIF 
     718               ENDIF 
    698719            ENDIF 
    699720 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/BDY/bdyice.F90

    r13226 r13998  
    6161      !!---------------------------------------------------------------------- 
    6262      ! controls 
    63       IF( ln_timing    )   CALL timing_start('bdy_ice_thd')                                                            ! timing 
    64       IF( ln_icediachk )   CALL ice_cons_hsm(0,'bdy_ice_thd', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft) ! conservation 
    65       IF( ln_icediachk )   CALL ice_cons2D  (0,'bdy_ice_thd',  diag_v,  diag_s,  diag_t,  diag_fv,  diag_fs,  diag_ft) ! conservation 
     63      IF( ln_timing )   CALL timing_start('bdy_ice_thd')   ! timing 
    6664      ! 
    6765      CALL ice_var_glo2eqv 
    … …  
    9492         IF( ANY(llsend1) .OR. ANY(llrecv1) ) THEN   ! if need to send/recv in at least one direction 
    9593            ! exchange 3d arrays 
    96             CALL lbc_lnk_multi( 'bdyice', a_i , 'T', 1.0_wp, h_i , 'T', 1.0_wp, h_s , 'T', 1.0_wp, oa_i, 'T', 1.0_wp & 
    97                  &                      , a_ip, 'T', 1.0_wp, v_ip, 'T', 1.0_wp, s_i , 'T', 1.0_wp, t_su, 'T', 1.0_wp & 
    98                  &                      , v_i , 'T', 1.0_wp, v_s , 'T', 1.0_wp, sv_i, 'T', 1.0_wp                & 
    99                  &                      , kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1      ) 
     94            CALL lbc_lnk_multi('bdyice', a_i , 'T', 1._wp, h_i , 'T', 1._wp, h_s , 'T', 1._wp, oa_i, 'T', 1._wp                  & 
     95               &                       , s_i , 'T', 1._wp, t_su, 'T', 1._wp, v_i , 'T', 1._wp, v_s , 'T', 1._wp, sv_i, 'T', 1._wp & 
     96               &                       , a_ip, 'T', 1._wp, v_ip, 'T', 1._wp, v_il, 'T', 1._wp                                     & 
     97               &                       , kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) 
    10098            ! exchange 4d arrays :   third dimension = 1   and then   third dimension = jpk 
    101             CALL lbc_lnk_multi( 'bdyice', t_s , 'T', 1.0_wp, e_s , 'T', 1.0_wp, kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) 
    102             CALL lbc_lnk_multi( 'bdyice', t_i , 'T', 1.0_wp, e_i , 'T', 1.0_wp, kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) 
     99            CALL lbc_lnk_multi('bdyice', t_s , 'T', 1._wp, e_s , 'T', 1._wp, kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) 
     100            CALL lbc_lnk_multi('bdyice', t_i , 'T', 1._wp, e_i , 'T', 1._wp, kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) 
    103101         END IF 
    104102      END DO   ! ir 
    … …  
    110108      ! 
    111109      ! controls 
    112       IF( ln_icectl    )   CALL ice_prt     ( kt, iiceprt, jiceprt, 1, ' - ice thermo bdy - ' )                        ! prints 
    113       IF( ln_icediachk )   CALL ice_cons_hsm(1,'bdy_ice_thd', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft) ! conservation 
    114       IF( ln_icediachk )   CALL ice_cons2D  (1,'bdy_ice_thd',  diag_v,  diag_s,  diag_t,  diag_fv,  diag_fs,  diag_ft) ! conservation 
    115       IF( ln_timing    )   CALL timing_stop ('bdy_ice_thd')                                                            ! timing 
     110      IF( ln_icectl )   CALL ice_prt     ( kt, iiceprt, jiceprt, 1, ' - ice thermo bdy - ' )   ! prints 
     111      IF( ln_timing )   CALL timing_stop ('bdy_ice_thd')                                       ! timing 
    116112      ! 
    117113   END SUBROUTINE bdy_ice 
    … …  
    163159            a_ip(ji,jj,  jl) = ( a_ip(ji,jj,  jl) * zwgt1 + dta%aip(i_bdy,jl) * zwgt ) * tmask(ji,jj,1)  ! Ice  pond concentration 
    164160            h_ip(ji,jj,  jl) = ( h_ip(ji,jj,  jl) * zwgt1 + dta%hip(i_bdy,jl) * zwgt ) * tmask(ji,jj,1)  ! Ice  pond depth 
     161            h_il(ji,jj,  jl) = ( h_il(ji,jj,  jl) * zwgt1 + dta%hil(i_bdy,jl) * zwgt ) * tmask(ji,jj,1)  ! Ice  pond lid depth 
    165162            ! 
    166163            sz_i(ji,jj,:,jl) = s_i(ji,jj,jl) 
    … …  
    170167               a_ip(ji,jj,jl) = 0._wp 
    171168               h_ip(ji,jj,jl) = 0._wp 
     169               h_il(ji,jj,jl) = 0._wp 
     170            ENDIF 
     171 
     172            IF( .NOT.ln_pnd_lids ) THEN 
     173               h_il(ji,jj,jl) = 0._wp 
    172174            ENDIF 
    173175            ! 
    … …  
    231233               a_ip(ji,jj,  jl) = a_ip(ib,jb,  jl) 
    232234               h_ip(ji,jj,  jl) = h_ip(ib,jb,  jl) 
     235               h_il(ji,jj,  jl) = h_il(ib,jb,  jl) 
    233236               ! 
    234237               sz_i(ji,jj,:,jl) = sz_i(ib,jb,:,jl) 
    … …  
    265268               ! 
    266269               ! melt ponds 
    267                IF( a_i(ji,jj,jl) > epsi10 ) THEN 
    268                   a_ip_frac(ji,jj,jl) = a_ip(ji,jj,jl) / a_i (ji,jj,jl) 
    269                ELSE 
    270                   a_ip_frac(ji,jj,jl) = 0._wp 
    271                ENDIF 
    272270               v_ip(ji,jj,jl) = h_ip(ji,jj,jl) * a_ip(ji,jj,jl) 
     271               v_il(ji,jj,jl) = h_il(ji,jj,jl) * a_ip(ji,jj,jl) 
    273272               ! 
    274273            ELSE   ! no ice at the boundary 
    … …  
    278277               h_s (ji,jj,  jl) = 0._wp 
    279278               oa_i(ji,jj,  jl) = 0._wp 
    280                a_ip(ji,jj,  jl) = 0._wp 
    281                v_ip(ji,jj,  jl) = 0._wp 
    282279               t_su(ji,jj,  jl) = rt0 
    283280               t_s (ji,jj,:,jl) = rt0 
    284281               t_i (ji,jj,:,jl) = rt0  
    285282 
    286                a_ip_frac(ji,jj,jl) = 0._wp 
    287                h_ip     (ji,jj,jl) = 0._wp 
    288                a_ip     (ji,jj,jl) = 0._wp 
    289                v_ip     (ji,jj,jl) = 0._wp 
     283               a_ip(ji,jj,jl) = 0._wp 
     284               h_ip(ji,jj,jl) = 0._wp 
     285               h_il(ji,jj,jl) = 0._wp 
    290286                
    291287               IF( nn_icesal == 1 ) THEN     ! if constant salinity 
    … …  
    303299               e_s (ji,jj,:,jl) = 0._wp 
    304300               e_i (ji,jj,:,jl) = 0._wp 
     301               v_ip(ji,jj,  jl) = 0._wp 
     302               v_il(ji,jj,  jl) = 0._wp 
    305303 
    306304            ENDIF 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/BDY/bdyini.F90

    r13286 r13998  
    786786                  ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 
    787787                  ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 
    788                   IF(  mig(ii) > 2 .AND. mig(ii) < jpiglo-2 .AND. mjg(ij) > 2 .AND. mjg(ij) < jpjglo-2  ) THEN 
     788                  IF(  mig0(ii) > 2 .AND. mig0(ii) < Ni0glo-2 .AND. mjg0(ij) > 2 .AND. mjg0(ij) < Nj0glo-2  ) THEN 
    789789                     WRITE(ctmp1,*) ' Orlanski is not safe when the open boundaries are on the interior of the computational domain' 
    790790                     CALL ctl_stop( ctmp1 ) 
    … …  
    10711071   SUBROUTINE bdy_read_seg( kb_bdy, knblendta )  
    10721072      !!---------------------------------------------------------------------- 
    1073       !!                 ***  ROUTINE bdy_coords_seg  *** 
     1073      !!                 ***  ROUTINE bdy_read_seg  *** 
    10741074      !! 
    10751075      !! ** Purpose :  build bdy coordinates with segments defined in namelist 
    … …  
    11111111      CASE( 'N' ) 
    11121112         IF( nbdyind == -1 ) THEN  ! Automatic boundary definition: if nbdysegX = -1 
    1113             nbdyind  = jpjglo - 2  ! set boundary to whole side of model domain. 
     1113            nbdyind  = Nj0glo - 2  ! set boundary to whole side of model domain. 
    11141114            nbdybeg  = 2 
    1115             nbdyend  = jpiglo - 1 
     1115            nbdyend  = Ni0glo - 1 
    11161116         ENDIF 
    11171117         nbdysegn = nbdysegn + 1 
    11181118         npckgn(nbdysegn) = kb_bdy ! Save bdy package number 
    1119          jpjnob(nbdysegn) = nbdyind 
     1119         jpjnob(nbdysegn) = nbdyind  
    11201120         jpindt(nbdysegn) = nbdybeg 
    11211121         jpinft(nbdysegn) = nbdyend 
    … …  
    11251125            nbdyind  = 2           ! set boundary to whole side of model domain. 
    11261126            nbdybeg  = 2 
    1127             nbdyend  = jpiglo - 1 
     1127            nbdyend  = Ni0glo - 1 
    11281128         ENDIF 
    11291129         nbdysegs = nbdysegs + 1 
    … …  
    11351135      CASE( 'E' ) 
    11361136         IF( nbdyind == -1 ) THEN  ! Automatic boundary definition: if nbdysegX = -1 
    1137             nbdyind  = jpiglo - 2  ! set boundary to whole side of model domain. 
     1137            nbdyind  = Ni0glo - 2  ! set boundary to whole side of model domain. 
    11381138            nbdybeg  = 2 
    1139             nbdyend  = jpjglo - 1 
     1139            nbdyend  = Nj0glo - 1 
    11401140         ENDIF 
    11411141         nbdysege = nbdysege + 1  
    … …  
    11491149            nbdyind  = 2           ! set boundary to whole side of model domain. 
    11501150            nbdybeg  = 2 
    1151             nbdyend  = jpjglo - 1 
     1151            nbdyend  = Nj0glo - 1 
    11521152         ENDIF 
    11531153         nbdysegw = nbdysegw + 1 
    … …  
    11921192      IF(lwp) WRITE(numout,*) 'Number of north segments     : ', nbdysegn 
    11931193      IF(lwp) WRITE(numout,*) 'Number of south segments     : ', nbdysegs 
     1194      ! 
    11941195      ! 1. Check bounds 
    11951196      !---------------- 
    11961197      DO ib = 1, nbdysegn 
    11971198         IF (lwp) WRITE(numout,*) '**check north seg bounds pckg: ', npckgn(ib) 
    1198          IF ((jpjnob(ib).ge.jpjglo-1).or.&  
     1199         IF ((jpjnob(ib).ge.Nj0glo-1).or.&  
    11991200            &(jpjnob(ib).le.1))        CALL ctl_stop( 'nbdyind out of domain' ) 
    12001201         IF (jpindt(ib).ge.jpinft(ib)) CALL ctl_stop( 'Bdy start index is greater than end index' ) 
    12011202         IF (jpindt(ib).lt.1     )     CALL ctl_stop( 'Start index out of domain' ) 
    1202          IF (jpinft(ib).gt.jpiglo)     CALL ctl_stop( 'End index out of domain' ) 
     1203         IF (jpinft(ib).gt.Ni0glo)     CALL ctl_stop( 'End index out of domain' ) 
    12031204      END DO 
    12041205      ! 
    12051206      DO ib = 1, nbdysegs 
    12061207         IF (lwp) WRITE(numout,*) '**check south seg bounds pckg: ', npckgs(ib) 
    1207          IF ((jpjsob(ib).ge.jpjglo-1).or.&  
     1208         IF ((jpjsob(ib).ge.Nj0glo-1).or.&  
    12081209            &(jpjsob(ib).le.1))        CALL ctl_stop( 'nbdyind out of domain' ) 
    12091210         IF (jpisdt(ib).ge.jpisft(ib)) CALL ctl_stop( 'Bdy start index is greater than end index' ) 
    12101211         IF (jpisdt(ib).lt.1     )     CALL ctl_stop( 'Start index out of domain' ) 
    1211          IF (jpisft(ib).gt.jpiglo)     CALL ctl_stop( 'End index out of domain' ) 
     1212         IF (jpisft(ib).gt.Ni0glo)     CALL ctl_stop( 'End index out of domain' ) 
    12121213      END DO 
    12131214      ! 
    12141215      DO ib = 1, nbdysege 
    12151216         IF (lwp) WRITE(numout,*) '**check east  seg bounds pckg: ', npckge(ib) 
    1216          IF ((jpieob(ib).ge.jpiglo-1).or.&  
     1217         IF ((jpieob(ib).ge.Ni0glo-1).or.&  
    12171218            &(jpieob(ib).le.1))        CALL ctl_stop( 'nbdyind out of domain' ) 
    12181219         IF (jpjedt(ib).ge.jpjeft(ib)) CALL ctl_stop( 'Bdy start index is greater than end index' ) 
    12191220         IF (jpjedt(ib).lt.1     )     CALL ctl_stop( 'Start index out of domain' ) 
    1220          IF (jpjeft(ib).gt.jpjglo)     CALL ctl_stop( 'End index out of domain' ) 
     1221         IF (jpjeft(ib).gt.Nj0glo)     CALL ctl_stop( 'End index out of domain' ) 
    12211222      END DO 
    12221223      ! 
    12231224      DO ib = 1, nbdysegw 
    12241225         IF (lwp) WRITE(numout,*) '**check west  seg bounds pckg: ', npckgw(ib) 
    1225          IF ((jpiwob(ib).ge.jpiglo-1).or.&  
     1226         IF ((jpiwob(ib).ge.Ni0glo-1).or.&  
    12261227            &(jpiwob(ib).le.1))        CALL ctl_stop( 'nbdyind out of domain' ) 
    12271228         IF (jpjwdt(ib).ge.jpjwft(ib)) CALL ctl_stop( 'Bdy start index is greater than end index' ) 
    12281229         IF (jpjwdt(ib).lt.1     )     CALL ctl_stop( 'Start index out of domain' ) 
    1229          IF (jpjwft(ib).gt.jpjglo)     CALL ctl_stop( 'End index out of domain' ) 
     1230         IF (jpjwft(ib).gt.Nj0glo)     CALL ctl_stop( 'End index out of domain' ) 
    12301231      ENDDO 
    1231       ! 
    12321232      !       
    12331233      ! 2. Look for segment crossings 
    … …  
    13781378         DO ji = 1, jpi 
    13791379            DO jj = 1, jpj              
    1380               IF( mig(ji) == jpiwob(ib) .AND. mjg(jj) == jpjwdt(ib) )   ztestmask(1) = tmask(ji,jj,1) 
    1381               IF( mig(ji) == jpiwob(ib) .AND. mjg(jj) == jpjwft(ib) )   ztestmask(2) = tmask(ji,jj,1)   
     1380              IF( mig0(ji) == jpiwob(ib) .AND. mjg0(jj) == jpjwdt(ib) )   ztestmask(1) = tmask(ji,jj,1) 
     1381              IF( mig0(ji) == jpiwob(ib) .AND. mjg0(jj) == jpjwft(ib) )   ztestmask(2) = tmask(ji,jj,1)   
    13821382            END DO 
    13831383         END DO 
    … …  
    14141414         DO ji = 1, jpi 
    14151415            DO jj = 1, jpj              
    1416               IF( mig(ji) == jpieob(ib)+1 .AND. mjg(jj) == jpjedt(ib) )   ztestmask(1) = tmask(ji,jj,1) 
    1417               IF( mig(ji) == jpieob(ib)+1 .AND. mjg(jj) == jpjeft(ib) )   ztestmask(2) = tmask(ji,jj,1)   
     1416              IF( mig0(ji) == jpieob(ib)+1 .AND. mjg0(jj) == jpjedt(ib) )   ztestmask(1) = tmask(ji,jj,1) 
     1417              IF( mig0(ji) == jpieob(ib)+1 .AND. mjg0(jj) == jpjeft(ib) )   ztestmask(2) = tmask(ji,jj,1)   
    14181418            END DO 
    14191419         END DO 
    … …  
    14501450         DO ji = 1, jpi 
    14511451            DO jj = 1, jpj              
    1452               IF( mjg(jj) == jpjsob(ib) .AND. mig(ji) == jpisdt(ib) )   ztestmask(1) = tmask(ji,jj,1) 
    1453               IF( mjg(jj) == jpjsob(ib) .AND. mig(ji) == jpisft(ib) )   ztestmask(2) = tmask(ji,jj,1)   
     1452              IF( mjg0(jj) == jpjsob(ib) .AND. mig0(ji) == jpisdt(ib) )   ztestmask(1) = tmask(ji,jj,1) 
     1453              IF( mjg0(jj) == jpjsob(ib) .AND. mig0(ji) == jpisft(ib) )   ztestmask(2) = tmask(ji,jj,1)   
    14541454            END DO 
    14551455         END DO 
    … …  
    14721472         DO ji = 1, jpi 
    14731473            DO jj = 1, jpj              
    1474                IF( mjg(jj) == jpjnob(ib)+1 .AND. mig(ji) == jpindt(ib) )   ztestmask(1) = tmask(ji,jj,1) 
    1475                IF( mjg(jj) == jpjnob(ib)+1 .AND. mig(ji) == jpinft(ib) )   ztestmask(2) = tmask(ji,jj,1)   
     1474               IF( mjg0(jj) == jpjnob(ib)+1 .AND. mig0(ji) == jpindt(ib) )   ztestmask(1) = tmask(ji,jj,1) 
     1475               IF( mjg0(jj) == jpjnob(ib)+1 .AND. mig0(ji) == jpinft(ib) )   ztestmask(2) = tmask(ji,jj,1)   
    14761476            END DO 
    14771477         END DO 
    … …  
    15261526            DO ij = jpjedt(iseg), jpjeft(iseg) 
    15271527               icount = icount + 1 
    1528                nbidta(icount, igrd, ib_bdy) = jpieob(iseg) + 2 - ir 
    1529                nbjdta(icount, igrd, ib_bdy) = ij 
     1528               nbidta(icount, igrd, ib_bdy) = jpieob(iseg) + 2 - ir + nn_hls 
     1529               nbjdta(icount, igrd, ib_bdy) = ij + nn_hls 
    15301530               nbrdta(icount, igrd, ib_bdy) = ir 
    15311531            ENDDO 
    … …  
    15381538            DO ij = jpjedt(iseg), jpjeft(iseg) 
    15391539               icount = icount + 1 
    1540                nbidta(icount, igrd, ib_bdy) = jpieob(iseg) + 1 - ir 
    1541                nbjdta(icount, igrd, ib_bdy) = ij 
     1540               nbidta(icount, igrd, ib_bdy) = jpieob(iseg) + 1 - ir + nn_hls 
     1541               nbjdta(icount, igrd, ib_bdy) = ij + nn_hls 
    15421542               nbrdta(icount, igrd, ib_bdy) = ir 
    15431543            ENDDO 
    … …  
    15511551            DO ij = jpjedt(iseg), jpjeft(iseg) 
    15521552               icount = icount + 1 
    1553                nbidta(icount, igrd, ib_bdy) = jpieob(iseg) + 2 - ir 
    1554                nbjdta(icount, igrd, ib_bdy) = ij 
     1553               nbidta(icount, igrd, ib_bdy) = jpieob(iseg) + 2 - ir + nn_hls 
     1554               nbjdta(icount, igrd, ib_bdy) = ij + nn_hls 
    15551555               nbrdta(icount, igrd, ib_bdy) = ir 
    15561556            ENDDO 
    … …  
    15711571            DO ij = jpjwdt(iseg), jpjwft(iseg) 
    15721572               icount = icount + 1 
    1573                nbidta(icount, igrd, ib_bdy) = jpiwob(iseg) + ir - 1 
    1574                nbjdta(icount, igrd, ib_bdy) = ij 
     1573               nbidta(icount, igrd, ib_bdy) = jpiwob(iseg) + ir - 1 + nn_hls 
     1574               nbjdta(icount, igrd, ib_bdy) = ij + nn_hls 
    15751575               nbrdta(icount, igrd, ib_bdy) = ir 
    15761576            ENDDO 
    … …  
    15831583            DO ij = jpjwdt(iseg), jpjwft(iseg) 
    15841584               icount = icount + 1 
    1585                nbidta(icount, igrd, ib_bdy) = jpiwob(iseg) + ir - 1 
    1586                nbjdta(icount, igrd, ib_bdy) = ij 
     1585               nbidta(icount, igrd, ib_bdy) = jpiwob(iseg) + ir - 1 + nn_hls 
     1586               nbjdta(icount, igrd, ib_bdy) = ij + nn_hls 
    15871587               nbrdta(icount, igrd, ib_bdy) = ir 
    15881588            ENDDO 
    … …  
    15961596            DO ij = jpjwdt(iseg), jpjwft(iseg) 
    15971597               icount = icount + 1 
    1598                nbidta(icount, igrd, ib_bdy) = jpiwob(iseg) + ir - 1 
    1599                nbjdta(icount, igrd, ib_bdy) = ij 
     1598               nbidta(icount, igrd, ib_bdy) = jpiwob(iseg) + ir - 1 + nn_hls 
     1599               nbjdta(icount, igrd, ib_bdy) = ij + nn_hls 
    16001600               nbrdta(icount, igrd, ib_bdy) = ir 
    16011601            ENDDO 
    … …  
    16161616            DO ii = jpindt(iseg), jpinft(iseg) 
    16171617               icount = icount + 1 
    1618                nbidta(icount, igrd, ib_bdy) = ii 
    1619                nbjdta(icount, igrd, ib_bdy) = jpjnob(iseg) + 2 - ir  
     1618               nbidta(icount, igrd, ib_bdy) = ii + nn_hls 
     1619               nbjdta(icount, igrd, ib_bdy) = jpjnob(iseg) + 2 - ir + nn_hls  
    16201620               nbrdta(icount, igrd, ib_bdy) = ir 
    16211621            ENDDO 
    … …  
    16291629            DO ii = jpindt(iseg), jpinft(iseg) 
    16301630               icount = icount + 1 
    1631                nbidta(icount, igrd, ib_bdy) = ii 
    1632                nbjdta(icount, igrd, ib_bdy) = jpjnob(iseg) + 2 - ir 
     1631               nbidta(icount, igrd, ib_bdy) = ii + nn_hls 
     1632               nbjdta(icount, igrd, ib_bdy) = jpjnob(iseg) + 2 - ir + nn_hls 
    16331633               nbrdta(icount, igrd, ib_bdy) = ir 
    16341634            ENDDO 
    … …  
    16431643            DO ii = jpindt(iseg), jpinft(iseg) 
    16441644               icount = icount + 1 
    1645                nbidta(icount, igrd, ib_bdy) = ii 
    1646                nbjdta(icount, igrd, ib_bdy) = jpjnob(iseg) + 1 - ir 
     1645               nbidta(icount, igrd, ib_bdy) = ii + nn_hls 
     1646               nbjdta(icount, igrd, ib_bdy) = jpjnob(iseg) + 1 - ir + nn_hls 
    16471647               nbrdta(icount, igrd, ib_bdy) = ir 
    16481648            ENDDO 
    … …  
    16611661            DO ii = jpisdt(iseg), jpisft(iseg) 
    16621662               icount = icount + 1 
    1663                nbidta(icount, igrd, ib_bdy) = ii 
    1664                nbjdta(icount, igrd, ib_bdy) = jpjsob(iseg) + ir - 1 
     1663               nbidta(icount, igrd, ib_bdy) = ii + nn_hls 
     1664               nbjdta(icount, igrd, ib_bdy) = jpjsob(iseg) + ir - 1 + nn_hls 
    16651665               nbrdta(icount, igrd, ib_bdy) = ir 
    16661666            ENDDO 
    … …  
    16741674            DO ii = jpisdt(iseg), jpisft(iseg) 
    16751675               icount = icount + 1 
    1676                nbidta(icount, igrd, ib_bdy) = ii 
    1677                nbjdta(icount, igrd, ib_bdy) = jpjsob(iseg) + ir - 1 
     1676               nbidta(icount, igrd, ib_bdy) = ii + nn_hls 
     1677               nbjdta(icount, igrd, ib_bdy) = jpjsob(iseg) + ir - 1 + nn_hls 
    16781678               nbrdta(icount, igrd, ib_bdy) = ir 
    16791679            ENDDO 
    … …  
    16881688            DO ii = jpisdt(iseg), jpisft(iseg) 
    16891689               icount = icount + 1 
    1690                nbidta(icount, igrd, ib_bdy) = ii 
    1691                nbjdta(icount, igrd, ib_bdy) = jpjsob(iseg) + ir - 1 
     1690               nbidta(icount, igrd, ib_bdy) = ii + nn_hls 
     1691               nbjdta(icount, igrd, ib_bdy) = jpjsob(iseg) + ir - 1 + nn_hls 
    16921692               nbrdta(icount, igrd, ib_bdy) = ir 
    16931693            ENDDO 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/BDY/bdylib.F90

    r13226 r13998  
    4444      !!---------------------------------------------------------------------- 
    4545      TYPE(OBC_INDEX),                     INTENT(in) ::   idx  ! OBC indices 
    46       REAL(wp), DIMENSION(:,:),            INTENT(in) ::   dta  ! OBC external data 
     46      REAL(wp), DIMENSION(:,:), POINTER,   INTENT(in) ::   dta  ! OBC external data 
    4747      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   phia  ! tracer trend 
    4848      !! 
    … …  
    7373      !!---------------------------------------------------------------------- 
    7474      TYPE(OBC_INDEX),                     INTENT(in) ::   idx  ! OBC indices 
    75       REAL(wp), DIMENSION(:,:),            INTENT(in) ::   dta  ! OBC external data 
     75      REAL(wp), DIMENSION(:,:), POINTER,   INTENT(in) ::   dta  ! OBC external data 
    7676      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   phia  ! tracer trend 
    7777      !! 
    … …  
    100100      !! 
    101101      !!---------------------------------------------------------------------- 
    102       TYPE(OBC_INDEX),                     INTENT(in) ::   idx  ! OBC indices 
    103       REAL(wp), DIMENSION(:,:),            INTENT(in) ::   dta  ! OBC external data 
    104       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   phib  ! before tracer field 
    105       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   phia  ! tracer trend 
    106       LOGICAL                 , OPTIONAL,  INTENT(in) ::   lrim0   ! indicate if rim 0 is treated 
    107       LOGICAL,                             INTENT(in) ::   ll_npo  ! switch for NPO version 
     102      TYPE(OBC_INDEX),                   INTENT(in   ) ::   idx  ! OBC indices 
     103      REAL(wp), DIMENSION(:,:), POINTER, INTENT(in   ) ::   dta  ! OBC external data 
     104      REAL(wp), DIMENSION(jpi,jpj,jpk),  INTENT(inout) ::   phib  ! before tracer field 
     105      REAL(wp), DIMENSION(jpi,jpj,jpk),  INTENT(inout) ::   phia  ! tracer trend 
     106      LOGICAL ,                          INTENT(in   ) ::   lrim0   ! indicate if rim 0 is treated 
     107      LOGICAL ,                          INTENT(in   ) ::   ll_npo  ! switch for NPO version 
    108108      !! 
    109109      INTEGER  ::   igrd                                    ! grid index 
    … …  
    128128      !! References:  Marchesiello, McWilliams and Shchepetkin, Ocean Modelling vol. 3 (2001)     
    129129      !!---------------------------------------------------------------------- 
    130       TYPE(OBC_INDEX),          INTENT(in   ) ::   idx      ! BDY indices 
    131       INTEGER ,                 INTENT(in   ) ::   igrd     ! grid index 
    132       REAL(wp), DIMENSION(:,:), INTENT(in   ) ::   phib     ! model before 2D field 
    133       REAL(wp), DIMENSION(:,:), INTENT(inout) ::   phia     ! model after 2D field (to be updated) 
    134       REAL(wp), DIMENSION(:)  , INTENT(in   ) ::   phi_ext  ! external forcing data 
    135       LOGICAL, OPTIONAL,        INTENT(in   ) ::   lrim0    ! indicate if rim 0 is treated 
    136       LOGICAL ,                 INTENT(in   ) ::   ll_npo   ! switch for NPO version 
     130      TYPE(OBC_INDEX),                   INTENT(in   ) ::   idx      ! BDY indices 
     131      INTEGER ,                          INTENT(in   ) ::   igrd     ! grid index 
     132      REAL(wp), DIMENSION(:,:),          INTENT(in   ) ::   phib     ! model before 2D field 
     133      REAL(wp), DIMENSION(:,:),          INTENT(inout) ::   phia     ! model after 2D field (to be updated) 
     134      REAL(wp), DIMENSION(:  ), POINTER, INTENT(in   ) ::   phi_ext  ! external forcing data 
     135      LOGICAL ,                          INTENT(in   ) ::   lrim0    ! indicate if rim 0 is treated 
     136      LOGICAL ,                          INTENT(in   ) ::   ll_npo   ! switch for NPO version 
    137137      ! 
    138138      INTEGER  ::   jb                                     ! dummy loop indices 
    … …  
    188188      END SELECT 
    189189      ! 
    190       IF( PRESENT(lrim0) ) THEN 
    191          IF( lrim0 ) THEN   ;   ibeg = 1                       ;   iend = idx%nblenrim0(igrd)   ! rim 0 
    192          ELSE               ;   ibeg = idx%nblenrim0(igrd)+1   ;   iend = idx%nblenrim(igrd)    ! rim 1 
    193          END IF 
    194       ELSE                  ;   ibeg = 1                       ;   iend = idx%nblenrim(igrd)    ! both 
    195       END IF 
     190      IF( lrim0 ) THEN   ;   ibeg = 1                       ;   iend = idx%nblenrim0(igrd)   ! rim 0 
     191      ELSE               ;   ibeg = idx%nblenrim0(igrd)+1   ;   iend = idx%nblenrim(igrd)    ! rim 1 
     192      ENDIF 
    196193      ! 
    197194      DO jb = ibeg, iend 
    … …  
    275272           &                    - (1.-zsign_ups) * zry * ( phib(iijp1,ijjp1) - phib(ii   ,ij    ) ) & 
    276273           &                    + zwgt * ( phi_ext(jb) - phib(ii,ij) ) ) / ( 1. + zrx )  
    277          end if 
     274         endif 
    278275         phia(ii,ij) = phia(ii,ij) * zmask(ii,ij) 
    279276      END DO 
    … …  
    293290      !! References:  Marchesiello, McWilliams and Shchepetkin, Ocean Modelling vol. 3 (2001)     
    294291      !!---------------------------------------------------------------------- 
    295       TYPE(OBC_INDEX),            INTENT(in   ) ::   idx      ! BDY indices 
    296       INTEGER ,                   INTENT(in   ) ::   igrd     ! grid index 
    297       REAL(wp), DIMENSION(:,:,:), INTENT(in   ) ::   phib     ! model before 3D field 
    298       REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   phia     ! model after 3D field (to be updated) 
    299       REAL(wp), DIMENSION(:,:)  , INTENT(in   ) ::   phi_ext  ! external forcing data 
    300       LOGICAL, OPTIONAL,          INTENT(in   ) ::   lrim0    ! indicate if rim 0 is treated 
    301       LOGICAL ,                   INTENT(in   ) ::   ll_npo   ! switch for NPO version 
     292      TYPE(OBC_INDEX),                     INTENT(in   ) ::   idx      ! BDY indices 
     293      INTEGER ,                            INTENT(in   ) ::   igrd     ! grid index 
     294      REAL(wp), DIMENSION(:,:,:),          INTENT(in   ) ::   phib     ! model before 3D field 
     295      REAL(wp), DIMENSION(:,:,:),          INTENT(inout) ::   phia     ! model after 3D field (to be updated) 
     296      REAL(wp), DIMENSION(:,:  ), POINTER, INTENT(in   ) ::   phi_ext  ! external forcing data 
     297      LOGICAL ,                            INTENT(in   ) ::   lrim0    ! indicate if rim 0 is treated 
     298      LOGICAL ,                            INTENT(in   ) ::   ll_npo   ! switch for NPO version 
    302299      ! 
    303300      INTEGER  ::   jb, jk                                 ! dummy loop indices 
    … …  
    353350      END SELECT 
    354351      ! 
    355       IF( PRESENT(lrim0) ) THEN 
    356          IF( lrim0 ) THEN   ;   ibeg = 1                       ;   iend = idx%nblenrim0(igrd)   ! rim 0 
    357          ELSE               ;   ibeg = idx%nblenrim0(igrd)+1   ;   iend = idx%nblenrim(igrd)    ! rim 1 
    358          END IF 
    359       ELSE                  ;   ibeg = 1                       ;   iend = idx%nblenrim(igrd)    ! both 
    360       END IF 
     352      IF( lrim0 ) THEN   ;   ibeg = 1                       ;   iend = idx%nblenrim0(igrd)   ! rim 0 
     353      ELSE               ;   ibeg = idx%nblenrim0(igrd)+1   ;   iend = idx%nblenrim(igrd)    ! rim 1 
     354      ENDIF 
    361355      ! 
    362356      DO jk = 1, jpk 
    … …  
    441435              &                       - (1.-zsign_ups) * zry * ( phib(iijp1,ijjp1,jk) - phib(ii   ,ij   ,jk) ) & 
    442436              &                       + zwgt * ( phi_ext(jb,jk) - phib(ii,ij,jk) ) ) / ( 1. + zrx )  
    443             end if 
     437            endif 
    444438            phia(ii,ij,jk) = phia(ii,ij,jk) * zmask(ii,ij,jk) 
    445439         END DO 
    … …  
    466460      REAL(wp), DIMENSION(:,:,:), INTENT(inout)  ::   phia     ! model after 3D field (to be updated), must be masked 
    467461      TYPE(OBC_INDEX),            INTENT(in   )  ::   idx      ! OBC indices 
    468       LOGICAL, OPTIONAL,          INTENT(in   )  ::   lrim0    ! indicate if rim 0 is treated 
     462      LOGICAL ,                   INTENT(in   )  ::   lrim0    ! indicate if rim 0 is treated 
    469463      !!  
    470464      REAL(wp) ::   zweight 
    … …  
    486480      END SELECT 
    487481      ! 
    488       IF( PRESENT(lrim0) ) THEN 
    489          IF( lrim0 ) THEN   ;   ibeg = 1                       ;   iend = idx%nblenrim0(igrd)   ! rim 0 
    490          ELSE               ;   ibeg = idx%nblenrim0(igrd)+1   ;   iend = idx%nblenrim(igrd)    ! rim 1 
    491          END IF 
    492       ELSE                  ;   ibeg = 1                       ;   iend = idx%nblenrim(igrd)    ! both 
    493       END IF 
     482      IF( lrim0 ) THEN   ;   ibeg = 1                       ;   iend = idx%nblenrim0(igrd)   ! rim 0 
     483      ELSE               ;   ibeg = idx%nblenrim0(igrd)+1   ;   iend = idx%nblenrim(igrd)    ! rim 1 
     484      ENDIF 
    494485      ! 
    495486      DO ib = ibeg, iend 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/BDY/bdytra.F90

    r13226 r13998  
    6161         IF( ir == 0 ) THEN   ;   llrim0 = .TRUE. 
    6262         ELSE                 ;   llrim0 = .FALSE. 
    63          END IF 
     63         ENDIF 
    6464         DO ib_bdy=1, nb_bdy 
    6565            ! 
    … …  
    6969            DO jn = 1, jpts 
    7070               ! 
    71                SELECT CASE( TRIM(cn_tra(ib_bdy)) ) 
     71               SELECT CASE( cn_tra(ib_bdy) ) 
    7272               CASE('none'        )   ;   CYCLE 
    7373               CASE('frs'         )   ! treat the whole boundary at once 
    74                   IF( ir == 0 ) CALL bdy_frs ( idx_bdy(ib_bdy),                pts(:,:,:,jn,Kaa), zdta(jn)%tra ) 
     74                  IF( ir == 0 )           CALL bdy_frs ( idx_bdy(ib_bdy),                    pts(:,:,:,jn,Kaa), zdta(jn)%tra ) 
    7575               CASE('specified'   )   ! treat the whole rim      at once 
    76                   IF( ir == 0 ) CALL bdy_spe ( idx_bdy(ib_bdy),                pts(:,:,:,jn,Kaa), zdta(jn)%tra ) 
    77                CASE('neumann'     )   ;   CALL bdy_nmn ( idx_bdy(ib_bdy), igrd         , pts(:,:,:,jn,Kaa), llrim0 )   ! tsa masked 
    78                CASE('orlanski'    )   ;   CALL bdy_orl ( idx_bdy(ib_bdy), pts(:,:,:,jn,Kbb), pts(:,:,:,jn,Kaa), & 
    79                     & zdta(jn)%tra, llrim0, ll_npo=.false. ) 
    80                CASE('orlanski_npo')   ;   CALL bdy_orl ( idx_bdy(ib_bdy), pts(:,:,:,jn,Kbb), pts(:,:,:,jn,Kaa), & 
    81                     & zdta(jn)%tra, llrim0, ll_npo=.true.  ) 
    82                CASE('runoff'      )   ;   CALL bdy_rnf ( idx_bdy(ib_bdy),                pts(:,:,:,jn,Kaa), jn, llrim0 ) 
     76                  IF( ir == 0 )           CALL bdy_spe ( idx_bdy(ib_bdy),                    pts(:,:,:,jn,Kaa), zdta(jn)%tra ) 
     77               CASE('neumann'     )   ;   CALL bdy_nmn ( idx_bdy(ib_bdy), igrd             , pts(:,:,:,jn,Kaa), llrim0 )   ! tsa masked 
     78               CASE('orlanski'    )   ;   CALL bdy_orl ( idx_bdy(ib_bdy), pts(:,:,:,jn,Kbb), pts(:,:,:,jn,Kaa), zdta(jn)%tra,   & 
     79                  &                                      llrim0, ll_npo=.FALSE. ) 
     80               CASE('orlanski_npo')   ;   CALL bdy_orl ( idx_bdy(ib_bdy), pts(:,:,:,jn,Kbb), pts(:,:,:,jn,Kaa), zdta(jn)%tra,   & 
     81                  &                                      llrim0, ll_npo=.TRUE.  ) 
     82               CASE('runoff'      )   ;   CALL bdy_rnf ( idx_bdy(ib_bdy),                    pts(:,:,:,jn,Kaa), jn, llrim0 ) 
    8383               CASE DEFAULT           ;   CALL ctl_stop( 'bdy_tra : unrecognised option for open boundaries for T and S' ) 
    8484               END SELECT 
    … …  
    8888         ! 
    8989         IF( nn_hls > 1 .AND. ir == 1 ) CYCLE   ! at least 2 halos will be corrected -> no need to correct rim 1 before rim 0 
    90          IF( nn_hls == 1 ) THEN   ;   llsend1(:) = .false.   ;   llrecv1(:) = .false.   ;   END IF 
     90         IF( nn_hls == 1 ) THEN   ;   llsend1(:) = .false.   ;   llrecv1(:) = .false.   ;   ENDIF 
    9191         DO ib_bdy=1, nb_bdy 
    92             SELECT CASE( TRIM(cn_tra(ib_bdy)) ) 
     92            SELECT CASE( cn_tra(ib_bdy) ) 
    9393            CASE('neumann','runoff') 
    9494               llsend1(:) = llsend1(:) .OR. lsend_bdyint(ib_bdy,1,:,ir)   ! possibly every direction, T points 
    … …  
    101101         IF( ANY(llsend1) .OR. ANY(llrecv1) ) THEN   ! if need to send/recv in at least one direction 
    102102            CALL lbc_lnk( 'bdytra', pts(:,:,:,jn,Kaa), 'T',  1.0_wp, kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) 
    103          END IF 
     103         ENDIF 
    104104         ! 
    105105      END DO   ! ir 
    … …  
    135135            pt(ii,ij,1:jpkm1) = 0.1 * tmask(ii,ij,1:jpkm1) 
    136136         END DO 
    137       END IF 
     137      ENDIF 
    138138      ! 
    139139   END SUBROUTINE bdy_rnf 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/C1D/dtauvd.F90

    r13295 r13998  
    158158         ENDIF 
    159159         ! 
    160          DO_2D( 1, 1, 1, 1 ) 
     160         DO_2D( 1, 1, 1, 1 )           ! vertical interpolation of U & V current: 
    161161            DO jk = 1, jpk 
    162162               zl = gdept(ji,jj,jk,Kmm) 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/CRS/crsfld.F90

    r13295 r13998  
    146146      CALL iom_put( "voces" , zs_crs )   ! vS 
    147147 
    148       IF( iom_use( "eken") ) THEN     !      kinetic energy 
     148      IF( iom_use( "ke") ) THEN     !      kinetic energy 
    149149         z3d(:,:,jk) = 0._wp  
    150150         DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
    … …  
    159159         ! 
    160160         CALL crs_dom_ope( z3d, 'VOL', 'T', tmask, zt_crs, p_e12=e1e2t, p_e3=ze3t, psgn=1.0_wp ) 
    161          CALL iom_put( "eken", zt_crs ) 
     161         CALL iom_put( "ke", zt_crs ) 
    162162      ENDIF 
    163163      !  Horizontal divergence ( following OCE/DYN/divhor.F90 )  

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DIA/diaar5.F90

    r13295 r13998  
    144144         IF( ln_linssh ) THEN 
    145145            IF( ln_isfcav ) THEN 
    146                DO ji = 1, jpi 
    147                   DO jj = 1, jpj 
    148                      iks = mikt(ji,jj) 
    149                      zbotpres(ji,jj) = zbotpres(ji,jj) + ssh(ji,jj,Kmm) * zrhd(ji,jj,iks) + riceload(ji,jj) 
    150                   END DO 
    151                END DO 
     146               DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
     147                  iks = mikt(ji,jj) 
     148                  zbotpres(ji,jj) = zbotpres(ji,jj) + ssh(ji,jj,Kmm) * zrhd(ji,jj,iks) + riceload(ji,jj) 
     149               END_2D 
    152150            ELSE 
    153151               zbotpres(:,:) = zbotpres(:,:) + ssh(:,:,Kmm) * zrhd(:,:,1) 
    … …  
    385383         zvol0 (:,:) = 0._wp 
    386384         thick0(:,:) = 0._wp 
    387          DO_3D( 1, 1, 1, 1, 1, jpkm1 ) 
     385         DO_3D( 1, 1, 1, 1, 1, jpkm1 )   ! interpolation of salinity at the last ocean level (i.e. the partial step) 
    388386            idep = tmask(ji,jj,jk) * e3t_0(ji,jj,jk) 
    389387            zvol0 (ji,jj) = zvol0 (ji,jj) +  idep * e1e2t(ji,jj) 
    … …  
    403401            sn0(:,:,:) = sn0(:,:,:) * tmask(:,:,:) 
    404402            IF( ln_zps ) THEN               ! z-coord. partial steps 
    405                DO_2D( 1, 1, 1, 1 ) 
     403               DO_2D( 1, 1, 1, 1 )          ! interpolation of salinity at the last ocean level (i.e. the partial step) 
    406404                  ik = mbkt(ji,jj) 
    407405                  IF( ik > 1 ) THEN 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DIA/diacfl.F90

    r13295 r13998  
    5656      INTEGER , DIMENSION(3)           ::   iloc_u , iloc_v , iloc_w , iloc  ! workspace 
    5757      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zCu_cfl, zCv_cfl, zCw_cfl        ! workspace 
     58      LOGICAL , DIMENSION(jpi,jpj,jpk) ::   llmsk 
    5859      !!---------------------------------------------------------------------- 
    5960      ! 
    6061      IF( ln_timing )   CALL timing_start('dia_cfl') 
    6162      ! 
    62       DO_3D( 1, 1, 1, 1, 1, jpk ) 
     63      llmsk(   1:Nis1,:,:) = .FALSE.                                              ! exclude halos from the checked region 
     64      llmsk(Nie1: jpi,:,:) = .FALSE. 
     65      llmsk(:,   1:Njs1,:) = .FALSE. 
     66      llmsk(:,Nje1: jpj,:) = .FALSE. 
     67      ! 
     68      DO_3D( 0, 0, 0, 0, 1, jpk )      ! calculate Courant numbers 
    6369         zCu_cfl(ji,jj,jk) = ABS( uu(ji,jj,jk,Kmm) ) * rDt / e1u  (ji,jj)      ! for i-direction 
    6470         zCv_cfl(ji,jj,jk) = ABS( vv(ji,jj,jk,Kmm) ) * rDt / e2v  (ji,jj)      ! for j-direction 
    65          zCw_cfl(ji,jj,jk) = ABS( ww(ji,jj,jk) ) * rDt / e3w(ji,jj,jk,Kmm)   ! for k-direction 
     71         zCw_cfl(ji,jj,jk) = ABS( ww(ji,jj,jk) ) * rDt / e3w(ji,jj,jk,Kmm)     ! for k-direction 
    6672      END_3D 
    6773      ! 
    6874      ! write outputs 
    69       IF( iom_use('cfl_cu') )   CALL iom_put( 'cfl_cu', MAXVAL( zCu_cfl, dim=3 ) ) 
    70       IF( iom_use('cfl_cv') )   CALL iom_put( 'cfl_cv', MAXVAL( zCv_cfl, dim=3 ) ) 
    71       IF( iom_use('cfl_cw') )   CALL iom_put( 'cfl_cw', MAXVAL( zCw_cfl, dim=3 ) ) 
     75      IF( iom_use('cfl_cu') ) THEN 
     76         llmsk(Nis0:Nie0,Njs0:Nje0,:) = umask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp        ! define only the inner domain 
     77         CALL iom_put( 'cfl_cu', MAXVAL( zCu_cfl, mask = llmsk, dim=3 ) ) 
     78      ENDIF 
     79      IF( iom_use('cfl_cv') ) THEN 
     80         llmsk(Nis0:Nie0,Njs0:Nje0,:) = vmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp        ! define only the inner domain 
     81         CALL iom_put( 'cfl_cv', MAXVAL( zCv_cfl, mask = llmsk, dim=3 ) ) 
     82      ENDIF 
     83      IF( iom_use('cfl_cw') ) THEN 
     84         llmsk(Nis0:Nie0,Njs0:Nje0,:) = wmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp        ! define only the inner domain 
     85         CALL iom_put( 'cfl_cw', MAXVAL( zCw_cfl, mask = llmsk, dim=3 ) ) 
     86      ENDIF 
    7287 
    7388      !                    ! calculate maximum values and locations 
    74       IF( lk_mpp ) THEN 
    75          CALL mpp_maxloc( 'diacfl', zCu_cfl, umask, zCu_max, iloc_u ) 
    76          CALL mpp_maxloc( 'diacfl', zCv_cfl, vmask, zCv_max, iloc_v ) 
    77          CALL mpp_maxloc( 'diacfl', zCw_cfl, wmask, zCw_max, iloc_w ) 
    78       ELSE 
    79          iloc = MAXLOC( ABS( zcu_cfl(:,:,:) ) ) 
    80          iloc_u(1) = iloc(1) + nimpp - 1 
    81          iloc_u(2) = iloc(2) + njmpp - 1 
    82          iloc_u(3) = iloc(3) 
    83          zCu_max = zCu_cfl(iloc(1),iloc(2),iloc(3)) 
    84          ! 
    85          iloc = MAXLOC( ABS( zcv_cfl(:,:,:) ) ) 
    86          iloc_v(1) = iloc(1) + nimpp - 1 
    87          iloc_v(2) = iloc(2) + njmpp - 1 
    88          iloc_v(3) = iloc(3) 
    89          zCv_max = zCv_cfl(iloc(1),iloc(2),iloc(3)) 
    90          ! 
    91          iloc = MAXLOC( ABS( zcw_cfl(:,:,:) ) ) 
    92          iloc_w(1) = iloc(1) + nimpp - 1 
    93          iloc_w(2) = iloc(2) + njmpp - 1 
    94          iloc_w(3) = iloc(3) 
    95          zCw_max = zCw_cfl(iloc(1),iloc(2),iloc(3)) 
    96       ENDIF 
     89      llmsk(Nis0:Nie0,Njs0:Nje0,:) = umask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp        ! define only the inner domain 
     90      CALL mpp_maxloc( 'diacfl', zCu_cfl, llmsk, zCu_max, iloc_u ) 
     91      llmsk(Nis0:Nie0,Njs0:Nje0,:) = vmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp        ! define only the inner domain 
     92      CALL mpp_maxloc( 'diacfl', zCv_cfl, llmsk, zCv_max, iloc_v ) 
     93      llmsk(Nis0:Nie0,Njs0:Nje0,:) = wmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp        ! define only the inner domain 
     94      CALL mpp_maxloc( 'diacfl', zCw_cfl, llmsk, zCw_max, iloc_w ) 
    9795      ! 
    98       !                    ! write out to file 
    99       IF( lwp ) THEN 
     96      IF( lwp ) THEN       ! write out to file 
    10097         WRITE(numcfl,FMT='(2x,i6,3x,a6,4x,f7.4,1x,i4,1x,i4,1x,i4)') kt, 'Max Cu', zCu_max, iloc_u(1), iloc_u(2), iloc_u(3) 
    10198         WRITE(numcfl,FMT='(11x,     a6,4x,f7.4,1x,i4,1x,i4,1x,i4)')     'Max Cv', zCv_max, iloc_v(1), iloc_v(2), iloc_v(3) 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DIA/diahth.F90

    r13295 r13998  
    170170            ! MLD: rho = rho(1) + zrho1                                     ! 
    171171            ! ------------------------------------------------------------- ! 
    172             DO_3DS( 1, 1, 1, 1, jpkm1, 2, -1 ) 
     172            DO_3DS( 1, 1, 1, 1, jpkm1, 2, -1 )   ! loop from bottom to 2 
    173173               ! 
    174174               zzdep = gdepw(ji,jj,jk,Kmm) 
    … …  
    207207            ! depth of temperature inversion                                ! 
    208208            ! ------------------------------------------------------------- ! 
    209             DO_3DS( 1, 1, 1, 1, jpkm1, nlb10, -1 ) 
     209            DO_3DS( 1, 1, 1, 1, jpkm1, nlb10, -1 )   ! loop from bottom to nlb10 
    210210               ! 
    211211               zzdep = gdepw(ji,jj,jk,Kmm) * tmask(ji,jj,1) 
    … …  
    305305      ! --------------------------------------- ! 
    306306      iktem(:,:) = 1 
    307       DO_3D( 1, 1, 1, 1, 1, jpkm1 ) 
     307      DO_3D( 1, 1, 1, 1, 1, jpkm1 )   ! beware temperature is not always decreasing with depth => loop from top to bottom 
    308308         zztmp = ts(ji,jj,jk,jp_tem,Kmm) 
    309309         IF( zztmp >= ptem )   iktem(ji,jj) = jk 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DIA/diaptr.F90

    r13295 r13998  
    3636   END INTERFACE 
    3737 
    38    PUBLIC   ptr_sj         ! call by tra_ldf & tra_adv routines 
    39    PUBLIC   ptr_sjk        !  
    40    PUBLIC   dia_ptr_init   ! call in memogcm 
    4138   PUBLIC   dia_ptr        ! call in step module 
    4239   PUBLIC   dia_ptr_hst    ! called from tra_ldf/tra_adv routines 
    4340 
    44    !                                  !!** namelist  namptr  ** 
    4541   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   hstr_adv, hstr_ldf, hstr_eiv   !: Heat/Salt TRansports(adv, diff, Bolus.) 
    4642   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   hstr_ove, hstr_btr, hstr_vtr   !: heat Salt TRansports(overturn, baro, merional) 
    4743 
    48    LOGICAL , PUBLIC ::   l_diaptr        !: tracers  trend flag (set from namelist in trdini) 
    49    INTEGER, PARAMETER, PUBLIC ::   nptr = 5  ! (glo, atl, pac, ind, ipc) 
     44   LOGICAL, PUBLIC ::   l_diaptr       !: tracers  trend flag 
    5045 
    5146   REAL(wp) ::   rc_sv    = 1.e-6_wp   ! conversion from m3/s to Sverdrup 
    … …  
    5954   REAL(wp), TARGET, ALLOCATABLE, SAVE, DIMENSION(:,:) :: p_fval2d 
    6055 
    61    LOGICAL ::   ll_init = .TRUE.        !: tracers  trend flag (set from namelist in trdini) 
     56   LOGICAL ::   ll_init = .TRUE.        !: tracers  trend flag 
    6257    
    6358   !! * Substitutions 
    … …  
    8883      ! 
    8984      !overturning calculation 
    90       REAL(wp), DIMENSION(jpj,jpk,nptr) :: sjk, r1_sjk, v_msf  ! i-mean i-k-surface and its inverse 
    91       REAL(wp), DIMENSION(jpj,jpk,nptr) :: zt_jk, zs_jk ! i-mean T and S, j-Stream-Function 
    92  
    93       REAL(wp), DIMENSION(jpi,jpj,jpk,nptr)  :: z4d1, z4d2 
    94       REAL(wp), DIMENSION(jpi,jpj,nptr)      :: z3dtr ! i-mean T and S, j-Stream-Function 
     85      REAL(wp), DIMENSION(:,:,:  ), ALLOCATABLE ::  sjk, r1_sjk, v_msf  ! i-mean i-k-surface and its inverse 
     86      REAL(wp), DIMENSION(:,:,:  ), ALLOCATABLE ::   zt_jk, zs_jk        ! i-mean T and S, j-Stream-Function 
     87 
     88      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE ::  z4d1, z4d2 
     89      REAL(wp), DIMENSION(:,:,:  ), ALLOCATABLE ::   z3dtr 
    9590      !!---------------------------------------------------------------------- 
    9691      ! 
    9792      IF( ln_timing )   CALL timing_start('dia_ptr') 
    9893 
    99       IF( kt == nit000 .AND. ll_init )   CALL dia_ptr_init 
    100       ! 
    101       IF( .NOT. l_diaptr )   RETURN 
    102  
     94      IF( kt == nit000 .AND. ll_init )   CALL dia_ptr_init   ! -> will define l_diaptr and nbasin 
     95      ! 
     96      IF( .NOT. l_diaptr ) THEN 
     97         IF( ln_timing ) CALL timing_stop('dia_ptr') 
     98         RETURN 
     99      ENDIF 
     100      ! 
     101      ALLOCATE( z3dtr(jpi,jpj,nbasin) ) 
     102      ! 
    103103      IF( PRESENT( pvtr ) ) THEN 
    104104         IF( iom_use( 'zomsf' ) ) THEN    ! effective MSF 
    105             DO jn = 1, nptr                                    ! by sub-basins 
     105            ALLOCATE( z4d1(jpi,jpj,jpk,nbasin) ) 
     106            DO jn = 1, nbasin                                    ! by sub-basins 
    106107               z4d1(1,:,:,jn) =  ptr_sjk( pvtr(:,:,:), btmsk34(:,:,jn) )  ! zonal cumulative effective transport excluding closed seas 
    107108               DO jk = jpkm1, 1, -1  
    … …  
    113114            END DO 
    114115            CALL iom_put( 'zomsf', z4d1 * rc_sv ) 
     116            DEALLOCATE( z4d1 ) 
    115117         ENDIF 
    116118         IF(  iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) .OR.   & 
    … …  
    127129         ENDIF 
    128130         IF( iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) ) THEN 
    129             DO jn = 1, nptr 
     131            DO jn = 1, nbasin 
     132               ALLOCATE( sjk(jpj,jpk,nbasin), r1_sjk(jpj,jpk,nbasin), v_msf(jpj,jpk,nbasin),   & 
     133                  &                          zt_jk(jpj,jpk,nbasin), zs_jk(jpj,jpk,nbasin) ) 
    130134               sjk(:,:,jn) = ptr_sjk( zmask(:,:,:), btmsk(:,:,jn) ) 
    131135               r1_sjk(:,:,jn) = 0._wp 
    … …  
    137141               hstr_ove(:,jp_tem,jn) = SUM( v_msf(:,:,jn)*zt_jk(:,:,jn), 2 ) 
    138142               hstr_ove(:,jp_sal,jn) = SUM( v_msf(:,:,jn)*zs_jk(:,:,jn), 2 ) 
     143               DEALLOCATE( sjk, r1_sjk, v_msf, zt_jk, zs_jk ) 
    139144               ! 
    140145            ENDDO 
    141             DO jn = 1, nptr 
     146            DO jn = 1, nbasin 
    142147               z3dtr(1,:,jn) = hstr_ove(:,jp_tem,jn) * rc_pwatt  !  (conversion in PW) 
    143148               DO ji = 1, jpi 
    … …  
    146151            ENDDO 
    147152            CALL iom_put( 'sophtove', z3dtr ) 
    148             DO jn = 1, nptr 
     153            DO jn = 1, nbasin 
    149154               z3dtr(1,:,jn) = hstr_ove(:,jp_sal,jn) * rc_ggram !  (conversion in Gg) 
    150155               DO ji = 1, jpi 
    … …  
    157162         IF( iom_use( 'sopstbtr' ) .OR. iom_use( 'sophtbtr' ) ) THEN 
    158163            ! Calculate barotropic heat and salt transport here  
    159             DO jn = 1, nptr 
     164            DO jn = 1, nbasin 
     165               ALLOCATE( sjk(jpj,1,nbasin), r1_sjk(jpj,1,nbasin) ) 
    160166               sjk(:,1,jn) = ptr_sj( zmask(:,:,:), btmsk(:,:,jn) ) 
    161167               r1_sjk(:,1,jn) = 0._wp 
    … …  
    167173               hstr_btr(:,jp_tem,jn) = zvsum(:) * ztsum(:) * r1_sjk(:,1,jn) 
    168174               hstr_btr(:,jp_sal,jn) = zvsum(:) * zssum(:) * r1_sjk(:,1,jn) 
     175               DEALLOCATE( sjk, r1_sjk ) 
    169176               ! 
    170177            ENDDO 
    171             DO jn = 1, nptr 
     178            DO jn = 1, nbasin 
    172179               z3dtr(1,:,jn) = hstr_btr(:,jp_tem,jn) * rc_pwatt  !  (conversion in PW) 
    173180               DO ji = 1, jpi 
    … …  
    176183            ENDDO 
    177184            CALL iom_put( 'sophtbtr', z3dtr ) 
    178             DO jn = 1, nptr 
     185            DO jn = 1, nbasin 
    179186               z3dtr(1,:,jn) = hstr_btr(:,jp_sal,jn) * rc_ggram !  (conversion in Gg) 
    180187               DO ji = 1, jpi 
    … …  
    190197         zts(:,:,:,:) = 0._wp 
    191198         IF( iom_use( 'zotem' ) .OR. iom_use( 'zosal' ) .OR. iom_use( 'zosrf' )  ) THEN    ! i-mean i-k-surface  
     199            ALLOCATE( z4d1(jpi,jpj,jpk,nbasin), z4d2(jpi,jpj,jpk,nbasin) ) 
    192200            DO_3D( 1, 1, 1, 1, 1, jpkm1 ) 
    193201               zsfc = e1t(ji,jj) * e3t(ji,jj,jk,Kmm) 
    … …  
    197205            END_3D 
    198206            ! 
    199             DO jn = 1, nptr 
     207            DO jn = 1, nbasin 
    200208               zmask(1,:,:) = ptr_sjk( zmask(:,:,:), btmsk(:,:,jn) ) 
     209               DO ji = 1, jpi 
     210                  zmask(ji,:,:) = zmask(1,:,:) 
     211               ENDDO 
    201212               z4d1(:,:,:,jn) = zmask(:,:,:) 
    202213            ENDDO 
    203214            CALL iom_put( 'zosrf', z4d1 ) 
    204215            ! 
    205             DO jn = 1, nptr 
     216            DO jn = 1, nbasin 
    206217               z4d2(1,:,:,jn) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) & 
    207218                  &            / MAX( z4d1(1,:,:,jn), 10.e-15 ) 
    … …  
    212223            CALL iom_put( 'zotem', z4d2 ) 
    213224            ! 
    214             DO jn = 1, nptr 
     225            DO jn = 1, nbasin 
    215226               z4d2(1,:,:,jn) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) & 
    216227                  &            / MAX( z4d1(1,:,:,jn), 10.e-15 ) 
    … …  
    220231            ENDDO 
    221232            CALL iom_put( 'zosal', z4d2 ) 
     233            DEALLOCATE( z4d1, z4d2 ) 
    222234            ! 
    223235         ENDIF 
    … …  
    226238         IF( iom_use( 'sophtadv' ) .OR. iom_use( 'sopstadv' ) ) THEN   
    227239            !  
    228             DO jn = 1, nptr 
     240            DO jn = 1, nbasin 
    229241               z3dtr(1,:,jn) = hstr_adv(:,jp_tem,jn) * rc_pwatt  !  (conversion in PW) 
    230242               DO ji = 1, jpi 
    … …  
    233245            ENDDO 
    234246            CALL iom_put( 'sophtadv', z3dtr ) 
    235             DO jn = 1, nptr 
     247            DO jn = 1, nbasin 
    236248               z3dtr(1,:,jn) = hstr_adv(:,jp_sal,jn) * rc_ggram !  (conversion in Gg) 
    237249               DO ji = 1, jpi 
    … …  
    244256         IF( iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) ) THEN   
    245257            !  
    246             DO jn = 1, nptr 
     258            DO jn = 1, nbasin 
    247259               z3dtr(1,:,jn) = hstr_ldf(:,jp_tem,jn) * rc_pwatt  !  (conversion in PW) 
    248260               DO ji = 1, jpi 
    … …  
    251263            ENDDO 
    252264            CALL iom_put( 'sophtldf', z3dtr ) 
    253             DO jn = 1, nptr 
     265            DO jn = 1, nbasin 
    254266               z3dtr(1,:,jn) = hstr_ldf(:,jp_sal,jn) * rc_ggram !  (conversion in Gg) 
    255267               DO ji = 1, jpi 
    … …  
    262274         IF( iom_use( 'sophteiv' ) .OR. iom_use( 'sopsteiv' ) ) THEN   
    263275            !  
    264             DO jn = 1, nptr 
     276            DO jn = 1, nbasin 
    265277               z3dtr(1,:,jn) = hstr_eiv(:,jp_tem,jn) * rc_pwatt  !  (conversion in PW) 
    266278               DO ji = 1, jpi 
    … …  
    269281            ENDDO 
    270282            CALL iom_put( 'sophteiv', z3dtr ) 
    271             DO jn = 1, nptr 
     283            DO jn = 1, nbasin 
    272284               z3dtr(1,:,jn) = hstr_eiv(:,jp_sal,jn) * rc_ggram !  (conversion in Gg) 
    273285               DO ji = 1, jpi 
    … …  
    287299             CALL dia_ptr_hst( jp_tem, 'vtr', zts(:,:,:,jp_tem) ) 
    288300             CALL dia_ptr_hst( jp_sal, 'vtr', zts(:,:,:,jp_sal) ) 
    289              DO jn = 1, nptr 
     301             DO jn = 1, nbasin 
    290302                z3dtr(1,:,jn) = hstr_vtr(:,jp_tem,jn) * rc_pwatt  !  (conversion in PW) 
    291303                DO ji = 1, jpi 
    … …  
    294306             ENDDO 
    295307             CALL iom_put( 'sophtvtr', z3dtr ) 
    296              DO jn = 1, nptr 
     308             DO jn = 1, nbasin 
    297309               z3dtr(1,:,jn) = hstr_vtr(:,jp_sal,jn) * rc_ggram !  (conversion in Gg) 
    298310               DO ji = 1, jpi 
    … …  
    311323      ENDIF 
    312324      ! 
     325      DEALLOCATE( z3dtr ) 
     326      ! 
    313327      IF( ln_timing )   CALL timing_stop('dia_ptr') 
    314328      ! 
    … …  
    320334      !!                  ***  ROUTINE dia_ptr_init  *** 
    321335      !!                    
    322       !! ** Purpose :   Initialization, namelist read 
     336      !! ** Purpose :   Initialization 
    323337      !!---------------------------------------------------------------------- 
    324338      INTEGER ::  inum, jn           ! local integers 
    … …  
    326340      REAL(wp), DIMENSION(jpi,jpj) :: zmsk 
    327341      !!---------------------------------------------------------------------- 
    328  
    329       l_diaptr = .FALSE. 
    330       IF(   iom_use( 'zomsf'    ) .OR. iom_use( 'zotem'    ) .OR. iom_use( 'zosal'    ) .OR.  & 
    331          &  iom_use( 'zosrf'    ) .OR. iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) .OR.  & 
    332          &  iom_use( 'sopstbtr' ) .OR. iom_use( 'sophtbtr' ) .OR. iom_use( 'sophtadv' ) .OR.  & 
    333          &  iom_use( 'sopstadv' ) .OR. iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) .OR.  &  
    334          &  iom_use( 'sophteiv' ) .OR. iom_use( 'sopsteiv' ) .OR. iom_use( 'sopstvtr' ) .OR.  & 
    335          &  iom_use( 'sophtvtr' ) .OR. iom_use( 'uocetr_vsum_cumul' ) )  l_diaptr  = .TRUE. 
    336  
     342       
     343      ! l_diaptr is defined with iom_use 
     344      !   --> dia_ptr_init must be done after the call to iom_init 
     345      !   --> cannot be .TRUE. without cpp key: key_iom -->  nbasin define by iom_init is initialized 
     346      l_diaptr = iom_use( 'zomsf'    ) .OR. iom_use( 'zotem'    ) .OR. iom_use( 'zosal'    ) .OR.  & 
     347         &       iom_use( 'zosrf'    ) .OR. iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) .OR.  & 
     348         &       iom_use( 'sopstbtr' ) .OR. iom_use( 'sophtbtr' ) .OR. iom_use( 'sophtadv' ) .OR.  & 
     349         &       iom_use( 'sopstadv' ) .OR. iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) .OR.  &  
     350         &       iom_use( 'sophteiv' ) .OR. iom_use( 'sopsteiv' ) .OR. iom_use( 'sopstvtr' ) .OR.  & 
     351         &       iom_use( 'sophtvtr' ) .OR. iom_use( 'uocetr_vsum_cumul' )  
    337352  
    338353      IF(lwp) THEN                     ! Control print 
    … …  
    340355         WRITE(numout,*) 'dia_ptr_init : poleward transport and msf initialization' 
    341356         WRITE(numout,*) '~~~~~~~~~~~~' 
    342          WRITE(numout,*) '   Namelist namptr : set ptr parameters' 
    343357         WRITE(numout,*) '      Poleward heat & salt transport (T) or not (F)      l_diaptr  = ', l_diaptr 
    344358      ENDIF 
    … …  
    347361         ! 
    348362         IF( dia_ptr_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'dia_ptr_init : unable to allocate arrays' ) 
    349  
     363         ! 
    350364         rc_pwatt = rc_pwatt * rho0_rcp          ! conversion from K.s-1 to PetaWatt 
    351365         rc_ggram = rc_ggram * rho0              ! conversion from m3/s to Gg/s 
    … …  
    354368 
    355369         btmsk(:,:,1) = tmask_i(:,:)                  
    356          CALL iom_open( 'subbasins', inum,  ldstop = .FALSE.  ) 
    357          CALL iom_get( inum, jpdom_global, 'atlmsk', btmsk(:,:,2) )   ! Atlantic basin 
    358          CALL iom_get( inum, jpdom_global, 'pacmsk', btmsk(:,:,3) )   ! Pacific  basin 
    359          CALL iom_get( inum, jpdom_global, 'indmsk', btmsk(:,:,4) )   ! Indian   basin 
    360          CALL iom_close( inum ) 
    361          btmsk(:,:,5) = MAX ( btmsk(:,:,3), btmsk(:,:,4) )          ! Indo-Pacific basin 
    362          DO jn = 2, nptr 
    363             btmsk(:,:,jn) = btmsk(:,:,jn) * tmask_i(:,:)               ! interior domain only 
     370         IF( nbasin == 5 ) THEN   ! nbasin has been initialized in iom_init to define the axis "basin" 
     371            CALL iom_open( 'subbasins', inum ) 
     372            CALL iom_get( inum, jpdom_global, 'atlmsk', btmsk(:,:,2) )   ! Atlantic basin 
     373            CALL iom_get( inum, jpdom_global, 'pacmsk', btmsk(:,:,3) )   ! Pacific  basin 
     374            CALL iom_get( inum, jpdom_global, 'indmsk', btmsk(:,:,4) )   ! Indian   basin 
     375            CALL iom_close( inum ) 
     376            btmsk(:,:,5) = MAX ( btmsk(:,:,3), btmsk(:,:,4) )            ! Indo-Pacific basin 
     377         ENDIF 
     378         DO jn = 2, nbasin 
     379            btmsk(:,:,jn) = btmsk(:,:,jn) * tmask_i(:,:)                 ! interior domain only 
    364380         END DO 
    365381         ! JD : modification so that overturning streamfunction is available in Atlantic at 34S to compare with observations 
    … …  
    370386         END WHERE 
    371387         btmsk34(:,:,1) = btmsk(:,:,1)                  
    372          DO jn = 2, nptr 
    373             btmsk34(:,:,jn) = btmsk(:,:,jn) * zmsk(:,:)               ! interior domain only 
     388         DO jn = 2, nbasin 
     389            btmsk34(:,:,jn) = btmsk(:,:,jn) * zmsk(:,:)                  ! interior domain only 
    374390         ENDDO 
    375391 
    … …  
    405421      IF( cptr == 'adv' ) THEN 
    406422         IF( ktra == jp_tem )  THEN 
    407              DO jn = 1, nptr 
     423             DO jn = 1, nbasin 
    408424                hstr_adv(:,jp_tem,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 
    409425             ENDDO 
    410426         ENDIF 
    411427         IF( ktra == jp_sal )  THEN 
    412              DO jn = 1, nptr 
     428             DO jn = 1, nbasin 
    413429                hstr_adv(:,jp_sal,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 
    414430             ENDDO 
    … …  
    418434      IF( cptr == 'ldf' ) THEN 
    419435         IF( ktra == jp_tem )  THEN 
    420              DO jn = 1, nptr 
     436             DO jn = 1, nbasin 
    421437                hstr_ldf(:,jp_tem,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 
    422438             ENDDO 
    423439         ENDIF 
    424440         IF( ktra == jp_sal )  THEN 
    425              DO jn = 1, nptr 
     441             DO jn = 1, nbasin 
    426442                hstr_ldf(:,jp_sal,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 
    427443             ENDDO 
    … …  
    431447      IF( cptr == 'eiv' ) THEN 
    432448         IF( ktra == jp_tem )  THEN 
    433              DO jn = 1, nptr 
     449             DO jn = 1, nbasin 
    434450                hstr_eiv(:,jp_tem,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 
    435451             ENDDO 
    436452         ENDIF 
    437453         IF( ktra == jp_sal )  THEN 
    438              DO jn = 1, nptr 
     454             DO jn = 1, nbasin 
    439455                hstr_eiv(:,jp_sal,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 
    440456             ENDDO 
    … …  
    444460      IF( cptr == 'vtr' ) THEN 
    445461         IF( ktra == jp_tem )  THEN 
    446              DO jn = 1, nptr 
     462             DO jn = 1, nbasin 
    447463                hstr_vtr(:,jp_tem,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 
    448464             ENDDO 
    449465         ENDIF 
    450466         IF( ktra == jp_sal )  THEN 
    451              DO jn = 1, nptr 
     467             DO jn = 1, nbasin 
    452468                hstr_vtr(:,jp_sal,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) ) 
    453469             ENDDO 
    … …  
    467483      ierr(:) = 0 
    468484      ! 
     485      ! nbasin has been initialized in iom_init to define the axis "basin" 
     486      ! 
    469487      IF( .NOT. ALLOCATED( btmsk ) ) THEN 
    470          ALLOCATE( btmsk(jpi,jpj,nptr)    , btmsk34(jpi,jpj,nptr),   & 
    471             &      hstr_adv(jpj,jpts,nptr), hstr_eiv(jpj,jpts,nptr), & 
    472             &      hstr_ove(jpj,jpts,nptr), hstr_btr(jpj,jpts,nptr), & 
    473             &      hstr_ldf(jpj,jpts,nptr), hstr_vtr(jpj,jpts,nptr), STAT=ierr(1)  ) 
     488         ALLOCATE( btmsk(jpi,jpj,nbasin)    , btmsk34(jpi,jpj,nbasin),   & 
     489            &      hstr_adv(jpj,jpts,nbasin), hstr_eiv(jpj,jpts,nbasin), & 
     490            &      hstr_ove(jpj,jpts,nbasin), hstr_btr(jpj,jpts,nbasin), & 
     491            &      hstr_ldf(jpj,jpts,nbasin), hstr_vtr(jpj,jpts,nbasin), STAT=ierr(1)  ) 
    474492            ! 
    475493         ALLOCATE( p_fval1d(jpj), p_fval2d(jpj,jpk), Stat=ierr(2)) 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DIA/diawri.F90

    r13734 r13998  
    190190      CALL iom_put(  "sst", ts(:,:,1,jp_tem,Kmm) )    ! surface temperature 
    191191      IF ( iom_use("sbt") ) THEN 
    192          DO_2D( 1, 1, 1, 1 ) 
     192         DO_2D( 0, 0, 0, 0 ) 
    193193            ikbot = mbkt(ji,jj) 
    194194            z2d(ji,jj) = ts(ji,jj,ikbot,jp_tem,Kmm) 
    … …  
    200200      CALL iom_put(  "sss", ts(:,:,1,jp_sal,Kmm) )    ! surface salinity 
    201201      IF ( iom_use("sbs") ) THEN 
    202          DO_2D( 1, 1, 1, 1 ) 
     202         DO_2D( 0, 0, 0, 0 ) 
    203203            ikbot = mbkt(ji,jj) 
    204204            z2d(ji,jj) = ts(ji,jj,ikbot,jp_sal,Kmm) 
    … …  
    222222            ! 
    223223         END_2D 
    224          CALL lbc_lnk( 'diawri', z2d, 'T', 1.0_wp ) 
    225224         CALL iom_put( "taubot", z2d )            
    226225      ENDIF 
    … …  
    229228      CALL iom_put(  "ssu", uu(:,:,1,Kmm) )            ! surface i-current 
    230229      IF ( iom_use("sbu") ) THEN 
    231          DO_2D( 1, 1, 1, 1 ) 
     230         DO_2D( 0, 0, 0, 0 ) 
    232231            ikbot = mbku(ji,jj) 
    233232            z2d(ji,jj) = uu(ji,jj,ikbot,Kmm) 
    … …  
    239238      CALL iom_put(  "ssv", vv(:,:,1,Kmm) )            ! surface j-current 
    240239      IF ( iom_use("sbv") ) THEN 
    241          DO_2D( 1, 1, 1, 1 ) 
     240         DO_2D( 0, 0, 0, 0 ) 
    242241            ikbot = mbkv(ji,jj) 
    243242            z2d(ji,jj) = vv(ji,jj,ikbot,Kmm) 
    … …  
    268267      IF( iom_use('logavs') )   CALL iom_put( "logavs", LOG( MAX( 1.e-20_wp, avs(:,:,:) ) ) ) 
    269268 
     269      IF ( iom_use("socegrad") .OR. iom_use("socegrad2") ) THEN 
     270         z3d(:,:,jpk) = 0. 
     271         DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     272            zztmp  = ts(ji,jj,jk,jp_sal,Kmm) 
     273            zztmpx = (ts(ji+1,jj,jk,jp_sal,Kmm) - zztmp) * r1_e1u(ji,jj) + (zztmp - ts(ji-1,jj  ,jk,jp_sal,Kmm)) * r1_e1u(ji-1,jj) 
     274            zztmpy = (ts(ji,jj+1,jk,jp_sal,Kmm) - zztmp) * r1_e2v(ji,jj) + (zztmp - ts(ji  ,jj-1,jk,jp_sal,Kmm)) * r1_e2v(ji,jj-1) 
     275            z3d(ji,jj,jk) = 0.25 * ( zztmpx * zztmpx + zztmpy * zztmpy )   & 
     276               &                 * umask(ji,jj,jk) * umask(ji-1,jj,jk) * vmask(ji,jj,jk) * umask(ji,jj-1,jk) 
     277         END_3D 
     278         CALL iom_put( "socegrad2",  z3d )          ! square of module of sal gradient 
     279         DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     280            z3d(ji,jj,jk) = SQRT( z3d(ji,jj,jk) ) 
     281         END_3D 
     282         CALL iom_put( "socegrad" ,  z3d )          ! module of sal gradient 
     283      ENDIF 
     284          
    270285      IF ( iom_use("sstgrad") .OR. iom_use("sstgrad2") ) THEN 
    271          DO_2D( 0, 0, 0, 0 ) 
     286         DO_2D( 0, 0, 0, 0 )                                 ! sst gradient 
    272287            zztmp  = ts(ji,jj,1,jp_tem,Kmm) 
    273288            zztmpx = ( ts(ji+1,jj,1,jp_tem,Kmm) - zztmp ) * r1_e1u(ji,jj) + ( zztmp - ts(ji-1,jj  ,1,jp_tem,Kmm) ) * r1_e1u(ji-1,jj) 
    … …  
    276291               &              * umask(ji,jj,1) * umask(ji-1,jj,1) * vmask(ji,jj,1) * umask(ji,jj-1,1) 
    277292         END_2D 
    278          CALL lbc_lnk( 'diawri', z2d, 'T', 1.0_wp ) 
    279293         CALL iom_put( "sstgrad2",  z2d )          ! square of module of sst gradient 
    280          z2d(:,:) = SQRT( z2d(:,:) ) 
     294         DO_2D( 0, 0, 0, 0 ) 
     295            z2d(ji,jj) = SQRT( z2d(ji,jj) ) 
     296         END_2D 
    281297         CALL iom_put( "sstgrad" ,  z2d )          ! module of sst gradient 
    282298      ENDIF 
    … …  
    285301      IF( iom_use("heatc") ) THEN 
    286302         z2d(:,:)  = 0._wp  
    287          DO_3D( 1, 1, 1, 1, 1, jpkm1 ) 
     303         DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
    288304            z2d(ji,jj) = z2d(ji,jj) + e3t(ji,jj,jk,Kmm) * ts(ji,jj,jk,jp_tem,Kmm) * tmask(ji,jj,jk) 
    289305         END_3D 
    … …  
    293309      IF( iom_use("saltc") ) THEN 
    294310         z2d(:,:)  = 0._wp  
    295          DO_3D( 1, 1, 1, 1, 1, jpkm1 ) 
     311         DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
    296312            z2d(ji,jj) = z2d(ji,jj) + e3t(ji,jj,jk,Kmm) * ts(ji,jj,jk,jp_sal,Kmm) * tmask(ji,jj,jk) 
    297313         END_3D 
    … …  
    299315      ENDIF 
    300316      ! 
    301       IF ( iom_use("eken") ) THEN 
     317      IF( iom_use("salt2c") ) THEN 
     318         z2d(:,:)  = 0._wp  
     319         DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     320            z2d(ji,jj) = z2d(ji,jj) + e3t(ji,jj,jk,Kmm) * ts(ji,jj,jk,jp_sal,Kmm) * ts(ji,jj,jk,jp_sal,Kmm) * tmask(ji,jj,jk) 
     321         END_3D 
     322         CALL iom_put( "salt2c", rho0 * z2d )          ! vertically integrated salt content (PSU*kg/m2) 
     323      ENDIF 
     324      ! 
     325      IF ( iom_use("ke") .OR. iom_use("ke_int") ) THEN 
    302326         z3d(:,:,jpk) = 0._wp  
    303327         DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
    304             zztmp  = 0.25_wp * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
    305             z3d(ji,jj,jk) = zztmp * (  uu(ji-1,jj,jk,Kmm)**2 * e2u(ji-1,jj) * e3u(ji-1,jj,jk,Kmm)   & 
    306                &                     + uu(ji  ,jj,jk,Kmm)**2 * e2u(ji  ,jj) * e3u(ji  ,jj,jk,Kmm)   & 
    307                &                     + vv(ji,jj-1,jk,Kmm)**2 * e1v(ji,jj-1) * e3v(ji,jj-1,jk,Kmm)   & 
    308                &                     + vv(ji,jj  ,jk,Kmm)**2 * e1v(ji,jj  ) * e3v(ji,jj  ,jk,Kmm)   ) 
    309          END_3D 
    310          CALL lbc_lnk( 'diawri', z3d, 'T', 1.0_wp ) 
    311          CALL iom_put( "eken", z3d )                 ! kinetic energy 
     328            zztmpx = 0.5 * ( uu(ji-1,jj  ,jk,Kmm) + uu(ji,jj,jk,Kmm) ) 
     329            zztmpy = 0.5 * ( vv(ji  ,jj-1,jk,Kmm) + vv(ji,jj,jk,Kmm) ) 
     330            z3d(ji,jj,jk) = 0.5 * ( zztmpx*zztmpx + zztmpy*zztmpy ) 
     331         END_3D 
     332         CALL iom_put( "ke", z3d )                 ! kinetic energy 
     333 
     334         z2d(:,:)  = 0._wp  
     335         DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     336            z2d(ji,jj) = z2d(ji,jj) + e3t(ji,jj,jk,Kmm) * z3d(ji,jj,jk) * e1e2t(ji,jj) * tmask(ji,jj,jk) 
     337         END_3D 
     338         CALL iom_put( "ke_int", z2d )   ! vertically integrated kinetic energy 
    312339      ENDIF 
    313340      ! 
    … …  
    339366      ! 
    340367      CALL iom_put( "hdiv", hdiv )                  ! Horizontal divergence 
     368 
     369      IF ( iom_use("relvor") .OR. iom_use("absvor") .OR. iom_use("potvor") ) THEN 
     370          
     371         z3d(:,:,jpk) = 0._wp  
     372         DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     373            z3d(ji,jj,jk) = (   e2v(ji+1,jj  ) * vv(ji+1,jj  ,jk,Kmm) - e2v(ji,jj) * vv(ji,jj,jk,Kmm)    & 
     374               &              - e1u(ji  ,jj+1) * uu(ji  ,jj+1,jk,Kmm) + e1u(ji,jj) * uu(ji,jj,jk,Kmm)  ) * r1_e1e2f(ji,jj) 
     375         END_3D 
     376         CALL iom_put( "relvor", z3d )                  ! relative vorticity 
     377 
     378         DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     379            z3d(ji,jj,jk) = ff_f(ji,jj) + z3d(ji,jj,jk)  
     380         END_3D 
     381         CALL iom_put( "absvor", z3d )                  ! absolute vorticity 
     382 
     383         DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     384            ze3  = (  e3t(ji,jj+1,jk,Kmm)*tmask(ji,jj+1,jk) + e3t(ji+1,jj+1,jk,Kmm)*tmask(ji+1,jj+1,jk)   & 
     385               &    + e3t(ji,jj  ,jk,Kmm)*tmask(ji,jj  ,jk) + e3t(ji+1,jj  ,jk,Kmm)*tmask(ji+1,jj  ,jk)  ) 
     386            IF( ze3 /= 0._wp ) THEN   ;   ze3 = 4._wp / ze3 
     387            ELSE                      ;   ze3 = 0._wp 
     388            ENDIF 
     389            z3d(ji,jj,jk) = ze3 * z3d(ji,jj,jk)  
     390         END_3D 
     391         CALL iom_put( "potvor", z3d )                  ! potential vorticity 
     392 
     393      ENDIF 
    341394      ! 
    342395      IF( iom_use("u_masstr") .OR. iom_use("u_masstr_vint") .OR. iom_use("u_heattr") .OR. iom_use("u_salttr") ) THEN 
    … …  
    356409            z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) * ( ts(ji,jj,jk,jp_tem,Kmm) + ts(ji+1,jj,jk,jp_tem,Kmm) ) 
    357410         END_3D 
    358          CALL lbc_lnk( 'diawri', z2d, 'U', -1.0_wp ) 
    359411         CALL iom_put( "u_heattr", 0.5*rcp * z2d )    ! heat transport in i-direction 
    360412      ENDIF 
    … …  
    365417            z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) * ( ts(ji,jj,jk,jp_sal,Kmm) + ts(ji+1,jj,jk,jp_sal,Kmm) ) 
    366418         END_3D 
    367          CALL lbc_lnk( 'diawri', z2d, 'U', -1.0_wp ) 
    368419         CALL iom_put( "u_salttr", 0.5 * z2d )        ! heat transport in i-direction 
    369420      ENDIF 
    … …  
    383434            z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) * ( ts(ji,jj,jk,jp_tem,Kmm) + ts(ji,jj+1,jk,jp_tem,Kmm) ) 
    384435         END_3D 
    385          CALL lbc_lnk( 'diawri', z2d, 'V', -1.0_wp ) 
    386436         CALL iom_put( "v_heattr", 0.5*rcp * z2d )    !  heat transport in j-direction 
    387437      ENDIF 
    … …  
    392442            z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) * ( ts(ji,jj,jk,jp_sal,Kmm) + ts(ji,jj+1,jk,jp_sal,Kmm) ) 
    393443         END_3D 
    394          CALL lbc_lnk( 'diawri', z2d, 'V', -1.0_wp ) 
    395444         CALL iom_put( "v_salttr", 0.5 * z2d )        !  heat transport in j-direction 
    396445      ENDIF 
    … …  
    401450            z2d(ji,jj) = z2d(ji,jj) + e3t(ji,jj,jk,Kmm) *  ts(ji,jj,jk,jp_tem,Kmm) 
    402451         END_3D 
    403          CALL lbc_lnk( 'diawri', z2d, 'T', -1.0_wp ) 
    404452         CALL iom_put( "tosmint", rho0 * z2d )        ! Vertical integral of temperature 
    405453      ENDIF 
    … …  
    409457            z2d(ji,jj) = z2d(ji,jj) + e3t(ji,jj,jk,Kmm) * ts(ji,jj,jk,jp_sal,Kmm) 
    410458         END_3D 
    411          CALL lbc_lnk( 'diawri', z2d, 'T', -1.0_wp ) 
    412459         CALL iom_put( "somint", rho0 * z2d )         ! Vertical integral of salinity 
    413460      ENDIF 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DIU/diu_bulk.F90

    r13295 r13998  
    2222    
    2323   ! Namelist parameters 
    24    LOGICAL, PUBLIC :: ln_diurnal 
    25    LOGICAL, PUBLIC :: ln_diurnal_only 
     24   LOGICAL, PUBLIC :: ln_diurnal      = .false.   ! force definition if diurnal_sst_bulk_init is not called 
     25   LOGICAL, PUBLIC :: ln_diurnal_only = .false.   ! force definition if diurnal_sst_bulk_init is not called 
    2626 
    2727   ! Parameters 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DIU/diu_coolskin.F90

    r13295 r13998  
    9595      !!---------------------------------------------------------------------- 
    9696      ! 
    97       IF( .NOT. ln_blk )   CALL ctl_stop("diu_coolskin.f90: diurnal flux processing only implemented for bulk forcing") 
     97      IF( .NOT. (ln_blk .OR. ln_abl) )   CALL ctl_stop("diu_coolskin.f90: diurnal flux processing only implemented for bulk forcing") 
    9898      ! 
    9999      DO_2D( 1, 1, 1, 1 ) 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DOM/closea.F90

    r13286 r13998  
    3838   LOGICAL, PUBLIC :: ln_clo_rnf       !: closed sea treated as runoff (update rnf mask) 
    3939 
    40    LOGICAL, PUBLIC :: l_sbc_clo  !: T => net evap/precip over closed seas spread outover the globe/river mouth 
    41    LOGICAL, PUBLIC :: l_clo_rnf  !: T => Some closed seas output freshwater (RNF) to specified runoff points. 
    42  
    43    INTEGER, PUBLIC :: ncsg      !: number of closed seas global mappings (inferred from closea_mask_glo field) 
    44    INTEGER, PUBLIC :: ncsr      !: number of closed seas rnf    mappings (inferred from closea_mask_rnf field) 
    45    INTEGER, PUBLIC :: ncse      !: number of closed seas empmr  mappings (inferred from closea_mask_emp field) 
     40   ! WARNING: keep default definitions in the following lines as dom_clo is called only if ln_closea = .true. 
     41   LOGICAL, PUBLIC :: l_sbc_clo = .FALSE.   !: T => net evap/precip over closed seas spread outover the globe/river mouth 
     42   LOGICAL, PUBLIC :: l_clo_rnf = .FALSE.   !: T => Some closed seas output freshwater (RNF) to specified runoff points. 
     43 
     44   INTEGER, PUBLIC :: ncsg = 0   !: number of closed seas global mappings (inferred from closea_mask_glo field) 
     45   INTEGER, PUBLIC :: ncsr = 0   !: number of closed seas rnf    mappings (inferred from closea_mask_rnf field) 
     46   INTEGER, PUBLIC :: ncse = 0   !: number of closed seas empmr  mappings (inferred from closea_mask_emp field) 
    4647 
    4748   INTEGER, PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:) :: mask_opnsea, mask_csundef  !: mask defining the open sea and the undefined closed sea 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DOM/daymod.F90

    r13286 r13998  
    8282      ndt05   = NINT( 0.5 * rn_Dt  ) 
    8383 
    84       IF( .NOT. l_offline )   CALL day_rst( nit000, 'READ' ) 
    85  
     84      lrst_oce = .NOT. l_offline   ! force definition of offline 
     85      IF( lrst_oce )   CALL day_rst( nit000, 'READ' ) 
     86       
    8687      ! set the calandar from ndastp (read in restart file and namelist) 
    8788      nyear   =   ndastp / 10000 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DOM/dom_oce.F90

    r13736 r13998  
    222222 
    223223   !!---------------------------------------------------------------------- 
     224   !! variable defined here to avoid circular dependencies... 
     225   !! --------------------------------------------------------------------- 
     226   INTEGER, PUBLIC ::   nbasin         ! number of basin to be considered in diaprt (glo, atl, pac, ind, ipc) 
     227 
     228   !!---------------------------------------------------------------------- 
    224229   !! agrif domain 
    225230   !!---------------------------------------------------------------------- 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DOM/domain.F90

    r13914 r13998  
    257257      !!---------------------------------------------------------------------- 
    258258      ! 
    259       DO ji = 1, jpi                 ! local domain indices ==> global domain, including halos, indices 
     259      DO ji = 1, jpi                 ! local domain indices ==> global domain indices, including halos 
    260260        mig(ji) = ji + nimpp - 1 
    261261      END DO 
    … …  
    263263        mjg(jj) = jj + njmpp - 1 
    264264      END DO 
    265       !                              ! local domain indices ==> global domain, excluding halos, indices 
     265      !                              ! local domain indices ==> global domain indices, excluding halos 
    266266      ! 
    267267      mig0(:) = mig(:) - nn_hls 
    … …  
    568568      !!---------------------------------------------------------------------- 
    569569      ! 
    570       IF(lk_mpp) THEN 
    571          CALL mpp_minloc( 'domain', glamt(:,:), tmask_i(:,:), zglmin, imil ) 
    572          CALL mpp_minloc( 'domain', gphit(:,:), tmask_i(:,:), zgpmin, imip ) 
    573          CALL mpp_minloc( 'domain',   e1t(:,:), tmask_i(:,:), ze1min, imi1 ) 
    574          CALL mpp_minloc( 'domain',   e2t(:,:), tmask_i(:,:), ze2min, imi2 ) 
    575          CALL mpp_maxloc( 'domain', glamt(:,:), tmask_i(:,:), zglmax, imal ) 
    576          CALL mpp_maxloc( 'domain', gphit(:,:), tmask_i(:,:), zgpmax, imap ) 
    577          CALL mpp_maxloc( 'domain',   e1t(:,:), tmask_i(:,:), ze1max, ima1 ) 
    578          CALL mpp_maxloc( 'domain',   e2t(:,:), tmask_i(:,:), ze2max, ima2 ) 
    579       ELSE 
    580          llmsk = tmask_i(:,:) == 1._wp 
    581          zglmin = MINVAL( glamt(:,:), mask = llmsk )     
    582          zgpmin = MINVAL( gphit(:,:), mask = llmsk )     
    583          ze1min = MINVAL(   e1t(:,:), mask = llmsk )     
    584          ze2min = MINVAL(   e2t(:,:), mask = llmsk )     
    585          zglmin = MAXVAL( glamt(:,:), mask = llmsk )     
    586          zgpmin = MAXVAL( gphit(:,:), mask = llmsk )     
    587          ze1max = MAXVAL(   e1t(:,:), mask = llmsk )     
    588          ze2max = MAXVAL(   e2t(:,:), mask = llmsk )     
    589          ! 
    590          imil   = MINLOC( glamt(:,:), mask = llmsk ) + (/ nimpp - 1, njmpp - 1 /) 
    591          imip   = MINLOC( gphit(:,:), mask = llmsk ) + (/ nimpp - 1, njmpp - 1 /) 
    592          imi1   = MINLOC(   e1t(:,:), mask = llmsk ) + (/ nimpp - 1, njmpp - 1 /) 
    593          imi2   = MINLOC(   e2t(:,:), mask = llmsk ) + (/ nimpp - 1, njmpp - 1 /) 
    594          imal   = MAXLOC( glamt(:,:), mask = llmsk ) + (/ nimpp - 1, njmpp - 1 /) 
    595          imap   = MAXLOC( gphit(:,:), mask = llmsk ) + (/ nimpp - 1, njmpp - 1 /) 
    596          ima1   = MAXLOC(   e1t(:,:), mask = llmsk ) + (/ nimpp - 1, njmpp - 1 /) 
    597          ima2   = MAXLOC(   e2t(:,:), mask = llmsk ) + (/ nimpp - 1, njmpp - 1 /) 
    598       ENDIF 
     570      llmsk = tmask_h(:,:) == 1._wp 
     571      ! 
     572      CALL mpp_minloc( 'domain', glamt(:,:), llmsk, zglmin, imil ) 
     573      CALL mpp_minloc( 'domain', gphit(:,:), llmsk, zgpmin, imip ) 
     574      CALL mpp_minloc( 'domain',   e1t(:,:), llmsk, ze1min, imi1 ) 
     575      CALL mpp_minloc( 'domain',   e2t(:,:), llmsk, ze2min, imi2 ) 
     576      CALL mpp_maxloc( 'domain', glamt(:,:), llmsk, zglmax, imal ) 
     577      CALL mpp_maxloc( 'domain', gphit(:,:), llmsk, zgpmax, imap ) 
     578      CALL mpp_maxloc( 'domain',   e1t(:,:), llmsk, ze1max, ima1 ) 
     579      CALL mpp_maxloc( 'domain',   e2t(:,:), llmsk, ze2max, ima2 ) 
    599580      ! 
    600581      IF(lwp) THEN 
    … …  
    718699      ! 
    719700      !                             !==  ORCA family specificities  ==! 
    720       IF( cn_cfg == "ORCA" ) THEN 
     701      IF( TRIM(cn_cfg) == "orca" .OR. TRIM(cn_cfg) == "ORCA" ) THEN 
    721702         CALL iom_rstput( 0, 0, inum, 'ORCA'      , 1._wp            , ktype = jp_i4 ) 
    722703         CALL iom_rstput( 0, 0, inum, 'ORCA_index', REAL( nn_cfg, wp), ktype = jp_i4 )          

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DOM/dommsk.F90

    r13736 r13998  
    9292      INTEGER  ::   iktop, ikbot   !   -       - 
    9393      INTEGER  ::   ios, inum 
    94       REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   zwf   ! 2D workspace 
    9594      !! 
    9695      NAMELIST/namlbc/ rn_shlat, ln_vorlat 
    … …  
    205204      IF( rn_shlat /= 0 ) THEN      ! Not free-slip lateral boundary condition 
    206205         ! 
    207          ALLOCATE( zwf(jpi,jpj) ) 
    208          ! 
    209206         DO jk = 1, jpk 
    210             zwf(:,:) = fmask(:,:,jk)          
    211207            DO_2D( 0, 0, 0, 0 ) 
    212208               IF( fmask(ji,jj,jk) == 0._wp ) THEN 
    213                   fmask(ji,jj,jk) = rn_shlat * MIN( 1._wp , MAX( zwf(ji+1,jj), zwf(ji,jj+1),  & 
    214                      &                                           zwf(ji-1,jj), zwf(ji,jj-1)  ) ) 
     209                  fmask(ji,jj,jk) = rn_shlat * MIN( 1._wp , MAX( umask(ji,jj,jk), umask(ji,jj+1,jk), & 
     210                     &                                           vmask(ji,jj,jk), vmask(ji+1,jj,jk) ) ) 
    215211               ENDIF 
    216212            END_2D 
    217213            DO jj = 2, jpjm1 
    218214               IF( fmask(1,jj,jk) == 0._wp ) THEN 
    219                   fmask(1  ,jj,jk) = rn_shlat * MIN( 1._wp , MAX( zwf(2,jj), zwf(1,jj+1), zwf(1,jj-1) ) ) 
     215                  fmask(1  ,jj,jk) = rn_shlat * MIN( 1._wp , MAX( vmask(2,jj,jk), umask(1,jj+1,jk), umask(1,jj,jk) ) ) 
    220216               ENDIF 
    221217               IF( fmask(jpi,jj,jk) == 0._wp ) THEN 
    222                   fmask(jpi,jj,jk) = rn_shlat * MIN( 1._wp , MAX( zwf(jpi,jj+1), zwf(jpim1,jj), zwf(jpi,jj-1) ) ) 
     218                  fmask(jpi,jj,jk) = rn_shlat * MIN( 1._wp , MAX( umask(jpi,jj+1,jk), vmask(jpim1,jj,jk), umask(jpi,jj-1,jk) ) ) 
    223219               ENDIF 
    224220            END DO          
    225221            DO ji = 2, jpim1 
    226222               IF( fmask(ji,1,jk) == 0._wp ) THEN 
    227                   fmask(ji, 1 ,jk) = rn_shlat * MIN( 1._wp , MAX( zwf(ji+1,1), zwf(ji,2), zwf(ji-1,1) ) ) 
     223                  fmask(ji, 1 ,jk) = rn_shlat * MIN( 1._wp , MAX( vmask(ji+1,1,jk), umask(ji,2,jk), vmask(ji,1,jk) ) ) 
    228224               ENDIF 
    229225               IF( fmask(ji,jpj,jk) == 0._wp ) THEN 
    230                   fmask(ji,jpj,jk) = rn_shlat * MIN( 1._wp , MAX( zwf(ji+1,jpj), zwf(ji-1,jpj), zwf(ji,jpjm1) ) ) 
     226                  fmask(ji,jpj,jk) = rn_shlat * MIN( 1._wp , MAX( vmask(ji+1,jpj,jk), vmask(ji-1,jpj,jk), umask(ji,jpjm1,jk) ) ) 
    231227               ENDIF 
    232228            END DO 
    233229         END DO 
    234          ! 
    235          DEALLOCATE( zwf ) 
    236230         ! 
    237231         CALL lbc_lnk( 'dommsk', fmask, 'F', 1._wp )      ! Lateral boundary conditions on fmask 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DOM/domutl.F90

    r13286 r13998  
    4848      INTEGER , DIMENSION(2) ::   iloc 
    4949      REAL(wp)               ::   zlon, zmini 
    50       REAL(wp), DIMENSION(jpi,jpj) ::   zglam, zgphi, zmask, zdist 
     50      REAL(wp), DIMENSION(jpi,jpj) ::   zglam, zgphi, zdist 
     51      LOGICAL , DIMENSION(jpi,jpj) ::   llmsk 
    5152      !!-------------------------------------------------------------------- 
    5253      ! 
    … …  
    5455      IF ( PRESENT(kkk) ) ik=kkk 
    5556      ! 
    56       CALL dom_uniq(zmask,cdgrid) 
    57       ! 
    5857      SELECT CASE( cdgrid ) 
    59       CASE( 'U' )    ;   zglam(:,:) = glamu(:,:)   ;   zgphi(:,:) = gphiu(:,:)   ;   zmask(:,:) = zmask(:,:) * umask(:,:,ik) 
    60       CASE( 'V' )    ;   zglam(:,:) = glamv(:,:)   ;   zgphi(:,:) = gphiv(:,:)   ;   zmask(:,:) = zmask(:,:) * vmask(:,:,ik) 
    61       CASE( 'F' )    ;   zglam(:,:) = glamf(:,:)   ;   zgphi(:,:) = gphif(:,:)   ;   zmask(:,:) = zmask(:,:) * fmask(:,:,ik) 
    62       CASE DEFAULT   ;   zglam(:,:) = glamt(:,:)   ;   zgphi(:,:) = gphit(:,:)   ;   zmask(:,:) = zmask(:,:) * tmask(:,:,ik) 
     58      CASE( 'U' ) ;   zglam(:,:) = glamu(:,:)   ;   zgphi(:,:) = gphiu(:,:)   ;   llmsk(:,:) = tmask_h(:,:) * umask(:,:,ik) == 1._wp 
     59      CASE( 'V' ) ;   zglam(:,:) = glamv(:,:)   ;   zgphi(:,:) = gphiv(:,:)   ;   llmsk(:,:) = tmask_h(:,:) * vmask(:,:,ik) == 1._wp 
     60      CASE( 'F' ) ;   zglam(:,:) = glamf(:,:)   ;   zgphi(:,:) = gphif(:,:)   ;   llmsk(:,:) = tmask_h(:,:) * fmask(:,:,ik) == 1._wp 
     61      CASE DEFAULT;   zglam(:,:) = glamt(:,:)   ;   zgphi(:,:) = gphit(:,:)   ;   llmsk(:,:) = tmask_h(:,:) * tmask(:,:,ik) == 1._wp 
    6362      END SELECT 
    6463      ! 
    … …  
    6867      IF( zlon <  90. )   WHERE( zglam(:,:) > 180. ) zglam(:,:) = zglam(:,:) - 360.   ! glam between -180 and 180 
    6968      zglam(:,:) = zglam(:,:) - zlon 
    70  
     69      ! 
    7170      zgphi(:,:) = zgphi(:,:) - plat 
    7271      zdist(:,:) = zglam(:,:) * zglam(:,:) + zgphi(:,:) * zgphi(:,:) 
    73        
    74       IF( lk_mpp ) THEN   
    75          CALL mpp_minloc( 'domngb', zdist(:,:), zmask, zmini, iloc) 
    76          kii = iloc(1) ; kjj = iloc(2) 
    77       ELSE 
    78          iloc(:) = MINLOC( zdist(:,:), mask = zmask(:,:) == 1.e0 ) 
    79          kii = iloc(1) + nimpp - 1 
    80          kjj = iloc(2) + njmpp - 1 
    81       ENDIF 
     72      ! 
     73      CALL mpp_minloc( 'domngb', zdist(:,:), llmsk, zmini, iloc, ldhalo = .TRUE. ) 
     74      kii = iloc(1) 
     75      kjj = iloc(2) 
    8276      ! 
    8377   END SUBROUTINE dom_ngb 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DOM/domvvl.F90

    r13895 r13998  
    202202      gdept(:,:,1,Kbb) = 0.5_wp * e3w(:,:,1,Kbb) 
    203203      gdepw(:,:,1,Kbb) = 0.0_wp 
    204       DO_3D( 1, 1, 1, 1, 2, jpk ) 
     204      DO_3D( 1, 1, 1, 1, 2, jpk )                     ! vertical sum 
    205205         !    zcoef = tmask - wmask    ! 0 everywhere tmask = wmask, ie everywhere expect at jk = mikt 
    206206         !                             ! 1 everywhere from mbkt to mikt + 1 or 1 (if no isf) 
    … …  
    334334      LOGICAL                ::   ll_do_bclinic         ! local logical 
    335335      REAL(wp), DIMENSION(jpi,jpj)     ::   zht, z_scale, zwu, zwv, zhdiv 
    336       REAL(wp), DIMENSION(jpi,jpj,jpk) ::   ze3t 
     336      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::   ze3t 
     337      LOGICAL , DIMENSION(:,:,:), ALLOCATABLE ::   llmsk 
    337338      !!---------------------------------------------------------------------- 
    338339      ! 
    … …  
    419420         zwu(:,:) = 0._wp 
    420421         zwv(:,:) = 0._wp 
    421          DO_3D( 1, 0, 1, 0, 1, jpkm1 ) 
     422         DO_3D( 1, 0, 1, 0, 1, jpkm1 )   ! a - first derivative: diffusive fluxes 
    422423            un_td(ji,jj,jk) = rn_ahe3 * umask(ji,jj,jk) * e2_e1u(ji,jj)           & 
    423424               &            * ( tilde_e3t_b(ji,jj,jk) - tilde_e3t_b(ji+1,jj  ,jk) ) 
    … …  
    427428            zwv(ji,jj) = zwv(ji,jj) + vn_td(ji,jj,jk) 
    428429         END_3D 
    429          DO_2D( 1, 1, 1, 1 ) 
     430         DO_2D( 1, 1, 1, 1 )             ! b - correction for last oceanic u-v points 
    430431            un_td(ji,jj,mbku(ji,jj)) = un_td(ji,jj,mbku(ji,jj)) - zwu(ji,jj) 
    431432            vn_td(ji,jj,mbkv(ji,jj)) = vn_td(ji,jj,mbkv(ji,jj)) - zwv(ji,jj) 
    432433         END_2D 
    433          DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     434         DO_3D( 0, 0, 0, 0, 1, jpkm1 )   ! c - second derivative: divergence of diffusive fluxes 
    434435            tilde_e3t_a(ji,jj,jk) = tilde_e3t_a(ji,jj,jk) + (   un_td(ji-1,jj  ,jk) - un_td(ji,jj,jk)    & 
    435436               &                                          +     vn_td(ji  ,jj-1,jk) - vn_td(ji,jj,jk)    & 
    436437               &                                            ) * r1_e1e2t(ji,jj) 
    437438         END_3D 
    438          !                       ! d - thickness diffusion transport: boundary conditions 
     439         !                               ! d - thickness diffusion transport: boundary conditions 
    439440         !                             (stored for tracer advction and continuity equation) 
    440441         CALL lbc_lnk_multi( 'domvvl', un_td , 'U' , -1._wp, vn_td , 'V' , -1._wp) 
    … …  
    447448         ! Maximum deformation control 
    448449         ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~ 
    449          ze3t(:,:,jpk) = 0._wp 
    450          DO jk = 1, jpkm1 
    451             ze3t(:,:,jk) = tilde_e3t_a(:,:,jk) / e3t_0(:,:,jk) * tmask(:,:,jk) * tmask_i(:,:) 
    452          END DO 
    453          z_tmax = MAXVAL( ze3t(:,:,:) ) 
    454          CALL mpp_max( 'domvvl', z_tmax )                 ! max over the global domain 
    455          z_tmin = MINVAL( ze3t(:,:,:) ) 
    456          CALL mpp_min( 'domvvl', z_tmin )                 ! min over the global domain 
     450         ALLOCATE( ze3t(jpi,jpj,jpk), llmsk(jpi,jpj,jpk) ) 
     451         DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     452            ze3t(ji,jj,jk) = tilde_e3t_a(ji,jj,jk) / e3t_0(ji,jj,jk) * tmask(ji,jj,jk) * tmask_i(ji,jj) 
     453         END_3D 
     454         ! 
     455         llmsk(   1:Nis1,:,:) = .FALSE.   ! exclude halos from the checked region 
     456         llmsk(Nie1: jpi,:,:) = .FALSE. 
     457         llmsk(:,   1:Njs1,:) = .FALSE. 
     458         llmsk(:,Nje1: jpj,:) = .FALSE. 
     459         ! 
     460         llmsk(Nis0:Nie0,Njs0:Nje0,:) = tmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp                  ! define only the inner domain 
     461         z_tmax = MAXVAL( ze3t(:,:,:), mask = llmsk )   ;   CALL mpp_max( 'domvvl', z_tmax )   ! max over the global domain 
     462         z_tmin = MINVAL( ze3t(:,:,:), mask = llmsk )   ;   CALL mpp_min( 'domvvl', z_tmin )   ! min over the global domain 
    457463         ! - ML - test: for the moment, stop simulation for too large e3_t variations 
    458464         IF( ( z_tmax >  rn_zdef_max ) .OR. ( z_tmin < - rn_zdef_max ) ) THEN 
    459             IF( lk_mpp ) THEN 
    460                CALL mpp_maxloc( 'domvvl', ze3t, tmask, z_tmax, ijk_max ) 
    461                CALL mpp_minloc( 'domvvl', ze3t, tmask, z_tmin, ijk_min ) 
    462             ELSE 
    463                ijk_max = MAXLOC( ze3t(:,:,:) ) 
    464                ijk_max(1) = ijk_max(1) + nimpp - 1 
    465                ijk_max(2) = ijk_max(2) + njmpp - 1 
    466                ijk_min = MINLOC( ze3t(:,:,:) ) 
    467                ijk_min(1) = ijk_min(1) + nimpp - 1 
    468                ijk_min(2) = ijk_min(2) + njmpp - 1 
    469             ENDIF 
     465            CALL mpp_maxloc( 'domvvl', ze3t, llmsk, z_tmax, ijk_max ) 
     466            CALL mpp_minloc( 'domvvl', ze3t, llmsk, z_tmin, ijk_min ) 
    470467            IF (lwp) THEN 
    471468               WRITE(numout, *) 'MAX( tilde_e3t_a(:,:,:) / e3t_0(:,:,:) ) =', z_tmax 
    … …  
    476473            ENDIF 
    477474         ENDIF 
     475         DEALLOCATE( ze3t, llmsk ) 
    478476         ! - ML - end test 
    479477         ! - ML - Imposing these limits will cause a baroclinicity error which is corrected for below 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DOM/dtatsd.F90

    r13295 r13998  
    186186         ENDIF 
    187187         ! 
    188          DO_2D( 1, 1, 1, 1 ) 
     188         DO_2D( 1, 1, 1, 1 )                  ! vertical interpolation of T & S 
    189189            DO jk = 1, jpk                        ! determines the intepolated T-S profiles at each (i,j) points 
    190190               zl = gdept_0(ji,jj,jk) 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DYN/divhor.F90

    r13295 r13998  
    7777      ENDIF 
    7878      ! 
    79       DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
    80          hdiv(ji,jj,jk) = (  e2u(ji  ,jj) * e3u(ji  ,jj,jk,Kmm) * uu(ji  ,jj,jk,Kmm)      & 
     79      DO_3D( 0, 0, 0, 0, 1, jpkm1 )                                    !==  Horizontal divergence  ==! 
     80         hdiv(ji,jj,jk) = (   e2u(ji  ,jj) * e3u(ji  ,jj,jk,Kmm) * uu(ji  ,jj,jk,Kmm)      & 
    8181            &               - e2u(ji-1,jj) * e3u(ji-1,jj,jk,Kmm) * uu(ji-1,jj,jk,Kmm)      & 
    8282            &               + e1v(ji,jj  ) * e3v(ji,jj  ,jk,Kmm) * vv(ji,jj  ,jk,Kmm)      & 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DYN/dynadv_cen2.F90

    r13295 r13998  
    7272         zfu(:,:,jk) = 0.25_wp * e2u(:,:) * e3u(:,:,jk,Kmm) * puu(:,:,jk,Kmm) 
    7373         zfv(:,:,jk) = 0.25_wp * e1v(:,:) * e3v(:,:,jk,Kmm) * pvv(:,:,jk,Kmm) 
    74          DO_2D( 1, 0, 1, 0 ) 
     74         DO_2D( 1, 0, 1, 0 )              ! horizontal momentum fluxes (at T- and F-point) 
    7575            zfu_t(ji+1,jj  ,jk) = ( zfu(ji,jj,jk) + zfu(ji+1,jj,jk) ) * ( puu(ji,jj,jk,Kmm) + puu(ji+1,jj  ,jk,Kmm) ) 
    7676            zfv_f(ji  ,jj  ,jk) = ( zfv(ji,jj,jk) + zfv(ji+1,jj,jk) ) * ( puu(ji,jj,jk,Kmm) + puu(ji  ,jj+1,jk,Kmm) ) 
    … …  
    7878            zfv_t(ji  ,jj+1,jk) = ( zfv(ji,jj,jk) + zfv(ji,jj+1,jk) ) * ( pvv(ji,jj,jk,Kmm) + pvv(ji  ,jj+1,jk,Kmm) ) 
    7979         END_2D 
    80          DO_2D( 0, 0, 0, 0 ) 
     80         DO_2D( 0, 0, 0, 0 )              ! divergence of horizontal momentum fluxes 
    8181            puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) - (  zfu_t(ji+1,jj,jk) - zfu_t(ji,jj  ,jk)    & 
    8282               &                           + zfv_f(ji  ,jj,jk) - zfv_f(ji,jj-1,jk)  ) * r1_e1e2u(ji,jj)   & 
    … …  
    9898      !                             !==  Vertical advection  ==! 
    9999      ! 
    100       DO_2D( 0, 0, 0, 0 ) 
     100      DO_2D( 0, 0, 0, 0 )                 ! surface/bottom advective fluxes set to zero 
    101101         zfu_uw(ji,jj,jpk) = 0._wp   ;   zfv_vw(ji,jj,jpk) = 0._wp 
    102102         zfu_uw(ji,jj, 1 ) = 0._wp   ;   zfv_vw(ji,jj, 1 ) = 0._wp 
    … …  
    109109      ENDIF 
    110110      DO jk = 2, jpkm1                    ! interior advective fluxes 
    111          DO_2D( 0, 1, 0, 1 ) 
     111         DO_2D( 0, 1, 0, 1 )                  ! 1/4 * Vertical transport 
    112112            zfw(ji,jj,jk) = 0.25_wp * e1e2t(ji,jj) * ww(ji,jj,jk) 
    113113         END_2D 
    … …  
    117117         END_2D 
    118118      END DO 
    119       DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     119      DO_3D( 0, 0, 0, 0, 1, jpkm1 )       ! divergence of vertical momentum flux divergence 
    120120         puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) - ( zfu_uw(ji,jj,jk) - zfu_uw(ji,jj,jk+1) ) * r1_e1e2u(ji,jj)   & 
    121121            &                                      / e3u(ji,jj,jk,Kmm) 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DYN/dynadv_ubs.F90

    r13295 r13998  
    108108         zfv(:,:,jk) = e1v(:,:) * e3v(:,:,jk,Kmm) * pvv(:,:,jk,Kmm) 
    109109         !             
    110          DO_2D( 0, 0, 0, 0 ) 
     110         DO_2D( 0, 0, 0, 0 )                       ! laplacian 
    111111            zlu_uu(ji,jj,jk,1) = ( puu (ji+1,jj  ,jk,Kbb) - 2.*puu (ji,jj,jk,Kbb) + puu (ji-1,jj  ,jk,Kbb) ) * umask(ji,jj,jk) 
    112112            zlv_vv(ji,jj,jk,1) = ( pvv (ji  ,jj+1,jk,Kbb) - 2.*pvv (ji,jj,jk,Kbb) + pvv (ji  ,jj-1,jk,Kbb) ) * vmask(ji,jj,jk) 
    … …  
    136136         zfv(:,:,jk) = 0.25_wp * e1v(:,:) * e3v(:,:,jk,Kmm) * pvv(:,:,jk,Kmm) 
    137137         ! 
    138          DO_2D( 1, 0, 1, 0 ) 
     138         DO_2D( 1, 0, 1, 0 )                       ! horizontal momentum fluxes at T- and F-point 
    139139            zui = ( puu(ji,jj,jk,Kmm) + puu(ji+1,jj  ,jk,Kmm) ) 
    140140            zvj = ( pvv(ji,jj,jk,Kmm) + pvv(ji  ,jj+1,jk,Kmm) ) 
    … …  
    168168               &                * ( pvv(ji,jj,jk,Kmm) + pvv(ji+1,jj  ,jk,Kmm) - gamma1 * zl_v ) 
    169169         END_2D 
    170          DO_2D( 0, 0, 0, 0 ) 
     170         DO_2D( 0, 0, 0, 0 )                       ! divergence of horizontal momentum fluxes 
    171171            puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) - (  zfu_t(ji+1,jj,jk) - zfu_t(ji,jj  ,jk)    & 
    172172               &                           + zfv_f(ji  ,jj,jk) - zfv_f(ji,jj-1,jk)  ) * r1_e1e2u(ji,jj)   & 
    … …  
    187187      !                                      !  Vertical advection  ! 
    188188      !                                      ! ==================== ! 
    189       DO_2D( 0, 0, 0, 0 ) 
     189      DO_2D( 0, 0, 0, 0 )                          ! surface/bottom advective fluxes set to zero 
    190190         zfu_uw(ji,jj,jpk) = 0._wp 
    191191         zfv_vw(ji,jj,jpk) = 0._wp 
    … …  
    208208         END_2D 
    209209      END DO 
    210       DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     210      DO_3D( 0, 0, 0, 0, 1, jpkm1 )             ! divergence of vertical momentum flux divergence 
    211211         puu(ji,jj,jk,Krhs) =  puu(ji,jj,jk,Krhs) - ( zfu_uw(ji,jj,jk) - zfu_uw(ji,jj,jk+1) ) * r1_e1e2u(ji,jj)   & 
    212212            &                                       / e3u(ji,jj,jk,Kmm) 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DYN/dynatf.F90

    r13295 r13998  
    3434   USE dynspg_ts      ! surface pressure gradient: split-explicit scheme 
    3535   USE domvvl         ! variable volume 
    36    USE bdy_oce   , ONLY: ln_bdy 
     36   USE bdy_oce , ONLY : ln_bdy 
    3737   USE bdydta         ! ocean open boundary conditions 
    3838   USE bdydyn         ! ocean open boundary conditions 
    … …  
    5050   USE prtctl         ! Print control 
    5151   USE timing         ! Timing 
     52   USE zdfdrg ,  ONLY : ln_drgice_imp, rCdU_top 
    5253#if defined key_agrif 
    5354   USE agrif_oce_interp 
    … …  
    120121      REAL(wp) ::   zve3a, zve3n, zve3b, z1_2dt   !   -      - 
    121122      REAL(wp), ALLOCATABLE, DIMENSION(:,:)   ::   zue, zve, zwfld 
     123      REAL(wp), ALLOCATABLE, DIMENSION(:,:)   ::   zutau, zvtau 
    122124      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   ze3t_f, ze3u_f, ze3v_f, zua, zva  
    123125      !!---------------------------------------------------------------------- 
    … …  
    321323      ENDIF 
    322324      ! 
     325      IF ( iom_use("utau") ) THEN 
     326         IF ( ln_drgice_imp.OR.ln_isfcav ) THEN 
     327            ALLOCATE(zutau(jpi,jpj))  
     328            DO_2D( 0, 0, 0, 0 ) 
     329               jk = miku(ji,jj)  
     330               zutau(ji,jj) = utau(ji,jj) + 0.5_wp * rho0 * ( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) * puu(ji,jj,jk,Kaa) 
     331            END_2D 
     332            CALL iom_put(  "utau", zutau(:,:) ) 
     333            DEALLOCATE(zutau) 
     334         ELSE 
     335            CALL iom_put(  "utau", utau(:,:) ) 
     336         ENDIF 
     337      ENDIF 
     338      ! 
     339      IF ( iom_use("vtau") ) THEN 
     340         IF ( ln_drgice_imp.OR.ln_isfcav ) THEN 
     341            ALLOCATE(zvtau(jpi,jpj)) 
     342            DO_2D( 0, 0, 0, 0 ) 
     343               jk = mikv(ji,jj) 
     344               zvtau(ji,jj) = vtau(ji,jj) + 0.5_wp * rho0 * ( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) * pvv(ji,jj,jk,Kaa) 
     345            END_2D 
     346            CALL iom_put(  "vtau", zvtau(:,:) ) 
     347            DEALLOCATE(zvtau) 
     348         ELSE 
     349            CALL iom_put(  "vtau", vtau(:,:) ) 
     350         ENDIF 
     351      ENDIF 
     352      ! 
    323353      IF(sn_cfctl%l_prtctl)   CALL prt_ctl( tab3d_1=puu(:,:,:,Kaa), clinfo1=' nxt  - puu(:,:,:,Kaa): ', mask1=umask,   & 
    324354         &                                  tab3d_2=pvv(:,:,:,Kaa), clinfo2=' pvv(:,:,:,Kaa): '       , mask2=vmask ) 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DYN/dynkeg.F90

    r13295 r13998  
    125125      END SELECT  
    126126      ! 
    127       DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     127      DO_3D( 0, 0, 0, 0, 1, jpkm1 )       !==  grad( KE ) added to the general momentum trends  ==! 
    128128         puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) - ( zhke(ji+1,jj  ,jk) - zhke(ji,jj,jk) ) / e1u(ji,jj) 
    129129         pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) - ( zhke(ji  ,jj+1,jk) - zhke(ji,jj,jk) ) / e2v(ji,jj) 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DYN/dynldf_iso.F90

    r13295 r13998  
    128128      IF( ln_dynldf_hor .AND. ln_traldf_iso ) THEN 
    129129         ! 
    130          DO_3D( 0, 0, 0, 0, 1, jpk ) 
     130         DO_3D( 0, 0, 0, 0, 1, jpk )      ! set the slopes of iso-level 
    131131            uslp (ji,jj,jk) = - ( gdept(ji+1,jj,jk,Kbb) - gdept(ji ,jj ,jk,Kbb) ) * r1_e1u(ji,jj) * umask(ji,jj,jk) 
    132132            vslp (ji,jj,jk) = - ( gdept(ji,jj+1,jk,Kbb) - gdept(ji ,jj ,jk,Kbb) ) * r1_e2v(ji,jj) * vmask(ji,jj,jk) 
    … …  
    268268         ! Second derivative (divergence) and add to the general trend 
    269269         ! ----------------------------------------------------------- 
    270          DO_2D( 0, 0, 0, 0 ) 
     270         DO_2D( 0, 0, 0, 0 )      !!gm Question vectop possible??? !!bug 
    271271            puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + (  ziut(ji+1,jj) - ziut(ji,jj  )    & 
    272272               &                           + zjuf(ji  ,jj) - zjuf(ji,jj-1)  ) * r1_e1e2u(ji,jj)   & 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DYN/dynldf_lap_blp.F90

    r13513 r13998  
    9494            END_2D 
    9595            ! 
    96             DO_2D( 0, 0, 0, 0 ) 
     96            DO_2D( 0, 0, 0, 0 )                       ! - curl( curl) + grad( div ) 
    9797               pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + zsign * umask(ji,jj,jk) * (    &    ! * by umask is mandatory for dyn_ldf_blp use 
    9898                  &              - ( zcur(ji  ,jj) - zcur(ji,jj-1) ) * r1_e2u(ji,jj) / e3u(ji,jj,jk,Kmm)   & 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DYN/dynspg.F90

    r13295 r13998  
    102102         IF( ln_apr_dyn .AND. .NOT.ln_dynspg_ts ) THEN   !==  Atmospheric pressure gradient (added later in time-split case) ==! 
    103103            zg_2 = grav * 0.5 
    104             DO_2D( 0, 0, 0, 0 ) 
     104            DO_2D( 0, 0, 0, 0 )                       ! gradient of Patm using inverse barometer ssh 
    105105               spgu(ji,jj) = spgu(ji,jj) + zg_2 * (  ssh_ib (ji+1,jj) - ssh_ib (ji,jj)    & 
    106106                  &                                + ssh_ibb(ji+1,jj) - ssh_ibb(ji,jj)  ) * r1_e1u(ji,jj) 
    … …  
    117117            CALL upd_tide(zt0step, Kmm) 
    118118            ! 
    119             DO_2D( 0, 0, 0, 0 ) 
     119            DO_2D( 0, 0, 0, 0 )                      ! add tide potential forcing 
    120120               spgu(ji,jj) = spgu(ji,jj) + grav * ( pot_astro(ji+1,jj) - pot_astro(ji,jj) ) * r1_e1u(ji,jj) 
    121121               spgv(ji,jj) = spgv(ji,jj) + grav * ( pot_astro(ji,jj+1) - pot_astro(ji,jj) ) * r1_e2v(ji,jj) 
    … …  
    124124            IF (ln_scal_load) THEN 
    125125               zld = rn_scal_load * grav 
    126                DO_2D( 0, 0, 0, 0 ) 
     126               DO_2D( 0, 0, 0, 0 )                   ! add scalar approximation for load potential 
    127127                  spgu(ji,jj) = spgu(ji,jj) + zld * ( pssh(ji+1,jj,Kmm) - pssh(ji,jj,Kmm) ) * r1_e1u(ji,jj) 
    128128                  spgv(ji,jj) = spgv(ji,jj) + zld * ( pssh(ji,jj+1,Kmm) - pssh(ji,jj,Kmm) ) * r1_e2v(ji,jj) 
    … …  
    143143         ENDIF 
    144144         ! 
    145          DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     145         DO_3D( 0, 0, 0, 0, 1, jpkm1 )       !== Add all terms to the general trend 
    146146            puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + spgu(ji,jj) 
    147147            pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) + spgv(ji,jj) 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DYN/dynspg_exp.F90

    r13295 r13998  
    7474      IF( ln_linssh ) THEN          !* linear free surface : add the surface pressure gradient trend 
    7575         ! 
    76          DO_2D( 0, 0, 0, 0 ) 
     76         DO_2D( 0, 0, 0, 0 )                 ! now surface pressure gradient 
    7777            spgu(ji,jj) = - grav * ( ssh(ji+1,jj,Kmm) - ssh(ji,jj,Kmm) ) * r1_e1u(ji,jj) 
    7878            spgv(ji,jj) = - grav * ( ssh(ji,jj+1,Kmm) - ssh(ji,jj,Kmm) ) * r1_e2v(ji,jj) 
    7979         END_2D 
    8080         ! 
    81          DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     81         DO_3D( 0, 0, 0, 0, 1, jpkm1 )       ! Add it to the general trend 
    8282            puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) + spgu(ji,jj) 
    8383            pvv(ji,jj,jk,Krhs) = pvv(ji,jj,jk,Krhs) + spgv(ji,jj) 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DYN/dynspg_ts.F90

    r13895 r13998  
    264264         IF( ln_wd_il ) THEN                       ! W/D : limiter applied to spgspg 
    265265            CALL wad_spg( pssh(:,:,Kmm), zcpx, zcpy )          ! Calculating W/D gravity filters, zcpx and zcpy 
    266             DO_2D( 0, 0, 0, 0 ) 
     266            DO_2D( 0, 0, 0, 0 )                                ! SPG with the application of W/D gravity filters 
    267267               zu_trd(ji,jj) = zu_trd(ji,jj) - grav * ( pssh(ji+1,jj  ,Kmm) - pssh(ji  ,jj ,Kmm) )   & 
    268268                  &                          * r1_e1u(ji,jj) * zcpx(ji,jj)  * wdrampu(ji,jj)  !jth 
    … …  
    279279      ENDIF 
    280280      ! 
    281       DO_2D( 0, 0, 0, 0 ) 
     281      DO_2D( 0, 0, 0, 0 )                          ! Remove coriolis term (and possibly spg) from barotropic trend 
    282282          zu_frc(ji,jj) = zu_frc(ji,jj) - zu_trd(ji,jj) * ssumask(ji,jj) 
    283283          zv_frc(ji,jj) = zv_frc(ji,jj) - zv_trd(ji,jj) * ssvmask(ji,jj) 
    … …  
    477477#if defined key_qcoTest_FluxForm 
    478478            !                                ! 'key_qcoTest_FluxForm' : simple ssh average 
    479             DO_2D( 1, 1, 1, 0 ) 
     479            DO_2D( 1, 1, 1, 0 )   ! not jpi-column 
    480480               zhup2_e(ji,jj) = hu_0(ji,jj) + r1_2 * (  zsshp2_e(ji,jj) + zsshp2_e(ji+1,jj  )  ) * ssumask(ji,jj) 
    481481            END_2D 
    … …  
    485485#else 
    486486            !                                ! no 'key_qcoTest_FluxForm' : surface weighted ssh average 
    487             DO_2D( 1, 1, 1, 0 ) 
     487            DO_2D( 1, 1, 1, 0 )   ! not jpi-column 
    488488               zhup2_e(ji,jj) = hu_0(ji,jj) + r1_2 * r1_e1e2u(ji,jj)                        & 
    489489                    &                              * (  e1e2t(ji  ,jj) * zsshp2_e(ji  ,jj)  & 
    490490                    &                                 + e1e2t(ji+1,jj) * zsshp2_e(ji+1,jj)  ) * ssumask(ji,jj) 
    491491            END_2D 
    492             DO_2D( 1, 0, 1, 1 ) 
     492            DO_2D( 1, 0, 1, 1 )   ! not jpj-row 
    493493               zhvp2_e(ji,jj) = hv_0(ji,jj) + r1_2 * r1_e1e2v(ji,jj)                        & 
    494494                    &                              * (  e1e2t(ji,jj  ) * zsshp2_e(ji,jj  )  & 
    … …  
    950950               CALL iom_get( numror, jpdom_auto, 'ub2_i_b'  , ub2_i_b(:,:), cd_type = 'U', psgn = -1._wp, ldxios = lrxios )    
    951951               CALL iom_get( numror, jpdom_auto, 'vb2_i_b'  , vb2_i_b(:,:), cd_type = 'V', psgn = -1._wp, ldxios = lrxios ) 
     952            ELSE 
     953               ub2_i_b(:,:) = 0._wp   ;   vb2_i_b(:,:) = 0._wp   ! used in the 1st update of agrif 
    952954            ENDIF 
    953955#endif 
    … …  
    955957            IF(lwp) WRITE(numout,*) 
    956958            IF(lwp) WRITE(numout,*) '   ==>>>   start from rest: set barotropic values to 0' 
    957             ub2_b (:,:) = 0._wp   ;   vb2_b (:,:) = 0._wp   ! used in the 1st interpol of agrif 
    958             un_adv(:,:) = 0._wp   ;   vn_adv(:,:) = 0._wp   ! used in the 1st interpol of agrif 
    959             un_bf (:,:) = 0._wp   ;   vn_bf (:,:) = 0._wp   ! used in the 1st update   of agrif 
     959            ub2_b  (:,:) = 0._wp   ;   vb2_b (:,:) = 0._wp   ! used in the 1st interpol of agrif 
     960            un_adv (:,:) = 0._wp   ;   vn_adv (:,:) = 0._wp   ! used in the 1st interpol of agrif 
     961            un_bf  (:,:) = 0._wp   ;   vn_bf (:,:) = 0._wp   ! used in the 1st update   of agrif 
    960962#if defined key_agrif 
    961             IF ( .NOT.Agrif_Root() ) THEN 
    962                ub2_i_b(:,:) = 0._wp   ;   vb2_i_b(:,:) = 0._wp   ! used in the 1st update of agrif 
    963             ENDIF 
     963            ub2_i_b(:,:) = 0._wp   ;   vb2_i_b(:,:) = 0._wp   ! used in the 1st update of agrif 
    964964#endif 
    965965         ENDIF 
    … …  
    12951295      !!---------------------------------------------------------------------- 
    12961296      ! 
    1297       DO_2D( 1, 1, 1, 0 ) 
     1297      DO_2D( 1, 1, 1, 0 )   ! not jpi-column 
    12981298         IF ( phU(ji,jj) > 0._wp ) THEN   ;   pUmsk(ji,jj) = pTmsk(ji  ,jj)  
    12991299         ELSE                             ;   pUmsk(ji,jj) = pTmsk(ji+1,jj)   
    … …  
    13031303      END_2D 
    13041304      ! 
    1305       DO_2D( 1, 0, 1, 1 ) 
     1305      DO_2D( 1, 0, 1, 1 )   ! not jpj-row 
    13061306         IF ( phV(ji,jj) > 0._wp ) THEN   ;   pVmsk(ji,jj) = pTmsk(ji,jj  ) 
    13071307         ELSE                             ;   pVmsk(ji,jj) = pTmsk(ji,jj+1)   
    … …  
    13911391      !                    !==  Set the barotropic drag coef.  ==! 
    13921392      ! 
    1393       IF( ln_isfcav ) THEN          ! top+bottom friction (ocean cavities) 
     1393      IF( ln_isfcav.OR.ln_drgice_imp ) THEN          ! top+bottom friction (ocean cavities) 
    13941394          
    13951395         DO_2D( 0, 0, 0, 0 ) 
    … …  
    14421442      !                    !==  TOP stress contribution from baroclinic velocities  ==!   (no W/D case) 
    14431443      ! 
    1444       IF( ln_isfcav ) THEN 
     1444      IF( ln_isfcav.OR.ln_drgice_imp ) THEN 
    14451445         ! 
    14461446         IF( ln_bt_fw ) THEN                ! FORWARD integration: use NOW top baroclinic velocity 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DYN/dynvor.F90

    r13734 r13998  
    223223      REAL(wp) ::   zx1, zy1, zx2, zy2   ! local scalars 
    224224      REAL(wp), DIMENSION(jpi,jpj)     ::   zwx, zwy, zwt   ! 2D workspace 
    225       REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   zwz      ! 3D workspace 
     225      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   zwz      ! 3D workspace, jpkm1 -> avoid lbc_lnk on jpk that is not defined 
    226226      !!---------------------------------------------------------------------- 
    227227      ! 
    … …  
    248248            ENDIF 
    249249         END DO 
    250          CALL lbc_lnk( 'dynvor', zwz, 'F', 1. ) 
     250         CALL lbc_lnk( 'dynvor', zwz, 'F', 1.0_wp ) 
    251251         ! 
    252252      END SELECT 
    … …  
    591591      REAL(wp) ::   zua, zva     ! local scalars 
    592592      REAL(wp) ::   zmsk, ze3f   ! local scalars 
    593       REAL(wp), DIMENSION(jpi,jpj)     ::   zwx , zwy , z1_e3f 
    594       REAL(wp), DIMENSION(jpi,jpj)     ::   ztnw, ztne, ztsw, ztse 
    595       REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zwz 
     593      REAL(wp), DIMENSION(jpi,jpj)       ::   zwx , zwy , z1_e3f 
     594      REAL(wp), DIMENSION(jpi,jpj)       ::   ztnw, ztne, ztsw, ztse 
     595      REAL(wp), DIMENSION(jpi,jpj,jpkm1) ::   zwz   ! 3D workspace, jpkm1 -> jpkm1 -> avoid lbc_lnk on jpk that is not defined 
    596596      !!---------------------------------------------------------------------- 
    597597      ! 
    … …  
    740740      REAL(wp) ::   zua, zva       ! local scalars 
    741741      REAL(wp) ::   zmsk, z1_e3t   ! local scalars 
    742       REAL(wp), DIMENSION(jpi,jpj)     ::   zwx , zwy  
    743       REAL(wp), DIMENSION(jpi,jpj)     ::   ztnw, ztne, ztsw, ztse 
    744       REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zwz 
     742      REAL(wp), DIMENSION(jpi,jpj)       ::   zwx , zwy  
     743      REAL(wp), DIMENSION(jpi,jpj)       ::   ztnw, ztne, ztsw, ztse 
     744      REAL(wp), DIMENSION(jpi,jpj,jpkm1) ::   zwz   ! 3D workspace, avoid lbc_lnk on jpk that is not defined 
    745745      !!---------------------------------------------------------------------- 
    746746      ! 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DYN/dynzad.F90

    r13295 r13998  
    7171      ENDIF 
    7272 
    73       IF( l_trddyn )   THEN         ! Save puu(:,:,:,Krhs) and pvv(:,:,:,Krhs) trends 
     73      IF( l_trddyn )   THEN           ! Save puu(:,:,:,Krhs) and pvv(:,:,:,Krhs) trends 
    7474         ALLOCATE( ztrdu(jpi,jpj,jpk) , ztrdv(jpi,jpj,jpk) )  
    7575         ztrdu(:,:,:) = puu(:,:,:,Krhs)  
    … …  
    7777      ENDIF 
    7878       
    79       DO jk = 2, jpkm1              ! Vertical momentum advection at level w and u- and v- vertical 
    80          DO_2D( 0, 1, 0, 1 ) 
     79      DO jk = 2, jpkm1                ! Vertical momentum advection at level w and u- and v- vertical 
     80         DO_2D( 0, 1, 0, 1 )              ! vertical fluxes 
    8181            zww(ji,jj) = 0.25_wp * e1e2t(ji,jj) * ww(ji,jj,jk) 
    8282         END_2D 
    83          DO_2D( 0, 0, 0, 0 ) 
     83         DO_2D( 0, 0, 0, 0 )              ! vertical momentum advection at w-point 
    8484            zwuw(ji,jj,jk) = ( zww(ji+1,jj  ) + zww(ji,jj) ) * ( puu(ji,jj,jk-1,Kmm) - puu(ji,jj,jk,Kmm) ) 
    8585            zwvw(ji,jj,jk) = ( zww(ji  ,jj+1) + zww(ji,jj) ) * ( pvv(ji,jj,jk-1,Kmm) - pvv(ji,jj,jk,Kmm) ) 
    … …  
    9595      END_2D 
    9696      ! 
    97       DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     97      DO_3D( 0, 0, 0, 0, 1, jpkm1 )   ! Vertical momentum advection at u- and v-points 
    9898         puu(ji,jj,jk,Krhs) = puu(ji,jj,jk,Krhs) - ( zwuw(ji,jj,jk) + zwuw(ji,jj,jk+1) ) * r1_e1e2u(ji,jj)   & 
    9999            &                                      / e3u(ji,jj,jk,Kmm) 
    … …  
    102102      END_3D 
    103103 
    104       IF( l_trddyn ) THEN           ! save the vertical advection trends for diagnostic 
     104      IF( l_trddyn ) THEN             ! save the vertical advection trends for diagnostic 
    105105         ztrdu(:,:,:) = puu(:,:,:,Krhs) - ztrdu(:,:,:) 
    106106         ztrdv(:,:,:) = pvv(:,:,:,Krhs) - ztrdv(:,:,:) 
    … …  
    108108         DEALLOCATE( ztrdu, ztrdv )  
    109109      ENDIF 
    110       !                             ! Control print 
     110      !                               ! Control print 
    111111      IF(sn_cfctl%l_prtctl)   CALL prt_ctl( tab3d_1=puu(:,:,:,Krhs), clinfo1=' zad  - Ua: ', mask1=umask,   & 
    112112         &                                  tab3d_2=pvv(:,:,:,Krhs), clinfo2=       ' Va: ', mask2=vmask, clinfo3='dyn' ) 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DYN/dynzdf.F90

    r13295 r13998  
    131131            pvv(ji,jj,jk,Kaa) = ( pvv(ji,jj,jk,Kaa) - vv_b(ji,jj,Kaa) ) * vmask(ji,jj,jk) 
    132132         END_3D 
    133          DO_2D( 0, 0, 0, 0 ) 
     133         DO_2D( 0, 0, 0, 0 )      ! Add bottom/top stress due to barotropic component only 
    134134            iku = mbku(ji,jj)         ! ocean bottom level at u- and v-points  
    135135            ikv = mbkv(ji,jj)         ! (deepest ocean u- and v-points) 
    … …  
    141141            pvv(ji,jj,ikv,Kaa) = pvv(ji,jj,ikv,Kaa) + rDt * 0.5*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) * vv_b(ji,jj,Kaa) / ze3va 
    142142         END_2D 
    143          IF( ln_isfcav ) THEN    ! Ocean cavities (ISF) 
     143         IF( ln_isfcav.OR.ln_drgice_imp ) THEN    ! Ocean cavities (ISF) 
    144144            DO_2D( 0, 0, 0, 0 ) 
    145145               iku = miku(ji,jj)         ! top ocean level at u- and v-points  
    … …  
    190190            END_3D 
    191191         END SELECT 
    192          DO_2D( 0, 0, 0, 0 ) 
     192         DO_2D( 0, 0, 0, 0 )     !* Surface boundary conditions 
    193193            zwi(ji,jj,1) = 0._wp 
    194194            ze3ua =  ( 1._wp - r_vvl ) * e3u(ji,jj,1,Kmm)    & 
    … …  
    227227            END_3D 
    228228         END SELECT 
    229          DO_2D( 0, 0, 0, 0 ) 
     229         DO_2D( 0, 0, 0, 0 )     !* Surface boundary conditions 
    230230            zwi(ji,jj,1) = 0._wp 
    231231            zwd(ji,jj,1) = 1._wp - zws(ji,jj,1) 
    … …  
    247247            zwd(ji,jj,iku) = zwd(ji,jj,iku) - rDt * 0.5*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) / ze3ua 
    248248         END_2D 
    249          IF ( ln_isfcav ) THEN   ! top friction (always implicit) 
     249         IF ( ln_isfcav.OR.ln_drgice_imp ) THEN   ! top friction (always implicit) 
    250250            DO_2D( 0, 0, 0, 0 ) 
    251251               !!gm   top Cd is masked (=0 outside cavities) no need of test on mik>=2  ==>> it has been suppressed 
    … …  
    273273      !----------------------------------------------------------------------- 
    274274      ! 
    275       DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 
     275      DO_3D( 0, 0, 0, 0, 2, jpkm1 )   !==  First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1   (increasing k)  == 
    276276         zwd(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) / zwd(ji,jj,jk-1) 
    277277      END_3D 
    278278      ! 
    279       DO_2D( 0, 0, 0, 0 ) 
     279      DO_2D( 0, 0, 0, 0 )             !==  second recurrence:    SOLk = RHSk - Lk / Dk-1  Lk-1  ==! 
    280280         ze3ua =  ( 1._wp - r_vvl ) * e3u(ji,jj,1,Kmm)    & 
    281281            &             + r_vvl   * e3u(ji,jj,1,Kaa)  
    … …  
    287287      END_3D 
    288288      ! 
    289       DO_2D( 0, 0, 0, 0 ) 
     289      DO_2D( 0, 0, 0, 0 )             !==  thrid recurrence : SOLk = ( Lk - Uk * Ek+1 ) / Dk  ==! 
    290290         puu(ji,jj,jpkm1,Kaa) = puu(ji,jj,jpkm1,Kaa) / zwd(ji,jj,jpkm1) 
    291291      END_2D 
    … …  
    329329            END_3D 
    330330         END SELECT 
    331          DO_2D( 0, 0, 0, 0 ) 
     331         DO_2D( 0, 0, 0, 0 )   !* Surface boundary conditions 
    332332            zwi(ji,jj,1) = 0._wp 
    333333            ze3va =  ( 1._wp - r_vvl ) * e3v(ji,jj,1,Kmm)    & 
    … …  
    366366            END_3D 
    367367         END SELECT 
    368          DO_2D( 0, 0, 0, 0 ) 
     368         DO_2D( 0, 0, 0, 0 )        !* Surface boundary conditions 
    369369            zwi(ji,jj,1) = 0._wp 
    370370            zwd(ji,jj,1) = 1._wp - zws(ji,jj,1) 
    … …  
    385385            zwd(ji,jj,ikv) = zwd(ji,jj,ikv) - rDt * 0.5*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) / ze3va            
    386386         END_2D 
    387          IF ( ln_isfcav ) THEN 
     387         IF ( ln_isfcav.OR.ln_drgice_imp ) THEN 
    388388            DO_2D( 0, 0, 0, 0 ) 
    389389               ikv = mikv(ji,jj)       ! (first wet ocean u- and v-points) 
    … …  
    410410      !----------------------------------------------------------------------- 
    411411      ! 
    412       DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 
     412      DO_3D( 0, 0, 0, 0, 2, jpkm1 )   !==  First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1   (increasing k)  == 
    413413         zwd(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) / zwd(ji,jj,jk-1) 
    414414      END_3D 
    415415      ! 
    416       DO_2D( 0, 0, 0, 0 ) 
     416      DO_2D( 0, 0, 0, 0 )             !==  second recurrence:    SOLk = RHSk - Lk / Dk-1  Lk-1  ==! 
    417417         ze3va =  ( 1._wp - r_vvl ) * e3v(ji,jj,1,Kmm)    & 
    418418            &             + r_vvl   * e3v(ji,jj,1,Kaa)  
    … …  
    424424      END_3D 
    425425      ! 
    426       DO_2D( 0, 0, 0, 0 ) 
     426      DO_2D( 0, 0, 0, 0 )             !==  third recurrence : SOLk = ( Lk - Uk * SOLk+1 ) / Dk  ==! 
    427427         pvv(ji,jj,jpkm1,Kaa) = pvv(ji,jj,jpkm1,Kaa) / zwd(ji,jj,jpkm1) 
    428428      END_2D 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DYN/sshwzv.F90

    r13915 r13998  
    206206      ELSE                                            !==  Quasi-Eulerian vertical coordinate  ==!   ('key_qco') 
    207207         !                                            !==========================================! 
    208          DO jk = jpkm1, 1, -1                       ! integrate from the bottom the hor. divergence 
     208         DO jk = jpkm1, 1, -1                               ! integrate from the bottom the hor. divergence 
    209209            pww(:,:,jk) = pww(:,:,jk+1) - (  e3t(:,:,jk,Kmm) * hdiv(:,:,jk)                 & 
    210210               &                            + r1_Dt * (  e3t(:,:,jk,Kaa)        & 
    … …  
    398398      ! 
    399399      IF( MAXVAL( Cu_adv(:,:,:) ) > Cu_min ) THEN       ! Quick check if any breaches anywhere 
    400          DO_3DS( 1, 1, 1, 1, jpkm1, 2, -1 ) 
     400         DO_3DS( 1, 1, 1, 1, jpkm1, 2, -1 )             ! or scan Courant criterion and partition ! w where necessary 
    401401            ! 
    402402            zCu = MAX( Cu_adv(ji,jj,jk) , Cu_adv(ji,jj,jk-1) ) 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/DYN/wet_dry.F90

    r13295 r13998  
    5757   REAL(wp), PUBLIC  ::   ssh_ref     !: height of z=0 with respect to the geoid;  
    5858 
    59    LOGICAL,  PUBLIC  ::   ll_wd       !: Wetting/drying activation switch if either ln_wd_il or ln_wd_dl 
     59   LOGICAL,  PUBLIC  ::   ll_wd = .FALSE. !: Wetting/drying activation switch (ln_wd_il or ln_wd_dl) <- default def if wad_init not called 
    6060 
    6161   PUBLIC   wad_init                  ! initialisation routine called by step.F90 
    … …  
    111111 
    112112      r_rn_wdmin1 = 1 / rn_wdmin1 
    113       ll_wd = .FALSE. 
    114113      IF( ln_wd_il .OR. ln_wd_dl ) THEN 
    115114         ll_wd = .TRUE. 
    … …  
    307306      zwdlmtv(:,:) = 1._wp 
    308307      ! 
    309       DO_2D( 0, 1, 0, 1 ) 
     308      DO_2D( 0, 1, 0, 1 )      ! Horizontal Flux in u and v direction 
    310309         ! 
    311310         IF( tmask(ji, jj, 1 ) < 0.5_wp) CYCLE   ! we don't care about land cells 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/FLO/flo_oce.F90

    r11536 r13998  
    1919   !! ---------------- 
    2020   LOGICAL, PUBLIC ::   ln_floats   !: Activate floats or not 
    21    INTEGER, PUBLIC ::   jpnfl       !: total number of floats during the run 
     21   INTEGER, PUBLIC ::   jpnfl = 0   !: total number of floats during the run 
    2222   INTEGER, PUBLIC ::   jpnnewflo   !: number of floats added in a new run 
    2323   INTEGER, PUBLIC ::   jpnrstflo   !: number of floats for the restart 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/ICB/icbtrj.F90

    r13062 r13998  
    3535   PUBLIC   icb_trj_end     ! routine called in icbstp.F90 module 
    3636 
    37    INTEGER ::   num_traj 
     37   INTEGER ::   num_traj = 0 
    3838   INTEGER ::   n_dim, m_dim 
    3939   INTEGER ::   ntrajid 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/IOM/iom.F90

    r13512 r13998  
    123123      REAL(wp), DIMENSION(2,jpkam1)         :: za_bnds   ! ABL vertical boundaries 
    124124      LOGICAL ::   ll_closedef = .TRUE. 
     125      LOGICAL ::   ll_exist 
    125126      !!---------------------------------------------------------------------- 
    126127      ! 
    … …  
    235236          CALL iom_set_axis_attr( "ghw_abl", bounds=za_bnds ) 
    236237 
    237           CALL iom_set_axis_attr( "nfloat", (/ (REAL(ji,wp), ji=1,jpnfl) /) ) 
     238          CALL iom_set_axis_attr(  "nfloat", (/ (REAL(ji,wp), ji=1,jpnfl) /) ) 
    238239# if defined key_si3 
    239240          CALL iom_set_axis_attr( "ncatice", (/ (REAL(ji,wp), ji=1,jpl) /) ) 
    … …  
    248249          CALL iom_set_axis_attr( "iax_26C", (/ REAL(26,wp) /) )   ! strange syntaxe and idea... 
    249250          CALL iom_set_axis_attr( "iax_28C", (/ REAL(28,wp) /) )   ! strange syntaxe and idea... 
    250           CALL iom_set_axis_attr( "basin"  , (/ (REAL(ji,wp), ji=1,5) /) ) 
     251          ! for diaprt, we need to define an axis which size can be 1 (default) or 5 (if the file subbasins.nc exists) 
     252          INQUIRE( FILE = 'subbasins.nc', EXIST = ll_exist ) 
     253          nbasin = 1 + 4 * COUNT( (/ll_exist/) ) 
     254          CALL iom_set_axis_attr( "basin"  , (/ (REAL(ji,wp), ji=1,nbasin) /) ) 
    251255      ENDIF 
    252256      ! 
    … …  
    355359           rst_file = TRIM(clpath)//TRIM(cn_ocerst_in) 
    356360        ELSE 
    357            rst_file = TRIM(clpath)//'1_'//TRIM(cn_ocerst_in) 
     361           rst_file = TRIM(clpath)//TRIM(Agrif_CFixed())//'_'//TRIM(cn_ocerst_in) 
    358362        ENDIF 
    359363!set name of the restart file and enable available fields 
    … …  
    19151919      IF( iom_use(cdname) ) THEN 
    19161920#if defined key_iomput 
    1917          IF( SIZE(pfield2d, dim=1) == jpi .AND. SIZE(pfield2d, dim=2) == jpj ) THEN 
    1918             CALL xios_send_field( cdname, pfield2d(Nis0:Nie0, Njs0:Nje0) )       ! this extraction will create a copy of pfield2d 
    1919          ELSE 
    1920             CALL xios_send_field( cdname, pfield2d ) 
    1921          ENDIF 
     1921         CALL xios_send_field( cdname, pfield2d ) 
    19221922#else 
    19231923         WRITE(numout,*) pfield2d   ! iom_use(cdname) = .F. -> useless test to avoid compilation warnings 
    … …  
    19311931      IF( iom_use(cdname) ) THEN 
    19321932#if defined key_iomput 
    1933          IF( SIZE(pfield2d, dim=1) == jpi .AND. SIZE(pfield2d, dim=2) == jpj ) THEN 
    1934             CALL xios_send_field( cdname, pfield2d(Nis0:Nie0, Njs0:Nje0) )       ! this extraction will create a copy of pfield2d 
    1935          ELSE 
    1936             CALL xios_send_field( cdname, pfield2d ) 
    1937          ENDIF 
     1933         CALL xios_send_field( cdname, pfield2d ) 
    19381934#else 
    19391935         WRITE(numout,*) pfield2d   ! iom_use(cdname) = .F. -> useless test to avoid compilation warnings 
    … …  
    19471943      IF( iom_use(cdname) ) THEN 
    19481944#if defined key_iomput 
    1949          IF( SIZE(pfield3d, dim=1) == jpi .AND. SIZE(pfield3d, dim=2) == jpj ) THEN 
    1950             CALL xios_send_field( cdname, pfield3d(Nis0:Nie0, Njs0:Nje0,:) )     ! this extraction will create a copy of pfield3d 
    1951          ELSE 
    1952             CALL xios_send_field( cdname, pfield3d ) 
    1953          ENDIF 
     1945         CALL xios_send_field( cdname, pfield3d ) 
    19541946#else 
    19551947         WRITE(numout,*) pfield3d   ! iom_use(cdname) = .F. -> useless test to avoid compilation warnings 
    … …  
    19631955      IF( iom_use(cdname) ) THEN 
    19641956#if defined key_iomput 
    1965          IF( SIZE(pfield3d, dim=1) == jpi .AND. SIZE(pfield3d, dim=2) == jpj ) THEN 
    1966             CALL xios_send_field( cdname, pfield3d(Nis0:Nie0, Njs0:Nje0,:) )     ! this extraction will create a copy of pfield3d 
    1967          ELSE 
    1968             CALL xios_send_field( cdname, pfield3d ) 
    1969          ENDIF 
     1957         CALL xios_send_field( cdname, pfield3d ) 
    19701958#else 
    19711959         WRITE(numout,*) pfield3d   ! iom_use(cdname) = .F. -> useless test to avoid compilation warnings 
    … …  
    19791967      IF( iom_use(cdname) ) THEN 
    19801968#if defined key_iomput 
    1981          IF( SIZE(pfield4d, dim=1) == jpi .AND. SIZE(pfield4d, dim=2) == jpj ) THEN 
    1982             CALL xios_send_field( cdname, pfield4d(Nis0:Nie0, Njs0:Nje0,:,:) )   ! this extraction will create a copy of pfield4d 
    1983          ELSE 
    1984             CALL xios_send_field (cdname, pfield4d ) 
    1985          ENDIF 
     1969         CALL xios_send_field (cdname, pfield4d ) 
    19861970#else 
    19871971         WRITE(numout,*) pfield4d   ! iom_use(cdname) = .F. -> useless test to avoid compilation warnings 
    … …  
    19951979      IF( iom_use(cdname) ) THEN 
    19961980#if defined key_iomput 
    1997          IF( SIZE(pfield4d, dim=1) == jpi .AND. SIZE(pfield4d, dim=2) == jpj ) THEN 
    1998             CALL xios_send_field( cdname, pfield4d(Nis0:Nie0, Njs0:Nje0,:,:) )   ! this extraction will create a copy of pfield4d 
    1999          ELSE 
    2000             CALL xios_send_field (cdname, pfield4d ) 
    2001          ENDIF 
     1981         CALL xios_send_field (cdname, pfield4d ) 
    20021982#else 
    20031983         WRITE(numout,*) pfield4d   ! iom_use(cdname) = .F. -> useless test to avoid compilation warnings 
    … …  
    22052185      ! 
    22062186      CALL iom_set_domain_attr("grid_"//cdgrd, ni_glo=Ni0glo,nj_glo=Nj0glo,ibegin=mig0(Nis0)-1,jbegin=mjg0(Njs0)-1,ni=Ni_0,nj=Nj_0) 
    2207       CALL iom_set_domain_attr("grid_"//cdgrd, data_dim=2, data_ibegin = 0, data_ni = Ni_0, data_jbegin = 0, data_nj = Nj_0) 
     2187      CALL iom_set_domain_attr("grid_"//cdgrd, data_dim=2, data_ibegin = -nn_hls, data_ni = jpi, data_jbegin = -nn_hls, data_nj = jpj) 
    22082188!don't define lon and lat for restart reading context.  
    22092189      IF ( .NOT.ldrxios ) & 
    … …  
    23042284      CALL dom_ngb( 180.0_wp, 90.0_wp, ix, iy, 'T' ) !  i-line that passes near the North Pole : Reference latitude (used in plots) 
    23052285      CALL iom_set_domain_attr("gznl", ni_glo=Ni0glo, nj_glo=Nj0glo, ibegin=mig0(Nis0)-1, jbegin=mjg0(Njs0)-1, ni=Ni_0, nj=Nj_0) 
    2306       CALL iom_set_domain_attr("gznl", data_dim=2, data_ibegin = 0, data_ni = Ni_0, data_jbegin = 0, data_nj = Nj_0) 
     2286      CALL iom_set_domain_attr("gznl", data_dim=2, data_ibegin = -nn_hls, data_ni = jpi, data_jbegin = -nn_hls, data_nj = jpj) 
    23072287      CALL iom_set_domain_attr("gznl", lonvalue = real(zlon, dp),   & 
    23082288         &                             latvalue = real(RESHAPE(plat(Nis0:Nie0, Njs0:Nje0),(/ Ni_0*Nj_0 /)),dp))   
    2309       CALL iom_set_zoom_domain_attr("ptr", ibegin=ix-1, jbegin=0, ni=1, nj=Nj_0) 
     2289      CALL iom_set_zoom_domain_attr("ptr", ibegin=ix-1, jbegin=0, ni=1, nj=Nj0glo) 
    23102290      ! 
    23112291      CALL iom_update_file_name('ptr') 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/IOM/iom_def.F90

    r13286 r13998  
    3333   INTEGER, PUBLIC            ::   iom_open_init = 0   !: used to initialize iom_file(:)%nfid to 0 
    3434!XIOS write restart    
    35    LOGICAL, PUBLIC            ::   lwxios          !: write single file restart using XIOS 
    36    INTEGER, PUBLIC            ::   nxioso          !: type of restart file when writing using XIOS 1 - single, 2 - multiple 
     35   LOGICAL, PUBLIC            ::   lwxios = .FALSE.    !: write single file restart using XIOS 
     36   INTEGER, PUBLIC            ::   nxioso = 0          !: type of restart file when writing using XIOS 1 - single, 2 - multiple 
    3737!XIOS read restart    
    38    LOGICAL, PUBLIC            ::   lrxios          !: read single file restart using XIOS 
     38   LOGICAL, PUBLIC            ::   lrxios = .FALSE.     !: read single file restart using XIOS 
    3939   LOGICAL, PUBLIC            ::   lxios_sini = .FALSE. ! is restart in a single file 
    4040   LOGICAL, PUBLIC            ::   lxios_set  = .FALSE.  

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/ISF/isf_oce.F90

    r12077 r13998  
    7474   ! 
    7575   ! 2.1 -------- ice shelf cavity parameter -------------- 
    76    LOGICAL , PUBLIC            :: l_isfoasis 
     76   LOGICAL , PUBLIC            :: l_isfoasis = .FALSE. 
    7777   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)    ::   risfload                    !: ice shelf load 
    7878   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)    ::   fwfisf_oasis 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/ISF/isfcavmlt.F90

    r13295 r13998  
    136136      !! ** Method     : The ice shelf melt latent heat is defined as being equal to the ocean/ice heat flux. 
    137137      !!                 From this we can derived the fwf, ocean/ice heat flux and the heat content flux as being : 
    138       !!                   qfwf  = Gammat * Rau0 * Cp * ( Tw - Tfrz ) / Lf  
     138      !!                   qfwf  = Gammat * rho0 * Cp * ( Tw - Tfrz ) / Lf  
    139139      !!                   qhoce = qlat 
    140140      !!                   qhc   = qfwf * Cp * Tfrz 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/LBC/lbc_lnk_multi_generic.h90

    r13286 r13998  
    3535#endif 
    3636 
    37    SUBROUTINE ROUTINE_MULTI( cdname                                                                             & 
    38       &                    , pt1, cdna1, psgn1, pt2 , cdna2 , psgn2 , pt3 , cdna3 , psgn3 , pt4, cdna4, psgn4   & 
    39       &                    , pt5, cdna5, psgn5, pt6 , cdna6 , psgn6 , pt7 , cdna7 , psgn7 , pt8, cdna8, psgn8   & 
    40       &                    , pt9, cdna9, psgn9, pt10, cdna10, psgn10, pt11, cdna11, psgn11                      & 
     37   SUBROUTINE ROUTINE_MULTI( cdname                                                                               & 
     38      &                    , pt1 , cdna1 , psgn1 , pt2 , cdna2 , psgn2 , pt3 , cdna3 , psgn3 , pt4 , cdna4 , psgn4   & 
     39      &                    , pt5 , cdna5 , psgn5 , pt6 , cdna6 , psgn6 , pt7 , cdna7 , psgn7 , pt8 , cdna8 , psgn8   & 
     40      &                    , pt9 , cdna9 , psgn9 , pt10, cdna10, psgn10, pt11, cdna11, psgn11, pt12, cdna12, psgn12  & 
     41      &                    , pt13, cdna13, psgn13, pt14, cdna14, psgn14, pt15, cdna15, psgn15, pt16, cdna16, psgn16  & 
    4142      &                    , kfillmode, pfillval, lsend, lrecv ) 
    4243      !!--------------------------------------------------------------------- 
    43       CHARACTER(len=*)   ,                   INTENT(in   ) :: cdname  ! name of the calling subroutine 
    44       ARRAY_TYPE(:,:,:,:)          , TARGET, INTENT(inout) :: pt1     ! arrays on which the lbc is applied 
    45       ARRAY_TYPE(:,:,:,:), OPTIONAL, TARGET, INTENT(inout) :: pt2  , pt3  , pt4  , pt5  , pt6  , pt7  , pt8  , pt9  , pt10  , pt11 
    46       CHARACTER(len=1)                     , INTENT(in   ) :: cdna1   ! nature of pt2D. array grid-points 
    47       CHARACTER(len=1)   , OPTIONAL        , INTENT(in   ) :: cdna2, cdna3, cdna4, cdna5, cdna6, cdna7, cdna8, cdna9, cdna10, cdna11 
    48       REAL(wp)                             , INTENT(in   ) :: psgn1   ! sign used across the north fold 
    49       REAL(wp)           , OPTIONAL        , INTENT(in   ) :: psgn2, psgn3, psgn4, psgn5, psgn6, psgn7, psgn8, psgn9, psgn10, psgn11 
    50       INTEGER            , OPTIONAL        , INTENT(in   ) :: kfillmode   ! filling method for halo over land (default = constant) 
    51       REAL(wp)           , OPTIONAL        , INTENT(in   ) :: pfillval    ! background value (used at closed boundaries) 
    52       LOGICAL, DIMENSION(4), OPTIONAL      , INTENT(in   ) :: lsend, lrecv   ! indicate how communications are to be carried out 
     44      CHARACTER(len=*)     ,                   INTENT(in   ) ::   cdname  ! name of the calling subroutine 
     45      ARRAY_TYPE(:,:,:,:)            , TARGET, INTENT(inout) ::   pt1     ! arrays on which the lbc is applied 
     46      ARRAY_TYPE(:,:,:,:)  , OPTIONAL, TARGET, INTENT(inout) ::   pt2   , pt3   , pt4   , pt5   , pt6   , pt7   , pt8   , pt9  , & 
     47         &                                                        pt10  , pt11  , pt12  , pt13  , pt14  , pt15  , pt16 
     48      CHARACTER(len=1)                       , INTENT(in   ) ::   cdna1   ! nature of pt2D. array grid-points 
     49      CHARACTER(len=1)     , OPTIONAL        , INTENT(in   ) ::   cdna2 , cdna3 , cdna4 , cdna5 , cdna6 , cdna7 , cdna8 , cdna9, & 
     50         &                                                        cdna10, cdna11, cdna12, cdna13, cdna14, cdna15, cdna16 
     51      REAL(wp)                               , INTENT(in   ) ::   psgn1   ! sign used across the north fold 
     52      REAL(wp)             , OPTIONAL        , INTENT(in   ) ::   psgn2 , psgn3 , psgn4 , psgn5 , psgn6 , psgn7 , psgn8 , psgn9, & 
     53         &                                                        psgn10, psgn11, psgn12, psgn13, psgn14, psgn15, psgn16 
     54      INTEGER              , OPTIONAL        , INTENT(in   ) ::   kfillmode   ! filling method for halo over land (default = constant) 
     55      REAL(wp)             , OPTIONAL        , INTENT(in   ) ::   pfillval    ! background value (used at closed boundaries) 
     56      LOGICAL, DIMENSION(4), OPTIONAL        , INTENT(in   ) ::   lsend, lrecv   ! indicate how communications are to be carried out 
    5357      !! 
    5458      INTEGER                          ::   kfld        ! number of elements that will be attributed 
    55       PTR_TYPE         , DIMENSION(11) ::   ptab_ptr    ! pointer array 
    56       CHARACTER(len=1) , DIMENSION(11) ::   cdna_ptr    ! nature of ptab_ptr grid-points 
    57       REAL(wp)         , DIMENSION(11) ::   psgn_ptr    ! sign used across the north fold boundary 
     59      PTR_TYPE         , DIMENSION(16) ::   ptab_ptr    ! pointer array 
     60      CHARACTER(len=1) , DIMENSION(16) ::   cdna_ptr    ! nature of ptab_ptr grid-points 
     61      REAL(wp)         , DIMENSION(16) ::   psgn_ptr    ! sign used across the north fold boundary 
    5862      !!--------------------------------------------------------------------- 
    5963      ! 
    … …  
    7478      IF( PRESENT(psgn10) )   CALL ROUTINE_LOAD( pt10, cdna10, psgn10, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
    7579      IF( PRESENT(psgn11) )   CALL ROUTINE_LOAD( pt11, cdna11, psgn11, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
     80      IF( PRESENT(psgn12) )   CALL ROUTINE_LOAD( pt12, cdna12, psgn12, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
     81      IF( PRESENT(psgn13) )   CALL ROUTINE_LOAD( pt13, cdna13, psgn13, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
     82      IF( PRESENT(psgn14) )   CALL ROUTINE_LOAD( pt14, cdna14, psgn14, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
     83      IF( PRESENT(psgn15) )   CALL ROUTINE_LOAD( pt15, cdna15, psgn15, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
     84      IF( PRESENT(psgn16) )   CALL ROUTINE_LOAD( pt16, cdna16, psgn16, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
    7685      ! 
    77       CALL lbc_lnk_ptr    ( cdname,              ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, lsend, lrecv ) 
     86      CALL lbc_lnk_ptr( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, lsend, lrecv ) 
    7887      ! 
    7988   END SUBROUTINE ROUTINE_MULTI 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/LBC/lib_mpp.F90

    r13286 r13998  
    7373   PUBLIC   tic_tac 
    7474#if ! defined key_mpp_mpi 
     75   PUBLIC MPI_wait 
    7576   PUBLIC MPI_Wtime 
    7677#endif 
    … …  
    115116#else    
    116117   INTEGER, PUBLIC, PARAMETER ::   MPI_STATUS_SIZE = 1 
     118   INTEGER, PUBLIC, PARAMETER ::   MPI_REAL = 4 
    117119   INTEGER, PUBLIC, PARAMETER ::   MPI_DOUBLE_PRECISION = 8 
    118120   LOGICAL, PUBLIC, PARAMETER ::   lk_mpp = .FALSE.    !: mpp flag 
    … …  
    509511            ALLOCATE(todelay(idvar)%y1d(isz)) 
    510512            todelay(idvar)%y1d(:) = CMPLX(todelay(idvar)%z1d(:), 0., wp)   ! create %y1d, complex variable needed by mpi_sumdd 
     513            ndelayid(idvar) = MPI_REQUEST_NULL                             ! initialised request to a valid value 
    511514         END IF 
    512515      ENDIF 
    … …  
    516519         ALLOCATE(todelay(idvar)%z1d(isz), todelay(idvar)%y1d(isz))   ! allocate also %z1d as used for the restart 
    517520         CALL mpi_allreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ierr )   ! get %y1d 
    518          todelay(idvar)%z1d(:) = REAL(todelay(idvar)%y1d(:), wp)      ! define %z1d from %y1d 
    519       ENDIF 
    520  
    521       IF( ndelayid(idvar) > 0 )   CALL mpp_delay_rcv( idvar )         ! make sure %z1d is received 
     521         ndelayid(idvar) = MPI_REQUEST_NULL 
     522      ENDIF 
     523 
     524      CALL mpp_delay_rcv( idvar )         ! make sure %z1d is received 
    522525 
    523526      ! send back pout from todelay(idvar)%z1d defined at previous call 
    … …  
    528531      IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.) 
    529532      CALL  mpi_allreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ierr ) 
    530       ndelayid(idvar) = 1 
     533      ndelayid(idvar) = MPI_REQUEST_NULL 
    531534      IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) 
    532535# else 
    … …  
    589592            DEALLOCATE(todelay(idvar)%z1d) 
    590593            ndelayid(idvar) = -1                                      ! do as if we had no restart 
     594         ELSE 
     595            ndelayid(idvar) = MPI_REQUEST_NULL 
    591596         END IF 
    592597      ENDIF 
    … …  
    596601         ALLOCATE(todelay(idvar)%z1d(isz)) 
    597602         CALL mpi_allreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ierr )   ! get %z1d 
    598       ENDIF 
    599  
    600       IF( ndelayid(idvar) > 0 )   CALL mpp_delay_rcv( idvar )         ! make sure %z1d is received 
     603         ndelayid(idvar) = MPI_REQUEST_NULL 
     604      ENDIF 
     605 
     606      CALL mpp_delay_rcv( idvar )         ! make sure %z1d is received 
    601607 
    602608      ! send back pout from todelay(idvar)%z1d defined at previous call 
    … …  
    604610 
    605611      ! send p_in into todelay(idvar)%z1d with a non-blocking communication 
     612      ! (PM) Should we get rid of MPI2 option ? MPI3 was release in 2013. Who is still using MPI2 ? 
    606613# if defined key_mpi2 
    607614      IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.) 
    608       CALL  mpi_allreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_TYPE, mpi_max, ilocalcomm, ndelayid(idvar), ierr ) 
     615      CALL  mpi_allreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_TYPE, mpi_max, ilocalcomm, ierr ) 
    609616      IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) 
    610617# else 
    … …  
    629636      !!---------------------------------------------------------------------- 
    630637#if defined key_mpp_mpi 
    631       IF( ndelayid(kid) /= -2 ) THEN   
    632 #if ! defined key_mpi2 
    633          IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.) 
    634          CALL mpi_wait( ndelayid(kid), MPI_STATUS_IGNORE, ierr )                        ! make sure todelay(kid) is received 
    635          IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) 
    636 #endif 
    637          IF( ASSOCIATED(todelay(kid)%y1d) )   todelay(kid)%z1d(:) = REAL(todelay(kid)%y1d(:), wp)  ! define %z1d from %y1d 
    638          ndelayid(kid) = -2   ! add flag to know that mpi_wait was already called on kid 
    639       ENDIF 
     638      IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.) 
     639      ! test on ndelayid(kid) useless as mpi_wait return immediatly if the request handle is MPI_REQUEST_NULL 
     640      CALL mpi_wait( ndelayid(kid), MPI_STATUS_IGNORE, ierr ) ! after this ndelayid(kid) = MPI_REQUEST_NULL 
     641      IF( ln_timing ) CALL tic_tac( .FALSE., ld_global = .TRUE.) 
     642      IF( ASSOCIATED(todelay(kid)%y1d) )   todelay(kid)%z1d(:) = REAL(todelay(kid)%y1d(:), wp)  ! define %z1d from %y1d 
    640643#endif 
    641644   END SUBROUTINE mpp_delay_rcv 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/LBC/mpp_lbc_north_icb_generic.h90

    r13286 r13998  
    6767      ! 
    6868      IF( ln_timing ) CALL tic_tac(.TRUE.) 
     69#if defined key_mpp_mpi 
    6970      CALL MPI_ALLGATHER( znorthloc_e(1,1-kextj)    , itaille, MPI_TYPE,    & 
    7071         &                znorthgloio_e(1,1-kextj,1), itaille, MPI_TYPE,    & 
    7172         &                ncomm_north, ierr ) 
     73#endif 
    7274      ! 
    7375      IF( ln_timing ) CALL tic_tac(.FALSE.) 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/LBC/mpp_loc_generic.h90

    r13286 r13998  
    22#   if defined SINGLE_PRECISION 
    33#      define ARRAY_TYPE(i,j,k)    REAL(sp)        , INTENT(in   ) ::   ARRAY_IN(i,j,k) 
    4 #      define MASK_TYPE(i,j,k)     REAL(sp)        , INTENT(in   ) ::   MASK_IN(i,j,k) 
     4#if defined key_mpp_mpi 
     5#      define MPI_TYPE MPI_2REAL 
     6#endif 
    57#      define PRECISION sp 
    68#   else 
    79#      define ARRAY_TYPE(i,j,k)    REAL(dp)        , INTENT(in   ) ::   ARRAY_IN(i,j,k) 
    8 #      define MASK_TYPE(i,j,k)     REAL(dp)        , INTENT(in   ) ::   MASK_IN(i,j,k) 
     10#if defined key_mpp_mpi 
     11#      define MPI_TYPE MPI_2DOUBLE_PRECISION 
     12#endif 
    913#      define PRECISION dp 
    1014#   endif 
    … …  
    1216#   if defined DIM_2d 
    1317#      define ARRAY_IN(i,j,k)   ptab(i,j) 
    14 #      define MASK_IN(i,j,k)    pmask(i,j) 
     18#      define MASK_IN(i,j,k)    ldmsk(i,j) 
    1519#      define INDEX_TYPE(k)        INTEGER         , INTENT(  out) ::   kindex(2) 
    1620#      define K_SIZE(ptab)      1 
    … …  
    1822#   if defined DIM_3d 
    1923#      define ARRAY_IN(i,j,k)   ptab(i,j,k) 
    20 #      define MASK_IN(i,j,k)    pmask(i,j,k) 
     24#      define MASK_IN(i,j,k)    ldmsk(i,j,k) 
    2125#      define INDEX_TYPE(k)        INTEGER         , INTENT(  out) ::   kindex(3) 
    2226#      define K_SIZE(ptab)      SIZE(ptab,3) 
    2327#   endif 
    2428#   if defined OPERATION_MAXLOC 
    25 #      define MPI_OPERATION mpi_maxloc 
     29#      define MPI_OPERATION MPI_MAXLOC 
    2630#      define LOC_OPERATION MAXLOC 
    2731#      define ERRVAL -HUGE 
    2832#   endif 
    2933#   if defined OPERATION_MINLOC 
    30 #      define MPI_OPERATION mpi_minloc 
     34#      define MPI_OPERATION MPI_MINLOC 
    3135#      define LOC_OPERATION MINLOC 
    3236#      define ERRVAL HUGE 
    3337#   endif 
    3438 
    35    SUBROUTINE ROUTINE_LOC( cdname, ptab, pmask, pmin, kindex ) 
     39   SUBROUTINE ROUTINE_LOC( cdname, ptab, ldmsk, pmin, kindex, ldhalo ) 
    3640      !!---------------------------------------------------------------------- 
    37       CHARACTER(len=*), INTENT(in   ) ::   cdname  ! name of the calling subroutine 
     41      CHARACTER(len=*), INTENT(in    ) ::   cdname  ! name of the calling subroutine 
    3842      ARRAY_TYPE(:,:,:)                            ! array on which loctrans operation is applied 
    39       MASK_TYPE(:,:,:)                             ! local mask 
    40       REAL(PRECISION)        , INTENT(  out) ::   pmin    ! Global minimum of ptab 
     43      LOGICAL          , INTENT(in   ) ::   MASK_IN(:,:,:)                     ! local mask 
     44      REAL(PRECISION)  , INTENT(  out) ::   pmin    ! Global minimum of ptab 
    4145      INDEX_TYPE(:)                                ! index of minimum in global frame 
     46      LOGICAL, OPTIONAL, INTENT(in   ) ::   ldhalo  ! If .false. (default) excludes halos in kindex  
    4247      ! 
    4348      INTEGER  ::   ierror, ii, idim 
    4449      INTEGER  ::   index0 
     50      INTEGER , DIMENSION(:), ALLOCATABLE  ::   ilocs 
    4551      REAL(PRECISION) ::   zmin     ! local minimum 
    46       INTEGER , DIMENSION(:), ALLOCATABLE  ::   ilocs 
    47       REAL(dp), DIMENSION(2,1) ::   zain, zaout 
     52      REAL(PRECISION), DIMENSION(2,1) ::   zain, zaout 
     53      LOGICAL  ::   llhalo 
    4854      !!----------------------------------------------------------------------- 
    4955      ! 
    5056      IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ld_glb = .TRUE. ) 
    5157      ! 
     58      IF( PRESENT(ldhalo) ) THEN   ;   llhalo = ldhalo 
     59      ELSE                         ;   llhalo = .FALSE. 
     60      ENDIF 
     61      ! 
    5262      idim = SIZE(kindex) 
    5363      ! 
    54       IF ( ALL(MASK_IN(:,:,:) /= 1._wp) ) THEN 
    55          ! special case for land processors 
    56          zmin = ERRVAL(zmin) 
    57          index0 = 0 
    58       ELSE 
     64      IF ( ANY( MASK_IN(:,:,:) ) ) THEN   ! there is at least 1 valid point... 
     65         ! 
    5966         ALLOCATE ( ilocs(idim) ) 
    6067         ! 
    61          ilocs = LOC_OPERATION( ARRAY_IN(:,:,:) , mask= MASK_IN(:,:,:) == 1._wp ) 
     68         ilocs = LOC_OPERATION( ARRAY_IN(:,:,:) , mask= MASK_IN(:,:,:) ) 
    6269         zmin  = ARRAY_IN(ilocs(1),ilocs(2),ilocs(3)) 
    6370         ! 
    … …  
    7986         index0 = index0 + jpiglo * jpjglo * (kindex(3)-1) 
    8087#endif 
     88      ELSE 
     89         ! special case for land processors 
     90         zmin = ERRVAL(zmin) 
     91         index0 = 0 
    8192      END IF 
     93      ! 
    8294      zain(1,:) = zmin 
    83       zain(2,:) = REAL(index0, wp) 
     95      zain(2,:) = REAL(index0, PRECISION) 
    8496      ! 
     97#if defined key_mpp_mpi 
    8598      IF( ln_timing ) CALL tic_tac(.TRUE., ld_global = .TRUE.) 
    86 #if defined key_mpp_mpi 
    87       CALL MPI_ALLREDUCE( zain, zaout, 1, MPI_2DOUBLE_PRECISION, MPI_OPERATION ,MPI_COMM_OCE, ierror) 
     99      CALL MPI_ALLREDUCE( zain, zaout, 1, MPI_TYPE, MPI_OPERATION ,MPI_COMM_OCE, ierror) 
     100      IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) 
    88101#else 
    89102      zaout(:,:) = zain(:,:) 
    90103#endif 
    91       IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) 
    92104      ! 
    93105      pmin      = zaout(1,1) 
    … …  
    104116      kindex(:) = kindex(:) + 1   ! start indices at 1 
    105117 
     118      IF( .NOT. llhalo ) THEN 
     119         kindex(1)  = kindex(1) - nn_hls 
     120#if defined DIM_2d || defined DIM_3d   /* avoid warning when kindex has 1 element */ 
     121         kindex(2)  = kindex(2) - nn_hls 
     122#endif 
     123      ENDIF 
     124       
    106125   END SUBROUTINE ROUTINE_LOC 
    107126 
    … …  
    109128#undef PRECISION 
    110129#undef ARRAY_TYPE 
    111 #undef MASK_TYPE 
    112130#undef ARRAY_IN 
    113131#undef MASK_IN 
    114132#undef K_SIZE 
     133#if defined key_mpp_mpi 
     134#   undef MPI_TYPE 
     135#endif 
    115136#undef MPI_OPERATION 
    116137#undef LOC_OPERATION 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/LBC/mpp_nfd_generic.h90

    r13290 r13998  
    317317         ! start waiting time measurement 
    318318         IF( ln_timing ) CALL tic_tac(.TRUE.) 
     319#if defined key_mpp_mpi 
    319320         CALL MPI_ALLGATHER( znorthloc, ibuffsize, MPI_TYPE, znorthglo, ibuffsize, MPI_TYPE, ncomm_north, ierr ) 
     321#endif 
    320322         ! stop waiting time measurement 
    321323         IF( ln_timing ) CALL tic_tac(.FALSE.) 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/LBC/mppini.F90

    r13915 r13998  
    6262      !!---------------------------------------------------------------------- 
    6363      ! 
    64       jpiglo = Ni0glo 
    65       jpjglo = Nj0glo 
     64      nn_hls = 1 
     65      jpiglo = Ni0glo + 2 * nn_hls 
     66      jpjglo = Nj0glo + 2 * nn_hls 
    6667      jpimax = jpiglo 
    6768      jpjmax = jpjglo 
    … …  
    7273      jpjm1  = jpj-1                         !   "           " 
    7374      jpkm1  = MAX( 1, jpk-1 )               !   "           " 
    74       ! 
    75       CALL init_doloop                       ! set start/end indices or do-loop depending on the halo width value (nn_hls)  
    76       ! 
    7775      jpij   = jpi*jpj 
    7876      jpni   = 1 
    7977      jpnj   = 1 
    8078      jpnij  = jpni*jpnj 
    81       nn_hls = 1 
    8279      nimpp  = 1 
    8380      njmpp  = 1 
    … …  
    9188      l_Jperio = jpnj == 1 .AND. (jperio == 2 .OR. jperio == 7) 
    9289      ! 
     90      CALL init_doloop                       ! set start/end indices or do-loop depending on the halo width value (nn_hls)  
     91      ! 
    9392      IF(lwp) THEN 
    9493         WRITE(numout,*) 
    … …  
    9998      ENDIF 
    10099      ! 
    101       IF(  jpni /= 1 .OR. jpnj /= 1 .OR. jpnij /= 1 )                                     & 
    102          CALL ctl_stop( 'mpp_init: equality  jpni = jpnj = jpnij = 1 is not satisfied',   & 
    103             &           'the domain is lay out for distributed memory computing!' ) 
    104          ! 
    105100#if defined key_agrif 
    106101    IF (.NOT.agrif_root()) THEN 
    … …  
    676671    END SUBROUTINE mpp_init 
    677672 
     673#endif 
    678674 
    679675    SUBROUTINE mpp_basesplit( kiglo, kjglo, khls, knbi, knbj, kimax, kjmax, kimppt, kjmppt, klci, klcj) 
    … …  
    790786      !! ** Method  : 
    791787      !!---------------------------------------------------------------------- 
    792       INTEGER,           INTENT(in   ) ::   knbij         ! total number if subdomains              (knbi*knbj) 
     788      INTEGER,           INTENT(in   ) ::   knbij         ! total number of subdomains (knbi*knbj) 
    793789      INTEGER, OPTIONAL, INTENT(  out) ::   knbi, knbj    ! number if subdomains along i and j (knbi and knbj) 
    794790      INTEGER, OPTIONAL, INTENT(  out) ::   knbcnt        ! number of land subdomains 
    … …  
    798794      INTEGER :: iszitst, iszjtst 
    799795      INTEGER :: isziref, iszjref 
     796      INTEGER :: iszimin, iszjmin 
    800797      INTEGER :: inbij, iszij 
    801798      INTEGER :: inbimax, inbjmax, inbijmax, inbijold 
    … …  
    826823      inbimax = 0 
    827824      inbjmax = 0 
    828       isziref = Ni0glo*Nj0glo+1 
    829       iszjref = Ni0glo*Nj0glo+1 
     825      isziref = jpiglo*jpjglo+1   ! define a value that is larger than the largest possible 
     826      iszjref = jpiglo*jpjglo+1 
     827      ! 
     828      iszimin = 4*nn_hls          ! minimum size of the MPI subdomain so halos are always adressing neighbor inner domain 
     829      iszjmin = 4*nn_hls 
     830      IF( jperio == 3 .OR. jperio == 4 )   iszjmin = MAX(iszjmin, 2+3*nn_hls)   ! V and F folding must be outside of southern halos 
     831      IF( jperio == 5 .OR. jperio == 6 )   iszjmin = MAX(iszjmin, 1+3*nn_hls)   ! V and F folding must be outside of southern halos 
    830832      ! 
    831833      ! get the list of knbi that gives a smaller jpimax than knbi-1 
    … …  
    835837         iszitst = ( nx_global+2-2*nn_hls + (ji-1) ) / ji + 2*nn_hls    ! first  dim. 
    836838#else 
    837          iszitst = ( Ni0glo + (ji-1) ) / ji 
     839         iszitst = ( Ni0glo + (ji-1) ) / ji + 2*nn_hls   ! max subdomain i-size 
    838840#endif 
    839          IF( iszitst < isziref ) THEN 
     841         IF( iszitst < isziref .AND. iszitst >= iszimin ) THEN 
    840842            isziref = iszitst 
    841843            inbimax = inbimax + 1 
    … …  
    846848         iszjtst = ( ny_global+2-2*nn_hls + (ji-1) ) / ji + 2*nn_hls    ! first  dim. 
    847849#else 
    848          iszjtst = ( Nj0glo + (ji-1) ) / ji 
     850         iszjtst = ( Nj0glo + (ji-1) ) / ji + 2*nn_hls   ! max subdomain j-size 
    849851#endif 
    850          IF( iszjtst < iszjref ) THEN 
     852         IF( iszjtst < iszjref .AND. iszjtst >= iszjmin ) THEN 
    851853            iszjref = iszjtst 
    852854            inbjmax = inbjmax + 1 
    … …  
    901903      isz0 = 0                                                  ! number of best partitions      
    902904      inbij = 1                                                 ! start with the min value of inbij1 => 1 
    903       iszij = Ni0glo*Nj0glo+1                                   ! default: larger than global domain 
     905      iszij = jpiglo*jpjglo+1                                   ! default: larger than global domain 
    904906      DO WHILE( inbij <= inbijmax )                             ! if we did not reach the max of inbij1 
    905907         ii = MINLOC(iszij1, mask = inbij1 == inbij, dim = 1)   ! warning: send back the first occurence if multiple results 
    906908         IF ( iszij1(ii) < iszij ) THEN 
     909            ii = MINLOC( iszi1+iszj1, mask = iszij1 == iszij1(ii) .AND. inbij1 == inbij, dim = 1)  ! select the smaller perimeter if multiple min 
    907910            isz0 = isz0 + 1 
    908911            indexok(isz0) = ii 
    … …  
    13221325   END SUBROUTINE init_nfdcom 
    13231326 
    1324 #endif 
    13251327 
    13261328   SUBROUTINE init_doloop 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/LDF/ldfc1d_c2d.F90

    r13295 r13998  
    8080            pah1(:,:,jk) = pahs1(:,:) * (  zratio + zc * ( 1._wp + TANH( - ( gdept_0(:,:,jk) - zh ) * zw) )  ) 
    8181         END DO 
    82          DO_3DS( 1, 0, 1, 0, jpkm1, 1, -1 ) 
     82         DO_3DS( 1, 0, 1, 0, jpkm1, 1, -1 )  ! pah2 at F-point (zdep2 is an approximation in zps-coord.) 
    8383            zdep2 = (  gdept_0(ji,jj+1,jk) + gdept_0(ji+1,jj+1,jk)   & 
    8484               &     + gdept_0(ji,jj  ,jk) + gdept_0(ji+1,jj  ,jk)  ) * r1_4 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/LDF/ldfdyn.F90

    r13769 r13998  
    325325            IF( ierr /= 0 )   CALL ctl_stop( 'STOP', 'ldf_dyn_init: failed to allocate Smagorinsky arrays') 
    326326            ! 
    327             DO_2D( 1, 1, 1, 1 ) 
     327            DO_2D( 1, 1, 1, 1 )        ! Set local gridscale values 
    328328               esqt(ji,jj) = ( 2._wp * e1e2t(ji,jj) / ( e1t(ji,jj) + e2t(ji,jj) ) )**2  
    329329               esqf(ji,jj) = ( 2._wp * e1e2f(ji,jj) / ( e1f(ji,jj) + e2f(ji,jj) ) )**2  
    … …  
    448448            DO jk = 1, jpkm1 
    449449              ! 
    450                DO_2D( 0, 0, 0, 0 ) 
     450               DO_2D( 0, 0, 0, 0 )                                   ! T-point value 
    451451                  ! 
    452452                  zu2pv2_ij    = uu(ji  ,jj  ,jk,Kbb) * uu(ji  ,jj  ,jk,Kbb) + vv(ji  ,jj  ,jk,Kbb) * vv(ji  ,jj  ,jk,Kbb) 
    … …  
    462462               END_2D 
    463463               ! 
    464                DO_2D( 1, 0, 1, 0 ) 
     464               DO_2D( 1, 0, 1, 0 )                                   ! F-point value 
    465465                  ! 
    466466                  zu2pv2_ij_p1 = uu(ji  ,jj+1,jk, kbb) * uu(ji  ,jj+1,jk, kbb) + vv(ji+1,jj  ,jk, kbb) * vv(ji+1,jj  ,jk, kbb) 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/LDF/ldfslp.F90

    r13295 r13998  
    128128      IF( ln_timing )   CALL timing_start('ldf_slp') 
    129129      ! 
    130       zeps   =  1.e-20_wp        !==   Local constant initialization   ==! 
     130      zeps   =  1.e-20_wp           !==   Local constant initialization   ==! 
    131131      z1_16  =  1.0_wp / 16._wp 
    132132      zm1_g  = -1.0_wp / grav 
    … …  
    137137      zwz(:,:,:) = 0._wp 
    138138      ! 
    139       DO_3D( 1, 0, 1, 0, 1, jpk ) 
     139      DO_3D( 1, 0, 1, 0, 1, jpk )   !==   i- & j-gradient of density   ==! 
    140140         zgru(ji,jj,jk) = umask(ji,jj,jk) * ( prd(ji+1,jj  ,jk) - prd(ji,jj,jk) ) 
    141141         zgrv(ji,jj,jk) = vmask(ji,jj,jk) * ( prd(ji  ,jj+1,jk) - prd(ji,jj,jk) ) 
    … …  
    154154      ENDIF 
    155155      ! 
    156       zdzr(:,:,1) = 0._wp        !==   Local vertical density gradient at T-point   == !   (evaluated from N^2) 
     156      zdzr(:,:,1) = 0._wp           !==   Local vertical density gradient at T-point   == !   (evaluated from N^2) 
    157157      DO jk = 2, jpkm1 
    158158         !                                ! zdzr = d/dz(prd)= - ( prd ) / grav * mk(pn2) -- at t point 
    … …  
    165165      END DO 
    166166      ! 
    167       !                          !==   Slopes just below the mixed layer   ==! 
     167      !                             !==   Slopes just below the mixed layer   ==! 
    168168      CALL ldf_slp_mxl( prd, pn2, zgru, zgrv, zdzr, Kmm )        ! output: uslpml, vslpml, wslpiml, wslpjml 
    169169 
    … …  
    186186      END IF 
    187187 
    188       DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 
     188      DO_3D( 0, 0, 0, 0, 2, jpkm1 )        !* Slopes at u and v points 
    189189         !                                      ! horizontal and vertical density gradient at u- and v-points 
    190190         zau = zgru(ji,jj,jk) * r1_e1u(ji,jj) 
    … …  
    231231      CALL lbc_lnk_multi( 'ldfslp', zwz, 'U', -1.0_wp,  zww, 'V', -1.0_wp )      ! lateral boundary conditions 
    232232      ! 
    233       !                                            !* horizontal Shapiro filter 
     233      !                                    !* horizontal Shapiro filter 
    234234      DO jk = 2, jpkm1 
    235          DO_2D( 0, 0, 0, 0 ) 
     235         DO_2D( 0, 0, 0, 0 )                                 ! rows jj=2 and =jpjm1 only 
    236236            uslp(ji,jj,jk) = z1_16 * (        zwz(ji-1,jj-1,jk) + zwz(ji+1,jj-1,jk)      & 
    237237               &                       +      zwz(ji-1,jj+1,jk) + zwz(ji+1,jj+1,jk)      & 
    … …  
    245245               &                       + 4.*  zww(ji,jj    ,jk)                       ) 
    246246         END_2D 
    247          DO jj = 3, jpj-2                               ! other rows 
     247         DO jj = 3, jpj-2                                    ! other rows 
    248248            DO ji = 2, jpim1   ! vector opt. 
    249249               uslp(ji,jj,jk) = z1_16 * (        zwz(ji-1,jj-1,jk) + zwz(ji+1,jj-1,jk)      & 
    … …  
    259259            END DO 
    260260         END DO 
    261          !                                        !* decrease along coastal boundaries 
     261         !                                 !* decrease along coastal boundaries 
    262262         DO_2D( 0, 0, 0, 0 ) 
    263263            uslp(ji,jj,jk) = uslp(ji,jj,jk) * ( umask(ji,jj+1,jk) + umask(ji,jj-1,jk  ) ) * 0.5_wp   & 
    … …  
    307307      !                                           !* horizontal Shapiro filter 
    308308      DO jk = 2, jpkm1 
    309          DO_2D( 0, 0, 0, 0 ) 
     309         DO_2D( 0, 0, 0, 0 )                             ! rows jj=2 and =jpjm1 only 
    310310            zcofw = wmask(ji,jj,jk) * z1_16 
    311311            wslpi(ji,jj,jk) = (         zwz(ji-1,jj-1,jk) + zwz(ji+1,jj-1,jk)     & 
    … …  
    401401         ! 
    402402         ip = jl   ;   jp = jl                ! guaranteed nonzero gradients ( absolute value larger than repsln) 
    403          DO_3D( 1, 0, 1, 0, 1, jpkm1 ) 
     403         DO_3D( 1, 0, 1, 0, 1, jpkm1 )        ! done each pair of triad ! NB: not masked ==>  a minimum value is set 
    404404            zdit = ( ts(ji+1,jj,jk,jp_tem,Kbb) - ts(ji,jj,jk,jp_tem,Kbb) )    ! i-gradient of T & S at u-point 
    405405            zdis = ( ts(ji+1,jj,jk,jp_sal,Kbb) - ts(ji,jj,jk,jp_sal,Kbb) ) 
    … …  
    427427 
    428428      DO kp = 0, 1                            !==  unmasked before density i- j-, k-gradients  ==! 
    429          DO_3D( 1, 1, 1, 1, 1, jpkm1 ) 
    430             IF( jk+kp > 1 ) THEN        ! k-gradient of T & S a jk+kp 
     429         DO_3D( 1, 1, 1, 1, 1, jpkm1 )        ! done each pair of triad ! NB: not masked ==>  a minimum value is set 
     430            IF( jk+kp > 1 ) THEN              ! k-gradient of T & S a jk+kp 
    431431               zdkt = ( ts(ji,jj,jk+kp-1,jp_tem,Kbb) - ts(ji,jj,jk+kp,jp_tem,Kbb) ) 
    432432               zdks = ( ts(ji,jj,jk+kp-1,jp_sal,Kbb) - ts(ji,jj,jk+kp,jp_sal,Kbb) ) 
    … …  
    442442      END DO 
    443443      ! 
    444       DO_2D( 1, 1, 1, 1 ) 
     444      DO_2D( 1, 1, 1, 1 )                     !==  Reciprocal depth of the w-point below ML base  ==! 
    445445         jk = MIN( nmln(ji,jj), mbkt(ji,jj) ) + 1     ! MIN in case ML depth is the ocean depth 
    446446         z1_mlbw(ji,jj) = 1._wp / gdepw(ji,jj,jk,Kmm) 
    … …  
    628628      ! 
    629629      !                                            !==   surface mixed layer mask   ! 
    630       DO_3D( 1, 1, 1, 1, 1, jpk ) 
     630      DO_3D( 1, 1, 1, 1, 1, jpk )                  ! =1 inside the mixed layer, =0 otherwise 
    631631         ik = nmln(ji,jj) - 1 
    632632         IF( jk <= ik ) THEN   ;   omlmask(ji,jj,jk) = 1._wp 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/LDF/ldftra.F90

    r13295 r13998  
    246246      ENDIF 
    247247      ! 
    248       IF( ln_ldfeiv .AND. .NOT.( ln_traldf_iso .OR. ln_traldf_triad ) )                & 
    249            &            CALL ctl_stop( 'ln_ldfeiv=T requires iso-neutral laplacian diffusion' ) 
    250       IF( ln_isfcav .AND. ln_traldf_triad ) & 
    251            &            CALL ctl_stop( ' ice shelf cavity and traldf_triad not tested' ) 
     248      IF( ln_isfcav .AND. ln_traldf_triad )   CALL ctl_stop( ' ice shelf cavity and traldf_triad not tested' ) 
    252249           ! 
    253250      IF(  nldf_tra == np_lap_i .OR. nldf_tra == np_lap_it .OR. & 
    … …  
    541538         IF( ln_traldf_blp )   CALL ctl_stop( 'ldf_eiv_init: eddy induced velocity ONLY with laplacian diffusivity' ) 
    542539         ! 
     540         IF( .NOT.( ln_traldf_iso .OR. ln_traldf_triad ) )   & 
     541           &                  CALL ctl_stop( 'ln_ldfeiv=T requires iso-neutral laplacian diffusion' ) 
    543542         !                                != allocate the aei arrays 
    544543         ALLOCATE( aeiu(jpi,jpj,jpk), aeiv(jpi,jpj,jpk), STAT=ierr ) 
    … …  
    694693      CALL lbc_lnk( 'ldftra', zaeiw(:,:), 'W', 1.0_wp )       ! lateral boundary condition 
    695694      !                
    696       DO_2D( 0, 0, 0, 0 ) 
     695      DO_2D( 0, 0, 0, 0 )                       !== aei at u- and v-points  ==! 
    697696         paeiu(ji,jj,1) = 0.5_wp * ( zaeiw(ji,jj) + zaeiw(ji+1,jj  ) ) * umask(ji,jj,1) 
    698697         paeiv(ji,jj,1) = 0.5_wp * ( zaeiw(ji,jj) + zaeiw(ji  ,jj+1) ) * vmask(ji,jj,1) 
    … …  
    813812      CALL iom_put( "voce_eiv", zw3d ) 
    814813      ! 
    815       DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     814      DO_3D( 0, 0, 0, 0, 1, jpkm1 )                            ! e1 e2 w_eiv = dk[psix] + dk[psix] 
    816815         zw3d(ji,jj,jk) = (  psi_vw(ji,jj,jk) - psi_vw(ji  ,jj-1,jk)    & 
    817816            &              + psi_uw(ji,jj,jk) - psi_uw(ji-1,jj  ,jk)  ) / e1e2t(ji,jj) 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/SBC/cpl_oasis3.F90

    r13286 r13998  
    165165      ENDIF 
    166166      ! 
    167       ! ... Define the shape for the area that excludes the halo 
    168       !     For serial configuration (key_mpp_mpi not being active) 
    169       !     nl* is set to the global values 1 and jp*glo. 
     167      ! ... Define the shape for the area that excludes the halo as we don't want them to be "seen" by oasis 
    170168      ! 
    171169      ishape(1) = 1 
    … …  
    176174      ! ... Allocate memory for data exchange 
    177175      ! 
    178       ALLOCATE(exfld(Ni_0, Nj_0), stat = nerror) 
     176      ALLOCATE(exfld(Ni_0, Nj_0), stat = nerror)        ! allocate only inner domain (without halos) 
    179177      IF( nerror > 0 ) THEN 
    180178         CALL oasis_abort ( ncomp_id, 'cpl_define', 'Failure in allocating exfld')   ;   RETURN 
    … …  
    182180      ! 
    183181      ! ----------------------------------------------------------------- 
    184       ! ... Define the partition  
     182      ! ... Define the partition, excluding halos as we don't want them to be "seen" by oasis     
    185183      ! ----------------------------------------------------------------- 
    186184       
    187       paral(1) = 2                                              ! box partitioning 
    188       paral(2) = jpiglo * (Njs0-1+njmpp-1) + (Nis0-1+nimpp-1)   ! NEMO lower left corner global offset     
    189       paral(3) = Ni_0                                           ! local extent in i  
    190       paral(4) = Nj_0                                           ! local extent in j 
    191       paral(5) = jpiglo                                         ! global extent in x 
     185      paral(1) = 2                                      ! box partitioning 
     186      paral(2) = Ni0glo * mjg0(nn_hls) + mig0(nn_hls)   ! NEMO lower left corner global offset, without halos  
     187      paral(3) = Ni_0                                   ! local extent in i, excluding halos 
     188      paral(4) = Nj_0                                   ! local extent in j, excluding halos 
     189      paral(5) = Ni0glo                                 ! global extent in x, excluding halos 
    192190       
    193191      IF( sn_cfctl%l_oasout ) THEN 
    194192         WRITE(numout,*) ' multiexchg: paral (1:5)', paral 
    195          WRITE(numout,*) ' multiexchg: jpi, jpj =', jpi, jpj 
     193         WRITE(numout,*) ' multiexchg: Ni_0, Nj_0 =', Ni_0, Nj_0 
    196194         WRITE(numout,*) ' multiexchg: Nis0, Nie0, nimpp =', Nis0, Nie0, nimpp 
    197195         WRITE(numout,*) ' multiexchg: Njs0, Nje0, njmpp =', Njs0, Nje0, njmpp 
    198196      ENDIF 
    199197    
    200       CALL oasis_def_partition ( id_part, paral, nerror, jpiglo*jpjglo ) 
     198      CALL oasis_def_partition ( id_part, paral, nerror, Ni0glo*Nj0glo )   ! global number of points, excluding halos 
    201199      ! 
    202200      ! ... Announce send variables.  
    … …  
    327325         DO jm = 1, ssnd(kid)%ncplmodel 
    328326         
    329             IF( ssnd(kid)%nid(jc,jm) /= -1 ) THEN 
     327            IF( ssnd(kid)%nid(jc,jm) /= -1 ) THEN   ! exclude halos from data sent to oasis 
    330328               CALL oasis_put ( ssnd(kid)%nid(jc,jm), kstep, pdata(Nis0:Nie0, Njs0:Nje0,jc), kinfo ) 
    331329                
    … …  
    386384                  &        kinfo == OASIS_RecvOut .OR. kinfo == OASIS_FromRestOut 
    387385                
    388                IF ( sn_cfctl%l_oasout )   WRITE(numout,*) "llaction, kinfo, kstep, ivarid: " , llaction, kinfo, kstep, srcv(kid)%nid(jc,jm) 
     386               IF ( sn_cfctl%l_oasout )   & 
     387                  &  WRITE(numout,*) "llaction, kinfo, kstep, ivarid: " , llaction, kinfo, kstep, srcv(kid)%nid(jc,jm) 
    389388                
    390                IF( llaction ) THEN 
     389               IF( llaction ) THEN   ! data received from oasis do not include halos 
    391390                   
    392391                  kinfo = OASIS_Rcv 
    … …  
    417416         ENDDO 
    418417 
    419          !--- Fill the overlap areas and extra hallows (mpp) 
    420          !--- check periodicity conditions (all cases) 
     418         !--- we must call lbc_lnk to fill the halos that where not received. 
    421419         IF( .NOT. ll_1st ) THEN 
    422420            CALL lbc_lnk( 'cpl_oasis3', pdata(:,:,jc), srcv(kid)%clgrid, srcv(kid)%nsgn )    

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/SBC/fldread.F90

    r13295 r13998  
    216216                  WRITE(numout, clfmt)  TRIM( sd(jf)%clvar ), kt, REAL(isecsbc,wp)/rday, nyear, nmonth, nday,   &             
    217217                     & sd(jf)%nrec(1,ibb), sd(jf)%nrec(1,iaa), REAL(sd(jf)%nrec(2,ibb),wp)/rday, REAL(sd(jf)%nrec(2,iaa),wp)/rday 
    218                   WRITE(numout, *) '      zt_offset is : ',zt_offset 
     218                  IF( zt_offset /= 0._wp )   WRITE(numout, *) '      zt_offset is : ', zt_offset 
    219219               ENDIF 
    220220               ! temporal interpolation weights 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/SBC/sbc_ice.F90

    r12396 r13998  
    6969   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   emp_oce        !: evap - precip over ocean                 [kg/m2/s] 
    7070   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   wndm_ice       !: wind speed module at T-point                 [m/s] 
    71    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   sstfrz         !: wind speed module at T-point                 [m/s] 
     71   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   sstfrz         !: sea surface freezing temperature            [degC] 
     72   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   rCdU_ice       !: ice-ocean drag at T-point (<0)               [m/s] 
    7273#endif 
    7374 
    … …  
    8990   ! variables used in the coupled interface 
    9091   INTEGER , PUBLIC, PARAMETER ::   jpl = ncat 
    91    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   u_ice, v_ice          ! jpi, jpj 
     92   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   u_ice, v_ice  
    9293    
    9394   ! already defined in ice.F90 for SI3 
    … …  
    9899#endif 
    99100 
    100    REAL(wp), PUBLIC, SAVE ::   cldf_ice = 0.81    !: cloud fraction over sea ice, summer CLIO value   [-] 
     101   REAL(wp), PUBLIC, SAVE ::   pp_cldf = 0.81    !: cloud fraction over sea ice, summer CLIO value   [-] 
    101102 
    102103   !! arrays relating to embedding ice in the ocean 
    … …  
    131132         &      qemp_ice(jpi,jpj)     , qevap_ice(jpi,jpj,jpl) , qemp_oce   (jpi,jpj)     ,   & 
    132133         &      qns_oce (jpi,jpj)     , qsr_oce  (jpi,jpj)     , emp_oce    (jpi,jpj)     ,   & 
    133          &      emp_ice (jpi,jpj)     , sstfrz   (jpi,jpj)     , STAT= ierr(2) ) 
     134         &      emp_ice (jpi,jpj)     , sstfrz   (jpi,jpj)     , rCdU_ice   (jpi,jpj)     , STAT= ierr(2) ) 
    134135#endif 
    135136 
    … …  
    167168   LOGICAL         , PUBLIC, PARAMETER ::   lk_si3     = .FALSE.  !: no SI3 ice model 
    168169   LOGICAL         , PUBLIC, PARAMETER ::   lk_cice    = .FALSE.  !: no CICE ice model 
    169    REAL(wp)        , PUBLIC, PARAMETER ::   cldf_ice = 0.81       !: cloud fraction over sea ice, summer CLIO value   [-] 
     170   REAL(wp)        , PUBLIC, PARAMETER ::   pp_cldf    = 0.81     !: cloud fraction over sea ice, summer CLIO value   [-] 
    170171   INTEGER         , PUBLIC, PARAMETER ::   jpl = 1  
    171172   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   u_ice, v_ice                        ! jpi, jpj 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/SBC/sbc_oce.F90

    r13295 r13998  
    136136   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   atm_co2           !: atmospheric pCO2                             [ppm] 
    137137   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: xcplmask          !: coupling mask for ln_mixcpl (warning: allocated in sbccpl) 
     138   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   cloud_fra         !: cloud cover (fraction of cloud in a gridcell) [-] 
    138139 
    139140   !!--------------------------------------------------------------------- 
    … …  
    188189      ! 
    189190      ALLOCATE( tprecip(jpi,jpj) , sprecip(jpi,jpj) , fr_i(jpi,jpj) ,     & 
    190          &      atm_co2(jpi,jpj) , tsk_m(jpi,jpj) ,                       & 
     191         &      atm_co2(jpi,jpj) , tsk_m(jpi,jpj) , cloud_fra(jpi,jpj),   & 
    191192         &      ssu_m  (jpi,jpj) , sst_m(jpi,jpj) , frq_m(jpi,jpj) ,      & 
    192193         &      ssv_m  (jpi,jpj) , sss_m(jpi,jpj) , ssh_m(jpi,jpj) , STAT=ierr(4) ) 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/SBC/sbcblk.F90

    r13305 r13998  
    4444   USE lib_fortran    ! to use key_nosignedzero 
    4545#if defined key_si3 
    46    USE ice     , ONLY :   jpl, a_i_b, at_i_b, rn_cnd_s, hfx_err_dif 
    47    USE icethd_dh      ! for CALL ice_thd_snwblow 
     46   USE ice     , ONLY :   u_ice, v_ice, jpl, a_i_b, at_i_b, t_su, rn_cnd_s, hfx_err_dif, nn_qtrice 
     47   USE icevar         ! for CALL ice_var_snwblow 
    4848#endif 
    4949   USE sbcblk_algo_ncar     ! => turb_ncar     : NCAR - CORE (Large & Yeager, 2009) 
    … …  
    8787   INTEGER , PUBLIC, PARAMETER ::   jp_voatm = 11   ! index of surface current (j-component) 
    8888   !                                                !          seen by the atmospheric forcing (m/s) at T-point 
    89    INTEGER , PUBLIC, PARAMETER ::   jp_hpgi  = 12   ! index of ABL geostrophic wind or hpg (i-component) (m/s) at T-point 
    90    INTEGER , PUBLIC, PARAMETER ::   jp_hpgj  = 13   ! index of ABL geostrophic wind or hpg (j-component) (m/s) at T-point 
    91    INTEGER , PUBLIC, PARAMETER ::   jpfld    = 13   ! maximum number of files to read 
     89   INTEGER , PUBLIC, PARAMETER ::   jp_cc    = 12   ! index of cloud cover                     (-)      range:0-1 
     90   INTEGER , PUBLIC, PARAMETER ::   jp_hpgi  = 13   ! index of ABL geostrophic wind or hpg (i-component) (m/s) at T-point 
     91   INTEGER , PUBLIC, PARAMETER ::   jp_hpgj  = 14   ! index of ABL geostrophic wind or hpg (j-component) (m/s) at T-point 
     92   INTEGER , PUBLIC, PARAMETER ::   jpfld    = 14   ! maximum number of files to read 
    9293 
    9394   ! Warning: keep this structure allocatable for Agrif... 
    … …  
    175176      TYPE(FLD_N) ::   sn_qlw , sn_tair , sn_prec, sn_snow     !       "                        " 
    176177      TYPE(FLD_N) ::   sn_slp , sn_uoatm, sn_voatm             !       "                        " 
    177       TYPE(FLD_N) ::   sn_hpgi, sn_hpgj                        !       "                        " 
     178      TYPE(FLD_N) ::   sn_cc, sn_hpgi, sn_hpgj                 !       "                        " 
    178179      INTEGER     ::   ipka                                    ! number of levels in the atmospheric variable 
    179180      NAMELIST/namsbc_blk/ sn_wndi, sn_wndj, sn_humi, sn_qsr, sn_qlw ,                &   ! input fields 
    180181         &                 sn_tair, sn_prec, sn_snow, sn_slp, sn_uoatm, sn_voatm,     & 
    181          &                 sn_hpgi, sn_hpgj,                                          & 
     182         &                 sn_cc, sn_hpgi, sn_hpgj,                                   & 
    182183         &                 ln_NCAR, ln_COARE_3p0, ln_COARE_3p6, ln_ECMWF,             &   ! bulk algorithm 
    183184         &                 cn_dir , rn_zqt, rn_zu,                                    & 
    … …  
    260261      slf_i(jp_tair ) = sn_tair    ;   slf_i(jp_humi ) = sn_humi 
    261262      slf_i(jp_prec ) = sn_prec    ;   slf_i(jp_snow ) = sn_snow 
    262       slf_i(jp_slp  ) = sn_slp 
     263      slf_i(jp_slp  ) = sn_slp     ;   slf_i(jp_cc   ) = sn_cc 
    263264      slf_i(jp_uoatm) = sn_uoatm   ;   slf_i(jp_voatm) = sn_voatm 
    264265      slf_i(jp_hpgi ) = sn_hpgi    ;   slf_i(jp_hpgj ) = sn_hpgj 
    … …  
    289290         ! 
    290291         IF( TRIM(sf(jfpr)%clrootname) == 'NOT USED' ) THEN    !--  not used field  --!   (only now allocated and set to default) 
    291             IF(     jfpr == jp_slp  ) THEN 
     292            IF(     jfpr == jp_slp ) THEN 
    292293               sf(jfpr)%fnow(:,:,1:ipka) = 101325._wp   ! use standard pressure in Pa 
    293294            ELSEIF( jfpr == jp_prec .OR. jfpr == jp_snow .OR. jfpr == jp_uoatm .OR. jfpr == jp_voatm ) THEN 
    294295               sf(jfpr)%fnow(:,:,1:ipka) = 0._wp        ! no precip or no snow or no surface currents 
    295             ELSEIF( ( jfpr == jp_hpgi .OR. jfpr == jp_hpgj ) .AND. .NOT. ln_abl ) THEN 
    296                DEALLOCATE( sf(jfpr)%fnow )              ! deallocate as not used in this case 
     296            ELSEIF( jfpr == jp_hpgi .OR. jfpr == jp_hpgj ) THEN 
     297               IF( .NOT. ln_abl ) THEN 
     298                  DEALLOCATE( sf(jfpr)%fnow )   ! deallocate as not used in this case 
     299               ELSE 
     300                  sf(jfpr)%fnow(:,:,1:ipka) = 0._wp 
     301               ENDIF 
     302            ELSEIF( jfpr == jp_cc  ) THEN 
     303               sf(jp_cc)%fnow(:,:,1:ipka) = pp_cldf 
    297304            ELSE 
    298305               WRITE(ctmp1,*) 'sbc_blk_init: no default value defined for field number', jfpr 
    … …  
    303310            ! 
    304311            IF( sf(jfpr)%freqh > 0. .AND. MOD( NINT(3600. * sf(jfpr)%freqh), nn_fsbc * NINT(rn_Dt) ) /= 0 )   & 
    305                &  CALL ctl_warn( 'sbc_blk_init: sbcmod timestep rn_Dt*nn_fsbc is NOT a submultiple of atmospheric forcing frequency.',   & 
    306                &                 '               This is not ideal. You should consider changing either rn_Dt or nn_fsbc value...' ) 
     312         &  CALL ctl_warn( 'sbc_blk_init: sbcmod timestep rn_Dt*nn_fsbc is NOT a submultiple of atmospheric forcing frequency.',   & 
     313         &                 '               This is not ideal. You should consider changing either rn_Dt or nn_fsbc value...' ) 
    307314         ENDIF 
    308315      END DO 
    … …  
    559566      ptsk(:,:) = pst(:,:) + rt0  ! by default: skin temperature = "bulk SST" (will remain this way if NCAR algorithm used!) 
    560567 
     568      ! --- cloud cover --- ! 
     569      cloud_fra(:,:) = sf(jp_cc)%fnow(:,:,1) 
     570 
    561571      ! ----------------------------------------------------------------------------- ! 
    562572      !      0   Wind components and module at T-point relative to the moving ocean   ! 
    … …  
    10191029      REAL(wp) ::   zcoef_dqlw, zcoef_dqla   !   -      - 
    10201030      REAL(wp) ::   zztmp, zztmp2, z1_rLsub  !   -      - 
    1021       REAL(wp) ::   zfr1, zfr2               ! local variables 
    10221031      REAL(wp), DIMENSION(jpi,jpj,jpl) ::   z1_st         ! inverse of surface temperature 
    10231032      REAL(wp), DIMENSION(jpi,jpj,jpl) ::   z_qlw         ! long wave heat flux over ice 
    … …  
    10281037      REAL(wp), DIMENSION(jpi,jpj)     ::   zqair         ! specific humidity of air at z=rn_zqt [kg/kg] !LB 
    10291038      REAL(wp), DIMENSION(jpi,jpj)     ::   ztmp, ztmp2 
     1039      REAL(wp), DIMENSION(jpi,jpj)     ::   ztri 
    10301040      !!--------------------------------------------------------------------- 
    10311041      ! 
    … …  
    11121122      ! --- evaporation minus precipitation --- ! 
    11131123      zsnw(:,:) = 0._wp 
    1114       CALL ice_thd_snwblow( (1.-at_i_b(:,:)), zsnw )  ! snow distribution over ice after wind blowing 
     1124      CALL ice_var_snwblow( (1.-at_i_b(:,:)), zsnw )  ! snow distribution over ice after wind blowing 
    11151125      emp_oce(:,:) = ( 1._wp - at_i_b(:,:) ) * zevap(:,:) - ( tprecip(:,:) - sprecip(:,:) ) - sprecip(:,:) * (1._wp - zsnw ) 
    11161126      emp_ice(:,:) = SUM( a_i_b(:,:,:) * evap_ice(:,:,:), dim=3 ) - sprecip(:,:) * zsnw 
    … …  
    11391149      END DO 
    11401150 
    1141       ! --- shortwave radiation transmitted below the surface (W/m2, see Grenfell Maykut 77) --- ! 
    1142       zfr1 = ( 0.18 * ( 1.0 - cldf_ice ) + 0.35 * cldf_ice )            ! transmission when hi>10cm 
    1143       zfr2 = ( 0.82 * ( 1.0 - cldf_ice ) + 0.65 * cldf_ice )            ! zfr2 such that zfr1 + zfr2 to equal 1 
    1144       ! 
    1145       WHERE    ( phs(:,:,:) <= 0._wp .AND. phi(:,:,:) <  0.1_wp )       ! linear decrease from hi=0 to 10cm 
    1146          qtr_ice_top(:,:,:) = qsr_ice(:,:,:) * ( zfr1 + zfr2 * ( 1._wp - phi(:,:,:) * 10._wp ) ) 
    1147       ELSEWHERE( phs(:,:,:) <= 0._wp .AND. phi(:,:,:) >= 0.1_wp )       ! constant (zfr1) when hi>10cm 
    1148          qtr_ice_top(:,:,:) = qsr_ice(:,:,:) * zfr1 
    1149       ELSEWHERE                                                         ! zero when hs>0 
    1150          qtr_ice_top(:,:,:) = 0._wp 
    1151       END WHERE 
    1152       ! 
    1153  
     1151      ! --- shortwave radiation transmitted thru the surface scattering layer (W/m2) --- ! 
     1152      IF( nn_qtrice == 0 ) THEN 
     1153         ! formulation derived from Grenfell and Maykut (1977), where transmission rate 
     1154         !    1) depends on cloudiness 
     1155         !    2) is 0 when there is any snow 
     1156         !    3) tends to 1 for thin ice 
     1157         ztri(:,:) = 0.18 * ( 1.0 - cloud_fra(:,:) ) + 0.35 * cloud_fra(:,:)  ! surface transmission when hi>10cm 
     1158         DO jl = 1, jpl 
     1159            WHERE    ( phs(:,:,jl) <= 0._wp .AND. phi(:,:,jl) <  0.1_wp )     ! linear decrease from hi=0 to 10cm   
     1160               qtr_ice_top(:,:,jl) = qsr_ice(:,:,jl) * ( ztri(:,:) + ( 1._wp - ztri(:,:) ) * ( 1._wp - phi(:,:,jl) * 10._wp ) ) 
     1161            ELSEWHERE( phs(:,:,jl) <= 0._wp .AND. phi(:,:,jl) >= 0.1_wp )     ! constant (ztri) when hi>10cm 
     1162               qtr_ice_top(:,:,jl) = qsr_ice(:,:,jl) * ztri(:,:) 
     1163            ELSEWHERE                                                         ! zero when hs>0 
     1164               qtr_ice_top(:,:,jl) = 0._wp  
     1165            END WHERE 
     1166         ENDDO 
     1167      ELSEIF( nn_qtrice == 1 ) THEN 
     1168         ! formulation is derived from the thesis of M. Lebrun (2019). 
     1169         !    It represents the best fit using several sets of observations 
     1170         !    It comes with snow conductivities adapted to freezing/melting conditions (see icethd_zdf_bl99.F90) 
     1171         qtr_ice_top(:,:,:) = 0.3_wp * qsr_ice(:,:,:) 
     1172      ENDIF 
     1173      ! 
    11541174      IF( iom_use('evap_ao_cea') .OR. iom_use('hflx_evap_cea') ) THEN 
    11551175         ztmp(:,:) = zevap(:,:) * ( 1._wp - at_i_b(:,:) ) 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/SBC/sbcblk_algo_coare3p0.F90

    r13295 r13998  
    394394      !!------------------------------------------------------------------- 
    395395      ! 
    396       DO_2D( 1, 1, 1, 1 ) 
     396      DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
    397397      ! 
    398398      zw = pwnd(ji,jj)   ! wind speed 
    … …  
    430430      !!---------------------------------------------------------------------------------- 
    431431      ! 
    432       DO_2D( 1, 1, 1, 1 ) 
     432      DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
    433433      ! 
    434434      zta = pzeta(ji,jj) 
    … …  
    481481      REAL(wp) :: zta, zphi_h, zphi_c, zpsi_k, zpsi_c, zf, zc, zstab 
    482482      ! 
    483       DO_2D( 1, 1, 1, 1 ) 
     483      DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
    484484      ! 
    485485      zta = pzeta(ji,jj) 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/SBC/sbcblk_algo_coare3p6.F90

    r13295 r13998  
    430430      !!---------------------------------------------------------------------------------- 
    431431      ! 
    432       DO_2D( 1, 1, 1, 1 ) 
     432      DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
    433433      ! 
    434434      zta = pzeta(ji,jj) 
    … …  
    481481      REAL(wp) :: zta, zphi_h, zphi_c, zpsi_k, zpsi_c, zf, zc, zstab 
    482482      ! 
    483       DO_2D( 1, 1, 1, 1 ) 
     483      DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
    484484      ! 
    485485      zta = pzeta(ji,jj) 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/SBC/sbcblk_algo_ecmwf.F90

    r13295 r13998  
    410410      REAL(wp) :: zzeta, zx, ztmp, psi_unst, psi_stab, stab 
    411411      !!---------------------------------------------------------------------------------- 
    412       DO_2D( 1, 1, 1, 1 ) 
     412      DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
    413413      ! 
    414414      zzeta = MIN( pzeta(ji,jj) , 5._wp ) !! Very stable conditions (L positif and big!): 
    … …  
    455455      !!---------------------------------------------------------------------------------- 
    456456      ! 
    457       DO_2D( 1, 1, 1, 1 ) 
     457      DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
    458458      ! 
    459459      zzeta = MIN(pzeta(ji,jj) , 5._wp)   ! Very stable conditions (L positif and big!): 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/SBC/sbcblk_algo_ncar.F90

    r13295 r13998  
    241241      !!---------------------------------------------------------------------------------- 
    242242      ! 
    243       DO_2D( 1, 1, 1, 1 ) 
     243      DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
    244244         ! 
    245245         zw  = pw10(ji,jj) 
    … …  
    277277      REAL(wp) :: zx2, zx, zstab   ! local scalars 
    278278      !!---------------------------------------------------------------------------------- 
    279       DO_2D( 1, 1, 1, 1 ) 
     279      DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
    280280         zx2 = SQRT( ABS( 1._wp - 16._wp*pzeta(ji,jj) ) ) 
    281281         zx2 = MAX( zx2 , 1._wp ) 
    … …  
    308308      !!---------------------------------------------------------------------------------- 
    309309      ! 
    310       DO_2D( 1, 1, 1, 1 ) 
     310      DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
    311311         zx2 = SQRT( ABS( 1._wp - 16._wp*pzeta(ji,jj) ) ) 
    312312         zx2 = MAX( zx2 , 1._wp ) 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/SBC/sbcblk_skin_coare.F90

    r13295 r13998  
    8989      REAL(wp) :: zQabs, zdlt, zfr, zalfa, zqlat, zus 
    9090      !!--------------------------------------------------------------------- 
    91       DO_2D( 1, 1, 1, 1 ) 
     91      DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
    9292 
    9393         zQabs = pQnsol(ji,jj) ! first guess of heat flux absorbed within the viscous sublayer of thicknes delta, 
    … …  
    156156      ztime = REAL(nsec_day,wp)/(24._wp*3600._wp) ! time of current time step since 00:00 for current day (UTC) -> ztime = 0 -> 00:00 / ztime = 0.5 -> 12:00 ... 
    157157 
    158       DO_2D( 1, 1, 1, 1 ) 
     158      DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
    159159 
    160160         l_exit       = .FALSE. 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/SBC/sbcblk_skin_ecmwf.F90

    r13295 r13998  
    9595      REAL(wp) :: zQabs, zdlt, zfr, zalfa, zus 
    9696      !!--------------------------------------------------------------------- 
    97       DO_2D( 1, 1, 1, 1 ) 
     97      DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
    9898 
    9999         zQabs = pQnsol(ji,jj) ! first guess of heat flux absorbed within the viscous sublayer of thicknes delta, 
    … …  
    173173      IF( PRESENT(pustk) ) l_pustk_known = .TRUE. 
    174174 
    175       DO_2D( 1, 1, 1, 1 ) 
     175      DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
    176176 
    177177         zHwl = Hz_wl(ji,jj) ! first guess for warm-layer depth (and unique..., less advanced than COARE3p6 !) 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/SBC/sbccpl.F90

    r13295 r13998  
    4141#endif 
    4242#if defined key_si3 
    43    USE icethd_dh      ! for CALL ice_thd_snwblow 
     43   USE icevar         ! for CALL ice_var_snwblow 
    4444#endif 
    4545   ! 
    … …  
    4848   USE lib_mpp        ! distribued memory computing library 
    4949   USE lbclnk         ! ocean lateral boundary conditions (or mpp link) 
     50 
     51#if defined key_oasis3  
     52   USE mod_oasis, ONLY : OASIS_Sent, OASIS_ToRest, OASIS_SentOut, OASIS_ToRestOut  
     53#endif  
    5054 
    5155   IMPLICIT NONE 
    … …  
    152156   INTEGER, PARAMETER ::   jps_wlev   = 32   ! water level  
    153157   INTEGER, PARAMETER ::   jps_fice1  = 33   ! first-order ice concentration (for semi-implicit coupling of atmos-ice fluxes) 
    154    INTEGER, PARAMETER ::   jps_a_p    = 34   ! meltpond area 
     158   INTEGER, PARAMETER ::   jps_a_p    = 34   ! meltpond area fraction 
    155159   INTEGER, PARAMETER ::   jps_ht_p   = 35   ! meltpond thickness 
    156160   INTEGER, PARAMETER ::   jps_kice   = 36   ! sea ice effective conductivity 
    … …  
    159163 
    160164   INTEGER, PARAMETER ::   jpsnd      = 38   ! total number of fields sent  
     165 
     166#if ! defined key_oasis3  
     167   ! Dummy variables to enable compilation when oasis3 is not being used  
     168   INTEGER                    ::   OASIS_Sent        = -1  
     169   INTEGER                    ::   OASIS_SentOut     = -1  
     170   INTEGER                    ::   OASIS_ToRest      = -1  
     171   INTEGER                    ::   OASIS_ToRestOut   = -1  
     172#endif  
    161173 
    162174   !                                  !!** namelist namsbc_cpl ** 
    … …  
    184196   LOGICAL     ::   ln_usecplmask         !  use a coupling mask file to merge data received from several models 
    185197                                          !   -> file cplmask.nc with the float variable called cplmask (jpi,jpj,nn_cplmodel) 
     198   LOGICAL     ::   ln_scale_ice_flux     !  use ice fluxes that are already "ice weighted" ( i.e. multiplied ice concentration)  
     199 
    186200   TYPE ::   DYNARR      
    187201      REAL(wp), POINTER, DIMENSION(:,:,:) ::   z3    
    … …  
    191205 
    192206   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   alb_oce_mix    ! ocean albedo sent to atmosphere (mix clear/overcast sky) 
     207#if defined key_si3 || defined key_cice 
     208   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   a_i_last_couple !: Ice fractional area at last coupling time 
     209#endif 
    193210 
    194211   REAL(wp) ::   rpref = 101000._wp   ! reference atmospheric pressure[N/m2]  
    … …  
    211228      !!             ***  FUNCTION sbc_cpl_alloc  *** 
    212229      !!---------------------------------------------------------------------- 
    213       INTEGER :: ierr(4) 
     230      INTEGER :: ierr(5) 
    214231      !!---------------------------------------------------------------------- 
    215232      ierr(:) = 0 
    … …  
    221238#endif 
    222239      ALLOCATE( xcplmask(jpi,jpj,0:nn_cplmodel) , STAT=ierr(3) ) 
    223       ! 
    224       IF( .NOT. ln_apr_dyn ) ALLOCATE( ssh_ib(jpi,jpj), ssh_ibb(jpi,jpj), apr(jpi, jpj), STAT=ierr(4) )  
     240#if defined key_si3 || defined key_cice 
     241      ALLOCATE( a_i_last_couple(jpi,jpj,jpl) , STAT=ierr(4) ) 
     242#endif 
     243      ! 
     244      IF( .NOT. ln_apr_dyn ) ALLOCATE( ssh_ib(jpi,jpj), ssh_ibb(jpi,jpj), apr(jpi, jpj), STAT=ierr(5) ) 
    225245 
    226246      sbc_cpl_alloc = MAXVAL( ierr ) 
    … …  
    249269      REAL(wp), DIMENSION(jpi,jpj) ::   zacs, zaos 
    250270      !! 
    251       NAMELIST/namsbc_cpl/  sn_snd_temp  , sn_snd_alb   , sn_snd_thick, sn_snd_crt   , sn_snd_co2  ,   &  
     271      NAMELIST/namsbc_cpl/  nn_cplmodel  , ln_usecplmask, nn_cats_cpl , ln_scale_ice_flux,             & 
     272         &                  sn_snd_temp  , sn_snd_alb   , sn_snd_thick, sn_snd_crt   , sn_snd_co2   ,  &  
    252273         &                  sn_snd_ttilyr, sn_snd_cond  , sn_snd_mpnd , sn_snd_sstfrz, sn_snd_thick1,  &  
    253          &                  sn_snd_ifrac , sn_snd_crtw  , sn_snd_wlev , sn_rcv_hsig  , sn_rcv_phioc,   &  
    254          &                  sn_rcv_w10m  , sn_rcv_taumod, sn_rcv_tau  , sn_rcv_dqnsdt, sn_rcv_qsr  ,   &  
     274         &                  sn_snd_ifrac , sn_snd_crtw  , sn_snd_wlev , sn_rcv_hsig  , sn_rcv_phioc ,  &  
     275         &                  sn_rcv_w10m  , sn_rcv_taumod, sn_rcv_tau  , sn_rcv_dqnsdt, sn_rcv_qsr   ,  &  
    255276         &                  sn_rcv_sdrfx , sn_rcv_sdrfy , sn_rcv_wper , sn_rcv_wnum  , sn_rcv_tauwoc,  & 
    256          &                  sn_rcv_wdrag , sn_rcv_qns   , sn_rcv_emp  , sn_rcv_rnf   , sn_rcv_cal  ,   & 
    257          &                  sn_rcv_iceflx, sn_rcv_co2   , nn_cplmodel , ln_usecplmask, sn_rcv_mslp ,   & 
    258          &                  sn_rcv_icb   , sn_rcv_isf   , sn_rcv_wfreq , sn_rcv_tauw, nn_cats_cpl  ,   & 
     277         &                  sn_rcv_wdrag , sn_rcv_qns   , sn_rcv_emp  , sn_rcv_rnf   , sn_rcv_cal   ,  & 
     278         &                  sn_rcv_iceflx, sn_rcv_co2   , sn_rcv_mslp ,                                & 
     279         &                  sn_rcv_icb   , sn_rcv_isf   , sn_rcv_wfreq, sn_rcv_tauw  ,                 & 
    259280         &                  sn_rcv_ts_ice 
    260  
    261281      !!--------------------------------------------------------------------- 
    262282      ! 
    … …  
    278298      ENDIF 
    279299      IF( lwp .AND. ln_cpl ) THEN                        ! control print 
     300         WRITE(numout,*)'  nn_cplmodel                         = ', nn_cplmodel 
     301         WRITE(numout,*)'  ln_usecplmask                       = ', ln_usecplmask 
     302         WRITE(numout,*)'  ln_scale_ice_flux                   = ', ln_scale_ice_flux 
     303         WRITE(numout,*)'  nn_cats_cpl                         = ', nn_cats_cpl 
    280304         WRITE(numout,*)'  received fields (mutiple ice categogies)' 
    281305         WRITE(numout,*)'      10m wind module                 = ', TRIM(sn_rcv_w10m%cldes  ), ' (', TRIM(sn_rcv_w10m%clcat  ), ')' 
    … …  
    326350         WRITE(numout,*)'                      - orientation   = ', sn_snd_crtw%clvor  
    327351         WRITE(numout,*)'                      - mesh          = ', sn_snd_crtw%clvgrd  
    328          WRITE(numout,*)'  nn_cplmodel                         = ', nn_cplmodel 
    329          WRITE(numout,*)'  ln_usecplmask                       = ', ln_usecplmask 
    330          WRITE(numout,*)'  nn_cats_cpl                         = ', nn_cats_cpl 
    331352      ENDIF 
    332353 
    … …  
    367388      IF(       TRIM( sn_rcv_tau%cldes ) == 'oce only' .OR. TRIM( sn_rcv_tau%cldes ) == 'oce and ice'  & 
    368389           .OR. TRIM( sn_rcv_tau%cldes ) == 'mixed oce-ice' ) THEN ! avoid working with the atmospheric fields if they are not coupled 
    369  
     390      ! 
    370391      IF( TRIM( sn_rcv_tau%clvor ) == 'local grid' )   srcv(jpr_otx1:jpr_itz2)%nsgn = -1. 
    371392       
    … …  
    698719         ! Change first letter to couple with atmosphere if already coupled OPA 
    699720         ! this is nedeed as each variable name used in the namcouple must be unique: 
    700          ! for example O_Runoff received by OPA from SAS and therefore O_Runoff received by SAS from the Atmosphere 
     721         ! for example O_Runoff received by OPA from SAS and therefore S_Runoff received by SAS from the Atmosphere 
    701722         DO jn = 1, jprcv 
    702723            IF( srcv(jn)%clname(1:1) == "O" ) srcv(jn)%clname = "S"//srcv(jn)%clname(2:LEN(srcv(jn)%clname)) 
    … …  
    822843      END SELECT 
    823844 
     845      ! Initialise ice fractions from last coupling time to zero (needed by Met-Office) 
     846#if defined key_si3 || defined key_cice 
     847       a_i_last_couple(:,:,:) = 0._wp 
     848#endif 
    824849      !                                                      ! ------------------------- !  
    825850      !                                                      !      Ice Meltponds        !  
    … …  
    11101135      REAL(wp) ::   zcdrag = 1.5e-3        ! drag coefficient 
    11111136      REAL(wp) ::   zzx, zzy               ! temporary variables 
    1112       REAL(wp), DIMENSION(jpi,jpj) ::   ztx, zty, zmsk, zemp, zqns, zqsr 
     1137      REAL(wp), DIMENSION(jpi,jpj) ::   ztx, zty, zmsk, zemp, zqns, zqsr, zcloud_fra 
    11131138      !!---------------------------------------------------------------------- 
    11141139      ! 
    … …  
    11701195            !                               
    11711196            IF( srcv(jpr_otx1)%clgrid == 'T' ) THEN 
    1172                DO_2D( 0, 0, 0, 0 ) 
     1197               DO_2D( 0, 0, 0, 0 )                                        ! T ==> (U,V) 
    11731198                  frcv(jpr_otx1)%z3(ji,jj,1) = 0.5 * ( frcv(jpr_otx1)%z3(ji+1,jj  ,1) + frcv(jpr_otx1)%z3(ji,jj,1) ) 
    11741199                  frcv(jpr_oty1)%z3(ji,jj,1) = 0.5 * ( frcv(jpr_oty1)%z3(ji  ,jj+1,1) + frcv(jpr_oty1)%z3(ji,jj,1) ) 
    … …  
    12241249         ENDIF 
    12251250      ENDIF 
    1226  
     1251!!$      !                                                      ! ========================= ! 
     1252!!$      SELECT CASE( TRIM( sn_rcv_clouds%cldes ) )             !       cloud fraction      ! 
     1253!!$      !                                                      ! ========================= ! 
     1254!!$      cloud_fra(:,:) = frcv(jpr_clfra)*z3(:,:,1) 
     1255!!$      END SELECT 
     1256!!$ 
     1257      zcloud_fra(:,:) = pp_cldf   ! should be real cloud fraction instead (as in the bulk) but needs to be read from atm. 
     1258      IF( ln_mixcpl ) THEN 
     1259         cloud_fra(:,:) = cloud_fra(:,:) * xcplmask(:,:,0) + zcloud_fra(:,:)* zmsk(:,:) 
     1260      ELSE 
     1261         cloud_fra(:,:) = zcloud_fra(:,:) 
     1262      ENDIF 
     1263      !                                                      ! ========================= ! 
    12271264      ! u(v)tau and taum will be modified by ice model 
    12281265      ! -> need to be reset before each call of the ice/fsbc       
    … …  
    15491586            p_tauj(:,:) = frcv(jpr_ity1)%z3(:,:,1) 
    15501587         CASE( 'T' ) 
    1551             DO_2D( 0, 0, 0, 0 ) 
     1588            DO_2D( 0, 0, 0, 0 )                    ! T ==> (U,V) 
    15521589               ! take care of the land-sea mask to avoid "pollution" of coastal stress. p[uv]taui used in frazil and  rheology  
    15531590               zztmp1 = 0.5_wp * ( 2. - umask(ji,jj,1) ) * MAX( tmask(ji,jj,1),tmask(ji+1,jj  ,1) ) 
    … …  
    16231660      ! 
    16241661      INTEGER  ::   ji, jj, jl   ! dummy loop index 
    1625       REAL(wp) ::   ztri         ! local scalar 
    16261662      REAL(wp), DIMENSION(jpi,jpj)     ::   zcptn, zcptrain, zcptsnw, ziceld, zmsk, zsnw 
    16271663      REAL(wp), DIMENSION(jpi,jpj)     ::   zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip  , zevap_oce, zdevap_ice 
    16281664      REAL(wp), DIMENSION(jpi,jpj)     ::   zqns_tot, zqns_oce, zqsr_tot, zqsr_oce, zqprec_ice, zqemp_oce, zqemp_ice 
     1665      REAL(wp), DIMENSION(jpi,jpj)     ::   zevap_ice_total 
    16291666      REAL(wp), DIMENSION(jpi,jpj,jpl) ::   zqns_ice, zqsr_ice, zdqns_ice, zqevap_ice, zevap_ice, zqtr_ice_top, ztsu 
     1667      REAL(wp), DIMENSION(jpi,jpj)     ::   ztri 
    16301668      !!---------------------------------------------------------------------- 
    16311669      ! 
    … …  
    16471685         ztprecip(:,:) =   frcv(jpr_rain)%z3(:,:,1) + zsprecip(:,:)  ! May need to ensure positive here 
    16481686         zemp_tot(:,:) =   frcv(jpr_tevp)%z3(:,:,1) - ztprecip(:,:) 
    1649          zemp_ice(:,:) = ( frcv(jpr_ievp)%z3(:,:,1) - frcv(jpr_snow)%z3(:,:,1) ) * picefr(:,:) 
    16501687      CASE( 'oce and ice'   )   ! received fields: jpr_sbpr, jpr_semp, jpr_oemp, jpr_ievp 
    16511688         zemp_tot(:,:) = ziceld(:,:) * frcv(jpr_oemp)%z3(:,:,1) + picefr(:,:) * frcv(jpr_sbpr)%z3(:,:,1) 
    … …  
    16591696 
    16601697#if defined key_si3 
     1698 
     1699      ! --- evaporation over ice (kg/m2/s) --- ! 
     1700      IF (ln_scale_ice_flux) THEN ! typically met-office requirements 
     1701         IF (sn_rcv_emp%clcat == 'yes') THEN 
     1702            WHERE( a_i(:,:,:) > 1.e-10 )  ; zevap_ice(:,:,:) = frcv(jpr_ievp)%z3(:,:,:) * a_i_last_couple(:,:,:) / a_i(:,:,:) 
     1703            ELSEWHERE                     ; zevap_ice(:,:,:) = 0._wp 
     1704            END WHERE 
     1705            WHERE( picefr(:,:) > 1.e-10 ) ; zevap_ice_total(:,:) = SUM( zevap_ice(:,:,:) * a_i(:,:,:), dim=3 ) / picefr(:,:) 
     1706            ELSEWHERE                     ; zevap_ice_total(:,:) = 0._wp 
     1707            END WHERE 
     1708         ELSE 
     1709            WHERE( picefr(:,:) > 1.e-10 ) ; zevap_ice(:,:,1) = frcv(jpr_ievp)%z3(:,:,1) * SUM( a_i_last_couple, dim=3 ) / picefr(:,:) 
     1710            ELSEWHERE                     ; zevap_ice(:,:,1) = 0._wp 
     1711            END WHERE 
     1712            zevap_ice_total(:,:) = zevap_ice(:,:,1) 
     1713            DO jl = 2, jpl 
     1714               zevap_ice(:,:,jl) = zevap_ice(:,:,1) 
     1715            ENDDO 
     1716         ENDIF 
     1717      ELSE 
     1718         IF (sn_rcv_emp%clcat == 'yes') THEN 
     1719            zevap_ice(:,:,1:jpl) = frcv(jpr_ievp)%z3(:,:,1:jpl) 
     1720            WHERE( picefr(:,:) > 1.e-10 ) ; zevap_ice_total(:,:) = SUM( zevap_ice(:,:,:) * a_i(:,:,:), dim=3 ) / picefr(:,:) 
     1721            ELSEWHERE                     ; zevap_ice_total(:,:) = 0._wp 
     1722            END WHERE 
     1723         ELSE 
     1724            zevap_ice(:,:,1) = frcv(jpr_ievp)%z3(:,:,1) 
     1725            zevap_ice_total(:,:) = zevap_ice(:,:,1) 
     1726            DO jl = 2, jpl 
     1727               zevap_ice(:,:,jl) = zevap_ice(:,:,1) 
     1728            ENDDO 
     1729         ENDIF 
     1730      ENDIF 
     1731 
     1732      IF ( TRIM( sn_rcv_emp%cldes ) == 'conservative' ) THEN 
     1733         ! For conservative case zemp_ice has not been defined yet. Do it now. 
     1734         zemp_ice(:,:) = zevap_ice_total(:,:) * picefr(:,:) - frcv(jpr_snow)%z3(:,:,1) * picefr(:,:) 
     1735      ENDIF 
     1736 
    16611737      ! zsnw = snow fraction over ice after wind blowing (=picefr if no blowing) 
    1662       zsnw(:,:) = 0._wp   ;   CALL ice_thd_snwblow( ziceld, zsnw ) 
     1738      zsnw(:,:) = 0._wp   ;   CALL ice_var_snwblow( ziceld, zsnw ) 
    16631739       
    16641740      ! --- evaporation minus precipitation corrected (because of wind blowing on snow) --- ! 
    … …  
    16671743 
    16681744      ! --- evaporation over ocean (used later for qemp) --- ! 
    1669       zevap_oce(:,:) = frcv(jpr_tevp)%z3(:,:,1) - frcv(jpr_ievp)%z3(:,:,1) * picefr(:,:) 
    1670  
    1671       ! --- evaporation over ice (kg/m2/s) --- ! 
    1672       DO jl=1,jpl 
    1673          IF(sn_rcv_emp%clcat == 'yes') THEN   ;   zevap_ice(:,:,jl) = frcv(jpr_ievp)%z3(:,:,jl) 
    1674          ELSE                                  ;   zevap_ice(:,:,jl) = frcv(jpr_ievp)%z3(:,:,1 )   ;   ENDIF 
    1675       ENDDO 
     1745      zevap_oce(:,:) = frcv(jpr_tevp)%z3(:,:,1) - zevap_ice_total(:,:) * picefr(:,:) 
    16761746 
    16771747      ! since the sensitivity of evap to temperature (devap/dT) is not prescribed by the atmosphere, we set it to 0 
    … …  
    17511821!!      IF( srcv(jpr_rnf)%laction )   CALL iom_put( 'runoffs' , rnf(:,:) * tmask(:,:,1)                                 )  ! runoff 
    17521822!!      IF( srcv(jpr_isf)%laction )   CALL iom_put( 'iceshelf_cea', -fwfisf(:,:) * tmask(:,:,1)                         )  ! iceshelf 
    1753       IF( srcv(jpr_cal)%laction )   CALL iom_put( 'calving_cea' , frcv(jpr_cal)%z3(:,:,1) * tmask(:,:,1)                )  ! calving 
    1754       IF( srcv(jpr_icb)%laction )   CALL iom_put( 'iceberg_cea' , frcv(jpr_icb)%z3(:,:,1) * tmask(:,:,1)                )  ! icebergs 
    1755       IF( iom_use('snowpre') )      CALL iom_put( 'snowpre'     , sprecip(:,:)                                          )  ! Snow 
    1756       IF( iom_use('precip') )       CALL iom_put( 'precip'      , tprecip(:,:)                                          )  ! total  precipitation 
    1757       IF( iom_use('rain') )         CALL iom_put( 'rain'        , tprecip(:,:) - sprecip(:,:)                           )  ! liquid precipitation  
    1758       IF( iom_use('snow_ao_cea') )  CALL iom_put( 'snow_ao_cea' , sprecip(:,:) * ( 1._wp - zsnw(:,:) )                  )  ! Snow over ice-free ocean  (cell average) 
    1759       IF( iom_use('snow_ai_cea') )  CALL iom_put( 'snow_ai_cea' , sprecip(:,:) *           zsnw(:,:)                    )  ! Snow over sea-ice         (cell average) 
    1760       IF( iom_use('rain_ao_cea') )  CALL iom_put( 'rain_ao_cea' , ( tprecip(:,:) - sprecip(:,:) ) * picefr(:,:)         )  ! liquid precipitation over ocean (cell average) 
    1761       IF( iom_use('subl_ai_cea') )  CALL iom_put( 'subl_ai_cea' , frcv(jpr_ievp)%z3(:,:,1) * picefr(:,:) * tmask(:,:,1) )  ! Sublimation over sea-ice (cell average) 
    1762       IF( iom_use('evap_ao_cea') )  CALL iom_put( 'evap_ao_cea' , ( frcv(jpr_tevp)%z3(:,:,1)  & 
    1763          &                                                        - frcv(jpr_ievp)%z3(:,:,1) * picefr(:,:) ) * tmask(:,:,1) ) ! ice-free oce evap (cell average) 
     1823      IF( srcv(jpr_cal)%laction )    CALL iom_put( 'calving_cea' , frcv(jpr_cal)%z3(:,:,1) * tmask(:,:,1)                )  ! calving 
     1824      IF( srcv(jpr_icb)%laction )    CALL iom_put( 'iceberg_cea' , frcv(jpr_icb)%z3(:,:,1) * tmask(:,:,1)                )  ! icebergs 
     1825      IF( iom_use('snowpre') )       CALL iom_put( 'snowpre'     , sprecip(:,:)                                          )  ! Snow 
     1826      IF( iom_use('precip') )        CALL iom_put( 'precip'      , tprecip(:,:)                                          )  ! total  precipitation 
     1827      IF( iom_use('rain') )          CALL iom_put( 'rain'        , tprecip(:,:) - sprecip(:,:)                           )  ! liquid precipitation  
     1828      IF( iom_use('snow_ao_cea') )   CALL iom_put( 'snow_ao_cea' , sprecip(:,:) * ( 1._wp - zsnw(:,:) )                  )  ! Snow over ice-free ocean  (cell average) 
     1829      IF( iom_use('snow_ai_cea') )   CALL iom_put( 'snow_ai_cea' , sprecip(:,:) *           zsnw(:,:)                    )  ! Snow over sea-ice         (cell average) 
     1830      IF( iom_use('rain_ao_cea') )   CALL iom_put( 'rain_ao_cea' , ( tprecip(:,:) - sprecip(:,:) ) * picefr(:,:)         )  ! liquid precipitation over ocean (cell average) 
     1831      IF( iom_use('subl_ai_cea') )   CALL iom_put( 'subl_ai_cea' , frcv(jpr_ievp)%z3(:,:,1) * picefr(:,:) * tmask(:,:,1) )     ! Sublimation over sea-ice (cell average) 
     1832      IF( iom_use('evap_ao_cea') )   CALL iom_put( 'evap_ao_cea' , ( frcv(jpr_tevp)%z3(:,:,1)  & 
     1833         &                                                         - frcv(jpr_ievp)%z3(:,:,1) * picefr(:,:) ) * tmask(:,:,1) ) ! ice-free oce evap (cell average) 
    17641834      ! note: runoff output is done in sbcrnf (which includes icebergs too) and iceshelf output is done in sbcisf 
    17651835      ! 
    … …  
    17691839      CASE( 'oce only' )         ! the required field is directly provided 
    17701840         zqns_tot(:,:) = frcv(jpr_qnsoce)%z3(:,:,1) 
     1841         ! For Met Office sea ice non-solar fluxes are already delt with by JULES so setting to zero 
     1842         ! here so the only flux is the ocean only one. 
     1843         zqns_ice(:,:,:) = 0._wp  
    17711844      CASE( 'conservative' )     ! the required fields are directly provided 
    17721845         zqns_tot(:,:) = frcv(jpr_qnsmix)%z3(:,:,1) 
    … …  
    17981871               zqns_ice(:,:,jl) = frcv(jpr_qnsmix)%z3(:,:,jl)    & 
    17991872                  &             + frcv(jpr_dqnsdt)%z3(:,:,jl) * ( pist(:,:,jl) - ( ( rt0 + psst(:,:) ) * ziceld(:,:)   & 
    1800                   &                                                                + pist(:,:,jl) * picefr(:,:) ) ) 
     1873                  &                                             + pist(:,:,jl) * picefr(:,:) ) ) 
    18011874            END DO 
    18021875         ELSE 
    … …  
    18041877               zqns_ice(:,:,jl) = frcv(jpr_qnsmix)%z3(:,:, 1)    & 
    18051878                  &             + frcv(jpr_dqnsdt)%z3(:,:, 1) * ( pist(:,:,jl) - ( ( rt0 + psst(:,:) ) * ziceld(:,:)   & 
    1806                   &                                                                + pist(:,:,jl) * picefr(:,:) ) ) 
     1879                  &                                             + pist(:,:,jl) * picefr(:,:) ) ) 
    18071880            END DO 
    18081881         ENDIF 
    … …  
    19101983      CASE( 'oce only' ) 
    19111984         zqsr_tot(:,:  ) = MAX( 0._wp , frcv(jpr_qsroce)%z3(:,:,1) ) 
     1985         ! For Met Office sea ice solar fluxes are already delt with by JULES so setting to zero 
     1986         ! here so the only flux is the ocean only one. 
     1987         zqsr_ice(:,:,:) = 0._wp 
    19121988      CASE( 'conservative' ) 
    19131989         zqsr_tot(:,:  ) = frcv(jpr_qsrmix)%z3(:,:,1) 
    … …  
    19952071            ENDDO 
    19962072         ENDIF 
     2073      CASE( 'none' )  
     2074         zdqns_ice(:,:,:) = 0._wp 
    19972075      END SELECT 
    19982076       
    … …  
    20102088      !                                                      ! ========================= ! 
    20112089      CASE ('coupled') 
    2012          IF( ln_mixcpl ) THEN 
    2013             DO jl=1,jpl 
    2014                qml_ice(:,:,jl) = qml_ice(:,:,jl) * xcplmask(:,:,0) + frcv(jpr_topm)%z3(:,:,jl) * zmsk(:,:) 
    2015                qcn_ice(:,:,jl) = qcn_ice(:,:,jl) * xcplmask(:,:,0) + frcv(jpr_botm)%z3(:,:,jl) * zmsk(:,:) 
    2016             ENDDO 
     2090         IF (ln_scale_ice_flux) THEN 
     2091            WHERE( a_i(:,:,:) > 1.e-10_wp ) 
     2092               qml_ice(:,:,:) = frcv(jpr_topm)%z3(:,:,:) * a_i_last_couple(:,:,:) / a_i(:,:,:) 
     2093               qcn_ice(:,:,:) = frcv(jpr_botm)%z3(:,:,:) * a_i_last_couple(:,:,:) / a_i(:,:,:) 
     2094            ELSEWHERE 
     2095               qml_ice(:,:,:) = 0.0_wp 
     2096               qcn_ice(:,:,:) = 0.0_wp 
     2097            END WHERE 
    20172098         ELSE 
    20182099            qml_ice(:,:,:) = frcv(jpr_topm)%z3(:,:,:) 
    … …  
    20252106      IF( .NOT.ln_cndflx ) THEN                              !==  No conduction flux as surface forcing  ==! 
    20262107         ! 
    2027          !                    ! ===> used prescribed cloud fraction representative for polar oceans in summer (0.81) 
    2028          ztri = 0.18 * ( 1.0 - cldf_ice ) + 0.35 * cldf_ice    ! surface transmission when hi>10cm (Grenfell Maykut 77) 
    2029          ! 
    2030          WHERE    ( phs(:,:,:) <= 0._wp .AND. phi(:,:,:) <  0.1_wp )       ! linear decrease from hi=0 to 10cm   
    2031             zqtr_ice_top(:,:,:) = qsr_ice(:,:,:) * ( ztri + ( 1._wp - ztri ) * ( 1._wp - phi(:,:,:) * 10._wp ) ) 
    2032          ELSEWHERE( phs(:,:,:) <= 0._wp .AND. phi(:,:,:) >= 0.1_wp )       ! constant (ztri) when hi>10cm 
    2033             zqtr_ice_top(:,:,:) = qsr_ice(:,:,:) * ztri 
    2034          ELSEWHERE                                                         ! zero when hs>0 
    2035             zqtr_ice_top(:,:,:) = 0._wp 
    2036          END WHERE 
     2108         IF( nn_qtrice == 0 ) THEN 
     2109            ! formulation derived from Grenfell and Maykut (1977), where transmission rate 
     2110            !    1) depends on cloudiness 
     2111            !       ! ===> used prescribed cloud fraction representative for polar oceans in summer (0.81) 
     2112            !       !      should be real cloud fraction instead (as in the bulk) but needs to be read from atm. 
     2113            !    2) is 0 when there is any snow 
     2114            !    3) tends to 1 for thin ice 
     2115            ztri(:,:) = 0.18 * ( 1.0 - cloud_fra(:,:) ) + 0.35 * cloud_fra(:,:)  ! surface transmission when hi>10cm 
     2116            DO jl = 1, jpl 
     2117               WHERE    ( phs(:,:,jl) <= 0._wp .AND. phi(:,:,jl) <  0.1_wp )       ! linear decrease from hi=0 to 10cm   
     2118                  zqtr_ice_top(:,:,jl) = zqsr_ice(:,:,jl) * ( ztri(:,:) + ( 1._wp - ztri(:,:) ) * ( 1._wp - phi(:,:,jl) * 10._wp ) ) 
     2119               ELSEWHERE( phs(:,:,jl) <= 0._wp .AND. phi(:,:,jl) >= 0.1_wp )       ! constant (ztri) when hi>10cm 
     2120                  zqtr_ice_top(:,:,jl) = zqsr_ice(:,:,jl) * ztri(:,:) 
     2121               ELSEWHERE                                                           ! zero when hs>0 
     2122                  zqtr_ice_top(:,:,jl) = 0._wp  
     2123               END WHERE 
     2124            ENDDO 
     2125         ELSEIF( nn_qtrice == 1 ) THEN 
     2126            ! formulation is derived from the thesis of M. Lebrun (2019). 
     2127            !    It represents the best fit using several sets of observations 
     2128            !    It comes with snow conductivities adapted to freezing/melting conditions (see icethd_zdf_bl99.F90) 
     2129            zqtr_ice_top(:,:,:) = 0.3_wp * zqsr_ice(:,:,:) 
     2130         ENDIF 
    20372131         !      
    20382132      ELSEIF( ln_cndflx .AND. .NOT.ln_cndemulate ) THEN      !==  conduction flux as surface forcing  ==! 
    20392133         ! 
    2040          !                    ! ===> here we must receive the qtr_ice_top array from the coupler 
    2041          !                           for now just assume zero (fully opaque ice) 
     2134         !          ! ===> here we must receive the qtr_ice_top array from the coupler 
     2135         !                 for now just assume zero (fully opaque ice) 
    20422136         zqtr_ice_top(:,:,:) = 0._wp 
    20432137         ! 
    … …  
    20962190      ! 
    20972191      isec = ( kt - nit000 ) * NINT( rn_Dt )        ! date of exchanges 
     2192      info = OASIS_idle 
    20982193 
    20992194      zfr_l(:,:) = 1.- fr_i(:,:) 
    … …  
    22342329      ENDIF 
    22352330 
     2331#if defined key_si3 || defined key_cice 
     2332      ! If this coupling was successful then save ice fraction for use between coupling points.  
     2333      ! This is needed for some calculations where the ice fraction at the last coupling point  
     2334      ! is needed.  
     2335      IF(  info == OASIS_Sent    .OR. info == OASIS_ToRest .OR. &  
     2336         & info == OASIS_SentOut .OR. info == OASIS_ToRestOut ) THEN  
     2337         IF ( sn_snd_thick%clcat == 'yes' ) THEN  
     2338           a_i_last_couple(:,:,1:jpl) = a_i(:,:,1:jpl) 
     2339         ENDIF 
     2340      ENDIF 
     2341#endif 
     2342 
    22362343      IF( ssnd(jps_fice1)%laction ) THEN 
    22372344         SELECT CASE( sn_snd_thick1%clcat ) 
    … …  
    22972404            SELECT CASE( sn_snd_mpnd%clcat )   
    22982405            CASE( 'yes' )   
    2299                ztmp3(:,:,1:jpl) =  a_ip_frac(:,:,1:jpl) 
     2406               ztmp3(:,:,1:jpl) =  a_ip_eff(:,:,1:jpl) 
    23002407               ztmp4(:,:,1:jpl) =  h_ip(:,:,1:jpl)   
    23012408            CASE( 'no' )   
    … …  
    23032410               ztmp4(:,:,:) = 0.0   
    23042411               DO jl=1,jpl   
    2305                  ztmp3(:,:,1) = ztmp3(:,:,1) + a_ip_frac(:,:,jpl)   
    2306                  ztmp4(:,:,1) = ztmp4(:,:,1) + h_ip(:,:,jpl)  
     2412                 ztmp3(:,:,1) = ztmp3(:,:,1) + a_ip_frac(:,:,jpl) 
     2413                 ztmp4(:,:,1) = ztmp4(:,:,1) + h_ip(:,:,jpl) 
    23072414               ENDDO   
    23082415            CASE default   ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_mpnd%clcat' )   

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/SBC/sbcdcy.F90

    r13295 r13998  
    110110 
    111111      imask_night(:,:) = 0 
    112       DO_2D( 1, 1, 1, 1 ) 
     112      DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
    113113         ztmpm = 0._wp 
    114114         IF( ABS(rab(ji,jj)) < 1. ) THEN         ! day duration is less than 24h 
    … …  
    193193 
    194194         zsin = SIN( zdecrad )   ;   zcos = COS( zdecrad ) 
    195          DO_2D( 1, 1, 1, 1 ) 
     195         DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
    196196            ztmp = rad * gphit(ji,jj) 
    197197            raa(ji,jj) = SIN( ztmp ) * zsin 
    … …  
    202202         ! rab to test if the day time is equal to 0, less than 24h of full day 
    203203         rab(:,:) = -raa(:,:) / rbb(:,:) 
    204          DO_2D( 1, 1, 1, 1 ) 
     204         DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
    205205            IF( ABS(rab(ji,jj)) < 1._wp ) THEN         ! day duration is less than 24h 
    206206               ! When is it night? 
    … …  
    226226         !         Avoid possible infinite scaling factor, associated with very short daylight 
    227227         !         periods, by ignoring periods less than 1/1000th of a day (ticket #1040) 
    228          DO_2D( 1, 1, 1, 1 ) 
     228         DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
    229229            IF( ABS(rab(ji,jj)) < 1._wp ) THEN         ! day duration is less than 24h 
    230230               rscal(ji,jj) = 0.0_wp 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/SBC/sbcflx.F90

    r13295 r13998  
    2929   PUBLIC sbc_flx       ! routine called by step.F90 
    3030 
    31    INTEGER , PARAMETER ::   jpfld   = 5   ! maximum number of files to read  
    3231   INTEGER , PARAMETER ::   jp_utau = 1   ! index of wind stress (i-component) file 
    3332   INTEGER , PARAMETER ::   jp_vtau = 2   ! index of wind stress (j-component) file 
    … …  
    3534   INTEGER , PARAMETER ::   jp_qsr  = 4   ! index of solar heat file 
    3635   INTEGER , PARAMETER ::   jp_emp  = 5   ! index of evaporation-precipation file 
     36 !!INTEGER , PARAMETER ::   jp_sfx  = 6   ! index of salt flux flux 
     37   INTEGER , PARAMETER ::   jpfld   = 5 !! 6 ! maximum number of files to read  
    3738   TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf    ! structure of input fields (file informations, fields read) 
    3839 
    … …  
    5960      !!                   net downward radiative flux            qsr   (watt/m2) 
    6061      !!                   net upward freshwater (evapo - precip) emp   (kg/m2/s) 
     62      !!                   salt flux                              sfx   (pss*dh*rho/dt => g/m2/s) 
    6163      !! 
    6264      !!      CAUTION :  - never mask the surface stress fields 
    … …  
    7173      !!              - emp         upward mass flux (evap. - precip.) 
    7274      !!              - sfx         salt flux; set to zero at nit000 but possibly non-zero 
    73       !!                            if ice is present 
     75      !!                            if ice 
    7476      !!---------------------------------------------------------------------- 
    7577      INTEGER, INTENT(in) ::   kt   ! ocean time step 
    … …  
    8587      CHARACTER(len=100) ::  cn_dir                               ! Root directory for location of flx files 
    8688      TYPE(FLD_N), DIMENSION(jpfld) ::   slf_i                    ! array of namelist information structures 
    87       TYPE(FLD_N) ::   sn_utau, sn_vtau, sn_qtot, sn_qsr, sn_emp ! informations about the fields to be read 
    88       NAMELIST/namsbc_flx/ cn_dir, sn_utau, sn_vtau, sn_qtot, sn_qsr, sn_emp 
     89      TYPE(FLD_N) ::   sn_utau, sn_vtau, sn_qtot, sn_qsr, sn_emp !!, sn_sfx ! informations about the fields to be read 
     90      NAMELIST/namsbc_flx/ cn_dir, sn_utau, sn_vtau, sn_qtot, sn_qsr, sn_emp !!, sn_sfx 
    8991      !!--------------------------------------------------------------------- 
    9092      ! 
    … …  
    105107         slf_i(jp_utau) = sn_utau   ;   slf_i(jp_vtau) = sn_vtau 
    106108         slf_i(jp_qtot) = sn_qtot   ;   slf_i(jp_qsr ) = sn_qsr  
    107          slf_i(jp_emp ) = sn_emp 
     109         slf_i(jp_emp ) = sn_emp !! ;   slf_i(jp_sfx ) = sn_sfx 
    108110         ! 
    109111         ALLOCATE( sf(jpfld), STAT=ierror )        ! set sf structure 
    … …  
    118120         CALL fld_fill( sf, slf_i, cn_dir, 'sbc_flx', 'flux formulation for ocean surface boundary condition', 'namsbc_flx' ) 
    119121         ! 
    120          sfx(:,:) = 0.0_wp                         ! salt flux due to freezing/melting (non-zero only if ice is present) 
    121          ! 
    122122      ENDIF 
    123123 
    … …  
    126126      IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN                        ! update ocean fluxes at each SBC frequency 
    127127 
    128          IF( ln_dm2dc ) THEN   ;   qsr(:,:) = sbc_dcy( sf(jp_qsr)%fnow(:,:,1) )   ! modify now Qsr to include the diurnal cycle 
    129          ELSE                  ;   qsr(:,:) =          sf(jp_qsr)%fnow(:,:,1) 
     128         IF( ln_dm2dc ) THEN   ! modify now Qsr to include the diurnal cycle 
     129            qsr(:,:) = sbc_dcy( sf(jp_qsr)%fnow(:,:,1) ) * tmask(ji,jj,1) 
     130         ELSE 
     131            DO_2D( 0, 0, 0, 0 ) 
     132               qsr(ji,jj) =          sf(jp_qsr)%fnow(ji,jj,1)   * tmask(ji,jj,1) 
     133            END_2D 
    130134         ENDIF 
    131          DO_2D( 1, 1, 1, 1 ) 
    132             utau(ji,jj) = sf(jp_utau)%fnow(ji,jj,1) 
    133             vtau(ji,jj) = sf(jp_vtau)%fnow(ji,jj,1) 
    134             qns (ji,jj) = sf(jp_qtot)%fnow(ji,jj,1) - sf(jp_qsr)%fnow(ji,jj,1) 
    135             emp (ji,jj) = sf(jp_emp )%fnow(ji,jj,1) 
     135         DO_2D( 0, 0, 0, 0 )                                      ! set the ocean fluxes from read fields 
     136            utau(ji,jj) =   sf(jp_utau)%fnow(ji,jj,1)                              * umask(ji,jj,1) 
     137            vtau(ji,jj) =   sf(jp_vtau)%fnow(ji,jj,1)                              * vmask(ji,jj,1) 
     138            qns (ji,jj) = ( sf(jp_qtot)%fnow(ji,jj,1) - sf(jp_qsr)%fnow(ji,jj,1) ) * tmask(ji,jj,1) 
     139            emp (ji,jj) =   sf(jp_emp )%fnow(ji,jj,1)                              * tmask(ji,jj,1) 
     140            !!sfx (ji,jj) = sf(jp_sfx )%fnow(ji,jj,1)                              * tmask(ji,jj,1)  
    136141         END_2D 
    137142         !                                                        ! add to qns the heat due to e-p 
    138          qns(:,:) = qns(:,:) - emp(:,:) * sst_m(:,:) * rcp        ! mass flux is at SST 
     143         !!clem: I do not think it is needed 
     144         !!qns(:,:) = qns(:,:) - emp(:,:) * sst_m(:,:) * rcp        ! mass flux is at SST 
    139145         ! 
    140          qns(:,:) = qns(:,:) * tmask(:,:,1) 
    141          emp(:,:) = emp(:,:) * tmask(:,:,1) 
     146         ! clem: without these lbc calls, it seems that the northfold is not ok (true in 3.6, not sure in 4.x)  
     147         CALL lbc_lnk_multi( 'sbcflx', utau, 'U', -1._wp, vtau, 'V', -1._wp, & 
     148            &                           qns, 'T',  1._wp, emp , 'T',  1._wp, qsr, 'T', 1._wp ) !! sfx, 'T', 1._wp  ) 
    142149         ! 
    143          !                                                        ! module of wind stress and wind speed at T-point 
    144          zcoef = 1. / ( zrhoa * zcdrag ) 
    145          DO_2D( 0, 0, 0, 0 ) 
    146             ztx = utau(ji-1,jj  ) + utau(ji,jj)  
    147             zty = vtau(ji  ,jj-1) + vtau(ji,jj)  
    148             zmod = 0.5 * SQRT( ztx * ztx + zty * zty ) 
    149             taum(ji,jj) = zmod 
    150             wndm(ji,jj) = SQRT( zmod * zcoef ) 
    151          END_2D 
    152          taum(:,:) = taum(:,:) * tmask(:,:,1) ; wndm(:,:) = wndm(:,:) * tmask(:,:,1) 
    153          CALL lbc_lnk( 'sbcflx', taum(:,:), 'T', 1.0_wp )   ;   CALL lbc_lnk( 'sbcflx', wndm(:,:), 'T', 1.0_wp ) 
    154  
    155150         IF( nitend-nit000 <= 100 .AND. lwp ) THEN                ! control print (if less than 100 time-step asked) 
    156151            WRITE(numout,*)  
    … …  
    166161         ! 
    167162      ENDIF 
     163      !                                                           ! module of wind stress and wind speed at T-point 
     164      ! Note the use of 0.5*(2-umask) in order to unmask the stress along coastlines 
     165      zcoef = 1. / ( zrhoa * zcdrag ) 
     166      DO_2D( 0, 0, 0, 0 ) 
     167         ztx = ( utau(ji-1,jj  ) + utau(ji,jj) ) * 0.5_wp * ( 2._wp - MIN( umask(ji-1,jj  ,1), umask(ji,jj,1) ) ) 
     168         zty = ( vtau(ji  ,jj-1) + vtau(ji,jj) ) * 0.5_wp * ( 2._wp - MIN( vmask(ji  ,jj-1,1), vmask(ji,jj,1) ) )  
     169         zmod = 0.5_wp * SQRT( ztx * ztx + zty * zty ) * tmask(ji,jj,1) 
     170         taum(ji,jj) = zmod 
     171         wndm(ji,jj) = SQRT( zmod * zcoef )  !!clem: not used? 
     172      END_2D 
     173      ! 
     174      CALL lbc_lnk_multi( 'sbcflx', taum, 'T', 1._wp, wndm, 'T', 1._wp ) 
    168175      ! 
    169176   END SUBROUTINE sbc_flx 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/SBC/sbcfwb.F90

    r13286 r13998  
    9494         snwice_mass_b(:,:) = 0.e0               ! no sea-ice model is being used : no snow+ice mass 
    9595         snwice_mass  (:,:) = 0.e0 
     96         snwice_fmass (:,:) = 0.e0 
    9697#endif 
    9798         ! 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/SBC/sbcmod.F90

    r13895 r13998  
    9999         &             nn_ice   , ln_ice_embd,                                       & 
    100100         &             ln_traqsr, ln_dm2dc ,                                         & 
    101          &             ln_rnf   , nn_fwb     , ln_ssr   , ln_apr_dyn,              & 
    102          &             ln_wave  , ln_cdgw  , ln_sdw   , ln_tauwoc  , ln_stcor  ,     & 
     101         &             ln_rnf   , nn_fwb   , ln_ssr   , ln_apr_dyn,                  & 
     102         &             ln_wave  , ln_cdgw  , ln_sdw   , ln_tauwoc , ln_stcor  ,      & 
    103103         &             ln_tauw  , nn_lsm, nn_sdrift 
    104104      !!---------------------------------------------------------------------- 
    … …  
    119119#if defined key_mpp_mpi 
    120120      ncom_fsbc = nn_fsbc    ! make nn_fsbc available for lib_mpp 
     121#endif 
     122#if ! defined key_si3 
     123      IF( nn_ice == 2 )    nn_ice = 0  ! without key key_si3 you cannot use si3... 
    121124#endif 
    122125      ! 
    … …  
    226229      CASE DEFAULT                     !- not supported 
    227230      END SELECT 
    228       IF( ln_diurnal .AND. .NOT. ln_blk )   CALL ctl_stop( "sbc_init: diurnal flux processing only implemented for bulk forcing" ) 
     231      IF( ln_diurnal .AND. .NOT. (ln_blk.OR.ln_abl) )   CALL ctl_stop( "sbc_init: diurnal flux processing only implemented for bulk forcing" ) 
    229232      ! 
    230233      !                       !**  allocate and set required variables 
    … …  
    243246      ENDIF 
    244247      ! 
    245  
    246248      IF( nn_ice == 0 ) THEN        !* No sea-ice in the domain : ice fraction is always zero 
    247249         IF( nn_components /= jp_iam_opa )   fr_i(:,:) = 0._wp    ! except for OPA in SAS-OPA coupled case 
    … …  
    250252      sfx   (:,:) = 0._wp           !* salt flux due to freezing/melting 
    251253      fmmflx(:,:) = 0._wp           !* freezing minus melting flux 
     254      cloud_fra(:,:) = pp_cldf      !* cloud fraction over sea ice (used in si3) 
    252255 
    253256      taum(:,:) = 0._wp             !* wind stress module (needed in GLS in case of reduced restart) 
    … …  
    334337      IF( l_sbc_clo   )   CALL sbc_clo_init              ! closed sea surface initialisation 
    335338      ! 
    336       IF( ln_blk      )   CALL sbc_blk_init            ! bulk formulae initialization 
    337  
    338       IF( ln_abl      )   CALL sbc_abl_init            ! Atmospheric Boundary Layer (ABL) 
    339  
    340       IF( ln_ssr      )   CALL sbc_ssr_init            ! Sea-Surface Restoring initialization 
     339      IF( ln_blk      )   CALL sbc_blk_init              ! bulk formulae initialization 
     340 
     341      IF( ln_abl      )   CALL sbc_abl_init              ! Atmospheric Boundary Layer (ABL) 
     342 
     343      IF( ln_ssr      )   CALL sbc_ssr_init              ! Sea-Surface Restoring initialization 
    341344      ! 
    342345      ! 
    … …  
    561564      ENDIF 
    562565      ! 
    563       CALL iom_put( "utau", utau )   ! i-wind stress   (stress can be updated at each time step in sea-ice) 
    564       CALL iom_put( "vtau", vtau )   ! j-wind stress 
    565       ! 
    566566      IF(sn_cfctl%l_prtctl) THEN     ! print mean trends (used for debugging) 
    567567         CALL prt_ctl(tab2d_1=fr_i                , clinfo1=' fr_i     - : ', mask1=tmask ) 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/SBC/sbcrnf.F90

    r13895 r13998  
    214214            END_2D 
    215215         ELSE                    !* variable volume case 
    216             DO_2D( 1, 1, 1, 1 ) 
     216            DO_2D( 1, 1, 1, 1 )              ! update the depth over which runoffs are distributed 
    217217               h_rnf(ji,jj) = 0._wp 
    218                DO jk = 1, nk_rnf(ji,jj)                           ! recalculates h_rnf to be the depth in metres 
     218               DO jk = 1, nk_rnf(ji,jj)                             ! recalculates h_rnf to be the depth in metres 
    219219                  h_rnf(ji,jj) = h_rnf(ji,jj) + e3t(ji,jj,jk,Kmm)   ! to the bottom of the relevant grid box 
    220220               END DO 
    … …  
    373373            ENDIF 
    374374         END_2D 
    375          DO_2D( 1, 1, 1, 1 ) 
     375         DO_2D( 1, 1, 1, 1 )                           ! set the associated depth 
    376376            h_rnf(ji,jj) = 0._wp 
    377377            DO jk = 1, nk_rnf(ji,jj) 
    … …  
    403403         WHERE( zrnfcl(:,:,1) > 0._wp )  h_rnf(:,:) = zacoef * zrnfcl(:,:,1)   ! compute depth for all runoffs 
    404404         ! 
    405          DO_2D( 1, 1, 1, 1 ) 
     405         DO_2D( 1, 1, 1, 1 )                ! take in account min depth of ocean rn_hmin 
    406406            IF( zrnfcl(ji,jj,1) > 0._wp ) THEN 
    407407               jk = mbkt(ji,jj) 
    … …  
    422422         END_2D 
    423423         ! 
    424          DO_2D( 1, 1, 1, 1 ) 
     424         DO_2D( 1, 1, 1, 1 )                          ! set the associated depth 
    425425            h_rnf(ji,jj) = 0._wp 
    426426            DO jk = 1, nk_rnf(ji,jj) 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/SBC/sbcwave.F90

    r13295 r13998  
    106106      !!--------------------------------------------------------------------- 
    107107      ! 
    108       ALLOCATE( ze3divh(jpi,jpj,jpk) ) 
     108      ALLOCATE( ze3divh(jpi,jpj,jpkm1) )   ! jpkm1 -> avoid lbc_lnk on jpk that is not defined 
    109109      ALLOCATE( zk_t(jpi,jpj), zk_u(jpi,jpj), zk_v(jpi,jpj), zu0_sd(jpi,jpj), zv0_sd(jpi,jpj) ) 
    110110      ! 
    … …  
    121121            zk_t(ji,jj) = ABS( tsd2d(ji,jj) ) / MAX( ABS( 5.97_wp*ztransp ), 0.0000001_wp ) 
    122122         END_2D 
    123          DO_2D( 1, 0, 1, 0 ) 
     123         DO_2D( 1, 0, 1, 0 )          ! exp. wave number & Stokes drift velocity at u- & v-points 
    124124            zk_u(ji,jj) = 0.5_wp * ( zk_t(ji,jj) + zk_t(ji+1,jj) ) 
    125125            zk_v(ji,jj) = 0.5_wp * ( zk_t(ji,jj) + zk_t(ji,jj+1) ) 
    … …  
    164164         zsqrtpi = SQRT(rpi) 
    165165         z_two_thirds = 2.0_wp / 3.0_wp 
    166          DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     166         DO_3D( 0, 0, 0, 0, 1, jpkm1 )       ! exp. wave number & Stokes drift velocity at u- & v-points 
    167167            zbot_u = ( gdepw(ji,jj,jk+1,Kmm) + gdepw(ji+1,jj,jk+1,Kmm) )  ! 2 * bottom depth 
    168168            zbot_v = ( gdepw(ji,jj,jk+1,Kmm) + gdepw(ji,jj+1,jk+1,Kmm) )  ! 2 * bottom depth 
    … …  
    204204      !                       !==  vertical Stokes Drift 3D velocity  ==! 
    205205      ! 
    206       DO_3D( 0, 1, 0, 1, 1, jpkm1 ) 
     206      DO_3D( 0, 1, 0, 1, 1, jpkm1 )    ! Horizontal e3*divergence 
    207207         ze3divh(ji,jj,jk) = (  e2u(ji  ,jj) * e3u(ji  ,jj,jk,Kmm) * usd(ji  ,jj,jk)    & 
    208208            &                 - e2u(ji-1,jj) * e3u(ji-1,jj,jk,Kmm) * usd(ji-1,jj,jk)    & 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRA/eosbn2.F90

    r13295 r13998  
    873873      IF( ln_timing )   CALL timing_start('bn2') 
    874874      ! 
    875       DO_3D( 1, 1, 1, 1, 2, jpkm1 ) 
     875      DO_3D( 1, 1, 1, 1, 2, jpkm1 )      ! interior points only (2=< jk =< jpkm1 ); surface and bottom value set to zero one for all in istate.F90 
    876876         zrw =   ( gdepw(ji,jj,jk  ,Kmm) - gdept(ji,jj,jk,Kmm) )   & 
    877877            &  / ( gdept(ji,jj,jk-1,Kmm) - gdept(ji,jj,jk,Kmm) )  

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRA/traadv_cen.F90

    r13295 r13998  
    112112            ztu(:,:,jpk) = 0._wp                   ! Bottom value : flux set to zero 
    113113            ztv(:,:,jpk) = 0._wp 
    114             DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     114            DO_3D( 0, 0, 0, 0, 1, jpkm1 )          ! masked gradient 
    115115               ztu(ji,jj,jk) = ( pt(ji+1,jj  ,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * umask(ji,jj,jk) 
    116116               ztv(ji,jj,jk) = ( pt(ji  ,jj+1,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * vmask(ji,jj,jk) 
    … …  
    118118            CALL lbc_lnk_multi( 'traadv_cen', ztu, 'U', -1.0_wp , ztv, 'V', -1.0_wp )   ! Lateral boundary cond. 
    119119            ! 
    120             DO_3D( 0, 0, 1, 0, 1, jpkm1 ) 
     120            DO_3D( 0, 0, 0, 0, 1, jpkm1 )           ! Horizontal advective fluxes 
    121121               zC2t_u = pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj  ,jk,jn,Kmm)   ! C2 interpolation of T at u- & v-points (x2) 
    122122               zC2t_v = pt(ji,jj,jk,jn,Kmm) + pt(ji  ,jj+1,jk,jn,Kmm) 
    … …  
    128128               zwy(ji,jj,jk) =  0.5_wp * pV(ji,jj,jk) * zC4t_v 
    129129            END_3D 
     130            CALL lbc_lnk_multi( 'traadv_cen', zwx, 'U', -1. , zwy, 'V', -1. ) 
    130131            ! 
    131132         CASE DEFAULT 
    132             CALL ctl_stop( 'traadv_fct: wrong value for nn_fct' ) 
     133            CALL ctl_stop( 'traadv_cen: wrong value for nn_cen' ) 
    133134         END SELECT 
    134135         ! 
    … …  
    158159         ENDIF 
    159160         !                
    160          DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     161         DO_3D( 0, 0, 0, 0, 1, jpkm1 )   !--  Divergence of advective fluxes  --! 
    161162            pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs)    & 
    162163               &             - (  zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk  )    & 
    … …  
    165166               &                * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
    166167         END_3D 
    167          !                             ! trend diagnostics 
     168         !                               ! trend diagnostics 
    168169         IF( l_trd ) THEN 
    169170            CALL trd_tra( kt, Kmm, Krhs, cdtype, jn, jptra_xad, zwx, pU, pt(:,:,:,jn,Kmm) ) 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRA/traadv_fct.F90

    r13295 r13998  
    160160            zwy(ji,jj,jk) = 0.5 * ( zfp_vj * pt(ji,jj,jk,jn,Kbb) + zfm_vj * pt(ji  ,jj+1,jk,jn,Kbb) ) 
    161161         END_3D 
    162          !                    !* upstream tracer flux in the k direction *! 
    163          DO_3D( 1, 1, 1, 1, 2, jpkm1 ) 
     162         !                               !* upstream tracer flux in the k direction *! 
     163         DO_3D( 1, 1, 1, 1, 2, jpkm1 )      ! Interior value ( multiplied by wmask) 
    164164            zfp_wk = pW(ji,jj,jk) + ABS( pW(ji,jj,jk) ) 
    165165            zfm_wk = pW(ji,jj,jk) - ABS( pW(ji,jj,jk) ) 
    166166            zwz(ji,jj,jk) = 0.5 * ( zfp_wk * pt(ji,jj,jk,jn,Kbb) + zfm_wk * pt(ji,jj,jk-1,jn,Kbb) ) * wmask(ji,jj,jk) 
    167167         END_3D 
    168          IF( ln_linssh ) THEN    ! top ocean value (only in linear free surface as zwz has been w-masked) 
    169             IF( ln_isfcav ) THEN             ! top of the ice-shelf cavities and at the ocean surface 
     168         IF( ln_linssh ) THEN               ! top ocean value (only in linear free surface as zwz has been w-masked) 
     169            IF( ln_isfcav ) THEN                        ! top of the ice-shelf cavities and at the ocean surface 
    170170               DO_2D( 1, 1, 1, 1 ) 
    171171                  zwz(ji,jj, mikt(ji,jj) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kbb)   ! linear free surface  
    172172               END_2D 
    173             ELSE                             ! no cavities: only at the ocean surface 
     173            ELSE                                        ! no cavities: only at the ocean surface 
    174174               DO_2D( 1, 1, 1, 1 ) 
    175175                  zwz(ji,jj,1) = pW(ji,jj,1) * pt(ji,jj,1,jn,Kbb) 
    … …  
    178178         ENDIF 
    179179         !                
    180          DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
    181             !                             ! total intermediate advective trends 
     180         DO_3D( 0, 0, 0, 0, 1, jpkm1 )   !* trend and after field with monotonic scheme 
     181            !                               ! total intermediate advective trends 
    182182            ztra = - (  zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk  )   & 
    183183               &      + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk  )   & 
    184184               &      + zwz(ji,jj,jk) - zwz(ji  ,jj  ,jk+1) ) * r1_e1e2t(ji,jj) 
    185             !                             ! update and guess with monotonic sheme 
     185            !                               ! update and guess with monotonic sheme 
    186186            pt(ji,jj,jk,jn,Krhs) =                   pt(ji,jj,jk,jn,Krhs) +       ztra   & 
    187187               &                                  / e3t(ji,jj,jk,Kmm ) * tmask(ji,jj,jk) 
    … …  
    194194            ! 
    195195            ztw(:,:,1) = 0._wp ; ztw(:,:,jpk) = 0._wp ; 
    196             DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 
     196            DO_3D( 0, 0, 0, 0, 2, jpkm1 )       ! Interior value ( multiplied by wmask) 
    197197               zfp_wk = wi(ji,jj,jk) + ABS( wi(ji,jj,jk) ) 
    198198               zfm_wk = wi(ji,jj,jk) - ABS( wi(ji,jj,jk) ) 
    … …  
    227227            zltv(:,:,jpk) = 0._wp 
    228228            DO jk = 1, jpkm1                 ! Laplacian 
    229                DO_2D( 1, 0, 1, 0 ) 
     229               DO_2D( 1, 0, 1, 0 )                 ! 1st derivative (gradient) 
    230230                  ztu(ji,jj,jk) = ( pt(ji+1,jj  ,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * umask(ji,jj,jk) 
    231231                  ztv(ji,jj,jk) = ( pt(ji  ,jj+1,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * vmask(ji,jj,jk) 
    232232               END_2D 
    233                DO_2D( 0, 0, 0, 0 ) 
     233               DO_2D( 0, 0, 0, 0 )                 ! 2nd derivative * 1/ 6 
    234234                  zltu(ji,jj,jk) = (  ztu(ji,jj,jk) + ztu(ji-1,jj,jk)  ) * r1_6 
    235235                  zltv(ji,jj,jk) = (  ztv(ji,jj,jk) + ztv(ji,jj-1,jk)  ) * r1_6 
    … …  
    238238            CALL lbc_lnk_multi( 'traadv_fct', zltu, 'T', 1.0_wp , zltv, 'T', 1.0_wp )   ! Lateral boundary cond. (unchanged sgn) 
    239239            ! 
    240             DO_3D( 1, 0, 1, 0, 1, jpkm1 ) 
     240            DO_3D( 1, 0, 1, 0, 1, jpkm1 )    ! Horizontal advective fluxes 
    241241               zC2t_u = pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj  ,jk,jn,Kmm)   ! 2 x C2 interpolation of T at u- & v-points 
    242242               zC2t_v = pt(ji,jj,jk,jn,Kmm) + pt(ji  ,jj+1,jk,jn,Kmm) 
    243                !                                                  ! C4 minus upstream advective fluxes  
     243               !                                                        ! C4 minus upstream advective fluxes  
    244244               zwx(ji,jj,jk) =  0.5_wp * pU(ji,jj,jk) * ( zC2t_u + zltu(ji,jj,jk) - zltu(ji+1,jj,jk) ) - zwx(ji,jj,jk) 
    245245               zwy(ji,jj,jk) =  0.5_wp * pV(ji,jj,jk) * ( zC2t_v + zltv(ji,jj,jk) - zltv(ji,jj+1,jk) ) - zwy(ji,jj,jk) 
    … …  
    249249            ztu(:,:,jpk) = 0._wp             ! Bottom value : flux set to zero 
    250250            ztv(:,:,jpk) = 0._wp 
    251             DO_3D( 1, 0, 1, 0, 1, jpkm1 ) 
     251            DO_3D( 1, 0, 1, 0, 1, jpkm1 )    ! 1st derivative (gradient) 
    252252               ztu(ji,jj,jk) = ( pt(ji+1,jj  ,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * umask(ji,jj,jk) 
    253253               ztv(ji,jj,jk) = ( pt(ji  ,jj+1,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * vmask(ji,jj,jk) 
    … …  
    255255            CALL lbc_lnk_multi( 'traadv_fct', ztu, 'U', -1.0_wp , ztv, 'V', -1.0_wp )   ! Lateral boundary cond. (unchanged sgn) 
    256256            ! 
    257             DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     257            DO_3D( 0, 0, 0, 0, 1, jpkm1 )    ! Horizontal advective fluxes 
    258258               zC2t_u = pt(ji,jj,jk,jn,Kmm) + pt(ji+1,jj  ,jk,jn,Kmm)   ! 2 x C2 interpolation of T at u- & v-points (x2) 
    259259               zC2t_v = pt(ji,jj,jk,jn,Kmm) + pt(ji  ,jj+1,jk,jn,Kmm) 
    … …  
    288288         !          
    289289         IF ( ll_zAimp ) THEN 
    290             DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
    291                !                             ! total intermediate advective trends 
     290            DO_3D( 0, 0, 0, 0, 1, jpkm1 )    !* trend and after field with monotonic scheme 
     291               !                                                ! total intermediate advective trends 
    292292               ztra = - (  zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk  )   & 
    293293                  &      + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk  )   & 
    … …  
    298298            CALL tridia_solver( zwdia, zwsup, zwinf, ztw, ztw , 0 ) 
    299299            ! 
    300             DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 
     300            DO_3D( 0, 0, 0, 0, 2, jpkm1 )       ! Interior value ( multiplied by wmask) 
    301301               zfp_wk = wi(ji,jj,jk) + ABS( wi(ji,jj,jk) ) 
    302302               zfm_wk = wi(ji,jj,jk) - ABS( wi(ji,jj,jk) ) 
    … …  
    324324            ! 
    325325            ztw(:,:,1) = 0._wp ; ztw(:,:,jpk) = 0._wp 
    326             DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 
     326            DO_3D( 0, 0, 0, 0, 2, jpkm1 )      ! Interior value ( multiplied by wmask) 
    327327               zfp_wk = wi(ji,jj,jk) + ABS( wi(ji,jj,jk) ) 
    328328               zfm_wk = wi(ji,jj,jk) - ABS( wi(ji,jj,jk) ) 
    … …  
    454454         pbb(ji,jj,jk) = pbb(ji,jj,jk) * ( zcv * zav + ( 1._wp - zcv) * zbv ) 
    455455 
    456 ! monotonic flux in the k direction, i.e. pcc 
    457 ! ------------------------------------------- 
     456      ! monotonic flux in the k direction, i.e. pcc 
     457      ! ------------------------------------------- 
    458458         za = MIN( 1., zbetdo(ji,jj,jk+1), zbetup(ji,jj,jk) ) 
    459459         zb = MIN( 1., zbetup(ji,jj,jk+1), zbetdo(ji,jj,jk) ) 
    … …  
    481481      !!---------------------------------------------------------------------- 
    482482       
    483       DO_3D( 1, 1, 1, 1, 3, jpkm1 ) 
     483      DO_3D( 1, 1, 1, 1, 3, jpkm1 )       !==  build the three diagonal matrix  ==! 
    484484         zwd (ji,jj,jk) = 4._wp 
    485485         zwi (ji,jj,jk) = 1._wp 
    … …  
    495495      END_3D 
    496496      ! 
    497       jk = 2                                          ! Switch to second order centered at top 
     497      jk = 2                                    ! Switch to second order centered at top 
    498498      DO_2D( 1, 1, 1, 1 ) 
    499499         zwd (ji,jj,jk) = 1._wp 
    … …  
    504504      ! 
    505505      !                       !==  tridiagonal solve  ==! 
    506       DO_2D( 1, 1, 1, 1 ) 
     506      DO_2D( 1, 1, 1, 1 )           ! first recurrence 
    507507         zwt(ji,jj,2) = zwd(ji,jj,2) 
    508508      END_2D 
    … …  
    511511      END_3D 
    512512      ! 
    513       DO_2D( 1, 1, 1, 1 ) 
     513      DO_2D( 1, 1, 1, 1 )           ! second recurrence:    Zk = Yk - Ik / Tk-1  Zk-1 
    514514         pt_out(ji,jj,2) = zwrm(ji,jj,2) 
    515515      END_2D 
    … …  
    518518      END_3D 
    519519 
    520       DO_2D( 1, 1, 1, 1 ) 
     520      DO_2D( 1, 1, 1, 1 )           ! third recurrence: Xk = (Zk - Sk Xk+1 ) / Tk 
    521521         pt_out(ji,jj,jpkm1) = pt_out(ji,jj,jpkm1) / zwt(ji,jj,jpkm1) 
    522522      END_2D 
    … …  
    546546      !                      !==  build the three diagonal matrix & the RHS  ==! 
    547547      ! 
    548       DO_3D( 0, 0, 0, 0, 3, jpkm1 ) 
     548      DO_3D( 0, 0, 0, 0, 3, jpkm1 )    ! interior (from jk=3 to jpk-1) 
    549549         zwd (ji,jj,jk) = 3._wp * wmask(ji,jj,jk) + 1._wp                 !       diagonal 
    550550         zwi (ji,jj,jk) =         wmask(ji,jj,jk)                         ! lower diagonal 
    … …  
    565565      END IF 
    566566      ! 
    567       DO_2D( 0, 0, 0, 0 ) 
     567      DO_2D( 0, 0, 0, 0 )              ! 2nd order centered at top & bottom 
    568568         ikt = mikt(ji,jj) + 1            ! w-point below the 1st  wet point 
    569569         ikb = MAX(mbkt(ji,jj), 2)        !     -   above the last wet point 
    … …  
    582582      !                       !==  tridiagonal solver  ==! 
    583583      ! 
    584       DO_2D( 0, 0, 0, 0 ) 
     584      DO_2D( 0, 0, 0, 0 )           !* 1st recurrence:   Tk = Dk - Ik Sk-1 / Tk-1 
    585585         zwt(ji,jj,2) = zwd(ji,jj,2) 
    586586      END_2D 
    … …  
    589589      END_3D 
    590590      ! 
    591       DO_2D( 0, 0, 0, 0 ) 
     591      DO_2D( 0, 0, 0, 0 )           !* 2nd recurrence:    Zk = Yk - Ik / Tk-1  Zk-1 
    592592         pt_out(ji,jj,2) = zwrm(ji,jj,2) 
    593593      END_2D 
    … …  
    596596      END_3D 
    597597 
    598       DO_2D( 0, 0, 0, 0 ) 
     598      DO_2D( 0, 0, 0, 0 )           !* 3d recurrence:    Xk = (Zk - Sk Xk+1 ) / Tk 
    599599         pt_out(ji,jj,jpkm1) = pt_out(ji,jj,jpkm1) / zwt(ji,jj,jpkm1) 
    600600      END_2D 
    … …  
    638638      kstart =  1  + klev 
    639639      ! 
    640       DO_2D( 0, 0, 0, 0 ) 
     640      DO_2D( 0, 0, 0, 0 )                         !* 1st recurrence:   Tk = Dk - Ik Sk-1 / Tk-1 
    641641         zwt(ji,jj,kstart) = pD(ji,jj,kstart) 
    642642      END_2D 
    … …  
    645645      END_3D 
    646646      ! 
    647       DO_2D( 0, 0, 0, 0 ) 
     647      DO_2D( 0, 0, 0, 0 )                        !* 2nd recurrence:    Zk = Yk - Ik / Tk-1  Zk-1 
    648648         pt_out(ji,jj,kstart) = pRHS(ji,jj,kstart) 
    649649      END_2D 
    … …  
    652652      END_3D 
    653653 
    654       DO_2D( 0, 0, 0, 0 ) 
     654      DO_2D( 0, 0, 0, 0 )                       !* 3d recurrence:    Xk = (Zk - Sk Xk+1 ) / Tk 
    655655         pt_out(ji,jj,jpkm1) = pt_out(ji,jj,jpkm1) / zwt(ji,jj,jpkm1) 
    656656      END_2D 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRA/traadv_mus.F90

    r13295 r13998  
    148148         END_3D 
    149149         ! 
    150          DO_3D( 0, 1, 0, 1, 1, jpkm1 ) 
     150         DO_3D( 0, 1, 0, 1, 1, jpkm1 )    !-- Slopes limitation 
    151151            zslpx(ji,jj,jk) = SIGN( 1.0_wp, zslpx(ji,jj,jk) ) * MIN(    ABS( zslpx(ji  ,jj,jk) ),   & 
    152152               &                                                     2.*ABS( zwx  (ji-1,jj,jk) ),   & 
    … …  
    157157         END_3D 
    158158         ! 
    159          DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     159         DO_3D( 0, 0, 0, 0, 1, jpkm1 )    !-- MUSCL horizontal advective fluxes 
    160160            ! MUSCL fluxes 
    161161            z0u = SIGN( 0.5_wp, pU(ji,jj,jk) ) 
    … …  
    175175         CALL lbc_lnk_multi( 'traadv_mus', zwx, 'U', -1.0_wp , zwy, 'V', -1.0_wp )   ! lateral boundary conditions   (changed sign) 
    176176         ! 
    177          DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     177         DO_3D( 0, 0, 0, 0, 1, jpkm1 )    !-- Tracer advective trend 
    178178            pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk  )       & 
    179179            &                                     + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk  ) )     & 
    … …  
    204204               &            * (  0.25 + SIGN( 0.25_wp, zwx(ji,jj,jk) * zwx(ji,jj,jk+1) )  ) 
    205205         END_3D 
    206          DO_3D( 1, 1, 1, 1, 2, jpkm1 ) 
     206         DO_3D( 1, 1, 1, 1, 2, jpkm1 )    !-- Slopes limitation 
    207207            zslpx(ji,jj,jk) = SIGN( 1.0_wp, zslpx(ji,jj,jk) ) * MIN(    ABS( zslpx(ji,jj,jk  ) ),   & 
    208208               &                                                     2.*ABS( zwx  (ji,jj,jk+1) ),   & 
    209209               &                                                     2.*ABS( zwx  (ji,jj,jk  ) )  ) 
    210210         END_3D 
    211          DO_3D( 0, 0, 0, 0, 1, jpk-2 ) 
     211         DO_3D( 0, 0, 0, 0, 1, jpk-2 )    !-- vertical advective flux 
    212212            z0w = SIGN( 0.5_wp, pW(ji,jj,jk+1) ) 
    213213            zalpha = 0.5 + z0w 
    … …  
    227227         ENDIF 
    228228         ! 
    229          DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     229         DO_3D( 0, 0, 0, 0, 1, jpkm1 )     !-- vertical advective trend 
    230230            pt(ji,jj,jk,jn,Krhs) =  pt(ji,jj,jk,jn,Krhs) - ( zwx(ji,jj,jk) - zwx(ji,jj,jk+1) )   & 
    231231               &                                      * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRA/traadv_qck.F90

    r13295 r13998  
    142142         ! 
    143143!!gm why not using a SHIFT instruction... 
    144          DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     144         DO_3D( 0, 0, 0, 0, 1, jpkm1 )     !--- Computation of the ustream and downstream value of the tracer and the mask 
    145145            zfc(ji,jj,jk) = pt(ji-1,jj,jk,jn,Kbb)        ! Upstream   in the x-direction for the tracer 
    146146            zfd(ji,jj,jk) = pt(ji+1,jj,jk,jn,Kbb)        ! Downstream in the x-direction for the tracer 
    … …  
    327327         !                                                       ! =========== 
    328328         ! 
    329          DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 
     329         DO_3D( 0, 0, 0, 0, 2, jpkm1 )       !* Interior point   (w-masked 2nd order centered flux) 
    330330            zwz(ji,jj,jk) = 0.5 * pW(ji,jj,jk) * ( pt(ji,jj,jk-1,jn,Kmm) + pt(ji,jj,jk,jn,Kmm) ) * wmask(ji,jj,jk) 
    331331         END_3D 
    … …  
    340340         ENDIF 
    341341         ! 
    342          DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     342         DO_3D( 0, 0, 0, 0, 1, jpkm1 )   !==  Tracer flux divergence added to the general trend  ==! 
    343343            pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( zwz(ji,jj,jk) - zwz(ji,jj,jk+1) )   & 
    344344               &                                * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRA/traadv_ubs.F90

    r13295 r13998  
    124124         !                                                       ! =========== 
    125125         !                                               
    126          DO jk = 1, jpkm1        !==  horizontal laplacian of before tracer ==! 
    127             DO_2D( 1, 0, 1, 0 ) 
     126         DO jk = 1, jpkm1                !==  horizontal laplacian of before tracer ==! 
     127            DO_2D( 1, 0, 1, 0 )                   ! First derivative (masked gradient) 
    128128               zeeu = e2_e1u(ji,jj) * e3u(ji,jj,jk,Kmm) * umask(ji,jj,jk) 
    129129               zeev = e1_e2v(ji,jj) * e3v(ji,jj,jk,Kmm) * vmask(ji,jj,jk) 
    … …  
    131131               ztv(ji,jj,jk) = zeev * ( pt(ji  ,jj+1,jk,jn,Kbb) - pt(ji,jj,jk,jn,Kbb) ) 
    132132            END_2D 
    133             DO_2D( 0, 0, 0, 0 ) 
     133            DO_2D( 0, 0, 0, 0 )                   ! Second derivative (divergence) 
    134134               zcoef = 1._wp / ( 6._wp * e3t(ji,jj,jk,Kmm) ) 
    135135               zltu(ji,jj,jk) = (  ztu(ji,jj,jk) - ztu(ji-1,jj,jk)  ) * zcoef 
    … …  
    140140         CALL lbc_lnk( 'traadv_ubs', zltu, 'T', 1.0_wp )   ;    CALL lbc_lnk( 'traadv_ubs', zltv, 'T', 1.0_wp )   ! Lateral boundary cond. (unchanged sgn) 
    141141         !     
    142          DO_3D( 1, 0, 1, 0, 1, jpkm1 ) 
    143             zfp_ui = pU(ji,jj,jk) + ABS( pU(ji,jj,jk) )      ! upstream transport (x2) 
     142         DO_3D( 1, 0, 1, 0, 1, jpkm1 )   !==  Horizontal advective fluxes  ==!     (UBS) 
     143            zfp_ui = pU(ji,jj,jk) + ABS( pU(ji,jj,jk) )        ! upstream transport (x2) 
    144144            zfm_ui = pU(ji,jj,jk) - ABS( pU(ji,jj,jk) ) 
    145145            zfp_vj = pV(ji,jj,jk) + ABS( pV(ji,jj,jk) ) 
    … …  
    166166         ! 
    167167         zltu(:,:,:) = pt(:,:,:,jn,Krhs) - zltu(:,:,:)    ! Horizontal advective trend used in vertical 2nd order FCT case 
    168          !                                            ! and/or in trend diagnostic (l_trd=T)  
     168         !                                                ! and/or in trend diagnostic (l_trd=T)  
    169169         !                 
    170170         IF( l_trd ) THEN                  ! trend diagnostics 
    … …  
    187187            IF( l_trd )   zltv(:,:,:) = pt(:,:,:,jn,Krhs)          ! store pt(:,:,:,:,Krhs) if trend diag. 
    188188            ! 
    189             !                          !*  upstream advection with initial mass fluxes & intermediate update  ==! 
     189            !                               !*  upstream advection with initial mass fluxes & intermediate update  ==! 
    190190            DO_3D( 1, 1, 1, 1, 2, jpkm1 ) 
    191191               zfp_wk = pW(ji,jj,jk) + ABS( pW(ji,jj,jk) ) 
    … …  
    193193               ztw(ji,jj,jk) = 0.5_wp * (  zfp_wk * pt(ji,jj,jk,jn,Kbb) + zfm_wk * pt(ji,jj,jk-1,jn,Kbb)  ) * wmask(ji,jj,jk) 
    194194            END_3D 
    195             IF( ln_linssh ) THEN             ! top ocean value (only in linear free surface as ztw has been w-masked) 
    196                IF( ln_isfcav ) THEN                ! top of the ice-shelf cavities and at the ocean surface 
     195            IF( ln_linssh ) THEN                ! top ocean value (only in linear free surface as ztw has been w-masked) 
     196               IF( ln_isfcav ) THEN                   ! top of the ice-shelf cavities and at the ocean surface 
    197197                  DO_2D( 1, 1, 1, 1 ) 
    198198                     ztw(ji,jj, mikt(ji,jj) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kbb)   ! linear free surface  
    199199                  END_2D 
    200                ELSE                                ! no cavities: only at the ocean surface 
     200               ELSE                                   ! no cavities: only at the ocean surface 
    201201                  ztw(:,:,1) = pW(:,:,1) * pt(:,:,1,jn,Kbb) 
    202202               ENDIF 
    203203            ENDIF 
    204204            ! 
    205             DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     205            DO_3D( 0, 0, 0, 0, 1, jpkm1 )   !* trend and after field with monotonic scheme 
    206206               ztak = - ( ztw(ji,jj,jk) - ztw(ji,jj,jk+1) )    & 
    207207                  &     * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
    … …  
    230230         END SELECT 
    231231         ! 
    232          DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     232         DO_3D( 0, 0, 0, 0, 1, jpkm1 )   !  final trend with corrected fluxes 
    233233            pt(ji,jj,jk,jn,Krhs) = pt(ji,jj,jk,jn,Krhs) - ( ztw(ji,jj,jk) - ztw(ji,jj,jk+1) )    & 
    234234               &                                        * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
    235235         END_3D 
    236236         ! 
    237          IF( l_trd )  THEN       ! vertical advective trend diagnostics 
    238             DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     237         IF( l_trd )  THEN               ! vertical advective trend diagnostics 
     238            DO_3D( 0, 0, 0, 0, 1, jpkm1 )                 ! (compute -w.dk[ptn]= -dk[w.ptn] + ptn.dk[w]) 
    239239               zltv(ji,jj,jk) = pt(ji,jj,jk,jn,Krhs) - zltv(ji,jj,jk)                          & 
    240240                  &           + pt(ji,jj,jk,jn,Kmm) * (  pW(ji,jj,jk) - pW(ji,jj,jk+1)  )   & 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRA/trabbl.F90

    r13295 r13998  
    197197         END_2D 
    198198         !                
    199          DO_2D( 0, 0, 0, 0 ) 
     199         DO_2D( 0, 0, 0, 0 )                               ! Compute the trend 
    200200            ik = mbkt(ji,jj)                            ! bottom T-level index 
    201201            pt_rhs(ji,jj,ik,jn) = pt_rhs(ji,jj,ik,jn)                                                  & 
    … …  
    358358      IF( nn_bbl_ldf == 1 ) THEN          !   diffusive bbl   ! 
    359359         !                                !-------------------! 
    360          DO_2D( 1, 0, 1, 0 ) 
     360         DO_2D( 1, 0, 1, 0 )                   ! (criteria for non zero flux: grad(rho).grad(h) < 0 ) 
    361361            !                                                   ! i-direction 
    362362            za = zab(ji+1,jj,jp_tem) + zab(ji,jj,jp_tem)              ! 2*(alpha,beta) at u-point 
    … …  
    388388         ! 
    389389         CASE( 1 )                                   != use of upper velocity 
    390             DO_2D( 1, 0, 1, 0 ) 
     390            DO_2D( 1, 0, 1, 0 )                              ! criteria: grad(rho).grad(h)<0  and grad(rho).grad(h)<0 
    391391               !                                                  ! i-direction 
    392392               za = zab(ji+1,jj,jp_tem) + zab(ji,jj,jp_tem)               ! 2*(alpha,beta) at u-point 
    … …  
    417417         CASE( 2 )                                 != bbl velocity = F( delta rho ) 
    418418            zgbbl = grav * rn_gambbl 
    419             DO_2D( 1, 0, 1, 0 ) 
     419            DO_2D( 1, 0, 1, 0 )                         ! criteria: rho_up > rho_down 
    420420               !                                                  ! i-direction 
    421421               ! down-slope T-point i/k-index (deep)  &   up-slope T-point i/k-index (shelf) 
    … …  
    505505      IF( tra_bbl_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'tra_bbl_init : unable to allocate arrays' ) 
    506506      ! 
    507       IF( nn_bbl_adv == 1 )    WRITE(numout,*) '       * Advective BBL using upper velocity' 
    508       IF( nn_bbl_adv == 2 )    WRITE(numout,*) '       * Advective BBL using velocity = F( delta rho)' 
     507      IF(lwp) THEN 
     508         IF( nn_bbl_adv == 1 )    WRITE(numout,*) '       * Advective BBL using upper velocity' 
     509         IF( nn_bbl_adv == 2 )    WRITE(numout,*) '       * Advective BBL using velocity = F( delta rho)' 
     510      ENDIF 
    509511      ! 
    510512      !                             !* vertical index of  "deep" bottom u- and v-points 
    511       DO_2D( 1, 0, 1, 0 ) 
     513      DO_2D( 1, 0, 1, 0 )                 ! (the "shelf" bottom k-indices are mbku and mbkv) 
    512514         mbku_d(ji,jj) = MAX(  mbkt(ji+1,jj  ) , mbkt(ji,jj)  )   ! >= 1 as mbkt=1 over land 
    513515         mbkv_d(ji,jj) = MAX(  mbkt(ji  ,jj+1) , mbkt(ji,jj)  ) 
    … …  
    530532      END_2D 
    531533      ! 
    532       DO_2D( 1, 0, 1, 0 ) 
     534      DO_2D( 1, 0, 1, 0 )           !* bbl thickness at u- (v-) point; minimum of top & bottom e3u_0 (e3v_0) 
    533535         e3u_bbl_0(ji,jj) = MIN( e3u_0(ji,jj,mbkt(ji+1,jj  )), e3u_0(ji,jj,mbkt(ji,jj)) ) 
    534536         e3v_bbl_0(ji,jj) = MIN( e3v_0(ji,jj,mbkt(ji  ,jj+1)), e3v_0(ji,jj,mbkt(ji,jj)) ) 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRA/traldf_iso.F90

    r13295 r13998  
    205205         END_3D 
    206206         IF( ln_zps ) THEN      ! botton and surface ocean correction of the horizontal gradient 
    207             DO_2D( 1, 0, 1, 0 ) 
     207            DO_2D( 1, 0, 1, 0 )           ! bottom correction (partial bottom cell) 
    208208               zdit(ji,jj,mbku(ji,jj)) = pgu(ji,jj,jn)           
    209209               zdjt(ji,jj,mbkv(ji,jj)) = pgv(ji,jj,jn) 
    … …  
    229229            ELSE                 ;   zdkt(:,:) = ( pt(:,:,jk-1,jn) - pt(:,:,jk,jn) ) * wmask(:,:,jk) 
    230230            ENDIF 
    231             DO_2D( 1, 0, 1, 0 ) 
     231            DO_2D( 1, 0, 1, 0 )           !==  Horizontal fluxes 
    232232               zabe1 = pahu(ji,jj,jk) * e2_e1u(ji,jj) * e3u(ji,jj,jk,Kmm) 
    233233               zabe2 = pahv(ji,jj,jk) * e1_e2v(ji,jj) * e3v(ji,jj,jk,Kmm) 
    … …  
    250250            END_2D 
    251251            ! 
    252             DO_2D( 0, 0, 0, 0 ) 
     252            DO_2D( 0, 0, 0, 0 )           !== horizontal divergence and add to pta 
    253253               pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn)    & 
    254254                  &       + zsign * (  zftu(ji,jj,jk) - zftu(ji-1,jj,jk) + zftv(ji,jj,jk) - zftv(ji,jj-1,jk)  )   & 
    … …  
    266266         ztfw(:,:, 1 ) = 0._wp      ;      ztfw(:,:,jpk) = 0._wp 
    267267          
    268          DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 
     268         DO_3D( 0, 0, 0, 0, 2, jpkm1 )    ! interior (2=<jk=<jpk-1) 
    269269            ! 
    270270            zmsku = wmask(ji,jj,jk) / MAX(   umask(ji  ,jj,jk-1) + umask(ji-1,jj,jk)          & 
    … …  
    311311         ENDIF 
    312312         !          
    313          DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     313         DO_3D( 0, 0, 0, 0, 1, jpkm1 )    !==  Divergence of vertical fluxes added to pta  ==! 
    314314            pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn) + zsign * (  ztfw (ji,jj,jk) - ztfw(ji,jj,jk+1)  ) * r1_e1e2t(ji,jj)   & 
    315315               &                                             / e3t(ji,jj,jk,Kmm) 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRA/traldf_lap_blp.F90

    r13295 r13998  
    108108         !                          ! =========== !     
    109109         !                                
    110          DO_3D( 1, 0, 1, 0, 1, jpkm1 ) 
     110         DO_3D( 1, 0, 1, 0, 1, jpkm1 )            !== First derivative (gradient)  ==! 
    111111            ztu(ji,jj,jk) = zaheeu(ji,jj,jk) * ( pt(ji+1,jj  ,jk,jn) - pt(ji,jj,jk,jn) ) 
    112112            ztv(ji,jj,jk) = zaheev(ji,jj,jk) * ( pt(ji  ,jj+1,jk,jn) - pt(ji,jj,jk,jn) ) 
    113113         END_3D 
    114          IF( ln_zps ) THEN                ! set gradient at bottom/top ocean level 
    115             DO_2D( 1, 0, 1, 0 ) 
     114         IF( ln_zps ) THEN                             ! set gradient at bottom/top ocean level 
     115            DO_2D( 1, 0, 1, 0 )                              ! bottom 
    116116               ztu(ji,jj,mbku(ji,jj)) = zaheeu(ji,jj,mbku(ji,jj)) * pgu(ji,jj,jn) 
    117117               ztv(ji,jj,mbkv(ji,jj)) = zaheev(ji,jj,mbkv(ji,jj)) * pgv(ji,jj,jn) 
    118118            END_2D 
    119             IF( ln_isfcav ) THEN                ! top in ocean cavities only 
     119            IF( ln_isfcav ) THEN                             ! top in ocean cavities only 
    120120               DO_2D( 1, 0, 1, 0 ) 
    121121                  IF( miku(ji,jj) > 1 )   ztu(ji,jj,miku(ji,jj)) = zaheeu(ji,jj,miku(ji,jj)) * pgui(ji,jj,jn)  
    … …  
    125125         ENDIF 
    126126         ! 
    127          DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     127         DO_3D( 0, 0, 0, 0, 1, jpkm1 )            !== Second derivative (divergence) added to the general tracer trends  ==! 
    128128            pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn) + (  ztu(ji,jj,jk) - ztu(ji-1,jj,jk)     & 
    129129               &                                      +    ztv(ji,jj,jk) - ztv(ji,jj-1,jk) )   & 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRA/traldf_triad.F90

    r13295 r13998  
    211211         zftv(:,:,:) = 0._wp 
    212212         ! 
    213          DO_3D( 1, 0, 1, 0, 1, jpkm1 ) 
     213         DO_3D( 1, 0, 1, 0, 1, jpkm1 )    !==  before lateral T & S gradients at T-level jk  ==! 
    214214            zdit(ji,jj,jk) = ( pt(ji+1,jj  ,jk,jn) - pt(ji,jj,jk,jn) ) * umask(ji,jj,jk) 
    215215            zdjt(ji,jj,jk) = ( pt(ji  ,jj+1,jk,jn) - pt(ji,jj,jk,jn) ) * vmask(ji,jj,jk) 
    216216         END_3D 
    217217         IF( ln_zps .AND. l_grad_zps ) THEN    ! partial steps: correction at top/bottom ocean level 
    218             DO_2D( 1, 0, 1, 0 ) 
     218            DO_2D( 1, 0, 1, 0 )                    ! bottom level 
    219219               zdit(ji,jj,mbku(ji,jj)) = pgu(ji,jj,jn) 
    220220               zdjt(ji,jj,mbkv(ji,jj)) = pgv(ji,jj,jn) 
    … …  
    361361         ENDIF 
    362362         ! 
    363          DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     363         DO_3D( 0, 0, 0, 0, 1, jpkm1 )      !==  Divergence of vertical fluxes added to pta  ==! 
    364364            pt_rhs(ji,jj,jk,jn) = pt_rhs(ji,jj,jk,jn)    & 
    365365            &                                  + zsign * (  ztfw(ji,jj,jk+1) - ztfw(ji,jj,jk)  )   & 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRA/tramle.F90

    r13295 r13998  
    100100      inml_mle(:,:) = mbkt(:,:) + 1                    ! init. to number of ocean w-level (T-level + 1) 
    101101      IF ( nla10 > 0 ) THEN                            ! avoid case where first level is thicker than 10m 
    102          DO_3DS( 1, 1, 1, 1, jpkm1, nlb10, -1 ) 
     102         DO_3DS( 1, 1, 1, 1, jpkm1, nlb10, -1 )        ! from the bottom to nlb10 (10m) 
    103103            IF( rhop(ji,jj,jk) > rhop(ji,jj,nla10) + rn_rho_c_mle )   inml_mle(ji,jj) = jk      ! Mixed layer 
    104104         END_3D 
    … …  
    110110      zbm (:,:) = 0._wp 
    111111      zn2 (:,:) = 0._wp 
    112       DO_3D( 1, 1, 1, 1, 1, ikmax ) 
     112      DO_3D( 1, 1, 1, 1, 1, ikmax )                    ! MLD and mean buoyancy and N2 over the mixed layer 
    113113         zc = e3t(ji,jj,jk,Kmm) * REAL( MIN( MAX( 0, inml_mle(ji,jj)-jk ) , 1  )  )    ! zc being 0 outside the ML t-points 
    114114         zmld(ji,jj) = zmld(ji,jj) + zc 
    … …  
    182182      zpsi_vw(:,:,:) = 0._wp 
    183183      ! 
    184       DO_3D( 1, 0, 1, 0, 2, ikmax ) 
     184      DO_3D( 1, 0, 1, 0, 2, ikmax )                ! start from 2 : surface value = 0 
    185185         zcuw = 1._wp - ( gdepw(ji+1,jj,jk,Kmm) + gdepw(ji,jj,jk,Kmm) ) * zhu(ji,jj) 
    186186         zcvw = 1._wp - ( gdepw(ji,jj+1,jk,Kmm) + gdepw(ji,jj,jk,Kmm) ) * zhv(ji,jj) 
    … …  
    196196      !                                      !==  transport increased by the MLE induced transport ==! 
    197197      DO jk = 1, ikmax 
    198          DO_2D( 1, 0, 1, 0 ) 
     198         DO_2D( 1, 0, 1, 0 )                      ! CAUTION pu,pv must be defined at row/column i=1 / j=1 
    199199            pu(ji,jj,jk) = pu(ji,jj,jk) + ( zpsi_uw(ji,jj,jk) - zpsi_uw(ji,jj,jk+1) ) 
    200200            pv(ji,jj,jk) = pv(ji,jj,jk) + ( zpsi_vw(ji,jj,jk) - zpsi_vw(ji,jj,jk+1) ) 
    … …  
    283283            IF( ierr /= 0 )   CALL ctl_stop( 'tra_adv_mle_init: failed to allocate arrays' ) 
    284284            z1_t2 = 1._wp / ( rn_time * rn_time ) 
    285             DO_2D( 0, 1, 0, 1 ) 
     285            DO_2D( 0, 1, 0, 1 )                      ! "coriolis+ time^-1" at u- & v-points 
    286286               zfu = ( ff_f(ji,jj) + ff_f(ji,jj-1) ) * 0.5_wp 
    287287               zfv = ( ff_f(ji,jj) + ff_f(ji-1,jj) ) * 0.5_wp 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRA/tranpc.F90

    r13295 r13998  
    103103         inpcc = 0 
    104104         ! 
    105          DO_2D( 0, 0, 0, 0 ) 
     105         DO_2D( 0, 0, 0, 0 )                                ! interior column only 
    106106            ! 
    107107            IF( tmask(ji,jj,2) == 1 ) THEN      ! At least 2 ocean points 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRA/traqsr.F90

    r13895 r13998  
    6363   REAL(wp) ::   xsi1r   ! inverse of rn_si1 
    6464   ! 
    65    REAL(wp) , DIMENSION(3,61)           ::   rkrgb    ! tabulated attenuation coefficients for RGB absorption 
     65   REAL(wp) , PUBLIC, DIMENSION(3,61)   ::   rkrgb    ! tabulated attenuation coefficients for RGB absorption 
    6666   TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_chl   ! structure of input Chl (file informations, fields read) 
    6767 
    … …  
    231231         END_2D 
    232232         ! 
    233          !* interior equi-partition in R-G-B depending on vertical profile of Chl 
     233         !                                    !* interior equi-partition in R-G-B depending on vertical profile of Chl 
    234234         DO_3D( 0, 0, 0, 0, 2, nksr + 1 ) 
    235235            ze3t = e3t(ji,jj,jk-1,Kmm) 
    … …  
    246246         END_3D 
    247247         ! 
    248          DO_3D( 0, 0, 0, 0, 1, nksr ) 
     248         DO_3D( 0, 0, 0, 0, 1, nksr )          !* now qsr induced heat content 
    249249            qsr_hc(ji,jj,jk) = r1_rho0_rcp * ( ztmp3d(ji,jj,jk) - ztmp3d(ji,jj,jk+1) ) 
    250250         END_3D 
    … …  
    256256         zz0 =        rn_abs   * r1_rho0_rcp      ! surface equi-partition in 2-bands 
    257257         zz1 = ( 1. - rn_abs ) * r1_rho0_rcp 
    258          DO_3D( 0, 0, 0, 0, 1, nksr ) 
     258         DO_3D( 0, 0, 0, 0, 1, nksr )             ! solar heat absorbed at T-point in the top 400m  
    259259            zc0 = zz0 * EXP( -gdepw(ji,jj,jk  ,Kmm)*xsi0r ) + zz1 * EXP( -gdepw(ji,jj,jk  ,Kmm)*xsi1r ) 
    260260            zc1 = zz0 * EXP( -gdepw(ji,jj,jk+1,Kmm)*xsi0r ) + zz1 * EXP( -gdepw(ji,jj,jk+1,Kmm)*xsi1r ) 
    … …  
    264264      END SELECT 
    265265      ! 
     266      !                          !-----------------------------! 
     267      !                          !  update to the temp. trend  ! 
    266268      !                          !-----------------------------! 
    267269      DO_3D( 0, 0, 0, 0, 1, nksr ) 
    … …  
    417419         IF( .NOT.lk_top )   CALL ctl_stop( 'No bio model : ln_qsr_bio = true impossible ' ) 
    418420         ! 
     421         CALL trc_oce_rgb( rkrgb )                 ! tabulated attenuation coef. 
     422         !                                    
     423         nksr = trc_oce_ext_lev( r_si2, 33._wp )   ! level of light extinction 
     424         ! 
     425         IF(lwp) WRITE(numout,*) '        level of light extinction = ', nksr, ' ref depth = ', gdepw_1d(nksr+1), ' m' 
     426         ! 
    419427      END SELECT 
    420428      ! 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRA/trasbc.F90

    r13895 r13998  
    128128      END_2D 
    129129      IF( ln_linssh ) THEN                !* linear free surface   
    130          DO_2D( 0, 0, 0, 0 ) 
     130         DO_2D( 0, 1, 0, 0 )                    !==>> add concentration/dilution effect due to constant volume cell 
    131131            sbc_tsc(ji,jj,jp_tem) = sbc_tsc(ji,jj,jp_tem) + r1_rho0 * emp(ji,jj) * pts(ji,jj,1,jp_tem,Kmm) 
    132132            sbc_tsc(ji,jj,jp_sal) = sbc_tsc(ji,jj,jp_sal) + r1_rho0 * emp(ji,jj) * pts(ji,jj,1,jp_sal,Kmm) 
    133          END_2D 
     133         END_2D                                 !==>> output c./d. term 
    134134         IF( iom_use('emp_x_sst') )   CALL iom_put( "emp_x_sst", emp (:,:) * pts(:,:,1,jp_tem,Kmm) ) 
    135135         IF( iom_use('emp_x_sss') )   CALL iom_put( "emp_x_sss", emp (:,:) * pts(:,:,1,jp_sal,Kmm) ) 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRA/trazdf.F90

    r13295 r13998  
    208208            !   used as a work space array: its value is modified. 
    209209            ! 
    210             DO_2D( 0, 0, 0, 0 ) 
     210            DO_2D( 0, 0, 0, 0 )      !* 1st recurrence:   Tk = Dk - Ik Sk-1 / Tk-1   (increasing k) ! done one for all passive tracers (so included in the IF instruction) 
    211211               zwt(ji,jj,1) = zwd(ji,jj,1) 
    212212            END_2D 
    … …  
    217217         ENDIF  
    218218         !          
    219          DO_2D( 0, 0, 0, 0 ) 
     219         DO_2D( 0, 0, 0, 0 )         !* 2nd recurrence:    Zk = Yk - Ik / Tk-1  Zk-1 
    220220            pt(ji,jj,1,jn,Kaa) =        e3t(ji,jj,1,Kbb) * pt(ji,jj,1,jn,Kbb)    & 
    221221               &               + p2dt * e3t(ji,jj,1,Kmm) * pt(ji,jj,1,jn,Krhs) 
    … …  
    227227         END_3D 
    228228         ! 
    229          DO_2D( 0, 0, 0, 0 ) 
     229         DO_2D( 0, 0, 0, 0 )         !* 3d recurrence:    Xk = (Zk - Sk Xk+1 ) / Tk   (result is the after tracer) 
    230230            pt(ji,jj,jpkm1,jn,Kaa) = pt(ji,jj,jpkm1,jn,Kaa) / zwt(ji,jj,jpkm1) * tmask(ji,jj,jpkm1) 
    231231         END_2D 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRA/zpshde.F90

    r13295 r13998  
    167167         CALL eos( ztj, zhj, zrj )        ! at the partial step depth output in  zri, zrj  
    168168         ! 
    169          DO_2D( 1, 0, 1, 0 ) 
     169         DO_2D( 1, 0, 1, 0 )              ! Gradient of density at the last level 
    170170            iku = mbku(ji,jj) 
    171171            ikv = mbkv(ji,jj) 
    … …  
    329329         CALL eos( ztj, zhj, zrj ) 
    330330 
    331          DO_2D( 1, 0, 1, 0 ) 
     331         DO_2D( 1, 0, 1, 0 )            ! Gradient of density at the last level 
    332332            iku = mbku(ji,jj) 
    333333            ikv = mbkv(ji,jj) 
    … …  
    420420         CALL eos( ztj, zhj, zrj )        ! at the partial step depth output in  zri, zrj  
    421421         ! 
    422          DO_2D( 1, 0, 1, 0 ) 
     422         DO_2D( 1, 0, 1, 0 )              ! Gradient of density at the last level 
    423423            iku = miku(ji,jj)  
    424424            ikv = mikv(ji,jj)  

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRD/trddyn.F90

    r13295 r13998  
    124124                              z3dx(:,:,:) = 0._wp                  ! U.dxU & V.dyV (approximation) 
    125125                              z3dy(:,:,:) = 0._wp 
    126                               DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     126                              DO_3D( 0, 0, 0, 0, 1, jpkm1 )   ! no mask as un,vn are masked 
    127127                                 z3dx(ji,jj,jk) = uu(ji,jj,jk,Kmm) * ( uu(ji+1,jj,jk,Kmm) - uu(ji-1,jj,jk,Kmm) ) / ( 2._wp * e1u(ji,jj) ) 
    128128                                 z3dy(ji,jj,jk) = vv(ji,jj,jk,Kmm) * ( vv(ji,jj+1,jk,Kmm) - vv(ji,jj-1,jk,Kmm) ) / ( 2._wp * e2v(ji,jj) ) 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRD/trdglo.F90

    r13295 r13998  
    8686         ! 
    8787         CASE( 'TRA' )          !==  Tracers (T & S)  ==! 
    88             DO_3D( 1, 1, 1, 1, 1, jpkm1 ) 
     88            DO_3D( 1, 1, 1, 1, 1, jpkm1 )   ! global sum of mask volume trend and trend*T (including interior mask) 
    8989               zvm = e1e2t(ji,jj) * e3t(ji,jj,jk,Kmm) * tmask(ji,jj,jk) * tmask_i(ji,jj) 
    9090               zvt = ptrdx(ji,jj,jk) * zvm 
    … …  
    218218         END_3D 
    219219          
    220          DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     220         DO_3D( 0, 0, 0, 0, 1, jpkm1 )    ! Density flux divergence at t-point 
    221221            zkepe(ji,jj,jk) = - (  zkz(ji,jj,jk) - zkz(ji  ,jj  ,jk+1)               & 
    222222               &                 + zkx(ji,jj,jk) - zkx(ji-1,jj  ,jk  )               & 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRD/trdmxl.F90

    r13295 r13998  
    120120         ! 
    121121         wkx(:,:,:) = 0._wp         !==  now ML weights for vertical averaging  ==! 
    122          DO_3D( 1, 1, 1, 1, 1, jpktrd ) 
     122         DO_3D( 1, 1, 1, 1, 1, jpktrd )  ! initialize wkx with vertical scale factor in mixed-layer 
    123123            IF( jk - kmxln(ji,jj) < 0 )   THEN 
    124124               wkx(ji,jj,jk) = e3t(ji,jj,jk,Kmm) * tmask(ji,jj,jk) 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRD/trdtra.F90

    r13295 r13998  
    210210      !!---------------------------------------------------------------------- 
    211211      ! 
    212       SELECT CASE( cdir )      ! shift depending on the direction 
     212      SELECT CASE( cdir )             ! shift depending on the direction 
    213213      CASE( 'X' )   ;   ii = 1   ;   ij = 0   ;   ik = 0      ! i-trend 
    214214      CASE( 'Y' )   ;   ii = 0   ;   ij = 1   ;   ik = 0      ! j-trend 
    … …  
    216216      END SELECT 
    217217      ! 
    218       !                        ! set to zero uncomputed values 
     218      !                               ! set to zero uncomputed values 
    219219      ptrd(jpi,:,:) = 0._wp   ;   ptrd(1,:,:) = 0._wp 
    220220      ptrd(:,jpj,:) = 0._wp   ;   ptrd(:,1,:) = 0._wp 
    221221      ptrd(:,:,jpk) = 0._wp 
    222222      ! 
    223       DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     223      DO_3D( 0, 0, 0, 0, 1, jpkm1 )   ! advective trend 
    224224         ptrd(ji,jj,jk) = - (     pf (ji,jj,jk) - pf (ji-ii,jj-ij,jk-ik)                        & 
    225225           &                  - ( pu(ji,jj,jk) - pu(ji-ii,jj-ij,jk-ik) ) * pt(ji,jj,jk)  )   & 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/TRD/trdvor.F90

    r13295 r13998  
    103103      CASE( jpdyn_zad )   ;   CALL trd_vor_zint( putrd, pvtrd, jpvor_zad, Kmm )   ! Vertical Advection  
    104104      CASE( jpdyn_spg )   ;   CALL trd_vor_zint( putrd, pvtrd, jpvor_spg, Kmm )   ! Surface Pressure Grad.  
    105       CASE( jpdyn_zdf )                                                      ! Vertical Diffusion  
     105      CASE( jpdyn_zdf )                                                           ! Vertical Diffusion  
    106106         ztswu(:,:) = 0.e0   ;   ztswv(:,:) = 0.e0 
    107          DO_2D( 0, 0, 0, 0 ) 
     107         DO_2D( 0, 0, 0, 0 )                                                               ! wind stress trends 
    108108            ztswu(ji,jj) = 0.5 * ( utau_b(ji,jj) + utau(ji,jj) ) / ( e3u(ji,jj,1,Kmm) * rho0 ) 
    109109            ztswv(ji,jj) = 0.5 * ( vtau_b(ji,jj) + vtau(ji,jj) ) / ( e3v(ji,jj,1,Kmm) * rho0 ) 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/USR/usrdef_fmask.F90

    r13286 r13998  
    5858      !!---------------------------------------------------------------------- 
    5959      ! 
    60       IF( TRIM( cd_cfg ) == "orca" ) THEN      !==  ORCA Configurations  ==! 
     60      IF( TRIM( cd_cfg ) == "orca" .OR. TRIM( cd_cfg ) == "ORCA" ) THEN      !==  ORCA Configurations  ==! 
    6161         ! 
    6262         SELECT CASE ( kcfg ) 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/USR/usrdef_istate.F90

    r13874 r13998  
    5858      IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~   Ocean at rest, with an horizontally uniform T and S profiles' 
    5959      ! 
    60       pu  (:,:,:) = 0._wp        ! ocean at rest 
     60      pu  (:,:,:) = 0._wp           ! ocean at rest 
    6161      pv  (:,:,:) = 0._wp 
    6262      ! 
    63       DO_3D( 1, 1, 1, 1, 1, jpk ) 
     63      DO_3D( 1, 1, 1, 1, 1, jpk )   ! horizontally uniform T & S profiles 
    6464         pts(ji,jj,jk,jp_tem) =  (  (  16. - 12. * TANH( (pdept(ji,jj,jk) - 400) / 700 ) )   & 
    6565              &           * (-TANH( (500. - pdept(ji,jj,jk)) / 150. ) + 1.) / 2.             & 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/ZDF/zdfddm.F90

    r13427 r13998  
    9595!!gm                            and many acces in memory 
    9696          
    97          DO_2D( 1, 1, 1, 1 ) 
     97         DO_2D( 1, 1, 1, 1 )           !==  R=zrau = (alpha / beta) (dk[t] / dk[s])  ==! 
    9898            zrw =   ( gdepw(ji,jj,jk  ,Kmm) - gdept(ji,jj,jk,Kmm) )   & 
    9999!!gm please, use e3w at Kmm below  
    … …  
    111111         END_2D 
    112112 
    113          DO_2D( 1, 1, 1, 1 ) 
     113         DO_2D( 1, 1, 1, 1 )           !==  indicators  ==! 
    114114            ! stability indicator: msks=1 if rn2>0; 0 elsewhere 
    115115            IF( rn2(ji,jj,jk) + 1.e-12  <= 0. ) THEN   ;   zmsks(ji,jj) = 0._wp 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/ZDF/zdfdrg.F90

    r13295 r13998  
    3232   USE lib_mpp        ! distributed memory computing 
    3333   USE prtctl         ! Print control 
     34   USE sbc_oce , ONLY : nn_ice  
    3435 
    3536   IMPLICIT NONE 
    … …  
    4142 
    4243   !                                 !!* Namelist namdrg: nature of drag coefficient namelist * 
    43    LOGICAL          ::   ln_OFF       ! free-slip       : Cd = 0 
     44   LOGICAL , PUBLIC ::   ln_drg_OFF   ! free-slip       : Cd = 0 
    4445   LOGICAL          ::   ln_lin       !     linear  drag: Cd = Cd0_lin 
    4546   LOGICAL          ::   ln_non_lin   ! non-linear  drag: Cd = Cd0_nl |U| 
    4647   LOGICAL          ::   ln_loglayer  ! logarithmic drag: Cd = vkarmn/log(z/z0) 
    4748   LOGICAL , PUBLIC ::   ln_drgimp    ! implicit top/bottom friction flag 
    48  
     49   LOGICAL , PUBLIC ::   ln_drgice_imp ! implicit ice-ocean drag  
    4950   !                                 !!* Namelist namdrg_top & _bot: TOP or BOTTOM coefficient namelist * 
    5051   REAL(wp)         ::   rn_Cd0       !: drag coefficient                                           [ - ] 
    … …  
    226227      INTEGER   ::   ios, ioptio   ! local integers 
    227228      !! 
    228       NAMELIST/namdrg/ ln_OFF, ln_lin, ln_non_lin, ln_loglayer, ln_drgimp 
     229      NAMELIST/namdrg/ ln_drg_OFF, ln_lin, ln_non_lin, ln_loglayer, ln_drgimp, ln_drgice_imp 
    229230      !!---------------------------------------------------------------------- 
    230231      ! 
    … …  
    237238      IF(lwm) WRITE ( numond, namdrg ) 
    238239      ! 
     240      IF ( ln_drgice_imp .AND.   nn_ice /= 2  )   ln_drgice_imp = .FALSE. 
     241      ! 
    239242      IF(lwp) THEN 
    240243         WRITE(numout,*) 
    … …  
    242245         WRITE(numout,*) '~~~~~~~~~~~~' 
    243246         WRITE(numout,*) '   Namelist namdrg : top/bottom friction choices' 
    244          WRITE(numout,*) '      free-slip       : Cd = 0                  ln_OFF      = ', ln_OFF  
     247         WRITE(numout,*) '      free-slip       : Cd = 0                  ln_drg_OFF  = ', ln_drg_OFF  
    245248         WRITE(numout,*) '      linear  drag    : Cd = Cd0                ln_lin      = ', ln_lin 
    246249         WRITE(numout,*) '      non-linear  drag: Cd = Cd0_nl |U|         ln_non_lin  = ', ln_non_lin 
    247250         WRITE(numout,*) '      logarithmic drag: Cd = vkarmn/log(z/z0)   ln_loglayer = ', ln_loglayer 
    248251         WRITE(numout,*) '      implicit friction                         ln_drgimp   = ', ln_drgimp 
     252         WRITE(numout,*) '      implicit ice-ocean drag                   ln_drgice_imp  =', ln_drgice_imp 
    249253      ENDIF 
    250254      ! 
    251255      ioptio = 0                       ! set ndrg and control check 
    252       IF( ln_OFF      ) THEN   ;   ndrg = np_OFF        ;   ioptio = ioptio + 1   ;   ENDIF 
     256      IF( ln_drg_OFF  ) THEN   ;   ndrg = np_OFF        ;   ioptio = ioptio + 1   ;   ENDIF 
    253257      IF( ln_lin      ) THEN   ;   ndrg = np_lin        ;   ioptio = ioptio + 1   ;   ENDIF 
    254258      IF( ln_non_lin  ) THEN   ;   ndrg = np_non_lin    ;   ioptio = ioptio + 1   ;   ENDIF 
    … …  
    257261      IF( ioptio /= 1 )   CALL ctl_stop( 'zdf_drg_init: Choose ONE type of drag coef in namdrg' ) 
    258262      ! 
     263      IF ( ln_drgice_imp.AND.(.NOT.ln_drgimp) ) &  
     264         &                CALL ctl_stop( 'zdf_drg_init: ln_drgice_imp=T requires ln_drgimp=T' ) 
    259265      ! 
    260266      !                     !==  BOTTOM drag setting  ==!   (applied at seafloor) 
    … …  
    263269      CALL drg_init( 'BOTTOM'   , mbkt       ,                                         &   ! <== in 
    264270         &           r_Cdmin_bot, r_Cdmax_bot, r_z0_bot, r_ke0_bot, rCd0_bot, rCdU_bot )   ! ==> out 
    265  
    266271      ! 
    267272      !                     !==  TOP drag setting  ==!   (applied at the top of ocean cavities) 
    268273      ! 
    269       IF( ln_isfcav ) THEN              ! Ocean cavities: top friction setting 
    270          ALLOCATE( rCd0_top(jpi,jpj), rCdU_top(jpi,jpj) ) 
     274      IF( ln_isfcav.OR.ln_drgice_imp ) THEN              ! Ocean cavities: top friction setting 
     275         ALLOCATE( rCdU_top(jpi,jpj) ) 
     276      ENDIF 
     277      ! 
     278      IF( ln_isfcav ) THEN 
     279         ALLOCATE( rCd0_top(jpi,jpj)) 
    271280         CALL drg_init( 'TOP   '   , mikt       ,                                         &   ! <== in 
    272281            &           r_Cdmin_top, r_Cdmax_top, r_z0_top, r_ke0_top, rCd0_top, rCdU_top )   ! ==> out 
    … …  
    374383      IF(ll_bot)   zmsk_boost(:,:) = zmsk_boost(:,:) * ssmask(:,:)                         ! x seafloor mask 
    375384      ! 
     385      l_log_not_linssh = .FALSE.    ! default definition 
    376386      ! 
    377387      SELECT CASE( ndrg ) 
    … …  
    422432            l_log_not_linssh = .FALSE.    !- don't update Cd at each time step 
    423433            ! 
    424             DO_2D( 1, 1, 1, 1 ) 
     434            DO_2D( 1, 1, 1, 1 )              ! pCd0 = mask (and boosted) logarithmic drag coef. 
    425435               zzz =  0.5_wp * e3t_0(ji,jj,k_mk(ji,jj)) 
    426436               zcd = (  vkarmn / LOG( zzz / rn_z0 )  )**2 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/ZDF/zdfgls.F90

    r13295 r13998  
    1919   USE dom_oce        ! ocean space and time domain 
    2020   USE domvvl         ! ocean space and time domain : variable volume layer 
     21   USE zdfdrg  , ONLY : ln_drg_OFF            ! top/bottom free-slip flag 
    2122   USE zdfdrg  , ONLY : r_z0_top , r_z0_bot   ! top/bottom roughness 
    2223   USE zdfdrg  , ONLY : rCdU_top , rCdU_bot   ! top/bottom friction 
    … …  
    5354   INTEGER  ::   nn_bc_bot         ! bottom boundary condition (=0/1) 
    5455   INTEGER  ::   nn_z0_met         ! Method for surface roughness computation 
     56   INTEGER  ::   nn_z0_ice         ! Roughness accounting for sea ice 
    5557   INTEGER  ::   nn_stab_func      ! stability functions G88, KC or Canuto (=0/1/2) 
    5658   INTEGER  ::   nn_clos           ! closure 0/1/2/3 MY82/k-eps/k-w/gen 
    … …  
    6163   REAL(wp) ::   rn_crban          ! Craig and Banner constant for surface breaking waves mixing 
    6264   REAL(wp) ::   rn_hsro           ! Minimum surface roughness 
     65   REAL(wp) ::   rn_hsri           ! Ice ocean roughness 
    6366   REAL(wp) ::   rn_frac_hs        ! Fraction of wave height as surface roughness (if nn_z0_met > 1)  
    6467 
    … …  
    152155      REAL(wp), DIMENSION(jpi,jpj)     ::   zflxs       ! Turbulence fluxed induced by internal waves  
    153156      REAL(wp), DIMENSION(jpi,jpj)     ::   zhsro       ! Surface roughness (surface waves) 
     157      REAL(wp), DIMENSION(jpi,jpj)     ::   zice_fra    ! Tapering of wave breaking under sea ice 
    154158      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   eb          ! tke at time before 
    155159      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   hmxl_b      ! mixing length at time before 
    … …  
    167171      ustar2_bot (:,:) = 0._wp 
    168172 
     173      SELECT CASE ( nn_z0_ice ) 
     174      CASE( 0 )   ;   zice_fra(:,:) = 0._wp 
     175      CASE( 1 )   ;   zice_fra(:,:) =        TANH( fr_i(:,:) * 10._wp ) 
     176      CASE( 2 )   ;   zice_fra(:,:) =              fr_i(:,:) 
     177      CASE( 3 )   ;   zice_fra(:,:) = MIN( 4._wp * fr_i(:,:) , 1._wp ) 
     178      END SELECT 
     179       
    169180      ! Compute surface, top and bottom friction at T-points 
    170       DO_2D( 0, 0, 0, 0 ) 
    171          ! 
    172          ! surface friction 
    173          ustar2_surf(ji,jj) = r1_rho0 * taum(ji,jj) * tmask(ji,jj,1) 
    174          !    
    175 !!gm Rq we may add here r_ke0(_top/_bot) ?  ==>> think about that... 
    176        ! bottom friction (explicit before friction) 
    177        zmsku = ( 2._wp - umask(ji-1,jj,mbkt(ji,jj)) * umask(ji,jj,mbkt(ji,jj)) ) 
    178        zmskv = ( 2._wp - vmask(ji,jj-1,mbkt(ji,jj)) * vmask(ji,jj,mbkt(ji,jj)) )     ! (CAUTION: CdU<0) 
    179        ustar2_bot(ji,jj) = - rCdU_bot(ji,jj) * SQRT(  ( zmsku*( uu(ji,jj,mbkt(ji,jj),Kbb)+uu(ji-1,jj,mbkt(ji,jj),Kbb) ) )**2  & 
    180           &                                         + ( zmskv*( vv(ji,jj,mbkt(ji,jj),Kbb)+vv(ji,jj-1,mbkt(ji,jj),Kbb) ) )**2  ) 
     181      DO_2D( 0, 0, 0, 0 )          !==  surface ocean friction 
     182         ustar2_surf(ji,jj) = r1_rho0 * taum(ji,jj) * tmask(ji,jj,1)   ! surface friction 
    181183      END_2D 
    182       IF( ln_isfcav ) THEN       !top friction 
    183          DO_2D( 0, 0, 0, 0 ) 
    184             zmsku = ( 2. - umask(ji-1,jj,mikt(ji,jj)) * umask(ji,jj,mikt(ji,jj)) ) 
    185             zmskv = ( 2. - vmask(ji,jj-1,mikt(ji,jj)) * vmask(ji,jj,mikt(ji,jj)) )     ! (CAUTION: CdU<0) 
    186             ustar2_top(ji,jj) = - rCdU_top(ji,jj) * SQRT(  ( zmsku*( uu(ji,jj,mikt(ji,jj),Kbb)+uu(ji-1,jj,mikt(ji,jj),Kbb) ) )**2  & 
    187                &                                         + ( zmskv*( vv(ji,jj,mikt(ji,jj),Kbb)+vv(ji,jj-1,mikt(ji,jj),Kbb) ) )**2  ) 
     184      ! 
     185      !!gm Rq we may add here r_ke0(_top/_bot) ?  ==>> think about that... 
     186      !     
     187      IF( .NOT.ln_drg_OFF ) THEN     !== top/bottom friction   (explicit before friction) 
     188         DO_2D( 0, 0, 0, 0 )         ! bottom friction (explicit before friction) 
     189            zmsku = ( 2._wp - umask(ji-1,jj,mbkt(ji,jj)) * umask(ji,jj,mbkt(ji,jj)) ) 
     190            zmskv = ( 2._wp - vmask(ji,jj-1,mbkt(ji,jj)) * vmask(ji,jj,mbkt(ji,jj)) )     ! (CAUTION: CdU<0) 
     191            ustar2_bot(ji,jj) = - rCdU_bot(ji,jj) * SQRT(  ( zmsku*( uu(ji,jj,mbkt(ji,jj),Kbb)+uu(ji-1,jj,mbkt(ji,jj),Kbb) ) )**2  & 
     192               &                                         + ( zmskv*( vv(ji,jj,mbkt(ji,jj),Kbb)+vv(ji,jj-1,mbkt(ji,jj),Kbb) ) )**2  ) 
    188193         END_2D 
     194         IF( ln_isfcav ) THEN 
     195            DO_2D( 0, 0, 0, 0 )      ! top friction 
     196               zmsku = ( 2. - umask(ji-1,jj,mikt(ji,jj)) * umask(ji,jj,mikt(ji,jj)) ) 
     197               zmskv = ( 2. - vmask(ji,jj-1,mikt(ji,jj)) * vmask(ji,jj,mikt(ji,jj)) )     ! (CAUTION: CdU<0) 
     198               ustar2_top(ji,jj) = - rCdU_top(ji,jj) * SQRT(  ( zmsku*( uu(ji,jj,mikt(ji,jj),Kbb)+uu(ji-1,jj,mikt(ji,jj),Kbb) ) )**2  & 
     199                  &                                         + ( zmskv*( vv(ji,jj,mikt(ji,jj),Kbb)+vv(ji,jj-1,mikt(ji,jj),Kbb) ) )**2  ) 
     200            END_2D 
     201         ENDIF 
    189202      ENDIF 
    190203    
    … …  
    204217      END SELECT 
    205218      ! 
    206       DO_3D( 1, 0, 1, 0, 2, jpkm1 ) 
     219      ! adapt roughness where there is sea ice 
     220      zhsro(:,:) = ( (1._wp-zice_fra(:,:)) * zhsro(:,:) + zice_fra(:,:) * rn_hsri )*tmask(:,:,1)  + (1._wp - tmask(:,:,1))*rn_hsro 
     221      ! 
     222      DO_3D( 0, 0, 0, 0, 2, jpkm1 )  !==  Compute dissipation rate  ==! 
    207223         eps(ji,jj,jk)  = rc03 * en(ji,jj,jk) * SQRT( en(ji,jj,jk) ) / hmxl_n(ji,jj,jk) 
    208224      END_3D 
    … …  
    288304      CASE ( 0 )             ! Dirichlet boundary condition (set e at k=1 & 2)  
    289305      ! First level 
    290       en   (:,:,1) = MAX(  rn_emin , rc02r * ustar2_surf(:,:) * (1._wp + rsbc_tke1)**r2_3  ) 
     306      en   (:,:,1) = MAX(  rn_emin , rc02r * ustar2_surf(:,:) * (1._wp + (1._wp-zice_fra(:,:))*rsbc_tke1)**r2_3  ) 
    291307      zd_lw(:,:,1) = en(:,:,1) 
    292308      zd_up(:,:,1) = 0._wp 
    … …  
    294310      !  
    295311      ! One level below 
    296       en   (:,:,2) =  MAX(  rc02r * ustar2_surf(:,:) * (  1._wp + rsbc_tke1 * ((zhsro(:,:)+gdepw(:,:,2,Kmm))  & 
    297          &                 / zhsro(:,:) )**(1.5_wp*ra_sf)  )**(2._wp/3._wp)                      , rn_emin   ) 
     312      en   (:,:,2) =  MAX(  rc02r * ustar2_surf(:,:) * (  1._wp + (1._wp-zice_fra(:,:))*rsbc_tke1 * ((zhsro(:,:)+gdepw(:,:,2,Kmm)) & 
     313         &                 / zhsro(:,:) )**(1.5_wp*ra_sf)  )**(2._wp/3._wp) , rn_emin   ) 
    298314      zd_lw(:,:,2) = 0._wp  
    299315      zd_up(:,:,2) = 0._wp 
    … …  
    304320      ! 
    305321      ! Dirichlet conditions at k=1 
    306       en   (:,:,1) = MAX(  rc02r * ustar2_surf(:,:) * (1._wp + rsbc_tke1)**r2_3 , rn_emin  ) 
     322      en   (:,:,1) = MAX(  rc02r * ustar2_surf(:,:) * (1._wp + (1._wp-zice_fra(:,:))*rsbc_tke1)**r2_3 , rn_emin  ) 
    307323      zd_lw(:,:,1) = en(:,:,1) 
    308324      zd_up(:,:,1) = 0._wp 
    … …  
    311327      ! at k=2, set de/dz=Fw 
    312328      !cbr 
    313       zdiag(:,:,2) = zdiag(:,:,2) +  zd_lw(:,:,2) ! Remove zd_lw from zdiag 
    314       zd_lw(:,:,2) = 0._wp 
     329      DO_2D( 0, 0, 0, 0 )   ! zdiag zd_lw not defined/used on the halo 
     330         zdiag(ji,jj,2) = zdiag(ji,jj,2) +  zd_lw(ji,jj,2) ! Remove zd_lw from zdiag 
     331         zd_lw(ji,jj,2) = 0._wp 
     332      END_2D 
    315333      zkar (:,:)   = (rl_sf + (vkarmn-rl_sf)*(1.-EXP(-rtrans*gdept(:,:,1,Kmm)/zhsro(:,:)) )) 
    316       zflxs(:,:)   = rsbc_tke2 * ustar2_surf(:,:)**1.5_wp * zkar(:,:) & 
     334      zflxs(:,:)   = rsbc_tke2 * (1._wp-zice_fra(:,:)) * ustar2_surf(:,:)**1.5_wp * zkar(:,:) & 
    317335          &                    * (  ( zhsro(:,:)+gdept(:,:,1,Kmm) ) / zhsro(:,:)  )**(1.5_wp*ra_sf) 
    318336!!gm why not   :                        * ( 1._wp + gdept(:,:,1,Kmm) / zhsro(:,:) )**(1.5_wp*ra_sf) 
    … …  
    400418      ! ---------------------------------------------------------- 
    401419      ! 
    402       DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 
     420      DO_3D( 0, 0, 0, 0, 2, jpkm1 )                ! First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 
    403421         zdiag(ji,jj,jk) = zdiag(ji,jj,jk) - zd_lw(ji,jj,jk) * zd_up(ji,jj,jk-1) / zdiag(ji,jj,jk-1) 
    404422      END_3D 
    405       DO_3D( 0, 0, 0, 0, 2, jpk ) 
     423      DO_3D( 0, 0, 0, 0, 2, jpkm1 )                ! Second recurrence : Lk = RHSk - Lk / Dk-1 * Lk-1 
    406424         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) 
    407425      END_3D 
    408       DO_3DS( 0, 0, 0, 0, jpk-1, 2, -1 ) 
     426      DO_3DS( 0, 0, 0, 0, jpkm1, 2, -1 )           ! thrid recurrence : Ek = ( Lk - Uk * Ek+1 ) / Dk 
    409427         en(ji,jj,jk) = ( zd_lw(ji,jj,jk) - zd_up(ji,jj,jk) * en(ji,jj,jk+1) ) / zdiag(ji,jj,jk) 
    410428      END_3D 
    … …  
    521539         ! 
    522540         ! Neumann condition at k=2 
    523          zdiag(:,:,2) = zdiag(:,:,2) +  zd_lw(:,:,2) ! Remove zd_lw from zdiag 
    524          zd_lw(:,:,2) = 0._wp 
     541         DO_2D( 0, 0, 0, 0 )   ! zdiag zd_lw not defined/used on the halo 
     542            zdiag(ji,jj,2) = zdiag(ji,jj,2) +  zd_lw(ji,jj,2) ! Remove zd_lw from zdiag 
     543            zd_lw(ji,jj,2) = 0._wp 
     544         END_2D 
    525545         ! 
    526546         ! Set psi vertical flux at the surface: 
    527547         zkar (:,:)   = rl_sf + (vkarmn-rl_sf)*(1._wp-EXP(-rtrans*gdept(:,:,1,Kmm)/zhsro(:,:) )) ! Lengh scale slope 
    528548         zdep (:,:)   = ((zhsro(:,:) + gdept(:,:,1,Kmm)) / zhsro(:,:))**(rmm*ra_sf) 
    529          zflxs(:,:)   = (rnn + rsbc_tke1 * (rnn + rmm*ra_sf) * zdep(:,:))*(1._wp + rsbc_tke1*zdep(:,:))**(2._wp*rmm/3._wp-1_wp) 
     549         zflxs(:,:)   = (rnn + (1._wp-zice_fra(:,:))*rsbc_tke1 * (rnn + rmm*ra_sf) * zdep(:,:)) & 
     550            &           *(1._wp + (1._wp-zice_fra(:,:))*rsbc_tke1*zdep(:,:))**(2._wp*rmm/3._wp-1_wp) 
    530551         zdep (:,:)   = rsbc_psi1 * (zwall_psi(:,:,1)*p_avm(:,:,1)+zwall_psi(:,:,2)*p_avm(:,:,2)) * & 
    531552            &           ustar2_surf(:,:)**rmm * zkar(:,:)**rnn * (zhsro(:,:) + gdept(:,:,1,Kmm))**(rnn-1.) 
    … …  
    593614      ! ---------------- 
    594615      ! 
    595       DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 
     616      DO_3D( 0, 0, 0, 0, 2, jpkm1 )                ! First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 
    596617         zdiag(ji,jj,jk) = zdiag(ji,jj,jk) - zd_lw(ji,jj,jk) * zd_up(ji,jj,jk-1) / zdiag(ji,jj,jk-1) 
    597618      END_3D 
    598       DO_3D( 0, 0, 0, 0, 2, jpk ) 
     619      DO_3D( 0, 0, 0, 0, 2, jpkm1 )                ! Second recurrence : Lk = RHSk - Lk / Dk-1 * Lk-1 
    599620         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) 
    600621      END_3D 
    601       DO_3DS( 0, 0, 0, 0, jpk-1, 2, -1 ) 
     622      DO_3DS( 0, 0, 0, 0, jpkm1, 2, -1 )           ! Third recurrence : Ek = ( Lk - Uk * Ek+1 ) / Dk 
    602623         psi(ji,jj,jk) = ( zd_lw(ji,jj,jk) - zd_up(ji,jj,jk) * psi(ji,jj,jk+1) ) / zdiag(ji,jj,jk) 
    603624      END_3D 
    … …  
    635656      ! Limit dissipation rate under stable stratification 
    636657      ! -------------------------------------------------- 
    637       DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     658      DO_3D( 0, 0, 0, 0, 1, jpkm1 )   ! Note that this set boundary conditions on hmxl_n at the same time 
    638659         ! limitation 
    639660         eps   (ji,jj,jk)  = MAX( eps(ji,jj,jk), rn_epsmin ) 
    … …  
    700721      ! default value, in case jpk > mbkt(ji,jj)+1. Not needed but avoid a bug when looking for undefined values (-fpe0) 
    701722      zstm(:,:,jpk) = 0.   
    702       DO_2D( 0, 0, 0, 0 ) 
     723      DO_2D( 0, 0, 0, 0 )             ! update bottom with good values 
    703724         zstm(ji,jj,mbkt(ji,jj)+1) = zstm(ji,jj,mbkt(ji,jj)) 
    704725      END_2D 
    … …  
    750771      REAL(wp)::   zcr   ! local scalar 
    751772      !! 
    752       NAMELIST/namzdf_gls/rn_emin, rn_epsmin, ln_length_lim, & 
    753          &            rn_clim_galp, ln_sigpsi, rn_hsro,      & 
    754          &            rn_crban, rn_charn, rn_frac_hs,        & 
    755          &            nn_bc_surf, nn_bc_bot, nn_z0_met,     & 
     773      NAMELIST/namzdf_gls/rn_emin, rn_epsmin, ln_length_lim,       & 
     774         &            rn_clim_galp, ln_sigpsi, rn_hsro, rn_hsri,   & 
     775         &            rn_crban, rn_charn, rn_frac_hs,              & 
     776         &            nn_bc_surf, nn_bc_bot, nn_z0_met, nn_z0_ice, & 
    756777         &            nn_stab_func, nn_clos 
    757778      !!---------------------------------------------------------- 
    … …  
    779800         WRITE(numout,*) '      Charnock coefficient                          rn_charn       = ', rn_charn 
    780801         WRITE(numout,*) '      Surface roughness formula                     nn_z0_met      = ', nn_z0_met 
     802         WRITE(numout,*) '      surface wave breaking under ice               nn_z0_ice      = ', nn_z0_ice 
     803         SELECT CASE( nn_z0_ice ) 
     804         CASE( 0 )   ;   WRITE(numout,*) '   ==>>>   no impact of ice cover on surface wave breaking' 
     805         CASE( 1 )   ;   WRITE(numout,*) '   ==>>>   roughness uses rn_hsri and is weigthed by 1-TANH( fr_i(:,:) * 10 )' 
     806         CASE( 2 )   ;   WRITE(numout,*) '   ==>>>   roughness uses rn_hsri and is weighted by 1-fr_i(:,:)' 
     807         CASE( 3 )   ;   WRITE(numout,*) '   ==>>>   roughness uses rn_hsri and is weighted by 1-MIN( 1, 4 * fr_i(:,:) )' 
     808         CASE DEFAULT 
     809            CALL ctl_stop( 'zdf_gls_init: wrong value for nn_z0_ice, should be 0,1,2, or 3') 
     810         END SELECT 
    781811         WRITE(numout,*) '      Wave height frac. (used if nn_z0_met=2)       rn_frac_hs     = ', rn_frac_hs 
    782812         WRITE(numout,*) '      Stability functions                           nn_stab_func   = ', nn_stab_func 
    783813         WRITE(numout,*) '      Type of closure                               nn_clos        = ', nn_clos 
    784814         WRITE(numout,*) '      Surface roughness (m)                         rn_hsro        = ', rn_hsro 
    785          WRITE(numout,*) 
    786          WRITE(numout,*) '   Namelist namdrg_top/_bot:   used values:' 
    787          WRITE(numout,*) '      top    ocean cavity roughness (m)             rn_z0(_top)   = ', r_z0_top 
    788          WRITE(numout,*) '      Bottom seafloor     roughness (m)             rn_z0(_bot)   = ', r_z0_bot 
     815         WRITE(numout,*) '      Ice-ocean roughness (used if nn_z0_ice/=0)    rn_hsri        = ', rn_hsri 
    789816         WRITE(numout,*) 
    790817      ENDIF 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/ZDF/zdfiwm.F90

    r13295 r13998  
    146146            zemx_iwm (ji,jj,1) = 0._wp   ;   zemx_iwm (ji,jj,jpk) = 0._wp 
    147147         END_2D 
    148          zemx_iwm (           1:nn_hls,:,:) = 0._wp   ;   zemx_iwm (:,           1:nn_hls,:) = 0._wp 
    149          zemx_iwm (jpi-nn_hls+1:jpi   ,:,:) = 0._wp   ;   zemx_iwm (:,jpj-nn_hls+1:   jpj,:) = 0._wp 
    150148      ENDIF 
    151149      IF( iom_use("av_ratio") ) THEN 
    … …  
    153151            zav_ratio(ji,jj,1) = 0._wp   ;   zav_ratio(ji,jj,jpk) = 0._wp 
    154152         END_2D 
    155          zav_ratio(           1:nn_hls,:,:) = 0._wp   ;   zav_ratio(:,           1:nn_hls,:) = 0._wp 
    156          zav_ratio(jpi-nn_hls+1:jpi   ,:,:) = 0._wp   ;   zav_ratio(:,jpj-nn_hls+1:   jpj,:) = 0._wp 
    157       ENDIF 
    158       IF( iom_use("av_wave") ) THEN 
     153      ENDIF 
     154      IF( iom_use("av_wave") .OR. sn_cfctl%l_prtctl ) THEN 
    159155         DO_2D( 0, 0, 0, 0 ) 
    160156            zav_wave (ji,jj,1) = 0._wp   ;   zav_wave (ji,jj,jpk) = 0._wp 
    161157         END_2D 
    162          zav_wave(           1:nn_hls,:,:) = 0._wp   ;   zav_wave(:,           1:nn_hls,:) = 0._wp 
    163          zav_wave(jpi-nn_hls+1:jpi   ,:,:) = 0._wp   ;   zav_wave(:,jpj-nn_hls+1:   jpj,:) = 0._wp 
    164158      ENDIF 
    165159      ! 
    … …  
    170164      !                       !* Critical slope mixing: distribute energy over the time-varying ocean depth, 
    171165      !                                                 using an exponential decay from the seafloor. 
    172       DO_2D( 0, 0, 0, 0 ) 
     166      DO_2D( 0, 0, 0, 0 )             ! part independent of the level 
    173167         zhdep(ji,jj) = gdepw_0(ji,jj,mbkt(ji,jj)+1)       ! depth of the ocean 
    174168         zfact(ji,jj) = rho0 * (  1._wp - EXP( -zhdep(ji,jj) / hcri_iwm(ji,jj) )  ) 
    … …  
    176170      END_2D 
    177171!!gm gde3w ==>>>  check for ssh taken into account.... seem OK gde3w_n=gdept(:,:,:,Kmm) - ssh(:,:,Kmm) 
    178       DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 
     172      DO_3D( 0, 0, 0, 0, 2, jpkm1 )   ! complete with the level-dependent part 
    179173         IF ( zfact(ji,jj) == 0._wp .OR. wmask(ji,jj,jk) == 0._wp ) THEN   ! optimization 
    180174            zemx_iwm(ji,jj,jk) = 0._wp 
    … …  
    299293      END_3D 
    300294      ! 
    301       IF( ln_mevar ) THEN              ! Variable mixing efficiency case : modify zav_wave in the 
    302          DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 
     295      IF( ln_mevar ) THEN                ! Variable mixing efficiency case : modify zav_wave in the 
     296         DO_3D( 0, 0, 0, 0, 2, jpkm1 )   ! energetic (Reb > 480) and buoyancy-controlled (Reb <10.224 ) regimes 
    303297            IF( zReb(ji,jj,jk) > 480.00_wp ) THEN 
    304298               zav_wave(ji,jj,jk) = 3.6515_wp * znu_w(ji,jj,jk) * SQRT( zReb(ji,jj,jk) ) 
    … …  
    309303      ENDIF 
    310304      ! 
    311       DO_3D( 0, 0, 0, 0, 2, jpkm1 )          ! Bound diffusivity by molecular value and 100 cm2/s 
     305      DO_3D( 0, 0, 0, 0, 2, jpkm1 )      ! Bound diffusivity by molecular value and 100 cm2/s 
    312306         zav_wave(ji,jj,jk) = MIN(  MAX( 1.4e-7_wp, zav_wave(ji,jj,jk) ), 1.e-2_wp  ) * wmask(ji,jj,jk) 
    313307      END_3D 
    … …  
    336330      !                          ! ----------------------- ! 
    337331      !       
    338       IF( ln_tsdiff ) THEN          !* Option for differential mixing of salinity and temperature 
     332      IF( ln_tsdiff ) THEN                !* Option for differential mixing of salinity and temperature 
    339333         ztmp1 = 0.505_wp + 0.495_wp * TANH( 0.92_wp * ( LOG10( 1.e-20_wp ) - 0.60_wp ) ) 
    340          DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 
     334         DO_3D( 0, 0, 0, 0, 2, jpkm1 )       ! Calculate S/T diffusivity ratio as a function of Reb 
    341335            ztmp2 = zReb(ji,jj,jk) * 5._wp * r1_6 
    342336            IF ( ztmp2 > 1.e-20_wp .AND. wmask(ji,jj,jk) == 1._wp ) THEN 
    … …  
    353347         END_3D 
    354348         ! 
    355       ELSE                          !* update momentum & tracer diffusivity with wave-driven mixing 
     349      ELSE                                !* update momentum & tracer diffusivity with wave-driven mixing 
    356350         DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 
    357351            p_avs(ji,jj,jk) = p_avs(ji,jj,jk) + zav_wave(ji,jj,jk) 
    … …  
    361355      ENDIF 
    362356 
    363       !                             !* output internal wave-driven mixing coefficient 
     357      !                                   !* output internal wave-driven mixing coefficient 
    364358      CALL iom_put( "av_wave", zav_wave ) 
    365                                     !* output useful diagnostics: Kz*N^2 ,  
     359                                          !* output useful diagnostics: Kz*N^2 ,  
    366360!!gm Kz*N2 should take into account the ratio avs/avt if it is used.... (see diaar5) 
    367                                     !  vertical integral of rho0 * Kz * N^2 , energy density (zemx_iwm) 
     361                                          !  vertical integral of rho0 * Kz * N^2 , energy density (zemx_iwm) 
    368362      IF( iom_use("bflx_iwm") .OR. iom_use("pcmap_iwm") ) THEN 
    369363         ALLOCATE( z2d(jpi,jpj) , z3d(jpi,jpj,jpk) ) 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/ZDF/zdfmxl.F90

    r13295 r13998  
    9696      ! 
    9797      ! w-level of the mixing and mixed layers 
    98       nmln(:,:)  = nlb10               ! Initialization to the number of w ocean point 
    99       hmlp(:,:)  = 0._wp               ! here hmlp used as a dummy variable, integrating vertically N^2 
    100       zN2_c = grav * rho_c * r1_rho0   ! convert density criteria into N^2 criteria 
    101       DO_3D( 1, 1, 1, 1, nlb10, jpkm1 ) 
     98      nmln(:,:)  = nlb10                  ! Initialization to the number of w ocean point 
     99      hmlp(:,:)  = 0._wp                  ! here hmlp used as a dummy variable, integrating vertically N^2 
     100      zN2_c = grav * rho_c * r1_rho0      ! convert density criteria into N^2 criteria 
     101      DO_3D( 1, 1, 1, 1, nlb10, jpkm1 )   ! Mixed layer level: w-level 
    102102         ikt = mbkt(ji,jj) 
    103103         hmlp(ji,jj) =   & 
    … …  
    107107      ! 
    108108      ! w-level of the turbocline and mixing layer (iom_use) 
    109       imld(:,:) = mbkt(:,:) + 1        ! Initialization to the number of w ocean point 
    110       DO_3DS( 1, 1, 1, 1, jpkm1, nlb10, -1 ) 
     109      imld(:,:) = mbkt(:,:) + 1                ! Initialization to the number of w ocean point 
     110      DO_3DS( 1, 1, 1, 1, jpkm1, nlb10, -1 )   ! from the bottom to nlb10 
    111111         IF( avt (ji,jj,jk) < avt_c * wmask(ji,jj,jk) )   imld(ji,jj) = jk      ! Turbocline  
    112112      END_3D 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/ZDF/zdfosm.F90

    r13295 r13998  
    11841184! KPP-style Ri# mixing 
    11851185       IF( ln_kpprimix) THEN 
    1186           DO_3D( 1, 0, 1, 0, 2, jpkm1 ) 
     1186          DO_3D( 1, 0, 1, 0, 2, jpkm1 )      !* Shear production at uw- and vw-points (energy conserving form) 
    11871187             z3du(ji,jj,jk) = 0.5 * (  uu(ji,jj,jk-1,Kmm) -  uu(ji  ,jj,jk,Kmm) )   & 
    11881188                  &                 * (  uu(ji,jj,jk-1,Kbb) -  uu(ji  ,jj,jk,Kbb) ) * wumask(ji,jj,jk) & 
    … …  
    15161516     ! 
    15171517     hbl(:,:)  = 0._wp              ! here hbl used as a dummy variable, integrating vertically N^2 
    1518      DO_3D( 1, 1, 1, 1, 1, jpkm1 ) 
     1518     DO_3D( 1, 1, 1, 1, 1, jpkm1 )  ! Mixed layer level: w-level 
    15191519        ikt = mbkt(ji,jj) 
    15201520        hbl(ji,jj) = hbl(ji,jj) + MAX( rn2(ji,jj,jk) , 0._wp ) * e3w(ji,jj,jk,Kmm) 
    … …  
    16291629      !code saving tracer trends removed, replace with trdmxl_oce 
    16301630 
    1631       DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     1631      DO_3D( 0, 0, 0, 0, 1, jpkm1 )       ! add non-local u and v fluxes 
    16321632         puu(ji,jj,jk,Krhs) =  puu(ji,jj,jk,Krhs)                      & 
    16331633            &                 - (  ghamu(ji,jj,jk  )  & 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/ZDF/zdfphy.F90

    r13226 r13998  
    2828   USE sbc_oce        ! surface module (only for nn_isf in the option compatibility test) 
    2929   USE sbcrnf         ! surface boundary condition: runoff variables 
     30   USE sbc_ice        ! sea ice drag 
    3031#if defined key_agrif 
    3132   USE agrif_oce_interp   ! interpavm 
    … …  
    253254      ENDIF 
    254255      ! 
     256#if defined key_si3 
     257      IF ( ln_drgice_imp) THEN 
     258         IF ( ln_isfcav ) THEN 
     259            rCdU_top(:,:) = rCdU_top(:,:) + ssmask(:,:) * tmask(:,:,1) * rCdU_ice(:,:) 
     260         ELSE 
     261            rCdU_top(:,:) = rCdU_ice(:,:) 
     262         ENDIF 
     263      ENDIF 
     264#endif 
     265      !  
    255266      !                       !==  Kz from chosen turbulent closure  ==!   (avm_k, avt_k) 
    256267      ! 
    … …  
    326337      ! 
    327338   END SUBROUTINE zdf_phy 
     339 
     340 
    328341   INTEGER FUNCTION zdf_phy_alloc() 
    329342      !!---------------------------------------------------------------------- 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/ZDF/zdfric.F90

    r13295 r13998  
    160160      ! 
    161161      !                       !==  avm and avt = F(Richardson number)  ==! 
    162       DO_3D( 1, 0, 1, 0, 2, jpkm1 ) 
     162      DO_3D( 1, 0, 1, 0, 2, jpkm1 )       ! coefficient = F(richardson number) (avm-weighted Ri) 
    163163         zcfRi = 1._wp / (  1._wp + rn_alp * MAX(  0._wp , avm(ji,jj,jk) * rn2(ji,jj,jk) / ( p_sh2(ji,jj,jk) + 1.e-20 ) )  ) 
    164164         zav   = rn_avmri * zcfRi**nn_ric 
    … …  
    173173      IF( ln_mldw ) THEN      !==  set a minimum value in the Ekman layer  ==! 
    174174         ! 
    175          DO_2D( 0, 0, 0, 0 ) 
     175         DO_2D( 0, 0, 0, 0 )             !* Ekman depth 
    176176            zustar = SQRT( taum(ji,jj) * r1_rho0 ) 
    177177            zhek   = rn_ekmfc * zustar / ( ABS( ff_t(ji,jj) ) + rsmall )   ! Ekman depth 
    178178            zh_ekm(ji,jj) = MAX(  rn_mldmin , MIN( zhek , rn_mldmax )  )   ! set allowed range 
    179179         END_2D 
    180          DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 
     180         DO_3D( 0, 0, 0, 0, 2, jpkm1 )   !* minimum mixing coeff. within the Ekman layer 
    181181            IF( gdept(ji,jj,jk,Kmm) < zh_ekm(ji,jj) ) THEN 
    182182               p_avm(ji,jj,jk) = MAX(  p_avm(ji,jj,jk), rn_wvmix  ) * wmask(ji,jj,jk) 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/ZDF/zdfsh2.F90

    r13295 r13998  
    6060      ! 
    6161      DO jk = 2, jpkm1 
    62          DO_2D( 1, 0, 1, 0 ) 
     62         DO_2D( 1, 0, 1, 0 )     !* 2 x shear production at uw- and vw-points (energy conserving form) 
    6363            zsh2u(ji,jj) = ( p_avm(ji+1,jj,jk) + p_avm(ji,jj,jk) ) & 
    6464               &         * (   uu(ji,jj,jk-1,Kmm) -   uu(ji,jj,jk,Kmm) ) & 
    … …  
    7272               &         * wvmask(ji,jj,jk) 
    7373         END_2D 
    74          DO_2D( 0, 0, 0, 0 ) 
     74         DO_2D( 0, 0, 0, 0 )     !* shear production at w-point ! coast mask: =2 at the coast ; =1 otherwise (NB: wmask useless as zsh2 are masked) 
    7575            p_sh2(ji,jj,jk) = 0.25 * (   ( zsh2u(ji-1,jj) + zsh2u(ji,jj) ) * ( 2. - umask(ji-1,jj,jk) * umask(ji,jj,jk) )   & 
    7676               &                       + ( zsh2v(ji,jj-1) + zsh2v(ji,jj) ) * ( 2. - vmask(ji,jj-1,jk) * vmask(ji,jj,jk) )   ) 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/ZDF/zdftke.F90

    r13295 r13998  
    2828   !!            3.6  !  2014-11  (P. Mathiot) add ice shelf capability 
    2929   !!            4.0  !  2017-04  (G. Madec)  remove CPP ddm key & avm at t-point only  
    30    !!             -   !  2017-05  (G. Madec)  add top/bottom friction as boundary condition (ln_drg) 
     30   !!             -   !  2017-05  (G. Madec)  add top/bottom friction as boundary condition 
    3131   !!---------------------------------------------------------------------- 
    3232 
    … …  
    6868   !                      !!** Namelist  namzdf_tke  ** 
    6969   LOGICAL  ::   ln_mxl0   ! mixing length scale surface value as function of wind stress or not 
     70   INTEGER  ::   nn_mxlice ! type of scaling under sea-ice (=0/1/2/3) 
     71   REAL(wp) ::   rn_mxlice ! ice thickness value when scaling under sea-ice 
    7072   INTEGER  ::   nn_mxl    ! type of mixing length (=0/1/2/3) 
    7173   REAL(wp) ::   rn_mxl0   ! surface  min value of mixing length (kappa*z_o=0.4*0.1 m)  [m] 
    72    INTEGER  ::      nn_mxlice ! type of scaling under sea-ice 
    73    REAL(wp) ::      rn_mxlice ! max constant ice thickness value when scaling under sea-ice ( nn_mxlice=1) 
    7474   INTEGER  ::   nn_pdl    ! Prandtl number or not (ratio avt/avm) (=0/1) 
    7575   REAL(wp) ::   rn_ediff  ! coefficient for avt: avt=rn_ediff*mxl*sqrt(e) 
    … …  
    7979   REAL(wp) ::   rn_emin0  ! surface minimum value of tke   [m2/s2] 
    8080   REAL(wp) ::   rn_bshear ! background shear (>0) currently a numerical threshold (do not change it) 
    81    LOGICAL  ::   ln_drg    ! top/bottom friction forcing flag  
    8281   INTEGER  ::   nn_etau   ! type of depth penetration of surface tke (=0/1/2/3) 
    8382   INTEGER  ::      nn_htau   ! type of tke profile of penetration (=0/1) 
    8483   REAL(wp) ::      rn_efr    ! fraction of TKE surface value which penetrates in the ocean 
    85    REAL(wp) ::      rn_eice   ! =0 ON below sea-ice, =4 OFF when ice fraction > 1/4    
    8684   LOGICAL  ::   ln_lc     ! Langmuir cells (LC) as a source term of TKE or not 
    8785   REAL(wp) ::      rn_lc     ! coef to compute vertical velocity of Langmuir cells 
     86   INTEGER  ::   nn_eice   ! attenutaion of langmuir & surface wave breaking under ice (=0/1/2/3)    
    8887 
    8988   REAL(wp) ::   ri_cri    ! critic Richardson number (deduced from rn_ediff and rn_ediss values) 
    … …  
    200199      REAL(wp), DIMENSION(:,:,:) , INTENT(in   ) ::   p_avm, p_avt   ! vertical eddy viscosity & diffusivity (w-points) 
    201200      ! 
    202       INTEGER ::   ji, jj, jk              ! dummy loop arguments 
     201      INTEGER ::   ji, jj, jk                  ! dummy loop arguments 
    203202      REAL(wp) ::   zetop, zebot, zmsku, zmskv ! local scalars 
    204203      REAL(wp) ::   zrhoa  = 1.22              ! Air density kg/m3 
    205204      REAL(wp) ::   zcdrag = 1.5e-3            ! drag coefficient 
    206       REAL(wp) ::   zbbrau, zri                ! local scalars 
    207       REAL(wp) ::   zfact1, zfact2, zfact3     !   -         - 
    208       REAL(wp) ::   ztx2  , zty2  , zcof       !   -         - 
    209       REAL(wp) ::   ztau  , zdif               !   -         - 
    210       REAL(wp) ::   zus   , zwlc  , zind       !   -         - 
    211       REAL(wp) ::   zzd_up, zzd_lw             !   -         - 
     205      REAL(wp) ::   zbbrau, zbbirau, zri       ! local scalars 
     206      REAL(wp) ::   zfact1, zfact2, zfact3     !   -      - 
     207      REAL(wp) ::   ztx2  , zty2  , zcof       !   -      - 
     208      REAL(wp) ::   ztau  , zdif               !   -      - 
     209      REAL(wp) ::   zus   , zwlc  , zind       !   -      - 
     210      REAL(wp) ::   zzd_up, zzd_lw             !   -      - 
    212211      INTEGER , DIMENSION(jpi,jpj)     ::   imlc 
    213       REAL(wp), DIMENSION(jpi,jpj)     ::   zhlc, zfr_i 
     212      REAL(wp), DIMENSION(jpi,jpj)     ::   zice_fra, zhlc, zus3 
    214213      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zpelc, zdiag, zd_up, zd_lw 
    215214      !!-------------------------------------------------------------------- 
    216215      ! 
    217       zbbrau = rn_ebb / rho0       ! Local constant initialisation 
    218       zfact1 = -.5_wp * rn_Dt  
    219       zfact2 = 1.5_wp * rn_Dt * rn_ediss 
    220       zfact3 = 0.5_wp       * rn_ediss 
     216      zbbrau  = rn_ebb / rho0       ! Local constant initialisation 
     217      zbbirau = 3.75_wp / rho0 
     218      zfact1  = -.5_wp * rn_Dt  
     219      zfact2  = 1.5_wp * rn_Dt * rn_ediss 
     220      zfact3  = 0.5_wp         * rn_ediss 
     221      ! 
     222      ! ice fraction considered for attenuation of langmuir & wave breaking 
     223      SELECT CASE ( nn_eice ) 
     224      CASE( 0 )   ;   zice_fra(:,:) = 0._wp 
     225      CASE( 1 )   ;   zice_fra(:,:) =        TANH( fr_i(:,:) * 10._wp ) 
     226      CASE( 2 )   ;   zice_fra(:,:) =              fr_i(:,:) 
     227      CASE( 3 )   ;   zice_fra(:,:) = MIN( 4._wp * fr_i(:,:) , 1._wp ) 
     228      END SELECT 
    221229      ! 
    222230      !                     !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
    223231      !                     !  Surface/top/bottom boundary condition on tke 
    224232      !                     !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
    225       !  
    226       DO_2D( 0, 0, 0, 0 ) 
     233      ! 
     234      DO_2D( 0, 0, 0, 0 )         ! en(1)   = rn_ebb taum / rau0  (min value rn_emin0) 
     235!! clem: this should be the right formulation but it makes the model unstable unless drags are calculated implicitly 
     236!!       one way around would be to increase zbbirau  
     237!!          en(ji,jj,1) = MAX( rn_emin0, ( ( 1._wp - fr_i(ji,jj) ) * zbbrau + & 
     238!!             &                                     fr_i(ji,jj)   * zbbirau ) * taum(ji,jj) ) * tmask(ji,jj,1) 
    227239         en(ji,jj,1) = MAX( rn_emin0, zbbrau * taum(ji,jj) ) * tmask(ji,jj,1) 
    228240      END_2D 
    … …  
    236248      ! Note that stress averaged is done using an wet-only calculation of u and v at t-point like in zdfsh2 
    237249      ! 
    238       IF( ln_drg ) THEN       !== friction used as top/bottom boundary condition on TKE 
    239          ! 
    240          DO_2D( 0, 0, 0, 0 ) 
     250      IF( .NOT.ln_drg_OFF ) THEN    !== friction used as top/bottom boundary condition on TKE 
     251         ! 
     252         DO_2D( 0, 0, 0, 0 )        ! bottom friction 
    241253            zmsku = ( 2. - umask(ji-1,jj,mbkt(ji,jj)) * umask(ji,jj,mbkt(ji,jj)) ) 
    242254            zmskv = ( 2. - vmask(ji,jj-1,mbkt(ji,jj)) * vmask(ji,jj,mbkt(ji,jj)) ) 
    … …  
    246258            en(ji,jj,mbkt(ji,jj)+1) = MAX( zebot, rn_emin ) * ssmask(ji,jj) 
    247259         END_2D 
    248          IF( ln_isfcav ) THEN       ! top friction 
    249             DO_2D( 0, 0, 0, 0 ) 
     260         IF( ln_isfcav ) THEN 
     261            DO_2D( 0, 0, 0, 0 )     ! top friction 
    250262               zmsku = ( 2. - umask(ji-1,jj,mikt(ji,jj)) * umask(ji,jj,mikt(ji,jj)) ) 
    251263               zmskv = ( 2. - vmask(ji,jj-1,mikt(ji,jj)) * vmask(ji,jj,mikt(ji,jj)) ) 
    … …  
    274286         zcof = 0.5 * 0.016 * 0.016 / ( zrhoa * zcdrag ) 
    275287         imlc(:,:) = mbkt(:,:) + 1       ! Initialization to the number of w ocean point (=2 over land) 
    276          DO_3DS( 1, 1, 1, 1, jpkm1, 2, -1 ) 
    277             zus  = zcof * taum(ji,jj) 
     288         DO_3DS( 1, 1, 1, 1, jpkm1, 2, -1 )   ! Last w-level at which zpelc>=0.5*us*us  
     289            zus = zcof * taum(ji,jj)          !      with us=0.016*wind(starting from jpk-1) 
    278290            IF( zpelc(ji,jj,jk) > zus )   imlc(ji,jj) = jk 
    279291         END_3D 
    … …  
    285297         DO_2D( 0, 0, 0, 0 ) 
    286298            zus  = zcof * SQRT( taum(ji,jj) )           ! Stokes drift 
    287             zfr_i(ji,jj) = ( 1._wp - 4._wp * fr_i(ji,jj) ) * zus * zus * zus * tmask(ji,jj,1) ! zus > 0. ok 
    288             IF (zfr_i(ji,jj) < 0. ) zfr_i(ji,jj) = 0. 
     299            zus3(ji,jj) = MAX( 0._wp, 1._wp - zice_fra(ji,jj) ) * zus * zus * zus * tmask(ji,jj,1) ! zus > 0. ok 
    289300         END_2D 
    290          DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 
    291             IF ( zfr_i(ji,jj) /= 0. ) THEN                
    292                ! vertical velocity due to LC    
     301         DO_3D( 0, 0, 0, 0, 2, jpkm1 )                  !* TKE Langmuir circulation source term added to en 
     302            IF ( zus3(ji,jj) /= 0._wp ) THEN                
    293303               IF ( gdepw(ji,jj,jk,Kmm) - zhlc(ji,jj) < 0 .AND. wmask(ji,jj,jk) /= 0. ) THEN 
    294304                  !                                           ! vertical velocity due to LC 
    295                   zwlc = rn_lc * SIN( rpi * gdepw(ji,jj,jk,Kmm) / zhlc(ji,jj) )   ! warning: optimization: zus^3 is in zfr_i 
     305                  zwlc = rn_lc * SIN( rpi * gdepw(ji,jj,jk,Kmm) / zhlc(ji,jj) ) 
    296306                  !                                           ! TKE Langmuir circulation source term 
    297                   en(ji,jj,jk) = en(ji,jj,jk) + rn_Dt * zfr_i(ji,jj) * ( zwlc * zwlc * zwlc ) / zhlc(ji,jj) 
     307                  en(ji,jj,jk) = en(ji,jj,jk) + rn_Dt * zus3(ji,jj) * ( zwlc * zwlc * zwlc ) / zhlc(ji,jj) 
    298308               ENDIF 
    299309            ENDIF 
    … …  
    309319      !                     ! zdiag : diagonal zd_up : upper diagonal zd_lw : lower diagonal 
    310320      ! 
    311       IF( nn_pdl == 1 ) THEN      !* Prandtl number = F( Ri ) 
     321      IF( nn_pdl == 1 ) THEN          !* Prandtl number = F( Ri ) 
    312322         DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 
    313323            !                             ! local Richardson number 
    … …  
    322332      ENDIF 
    323333      !          
    324       DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 
     334      DO_3D( 0, 0, 0, 0, 2, jpkm1 )   !* Matrix and right hand side in en 
    325335         zcof   = zfact1 * tmask(ji,jj,jk) 
    326336         !                                   ! A minimum of 2.e-5 m2/s is imposed on TKE vertical 
    327337         !                                   ! eddy coefficient (ensure numerical stability) 
    328338         zzd_up = zcof * MAX(  p_avm(ji,jj,jk+1) + p_avm(ji,jj,jk  ) , 2.e-5_wp  )   &  ! upper diagonal 
    329             &          /    (  e3t(ji,jj,jk  ,Kmm)   & 
    330             &                * e3w(ji,jj,jk  ,Kmm)  ) 
     339            &          /    (  e3t(ji,jj,jk  ,Kmm) * e3w(ji,jj,jk  ,Kmm)  ) 
    331340         zzd_lw = zcof * MAX(  p_avm(ji,jj,jk  ) + p_avm(ji,jj,jk-1) , 2.e-5_wp  )   &  ! lower diagonal 
    332             &          /    (  e3t(ji,jj,jk-1,Kmm)   & 
    333             &                * e3w(ji,jj,jk  ,Kmm)  ) 
     341            &          /    (  e3t(ji,jj,jk-1,Kmm) * e3w(ji,jj,jk  ,Kmm)  ) 
    334342         ! 
    335343         zd_up(ji,jj,jk) = zzd_up            ! Matrix (zdiag, zd_up, zd_lw) 
    … …  
    344352      END_3D 
    345353      !                          !* Matrix inversion from level 2 (tke prescribed at level 1) 
    346       DO_3D( 0, 0, 0, 0, 3, jpkm1 ) 
     354      DO_3D( 0, 0, 0, 0, 3, jpkm1 )                ! First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 
    347355         zdiag(ji,jj,jk) = zdiag(ji,jj,jk) - zd_lw(ji,jj,jk) * zd_up(ji,jj,jk-1) / zdiag(ji,jj,jk-1) 
    348356      END_3D 
    349       DO_2D( 0, 0, 0, 0 ) 
     357      DO_2D( 0, 0, 0, 0 )                          ! Second recurrence : Lk = RHSk - Lk / Dk-1 * Lk-1 
    350358         zd_lw(ji,jj,2) = en(ji,jj,2) - zd_lw(ji,jj,2) * en(ji,jj,1)    ! Surface boudary conditions on tke 
    351359      END_2D 
    … …  
    353361         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) 
    354362      END_3D 
    355       DO_2D( 0, 0, 0, 0 ) 
     363      DO_2D( 0, 0, 0, 0 )                          ! thrid recurrence : Ek = ( Lk - Uk * Ek+1 ) / Dk 
    356364         en(ji,jj,jpkm1) = zd_lw(ji,jj,jpkm1) / zdiag(ji,jj,jpkm1) 
    357365      END_2D 
    … …  
    359367         en(ji,jj,jk) = ( zd_lw(ji,jj,jk) - zd_up(ji,jj,jk) * en(ji,jj,jk+1) ) / zdiag(ji,jj,jk) 
    360368      END_3D 
    361       DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 
     369      DO_3D( 0, 0, 0, 0, 2, jpkm1 )                ! set the minimum value of tke 
    362370         en(ji,jj,jk) = MAX( en(ji,jj,jk), rn_emin ) * wmask(ji,jj,jk) 
    363371      END_3D 
    … …  
    368376!!gm BUG : in the exp  remove the depth of ssh !!! 
    369377!!gm       i.e. use gde3w in argument (gdepw(:,:,:,Kmm)) 
    370        
    371        
     378      ! 
     379      ! penetration is partly switched off below sea-ice if nn_eice/=0 
     380      ! 
    372381      IF( nn_etau == 1 ) THEN           !* penetration below the mixed layer (rn_efr fraction) 
    373          DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 
     382         DO_3D( 0, 0, 0, 0, 2, jpkm1 )  
    374383            en(ji,jj,jk) = en(ji,jj,jk) + rn_efr * en(ji,jj,1) * EXP( -gdepw(ji,jj,jk,Kmm) / htau(ji,jj) )   & 
    375                &                                 * MAX(0.,1._wp - rn_eice *fr_i(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1) 
     384               &                                 * MAX( 0._wp, 1._wp - zice_fra(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1) 
    376385         END_3D 
    377386      ELSEIF( nn_etau == 2 ) THEN       !* act only at the base of the mixed layer (jk=nmln)  (rn_efr fraction) 
    … …  
    379388            jk = nmln(ji,jj) 
    380389            en(ji,jj,jk) = en(ji,jj,jk) + rn_efr * en(ji,jj,1) * EXP( -gdepw(ji,jj,jk,Kmm) / htau(ji,jj) )   & 
    381                &                                 * MAX(0.,1._wp - rn_eice *fr_i(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1) 
     390               &                                 * MAX( 0._wp, 1._wp - zice_fra(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1) 
    382391         END_2D 
    383392      ELSEIF( nn_etau == 3 ) THEN       !* penetration belox the mixed layer (HF variability) 
    … …  
    389398            zdif = rhftau_scl * MAX( 0._wp, zdif + rhftau_add )  ! apply some modifications... 
    390399            en(ji,jj,jk) = en(ji,jj,jk) + zbbrau * zdif * EXP( -gdepw(ji,jj,jk,Kmm) / htau(ji,jj) )   & 
    391                &                        * MAX(0.,1._wp - rn_eice *fr_i(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1) 
     400               &                        * MAX( 0._wp, 1._wp - zice_fra(ji,jj) ) * wmask(ji,jj,jk) * tmask(ji,jj,1) 
    392401         END_3D 
    393402      ENDIF 
    … …  
    451460      zmxlm(:,:,:)  = rmxl_min     
    452461      zmxld(:,:,:)  = rmxl_min 
    453       ! 
     462      !  
    454463     IF( ln_mxl0 ) THEN            ! surface mixing length = F(stress) : l=vkarmn*2.e5*taum/(rho0*g) 
    455464         ! 
    456465         zraug = vkarmn * 2.e5_wp / ( rho0 * grav ) 
    457466#if ! defined key_si3 && ! defined key_cice 
    458          DO_2D( 0, 0, 0, 0 ) 
     467         DO_2D( 0, 0, 0, 0 )                  ! No sea-ice 
    459468            zmxlm(ji,jj,1) =  zraug * taum(ji,jj) * tmask(ji,jj,1) 
    460469         END_2D 
    … …  
    467476            END_2D 
    468477            ! 
    469          CASE( 1 )                           ! scaling with constant sea-ice thickness 
     478         CASE( 1 )                      ! scaling with constant sea-ice thickness 
    470479            DO_2D( 0, 0, 0, 0 ) 
    471                zmxlm(ji,jj,1) =  ( ( 1. - fr_i(ji,jj) ) * zraug * taum(ji,jj) + fr_i(ji,jj) * rn_mxlice ) * tmask(ji,jj,1) 
     480               zmxlm(ji,jj,1) =  ( ( 1._wp - fr_i(ji,jj) ) * zraug * taum(ji,jj) + & 
     481                  &                          fr_i(ji,jj)   * rn_mxlice           ) * tmask(ji,jj,1) 
    472482            END_2D 
    473483            ! 
    474          CASE( 2 )                                 ! scaling with mean sea-ice thickness 
     484         CASE( 2 )                      ! scaling with mean sea-ice thickness 
    475485            DO_2D( 0, 0, 0, 0 ) 
    476486#if defined key_si3 
    477                zmxlm(ji,jj,1) = ( ( 1. - fr_i(ji,jj) ) * zraug * taum(ji,jj) + fr_i(ji,jj) * hm_i(ji,jj) * 2. ) * tmask(ji,jj,1) 
     487               zmxlm(ji,jj,1) = ( ( 1._wp - fr_i(ji,jj) ) * zraug * taum(ji,jj) + & 
     488                  &                         fr_i(ji,jj)   * hm_i(ji,jj) * 2._wp ) * tmask(ji,jj,1) 
    478489#elif defined key_cice 
    479490               zmaxice = MAXVAL( h_i(ji,jj,:) ) 
    480                zmxlm(ji,jj,1) = ( ( 1. - fr_i(ji,jj) ) * zraug * taum(ji,jj) + fr_i(ji,jj) * zmaxice ) * tmask(ji,jj,1) 
     491               zmxlm(ji,jj,1) = ( ( 1._wp - fr_i(ji,jj) ) * zraug * taum(ji,jj) + & 
     492                  &                         fr_i(ji,jj)   * zmaxice             ) * tmask(ji,jj,1) 
    481493#endif 
    482494            END_2D 
    483495            ! 
    484          CASE( 3 )                                 ! scaling with max sea-ice thickness 
     496         CASE( 3 )                      ! scaling with max sea-ice thickness 
    485497            DO_2D( 0, 0, 0, 0 ) 
    486498               zmaxice = MAXVAL( h_i(ji,jj,:) ) 
    487                zmxlm(ji,jj,1) = ( ( 1. - fr_i(ji,jj) ) * zraug * taum(ji,jj) + fr_i(ji,jj) * zmaxice ) * tmask(ji,jj,1) 
     499               zmxlm(ji,jj,1) = ( ( 1._wp - fr_i(ji,jj) ) * zraug * taum(ji,jj) + & 
     500                  &                         fr_i(ji,jj)   * zmaxice             ) * tmask(ji,jj,1) 
    488501            END_2D 
    489502            ! 
    … …  
    533546         ! 
    534547      CASE ( 2 )           ! |dk[xml]| bounded by e3t : 
    535          DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 
     548         DO_3D( 0, 0, 0, 0, 2, jpkm1 )        ! from the surface to the bottom : 
    536549            zmxlm(ji,jj,jk) =   & 
    537550               &    MIN( zmxlm(ji,jj,jk-1) + e3t(ji,jj,jk-1,Kmm), zmxlm(ji,jj,jk) ) 
    538551         END_3D 
    539          DO_3DS( 0, 0, 0, 0, jpkm1, 2, -1 ) 
     552         DO_3DS( 0, 0, 0, 0, jpkm1, 2, -1 )   ! from the bottom to the surface : 
    540553            zemxl = MIN( zmxlm(ji,jj,jk+1) + e3t(ji,jj,jk+1,Kmm), zmxlm(ji,jj,jk) ) 
    541554            zmxlm(ji,jj,jk) = zemxl 
    … …  
    544557         ! 
    545558      CASE ( 3 )           ! lup and ldown, |dk[xml]| bounded by e3t : 
    546          DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 
     559         DO_3D( 0, 0, 0, 0, 2, jpkm1 )        ! from the surface to the bottom : lup 
    547560            zmxld(ji,jj,jk) =    & 
    548561               &    MIN( zmxld(ji,jj,jk-1) + e3t(ji,jj,jk-1,Kmm), zmxlm(ji,jj,jk) ) 
    549562         END_3D 
    550          DO_3DS( 0, 0, 0, 0, jpkm1, 2, -1 ) 
     563         DO_3DS( 0, 0, 0, 0, jpkm1, 2, -1 )   ! from the bottom to the surface : ldown 
    551564            zmxlm(ji,jj,jk) =   & 
    552565               &    MIN( zmxlm(ji,jj,jk+1) + e3t(ji,jj,jk+1,Kmm), zmxlm(ji,jj,jk) ) 
    … …  
    564577      !                     !  Vertical eddy viscosity and diffusivity  (avm and avt) 
    565578      !                     !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
    566       DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     579      DO_3D( 0, 0, 0, 0, 1, jpkm1 )   !* vertical eddy viscosity & diffivity at w-points 
    567580         zsqen = SQRT( en(ji,jj,jk) ) 
    568581         zav   = rn_ediff * zmxlm(ji,jj,jk) * zsqen 
    … …  
    573586      ! 
    574587      ! 
    575       IF( nn_pdl == 1 ) THEN      !* Prandtl number case: update avt 
     588      IF( nn_pdl == 1 ) THEN          !* Prandtl number case: update avt 
    576589         DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 
    577590            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) 
    … …  
    610623         &                 rn_emin0, rn_bshear, nn_mxl   , ln_mxl0  ,  & 
    611624         &                 rn_mxl0 , nn_mxlice, rn_mxlice,             & 
    612          &                 nn_pdl  , ln_drg   , ln_lc    , rn_lc,      & 
    613          &                 nn_etau , nn_htau  , rn_efr   , rn_eice   
     625         &                 nn_pdl  , ln_lc    , rn_lc    ,             & 
     626         &                 nn_etau , nn_htau  , rn_efr   , nn_eice   
    614627      !!---------------------------------------------------------------------- 
    615628      ! 
    … …  
    637650         WRITE(numout,*) '      mixing length type                          nn_mxl    = ', nn_mxl 
    638651         WRITE(numout,*) '         surface mixing length = F(stress) or not    ln_mxl0   = ', ln_mxl0 
     652         WRITE(numout,*) '         surface  mixing length minimum value        rn_mxl0   = ', rn_mxl0 
    639653         IF( ln_mxl0 ) THEN 
    640654            WRITE(numout,*) '      type of scaling under sea-ice               nn_mxlice = ', nn_mxlice 
    641655            IF( nn_mxlice == 1 ) & 
    642656            WRITE(numout,*) '      ice thickness when scaling under sea-ice    rn_mxlice = ', rn_mxlice 
    643          ENDIF          
    644          WRITE(numout,*) '         surface  mixing length minimum value        rn_mxl0   = ', rn_mxl0 
    645          WRITE(numout,*) '      top/bottom friction forcing flag            ln_drg    = ', ln_drg 
     657            SELECT CASE( nn_mxlice )             ! Type of scaling under sea-ice 
     658            CASE( 0 )   ;   WRITE(numout,*) '   ==>>>   No scaling under sea-ice' 
     659            CASE( 1 )   ;   WRITE(numout,*) '   ==>>>   scaling with constant sea-ice thickness' 
     660            CASE( 2 )   ;   WRITE(numout,*) '   ==>>>   scaling with mean sea-ice thickness' 
     661            CASE( 3 )   ;   WRITE(numout,*) '   ==>>>   scaling with max sea-ice thickness' 
     662            CASE DEFAULT 
     663               CALL ctl_stop( 'zdf_tke_init: wrong value for nn_mxlice, should be 0,1,2,3 or 4') 
     664            END SELECT 
     665         ENDIF 
    646666         WRITE(numout,*) '      Langmuir cells parametrization              ln_lc     = ', ln_lc 
    647667         WRITE(numout,*) '         coef to compute vertical velocity of LC     rn_lc  = ', rn_lc 
    … …  
    649669         WRITE(numout,*) '          type of tke penetration profile            nn_htau   = ', nn_htau 
    650670         WRITE(numout,*) '          fraction of TKE that penetrates            rn_efr    = ', rn_efr 
    651          WRITE(numout,*) '          below sea-ice:  =0 ON                      rn_eice   = ', rn_eice 
    652          WRITE(numout,*) '          =4 OFF when ice fraction > 1/4   ' 
    653          IF( ln_drg ) THEN 
    654             WRITE(numout,*) 
    655             WRITE(numout,*) '   Namelist namdrg_top/_bot:   used values:' 
    656             WRITE(numout,*) '      top    ocean cavity roughness (m)          rn_z0(_top)= ', r_z0_top 
    657             WRITE(numout,*) '      Bottom seafloor     roughness (m)          rn_z0(_bot)= ', r_z0_bot 
    658          ENDIF 
     671         WRITE(numout,*) '      langmuir & surface wave breaking under ice  nn_eice = ', nn_eice 
     672         SELECT CASE( nn_eice )  
     673         CASE( 0 )   ;   WRITE(numout,*) '   ==>>>   no impact of ice cover on langmuir & surface wave breaking' 
     674         CASE( 1 )   ;   WRITE(numout,*) '   ==>>>   weigthed by 1-TANH( fr_i(:,:) * 10 )' 
     675         CASE( 2 )   ;   WRITE(numout,*) '   ==>>>   weighted by 1-fr_i(:,:)' 
     676         CASE( 3 )   ;   WRITE(numout,*) '   ==>>>   weighted by 1-MIN( 1, 4 * fr_i(:,:) )' 
     677         CASE DEFAULT 
     678            CALL ctl_stop( 'zdf_tke_init: wrong value for nn_eice, should be 0,1,2, or 3') 
     679         END SELECT       
    659680         WRITE(numout,*) 
    660681         WRITE(numout,*) '   ==>>>   critical Richardson nb with your parameters  ri_cri = ', ri_cri 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/module_example

    r11536 r13998  
    9393      INTEGER  ::   ji, jj, jk       ! dummy loop arguments  (DOCTOR : start with j, but not jp) 
    9494      INTEGER  ::   itoto, itata     ! temporary integers    (DOCTOR : start with i 
    95       REAL(wp) ::   zmlmin, zbbrau   ! temporary scalars     (DOCTOR : start with z) 
     95      REAL(wp) ::   zmlmin, zbbrho   ! temporary scalars     (DOCTOR : start with z) 
    9696      REAL(wp) ::   zfact1, zfact2   ! do not use continuation lines in declaration 
    9797      REAL(wp), DIMENSION(jpi,jpj) ::   zwrk_2d   ! 2D workspace 
    … …  
    101101 
    102102      zmlmin = 1.e-8                             ! Local constant initialization 
    103       zbbrau =  .5 * ebb / rau0 
     103      zbbrho =  .5 * ebb / rho0 
    104104      zfact1 = -.5 * rdt * efave 
    105105      zfact2 = 1.5 * rdt * ediss 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/nemogcm.F90

    r13915 r13998  
    449449      !                                         ! Lateral physics 
    450450                           CALL ldf_tra_init      ! Lateral ocean tracer physics 
    451                            CALL ldf_eiv_init      ! eddy induced velocity param. 
     451                           CALL ldf_eiv_init      ! eddy induced velocity param. must be done after ldf_tra_init 
    452452                           CALL ldf_dyn_init      ! Lateral ocean momentum physics 
    453453 
    … …  
    487487                           CALL     flo_init( Nnn )    ! drifting Floats 
    488488      IF( ln_diacfl    )   CALL dia_cfl_init    ! Initialise CFL diagnostics 
    489 !                           CALL dia_ptr_init    ! Poleward TRansports initialization 
    490489                           CALL dia_dct_init    ! Sections tranports 
    491490                           CALL dia_hsb_init( Nnn )    ! heat content, salt content and volume budgets 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/stpctl.F90

    r13608 r13998  
    4949      !! 
    5050      !! ** Method  : - Save the time step in numstp 
    51       !!              - Print it each 50 time steps 
    5251      !!              - Stop the run IF problem encountered by setting nstop > 0 
    5352      !!                Problems checked: |ssh| maximum larger than 10 m 
    … …  
    6867      REAL(wp)                        ::   zzz                                   ! local real  
    6968      REAL(wp), DIMENSION(9)          ::   zmax, zmaxlocal 
    70       LOGICAL                         ::   ll_wrtstp, ll_colruns, ll_wrtruns 
     69      LOGICAL                         ::   ll_wrtstp, ll_colruns, ll_wrtruns, ll_0oce 
    7170      LOGICAL, DIMENSION(jpi,jpj,jpk) ::   llmsk 
    7271      CHARACTER(len=20)               ::   clname 
    … …  
    120119      !                                   !==            test of local extrema           ==! 
    121120      !                                   !==  done by all processes at every time step  ==! 
    122       llmsk(:,:,1) = ssmask(:,:) == 1._wp 
     121      ! 
     122      llmsk(   1:Nis1,:,:) = .FALSE.                                              ! exclude halos from the checked region 
     123      llmsk(Nie1: jpi,:,:) = .FALSE. 
     124      llmsk(:,   1:Njs1,:) = .FALSE. 
     125      llmsk(:,Nje1: jpj,:) = .FALSE. 
     126      ! 
     127      llmsk(Nis0:Nie0,Njs0:Nje0,1) = ssmask(Nis0:Nie0,Njs0:Nje0) == 1._wp         ! define only the inner domain 
     128      ! 
     129      ll_0oce = .NOT. ANY( llmsk(:,:,1) )                                         ! no ocean point in the inner domain? 
     130      ! 
    123131      IF( ll_wd ) THEN 
    124132         zmax(1) = MAXVAL( ABS( ssh(:,:,Kmm) + ssh_ref ), mask = llmsk(:,:,1) )   ! ssh max 
    … …  
    126134         zmax(1) = MAXVAL( ABS( ssh(:,:,Kmm)           ), mask = llmsk(:,:,1) )   ! ssh max 
    127135      ENDIF 
    128       llmsk(:,:,:) = umask(:,:,:) == 1._wp 
     136      llmsk(Nis0:Nie0,Njs0:Nje0,:) = umask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp        ! define only the inner domain 
    129137      zmax(2) = MAXVAL(  ABS( uu(:,:,:,Kmm) ), mask = llmsk )                     ! velocity max (zonal only) 
    130       llmsk(:,:,:) = tmask(:,:,:) == 1._wp 
     138      llmsk(Nis0:Nie0,Njs0:Nje0,:) = tmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp        ! define only the inner domain 
    131139      zmax(3) = MAXVAL( -ts(:,:,:,jp_sal,Kmm), mask = llmsk )                     ! minus salinity max 
    132140      zmax(4) = MAXVAL(  ts(:,:,:,jp_sal,Kmm), mask = llmsk )                     !       salinity max 
    … …  
    144152         zmax(5:8) = 0._wp 
    145153      ENDIF 
    146       zmax(9) = REAL( nstop, wp )                                              ! stop indicator 
     154      zmax(9) = REAL( nstop, wp )                                                 ! stop indicator 
     155      ! 
    147156      !                                   !==               get global extrema             ==! 
    148157      !                                   !==  done by all processes if writting run.stat  ==! 
    149158      IF( ll_colruns ) THEN 
    150159         zmaxlocal(:) = zmax(:) 
    151          CALL mpp_max( "stpctl", zmax )          ! max over the global domain 
     160         CALL mpp_max( "stpctl", zmax )          ! max over the global domain: ok even of ll_0oce = .true.  
    152161         nstop = NINT( zmax(9) )                 ! update nstop indicator (now sheared among all local domains) 
    153       ENDIF 
     162      ELSE 
     163         ! if no ocean point: MAXVAL returns -HUGE => we must overwrite this value to avoid error handling bellow. 
     164         IF( ll_0oce )   zmax(1:4) = (/ 0._wp, 0._wp, -1._wp, 1._wp /)   ! default "valid" values... 
     165      ENDIF 
     166      ! 
     167      zmax(3) = -zmax(3)                         ! move back from max(-zz) to min(zz) : easier to manage!  
     168      zmax(5) = -zmax(5)                         ! move back from max(-zz) to min(zz) : easier to manage! 
     169      IF( ll_colruns ) THEN 
     170         zmaxlocal(3) = -zmaxlocal(3)            ! move back from max(-zz) to min(zz) : easier to manage!  
     171         zmaxlocal(5) = -zmaxlocal(5)            ! move back from max(-zz) to min(zz) : easier to manage! 
     172      ENDIF 
     173      ! 
    154174      !                                   !==              write "run.stat" files              ==! 
    155175      !                                   !==  done only by 1st subdomain at writting timestep  ==! 
    156176      IF( ll_wrtruns ) THEN 
    157          WRITE(numrun,9500) kt, zmax(1), zmax(2), -zmax(3), zmax(4) 
    158          istatus = NF90_PUT_VAR( nrunid, nvarid(1), (/ zmax(1)/), (/kt/), (/1/) ) 
    159          istatus = NF90_PUT_VAR( nrunid, nvarid(2), (/ zmax(2)/), (/kt/), (/1/) ) 
    160          istatus = NF90_PUT_VAR( nrunid, nvarid(3), (/-zmax(3)/), (/kt/), (/1/) ) 
    161          istatus = NF90_PUT_VAR( nrunid, nvarid(4), (/ zmax(4)/), (/kt/), (/1/) ) 
    162          istatus = NF90_PUT_VAR( nrunid, nvarid(5), (/-zmax(5)/), (/kt/), (/1/) ) 
    163          istatus = NF90_PUT_VAR( nrunid, nvarid(6), (/ zmax(6)/), (/kt/), (/1/) ) 
    164          IF( ln_zad_Aimp ) THEN 
    165             istatus = NF90_PUT_VAR( nrunid, nvarid(7), (/ zmax(7)/), (/kt/), (/1/) ) 
    166             istatus = NF90_PUT_VAR( nrunid, nvarid(8), (/ zmax(8)/), (/kt/), (/1/) ) 
    167          ENDIF 
     177         WRITE(numrun,9500) kt, zmax(1), zmax(2), zmax(3), zmax(4) 
     178         DO ji = 1, 6 + 2 * COUNT( (/ln_zad_Aimp/) ) 
     179            istatus = NF90_PUT_VAR( nrunid, nvarid(ji), (/zmax(ji)/), (/kt/), (/1/) ) 
     180         END DO 
    168181         IF( kt == nitend )   istatus = NF90_CLOSE(nrunid) 
    169182      ENDIF 
    … …  
    171184      !                                   !==  done by all processes at every time step  ==! 
    172185      ! 
    173       IF(   zmax(1) >   20._wp .OR.   &                   ! too large sea surface height ( > 20 m ) 
    174          &  zmax(2) >   10._wp .OR.   &                   ! too large velocity ( > 10 m/s) 
    175          &  zmax(3) >=   0._wp .OR.   &                   ! negative or zero sea surface salinity 
    176          &  zmax(4) >= 100._wp .OR.   &                   ! too large sea surface salinity ( > 100 ) 
    177          &  zmax(4) <    0._wp .OR.   &                   ! too large sea surface salinity (keep this line for sea-ice) 
    178          &  ISNAN( zmax(1) + zmax(2) + zmax(3) ) .OR.   &               ! NaN encounter in the tests 
    179          &  ABS(   zmax(1) + zmax(2) + zmax(3) ) > HUGE(1._wp) ) THEN   ! Infinity encounter in the tests 
     186      IF(  zmax(1) >   20._wp .OR.   &                   ! too large sea surface height ( > 20 m ) 
     187         & zmax(2) >   10._wp .OR.   &                   ! too large velocity ( > 10 m/s) 
     188         & zmax(3) <=   0._wp .OR.   &                   ! negative or zero sea surface salinity 
     189         & zmax(4) >= 100._wp .OR.   &                   ! too large sea surface salinity ( > 100 ) 
     190         & zmax(4) <    0._wp .OR.   &                   ! too large sea surface salinity (keep this line for sea-ice) 
     191         & ISNAN( zmax(1) + zmax(2) + zmax(3) ) .OR.   &               ! NaN encounter in the tests 
     192         & ABS(   zmax(1) + zmax(2) + zmax(3) ) > HUGE(1._wp) ) THEN   ! Infinity encounter in the tests 
    180193         ! 
    181194         iloc(:,:) = 0 
    … …  
    184197            IF( lwm .AND. kt /= nitend )   istatus = NF90_CLOSE(nrunid) 
    185198            ! get global loc on the min/max 
    186             CALL mpp_maxloc( 'stpctl', ABS(ssh(:,:,         Kmm)), ssmask(:,:  ), zzz, iloc(1:2,1) )   ! mpp_maxloc ok if mask = F  
    187             CALL mpp_maxloc( 'stpctl', ABS( uu(:,:,:,       Kmm)),  umask(:,:,:), zzz, iloc(1:3,2) ) 
    188             CALL mpp_minloc( 'stpctl',      ts(:,:,:,jp_sal,Kmm) ,  tmask(:,:,:), zzz, iloc(1:3,3) ) 
    189             CALL mpp_maxloc( 'stpctl',      ts(:,:,:,jp_sal,Kmm) ,  tmask(:,:,:), zzz, iloc(1:3,4) ) 
     199            llmsk(Nis0:Nie0,Njs0:Nje0,1) = ssmask(Nis0:Nie0,Njs0:Nje0 ) == 1._wp         ! define only the inner domain 
     200            CALL mpp_maxloc( 'stpctl', ABS(ssh(:,:,         Kmm)), llmsk(:,:,1), zzz, iloc(1:2,1) )   ! mpp_maxloc ok if mask = F  
     201            llmsk(Nis0:Nie0,Njs0:Nje0,:) = umask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp        ! define only the inner domain 
     202            CALL mpp_maxloc( 'stpctl', ABS( uu(:,:,:,       Kmm)), llmsk(:,:,:), zzz, iloc(1:3,2) ) 
     203            llmsk(Nis0:Nie0,Njs0:Nje0,:) = tmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp        ! define only the inner domain 
     204            CALL mpp_minloc( 'stpctl',      ts(:,:,:,jp_sal,Kmm) , llmsk(:,:,:), zzz, iloc(1:3,3) ) 
     205            CALL mpp_maxloc( 'stpctl',      ts(:,:,:,jp_sal,Kmm) , llmsk(:,:,:), zzz, iloc(1:3,4) ) 
    190206            ! find which subdomain has the max. 
    191207            iareamin(:) = jpnij+1   ;   iareamax(:) = 0   ;   iareasum(:) = 0 
    … …  
    200216         ELSE                    ! find local min and max locations: 
    201217            ! if we are here, this means that the subdomain contains some oce points -> no need to test the mask used in maxloc 
    202             iloc(1:2,1) = MAXLOC( ABS( ssh(:,:,         Kmm)), mask = ssmask(:,:  ) == 1._wp ) + (/ nimpp - 1, njmpp - 1    /) 
    203             iloc(1:3,2) = MAXLOC( ABS(  uu(:,:,:,       Kmm)), mask =  umask(:,:,:) == 1._wp ) + (/ nimpp - 1, njmpp - 1, 0 /) 
    204             iloc(1:3,3) = MINLOC(       ts(:,:,:,jp_sal,Kmm) , mask =  tmask(:,:,:) == 1._wp ) + (/ nimpp - 1, njmpp - 1, 0 /) 
    205             iloc(1:3,4) = MAXLOC(       ts(:,:,:,jp_sal,Kmm) , mask =  tmask(:,:,:) == 1._wp ) + (/ nimpp - 1, njmpp - 1, 0 /) 
     218            llmsk(Nis0:Nie0,Njs0:Nje0,1) = ssmask(Nis0:Nie0,Njs0:Nje0 ) == 1._wp        ! define only the inner domain 
     219            iloc(1:2,1) = MAXLOC( ABS( ssh(:,:,         Kmm)), mask = llmsk(:,:,1) ) 
     220            llmsk(Nis0:Nie0,Njs0:Nje0,:) = umask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp        ! define only the inner domain 
     221            iloc(1:3,2) = MAXLOC( ABS(  uu(:,:,:,       Kmm)), mask = llmsk(:,:,:) ) 
     222            llmsk(Nis0:Nie0,Njs0:Nje0,:) = tmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp        ! define only the inner domain 
     223            iloc(1:3,3) = MINLOC(       ts(:,:,:,jp_sal,Kmm) , mask = llmsk(:,:,:) ) 
     224            iloc(1:3,4) = MAXLOC(       ts(:,:,:,jp_sal,Kmm) , mask = llmsk(:,:,:) ) 
     225            DO ji = 1, 4   ! local domain indices ==> global domain indices, excluding halos 
     226               iloc(1:2,ji) = (/ mig0(iloc(1,ji)), mjg0(iloc(2,ji)) /) 
     227            END DO 
    206228            iareamin(:) = narea   ;   iareamax(:) = narea   ;   iareasum(:) = 1         ! this is local information 
    207229         ENDIF 
    208230         ! 
    209231         WRITE(ctmp1,*) ' stp_ctl: |ssh| > 20 m  or  |U| > 10 m/s  or  S <= 0  or  S >= 100  or  NaN encounter in the tests' 
    210          CALL wrt_line( ctmp2, kt, '|ssh| max',  zmax(1), iloc(:,1), iareasum(1), iareamin(1), iareamax(1) ) 
    211          CALL wrt_line( ctmp3, kt, '|U|   max',  zmax(2), iloc(:,2), iareasum(2), iareamin(2), iareamax(2) ) 
    212          CALL wrt_line( ctmp4, kt, 'Sal   min', -zmax(3), iloc(:,3), iareasum(3), iareamin(3), iareamax(3) ) 
    213          CALL wrt_line( ctmp5, kt, 'Sal   max',  zmax(4), iloc(:,4), iareasum(4), iareamin(4), iareamax(4) ) 
     232         CALL wrt_line( ctmp2, kt, '|ssh| max', zmax(1), iloc(:,1), iareasum(1), iareamin(1), iareamax(1) ) 
     233         CALL wrt_line( ctmp3, kt, '|U|   max', zmax(2), iloc(:,2), iareasum(2), iareamin(2), iareamax(2) ) 
     234         CALL wrt_line( ctmp4, kt, 'Sal   min', zmax(3), iloc(:,3), iareasum(3), iareamin(3), iareamax(3) ) 
     235         CALL wrt_line( ctmp5, kt, 'Sal   max', zmax(4), iloc(:,4), iareasum(4), iareamin(4), iareamax(4) ) 
    214236         IF( Agrif_Root() ) THEN 
    215237            WRITE(ctmp6,*) '      ===> output of last computed fields in output.abort* files' 

  • NEMO/branches/2020/dev_r13327_KERNEL-06_2_techene_e3/src/OCE/timing.F90

    r12489 r13998  
    213213  
    214214  
    215    SUBROUTINE timing_init 
     215   SUBROUTINE timing_init( clname ) 
    216216      !!---------------------------------------------------------------------- 
    217217      !!               ***  ROUTINE timing_init  *** 
    … …  
    221221      REAL(wp) :: zdum 
    222222      LOGICAL :: ll_f 
    223               
     223      CHARACTER(len=*), INTENT(in), OPTIONAL :: clname 
     224      CHARACTER(len=20)                      :: cln 
     225 
     226      IF( PRESENT(clname) ) THEN   ;   cln = clname 
     227      ELSE                         ;   cln = 'timing.output' 
     228      ENDIF 
     229 
    224230      IF( ln_onefile ) THEN 
    225          IF( lwp) CALL ctl_opn( numtime, 'timing.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout,.TRUE., narea ) 
     231         IF( lwp) CALL ctl_opn( numtime, cln, 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout,.TRUE., narea ) 
    226232         lwriter = lwp 
    227233      ELSE 
    228          CALL ctl_opn( numtime, 'timing.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout,.FALSE., narea ) 
     234         CALL ctl_opn( numtime, cln, 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout,.FALSE., narea ) 
    229235         lwriter = .TRUE. 
    230236      ENDIF 
    … …  
    418424         s_timer => s_timer_root 
    419425         DO WHILE ( ASSOCIATED( s_timer%next ) ) 
    420          IF (.NOT. ASSOCIATED(s_timer%next)) EXIT 
     426            IF (.NOT. ASSOCIATED(s_timer%next)) EXIT 
    421427            IF ( s_timer%tsum_clock < s_timer%next%tsum_clock ) THEN  
    422428               ALLOCATE(s_wrk) 
    … …  
    426432               ll_ord = .FALSE. 
    427433               CYCLE             
    428             ENDIF            
    429          IF( ASSOCIATED(s_timer%next) ) s_timer => s_timer%next 
    430          END DO          
     434            ENDIF 
     435            IF( ASSOCIATED(s_timer%next) ) s_timer => s_timer%next 
     436         END DO 
    431437         IF( ll_ord ) EXIT 
    432438      END DO 
    … …  
    441447      clfmt = '(1x,a,4x,f12.3,6x,f12.3,x,f12.3,2x,f12.3,6x,f7.3,2x,i9)' 
    442448      DO WHILE ( ASSOCIATED(s_timer) ) 
    443          WRITE(numtime,TRIM(clfmt))   s_timer%cname,   & 
    444          &   s_timer%tsum_clock,s_timer%tsum_clock*100./t_elaps(2),            & 
    445          &   s_timer%tsum_cpu  ,s_timer%tsum_cpu*100./t_cpu(2)    ,            & 
    446          &   s_timer%tsum_cpu/s_timer%tsum_clock, s_timer%niter 
     449         IF( s_timer%tsum_clock > 0._wp )                                & 
     450            WRITE(numtime,TRIM(clfmt))   s_timer%cname,                  & 
     451            &   s_timer%tsum_clock,s_timer%tsum_clock*100./t_elaps(2),   & 
     452            &   s_timer%tsum_cpu  ,s_timer%tsum_cpu*100./t_cpu(2)    ,   & 
     453            &   s_timer%tsum_cpu/s_timer%tsum_clock, s_timer%niter 
    447454         s_timer => s_timer%next 
    448455      END DO 
    … …  
    607614         clfmt = '((A),E15.7,2x,f6.2,5x,f12.2,5x,f6.2,5x,f7.2,2x,f12.2,4x,f6.2,2x,f9.2)' 
    608615         DO WHILE ( ASSOCIATED(sl_timer_ave) ) 
    609             WRITE(numtime,TRIM(clfmt))   sl_timer_ave%cname(1:18),                            & 
    610             &   sl_timer_ave%tsum_clock,sl_timer_ave%tsum_clock*100.*jpnij/tot_etime,   & 
    611             &   sl_timer_ave%tsum_cpu  ,sl_timer_ave%tsum_cpu*100.*jpnij/tot_ctime  ,   & 
    612             &   sl_timer_ave%tsum_cpu/sl_timer_ave%tsum_clock,                          & 
    613             &   sl_timer_ave%tmax_clock*100.*jpnij/tot_etime,                           & 
    614             &   sl_timer_ave%tmin_clock*100.*jpnij/tot_etime,                           &                                                
    615             &   sl_timer_ave%niter/REAL(jpnij) 
     616            IF( sl_timer_ave%tsum_clock > 0. )                                             &  
     617               WRITE(numtime,TRIM(clfmt))   sl_timer_ave%cname(1:18),                      & 
     618               &   sl_timer_ave%tsum_clock,sl_timer_ave%tsum_clock*100.*jpnij/tot_etime,   & 
     619               &   sl_timer_ave%tsum_cpu  ,sl_timer_ave%tsum_cpu*100.*jpnij/tot_ctime  ,   & 
     620               &   sl_timer_ave%tsum_cpu/sl_timer_ave%tsum_clock,                          & 
     621               &   sl_timer_ave%tmax_clock*100.*jpnij/tot_etime,                           & 
     622               &   sl_timer_ave%tmin_clock*100.*jpnij/tot_etime,                           & 
     623               &   sl_timer_ave%niter/REAL(jpnij) 
    616624            sl_timer_ave => sl_timer_ave%next 
    617625         END DO 
Note: See TracChangeset for help on using the changeset viewer.