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 13571 for NEMO/branches – NEMO

Changeset 13571 for NEMO/branches


Ignore:
Timestamp:
2020-10-06T18:17:44+02:00 (4 years ago)
Author:
mocavero
Message:

Align branch with trunk

Location:
NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src
Files:
166 edited

Legend:

Unmodified
Added
Removed

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/ICE/ice.F90

    r12489 r13571  
    7070   !! a_ip        |      -      |    Ice pond concentration       |       | 
    7171   !! v_ip        |      -      |    Ice pond volume per unit area| m     | 
     72   !! v_il        |    v_il_1d  |    Ice pond lid volume per area | m     | 
    7273   !!                                                                     | 
    7374   !!-------------|-------------|---------------------------------|-------| 
    … …  
    8586   !! t_su        ! t_su_1d     |    Sea ice surface temperature  ! K     | 
    8687   !! h_ip        | h_ip_1d     |    Ice pond thickness           | m     | 
     88   !! h_il        | h_il_1d     |    Ice pond lid thickness       | m     | 
    8789   !!                                                                     | 
    8890   !! notes: the ice model only sees a bulk (i.e., vertically averaged)   | 
    … …  
    112114   !! hm_ip       |      -      |    Mean ice pond depth          | m     | 
    113115   !! vt_ip       |      -      |    Total ice pond vol. per unit area| m | 
     116   !! hm_il       |      -      |    Mean ice pond lid depth      | m     | 
     117   !! vt_il       |      -      |    Total ice pond lid vol. per area | m | 
    114118   !!===================================================================== 
    115119 
    … …  
    137141   REAL(wp), PUBLIC ::   rn_ishlat        !: lateral boundary condition for sea-ice 
    138142   LOGICAL , PUBLIC ::   ln_landfast_L16  !: landfast ice parameterizationfrom lemieux2016  
    139    REAL(wp), PUBLIC ::   rn_depfra        !:    fraction of ocean depth that ice must reach to initiate landfast ice 
    140    REAL(wp), PUBLIC ::   rn_icebfr        !:    maximum bottom stress per unit area of contact (lemieux2016) or per unit volume (home)  
    141    REAL(wp), PUBLIC ::   rn_lfrelax       !:    relaxation time scale (s-1) to reach static friction 
    142    REAL(wp), PUBLIC ::   rn_tensile       !:    isotropic tensile strength 
     143   REAL(wp), PUBLIC ::   rn_lf_depfra     !:    fraction of ocean depth that ice must reach to initiate landfast ice 
     144   REAL(wp), PUBLIC ::   rn_lf_bfr        !:    maximum bottom stress per unit area of contact (lemieux2016) or per unit volume (home)  
     145   REAL(wp), PUBLIC ::   rn_lf_relax      !:    relaxation time scale (s-1) to reach static friction 
     146   REAL(wp), PUBLIC ::   rn_lf_tensile    !:    isotropic tensile strength 
    143147   ! 
    144148   !                                     !!** ice-ridging/rafting namelist (namdyn_rdgrft) ** 
    … …  
    151155   INTEGER , PUBLIC ::   nn_nevp          !: number of iterations for subcycling 
    152156   REAL(wp), PUBLIC ::   rn_relast        !: ratio => telast/rDt_ice (1/3 or 1/9 depending on nb of subcycling nevp)  
     157   INTEGER , PUBLIC ::   nn_rhg_chkcvg    !: check ice rheology convergence  
    153158   ! 
    154159   !                                     !!** ice-advection namelist (namdyn_adv) ** 
    … …  
    158163   !                                     !!** ice-surface boundary conditions namelist (namsbc) ** 
    159164                                          ! -- icethd_dh -- ! 
    160    REAL(wp), PUBLIC ::   rn_blow_s        !: coef. for partitioning of snowfall between leads and sea ice 
     165   REAL(wp), PUBLIC ::   rn_snwblow       !: coef. for partitioning of snowfall between leads and sea ice 
     166                                          ! -- icethd_zdf and icealb -- ! 
     167   INTEGER , PUBLIC ::   nn_snwfra        !: calculate the fraction of ice covered by snow 
     168   !                                      !   = 0  fraction = 1 (if snow) or 0 (if no snow) 
     169   !                                      !   = 1  fraction = 1-exp(-0.2*rhos*hsnw) [MetO formulation] 
     170   !                                      !   = 2  fraction = hsnw / (hsnw+0.02)    [CICE formulation] 
    161171                                          ! -- icethd -- ! 
    162172   REAL(wp), PUBLIC ::   rn_cio           !: drag coefficient for oceanic stress 
    … …  
    166176   !                                      !   = 1  Average N(cat) fluxes then redistribute over the N(cat) ice using T-ice and albedo sensitivity 
    167177   !                                      !   = 2  Redistribute a single flux over categories 
     178                                          ! -- icethd_zdf -- ! 
    168179   LOGICAL , PUBLIC ::   ln_cndflx        !: use conduction flux as surface boundary condition (instead of qsr and qns)  
    169180   LOGICAL , PUBLIC ::   ln_cndemulate    !: emulate conduction flux (if not provided)  
    … …  
    172183   INTEGER, PUBLIC, PARAMETER ::   np_cnd_ON  = 1  !: forcing from conduction flux (SM0L) (compute qcn and qsr_tr via sbcblk.F90 or sbccpl.F90) 
    173184   INTEGER, PUBLIC, PARAMETER ::   np_cnd_EMU = 2  !: emulate conduction flux via icethd_zdf.F90 (BL99) (1st round compute qcn and qsr_tr, 2nd round use it) 
    174  
     185   INTEGER, PUBLIC ::   nn_qtrice         !: Solar flux transmitted thru the surface scattering layer: 
     186   !                                      !   = 0  Grenfell and Maykut 1977 (depends on cloudiness and is 0 when there is snow)  
     187   !                                      !   = 1  Lebrun 2019 (equals 0.3 anytime with different melting/dry snw conductivities) 
     188   ! 
    175189   !                                     !!** ice-vertical diffusion namelist (namthd_zdf) ** 
    176190   LOGICAL , PUBLIC ::   ln_cndi_U64      !: thermal conductivity: Untersteiner (1964) 
    177191   LOGICAL , PUBLIC ::   ln_cndi_P07      !: thermal conductivity: Pringle et al (2007) 
    178    REAL(wp), PUBLIC ::   rn_kappa_i       !: coef. for the extinction of radiation Grenfell et al. (2006) [1/m] 
    179192   REAL(wp), PUBLIC ::   rn_cnd_s         !: thermal conductivity of the snow [W/m/K]    
     193   REAL(wp), PUBLIC ::   rn_kappa_i       !: coef. for the extinction of radiation in sea ice, Grenfell et al. (2006) [1/m] 
     194   REAL(wp), PUBLIC ::   rn_kappa_s       !: coef. for the extinction of radiation in snw (nn_qtrice=0) [1/m] 
     195   REAL(wp), PUBLIC ::   rn_kappa_smlt    !: coef. for the extinction of radiation in melt snw (nn_qtrice=1) [1/m] 
     196   REAL(wp), PUBLIC ::   rn_kappa_sdry    !: coef. for the extinction of radiation in dry  snw (nn_qtrice=1) [1/m] 
     197   LOGICAL , PUBLIC ::   ln_zdf_chkcvg    !: check convergence of heat diffusion scheme 
    180198 
    181199   !                                     !!** ice-salinity namelist (namthd_sal) ** 
    … …  
    190208   !                                     !!** ice-ponds namelist (namthd_pnd) 
    191209   LOGICAL , PUBLIC ::   ln_pnd           !: Melt ponds (T) or not (F) 
    192    LOGICAL , PUBLIC ::   ln_pnd_H12       !: Melt ponds scheme from Holland et al 2012 
     210   LOGICAL , PUBLIC ::   ln_pnd_LEV       !: Melt ponds scheme from Holland et al (2012), Flocco et al (2007, 2010) 
     211   REAL(wp), PUBLIC ::   rn_apnd_min      !: Minimum ice fraction that contributes to melt ponds 
     212   REAL(wp), PUBLIC ::   rn_apnd_max      !: Maximum ice fraction that contributes to melt ponds 
    193213   LOGICAL , PUBLIC ::   ln_pnd_CST       !: Melt ponds scheme with constant fraction and depth 
    194214   REAL(wp), PUBLIC ::   rn_apnd          !: prescribed pond fraction (0<rn_apnd<1) 
    195215   REAL(wp), PUBLIC ::   rn_hpnd          !: prescribed pond depth    (0<rn_hpnd<1) 
     216   LOGICAL,  PUBLIC ::   ln_pnd_lids      !: Allow ponds to have frozen lids 
    196217   LOGICAL , PUBLIC ::   ln_pnd_alb       !: melt ponds affect albedo 
    197218 
    … …  
    218239 
    219240   !                                     !!** define arrays 
    220    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   u_oce,v_oce !: surface ocean velocity used in ice dynamics 
    221    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ht_i_new    !: ice collection thickness accreted in leads 
    222    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   strength    !: ice strength 
    223    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   stress1_i, stress2_i, stress12_i   !: 1st, 2nd & diagonal stress tensor element 
    224    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   delta_i     !: ice rheology elta factor (Flato & Hibler 95) [s-1] 
    225    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   divu_i      !: Divergence of the velocity field             [s-1] 
    226    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   shear_i     !: Shear of the velocity field                  [s-1] 
    227    ! 
    228    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   t_bo        !: Sea-Ice bottom temperature [Kelvin]      
    229    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   qlead       !: heat balance of the lead (or of the open ocean) 
    230    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   qsb_ice_bot !: net downward heat flux from the ice to the ocean 
    231    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   fhld        !: heat flux from the lead used for bottom melting 
    232  
    233    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_snw     !: mass flux from snow-ocean mass exchange             [kg.m-2.s-1] 
    234    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_snw_sni !: mass flux from snow ice growth component of wfx_snw [kg.m-2.s-1] 
    235    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_snw_sum !: mass flux from surface melt component of wfx_snw    [kg.m-2.s-1] 
    236    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_pnd     !: mass flux from melt pond-ocean mass exchange        [kg.m-2.s-1] 
    237    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_spr     !: mass flux from snow precipitation on ice            [kg.m-2.s-1] 
    238    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_sub     !: mass flux from sublimation of snow/ice              [kg.m-2.s-1] 
    239    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_snw_sub !: mass flux from snow sublimation                     [kg.m-2.s-1] 
    240    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_ice_sub !: mass flux from ice sublimation                      [kg.m-2.s-1] 
    241  
    242    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_snw_dyn !: mass flux from dynamical component of wfx_snw       [kg.m-2.s-1] 
    243  
    244    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_ice     !: mass flux from ice-ocean mass exchange                   [kg.m-2.s-1] 
    245    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_sni     !: mass flux from snow ice growth component of wfx_ice      [kg.m-2.s-1] 
    246    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_opw     !: mass flux from lateral ice growth component of wfx_ice   [kg.m-2.s-1] 
    247    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_bog     !: mass flux from bottom ice growth component of wfx_ice    [kg.m-2.s-1] 
    248    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_dyn     !: mass flux from dynamical ice growth component of wfx_ice [kg.m-2.s-1] 
    249    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_bom     !: mass flux from bottom melt component of wfx_ice          [kg.m-2.s-1] 
    250    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_sum     !: mass flux from surface melt component of wfx_ice         [kg.m-2.s-1] 
    251    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_lam     !: mass flux from lateral melt component of wfx_ice         [kg.m-2.s-1] 
    252    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_res     !: mass flux from residual component of wfx_ice             [kg.m-2.s-1] 
    253    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_err_sub !: mass flux error after sublimation                        [kg.m-2.s-1] 
    254  
    255    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sfx_bog     !: salt flux due to ice bottom growth                   [pss.kg.m-2.s-1 => g.m-2.s-1] 
    256    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sfx_bom     !: salt flux due to ice bottom melt                     [pss.kg.m-2.s-1 => g.m-2.s-1] 
    257    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sfx_lam     !: salt flux due to ice lateral melt                    [pss.kg.m-2.s-1 => g.m-2.s-1] 
    258    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sfx_sum     !: salt flux due to ice surface melt                    [pss.kg.m-2.s-1 => g.m-2.s-1] 
    259    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sfx_sni     !: salt flux due to snow-ice growth                     [pss.kg.m-2.s-1 => g.m-2.s-1] 
    260    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sfx_opw     !: salt flux due to growth in open water                [pss.kg.m-2.s-1 => g.m-2.s-1] 
    261    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sfx_bri     !: salt flux due to brine rejection                     [pss.kg.m-2.s-1 => g.m-2.s-1] 
    262    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sfx_dyn     !: salt flux due to porous ridged ice formation         [pss.kg.m-2.s-1 => g.m-2.s-1] 
    263    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sfx_res     !: salt flux due to correction on ice thick. (residual) [pss.kg.m-2.s-1 => g.m-2.s-1] 
    264    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sfx_sub     !: salt flux due to ice sublimation                     [pss.kg.m-2.s-1 => g.m-2.s-1] 
    265  
    266    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_bog     !: total heat flux causing bottom ice growth           [W.m-2] 
    267    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_bom     !: total heat flux causing bottom ice melt             [W.m-2] 
    268    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_sum     !: total heat flux causing surface ice melt            [W.m-2] 
    269    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_opw     !: total heat flux causing open water ice formation    [W.m-2] 
    270    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_dif     !: total heat flux causing Temp change in the ice      [W.m-2] 
    271    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_snw     !: heat flux for snow melt                             [W.m-2] 
    272    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_err_dif !: heat flux remaining due to change in non-solar flux [W.m-2] 
    273    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_err_rem !: heat flux error after heat remapping => must be 0   [W.m-2] 
    274    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   qt_atm_oi   !: heat flux at the interface atm-[oce+ice]            [W.m-2] 
    275    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   qt_oce_ai   !: heat flux at the interface oce-[atm+ice]            [W.m-2] 
     241   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   u_oce,v_oce     !: surface ocean velocity used in ice dynamics 
     242   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   ht_i_new        !: ice collection thickness accreted in leads 
     243   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   strength        !: ice strength 
     244   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   stress1_i, stress2_i, stress12_i   !: 1st, 2nd & diagonal stress tensor element 
     245   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   delta_i         !: ice rheology elta factor (Flato & Hibler 95) [s-1] 
     246   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   divu_i          !: Divergence of the velocity field             [s-1] 
     247   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   shear_i         !: Shear of the velocity field                  [s-1] 
     248   ! 
     249   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   t_bo            !: Sea-Ice bottom temperature [Kelvin]      
     250   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   qlead           !: heat balance of the lead (or of the open ocean) 
     251   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   qsb_ice_bot     !: net downward heat flux from the ice to the ocean 
     252   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   fhld            !: heat flux from the lead used for bottom melting 
     253 
     254   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   wfx_snw         !: mass flux from snow-ocean mass exchange             [kg.m-2.s-1] 
     255   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   wfx_snw_sni     !: mass flux from snow ice growth component of wfx_snw [kg.m-2.s-1] 
     256   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   wfx_snw_sum     !: mass flux from surface melt component of wfx_snw    [kg.m-2.s-1] 
     257   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   wfx_pnd         !: mass flux from melt pond-ocean mass exchange        [kg.m-2.s-1] 
     258   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   wfx_spr         !: mass flux from snow precipitation on ice            [kg.m-2.s-1] 
     259   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   wfx_sub         !: mass flux from sublimation of snow/ice              [kg.m-2.s-1] 
     260   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   wfx_snw_sub     !: mass flux from snow sublimation                     [kg.m-2.s-1] 
     261   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   wfx_ice_sub     !: mass flux from ice sublimation                      [kg.m-2.s-1] 
     262 
     263   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   wfx_snw_dyn     !: mass flux from dynamical component of wfx_snw       [kg.m-2.s-1] 
     264 
     265   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   wfx_ice         !: mass flux from ice-ocean mass exchange                   [kg.m-2.s-1] 
     266   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   wfx_sni         !: mass flux from snow ice growth component of wfx_ice      [kg.m-2.s-1] 
     267   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   wfx_opw         !: mass flux from lateral ice growth component of wfx_ice   [kg.m-2.s-1] 
     268   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   wfx_bog         !: mass flux from bottom ice growth component of wfx_ice    [kg.m-2.s-1] 
     269   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   wfx_dyn         !: mass flux from dynamical ice growth component of wfx_ice [kg.m-2.s-1] 
     270   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   wfx_bom         !: mass flux from bottom melt component of wfx_ice          [kg.m-2.s-1] 
     271   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   wfx_sum         !: mass flux from surface melt component of wfx_ice         [kg.m-2.s-1] 
     272   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   wfx_lam         !: mass flux from lateral melt component of wfx_ice         [kg.m-2.s-1] 
     273   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   wfx_res         !: mass flux from residual component of wfx_ice             [kg.m-2.s-1] 
     274   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   wfx_err_sub     !: mass flux error after sublimation                        [kg.m-2.s-1] 
     275 
     276   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   sfx_bog         !: salt flux due to ice bottom growth                   [pss.kg.m-2.s-1 => g.m-2.s-1] 
     277   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   sfx_bom         !: salt flux due to ice bottom melt                     [pss.kg.m-2.s-1 => g.m-2.s-1] 
     278   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   sfx_lam         !: salt flux due to ice lateral melt                    [pss.kg.m-2.s-1 => g.m-2.s-1] 
     279   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   sfx_sum         !: salt flux due to ice surface melt                    [pss.kg.m-2.s-1 => g.m-2.s-1] 
     280   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   sfx_sni         !: salt flux due to snow-ice growth                     [pss.kg.m-2.s-1 => g.m-2.s-1] 
     281   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   sfx_opw         !: salt flux due to growth in open water                [pss.kg.m-2.s-1 => g.m-2.s-1] 
     282   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   sfx_bri         !: salt flux due to brine rejection                     [pss.kg.m-2.s-1 => g.m-2.s-1] 
     283   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   sfx_dyn         !: salt flux due to porous ridged ice formation         [pss.kg.m-2.s-1 => g.m-2.s-1] 
     284   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   sfx_res         !: salt flux due to correction on ice thick. (residual) [pss.kg.m-2.s-1 => g.m-2.s-1] 
     285   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   sfx_sub         !: salt flux due to ice sublimation                     [pss.kg.m-2.s-1 => g.m-2.s-1] 
     286 
     287   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   hfx_bog         !: total heat flux causing bottom ice growth           [W.m-2] 
     288   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   hfx_bom         !: total heat flux causing bottom ice melt             [W.m-2] 
     289   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   hfx_sum         !: total heat flux causing surface ice melt            [W.m-2] 
     290   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   hfx_opw         !: total heat flux causing open water ice formation    [W.m-2] 
     291   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   hfx_dif         !: total heat flux causing Temp change in the ice      [W.m-2] 
     292   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   hfx_snw         !: heat flux for snow melt                             [W.m-2] 
     293   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   hfx_err_dif     !: heat flux remaining due to change in non-solar flux [W.m-2] 
     294   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   qt_atm_oi       !: heat flux at the interface atm-[oce+ice]            [W.m-2] 
     295   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   qt_oce_ai       !: heat flux at the interface oce-[atm+ice]            [W.m-2] 
    276296    
    277297   ! heat flux associated with ice-atmosphere mass exchange 
    278    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_sub     !: heat flux for sublimation            [W.m-2] 
    279    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_spr     !: heat flux of the snow precipitation  [W.m-2] 
     298   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   hfx_sub         !: heat flux for sublimation            [W.m-2] 
     299   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   hfx_spr         !: heat flux of the snow precipitation  [W.m-2] 
    280300 
    281301   ! heat flux associated with ice-ocean mass exchange 
    282    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_thd     !: ice-ocean heat flux from thermo processes (icethd_dh) [W.m-2] 
    283    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_dyn     !: ice-ocean heat flux from ridging                      [W.m-2] 
    284    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_res     !: heat flux due to correction on ice thick. (residual)  [W.m-2] 
    285  
    286    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   rn_amax_2d     !: maximum ice concentration 2d array 
    287    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   qtr_ice_bot    !: transmitted solar radiation under ice 
    288    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   t1_ice         !: temperature of the first layer                (ln_cndflx=T) [K] 
    289    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   cnd_ice        !: effective conductivity at the top of ice/snow (ln_cndflx=T) [W.m-2.K-1] 
     302   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   hfx_thd         !: ice-ocean heat flux from thermo processes (icethd_dh) [W.m-2] 
     303   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   hfx_dyn         !: ice-ocean heat flux from ridging                      [W.m-2] 
     304   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   hfx_res         !: heat flux due to correction on ice thick. (residual)  [W.m-2] 
     305 
     306   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   rn_amax_2d      !: maximum ice concentration 2d array 
     307   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   qtr_ice_bot     !: transmitted solar radiation under ice 
     308   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   t1_ice          !: temperature of the first layer          (ln_cndflx=T) [K] 
     309   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   cnd_ice         !: effective conductivity of the 1st layer (ln_cndflx=T) [W.m-2.K-1] 
    290310 
    291311   !!---------------------------------------------------------------------- 
    … …  
    293313   !!---------------------------------------------------------------------- 
    294314   !! Variables defined for each ice category 
    295    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   h_i       !: Ice thickness                           (m) 
    296    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   a_i       !: Ice fractional areas (concentration) 
    297    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   v_i       !: Ice volume per unit area                (m) 
    298    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   v_s       !: Snow volume per unit area               (m) 
    299    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   h_s       !: Snow thickness                          (m) 
    300    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   t_su      !: Sea-Ice Surface Temperature             (K) 
    301    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   s_i       !: Sea-Ice Bulk salinity                   (pss) 
    302    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   sv_i      !: Sea-Ice Bulk salinity * volume per area (pss.m) 
    303    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   o_i       !: Sea-Ice Age                             (s) 
    304    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   oa_i      !: Sea-Ice Age times ice area              (s) 
    305    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   bv_i      !: brine volume 
     315   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   h_i           !: Ice thickness                           (m) 
     316   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   a_i           !: Ice fractional areas (concentration) 
     317   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   v_i           !: Ice volume per unit area                (m) 
     318   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   v_s           !: Snow volume per unit area               (m) 
     319   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   h_s           !: Snow thickness                          (m) 
     320   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   t_su          !: Sea-Ice Surface Temperature             (K) 
     321   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   s_i           !: Sea-Ice Bulk salinity                   (pss) 
     322   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   sv_i          !: Sea-Ice Bulk salinity * volume per area (pss.m) 
     323   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   o_i           !: Sea-Ice Age                             (s) 
     324   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   oa_i          !: Sea-Ice Age times ice area              (s) 
     325   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   bv_i          !: brine volume 
    306326 
    307327   !! Variables summed over all categories, or associated to all the ice in a single grid cell 
    308    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   u_ice, v_ice !: components of the ice velocity                          (m/s) 
    309    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   vt_i , vt_s  !: ice and snow total volume per unit area                 (m) 
    310    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   st_i         !: Total ice salinity content                              (pss.m) 
    311    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   at_i         !: ice total fractional area (ice concentration) 
    312    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ato_i        !: =1-at_i ; total open water fractional area 
    313    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   et_i , et_s  !: ice and snow total heat content                         (J/m2) 
    314    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   tm_i         !: mean ice temperature over all categories                (K) 
    315    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   tm_s         !: mean snw temperature over all categories                (K) 
    316    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   bvm_i        !: brine volume averaged over all categories 
    317    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sm_i         !: mean sea ice salinity averaged over all categories      (pss) 
    318    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   tm_su        !: mean surface temperature over all categories            (K) 
    319    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hm_i         !: mean ice  thickness over all categories                 (m) 
    320    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hm_s         !: mean snow thickness over all categories                 (m) 
    321    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   om_i         !: mean ice age over all categories                        (s) 
    322    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   tau_icebfr   !: ice friction on ocean bottom (landfast param activated) 
    323  
    324    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   t_s      !: Snow temperatures     [K] 
    325    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   e_s      !: Snow enthalpy         [J/m2] 
    326    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   t_i      !: ice temperatures      [K] 
    327    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   e_i      !: ice enthalpy          [J/m2] 
    328    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   sz_i     !: ice salinity          [PSS] 
    329  
    330    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   a_ip       !: melt pond concentration 
    331    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   v_ip       !: melt pond volume per grid cell area      [m] 
    332    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   a_ip_frac  !: melt pond fraction (a_ip/a_i) 
    333    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   h_ip       !: melt pond depth                          [m] 
    334  
    335    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   at_ip      !: total melt pond concentration 
    336    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   hm_ip      !: mean melt pond depth                     [m] 
    337    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   vt_ip      !: total melt pond volume per gridcell area [m] 
    338  
    339    !!---------------------------------------------------------------------- 
    340    !! * Old values of global variables 
    341    !!---------------------------------------------------------------------- 
    342    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   v_s_b, v_i_b, h_s_b, h_i_b, h_ip_b    !: snow and ice volumes/thickness 
    343    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   a_i_b, sv_i_b, oa_i_b                 !: 
    344    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   e_s_b                                 !: snow heat content 
    345    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   e_i_b                                 !: ice temperatures 
    346    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)     ::   u_ice_b, v_ice_b                      !: ice velocity 
    347    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)     ::   at_i_b                                !: ice concentration (total) 
     328   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)     ::   u_ice, v_ice  !: components of the ice velocity                          (m/s) 
     329   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)     ::   vt_i , vt_s   !: ice and snow total volume per unit area                 (m) 
     330   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)     ::   st_i          !: Total ice salinity content                              (pss.m) 
     331   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)     ::   at_i          !: ice total fractional area (ice concentration) 
     332   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)     ::   ato_i         !: =1-at_i ; total open water fractional area 
     333   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)     ::   et_i , et_s   !: ice and snow total heat content                         (J/m2) 
     334   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)     ::   tm_i          !: mean ice temperature over all categories                (K) 
     335   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)     ::   tm_s          !: mean snw temperature over all categories                (K) 
     336   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)     ::   bvm_i         !: brine volume averaged over all categories 
     337   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)     ::   sm_i          !: mean sea ice salinity averaged over all categories      (pss) 
     338   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)     ::   tm_su         !: mean surface temperature over all categories            (K) 
     339   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)     ::   hm_i          !: mean ice  thickness over all categories                 (m) 
     340   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)     ::   hm_s          !: mean snow thickness over all categories                 (m) 
     341   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)     ::   om_i          !: mean ice age over all categories                        (s) 
     342   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)     ::   tau_icebfr    !: ice friction on ocean bottom (landfast param activated) 
     343 
     344   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   t_s           !: Snow temperatures     [K] 
     345   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   e_s           !: Snow enthalpy         [J/m2] 
     346   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   t_i           !: ice temperatures      [K] 
     347   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   e_i           !: ice enthalpy          [J/m2] 
     348   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   sz_i          !: ice salinity          [PSS] 
     349 
     350   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   a_ip          !: melt pond concentration 
     351   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   v_ip          !: melt pond volume per grid cell area      [m] 
     352   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   a_ip_frac     !: melt pond fraction (a_ip/a_i) 
     353   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   a_ip_eff      !: melt pond effective fraction (not covered up by lid) (a_ip/a_i) 
     354   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   h_ip          !: melt pond depth                          [m] 
     355   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   v_il          !: melt pond lid volume                     [m] 
     356   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   h_il          !: melt pond lid thickness                  [m] 
     357 
     358   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)     ::   at_ip         !: total melt pond concentration 
     359   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)     ::   hm_ip         !: mean melt pond depth                     [m] 
     360   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)     ::   vt_ip         !: total melt pond volume per gridcell area [m] 
     361   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)     ::   hm_il         !: mean melt pond lid depth                     [m] 
     362   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)     ::   vt_il         !: total melt pond lid volume per gridcell area [m] 
     363 
     364   !!---------------------------------------------------------------------- 
     365   !! * Global variables at before time step 
     366   !!---------------------------------------------------------------------- 
     367   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   v_s_b, v_i_b, h_s_b, h_i_b !: snow and ice volumes/thickness 
     368   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   a_i_b, sv_i_b              !: 
     369   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   e_s_b                      !: snow heat content 
     370   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   e_i_b                      !: ice temperatures 
     371   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)     ::   u_ice_b, v_ice_b           !: ice velocity 
     372   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)     ::   at_i_b                     !: ice concentration (total) 
    348373             
    349374   !!---------------------------------------------------------------------- 
    350375   !! * Ice thickness distribution variables 
    351376   !!---------------------------------------------------------------------- 
    352    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   hi_max         !: Boundary of ice thickness categories in thickness space 
    353    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   hi_mean        !: Mean ice thickness in catgories  
     377   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:)   ::   hi_max            !: Boundary of ice thickness categories in thickness space 
     378   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:)   ::   hi_mean           !: Mean ice thickness in catgories  
    354379   ! 
    355380   !!---------------------------------------------------------------------- 
    356381   !! * Ice diagnostics 
    357382   !!---------------------------------------------------------------------- 
    358    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   diag_trp_vi   !: transport of ice volume 
    359    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   diag_trp_vs   !: transport of snw volume 
    360    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   diag_trp_ei   !: transport of ice enthalpy [W/m2] 
    361    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   diag_trp_es   !: transport of snw enthalpy [W/m2] 
    362    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   diag_trp_sv   !: transport of salt content 
    363    ! 
    364    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   diag_heat     !: snw/ice heat content variation   [W/m2]  
    365    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   diag_sice     !: ice salt content variation   []  
    366    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   diag_vice     !: ice volume variation   [m/s]  
    367    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   diag_vsnw     !: snw volume variation   [m/s]  
    368  
     383   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   diag_trp_vi       !: transport of ice volume 
     384   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   diag_trp_vs       !: transport of snw volume 
     385   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   diag_trp_ei       !: transport of ice enthalpy [W/m2] 
     386   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   diag_trp_es       !: transport of snw enthalpy [W/m2] 
     387   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   diag_trp_sv       !: transport of salt content 
     388   ! 
     389   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   diag_heat         !: snw/ice heat content variation   [W/m2]  
     390   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   diag_sice         !: ice salt content variation   []  
     391   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   diag_vice         !: ice volume variation   [m/s]  
     392   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   diag_vsnw         !: snw volume variation   [m/s]  
     393   ! 
    369394   !!---------------------------------------------------------------------- 
    370395   !! * Ice conservation 
    371396   !!---------------------------------------------------------------------- 
    372    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   diag_v        !: conservation of ice volume 
    373    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   diag_s        !: conservation of ice salt 
    374    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   diag_t        !: conservation of ice heat 
    375    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   diag_fv       !: conservation of ice volume 
    376    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   diag_fs       !: conservation of ice salt 
    377    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   diag_ft       !: conservation of ice heat 
     397   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   diag_v            !: conservation of ice volume 
     398   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   diag_s            !: conservation of ice salt 
     399   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   diag_t            !: conservation of ice heat 
     400   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   diag_fv           !: conservation of ice volume 
     401   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   diag_fs           !: conservation of ice salt 
     402   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   diag_ft           !: conservation of ice heat 
    378403   ! 
    379404   !!---------------------------------------------------------------------- 
    … …  
    381406   !!---------------------------------------------------------------------- 
    382407   ! Extra sea ice diagnostics to address the data request 
    383    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   t_si          !: Temperature at Snow-ice interface (K)  
    384    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   tm_si         !: mean temperature at the snow-ice interface (K)  
    385    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   qcn_ice_bot   !: Bottom  conduction flux (W/m2) 
    386    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   qcn_ice_top   !: Surface conduction flux (W/m2) 
    387  
     408   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   t_si            !: Temperature at Snow-ice interface (K)  
     409   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   tm_si           !: mean temperature at the snow-ice interface (K)  
     410   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   qcn_ice_bot     !: Bottom  conduction flux (W/m2) 
     411   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   qcn_ice_top     !: Surface conduction flux (W/m2) 
    388412   ! 
    389413   !!---------------------------------------------------------------------- 
    … …  
    424448         &      hfx_sum    (jpi,jpj) , hfx_bom   (jpi,jpj) , hfx_bog(jpi,jpj) , hfx_dif(jpi,jpj) ,     & 
    425449         &      hfx_opw    (jpi,jpj) , hfx_thd   (jpi,jpj) , hfx_dyn(jpi,jpj) , hfx_spr(jpi,jpj) ,     & 
    426          &      hfx_err_dif(jpi,jpj) , hfx_err_rem(jpi,jpj) , wfx_err_sub(jpi,jpj)             , STAT=ierr(ii) ) 
     450         &      hfx_err_dif(jpi,jpj) , wfx_err_sub(jpi,jpj)                   , STAT=ierr(ii) ) 
    427451 
    428452      ! * Ice global state variables 
    … …  
    448472 
    449473      ii = ii + 1 
    450       ALLOCATE( a_ip(jpi,jpj,jpl) , v_ip(jpi,jpj,jpl) , a_ip_frac(jpi,jpj,jpl) , h_ip(jpi,jpj,jpl) , STAT = ierr(ii) ) 
    451  
    452       ii = ii + 1 
    453       ALLOCATE( at_ip(jpi,jpj) , hm_ip(jpi,jpj) , vt_ip(jpi,jpj) , STAT = ierr(ii) ) 
     474      ALLOCATE( a_ip(jpi,jpj,jpl) , v_ip(jpi,jpj,jpl) , a_ip_frac(jpi,jpj,jpl) , h_ip(jpi,jpj,jpl),  & 
     475         &      v_il(jpi,jpj,jpl) , h_il(jpi,jpj,jpl) , a_ip_eff (jpi,jpj,jpl) , STAT = ierr(ii) ) 
     476 
     477      ii = ii + 1 
     478      ALLOCATE( at_ip(jpi,jpj) , hm_ip(jpi,jpj) , vt_ip(jpi,jpj) , hm_il(jpi,jpj) , vt_il(jpi,jpj) , STAT = ierr(ii) ) 
    454479 
    455480      ! * Old values of global variables 
    456481      ii = ii + 1 
    457       ALLOCATE( v_s_b (jpi,jpj,jpl) , v_i_b (jpi,jpj,jpl) , h_s_b(jpi,jpj,jpl)        , h_i_b(jpi,jpj,jpl), h_ip_b(jpi,jpj,jpl),  & 
    458          &      a_i_b (jpi,jpj,jpl) , sv_i_b(jpi,jpj,jpl) , e_i_b(jpi,jpj,nlay_i,jpl) , e_s_b(jpi,jpj,nlay_s,jpl) ,               & 
    459          &      oa_i_b(jpi,jpj,jpl)                                                   , STAT=ierr(ii) ) 
     482      ALLOCATE( v_s_b (jpi,jpj,jpl) , v_i_b (jpi,jpj,jpl) , h_s_b(jpi,jpj,jpl)        , h_i_b(jpi,jpj,jpl),         & 
     483         &      a_i_b (jpi,jpj,jpl) , sv_i_b(jpi,jpj,jpl) , e_i_b(jpi,jpj,nlay_i,jpl) , e_s_b(jpi,jpj,nlay_s,jpl) , & 
     484         &      STAT=ierr(ii) ) 
    460485 
    461486      ii = ii + 1 
    … …  
    484509      IF( ice_alloc /= 0 )   CALL ctl_stop( 'STOP', 'ice_alloc: failed to allocate arrays.' ) 
    485510      ! 
     511 
    486512   END FUNCTION ice_alloc 
    487513 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/ICE/ice1d.F90

    r10786 r13571  
    5151   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   hfx_snw_1d 
    5252   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   hfx_dyn_1d 
    53    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   hfx_err_rem_1d 
    5453   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   hfx_err_dif_1d 
    5554   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   qt_oce_ai_1d 
    … …  
    124123   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   oa_i_1d       !: 
    125124   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   o_i_1d        !: 
    126    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   a_ip_1d       !: 
     125   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   a_ip_1d       !: ice ponds 
    127126   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   v_ip_1d       !: 
    128127   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   h_ip_1d       !: 
    129    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   a_ip_frac_1d  !: 
     128   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   v_il_1d       !: Ice pond lid 
     129   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   h_il_1d       !: 
    130130 
    131131   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   t_s_1d      !: corresponding to the 2D var  t_s 
    … …  
    146146   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   sss_1d 
    147147 
     148   ! convergence check 
     149   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   tice_cvgerr_1d   !: convergence of ice/snow temp (dT)          [K] 
     150   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   tice_cvgstp_1d   !: convergence of ice/snow temp (subtimestep) [-] 
    148151   !  
    149152   !!---------------------- 
    … …  
    157160   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   a_ip_2d 
    158161   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   v_ip_2d  
     162   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   v_il_2d  
    159163   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   t_su_2d  
    160164   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   h_i_2d 
    … …  
    175179      !!---------------------------------------------------------------------! 
    176180      INTEGER ::   ice1D_alloc   ! return value 
    177       INTEGER ::   ierr(7), ii 
     181      INTEGER ::   ierr(8), ii 
    178182      !!---------------------------------------------------------------------! 
    179183      ierr(:) = 0 
    … …  
    189193         &      hfx_thd_1d(jpij) , hfx_spr_1d    (jpij) ,                      & 
    190194         &      hfx_snw_1d(jpij) , hfx_sub_1d    (jpij) ,                      & 
    191          &      hfx_res_1d(jpij) , hfx_err_rem_1d(jpij) , hfx_err_dif_1d(jpij) , qt_oce_ai_1d(jpij), STAT=ierr(ii) ) 
     195         &      hfx_res_1d(jpij) , hfx_err_dif_1d(jpij) , qt_oce_ai_1d(jpij), STAT=ierr(ii) ) 
    192196      ! 
    193197      ii = ii + 1 
    … …  
    208212         &      dh_s_tot(jpij) , dh_i_sum(jpij) , dh_i_itm  (jpij) , dh_i_bom(jpij) , dh_i_bog(jpij) ,  &     
    209213         &      dh_i_sub(jpij) , dh_s_mlt(jpij) , dh_snowice(jpij) , s_i_1d  (jpij) , s_i_new (jpij) ,  & 
    210          &      a_ip_1d (jpij) , v_ip_1d (jpij) , v_i_1d    (jpij) , v_s_1d  (jpij) ,                   & 
    211          &      h_ip_1d (jpij) , a_ip_frac_1d(jpij) ,                                                   & 
     214         &      a_ip_1d (jpij) , v_ip_1d (jpij) , v_i_1d    (jpij) , v_s_1d  (jpij) , v_il_1d (jpij) ,  & 
     215         &      h_il_1d (jpij) , h_ip_1d (jpij) ,                                                       & 
    212216         &      sv_i_1d (jpij) , oa_i_1d (jpij) , o_i_1d    (jpij) , STAT=ierr(ii) ) 
    213217      ! 
    … …  
    224228      ! 
    225229      ii = ii + 1 
     230      ALLOCATE( tice_cvgerr_1d(jpij) , tice_cvgstp_1d(jpij) , STAT=ierr(ii) ) 
     231      ! 
     232      ii = ii + 1 
    226233      ALLOCATE( a_i_2d (jpij,jpl) , a_ib_2d(jpij,jpl) , h_i_2d (jpij,jpl) , h_ib_2d(jpij,jpl) ,  & 
    227234         &      v_i_2d (jpij,jpl) , v_s_2d (jpij,jpl) , oa_i_2d(jpij,jpl) , sv_i_2d(jpij,jpl) ,  & 
    228          &      a_ip_2d(jpij,jpl) , v_ip_2d(jpij,jpl) , t_su_2d(jpij,jpl) ,                      & 
     235         &      a_ip_2d(jpij,jpl) , v_ip_2d(jpij,jpl) , t_su_2d(jpij,jpl) , v_il_2d(jpij,jpl) ,  & 
    229236         &      STAT=ierr(ii) ) 
    230237 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/ICE/icealb.F90

    r13295 r13571  
    1414   !!   ice_alb_init   : initialisation of albedo computation 
    1515   !!---------------------------------------------------------------------- 
    16    USE ice, ONLY: jpl ! sea-ice: number of categories 
    1716   USE phycst         ! physical constants 
    1817   USE dom_oce        ! domain: ocean 
     18   USE ice, ONLY: jpl ! sea-ice: number of categories 
     19   USE icevar         ! sea-ice: operations 
    1920   ! 
    2021   USE in_out_manager ! I/O manager 
    … …  
    4748CONTAINS 
    4849 
    49    SUBROUTINE ice_alb( pt_su, ph_ice, ph_snw, ld_pnd_alb, pafrac_pnd, ph_pnd, palb_cs, palb_os ) 
     50   SUBROUTINE ice_alb( pt_su, ph_ice, ph_snw, ld_pnd_alb, pafrac_pnd, ph_pnd, pcloud_fra, palb_ice ) 
    5051      !!---------------------------------------------------------------------- 
    5152      !!               ***  ROUTINE ice_alb  *** 
    … …  
    99100      REAL(wp), INTENT(in   ), DIMENSION(:,:,:) ::   pafrac_pnd   !  melt pond relative fraction (per unit ice area) 
    100101      REAL(wp), INTENT(in   ), DIMENSION(:,:,:) ::   ph_pnd       !  melt pond depth 
    101       REAL(wp), INTENT(  out), DIMENSION(:,:,:) ::   palb_cs      !  albedo of ice under clear    sky 
    102       REAL(wp), INTENT(  out), DIMENSION(:,:,:) ::   palb_os      !  albedo of ice under overcast sky 
    103       ! 
     102      REAL(wp), INTENT(in   ), DIMENSION(:,:)   ::   pcloud_fra   !  cloud fraction 
     103      REAL(wp), INTENT(  out), DIMENSION(:,:,:) ::   palb_ice     !  albedo of ice 
     104      ! 
     105      REAL(wp), DIMENSION(jpi,jpj,jpl) :: za_s_fra   ! ice fraction covered by snow 
    104106      INTEGER  ::   ji, jj, jl                ! dummy loop indices 
    105107      REAL(wp) ::   z1_c1, z1_c2,z1_c3, z1_c4 ! local scalar 
    … …  
    108110      REAL(wp) ::   zalb_ice, zafrac_ice      ! bare sea ice albedo & relative ice fraction 
    109111      REAL(wp) ::   zalb_snw, zafrac_snw      ! snow-covered sea ice albedo & relative snow fraction 
     112      REAL(wp) ::   zalb_cs, zalb_os          ! albedo of ice under clear/overcast sky 
    110113      !!--------------------------------------------------------------------- 
    111114      ! 
    … …  
    118121      z1_c4 = 1. / 0.03 
    119122      ! 
     123      CALL ice_var_snwfra( ph_snw, za_s_fra )   ! calculate ice fraction covered by snow 
     124      ! 
    120125      DO jl = 1, jpl 
    121126         DO_2D( 1, 1, 1, 1 ) 
    122             !                       !--- Specific snow, ice and pond fractions (for now, we prevent melt ponds and snow at the same time) 
    123             IF( ph_snw(ji,jj,jl) == 0._wp ) THEN 
    124                zafrac_snw = 0._wp 
    125                IF( ld_pnd_alb ) THEN 
    126                   zafrac_pnd = pafrac_pnd(ji,jj,jl) 
    127                ELSE 
    128                   zafrac_pnd = 0._wp 
    129                ENDIF 
    130                zafrac_ice = 1._wp - zafrac_pnd 
     127            ! 
     128            !---------------------------------------------! 
     129            !--- Specific snow, ice and pond fractions ---! 
     130            !---------------------------------------------!                
     131            zafrac_snw = za_s_fra(ji,jj,jl) 
     132            IF( ld_pnd_alb ) THEN 
     133               zafrac_pnd = MIN( pafrac_pnd(ji,jj,jl), 1._wp - zafrac_snw ) ! make sure (a_ip_eff + a_s_fra) <= 1 
    131134            ELSE 
    132                zafrac_snw = 1._wp      ! Snow fully "shades" melt ponds and ice 
    133135               zafrac_pnd = 0._wp 
    134                zafrac_ice = 0._wp 
    135             ENDIF 
    136             ! 
     136            ENDIF 
     137            zafrac_ice = MAX( 0._wp, 1._wp - zafrac_pnd - zafrac_snw ) ! max for roundoff errors 
     138            ! 
     139            !---------------! 
     140            !--- Albedos ---! 
     141            !---------------!                
    137142            !                       !--- Bare ice albedo (for hi > 150cm) 
    138143            IF( ld_pnd_alb ) THEN 
    139144               zalb_ice = rn_alb_idry 
    140145            ELSE 
    141                IF( ph_snw(ji,jj,jl) == 0._wp .AND. pt_su(ji,jj,jl) >= rt0 ) THEN  ;   zalb_ice = rn_alb_imlt 
    142                ELSE                                                               ;   zalb_ice = rn_alb_idry   ;   ENDIF 
     146               IF( ph_snw(ji,jj,jl) == 0._wp .AND. pt_su(ji,jj,jl) >= rt0 ) THEN   ;   zalb_ice = rn_alb_imlt 
     147               ELSE                                                                ;   zalb_ice = rn_alb_idry   ;   ENDIF 
    143148            ENDIF 
    144149            !                       !--- Bare ice albedo (for hi < 150cm) 
    … …  
    156161            ENDIF 
    157162            !                       !--- Ponded ice albedo 
    158             IF( ld_pnd_alb ) THEN 
    159                zalb_pnd = rn_alb_dpnd - ( rn_alb_dpnd - zalb_ice ) * EXP( - ph_pnd(ji,jj,jl) * z1_href_pnd )  
    160             ELSE 
    161                zalb_pnd = rn_alb_dpnd 
    162             ENDIF 
     163            zalb_pnd = rn_alb_dpnd - ( rn_alb_dpnd - zalb_ice ) * EXP( - ph_pnd(ji,jj,jl) * z1_href_pnd )  
     164            ! 
    163165            !                       !--- Surface albedo is weighted mean of snow, ponds and bare ice contributions 
    164             palb_os(ji,jj,jl) = ( zafrac_snw * zalb_snw + zafrac_pnd * zalb_pnd + zafrac_ice * zalb_ice ) * tmask(ji,jj,1) 
    165             ! 
    166             palb_cs(ji,jj,jl) = palb_os(ji,jj,jl)  & 
    167                &                - ( - 0.1010 * palb_os(ji,jj,jl) * palb_os(ji,jj,jl)  & 
    168                &                    + 0.1933 * palb_os(ji,jj,jl) - 0.0148 ) * tmask(ji,jj,1) 
    169             ! 
     166            zalb_os = ( zafrac_snw * zalb_snw + zafrac_pnd * zalb_pnd + zafrac_ice * zalb_ice ) * tmask(ji,jj,1) 
     167            ! 
     168            zalb_cs = zalb_os - ( - 0.1010 * zalb_os * zalb_os  & 
     169               &                  + 0.1933 * zalb_os - 0.0148 ) * tmask(ji,jj,1) 
     170            ! 
     171            ! albedo depends on cloud fraction because of non-linear spectral effects 
     172            palb_ice(ji,jj,jl) = ( 1._wp - pcloud_fra(ji,jj) ) * zalb_cs + pcloud_fra(ji,jj) * zalb_os 
     173 
    170174         END_2D 
    171175      END DO 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/ICE/icecor.F90

    r13295 r13571  
    8181      DO jl = 1, jpl 
    8282         WHERE( at_i(:,:) > rn_amax_2d(:,:) )   a_i(:,:,jl) = a_i(:,:,jl) * rn_amax_2d(:,:) / at_i(:,:) 
    83       END DO 
    84      
     83      END DO     
     84      !                             !----------------------------------------------------- 
     85      !                             !  Rebin categories with thickness out of bounds     ! 
     86      !                             !----------------------------------------------------- 
     87      IF ( jpl > 1 )   CALL ice_itd_reb( kt ) 
     88      ! 
    8589      !                             !----------------------------------------------------- 
    8690      IF ( nn_icesal == 2 ) THEN    !  salinity must stay in bounds [Simin,Simax]        ! 
    … …  
    96100      ENDIF 
    97101      !                             !----------------------------------------------------- 
    98       !                             !  Rebin categories with thickness out of bounds     ! 
    99       !                             !----------------------------------------------------- 
    100       IF ( jpl > 1 )   CALL ice_itd_reb( kt ) 
    101  
    102       !                             !----------------------------------------------------- 
    103102      CALL ice_var_zapsmall         !  Zap small values                                  ! 
    104103      !                             !----------------------------------------------------- 
    … …  
    106105      !                             !----------------------------------------------------- 
    107106      IF( kn == 2 ) THEN            !  Ice drift case: Corrections to avoid wrong values ! 
    108          DO_2D( 0, 0, 0, 0 ) 
     107         DO_2D( 0, 0, 0, 0 )        !----------------------------------------------------- 
    109108            IF ( at_i(ji,jj) == 0._wp ) THEN    ! what to do if there is no ice 
    110109               IF ( at_i(ji+1,jj) == 0._wp )   u_ice(ji  ,jj) = 0._wp   ! right side 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/ICE/icectl.F90

    r13295 r13571  
    350350      !!                   ***  ROUTINE ice_ctl ***  
    351351      !!                  
    352       !! ** Purpose :   Alerts in case of model crash 
     352      !! ** Purpose :   control checks 
    353353      !!------------------------------------------------------------------- 
    354354      INTEGER, INTENT(in) ::   kt      ! ocean time step 
    355       INTEGER  ::   ji, jj, jk,  jl   ! dummy loop indices 
    356       INTEGER  ::   inb_altests       ! number of alert tests (max 20) 
    357       INTEGER  ::   ialert_id         ! number of the current alert 
    358       REAL(wp) ::   ztmelts           ! ice layer melting point 
     355      INTEGER  ::   ja, ji, jj, jk, jl ! dummy loop indices 
     356      INTEGER  ::   ialert_id          ! number of the current alert 
     357      REAL(wp) ::   ztmelts            ! ice layer melting point 
    359358      CHARACTER (len=30), DIMENSION(20) ::   cl_alname   ! name of alert 
    360359      INTEGER           , DIMENSION(20) ::   inb_alp     ! number of alerts positive 
    361360      !!------------------------------------------------------------------- 
    362  
    363       inb_altests = 10 
    364       inb_alp(:)  =  0 
    365  
    366       ! Alert if incompatible volume and concentration 
    367       ialert_id = 2 ! reference number of this alert 
    368       cl_alname(ialert_id) = ' Incompat vol and con         '    ! name of the alert 
     361      inb_alp(:) = 0 
     362      ialert_id = 0 
     363       
     364      ! Alert if very high salinity 
     365      ialert_id = ialert_id + 1 ! reference number of this alert 
     366      cl_alname(ialert_id) = ' Very high salinity ' ! name of the alert 
    369367      DO jl = 1, jpl 
    370368         DO_2D( 1, 1, 1, 1 ) 
    371             IF(  v_i(ji,jj,jl) /= 0._wp   .AND.   a_i(ji,jj,jl) == 0._wp   ) THEN 
    372                WRITE(numout,*) ' ALERTE 2 :   Incompatible volume and concentration ' 
    373                inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
     369            IF( v_i(ji,jj,jl) > epsi10  ) THEN 
     370               IF( sv_i(ji,jj,jl) / v_i(ji,jj,jl) > rn_simax ) THEN 
     371                  WRITE(numout,*) ' ALERTE :   Very high salinity ',sv_i(ji,jj,jl)/v_i(ji,jj,jl) 
     372                  WRITE(numout,*) ' at i,j,l = ',ji,jj,jl 
     373                  inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
     374               ENDIF 
    374375            ENDIF 
    375376         END_2D 
    376377      END DO 
    377378 
    378       ! Alerte if very thick ice 
    379       ialert_id = 3 ! reference number of this alert 
    380       cl_alname(ialert_id) = ' Very thick ice               ' ! name of the alert 
    381       jl = jpl  
    382       DO_2D( 1, 1, 1, 1 ) 
    383          IF(   h_i(ji,jj,jl)  >  50._wp   ) THEN 
    384             WRITE(numout,*) ' ALERTE 3 :   Very thick ice' 
    385             !CALL ice_prt( kt, ji, jj, 2, ' ALERTE 3 :   Very thick ice ' ) 
    386             inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
    387          ENDIF 
    388       END_2D 
    389  
    390       ! Alert if very fast ice 
    391       ialert_id = 4 ! reference number of this alert 
    392       cl_alname(ialert_id) = ' Very fast ice               ' ! name of the alert 
    393       DO_2D( 1, 1, 1, 1 ) 
    394          IF(   MAX( ABS( u_ice(ji,jj) ), ABS( v_ice(ji,jj) ) ) > 2.  .AND.  & 
    395             &  at_i(ji,jj) > 0._wp   ) THEN 
    396             WRITE(numout,*) ' ALERTE 4 :   Very fast ice' 
    397             !CALL ice_prt( kt, ji, jj, 1, ' ALERTE 4 :   Very fast ice ' ) 
    398             inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
    399          ENDIF 
    400       END_2D 
    401  
    402       ! Alert on salt flux 
    403       ialert_id = 5 ! reference number of this alert 
    404       cl_alname(ialert_id) = ' High salt flux               ' ! name of the alert 
    405       DO_2D( 1, 1, 1, 1 ) 
    406          IF( ABS( sfx (ji,jj) ) > 1.0e-2 ) THEN  ! = 1 psu/day for 1m ocean depth 
    407             WRITE(numout,*) ' ALERTE 5 :   High salt flux' 
    408             !CALL ice_prt( kt, ji, jj, 3, ' ALERTE 5 :   High salt flux ' ) 
    409             inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
    410          ENDIF 
    411       END_2D 
    412  
    413       ! Alert if there is ice on continents 
    414       ialert_id = 6 ! reference number of this alert 
    415       cl_alname(ialert_id) = ' Ice on continents           ' ! name of the alert 
    416       DO_2D( 1, 1, 1, 1 ) 
    417          IF(   tmask(ji,jj,1) <= 0._wp   .AND.   at_i(ji,jj) > 0._wp   ) THEN  
    418             WRITE(numout,*) ' ALERTE 6 :   Ice on continents' 
    419             !CALL ice_prt( kt, ji, jj, 1, ' ALERTE 6 :   Ice on continents ' ) 
    420             inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
    421          ENDIF 
    422       END_2D 
    423  
    424 ! 
    425 !     ! Alert if very fresh ice 
    426       ialert_id = 7 ! reference number of this alert 
    427       cl_alname(ialert_id) = ' Very fresh ice               ' ! name of the alert 
     379      ! Alert if very low salinity 
     380      ialert_id = ialert_id + 1 ! reference number of this alert 
     381      cl_alname(ialert_id) = ' Very low salinity ' ! name of the alert 
    428382      DO jl = 1, jpl 
    429383         DO_2D( 1, 1, 1, 1 ) 
    430             IF( s_i(ji,jj,jl) < 0.1 .AND. a_i(ji,jj,jl) > 0._wp ) THEN 
    431                WRITE(numout,*) ' ALERTE 7 :   Very fresh ice' 
    432 !                 CALL ice_prt(kt,ji,jj,1, ' ALERTE 7 :   Very fresh ice ' ) 
    433                inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
     384            IF( v_i(ji,jj,jl) > epsi10  ) THEN 
     385               IF( sv_i(ji,jj,jl) / v_i(ji,jj,jl) < rn_simin ) THEN 
     386                  WRITE(numout,*) ' ALERTE :   Very low salinity ',sv_i(ji,jj,jl),v_i(ji,jj,jl) 
     387                  WRITE(numout,*) ' at i,j,l = ',ji,jj,jl 
     388                  inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
     389               ENDIF 
    434390            ENDIF 
    435391         END_2D 
    436392      END DO 
    437 ! 
    438       ! Alert if qns very big 
    439       ialert_id = 8 ! reference number of this alert 
    440       cl_alname(ialert_id) = ' fnsolar very big             ' ! name of the alert 
    441       DO_2D( 1, 1, 1, 1 ) 
    442          IF( ABS( qns(ji,jj) ) > 1500._wp .AND. at_i(ji,jj) > 0._wp ) THEN 
    443             ! 
    444             WRITE(numout,*) ' ALERTE 8 :   Very high non-solar heat flux' 
    445             !CALL ice_prt( kt, ji, jj, 2, '   ') 
    446             inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
    447             ! 
    448          ENDIF 
    449       END_2D 
    450       !+++++ 
    451  
    452 !     ! Alert if too old ice 
    453       ialert_id = 9 ! reference number of this alert 
    454       cl_alname(ialert_id) = ' Very old   ice               ' ! name of the alert 
    455       DO jl = 1, jpl 
    456          DO_2D( 1, 1, 1, 1 ) 
    457             IF ( ( ( ABS( o_i(ji,jj,jl) ) > rDt_ice ) .OR. & 
    458                    ( ABS( o_i(ji,jj,jl) ) < 0._wp) ) .AND. & 
    459                           ( a_i(ji,jj,jl) > 0._wp ) ) THEN 
    460                WRITE(numout,*) ' ALERTE 9 :   Wrong ice age' 
    461                !CALL ice_prt( kt, ji, jj, 1, ' ALERTE 9 :   Wrong ice age ') 
    462                inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
    463             ENDIF 
    464          END_2D 
    465       END DO 
    466    
    467       ! Alert if very warm ice 
    468       ialert_id = 10 ! reference number of this alert 
    469       cl_alname(ialert_id) = ' Very warm ice                ' ! name of the alert 
    470       inb_alp(ialert_id) = 0 
     393 
     394      ! Alert if very cold ice 
     395      ialert_id = ialert_id + 1 ! reference number of this alert 
     396      cl_alname(ialert_id) = ' Very cold ice ' ! name of the alert 
    471397      DO jl = 1, jpl 
    472398         DO_3D( 1, 1, 1, 1, 1, nlay_i ) 
    473399            ztmelts    =  -rTmlt * sz_i(ji,jj,jk,jl) + rt0 
    474             IF( t_i(ji,jj,jk,jl) > ztmelts  .AND.  v_i(ji,jj,jl) > 1.e-10   & 
    475                &                            .AND.  a_i(ji,jj,jl) > 0._wp   ) THEN 
    476                WRITE(numout,*) ' ALERTE 10 :   Very warm ice' 
     400            IF( t_i(ji,jj,jk,jl) < -50.+rt0  .AND.  v_i(ji,jj,jl) > epsi10 ) THEN 
     401               WRITE(numout,*) ' ALERTE :   Very cold ice ',(t_i(ji,jj,jk,jl)-rt0) 
     402               WRITE(numout,*) ' at i,j,k,l = ',ji,jj,jk,jl 
    477403              inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
    478404            ENDIF 
    479405         END_3D 
    480406      END DO 
     407   
     408      ! Alert if very warm ice 
     409      ialert_id = ialert_id + 1 ! reference number of this alert 
     410      cl_alname(ialert_id) = ' Very warm ice ' ! name of the alert 
     411      DO jl = 1, jpl 
     412         DO_3D( 1, 1, 1, 1, 1, nlay_i ) 
     413            ztmelts    =  -rTmlt * sz_i(ji,jj,jk,jl) + rt0 
     414            IF( t_i(ji,jj,jk,jl) > ztmelts  .AND.  v_i(ji,jj,jl) > epsi10 ) THEN 
     415               WRITE(numout,*) ' ALERTE :   Very warm ice',(t_i(ji,jj,jk,jl)-rt0) 
     416               WRITE(numout,*) ' at i,j,k,l = ',ji,jj,jk,jl 
     417              inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
     418            ENDIF 
     419         END_3D 
     420      END DO 
     421       
     422      ! Alerte if very thick ice 
     423      ialert_id = ialert_id + 1 ! reference number of this alert 
     424      cl_alname(ialert_id) = ' Very thick ice ' ! name of the alert 
     425      jl = jpl  
     426      DO_2D( 1, 1, 1, 1 ) 
     427         IF( h_i(ji,jj,jl) > 50._wp ) THEN 
     428            WRITE(numout,*) ' ALERTE :   Very thick ice ',h_i(ji,jj,jl) 
     429            WRITE(numout,*) ' at i,j,l = ',ji,jj,jl 
     430            inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
     431         ENDIF 
     432      END_2D 
     433 
     434      ! Alerte if very thin ice 
     435      ialert_id = ialert_id + 1 ! reference number of this alert 
     436      cl_alname(ialert_id) = ' Very thin ice ' ! name of the alert 
     437      jl = 1  
     438      DO_2D( 1, 1, 1, 1 ) 
     439         IF( h_i(ji,jj,jl) < rn_himin ) THEN 
     440            WRITE(numout,*) ' ALERTE :   Very thin ice ',h_i(ji,jj,jl) 
     441            WRITE(numout,*) ' at i,j,l = ',ji,jj,jl 
     442            inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
     443         ENDIF 
     444      END_2D 
     445 
     446      ! Alert if very fast ice 
     447      ialert_id = ialert_id + 1 ! reference number of this alert 
     448      cl_alname(ialert_id) = ' Very fast ice ' ! name of the alert 
     449      DO_2D( 1, 1, 1, 1 ) 
     450         IF( MAX( ABS( u_ice(ji,jj) ), ABS( v_ice(ji,jj) ) ) > 2. ) THEN 
     451            WRITE(numout,*) ' ALERTE :   Very fast ice ',MAX( ABS( u_ice(ji,jj) ), ABS( v_ice(ji,jj) ) ) 
     452            WRITE(numout,*) ' at i,j = ',ji,jj 
     453            inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
     454         ENDIF 
     455      END_2D 
     456 
     457      ! Alert if there is ice on continents 
     458      ialert_id = ialert_id + 1 ! reference number of this alert 
     459      cl_alname(ialert_id) = ' Ice on continents ' ! name of the alert 
     460      DO_2D( 1, 1, 1, 1 ) 
     461         IF( tmask(ji,jj,1) == 0._wp .AND. ( at_i(ji,jj) > 0._wp .OR. vt_i(ji,jj) > 0._wp ) ) THEN  
     462            WRITE(numout,*) ' ALERTE :   Ice on continents ',at_i(ji,jj),vt_i(ji,jj) 
     463            WRITE(numout,*) ' at i,j = ',ji,jj 
     464            inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
     465         ENDIF 
     466      END_2D 
     467 
     468      ! Alert if incompatible ice concentration and volume 
     469      ialert_id = ialert_id + 1 ! reference number of this alert 
     470      cl_alname(ialert_id) = ' Incompatible ice conc and vol ' ! name of the alert 
     471      DO_2D( 1, 1, 1, 1 ) 
     472         IF(  ( vt_i(ji,jj) == 0._wp .AND. at_i(ji,jj) >  0._wp ) .OR. & 
     473            & ( vt_i(ji,jj) >  0._wp .AND. at_i(ji,jj) == 0._wp ) ) THEN  
     474            WRITE(numout,*) ' ALERTE :   Incompatible ice conc and vol ',at_i(ji,jj),vt_i(ji,jj) 
     475            WRITE(numout,*) ' at i,j = ',ji,jj 
     476            inb_alp(ialert_id) = inb_alp(ialert_id) + 1 
     477         ENDIF 
     478      END_2D 
    481479 
    482480      ! sum of the alerts on all processors 
    483481      IF( lk_mpp ) THEN 
    484          DO ialert_id = 1, inb_altests 
    485             CALL mpp_sum('icectl', inb_alp(ialert_id)) 
     482         DO ja = 1, ialert_id 
     483            CALL mpp_sum('icectl', inb_alp(ja)) 
    486484         END DO 
    487485      ENDIF 
    … …  
    489487      ! print alerts 
    490488      IF( lwp ) THEN 
    491          ialert_id = 1                                 ! reference number of this alert 
    492          cl_alname(ialert_id) = ' NO alerte 1      '   ! name of the alert 
    493489         WRITE(numout,*) ' time step ',kt 
    494490         WRITE(numout,*) ' All alerts at the end of ice model ' 
    495          DO ialert_id = 1, inb_altests 
    496             WRITE(numout,*) ialert_id, cl_alname(ialert_id)//' : ', inb_alp(ialert_id), ' times ! ' 
     491         DO ja = 1, ialert_id 
     492            WRITE(numout,*) ja, cl_alname(ja)//' : ', inb_alp(ja), ' times ! ' 
    497493         END DO 
    498494      ENDIF 
    … …  
    543539               WRITE(numout,*) ' v_ice(i  ,j)  : ', v_ice(ji,jj) 
    544540               WRITE(numout,*) ' strength      : ', strength(ji,jj) 
    545                WRITE(numout,*) 
    546541               WRITE(numout,*) ' - Cell values ' 
    547542               WRITE(numout,*) '   ~~~~~~~~~~~ ' 
    … …  
    552547               DO jl = 1, jpl 
    553548                  WRITE(numout,*) ' - Category (', jl,')' 
     549                  WRITE(numout,*) '   ~~~~~~~~~~~ ' 
    554550                  WRITE(numout,*) ' a_i           : ', a_i(ji,jj,jl) 
    555551                  WRITE(numout,*) ' h_i           : ', h_i(ji,jj,jl) 
    … …  
    588584               WRITE(numout,*) ' v_ice(i  ,j)  : ', v_ice(ji,jj) 
    589585               WRITE(numout,*) ' strength      : ', strength(ji,jj) 
    590                WRITE(numout,*) ' u_ice_b       : ', u_ice_b(ji,jj)    , ' v_ice_b       : ', v_ice_b(ji,jj)   
    591586               WRITE(numout,*) 
    592587                
    … …  
    605600                  WRITE(numout,*) ' e_snow     : ', e_s(ji,jj,1,jl)            , ' e_snow_b   : ', e_s_b(ji,jj,1,jl)  
    606601                  WRITE(numout,*) ' sv_i       : ', sv_i(ji,jj,jl)             , ' sv_i_b     : ', sv_i_b(ji,jj,jl)    
    607                   WRITE(numout,*) ' oa_i       : ', oa_i(ji,jj,jl)             , ' oa_i_b     : ', oa_i_b(ji,jj,jl) 
    608602               END DO !jl 
    609603                
    … …  
    713707         CALL prt_ctl(tab2d_1=v_i        (:,:,jl)        , clinfo1= ' v_i         : ') 
    714708         CALL prt_ctl(tab2d_1=v_s        (:,:,jl)        , clinfo1= ' v_s         : ') 
    715          CALL prt_ctl(tab2d_1=e_i        (:,:,1,jl)      , clinfo1= ' e_i1        : ') 
    716709         CALL prt_ctl(tab2d_1=e_s        (:,:,1,jl)      , clinfo1= ' e_snow      : ') 
    717710         CALL prt_ctl(tab2d_1=sv_i       (:,:,jl)        , clinfo1= ' sv_i        : ') 
    … …  
    721714            CALL prt_ctl_info(' - Layer : ', ivar=jk) 
    722715            CALL prt_ctl(tab2d_1=t_i(:,:,jk,jl) , clinfo1= ' t_i       : ') 
     716            CALL prt_ctl(tab2d_1=e_i(:,:,jk,jl) , clinfo1= ' e_i       : ') 
    723717         END DO 
    724718      END DO 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/ICE/icedyn.F90

    r13295 r13571  
    100100      WHERE( a_ip(:,:,:) >= epsi20 ) 
    101101         h_ip(:,:,:) = v_ip(:,:,:) / a_ip(:,:,:) 
     102         h_il(:,:,:) = v_il(:,:,:) / a_ip(:,:,:) 
    102103      ELSEWHERE 
    103104         h_ip(:,:,:) = 0._wp 
     105         h_il(:,:,:) = 0._wp 
    104106      END WHERE 
    105107      ! 
    … …  
    127129         ! Then for dx = 2m and dt = 1s => rn_uice = u (1/6th) = 1m/s  
    128130         DO_2D( 1, 1, 1, 1 ) 
    129             zcoefu = ( REAL(jpiglo+1)*0.5 - REAL(ji+nimpp-1) ) / ( REAL(jpiglo+1)*0.5 - 1. ) 
    130             zcoefv = ( REAL(jpjglo+1)*0.5 - REAL(jj+njmpp-1) ) / ( REAL(jpjglo+1)*0.5 - 1. ) 
    131             u_ice(ji,jj) = rn_uice * 1.5 * SIGN( 1.0_wp, zcoefu ) * ABS( zcoefu ) * umask(ji,jj,1) 
    132             v_ice(ji,jj) = rn_vice * 1.5 * SIGN( 1.0_wp, zcoefv ) * ABS( zcoefv ) * vmask(ji,jj,1) 
     131            zcoefu = ( REAL(jpiglo+1)*0.5_wp - REAL(ji+nimpp-1) ) / ( REAL(jpiglo+1)*0.5_wp - 1._wp ) 
     132            zcoefv = ( REAL(jpjglo+1)*0.5_wp - REAL(jj+njmpp-1) ) / ( REAL(jpjglo+1)*0.5_wp - 1._wp ) 
     133            u_ice(ji,jj) = rn_uice * 1.5_wp * SIGN( 1.0_wp, zcoefu ) * ABS( zcoefu ) * umask(ji,jj,1) 
     134            v_ice(ji,jj) = rn_vice * 1.5_wp * SIGN( 1.0_wp, zcoefv ) * ABS( zcoefv ) * vmask(ji,jj,1) 
    133135         END_2D 
    134136         ! --- 
    … …  
    218220      NAMELIST/namdyn/ ln_dynALL, ln_dynRHGADV, ln_dynADV1D, ln_dynADV2D, rn_uice, rn_vice,  & 
    219221         &             rn_ishlat ,                                                           & 
    220          &             ln_landfast_L16, rn_depfra, rn_icebfr, rn_lfrelax, rn_tensile 
     222         &             ln_landfast_L16, rn_lf_depfra, rn_lf_bfr, rn_lf_relax, rn_lf_tensile 
    221223      !!------------------------------------------------------------------- 
    222224      ! 
    … …  
    239241         WRITE(numout,*) '      lateral boundary condition for sea ice dynamics        rn_ishlat       = ', rn_ishlat 
    240242         WRITE(numout,*) '      Landfast: param from Lemieux 2016                      ln_landfast_L16 = ', ln_landfast_L16 
    241          WRITE(numout,*) '         fraction of ocean depth that ice must reach         rn_depfra       = ', rn_depfra 
    242          WRITE(numout,*) '         maximum bottom stress per unit area of contact      rn_icebfr       = ', rn_icebfr 
    243          WRITE(numout,*) '         relax time scale (s-1) to reach static friction     rn_lfrelax      = ', rn_lfrelax 
    244          WRITE(numout,*) '         isotropic tensile strength                          rn_tensile      = ', rn_tensile 
     243         WRITE(numout,*) '         fraction of ocean depth that ice must reach         rn_lf_depfra    = ', rn_lf_depfra 
     244         WRITE(numout,*) '         maximum bottom stress per unit area of contact      rn_lf_bfr       = ', rn_lf_bfr 
     245         WRITE(numout,*) '         relax time scale (s-1) to reach static friction     rn_lf_relax     = ', rn_lf_relax 
     246         WRITE(numout,*) '         isotropic tensile strength                          rn_lf_tensile   = ', rn_lf_tensile 
    245247         WRITE(numout,*) 
    246248      ENDIF 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/ICE/icedyn_adv.F90

    r12489 r13571  
    8282         !                             !-----------------------! 
    8383         CALL ice_dyn_adv_umx( nn_UMx, kt, u_ice, v_ice, h_i, h_s, h_ip, & 
    84             &                          ato_i, v_i, v_s, sv_i, oa_i, a_i, a_ip, v_ip, e_s, e_i ) 
     84            &                          ato_i, v_i, v_s, sv_i, oa_i, a_i, a_ip, v_ip, v_il, e_s, e_i ) 
    8585         !                             !-----------------------! 
    8686      CASE( np_advPRA )                ! PRATHER scheme        ! 
    8787         !                             !-----------------------! 
    8888         CALL ice_dyn_adv_pra(         kt, u_ice, v_ice, h_i, h_s, h_ip, & 
    89             &                          ato_i, v_i, v_s, sv_i, oa_i, a_i, a_ip, v_ip, e_s, e_i ) 
     89            &                          ato_i, v_i, v_s, sv_i, oa_i, a_i, a_ip, v_ip, v_il, e_s, e_i ) 
    9090      END SELECT 
    9191 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/ICE/icedyn_adv_pra.F90

    r13295 r13571  
    4444   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   sxap , syap , sxxap , syyap , sxyap    ! melt pond fraction 
    4545   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   sxvp , syvp , sxxvp , syyvp , sxyvp    ! melt pond volume 
     46   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   sxvl , syvl , sxxvl , syyvl , sxyvl    ! melt pond lid volume 
    4647 
    4748   !! * Substitutions 
    … …  
    5556 
    5657   SUBROUTINE ice_dyn_adv_pra(         kt, pu_ice, pv_ice, ph_i, ph_s, ph_ip,  & 
    57       &                        pato_i, pv_i, pv_s, psv_i, poa_i, pa_i, pa_ip, pv_ip, pe_s, pe_i ) 
     58      &                        pato_i, pv_i, pv_s, psv_i, poa_i, pa_i, pa_ip, pv_ip, pv_il, pe_s, pe_i ) 
    5859      !!---------------------------------------------------------------------- 
    5960      !!                **  routine ice_dyn_adv_pra  ** 
    … …  
    8182      REAL(wp), DIMENSION(:,:,:)  , INTENT(inout) ::   pa_ip      ! melt pond fraction 
    8283      REAL(wp), DIMENSION(:,:,:)  , INTENT(inout) ::   pv_ip      ! melt pond volume 
     84      REAL(wp), DIMENSION(:,:,:)  , INTENT(inout) ::   pv_il      ! melt pond lid thickness 
    8385      REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) ::   pe_s       ! snw heat content 
    8486      REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) ::   pe_i       ! ice heat content 
    8587      ! 
    86       INTEGER  ::   ji,jj, jk, jl, jt       ! dummy loop indices 
     88      INTEGER  ::   ji, jj, jk, jl, jt      ! dummy loop indices 
    8789      INTEGER  ::   icycle                  ! number of sub-timestep for the advection 
    8890      REAL(wp) ::   zdt                     !   -      - 
    … …  
    9092      REAL(wp), DIMENSION(jpi,jpj)            ::   zati1, zati2 
    9193      REAL(wp), DIMENSION(jpi,jpj)            ::   zudy, zvdx 
    92       REAL(wp), DIMENSION(jpi,jpj,jpl)        ::   zhi_max, zhs_max, zhip_max 
     94      REAL(wp), DIMENSION(jpi,jpj,jpl)        ::   zhi_max, zhs_max, zhip_max, zs_i, zsi_max 
     95      REAL(wp), DIMENSION(jpi,jpj,nlay_i,jpl) ::   ze_i, zei_max 
     96      REAL(wp), DIMENSION(jpi,jpj,nlay_s,jpl) ::   ze_s, zes_max 
    9397      REAL(wp), DIMENSION(jpi,jpj,jpl)        ::   zarea 
    9498      REAL(wp), DIMENSION(jpi,jpj,jpl)        ::   z0ice, z0snw, z0ai, z0smi, z0oi 
    95       REAL(wp), DIMENSION(jpi,jpj,jpl)        ::   z0ap , z0vp 
     99      REAL(wp), DIMENSION(jpi,jpj,jpl)        ::   z0ap , z0vp, z0vl 
    96100      REAL(wp), DIMENSION(jpi,jpj,nlay_s,jpl) ::   z0es 
    97101      REAL(wp), DIMENSION(jpi,jpj,nlay_i,jpl) ::   z0ei 
    … …  
    100104      IF( kt == nit000 .AND. lwp )   WRITE(numout,*) '-- ice_dyn_adv_pra: Prather advection scheme' 
    101105      ! 
    102       ! --- Record max of the surrounding 9-pts ice thick. (for call Hbig) --- ! 
     106      ! --- Record max of the surrounding 9-pts (for call Hbig) --- ! 
     107      ! thickness and salinity 
     108      WHERE( pv_i(:,:,:) >= epsi10 ) ; zs_i(:,:,:) = psv_i(:,:,:) / pv_i(:,:,:) 
     109      ELSEWHERE                      ; zs_i(:,:,:) = 0._wp 
     110      END WHERE 
    103111      DO jl = 1, jpl 
    104112         DO_2D( 0, 0, 0, 0 ) 
    … …  
    115123               &                                               ph_s (ji+1,jj+1,jl), ph_s (ji-1,jj-1,jl), & 
    116124               &                                               ph_s (ji+1,jj-1,jl), ph_s (ji-1,jj+1,jl) ) 
     125            zsi_max (ji,jj,jl) = MAX( epsi20, zs_i (ji,jj,jl), zs_i (ji+1,jj  ,jl), zs_i (ji  ,jj+1,jl), & 
     126               &                                               zs_i (ji-1,jj  ,jl), zs_i (ji  ,jj-1,jl), & 
     127               &                                               zs_i (ji+1,jj+1,jl), zs_i (ji-1,jj-1,jl), & 
     128               &                                               zs_i (ji+1,jj-1,jl), zs_i (ji-1,jj+1,jl) ) 
    117129         END_2D 
    118130      END DO 
    119       CALL lbc_lnk_multi( 'icedyn_adv_pra', zhi_max, 'T', 1.0_wp, zhs_max, 'T', 1.0_wp, zhip_max, 'T', 1.0_wp ) 
     131      CALL lbc_lnk_multi( 'icedyn_adv_pra', zhi_max, 'T', 1._wp, zhs_max, 'T', 1._wp, zhip_max, 'T', 1._wp, zsi_max, 'T', 1._wp ) 
     132      ! 
     133      ! enthalpies 
     134      DO jk = 1, nlay_i 
     135         WHERE( pv_i(:,:,:) >= epsi10 ) ; ze_i(:,:,jk,:) = pe_i(:,:,jk,:) / pv_i(:,:,:) 
     136         ELSEWHERE                      ; ze_i(:,:,jk,:) = 0._wp 
     137         END WHERE 
     138      END DO 
     139      DO jk = 1, nlay_s 
     140         WHERE( pv_s(:,:,:) >= epsi10 ) ; ze_s(:,:,jk,:) = pe_s(:,:,jk,:) / pv_s(:,:,:) 
     141         ELSEWHERE                      ; ze_s(:,:,jk,:) = 0._wp 
     142         END WHERE 
     143      END DO 
     144      DO jl = 1, jpl 
     145         DO_3D( 0, 0, 0, 0, 1, nlay_i ) 
     146            zei_max(ji,jj,jk,jl) = MAX( epsi20, ze_i(ji,jj,jk,jl), ze_i(ji+1,jj  ,jk,jl), ze_i(ji  ,jj+1,jk,jl), & 
     147               &                                                   ze_i(ji-1,jj  ,jk,jl), ze_i(ji  ,jj-1,jk,jl), & 
     148               &                                                   ze_i(ji+1,jj+1,jk,jl), ze_i(ji-1,jj-1,jk,jl), & 
     149               &                                                   ze_i(ji+1,jj-1,jk,jl), ze_i(ji-1,jj+1,jk,jl) ) 
     150         END_3D 
     151      END DO 
     152      DO jl = 1, jpl 
     153         DO_3D( 0, 0, 0, 0, 1, nlay_s ) 
     154            zes_max(ji,jj,jk,jl) = MAX( epsi20, ze_s(ji,jj,jk,jl), ze_s(ji+1,jj  ,jk,jl), ze_s(ji  ,jj+1,jk,jl), & 
     155               &                                                   ze_s(ji-1,jj  ,jk,jl), ze_s(ji  ,jj-1,jk,jl), & 
     156               &                                                   ze_s(ji+1,jj+1,jk,jl), ze_s(ji-1,jj-1,jk,jl), & 
     157               &                                                   ze_s(ji+1,jj-1,jk,jl), ze_s(ji-1,jj+1,jk,jl) ) 
     158         END_3D 
     159      END DO 
     160      CALL lbc_lnk( 'icedyn_adv_pra', zei_max, 'T', 1. ) 
     161      CALL lbc_lnk( 'icedyn_adv_pra', zes_max, 'T', 1. ) 
     162      ! 
    120163      ! 
    121164      ! --- If ice drift is too fast, use  subtime steps for advection (CFL test for stability) --- ! 
    … …  
    156199               z0ei(:,:,jk,jl) = pe_i(:,:,jk,jl) * e1e2t(:,:) ! Ice  heat content 
    157200            END DO 
    158             IF ( ln_pnd_H12 ) THEN 
    159                z0ap(:,:,jl)  = pa_ip(:,:,jl) * e1e2t(:,:)     ! Melt pond fraction 
    160                z0vp(:,:,jl)  = pv_ip(:,:,jl) * e1e2t(:,:)     ! Melt pond volume 
     201            IF ( ln_pnd_LEV ) THEN 
     202               z0ap(:,:,jl) = pa_ip(:,:,jl) * e1e2t(:,:)      ! Melt pond fraction 
     203               z0vp(:,:,jl) = pv_ip(:,:,jl) * e1e2t(:,:)      ! Melt pond volume 
     204               IF ( ln_pnd_lids ) THEN 
     205                  z0vl(:,:,jl) = pv_il(:,:,jl) * e1e2t(:,:)   ! Melt pond lid volume 
     206               ENDIF 
    161207            ENDIF 
    162208         END DO 
    … …  
    189235            END DO 
    190236            ! 
    191             IF ( ln_pnd_H12 ) THEN 
     237            IF ( ln_pnd_LEV ) THEN 
    192238               CALL adv_x( zdt , zudy , 1._wp , zarea , z0ap , sxap , sxxap , syap , syyap , sxyap )    !--- melt pond fraction 
    193239               CALL adv_y( zdt , zvdx , 0._wp , zarea , z0ap , sxap , sxxap , syap , syyap , sxyap )  
    194240               CALL adv_x( zdt , zudy , 1._wp , zarea , z0vp , sxvp , sxxvp , syvp , syyvp , sxyvp )    !--- melt pond volume 
    195241               CALL adv_y( zdt , zvdx , 0._wp , zarea , z0vp , sxvp , sxxvp , syvp , syyvp , sxyvp )  
     242               IF ( ln_pnd_lids ) THEN 
     243                  CALL adv_x( zdt , zudy , 1._wp , zarea , z0vl , sxvl , sxxvl , syvl , syyvl , sxyvl ) !--- melt pond lid volume 
     244                  CALL adv_y( zdt , zvdx , 0._wp , zarea , z0vl , sxvl , sxxvl , syvl , syyvl , sxyvl )  
     245               ENDIF 
    196246            ENDIF 
    197247            !                                                               !--------------------------------------------! 
    … …  
    220270                  &                                 sxxe(:,:,jk,:), sye(:,:,jk,:), syye(:,:,jk,:), sxye(:,:,jk,:) ) 
    221271            END DO 
    222             IF ( ln_pnd_H12 ) THEN 
     272            IF ( ln_pnd_LEV ) THEN 
    223273               CALL adv_y( zdt , zvdx , 1._wp , zarea , z0ap , sxap , sxxap , syap , syyap , sxyap )    !--- melt pond fraction 
    224274               CALL adv_x( zdt , zudy , 0._wp , zarea , z0ap , sxap , sxxap , syap , syyap , sxyap ) 
    225275               CALL adv_y( zdt , zvdx , 1._wp , zarea , z0vp , sxvp , sxxvp , syvp , syyvp , sxyvp )    !--- melt pond volume 
    226276               CALL adv_x( zdt , zudy , 0._wp , zarea , z0vp , sxvp , sxxvp , syvp , syyvp , sxyvp ) 
    227             ENDIF 
     277               IF ( ln_pnd_lids ) THEN 
     278                  CALL adv_y( zdt , zvdx , 1._wp , zarea , z0vl , sxvl , sxxvl , syvl , syyvl , sxyvl ) !--- melt pond lid volume 
     279                  CALL adv_x( zdt , zudy , 0._wp , zarea , z0vl , sxvl , sxxvl , syvl , syyvl , sxyvl )  
     280               ENDIF 
     281           ENDIF 
    228282            ! 
    229283         ENDIF 
    … …  
    242296               pe_i(:,:,jk,jl) = z0ei(:,:,jk,jl) * r1_e1e2t(:,:) * tmask(:,:,1) 
    243297            END DO 
    244             IF ( ln_pnd_H12 ) THEN 
     298            IF ( ln_pnd_LEV ) THEN 
    245299               pa_ip(:,:,jl) = z0ap(:,:,jl) * r1_e1e2t(:,:) * tmask(:,:,1) 
    246300               pv_ip(:,:,jl) = z0vp(:,:,jl) * r1_e1e2t(:,:) * tmask(:,:,1) 
     301               IF ( ln_pnd_lids ) THEN 
     302                  pv_il(:,:,jl) = z0vl(:,:,jl) * r1_e1e2t(:,:) * tmask(:,:,1) 
     303               ENDIF 
    247304            ENDIF 
    248305         END DO 
    … …  
    259316         !     Remove negative values (conservation is ensured) 
    260317         !     (because advected fields are not perfectly bounded and tiny negative values can occur, e.g. -1.e-20) 
    261          CALL ice_var_zapneg( zdt, pato_i, pv_i, pv_s, psv_i, poa_i, pa_i, pa_ip, pv_ip, pe_s, pe_i ) 
     318         CALL ice_var_zapneg( zdt, pato_i, pv_i, pv_s, psv_i, poa_i, pa_i, pa_ip, pv_ip, pv_il, pe_s, pe_i ) 
    262319         ! 
    263320         ! --- Make sure ice thickness is not too big --- ! 
    264321         !     (because ice thickness can be too large where ice concentration is very small) 
    265          CALL Hbig( zdt, zhi_max, zhs_max, zhip_max, pv_i, pv_s, pa_i, pa_ip, pv_ip, pe_s ) 
     322         CALL Hbig( zdt, zhi_max, zhs_max, zhip_max, zsi_max, zes_max, zei_max, & 
     323            &            pv_i, pv_s, pa_i, pa_ip, pv_ip, psv_i, pe_s, pe_i ) 
    266324         ! 
    267325         ! --- Ensure snow load is not too big --- ! 
    … …  
    325383 
    326384         !  Calculate fluxes and moments between boxes i<-->i+1               
    327          DO_2D( 0, 0, 1, 1 ) 
     385         DO_2D( 0, 0, 1, 1 )                   !  Flux from i to i+1 WHEN u GT 0 
    328386            zbet(ji,jj)  =  MAX( 0._wp, SIGN( 1._wp, put(ji,jj) ) ) 
    329387            zalf         =  MAX( 0._wp, put(ji,jj) ) * pdt / psm(ji,jj,jl) 
    … …  
    350408         END_2D 
    351409 
    352          DO_2D( 0, 0, 1, 0 ) 
     410         DO_2D( 0, 0, 1, 0 )                   !  Flux from i+1 to i when u LT 0. 
    353411            zalf          = MAX( 0._wp, -put(ji,jj) ) * pdt / psm(ji+1,jj,jl)  
    354412            zalg  (ji,jj) = zalf 
    … …  
    369427         END_2D 
    370428 
    371          DO_2D( 0, 0, 0, 0 ) 
     429         DO_2D( 0, 0, 0, 0 )                   !  Readjust moments remaining in the box. 
    372430            zbt  =       zbet(ji-1,jj) 
    373431            zbt1 = 1.0 - zbet(ji-1,jj) 
    … …  
    383441 
    384442         !   Put the temporary moments into appropriate neighboring boxes.     
    385          DO_2D( 0, 0, 0, 0 ) 
     443         DO_2D( 0, 0, 0, 0 )                   !   Flux from i to i+1 IF u GT 0. 
    386444            zbt  =       zbet(ji-1,jj) 
    387445            zbt1 = 1.0 - zbet(ji-1,jj) 
    … …  
    403461         END_2D 
    404462 
    405          DO_2D( 0, 0, 0, 0 ) 
     463         DO_2D( 0, 0, 0, 0 )                   !  Flux from i+1 to i IF u LT 0. 
    406464            zbt  =       zbet(ji,jj) 
    407465            zbt1 = 1.0 - zbet(ji,jj) 
    … …  
    482540  
    483541         !  Calculate fluxes and moments between boxes j<-->j+1               
    484          DO_2D( 1, 1, 0, 0 ) 
     542         DO_2D( 1, 1, 0, 0 )                   !  Flux from j to j+1 WHEN v GT 0 
    485543            zbet(ji,jj)  =  MAX( 0._wp, SIGN( 1._wp, pvt(ji,jj) ) ) 
    486544            zalf         =  MAX( 0._wp, pvt(ji,jj) ) * pdt / psm(ji,jj,jl) 
    … …  
    507565         END_2D 
    508566         ! 
    509          DO_2D( 1, 0, 0, 0 ) 
     567         DO_2D( 1, 0, 0, 0 )                   !  Flux from j+1 to j when v LT 0. 
    510568            zalf          = MAX( 0._wp, -pvt(ji,jj) ) * pdt / psm(ji,jj+1,jl)  
    511569            zalg  (ji,jj) = zalf 
    … …  
    541599 
    542600         !   Put the temporary moments into appropriate neighboring boxes.     
    543          DO_2D( 0, 0, 0, 0 ) 
     601         DO_2D( 0, 0, 0, 0 )                   !  Flux from j to j+1 IF v GT 0. 
    544602            zbt  =       zbet(ji,jj-1) 
    545603            zbt1 = 1.0 - zbet(ji,jj-1) 
    … …  
    562620         END_2D 
    563621 
    564          DO_2D( 0, 0, 0, 0 ) 
     622         DO_2D( 0, 0, 0, 0 )                   !  Flux from j+1 to j IF v LT 0. 
    565623            zbt  =       zbet(ji,jj) 
    566624            zbt1 = 1.0 - zbet(ji,jj) 
    … …  
    591649 
    592650 
    593    SUBROUTINE Hbig( pdt, phi_max, phs_max, phip_max, pv_i, pv_s, pa_i, pa_ip, pv_ip, pe_s ) 
     651   SUBROUTINE Hbig( pdt, phi_max, phs_max, phip_max, psi_max, pes_max, pei_max, & 
     652      &                  pv_i, pv_s, pa_i, pa_ip, pv_ip, psv_i, pe_s, pe_i ) 
    594653      !!------------------------------------------------------------------- 
    595654      !!                  ***  ROUTINE Hbig  *** 
    … …  
    605664      !! ** input   : Max thickness of the surrounding 9-points 
    606665      !!------------------------------------------------------------------- 
    607       REAL(wp)                    , INTENT(in   ) ::   pdt                          ! tracer time-step 
    608       REAL(wp), DIMENSION(:,:,:)  , INTENT(in   ) ::   phi_max, phs_max, phip_max   ! max ice thick from surrounding 9-pts 
    609       REAL(wp), DIMENSION(:,:,:)  , INTENT(inout) ::   pv_i, pv_s, pa_i, pa_ip, pv_ip 
     666      REAL(wp)                    , INTENT(in   ) ::   pdt                                   ! tracer time-step 
     667      REAL(wp), DIMENSION(:,:,:)  , INTENT(in   ) ::   phi_max, phs_max, phip_max, psi_max   ! max ice thick from surrounding 9-pts 
     668      REAL(wp), DIMENSION(:,:,:,:), INTENT(in   ) ::   pes_max 
     669      REAL(wp), DIMENSION(:,:,:,:), INTENT(in   ) ::   pei_max 
     670      REAL(wp), DIMENSION(:,:,:)  , INTENT(inout) ::   pv_i, pv_s, pa_i, pa_ip, pv_ip, psv_i 
    610671      REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) ::   pe_s 
    611       ! 
    612       INTEGER  ::   ji, jj, jl         ! dummy loop indices 
    613       REAL(wp) ::   z1_dt, zhip, zhi, zhs, zfra 
     672      REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) ::   pe_i 
     673      ! 
     674      INTEGER  ::   ji, jj, jk, jl         ! dummy loop indices 
     675      REAL(wp) ::   z1_dt, zhip, zhi, zhs, zsi, zes, zei, zfra 
    614676      !!------------------------------------------------------------------- 
    615677      ! 
    … …  
    617679      ! 
    618680      DO jl = 1, jpl 
    619  
    620681         DO_2D( 1, 1, 1, 1 ) 
    621682            IF ( pv_i(ji,jj,jl) > 0._wp ) THEN 
    … …  
    623684               !                               ! -- check h_ip -- ! 
    624685               ! if h_ip is larger than the surrounding 9 pts => reduce h_ip and increase a_ip 
    625                IF( ln_pnd_H12 .AND. pv_ip(ji,jj,jl) > 0._wp ) THEN 
     686               IF( ln_pnd_LEV .AND. pv_ip(ji,jj,jl) > 0._wp ) THEN 
    626687                  zhip = pv_ip(ji,jj,jl) / MAX( epsi20, pa_ip(ji,jj,jl) ) 
    627688                  IF( zhip > phip_max(ji,jj,jl) .AND. pa_ip(ji,jj,jl) < 0.15 ) THEN 
    … …  
    650711               ENDIF            
    651712               !                   
     713               !                               ! -- check s_i -- ! 
     714               ! if s_i is larger than the surrounding 9 pts => put salt excess in the ocean 
     715               zsi = psv_i(ji,jj,jl) / pv_i(ji,jj,jl) 
     716               IF( zsi > psi_max(ji,jj,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 
     717                  zfra = psi_max(ji,jj,jl) / zsi 
     718                  sfx_res(ji,jj) = sfx_res(ji,jj) + psv_i(ji,jj,jl) * ( 1._wp - zfra ) * rhoi * z1_dt 
     719                  psv_i(ji,jj,jl) = psv_i(ji,jj,jl) * zfra 
     720               ENDIF 
     721               ! 
    652722            ENDIF 
    653723         END_2D 
    654724      END DO  
     725      ! 
     726      !                                           ! -- check e_i/v_i -- ! 
     727      DO jl = 1, jpl 
     728         DO_3D( 1, 1, 1, 1, 1, nlay_i ) 
     729            IF ( pv_i(ji,jj,jl) > 0._wp ) THEN 
     730               ! if e_i/v_i is larger than the surrounding 9 pts => put the heat excess in the ocean 
     731               zei = pe_i(ji,jj,jk,jl) / pv_i(ji,jj,jl) 
     732               IF( zei > pei_max(ji,jj,jk,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 
     733                  zfra = pei_max(ji,jj,jk,jl) / zei 
     734                  hfx_res(ji,jj) = hfx_res(ji,jj) - pe_i(ji,jj,jk,jl) * ( 1._wp - zfra ) * z1_dt ! W.m-2 <0 
     735                  pe_i(ji,jj,jk,jl) = pe_i(ji,jj,jk,jl) * zfra 
     736               ENDIF 
     737            ENDIF 
     738         END_3D 
     739      END DO 
     740      !                                           ! -- check e_s/v_s -- ! 
     741      DO jl = 1, jpl 
     742         DO_3D( 1, 1, 1, 1, 1, nlay_s ) 
     743            IF ( pv_s(ji,jj,jl) > 0._wp ) THEN 
     744               ! if e_s/v_s is larger than the surrounding 9 pts => put the heat excess in the ocean 
     745               zes = pe_s(ji,jj,jk,jl) / pv_s(ji,jj,jl) 
     746               IF( zes > pes_max(ji,jj,jk,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 
     747                  zfra = pes_max(ji,jj,jk,jl) / zes 
     748                  hfx_res(ji,jj) = hfx_res(ji,jj) - pe_s(ji,jj,jk,jl) * ( 1._wp - zfra ) * z1_dt ! W.m-2 <0 
     749                  pe_s(ji,jj,jk,jl) = pe_s(ji,jj,jk,jl) * zfra 
     750               ENDIF 
     751            ENDIF 
     752         END_3D 
     753      END DO 
    655754      ! 
    656755   END SUBROUTINE Hbig 
    … …  
    724823         &      sxsal(jpi,jpj,jpl) , sysal(jpi,jpj,jpl) , sxxsal(jpi,jpj,jpl) , syysal(jpi,jpj,jpl) , sxysal(jpi,jpj,jpl) ,   & 
    725824         &      sxage(jpi,jpj,jpl) , syage(jpi,jpj,jpl) , sxxage(jpi,jpj,jpl) , syyage(jpi,jpj,jpl) , sxyage(jpi,jpj,jpl) ,   & 
    726          &      sxap(jpi,jpj,jpl)  , syap (jpi,jpj,jpl) , sxxap (jpi,jpj,jpl) , syyap (jpi,jpj,jpl) , sxyap (jpi,jpj,jpl) ,   & 
    727          &      sxvp(jpi,jpj,jpl)  , syvp (jpi,jpj,jpl) , sxxvp (jpi,jpj,jpl) , syyvp (jpi,jpj,jpl) , sxyvp (jpi,jpj,jpl) ,   & 
     825         &      sxap (jpi,jpj,jpl) , syap (jpi,jpj,jpl) , sxxap (jpi,jpj,jpl) , syyap (jpi,jpj,jpl) , sxyap (jpi,jpj,jpl) ,   & 
     826         &      sxvp (jpi,jpj,jpl) , syvp (jpi,jpj,jpl) , sxxvp (jpi,jpj,jpl) , syyvp (jpi,jpj,jpl) , sxyvp (jpi,jpj,jpl) ,   & 
     827         &      sxvl (jpi,jpj,jpl) , syvl (jpi,jpj,jpl) , sxxvl (jpi,jpj,jpl) , syyvl (jpi,jpj,jpl) , sxyvl (jpi,jpj,jpl) ,   & 
    728828         ! 
    729829         &      sxc0 (jpi,jpj,nlay_s,jpl) , syc0 (jpi,jpj,nlay_s,jpl) , sxxc0(jpi,jpj,nlay_s,jpl) , & 
    … …  
    820920            END DO 
    821921            ! 
    822             IF( ln_pnd_H12 ) THEN                                    ! melt pond fraction 
    823                CALL iom_get( numrir, jpdom_auto, 'sxap' , sxap  ) 
    824                CALL iom_get( numrir, jpdom_auto, 'syap' , syap  ) 
    825                CALL iom_get( numrir, jpdom_auto, 'sxxap', sxxap ) 
    826                CALL iom_get( numrir, jpdom_auto, 'syyap', syyap ) 
    827                CALL iom_get( numrir, jpdom_auto, 'sxyap', sxyap ) 
    828                !                                                     ! melt pond volume 
    829                CALL iom_get( numrir, jpdom_auto, 'sxvp' , sxvp  ) 
    830                CALL iom_get( numrir, jpdom_auto, 'syvp' , syvp  ) 
    831                CALL iom_get( numrir, jpdom_auto, 'sxxvp', sxxvp ) 
    832                CALL iom_get( numrir, jpdom_auto, 'syyvp', syyvp ) 
    833                CALL iom_get( numrir, jpdom_auto, 'sxyvp', sxyvp ) 
     922            IF( ln_pnd_LEV ) THEN                                    ! melt pond fraction 
     923               IF( iom_varid( numror, 'sxap', ldstop = .FALSE. ) > 0 ) THEN 
     924                  CALL iom_get( numrir, jpdom_auto, 'sxap' , sxap  ) 
     925                  CALL iom_get( numrir, jpdom_auto, 'syap' , syap  ) 
     926                  CALL iom_get( numrir, jpdom_auto, 'sxxap', sxxap ) 
     927                  CALL iom_get( numrir, jpdom_auto, 'syyap', syyap ) 
     928                  CALL iom_get( numrir, jpdom_auto, 'sxyap', sxyap ) 
     929                  !                                                     ! melt pond volume 
     930                  CALL iom_get( numrir, jpdom_auto, 'sxvp' , sxvp  ) 
     931                  CALL iom_get( numrir, jpdom_auto, 'syvp' , syvp  ) 
     932                  CALL iom_get( numrir, jpdom_auto, 'sxxvp', sxxvp ) 
     933                  CALL iom_get( numrir, jpdom_auto, 'syyvp', syyvp ) 
     934                  CALL iom_get( numrir, jpdom_auto, 'sxyvp', sxyvp ) 
     935               ELSE 
     936                  sxap = 0._wp ;   syap = 0._wp    ;   sxxap = 0._wp    ;   syyap = 0._wp    ;   sxyap = 0._wp   ! melt pond fraction 
     937                  sxvp = 0._wp ;   syvp = 0._wp    ;   sxxvp = 0._wp    ;   syyvp = 0._wp    ;   sxyvp = 0._wp   ! melt pond volume 
     938               ENDIF 
     939                  ! 
     940               IF ( ln_pnd_lids ) THEN                               ! melt pond lid volume 
     941                  IF( iom_varid( numror, 'sxvl', ldstop = .FALSE. ) > 0 ) THEN 
     942                     CALL iom_get( numrir, jpdom_auto, 'sxvl' , sxvl  ) 
     943                     CALL iom_get( numrir, jpdom_auto, 'syvl' , syvl  ) 
     944                     CALL iom_get( numrir, jpdom_auto, 'sxxvl', sxxvl ) 
     945                     CALL iom_get( numrir, jpdom_auto, 'syyvl', syyvl ) 
     946                     CALL iom_get( numrir, jpdom_auto, 'sxyvl', sxyvl ) 
     947                  ELSE 
     948                     sxvl = 0._wp; syvl = 0._wp    ;   sxxvl = 0._wp    ;   syyvl = 0._wp    ;   sxyvl = 0._wp   ! melt pond lid volume 
     949                  ENDIF 
     950               ENDIF 
    834951            ENDIF 
    835952            ! 
    … …  
    845962            sxc0  = 0._wp   ;   syc0  = 0._wp   ;   sxxc0  = 0._wp   ;   syyc0  = 0._wp   ;   sxyc0  = 0._wp      ! snow layers heat content 
    846963            sxe   = 0._wp   ;   sye   = 0._wp   ;   sxxe   = 0._wp   ;   syye   = 0._wp   ;   sxye   = 0._wp      ! ice layers heat content 
    847             IF( ln_pnd_H12 ) THEN 
    848                sxap  = 0._wp   ;   syap  = 0._wp   ;   sxxap  = 0._wp   ;   syyap  = 0._wp   ;   sxyap  = 0._wp   ! melt pond fraction 
    849                sxvp  = 0._wp   ;   syvp  = 0._wp   ;   sxxvp  = 0._wp   ;   syyvp  = 0._wp   ;   sxyvp  = 0._wp   ! melt pond volume 
     964            IF( ln_pnd_LEV ) THEN 
     965               sxap = 0._wp ;   syap = 0._wp    ;   sxxap = 0._wp    ;   syyap = 0._wp    ;   sxyap = 0._wp       ! melt pond fraction 
     966               sxvp = 0._wp ;   syvp = 0._wp    ;   sxxvp = 0._wp    ;   syyvp = 0._wp    ;   sxyvp = 0._wp       ! melt pond volume 
     967               IF ( ln_pnd_lids ) THEN 
     968                  sxvl = 0._wp; syvl = 0._wp    ;   sxxvl = 0._wp    ;   syyvl = 0._wp    ;   sxyvl = 0._wp       ! melt pond lid volume 
     969               ENDIF 
    850970            ENDIF 
    851971         ENDIF 
    … …  
    9101030         END DO 
    9111031         ! 
    912          IF( ln_pnd_H12 ) THEN                                       ! melt pond fraction 
     1032         IF( ln_pnd_LEV ) THEN                                       ! melt pond fraction 
    9131033            CALL iom_rstput( iter, nitrst, numriw, 'sxap' , sxap  ) 
    9141034            CALL iom_rstput( iter, nitrst, numriw, 'syap' , syap  ) 
    … …  
    9221042            CALL iom_rstput( iter, nitrst, numriw, 'syyvp', syyvp ) 
    9231043            CALL iom_rstput( iter, nitrst, numriw, 'sxyvp', sxyvp ) 
     1044            ! 
     1045            IF ( ln_pnd_lids ) THEN                                  ! melt pond lid volume 
     1046               CALL iom_rstput( iter, nitrst, numriw, 'sxvl' , sxvl  ) 
     1047               CALL iom_rstput( iter, nitrst, numriw, 'syvl' , syvl  ) 
     1048               CALL iom_rstput( iter, nitrst, numriw, 'sxxvl', sxxvl ) 
     1049               CALL iom_rstput( iter, nitrst, numriw, 'syyvl', syyvl ) 
     1050               CALL iom_rstput( iter, nitrst, numriw, 'sxyvl', sxyvl ) 
     1051            ENDIF 
    9241052         ENDIF 
    9251053         ! 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/ICE/icedyn_adv_umx.F90

    r13295 r13571  
    6060 
    6161   SUBROUTINE ice_dyn_adv_umx( kn_umx, kt, pu_ice, pv_ice, ph_i, ph_s, ph_ip,  & 
    62       &                        pato_i, pv_i, pv_s, psv_i, poa_i, pa_i, pa_ip, pv_ip, pe_s, pe_i ) 
     62      &                        pato_i, pv_i, pv_s, psv_i, poa_i, pa_i, pa_ip, pv_ip, pv_il, pe_s, pe_i ) 
    6363      !!---------------------------------------------------------------------- 
    6464      !!                  ***  ROUTINE ice_dyn_adv_umx  *** 
    … …  
    8585      REAL(wp), DIMENSION(:,:,:)  , INTENT(inout) ::   pa_ip      ! melt pond concentration 
    8686      REAL(wp), DIMENSION(:,:,:)  , INTENT(inout) ::   pv_ip      ! melt pond volume 
     87      REAL(wp), DIMENSION(:,:,:)  , INTENT(inout) ::   pv_il      ! melt pond lid volume 
    8788      REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) ::   pe_s       ! snw heat content 
    8889      REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) ::   pe_i       ! ice heat content 
    … …  
    9293      REAL(wp) ::   zamsk                   ! 1 if advection of concentration, 0 if advection of other tracers 
    9394      REAL(wp) ::   zdt, zvi_cen 
    94       REAL(wp), DIMENSION(1)           ::   zcflprv, zcflnow   ! for global communication 
    95       REAL(wp), DIMENSION(jpi,jpj)     ::   zudy, zvdx, zcu_box, zcv_box 
    96       REAL(wp), DIMENSION(jpi,jpj)     ::   zati1, zati2 
    97       REAL(wp), DIMENSION(jpi,jpj,jpl) ::   zu_cat, zv_cat 
    98       REAL(wp), DIMENSION(jpi,jpj,jpl) ::   zua_ho, zva_ho, zua_ups, zva_ups 
    99       REAL(wp), DIMENSION(jpi,jpj,jpl) ::   z1_ai , z1_aip, zhvar 
    100       REAL(wp), DIMENSION(jpi,jpj,jpl) ::   zhi_max, zhs_max, zhip_max 
     95      REAL(wp), DIMENSION(1)                  ::   zcflprv, zcflnow   ! for global communication 
     96      REAL(wp), DIMENSION(jpi,jpj)            ::   zudy, zvdx, zcu_box, zcv_box 
     97      REAL(wp), DIMENSION(jpi,jpj)            ::   zati1, zati2 
     98      REAL(wp), DIMENSION(jpi,jpj,jpl)        ::   zu_cat, zv_cat 
     99      REAL(wp), DIMENSION(jpi,jpj,jpl)        ::   zua_ho, zva_ho, zua_ups, zva_ups 
     100      REAL(wp), DIMENSION(jpi,jpj,jpl)        ::   z1_ai , z1_aip, zhvar 
     101      REAL(wp), DIMENSION(jpi,jpj,jpl)        ::   zhi_max, zhs_max, zhip_max, zs_i, zsi_max 
     102      REAL(wp), DIMENSION(jpi,jpj,nlay_i,jpl) ::   ze_i, zei_max 
     103      REAL(wp), DIMENSION(jpi,jpj,nlay_s,jpl) ::   ze_s, zes_max 
    101104      ! 
    102105      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   zuv_ho, zvv_ho, zuv_ups, zvv_ups, z1_vi, z1_vs  
    … …  
    105108      IF( kt == nit000 .AND. lwp )   WRITE(numout,*) '-- ice_dyn_adv_umx: Ultimate-Macho advection scheme' 
    106109      ! 
    107       ! --- Record max of the surrounding 9-pts ice thick. (for call Hbig) --- ! 
     110      ! --- Record max of the surrounding 9-pts (for call Hbig) --- ! 
     111      ! thickness and salinity 
     112      WHERE( pv_i(:,:,:) >= epsi10 ) ; zs_i(:,:,:) = psv_i(:,:,:) / pv_i(:,:,:) 
     113      ELSEWHERE                      ; zs_i(:,:,:) = 0._wp 
     114      END WHERE 
    108115      DO jl = 1, jpl 
    109116         DO_2D( 0, 0, 0, 0 ) 
    … …  
    120127               &                                               ph_s (ji+1,jj+1,jl), ph_s (ji-1,jj-1,jl), & 
    121128               &                                               ph_s (ji+1,jj-1,jl), ph_s (ji-1,jj+1,jl) ) 
    122          END_2D 
    123       END DO 
    124       CALL lbc_lnk_multi( 'icedyn_adv_umx', zhi_max, 'T', 1.0_wp, zhs_max, 'T', 1.0_wp, zhip_max, 'T', 1.0_wp ) 
     129            zsi_max (ji,jj,jl) = MAX( epsi20, zs_i (ji,jj,jl), zs_i (ji+1,jj  ,jl), zs_i (ji  ,jj+1,jl), & 
     130               &                                               zs_i (ji-1,jj  ,jl), zs_i (ji  ,jj-1,jl), & 
     131               &                                               zs_i (ji+1,jj+1,jl), zs_i (ji-1,jj-1,jl), & 
     132               &                                               zs_i (ji+1,jj-1,jl), zs_i (ji-1,jj+1,jl) ) 
     133         END_2D 
     134      END DO 
     135      CALL lbc_lnk_multi( 'icedyn_adv_umx', zhi_max, 'T', 1._wp, zhs_max, 'T', 1._wp, zhip_max, 'T', 1._wp, zsi_max, 'T', 1._wp ) 
     136      ! 
     137      ! enthalpies 
     138      DO jk = 1, nlay_i 
     139         WHERE( pv_i(:,:,:) >= epsi10 ) ; ze_i(:,:,jk,:) = pe_i(:,:,jk,:) / pv_i(:,:,:) 
     140         ELSEWHERE                      ; ze_i(:,:,jk,:) = 0._wp 
     141         END WHERE 
     142      END DO 
     143      DO jk = 1, nlay_s 
     144         WHERE( pv_s(:,:,:) >= epsi10 ) ; ze_s(:,:,jk,:) = pe_s(:,:,jk,:) / pv_s(:,:,:) 
     145         ELSEWHERE                      ; ze_s(:,:,jk,:) = 0._wp 
     146         END WHERE 
     147      END DO 
     148      DO jl = 1, jpl 
     149         DO_3D( 0, 0, 0, 0, 1, nlay_i ) 
     150            zei_max(ji,jj,jk,jl) = MAX( epsi20, ze_i(ji,jj,jk,jl), ze_i(ji+1,jj  ,jk,jl), ze_i(ji  ,jj+1,jk,jl), & 
     151               &                                                   ze_i(ji-1,jj  ,jk,jl), ze_i(ji  ,jj-1,jk,jl), & 
     152               &                                                   ze_i(ji+1,jj+1,jk,jl), ze_i(ji-1,jj-1,jk,jl), & 
     153               &                                                   ze_i(ji+1,jj-1,jk,jl), ze_i(ji-1,jj+1,jk,jl) ) 
     154         END_3D 
     155      END DO 
     156      DO jl = 1, jpl 
     157         DO_3D( 0, 0, 0, 0, 1, nlay_s ) 
     158            zes_max(ji,jj,jk,jl) = MAX( epsi20, ze_s(ji,jj,jk,jl), ze_s(ji+1,jj  ,jk,jl), ze_s(ji  ,jj+1,jk,jl), & 
     159               &                                                   ze_s(ji-1,jj  ,jk,jl), ze_s(ji  ,jj-1,jk,jl), & 
     160               &                                                   ze_s(ji+1,jj+1,jk,jl), ze_s(ji-1,jj-1,jk,jl), & 
     161               &                                                   ze_s(ji+1,jj-1,jk,jl), ze_s(ji-1,jj+1,jk,jl) ) 
     162         END_3D 
     163      END DO 
     164      CALL lbc_lnk( 'icedyn_adv_pra', zei_max, 'T', 1. ) 
     165      CALL lbc_lnk( 'icedyn_adv_pra', zes_max, 'T', 1. ) 
    125166      ! 
    126167      ! 
    … …  
    318359         ! 
    319360         !== melt ponds ==! 
    320          IF ( ln_pnd_H12 ) THEN 
     361         IF ( ln_pnd_LEV ) THEN 
    321362            ! concentration 
    322363            zamsk = 1._wp 
    … …  
    328369            CALL adv_umx( zamsk, kn_umx, jt, kt, zdt, zudy , zvdx , zua_ho , zva_ho , zcu_box, zcv_box, & 
    329370               &                                      zhvar, pv_ip, zua_ups, zva_ups ) 
     371            ! lid 
     372            IF ( ln_pnd_lids ) THEN 
     373               zamsk = 0._wp 
     374               zhvar(:,:,:) = pv_il(:,:,:) * z1_aip(:,:,:) 
     375               CALL adv_umx( zamsk, kn_umx, jt, kt, zdt, zudy , zvdx , zua_ho , zva_ho , zcu_box, zcv_box, & 
     376                  &                                      zhvar, pv_il, zua_ups, zva_ups ) 
     377            ENDIF 
    330378         ENDIF 
    331379         ! 
    … …  
    342390         ! Remove negative values (conservation is ensured) 
    343391         !    (because advected fields are not perfectly bounded and tiny negative values can occur, e.g. -1.e-20) 
    344          CALL ice_var_zapneg( zdt, pato_i, pv_i, pv_s, psv_i, poa_i, pa_i, pa_ip, pv_ip, pe_s, pe_i ) 
     392         CALL ice_var_zapneg( zdt, pato_i, pv_i, pv_s, psv_i, poa_i, pa_i, pa_ip, pv_ip, pv_il, pe_s, pe_i ) 
    345393         ! 
    346394         ! --- Make sure ice thickness is not too big --- ! 
    347395         !     (because ice thickness can be too large where ice concentration is very small) 
    348          CALL Hbig( zdt, zhi_max, zhs_max, zhip_max, pv_i, pv_s, pa_i, pa_ip, pv_ip, pe_s ) 
     396         CALL Hbig( zdt, zhi_max, zhs_max, zhip_max, zsi_max, zes_max, zei_max, & 
     397            &            pv_i, pv_s, pa_i, pa_ip, pv_ip, psv_i, pe_s, pe_i ) 
    349398         ! 
    350399         ! --- Ensure snow load is not too big --- ! 
    … …  
    9571006      !                                                     !--  Laplacian in j-direction  --! 
    9581007      DO jl = 1, jpl 
    959          DO_2D( 1, 0, 0, 0 ) 
     1008         DO_2D( 1, 0, 0, 0 )         ! First derivative (gradient) 
    9601009            ztv1(ji,jj,jl) = ( pt(ji,jj+1,jl) - pt(ji,jj,jl) ) * r1_e2v(ji,jj) * vmask(ji,jj,1) 
    9611010         END_2D 
    962          DO_2D( 0, 0, 0, 0 ) 
     1011         DO_2D( 0, 0, 0, 0 )         ! Second derivative (Laplacian) 
    9631012            ztv2(ji,jj,jl) = ( ztv1(ji,jj,jl) - ztv1(ji,jj-1,jl) ) * r1_e2t(ji,jj) 
    9641013         END_2D 
    … …  
    9681017      !                                                     !--  BiLaplacian in j-direction  --! 
    9691018      DO jl = 1, jpl 
    970          DO_2D( 1, 0, 0, 0 ) 
     1019         DO_2D( 1, 0, 0, 0 )         ! First derivative 
    9711020            ztv3(ji,jj,jl) = ( ztv2(ji,jj+1,jl) - ztv2(ji,jj,jl) ) * r1_e2v(ji,jj) * vmask(ji,jj,1) 
    9721021         END_2D 
    973          DO_2D( 0, 0, 0, 0 ) 
     1022         DO_2D( 0, 0, 0, 0 )         ! Second derivative 
    9741023            ztv4(ji,jj,jl) = ( ztv3(ji,jj,jl) - ztv3(ji,jj-1,jl) ) * r1_e2t(ji,jj) 
    9751024         END_2D 
    … …  
    14091458 
    14101459 
    1411    SUBROUTINE Hbig( pdt, phi_max, phs_max, phip_max, pv_i, pv_s, pa_i, pa_ip, pv_ip, pe_s ) 
     1460   SUBROUTINE Hbig( pdt, phi_max, phs_max, phip_max, psi_max, pes_max, pei_max, & 
     1461      &                  pv_i, pv_s, pa_i, pa_ip, pv_ip, psv_i, pe_s, pe_i ) 
    14121462      !!------------------------------------------------------------------- 
    14131463      !!                  ***  ROUTINE Hbig  *** 
    … …  
    14231473      !! ** input   : Max thickness of the surrounding 9-points 
    14241474      !!------------------------------------------------------------------- 
    1425       REAL(wp)                    , INTENT(in   ) ::   pdt                          ! tracer time-step 
    1426       REAL(wp), DIMENSION(:,:,:)  , INTENT(in   ) ::   phi_max, phs_max, phip_max   ! max ice thick from surrounding 9-pts 
    1427       REAL(wp), DIMENSION(:,:,:)  , INTENT(inout) ::   pv_i, pv_s, pa_i, pa_ip, pv_ip 
     1475      REAL(wp)                    , INTENT(in   ) ::   pdt                                   ! tracer time-step 
     1476      REAL(wp), DIMENSION(:,:,:)  , INTENT(in   ) ::   phi_max, phs_max, phip_max, psi_max   ! max ice thick from surrounding 9-pts 
     1477      REAL(wp), DIMENSION(:,:,:,:), INTENT(in   ) ::   pes_max 
     1478      REAL(wp), DIMENSION(:,:,:,:), INTENT(in   ) ::   pei_max 
     1479      REAL(wp), DIMENSION(:,:,:)  , INTENT(inout) ::   pv_i, pv_s, pa_i, pa_ip, pv_ip, psv_i 
    14281480      REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) ::   pe_s 
    1429       ! 
    1430       INTEGER  ::   ji, jj, jl         ! dummy loop indices 
    1431       REAL(wp) ::   z1_dt, zhip, zhi, zhs, zfra 
     1481      REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) ::   pe_i 
     1482      ! 
     1483      INTEGER  ::   ji, jj, jk, jl         ! dummy loop indices 
     1484      REAL(wp) ::   z1_dt, zhip, zhi, zhs, zsi, zes, zei, zfra 
    14321485      !!------------------------------------------------------------------- 
    14331486      ! 
    … …  
    14351488      ! 
    14361489      DO jl = 1, jpl 
    1437  
    14381490         DO_2D( 1, 1, 1, 1 ) 
    14391491            IF ( pv_i(ji,jj,jl) > 0._wp ) THEN 
    … …  
    14411493               !                               ! -- check h_ip -- ! 
    14421494               ! if h_ip is larger than the surrounding 9 pts => reduce h_ip and increase a_ip 
    1443                IF( ln_pnd_H12 .AND. pv_ip(ji,jj,jl) > 0._wp ) THEN 
     1495               IF( ln_pnd_LEV .AND. pv_ip(ji,jj,jl) > 0._wp ) THEN 
    14441496                  zhip = pv_ip(ji,jj,jl) / MAX( epsi20, pa_ip(ji,jj,jl) ) 
    14451497                  IF( zhip > phip_max(ji,jj,jl) .AND. pa_ip(ji,jj,jl) < 0.15 ) THEN 
    … …  
    14681520               ENDIF            
    14691521               !                   
     1522               !                               ! -- check s_i -- ! 
     1523               ! if s_i is larger than the surrounding 9 pts => put salt excess in the ocean 
     1524               zsi = psv_i(ji,jj,jl) / pv_i(ji,jj,jl) 
     1525               IF( zsi > psi_max(ji,jj,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 
     1526                  zfra = psi_max(ji,jj,jl) / zsi 
     1527                  sfx_res(ji,jj) = sfx_res(ji,jj) + psv_i(ji,jj,jl) * ( 1._wp - zfra ) * rhoi * z1_dt 
     1528                  psv_i(ji,jj,jl) = psv_i(ji,jj,jl) * zfra 
     1529               ENDIF 
     1530               ! 
    14701531            ENDIF 
    14711532         END_2D 
    14721533      END DO  
     1534      ! 
     1535      !                                           ! -- check e_i/v_i -- ! 
     1536      DO jl = 1, jpl 
     1537         DO_3D( 1, 1, 1, 1, 1, nlay_i ) 
     1538            IF ( pv_i(ji,jj,jl) > 0._wp ) THEN 
     1539               ! if e_i/v_i is larger than the surrounding 9 pts => put the heat excess in the ocean 
     1540               zei = pe_i(ji,jj,jk,jl) / pv_i(ji,jj,jl) 
     1541               IF( zei > pei_max(ji,jj,jk,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 
     1542                  zfra = pei_max(ji,jj,jk,jl) / zei 
     1543                  hfx_res(ji,jj) = hfx_res(ji,jj) - pe_i(ji,jj,jk,jl) * ( 1._wp - zfra ) * z1_dt ! W.m-2 <0 
     1544                  pe_i(ji,jj,jk,jl) = pe_i(ji,jj,jk,jl) * zfra 
     1545               ENDIF 
     1546            ENDIF 
     1547         END_3D 
     1548      END DO 
     1549      !                                           ! -- check e_s/v_s -- ! 
     1550      DO jl = 1, jpl 
     1551         DO_3D( 1, 1, 1, 1, 1, nlay_s ) 
     1552            IF ( pv_s(ji,jj,jl) > 0._wp ) THEN 
     1553               ! if e_s/v_s is larger than the surrounding 9 pts => put the heat excess in the ocean 
     1554               zes = pe_s(ji,jj,jk,jl) / pv_s(ji,jj,jl) 
     1555               IF( zes > pes_max(ji,jj,jk,jl) .AND. pa_i(ji,jj,jl) < 0.15 ) THEN 
     1556                  zfra = pes_max(ji,jj,jk,jl) / zes 
     1557                  hfx_res(ji,jj) = hfx_res(ji,jj) - pe_s(ji,jj,jk,jl) * ( 1._wp - zfra ) * z1_dt ! W.m-2 <0 
     1558                  pe_s(ji,jj,jk,jl) = pe_s(ji,jj,jk,jl) * zfra 
     1559               ENDIF 
     1560            ENDIF 
     1561         END_3D 
     1562      END DO 
    14731563      ! 
    14741564   END SUBROUTINE Hbig 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/ICE/icedyn_rdgrft.F90

    r13295 r13571  
    502502      REAL(wp)                  ::   airdg1, oirdg1, aprdg1, virdg1, sirdg1 
    503503      REAL(wp)                  ::   airft1, oirft1, aprft1 
    504       REAL(wp), DIMENSION(jpij) ::   airdg2, oirdg2, aprdg2, virdg2, sirdg2, vsrdg, vprdg  ! area etc of new ridges 
    505       REAL(wp), DIMENSION(jpij) ::   airft2, oirft2, aprft2, virft , sirft , vsrft, vprft  ! area etc of rafted ice 
     504      REAL(wp), DIMENSION(jpij) ::   airdg2, oirdg2, aprdg2, virdg2, sirdg2, vsrdg, vprdg, vlrdg  ! area etc of new ridges 
     505      REAL(wp), DIMENSION(jpij) ::   airft2, oirft2, aprft2, virft , sirft , vsrft, vprft, vlrft  ! area etc of rafted ice 
    506506      ! 
    507507      REAL(wp), DIMENSION(jpij) ::   ersw             ! enth of water trapped into ridges 
    … …  
    530530      DO jl1 = 1, jpl 
    531531 
    532          CALL tab_2d_1d( npti, nptidx(1:npti), s_i_1d(1:npti), s_i(:,:,jl1) ) 
     532         IF( nn_icesal /= 2 )  THEN       
     533            CALL tab_2d_1d( npti, nptidx(1:npti), s_i_1d(1:npti), s_i(:,:,jl1) ) 
     534         ENDIF 
    533535 
    534536         DO ji = 1, npti 
    … …  
    573575               oirft2(ji) = oa_i_2d(ji,jl1)   * afrft * hi_hrft  
    574576 
    575                IF ( ln_pnd_H12 ) THEN 
     577               IF ( ln_pnd_LEV ) THEN 
    576578                  aprdg1     = a_ip_2d(ji,jl1) * afrdg 
    577579                  aprdg2(ji) = a_ip_2d(ji,jl1) * afrdg * hi_hrdg(ji,jl1) 
    … …  
    580582                  aprft2(ji) = a_ip_2d(ji,jl1) * afrft * hi_hrft 
    581583                  vprft (ji) = v_ip_2d(ji,jl1) * afrft 
     584                  IF ( ln_pnd_lids ) THEN 
     585                     vlrdg (ji) = v_il_2d(ji,jl1) * afrdg 
     586                     vlrft (ji) = v_il_2d(ji,jl1) * afrft 
     587                  ENDIF 
    582588               ENDIF 
    583589 
    … …  
    606612               sv_i_2d(ji,jl1) = sv_i_2d(ji,jl1) - sirdg1    - sirft(ji) 
    607613               oa_i_2d(ji,jl1) = oa_i_2d(ji,jl1) - oirdg1    - oirft1 
    608                IF ( ln_pnd_H12 ) THEN 
     614               IF ( ln_pnd_LEV ) THEN 
    609615                  a_ip_2d(ji,jl1) = a_ip_2d(ji,jl1) - aprdg1    - aprft1 
    610616                  v_ip_2d(ji,jl1) = v_ip_2d(ji,jl1) - vprdg(ji) - vprft(ji) 
     617                  IF ( ln_pnd_lids ) THEN 
     618                     v_il_2d(ji,jl1) = v_il_2d(ji,jl1) - vlrdg(ji) - vlrft(ji) 
     619                  ENDIF 
    611620               ENDIF 
    612621            ENDIF 
    … …  
    700709                  v_s_2d (ji,jl2) = v_s_2d (ji,jl2) + ( vsrdg (ji) * rn_fsnwrdg * fvol(ji)  +  & 
    701710                     &                                  vsrft (ji) * rn_fsnwrft * zswitch(ji) ) 
    702                   IF ( ln_pnd_H12 ) THEN 
     711                  IF ( ln_pnd_LEV ) THEN 
    703712                     v_ip_2d (ji,jl2) = v_ip_2d(ji,jl2) + (   vprdg (ji) * rn_fpndrdg * fvol   (ji)   & 
    704713                        &                                   + vprft (ji) * rn_fpndrft * zswitch(ji)   ) 
    705714                     a_ip_2d (ji,jl2) = a_ip_2d(ji,jl2) + (   aprdg2(ji) * rn_fpndrdg * farea         &  
    706715                        &                                   + aprft2(ji) * rn_fpndrft * zswitch(ji)   ) 
     716                     IF ( ln_pnd_lids ) THEN 
     717                        v_il_2d (ji,jl2) = v_il_2d(ji,jl2) + (   vlrdg(ji) * rn_fpndrdg * fvol   (ji) & 
     718                           &                                   + vlrft(ji) * rn_fpndrft * zswitch(ji) ) 
     719                     ENDIF 
    707720                  ENDIF 
    708721                   
    … …  
    735748      !---------------- 
    736749      ! In case ridging/rafting lead to very small negative values (sometimes it happens) 
    737       CALL ice_var_roundoff( a_i_2d, v_i_2d, v_s_2d, sv_i_2d, oa_i_2d, a_ip_2d, v_ip_2d, ze_s_2d, ze_i_2d ) 
     750      CALL ice_var_roundoff( a_i_2d, v_i_2d, v_s_2d, sv_i_2d, oa_i_2d, a_ip_2d, v_ip_2d, v_il_2d, ze_s_2d, ze_i_2d ) 
    738751      ! 
    739752   END SUBROUTINE rdgrft_shift 
    … …  
    841854         CALL tab_3d_2d( npti, nptidx(1:npti), a_ip_2d(1:npti,1:jpl), a_ip(:,:,:) ) 
    842855         CALL tab_3d_2d( npti, nptidx(1:npti), v_ip_2d(1:npti,1:jpl), v_ip(:,:,:) ) 
     856         CALL tab_3d_2d( npti, nptidx(1:npti), v_il_2d(1:npti,1:jpl), v_il(:,:,:) ) 
    843857         DO jl = 1, jpl 
    844858            DO jk = 1, nlay_s 
    … …  
    867881         CALL tab_2d_3d( npti, nptidx(1:npti), a_ip_2d(1:npti,1:jpl), a_ip(:,:,:) ) 
    868882         CALL tab_2d_3d( npti, nptidx(1:npti), v_ip_2d(1:npti,1:jpl), v_ip(:,:,:) ) 
     883         CALL tab_2d_3d( npti, nptidx(1:npti), v_il_2d(1:npti,1:jpl), v_il(:,:,:) ) 
    869884         DO jl = 1, jpl 
    870885            DO jk = 1, nlay_s 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/ICE/icedyn_rhg.F90

    r12377 r13571  
    108108      INTEGER ::   ios, ioptio   ! Local integer output status for namelist read 
    109109      !! 
    110       NAMELIST/namdyn_rhg/  ln_rhg_EVP, ln_aEVP, rn_creepl, rn_ecc , nn_nevp, rn_relast 
     110      NAMELIST/namdyn_rhg/  ln_rhg_EVP, ln_aEVP, rn_creepl, rn_ecc , nn_nevp, rn_relast, nn_rhg_chkcvg 
    111111      !!------------------------------------------------------------------- 
    112112      ! 
    … …  
    122122         WRITE(numout,*) '~~~~~~~~~~~~~~~' 
    123123         WRITE(numout,*) '   Namelist : namdyn_rhg:' 
    124          WRITE(numout,*) '      rheology EVP (icedyn_rhg_evp)                        ln_rhg_EVP = ', ln_rhg_EVP 
    125          WRITE(numout,*) '         use adaptive EVP (aEVP)                           ln_aEVP    = ', ln_aEVP 
    126          WRITE(numout,*) '         creep limit                                       rn_creepl  = ', rn_creepl 
    127          WRITE(numout,*) '         eccentricity of the elliptical yield curve        rn_ecc     = ', rn_ecc 
    128          WRITE(numout,*) '         number of iterations for subcycling               nn_nevp    = ', nn_nevp 
    129          WRITE(numout,*) '         ratio of elastic timescale over ice time step     rn_relast  = ', rn_relast 
     124         WRITE(numout,*) '      rheology EVP (icedyn_rhg_evp)                        ln_rhg_EVP    = ', ln_rhg_EVP 
     125         WRITE(numout,*) '         use adaptive EVP (aEVP)                           ln_aEVP       = ', ln_aEVP 
     126         WRITE(numout,*) '         creep limit                                       rn_creepl     = ', rn_creepl 
     127         WRITE(numout,*) '         eccentricity of the elliptical yield curve        rn_ecc        = ', rn_ecc 
     128         WRITE(numout,*) '         number of iterations for subcycling               nn_nevp       = ', nn_nevp 
     129         WRITE(numout,*) '         ratio of elastic timescale over ice time step     rn_relast     = ', rn_relast 
     130         WRITE(numout,*) '      check convergence of rheology                        nn_rhg_chkcvg = ', nn_rhg_chkcvg 
     131         IF    ( nn_rhg_chkcvg == 0 ) THEN   ;   WRITE(numout,*) '         no check' 
     132         ELSEIF( nn_rhg_chkcvg == 1 ) THEN   ;   WRITE(numout,*) '         check cvg at the main time step' 
     133         ELSEIF( nn_rhg_chkcvg == 2 ) THEN   ;   WRITE(numout,*) '         check cvg at both main and rheology time steps' 
     134         ENDIF 
    130135      ENDIF 
    131136      ! 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/ICE/icedyn_rhg_evp.F90

    r13570 r13571  
    4141   USE prtctl         ! Print control 
    4242 
     43   USE netcdf         ! NetCDF library for convergence test 
    4344   IMPLICIT NONE 
    4445   PRIVATE 
    … …  
    5051#  include "do_loop_substitute.h90" 
    5152#  include "domzgr_substitute.h90" 
     53 
     54   !! for convergence tests 
     55   INTEGER ::   ncvgid   ! netcdf file id 
     56   INTEGER ::   nvarid   ! netcdf variable id 
     57   REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   zmsk00, zmsk15 
    5258   !!---------------------------------------------------------------------- 
    5359   !! NEMO/ICE 4.0 , NEMO Consortium (2018) 
    … …  
    121127      REAL(wp) ::   ecc2, z1_ecc2                                       ! square of yield ellipse eccenticity 
    122128      REAL(wp) ::   zalph1, z1_alph1, zalph2, z1_alph2                  ! alpha coef from Bouillon 2009 or Kimmritz 2017 
     129      REAl(wp) ::   zbetau, zbetav 
    123130      REAL(wp) ::   zm1, zm2, zm3, zmassU, zmassV, zvU, zvV             ! ice/snow mass and volume 
    124       REAL(wp) ::   zdelta, zp_delf, zds2, zdt, zdt2, zdiv, zdiv2       ! temporary scalars 
     131      REAL(wp) ::   zp_delf, zds2, zdt, zdt2, zdiv, zdiv2               ! temporary scalars 
    125132      REAL(wp) ::   zTauO, zTauB, zRHS, zvel                            ! temporary scalars 
    126133      REAL(wp) ::   zkt                                                 ! isotropic tensile strength for landfast ice 
    127134      REAL(wp) ::   zvCr                                                ! critical ice volume above which ice is landfast 
    128135      ! 
    129       REAL(wp) ::   zresm                                               ! Maximal error on ice velocity 
    130136      REAL(wp) ::   zintb, zintn                                        ! dummy argument 
    131137      REAL(wp) ::   zfac_x, zfac_y 
    132138      REAL(wp) ::   zshear, zdum1, zdum2 
    133139      ! 
    134       REAL(wp), DIMENSION(jpi,jpj) ::   zp_delt                         ! P/delta at T points 
     140      REAL(wp), DIMENSION(jpi,jpj) ::   zdelta, zp_delt                 ! delta and P/delta at T points 
    135141      REAL(wp), DIMENSION(jpi,jpj) ::   zbeta                           ! beta coef from Kimmritz 2017 
    136142      ! 
    … …  
    139145      REAL(wp), DIMENSION(jpi,jpj) ::   zmU_t, zmV_t                    ! (ice-snow_mass / dt) on U/V points 
    140146      REAL(wp), DIMENSION(jpi,jpj) ::   zmf                             ! coriolis parameter at T points 
    141       REAL(wp), DIMENSION(jpi,jpj) ::   v_oceU, u_oceV, v_iceU, u_iceV  ! ocean/ice u/v component on V/U points                            
     147      REAL(wp), DIMENSION(jpi,jpj) ::   v_oceU, u_oceV, v_iceU, u_iceV  ! ocean/ice u/v component on V/U points 
    142148      ! 
    143149      REAL(wp), DIMENSION(jpi,jpj) ::   zds                             ! shear 
    144150      REAL(wp), DIMENSION(jpi,jpj) ::   zs1, zs2, zs12                  ! stress tensor components 
    145 !!$      REAL(wp), DIMENSION(jpi,jpj) ::   zu_ice, zv_ice, zresr           ! check convergence 
    146151      REAL(wp), DIMENSION(jpi,jpj) ::   zsshdyn                         ! array used for the calculation of ice surface slope: 
    147152      !                                                                 !    ocean surface (ssh_m) if ice is not embedded 
    … …  
    157162      REAL(wp), DIMENSION(jpi,jpj) ::   zmsk01x, zmsk01y                ! dummy arrays 
    158163      REAL(wp), DIMENSION(jpi,jpj) ::   zmsk00x, zmsk00y                ! mask for ice presence 
    159       REAL(wp), DIMENSION(jpi,jpj) ::   zfmask, zwf                     ! mask at F points for the ice 
     164      REAL(wp), DIMENSION(jpi,jpj) ::   zfmask                          ! mask at F points for the ice 
    160165 
    161166      REAL(wp), PARAMETER          ::   zepsi  = 1.0e-20_wp             ! tolerance parameter 
    162167      REAL(wp), PARAMETER          ::   zmmin  = 1._wp                  ! ice mass (kg/m2)  below which ice velocity becomes very small 
    163168      REAL(wp), PARAMETER          ::   zamin  = 0.001_wp               ! ice concentration below which ice velocity becomes very small 
     169      !! --- check convergence 
     170      REAL(wp), DIMENSION(jpi,jpj) ::   zu_ice, zv_ice 
    164171      !! --- diags 
    165       REAL(wp), DIMENSION(jpi,jpj) ::   zmsk00 
    166172      REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   zsig1, zsig2, zsig3 
    167173      !! --- SIMIP diags 
    … …  
    176182      IF( kt == nit000 .AND. lwp )   WRITE(numout,*) '-- ice_dyn_rhg_evp: EVP sea-ice rheology' 
    177183      ! 
    178 !!gm for Clem:  OPTIMIZATION:  I think zfmask can be computed one for all at the initialization.... 
     184      ! for diagnostics and convergence tests 
     185      ALLOCATE( zmsk00(jpi,jpj), zmsk15(jpi,jpj) ) 
     186      DO_2D( 1, 1, 1, 1 ) 
     187         zmsk00(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi06  ) ) ! 1 if ice    , 0 if no ice 
     188         zmsk15(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - 0.15_wp ) ) ! 1 if 15% ice, 0 if less 
     189      END_2D 
     190      ! 
     191      !!gm for Clem:  OPTIMIZATION:  I think zfmask can be computed one for all at the initialization.... 
    179192      !------------------------------------------------------------------------------! 
    180193      ! 0) mask at F points for the ice 
    … …  
    191204 
    192205      ! Lateral boundary conditions on velocity (modify zfmask) 
    193       zwf(:,:) = zfmask(:,:) 
    194206      DO_2D( 0, 0, 0, 0 ) 
    195207         IF( zfmask(ji,jj) == 0._wp ) THEN 
    196             zfmask(ji,jj) = rn_ishlat * MIN( 1._wp , MAX( zwf(ji+1,jj), zwf(ji,jj+1), zwf(ji-1,jj), zwf(ji,jj-1) ) ) 
     208            zfmask(ji,jj) = rn_ishlat * MIN( 1._wp , MAX( umask(ji,jj,1), umask(ji,jj+1,1), & 
     209               &                                          vmask(ji,jj,1), vmask(ji+1,jj,1) ) ) 
    197210         ENDIF 
    198211      END_2D 
    199212      DO jj = 2, jpjm1 
    200213         IF( zfmask(1,jj) == 0._wp ) THEN 
    201             zfmask(1  ,jj) = rn_ishlat * MIN( 1._wp , MAX( zwf(2,jj), zwf(1,jj+1), zwf(1,jj-1) ) ) 
     214            zfmask(1  ,jj) = rn_ishlat * MIN( 1._wp , MAX( vmask(2,jj,1), umask(1,jj+1,1), umask(1,jj,1) ) ) 
    202215         ENDIF 
    203216         IF( zfmask(jpi,jj) == 0._wp ) THEN 
    204             zfmask(jpi,jj) = rn_ishlat * MIN( 1._wp , MAX( zwf(jpi,jj+1), zwf(jpim1,jj), zwf(jpi,jj-1) ) ) 
    205          ENDIF 
     217            zfmask(jpi,jj) = rn_ishlat * MIN( 1._wp , MAX( umask(jpi,jj+1,1), vmask(jpim1,jj,1), umask(jpi,jj-1,1) ) ) 
     218        ENDIF 
    206219      END DO 
    207220      DO ji = 2, jpim1 
    208221         IF( zfmask(ji,1) == 0._wp ) THEN 
    209             zfmask(ji,1  ) = rn_ishlat * MIN( 1._wp , MAX( zwf(ji+1,1), zwf(ji,2), zwf(ji-1,1) ) ) 
     222            zfmask(ji, 1 ) = rn_ishlat * MIN( 1._wp , MAX( vmask(ji+1,1,1), umask(ji,2,1), vmask(ji,1,1) ) ) 
    210223         ENDIF 
    211224         IF( zfmask(ji,jpj) == 0._wp ) THEN 
    212             zfmask(ji,jpj) = rn_ishlat * MIN( 1._wp , MAX( zwf(ji+1,jpj), zwf(ji-1,jpj), zwf(ji,jpjm1) ) ) 
     225            zfmask(ji,jpj) = rn_ishlat * MIN( 1._wp , MAX( vmask(ji+1,jpj,1), vmask(ji-1,jpj,1), umask(ji,jpjm1,1) ) ) 
    213226         ENDIF 
    214227      END DO 
    … …  
    228241      z1_ecc2 = 1._wp / ecc2 
    229242 
    230       ! Time step for subcycling 
    231       zdtevp   = rDt_ice / REAL( nn_nevp ) 
    232       z1_dtevp = 1._wp / zdtevp 
    233  
    234243      ! alpha parameters (Bouillon 2009) 
    235244      IF( .NOT. ln_aEVP ) THEN 
    236          zalph1 = ( 2._wp * rn_relast * rDt_ice ) * z1_dtevp 
     245         zdtevp   = rDt_ice / REAL( nn_nevp ) 
     246         zalph1 =   2._wp * rn_relast * REAL( nn_nevp ) 
    237247         zalph2 = zalph1 * z1_ecc2 
    238248 
    239249         z1_alph1 = 1._wp / ( zalph1 + 1._wp ) 
    240250         z1_alph2 = 1._wp / ( zalph2 + 1._wp ) 
     251      ELSE 
     252         zdtevp   = rdt_ice 
     253         ! zalpha parameters set later on adaptatively 
    241254      ENDIF 
     255      z1_dtevp = 1._wp / zdtevp 
    242256          
    243257      ! Initialise stress tensor  
    … …  
    250264 
    251265      ! landfast param from Lemieux(2016): add isotropic tensile strength (following Konig Beatty and Holland, 2010) 
    252       IF( ln_landfast_L16 ) THEN   ;   zkt = rn_tensile 
     266      IF( ln_landfast_L16 ) THEN   ;   zkt = rn_lf_tensile 
    253267      ELSE                         ;   zkt = 0._wp 
    254268      ENDIF 
    … …  
    322336            zvV = 0.5_wp * ( vt_i(ji,jj) * e1e2t(ji,jj) + vt_i(ji,jj+1) * e1e2t(ji,jj+1) ) * r1_e1e2v(ji,jj) * vmask(ji,jj,1) 
    323337            ! ice-bottom stress at U points 
    324             zvCr = zaU(ji,jj) * rn_depfra * hu(ji,jj,Kmm) 
    325             ztaux_base(ji,jj) = - rn_icebfr * MAX( 0._wp, zvU - zvCr ) * EXP( -rn_crhg * ( 1._wp - zaU(ji,jj) ) ) 
     338            zvCr = zaU(ji,jj) * rn_lf_depfra * hu(ji,jj,Kmm) 
     339            ztaux_base(ji,jj) = - rn_lf_bfr * MAX( 0._wp, zvU - zvCr ) * EXP( -rn_crhg * ( 1._wp - zaU(ji,jj) ) ) 
    326340            ! ice-bottom stress at V points 
    327             zvCr = zaV(ji,jj) * rn_depfra * hv(ji,jj,Kmm) 
    328             ztauy_base(ji,jj) = - rn_icebfr * MAX( 0._wp, zvV - zvCr ) * EXP( -rn_crhg * ( 1._wp - zaV(ji,jj) ) ) 
     341            zvCr = zaV(ji,jj) * rn_lf_depfra * hv(ji,jj,Kmm) 
     342            ztauy_base(ji,jj) = - rn_lf_bfr * MAX( 0._wp, zvV - zvCr ) * EXP( -rn_crhg * ( 1._wp - zaV(ji,jj) ) ) 
    329343            ! ice_bottom stress at T points 
    330             zvCr = at_i(ji,jj) * rn_depfra * ht(ji,jj) 
    331             tau_icebfr(ji,jj) = - rn_icebfr * MAX( 0._wp, vt_i(ji,jj) - zvCr ) * EXP( -rn_crhg * ( 1._wp - at_i(ji,jj) ) ) 
     344            zvCr = at_i(ji,jj) * rn_lf_depfra * ht(ji,jj) 
     345            tau_icebfr(ji,jj) = - rn_lf_bfr * MAX( 0._wp, vt_i(ji,jj) - zvCr ) * EXP( -rn_crhg * ( 1._wp - at_i(ji,jj) ) ) 
    332346         END_2D 
    333347#if defined key_mpi3 
    … …  
    353367         l_full_nf_update = jter == nn_nevp   ! false: disable full North fold update (performances) for iter = 1 to nn_nevp-1 
    354368         ! 
    355 !!$         IF(sn_cfctl%l_prtctl) THEN   ! Convergence test 
    356 !!$            DO jj = 1, jpjm1 
    357 !!$               zu_ice(:,jj) = u_ice(:,jj) ! velocity at previous time step 
    358 !!$               zv_ice(:,jj) = v_ice(:,jj) 
    359 !!$            END DO 
    360 !!$         ENDIF 
     369         ! convergence test 
     370         IF( nn_rhg_chkcvg == 1 .OR. nn_rhg_chkcvg == 2  ) THEN 
     371            DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
     372               zu_ice(ji,jj) = u_ice(ji,jj) * umask(ji,jj,1) ! velocity at previous time step 
     373               zv_ice(ji,jj) = v_ice(ji,jj) * vmask(ji,jj,1) 
     374            END_2D 
     375         ENDIF 
    361376 
    362377         ! --- divergence, tension & shear (Appendix B of Hunke & Dukowicz, 2002) --- ! 
    … …  
    369384 
    370385         END_2D 
    371          CALL lbc_lnk( 'icedyn_rhg_evp', zds, 'F', 1.0_wp ) 
    372  
    373          DO_2D( 0, 1, 0, 1 ) 
     386 
     387         DO_2D( 0, 0, 0, 0 ) 
    374388 
    375389            ! shear**2 at T points (doc eq. A16) 
    … …  
    391405             
    392406            ! delta at T points 
    393             zdelta = SQRT( zdiv2 + ( zdt2 + zds2 ) * z1_ecc2 )   
    394  
    395             ! P/delta at T points 
    396             zp_delt(ji,jj) = strength(ji,jj) / ( zdelta + rn_creepl ) 
    397  
    398             ! alpha & beta for aEVP 
     407            zdelta(ji,jj) = SQRT( zdiv2 + ( zdt2 + zds2 ) * z1_ecc2 )   
     408 
     409         END_2D 
     410         CALL lbc_lnk( 'icedyn_rhg_evp', zdelta, 'T', 1.0_wp ) 
     411 
     412         ! P/delta at T points 
     413         DO_2D( 1, 1, 1, 1 ) 
     414            zp_delt(ji,jj) = strength(ji,jj) / ( zdelta(ji,jj) + rn_creepl ) 
     415         END_2D 
     416 
     417         DO_2D( 0, 1, 0, 1 )   ! loop ends at jpi,jpj so that no lbc_lnk are needed for zs1 and zs2 
     418 
     419            ! divergence at T points (duplication to avoid communications) 
     420            zdiv  = ( e2u(ji,jj) * u_ice(ji,jj) - e2u(ji-1,jj) * u_ice(ji-1,jj)   & 
     421               &    + e1v(ji,jj) * v_ice(ji,jj) - e1v(ji,jj-1) * v_ice(ji,jj-1)   & 
     422               &    ) * r1_e1e2t(ji,jj) 
     423             
     424            ! tension at T points (duplication to avoid communications) 
     425            zdt  = ( ( u_ice(ji,jj) * r1_e2u(ji,jj) - u_ice(ji-1,jj) * r1_e2u(ji-1,jj) ) * e2t(ji,jj) * e2t(ji,jj)   & 
     426               &   - ( v_ice(ji,jj) * r1_e1v(ji,jj) - v_ice(ji,jj-1) * r1_e1v(ji,jj-1) ) * e1t(ji,jj) * e1t(ji,jj)   & 
     427               &   ) * r1_e1e2t(ji,jj) 
     428             
     429            ! alpha for aEVP 
    399430            !   gamma = 0.5*P/(delta+creepl) * (c*pi)**2/Area * dt/m 
    400431            !   alpha = beta = sqrt(4*gamma) 
    … …  
    404435               zalph2   = zalph1 
    405436               z1_alph2 = z1_alph1 
     437               ! explicit: 
     438               ! z1_alph1 = 1._wp / zalph1 
     439               ! z1_alph2 = 1._wp / zalph1 
     440               ! zalph1 = zalph1 - 1._wp 
     441               ! zalph2 = zalph1 
    406442            ENDIF 
    407443             
    408444            ! stress at T points (zkt/=0 if landfast) 
    409             zs1(ji,jj) = ( zs1(ji,jj) * zalph1 + zp_delt(ji,jj) * ( zdiv * (1._wp + zkt) - zdelta * (1._wp - zkt) ) ) * z1_alph1 
    410             zs2(ji,jj) = ( zs2(ji,jj) * zalph2 + zp_delt(ji,jj) * ( zdt * z1_ecc2 * (1._wp + zkt) ) ) * z1_alph2 
     445            zs1(ji,jj) = ( zs1(ji,jj)*zalph1 + zp_delt(ji,jj) * ( zdiv*(1._wp + zkt) - zdelta(ji,jj)*(1._wp - zkt) ) ) * z1_alph1 
     446            zs2(ji,jj) = ( zs2(ji,jj)*zalph2 + zp_delt(ji,jj) * ( zdt * z1_ecc2 * (1._wp + zkt) ) ) * z1_alph2 
    411447           
    412448         END_2D 
    413 #if defined key_mpi3 
    414          CALL lbc_lnk_nc_multi( 'icedyn_rhg_evp', zp_delt, 'T', 1.0_wp ) 
    415 #else 
    416          CALL lbc_lnk( 'icedyn_rhg_evp', zp_delt, 'T', 1.0_wp ) 
    417 #endif 
     449         ! Save beta at T-points for further computations 
     450         IF( ln_aEVP ) THEN 
     451            DO_2D( 1, 1, 1, 1 ) 
     452               zbeta(ji,jj) = MAX( 50._wp, rpi * SQRT( 0.5_wp * zp_delt(ji,jj) * r1_e1e2t(ji,jj) * zdt_m(ji,jj) ) ) 
     453            END_2D 
     454         ENDIF 
     455          
    418456         DO_2D( 1, 0, 1, 0 ) 
    419457 
    420             ! alpha & beta for aEVP 
     458            ! alpha for aEVP 
    421459            IF( ln_aEVP ) THEN 
    422                zalph2   = MAX( 50._wp, rpi * SQRT( 0.5_wp * zp_delt(ji,jj) * r1_e1e2t(ji,jj) * zdt_m(ji,jj) ) ) 
     460               zalph2   = MAX( zbeta(ji,jj), zbeta(ji+1,jj), zbeta(ji,jj+1), zbeta(ji+1,jj+1) ) 
    423461               z1_alph2 = 1._wp / ( zalph2 + 1._wp ) 
    424                zbeta(ji,jj) = zalph2 
     462               ! explicit: 
     463               ! z1_alph2 = 1._wp / zalph2 
     464               ! zalph2 = zalph2 - 1._wp 
    425465            ENDIF 
    426466             
    … …  
    488528               ! 
    489529               IF( ln_aEVP ) THEN !--- ice velocity using aEVP (Kimmritz et al 2016 & 2017) 
    490                   v_ice(ji,jj) = ( (          rswitch * ( zmV_t(ji,jj) * ( zbeta(ji,jj) * v_ice(ji,jj) + v_ice_b(ji,jj) )       & ! previous velocity 
    491                      &                                  + zRHS + zTauO * v_ice(ji,jj) )                                         & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 
    492                      &                                  / MAX( zepsi, zmV_t(ji,jj) * ( zbeta(ji,jj) + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast 
    493                      &               + ( 1._wp - rswitch ) * v_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lfrelax )           & ! static friction => slow decrease to v=0 
    494                      &             ) * zmsk01y(ji,jj) + v_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01y(ji,jj) )                     & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin 
     530                  zbetav = MAX( zbeta(ji,jj), zbeta(ji,jj+1) ) 
     531                  v_ice(ji,jj) = ( (          rswitch   * ( zmV_t(ji,jj) * ( zbetav * v_ice(ji,jj) + v_ice_b(ji,jj) )         & ! previous velocity 
     532                     &                                    + zRHS + zTauO * v_ice(ji,jj)                                       & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 
     533                     &                                    ) / MAX( zepsi, zmV_t(ji,jj) * ( zbetav + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast 
     534                     &            + ( 1._wp - rswitch ) * (  v_ice_b(ji,jj)                                                   &  
     535                     &                                     + v_ice  (ji,jj) * MAX( 0._wp, zbetav - zdtevp * rn_lf_relax )     & ! static friction => slow decrease to v=0 
     536                     &                                    ) / ( zbetav + 1._wp )                                              & 
     537                     &             ) * zmsk01y(ji,jj) + v_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01y(ji,jj) )                   & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin 
    495538                     &           )   * zmsk00y(ji,jj) 
    496539               ELSE               !--- ice velocity using EVP implicit formulation (cf Madec doc & Bouillon 2009) 
    497                   v_ice(ji,jj) = ( (           rswitch   * ( zmV_t(ji,jj) * v_ice(ji,jj)                                       & ! previous velocity 
    498                      &                                     + zRHS + zTauO * v_ice(ji,jj) )                                      & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 
    499                      &                                     / MAX( zepsi, zmV_t(ji,jj) + zTauO - zTauB )                         & ! m/dt + tau_io(only ice part) + landfast 
    500                      &                + ( 1._wp - rswitch ) * v_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lfrelax )          & ! static friction => slow decrease to v=0 
    501                      &              ) * zmsk01y(ji,jj) + v_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01y(ji,jj) )                    & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin 
    502                      &            )   * zmsk00y(ji,jj) 
     540                  v_ice(ji,jj) = ( (          rswitch   * ( zmV_t(ji,jj) * v_ice(ji,jj)                                       & ! previous velocity 
     541                     &                                    + zRHS + zTauO * v_ice(ji,jj)                                       & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 
     542                     &                                    ) / MAX( zepsi, zmV_t(ji,jj) + zTauO - zTauB )                      & ! m/dt + tau_io(only ice part) + landfast 
     543                     &            + ( 1._wp - rswitch ) *   v_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lf_relax )         & ! static friction => slow decrease to v=0 
     544                     &             ) * zmsk01y(ji,jj) + v_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01y(ji,jj) )                   & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin 
     545                     &            )  * zmsk00y(ji,jj) 
    503546               ENDIF 
    504547            END_2D 
    … …  
    541584               ! 
    542585               IF( ln_aEVP ) THEN !--- ice velocity using aEVP (Kimmritz et al 2016 & 2017) 
    543                   u_ice(ji,jj) = ( (          rswitch * ( zmU_t(ji,jj) * ( zbeta(ji,jj) * u_ice(ji,jj) + u_ice_b(ji,jj) )       & ! previous velocity 
    544                      &                                  + zRHS + zTauO * u_ice(ji,jj) )                                         & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 
    545                      &                                  / MAX( zepsi, zmU_t(ji,jj) * ( zbeta(ji,jj) + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast 
    546                      &               + ( 1._wp - rswitch ) * u_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lfrelax )           & ! static friction => slow decrease to v=0 
    547                      &             ) * zmsk01x(ji,jj) + u_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01x(ji,jj) )                     & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin  
     586                  zbetau = MAX( zbeta(ji,jj), zbeta(ji+1,jj) ) 
     587                  u_ice(ji,jj) = ( (          rswitch   * ( zmU_t(ji,jj) * ( zbetau * u_ice(ji,jj) + u_ice_b(ji,jj) )         & ! previous velocity 
     588                     &                                    + zRHS + zTauO * u_ice(ji,jj)                                       & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 
     589                     &                                    ) / MAX( zepsi, zmU_t(ji,jj) * ( zbetau + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast 
     590                     &            + ( 1._wp - rswitch ) * (  u_ice_b(ji,jj)                                                   & 
     591                     &                                     + u_ice  (ji,jj) * MAX( 0._wp, zbetau - zdtevp * rn_lf_relax )     & ! static friction => slow decrease to v=0 
     592                     &                                    ) / ( zbetau + 1._wp )                                              & 
     593                     &             ) * zmsk01x(ji,jj) + u_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01x(ji,jj) )                   & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin  
    548594                     &           )   * zmsk00x(ji,jj) 
    549595               ELSE               !--- ice velocity using EVP implicit formulation (cf Madec doc & Bouillon 2009) 
    550                   u_ice(ji,jj) = ( (           rswitch   * ( zmU_t(ji,jj) * u_ice(ji,jj)                                       & ! previous velocity 
    551                      &                                     + zRHS + zTauO * u_ice(ji,jj) )                                      & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 
    552                      &                                     / MAX( zepsi, zmU_t(ji,jj) + zTauO - zTauB )                         & ! m/dt + tau_io(only ice part) + landfast 
    553                      &                + ( 1._wp - rswitch ) * u_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lfrelax )          & ! static friction => slow decrease to v=0 
    554                      &              ) * zmsk01x(ji,jj) + u_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01x(ji,jj) )                    & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin  
    555                      &            )   * zmsk00x(ji,jj) 
     596                  u_ice(ji,jj) = ( (          rswitch   * ( zmU_t(ji,jj) * u_ice(ji,jj)                                       & ! previous velocity 
     597                     &                                    + zRHS + zTauO * u_ice(ji,jj)                                       & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 
     598                     &                                    ) / MAX( zepsi, zmU_t(ji,jj) + zTauO - zTauB )                      & ! m/dt + tau_io(only ice part) + landfast 
     599                     &            + ( 1._wp - rswitch ) *   u_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lf_relax )         & ! static friction => slow decrease to v=0 
     600                     &             ) * zmsk01x(ji,jj) + u_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01x(ji,jj) )                   & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin  
     601                     &           )   * zmsk00x(ji,jj) 
    556602               ENDIF 
    557603            END_2D 
    … …  
    596642               ! 
    597643               IF( ln_aEVP ) THEN !--- ice velocity using aEVP (Kimmritz et al 2016 & 2017) 
    598                   u_ice(ji,jj) = ( (          rswitch * ( zmU_t(ji,jj) * ( zbeta(ji,jj) * u_ice(ji,jj) + u_ice_b(ji,jj) )       & ! previous velocity 
    599                      &                                  + zRHS + zTauO * u_ice(ji,jj) )                                         & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 
    600                      &                                  / MAX( zepsi, zmU_t(ji,jj) * ( zbeta(ji,jj) + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast 
    601                      &               + ( 1._wp - rswitch ) * u_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lfrelax )           & ! static friction => slow decrease to v=0 
    602                      &             ) * zmsk01x(ji,jj) + u_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01x(ji,jj) )                     & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin  
     644                  zbetau = MAX( zbeta(ji,jj), zbeta(ji+1,jj) ) 
     645                  u_ice(ji,jj) = ( (          rswitch   * ( zmU_t(ji,jj) * ( zbetau * u_ice(ji,jj) + u_ice_b(ji,jj) )         & ! previous velocity 
     646                     &                                    + zRHS + zTauO * u_ice(ji,jj)                                       & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 
     647                     &                                    ) / MAX( zepsi, zmU_t(ji,jj) * ( zbetau + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast 
     648                     &            + ( 1._wp - rswitch ) * (  u_ice_b(ji,jj)                                                   & 
     649                     &                                     + u_ice  (ji,jj) * MAX( 0._wp, zbetau - zdtevp * rn_lf_relax )     & ! static friction => slow decrease to v=0 
     650                     &                                    ) / ( zbetau + 1._wp )                                              & 
     651                     &             ) * zmsk01x(ji,jj) + u_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01x(ji,jj) )                   & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin  
    603652                     &           )   * zmsk00x(ji,jj) 
    604653               ELSE               !--- ice velocity using EVP implicit formulation (cf Madec doc & Bouillon 2009) 
    605                   u_ice(ji,jj) = ( (           rswitch   * ( zmU_t(ji,jj) * u_ice(ji,jj)                                       & ! previous velocity 
    606                      &                                     + zRHS + zTauO * u_ice(ji,jj) )                                      & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 
    607                      &                                     / MAX( zepsi, zmU_t(ji,jj) + zTauO - zTauB )                         & ! m/dt + tau_io(only ice part) + landfast 
    608                      &                + ( 1._wp - rswitch ) * u_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lfrelax )          & ! static friction => slow decrease to v=0 
    609                      &              ) * zmsk01x(ji,jj) + u_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01x(ji,jj) )                    & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin 
    610                      &            )   * zmsk00x(ji,jj) 
     654                  u_ice(ji,jj) = ( (          rswitch   * ( zmU_t(ji,jj) * u_ice(ji,jj)                                       & ! previous velocity 
     655                     &                                    + zRHS + zTauO * u_ice(ji,jj)                                       & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 
     656                     &                                    ) / MAX( zepsi, zmU_t(ji,jj) + zTauO - zTauB )                      & ! m/dt + tau_io(only ice part) + landfast 
     657                     &            + ( 1._wp - rswitch ) *   u_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lf_relax )         & ! static friction => slow decrease to v=0 
     658                     &             ) * zmsk01x(ji,jj) + u_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01x(ji,jj) )                   & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin 
     659                     &           )   * zmsk00x(ji,jj) 
    611660               ENDIF 
    612661            END_2D 
    … …  
    649698               ! 
    650699               IF( ln_aEVP ) THEN !--- ice velocity using aEVP (Kimmritz et al 2016 & 2017) 
    651                   v_ice(ji,jj) = ( (          rswitch * ( zmV_t(ji,jj) * ( zbeta(ji,jj) * v_ice(ji,jj) + v_ice_b(ji,jj) )       & ! previous velocity 
    652                      &                                  + zRHS + zTauO * v_ice(ji,jj) )                                         & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 
    653                      &                                  / MAX( zepsi, zmV_t(ji,jj) * ( zbeta(ji,jj) + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast 
    654                      &               + ( 1._wp - rswitch ) * v_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lfrelax )           & ! static friction => slow decrease to v=0 
    655                      &             ) * zmsk01y(ji,jj) + v_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01y(ji,jj) )                     & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin 
     700                  zbetav = MAX( zbeta(ji,jj), zbeta(ji,jj+1) ) 
     701                  v_ice(ji,jj) = ( (          rswitch   * ( zmV_t(ji,jj) * ( zbetav * v_ice(ji,jj) + v_ice_b(ji,jj) )         & ! previous velocity 
     702                     &                                    + zRHS + zTauO * v_ice(ji,jj)                                       & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 
     703                     &                                    ) / MAX( zepsi, zmV_t(ji,jj) * ( zbetav + 1._wp ) + zTauO - zTauB ) & ! m/dt + tau_io(only ice part) + landfast 
     704                     &            + ( 1._wp - rswitch ) * (  v_ice_b(ji,jj)                                                   & 
     705                     &                                     + v_ice  (ji,jj) * MAX( 0._wp, zbetav - zdtevp * rn_lf_relax )     & ! static friction => slow decrease to v=0 
     706                     &                                    ) / ( zbetav + 1._wp )                                              &  
     707                     &             ) * zmsk01y(ji,jj) + v_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01y(ji,jj) )                   & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin 
    656708                     &           )   * zmsk00y(ji,jj) 
    657709               ELSE               !--- ice velocity using EVP implicit formulation (cf Madec doc & Bouillon 2009) 
    658                   v_ice(ji,jj) = ( (           rswitch   * ( zmV_t(ji,jj) * v_ice(ji,jj)                                       & ! previous velocity 
    659                      &                                     + zRHS + zTauO * v_ice(ji,jj) )                                      & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 
    660                      &                                     / MAX( zepsi, zmV_t(ji,jj) + zTauO - zTauB )                         & ! m/dt + tau_io(only ice part) + landfast 
    661                      &                + ( 1._wp - rswitch ) * v_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lfrelax )          & ! static friction => slow decrease to v=0 
    662                      &              ) * zmsk01y(ji,jj) + v_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01y(ji,jj) )                    & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin 
    663                      &            )   * zmsk00y(ji,jj) 
     710                  v_ice(ji,jj) = ( (          rswitch   * ( zmV_t(ji,jj) * v_ice(ji,jj)                                       & ! previous velocity 
     711                     &                                    + zRHS + zTauO * v_ice(ji,jj)                                       & ! F + tau_ia + Coriolis + spg + tau_io(only ocean part) 
     712                     &                                    ) / MAX( zepsi, zmV_t(ji,jj) + zTauO - zTauB )                      & ! m/dt + tau_io(only ice part) + landfast 
     713                     &            + ( 1._wp - rswitch ) *   v_ice(ji,jj) * MAX( 0._wp, 1._wp - zdtevp * rn_lf_relax )         & ! static friction => slow decrease to v=0 
     714                     &             ) * zmsk01y(ji,jj) + v_oce(ji,jj) * 0.01_wp * ( 1._wp - zmsk01y(ji,jj) )                   & ! v_ice = v_oce/100 if mass < zmmin & conc < zamin 
     715                     &           )   * zmsk00y(ji,jj) 
    664716               ENDIF 
    665717            END_2D 
    … …  
    678730         ENDIF 
    679731 
    680 !!$         IF(sn_cfctl%l_prtctl) THEN   ! Convergence test 
    681 !!$            DO jj = 2 , jpjm1 
    682 !!$               zresr(:,jj) = MAX( ABS( u_ice(:,jj) - zu_ice(:,jj) ), ABS( v_ice(:,jj) - zv_ice(:,jj) ) ) 
    683 !!$            END DO 
    684 !!$            zresm = MAXVAL( zresr( 1:jpi, 2:jpjm1 ) ) 
    685 !!$            CALL mpp_max( 'icedyn_rhg_evp', zresm )   ! max over the global domain 
    686 !!$         ENDIF 
     732         ! convergence test 
     733         IF( nn_rhg_chkcvg == 2 )   CALL rhg_cvg( kt, jter, nn_nevp, u_ice, v_ice, zu_ice, zv_ice ) 
    687734         ! 
    688735         !                                                ! ==================== ! 
    689736      END DO                                              !  end loop over jter  ! 
    690737      !                                                   ! ==================== ! 
     738      IF( ln_aEVP )   CALL iom_put( 'beta_evp' , zbeta ) 
    691739      ! 
    692740      !------------------------------------------------------------------------------! 
    … …  
    702750      END_2D 
    703751       
    704       DO_2D( 0, 0, 0, 0 ) 
     752      DO_2D( 0, 0, 0, 0 )   ! no vector loop 
    705753          
    706754         ! tension**2 at T points 
    … …  
    724772          
    725773         ! delta at T points 
    726          zdelta         = SQRT( pdivu_i(ji,jj) * pdivu_i(ji,jj) + ( zdt2 + zds2 ) * z1_ecc2 )   
    727          rswitch        = 1._wp - MAX( 0._wp, SIGN( 1._wp, -zdelta ) ) ! 0 if delta=0 
    728          pdelta_i(ji,jj) = zdelta + rn_creepl * rswitch 
     774         zdelta(ji,jj)   = SQRT( pdivu_i(ji,jj) * pdivu_i(ji,jj) + ( zdt2 + zds2 ) * z1_ecc2 )   
     775         rswitch         = 1._wp - MAX( 0._wp, SIGN( 1._wp, -zdelta(ji,jj) ) ) ! 0 if delta=0 
     776         pdelta_i(ji,jj) = zdelta(ji,jj) + rn_creepl * rswitch 
    729777 
    730778      END_2D 
    … …  
    749797      ! 5) diagnostics 
    750798      !------------------------------------------------------------------------------! 
    751       DO_2D( 1, 1, 1, 1 ) 
    752          zmsk00(ji,jj) = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi06 ) ) ! 1 if ice, 0 if no ice 
    753       END_2D 
    754  
    755799      ! --- ice-ocean, ice-atm. & ice-oceanbottom(landfast) stresses --- ! 
    756800      IF(  iom_use('utau_oi') .OR. iom_use('vtau_oi') .OR. iom_use('utau_ai') .OR. iom_use('vtau_ai') .OR. & 
    … …  
    816860         DEALLOCATE( zsig1 , zsig2 , zsig3 ) 
    817861      ENDIF 
    818        
     862 
    819863      ! --- SIMIP --- ! 
    820864      IF(  iom_use('dssh_dx') .OR. iom_use('dssh_dy') .OR. & 
    … …  
    881925      ENDIF 
    882926      ! 
     927      ! --- convergence tests --- ! 
     928      IF( nn_rhg_chkcvg == 1 .OR. nn_rhg_chkcvg == 2 ) THEN 
     929         IF( iom_use('uice_cvg') ) THEN 
     930            IF( ln_aEVP ) THEN   ! output: beta * ( u(t=nn_nevp) - u(t=nn_nevp-1) ) 
     931               CALL iom_put( 'uice_cvg', MAX( ABS( u_ice(:,:) - zu_ice(:,:) ) * zbeta(:,:) * umask(:,:,1) , & 
     932                  &                           ABS( v_ice(:,:) - zv_ice(:,:) ) * zbeta(:,:) * vmask(:,:,1) ) * zmsk15(:,:) ) 
     933            ELSE                 ! output: nn_nevp * ( u(t=nn_nevp) - u(t=nn_nevp-1) ) 
     934               CALL iom_put( 'uice_cvg', REAL( nn_nevp ) * MAX( ABS( u_ice(:,:) - zu_ice(:,:) ) * umask(:,:,1) , & 
     935                  &                                             ABS( v_ice(:,:) - zv_ice(:,:) ) * vmask(:,:,1) ) * zmsk15(:,:) ) 
     936            ENDIF 
     937         ENDIF 
     938      ENDIF       
     939      ! 
     940      DEALLOCATE( zmsk00, zmsk15 ) 
     941      ! 
    883942   END SUBROUTINE ice_dyn_rhg_evp 
     943 
     944 
     945   SUBROUTINE rhg_cvg( kt, kiter, kitermax, pu, pv, pub, pvb ) 
     946      !!---------------------------------------------------------------------- 
     947      !!                    ***  ROUTINE rhg_cvg  *** 
     948      !!                      
     949      !! ** Purpose :   check convergence of oce rheology 
     950      !! 
     951      !! ** Method  :   create a file ice_cvg.nc containing the convergence of ice velocity 
     952      !!                during the sub timestepping of rheology so as: 
     953      !!                  uice_cvg = MAX( u(t+1) - u(t) , v(t+1) - v(t) ) 
     954      !!                This routine is called every sub-iteration, so it is cpu expensive 
     955      !! 
     956      !! ** Note    :   for the first sub-iteration, uice_cvg is set to 0 (too large otherwise)    
     957      !!---------------------------------------------------------------------- 
     958      INTEGER ,                 INTENT(in) ::   kt, kiter, kitermax       ! ocean time-step index 
     959      REAL(wp), DIMENSION(:,:), INTENT(in) ::   pu, pv, pub, pvb          ! now and before velocities 
     960      !! 
     961      INTEGER           ::   it, idtime, istatus 
     962      INTEGER           ::   ji, jj          ! dummy loop indices 
     963      REAL(wp)          ::   zresm           ! local real  
     964      CHARACTER(len=20) ::   clname 
     965      REAL(wp), DIMENSION(jpi,jpj) ::   zres           ! check convergence 
     966      !!---------------------------------------------------------------------- 
     967 
     968      ! create file 
     969      IF( kt == nit000 .AND. kiter == 1 ) THEN 
     970         ! 
     971         IF( lwp ) THEN 
     972            WRITE(numout,*) 
     973            WRITE(numout,*) 'rhg_cvg : ice rheology convergence control' 
     974            WRITE(numout,*) '~~~~~~~' 
     975         ENDIF 
     976         ! 
     977         IF( lwm ) THEN 
     978            clname = 'ice_cvg.nc' 
     979            IF( .NOT. Agrif_Root() )   clname = TRIM(Agrif_CFixed())//"_"//TRIM(clname) 
     980            istatus = NF90_CREATE( TRIM(clname), NF90_CLOBBER, ncvgid ) 
     981            istatus = NF90_DEF_DIM( ncvgid, 'time'  , NF90_UNLIMITED, idtime ) 
     982            istatus = NF90_DEF_VAR( ncvgid, 'uice_cvg', NF90_DOUBLE   , (/ idtime /), nvarid ) 
     983            istatus = NF90_ENDDEF(ncvgid) 
     984         ENDIF 
     985         ! 
     986      ENDIF 
     987 
     988      ! time 
     989      it = ( kt - 1 ) * kitermax + kiter 
     990       
     991      ! convergence 
     992      IF( kiter == 1 ) THEN ! remove the first iteration for calculations of convergence (always very large) 
     993         zresm = 0._wp 
     994      ELSE 
     995         DO_2D( 1, 1, 1, 1 ) 
     996            zres(ji,jj) = MAX( ABS( pu(ji,jj) - pub(ji,jj) ) * umask(ji,jj,1), & 
     997               &               ABS( pv(ji,jj) - pvb(ji,jj) ) * vmask(ji,jj,1) ) * zmsk15(ji,jj) 
     998         END_2D 
     999         zresm = MAXVAL( zres ) 
     1000         CALL mpp_max( 'icedyn_rhg_evp', zresm )   ! max over the global domain 
     1001      ENDIF 
     1002 
     1003      IF( lwm ) THEN 
     1004         ! write variables 
     1005         istatus = NF90_PUT_VAR( ncvgid, nvarid, (/zresm/), (/it/), (/1/) ) 
     1006         ! close file 
     1007         IF( kt == nitend )   istatus = NF90_CLOSE(ncvgid) 
     1008      ENDIF 
     1009       
     1010   END SUBROUTINE rhg_cvg 
    8841011 
    8851012 
    … …  
    9391066   END SUBROUTINE rhg_evp_rst 
    9401067 
     1068    
    9411069#else 
    9421070   !!---------------------------------------------------------------------- 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/ICE/iceistate.F90

    r13295 r13571  
    4747   !                             !! ** namelist (namini) ** 
    4848   LOGICAL, PUBLIC  ::   ln_iceini        !: Ice initialization or not 
    49    LOGICAL, PUBLIC  ::   ln_iceini_file   !: Ice initialization from 2D netcdf file 
     49   INTEGER, PUBLIC  ::   nn_iceini_file   !: Ice initialization: 
     50                                  !        0 = Initialise sea ice based on SSTs 
     51                                  !        1 = Initialise sea ice from single category netcdf file 
     52                                  !        2 = Initialise sea ice from multi category restart file 
    5053   REAL(wp) ::   rn_thres_sst 
    5154   REAL(wp) ::   rn_hti_ini_n, rn_hts_ini_n, rn_ati_ini_n, rn_smi_ini_n, rn_tmi_ini_n, rn_tsu_ini_n, rn_tms_ini_n 
    5255   REAL(wp) ::   rn_hti_ini_s, rn_hts_ini_s, rn_ati_ini_s, rn_smi_ini_s, rn_tmi_ini_s, rn_tsu_ini_s, rn_tms_ini_s 
    53    REAL(wp) ::   rn_apd_ini_n, rn_hpd_ini_n 
    54    REAL(wp) ::   rn_apd_ini_s, rn_hpd_ini_s 
     56   REAL(wp) ::   rn_apd_ini_n, rn_hpd_ini_n, rn_hld_ini_n 
     57   REAL(wp) ::   rn_apd_ini_s, rn_hpd_ini_s, rn_hld_ini_s 
    5558   ! 
    56    !                              ! if ln_iceini_file = T 
    57    INTEGER , PARAMETER ::   jpfldi = 9           ! maximum number of files to read 
     59   !                              ! if nn_iceini_file = 1 
     60   INTEGER , PARAMETER ::   jpfldi = 10          ! maximum number of files to read 
    5861   INTEGER , PARAMETER ::   jp_hti = 1           ! index of ice thickness    (m) 
    5962   INTEGER , PARAMETER ::   jp_hts = 2           ! index of snw thickness    (m) 
    … …  
    6568   INTEGER , PARAMETER ::   jp_apd = 8           ! index of pnd fraction     (-) 
    6669   INTEGER , PARAMETER ::   jp_hpd = 9           ! index of pnd depth        (m) 
     70   INTEGER , PARAMETER ::   jp_hld = 10          ! index of pnd lid depth    (m) 
    6771   TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   si  ! structure of input fields (file informations, fields read) 
    6872 
    … …  
    8993      !! ** Steps   :   1) Set initial surface and basal temperatures 
    9094      !!                2) Recompute or read sea ice state variables 
    91       !!                3) Fill in the ice thickness distribution using gaussian 
    92       !!                4) Fill in space-dependent arrays for state variables 
    93       !!                5) snow-ice mass computation 
    94       !!                6) store before fields 
     95      !!                3) Fill in space-dependent arrays for state variables 
     96      !!                4) snow-ice mass computation 
    9597      !! 
    9698      !! ** Notes   : o_i, t_su, t_s, t_i, sz_i must be filled everywhere, even 
    … …  
    107109      REAL(wp), DIMENSION(jpi,jpj)     ::   zht_i_ini, zat_i_ini, ztm_s_ini            !data from namelist or nc file 
    108110      REAL(wp), DIMENSION(jpi,jpj)     ::   zt_su_ini, zht_s_ini, zsm_i_ini, ztm_i_ini !data from namelist or nc file 
    109       REAL(wp), DIMENSION(jpi,jpj)     ::   zapnd_ini, zhpnd_ini                       !data from namelist or nc file 
    110       REAL(wp), DIMENSION(jpi,jpj,jpl) ::   zti_3d , zts_3d                            !locak arrays 
    111       !! 
    112       REAL(wp), DIMENSION(:,:), ALLOCATABLE ::   zhi_2d, zhs_2d, zai_2d, zti_2d, zts_2d, ztsu_2d, zsi_2d, zaip_2d, zhip_2d 
     111      REAL(wp), DIMENSION(jpi,jpj)     ::   zapnd_ini, zhpnd_ini, zhlid_ini            !data from namelist or nc file 
     112      REAL(wp), DIMENSION(jpi,jpj,jpl) ::   zti_3d , zts_3d                            !temporary arrays 
     113      !! 
     114      REAL(wp), DIMENSION(:,:), ALLOCATABLE ::   zhi_2d, zhs_2d, zai_2d, zti_2d, zts_2d, ztsu_2d, zsi_2d, zaip_2d, zhip_2d, zhil_2d 
    113115      !-------------------------------------------------------------------- 
    114116 
    … …  
    164166      a_ip     (:,:,:) = 0._wp 
    165167      v_ip     (:,:,:) = 0._wp 
    166       a_ip_frac(:,:,:) = 0._wp 
     168      v_il     (:,:,:) = 0._wp 
     169      a_ip_eff (:,:,:) = 0._wp 
    167170      h_ip     (:,:,:) = 0._wp 
     171      h_il     (:,:,:) = 0._wp 
    168172      ! 
    169173      ! ice velocities 
    … …  
    174178      ! 2) overwrite some of the fields with namelist parameters or netcdf file 
    175179      !------------------------------------------------------------------------ 
    176  
    177  
    178180      IF( ln_iceini ) THEN 
    179          !                             !---------------! 
    180           
     181         ! 
    181182         IF( Agrif_Root() ) THEN 
    182  
    183             IF( ln_iceini_file )THEN      ! Read a file   ! 
     183            !                             !---------------! 
     184            IF( nn_iceini_file == 1 )THEN ! Read a file   ! 
    184185               !                          !---------------! 
    185186               WHERE( ff_t(:,:) >= 0._wp )   ;   zswitch(:,:) = 1._wp 
    … …  
    195196 
    196197               ! -- optional fields -- ! 
    197                !    if fields do not exist then set them to the values present in the namelist (except for snow and surface temperature) 
     198               !    if fields do not exist then set them to the values present in the namelist (except for temperatures) 
    198199               ! 
    199200               ! ice salinity 
    … …  
    207208                  si(jp_tsu)%fnow(:,:,1) = ( rn_tsu_ini_n * zswitch + rn_tsu_ini_s * (1._wp - zswitch) ) * tmask(:,:,1) 
    208209                  si(jp_tms)%fnow(:,:,1) = ( rn_tms_ini_n * zswitch + rn_tms_ini_s * (1._wp - zswitch) ) * tmask(:,:,1) 
    209                ELSEIF( TRIM(si(jp_tmi)%clrootname) == 'NOT USED' .AND. TRIM(si(jp_tms)%clrootname) /= 'NOT USED' ) THEN ! if T_s is read and not T_i, set T_i = (T_s + T_freeze)/2 
    210                   si(jp_tmi)%fnow(:,:,1) = 0.5_wp * ( si(jp_tms)%fnow(:,:,1) + 271.15 ) 
    211                ELSEIF( TRIM(si(jp_tmi)%clrootname) == 'NOT USED' .AND. TRIM(si(jp_tsu)%clrootname) /= 'NOT USED' ) THEN ! if T_su is read and not T_i, set T_i = (T_su + T_freeze)/2 
    212                   si(jp_tmi)%fnow(:,:,1) = 0.5_wp * ( si(jp_tsu)%fnow(:,:,1) + 271.15 ) 
    213                ELSEIF( TRIM(si(jp_tsu)%clrootname) == 'NOT USED' .AND. TRIM(si(jp_tms)%clrootname) /= 'NOT USED' ) THEN ! if T_s is read and not T_su, set T_su = T_s 
    214                   si(jp_tsu)%fnow(:,:,1) = si(jp_tms)%fnow(:,:,1) 
    215                ELSEIF( TRIM(si(jp_tsu)%clrootname) == 'NOT USED' .AND. TRIM(si(jp_tmi)%clrootname) /= 'NOT USED' ) THEN ! if T_i is read and not T_su, set T_su = T_i 
    216                   si(jp_tsu)%fnow(:,:,1) = si(jp_tmi)%fnow(:,:,1) 
    217                ELSEIF( TRIM(si(jp_tms)%clrootname) == 'NOT USED' .AND. TRIM(si(jp_tsu)%clrootname) /= 'NOT USED' ) THEN ! if T_su is read and not T_s, set T_s = T_su 
    218                   si(jp_tms)%fnow(:,:,1) = si(jp_tsu)%fnow(:,:,1) 
    219                ELSEIF( TRIM(si(jp_tms)%clrootname) == 'NOT USED' .AND. TRIM(si(jp_tmi)%clrootname) /= 'NOT USED' ) THEN ! if T_i is read and not T_s, set T_s = T_i 
    220                   si(jp_tms)%fnow(:,:,1) = si(jp_tmi)%fnow(:,:,1) 
    221210               ENDIF 
     211               IF( TRIM(si(jp_tmi)%clrootname) == 'NOT USED' .AND. TRIM(si(jp_tms)%clrootname) /= 'NOT USED' ) & ! if T_s is read and not T_i, set T_i = (T_s + T_freeze)/2 
     212                  &     si(jp_tmi)%fnow(:,:,1) = 0.5_wp * ( si(jp_tms)%fnow(:,:,1) + 271.15 ) 
     213               IF( TRIM(si(jp_tmi)%clrootname) == 'NOT USED' .AND. TRIM(si(jp_tsu)%clrootname) /= 'NOT USED' ) & ! if T_su is read and not T_i, set T_i = (T_su + T_freeze)/2 
     214                  &     si(jp_tmi)%fnow(:,:,1) = 0.5_wp * ( si(jp_tsu)%fnow(:,:,1) + 271.15 ) 
     215               IF( TRIM(si(jp_tsu)%clrootname) == 'NOT USED' .AND. TRIM(si(jp_tms)%clrootname) /= 'NOT USED' ) & ! if T_s is read and not T_su, set T_su = T_s 
     216                  &     si(jp_tsu)%fnow(:,:,1) = si(jp_tms)%fnow(:,:,1) 
     217               IF( TRIM(si(jp_tsu)%clrootname) == 'NOT USED' .AND. TRIM(si(jp_tmi)%clrootname) /= 'NOT USED' ) & ! if T_i is read and not T_su, set T_su = T_i 
     218                  &     si(jp_tsu)%fnow(:,:,1) = si(jp_tmi)%fnow(:,:,1) 
     219               IF( TRIM(si(jp_tms)%clrootname) == 'NOT USED' .AND. TRIM(si(jp_tsu)%clrootname) /= 'NOT USED' ) & ! if T_su is read and not T_s, set T_s = T_su 
     220                  &     si(jp_tms)%fnow(:,:,1) = si(jp_tsu)%fnow(:,:,1) 
     221               IF( TRIM(si(jp_tms)%clrootname) == 'NOT USED' .AND. TRIM(si(jp_tmi)%clrootname) /= 'NOT USED' ) & ! if T_i is read and not T_s, set T_s = T_i 
     222                  &     si(jp_tms)%fnow(:,:,1) = si(jp_tmi)%fnow(:,:,1) 
    222223               ! 
    223224               ! pond concentration 
    … …  
    229230               IF( TRIM(si(jp_hpd)%clrootname) == 'NOT USED' ) & 
    230231                  &     si(jp_hpd)%fnow(:,:,1) = ( rn_hpd_ini_n * zswitch + rn_hpd_ini_s * (1._wp - zswitch) ) * tmask(:,:,1) 
     232               ! 
     233               ! pond lid depth 
     234               IF( TRIM(si(jp_hld)%clrootname) == 'NOT USED' ) & 
     235                  &     si(jp_hld)%fnow(:,:,1) = ( rn_hld_ini_n * zswitch + rn_hld_ini_s * (1._wp - zswitch) ) * tmask(:,:,1) 
    231236               ! 
    232237               zsm_i_ini(:,:) = si(jp_smi)%fnow(:,:,1) * tmask(:,:,1) 
    … …  
    236241               zapnd_ini(:,:) = si(jp_apd)%fnow(:,:,1) * tmask(:,:,1) 
    237242               zhpnd_ini(:,:) = si(jp_hpd)%fnow(:,:,1) * tmask(:,:,1) 
     243               zhlid_ini(:,:) = si(jp_hld)%fnow(:,:,1) * tmask(:,:,1) 
    238244               ! 
    239245               ! change the switch for the following 
    … …  
    261267                  zapnd_ini(:,:) = rn_apd_ini_n * zswitch(:,:) * zat_i_ini(:,:) ! rn_apd = pond fraction => rn_apd * a_i = pond conc.  
    262268                  zhpnd_ini(:,:) = rn_hpd_ini_n * zswitch(:,:) 
     269                  zhlid_ini(:,:) = rn_hld_ini_n * zswitch(:,:) 
    263270               ELSEWHERE 
    264271                  zht_i_ini(:,:) = rn_hti_ini_s * zswitch(:,:) 
    … …  
    271278                  zapnd_ini(:,:) = rn_apd_ini_s * zswitch(:,:) * zat_i_ini(:,:) ! rn_apd = pond fraction => rn_apd * a_i = pond conc. 
    272279                  zhpnd_ini(:,:) = rn_hpd_ini_s * zswitch(:,:) 
     280                  zhlid_ini(:,:) = rn_hld_ini_s * zswitch(:,:) 
    273281               END WHERE 
    274282               ! 
    … …  
    281289               zapnd_ini(:,:) = 0._wp 
    282290               zhpnd_ini(:,:) = 0._wp 
     291               zhlid_ini(:,:) = 0._wp 
    283292            ENDIF 
    284293             
    285             !-------------! 
    286             ! fill fields ! 
    287             !-------------! 
     294            IF ( .NOT.ln_pnd_lids ) THEN 
     295               zhlid_ini(:,:) = 0._wp 
     296            ENDIF 
     297             
     298            !----------------! 
     299            ! 3) fill fields ! 
     300            !----------------! 
    288301            ! select ice covered grid points 
    289302            npti = 0 ; nptidx(:) = 0 
    … …  
    305318            CALL tab_2d_1d( npti, nptidx(1:npti), a_ip_1d(1:npti)  , zapnd_ini ) 
    306319            CALL tab_2d_1d( npti, nptidx(1:npti), h_ip_1d(1:npti)  , zhpnd_ini ) 
    307  
     320            CALL tab_2d_1d( npti, nptidx(1:npti), h_il_1d(1:npti)  , zhlid_ini ) 
     321             
    308322            ! allocate temporary arrays 
    309             ALLOCATE( zhi_2d(npti,jpl), zhs_2d(npti,jpl), zai_2d (npti,jpl), & 
    310                &      zti_2d(npti,jpl), zts_2d(npti,jpl), ztsu_2d(npti,jpl), zsi_2d(npti,jpl), zaip_2d(npti,jpl), zhip_2d(npti,jpl) ) 
    311              
     323            ALLOCATE( zhi_2d (npti,jpl), zhs_2d (npti,jpl), zai_2d (npti,jpl), & 
     324               &      zti_2d (npti,jpl), zts_2d (npti,jpl), ztsu_2d(npti,jpl), zsi_2d(npti,jpl), & 
     325               &      zaip_2d(npti,jpl), zhip_2d(npti,jpl), zhil_2d(npti,jpl) ) 
     326 
    312327            ! distribute 1-cat into jpl-cat: (jpi*jpj) -> (jpi*jpj,jpl) 
    313             CALL ice_var_itd( h_i_1d(1:npti)  , h_s_1d(1:npti)  , at_i_1d(1:npti),                                                   & 
    314                &              zhi_2d          , zhs_2d          , zai_2d         ,                                                   & 
    315                &              t_i_1d(1:npti,1), t_s_1d(1:npti,1), t_su_1d(1:npti), s_i_1d(1:npti), a_ip_1d(1:npti), h_ip_1d(1:npti), & 
    316                &              zti_2d          , zts_2d          , ztsu_2d        , zsi_2d        , zaip_2d        , zhip_2d ) 
     328            CALL ice_var_itd( h_i_1d(1:npti)  , h_s_1d(1:npti)  , at_i_1d(1:npti),                  & 
     329               &              zhi_2d          , zhs_2d          , zai_2d         ,                  & 
     330               &              t_i_1d(1:npti,1), t_s_1d(1:npti,1), t_su_1d(1:npti),                  & 
     331               &              s_i_1d(1:npti)  , a_ip_1d(1:npti) , h_ip_1d(1:npti), h_il_1d(1:npti), & 
     332               &              zti_2d          , zts_2d          , ztsu_2d        ,                  & 
     333               &              zsi_2d          , zaip_2d         , zhip_2d        , zhil_2d ) 
    317334 
    318335            ! move to 3D arrays: (jpi*jpj,jpl) -> (jpi,jpj,jpl) 
    … …  
    330347            CALL tab_2d_3d( npti, nptidx(1:npti), zaip_2d  , a_ip   ) 
    331348            CALL tab_2d_3d( npti, nptidx(1:npti), zhip_2d  , h_ip   ) 
     349            CALL tab_2d_3d( npti, nptidx(1:npti), zhil_2d  , h_il   ) 
    332350 
    333351            ! deallocate temporary arrays 
    334352            DEALLOCATE( zhi_2d, zhs_2d, zai_2d , & 
    335                &        zti_2d, zts_2d, ztsu_2d, zsi_2d, zaip_2d, zhip_2d ) 
     353               &        zti_2d, zts_2d, ztsu_2d, zsi_2d, zaip_2d, zhip_2d, zhil_2d ) 
    336354 
    337355            ! calculate extensive and intensive variables 
    … …  
    363381               END_3D 
    364382            END DO 
    365  
    366             ! Melt ponds 
    367             WHERE( a_i > epsi10 ) 
    368                a_ip_frac(:,:,:) = a_ip(:,:,:) / a_i(:,:,:) 
    369             ELSEWHERE 
    370                a_ip_frac(:,:,:) = 0._wp 
    371             END WHERE 
    372             v_ip(:,:,:) = h_ip(:,:,:) * a_ip(:,:,:) 
    373               
    374             ! specific temperatures for coupled runs 
    375             tn_ice(:,:,:) = t_su(:,:,:) 
    376             t1_ice(:,:,:) = t_i (:,:,1,:) 
    377             ! 
    378           
     383             
    379384#if  defined key_agrif 
    380385         ELSE 
    … …  
    391396            Agrif_UseSpecialValue = .FALSE. 
    392397        ! lbc ????  
    393    ! Here we know : a_i, v_i, v_s, sv_i, oa_i, a_ip, v_ip, t_su, e_s, e_i 
     398   ! Here we know : a_i, v_i, v_s, sv_i, oa_i, a_ip, v_ip, v_il, t_su, e_s, e_i 
    394399            CALL ice_var_glo2eqv 
    395400            CALL ice_var_zapsmall 
    396401            CALL ice_var_agg(2) 
    397  
    398             ! Melt ponds 
    399             WHERE( a_i > epsi10 ) 
    400                a_ip_frac(:,:,:) = a_ip(:,:,:) / a_i(:,:,:) 
    401             ELSEWHERE 
    402                a_ip_frac(:,:,:) = 0._wp 
    403             END WHERE 
    404             WHERE( a_ip > 0._wp )       ! ???????     
    405                h_ip(:,:,:) = v_ip(:,:,:) / a_ip(:,:,:) 
    406             ELSEWHERE 
    407                h_ip(:,:,:) = 0._wp 
    408             END WHERE    
    409  
    410             tn_ice(:,:,:) = t_su(:,:,:) 
    411             t1_ice(:,:,:) = t_i (:,:,1,:) 
    412402#endif 
    413           ENDIF ! Agrif_Root 
     403         ENDIF ! Agrif_Root 
     404         ! 
     405         ! Melt ponds 
     406         WHERE( a_i > epsi10 )   ;   a_ip_eff(:,:,:) = a_ip(:,:,:) / a_i(:,:,:) 
     407         ELSEWHERE               ;   a_ip_eff(:,:,:) = 0._wp 
     408         END WHERE 
     409         v_ip(:,:,:) = h_ip(:,:,:) * a_ip(:,:,:) 
     410         v_il(:,:,:) = h_il(:,:,:) * a_ip(:,:,:) 
     411          
     412         ! specific temperatures for coupled runs 
     413         tn_ice(:,:,:) = t_su(:,:,:) 
     414         t1_ice(:,:,:) = t_i (:,:,1,:) 
     415         ! 
     416         ! ice concentration should not exceed amax 
     417         at_i(:,:) = SUM( a_i, dim=3 ) 
     418         DO jl = 1, jpl 
     419            WHERE( at_i(:,:) > rn_amax_2d(:,:) )   a_i(:,:,jl) = a_i(:,:,jl) * rn_amax_2d(:,:) / at_i(:,:) 
     420         END DO 
     421         at_i(:,:) = SUM( a_i, dim=3 ) 
     422         ! 
    414423      ENDIF ! ln_iceini 
    415424      ! 
    416       at_i(:,:) = SUM( a_i, dim=3 ) 
    417       ! 
    418425      !---------------------------------------------- 
    419       ! 3) Snow-ice mass (case ice is fully embedded) 
     426      ! 4) Snow-ice mass (case ice is fully embedded) 
    420427      !---------------------------------------------- 
    421428      snwice_mass  (:,:) = tmask(:,:,1) * SUM( rhos * v_s(:,:,:) + rhoi * v_i(:,:,:), dim=3  )   ! snow+ice mass 
    … …  
    469476!          ENDIF 
    470477      ENDIF 
    471        
    472       !------------------------------------ 
    473       ! 4) store fields at before time-step 
    474       !------------------------------------ 
    475       ! it is only necessary for the 1st interpolation by Agrif 
    476       a_i_b  (:,:,:)   = a_i  (:,:,:) 
    477       e_i_b  (:,:,:,:) = e_i  (:,:,:,:) 
    478       v_i_b  (:,:,:)   = v_i  (:,:,:) 
    479       v_s_b  (:,:,:)   = v_s  (:,:,:) 
    480       e_s_b  (:,:,:,:) = e_s  (:,:,:,:) 
    481       sv_i_b (:,:,:)   = sv_i (:,:,:) 
    482       oa_i_b (:,:,:)   = oa_i (:,:,:) 
    483       u_ice_b(:,:)     = u_ice(:,:) 
    484       v_ice_b(:,:)     = v_ice(:,:) 
    485       ! total concentration is needed for Lupkes parameterizations 
    486       at_i_b (:,:)     = at_i (:,:)  
    487  
    488 !!clem: output of initial state should be written here but it is impossible because 
    489 !!      the ocean and ice are in the same file 
    490 !!      CALL dia_wri_state( Kmm, 'output.init' ) 
     478 
     479      !!clem: output of initial state should be written here but it is impossible because 
     480      !!      the ocean and ice are in the same file 
     481      !!      CALL dia_wri_state( 'output.init' ) 
    491482      ! 
    492483   END SUBROUTINE ice_istate 
    … …  
    505496      !! 
    506497      !!----------------------------------------------------------------------------- 
    507       INTEGER ::   ios, ifpr, ierror   ! Local integers 
    508  
     498      INTEGER ::   ios   ! Local integer output status for namelist read 
     499      INTEGER ::   ifpr, ierror 
    509500      ! 
    510501      CHARACTER(len=256) ::  cn_dir          ! Root directory for location of ice files 
    511       TYPE(FLD_N)                    ::   sn_hti, sn_hts, sn_ati, sn_smi, sn_tmi, sn_tsu, sn_tms, sn_apd, sn_hpd 
     502      TYPE(FLD_N)                    ::   sn_hti, sn_hts, sn_ati, sn_smi, sn_tmi, sn_tsu, sn_tms, sn_apd, sn_hpd, sn_hld 
    512503      TYPE(FLD_N), DIMENSION(jpfldi) ::   slf_i                 ! array of namelist informations on the fields to read 
    513504      ! 
    514       NAMELIST/namini/ ln_iceini, ln_iceini_file, rn_thres_sst, & 
     505      NAMELIST/namini/ ln_iceini, nn_iceini_file, rn_thres_sst, & 
    515506         &             rn_hti_ini_n, rn_hti_ini_s, rn_hts_ini_n, rn_hts_ini_s, & 
    516507         &             rn_ati_ini_n, rn_ati_ini_s, rn_smi_ini_n, rn_smi_ini_s, & 
    517508         &             rn_tmi_ini_n, rn_tmi_ini_s, rn_tsu_ini_n, rn_tsu_ini_s, rn_tms_ini_n, rn_tms_ini_s, & 
    518          &             rn_apd_ini_n, rn_apd_ini_s, rn_hpd_ini_n, rn_hpd_ini_s, & 
    519          &             sn_hti, sn_hts, sn_ati, sn_tsu, sn_tmi, sn_smi, sn_tms, sn_apd, sn_hpd, cn_dir 
     509         &             rn_apd_ini_n, rn_apd_ini_s, rn_hpd_ini_n, rn_hpd_ini_s, rn_hld_ini_n, rn_hld_ini_s, & 
     510         &             sn_hti, sn_hts, sn_ati, sn_tsu, sn_tmi, sn_smi, sn_tms, sn_apd, sn_hpd, sn_hld, cn_dir 
    520511      !!----------------------------------------------------------------------------- 
    521512      ! 
    … …  
    529520      slf_i(jp_ati) = sn_ati  ;  slf_i(jp_smi) = sn_smi 
    530521      slf_i(jp_tmi) = sn_tmi  ;  slf_i(jp_tsu) = sn_tsu   ;   slf_i(jp_tms) = sn_tms 
    531       slf_i(jp_apd) = sn_apd  ;  slf_i(jp_hpd) = sn_hpd 
     522      slf_i(jp_apd) = sn_apd  ;  slf_i(jp_hpd) = sn_hpd   ;   slf_i(jp_hld) = sn_hld 
    532523      ! 
    533524      IF(lwp) THEN                          ! control print 
    … …  
    537528         WRITE(numout,*) '   Namelist namini:' 
    538529         WRITE(numout,*) '      ice initialization (T) or not (F)                ln_iceini      = ', ln_iceini 
    539          WRITE(numout,*) '      ice initialization from a netcdf file            ln_iceini_file = ', ln_iceini_file 
     530         WRITE(numout,*) '      ice initialization from a netcdf file            nn_iceini_file = ', nn_iceini_file 
    540531         WRITE(numout,*) '      max ocean temp. above Tfreeze with initial ice   rn_thres_sst   = ', rn_thres_sst 
    541          IF( ln_iceini .AND. .NOT.ln_iceini_file ) THEN 
     532         IF( ln_iceini .AND. nn_iceini_file == 0 ) THEN 
    542533            WRITE(numout,*) '      initial snw thickness in the north-south         rn_hts_ini     = ', rn_hts_ini_n,rn_hts_ini_s  
    543534            WRITE(numout,*) '      initial ice thickness in the north-south         rn_hti_ini     = ', rn_hti_ini_n,rn_hti_ini_s 
    … …  
    549540            WRITE(numout,*) '      initial pnd fraction  in the north-south         rn_apd_ini     = ', rn_apd_ini_n,rn_apd_ini_s 
    550541            WRITE(numout,*) '      initial pnd depth     in the north-south         rn_hpd_ini     = ', rn_hpd_ini_n,rn_hpd_ini_s 
     542            WRITE(numout,*) '      initial pnd lid depth in the north-south         rn_hld_ini     = ', rn_hld_ini_n,rn_hld_ini_s 
    551543         ENDIF 
    552544      ENDIF 
    553545      ! 
    554       IF( ln_iceini_file ) THEN                      ! Ice initialization using input file 
     546      IF( nn_iceini_file == 1 ) THEN                      ! Ice initialization using input file 
    555547         ! 
    556548         ! set si structure 
    … …  
    573565         rn_apd_ini_n = 0. ; rn_apd_ini_s = 0. 
    574566         rn_hpd_ini_n = 0. ; rn_hpd_ini_s = 0. 
    575          CALL ctl_warn( 'rn_apd_ini & rn_hpd_ini = 0 when no ponds' ) 
     567         rn_hld_ini_n = 0. ; rn_hld_ini_s = 0. 
     568         CALL ctl_warn( 'rn_apd_ini & rn_hpd_ini = 0 & rn_hld_ini = 0 when no ponds' ) 
     569      ENDIF 
     570      ! 
     571      IF( .NOT.ln_pnd_lids ) THEN 
     572         rn_hld_ini_n = 0. ; rn_hld_ini_s = 0. 
    576573      ENDIF 
    577574      ! 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/ICE/iceitd.F90

    r13295 r13571  
    4747   LOGICAL                    ::   ln_cat_usr   ! ice categories are defined by rn_catbnd 
    4848   REAL(wp), DIMENSION(0:100) ::   rn_catbnd    ! ice categories bounds 
     49   REAL(wp)                   ::   rn_himax     ! maximum ice thickness allowed 
    4950   ! 
    5051   !! * Substitutions 
    … …  
    314315            IF ( a_i_1d(ji) > epsi10 .AND. h_i_1d(ji) < rn_himin ) THEN 
    315316               a_i_1d(ji) = a_i_1d(ji) * h_i_1d(ji) / rn_himin  
    316                IF( ln_pnd_H12 )   a_ip_1d(ji) = a_ip_1d(ji) * h_i_1d(ji) / rn_himin 
     317               IF( ln_pnd_LEV )   a_ip_1d(ji) = a_ip_1d(ji) * h_i_1d(ji) / rn_himin 
    317318               h_i_1d(ji) = rn_himin 
    318319            ENDIF 
    … …  
    420421      CALL tab_3d_2d( npti, nptidx(1:npti), a_ip_2d(1:npti,1:jpl), a_ip ) 
    421422      CALL tab_3d_2d( npti, nptidx(1:npti), v_ip_2d(1:npti,1:jpl), v_ip ) 
     423      CALL tab_3d_2d( npti, nptidx(1:npti), v_il_2d(1:npti,1:jpl), v_il ) 
    422424      CALL tab_3d_2d( npti, nptidx(1:npti), t_su_2d(1:npti,1:jpl), t_su ) 
    423425      DO jl = 1, jpl 
    … …  
    484486               zaTsfn(ji,jl2)  = zaTsfn(ji,jl2) + ztrans 
    485487               !   
    486                IF ( ln_pnd_H12 ) THEN 
     488               IF ( ln_pnd_LEV ) THEN 
    487489                  ztrans          = a_ip_2d(ji,jl1) * zworka(ji)     ! Pond fraction 
    488490                  a_ip_2d(ji,jl1) = a_ip_2d(ji,jl1) - ztrans 
    … …  
    492494                  v_ip_2d(ji,jl1) = v_ip_2d(ji,jl1) - ztrans 
    493495                  v_ip_2d(ji,jl2) = v_ip_2d(ji,jl2) + ztrans 
     496                  ! 
     497                  IF ( ln_pnd_lids ) THEN                            ! Pond lid volume 
     498                     ztrans          = v_il_2d(ji,jl1) * zworka(ji) 
     499                     v_il_2d(ji,jl1) = v_il_2d(ji,jl1) - ztrans 
     500                     v_il_2d(ji,jl2) = v_il_2d(ji,jl2) + ztrans 
     501                  ENDIF 
    494502               ENDIF 
    495503               ! 
    … …  
    536544      ! clem: The transfer between one category to another can lead to very small negative values (-1.e-20) 
    537545      !       because of truncation error ( i.e. 1. - 1. /= 0 ) 
    538       CALL ice_var_roundoff( a_i_2d, v_i_2d, v_s_2d, sv_i_2d, oa_i_2d, a_ip_2d, v_ip_2d, ze_s_2d, ze_i_2d ) 
     546      CALL ice_var_roundoff( a_i_2d, v_i_2d, v_s_2d, sv_i_2d, oa_i_2d, a_ip_2d, v_ip_2d, v_il_2d, ze_s_2d, ze_i_2d ) 
    539547 
    540548      ! at_i must be <= rn_amax 
    … …  
    568576      CALL tab_2d_3d( npti, nptidx(1:npti), a_ip_2d(1:npti,1:jpl), a_ip ) 
    569577      CALL tab_2d_3d( npti, nptidx(1:npti), v_ip_2d(1:npti,1:jpl), v_ip ) 
     578      CALL tab_2d_3d( npti, nptidx(1:npti), v_il_2d(1:npti,1:jpl), v_il ) 
    570579      CALL tab_2d_3d( npti, nptidx(1:npti), t_su_2d(1:npti,1:jpl), t_su ) 
    571580      DO jl = 1, jpl 
    … …  
    693702      REAL(wp) ::   zhmax, znum, zden, zalpha   !   -      - 
    694703      ! 
    695       NAMELIST/namitd/ ln_cat_hfn, rn_himean, ln_cat_usr, rn_catbnd, rn_himin 
     704      NAMELIST/namitd/ ln_cat_hfn, rn_himean, ln_cat_usr, rn_catbnd, rn_himin, rn_himax 
    696705      !!------------------------------------------------------------------ 
    697706      ! 
    … …  
    710719         WRITE(numout,*) '         mean ice thickness in the domain                               rn_himean  = ', rn_himean 
    711720         WRITE(numout,*) '      Ice categories are defined by rn_catbnd                           ln_cat_usr = ', ln_cat_usr 
    712          WRITE(numout,*) '      minimum ice thickness                                             rn_himin   = ', rn_himin  
     721         WRITE(numout,*) '      minimum ice thickness allowed                                     rn_himin   = ', rn_himin  
     722         WRITE(numout,*) '      maximum ice thickness allowed                                     rn_himax   = ', rn_himax  
    713723      ENDIF 
    714724      ! 
    … …  
    747757      END DO 
    748758      ! 
    749       hi_max(jpl) = 99._wp          ! set to a big value to ensure that all ice is thinner than hi_max(jpl) 
     759      hi_max(jpl) = rn_himax        ! set to a big value to ensure that all ice is thinner than hi_max(jpl) 
    750760      ! 
    751761      IF(lwp) WRITE(numout,*) 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/ICE/icerst.F90

    r13286 r13571  
    1818   USE phycst  , ONLY : rt0 
    1919   USE sbc_oce , ONLY : nn_fsbc, ln_cpl 
     20   USE sbc_oce , ONLY : nn_components, jp_iam_sas   ! SAS ss[st]_m init 
     21   USE sbc_oce , ONLY : sst_m, sss_m                ! SAS ss[st]_m init 
     22   USE oce     , ONLY : ts                          ! SAS ss[st]_m init 
     23   USE eosbn2  , ONLY : l_useCT, eos_pt_from_ct     ! SAS ss[st]_m init 
    2024   USE iceistate      ! sea-ice: initial state 
    2125   USE icectl         ! sea-ice: control 
    … …  
    132136      CALL iom_rstput( iter, nitrst, numriw, 'a_ip' , a_ip  ) 
    133137      CALL iom_rstput( iter, nitrst, numriw, 'v_ip' , v_ip  ) 
     138      CALL iom_rstput( iter, nitrst, numriw, 'v_il' , v_il  ) 
    134139      ! Snow enthalpy 
    135140      DO jk = 1, nlay_s  
    … …  
    172177      INTEGER           ::   jk 
    173178      LOGICAL           ::   llok 
    174       INTEGER           ::   id0, id1, id2, id3, id4   ! local integer 
     179      INTEGER           ::   id0, id1, id2, id3, id4, id5   ! local integer 
    175180      CHARACTER(len=25) ::   znam 
    176181      CHARACTER(len=2)  ::   zchar, zchar1 
    … …  
    251256            v_ip(:,:,:) = 0._wp 
    252257         ENDIF 
     258         ! melt pond lids 
     259         id3 = iom_varid( numrir, 'v_il' , ldstop = .FALSE. ) 
     260         IF( id3 > 0 ) THEN 
     261            CALL iom_get( numrir, jpdom_auto, 'v_il', v_il) 
     262         ELSE 
     263            IF(lwp) WRITE(numout,*) '   ==>>   previous run without melt ponds lids output then set it to zero' 
     264            v_il(:,:,:) = 0._wp 
     265         ENDIF 
    253266         ! fields needed for Met Office (Jules) coupling 
    254267         IF( ln_cpl ) THEN 
    255             id3 = iom_varid( numrir, 'cnd_ice' , ldstop = .FALSE. ) 
    256             id4 = iom_varid( numrir, 't1_ice'  , ldstop = .FALSE. ) 
    257             IF( id3 > 0 .AND. id4 > 0 ) THEN         ! fields exist 
     268            id4 = iom_varid( numrir, 'cnd_ice' , ldstop = .FALSE. ) 
     269            id5 = iom_varid( numrir, 't1_ice'  , ldstop = .FALSE. ) 
     270            IF( id4 > 0 .AND. id5 > 0 ) THEN         ! fields exist 
    258271               CALL iom_get( numrir, jpdom_auto, 'cnd_ice', cnd_ice ) 
    259272               CALL iom_get( numrir, jpdom_auto, 't1_ice' , t1_ice  ) 
    … …  
    270283      ELSE                 ! == case of a simplified restart == ! 
    271284         !                 ! ---------------------------------- ! 
    272          CALL ctl_warn('ice_rst_read: you are using a simplified ice restart') 
     285         CALL ctl_warn('ice_rst_read: you are attempting to use an unsuitable ice restart') 
    273286         ! 
    274          CALL ice_istate_init 
     287         IF( .NOT. ln_iceini .OR. nn_iceini_file == 2 ) THEN 
     288            CALL ctl_stop('STOP', 'ice_rst_read: you need ln_ice_ini=T and nn_iceini_file=0 or 1') 
     289         ELSE 
     290            CALL ctl_warn('ice_rst_read: using ice_istate to set initial conditions instead') 
     291         ENDIF 
     292         ! 
     293         IF( nn_components == jp_iam_sas ) THEN   ! SAS case: ss[st]_m were not initialized by sbc_ssm_init 
     294            ! 
     295            IF(lwp) WRITE(numout,*) '  SAS: default initialisation of ss[st]_m arrays used in ice_istate' 
     296            IF( l_useCT )  THEN    ;   sst_m(:,:) = eos_pt_from_ct( ts(:,:,1,jp_tem, Kmm), ts(:,:,1,jp_sal, Kmm) ) 
     297            ELSE                   ;   sst_m(:,:) = ts(:,:,1,jp_tem, Kmm) 
     298            ENDIF 
     299            sss_m(:,:) = ts(:,:,1,jp_sal, Kmm) 
     300         ENDIF 
     301         ! 
    275302         CALL ice_istate( nit000, Kbb, Kmm, Kaa ) 
    276303         ! 
    277          IF( .NOT.ln_iceini .OR. .NOT.ln_iceini_file ) & 
    278             &   CALL ctl_stop('STOP', 'ice_rst_read: you need ln_ice_ini=T and ln_iceini_file=T') 
    279          ! 
    280304      ENDIF 
    281305 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/ICE/icesbc.F90

    r13295 r13571  
    119119      INTEGER  ::   ji, jj, jl      ! dummy loop index 
    120120      REAL(wp) ::   zmiss_val       ! missing value retrieved from xios  
    121       REAL(wp), DIMENSION(jpi,jpj,jpl)              ::   zalb_os, zalb_cs  ! ice albedo under overcast/clear sky 
    122       REAL(wp), DIMENSION(:,:)        , ALLOCATABLE ::   zalb, zmsk00      ! 2D workspace 
     121      REAL(wp), DIMENSION(:,:), ALLOCATABLE ::   zalb, zmsk00      ! 2D workspace 
    123122      !!-------------------------------------------------------------------- 
    124123      ! 
    … …  
    134133      CALL iom_miss_val( "icetemp", zmiss_val ) 
    135134 
    136       ! --- cloud-sky and overcast-sky ice albedos --- ! 
    137       CALL ice_alb( t_su, h_i, h_s, ln_pnd_alb, a_ip_frac, h_ip, zalb_cs, zalb_os ) 
    138  
    139       ! albedo depends on cloud fraction because of non-linear spectral effects 
    140 !!gm cldf_ice is a real, DOCTOR naming rule: start with cd means CHARACTER passed in argument ! 
    141       alb_ice(:,:,:) = ( 1. - cldf_ice ) * zalb_cs(:,:,:) + cldf_ice * zalb_os(:,:,:) 
    142       ! 
     135      ! --- ice albedo --- ! 
     136      CALL ice_alb( t_su, h_i, h_s, ln_pnd_alb, a_ip_eff, h_ip, cloud_fra, alb_ice ) 
     137 
    143138      ! 
    144139      SELECT CASE( ksbc )   !== fluxes over sea ice ==! 
    … …  
    285280      INTEGER ::   ios, ioptio   ! Local integer 
    286281      !! 
    287       NAMELIST/namsbc/ rn_cio, rn_blow_s, nn_flxdist, ln_cndflx, ln_cndemulate 
     282      NAMELIST/namsbc/ rn_cio, nn_snwfra, rn_snwblow, nn_flxdist, ln_cndflx, ln_cndemulate, nn_qtrice 
    288283      !!------------------------------------------------------------------- 
    289284      ! 
    … …  
    299294         WRITE(numout,*) '~~~~~~~~~~~~~~~~' 
    300295         WRITE(numout,*) '   Namelist namsbc:' 
    301          WRITE(numout,*) '      drag coefficient for oceanic stress              rn_cio        = ', rn_cio 
    302          WRITE(numout,*) '      coefficient for ice-lead partition of snowfall   rn_blow_s     = ', rn_blow_s 
    303          WRITE(numout,*) '      Multicategory heat flux formulation              nn_flxdist    = ', nn_flxdist 
    304          WRITE(numout,*) '      Use conduction flux as surface condition         ln_cndflx     = ', ln_cndflx 
    305          WRITE(numout,*) '         emulate conduction flux                       ln_cndemulate = ', ln_cndemulate 
     296         WRITE(numout,*) '      drag coefficient for oceanic stress                       rn_cio        = ', rn_cio 
     297         WRITE(numout,*) '      fraction of ice covered by snow (options 0,1,2)           nn_snwfra     = ', nn_snwfra 
     298         WRITE(numout,*) '      coefficient for ice-lead partition of snowfall            rn_snwblow    = ', rn_snwblow 
     299         WRITE(numout,*) '      Multicategory heat flux formulation                       nn_flxdist    = ', nn_flxdist 
     300         WRITE(numout,*) '      Use conduction flux as surface condition                  ln_cndflx     = ', ln_cndflx 
     301         WRITE(numout,*) '         emulate conduction flux                                ln_cndemulate = ', ln_cndemulate 
     302         WRITE(numout,*) '      solar flux transmitted thru the surface scattering layer  nn_qtrice     = ', nn_qtrice 
     303         WRITE(numout,*) '         = 0  Grenfell and Maykut 1977' 
     304         WRITE(numout,*) '         = 1  Lebrun 2019' 
    306305      ENDIF 
    307306      ! 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/ICE/icestp.F90

    r13216 r13571  
    201201         IF( lrst_ice )                 CALL ice_rst_write( kt )      ! -- Ice restart file  
    202202         ! 
    203          IF( ln_icectl )                CALL ice_ctl( kt )            ! -- alerts in case of model crash 
     203         IF( ln_icectl )                CALL ice_ctl( kt )            ! -- Control checks 
    204204         ! 
    205205      ENDIF   ! End sea-ice time step only 
    … …  
    224224      INTEGER, INTENT(in) :: Kbb, Kmm, Kaa 
    225225      ! 
    226       INTEGER :: ji, jj, ierr 
     226      INTEGER ::   ierr 
    227227      !!---------------------------------------------------------------------- 
    228228      IF(lwp) WRITE(numout,*) 
    … …  
    252252      IF( ierr /= 0 )   CALL ctl_stop('STOP', 'ice_init : unable to allocate ice arrays') 
    253253      ! 
    254       CALL ice_itd_init                ! ice thickness distribution initialization 
    255       ! 
    256       CALL ice_thd_init                ! set ice thermodynics parameters (clem: important to call it first for melt ponds) 
    257       ! 
    258       !                                ! Initial sea-ice state 
    259       IF( .NOT. ln_rstart ) THEN              ! start from rest: sea-ice deduced from sst 
    260          CALL ice_istate_init 
    261          CALL ice_istate( nit000, Kbb, Kmm, Kaa ) 
    262       ELSE                                    ! start from a restart file 
    263          CALL ice_rst_read( Kbb, Kmm, Kaa ) 
    264       ENDIF 
    265       CALL ice_var_glo2eqv 
    266       CALL ice_var_agg(1) 
    267       ! 
    268       CALL ice_sbc_init                ! set ice-ocean and ice-atm. coupling parameters 
    269       ! 
    270       CALL ice_dyn_init                ! set ice dynamics parameters 
    271       ! 
    272       CALL ice_update_init             ! ice surface boundary condition 
    273       ! 
    274       CALL ice_alb_init                ! ice surface albedo 
    275       ! 
    276       CALL ice_dia_init                ! initialization for diags 
    277       ! 
    278       fr_i  (:,:)   = at_i(:,:)        ! initialisation of sea-ice fraction 
    279       tn_ice(:,:,:) = t_su(:,:,:)      ! initialisation of surface temp for coupled simu 
    280       ! 
    281254      !                                ! set max concentration in both hemispheres 
    282255      WHERE( gphit(:,:) > 0._wp )   ;   rn_amax_2d(:,:) = rn_amax_n  ! NH 
    283256      ELSEWHERE                     ;   rn_amax_2d(:,:) = rn_amax_s  ! SH 
    284257      END WHERE 
    285  
     258      ! 
     259      CALL diag_set0                   ! set diag of mass, heat and salt fluxes to 0: needed for Agrif child grids 
     260      ! 
     261      CALL ice_itd_init                ! ice thickness distribution initialization 
     262      ! 
     263      CALL ice_thd_init                ! set ice thermodynics parameters (clem: important to call it first for melt ponds) 
     264      ! 
     265      CALL ice_sbc_init                ! set ice-ocean and ice-atm. coupling parameters 
     266      ! 
     267      CALL ice_istate_init             ! Initial sea-ice state 
     268      IF ( ln_rstart .OR. nn_iceini_file == 2 ) THEN 
     269         CALL ice_rst_read( Kbb, Kmm, Kaa )         ! start from a restart file 
     270      ELSE 
     271         CALL ice_istate( nit000, Kbb, Kmm, Kaa )   ! start from rest or read a file 
     272      ENDIF 
     273      CALL ice_var_glo2eqv 
     274      CALL ice_var_agg(1) 
     275      ! 
     276      CALL ice_dyn_init                ! set ice dynamics parameters 
     277      ! 
     278      CALL ice_update_init             ! ice surface boundary condition 
     279      ! 
     280      CALL ice_alb_init                ! ice surface albedo 
     281      ! 
     282      CALL ice_dia_init                ! initialization for diags 
     283      ! 
     284      fr_i  (:,:)   = at_i(:,:)        ! initialisation of sea-ice fraction 
     285      tn_ice(:,:,:) = t_su(:,:,:)      ! initialisation of surface temp for coupled simu 
     286      ! 
    286287      IF( ln_rstart )   CALL iom_close( numrir )  ! close input ice restart file 
    287288      ! 
    … …  
    366367      v_s_b (:,:,:)   = v_s (:,:,:)     ! snow volume 
    367368      sv_i_b(:,:,:)   = sv_i(:,:,:)     ! salt content 
    368       oa_i_b(:,:,:)   = oa_i(:,:,:)     ! areal age content 
    369369      e_s_b (:,:,:,:) = e_s (:,:,:,:)   ! snow thermal energy 
    370370      e_i_b (:,:,:,:) = e_i (:,:,:,:)   ! ice thermal energy 
    … …  
    375375         h_i_b(:,:,:) = 0._wp 
    376376         h_s_b(:,:,:) = 0._wp 
    377       END WHERE 
    378        
    379       WHERE( a_ip(:,:,:) >= epsi20 ) 
    380          h_ip_b(:,:,:) = v_ip(:,:,:) / a_ip(:,:,:)   ! ice pond thickness 
    381       ELSEWHERE 
    382          h_ip_b(:,:,:) = 0._wp 
    383377      END WHERE 
    384378      ! 
    … …  
    424418      hfx_res(:,:) = 0._wp   ;   hfx_sub(:,:) = 0._wp 
    425419      hfx_spr(:,:) = 0._wp   ;   hfx_dif(:,:) = 0._wp 
    426       hfx_err_rem(:,:) = 0._wp 
    427420      hfx_err_dif(:,:) = 0._wp 
    428421      wfx_err_sub(:,:) = 0._wp 
    … …  
    445438      diag_trp_ei(:,:) = 0._wp   ;   diag_trp_es(:,:) = 0._wp 
    446439      diag_trp_sv(:,:) = 0._wp 
    447  
     440       
    448441   END SUBROUTINE diag_set0 
    449442 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/ICE/icethd.F90

    r13295 r13571  
    3535   ! 
    3636   USE in_out_manager ! I/O manager 
     37   USE iom            ! I/O manager library 
    3738   USE lib_mpp        ! MPP library 
    3839   USE lib_fortran    ! fortran utilities (glob_sum + no signed zero) 
    … …  
    5152   LOGICAL ::   ln_icedO         ! activate ice growth in open-water (T) or not (F) 
    5253   LOGICAL ::   ln_icedS         ! activate gravity drainage and flushing (T) or not (F) 
     54   LOGICAL ::   ln_leadhfx       !  heat in the leads is used to melt sea-ice before warming the ocean 
     55 
     56   !! for convergence tests 
     57   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   ztice_cvgerr, ztice_cvgstp 
    5358 
    5459   !! * Substitutions 
    … …  
    101106         WRITE(numout,*) 'ice_thd: sea-ice thermodynamics' 
    102107         WRITE(numout,*) '~~~~~~~' 
     108      ENDIF 
     109 
     110      ! convergence tests 
     111      IF( ln_zdf_chkcvg ) THEN 
     112         ALLOCATE( ztice_cvgerr(jpi,jpj,jpl) , ztice_cvgstp(jpi,jpj,jpl) ) 
     113         ztice_cvgerr = 0._wp ; ztice_cvgstp = 0._wp 
    103114      ENDIF 
    104115       
    … …  
    159170         ! If the grid cell is fully covered by ice (no leads) => transfer energy from the lead budget to the ice bottom budget 
    160171         IF( ( zqld >= 0._wp .AND. at_i(ji,jj) > 0._wp ) .OR. at_i(ji,jj) >= (1._wp - epsi10) ) THEN 
    161             fhld (ji,jj) = rswitch * zqld * r1_Dt_ice / MAX( at_i(ji,jj), epsi10 ) ! divided by at_i since this is (re)multiplied by a_i in icethd_dh.F90 
     172            IF( ln_leadhfx ) THEN   ;   fhld(ji,jj) = rswitch * zqld * r1_Dt_ice / MAX( at_i(ji,jj), epsi10 ) ! divided by at_i since this is (re)multiplied by a_i in icethd_dh.F90 
     173            ELSE                    ;   fhld(ji,jj) = 0._wp 
     174            ENDIF 
    162175            qlead(ji,jj) = 0._wp 
    163176         ELSE 
    … …  
    208221            !                                                       ! --- & Change units of e_i, e_s from J/m2 to J/m3 --- ! 
    209222            ! 
    210             s_i_new   (1:npti) = 0._wp ; dh_s_tot(1:npti) = 0._wp  ! --- some init --- !  (important to have them here)  
     223            s_i_new   (1:npti) = 0._wp ; dh_s_tot(1:npti) = 0._wp   ! --- some init --- !  (important to have them here)  
    211224            dh_i_sum  (1:npti) = 0._wp ; dh_i_bom(1:npti) = 0._wp ; dh_i_itm  (1:npti) = 0._wp  
    212225            dh_i_sub  (1:npti) = 0._wp ; dh_i_bog(1:npti) = 0._wp 
    … …  
    218231                              CALL ice_thd_dh                           ! Ice-Snow thickness    
    219232                              CALL ice_thd_pnd                          ! Melt ponds formation 
    220                               CALL ice_thd_ent( e_i_1d(1:npti,:), .true. )      ! Ice enthalpy remapping 
     233                              CALL ice_thd_ent( e_i_1d(1:npti,:) )      ! Ice enthalpy remapping 
    221234            ENDIF 
    222235                              CALL ice_thd_sal( ln_icedS )          ! --- Ice salinity --- !     
    … …  
    241254      ! 
    242255      IF( ln_icedO )          CALL ice_thd_do                       ! --- Frazil ice growth in leads --- ! 
     256      ! 
     257      ! convergence tests 
     258      IF( ln_zdf_chkcvg ) THEN 
     259         CALL iom_put( 'tice_cvgerr', ztice_cvgerr ) ; DEALLOCATE( ztice_cvgerr ) 
     260         CALL iom_put( 'tice_cvgstp', ztice_cvgstp ) ; DEALLOCATE( ztice_cvgstp ) 
     261      ENDIF 
    243262      ! 
    244263      ! controls 
    … …  
    347366         CALL tab_2d_1d( npti, nptidx(1:npti), a_ip_1d     (1:npti), a_ip     (:,:,kl) ) 
    348367         CALL tab_2d_1d( npti, nptidx(1:npti), h_ip_1d     (1:npti), h_ip     (:,:,kl) ) 
    349          CALL tab_2d_1d( npti, nptidx(1:npti), a_ip_frac_1d(1:npti), a_ip_frac(:,:,kl) ) 
     368         CALL tab_2d_1d( npti, nptidx(1:npti), h_il_1d     (1:npti), h_il     (:,:,kl) ) 
    350369         ! 
    351370         CALL tab_2d_1d( npti, nptidx(1:npti), qprec_ice_1d  (1:npti), qprec_ice            ) 
    … …  
    399418         CALL tab_2d_1d( npti, nptidx(1:npti), hfx_res_1d    (1:npti), hfx_res       ) 
    400419         CALL tab_2d_1d( npti, nptidx(1:npti), hfx_err_dif_1d(1:npti), hfx_err_dif   ) 
    401          CALL tab_2d_1d( npti, nptidx(1:npti), hfx_err_rem_1d(1:npti), hfx_err_rem   ) 
    402420         CALL tab_2d_1d( npti, nptidx(1:npti), qt_oce_ai_1d  (1:npti), qt_oce_ai     ) 
    403421         ! 
    … …  
    434452         sv_i_1d(1:npti) = s_i_1d (1:npti) * v_i_1d (1:npti) 
    435453         v_ip_1d(1:npti) = h_ip_1d(1:npti) * a_ip_1d(1:npti) 
     454         v_il_1d(1:npti) = h_il_1d(1:npti) * a_ip_1d(1:npti) 
    436455         oa_i_1d(1:npti) = o_i_1d (1:npti) * a_i_1d (1:npti) 
    437456          
    … …  
    453472         CALL tab_1d_2d( npti, nptidx(1:npti), a_ip_1d     (1:npti), a_ip     (:,:,kl) ) 
    454473         CALL tab_1d_2d( npti, nptidx(1:npti), h_ip_1d     (1:npti), h_ip     (:,:,kl) ) 
    455          CALL tab_1d_2d( npti, nptidx(1:npti), a_ip_frac_1d(1:npti), a_ip_frac(:,:,kl) ) 
     474         CALL tab_1d_2d( npti, nptidx(1:npti), h_il_1d     (1:npti), h_il     (:,:,kl) ) 
    456475         ! 
    457476         CALL tab_1d_2d( npti, nptidx(1:npti), wfx_snw_sni_1d(1:npti), wfx_snw_sni ) 
    … …  
    491510         CALL tab_1d_2d( npti, nptidx(1:npti), hfx_res_1d    (1:npti), hfx_res     ) 
    492511         CALL tab_1d_2d( npti, nptidx(1:npti), hfx_err_dif_1d(1:npti), hfx_err_dif ) 
    493          CALL tab_1d_2d( npti, nptidx(1:npti), hfx_err_rem_1d(1:npti), hfx_err_rem ) 
    494512         CALL tab_1d_2d( npti, nptidx(1:npti), qt_oce_ai_1d  (1:npti), qt_oce_ai   ) 
    495513         ! 
    … …  
    508526         CALL tab_1d_2d( npti, nptidx(1:npti), sv_i_1d(1:npti), sv_i(:,:,kl) ) 
    509527         CALL tab_1d_2d( npti, nptidx(1:npti), v_ip_1d(1:npti), v_ip(:,:,kl) ) 
     528         CALL tab_1d_2d( npti, nptidx(1:npti), v_il_1d(1:npti), v_il(:,:,kl) ) 
    510529         CALL tab_1d_2d( npti, nptidx(1:npti), oa_i_1d(1:npti), oa_i(:,:,kl) ) 
     530         ! check convergence of heat diffusion scheme 
     531         IF( ln_zdf_chkcvg ) THEN 
     532            CALL tab_1d_2d( npti, nptidx(1:npti), tice_cvgerr_1d(1:npti), ztice_cvgerr(:,:,kl) ) 
     533            CALL tab_1d_2d( npti, nptidx(1:npti), tice_cvgstp_1d(1:npti), ztice_cvgstp(:,:,kl) ) 
     534         ENDIF 
    511535         ! 
    512536      END SELECT 
    … …  
    529553      INTEGER  ::   ios   ! Local integer output status for namelist read 
    530554      !! 
    531       NAMELIST/namthd/ ln_icedH, ln_icedA, ln_icedO, ln_icedS 
     555      NAMELIST/namthd/ ln_icedH, ln_icedA, ln_icedO, ln_icedS, ln_leadhfx 
    532556      !!------------------------------------------------------------------- 
    533557      ! 
    … …  
    543567         WRITE(numout,*) '~~~~~~~~~~~~' 
    544568         WRITE(numout,*) '   Namelist namthd:' 
    545          WRITE(numout,*) '      activate ice thick change from top/bot (T) or not (F)   ln_icedH  = ', ln_icedH 
    546          WRITE(numout,*) '      activate lateral melting (T) or not (F)                 ln_icedA  = ', ln_icedA 
    547          WRITE(numout,*) '      activate ice growth in open-water (T) or not (F)        ln_icedO  = ', ln_icedO 
    548          WRITE(numout,*) '      activate gravity drainage and flushing (T) or not (F)   ln_icedS  = ', ln_icedS 
     569         WRITE(numout,*) '      activate ice thick change from top/bot (T) or not (F)                ln_icedH   = ', ln_icedH 
     570         WRITE(numout,*) '      activate lateral melting (T) or not (F)                              ln_icedA   = ', ln_icedA 
     571         WRITE(numout,*) '      activate ice growth in open-water (T) or not (F)                     ln_icedO   = ', ln_icedO 
     572         WRITE(numout,*) '      activate gravity drainage and flushing (T) or not (F)                ln_icedS   = ', ln_icedS 
     573         WRITE(numout,*) '      heat in the leads is used to melt sea-ice before warming the ocean   ln_leadhfx = ', ln_leadhfx 
    549574     ENDIF 
    550575      ! 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/ICE/icethd_dh.F90

    r13226 r13571  
    1313   !!---------------------------------------------------------------------- 
    1414   !!   ice_thd_dh        : vertical sea-ice growth and melt 
    15    !!   ice_thd_snwblow   : distribute snow fall between ice and ocean 
    16   !!---------------------------------------------------------------------- 
     15   !!---------------------------------------------------------------------- 
    1716   USE dom_oce        ! ocean space and time domain 
    1817   USE phycst         ! physical constants 
    … …  
    2019   USE ice1D          ! sea-ice: thermodynamics variables 
    2120   USE icethd_sal     ! sea-ice: salinity profiles 
     21   USE icevar         ! for CALL ice_var_snwblow 
    2222   ! 
    2323   USE in_out_manager ! I/O manager 
    … …  
    2929 
    3030   PUBLIC   ice_thd_dh        ! called by ice_thd 
    31    PUBLIC   ice_thd_snwblow   ! called in sbcblk/sbccpl and here 
    32  
    33    INTERFACE ice_thd_snwblow 
    34       MODULE PROCEDURE ice_thd_snwblow_1d, ice_thd_snwblow_2d 
    35    END INTERFACE 
    3631 
    3732   !!---------------------------------------------------------------------- 
    … …  
    186181      ! Snow precipitation 
    187182      !------------------- 
    188       CALL ice_thd_snwblow( 1.0_wp - at_i_1d(1:npti), zsnw(1:npti) )   ! snow distribution over ice after wind blowing 
     183      CALL ice_var_snwblow( 1.0_wp - at_i_1d(1:npti), zsnw(1:npti) )   ! snow distribution over ice after wind blowing 
    189184 
    190185      zdeltah(1:npti,:) = 0._wp 
    … …  
    636631   END SUBROUTINE ice_thd_dh 
    637632 
    638  
    639    !!-------------------------------------------------------------------------- 
    640    !! INTERFACE ice_thd_snwblow 
    641    !! 
    642    !! ** Purpose :   Compute distribution of precip over the ice 
    643    !! 
    644    !!                Snow accumulation in one thermodynamic time step 
    645    !!                snowfall is partitionned between leads and ice. 
    646    !!                If snow fall was uniform, a fraction (1-at_i) would fall into leads 
    647    !!                but because of the winds, more snow falls on leads than on sea ice 
    648    !!                and a greater fraction (1-at_i)^beta of the total mass of snow  
    649    !!                (beta < 1) falls in leads. 
    650    !!                In reality, beta depends on wind speed,  
    651    !!                and should decrease with increasing wind speed but here, it is  
    652    !!                considered as a constant. an average value is 0.66 
    653    !!-------------------------------------------------------------------------- 
    654 !!gm  I think it can be usefull to set this as a FUNCTION, not a SUBROUTINE.... 
    655    SUBROUTINE ice_thd_snwblow_2d( pin, pout ) 
    656       REAL(wp), DIMENSION(:,:), INTENT(in   ) :: pin   ! previous fraction lead ( 1. - a_i_b ) 
    657       REAL(wp), DIMENSION(:,:), INTENT(inout) :: pout 
    658       pout = ( 1._wp - ( pin )**rn_blow_s ) 
    659    END SUBROUTINE ice_thd_snwblow_2d 
    660  
    661    SUBROUTINE ice_thd_snwblow_1d( pin, pout ) 
    662       REAL(wp), DIMENSION(:), INTENT(in   ) :: pin 
    663       REAL(wp), DIMENSION(:), INTENT(inout) :: pout 
    664       pout = ( 1._wp - ( pin )**rn_blow_s ) 
    665    END SUBROUTINE ice_thd_snwblow_1d 
    666  
    667633#else 
    668634   !!---------------------------------------------------------------------- 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/ICE/icethd_do.F90

    r13295 r13571  
    385385            END DO 
    386386            ! --- Ice enthalpy remapping --- ! 
    387             CALL ice_thd_ent( ze_i_2d(1:npti,:,jl), .false. )  
     387            CALL ice_thd_ent( ze_i_2d(1:npti,:,jl) )  
    388388         END DO 
    389389 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/ICE/icethd_ent.F90

    r13226 r13571  
    3838CONTAINS 
    3939  
    40    SUBROUTINE ice_thd_ent( qnew, compute_hfx_err ) 
     40   SUBROUTINE ice_thd_ent( qnew ) 
    4141      !!------------------------------------------------------------------- 
    4242      !!               ***   ROUTINE ice_thd_ent  *** 
    … …  
    6464      !!------------------------------------------------------------------- 
    6565      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   qnew             ! new enthlapies (J.m-3, remapped) 
    66       LOGICAL, INTENT(in)                     ::   compute_hfx_err  ! determines whether to compute diag. 
    67                                                                     ! error or not 
    6866      ! 
    6967      INTEGER  :: ji         !  dummy loop indices 
    … …  
    130128      ! comment: if input h_i_old and eh_i_old are already multiplied by a_i (as in icethd_do),  
    131129      ! then we should not (* a_i) again but not important since this is just to check that remap error is ~0 
    132       IF( compute_hfx_err ) THEN 
    133          DO ji = 1, npti 
    134             hfx_err_rem_1d(ji) = hfx_err_rem_1d(ji) + a_i_1d(ji) * r1_Dt_ice *  & 
    135                &               ( SUM( qnew(ji,1:nlay_i) ) * zhnew(ji) - SUM( eh_i_old(ji,0:nlay_i+1) ) ) 
    136          END DO 
    137       END IF 
    138   
     130      !DO ji = 1, npti 
     131      !   hfx_err_rem_1d(ji) = hfx_err_rem_1d(ji) + a_i_1d(ji) * r1_Dt_ice *  & 
     132      !      &               ( SUM( qnew(ji,1:nlay_i) ) * zhnew(ji) - SUM( eh_i_old(ji,0:nlay_i+1) ) )  
     133      !END DO 
     134       
    139135   END SUBROUTINE ice_thd_ent 
    140136 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/ICE/icethd_pnd.F90

    r12489 r13571  
    3535   !                                   ! associated indices: 
    3636   INTEGER, PARAMETER ::   np_pndNO  = 0   ! No pond scheme 
    37    INTEGER, PARAMETER ::   np_pndCST = 1   ! Constant pond scheme 
    38    INTEGER, PARAMETER ::   np_pndH12 = 2   ! Evolutive pond scheme (Holland et al. 2012) 
     37   INTEGER, PARAMETER ::   np_pndCST = 1   ! Constant ice pond scheme 
     38   INTEGER, PARAMETER ::   np_pndLEV = 2   ! Level ice pond scheme 
    3939 
    4040   !!---------------------------------------------------------------------- 
    … …  
    4949      !!               ***  ROUTINE ice_thd_pnd   *** 
    5050      !!                
    51       !! ** Purpose :   change melt pond fraction 
     51      !! ** Purpose :   change melt pond fraction and thickness 
    5252      !!                 
    53       !! ** Method  :   brut force 
    5453      !!------------------------------------------------------------------- 
    5554      ! 
    … …  
    5857      CASE (np_pndCST)   ;   CALL pnd_CST    !==  Constant melt ponds  ==! 
    5958         ! 
    60       CASE (np_pndH12)   ;   CALL pnd_H12    !==  Holland et al 2012 melt ponds  ==! 
     59      CASE (np_pndLEV)   ;   CALL pnd_LEV    !==  Level ice melt ponds  ==! 
    6160         ! 
    6261      END SELECT 
    … …  
    8685         ! 
    8786         IF( a_i_1d(ji) > 0._wp .AND. t_su_1d(ji) >= rt0 ) THEN 
    88             a_ip_frac_1d(ji) = rn_apnd 
    8987            h_ip_1d(ji)      = rn_hpnd     
    90             a_ip_1d(ji)      = a_ip_frac_1d(ji) * a_i_1d(ji) 
     88            a_ip_1d(ji)      = rn_apnd * a_i_1d(ji) 
     89            h_il_1d(ji)      = 0._wp    ! no pond lids whatsoever 
    9190         ELSE 
    92             a_ip_frac_1d(ji) = 0._wp 
    9391            h_ip_1d(ji)      = 0._wp     
    9492            a_ip_1d(ji)      = 0._wp 
     93            h_il_1d(ji)      = 0._wp 
    9594         ENDIF 
    9695         ! 
    … …  
    10099 
    101100 
    102    SUBROUTINE pnd_H12 
    103       !!------------------------------------------------------------------- 
    104       !!                ***  ROUTINE pnd_H12  *** 
    105       !! 
    106       !! ** Purpose    : Compute melt pond evolution 
    107       !! 
    108       !! ** Method     : Empirical method. A fraction of meltwater is accumulated in ponds  
    109       !!                 and sent to ocean when surface is freezing 
    110       !! 
    111       !!                 pond growth:      Vp = Vp + dVmelt 
    112       !!                    with dVmelt = R/rhow * ( rhoi*dh_i + rhos*dh_s ) * a_i 
    113       !!                 pond contraction: Vp = Vp * exp(0.01*MAX(Tp-Tsu,0)/Tp) 
    114       !!                    with Tp = -2degC 
    115       !!   
    116       !! ** Tunable parameters : (no real expertise yet, ideas?) 
     101   SUBROUTINE pnd_LEV 
     102      !!------------------------------------------------------------------- 
     103      !!                ***  ROUTINE pnd_LEV  *** 
     104      !! 
     105      !! ** Purpose : Compute melt pond evolution 
     106      !! 
     107      !! ** Method  : A fraction of meltwater is accumulated in ponds and sent to ocean when surface is freezing 
     108      !!              We  work with volumes and then redistribute changes into thickness and concentration 
     109      !!              assuming linear relationship between the two.  
     110      !! 
     111      !! ** Action  : - pond growth:      Vp = Vp + dVmelt                                          --- from Holland et al 2012 --- 
     112      !!                                     dVmelt = (1-r)/rhow * ( rhoi*dh_i + rhos*dh_s ) * a_i 
     113      !!                                        dh_i  = meltwater from ice surface melt 
     114      !!                                        dh_s  = meltwater from snow melt 
     115      !!                                        (1-r) = fraction of melt water that is not flushed 
     116      !! 
     117      !!              - limtations:       a_ip must not exceed (1-r)*a_i 
     118      !!                                  h_ip must not exceed 0.5*h_i 
     119      !! 
     120      !!              - pond shrinking: 
     121      !!                       if lids:   Vp = Vp -dH * a_ip 
     122      !!                                     dH = lid thickness change. Retrieved from this eq.:    --- from Flocco et al 2010 --- 
     123      !! 
     124      !!                                                                   rhoi * Lf * dH/dt = ki * MAX(Tp-Tsu,0) / H  
     125      !!                                                                      H = lid thickness 
     126      !!                                                                      Lf = latent heat of fusion 
     127      !!                                                                      Tp = -2C 
     128      !! 
     129      !!                                                                And solved implicitely as: 
     130      !!                                                                   H(t+dt)**2 -H(t) * H(t+dt) -ki * (Tp-Tsu) * dt / (rhoi*Lf) = 0 
     131      !! 
     132      !!                    if no lids:   Vp = Vp * exp(0.01*MAX(Tp-Tsu,0)/Tp)                      --- from Holland et al 2012 --- 
     133      !! 
     134      !!              - Flushing:         w = -perm/visc * rho_oce * grav * Hp / Hi                 --- from Flocco et al 2007 --- 
     135      !!                                     perm = permability of sea-ice 
     136      !!                                     visc = water viscosity 
     137      !!                                     Hp   = height of top of the pond above sea-level 
     138      !!                                     Hi   = ice thickness thru which there is flushing 
     139      !! 
     140      !!              - Corrections:      remove melt ponds when lid thickness is 10 times the pond thickness 
     141      !! 
     142      !!              - pond thickness and area is retrieved from pond volume assuming a linear relationship between h_ip and a_ip: 
     143      !!                                  a_ip/a_i = a_ip_frac = h_ip / zaspect 
     144      !! 
     145      !! ** Tunable parameters : ln_pnd_lids, rn_apnd_max, rn_apnd_min 
    117146      !!  
    118       !! ** Note       : Stolen from CICE for quick test of the melt pond 
    119       !!                 radiation and freshwater interfaces 
    120       !!                 Coupling can be radiative AND freshwater 
    121       !!                 Advection, ridging, rafting are called 
    122       !! 
    123       !! ** References : Holland, M. M. et al (J Clim 2012) 
    124       !!------------------------------------------------------------------- 
    125       REAL(wp), PARAMETER ::   zrmin       = 0.15_wp  ! minimum fraction of available meltwater retained for melt ponding 
    126       REAL(wp), PARAMETER ::   zrmax       = 0.70_wp  ! maximum     -           -         -         -            - 
    127       REAL(wp), PARAMETER ::   zpnd_aspect = 0.8_wp   ! pond aspect ratio 
    128       REAL(wp), PARAMETER ::   zTp         = -2._wp   ! reference temperature 
    129       ! 
    130       REAL(wp) ::   zfr_mlt          ! fraction of available meltwater retained for melt ponding 
    131       REAL(wp) ::   zdv_mlt          ! available meltwater for melt ponding 
    132       REAL(wp) ::   z1_Tp            ! inverse reference temperature 
    133       REAL(wp) ::   z1_rhow          ! inverse freshwater density 
    134       REAL(wp) ::   z1_zpnd_aspect   ! inverse pond aspect ratio 
    135       REAL(wp) ::   zfac, zdum 
    136       ! 
    137       INTEGER  ::   ji   ! loop indices 
    138       !!------------------------------------------------------------------- 
    139       z1_rhow        = 1._wp / rhow  
    140       z1_zpnd_aspect = 1._wp / zpnd_aspect 
    141       z1_Tp          = 1._wp / zTp  
     147      !! ** Note       :   mostly stolen from CICE 
     148      !! 
     149      !! ** References :   Flocco and Feltham (JGR, 2007) 
     150      !!                   Flocco et al       (JGR, 2010) 
     151      !!                   Holland et al      (J. Clim, 2012) 
     152      !!------------------------------------------------------------------- 
     153      REAL(wp), DIMENSION(nlay_i) ::   ztmp           ! temporary array 
     154      !! 
     155      REAL(wp), PARAMETER ::   zaspect =  0.8_wp      ! pond aspect ratio 
     156      REAL(wp), PARAMETER ::   zTp     = -2._wp       ! reference temperature 
     157      REAL(wp), PARAMETER ::   zvisc   =  1.79e-3_wp  ! water viscosity 
     158      !! 
     159      REAL(wp) ::   zfr_mlt, zdv_mlt                  ! fraction and volume of available meltwater retained for melt ponding 
     160      REAL(wp) ::   zdv_frz, zdv_flush                ! Amount of melt pond that freezes, flushes 
     161      REAL(wp) ::   zhp                               ! heigh of top of pond lid wrt ssh 
     162      REAL(wp) ::   zv_ip_max                         ! max pond volume allowed 
     163      REAL(wp) ::   zdT                               ! zTp-t_su 
     164      REAL(wp) ::   zsbr                              ! Brine salinity 
     165      REAL(wp) ::   zperm                             ! permeability of sea ice 
     166      REAL(wp) ::   zfac, zdum                        ! temporary arrays 
     167      REAL(wp) ::   z1_rhow, z1_aspect, z1_Tp         ! inverse 
     168      !! 
     169      INTEGER  ::   ji, jk                            ! loop indices 
     170      !!------------------------------------------------------------------- 
     171      z1_rhow   = 1._wp / rhow  
     172      z1_aspect = 1._wp / zaspect 
     173      z1_Tp     = 1._wp / zTp  
    142174 
    143175      DO ji = 1, npti 
    144          !                                                        !--------------------------------! 
    145          IF( h_i_1d(ji) < rn_himin) THEN                          ! Case ice thickness < rn_himin ! 
    146             !                                                     !--------------------------------! 
    147             !--- Remove ponds on thin ice 
     176         !                                                            !----------------------------------------------------! 
     177         IF( h_i_1d(ji) < rn_himin .OR. a_i_1d(ji) < epsi10 ) THEN    ! Case ice thickness < rn_himin or tiny ice fraction ! 
     178            !                                                         !----------------------------------------------------! 
     179            !--- Remove ponds on thin ice or tiny ice fractions 
    148180            a_ip_1d(ji)      = 0._wp 
    149             a_ip_frac_1d(ji) = 0._wp 
    150181            h_ip_1d(ji)      = 0._wp 
    151             !                                                     !--------------------------------! 
    152          ELSE                                                     ! Case ice thickness >= rn_himin ! 
    153             !                                                     !--------------------------------! 
    154             v_ip_1d(ji) = h_ip_1d(ji) * a_ip_1d(ji)   ! record pond volume at previous time step 
    155             ! 
    156             ! available meltwater for melt ponding [m, >0] and fraction 
    157             zdv_mlt = -( dh_i_sum(ji)*rhoi + dh_s_mlt(ji)*rhos ) * z1_rhow * a_i_1d(ji) 
    158             zfr_mlt = zrmin + ( zrmax - zrmin ) * a_i_1d(ji)  ! from CICE doc 
    159             !zfr_mlt = zrmin + zrmax * a_i_1d(ji)             ! from Holland paper  
    160             ! 
    161             !--- Pond gowth ---! 
    162             ! v_ip should never be negative, otherwise code crashes 
    163             v_ip_1d(ji) = MAX( 0._wp, v_ip_1d(ji) + zfr_mlt * zdv_mlt ) 
    164             ! 
    165             ! melt pond mass flux (<0) 
     182            h_il_1d(ji)      = 0._wp 
     183            !                                                         !--------------------------------! 
     184         ELSE                                                         ! Case ice thickness >= rn_himin ! 
     185            !                                                         !--------------------------------! 
     186            v_ip_1d(ji) = h_ip_1d(ji) * a_ip_1d(ji)   ! retrieve volume from thickness 
     187            v_il_1d(ji) = h_il_1d(ji) * a_ip_1d(ji) 
     188            ! 
     189            !------------------! 
     190            ! case ice melting ! 
     191            !------------------! 
     192            ! 
     193            !--- available meltwater for melt ponding ---! 
     194            zdum    = -( dh_i_sum(ji)*rhoi + dh_s_mlt(ji)*rhos ) * z1_rhow * a_i_1d(ji) 
     195            zfr_mlt = rn_apnd_min + ( rn_apnd_max - rn_apnd_min ) * at_i_1d(ji) !  = ( 1 - r ) = fraction of melt water that is not flushed 
     196            zdv_mlt = MAX( 0._wp, zfr_mlt * zdum ) ! max for roundoff errors?  
     197            ! 
     198            !--- overflow ---! 
     199            ! If pond area exceeds zfr_mlt * a_i_1d(ji) then reduce the pond volume 
     200            !    a_ip_max = zfr_mlt * a_i 
     201            !    => from zaspect = h_ip / (a_ip / a_i), set v_ip_max as:  
     202            zv_ip_max = zfr_mlt**2 * a_i_1d(ji) * zaspect 
     203            zdv_mlt = MAX( 0._wp, MIN( zdv_mlt, zv_ip_max - v_ip_1d(ji) ) ) 
     204 
     205            ! If pond depth exceeds half the ice thickness then reduce the pond volume 
     206            !    h_ip_max = 0.5 * h_i 
     207            !    => from zaspect = h_ip / (a_ip / a_i), set v_ip_max as:  
     208            zv_ip_max = z1_aspect * a_i_1d(ji) * 0.25 * h_i_1d(ji) * h_i_1d(ji) 
     209            zdv_mlt = MAX( 0._wp, MIN( zdv_mlt, zv_ip_max - v_ip_1d(ji) ) ) 
     210             
     211            !--- Pond growing ---! 
     212            v_ip_1d(ji) = v_ip_1d(ji) + zdv_mlt 
     213            ! 
     214            !--- Lid melting ---! 
     215            IF( ln_pnd_lids )   v_il_1d(ji) = MAX( 0._wp, v_il_1d(ji) - zdv_mlt ) ! must be bounded by 0 
     216            ! 
     217            !--- mass flux ---! 
    166218            IF( zdv_mlt > 0._wp ) THEN 
    167                zfac = zfr_mlt * zdv_mlt * rhow * r1_Dt_ice 
     219               zfac = zdv_mlt * rhow * r1_Dt_ice                        ! melt pond mass flux < 0 [kg.m-2.s-1] 
    168220               wfx_pnd_1d(ji) = wfx_pnd_1d(ji) - zfac 
    169221               ! 
    170                ! adjust ice/snow melting flux to balance melt pond flux (>0) 
    171                zdum = zfac / ( wfx_snw_sum_1d(ji) + wfx_sum_1d(ji) ) 
     222               zdum = zfac / ( wfx_snw_sum_1d(ji) + wfx_sum_1d(ji) )    ! adjust ice/snow melting flux > 0 to balance melt pond flux 
    172223               wfx_snw_sum_1d(ji) = wfx_snw_sum_1d(ji) * (1._wp + zdum) 
    173224               wfx_sum_1d(ji)     = wfx_sum_1d(ji)     * (1._wp + zdum) 
    174225            ENDIF 
     226 
     227            !-------------------! 
     228            ! case ice freezing ! i.e. t_su_1d(ji) < (zTp+rt0) 
     229            !-------------------! 
     230            ! 
     231            zdT = MAX( zTp+rt0 - t_su_1d(ji), 0._wp ) 
    175232            ! 
    176233            !--- Pond contraction (due to refreezing) ---! 
    177             v_ip_1d(ji) = v_ip_1d(ji) * EXP( 0.01_wp * MAX( zTp+rt0 - t_su_1d(ji), 0._wp ) * z1_Tp ) 
    178             ! 
    179             ! Set new pond area and depth assuming linear relation between h_ip and a_ip_frac 
    180             !    h_ip = zpnd_aspect * a_ip_frac = zpnd_aspect * a_ip/a_i 
    181             a_ip_1d(ji)      = SQRT( v_ip_1d(ji) * z1_zpnd_aspect * a_i_1d(ji) ) 
    182             a_ip_frac_1d(ji) = a_ip_1d(ji) / a_i_1d(ji) 
    183             h_ip_1d(ji)      = zpnd_aspect * a_ip_frac_1d(ji) 
     234            IF( ln_pnd_lids ) THEN 
     235               ! 
     236               !--- Lid growing and subsequent pond shrinking ---!  
     237               zdv_frz = 0.5_wp * MAX( 0._wp, -v_il_1d(ji) + & ! Flocco 2010 (eq. 5) solved implicitly as aH**2 + bH + c = 0 
     238                  &                    SQRT( v_il_1d(ji)**2 + a_ip_1d(ji)**2 * 4._wp * rcnd_i * zdT * rdt_ice / (rLfus * rhow) ) ) ! max for roundoff errors 
     239                
     240               ! Lid growing 
     241               v_il_1d(ji) = MAX( 0._wp, v_il_1d(ji) + zdv_frz ) 
     242                
     243               ! Pond shrinking 
     244               v_ip_1d(ji) = MAX( 0._wp, v_ip_1d(ji) - zdv_frz ) 
     245 
     246            ELSE 
     247               ! Pond shrinking 
     248               v_ip_1d(ji) = v_ip_1d(ji) * EXP( 0.01_wp * zdT * z1_Tp ) ! Holland 2012 (eq. 6) 
     249            ENDIF 
     250            ! 
     251            !--- Set new pond area and depth ---! assuming linear relation between h_ip and a_ip_frac 
     252            ! v_ip     = h_ip * a_ip 
     253            ! a_ip/a_i = a_ip_frac = h_ip / zaspect (cf Holland 2012, fitting SHEBA so that knowing v_ip we can distribute it to a_ip and h_ip) 
     254            a_ip_1d(ji)      = MIN( a_i_1d(ji), SQRT( v_ip_1d(ji) * z1_aspect * a_i_1d(ji) ) ) ! make sure a_ip < a_i 
     255            h_ip_1d(ji)      = zaspect * a_ip_1d(ji) / a_i_1d(ji) 
     256 
     257            !---------------!             
     258            ! Pond flushing ! 
     259            !---------------! 
     260            ! height of top of the pond above sea-level 
     261            zhp = ( h_i_1d(ji) * ( rho0 - rhoi ) + h_ip_1d(ji) * ( rho0 - rhow * a_ip_1d(ji) / a_i_1d(ji) ) ) * r1_rho0 
     262             
     263            ! Calculate the permeability of the ice (Assur 1958, see Flocco 2010) 
     264            DO jk = 1, nlay_i 
     265               zsbr = - 1.2_wp                                  & 
     266                  &   - 21.8_wp    * ( t_i_1d(ji,jk) - rt0 )    & 
     267                  &   - 0.919_wp   * ( t_i_1d(ji,jk) - rt0 )**2 & 
     268                  &   - 0.0178_wp  * ( t_i_1d(ji,jk) - rt0 )**3 
     269               ztmp(jk) = sz_i_1d(ji,jk) / zsbr 
     270            END DO 
     271            zperm = MAX( 0._wp, 3.e-08_wp * MINVAL(ztmp)**3 ) 
     272             
     273            ! Do the drainage using Darcy's law 
     274            zdv_flush   = -zperm * rho0 * grav * zhp * rdt_ice / (zvisc * h_i_1d(ji)) * a_ip_1d(ji) 
     275            zdv_flush   = MAX( zdv_flush, -v_ip_1d(ji) ) 
     276            v_ip_1d(ji) = v_ip_1d(ji) + zdv_flush 
     277             
     278            !--- Set new pond area and depth ---! assuming linear relation between h_ip and a_ip_frac 
     279            a_ip_1d(ji)      = MIN( a_i_1d(ji), SQRT( v_ip_1d(ji) * z1_aspect * a_i_1d(ji) ) ) ! make sure a_ip < a_i 
     280            h_ip_1d(ji)      = zaspect * a_ip_1d(ji) / a_i_1d(ji) 
     281 
     282            !--- Corrections and lid thickness ---! 
     283            IF( ln_pnd_lids ) THEN 
     284               !--- retrieve lid thickness from volume ---! 
     285               IF( a_ip_1d(ji) > epsi10 ) THEN   ;   h_il_1d(ji) = v_il_1d(ji) / a_ip_1d(ji) 
     286               ELSE                              ;   h_il_1d(ji) = 0._wp 
     287               ENDIF 
     288               !--- remove ponds if lids are much larger than ponds ---! 
     289               IF ( h_il_1d(ji) > h_ip_1d(ji) * 10._wp ) THEN 
     290                  a_ip_1d(ji)      = 0._wp 
     291                  h_ip_1d(ji)      = 0._wp 
     292                  h_il_1d(ji)      = 0._wp 
     293               ENDIF 
     294            ENDIF 
    184295            ! 
    185296         ENDIF 
     297          
    186298      END DO 
    187299      ! 
    188    END SUBROUTINE pnd_H12 
     300   END SUBROUTINE pnd_LEV 
    189301 
    190302 
    … …  
    203315      INTEGER  ::   ios, ioptio   ! Local integer 
    204316      !! 
    205       NAMELIST/namthd_pnd/  ln_pnd, ln_pnd_H12, ln_pnd_CST, rn_apnd, rn_hpnd, ln_pnd_alb 
     317      NAMELIST/namthd_pnd/  ln_pnd, ln_pnd_LEV , rn_apnd_min, rn_apnd_max, & 
     318         &                          ln_pnd_CST , rn_apnd, rn_hpnd,         & 
     319         &                          ln_pnd_lids, ln_pnd_alb 
    206320      !!------------------------------------------------------------------- 
    207321      ! 
    … …  
    217331         WRITE(numout,*) '~~~~~~~~~~~~~~~~' 
    218332         WRITE(numout,*) '   Namelist namicethd_pnd:' 
    219          WRITE(numout,*) '      Melt ponds activated or not                                     ln_pnd     = ', ln_pnd 
    220          WRITE(numout,*) '         Evolutive  melt pond fraction and depth (Holland et al 2012) ln_pnd_H12 = ', ln_pnd_H12 
    221          WRITE(numout,*) '         Prescribed melt pond fraction and depth                      ln_pnd_CST = ', ln_pnd_CST 
    222          WRITE(numout,*) '            Prescribed pond fraction                                  rn_apnd    = ', rn_apnd 
    223          WRITE(numout,*) '            Prescribed pond depth                                     rn_hpnd    = ', rn_hpnd 
    224          WRITE(numout,*) '         Melt ponds affect albedo or not                              ln_pnd_alb = ', ln_pnd_alb 
     333         WRITE(numout,*) '      Melt ponds activated or not                                 ln_pnd       = ', ln_pnd 
     334         WRITE(numout,*) '         Level ice melt pond scheme                               ln_pnd_LEV   = ', ln_pnd_LEV 
     335         WRITE(numout,*) '            Minimum ice fraction that contributes to melt ponds   rn_apnd_min  = ', rn_apnd_min 
     336         WRITE(numout,*) '            Maximum ice fraction that contributes to melt ponds   rn_apnd_max  = ', rn_apnd_max 
     337         WRITE(numout,*) '         Constant ice melt pond scheme                            ln_pnd_CST   = ', ln_pnd_CST 
     338         WRITE(numout,*) '            Prescribed pond fraction                              rn_apnd      = ', rn_apnd 
     339         WRITE(numout,*) '            Prescribed pond depth                                 rn_hpnd      = ', rn_hpnd 
     340         WRITE(numout,*) '         Frozen lids on top of melt ponds                         ln_pnd_lids  = ', ln_pnd_lids 
     341         WRITE(numout,*) '         Melt ponds affect albedo or not                          ln_pnd_alb   = ', ln_pnd_alb 
    225342      ENDIF 
    226343      ! 
    … …  
    229346      IF( .NOT.ln_pnd ) THEN   ;   ioptio = ioptio + 1   ;   nice_pnd = np_pndNO     ;   ENDIF 
    230347      IF( ln_pnd_CST  ) THEN   ;   ioptio = ioptio + 1   ;   nice_pnd = np_pndCST    ;   ENDIF 
    231       IF( ln_pnd_H12  ) THEN   ;   ioptio = ioptio + 1   ;   nice_pnd = np_pndH12    ;   ENDIF 
     348      IF( ln_pnd_LEV  ) THEN   ;   ioptio = ioptio + 1   ;   nice_pnd = np_pndLEV    ;   ENDIF 
    232349      IF( ioptio /= 1 )   & 
    233          & CALL ctl_stop( 'ice_thd_pnd_init: choose either none (ln_pnd=F) or only one pond scheme (ln_pnd_H12 or ln_pnd_CST)' ) 
     350         & CALL ctl_stop( 'ice_thd_pnd_init: choose either none (ln_pnd=F) or only one pond scheme (ln_pnd_LEV or ln_pnd_CST)' ) 
    234351      ! 
    235352      SELECT CASE( nice_pnd ) 
    236353      CASE( np_pndNO )          
    237          IF( ln_pnd_alb ) THEN ; ln_pnd_alb = .FALSE. ; CALL ctl_warn( 'ln_pnd_alb=false when no ponds' ) ; ENDIF 
     354         IF( ln_pnd_alb  ) THEN ; ln_pnd_alb  = .FALSE. ; CALL ctl_warn( 'ln_pnd_alb=false when no ponds' )  ; ENDIF 
     355         IF( ln_pnd_lids ) THEN ; ln_pnd_lids = .FALSE. ; CALL ctl_warn( 'ln_pnd_lids=false when no ponds' ) ; ENDIF 
     356      CASE( np_pndCST )          
     357         IF( ln_pnd_lids ) THEN ; ln_pnd_lids = .FALSE. ; CALL ctl_warn( 'ln_pnd_lids=false when constant ponds' ) ; ENDIF 
    238358      END SELECT 
    239359      ! 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/ICE/icethd_sal.F90

    r12489 r13571  
    5555      !!               -> nn_icesal = 3 -> Sice = S(z)   [multiyear ice] 
    5656      !!--------------------------------------------------------------------- 
    57       LOGICAL, INTENT(in) ::   ld_sal            ! gravity drainage and flushing or not  
     57      LOGICAL, INTENT(in) ::   ld_sal          ! gravity drainage and flushing or not  
    5858      ! 
    59       INTEGER  ::   ji, jk                       ! dummy loop indices  
    60       REAL(wp) ::   iflush, igravdr              ! local scalars 
    61       REAL(wp) ::   zs_sni, zs_i_gd, zs_i_fl, zs_i_si, zs_i_bg   ! local scalars 
     59      INTEGER  ::   ji                         ! dummy loop indices  
     60      REAL(wp) ::   zs_sni, zds                ! local scalars 
    6261      REAL(wp) ::   z1_time_gd, z1_time_fl 
    6362      !!--------------------------------------------------------------------- 
    … …  
    6867      CASE( 2 )       !  time varying salinity with linear profile  ! 
    6968         !            !---------------------------------------------! 
    70          z1_time_gd = 1._wp / rn_time_gd * rDt_ice 
    71          z1_time_fl = 1._wp / rn_time_fl * rDt_ice 
     69         z1_time_gd = rDt_ice / rn_time_gd 
     70         z1_time_fl = rDt_ice / rn_time_fl 
    7271         ! 
    7372         DO ji = 1, npti 
    7473            ! 
    75             !--------------------------------------------------------- 
    76             !  Update ice salinity from snow-ice and bottom growth 
    77             !--------------------------------------------------------- 
    7874            IF( h_i_1d(ji) > 0._wp ) THEN 
    79                zs_sni  = sss_1d(ji) * ( rhoi - rhos ) * r1_rhoi                     ! Salinity of snow ice 
    80                zs_i_si = ( zs_sni      - s_i_1d(ji) ) * dh_snowice(ji) / h_i_1d(ji) ! snow-ice     
    81                zs_i_bg = ( s_i_new(ji) - s_i_1d(ji) ) * dh_i_bog  (ji) / h_i_1d(ji) ! bottom growth 
    82                ! Update salinity (nb: salt flux already included in icethd_dh) 
    83                s_i_1d(ji) = s_i_1d(ji) + zs_i_bg + zs_i_si 
     75               ! 
     76               ! --- Update ice salinity from snow-ice and bottom growth --- ! 
     77               zs_sni = sss_1d(ji) * ( rhoi - rhos ) * r1_rhoi                           ! salinity of snow ice 
     78               zds    =       ( zs_sni      - s_i_1d(ji) ) * dh_snowice(ji) / h_i_1d(ji) ! snow-ice     
     79               zds    = zds + ( s_i_new(ji) - s_i_1d(ji) ) * dh_i_bog  (ji) / h_i_1d(ji) ! bottom growth 
     80               ! update salinity (nb: salt flux already included in icethd_dh) 
     81               s_i_1d(ji) = s_i_1d(ji) + zds 
     82               ! 
     83               ! --- Update ice salinity from brine drainage and flushing --- ! 
     84               IF( ld_sal ) THEN 
     85                  IF( t_su_1d(ji) >= rt0 ) THEN             ! flushing (summer time) 
     86                     zds = - MAX( s_i_1d(ji) - rn_sal_fl , 0._wp ) * z1_time_fl 
     87                  ELSEIF( t_su_1d(ji) <= t_bo_1d(ji) ) THEN ! gravity drainage 
     88                     zds = - MAX( s_i_1d(ji) - rn_sal_gd , 0._wp ) * z1_time_gd 
     89                  ELSE 
     90                     zds = 0._wp 
     91                  ENDIF 
     92                  ! update salinity 
     93                  s_i_1d(ji) = s_i_1d(ji) + zds 
     94                  ! salt flux 
     95                  sfx_bri_1d(ji) = sfx_bri_1d(ji) - rhoi * a_i_1d(ji) * h_i_1d(ji) * zds * r1_Dt_ice 
     96               ENDIF 
     97               ! 
     98               ! --- salinity must stay inbounds --- ! 
     99               zds =       MAX( 0._wp, rn_simin - s_i_1d(ji) ) ! > 0 if s_i < simin 
     100               zds = zds + MIN( 0._wp, rn_simax - s_i_1d(ji) ) ! < 0 if s_i > simax 
     101               ! update salinity 
     102               s_i_1d(ji) = s_i_1d(ji) + zds 
     103               ! salt flux 
     104               sfx_res_1d(ji) = sfx_res_1d(ji) - rhoi * a_i_1d(ji) * h_i_1d(ji) * zds * r1_Dt_ice 
     105               ! 
    84106            ENDIF 
    85107            ! 
    86             IF( ld_sal ) THEN 
    87                !--------------------------------------------------------- 
    88                !  Update ice salinity from brine drainage and flushing 
    89                !--------------------------------------------------------- 
    90                iflush   = MAX( 0._wp , SIGN( 1._wp , t_su_1d(ji) - rt0         ) )  ! =1 if summer  
    91                igravdr  = MAX( 0._wp , SIGN( 1._wp , t_bo_1d(ji) - t_su_1d(ji) ) )  ! =1 if t_su < t_bo 
    92  
    93                zs_i_gd = - igravdr * MAX( s_i_1d(ji) - rn_sal_gd , 0._wp ) * z1_time_gd  ! gravity drainage  
    94                zs_i_fl = - iflush  * MAX( s_i_1d(ji) - rn_sal_fl , 0._wp ) * z1_time_fl  ! flushing 
    95                 
    96                ! Update salinity    
    97                s_i_1d(ji) = s_i_1d(ji) + zs_i_fl + zs_i_gd 
    98                 
    99                ! Salt flux 
    100                sfx_bri_1d(ji) = sfx_bri_1d(ji) - rhoi * a_i_1d(ji) * h_i_1d(ji) * ( zs_i_fl + zs_i_gd ) * r1_Dt_ice 
    101             ENDIF 
    102108         END DO 
    103109         ! 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/ICE/icethd_zdf.F90

    r12377 r13571  
    8585      INTEGER  ::   ios, ioptio   ! Local integer 
    8686      !! 
    87       NAMELIST/namthd_zdf/ ln_zdf_BL99, ln_cndi_U64, ln_cndi_P07, rn_cnd_s, rn_kappa_i 
     87      NAMELIST/namthd_zdf/ ln_zdf_BL99, ln_cndi_U64, ln_cndi_P07, rn_cnd_s, & 
     88         &                 rn_kappa_i, rn_kappa_s, rn_kappa_smlt, rn_kappa_sdry, ln_zdf_chkcvg 
    8889      !!------------------------------------------------------------------- 
    8990      ! 
    … …  
    99100         WRITE(numout,*) '~~~~~~~~~~~~~~~~' 
    100101         WRITE(numout,*) '   Namelist namthd_zdf:' 
    101          WRITE(numout,*) '      Bitz and Lipscomb (1999) formulation                    ln_zdf_BL99  = ', ln_zdf_BL99 
    102          WRITE(numout,*) '      thermal conductivity in the ice (Untersteiner 1964)     ln_cndi_U64  = ', ln_cndi_U64 
    103          WRITE(numout,*) '      thermal conductivity in the ice (Pringle et al 2007)    ln_cndi_P07  = ', ln_cndi_P07 
    104          WRITE(numout,*) '      thermal conductivity in the snow                        rn_cnd_s     = ', rn_cnd_s 
    105          WRITE(numout,*) '      extinction radiation parameter in sea ice               rn_kappa_i   = ', rn_kappa_i 
     102         WRITE(numout,*) '      Bitz and Lipscomb (1999) formulation                      ln_zdf_BL99   = ', ln_zdf_BL99 
     103         WRITE(numout,*) '      thermal conductivity in the ice (Untersteiner 1964)       ln_cndi_U64   = ', ln_cndi_U64 
     104         WRITE(numout,*) '      thermal conductivity in the ice (Pringle et al 2007)      ln_cndi_P07   = ', ln_cndi_P07 
     105         WRITE(numout,*) '      thermal conductivity in the snow                          rn_cnd_s      = ', rn_cnd_s 
     106         WRITE(numout,*) '      extinction radiation parameter in sea ice                 rn_kappa_i    = ', rn_kappa_i 
     107         WRITE(numout,*) '      extinction radiation parameter in snw      (nn_qtrice=0)  rn_kappa_s    = ', rn_kappa_s 
     108         WRITE(numout,*) '      extinction radiation parameter in melt snw (nn_qtrice=1)  rn_kappa_smlt = ', rn_kappa_smlt 
     109         WRITE(numout,*) '      extinction radiation parameter in dry  snw (nn_qtrice=1)  rn_kappa_sdry = ', rn_kappa_sdry 
     110         WRITE(numout,*) '      check convergence of heat diffusion scheme                ln_zdf_chkcvg = ', ln_zdf_chkcvg 
    106111      ENDIF 
    107112      ! 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/ICE/icethd_zdf_bl99.F90

    r12489 r13571  
    8585 
    8686      LOGICAL, DIMENSION(jpij) ::   l_T_converged   ! true when T converges (per grid point) 
    87 ! 
     87      ! 
    8888      REAL(wp) ::   zg1s      =  2._wp        ! for the tridiagonal system 
    8989      REAL(wp) ::   zg1       =  2._wp        ! 
    9090      REAL(wp) ::   zgamma    =  18009._wp    ! for specific heat 
    9191      REAL(wp) ::   zbeta     =  0.117_wp     ! for thermal conductivity (could be 0.13) 
    92       REAL(wp) ::   zraext_s  =  10._wp       ! extinction coefficient of radiation in the snow 
    9392      REAL(wp) ::   zkimin    =  0.10_wp      ! minimum ice thermal conductivity 
    9493      REAL(wp) ::   ztsu_err  =  1.e-5_wp     ! range around which t_su is considered at 0C  
    9594      REAL(wp) ::   zdti_bnd  =  1.e-4_wp     ! maximal authorized error on temperature  
    96       REAL(wp) ::   zhs_min   =  0.01_wp      ! minimum snow thickness for conductivity calculation  
     95      REAL(wp) ::   zhs_ssl   =  0.03_wp      ! surface scattering layer in the snow  
     96      REAL(wp) ::   zhi_ssl   =  0.10_wp      ! surface scattering layer in the ice 
     97      REAL(wp) ::   zh_min    =  1.e-3_wp     ! minimum ice/snow thickness for conduction 
    9798      REAL(wp) ::   ztmelts                   ! ice melting temperature 
    9899      REAL(wp) ::   zdti_max                  ! current maximal error on temperature  
    99100      REAL(wp) ::   zcpi                      ! Ice specific heat 
    100101      REAL(wp) ::   zhfx_err, zdq             ! diag errors on heat 
    101       REAL(wp) ::   zfac                      ! dummy factor 
    102       ! 
    103       REAL(wp), DIMENSION(jpij) ::   isnow        ! switch for presence (1) or absence (0) of snow 
     102      ! 
     103      REAL(wp), DIMENSION(jpij) ::   zraext_s     ! extinction coefficient of radiation in the snow 
    104104      REAL(wp), DIMENSION(jpij) ::   ztsub        ! surface temperature at previous iteration 
    105105      REAL(wp), DIMENSION(jpij) ::   zh_i, z1_h_i ! ice layer thickness 
    … …  
    124124      REAL(wp), DIMENSION(jpij,0:nlay_s)   ::   zkappa_s    ! Kappa factor in the snow 
    125125      REAL(wp), DIMENSION(jpij,0:nlay_s)   ::   zeta_s      ! Eta factor in the snow 
     126      REAL(wp), DIMENSION(jpij)            ::   zkappa_comb ! Combined snow and ice surface conductivity 
    126127      REAL(wp), DIMENSION(jpij,nlay_i+3)   ::   zindterm    ! 'Ind'ependent term 
    127128      REAL(wp), DIMENSION(jpij,nlay_i+3)   ::   zindtbis    ! Temporary 'ind'ependent term 
    … …  
    130131      REAL(wp), DIMENSION(jpij)            ::   zq_ini      ! diag errors on heat 
    131132      REAL(wp), DIMENSION(jpij)            ::   zghe        ! G(he), th. conduct enhancement factor, mono-cat 
     133      REAL(wp), DIMENSION(jpij)            ::   za_s_fra    ! ice fraction covered by snow  
     134      REAL(wp), DIMENSION(jpij)            ::   isnow       ! snow presence (1) or not (0)  
     135      REAL(wp), DIMENSION(jpij)            ::   isnow_comb  ! snow presence for met-office  
    132136      ! 
    133137      ! Mono-category 
    … …  
    143147      END DO 
    144148 
     149      ! calculate ice fraction covered by snow for radiation 
     150      CALL ice_var_snwfra( h_s_1d(1:npti), za_s_fra(1:npti) ) 
     151       
    145152      !------------------ 
    146153      ! 1) Initialization 
    147154      !------------------ 
     155      ! 
     156      ! extinction radiation in the snow 
     157      IF    ( nn_qtrice == 0 ) THEN   ! constant  
     158         zraext_s(1:npti) = rn_kappa_s 
     159      ELSEIF( nn_qtrice == 1 ) THEN   ! depends on melting/freezing conditions 
     160         WHERE( t_su_1d(1:npti) < rt0 )   ;   zraext_s(1:npti) = rn_kappa_sdry   ! no surface melting 
     161         ELSEWHERE                        ;   zraext_s(1:npti) = rn_kappa_smlt   !    surface melting 
     162         END WHERE 
     163      ENDIF 
     164      ! 
     165      ! thicknesses 
    148166      DO ji = 1, npti 
    149          isnow(ji) = 1._wp - MAX( 0._wp , SIGN(1._wp, - h_s_1d(ji) ) )  ! is there snow or not 
    150          ! layer thickness 
    151          zh_i(ji) = h_i_1d(ji) * r1_nlay_i 
    152          zh_s(ji) = h_s_1d(ji) * r1_nlay_s 
     167         ! ice thickness 
     168         IF( h_i_1d(ji) > 0._wp ) THEN  
     169            zh_i  (ji) = MAX( zh_min , h_i_1d(ji) ) * r1_nlay_i ! set a minimum thickness for conduction 
     170            z1_h_i(ji) = 1._wp / zh_i(ji)                       !       it must be very small 
     171         ELSE 
     172            zh_i  (ji) = 0._wp 
     173            z1_h_i(ji) = 0._wp 
     174         ENDIF 
     175         ! snow thickness 
     176         IF( h_s_1d(ji) > 0._wp ) THEN 
     177            zh_s  (ji) = MAX( zh_min , h_s_1d(ji) ) * r1_nlay_s ! set a minimum thickness for conduction 
     178            z1_h_s(ji) = 1._wp / zh_s(ji)                       !       it must be very small 
     179            isnow (ji) = 1._wp 
     180         ELSE 
     181            zh_s  (ji) = 0._wp 
     182            z1_h_s(ji) = 0._wp 
     183            isnow (ji) = 0._wp 
     184         ENDIF 
     185         ! for Met-Office 
     186         IF( h_s_1d(ji) < zh_min ) THEN 
     187            isnow_comb(ji) = h_s_1d(ji) / zh_min 
     188         ELSE 
     189            isnow_comb(ji) = 1._wp 
     190         ENDIF 
    153191      END DO 
    154       ! 
    155       WHERE( zh_i(1:npti) >= epsi10 )   ;   z1_h_i(1:npti) = 1._wp / zh_i(1:npti) 
    156       ELSEWHERE                         ;   z1_h_i(1:npti) = 0._wp 
    157       END WHERE 
    158       ! 
    159       WHERE( zh_s(1:npti) > 0._wp   )       zh_s(1:npti) = MAX( zhs_min * r1_nlay_s, zh_s(1:npti) ) 
    160       ! 
    161       WHERE( zh_s(1:npti) > 0._wp   )   ;   z1_h_s(1:npti) = 1._wp / zh_s(1:npti) 
    162       ELSEWHERE                         ;   z1_h_s(1:npti) = 0._wp 
    163       END WHERE 
     192      ! clem: we should apply correction on snow thickness to take into account snow fraction 
     193      !       it must be a distribution, so it is a bit complicated 
    164194      ! 
    165195      ! Store initial temperatures and non solar heat fluxes 
    166196      IF( k_cnd == np_cnd_OFF .OR. k_cnd == np_cnd_EMU ) THEN 
    167          ! 
    168197         ztsub      (1:npti) = t_su_1d(1:npti)                          ! surface temperature at iteration n-1 
    169198         ztsuold    (1:npti) = t_su_1d(1:npti)                          ! surface temperature initial value 
    … …  
    185214         DO ji = 1, npti 
    186215            !                             ! radiation transmitted below the layer-th snow layer 
    187             zradtr_s(ji,jk) = zradtr_s(ji,0) * EXP( - zraext_s * h_s_1d(ji) * r1_nlay_s * REAL(jk) ) 
     216            zradtr_s(ji,jk) = zradtr_s(ji,0) * EXP( - zraext_s(ji) * MAX( 0._wp, zh_s(ji) * REAL(jk) - zhs_ssl ) ) 
    188217            !                             ! radiation absorbed by the layer-th snow layer 
    189218            zradab_s(ji,jk) = zradtr_s(ji,jk-1) - zradtr_s(ji,jk) 
    … …  
    191220      END DO 
    192221      ! 
    193       zradtr_i(1:npti,0) = zradtr_s(1:npti,nlay_s) * isnow(1:npti) + qtr_ice_top_1d(1:npti) * ( 1._wp - isnow(1:npti) ) 
     222      zradtr_i(1:npti,0) = zradtr_s(1:npti,nlay_s) * za_s_fra(1:npti) + qtr_ice_top_1d(1:npti) * ( 1._wp - za_s_fra(1:npti) ) 
    194223      DO jk = 1, nlay_i  
    195224         DO ji = 1, npti 
    196225            !                             ! radiation transmitted below the layer-th ice layer 
    197             zradtr_i(ji,jk) = zradtr_i(ji,0) * EXP( - rn_kappa_i * zh_i(ji) * REAL(jk) ) 
     226            zradtr_i(ji,jk) =           za_s_fra(ji)   * zradtr_s(ji,nlay_s)                       &   ! part covered by snow 
     227               &                                       * EXP( - rn_kappa_i * MAX( 0._wp, zh_i(ji) * REAL(jk) - zh_min  ) ) & 
     228               &            + ( 1._wp - za_s_fra(ji) ) * qtr_ice_top_1d(ji)                        &   ! part snow free 
     229               &                                       * EXP( - rn_kappa_i * MAX( 0._wp, zh_i(ji) * REAL(jk) - zhi_ssl ) )             
    198230            !                             ! radiation absorbed by the layer-th ice layer 
    199231            zradab_i(ji,jk) = zradtr_i(ji,jk-1) - zradtr_i(ji,jk) 
    … …  
    203235      qtr_ice_bot_1d(1:npti) = zradtr_i(1:npti,nlay_i)   ! record radiation transmitted below the ice 
    204236      ! 
    205       iconv    = 0          ! number of iterations 
     237      iconv = 0          ! number of iterations 
    206238      ! 
    207239      l_T_converged(:) = .FALSE. 
    … …  
    230262               DO ji = 1, npti 
    231263                  ztcond_i_cp(ji,jk) = rcnd_i + zbeta * 0.5_wp * ( sz_i_1d(ji,jk) + sz_i_1d(ji,jk+1) ) /  & 
    232                      &                         MIN( -epsi10, 0.5_wp * (t_i_1d(ji,jk) + t_i_1d(ji,jk+1)) - rt0 ) 
     264                     &                    MIN( -epsi10, 0.5_wp * (  t_i_1d(ji,jk) +  t_i_1d(ji,jk+1) ) - rt0 ) 
    233265               END DO 
    234266            END DO 
    … …  
    238270            DO ji = 1, npti 
    239271               ztcond_i_cp(ji,0)      = rcnd_i + 0.09_wp  *  sz_i_1d(ji,1)      / MIN( -epsi10, t_i_1d(ji,1) - rt0 )  & 
    240                   &                           - 0.011_wp * ( t_i_1d(ji,1) - rt0 ) 
     272                  &                            - 0.011_wp * ( t_i_1d(ji,1) - rt0 ) 
    241273               ztcond_i_cp(ji,nlay_i) = rcnd_i + 0.09_wp  *  sz_i_1d(ji,nlay_i) / MIN( -epsi10, t_bo_1d(ji)  - rt0 )  & 
    242                   &                           - 0.011_wp * ( t_bo_1d(ji) - rt0 ) 
     274                  &                            - 0.011_wp * ( t_bo_1d(ji) - rt0 ) 
    243275            END DO 
    244276            DO jk = 1, nlay_i-1 
    245277               DO ji = 1, npti 
    246                   ztcond_i_cp(ji,jk) = rcnd_i + 0.09_wp  *   0.5_wp * ( sz_i_1d(ji,jk) + sz_i_1d(ji,jk+1) ) /        & 
    247                      &                        MIN( -epsi10, 0.5_wp * ( t_i_1d (ji,jk) + t_i_1d (ji,jk+1) ) - rt0 ) & 
    248                      &                       - 0.011_wp * ( 0.5_wp * ( t_i_1d (ji,jk) + t_i_1d (ji,jk+1) ) - rt0 ) 
     278                  ztcond_i_cp(ji,jk) = rcnd_i + 0.09_wp  *   0.5_wp * ( sz_i_1d(ji,jk) + sz_i_1d(ji,jk+1) ) /       & 
     279                     &                         MIN( -epsi10, 0.5_wp * (  t_i_1d(ji,jk) +  t_i_1d(ji,jk+1) ) - rt0 ) & 
     280                     &                        - 0.011_wp * ( 0.5_wp * (  t_i_1d(ji,jk) +  t_i_1d(ji,jk+1) ) - rt0 ) 
    249281               END DO 
    250282            END DO 
    … …  
    290322         END DO 
    291323         DO ji = 1, npti   ! Snow-ice interface 
    292             IF ( .NOT. l_T_converged(ji) ) THEN 
    293                zfac = 0.5_wp * ( ztcond_i(ji,0) * zh_s(ji) + rn_cnd_s * zh_i(ji) ) 
    294                IF( zfac > epsi10 ) THEN 
    295                   zkappa_s(ji,nlay_s) = zghe(ji) * rn_cnd_s * ztcond_i(ji,0) / zfac 
    296                ELSE 
    297                   zkappa_s(ji,nlay_s) = 0._wp 
    298                ENDIF 
    299             ENDIF 
     324            IF ( .NOT. l_T_converged(ji) ) & 
     325               zkappa_s(ji,nlay_s) = isnow(ji) * zghe(ji) * rn_cnd_s * ztcond_i(ji,0) & 
     326                  &                            / ( 0.5_wp * ( ztcond_i(ji,0) * zh_s(ji) + rn_cnd_s * zh_i(ji) ) ) 
    300327         END DO 
    301328 
    … …  
    310337         END DO 
    311338         DO ji = 1, npti   ! Snow-ice interface 
    312             IF ( .NOT. l_T_converged(ji) ) & 
    313                zkappa_i(ji,0) = zkappa_s(ji,nlay_s) * isnow(ji) + zkappa_i(ji,0) * ( 1._wp - isnow(ji) ) 
     339            IF ( .NOT. l_T_converged(ji) ) THEN 
     340               ! Calculate combined surface snow and ice conductivity to pass through the coupler (met-office) 
     341               zkappa_comb(ji) = isnow_comb(ji) * zkappa_s(ji,0) + ( 1._wp - isnow_comb(ji) ) * zkappa_i(ji,0) 
     342               ! If there is snow then use the same snow-ice interface conductivity for the top layer of ice 
     343               IF( h_s_1d(ji) > 0._wp )   zkappa_i(ji,0) = zkappa_s(ji,nlay_s) 
     344           ENDIF 
    314345         END DO 
    315346         ! 
    … …  
    320351            DO ji = 1, npti 
    321352               zcpi = rcpi + zgamma * sz_i_1d(ji,jk) / MAX( ( t_i_1d(ji,jk) - rt0 ) * ( ztiold(ji,jk) - rt0 ), epsi10 ) 
    322                zeta_i(ji,jk) = rDt_ice * r1_rhoi * z1_h_i(ji) / MAX( epsi10, zcpi )  
     353               zeta_i(ji,jk) = rDt_ice * r1_rhoi * z1_h_i(ji) / zcpi 
    323354            END DO 
    324355         END DO 
    … …  
    544575                  ztsub(ji) = t_su_1d(ji) 
    545576                  IF( t_su_1d(ji) < rt0 ) THEN 
    546                      t_su_1d(ji) = ( zindtbis(ji,jm_min(ji)) - ztrid(ji,jm_min(ji),3) *  & 
    547                         &          ( isnow(ji) * t_s_1d(ji,1) + ( 1._wp - isnow(ji) ) * t_i_1d(ji,1) ) ) / zdiagbis(ji,jm_min(ji)) 
     577                     t_su_1d(ji) = (  zindtbis(ji,jm_min(ji)) - ztrid(ji,jm_min(ji),3) *  & 
     578                        &           ( isnow(ji) * t_s_1d(ji,1) + ( 1._wp - isnow(ji) ) * t_i_1d(ji,1) ) ) / zdiagbis(ji,jm_min(ji)) 
    548579                  ENDIF 
    549580               ENDIF 
    550581            END DO 
     582            !clem: in order to have several layers of snow, there is a missing loop here for t_s_1d(1:nlay_s-1) 
    551583            ! 
    552584            !-------------------------------------------------------------- 
    … …  
    561593 
    562594               IF ( .NOT. l_T_converged(ji) ) THEN 
     595 
    563596                  t_su_1d(ji) = MAX( MIN( t_su_1d(ji) , rt0 ) , rt0 - 100._wp ) 
    564597                  zdti_max    = MAX( zdti_max, ABS( t_su_1d(ji) - ztsub(ji) ) ) 
    565598 
    566                   t_s_1d(ji,1:nlay_s) = MAX( MIN( t_s_1d(ji,1:nlay_s), rt0 ), rt0 - 100._wp ) 
    567                   zdti_max = MAX ( zdti_max , MAXVAL( ABS( t_s_1d(ji,1:nlay_s) - ztsb(ji,1:nlay_s) ) ) ) 
     599                  IF( h_s_1d(ji) > 0._wp ) THEN 
     600                     DO jk = 1, nlay_s 
     601                        t_s_1d(ji,jk) = MAX( MIN( t_s_1d(ji,jk), rt0 ), rt0 - 100._wp ) 
     602                        zdti_max      = MAX ( zdti_max , ABS( t_s_1d(ji,jk) - ztsb(ji,jk) ) ) 
     603                     END DO 
     604                  ENDIF 
    568605 
    569606                  DO jk = 1, nlay_i 
    … …  
    572609                     zdti_max      =  MAX( zdti_max, ABS( t_i_1d(ji,jk) - ztib(ji,jk) ) ) 
    573610                  END DO 
    574  
    575                   IF ( zdti_max < zdti_bnd ) l_T_converged(ji) = .TRUE. 
     611                   
     612                  ! convergence test 
     613                  IF( ln_zdf_chkcvg ) THEN 
     614                     tice_cvgerr_1d(ji) = zdti_max 
     615                     tice_cvgstp_1d(ji) = REAL(iconv) 
     616                  ENDIF 
     617 
     618                  IF( zdti_max < zdti_bnd )   l_T_converged(ji) = .TRUE. 
    576619 
    577620               ENDIF 
    … …  
    726769               ENDIF 
    727770            END DO 
     771            !clem: in order to have several layers of snow, there is a missing loop here for t_s_1d(1:nlay_s-1) 
    728772            ! 
    729773            !-------------------------------------------------------------- 
    … …  
    738782 
    739783               IF ( .NOT. l_T_converged(ji) ) THEN 
    740                   ! t_s 
    741                   t_s_1d(ji,1:nlay_s) = MAX( MIN( t_s_1d(ji,1:nlay_s), rt0 ), rt0 - 100._wp ) 
    742                   zdti_max = MAX ( zdti_max , MAXVAL( ABS( t_s_1d(ji,1:nlay_s) - ztsb(ji,1:nlay_s) ) ) ) 
    743                   ! t_i 
     784 
     785                  IF( h_s_1d(ji) > 0._wp ) THEN 
     786                     DO jk = 1, nlay_s 
     787                        t_s_1d(ji,jk) = MAX( MIN( t_s_1d(ji,jk), rt0 ), rt0 - 100._wp ) 
     788                        zdti_max      = MAX ( zdti_max , ABS( t_s_1d(ji,jk) - ztsb(ji,jk) ) ) 
     789                     END DO 
     790                  ENDIF 
     791 
    744792                  DO jk = 1, nlay_i 
    745793                     ztmelts       = -rTmlt * sz_i_1d(ji,jk) + rt0  
    … …  
    748796                  END DO 
    749797 
    750                   IF ( zdti_max < zdti_bnd ) l_T_converged(ji) = .TRUE. 
     798                  ! convergence test 
     799                  IF( ln_zdf_chkcvg ) THEN 
     800                     tice_cvgerr_1d(ji) = zdti_max 
     801                     tice_cvgstp_1d(ji) = REAL(iconv) 
     802                  ENDIF 
     803 
     804                  IF( zdti_max < zdti_bnd )   l_T_converged(ji) = .TRUE. 
    751805 
    752806               ENDIF 
    … …  
    755809 
    756810         ENDIF ! k_cnd 
    757           
     811 
    758812      END DO  ! End of the do while iterative procedure 
    759        
    760       IF( ln_icectl .AND. lwp ) THEN 
    761          WRITE(numout,*) ' zdti_max : ', zdti_max 
    762          WRITE(numout,*) ' iconv    : ', iconv 
    763       ENDIF 
    764        
    765813      ! 
    766814      !----------------------------- 
    … …  
    771819      !     bottom ice conduction flux 
    772820      DO ji = 1, npti 
    773          qcn_ice_bot_1d(ji) = - zkappa_i(ji,nlay_i) * zg1  * ( t_bo_1d(ji ) - t_i_1d (ji,nlay_i) ) 
     821         qcn_ice_bot_1d(ji) = - zkappa_i(ji,nlay_i) * zg1 * ( t_bo_1d(ji ) - t_i_1d (ji,nlay_i) ) 
    774822      END DO 
    775823      !     surface ice conduction flux 
    … …  
    777825         ! 
    778826         DO ji = 1, npti 
    779             qcn_ice_top_1d(ji) =  -           isnow(ji)   * zkappa_s(ji,0) * zg1s * ( t_s_1d(ji,1) - t_su_1d(ji) ) & 
    780                &                  - ( 1._wp - isnow(ji) ) * zkappa_i(ji,0) * zg1  * ( t_i_1d(ji,1) - t_su_1d(ji) ) 
     827            qcn_ice_top_1d(ji) = -           isnow(ji)   * zkappa_s(ji,0) * zg1s * ( t_s_1d(ji,1) - t_su_1d(ji) ) & 
     828               &                 - ( 1._wp - isnow(ji) ) * zkappa_i(ji,0) * zg1  * ( t_i_1d(ji,1) - t_su_1d(ji) ) 
    781829         END DO 
    782830         ! 
    … …  
    792840         ! 
    793841         DO ji = 1, npti 
    794             t_su_1d(ji) = (  qcn_ice_top_1d(ji) &            ! calculate surface temperature 
    795                &           +           isnow(ji)   * zkappa_s(ji,0) * zg1s * t_s_1d(ji,1) & 
    796                &           + ( 1._wp - isnow(ji) ) * zkappa_i(ji,0) * zg1  * t_i_1d(ji,1) & 
    797                &          ) / MAX( epsi10, isnow(ji) * zkappa_s(ji,0) * zg1s + ( 1._wp - isnow(ji) ) * zkappa_i(ji,0) * zg1 ) 
     842            t_su_1d(ji) = ( qcn_ice_top_1d(ji) +          isnow(ji)   * zkappa_s(ji,0) * zg1s * t_s_1d(ji,1) + & 
     843               &                                ( 1._wp - isnow(ji) ) * zkappa_i(ji,0) * zg1  * t_i_1d(ji,1) ) & 
     844               &          / MAX( epsi10, isnow(ji) * zkappa_s(ji,0) * zg1s + ( 1._wp - isnow(ji) ) * zkappa_i(ji,0) * zg1 ) 
    798845            t_su_1d(ji) = MAX( MIN( t_su_1d(ji), rt0 ), rt0 - 100._wp )  ! cap t_su 
    799846         END DO 
    … …  
    853900      !-------------------------------------------------------------------- 
    854901      ! effective conductivity and 1st layer temperature (needed by Met Office) 
     902      ! this is a conductivity at mid-layer, hence the factor 2 
    855903      DO ji = 1, npti 
    856          IF( h_s_1d(ji) > 0.1_wp ) THEN  
    857             cnd_ice_1d(ji) = 2._wp * zkappa_s(ji,0) 
     904         IF( h_i_1d(ji) >= zhi_ssl ) THEN 
     905            cnd_ice_1d(ji) = 2._wp * zkappa_comb(ji) 
     906            !!cnd_ice_1d(ji) = 2._wp * zkappa_i(ji,0) 
    858907         ELSE 
    859             IF( h_i_1d(ji) > 0.1_wp ) THEN 
    860                cnd_ice_1d(ji) = 2._wp * zkappa_i(ji,0) 
    861             ELSE 
    862                cnd_ice_1d(ji) = 2._wp * ztcond_i(ji,0) * 10._wp 
    863             ENDIF 
     908            cnd_ice_1d(ji) = 2._wp * ztcond_i(ji,0) / zhi_ssl ! cnd_ice is capped by: cond_i/zhi_ssl 
    864909         ENDIF 
    865910         t1_ice_1d(ji) = isnow(ji) * t_s_1d(ji,1) + ( 1._wp - isnow(ji) ) * t_i_1d(ji,1) 
    … …  
    877922      DO ji = 1, npti          
    878923         !--- Snow-ice interfacial temperature (diagnostic SIMIP) 
    879          zfac = rn_cnd_s * zh_i(ji) + ztcond_i(ji,1) * zh_s(ji) 
    880          IF( h_s_1d(ji) >= zhs_min ) THEN 
    881             t_si_1d(ji) = ( rn_cnd_s       * zh_i(ji) * t_s_1d(ji,1) +   & 
    882                &            ztcond_i(ji,1) * zh_s(ji) * t_i_1d(ji,1) ) / MAX( epsi10, zfac ) 
     924         IF( h_s_1d(ji) >= zhs_ssl ) THEN 
     925            t_si_1d(ji) = (   rn_cnd_s       * h_i_1d(ji) * r1_nlay_i * t_s_1d(ji,1)   & 
     926               &            + ztcond_i(ji,1) * h_s_1d(ji) * r1_nlay_s * t_i_1d(ji,1) ) & 
     927               &          / ( rn_cnd_s       * h_i_1d(ji) * r1_nlay_i & 
     928               &            + ztcond_i(ji,1) * h_s_1d(ji) * r1_nlay_s ) 
    883929         ELSE 
    884930            t_si_1d(ji) = t_su_1d(ji) 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/ICE/iceupdate.F90

    r13295 r13571  
    2525   USE icectl         ! sea-ice: control prints 
    2626   USE bdy_oce , ONLY : ln_bdy 
     27   USE zdfdrg  , ONLY : ln_drgice_imp 
    2728   ! 
    2829   USE in_out_manager ! I/O manager 
    … …  
    9394      REAL(wp) ::   zqmass           ! Heat flux associated with mass exchange ice->ocean (W.m-2) 
    9495      REAL(wp) ::   zqsr             ! New solar flux received by the ocean 
    95       REAL(wp), DIMENSION(jpi,jpj)     ::   z2d                  ! 2D workspace 
    96       REAL(wp), DIMENSION(jpi,jpj,jpl) ::   zalb_cs, zalb_os     ! 3D workspace 
     96      REAL(wp), DIMENSION(jpi,jpj) ::   z2d                  ! 2D workspace 
    9797      !!--------------------------------------------------------------------- 
    9898      IF( ln_timing )   CALL timing_start('ice_update') 
    … …  
    182182      ! Snow/ice albedo (only if sent to coupler, useless in forced mode) 
    183183      !------------------------------------------------------------------ 
    184       CALL ice_alb( t_su, h_i, h_s, ln_pnd_alb, a_ip_frac, h_ip, zalb_cs, zalb_os ) ! cloud-sky and overcast-sky ice albedos 
    185       ! 
    186       alb_ice(:,:,:) = ( 1._wp - cldf_ice ) * zalb_cs(:,:,:) + cldf_ice * zalb_os(:,:,:) 
     184      CALL ice_alb( t_su, h_i, h_s, ln_pnd_alb, a_ip_eff, h_ip, cloud_fra, alb_ice ) ! ice albedo 
     185 
    187186      ! 
    188187      IF( lrst_ice ) THEN                       !* write snwice_mass fields in the restart file 
    … …  
    320319      REAL(wp) ::   zat_u, zutau_ice, zu_t, zmodt   ! local scalar 
    321320      REAL(wp) ::   zat_v, zvtau_ice, zv_t, zrhoco  !   -      - 
     321      REAL(wp) ::   zflagi                          !   -      - 
    322322      !!--------------------------------------------------------------------- 
    323323      IF( ln_timing )   CALL timing_start('ice_update_tau') 
    … …  
    332332      ! 
    333333      IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN     !==  Ice time-step only  ==!   (i.e. surface module time-step) 
    334          DO_2D( 0, 0, 0, 0 ) 
     334         DO_2D( 0, 0, 0, 0 )                          !* update the modulus of stress at ocean surface (T-point) 
    335335            !                                               ! 2*(U_ice-U_oce) at T-point 
    336336            zu_t = u_ice(ji,jj) + u_ice(ji-1,jj) - u_oce(ji,jj) - u_oce(ji-1,jj)    
    … …  
    350350      ! 
    351351      !                                      !==  every ocean time-step  ==! 
    352       ! 
    353       DO_2D( 0, 0, 0, 0 ) 
     352      IF ( ln_drgice_imp ) THEN 
     353         ! Save drag with right sign to update top drag in the ocean implicit friction  
     354         rCdU_ice(:,:) = -r1_rho0 * tmod_io(:,:) * at_i(:,:) * tmask(:,:,1)  
     355         zflagi = 0._wp 
     356      ELSE 
     357         zflagi = 1._wp 
     358      ENDIF 
     359      ! 
     360      DO_2D( 0, 0, 0, 0 )                             !* update the stress WITHOUT an ice-ocean rotation angle 
    354361         ! ice area at u and v-points  
    355362         zat_u  = ( at_i(ji,jj) * tmask(ji,jj,1) + at_i (ji+1,jj    ) * tmask(ji+1,jj  ,1) )  & 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/ICE/icevar.F90

    r13295 r13571  
    5151   !!   ice_var_sshdyn    : compute equivalent ssh in lead 
    5252   !!   ice_var_itd       : convert N-cat to M-cat 
     53   !!   ice_var_snwfra    : fraction of ice covered by snow 
     54   !!   ice_var_snwblow   : distribute snow fall between ice and ocean 
    5355   !!---------------------------------------------------------------------- 
    5456   USE dom_oce        ! ocean space and time domain 
    … …  
    7779   PUBLIC   ice_var_sshdyn 
    7880   PUBLIC   ice_var_itd 
     81   PUBLIC   ice_var_snwfra 
     82   PUBLIC   ice_var_snwblow 
    7983 
    8084   INTERFACE ice_var_itd 
    … …  
    8488   !! * Substitutions 
    8589#  include "do_loop_substitute.h90" 
     90 
     91   INTERFACE ice_var_snwfra 
     92      MODULE PROCEDURE ice_var_snwfra_1d, ice_var_snwfra_2d, ice_var_snwfra_3d 
     93   END INTERFACE 
     94 
     95   INTERFACE ice_var_snwblow 
     96      MODULE PROCEDURE ice_var_snwblow_1d, ice_var_snwblow_2d 
     97   END INTERFACE 
     98 
    8699   !!---------------------------------------------------------------------- 
    87100   !! NEMO/ICE 4.0 , NEMO Consortium (2018) 
    … …  
    115128      at_ip(:,:) = SUM( a_ip(:,:,:), dim=3 ) ! melt ponds 
    116129      vt_ip(:,:) = SUM( v_ip(:,:,:), dim=3 ) 
     130      vt_il(:,:) = SUM( v_il(:,:,:), dim=3 ) 
    117131      ! 
    118132      ato_i(:,:) = 1._wp - at_i(:,:)         ! open water fraction   
    … …  
    166180         ! 
    167181         !                           ! mean melt pond depth 
    168          WHERE( at_ip(:,:) > epsi20 )   ;   hm_ip(:,:) = vt_ip(:,:) / at_ip(:,:) 
    169          ELSEWHERE                      ;   hm_ip(:,:) = 0._wp 
     182         WHERE( at_ip(:,:) > epsi20 )   ;   hm_ip(:,:) = vt_ip(:,:) / at_ip(:,:)   ;   hm_il(:,:) = vt_il(:,:) / at_ip(:,:) 
     183         ELSEWHERE                      ;   hm_ip(:,:) = 0._wp                     ;   hm_il(:,:) = 0._wp 
    170184         END WHERE          
    171185         ! 
    … …  
    191205      REAL(wp) ::   zhmax, z1_zhmax                 !   -      - 
    192206      REAL(wp) ::   zlay_i, zlay_s                  !   -      - 
    193       REAL(wp), DIMENSION(jpi,jpj,jpl) ::   z1_a_i, z1_v_i 
     207      REAL(wp), PARAMETER ::   zhl_max =  0.015_wp  ! pond lid thickness above which the ponds disappear from the albedo calculation 
     208      REAL(wp), PARAMETER ::   zhl_min =  0.005_wp  ! pond lid thickness below which the full pond area is used in the albedo calculation 
     209      REAL(wp), DIMENSION(jpi,jpj,jpl) ::   z1_a_i, z1_v_i, z1_a_ip, za_s_fra 
    194210      !!------------------------------------------------------------------- 
    195211 
    … …  
    210226      ELSEWHERE                      ;   z1_v_i(:,:,:) = 0._wp 
    211227      END WHERE 
     228      ! 
     229      WHERE( a_ip(:,:,:) > epsi20 )  ;   z1_a_ip(:,:,:) = 1._wp / a_ip(:,:,:) 
     230      ELSEWHERE                      ;   z1_a_ip(:,:,:) = 0._wp 
     231      END WHERE 
    212232      !                                           !--- ice thickness 
    213233      h_i(:,:,:) = v_i (:,:,:) * z1_a_i(:,:,:) 
    … …  
    224244      !                                           !--- ice age       
    225245      o_i(:,:,:) = oa_i(:,:,:) * z1_a_i(:,:,:) 
    226       !                                           !--- pond fraction and thickness       
     246      !                                           !--- pond and lid thickness       
     247      h_ip(:,:,:) = v_ip(:,:,:) * z1_a_ip(:,:,:) 
     248      h_il(:,:,:) = v_il(:,:,:) * z1_a_ip(:,:,:) 
     249      !                                           !--- melt pond effective area (used for albedo) 
    227250      a_ip_frac(:,:,:) = a_ip(:,:,:) * z1_a_i(:,:,:) 
    228       WHERE( a_ip_frac(:,:,:) > epsi20 )   ;   h_ip(:,:,:) = v_ip(:,:,:) * z1_a_i(:,:,:) / a_ip_frac(:,:,:) 
    229       ELSEWHERE                            ;   h_ip(:,:,:) = 0._wp 
    230       END WHERE 
     251      WHERE    ( h_il(:,:,:) <= zhl_min )  ;   a_ip_eff(:,:,:) = a_ip_frac(:,:,:)       ! lid is very thin.  Expose all the pond 
     252      ELSEWHERE( h_il(:,:,:) >= zhl_max )  ;   a_ip_eff(:,:,:) = 0._wp                  ! lid is very thick. Cover all the pond up with ice and snow 
     253      ELSEWHERE                            ;   a_ip_eff(:,:,:) = a_ip_frac(:,:,:) * &   ! lid is in between. Expose part of the pond 
     254         &                                                       ( h_il(:,:,:) - zhl_min ) / ( zhl_max - zhl_min ) 
     255      END WHERE 
     256      ! 
     257      CALL ice_var_snwfra( h_s, za_s_fra )           ! calculate ice fraction covered by snow 
     258      a_ip_eff = MIN( a_ip_eff, 1._wp - za_s_fra )   ! make sure (a_ip_eff + a_s_fra) <= 1 
    231259      ! 
    232260      !                                           !---  salinity (with a minimum value imposed everywhere)      
    … …  
    292320      sv_i(:,:,:) = s_i (:,:,:) * v_i (:,:,:) 
    293321      v_ip(:,:,:) = h_ip(:,:,:) * a_ip(:,:,:) 
     322      v_il(:,:,:) = h_il(:,:,:) * a_ip(:,:,:) 
    294323      ! 
    295324   END SUBROUTINE ice_var_eqv2glo 
    … …  
    521550            a_ip (ji,jj,jl) = a_ip (ji,jj,jl) * zswitch(ji,jj) 
    522551            v_ip (ji,jj,jl) = v_ip (ji,jj,jl) * zswitch(ji,jj) 
     552            v_il (ji,jj,jl) = v_il (ji,jj,jl) * zswitch(ji,jj) 
    523553            ! 
    524554         END_2D 
    … …  
    542572 
    543573 
    544    SUBROUTINE ice_var_zapneg( pdt, pato_i, pv_i, pv_s, psv_i, poa_i, pa_i, pa_ip, pv_ip, pe_s, pe_i ) 
     574   SUBROUTINE ice_var_zapneg( pdt, pato_i, pv_i, pv_s, psv_i, poa_i, pa_i, pa_ip, pv_ip, pv_il, pe_s, pe_i ) 
    545575      !!------------------------------------------------------------------- 
    546576      !!                   ***  ROUTINE ice_var_zapneg *** 
    … …  
    557587      REAL(wp), DIMENSION(:,:,:)  , INTENT(inout) ::   pa_ip      ! melt pond fraction 
    558588      REAL(wp), DIMENSION(:,:,:)  , INTENT(inout) ::   pv_ip      ! melt pond volume 
     589      REAL(wp), DIMENSION(:,:,:)  , INTENT(inout) ::   pv_il      ! melt pond lid volume 
    559590      REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) ::   pe_s       ! snw heat content 
    560591      REAL(wp), DIMENSION(:,:,:,:), INTENT(inout) ::   pe_i       ! ice heat content 
    … …  
    613644      WHERE( pa_ip (:,:,:) < 0._wp )   pa_ip (:,:,:) = 0._wp 
    614645      WHERE( pv_ip (:,:,:) < 0._wp )   pv_ip (:,:,:) = 0._wp ! in theory one should change wfx_pnd(-) and wfx_sum(+) 
    615       !                                                        but it does not change conservation, so keep it this way is ok 
     646      WHERE( pv_il (:,:,:) < 0._wp )   pv_il (:,:,:) = 0._wp !    but it does not change conservation, so keep it this way is ok 
    616647      ! 
    617648   END SUBROUTINE ice_var_zapneg 
    618649 
    619650 
    620    SUBROUTINE ice_var_roundoff( pa_i, pv_i, pv_s, psv_i, poa_i, pa_ip, pv_ip, pe_s, pe_i ) 
     651   SUBROUTINE ice_var_roundoff( pa_i, pv_i, pv_s, psv_i, poa_i, pa_ip, pv_ip, pv_il, pe_s, pe_i ) 
    621652      !!------------------------------------------------------------------- 
    622653      !!                   ***  ROUTINE ice_var_roundoff *** 
    … …  
    631662      REAL(wp), DIMENSION(:,:)  , INTENT(inout) ::   pa_ip      ! melt pond fraction 
    632663      REAL(wp), DIMENSION(:,:)  , INTENT(inout) ::   pv_ip      ! melt pond volume 
     664      REAL(wp), DIMENSION(:,:)  , INTENT(inout) ::   pv_il      ! melt pond lid volume 
    633665      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pe_s       ! snw heat content 
    634666      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pe_i       ! ice heat content 
    … …  
    643675      WHERE( pe_i (1:npti,:,:) < 0._wp )   pe_i (1:npti,:,:) = 0._wp   !  e_i must be >= 0 
    644676      WHERE( pe_s (1:npti,:,:) < 0._wp )   pe_s (1:npti,:,:) = 0._wp   !  e_s must be >= 0 
    645       IF( ln_pnd_H12 ) THEN 
     677      IF( ln_pnd_LEV ) THEN 
    646678         WHERE( pa_ip(1:npti,:) < 0._wp )    pa_ip(1:npti,:)   = 0._wp   ! a_ip must be >= 0 
    647679         WHERE( pv_ip(1:npti,:) < 0._wp )    pv_ip(1:npti,:)   = 0._wp   ! v_ip must be >= 0 
     680         IF( ln_pnd_lids ) THEN 
     681            WHERE( pv_il(1:npti,:) < 0._wp .AND. pv_il(1:npti,:) > -epsi10 ) pv_il(1:npti,:)   = 0._wp   ! v_il must be >= 0 
     682         ENDIF 
    648683      ENDIF 
    649684      ! 
    … …  
    764799   !! ** Purpose :  converting N-cat ice to jpl ice categories 
    765800   !!------------------------------------------------------------------- 
    766    SUBROUTINE ice_var_itd_1c1c( phti, phts, pati ,                       ph_i, ph_s, pa_i, & 
    767       &                         ptmi, ptms, ptmsu, psmi, patip, phtip,   pt_i, pt_s, pt_su, ps_i, pa_ip, ph_ip ) 
     801   SUBROUTINE ice_var_itd_1c1c( phti, phts, pati ,                             ph_i, ph_s, pa_i, & 
     802      &                         ptmi, ptms, ptmsu, psmi, patip, phtip, phtil,  pt_i, pt_s, pt_su, ps_i, pa_ip, ph_ip, ph_il ) 
    768803      !!------------------------------------------------------------------- 
    769804      !! ** Purpose :  converting 1-cat ice to 1 ice category 
    … …  
    771806      REAL(wp), DIMENSION(:), INTENT(in)    ::   phti, phts, pati    ! input  ice/snow variables 
    772807      REAL(wp), DIMENSION(:), INTENT(inout) ::   ph_i, ph_s, pa_i    ! output ice/snow variables 
    773       REAL(wp), DIMENSION(:), INTENT(in)    ::   ptmi, ptms, ptmsu, psmi, patip, phtip    ! input  ice/snow temp & sal & ponds 
    774       REAL(wp), DIMENSION(:), INTENT(inout) ::   pt_i, pt_s, pt_su, ps_i, pa_ip, ph_ip    ! output ice/snow temp & sal & ponds 
     808      REAL(wp), DIMENSION(:), INTENT(in)    ::   ptmi, ptms, ptmsu, psmi, patip, phtip, phtil    ! input  ice/snow temp & sal & ponds 
     809      REAL(wp), DIMENSION(:), INTENT(inout) ::   pt_i, pt_s, pt_su, ps_i, pa_ip, ph_ip, ph_il    ! output ice/snow temp & sal & ponds 
    775810      !!------------------------------------------------------------------- 
    776811      ! == thickness and concentration == ! 
    … …  
    786821      pa_ip(:) = patip(:) 
    787822      ph_ip(:) = phtip(:) 
     823      ph_il(:) = phtil(:) 
    788824       
    789825   END SUBROUTINE ice_var_itd_1c1c 
    790826 
    791    SUBROUTINE ice_var_itd_Nc1c( phti, phts, pati ,                       ph_i, ph_s, pa_i, & 
    792       &                         ptmi, ptms, ptmsu, psmi, patip, phtip,   pt_i, pt_s, pt_su, ps_i, pa_ip, ph_ip ) 
     827   SUBROUTINE ice_var_itd_Nc1c( phti, phts, pati ,                             ph_i, ph_s, pa_i, & 
     828      &                         ptmi, ptms, ptmsu, psmi, patip, phtip, phtil,  pt_i, pt_s, pt_su, ps_i, pa_ip, ph_ip, ph_il ) 
    793829      !!------------------------------------------------------------------- 
    794830      !! ** Purpose :  converting N-cat ice to 1 ice category 
    … …  
    796832      REAL(wp), DIMENSION(:,:), INTENT(in)    ::   phti, phts, pati    ! input  ice/snow variables 
    797833      REAL(wp), DIMENSION(:)  , INTENT(inout) ::   ph_i, ph_s, pa_i    ! output ice/snow variables 
    798       REAL(wp), DIMENSION(:,:), INTENT(in)    ::   ptmi, ptms, ptmsu, psmi, patip, phtip    ! input  ice/snow temp & sal & ponds 
    799       REAL(wp), DIMENSION(:)  , INTENT(inout) ::   pt_i, pt_s, pt_su, ps_i, pa_ip, ph_ip    ! output ice/snow temp & sal & ponds 
     834      REAL(wp), DIMENSION(:,:), INTENT(in)    ::   ptmi, ptms, ptmsu, psmi, patip, phtip, phtil    ! input  ice/snow temp & sal & ponds 
     835      REAL(wp), DIMENSION(:)  , INTENT(inout) ::   pt_i, pt_s, pt_su, ps_i, pa_ip, ph_ip, ph_il    ! output ice/snow temp & sal & ponds 
    800836      ! 
    801837      REAL(wp), ALLOCATABLE, DIMENSION(:) ::   z1_ai, z1_vi, z1_vs 
    … …  
    832868      ! == ponds == ! 
    833869      pa_ip(:) = SUM( patip(:,:), dim=2 ) 
    834       WHERE( pa_ip(:) /= 0._wp )   ;   ph_ip(:) = SUM( phtip(:,:) * patip(:,:), dim=2 ) / pa_ip(:) 
    835       ELSEWHERE                    ;   ph_ip(:) = 0._wp 
     870      WHERE( pa_ip(:) /= 0._wp ) 
     871         ph_ip(:) = SUM( phtip(:,:) * patip(:,:), dim=2 ) / pa_ip(:) 
     872         ph_il(:) = SUM( phtil(:,:) * patip(:,:), dim=2 ) / pa_ip(:) 
     873      ELSEWHERE 
     874         ph_ip(:) = 0._wp 
     875         ph_il(:) = 0._wp 
    836876      END WHERE 
    837877      ! 
    … …  
    840880   END SUBROUTINE ice_var_itd_Nc1c 
    841881    
    842    SUBROUTINE ice_var_itd_1cMc( phti, phts, pati ,                       ph_i, ph_s, pa_i, & 
    843       &                         ptmi, ptms, ptmsu, psmi, patip, phtip,   pt_i, pt_s, pt_su, ps_i, pa_ip, ph_ip ) 
     882   SUBROUTINE ice_var_itd_1cMc( phti, phts, pati ,                             ph_i, ph_s, pa_i, & 
     883      &                         ptmi, ptms, ptmsu, psmi, patip, phtip, phtil,  pt_i, pt_s, pt_su, ps_i, pa_ip, ph_ip, ph_il ) 
    844884      !!------------------------------------------------------------------- 
    845885      !! 
    … …  
    863903      REAL(wp), DIMENSION(:),   INTENT(in)    ::   phti, phts, pati    ! input  ice/snow variables 
    864904      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   ph_i, ph_s, pa_i    ! output ice/snow variables 
    865       REAL(wp), DIMENSION(:)  , INTENT(in)    ::   ptmi, ptms, ptmsu, psmi, patip, phtip    ! input  ice/snow temp & sal & ponds 
    866       REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pt_i, pt_s, pt_su, ps_i, pa_ip, ph_ip    ! output ice/snow temp & sal & ponds 
     905      REAL(wp), DIMENSION(:)  , INTENT(in)    ::   ptmi, ptms, ptmsu, psmi, patip, phtip, phtil    ! input  ice/snow temp & sal & ponds 
     906      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pt_i, pt_s, pt_su, ps_i, pa_ip, ph_ip, ph_il    ! output ice/snow temp & sal & ponds 
    867907      ! 
    868908      REAL(wp), ALLOCATABLE, DIMENSION(:) ::   zfra, z1_hti 
    … …  
    954994         pt_su(:,jl) = ptmsu(:) 
    955995         ps_i (:,jl) = psmi (:) 
    956          ps_i (:,jl) = psmi (:)          
    957996      END DO 
    958997      ! 
    … …  
    9751014         END WHERE 
    9761015      END DO 
     1016      ! keep the same v_il/v_i ratio for each category 
     1017      WHERE( ( phti(:) * pati(:) ) /= 0._wp )   ;   zfra(:) = ( phtil(:) * patip(:) ) / ( phti(:) * pati(:) ) 
     1018      ELSEWHERE                                 ;   zfra(:) = 0._wp 
     1019      END WHERE 
     1020      DO jl = 1, jpl 
     1021         WHERE( pa_ip(:,jl) /= 0._wp )   ;   ph_il(:,jl) = zfra(:) * ( ph_i(:,jl) * pa_i(:,jl) ) / pa_ip(:,jl) 
     1022         ELSEWHERE                       ;   ph_il(:,jl) = 0._wp 
     1023         END WHERE 
     1024      END DO 
    9771025      DEALLOCATE( zfra ) 
    9781026      ! 
    9791027   END SUBROUTINE ice_var_itd_1cMc 
    9801028 
    981    SUBROUTINE ice_var_itd_NcMc( phti, phts, pati ,                       ph_i, ph_s, pa_i, & 
    982       &                         ptmi, ptms, ptmsu, psmi, patip, phtip,   pt_i, pt_s, pt_su, ps_i, pa_ip, ph_ip ) 
     1029   SUBROUTINE ice_var_itd_NcMc( phti, phts, pati ,                             ph_i, ph_s, pa_i, & 
     1030      &                         ptmi, ptms, ptmsu, psmi, patip, phtip, phtil,  pt_i, pt_s, pt_su, ps_i, pa_ip, ph_ip, ph_il ) 
    9831031      !!------------------------------------------------------------------- 
    9841032      !! 
    … …  
    9951043      !! 
    9961044      !!               2) Expand the filling to the cat jlmin-1 and jlmax+1 
    997        !!                   by removing 25% ice area from jlmin and jlmax (resp.)  
     1045      !!                   by removing 25% ice area from jlmin and jlmax (resp.)  
    9981046      !!               
    9991047      !!               3) Expand the filling to the empty cat between jlmin and jlmax  
    … …  
    10111059      REAL(wp), DIMENSION(:,:), INTENT(in)    ::   phti, phts, pati    ! input  ice/snow variables 
    10121060      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   ph_i, ph_s, pa_i    ! output ice/snow variables 
    1013       REAL(wp), DIMENSION(:,:), INTENT(in)    ::   ptmi, ptms, ptmsu, psmi, patip, phtip    ! input  ice/snow temp & sal & ponds 
    1014       REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pt_i, pt_s, pt_su, ps_i, pa_ip, ph_ip    ! output ice/snow temp & sal & ponds 
     1061      REAL(wp), DIMENSION(:,:), INTENT(in)    ::   ptmi, ptms, ptmsu, psmi, patip, phtip, phtil    ! input  ice/snow temp & sal & ponds 
     1062      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pt_i, pt_s, pt_su, ps_i, pa_ip, ph_ip, ph_il    ! output ice/snow temp & sal & ponds 
    10151063      ! 
    10161064      INTEGER , ALLOCATABLE, DIMENSION(:,:) ::   jlfil, jlfil2 
    … …  
    10411089         pa_ip(:,:) = patip(:,:) 
    10421090         ph_ip(:,:) = phtip(:,:) 
     1091         ph_il(:,:) = phtil(:,:) 
    10431092         !                              ! ---------------------- ! 
    10441093      ELSEIF( icat == 1 ) THEN          ! input cat = 1          ! 
    … …  
    10461095         CALL  ice_var_itd_1cMc( phti(:,1), phts(:,1), pati (:,1), & 
    10471096            &                    ph_i(:,:), ph_s(:,:), pa_i (:,:), & 
    1048             &                    ptmi(:,1), ptms(:,1), ptmsu(:,1), psmi(:,1), patip(:,1), phtip(:,1), & 
    1049             &                    pt_i(:,:), pt_s(:,:), pt_su(:,:), ps_i(:,:), pa_ip(:,:), ph_ip(:,:)  ) 
     1097            &                    ptmi(:,1), ptms(:,1), ptmsu(:,1), psmi(:,1), patip(:,1), phtip(:,1), phtil(:,1), & 
     1098            &                    pt_i(:,:), pt_s(:,:), pt_su(:,:), ps_i(:,:), pa_ip(:,:), ph_ip(:,:), ph_il(:,:)  ) 
    10501099         !                              ! ---------------------- ! 
    10511100      ELSEIF( jpl == 1 ) THEN           ! output cat = 1         ! 
    … …  
    10531102         CALL  ice_var_itd_Nc1c( phti(:,:), phts(:,:), pati (:,:), & 
    10541103            &                    ph_i(:,1), ph_s(:,1), pa_i (:,1), & 
    1055             &                    ptmi(:,:), ptms(:,:), ptmsu(:,:), psmi(:,:), patip(:,:), phtip(:,:), & 
    1056             &                    pt_i(:,1), pt_s(:,1), pt_su(:,1), ps_i(:,1), pa_ip(:,1), ph_ip(:,1)  ) 
     1104            &                    ptmi(:,:), ptms(:,:), ptmsu(:,:), psmi(:,:), patip(:,:), phtip(:,:), phtil(:,:), & 
     1105            &                    pt_i(:,1), pt_s(:,1), pt_su(:,1), ps_i(:,1), pa_ip(:,1), ph_ip(:,1), ph_il(:,1)  ) 
    10571106         !                              ! ----------------------- ! 
    10581107      ELSE                              ! input cat /= output cat ! 
    … …  
    11961245            END WHERE 
    11971246         END DO 
     1247         ! keep the same v_il/v_i ratio for each category 
     1248         WHERE( SUM( phti(:,:) * pati(:,:), dim=2 ) /= 0._wp ) 
     1249            zfra(:) = SUM( phtil(:,:) * patip(:,:), dim=2 ) / SUM( phti(:,:) * pati(:,:), dim=2 ) 
     1250         ELSEWHERE 
     1251            zfra(:) = 0._wp 
     1252         END WHERE 
     1253         DO jl = 1, jpl 
     1254            WHERE( pa_ip(:,jl) /= 0._wp )   ;   ph_il(:,jl) = zfra(:) * ( ph_i(:,jl) * pa_i(:,jl) ) / pa_ip(:,jl) 
     1255            ELSEWHERE                       ;   ph_il(:,jl) = 0._wp 
     1256            END WHERE 
     1257         END DO 
    11981258         DEALLOCATE( zfra ) 
    11991259         ! 
    … …  
    12011261      ! 
    12021262   END SUBROUTINE ice_var_itd_NcMc 
     1263 
     1264   !!------------------------------------------------------------------- 
     1265   !! INTERFACE ice_var_snwfra 
     1266   !! 
     1267   !! ** Purpose :  fraction of ice covered by snow 
     1268   !! 
     1269   !! ** Method  :  In absence of proper snow model on top of sea ice, 
     1270   !!               we argue that snow does not cover the whole ice because 
     1271   !!               of wind blowing... 
     1272   !!                 
     1273   !! ** Arguments : ph_s: snow thickness 
     1274   !!                 
     1275   !! ** Output    : pa_s_fra: fraction of ice covered by snow 
     1276   !! 
     1277   !!------------------------------------------------------------------- 
     1278   SUBROUTINE ice_var_snwfra_3d( ph_s, pa_s_fra ) 
     1279      REAL(wp), DIMENSION(:,:,:), INTENT(in   ) ::   ph_s        ! snow thickness 
     1280      REAL(wp), DIMENSION(:,:,:), INTENT(  out) ::   pa_s_fra    ! ice fraction covered by snow 
     1281      IF    ( nn_snwfra == 0 ) THEN   ! basic 0 or 1 snow cover 
     1282         WHERE( ph_s > 0._wp ) ; pa_s_fra = 1._wp 
     1283         ELSEWHERE             ; pa_s_fra = 0._wp 
     1284         END WHERE 
     1285      ELSEIF( nn_snwfra == 1 ) THEN   ! snow cover depends on hsnow (met-office style) 
     1286         pa_s_fra = 1._wp - EXP( -0.2_wp * rhos * ph_s ) 
     1287      ELSEIF( nn_snwfra == 2 ) THEN   ! snow cover depends on hsnow (cice style) 
     1288         pa_s_fra = ph_s / ( ph_s + 0.02_wp ) 
     1289      ENDIF 
     1290   END SUBROUTINE ice_var_snwfra_3d 
     1291 
     1292   SUBROUTINE ice_var_snwfra_2d( ph_s, pa_s_fra ) 
     1293      REAL(wp), DIMENSION(:,:), INTENT(in   ) ::   ph_s        ! snow thickness 
     1294      REAL(wp), DIMENSION(:,:), INTENT(  out) ::   pa_s_fra    ! ice fraction covered by snow 
     1295      IF    ( nn_snwfra == 0 ) THEN   ! basic 0 or 1 snow cover 
     1296         WHERE( ph_s > 0._wp ) ; pa_s_fra = 1._wp 
     1297         ELSEWHERE             ; pa_s_fra = 0._wp 
     1298         END WHERE 
     1299      ELSEIF( nn_snwfra == 1 ) THEN   ! snow cover depends on hsnow (met-office style) 
     1300         pa_s_fra = 1._wp - EXP( -0.2_wp * rhos * ph_s ) 
     1301      ELSEIF( nn_snwfra == 2 ) THEN   ! snow cover depends on hsnow (cice style) 
     1302         pa_s_fra = ph_s / ( ph_s + 0.02_wp ) 
     1303      ENDIF 
     1304   END SUBROUTINE ice_var_snwfra_2d 
     1305 
     1306   SUBROUTINE ice_var_snwfra_1d( ph_s, pa_s_fra ) 
     1307      REAL(wp), DIMENSION(:), INTENT(in   ) ::   ph_s        ! snow thickness 
     1308      REAL(wp), DIMENSION(:), INTENT(  out) ::   pa_s_fra    ! ice fraction covered by snow 
     1309      IF    ( nn_snwfra == 0 ) THEN   ! basic 0 or 1 snow cover 
     1310         WHERE( ph_s > 0._wp ) ; pa_s_fra = 1._wp 
     1311         ELSEWHERE             ; pa_s_fra = 0._wp 
     1312         END WHERE 
     1313      ELSEIF( nn_snwfra == 1 ) THEN   ! snow cover depends on hsnow (met-office style) 
     1314         pa_s_fra = 1._wp - EXP( -0.2_wp * rhos * ph_s ) 
     1315      ELSEIF( nn_snwfra == 2 ) THEN   ! snow cover depends on hsnow (cice style) 
     1316         pa_s_fra = ph_s / ( ph_s + 0.02_wp ) 
     1317      ENDIF 
     1318   END SUBROUTINE ice_var_snwfra_1d 
     1319    
     1320   !!-------------------------------------------------------------------------- 
     1321   !! INTERFACE ice_var_snwblow 
     1322   !! 
     1323   !! ** Purpose :   Compute distribution of precip over the ice 
     1324   !! 
     1325   !!                Snow accumulation in one thermodynamic time step 
     1326   !!                snowfall is partitionned between leads and ice. 
     1327   !!                If snow fall was uniform, a fraction (1-at_i) would fall into leads 
     1328   !!                but because of the winds, more snow falls on leads than on sea ice 
     1329   !!                and a greater fraction (1-at_i)^beta of the total mass of snow  
     1330   !!                (beta < 1) falls in leads. 
     1331   !!                In reality, beta depends on wind speed,  
     1332   !!                and should decrease with increasing wind speed but here, it is  
     1333   !!                considered as a constant. an average value is 0.66 
     1334   !!-------------------------------------------------------------------------- 
     1335!!gm  I think it can be usefull to set this as a FUNCTION, not a SUBROUTINE.... 
     1336   SUBROUTINE ice_var_snwblow_2d( pin, pout ) 
     1337      REAL(wp), DIMENSION(:,:), INTENT(in   ) :: pin   ! previous fraction lead ( 1. - a_i_b ) 
     1338      REAL(wp), DIMENSION(:,:), INTENT(inout) :: pout 
     1339      pout = ( 1._wp - ( pin )**rn_snwblow ) 
     1340   END SUBROUTINE ice_var_snwblow_2d 
     1341 
     1342   SUBROUTINE ice_var_snwblow_1d( pin, pout ) 
     1343      REAL(wp), DIMENSION(:), INTENT(in   ) :: pin 
     1344      REAL(wp), DIMENSION(:), INTENT(inout) :: pout 
     1345      pout = ( 1._wp - ( pin )**rn_snwblow ) 
     1346   END SUBROUTINE ice_var_snwblow_1d 
    12031347 
    12041348#else 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/ICE/icewri.F90

    r13295 r13571  
    114114      IF( iom_use('icehpnd' ) )   CALL iom_put( 'icehpnd', hm_ip  * zmsk00      )                                           ! melt pond depth 
    115115      IF( iom_use('icevpnd' ) )   CALL iom_put( 'icevpnd', vt_ip  * zmsk00      )                                           ! melt pond total volume per unit area 
     116      IF( iom_use('icehlid' ) )   CALL iom_put( 'icehlid', hm_il  * zmsk00      )                                           ! melt pond lid depth 
     117      IF( iom_use('icevlid' ) )   CALL iom_put( 'icevlid', vt_il  * zmsk00      )                                           ! melt pond lid total volume per unit area 
    116118      ! salt 
    117119      IF( iom_use('icesalt' ) )   CALL iom_put( 'icesalt', sm_i                 * zmsk00 + zmiss_val * ( 1._wp - zmsk00 ) ) ! mean ice salinity 
    … …  
    158160      IF( iom_use('icebrv_cat'  ) )   CALL iom_put( 'icebrv_cat'  ,   bv_i * 100.  * zmsk00l + zmiss_val * ( 1._wp - zmsk00l ) ) ! brine volume 
    159161      IF( iom_use('iceapnd_cat' ) )   CALL iom_put( 'iceapnd_cat' ,   a_ip         * zmsk00l                                   ) ! melt pond frac for categories 
    160       IF( iom_use('icehpnd_cat' ) )   CALL iom_put( 'icehpnd_cat' ,   h_ip         * zmsk00l + zmiss_val * ( 1._wp - zmsk00l ) ) ! melt pond frac for categories 
     162      IF( iom_use('icehpnd_cat' ) )   CALL iom_put( 'icehpnd_cat' ,   h_ip         * zmsk00l + zmiss_val * ( 1._wp - zmsk00l ) ) ! melt pond thickness for categories 
     163      IF( iom_use('icehlid_cat' ) )   CALL iom_put( 'icehlid_cat' ,   h_il         * zmsk00l + zmiss_val * ( 1._wp - zmsk00l ) ) ! melt pond lid thickness for categories 
    161164      IF( iom_use('iceafpnd_cat') )   CALL iom_put( 'iceafpnd_cat',   a_ip_frac    * zmsk00l                                   ) ! melt pond frac for categories 
     165      IF( iom_use('iceaepnd_cat') )   CALL iom_put( 'iceaepnd_cat',   a_ip_eff     * zmsk00l                                   ) ! melt pond effective frac for categories 
    162166      IF( iom_use('icealb_cat'  ) )   CALL iom_put( 'icealb_cat'  ,   alb_ice      * zmsk00l + zmiss_val * ( 1._wp - zmsk00l ) ) ! ice albedo for categories 
    163167 
    … …  
    173177      IF( iom_use('dmisum') )   CALL iom_put( 'dmisum', - wfx_sum                                                             ) ! Sea-ice mass change through surface melting 
    174178      IF( iom_use('dmibom') )   CALL iom_put( 'dmibom', - wfx_bom                                                             ) ! Sea-ice mass change through bottom melting 
     179      IF( iom_use('dmilam') )   CALL iom_put( 'dmilam', - wfx_lam                                                             ) ! Sea-ice mass change through lateral melting 
    175180      IF( iom_use('dmtsub') )   CALL iom_put( 'dmtsub', - wfx_sub                                                             ) ! Sea-ice mass change through evaporation and sublimation 
    176181      IF( iom_use('dmssub') )   CALL iom_put( 'dmssub', - wfx_snw_sub                                                         ) ! Snow mass change through sublimation 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/NST/agrif_ice_interp.F90

    r13286 r13571  
    176176            ptab(i1:i2,j1:j2,jm+5) = a_ip(i1:i2,j1:j2,jl) 
    177177            ptab(i1:i2,j1:j2,jm+6) = v_ip(i1:i2,j1:j2,jl) 
    178             ptab(i1:i2,j1:j2,jm+7) = t_su(i1:i2,j1:j2,jl) 
    179             jm = jm + 8 
     178            ptab(i1:i2,j1:j2,jm+7) = v_il(i1:i2,j1:j2,jl) 
     179            ptab(i1:i2,j1:j2,jm+8) = t_su(i1:i2,j1:j2,jl) 
     180            jm = jm + 9 
    180181            DO jk = 1, nlay_s 
    181182               ptab(i1:i2,j1:j2,jm) = e_s(i1:i2,j1:j2,jk,jl)   ;   jm = jm + 1 
    … …  
    206207                     a_ip(ji,jj,jl) = ptab(ji,jj,jm+5) * tmask(ji,jj,1) 
    207208                     v_ip(ji,jj,jl) = ptab(ji,jj,jm+6) * tmask(ji,jj,1) 
    208                      t_su(ji,jj,jl) = ptab(ji,jj,jm+7) * tmask(ji,jj,1) 
     209                     v_il(ji,jj,jl) = ptab(ji,jj,jm+7) * tmask(ji,jj,1) 
     210                     t_su(ji,jj,jl) = ptab(ji,jj,jm+8) * tmask(ji,jj,1) 
    209211                  END DO 
    210212               END DO 
    211                jm = jm + 8 
     213               jm = jm + 9 
    212214               ! 
    213215               DO jk = 1, nlay_s 
    … …  
    239241!               ztab(:,:,jm+5) = a_ip(:,:,jl) 
    240242!               ztab(:,:,jm+6) = v_ip(:,:,jl) 
    241 !               ztab(:,:,jm+7) = t_su(:,:,jl) 
    242 !               jm = jm + 8 
     243!               ztab(:,:,jm+7) = v_il(:,:,jl) 
     244!               ztab(:,:,jm+8) = t_su(:,:,jl) 
     245!               jm = jm + 9 
    243246!               DO jk = 1, nlay_s 
    244247!                  ztab(:,:,jm) = e_s(:,:,jk,jl) 
    … …  
    345348!                     a_ip(ji,jj,jl) = ztab(ji,jj,jm+5) * tmask(ji,jj,1) 
    346349!                     v_ip(ji,jj,jl) = ztab(ji,jj,jm+6) * tmask(ji,jj,1) 
    347 !                     t_su(ji,jj,jl) = ztab(ji,jj,jm+7) * tmask(ji,jj,1) 
     350!                     v_il(ji,jj,jl) = ztab(ji,jj,jm+7) * tmask(ji,jj,1) 
     351!                     t_su(ji,jj,jl) = ztab(ji,jj,jm+8) * tmask(ji,jj,1) 
    348352!                  END DO 
    349353!               END DO 
    350 !               jm = jm + 8 
     354!               jm = jm + 9 
    351355!               ! 
    352356!               DO jk = 1, nlay_s 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/NST/agrif_ice_update.F90

    r13216 r13571  
    109109            ptab(i1:i2,j1:j2,jm+5) = a_ip(i1:i2,j1:j2,jl) 
    110110            ptab(i1:i2,j1:j2,jm+6) = v_ip(i1:i2,j1:j2,jl) 
    111             ptab(i1:i2,j1:j2,jm+7) = t_su(i1:i2,j1:j2,jl) 
    112             jm = jm + 8 
     111            ptab(i1:i2,j1:j2,jm+7) = v_il(i1:i2,j1:j2,jl) 
     112            ptab(i1:i2,j1:j2,jm+8) = t_su(i1:i2,j1:j2,jl) 
     113            jm = jm + 9 
    113114            DO jk = 1, nlay_s 
    114115               ptab(i1:i2,j1:j2,jm) = e_s(i1:i2,j1:j2,jk,jl)   ;   jm = jm + 1 
    … …  
    138139                     a_ip(ji,jj,jl) = ptab(ji,jj,jm+5) * tmask(ji,jj,1) 
    139140                     v_ip(ji,jj,jl) = ptab(ji,jj,jm+6) * tmask(ji,jj,1) 
    140                      t_su(ji,jj,jl) = ptab(ji,jj,jm+7) * tmask(ji,jj,1) 
     141                     v_il(ji,jj,jl) = ptab(ji,jj,jm+7) * tmask(ji,jj,1) 
     142                     t_su(ji,jj,jl) = ptab(ji,jj,jm+8) * tmask(ji,jj,1) 
    141143                  ENDIF 
    142144               END DO 
    143145            END DO 
    144             jm = jm + 8 
     146            jm = jm + 9 
    145147            ! 
    146148            DO jk = 1, nlay_s 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/NST/agrif_oce_sponge.F90

    r13295 r13571  
    320320      END_2D 
    321321      ! 
    322       ztabramp (:,:) = REAL( mbkt_parent (:,:), wp ) 
    323       ztabrampu(:,:) = REAL( mbku_parentu(:,:), wp ) 
    324       ztabrampv(:,:) = REAL( mbkv_parentv(:,:), wp ) 
     322      ztabramp (:,:) = REAL( mbkt_parent(:,:), wp ) 
     323      ztabrampu(:,:) = REAL( mbku_parent(:,:), wp ) 
     324      ztabrampv(:,:) = REAL( mbkv_parent(:,:), wp ) 
    325325      CALL lbc_lnk_multi( 'Agrif_Sponge', ztabramp, 'T', 1._wp, ztabrampu, 'U', 1._wp, ztabrampv, 'V', 1._wp ) 
    326326      mbkt_parent(:,:) = NINT( ztabramp (:,:) ) 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/NST/agrif_user.F90

    r13295 r13571  
    405405         use_sign_north = .TRUE. 
    406406         sign_north = -1. 
     407         CALL Agrif_Bc_variable(ub2b_interp_id,calledweight=1.,procname=interpub2b)   ! must be called before unb_id to define ubdy 
     408         CALL Agrif_Bc_variable(vb2b_interp_id,calledweight=1.,procname=interpvb2b)   ! must be called before vnb_id to define vbdy 
    407409         CALL Agrif_Bc_variable(        unb_id,calledweight=1.,procname=interpunb ) 
    408410         CALL Agrif_Bc_variable(        vnb_id,calledweight=1.,procname=interpvnb ) 
    409          CALL Agrif_Bc_variable(ub2b_interp_id,calledweight=1.,procname=interpub2b) 
    410          CALL Agrif_Bc_variable(vb2b_interp_id,calledweight=1.,procname=interpvb2b) 
    411411         use_sign_north = .FALSE. 
    412412         ubdy(:,:) = 0._wp 
    … …  
    663663      ind2 = nn_hls + 2 + nbghostcells_x 
    664664      ind3 = nn_hls + 2 + nbghostcells_y_s 
    665       ipl = jpl*(8+nlay_s+nlay_i) 
     665      ipl = jpl*(9+nlay_s+nlay_i) 
    666666      CALL agrif_declare_variable((/2,2,0/),(/ind2,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,ipl/),tra_ice_id) 
    667667      CALL agrif_declare_variable((/1,2/)  ,(/ind2-1,ind3/),(/'x','y'    /),(/1,1  /),(/jpi,jpj    /),  u_ice_id) 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/OCE/BDY/bdy_oce.F90

    r12377 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/BDY/bdydta.F90

    r13237 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/BDY/bdyice.F90

    r13226 r13571  
    9494         IF( ANY(llsend1) .OR. ANY(llrecv1) ) THEN   ! if need to send/recv in at least one direction 
    9595            ! 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      ) 
     96            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                  & 
     97               &                       , 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 & 
     98               &                       , a_ip, 'T', 1._wp, v_ip, 'T', 1._wp, v_il, 'T', 1._wp                                     & 
     99               &                       , kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) 
    100100            ! 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 ) 
     101            CALL lbc_lnk_multi('bdyice', t_s , 'T', 1._wp, e_s , 'T', 1._wp, kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) 
     102            CALL lbc_lnk_multi('bdyice', t_i , 'T', 1._wp, e_i , 'T', 1._wp, kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) 
    103103         END IF 
    104104      END DO   ! ir 
    … …  
    163163            a_ip(ji,jj,  jl) = ( a_ip(ji,jj,  jl) * zwgt1 + dta%aip(i_bdy,jl) * zwgt ) * tmask(ji,jj,1)  ! Ice  pond concentration 
    164164            h_ip(ji,jj,  jl) = ( h_ip(ji,jj,  jl) * zwgt1 + dta%hip(i_bdy,jl) * zwgt ) * tmask(ji,jj,1)  ! Ice  pond depth 
     165            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 
    165166            ! 
    166167            sz_i(ji,jj,:,jl) = s_i(ji,jj,jl) 
    … …  
    170171               a_ip(ji,jj,jl) = 0._wp 
    171172               h_ip(ji,jj,jl) = 0._wp 
     173               h_il(ji,jj,jl) = 0._wp 
     174            ENDIF 
     175 
     176            IF( .NOT.ln_pnd_lids ) THEN 
     177               h_il(ji,jj,jl) = 0._wp 
    172178            ENDIF 
    173179            ! 
    … …  
    231237               a_ip(ji,jj,  jl) = a_ip(ib,jb,  jl) 
    232238               h_ip(ji,jj,  jl) = h_ip(ib,jb,  jl) 
     239               h_il(ji,jj,  jl) = h_il(ib,jb,  jl) 
    233240               ! 
    234241               sz_i(ji,jj,:,jl) = sz_i(ib,jb,:,jl) 
    … …  
    265272               ! 
    266273               ! 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 
    272274               v_ip(ji,jj,jl) = h_ip(ji,jj,jl) * a_ip(ji,jj,jl) 
     275               v_il(ji,jj,jl) = h_il(ji,jj,jl) * a_ip(ji,jj,jl) 
    273276               ! 
    274277            ELSE   ! no ice at the boundary 
    … …  
    278281               h_s (ji,jj,  jl) = 0._wp 
    279282               oa_i(ji,jj,  jl) = 0._wp 
    280                a_ip(ji,jj,  jl) = 0._wp 
    281                v_ip(ji,jj,  jl) = 0._wp 
    282283               t_su(ji,jj,  jl) = rt0 
    283284               t_s (ji,jj,:,jl) = rt0 
    284285               t_i (ji,jj,:,jl) = rt0  
    285286 
    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 
     287               a_ip(ji,jj,jl) = 0._wp 
     288               h_ip(ji,jj,jl) = 0._wp 
     289               h_il(ji,jj,jl) = 0._wp 
    290290                
    291291               IF( nn_icesal == 1 ) THEN     ! if constant salinity 
    … …  
    303303               e_s (ji,jj,:,jl) = 0._wp 
    304304               e_i (ji,jj,:,jl) = 0._wp 
     305               v_ip(ji,jj,  jl) = 0._wp 
     306               v_il(ji,jj,  jl) = 0._wp 
    305307 
    306308            ENDIF 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/OCE/BDY/bdyini.F90

    r13286 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/BDY/bdylib.F90

    r13226 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/BDY/bdytra.F90

    r13226 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/C1D/dtauvd.F90

    r13295 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/CRS/crsfld.F90

    r13295 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/DIA/diaar5.F90

    r13295 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/DIA/diacfl.F90

    r13295 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/DIA/diahth.F90

    r13295 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/DIA/diaptr.F90

    r13295 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/DIA/diawri.F90

    r13295 r13571  
    118118      INTEGER ::   ji, jj, jk       ! dummy loop indices 
    119119      INTEGER ::   ikbot            ! local integer 
     120      REAL(wp)::   ze3 
    120121      REAL(wp)::   zztmp , zztmpx   ! local scalar 
    121122      REAL(wp)::   zztmp2, zztmpy   !   -      - 
    … …  
    175176      CALL iom_put(  "sst", ts(:,:,1,jp_tem,Kmm) )    ! surface temperature 
    176177      IF ( iom_use("sbt") ) THEN 
    177          DO_2D( 1, 1, 1, 1 ) 
     178         DO_2D( 0, 0, 0, 0 ) 
    178179            ikbot = mbkt(ji,jj) 
    179180            z2d(ji,jj) = ts(ji,jj,ikbot,jp_tem,Kmm) 
    … …  
    185186      CALL iom_put(  "sss", ts(:,:,1,jp_sal,Kmm) )    ! surface salinity 
    186187      IF ( iom_use("sbs") ) THEN 
    187          DO_2D( 1, 1, 1, 1 ) 
     188         DO_2D( 0, 0, 0, 0 ) 
    188189            ikbot = mbkt(ji,jj) 
    189190            z2d(ji,jj) = ts(ji,jj,ikbot,jp_sal,Kmm) 
    … …  
    207208            ! 
    208209         END_2D 
    209          CALL lbc_lnk( 'diawri', z2d, 'T', 1.0_wp ) 
    210210         CALL iom_put( "taubot", z2d )            
    211211      ENDIF 
    … …  
    214214      CALL iom_put(  "ssu", uu(:,:,1,Kmm) )            ! surface i-current 
    215215      IF ( iom_use("sbu") ) THEN 
    216          DO_2D( 1, 1, 1, 1 ) 
     216         DO_2D( 0, 0, 0, 0 ) 
    217217            ikbot = mbku(ji,jj) 
    218218            z2d(ji,jj) = uu(ji,jj,ikbot,Kmm) 
    … …  
    224224      CALL iom_put(  "ssv", vv(:,:,1,Kmm) )            ! surface j-current 
    225225      IF ( iom_use("sbv") ) THEN 
    226          DO_2D( 1, 1, 1, 1 ) 
     226         DO_2D( 0, 0, 0, 0 ) 
    227227            ikbot = mbkv(ji,jj) 
    228228            z2d(ji,jj) = vv(ji,jj,ikbot,Kmm) 
    … …  
    253253      IF( iom_use('logavs') )   CALL iom_put( "logavs", LOG( MAX( 1.e-20_wp, avs(:,:,:) ) ) ) 
    254254 
     255      IF ( iom_use("socegrad") .OR. iom_use("socegrad2") ) THEN 
     256         z3d(:,:,jpk) = 0. 
     257         DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     258            zztmp  = ts(ji,jj,jk,jp_sal,Kmm) 
     259            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) 
     260            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) 
     261            z3d(ji,jj,jk) = 0.25 * ( zztmpx * zztmpx + zztmpy * zztmpy )   & 
     262               &                 * umask(ji,jj,jk) * umask(ji-1,jj,jk) * vmask(ji,jj,jk) * umask(ji,jj-1,jk) 
     263         END_3D 
     264         CALL iom_put( "socegrad2",  z3d )          ! square of module of sal gradient 
     265         DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     266            z3d(ji,jj,jk) = SQRT( z3d(ji,jj,jk) ) 
     267         END_3D 
     268         CALL iom_put( "socegrad" ,  z3d )          ! module of sal gradient 
     269      ENDIF 
     270          
    255271      IF ( iom_use("sstgrad") .OR. iom_use("sstgrad2") ) THEN 
    256          DO_2D( 0, 0, 0, 0 ) 
     272         DO_2D( 0, 0, 0, 0 )                                 ! sst gradient 
    257273            zztmp  = ts(ji,jj,1,jp_tem,Kmm) 
    258274            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) 
    … …  
    261277               &              * umask(ji,jj,1) * umask(ji-1,jj,1) * vmask(ji,jj,1) * umask(ji,jj-1,1) 
    262278         END_2D 
    263          CALL lbc_lnk( 'diawri', z2d, 'T', 1.0_wp ) 
    264279         CALL iom_put( "sstgrad2",  z2d )          ! square of module of sst gradient 
    265          z2d(:,:) = SQRT( z2d(:,:) ) 
     280         DO_2D( 0, 0, 0, 0 ) 
     281            z2d(ji,jj) = SQRT( z2d(ji,jj) ) 
     282         END_2D 
    266283         CALL iom_put( "sstgrad" ,  z2d )          ! module of sst gradient 
    267284      ENDIF 
    … …  
    270287      IF( iom_use("heatc") ) THEN 
    271288         z2d(:,:)  = 0._wp  
    272          DO_3D( 1, 1, 1, 1, 1, jpkm1 ) 
     289         DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
    273290            z2d(ji,jj) = z2d(ji,jj) + e3t(ji,jj,jk,Kmm) * ts(ji,jj,jk,jp_tem,Kmm) * tmask(ji,jj,jk) 
    274291         END_3D 
    … …  
    278295      IF( iom_use("saltc") ) THEN 
    279296         z2d(:,:)  = 0._wp  
    280          DO_3D( 1, 1, 1, 1, 1, jpkm1 ) 
     297         DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
    281298            z2d(ji,jj) = z2d(ji,jj) + e3t(ji,jj,jk,Kmm) * ts(ji,jj,jk,jp_sal,Kmm) * tmask(ji,jj,jk) 
    282299         END_3D 
    … …  
    284301      ENDIF 
    285302      ! 
    286       IF ( iom_use("eken") ) THEN 
     303      IF( iom_use("salt2c") ) THEN 
     304         z2d(:,:)  = 0._wp  
     305         DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     306            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) 
     307         END_3D 
     308         CALL iom_put( "salt2c", rho0 * z2d )          ! vertically integrated salt content (PSU*kg/m2) 
     309      ENDIF 
     310      ! 
     311      IF ( iom_use("ke") .OR. iom_use("ke_int") ) THEN 
    287312         z3d(:,:,jpk) = 0._wp  
    288313         DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
    289             zztmp  = 0.25_wp * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm) 
    290             z3d(ji,jj,jk) = zztmp * (  uu(ji-1,jj,jk,Kmm)**2 * e2u(ji-1,jj) * e3u(ji-1,jj,jk,Kmm)   & 
    291                &                     + uu(ji  ,jj,jk,Kmm)**2 * e2u(ji  ,jj) * e3u(ji  ,jj,jk,Kmm)   & 
    292                &                     + vv(ji,jj-1,jk,Kmm)**2 * e1v(ji,jj-1) * e3v(ji,jj-1,jk,Kmm)   & 
    293                &                     + vv(ji,jj  ,jk,Kmm)**2 * e1v(ji,jj  ) * e3v(ji,jj  ,jk,Kmm)   ) 
    294          END_3D 
    295          CALL lbc_lnk( 'diawri', z3d, 'T', 1.0_wp ) 
    296          CALL iom_put( "eken", z3d )                 ! kinetic energy 
     314            zztmpx = 0.5 * ( uu(ji-1,jj  ,jk,Kmm) + uu(ji,jj,jk,Kmm) ) 
     315            zztmpy = 0.5 * ( vv(ji  ,jj-1,jk,Kmm) + vv(ji,jj,jk,Kmm) ) 
     316            z3d(ji,jj,jk) = 0.5 * ( zztmpx*zztmpx + zztmpy*zztmpy ) 
     317         END_3D 
     318         CALL iom_put( "ke", z3d )                 ! kinetic energy 
     319 
     320         z2d(:,:)  = 0._wp  
     321         DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     322            z2d(ji,jj) = z2d(ji,jj) + e3t(ji,jj,jk,Kmm) * z3d(ji,jj,jk) * e1e2t(ji,jj) * tmask(ji,jj,jk) 
     323         END_3D 
     324         CALL iom_put( "ke_int", z2d )   ! vertically integrated kinetic energy 
    297325      ENDIF 
    298326      ! 
    299327      CALL iom_put( "hdiv", hdiv )                  ! Horizontal divergence 
     328 
     329      IF ( iom_use("relvor") .OR. iom_use("absvor") .OR. iom_use("potvor") ) THEN 
     330          
     331         z3d(:,:,jpk) = 0._wp  
     332         DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     333            z3d(ji,jj,jk) = (   e2v(ji+1,jj  ) * vv(ji+1,jj  ,jk,Kmm) - e2v(ji,jj) * vv(ji,jj,jk,Kmm)    & 
     334               &              - e1u(ji  ,jj+1) * uu(ji  ,jj+1,jk,Kmm) + e1u(ji,jj) * uu(ji,jj,jk,Kmm)  ) * r1_e1e2f(ji,jj) 
     335         END_3D 
     336         CALL iom_put( "relvor", z3d )                  ! relative vorticity 
     337 
     338         DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     339            z3d(ji,jj,jk) = ff_f(ji,jj) + z3d(ji,jj,jk)  
     340         END_3D 
     341         CALL iom_put( "absvor", z3d )                  ! absolute vorticity 
     342 
     343         DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     344            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)   & 
     345               &    + e3t(ji,jj  ,jk,Kmm)*tmask(ji,jj  ,jk) + e3t(ji+1,jj  ,jk,Kmm)*tmask(ji+1,jj  ,jk)  ) 
     346            IF( ze3 /= 0._wp ) THEN   ;   ze3 = 4._wp / ze3 
     347            ELSE                      ;   ze3 = 0._wp 
     348            ENDIF 
     349            z3d(ji,jj,jk) = ze3 * z3d(ji,jj,jk)  
     350         END_3D 
     351         CALL iom_put( "potvor", z3d )                  ! potential vorticity 
     352 
     353      ENDIF 
    300354      ! 
    301355      IF( iom_use("u_masstr") .OR. iom_use("u_masstr_vint") .OR. iom_use("u_heattr") .OR. iom_use("u_salttr") ) THEN 
    … …  
    315369            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) ) 
    316370         END_3D 
    317          CALL lbc_lnk( 'diawri', z2d, 'U', -1.0_wp ) 
    318371         CALL iom_put( "u_heattr", 0.5*rcp * z2d )    ! heat transport in i-direction 
    319372      ENDIF 
    … …  
    324377            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) ) 
    325378         END_3D 
    326          CALL lbc_lnk( 'diawri', z2d, 'U', -1.0_wp ) 
    327379         CALL iom_put( "u_salttr", 0.5 * z2d )        ! heat transport in i-direction 
    328380      ENDIF 
    … …  
    342394            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) ) 
    343395         END_3D 
    344          CALL lbc_lnk( 'diawri', z2d, 'V', -1.0_wp ) 
    345396         CALL iom_put( "v_heattr", 0.5*rcp * z2d )    !  heat transport in j-direction 
    346397      ENDIF 
    … …  
    351402            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) ) 
    352403         END_3D 
    353          CALL lbc_lnk( 'diawri', z2d, 'V', -1.0_wp ) 
    354404         CALL iom_put( "v_salttr", 0.5 * z2d )        !  heat transport in j-direction 
    355405      ENDIF 
    … …  
    360410            z2d(ji,jj) = z2d(ji,jj) + e3t(ji,jj,jk,Kmm) *  ts(ji,jj,jk,jp_tem,Kmm) 
    361411         END_3D 
    362          CALL lbc_lnk( 'diawri', z2d, 'T', -1.0_wp ) 
    363412         CALL iom_put( "tosmint", rho0 * z2d )        ! Vertical integral of temperature 
    364413      ENDIF 
    … …  
    368417            z2d(ji,jj) = z2d(ji,jj) + e3t(ji,jj,jk,Kmm) * ts(ji,jj,jk,jp_sal,Kmm) 
    369418         END_3D 
    370          CALL lbc_lnk( 'diawri', z2d, 'T', -1.0_wp ) 
    371419         CALL iom_put( "somint", rho0 * z2d )         ! Vertical integral of salinity 
    372420      ENDIF 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/OCE/DIU/diu_bulk.F90

    r13295 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/DOM/closea.F90

    r13286 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/DOM/daymod.F90

    r13286 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/DOM/dom_oce.F90

    r13561 r13571  
    224224 
    225225   !!---------------------------------------------------------------------- 
     226   !! variable defined here to avoid circular dependencies... 
     227   !! --------------------------------------------------------------------- 
     228   INTEGER, PUBLIC ::   nbasin         ! number of basin to be considered in diaprt (glo, atl, pac, ind, ipc) 
     229 
     230   !!---------------------------------------------------------------------- 
    226231   !! agrif domain 
    227232   !!---------------------------------------------------------------------- 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/OCE/DOM/domain.F90

    r13286 r13571  
    120120         WRITE(numout,*)     '         cn_cfg = ', TRIM( cn_cfg ), '   nn_cfg = ', nn_cfg 
    121121      ENDIF 
    122       lwxios = .FALSE. 
    123       ln_xios_read = .FALSE. 
    124122      ! 
    125123      !           !==  Reference coordinate system  ==! 
    … …  
    177175      ! 
    178176      IF( ln_linssh ) THEN       != Fix in time : set to the reference one for all 
    179       ! 
     177         ! 
    180178         DO jt = 1, jpt                         ! depth of t- and w-grid-points 
    181179            gdept(:,:,:,jt) = gdept_0(:,:,:) 
    … …  
    204202      ELSE                       != time varying : initialize before/now/after variables 
    205203         ! 
    206          IF( .NOT.l_offline )  CALL dom_vvl_init( Kbb, Kmm, Kaa ) 
     204         IF( .NOT.l_offline )   CALL dom_vvl_init( Kbb, Kmm, Kaa ) 
    207205         ! 
    208206      ENDIF 
    … …  
    248246      !!---------------------------------------------------------------------- 
    249247      ! 
    250       DO ji = 1, jpi                 ! local domain indices ==> global domain, including halos, indices 
     248      DO ji = 1, jpi                 ! local domain indices ==> global domain indices, including halos 
    251249        mig(ji) = ji + nimpp - 1 
    252250      END DO 
    … …  
    254252        mjg(jj) = jj + njmpp - 1 
    255253      END DO 
    256       !                              ! local domain indices ==> global domain, excluding halos, indices 
     254      !                              ! local domain indices ==> global domain indices, excluding halos 
    257255      ! 
    258256      mig0(:) = mig(:) - nn_hls 
    … …  
    493491      !!---------------------------------------------------------------------- 
    494492      ! 
    495       IF(lk_mpp) THEN 
    496          CALL mpp_minloc( 'domain', glamt(:,:), tmask_i(:,:), zglmin, imil ) 
    497          CALL mpp_minloc( 'domain', gphit(:,:), tmask_i(:,:), zgpmin, imip ) 
    498          CALL mpp_minloc( 'domain',   e1t(:,:), tmask_i(:,:), ze1min, imi1 ) 
    499          CALL mpp_minloc( 'domain',   e2t(:,:), tmask_i(:,:), ze2min, imi2 ) 
    500          CALL mpp_maxloc( 'domain', glamt(:,:), tmask_i(:,:), zglmax, imal ) 
    501          CALL mpp_maxloc( 'domain', gphit(:,:), tmask_i(:,:), zgpmax, imap ) 
    502          CALL mpp_maxloc( 'domain',   e1t(:,:), tmask_i(:,:), ze1max, ima1 ) 
    503          CALL mpp_maxloc( 'domain',   e2t(:,:), tmask_i(:,:), ze2max, ima2 ) 
    504       ELSE 
    505          llmsk = tmask_i(:,:) == 1._wp 
    506          zglmin = MINVAL( glamt(:,:), mask = llmsk )     
    507          zgpmin = MINVAL( gphit(:,:), mask = llmsk )     
    508          ze1min = MINVAL(   e1t(:,:), mask = llmsk )     
    509          ze2min = MINVAL(   e2t(:,:), mask = llmsk )     
    510          zglmin = MAXVAL( glamt(:,:), mask = llmsk )     
    511          zgpmin = MAXVAL( gphit(:,:), mask = llmsk )     
    512          ze1max = MAXVAL(   e1t(:,:), mask = llmsk )     
    513          ze2max = MAXVAL(   e2t(:,:), mask = llmsk )     
    514          ! 
    515          imil   = MINLOC( glamt(:,:), mask = llmsk ) + (/ nimpp - 1, njmpp - 1 /) 
    516          imip   = MINLOC( gphit(:,:), mask = llmsk ) + (/ nimpp - 1, njmpp - 1 /) 
    517          imi1   = MINLOC(   e1t(:,:), mask = llmsk ) + (/ nimpp - 1, njmpp - 1 /) 
    518          imi2   = MINLOC(   e2t(:,:), mask = llmsk ) + (/ nimpp - 1, njmpp - 1 /) 
    519          imal   = MAXLOC( glamt(:,:), mask = llmsk ) + (/ nimpp - 1, njmpp - 1 /) 
    520          imap   = MAXLOC( gphit(:,:), mask = llmsk ) + (/ nimpp - 1, njmpp - 1 /) 
    521          ima1   = MAXLOC(   e1t(:,:), mask = llmsk ) + (/ nimpp - 1, njmpp - 1 /) 
    522          ima2   = MAXLOC(   e2t(:,:), mask = llmsk ) + (/ nimpp - 1, njmpp - 1 /) 
    523       ENDIF 
     493      llmsk = tmask_h(:,:) == 1._wp 
     494      ! 
     495      CALL mpp_minloc( 'domain', glamt(:,:), llmsk, zglmin, imil ) 
     496      CALL mpp_minloc( 'domain', gphit(:,:), llmsk, zgpmin, imip ) 
     497      CALL mpp_minloc( 'domain',   e1t(:,:), llmsk, ze1min, imi1 ) 
     498      CALL mpp_minloc( 'domain',   e2t(:,:), llmsk, ze2min, imi2 ) 
     499      CALL mpp_maxloc( 'domain', glamt(:,:), llmsk, zglmax, imal ) 
     500      CALL mpp_maxloc( 'domain', gphit(:,:), llmsk, zgpmax, imap ) 
     501      CALL mpp_maxloc( 'domain',   e1t(:,:), llmsk, ze1max, ima1 ) 
     502      CALL mpp_maxloc( 'domain',   e2t(:,:), llmsk, ze2max, ima2 ) 
    524503      ! 
    525504      IF(lwp) THEN 
    … …  
    643622      ! 
    644623      !                             !==  ORCA family specificities  ==! 
    645       IF( cn_cfg == "ORCA" ) THEN 
     624      IF( TRIM(cn_cfg) == "orca" .OR. TRIM(cn_cfg) == "ORCA" ) THEN 
    646625         CALL iom_rstput( 0, 0, inum, 'ORCA'      , 1._wp            , ktype = jp_i4 ) 
    647626         CALL iom_rstput( 0, 0, inum, 'ORCA_index', REAL( nn_cfg, wp), ktype = jp_i4 )          

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/OCE/DOM/dommsk.F90

    r13295 r13571  
    9292      INTEGER  ::   iktop, ikbot   !   -       - 
    9393      INTEGER  ::   ios, inum 
    94       REAL(wp), ALLOCATABLE, DIMENSION(:,:) ::   zwf   ! 2D workspace 
    9594      !! 
    9695      NAMELIST/namlbc/ rn_shlat, ln_vorlat 
    … …  
    131130      ! 
    132131      tmask(:,:,:) = 0._wp 
    133       DO_2D( 1, 1, 1, 1 ) 
     132      DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
    134133         iktop = k_top(ji,jj) 
    135134         ikbot = k_bot(ji,jj) 
    … …  
    195194      IF( rn_shlat /= 0 ) THEN      ! Not free-slip lateral boundary condition 
    196195         ! 
    197          ALLOCATE( zwf(jpi,jpj) ) 
    198          ! 
    199196         DO jk = 1, jpk 
    200             zwf(:,:) = fmask(:,:,jk)          
    201197            DO_2D( 0, 0, 0, 0 ) 
    202198               IF( fmask(ji,jj,jk) == 0._wp ) THEN 
    203                   fmask(ji,jj,jk) = rn_shlat * MIN( 1._wp , MAX( zwf(ji+1,jj), zwf(ji,jj+1),  & 
    204                      &                                           zwf(ji-1,jj), zwf(ji,jj-1)  ) ) 
     199                  fmask(ji,jj,jk) = rn_shlat * MIN( 1._wp , MAX( umask(ji,jj,jk), umask(ji,jj+1,jk), & 
     200                     &                                           vmask(ji,jj,jk), vmask(ji+1,jj,jk) ) ) 
    205201               ENDIF 
    206202            END_2D 
    207203            DO jj = 2, jpjm1 
    208204               IF( fmask(1,jj,jk) == 0._wp ) THEN 
    209                   fmask(1  ,jj,jk) = rn_shlat * MIN( 1._wp , MAX( zwf(2,jj), zwf(1,jj+1), zwf(1,jj-1) ) ) 
     205                  fmask(1  ,jj,jk) = rn_shlat * MIN( 1._wp , MAX( vmask(2,jj,jk), umask(1,jj+1,jk), umask(1,jj,jk) ) ) 
    210206               ENDIF 
    211207               IF( fmask(jpi,jj,jk) == 0._wp ) THEN 
    212                   fmask(jpi,jj,jk) = rn_shlat * MIN( 1._wp , MAX( zwf(jpi,jj+1), zwf(jpim1,jj), zwf(jpi,jj-1) ) ) 
     208                  fmask(jpi,jj,jk) = rn_shlat * MIN( 1._wp , MAX( umask(jpi,jj+1,jk), vmask(jpim1,jj,jk), umask(jpi,jj-1,jk) ) ) 
    213209               ENDIF 
    214210            END DO          
    215211            DO ji = 2, jpim1 
    216212               IF( fmask(ji,1,jk) == 0._wp ) THEN 
    217                   fmask(ji, 1 ,jk) = rn_shlat * MIN( 1._wp , MAX( zwf(ji+1,1), zwf(ji,2), zwf(ji-1,1) ) ) 
     213                  fmask(ji, 1 ,jk) = rn_shlat * MIN( 1._wp , MAX( vmask(ji+1,1,jk), umask(ji,2,jk), vmask(ji,1,jk) ) ) 
    218214               ENDIF 
    219215               IF( fmask(ji,jpj,jk) == 0._wp ) THEN 
    220                   fmask(ji,jpj,jk) = rn_shlat * MIN( 1._wp , MAX( zwf(ji+1,jpj), zwf(ji-1,jpj), zwf(ji,jpjm1) ) ) 
     216                  fmask(ji,jpj,jk) = rn_shlat * MIN( 1._wp , MAX( vmask(ji+1,jpj,jk), vmask(ji-1,jpj,jk), umask(ji,jpjm1,jk) ) ) 
    221217               ENDIF 
    222218            END DO 
    223219         END DO 
    224          ! 
    225          DEALLOCATE( zwf ) 
    226220         ! 
    227221         CALL lbc_lnk( 'dommsk', fmask, 'F', 1._wp )      ! Lateral boundary conditions on fmask 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/OCE/DOM/domutl.F90

    r13286 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/DOM/domvvl.F90

    r13295 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/DOM/dtatsd.F90

    r13295 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/DYN/divhor.F90

    r13295 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/DYN/dynadv_cen2.F90

    r13295 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/DYN/dynadv_ubs.F90

    r13295 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/DYN/dynatf.F90

    r13295 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/DYN/dynkeg.F90

    r13295 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/DYN/dynldf_iso.F90

    r13295 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/DYN/dynldf_lap_blp.F90

    r13295 r13571  
    8484         END_2D 
    8585         ! 
    86          DO_2D( 0, 0, 0, 0 ) 
     86         DO_2D( 0, 0, 0, 0 )                       ! - curl( curl) + grad( div ) 
    8787            pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + zsign * umask(ji,jj,jk) * (    &    ! * by umask is mandatory for dyn_ldf_blp use 
    8888               &              - ( zcur(ji  ,jj) - zcur(ji,jj-1) ) * r1_e2u(ji,jj) / e3u(ji,jj,jk,Kmm)   & 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/OCE/DYN/dynspg.F90

    r13295 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/DYN/dynspg_exp.F90

    r13295 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/DYN/dynspg_ts.F90

    r13295 r13571  
    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) 
    … …  
    475475            ! 
    476476            !                          ! ocean u- and v-depth at mid-step   (separate DO-loops remove the need of a lbc_lnk) 
    477             DO_2D( 1, 1, 1, 0 ) 
     477            DO_2D( 1, 1, 1, 0 )   ! not jpi-column 
    478478               zhup2_e(ji,jj) = hu_0(ji,jj) + r1_2 * r1_e1e2u(ji,jj)                        & 
    479479                    &                              * (  e1e2t(ji  ,jj) * zsshp2_e(ji  ,jj)  & 
    480480                    &                                 + e1e2t(ji+1,jj) * zsshp2_e(ji+1,jj)  ) * ssumask(ji,jj) 
    481481            END_2D 
    482             DO_2D( 1, 0, 1, 1 ) 
     482            DO_2D( 1, 0, 1, 1 )   ! not jpj-row 
    483483               zhvp2_e(ji,jj) = hv_0(ji,jj) + r1_2 * r1_e1e2v(ji,jj)                        & 
    484484                    &                              * (  e1e2t(ji,jj  ) * zsshp2_e(ji,jj  )  & 
    … …  
    917917               CALL iom_get( numror, jpdom_auto, 'ub2_i_b'  , ub2_i_b(:,:), cd_type = 'U', psgn = -1._wp, ldxios = lrxios )    
    918918               CALL iom_get( numror, jpdom_auto, 'vb2_i_b'  , vb2_i_b(:,:), cd_type = 'V', psgn = -1._wp, ldxios = lrxios ) 
     919            ELSE 
     920               ub2_i_b(:,:) = 0._wp   ;   vb2_i_b(:,:) = 0._wp   ! used in the 1st update of agrif 
    919921            ENDIF 
    920922#endif 
    … …  
    922924            IF(lwp) WRITE(numout,*) 
    923925            IF(lwp) WRITE(numout,*) '   ==>>>   start from rest: set barotropic values to 0' 
    924             ub2_b (:,:) = 0._wp   ;   vb2_b (:,:) = 0._wp   ! used in the 1st interpol of agrif 
    925             un_adv(:,:) = 0._wp   ;   vn_adv(:,:) = 0._wp   ! used in the 1st interpol of agrif 
    926             un_bf (:,:) = 0._wp   ;   vn_bf (:,:) = 0._wp   ! used in the 1st update   of agrif 
     926            ub2_b  (:,:) = 0._wp   ;   vb2_b (:,:) = 0._wp   ! used in the 1st interpol of agrif 
     927            un_adv (:,:) = 0._wp   ;   vn_adv (:,:) = 0._wp   ! used in the 1st interpol of agrif 
     928            un_bf  (:,:) = 0._wp   ;   vn_bf (:,:) = 0._wp   ! used in the 1st update   of agrif 
    927929#if defined key_agrif 
    928             IF ( .NOT.Agrif_Root() ) THEN 
    929                ub2_i_b(:,:) = 0._wp   ;   vb2_i_b(:,:) = 0._wp   ! used in the 1st update of agrif 
    930             ENDIF 
     930            ub2_i_b(:,:) = 0._wp   ;   vb2_i_b(:,:) = 0._wp   ! used in the 1st update of agrif 
    931931#endif 
    932932         ENDIF 
    … …  
    13081308      !!---------------------------------------------------------------------- 
    13091309      ! 
    1310       DO_2D( 1, 1, 1, 0 ) 
     1310      DO_2D( 1, 1, 1, 0 )   ! not jpi-column 
    13111311         IF ( phU(ji,jj) > 0._wp ) THEN   ;   pUmsk(ji,jj) = pTmsk(ji  ,jj)  
    13121312         ELSE                             ;   pUmsk(ji,jj) = pTmsk(ji+1,jj)   
    … …  
    13161316      END_2D 
    13171317      ! 
    1318       DO_2D( 1, 0, 1, 1 ) 
     1318      DO_2D( 1, 0, 1, 1 )   ! not jpj-row 
    13191319         IF ( phV(ji,jj) > 0._wp ) THEN   ;   pVmsk(ji,jj) = pTmsk(ji,jj  ) 
    13201320         ELSE                             ;   pVmsk(ji,jj) = pTmsk(ji,jj+1)   
    … …  
    14051405      !                    !==  Set the barotropic drag coef.  ==! 
    14061406      ! 
    1407       IF( ln_isfcav ) THEN          ! top+bottom friction (ocean cavities) 
     1407      IF( ln_isfcav.OR.ln_drgice_imp ) THEN          ! top+bottom friction (ocean cavities) 
    14081408          
    14091409         DO_2D( 0, 0, 0, 0 ) 
    … …  
    14561456      !                    !==  TOP stress contribution from baroclinic velocities  ==!   (no W/D case) 
    14571457      ! 
    1458       IF( ln_isfcav ) THEN 
     1458      IF( ln_isfcav.OR.ln_drgice_imp ) THEN 
    14591459         ! 
    14601460         IF( ln_bt_fw ) THEN                ! FORWARD integration: use NOW top baroclinic velocity 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/OCE/DYN/dynvor.F90

    r13295 r13571  
    217217      INTEGER  ::   ji, jj, jk           ! dummy loop indices 
    218218      REAL(wp) ::   zx1, zy1, zx2, zy2   ! local scalars 
    219       REAL(wp), DIMENSION(jpi,jpj)     ::   zwx, zwy, zwt   ! 2D workspace 
    220       REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zwz             ! 3D workspace 
     219      REAL(wp), DIMENSION(jpi,jpj)       ::   zwx, zwy, zwt   ! 2D workspace 
     220      REAL(wp), DIMENSION(jpi,jpj,jpkm1) ::   zwz             ! 3D workspace, jpkm1 -> avoid lbc_lnk on jpk that is not defined 
    221221      !!---------------------------------------------------------------------- 
    222222      ! 
    … …  
    246246      CASE ( np_CRV )                           !* Coriolis + relative vorticity 
    247247         DO jk = 1, jpkm1                                 ! Horizontal slab 
    248             DO_2D( 1, 0, 1, 0 ) 
     248            DO_2D( 1, 0, 1, 0 )                          ! relative vorticity 
    249249               zwz(ji,jj,jk) = (   e2v(ji+1,jj) * pv(ji+1,jj,jk) - e2v(ji,jj) * pv(ji,jj,jk)   & 
    250250                  &              - e1u(ji,jj+1) * pu(ji,jj+1,jk) + e1u(ji,jj) * pu(ji,jj,jk)   ) * r1_e1e2f(ji,jj) 
    … …  
    533533      REAL(wp) ::   zua, zva     ! local scalars 
    534534      REAL(wp) ::   zmsk, ze3f   ! local scalars 
    535       REAL(wp), DIMENSION(jpi,jpj)     ::   zwx , zwy , z1_e3f 
    536       REAL(wp), DIMENSION(jpi,jpj)     ::   ztnw, ztne, ztsw, ztse 
    537       REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zwz 
     535      REAL(wp), DIMENSION(jpi,jpj)       ::   zwx , zwy , z1_e3f 
     536      REAL(wp), DIMENSION(jpi,jpj)       ::   ztnw, ztne, ztsw, ztse 
     537      REAL(wp), DIMENSION(jpi,jpj,jpkm1) ::   zwz   ! 3D workspace, jpkm1 -> jpkm1 -> avoid lbc_lnk on jpk that is not defined 
    538538      !!---------------------------------------------------------------------- 
    539539      ! 
    … …  
    677677      REAL(wp) ::   zua, zva       ! local scalars 
    678678      REAL(wp) ::   zmsk, z1_e3t   ! local scalars 
    679       REAL(wp), DIMENSION(jpi,jpj)     ::   zwx , zwy  
    680       REAL(wp), DIMENSION(jpi,jpj)     ::   ztnw, ztne, ztsw, ztse 
    681       REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zwz 
     679      REAL(wp), DIMENSION(jpi,jpj)       ::   zwx , zwy  
     680      REAL(wp), DIMENSION(jpi,jpj)       ::   ztnw, ztne, ztsw, ztse 
     681      REAL(wp), DIMENSION(jpi,jpj,jpkm1) ::   zwz   ! 3D workspace, avoid lbc_lnk on jpk that is not defined 
    682682      !!---------------------------------------------------------------------- 
    683683      ! 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/OCE/DYN/dynzad.F90

    r13295 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/DYN/dynzdf.F90

    r13295 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/DYN/sshwzv.F90

    r13295 r13571  
    203203      ELSE                                            !==  Quasi-Eulerian vertical coordinate  ==!   ('key_qco') 
    204204         !                                            !==========================================! 
    205          DO jk = jpkm1, 1, -1                       ! integrate from the bottom the hor. divergence 
     205         DO jk = jpkm1, 1, -1                               ! integrate from the bottom the hor. divergence 
    206206            pww(:,:,jk) = pww(:,:,jk+1) - (  e3t(:,:,jk,Kmm) * hdiv(:,:,jk)                 & 
    207207               &                            + r1_Dt * (  e3t(:,:,jk,Kaa)        & 
    … …  
    393393      ! 
    394394      IF( MAXVAL( Cu_adv(:,:,:) ) > Cu_min ) THEN       ! Quick check if any breaches anywhere 
    395          DO_3DS( 1, 1, 1, 1, jpkm1, 2, -1 ) 
     395         DO_3DS( 1, 1, 1, 1, jpkm1, 2, -1 )             ! or scan Courant criterion and partition ! w where necessary 
    396396            ! 
    397397            zCu = MAX( Cu_adv(ji,jj,jk) , Cu_adv(ji,jj,jk-1) ) 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/OCE/DYN/wet_dry.F90

    r13295 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/FLO/flo_oce.F90

    r11536 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/ICB/icbtrj.F90

    r13062 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/IOM/iom.F90

    r13295 r13571  
    123123      REAL(wp), DIMENSION(2,jpkam1)         :: za_bnds   ! ABL vertical boundaries 
    124124      LOGICAL ::   ll_closedef = .TRUE. 
     125      LOGICAL ::   ll_exist 
    125126      !!---------------------------------------------------------------------- 
    126127      ! 
    … …  
    230231          CALL iom_set_axis_attr( "ghw_abl", bounds=za_bnds ) 
    231232 
    232           CALL iom_set_axis_attr( "nfloat", (/ (REAL(ji,wp), ji=1,jpnfl) /) ) 
     233          CALL iom_set_axis_attr(  "nfloat", (/ (REAL(ji,wp), ji=1,jpnfl) /) ) 
    233234# if defined key_si3 
    234235          CALL iom_set_axis_attr( "ncatice", (/ (REAL(ji,wp), ji=1,jpl) /) ) 
    … …  
    243244          CALL iom_set_axis_attr( "iax_26C", (/ REAL(26,wp) /) )   ! strange syntaxe and idea... 
    244245          CALL iom_set_axis_attr( "iax_28C", (/ REAL(28,wp) /) )   ! strange syntaxe and idea... 
    245           CALL iom_set_axis_attr( "basin"  , (/ (REAL(ji,wp), ji=1,5) /) ) 
     246          ! for diaprt, we need to define an axis which size can be 1 (default) or 5 (if the file subbasins.nc exists) 
     247          INQUIRE( FILE = 'subbasins.nc', EXIST = ll_exist ) 
     248          nbasin = 1 + 4 * COUNT( (/ll_exist/) ) 
     249          CALL iom_set_axis_attr( "basin"  , (/ (REAL(ji,wp), ji=1,nbasin) /) ) 
    246250      ENDIF 
    247251      ! 
    … …  
    350354           rst_file = TRIM(clpath)//TRIM(cn_ocerst_in) 
    351355        ELSE 
    352            rst_file = TRIM(clpath)//'1_'//TRIM(cn_ocerst_in) 
     356           rst_file = TRIM(clpath)//TRIM(Agrif_CFixed())//'_'//TRIM(cn_ocerst_in) 
    353357        ENDIF 
    354358!set name of the restart file and enable available fields 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/OCE/IOM/iom_def.F90

    r13286 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/ISF/isf_oce.F90

    r12077 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/ISF/isfcavmlt.F90

    r13295 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/LBC/lbc_lnk_multi_generic.h90

    r13286 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/LBC/lib_mpp.F90

    r13561 r13571  
    7474   PUBLIC   tic_tac 
    7575#if ! defined key_mpp_mpi 
     76   PUBLIC MPI_wait 
    7677   PUBLIC MPI_Wtime 
    7778#endif 
    … …  
    116117#else    
    117118   INTEGER, PUBLIC, PARAMETER ::   MPI_STATUS_SIZE = 1 
     119   INTEGER, PUBLIC, PARAMETER ::   MPI_REAL = 4 
    118120   INTEGER, PUBLIC, PARAMETER ::   MPI_DOUBLE_PRECISION = 8 
    119121   LOGICAL, PUBLIC, PARAMETER ::   lk_mpp = .FALSE.    !: mpp flag 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/OCE/LBC/mpp_lbc_north_icb_generic.h90

    r13286 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/LBC/mpp_loc_generic.h90

    r13286 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/LBC/mpp_nfd_generic.h90

    r13290 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/LBC/mppini.F90

    r13561 r13571  
    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 
    … …  
    646641         WRITE(inum,'(6i8,a,3i8,a)') jpnij,jpimax,jpjmax,jpk,jpiglo,jpjglo,& 
    647642   &           ' ( local: ',narea,jpi,jpj,' )' 
    648          WRITE(inum,'(a)') 'nproc jpi jpj Nis0 Njs0 Nie0 Nje0 nimp njmp nono noso nowe noea nbondi nbondj ' 
     643         WRITE(inum,'(a)') 'nproc   jpi jpj Nis0 Njs0 Nie0 Nje0 nimp njmp nono noso nowe noea nbondi nbondj ' 
    649644 
    650645         DO jproc = 1, jpnij 
    … …  
    733728    END SUBROUTINE mpp_init 
    734729 
     730#endif 
    735731 
    736732    SUBROUTINE mpp_basesplit( kiglo, kjglo, khls, knbi, knbj, kimax, kjmax, kimppt, kjmppt, klci, klcj) 
    … …  
    847843      !! ** Method  : 
    848844      !!---------------------------------------------------------------------- 
    849       INTEGER,           INTENT(in   ) ::   knbij         ! total number if subdomains              (knbi*knbj) 
     845      INTEGER,           INTENT(in   ) ::   knbij         ! total number of subdomains (knbi*knbj) 
    850846      INTEGER, OPTIONAL, INTENT(  out) ::   knbi, knbj    ! number if subdomains along i and j (knbi and knbj) 
    851847      INTEGER, OPTIONAL, INTENT(  out) ::   knbcnt        ! number of land subdomains 
    … …  
    855851      INTEGER :: iszitst, iszjtst 
    856852      INTEGER :: isziref, iszjref 
     853      INTEGER :: iszimin, iszjmin 
    857854      INTEGER :: inbij, iszij 
    858855      INTEGER :: inbimax, inbjmax, inbijmax, inbijold 
    … …  
    883880      inbimax = 0 
    884881      inbjmax = 0 
    885       isziref = Ni0glo*Nj0glo+1 
    886       iszjref = Ni0glo*Nj0glo+1 
     882      isziref = jpiglo*jpjglo+1   ! define a value that is larger than the largest possible 
     883      iszjref = jpiglo*jpjglo+1 
     884      ! 
     885      iszimin = 4*nn_hls          ! minimum size of the MPI subdomain so halos are always adressing neighbor inner domain 
     886      iszjmin = 4*nn_hls 
     887      IF( jperio == 3 .OR. jperio == 4 )   iszjmin = MAX(iszjmin, 2+3*nn_hls)   ! V and F folding must be outside of southern halos 
     888      IF( jperio == 5 .OR. jperio == 6 )   iszjmin = MAX(iszjmin, 1+3*nn_hls)   ! V and F folding must be outside of southern halos 
    887889      ! 
    888890      ! get the list of knbi that gives a smaller jpimax than knbi-1 
    … …  
    892894         iszitst = ( nx_global+2-2*nn_hls + (ji-1) ) / ji + 2*nn_hls    ! first  dim. 
    893895#else 
    894          iszitst = ( Ni0glo + (ji-1) ) / ji 
     896         iszitst = ( Ni0glo + (ji-1) ) / ji + 2*nn_hls   ! max subdomain i-size 
    895897#endif 
    896          IF( iszitst < isziref ) THEN 
     898         IF( iszitst < isziref .AND. iszitst >= iszimin ) THEN 
    897899            isziref = iszitst 
    898900            inbimax = inbimax + 1 
    … …  
    903905         iszjtst = ( ny_global+2-2*nn_hls + (ji-1) ) / ji + 2*nn_hls    ! first  dim. 
    904906#else 
    905          iszjtst = ( Nj0glo + (ji-1) ) / ji 
     907         iszjtst = ( Nj0glo + (ji-1) ) / ji + 2*nn_hls   ! max subdomain j-size 
    906908#endif 
    907          IF( iszjtst < iszjref ) THEN 
     909         IF( iszjtst < iszjref .AND. iszjtst >= iszjmin ) THEN 
    908910            iszjref = iszjtst 
    909911            inbjmax = inbjmax + 1 
    … …  
    958960      isz0 = 0                                                  ! number of best partitions      
    959961      inbij = 1                                                 ! start with the min value of inbij1 => 1 
    960       iszij = Ni0glo*Nj0glo+1                                   ! default: larger than global domain 
     962      iszij = jpiglo*jpjglo+1                                   ! default: larger than global domain 
    961963      DO WHILE( inbij <= inbijmax )                             ! if we did not reach the max of inbij1 
    962964         ii = MINLOC(iszij1, mask = inbij1 == inbij, dim = 1)   ! warning: send back the first occurence if multiple results 
    963965         IF ( iszij1(ii) < iszij ) THEN 
     966            ii = MINLOC( iszi1+iszj1, mask = iszij1 == iszij1(ii) .AND. inbij1 == inbij, dim = 1)  ! select the smaller perimeter if multiple min 
    964967            isz0 = isz0 + 1 
    965968            indexok(isz0) = ii 
    … …  
    13791382   END SUBROUTINE init_nfdcom 
    13801383 
    1381 #endif 
    13821384 
    13831385   SUBROUTINE init_doloop 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/OCE/LDF/ldfc1d_c2d.F90

    r13295 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/LDF/ldfdyn.F90

    r13295 r13571  
    311311            IF( ierr /= 0 )   CALL ctl_stop( 'STOP', 'ldf_dyn_init: failed to allocate Smagorinsky arrays') 
    312312            ! 
    313             DO_2D( 1, 1, 1, 1 ) 
     313            DO_2D( 1, 1, 1, 1 )        ! Set local gridscale values 
    314314               esqt(ji,jj) = ( 2._wp * e1e2t(ji,jj) / ( e1t(ji,jj) + e2t(ji,jj) ) )**2  
    315315               esqf(ji,jj) = ( 2._wp * e1e2f(ji,jj) / ( e1f(ji,jj) + e2f(ji,jj) ) )**2  
    … …  
    434434            DO jk = 1, jpkm1 
    435435              ! 
    436                DO_2D( 0, 0, 0, 0 ) 
     436               DO_2D( 0, 0, 0, 0 )                                   ! T-point value 
    437437                  ! 
    438438                  zu2pv2_ij    = uu(ji  ,jj  ,jk,Kbb) * uu(ji  ,jj  ,jk,Kbb) + vv(ji  ,jj  ,jk,Kbb) * vv(ji  ,jj  ,jk,Kbb) 
    … …  
    448448               END_2D 
    449449               ! 
    450                DO_2D( 1, 0, 1, 0 ) 
     450               DO_2D( 1, 0, 1, 0 )                                   ! F-point value 
    451451                  ! 
    452452                  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_r13296_HPC-07_mocavero_mpi3/src/OCE/LDF/ldfslp.F90

    r13295 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/LDF/ldftra.F90

    r13295 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/SBC/cpl_oasis3.F90

    r13286 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/SBC/fldread.F90

    r13295 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/SBC/sbc_ice.F90

    r12396 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/SBC/sbc_oce.F90

    r13295 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/SBC/sbcblk.F90

    r13295 r13571  
    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   ! 
    … …  
    568578      zwnd_j(:,:) = 0._wp 
    569579      CALL wnd_cyc( kt, zwnd_i, zwnd_j )    ! add analytical tropical cyclone (Vincent et al. JGR 2012) 
    570       DO_2D( 1, 1, 1, 1 ) 
     580      DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
    571581         zwnd_i(ji,jj) = pwndi(ji,jj) + zwnd_i(ji,jj) 
    572582         zwnd_j(ji,jj) = pwndj(ji,jj) + zwnd_j(ji,jj) 
    … …  
    576586#else 
    577587      ! ... scalar wind module at T-point (not masked) 
    578       DO_2D( 1, 1, 1, 1 ) 
     588      DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
    579589         wndm(ji,jj) = SQRT(  pwndi(ji,jj) * pwndi(ji,jj) + pwndj(ji,jj) * pwndj(ji,jj)  ) 
    580590      END_2D 
    … …  
    628638         !     use scalar version of gamma_moist() ... 
    629639         IF( ln_tpot ) THEN 
    630             DO_2D( 1, 1, 1, 1 ) 
     640            DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
    631641               ztpot(ji,jj) = ptair(ji,jj) + gamma_moist( ptair(ji,jj), zqair(ji,jj) ) * rn_zqt 
    632642            END_2D 
    … …  
    690700 
    691701      IF( ln_abl ) THEN         !==  ABL formulation  ==!   multiplication by rho_air and turbulent fluxes computation done in ablstp 
    692          DO_2D( 1, 1, 1, 1 ) 
     702         DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
    693703            zztmp = zU_zu(ji,jj) 
    694704            wndm(ji,jj)   = zztmp                   ! Store zU_zu in wndm to compute ustar2 in ablmod 
    … …  
    710720         pevp(:,:) = pevp(:,:) * tmask(:,:,1) 
    711721 
    712          DO_2D( 1, 1, 1, 1 ) 
     722         DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
    713723            IF( wndm(ji,jj) > 0._wp ) THEN 
    714724               zztmp = taum(ji,jj) / wndm(ji,jj) 
    … …  
    828838 
    829839      ! use scalar version of L_vap() for AGRIF compatibility 
    830       DO_2D( 1, 1, 1, 1 ) 
     840      DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
    831841         zqla(ji,jj) = - L_vap( ztskk(ji,jj) ) * pevp(ji,jj)    ! Latent Heat flux !!GS: possibility to add a global qla to avoid recomputation after abl update 
    832842      END_2D 
    … …  
    933943      ! ------------------------------------------------------------ ! 
    934944      ! C-grid ice dynamics :   U & V-points (same as ocean) 
    935       DO_2D( 1, 1, 1, 1 ) 
     945      DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
    936946         wndm_ice(ji,jj) = SQRT( pwndi(ji,jj) * pwndi(ji,jj) + pwndj(ji,jj) * pwndj(ji,jj) ) 
    937947      END_2D 
    … …  
    978988         zztmp1 = 11637800.0_wp 
    979989         zztmp2 =    -5897.8_wp 
    980          DO_2D( 1, 1, 1, 1 ) 
     990         DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
    981991            pcd_dui(ji,jj) = zcd_dui (ji,jj) 
    982992            pseni  (ji,jj) = wndm_ice(ji,jj) * Ch_ice(ji,jj) 
    … …  
    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(:,:) ) 
    … …  
    12331253         ! 
    12341254         DO jl = 1, jpl 
    1235             DO_2D( 1, 1, 1, 1 ) 
     1255            DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
    12361256               zhe = ( rn_cnd_s * phi(ji,jj,jl) + rcnd_i * phs(ji,jj,jl) ) * zfac                            ! Effective thickness 
    12371257               IF( zhe >=  zfac2 )   zgfac(ji,jj,jl) = MIN( 2._wp, 0.5_wp * ( 1._wp + LOG( zhe * zfac3 ) ) ) ! Enhanced conduction factor 
    … …  
    12481268      ! 
    12491269      DO jl = 1, jpl 
    1250          DO_2D( 1, 1, 1, 1 ) 
     1270         DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
    12511271            ! 
    12521272            zkeff_h = zfac * zgfac(ji,jj,jl) / &                                    ! Effective conductivity of the snow-ice system divided by thickness 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/OCE/SBC/sbcblk_algo_coare3p0.F90

    r13295 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/SBC/sbcblk_algo_coare3p6.F90

    r13295 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/SBC/sbcblk_algo_ecmwf.F90

    r13295 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/SBC/sbcblk_algo_ncar.F90

    r13295 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/SBC/sbcblk_phy.F90

    r13295 r13571  
    181181      !!---------------------------------------------------------------------------------- 
    182182      ! 
    183       DO_2D( 1, 1, 1, 1 ) 
     183      DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
    184184         ztc  = ptak(ji,jj) - rt0   ! air temp, in deg. C 
    185185         ztc2 = ztc*ztc 
    … …  
    270270      INTEGER  ::   ji, jj         ! dummy loop indices 
    271271      !!---------------------------------------------------------------------------------- 
    272       DO_2D( 1, 1, 1, 1 ) 
     272      DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
    273273         gamma_moist_vctr(ji,jj) = gamma_moist_sclr( ptak(ji,jj), pqa(ji,jj) ) 
    274274      END_2D 
    … …  
    315315      !!------------------------------------------------------------------- 
    316316      ! 
    317       DO_2D( 1, 1, 1, 1 ) 
     317      DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
    318318         ! 
    319319         zqa = (1._wp + rctv0*pqa(ji,jj)) 
    … …  
    351351      !!------------------------------------------------------------------- 
    352352      ! 
    353       DO_2D( 1, 1, 1, 1 ) 
     353      DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
    354354         ! 
    355355         zqa = 0.5_wp*(pqa(ji,jj)+pssq(ji,jj))                                        ! ~ mean q within the layer... 
    … …  
    448448      !!---------------------------------------------------------------------------------- 
    449449      ! 
    450       DO_2D( 1, 1, 1, 1 ) 
     450      DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
    451451         ! 
    452452         ze_sat =  e_sat_sclr( ptak(ji,jj) ) 
    … …  
    473473      !!---------------------------------------------------------------------------------- 
    474474      ! 
    475       DO_2D( 1, 1, 1, 1 ) 
     475      DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
    476476         ze = prha(ji,jj)*e_sat_sclr(ptak(ji,jj)) 
    477477         q_air_rh(ji,jj) = ze*reps0/(pslp(ji,jj) - (1. - reps0)*ze) 
    … …  
    511511      INTEGER  ::   ji, jj     ! dummy loop indices 
    512512      !!---------------------------------------------------------------------------------- 
    513       DO_2D( 1, 1, 1, 1 ) 
     513      DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
    514514 
    515515         zdt = pTa(ji,jj) - pTs(ji,jj) ;  zdt = SIGN( MAX(ABS(zdt),1.E-6_wp), zdt ) 
    … …  
    621621      IF( PRESENT(pfact_evap) ) zfact_evap = pfact_evap 
    622622 
    623       DO_2D( 1, 1, 1, 1 ) 
     623      DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
    624624 
    625625         CALL BULK_FORMULA_SCLR( pzu, pTs(ji,jj), pqs(ji,jj), pTa(ji,jj), pqa(ji,jj), & 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/OCE/SBC/sbcblk_skin_coare.F90

    r13295 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/SBC/sbcblk_skin_ecmwf.F90

    r13295 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/SBC/sbccpl.F90

    r13295 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/SBC/sbcdcy.F90

    r13295 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/SBC/sbcflx.F90

    r13295 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/SBC/sbcmod.F90

    r13286 r13571  
    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      ! 
    … …  
    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      ! 
    … …  
    563566      ENDIF 
    564567      ! 
    565       CALL iom_put( "utau", utau )   ! i-wind stress   (stress can be updated at each time step in sea-ice) 
    566       CALL iom_put( "vtau", vtau )   ! j-wind stress 
    567       ! 
    568568      IF(sn_cfctl%l_prtctl) THEN     ! print mean trends (used for debugging) 
    569569         CALL prt_ctl(tab2d_1=fr_i             , clinfo1=' fr_i     - : ', mask1=tmask ) 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/OCE/SBC/sbcrnf.F90

    r13295 r13571  
    215215            END_2D 
    216216         ELSE                    !* variable volume case 
    217             DO_2D( 1, 1, 1, 1 ) 
     217            DO_2D( 1, 1, 1, 1 )              ! update the depth over which runoffs are distributed 
    218218               h_rnf(ji,jj) = 0._wp 
    219                DO jk = 1, nk_rnf(ji,jj)                           ! recalculates h_rnf to be the depth in metres 
     219               DO jk = 1, nk_rnf(ji,jj)                             ! recalculates h_rnf to be the depth in metres 
    220220                  h_rnf(ji,jj) = h_rnf(ji,jj) + e3t(ji,jj,jk,Kmm)   ! to the bottom of the relevant grid box 
    221221               END DO 
    … …  
    374374            ENDIF 
    375375         END_2D 
    376          DO_2D( 1, 1, 1, 1 ) 
     376         DO_2D( 1, 1, 1, 1 )                           ! set the associated depth 
    377377            h_rnf(ji,jj) = 0._wp 
    378378            DO jk = 1, nk_rnf(ji,jj) 
    … …  
    404404         WHERE( zrnfcl(:,:,1) > 0._wp )  h_rnf(:,:) = zacoef * zrnfcl(:,:,1)   ! compute depth for all runoffs 
    405405         ! 
    406          DO_2D( 1, 1, 1, 1 ) 
     406         DO_2D( 1, 1, 1, 1 )                ! take in account min depth of ocean rn_hmin 
    407407            IF( zrnfcl(ji,jj,1) > 0._wp ) THEN 
    408408               jk = mbkt(ji,jj) 
    … …  
    423423         END_2D 
    424424         ! 
    425          DO_2D( 1, 1, 1, 1 ) 
     425         DO_2D( 1, 1, 1, 1 )                          ! set the associated depth 
    426426            h_rnf(ji,jj) = 0._wp 
    427427            DO jk = 1, nk_rnf(ji,jj) 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/OCE/SBC/sbcwave.F90

    r13295 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/TRA/eosbn2.F90

    r13295 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/TRA/traadv_cen.F90

    r13295 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/TRA/traadv_fct.F90

    r13570 r13571  
    161161            zwy(ji,jj,jk) = 0.5 * ( zfp_vj * pt(ji,jj,jk,jn,Kbb) + zfm_vj * pt(ji  ,jj+1,jk,jn,Kbb) ) 
    162162         END_3D 
    163          !                    !* upstream tracer flux in the k direction *! 
    164          DO_3D( 1, 1, 1, 1, 2, jpkm1 ) 
     163         !                               !* upstream tracer flux in the k direction *! 
     164         DO_3D( 1, 1, 1, 1, 2, jpkm1 )      ! Interior value ( multiplied by wmask) 
    165165            zfp_wk = pW(ji,jj,jk) + ABS( pW(ji,jj,jk) ) 
    166166            zfm_wk = pW(ji,jj,jk) - ABS( pW(ji,jj,jk) ) 
    167167            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) 
    168168         END_3D 
    169          IF( ln_linssh ) THEN    ! top ocean value (only in linear free surface as zwz has been w-masked) 
    170             IF( ln_isfcav ) THEN             ! top of the ice-shelf cavities and at the ocean surface 
     169         IF( ln_linssh ) THEN               ! top ocean value (only in linear free surface as zwz has been w-masked) 
     170            IF( ln_isfcav ) THEN                        ! top of the ice-shelf cavities and at the ocean surface 
    171171               DO_2D( 1, 1, 1, 1 ) 
    172172                  zwz(ji,jj, mikt(ji,jj) ) = pW(ji,jj,mikt(ji,jj)) * pt(ji,jj,mikt(ji,jj),jn,Kbb)   ! linear free surface  
    173173               END_2D 
    174             ELSE                             ! no cavities: only at the ocean surface 
     174            ELSE                                        ! no cavities: only at the ocean surface 
    175175               DO_2D( 1, 1, 1, 1 ) 
    176176                  zwz(ji,jj,1) = pW(ji,jj,1) * pt(ji,jj,1,jn,Kbb) 
    … …  
    179179         ENDIF 
    180180         !                
    181          DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
    182             !                             ! total intermediate advective trends 
     181         DO_3D( 0, 0, 0, 0, 1, jpkm1 )   !* trend and after field with monotonic scheme 
     182            !                               ! total intermediate advective trends 
    183183            ztra = - (  zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk  )   & 
    184184               &      + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk  )   & 
    185185               &      + zwz(ji,jj,jk) - zwz(ji  ,jj  ,jk+1) ) * r1_e1e2t(ji,jj) 
    186             !                             ! update and guess with monotonic sheme 
     186            !                               ! update and guess with monotonic sheme 
    187187            pt(ji,jj,jk,jn,Krhs) =                   pt(ji,jj,jk,jn,Krhs) +       ztra   & 
    188188               &                                  / e3t(ji,jj,jk,Kmm ) * tmask(ji,jj,jk) 
    … …  
    195195            ! 
    196196            ztw(:,:,1) = 0._wp ; ztw(:,:,jpk) = 0._wp ; 
    197             DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 
     197            DO_3D( 0, 0, 0, 0, 2, jpkm1 )       ! Interior value ( multiplied by wmask) 
    198198               zfp_wk = wi(ji,jj,jk) + ABS( wi(ji,jj,jk) ) 
    199199               zfm_wk = wi(ji,jj,jk) - ABS( wi(ji,jj,jk) ) 
    … …  
    228228            zltv(:,:,jpk) = 0._wp 
    229229            DO jk = 1, jpkm1                 ! Laplacian 
    230                DO_2D( 1, 0, 1, 0 ) 
     230               DO_2D( 1, 0, 1, 0 )                 ! 1st derivative (gradient) 
    231231                  ztu(ji,jj,jk) = ( pt(ji+1,jj  ,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * umask(ji,jj,jk) 
    232232                  ztv(ji,jj,jk) = ( pt(ji  ,jj+1,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * vmask(ji,jj,jk) 
    233233               END_2D 
    234                DO_2D( 0, 0, 0, 0 ) 
     234               DO_2D( 0, 0, 0, 0 )                 ! 2nd derivative * 1/ 6 
    235235                  zltu(ji,jj,jk) = (  ztu(ji,jj,jk) + ztu(ji-1,jj,jk)  ) * r1_6 
    236236                  zltv(ji,jj,jk) = (  ztv(ji,jj,jk) + ztv(ji,jj-1,jk)  ) * r1_6 
    … …  
    243243#endif 
    244244            ! 
    245             DO_3D( 1, 0, 1, 0, 1, jpkm1 ) 
     245            DO_3D( 1, 0, 1, 0, 1, jpkm1 )    ! Horizontal advective fluxes 
    246246               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 
    247247               zC2t_v = pt(ji,jj,jk,jn,Kmm) + pt(ji  ,jj+1,jk,jn,Kmm) 
    248                !                                                  ! C4 minus upstream advective fluxes  
     248               !                                                        ! C4 minus upstream advective fluxes  
    249249               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) 
    250250               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) 
    … …  
    254254            ztu(:,:,jpk) = 0._wp             ! Bottom value : flux set to zero 
    255255            ztv(:,:,jpk) = 0._wp 
    256             DO_3D( 1, 0, 1, 0, 1, jpkm1 ) 
     256            DO_3D( 1, 0, 1, 0, 1, jpkm1 )    ! 1st derivative (gradient) 
    257257               ztu(ji,jj,jk) = ( pt(ji+1,jj  ,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * umask(ji,jj,jk) 
    258258               ztv(ji,jj,jk) = ( pt(ji  ,jj+1,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * vmask(ji,jj,jk) 
    … …  
    264264#endif 
    265265            ! 
    266             DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     266            DO_3D( 0, 0, 0, 0, 1, jpkm1 )    ! Horizontal advective fluxes 
    267267               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) 
    268268               zC2t_v = pt(ji,jj,jk,jn,Kmm) + pt(ji  ,jj+1,jk,jn,Kmm) 
    … …  
    297297         !          
    298298         IF ( ll_zAimp ) THEN 
    299             DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
    300                !                             ! total intermediate advective trends 
     299            DO_3D( 0, 0, 0, 0, 1, jpkm1 )    !* trend and after field with monotonic scheme 
     300               !                                                ! total intermediate advective trends 
    301301               ztra = - (  zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk  )   & 
    302302                  &      + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk  )   & 
    … …  
    307307            CALL tridia_solver( zwdia, zwsup, zwinf, ztw, ztw , 0 ) 
    308308            ! 
    309             DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 
     309            DO_3D( 0, 0, 0, 0, 2, jpkm1 )       ! Interior value ( multiplied by wmask) 
    310310               zfp_wk = wi(ji,jj,jk) + ABS( wi(ji,jj,jk) ) 
    311311               zfm_wk = wi(ji,jj,jk) - ABS( wi(ji,jj,jk) ) 
    … …  
    337337            ! 
    338338            ztw(:,:,1) = 0._wp ; ztw(:,:,jpk) = 0._wp 
    339             DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 
     339            DO_3D( 0, 0, 0, 0, 2, jpkm1 )      ! Interior value ( multiplied by wmask) 
    340340               zfp_wk = wi(ji,jj,jk) + ABS( wi(ji,jj,jk) ) 
    341341               zfm_wk = wi(ji,jj,jk) - ABS( wi(ji,jj,jk) ) 
    … …  
    471471         pbb(ji,jj,jk) = pbb(ji,jj,jk) * ( zcv * zav + ( 1._wp - zcv) * zbv ) 
    472472 
    473 ! monotonic flux in the k direction, i.e. pcc 
    474 ! ------------------------------------------- 
     473      ! monotonic flux in the k direction, i.e. pcc 
     474      ! ------------------------------------------- 
    475475         za = MIN( 1., zbetdo(ji,jj,jk+1), zbetup(ji,jj,jk) ) 
    476476         zb = MIN( 1., zbetup(ji,jj,jk+1), zbetdo(ji,jj,jk) ) 
    … …  
    502502      !!---------------------------------------------------------------------- 
    503503       
    504       DO_3D( 1, 1, 1, 1, 3, jpkm1 ) 
     504      DO_3D( 1, 1, 1, 1, 3, jpkm1 )       !==  build the three diagonal matrix  ==! 
    505505         zwd (ji,jj,jk) = 4._wp 
    506506         zwi (ji,jj,jk) = 1._wp 
    … …  
    516516      END_3D 
    517517      ! 
    518       jk = 2                                          ! Switch to second order centered at top 
     518      jk = 2                                    ! Switch to second order centered at top 
    519519      DO_2D( 1, 1, 1, 1 ) 
    520520         zwd (ji,jj,jk) = 1._wp 
    … …  
    525525      ! 
    526526      !                       !==  tridiagonal solve  ==! 
    527       DO_2D( 1, 1, 1, 1 ) 
     527      DO_2D( 1, 1, 1, 1 )           ! first recurrence 
    528528         zwt(ji,jj,2) = zwd(ji,jj,2) 
    529529      END_2D 
    … …  
    532532      END_3D 
    533533      ! 
    534       DO_2D( 1, 1, 1, 1 ) 
     534      DO_2D( 1, 1, 1, 1 )           ! second recurrence:    Zk = Yk - Ik / Tk-1  Zk-1 
    535535         pt_out(ji,jj,2) = zwrm(ji,jj,2) 
    536536      END_2D 
    … …  
    539539      END_3D 
    540540 
    541       DO_2D( 1, 1, 1, 1 ) 
     541      DO_2D( 1, 1, 1, 1 )           ! third recurrence: Xk = (Zk - Sk Xk+1 ) / Tk 
    542542         pt_out(ji,jj,jpkm1) = pt_out(ji,jj,jpkm1) / zwt(ji,jj,jpkm1) 
    543543      END_2D 
    … …  
    567567      !                      !==  build the three diagonal matrix & the RHS  ==! 
    568568      ! 
    569       DO_3D( 0, 0, 0, 0, 3, jpkm1 ) 
     569      DO_3D( 0, 0, 0, 0, 3, jpkm1 )    ! interior (from jk=3 to jpk-1) 
    570570         zwd (ji,jj,jk) = 3._wp * wmask(ji,jj,jk) + 1._wp                 !       diagonal 
    571571         zwi (ji,jj,jk) =         wmask(ji,jj,jk)                         ! lower diagonal 
    … …  
    586586      END IF 
    587587      ! 
    588       DO_2D( 0, 0, 0, 0 ) 
     588      DO_2D( 0, 0, 0, 0 )              ! 2nd order centered at top & bottom 
    589589         ikt = mikt(ji,jj) + 1            ! w-point below the 1st  wet point 
    590590         ikb = MAX(mbkt(ji,jj), 2)        !     -   above the last wet point 
    … …  
    603603      !                       !==  tridiagonal solver  ==! 
    604604      ! 
    605       DO_2D( 0, 0, 0, 0 ) 
     605      DO_2D( 0, 0, 0, 0 )           !* 1st recurrence:   Tk = Dk - Ik Sk-1 / Tk-1 
    606606         zwt(ji,jj,2) = zwd(ji,jj,2) 
    607607      END_2D 
    … …  
    610610      END_3D 
    611611      ! 
    612       DO_2D( 0, 0, 0, 0 ) 
     612      DO_2D( 0, 0, 0, 0 )           !* 2nd recurrence:    Zk = Yk - Ik / Tk-1  Zk-1 
    613613         pt_out(ji,jj,2) = zwrm(ji,jj,2) 
    614614      END_2D 
    … …  
    617617      END_3D 
    618618 
    619       DO_2D( 0, 0, 0, 0 ) 
     619      DO_2D( 0, 0, 0, 0 )           !* 3d recurrence:    Xk = (Zk - Sk Xk+1 ) / Tk 
    620620         pt_out(ji,jj,jpkm1) = pt_out(ji,jj,jpkm1) / zwt(ji,jj,jpkm1) 
    621621      END_2D 
    … …  
    659659      kstart =  1  + klev 
    660660      ! 
    661       DO_2D( 0, 0, 0, 0 ) 
     661      DO_2D( 0, 0, 0, 0 )                         !* 1st recurrence:   Tk = Dk - Ik Sk-1 / Tk-1 
    662662         zwt(ji,jj,kstart) = pD(ji,jj,kstart) 
    663663      END_2D 
    … …  
    666666      END_3D 
    667667      ! 
    668       DO_2D( 0, 0, 0, 0 ) 
     668      DO_2D( 0, 0, 0, 0 )                        !* 2nd recurrence:    Zk = Yk - Ik / Tk-1  Zk-1 
    669669         pt_out(ji,jj,kstart) = pRHS(ji,jj,kstart) 
    670670      END_2D 
    … …  
    673673      END_3D 
    674674 
    675       DO_2D( 0, 0, 0, 0 ) 
     675      DO_2D( 0, 0, 0, 0 )                       !* 3d recurrence:    Xk = (Zk - Sk Xk+1 ) / Tk 
    676676         pt_out(ji,jj,jpkm1) = pt_out(ji,jj,jpkm1) / zwt(ji,jj,jpkm1) 
    677677      END_2D 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/OCE/TRA/traadv_mus.F90

    r13295 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/TRA/traadv_qck.F90

    r13295 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/TRA/traadv_ubs.F90

    r13295 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/TRA/trabbl.F90

    r13295 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/TRA/traldf_iso.F90

    r13295 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/TRA/traldf_lap_blp.F90

    r13295 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/TRA/traldf_triad.F90

    r13295 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/TRA/tramle.F90

    r13295 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/TRA/tranpc.F90

    r13295 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/TRA/traqsr.F90

    r13295 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/TRA/trasbc.F90

    r13295 r13571  
    129129      END_2D 
    130130      IF( ln_linssh ) THEN                !* linear free surface   
    131          DO_2D( 0, 1, 0, 0 ) 
     131         DO_2D( 0, 1, 0, 0 )                    !==>> add concentration/dilution effect due to constant volume cell 
    132132            sbc_tsc(ji,jj,jp_tem) = sbc_tsc(ji,jj,jp_tem) + r1_rho0 * emp(ji,jj) * pts(ji,jj,1,jp_tem,Kmm) 
    133133            sbc_tsc(ji,jj,jp_sal) = sbc_tsc(ji,jj,jp_sal) + r1_rho0 * emp(ji,jj) * pts(ji,jj,1,jp_sal,Kmm) 
    134          END_2D 
     134         END_2D                                 !==>> output c./d. term 
    135135         IF( iom_use('emp_x_sst') )   CALL iom_put( "emp_x_sst", emp (:,:) * pts(:,:,1,jp_tem,Kmm) ) 
    136136         IF( iom_use('emp_x_sss') )   CALL iom_put( "emp_x_sss", emp (:,:) * pts(:,:,1,jp_sal,Kmm) ) 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/OCE/TRA/trazdf.F90

    r13295 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/TRA/zpshde.F90

    r13295 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/TRD/trddyn.F90

    r13295 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/TRD/trdglo.F90

    r13295 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/TRD/trdmxl.F90

    r13295 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/TRD/trdtra.F90

    r13295 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/TRD/trdvor.F90

    r13295 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/USR/usrdef_fmask.F90

    r13286 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/USR/usrdef_istate.F90

    r13295 r13571  
    5757      IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~   Ocean at rest, with an horizontally uniform T and S profiles' 
    5858      ! 
    59       pu  (:,:,:) = 0._wp        ! ocean at rest 
     59      pu  (:,:,:) = 0._wp           ! ocean at rest 
    6060      pv  (:,:,:) = 0._wp 
    6161      pssh(:,:)   = 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_r13296_HPC-07_mocavero_mpi3/src/OCE/ZDF/zdfddm.F90

    r13295 r13571  
    9494!!gm                            and many acces in memory 
    9595          
    96          DO_2D( 1, 1, 1, 1 ) 
     96         DO_2D( 1, 1, 1, 1 )           !==  R=zrau = (alpha / beta) (dk[t] / dk[s])  ==! 
    9797            zrw =   ( gdepw(ji,jj,jk  ,Kmm) - gdept(ji,jj,jk,Kmm) )   & 
    9898!!gm please, use e3w at Kmm below  
    … …  
    110110         END_2D 
    111111 
    112          DO_2D( 1, 1, 1, 1 ) 
     112         DO_2D( 1, 1, 1, 1 )           !==  indicators  ==! 
    113113            ! stability indicator: msks=1 if rn2>0; 0 elsewhere 
    114114            IF( rn2(ji,jj,jk) + 1.e-12  <= 0. ) THEN   ;   zmsks(ji,jj) = 0._wp 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/OCE/ZDF/zdfdrg.F90

    r13295 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/ZDF/zdfgls.F90

    r13295 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/ZDF/zdfiwm.F90

    r13295 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/ZDF/zdfmxl.F90

    r13295 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/ZDF/zdfosm.F90

    r13295 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/ZDF/zdfphy.F90

    r13226 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/ZDF/zdfric.F90

    r13295 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/ZDF/zdfsh2.F90

    r13295 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/ZDF/zdftke.F90

    r13295 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/lib_fortran.F90

    r13295 r13571  
    217217      IF( SIZE(p2d,2) /= jpj ) CALL ctl_stop( 'STOP', 'wrong call of sum3x3_2d, the second dimension is not equal to jpj' )  
    218218      ! 
    219       DO_2D( 1, 1, 1, 1 ) 
    220          IF( MOD(mig(ji), 3) == 1 .AND. MOD(mjg(jj), 3) == 1 ) THEN   ! bottom left corber of a 3x3 box 
     219      ! work over the whole domain (guarantees all internal cells are set when nn_hls=2) 
     220      ! 
     221      DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
     222         IF( MOD(mig(ji), 3) == MOD(nn_hls, 3) .AND.   & 
     223           & MOD(mjg(jj), 3) == MOD(nn_hls, 3)         ) THEN         ! bottom left corner of a 3x3 box 
    221224            ji2 = MIN(mig(ji)+2, jpiglo) - nimpp + 1                  ! right position of the box 
    222225            jj2 = MIN(mjg(jj)+2, jpjglo) - njmpp + 1                  ! upper position of the box 
    … …  
    227230      END_2D 
    228231      CALL lbc_lnk( 'lib_fortran', p2d, 'T', 1.0_wp ) 
    229       IF( nbondi /= -1 ) THEN 
    230          IF( MOD(mig(    1), 3) == 1 )   p2d(    1,:) = p2d(    2,:) 
    231          IF( MOD(mig(    1), 3) == 2 )   p2d(    2,:) = p2d(    1,:) 
     232      ! no need for 2nd exchange when nn_hls = 2 
     233      IF( nn_hls /= 2 ) THEN 
     234         IF( nbondi /= -1 ) THEN 
     235            IF( MOD(mig(    1), 3) == 1 )   p2d(    1,:) = p2d(    2,:) 
     236            IF( MOD(mig(    1), 3) == 2 )   p2d(    2,:) = p2d(    1,:) 
     237         ENDIF 
     238         IF( nbondi /=  1 ) THEN 
     239            IF( MOD(mig(jpi-2), 3) == 1 )   p2d(  jpi,:) = p2d(jpi-1,:) 
     240            IF( MOD(mig(jpi-2), 3) == 0 )   p2d(jpi-1,:) = p2d(  jpi,:) 
     241         ENDIF 
     242         IF( nbondj /= -1 ) THEN 
     243            IF( MOD(mjg(    1), 3) == 1 )   p2d(:,    1) = p2d(:,    2) 
     244            IF( MOD(mjg(    1), 3) == 2 )   p2d(:,    2) = p2d(:,    1) 
     245         ENDIF 
     246         IF( nbondj /=  1 ) THEN 
     247            IF( MOD(mjg(jpj-2), 3) == 1 )   p2d(:,  jpj) = p2d(:,jpj-1) 
     248            IF( MOD(mjg(jpj-2), 3) == 0 )   p2d(:,jpj-1) = p2d(:,  jpj) 
     249         ENDIF 
     250         CALL lbc_lnk( 'lib_fortran', p2d, 'T', 1.0_wp ) 
    232251      ENDIF 
    233       IF( nbondi /=  1 ) THEN 
    234          IF( MOD(mig(jpi-2), 3) == 1 )   p2d(  jpi,:) = p2d(jpi-1,:) 
    235          IF( MOD(mig(jpi-2), 3) == 0 )   p2d(jpi-1,:) = p2d(  jpi,:) 
    236       ENDIF 
    237       IF( nbondj /= -1 ) THEN 
    238          IF( MOD(mjg(    1), 3) == 1 )   p2d(:,    1) = p2d(:,    2) 
    239          IF( MOD(mjg(    1), 3) == 2 )   p2d(:,    2) = p2d(:,    1) 
    240       ENDIF 
    241       IF( nbondj /=  1 ) THEN 
    242          IF( MOD(mjg(jpj-2), 3) == 1 )   p2d(:,  jpj) = p2d(:,jpj-1) 
    243          IF( MOD(mjg(jpj-2), 3) == 0 )   p2d(:,jpj-1) = p2d(:,  jpj) 
    244       ENDIF 
    245       CALL lbc_lnk( 'lib_fortran', p2d, 'T', 1.0_wp ) 
    246252 
    247253   END SUBROUTINE sum3x3_2d 
    … …  
    264270      ! 
    265271      DO jn = 1, ipn 
    266          DO_2D( 1, 1, 1, 1 ) 
    267             IF( MOD(mig(ji), 3) == 1 .AND. MOD(mjg(jj), 3) == 1 ) THEN   ! bottom left corber of a 3x3 box 
     272         ! 
     273         ! work over the whole domain (guarantees all internal cells are set when nn_hls=2) 
     274         ! 
     275         DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
     276            IF( MOD(mig(ji), 3) == MOD(nn_hls, 3) .AND.   & 
     277              & MOD(mjg(jj), 3) == MOD(nn_hls, 3)         ) THEN         ! bottom left corner of a 3x3 box 
    268278               ji2 = MIN(mig(ji)+2, jpiglo) - nimpp + 1                  ! right position of the box 
    269279               jj2 = MIN(mjg(jj)+2, jpjglo) - njmpp + 1                  ! upper position of the box 
    … …  
    275285      END DO 
    276286      CALL lbc_lnk( 'lib_fortran', p3d, 'T', 1.0_wp ) 
    277       IF( nbondi /= -1 ) THEN 
    278          IF( MOD(mig(    1), 3) == 1 )   p3d(    1,:,:) = p3d(    2,:,:) 
    279          IF( MOD(mig(    1), 3) == 2 )   p3d(    2,:,:) = p3d(    1,:,:) 
     287      ! no need for 2nd exchange when nn_hls = 2 
     288      IF( nn_hls /= 2 ) THEN 
     289         IF( nbondi /= -1 ) THEN 
     290            IF( MOD(mig(    1), 3) == 1 )   p3d(    1,:,:) = p3d(    2,:,:) 
     291            IF( MOD(mig(    1), 3) == 2 )   p3d(    2,:,:) = p3d(    1,:,:) 
     292         ENDIF 
     293         IF( nbondi /=  1 ) THEN 
     294            IF( MOD(mig(jpi-2), 3) == 1 )   p3d(  jpi,:,:) = p3d(jpi-1,:,:) 
     295            IF( MOD(mig(jpi-2), 3) == 0 )   p3d(jpi-1,:,:) = p3d(  jpi,:,:) 
     296         ENDIF 
     297         IF( nbondj /= -1 ) THEN 
     298            IF( MOD(mjg(    1), 3) == 1 )   p3d(:,    1,:) = p3d(:,    2,:) 
     299            IF( MOD(mjg(    1), 3) == 2 )   p3d(:,    2,:) = p3d(:,    1,:) 
     300         ENDIF 
     301         IF( nbondj /=  1 ) THEN 
     302            IF( MOD(mjg(jpj-2), 3) == 1 )   p3d(:,  jpj,:) = p3d(:,jpj-1,:) 
     303            IF( MOD(mjg(jpj-2), 3) == 0 )   p3d(:,jpj-1,:) = p3d(:,  jpj,:) 
     304         ENDIF 
     305         CALL lbc_lnk( 'lib_fortran', p3d, 'T', 1.0_wp ) 
    280306      ENDIF 
    281       IF( nbondi /=  1 ) THEN 
    282          IF( MOD(mig(jpi-2), 3) == 1 )   p3d(  jpi,:,:) = p3d(jpi-1,:,:) 
    283          IF( MOD(mig(jpi-2), 3) == 0 )   p3d(jpi-1,:,:) = p3d(  jpi,:,:) 
    284       ENDIF 
    285       IF( nbondj /= -1 ) THEN 
    286          IF( MOD(mjg(    1), 3) == 1 )   p3d(:,    1,:) = p3d(:,    2,:) 
    287          IF( MOD(mjg(    1), 3) == 2 )   p3d(:,    2,:) = p3d(:,    1,:) 
    288       ENDIF 
    289       IF( nbondj /=  1 ) THEN 
    290          IF( MOD(mjg(jpj-2), 3) == 1 )   p3d(:,  jpj,:) = p3d(:,jpj-1,:) 
    291          IF( MOD(mjg(jpj-2), 3) == 0 )   p3d(:,jpj-1,:) = p3d(:,  jpj,:) 
    292       ENDIF 
    293       CALL lbc_lnk( 'lib_fortran', p3d, 'T', 1.0_wp ) 
    294307 
    295308   END SUBROUTINE sum3x3_3d 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/OCE/module_example

    r11536 r13571  
    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_r13296_HPC-07_mocavero_mpi3/src/OCE/nemogcm.F90

    r13286 r13571  
    5454   USE asminc         ! assimilation increments      
    5555   USE asmbkg         ! writing out state trajectory 
    56    USE diaptr         ! poleward transports           (dia_ptr_init routine) 
    5756   USE diadct         ! sections transports           (dia_dct_init routine) 
    5857   USE diaobs         ! Observation diagnostics       (dia_obs_init routine) 
    … …  
    472471      !                                         ! Lateral physics 
    473472                           CALL ldf_tra_init      ! Lateral ocean tracer physics 
    474                            CALL ldf_eiv_init      ! eddy induced velocity param. 
     473                           CALL ldf_eiv_init      ! eddy induced velocity param. must be done after ldf_tra_init 
    475474                           CALL ldf_dyn_init      ! Lateral ocean momentum physics 
    476475 
    … …  
    510509                           CALL     flo_init( Nnn )    ! drifting Floats 
    511510      IF( ln_diacfl    )   CALL dia_cfl_init    ! Initialise CFL diagnostics 
    512 !                           CALL dia_ptr_init    ! Poleward TRansports initialization 
    513511                           CALL dia_dct_init    ! Sections tranports 
    514512                           CALL dia_hsb_init( Nnn )    ! heat content, salt content and volume budgets 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/OCE/stpctl.F90

    r13216 r13571  
    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 
    … …  
    119118      !                                   !==            test of local extrema           ==! 
    120119      !                                   !==  done by all processes at every time step  ==! 
    121       llmsk(:,:,1) = ssmask(:,:) == 1._wp 
     120      ! 
     121      llmsk(   1:Nis1,:,:) = .FALSE.                                              ! exclude halos from the checked region 
     122      llmsk(Nie1: jpi,:,:) = .FALSE. 
     123      llmsk(:,   1:Njs1,:) = .FALSE. 
     124      llmsk(:,Nje1: jpj,:) = .FALSE. 
     125      ! 
     126      llmsk(Nis0:Nie0,Njs0:Nje0,1) = ssmask(Nis0:Nie0,Njs0:Nje0) == 1._wp         ! define only the inner domain 
    122127      IF( ll_wd ) THEN 
    123128         zmax(1) = MAXVAL( ABS( ssh(:,:,Kmm) + ssh_ref ), mask = llmsk(:,:,1) )   ! ssh max 
    … …  
    125130         zmax(1) = MAXVAL( ABS( ssh(:,:,Kmm)           ), mask = llmsk(:,:,1) )   ! ssh max 
    126131      ENDIF 
    127       llmsk(:,:,:) = umask(:,:,:) == 1._wp 
     132      llmsk(Nis0:Nie0,Njs0:Nje0,:) = umask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp        ! define only the inner domain 
    128133      zmax(2) = MAXVAL(  ABS( uu(:,:,:,Kmm) ), mask = llmsk )                     ! velocity max (zonal only) 
    129       llmsk(:,:,:) = tmask(:,:,:) == 1._wp 
     134      llmsk(Nis0:Nie0,Njs0:Nje0,:) = tmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp        ! define only the inner domain 
    130135      zmax(3) = MAXVAL( -ts(:,:,:,jp_sal,Kmm), mask = llmsk )                     ! minus salinity max 
    131136      zmax(4) = MAXVAL(  ts(:,:,:,jp_sal,Kmm), mask = llmsk )                     !       salinity max 
    … …  
    143148         zmax(5:8) = 0._wp 
    144149      ENDIF 
    145       zmax(9) = REAL( nstop, wp )                                              ! stop indicator 
     150      zmax(9) = REAL( nstop, wp )                                                 ! stop indicator 
    146151      !                                   !==               get global extrema             ==! 
    147152      !                                   !==  done by all processes if writting run.stat  ==! 
    … …  
    183188            IF( lwm .AND. kt /= nitend )   istatus = NF90_CLOSE(nrunid) 
    184189            ! get global loc on the min/max 
    185             CALL mpp_maxloc( 'stpctl', ABS(ssh(:,:,         Kmm)), ssmask(:,:  ), zzz, iloc(1:2,1) )   ! mpp_maxloc ok if mask = F  
    186             CALL mpp_maxloc( 'stpctl', ABS( uu(:,:,:,       Kmm)),  umask(:,:,:), zzz, iloc(1:3,2) ) 
    187             CALL mpp_minloc( 'stpctl',      ts(:,:,:,jp_sal,Kmm) ,  tmask(:,:,:), zzz, iloc(1:3,3) ) 
    188             CALL mpp_maxloc( 'stpctl',      ts(:,:,:,jp_sal,Kmm) ,  tmask(:,:,:), zzz, iloc(1:3,4) ) 
     190            llmsk(Nis0:Nie0,Njs0:Nje0,1) = ssmask(Nis0:Nie0,Njs0:Nje0 ) == 1._wp         ! define only the inner domain 
     191            CALL mpp_maxloc( 'stpctl', ABS(ssh(:,:,         Kmm)), llmsk(:,:,1), zzz, iloc(1:2,1) )   ! mpp_maxloc ok if mask = F  
     192            llmsk(Nis0:Nie0,Njs0:Nje0,:) = umask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp        ! define only the inner domain 
     193            CALL mpp_maxloc( 'stpctl', ABS( uu(:,:,:,       Kmm)), llmsk(:,:,:), zzz, iloc(1:3,2) ) 
     194            llmsk(Nis0:Nie0,Njs0:Nje0,:) = tmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp        ! define only the inner domain 
     195            CALL mpp_minloc( 'stpctl',      ts(:,:,:,jp_sal,Kmm) , llmsk(:,:,:), zzz, iloc(1:3,3) ) 
     196            CALL mpp_maxloc( 'stpctl',      ts(:,:,:,jp_sal,Kmm) , llmsk(:,:,:), zzz, iloc(1:3,4) ) 
    189197            ! find which subdomain has the max. 
    190198            iareamin(:) = jpnij+1   ;   iareamax(:) = 0   ;   iareasum(:) = 0 
    … …  
    199207         ELSE                    ! find local min and max locations: 
    200208            ! if we are here, this means that the subdomain contains some oce points -> no need to test the mask used in maxloc 
    201             iloc(1:2,1) = MAXLOC( ABS( ssh(:,:,         Kmm)), mask = ssmask(:,:  ) == 1._wp ) + (/ nimpp - 1, njmpp - 1    /) 
    202             iloc(1:3,2) = MAXLOC( ABS(  uu(:,:,:,       Kmm)), mask =  umask(:,:,:) == 1._wp ) + (/ nimpp - 1, njmpp - 1, 0 /) 
    203             iloc(1:3,3) = MINLOC(       ts(:,:,:,jp_sal,Kmm) , mask =  tmask(:,:,:) == 1._wp ) + (/ nimpp - 1, njmpp - 1, 0 /) 
    204             iloc(1:3,4) = MAXLOC(       ts(:,:,:,jp_sal,Kmm) , mask =  tmask(:,:,:) == 1._wp ) + (/ nimpp - 1, njmpp - 1, 0 /) 
     209            llmsk(Nis0:Nie0,Njs0:Nje0,1) = ssmask(Nis0:Nie0,Njs0:Nje0 ) == 1._wp        ! define only the inner domain 
     210            iloc(1:2,1) = MAXLOC( ABS( ssh(:,:,         Kmm)), mask = llmsk(:,:,1) ) 
     211            llmsk(Nis0:Nie0,Njs0:Nje0,:) = umask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp        ! define only the inner domain 
     212            iloc(1:3,2) = MAXLOC( ABS(  uu(:,:,:,       Kmm)), mask = llmsk(:,:,:) ) 
     213            llmsk(Nis0:Nie0,Njs0:Nje0,:) = tmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp        ! define only the inner domain 
     214            iloc(1:3,3) = MINLOC(       ts(:,:,:,jp_sal,Kmm) , mask = llmsk(:,:,:) ) 
     215            iloc(1:3,4) = MAXLOC(       ts(:,:,:,jp_sal,Kmm) , mask = llmsk(:,:,:) ) 
     216            DO ji = 1, 4   ! local domain indices ==> global domain indices, excluding halos 
     217               iloc(1:2,ji) = (/ mig0(iloc(1,ji)), mjg0(iloc(2,ji)) /) 
     218            END DO 
    205219            iareamin(:) = narea   ;   iareamax(:) = narea   ;   iareasum(:) = 1         ! this is local information 
    206220         ENDIF 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/OCE/timing.F90

    r12489 r13571  
    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 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/OFF/dtadyn.F90

    r13295 r13571  
    296296      sf_dyn(jf_uwd)%cltype = 'U'   ;   sf_dyn(jf_uwd)%zsgn = -1._wp   
    297297      sf_dyn(jf_vwd)%cltype = 'V'   ;   sf_dyn(jf_vwd)%zsgn = -1._wp   
    298       sf_dyn(jf_ubl)%cltype = 'U'   ;   sf_dyn(jf_ubl)%zsgn =  1._wp   
    299       sf_dyn(jf_vbl)%cltype = 'V'   ;   sf_dyn(jf_vbl)%zsgn =  1._wp   
     298      ! 
     299      IF( ln_trabbl ) THEN 
     300         sf_dyn(jf_ubl)%cltype = 'U'   ;   sf_dyn(jf_ubl)%zsgn =  1._wp   
     301         sf_dyn(jf_vbl)%cltype = 'V'   ;   sf_dyn(jf_vbl)%zsgn =  1._wp   
     302      END IF 
    300303      ! 
    301304      ! Open file for each variable to get his number of dimension 
    … …  
    409412            ENDIF 
    410413         END_2D 
    411 !!st pourquoi on n'utilise pas le gde3w ici plutôt que de faire une boucle ?  
    412          DO_2D( 1, 1, 1, 1 ) 
     414         DO_2D( 1, 1, 1, 1 )                           ! set the associated depth 
    413415            h_rnf(ji,jj) = 0._wp 
    414416            DO jk = 1, nk_rnf(ji,jj) 
    … …  
    685687      !!---------------------------------------------------------------------- 
    686688      ! 
    687 !!st code dupliqué même remarque que plus haut pourquoi ne pas utiliser gdepw ? 
    688       DO_2D( 1, 1, 1, 1 ) 
     689      DO_2D( 1, 1, 1, 1 )               ! update the depth over which runoffs are distributed 
    689690         h_rnf(ji,jj) = 0._wp 
    690691         DO jk = 1, nk_rnf(ji,jj)                           ! recalculates h_rnf to be the depth in metres 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/OFF/nemogcm.F90

    r13286 r13571  
    4040   USE sbcmod         ! surface boundary condition     (sbc_init     routine) 
    4141   USE phycst         ! physical constant                   (par_cst routine) 
     42   USE zdfphy         ! vertical physics manager       (zdf_phy_init routine) 
    4243   USE dtadyn         ! Lecture and Interpolation of the dynamical fields 
    4344   USE trcini         ! Initilization of the passive tracers 
    … …  
    4950   USE trcnam         ! passive tracer : namelist 
    5051   USE trcrst         ! passive tracer restart 
    51    USE diaptr         ! Need to initialise this as some variables are used in if statements later 
    5252   USE sbc_oce , ONLY : ln_rnf 
    5353   USE sbcrnf         ! surface boundary condition : runoffs 
    … …  
    7373 
    7474   CHARACTER (len=64) ::   cform_aaa="( /, 'AAAAAAAA', / ) "   ! flag for output listing 
     75#if defined key_mpp_mpi 
     76   ! need MPI_Wtime 
     77   INCLUDE 'mpif.h' 
     78#endif 
    7579 
    7680   !!---------------------------------------------------------------------- 
    … …  
    96100      !!---------------------------------------------------------------------- 
    97101      INTEGER :: istp       ! time step index 
     102      REAL(wp)::   zstptiming   ! elapsed time for 1 time step 
    98103      !!---------------------------------------------------------------------- 
    99104 
    … …  
    114119      !  
    115120      DO WHILE ( istp <= nitend .AND. nstop == 0 )    !==  OFF time-stepping  ==! 
     121 
     122         IF( ln_timing ) THEN 
     123            zstptiming = MPI_Wtime() 
     124            IF ( istp == ( nit000 + 1 ) ) elapsed_time = zstptiming 
     125            IF ( istp ==         nitend ) elapsed_time = zstptiming - elapsed_time 
     126         ENDIF 
    116127         ! 
    117128         IF( istp /= nit000 )   CALL day        ( istp )         ! Calendar (day was already called at nit000 in day_init) 
    … …  
    147158#endif 
    148159#endif          
    149                                 CALL stp_ctl    ( istp )             ! Time loop: control and print 
     160         CALL stp_ctl    ( istp )             ! Time loop: control and print 
    150161         istp = istp + 1 
     162 
     163         IF( lwp .AND. ln_timing )   WRITE(numtime,*) 'timing step ', istp-1, ' : ', MPI_Wtime() - zstptiming 
     164 
    151165      END DO 
    152166      ! 
    … …  
    333347 
    334348                           CALL     sbc_init( Nbb, Nnn, Naa )    ! Forcings : surface module 
    335                            CALL     bdy_init    ! Open boundaries initialisation     
     349                           CALL     bdy_init    ! Open boundaries initialisation 
     350                            
     351                           CALL zdf_phy_init( Nnn )    ! Vertical physics 
    336352 
    337353      !                                      ! Tracer physics 
    338354                           CALL ldf_tra_init    ! Lateral ocean tracer physics 
    339                            CALL ldf_eiv_init    ! Eddy induced velocity param 
     355                           CALL ldf_eiv_init    ! Eddy induced velocity param. must be done after ldf_tra_init 
    340356                           CALL tra_ldf_init    ! lateral mixing 
    341357      IF( l_ldfslp     )   CALL ldf_slp_init    ! slope of lateral mixing 
    … …  
    351367                           CALL dta_dyn_init( Nbb, Nnn, Naa )        ! Initialization for the dynamics 
    352368#endif 
    353  
    354369                           CALL     trc_init( Nbb, Nnn, Naa )        ! Passive tracers initialization 
    355                            CALL dia_ptr_init   ! Poleward TRansports initialization 
    356370                            
    357371      IF(lwp) WRITE(numout,cform_aaa)           ! Flag AAAAAAA 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/SAS/nemogcm.F90

    r13286 r13571  
    22   !!====================================================================== 
    33   !!                       ***  MODULE nemogcm   *** 
    4    !! StandAlone Surface module : surface fluxes + sea-ice + iceberg floats 
     4   !! StandAlone Surface module : surface fluxes + sea-ice + iceberg floats + ABL 
    55   !!====================================================================== 
    66   !! History :  3.6  ! 2011-11  (S. Alderson, G. Madec) original code 
    … …  
    5858 
    5959#if defined key_mpp_mpi 
     60   ! need MPI_Wtime 
    6061   INCLUDE 'mpif.h' 
    6162#endif 
    … …  
    8384      !!---------------------------------------------------------------------- 
    8485      INTEGER ::   istp   ! time step index 
     86      REAL(wp)::   zstptiming   ! elapsed time for 1 time step 
    8587      !!---------------------------------------------------------------------- 
    8688      ! 
    … …  
    9395#if defined key_agrif 
    9496      Kbb_a = Nbb; Kmm_a = Nnn; Krhs_a = Nrhs   ! agrif_oce module copies of time level indices 
    95       CALL Agrif_Declare_Var       !  "      "   "   "      "  DYN/TRA  
     97      CALL Agrif_Declare_Var       !  "      "   "   "      "  DYN/TRA 
    9698# if defined key_top 
    9799      CALL Agrif_Declare_Var_top   !  "      "   "   "      "  TOP 
    … …  
    107109      !                            !==   time stepping   ==! 
    108110      !                            !-----------------------! 
     111      ! 
     112      !                                               !== set the model time-step  ==! 
     113      ! 
    109114      istp = nit000 
    110115      ! 
    … …  
    124129      END DO 
    125130      ! 
    126 #else 
     131# else 
    127132      ! 
    128133      IF( .NOT.ln_diurnal_only ) THEN                 !==  Standard time-stepping  ==! 
    129134         ! 
    130135         DO WHILE( istp <= nitend .AND. nstop == 0 ) 
    131 #if defined key_mpp_mpi 
     136 
    132137            ncom_stp = istp 
    133             IF ( istp == ( nit000 + 1 ) ) elapsed_time = MPI_Wtime() 
    134             IF ( istp ==         nitend ) elapsed_time = MPI_Wtime() - elapsed_time 
    135 #endif 
     138            IF( ln_timing ) THEN 
     139               zstptiming = MPI_Wtime() 
     140               IF ( istp == ( nit000 + 1 ) ) elapsed_time = zstptiming 
     141               IF ( istp ==         nitend ) elapsed_time = zstptiming - elapsed_time 
     142            ENDIF 
     143             
    136144            CALL stp        ( istp )  
    137145            istp = istp + 1 
     146 
     147            IF( lwp .AND. ln_timing )   WRITE(numtime,*) 'timing step ', istp-1, ' : ', MPI_Wtime() - zstptiming 
     148 
    138149         END DO 
    139150         ! 
    … …  
    305316         WRITE(numout,*) "       )  )       \) |`\ \)  '.   \      (   (   " 
    306317         WRITE(numout,*) "      (  (           \_/       '-._\      )   )  " 
    307          WRITE(numout,*) "       )  ) jgs                    `     (   (   " 
     318         WRITE(numout,*) "       )  ) jgs                     `    (   (   " 
    308319         WRITE(numout,*) "     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ " 
    309320         WRITE(numout,*) 
    … …  
    355366      ! 
    356367      !                                      ! General initialization 
    357       IF( ln_timing    )   CALL timing_init     ! timing 
     368      IF( ln_timing    )   CALL timing_init ( 'timing_sas.output' ) 
    358369      IF( ln_timing    )   CALL timing_start( 'nemo_init') 
    359370 
    … …  
    367378         &                 CALL prt_ctl_init        ! Print control 
    368379       
     380      IF( ln_rstart )      CALL rst_read_open 
    369381                           CALL day_init        ! model calendar (using both namelist and restart infos) 
    370       IF( ln_rstart )      CALL rst_read_open 
    371  
     382 
     383#if defined key_agrif 
     384      uu(:,:,:,:) = 0.0_wp   ;   vv(:,:,:,:) = 0.0_wp   ;   ts(:,:,:,:,:) = 0.0_wp   ! needed for interp done at initialization phase 
     385#endif  
    372386      !                                      ! external forcing  
    373387                           CALL sbc_init( Nbb, Nnn, Naa )  ! Forcings : surface module  
    … …  
    480494      ierr =        dia_wri_alloc() 
    481495      ierr = ierr + dom_oce_alloc()          ! ocean domain 
    482       ierr = ierr + oce_alloc    ()          ! (tsn...) needed for agrif and/or SI3 and bdy 
     496      ierr = ierr + oce_alloc    ()          ! (ts...) needed for agrif and/or SI3 and bdy 
    483497      ierr = ierr + bdy_oce_alloc()          ! bdy masks (incl. initialization) 
    484498      ! 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/SAS/stpctl.F90

    r13136 r13571  
    2020   USE dom_oce         ! ocean space and time domain variables  
    2121   USE ice      , ONLY : vt_i, u_ice, tm_i 
     22   USE phycst   , ONLY : rt0 
     23   USE sbc_oce  , ONLY : lk_oasis 
    2224   ! 
    2325   USE diawri          ! Standard run outputs       (dia_wri_state routine) 
    … …  
    4850      !! 
    4951      !! ** Method  : - Save the time step in numstp 
    50       !!              - Print it each 50 time steps 
    5152      !!              - Stop the run IF problem encountered by setting nstop > 0 
    5253      !!                Problems checked: ice thickness maximum > 100 m 
    … …  
    8586         ENDIF 
    8687         !                                ! open time.step    ascii file, done only by 1st subdomain 
    87          IF( lwm )   CALL ctl_opn( numstp, 'time.step', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea ) 
     88         IF( lk_oasis ) THEN   ;   clname = 'time_sas.step' 
     89         ELSE                  ;   clname = 'time.step' 
     90         ENDIF 
     91         IF( lwm )   CALL ctl_opn( numstp, clname, 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea ) 
    8892         ! 
    8993         IF( ll_wrtruns ) THEN 
     94            IF( lk_oasis ) THEN   ;   clname = 'run_sas.stat' 
     95            ELSE                  ;   clname = 'run.stat' 
     96            ENDIF 
    9097            !                             ! open run.stat     ascii file, done only by 1st subdomain 
    91             CALL ctl_opn( numrun, 'run.stat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea ) 
     98            CALL ctl_opn( numrun, clname, 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea ) 
    9299            !                             ! open run.stat.nc netcdf file, done only by 1st subdomain 
    93             clname = 'run.stat.nc' 
     100            clname = TRIM(clname)//'.nc' 
    94101            IF( .NOT. Agrif_Root() )   clname = TRIM(Agrif_CFixed())//"_"//TRIM(clname) 
    95102            istatus = NF90_CREATE( TRIM(clname), NF90_CLOBBER, nrunid ) 
    … …  
    111118      !                                   !==            test of local extrema           ==! 
    112119      !                                   !==  done by all processes at every time step  ==! 
    113       llmsk(:,:) = tmask(:,:,1) == 1._wp 
     120      ! 
     121      llmsk(   1:Nis1,:) = .FALSE.                                              ! exclude halos from the checked region 
     122      llmsk(Nie1: jpi,:) = .FALSE. 
     123      llmsk(:,   1:Njs1) = .FALSE. 
     124      llmsk(:,Nje1: jpj) = .FALSE. 
     125      ! 
     126      llmsk(Nis0:Nie0,Njs0:Nje0) = tmask(Nis0:Nie0,Njs0:Nje0,1) == 1._wp   ! test only the inner domain 
    114127      IF( COUNT( llmsk(:,:) ) > 0 ) THEN   ! avoid huge values sent back for land processors... 
    115          zmax(1) = MAXVAL(      vt_i (:,:)            , mask = llmsk )   ! max ice thickness 
    116          zmax(2) = MAXVAL( ABS( u_ice(:,:) )          , mask = llmsk )   ! max ice velocity (zonal only) 
    117          zmax(3) = MAXVAL(     -tm_i (:,:) + 273.15_wp, mask = llmsk )   ! min ice temperature 
     128         zmax(1) = MAXVAL(      vt_i (:,:)      , mask = llmsk )   ! max ice thickness 
     129         zmax(2) = MAXVAL( ABS( u_ice(:,:) )    , mask = llmsk )   ! max ice velocity (zonal only) 
     130         zmax(3) = MAXVAL(     -tm_i (:,:) + rt0, mask = llmsk )   ! min ice temperature (in degC) 
    118131      ELSE 
    119132         IF( ll_colruns ) THEN    ! default value: must not be kept when calling mpp_max -> must be as small as possible 
    … …  
    154167            IF( lwm .AND. kt /= nitend )   istatus = NF90_CLOSE(nrunid) 
    155168            ! get global loc on the min/max 
    156             CALL mpp_maxloc( 'stpctl',      vt_i(:,:)            , tmask(:,:,1), zzz, iloc(1:2,1) )   ! mpp_maxloc ok if mask = F  
    157             CALL mpp_maxloc( 'stpctl',ABS( u_ice(:,:) )          , tmask(:,:,1), zzz, iloc(1:2,2) ) 
    158             CALL mpp_minloc( 'stpctl',      tm_i(:,:) - 273.15_wp, tmask(:,:,1), zzz, iloc(1:2,3) ) 
     169            CALL mpp_maxloc( 'stpctl',      vt_i(:,:)      , llmsk, zzz, iloc(1:2,1) )   ! mpp_maxloc ok if mask = F  
     170            CALL mpp_maxloc( 'stpctl',ABS( u_ice(:,:) )    , llmsk, zzz, iloc(1:2,2) ) 
     171            CALL mpp_minloc( 'stpctl',      tm_i(:,:) - rt0, llmsk, zzz, iloc(1:2,3) ) 
    159172            ! find which subdomain has the max. 
    160173            iareamin(:) = jpnij+1   ;   iareamax(:) = 0   ;   iareasum(:) = 0 
    … …  
    169182         ELSE                    ! find local min and max locations: 
    170183            ! if we are here, this means that the subdomain contains some oce points -> no need to test the mask used in maxloc 
    171             iloc(1:2,1) = MAXLOC(       vt_i(:,:)            , mask = llmsk ) + (/ nimpp - 1, njmpp - 1/) 
    172             iloc(1:2,2) = MAXLOC( ABS( u_ice(:,:) )          , mask = llmsk ) + (/ nimpp - 1, njmpp - 1/) 
    173             iloc(1:2,3) = MINLOC(       tm_i(:,:) - 273.15_wp, mask = llmsk ) + (/ nimpp - 1, njmpp - 1/) 
     184            iloc(1:2,1) = MAXLOC(       vt_i(:,:)      , mask = llmsk ) 
     185            iloc(1:2,2) = MAXLOC( ABS( u_ice(:,:) )    , mask = llmsk ) 
     186            iloc(1:2,3) = MINLOC(       tm_i(:,:) - rt0, mask = llmsk ) 
     187            DO ji = 1, 3   ! local domain indices ==> global domain indices, excluding halos 
     188               iloc(1:2,ji) = (/ mig0(iloc(1,ji)), mjg0(iloc(2,ji)) /) 
     189            END DO 
    174190            iareamin(:) = narea   ;   iareamax(:) = narea   ;   iareasum(:) = 1         ! this is local information 
    175191         ENDIF 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/SWE/asminc.F90

    r13295 r13571  
    362362 
    363363         IF ( ln_trainc ) THEN    
    364             CALL iom_get( inum, jpdom_autoglo, 'bckint', t_bkginc, 1 ) 
    365             CALL iom_get( inum, jpdom_autoglo, 'bckins', s_bkginc, 1 ) 
     364            CALL iom_get( inum, jpdom_auto, 'bckint', t_bkginc, 1 ) 
     365            CALL iom_get( inum, jpdom_auto, 'bckins', s_bkginc, 1 ) 
    366366            ! Apply the masks 
    367367            t_bkginc(:,:,:) = t_bkginc(:,:,:) * tmask(:,:,:) 
    … …  
    374374 
    375375         IF ( ln_dyninc ) THEN    
    376             CALL iom_get( inum, jpdom_autoglo, 'bckinu', u_bkginc, 1 )               
    377             CALL iom_get( inum, jpdom_autoglo, 'bckinv', v_bkginc, 1 )               
     376            CALL iom_get( inum, jpdom_auto, 'bckinu', u_bkginc, 1 )               
     377            CALL iom_get( inum, jpdom_auto, 'bckinv', v_bkginc, 1 )               
    378378            ! Apply the masks 
    379379            u_bkginc(:,:,:) = u_bkginc(:,:,:) * umask(:,:,:) 
    … …  
    386386         
    387387         IF ( ln_sshinc ) THEN 
    388             CALL iom_get( inum, jpdom_autoglo, 'bckineta', ssh_bkginc, 1 ) 
     388            CALL iom_get( inum, jpdom_auto, 'bckineta', ssh_bkginc, 1 ) 
    389389            ! Apply the masks 
    390390            ssh_bkginc(:,:) = ssh_bkginc(:,:) * tmask(:,:,1) 
    … …  
    395395 
    396396         IF ( ln_seaiceinc ) THEN 
    397             CALL iom_get( inum, jpdom_autoglo, 'bckinseaice', seaice_bkginc, 1 ) 
     397            CALL iom_get( inum, jpdom_auto, 'bckinseaice', seaice_bkginc, 1 ) 
    398398            ! Apply the masks 
    399399            seaice_bkginc(:,:) = seaice_bkginc(:,:) * tmask(:,:,1) 
    … …  
    469469         ! 
    470470         IF ( ln_trainc ) THEN    
    471             CALL iom_get( inum, jpdom_autoglo, 'tn', t_bkg ) 
    472             CALL iom_get( inum, jpdom_autoglo, 'sn', s_bkg ) 
     471            CALL iom_get( inum, jpdom_auto, 'tn', t_bkg ) 
     472            CALL iom_get( inum, jpdom_auto, 'sn', s_bkg ) 
    473473            t_bkg(:,:,:) = t_bkg(:,:,:) * tmask(:,:,:) 
    474474            s_bkg(:,:,:) = s_bkg(:,:,:) * tmask(:,:,:) 
    … …  
    476476         ! 
    477477         IF ( ln_dyninc ) THEN    
    478             CALL iom_get( inum, jpdom_autoglo, 'un', u_bkg ) 
    479             CALL iom_get( inum, jpdom_autoglo, 'vn', v_bkg ) 
     478            CALL iom_get( inum, jpdom_auto, 'un', u_bkg ) 
     479            CALL iom_get( inum, jpdom_auto, 'vn', v_bkg ) 
    480480            u_bkg(:,:,:) = u_bkg(:,:,:) * umask(:,:,:) 
    481481            v_bkg(:,:,:) = v_bkg(:,:,:) * vmask(:,:,:) 
    … …  
    483483         ! 
    484484         IF ( ln_sshinc ) THEN 
    485             CALL iom_get( inum, jpdom_autoglo, 'sshn', ssh_bkg ) 
     485            CALL iom_get( inum, jpdom_auto, 'sshn', ssh_bkg ) 
    486486            ssh_bkg(:,:) = ssh_bkg(:,:) * tmask(:,:,1) 
    487487         ENDIF 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/SWE/domain.F90

    r13295 r13571  
    245245      IF( lk_c1d         )   CALL cor_c1d       ! 1D configuration: Coriolis set at T-point 
    246246      ! 
     247 
     248#if defined key_agrif 
     249      IF( .NOT. Agrif_Root() ) CALL Agrif_Init_Domain( Kbb, Kmm, Kaa ) 
     250#endif 
    247251      IF( ln_meshmask    )   CALL dom_wri       ! Create a domain file 
    248  
    249252      IF( .NOT.ln_rstart )   CALL dom_ctl       ! Domain control 
    250253      ! 
    … …  
    269272      !! ** Method  :    
    270273      !! 
    271       !! ** Action  : - mig , mjg : local  domain indices ==> global domain indices 
     274      !! ** Action  : - mig , mjg : local  domain indices ==> global domain, including halos, indices 
     275      !!              - mig0, mjg0: local  domain indices ==> global domain, excluding halos, indices 
    272276      !!              - mi0 , mi1 : global domain indices ==> local  domain indices 
    273       !!              - mj0,, mj1   (global point not in the local domain ==> mi0>mi1 and/or mj0>mj1) 
     277      !!              - mj0 , mj1   (if global point not in the local domain ==> mi0>mi1 and/or mj0>mj1) 
    274278      !!---------------------------------------------------------------------- 
    275279      INTEGER ::   ji, jj   ! dummy loop argument 
    276280      !!---------------------------------------------------------------------- 
    277281      ! 
    278       DO ji = 1, jpi                 ! local domain indices ==> global domain indices 
     282      DO ji = 1, jpi                 ! local domain indices ==> global domain indices, including halos 
    279283        mig(ji) = ji + nimpp - 1 
    280284      END DO 
    … …  
    282286        mjg(jj) = jj + njmpp - 1 
    283287      END DO 
    284       !                              ! global domain indices ==> local domain indices 
     288      !                              ! local domain indices ==> global domain indices, excluding halos 
     289      ! 
     290      mig0(:) = mig(:) - nn_hls 
     291      mjg0(:) = mjg(:) - nn_hls   
     292      ! WARNING: to keep compatibility with the trunk that was including periodocity into the input data,  
     293      ! we must define mig0 and mjg0 as bellow. 
     294      ! Once we decide to forget trunk compatibility, we must simply define mig0 and mjg0 as: 
     295      mig0_oldcmp(:) = mig0(:) + COUNT( (/ jperio == 1 .OR. jperio == 4 .OR. jperio == 6 .OR. jperio == 7 /) ) 
     296      mjg0_oldcmp(:) = mjg0(:) + COUNT( (/ jperio == 2 .OR. jperio == 7 /) ) 
     297      ! 
     298      !                              ! global domain, including halos, indices ==> local domain indices 
    285299      !                                   ! (return (m.0,m.1)=(1,0) if data domain gridpoint is to the west/south of the  
    286300      !                                   ! local domain, or (m.0,m.1)=(jp.+1,jp.) to the east/north of local domain.  
    … …  
    300314         WRITE(numout,*) '   local  domain:   jpi    = ', jpi   , ' jpj    = ', jpj   , ' jpk    = ', jpk 
    301315         WRITE(numout,*) 
    302          WRITE(numout,*) '   conversion from local to global domain indices (and vise versa) done' 
    303          IF( nn_print >= 1 ) THEN 
    304             WRITE(numout,*) 
    305             WRITE(numout,*) '          conversion local  ==> global i-index domain (mig)' 
    306             WRITE(numout,25)              (mig(ji),ji = 1,jpi) 
    307             WRITE(numout,*) 
    308             WRITE(numout,*) '          conversion global ==> local  i-index domain' 
    309             WRITE(numout,*) '             starting index (mi0)' 
    310             WRITE(numout,25)              (mi0(ji),ji = 1,jpiglo) 
    311             WRITE(numout,*) '             ending index (mi1)' 
    312             WRITE(numout,25)              (mi1(ji),ji = 1,jpiglo) 
    313             WRITE(numout,*) 
    314             WRITE(numout,*) '          conversion local  ==> global j-index domain (mjg)' 
    315             WRITE(numout,25)              (mjg(jj),jj = 1,jpj) 
    316             WRITE(numout,*) 
    317             WRITE(numout,*) '          conversion global ==> local  j-index domain' 
    318             WRITE(numout,*) '             starting index (mj0)' 
    319             WRITE(numout,25)              (mj0(jj),jj = 1,jpjglo) 
    320             WRITE(numout,*) '             ending index (mj1)' 
    321             WRITE(numout,25)              (mj1(jj),jj = 1,jpjglo) 
    322          ENDIF 
    323       ENDIF 
    324  25   FORMAT( 100(10x,19i4,/) ) 
     316      ENDIF 
    325317      ! 
    326318   END SUBROUTINE dom_glo 
    … …  
    364356902   IF( ios >  0 )   CALL ctl_nam ( ios , 'namrun in configuration namelist' ) 
    365357      IF(lwm) WRITE ( numond, namrun ) 
     358 
     359#if defined key_agrif 
     360      IF( .NOT. Agrif_Root() ) THEN 
     361            nn_it000 = (Agrif_Parent(nn_it000)-1)*Agrif_IRhot() + 1 
     362            nn_itend =  Agrif_Parent(nn_itend)   *Agrif_IRhot() 
     363      ENDIF 
     364#endif 
    366365      ! 
    367366      IF(lwp) THEN                  ! control print 
    … …  
    435434#endif 
    436435 
    437 #if defined key_agrif 
    438436      IF( Agrif_Root() ) THEN 
    439 #endif 
    440       IF(lwp) WRITE(numout,*) 
    441       SELECT CASE ( nleapy )        ! Choose calendar for IOIPSL 
    442       CASE (  1 )  
    443          CALL ioconf_calendar('gregorian') 
    444          IF(lwp) WRITE(numout,*) '   ==>>>   The IOIPSL calendar is "gregorian", i.e. leap year' 
    445       CASE (  0 ) 
    446          CALL ioconf_calendar('noleap') 
    447          IF(lwp) WRITE(numout,*) '   ==>>>   The IOIPSL calendar is "noleap", i.e. no leap year' 
    448       CASE ( 30 ) 
    449          CALL ioconf_calendar('360d') 
    450          IF(lwp) WRITE(numout,*) '   ==>>>   The IOIPSL calendar is "360d", i.e. 360 days in a year' 
    451       END SELECT 
    452 #if defined key_agrif 
    453       ENDIF 
    454 #endif 
     437         IF(lwp) WRITE(numout,*) 
     438         SELECT CASE ( nleapy )        ! Choose calendar for IOIPSL 
     439         CASE (  1 )  
     440            CALL ioconf_calendar('gregorian') 
     441            IF(lwp) WRITE(numout,*) '   ==>>>   The IOIPSL calendar is "gregorian", i.e. leap year' 
     442         CASE (  0 ) 
     443            CALL ioconf_calendar('noleap') 
     444            IF(lwp) WRITE(numout,*) '   ==>>>   The IOIPSL calendar is "noleap", i.e. no leap year' 
     445         CASE ( 30 ) 
     446            CALL ioconf_calendar('360d') 
     447            IF(lwp) WRITE(numout,*) '   ==>>>   The IOIPSL calendar is "360d", i.e. 360 days in a year' 
     448         END SELECT 
     449      ENDIF 
    455450 
    456451      READ  ( numnam_ref, namdom, IOSTAT = ios, ERR = 903) 
    … …  
    459454904   IF( ios >  0 )   CALL ctl_nam ( ios , 'namdom in configuration namelist' ) 
    460455      IF(lwm) WRITE( numond, namdom ) 
     456      ! 
     457#if defined key_agrif 
     458      IF( .NOT. Agrif_Root() ) THEN 
     459            rn_Dt = Agrif_Parent(rn_Dt) / Agrif_Rhot() 
     460      ENDIF 
     461#endif 
    461462      ! 
    462463      IF(lwp) THEN 
    … …  
    519520      !! ** Method  :   compute and print extrema of masked scale factors 
    520521      !!---------------------------------------------------------------------- 
    521       INTEGER, DIMENSION(2) ::   imi1, imi2, ima1, ima2 
    522       INTEGER, DIMENSION(2) ::   iloc   !  
    523       REAL(wp) ::   ze1min, ze1max, ze2min, ze2max 
    524       !!---------------------------------------------------------------------- 
    525       ! 
    526       IF(lk_mpp) THEN 
    527          CALL mpp_minloc( 'domain', e1t(:,:), tmask_i(:,:), ze1min, imi1 ) 
    528          CALL mpp_minloc( 'domain', e2t(:,:), tmask_i(:,:), ze2min, imi2 ) 
    529          CALL mpp_maxloc( 'domain', e1t(:,:), tmask_i(:,:), ze1max, ima1 ) 
    530          CALL mpp_maxloc( 'domain', e2t(:,:), tmask_i(:,:), ze2max, ima2 ) 
    531       ELSE 
    532          ze1min = MINVAL( e1t(:,:), mask = tmask_i(:,:) == 1._wp )     
    533          ze2min = MINVAL( e2t(:,:), mask = tmask_i(:,:) == 1._wp )     
    534          ze1max = MAXVAL( e1t(:,:), mask = tmask_i(:,:) == 1._wp )     
    535          ze2max = MAXVAL( e2t(:,:), mask = tmask_i(:,:) == 1._wp )     
    536          ! 
    537          iloc  = MINLOC( e1t(:,:), mask = tmask_i(:,:) == 1._wp ) 
    538          imi1(1) = iloc(1) + nimpp - 1 
    539          imi1(2) = iloc(2) + njmpp - 1 
    540          iloc  = MINLOC( e2t(:,:), mask = tmask_i(:,:) == 1._wp ) 
    541          imi2(1) = iloc(1) + nimpp - 1 
    542          imi2(2) = iloc(2) + njmpp - 1 
    543          iloc  = MAXLOC( e1t(:,:), mask = tmask_i(:,:) == 1._wp ) 
    544          ima1(1) = iloc(1) + nimpp - 1 
    545          ima1(2) = iloc(2) + njmpp - 1 
    546          iloc  = MAXLOC( e2t(:,:), mask = tmask_i(:,:) == 1._wp ) 
    547          ima2(1) = iloc(1) + nimpp - 1 
    548          ima2(2) = iloc(2) + njmpp - 1 
    549       ENDIF 
     522      LOGICAL, DIMENSION(jpi,jpj) ::   llmsk 
     523      INTEGER, DIMENSION(2)       ::   imil, imip, imi1, imi2, imal, imap, ima1, ima2 
     524      REAL(wp)                    ::   zglmin, zglmax, zgpmin, zgpmax, ze1min, ze1max, ze2min, ze2max 
     525      !!---------------------------------------------------------------------- 
     526      ! 
     527      llmsk = tmask_h(:,:) == 1._wp 
     528      ! 
     529      CALL mpp_minloc( 'domain', glamt(:,:), llmsk, zglmin, imil ) 
     530      CALL mpp_minloc( 'domain', gphit(:,:), llmsk, zgpmin, imip ) 
     531      CALL mpp_minloc( 'domain',   e1t(:,:), llmsk, ze1min, imi1 ) 
     532      CALL mpp_minloc( 'domain',   e2t(:,:), llmsk, ze2min, imi2 ) 
     533      CALL mpp_maxloc( 'domain', glamt(:,:), llmsk, zglmax, imal ) 
     534      CALL mpp_maxloc( 'domain', gphit(:,:), llmsk, zgpmax, imap ) 
     535      CALL mpp_maxloc( 'domain',   e1t(:,:), llmsk, ze1max, ima1 ) 
     536      CALL mpp_maxloc( 'domain',   e2t(:,:), llmsk, ze2max, ima2 ) 
     537      ! 
    550538      IF(lwp) THEN 
    551539         WRITE(numout,*) 
    552540         WRITE(numout,*) 'dom_ctl : extrema of the masked scale factors' 
    553541         WRITE(numout,*) '~~~~~~~' 
    554          WRITE(numout,"(14x,'e1t maxi: ',1f10.2,' at i = ',i5,' j= ',i5)") ze1max, ima1(1), ima1(2) 
    555          WRITE(numout,"(14x,'e1t mini: ',1f10.2,' at i = ',i5,' j= ',i5)") ze1min, imi1(1), imi1(2) 
    556          WRITE(numout,"(14x,'e2t maxi: ',1f10.2,' at i = ',i5,' j= ',i5)") ze2max, ima2(1), ima2(2) 
    557          WRITE(numout,"(14x,'e2t mini: ',1f10.2,' at i = ',i5,' j= ',i5)") ze2min, imi2(1), imi2(2) 
     542         WRITE(numout,"(14x,'glamt mini: ',1f10.2,' at i = ',i5,' j= ',i5)") zglmin, imil(1), imil(2) 
     543         WRITE(numout,"(14x,'glamt maxi: ',1f10.2,' at i = ',i5,' j= ',i5)") zglmax, imal(1), imal(2) 
     544         WRITE(numout,"(14x,'gphit mini: ',1f10.2,' at i = ',i5,' j= ',i5)") zgpmin, imip(1), imip(2) 
     545         WRITE(numout,"(14x,'gphit maxi: ',1f10.2,' at i = ',i5,' j= ',i5)") zgpmax, imap(1), imap(2) 
     546         WRITE(numout,"(14x,'  e1t mini: ',1f10.2,' at i = ',i5,' j= ',i5)") ze1min, imi1(1), imi1(2) 
     547         WRITE(numout,"(14x,'  e1t maxi: ',1f10.2,' at i = ',i5,' j= ',i5)") ze1max, ima1(1), ima1(2) 
     548         WRITE(numout,"(14x,'  e2t mini: ',1f10.2,' at i = ',i5,' j= ',i5)") ze2min, imi2(1), imi2(2) 
     549         WRITE(numout,"(14x,'  e2t maxi: ',1f10.2,' at i = ',i5,' j= ',i5)") ze2max, ima2(1), ima2(2) 
    558550      ENDIF 
    559551      ! 
    … …  
    622614      IF(lwp) THEN 
    623615         WRITE(numout,*) '      cn_cfg = ', TRIM(cd_cfg), '   nn_cfg = ', kk_cfg 
    624          WRITE(numout,*) '      jpiglo = ', kpi 
    625          WRITE(numout,*) '      jpjglo = ', kpj 
     616         WRITE(numout,*) '      Ni0glo = ', kpi 
     617         WRITE(numout,*) '      Nj0glo = ', kpj 
    626618         WRITE(numout,*) '      jpkglo = ', kpk 
    627619         WRITE(numout,*) '      type of global domain lateral boundary   jperio = ', kperio 
    … …  
    662654      !          
    663655      clnam = cn_domcfg_out  ! filename (configuration information) 
    664       CALL iom_open( TRIM(clnam), inum, ldwrt = .TRUE. ) 
    665        
     656      CALL iom_open( TRIM(clnam), inum, ldwrt = .TRUE. )      
    666657      ! 
    667658      !                             !==  ORCA family specificities  ==! 
    668       IF( cn_cfg == "ORCA" ) THEN 
     659      IF( TRIM(cn_cfg) == "orca" .OR. TRIM(cn_cfg) == "ORCA" ) THEN 
    669660         CALL iom_rstput( 0, 0, inum, 'ORCA'      , 1._wp            , ktype = jp_i4 ) 
    670661         CALL iom_rstput( 0, 0, inum, 'ORCA_index', REAL( nn_cfg, wp), ktype = jp_i4 )          
    671662      ENDIF 
    672663      ! 
    673       !                             !==  global domain size  ==! 
    674       ! 
    675       CALL iom_rstput( 0, 0, inum, 'jpiglo', REAL( jpiglo, wp), ktype = jp_i4 ) 
    676       CALL iom_rstput( 0, 0, inum, 'jpjglo', REAL( jpjglo, wp), ktype = jp_i4 ) 
    677       CALL iom_rstput( 0, 0, inum, 'jpkglo', REAL( jpk   , wp), ktype = jp_i4 ) 
    678       ! 
    679664      !                             !==  domain characteristics  ==! 
    680665      ! 
    … …  
    683668      ! 
    684669      !                                   ! type of vertical coordinate 
    685       IF( ln_zco    ) THEN   ;   izco = 1   ;   ELSE   ;   izco = 0   ;   ENDIF 
    686       IF( ln_zps    ) THEN   ;   izps = 1   ;   ELSE   ;   izps = 0   ;   ENDIF 
    687       IF( ln_sco    ) THEN   ;   isco = 1   ;   ELSE   ;   isco = 0   ;   ENDIF 
    688       CALL iom_rstput( 0, 0, inum, 'ln_zco'   , REAL( izco, wp), ktype = jp_i4 ) 
    689       CALL iom_rstput( 0, 0, inum, 'ln_zps'   , REAL( izps, wp), ktype = jp_i4 ) 
    690       CALL iom_rstput( 0, 0, inum, 'ln_sco'   , REAL( isco, wp), ktype = jp_i4 ) 
     670      CALL iom_rstput( 0, 0, inum, 'ln_zco', REAL(COUNT((/ln_zco/)), wp), ktype = jp_i4 ) 
     671      CALL iom_rstput( 0, 0, inum, 'ln_zps', REAL(COUNT((/ln_zps/)), wp), ktype = jp_i4 ) 
     672      CALL iom_rstput( 0, 0, inum, 'ln_sco', REAL(COUNT((/ln_sco/)), wp), ktype = jp_i4 ) 
    691673      ! 
    692674      !                                   ! ocean cavities under iceshelves 
    693       IF( ln_isfcav ) THEN   ;   icav = 1   ;   ELSE   ;   icav = 0   ;   ENDIF 
    694       CALL iom_rstput( 0, 0, inum, 'ln_isfcav', REAL( icav, wp), ktype = jp_i4 ) 
     675      CALL iom_rstput( 0, 0, inum, 'ln_isfcav', REAL(COUNT((/ln_isfcav/)), wp), ktype = jp_i4 ) 
    695676      ! 
    696677      !                             !==  horizontal mesh  ! 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/SWE/domvvl.F90

    r13295 r13571  
    276276            IF( cn_cfg == "orca" .OR. cn_cfg == "ORCA" ) THEN 
    277277               IF( nn_cfg == 3 ) THEN   ! ORCA2: Suppress ztilde in the Foxe Basin for ORCA2 
    278                   ii0 = 103   ;   ii1 = 111        
    279                   ij0 = 128   ;   ij1 = 135   ;    
     278                  ii0 = 103 + nn_hls - 1   ;   ii1 = 111 + nn_hls - 1       
     279                  ij0 = 128 + nn_hls       ;   ij1 = 135 + nn_hls 
    280280                  frq_rst_e3t( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) =  0.0_wp 
    281281                  frq_rst_hdv( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) =  1.e0_wp / rn_Dt 
    … …  
    415415      LOGICAL                ::   ll_do_bclinic         ! local logical 
    416416      REAL(wp), DIMENSION(jpi,jpj)     ::   zht, z_scale, zwu, zwv, zhdiv 
    417       REAL(wp), DIMENSION(jpi,jpj,jpk) ::   ze3t 
     417      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::   ze3t 
     418      LOGICAL , DIMENSION(:,:,:), ALLOCATABLE ::   llmsk 
    418419      !!---------------------------------------------------------------------- 
    419420      ! 
    … …  
    528529         ! Maximum deformation control 
    529530         ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~ 
     531         ALLOCATE( ze3t(jpi,jpj,jpk), llmsk(jpi,jpj,jpk) ) 
    530532         ze3t(:,:,jpk) = 0._wp 
    531533         DO jk = 1, jpkm1 
    532534            ze3t(:,:,jk) = tilde_e3t_a(:,:,jk) / e3t_0(:,:,jk) * tmask(:,:,jk) * tmask_i(:,:) 
    533535         END DO 
    534          z_tmax = MAXVAL( ze3t(:,:,:) ) 
    535          CALL mpp_max( 'domvvl', z_tmax )                 ! max over the global domain 
    536          z_tmin = MINVAL( ze3t(:,:,:) ) 
    537          CALL mpp_min( 'domvvl', z_tmin )                 ! min over the global domain 
     536         ! 
     537         llmsk(   1:Nis1,:,:) = .FALSE.   ! exclude halos from the checked region 
     538         llmsk(Nie1: jpi,:,:) = .FALSE. 
     539         llmsk(:,   1:Njs1,:) = .FALSE. 
     540         llmsk(:,Nje1: jpj,:) = .FALSE. 
     541         ! 
     542         llmsk(Nis0:Nie0,Njs0:Nje0,:) = tmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp                  ! define only the inner domain 
     543         z_tmax = MAXVAL( ze3t(:,:,:), mask = llmsk )   ;   CALL mpp_max( 'domvvl', z_tmax )   ! max over the global domain 
     544         z_tmin = MINVAL( ze3t(:,:,:), mask = llmsk )   ;   CALL mpp_min( 'domvvl', z_tmin )   ! min over the global domain 
    538545         ! - ML - test: for the moment, stop simulation for too large e3_t variations 
    539546         IF( ( z_tmax >  rn_zdef_max ) .OR. ( z_tmin < - rn_zdef_max ) ) THEN 
    540             IF( lk_mpp ) THEN 
    541                CALL mpp_maxloc( 'domvvl', ze3t, tmask, z_tmax, ijk_max ) 
    542                CALL mpp_minloc( 'domvvl', ze3t, tmask, z_tmin, ijk_min ) 
    543             ELSE 
    544                ijk_max = MAXLOC( ze3t(:,:,:) ) 
    545                ijk_max(1) = ijk_max(1) + nimpp - 1 
    546                ijk_max(2) = ijk_max(2) + njmpp - 1 
    547                ijk_min = MINLOC( ze3t(:,:,:) ) 
    548                ijk_min(1) = ijk_min(1) + nimpp - 1 
    549                ijk_min(2) = ijk_min(2) + njmpp - 1 
    550             ENDIF 
     547            CALL mpp_maxloc( 'domvvl', ze3t, llmsk, z_tmax, ijk_max ) 
     548            CALL mpp_minloc( 'domvvl', ze3t, llmsk, z_tmin, ijk_min ) 
    551549            IF (lwp) THEN 
    552550               WRITE(numout, *) 'MAX( tilde_e3t_a(:,:,:) / e3t_0(:,:,:) ) =', z_tmax 
    … …  
    557555            ENDIF 
    558556         ENDIF 
     557         DEALLOCATE( ze3t, llmsk ) 
    559558         ! - ML - end test 
    560559         ! - ML - Imposing these limits will cause a baroclinicity error which is corrected for below 
    … …  
    697696      LOGICAL                ::   ll_do_bclinic         ! local logical 
    698697      REAL(wp), DIMENSION(jpi,jpj)     ::   zht, z_scale, zwu, zwv, zhdiv 
    699       REAL(wp), DIMENSION(jpi,jpj,jpk) ::   ze3t 
    700698      !!---------------------------------------------------------------------- 
    701699      ! 
    … …  
    11071105         IF( ln_rstart ) THEN                   !* Read the restart file 
    11081106            CALL rst_read_open                  !  open the restart file if necessary 
    1109             CALL iom_get( numror, jpdom_autoglo, 'sshn'   , ssh(:,:,Kmm), ldxios = lrxios    ) 
     1107            CALL iom_get( numror, jpdom_auto, 'sshn'   , ssh(:,:,Kmm), ldxios = lrxios    ) 
    11101108            ! 
    11111109            id1 = iom_varid( numror, 'e3t_b', ldstop = .FALSE. ) 
    … …  
    11201118            ! 
    11211119            IF( MIN( id1, id2 ) > 0 ) THEN       ! all required arrays exist 
    1122                CALL iom_get( numror, jpdom_autoglo, 'e3t_b', e3t(:,:,:,Kbb), ldxios = lrxios ) 
    1123                CALL iom_get( numror, jpdom_autoglo, 'e3t_n', e3t(:,:,:,Kmm), ldxios = lrxios ) 
     1120               CALL iom_get( numror, jpdom_auto, 'e3t_b', e3t(:,:,:,Kbb), ldxios = lrxios ) 
     1121               CALL iom_get( numror, jpdom_auto, 'e3t_n', e3t(:,:,:,Kmm), ldxios = lrxios ) 
    11241122               ! needed to restart if land processor not computed  
    11251123               IF(lwp) write(numout,*) 'dom_vvl_rst : e3t(:,:,:,Kbb) and e3t(:,:,:,Kmm) found in restart files' 
    … …  
    11351133               IF(lwp) write(numout,*) 'e3t_n set equal to e3t_b.' 
    11361134               IF(lwp) write(numout,*) 'l_1st_euler is forced to true' 
    1137                CALL iom_get( numror, jpdom_autoglo, 'e3t_b', e3t(:,:,:,Kbb), ldxios = lrxios ) 
     1135               CALL iom_get( numror, jpdom_auto, 'e3t_b', e3t(:,:,:,Kbb), ldxios = lrxios ) 
    11381136               e3t(:,:,:,Kmm) = e3t(:,:,:,Kbb) 
    11391137               l_1st_euler = .true. 
    … …  
    11421140               IF(lwp) write(numout,*) 'e3t_b set equal to e3t_n.' 
    11431141               IF(lwp) write(numout,*) 'l_1st_euler is forced to true' 
    1144                CALL iom_get( numror, jpdom_autoglo, 'e3t_n', e3t(:,:,:,Kmm), ldxios = lrxios ) 
     1142               CALL iom_get( numror, jpdom_auto, 'e3t_n', e3t(:,:,:,Kmm), ldxios = lrxios ) 
    11451143               e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm) 
    11461144               l_1st_euler = .true. 
    … …  
    11671165               !                          ! ----------------------- ! 
    11681166               IF( MIN( id3, id4 ) > 0 ) THEN  ! all required arrays exist 
    1169                   CALL iom_get( numror, jpdom_autoglo, 'tilde_e3t_b', tilde_e3t_b(:,:,:), ldxios = lrxios ) 
    1170                   CALL iom_get( numror, jpdom_autoglo, 'tilde_e3t_n', tilde_e3t_n(:,:,:), ldxios = lrxios ) 
     1167                  CALL iom_get( numror, jpdom_auto, 'tilde_e3t_b', tilde_e3t_b(:,:,:), ldxios = lrxios ) 
     1168                  CALL iom_get( numror, jpdom_auto, 'tilde_e3t_n', tilde_e3t_n(:,:,:), ldxios = lrxios ) 
    11711169               ELSE                            ! one at least array is missing 
    11721170                  tilde_e3t_b(:,:,:) = 0.0_wp 
    … …  
    11771175                  !                       ! ------------ ! 
    11781176                  IF( id5 > 0 ) THEN  ! required array exists 
    1179                      CALL iom_get( numror, jpdom_autoglo, 'hdiv_lf', hdiv_lf(:,:,:), ldxios = lrxios ) 
     1177                     CALL iom_get( numror, jpdom_auto, 'hdiv_lf', hdiv_lf(:,:,:), ldxios = lrxios ) 
    11801178                  ELSE                ! array is missing 
    11811179                     hdiv_lf(:,:,:) = 0.0_wp 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/SWE/step.F90

    r13295 r13571  
    291291      ! Control 
    292292      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
    293                          CALL stp_ctl      ( kstp, Nbb, Nnn, indic ) 
     293                         CALL stp_ctl      ( kstp, Nnn ) 
    294294                
    295295                          

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/SWE/stpctl.F90

    r12983 r13571  
    1919   USE dom_oce         ! ocean space and time domain variables  
    2020   USE c1d             ! 1D vertical configuration 
     21   USE zdf_oce ,  ONLY : ln_zad_Aimp       ! ocean vertical physics variables 
     22   USE wet_dry,   ONLY : ll_wd, ssh_ref    ! reference depth for negative bathy 
     23   !   
    2124   USE diawri          ! Standard run outputs       (dia_wri_state routine) 
    22    ! 
    2325   USE in_out_manager  ! I/O manager 
    2426   USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
    2527   USE lib_mpp         ! distributed memory computing 
    26    USE zdf_oce ,  ONLY : ln_zad_Aimp       ! ocean vertical physics variables 
    27    USE wet_dry,   ONLY : ll_wd, ssh_ref    ! reference depth for negative bathy 
    28  
     28   ! 
    2929   USE netcdf          ! NetCDF library 
    3030   IMPLICIT NONE 
    … …  
    3333   PUBLIC stp_ctl           ! routine called by step.F90 
    3434 
    35    INTEGER  ::   idrun, idtime, idssh, idu, ids1, ids2, idt1, idt2, idc1, idw1, istatus 
    36    LOGICAL  ::   lsomeoce 
    37 !!stoops 
    38 #  include "domzgr_substitute.h90" 
     35   INTEGER                ::   nrunid   ! netcdf file id 
     36   INTEGER, DIMENSION(2)  ::   nvarid   ! netcdf variable id 
    3937   !!---------------------------------------------------------------------- 
    4038   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    41    !! $Id: stpctl.F90 12614 2020-03-26 14:59:52Z gm $ 
     39   !! $Id: stpctl.F90 13216 2020-07-02 09:25:49Z rblod $ 
    4240   !! Software governed by the CeCILL license (see ./LICENSE) 
    4341   !!---------------------------------------------------------------------- 
    4442CONTAINS 
    4543 
    46    SUBROUTINE stp_ctl( kt, Kbb, Kmm, kindic ) 
     44   SUBROUTINE stp_ctl( kt, Kmm ) 
    4745      !!---------------------------------------------------------------------- 
    4846      !!                    ***  ROUTINE stp_ctl  *** 
    … …  
    5149      !! 
    5250      !! ** Method  : - Save the time step in numstp 
    53       !!              - Print it each 50 time steps 
    54       !!              - Stop the run IF problem encountered by setting indic=-3 
    55       !!                Problems checked: |ssh| maximum larger than 10 m 
     51      !!              - Stop the run IF problem encountered by setting nstop > 0 
     52      !!                Problems checked: negative sea surface height  
    5653      !!                                  |U|   maximum larger than 10 m/s  
    57       !!                                  negative sea surface salinity 
    5854      !! 
    5955      !! ** Actions :   "time.step" file = last ocean time-step 
    6056      !!                "run.stat"  file = run statistics 
    61       !!                nstop indicator sheared among all local domain (lk_mpp=T) 
     57      !!                 nstop indicator sheared among all local domain 
    6258      !!---------------------------------------------------------------------- 
    6359      INTEGER, INTENT(in   ) ::   kt       ! ocean time-step index 
    64       INTEGER, INTENT(in   ) ::   Kbb, Kmm      ! ocean time level index 
    65       INTEGER, INTENT(inout) ::   kindic   ! error indicator 
    66       !! 
    67       INTEGER                ::   ji, jj, jk          ! dummy loop indices 
    68       INTEGER, DIMENSION(2)  ::   ih                  ! min/max loc indices 
    69       INTEGER, DIMENSION(3)  ::   iu, is1, is2        ! min/max loc indices 
    70       REAL(wp)               ::   zzz                 ! local real  
    71       REAL(wp), DIMENSION(3) ::   zmax 
    72       LOGICAL                ::   ll_wrtstp, ll_colruns, ll_wrtruns 
    73       CHARACTER(len=20) :: clname 
    74       !!---------------------------------------------------------------------- 
    75       ! 
    76       ll_wrtstp  = ( MOD( kt, sn_cfctl%ptimincr ) == 0 ) .OR. ( kt == nitend ) 
    77       ll_colruns = ll_wrtstp .AND. ( sn_cfctl%l_runstat ) 
    78       ll_wrtruns = ll_colruns .AND. lwm 
    79       IF( kt == nit000 .AND. lwp ) THEN 
    80          WRITE(numout,*) 
    81          WRITE(numout,*) 'stp_ctl : time-stepping control' 
    82          WRITE(numout,*) '~~~~~~~' 
    83          !                                ! open time.step file 
    84          IF( lwm ) CALL ctl_opn( numstp, 'time.step', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea ) 
    85          !                                ! open run.stat file(s) at start whatever 
    86          !                                ! the value of sn_cfctl%ptimincr 
    87          IF( lwm .AND. ( sn_cfctl%l_runstat ) ) THEN 
     60      INTEGER, INTENT(in   ) ::   Kmm      ! ocean time level index 
     61      !! 
     62      INTEGER                         ::   ji                                    ! dummy loop indices 
     63      INTEGER                         ::   idtime, istatus 
     64      INTEGER , DIMENSION(3)          ::   iareasum, iareamin, iareamax 
     65      INTEGER , DIMENSION(3,2)        ::   iloc                                  ! min/max loc indices 
     66      REAL(wp)                        ::   zzz                                   ! local real  
     67      REAL(wp), DIMENSION(3)          ::   zmax, zmaxlocal 
     68      LOGICAL                         ::   ll_wrtstp, ll_colruns, ll_wrtruns 
     69      LOGICAL, DIMENSION(jpi,jpj,jpk) ::   llmsk 
     70      CHARACTER(len=20)               ::   clname 
     71      !!---------------------------------------------------------------------- 
     72      IF( nstop > 0 .AND. ngrdstop > -1 )   RETURN   !   stpctl was already called by a child grid 
     73      ! 
     74      ll_wrtstp  = ( MOD( kt-nit000, sn_cfctl%ptimincr ) == 0 ) .OR. ( kt == nitend ) 
     75      ll_colruns = ll_wrtstp .AND. sn_cfctl%l_runstat .AND. jpnij > 1  
     76      ll_wrtruns = ( ll_colruns .OR. jpnij == 1 ) .AND. lwm 
     77      ! 
     78      IF( kt == nit000 ) THEN 
     79         ! 
     80         IF( lwp ) THEN 
     81            WRITE(numout,*) 
     82            WRITE(numout,*) 'stp_ctl : time-stepping control' 
     83            WRITE(numout,*) '~~~~~~~' 
     84         ENDIF 
     85         !                                ! open time.step    ascii file, done only by 1st subdomain 
     86         IF( lwm )   CALL ctl_opn( numstp, 'time.step', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea ) 
     87         ! 
     88         IF( ll_wrtruns ) THEN 
     89            !                             ! open run.stat     ascii file, done only by 1st subdomain 
    8890            CALL ctl_opn( numrun, 'run.stat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea ) 
     91            !                             ! open run.stat.nc netcdf file, done only by 1st subdomain 
    8992            clname = 'run.stat.nc' 
    9093            IF( .NOT. Agrif_Root() )   clname = TRIM(Agrif_CFixed())//"_"//TRIM(clname) 
    91             istatus = NF90_CREATE( TRIM(clname), NF90_CLOBBER, idrun ) 
    92             istatus = NF90_DEF_DIM( idrun, 'time', NF90_UNLIMITED, idtime ) 
    93             istatus = NF90_DEF_VAR( idrun, 'abs_ssh_max', NF90_DOUBLE, (/ idtime /), idssh ) 
    94             istatus = NF90_DEF_VAR( idrun,   'abs_u_max', NF90_DOUBLE, (/ idtime /), idu   ) 
    95             istatus = NF90_ENDDEF(idrun) 
    96          ENDIF 
    97       ENDIF 
    98       IF( kt == nit000 )   lsomeoce = COUNT( ssmask(:,:) == 1._wp ) > 0 
    99       ! 
    100       IF(lwm .AND. ll_wrtstp) THEN        !==  current time step  ==!   ("time.step" file) 
     94            istatus = NF90_CREATE( TRIM(clname), NF90_CLOBBER, nrunid ) 
     95            istatus = NF90_DEF_DIM( nrunid, 'time', NF90_UNLIMITED, idtime ) 
     96            istatus = NF90_DEF_VAR( nrunid, 'abs_ssh_max', NF90_DOUBLE, (/ idtime /), nvarid(1) ) 
     97            istatus = NF90_DEF_VAR( nrunid,   'abs_u_max', NF90_DOUBLE, (/ idtime /), nvarid(2) ) 
     98            istatus = NF90_ENDDEF(nrunid) 
     99         ENDIF 
     100         !     
     101      ENDIF 
     102      ! 
     103      !                                   !==              write current time step              ==! 
     104      !                                   !==  done only by 1st subdomain at writting timestep  ==! 
     105      IF( lwm .AND. ll_wrtstp ) THEN 
    101106         WRITE ( numstp, '(1x, i8)' )   kt 
    102107         REWIND( numstp ) 
    103108      ENDIF 
    104       ! 
    105       !                                   !==  test of extrema  ==! 
    106       IF( ll_wd ) THEN 
    107          zmax(1) = MAXVAL(  ABS( ssh(:,:,Kmm) + ssh_ref*tmask(:,:,1) )  )        ! ssh max  
    108       ELSE 
    109          zmax(1) = MINVAL( e3t(:,:,1,Kmm)  )                                         ! ssh min 
    110       ENDIF 
    111       zmax(2) = MAXVAL(  ABS( uu(:,:,:,Kmm) )  )                                  ! velocity max (zonal only) 
    112       zmax(3) = REAL( nstop , wp )                                            ! stop indicator 
    113       ! 
     109      !                                   !==            test of local extrema           ==! 
     110      !                                   !==  done by all processes at every time step  ==! 
     111      ! 
     112      llmsk(   1:Nis1,:,:) = .FALSE.                                              ! exclude halos from the checked region 
     113      llmsk(Nie1: jpi,:,:) = .FALSE. 
     114      llmsk(:,   1:Njs1,:) = .FALSE. 
     115      llmsk(:,Nje1: jpj,:) = .FALSE. 
     116      ! 
     117      llmsk(Nis0:Nie0,Njs0:Nje0,1) = tmask(Nis0:Nie0,Njs0:Nje0,1) == 1._wp         ! define only the inner domain 
     118      zmax(1) = MAXVAL(     -e3t(:,:,1,Kmm) ), mask = llmsk(:,:,1) )      ! ssh max 
     119      llmsk(Nis0:Nie0,Njs0:Nje0,:) = umask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp        ! define only the inner domain 
     120      zmax(2) = MAXVAL(  ABS( uu(:,:,:,Kmm) ), mask = llmsk(:,:,:) )                     ! velocity max (zonal only) 
     121      zmax(3) = REAL( nstop, wp )                                                 ! stop indicator 
     122      !                                   !==               get global extrema             ==! 
     123      !                                   !==  done by all processes if writting run.stat  ==! 
    114124      IF( ll_colruns ) THEN 
     125         zmaxlocal(:) = zmax(:) 
    115126         CALL mpp_max( "stpctl", zmax )          ! max over the global domain 
    116          nstop = NINT( zmax(3) )                 ! nstop indicator sheared among all local domains 
    117       ENDIF 
    118       !                                   !==  run statistics  ==!   ("run.stat" files) 
     127         nstop = NINT( zmax(3) )                 ! update nstop indicator (now sheared among all local domains) 
     128      ENDIF 
     129      !                                   !==              write "run.stat" files              ==! 
     130      !                                   !==  done only by 1st subdomain at writting timestep  ==! 
    119131      IF( ll_wrtruns ) THEN 
    120132         WRITE(numrun,9500) kt, zmax(1), zmax(2) 
    121          istatus = NF90_PUT_VAR( idrun, idssh, (/ zmax(1)/), (/kt/), (/1/) ) 
    122          istatus = NF90_PUT_VAR( idrun,   idu, (/ zmax(2)/), (/kt/), (/1/) ) 
    123          IF( MOD( kt , 100 ) == 0 ) istatus = NF90_SYNC(idrun) 
    124          IF( kt == nitend         ) istatus = NF90_CLOSE(idrun) 
     133         istatus = NF90_PUT_VAR( nrunid, nvarid(1), (/ -zmax(1)/), (/kt/), (/1/) ) 
     134         istatus = NF90_PUT_VAR( nrunid, nvarid(2), (/  zmax(2)/), (/kt/), (/1/) ) 
     135         IF( kt == nitend )   istatus = NF90_CLOSE(nrunid) 
    125136      END IF 
    126       !                                   !==  error handling  ==! 
    127       IF( ( sn_cfctl%l_glochk .OR. lsomeoce ) .AND. (   &  ! domain contains some ocean points, check for sensible ranges 
    128          &  zmax(1) <    0._wp .OR.   &                    ! negative sea surface height  
    129          &  zmax(2) >   10._wp .OR.   &                    ! too large velocity ( > 10 m/s) 
    130          &  ISNAN( zmax(1) + zmax(2) ) ) ) THEN            ! NaN encounter in the tests 
    131          IF( lk_mpp .AND. sn_cfctl%l_glochk ) THEN 
    132             ! have use mpp_max (because sn_cfctl%l_glochk=.T. and distributed) 
    133             CALL mpp_maxloc( 'stpctl', ABS(ssh(:,:,Kmm))        , ssmask(:,:)  , zzz, ih  ) 
    134             CALL mpp_maxloc( 'stpctl', ABS(uu(:,:,:,Kmm))          , umask (:,:,:), zzz, iu  ) 
     137      !                                   !==               error handling               ==! 
     138      !                                   !==  done by all processes at every time step  ==! 
     139      ! 
     140      IF(   zmax(1) >  0._wp           .OR.   &               ! negative sea surface height  
     141         &  zmax(2) > 10._wp           .OR.   &               ! too large velocity ( > 10 m/s) 
     142         &  ISNAN( zmax(1) + zmax(2) ) .OR.   &               ! NaN encounter in the tests 
     143         &  ABS(   zmax(1) + zmax(2) ) > HUGE(1._wp) ) THEN   ! Infinity encounter in the tests 
     144         ! 
     145         iloc(:,:) = 0 
     146         IF( ll_colruns ) THEN   ! zmax is global, so it is the same on all subdomains -> no dead lock with mpp_maxloc 
     147            ! first: close the netcdf file, so we can read it 
     148            IF( lwm .AND. kt /= nitend )   istatus = NF90_CLOSE(nrunid) 
     149            ! get global loc on the min/max 
     150            llmsk(Nis0:Nie0,Njs0:Nje0,1) = tmask(Nis0:Nie0,Njs0:Nje0,1) == 1._wp         ! define only the inner domain 
     151            CALL mpp_maxloc( 'stpctl',   -e3t(:,:,1,Kmm) , llmsk(:,:,1), zzz, iloc(1:2,1) )   ! mpp_maxloc ok if mask = F  
     152            llmsk(Nis0:Nie0,Njs0:Nje0,:) = umask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp        ! define only the inner domain 
     153            CALL mpp_maxloc( 'stpctl', ABS(uu(:,:,:,Kmm)), llmsk(:,:,:), zzz, iloc(1:3,2) ) 
     154            ! find which subdomain has the max. 
     155            iareamin(:) = jpnij+1   ;   iareamax(:) = 0   ;   iareasum(:) = 0 
     156            DO ji = 1, 3 
     157               IF( zmaxlocal(ji) == zmax(ji) ) THEN 
     158                  iareamin(ji) = narea   ;   iareamax(ji) = narea   ;   iareasum(ji) = 1 
     159               ENDIF 
     160            END DO 
     161            CALL mpp_min( "stpctl", iareamin )         ! min over the global domain 
     162            CALL mpp_max( "stpctl", iareamax )         ! max over the global domain 
     163            CALL mpp_sum( "stpctl", iareasum )         ! sum over the global domain 
     164         ELSE                    ! find local min and max locations: 
     165            ! if we are here, this means that the subdomain contains some oce points -> no need to test the mask used in maxloc 
     166            llmsk(Nis0:Nie0,Njs0:Nje0,1) = tmask(Nis0:Nie0,Njs0:Nje0,1) == 1._wp         ! define only the inner domain 
     167            iloc(1:2,1) = MAXLOC(   -e3t(:,:,1,Kmm) , mask = llmsk(:,:,1) ) 
     168            llmsk(Nis0:Nie0,Njs0:Nje0,:) = umask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp        ! define only the inner domain 
     169            iloc(1:3,2) = MAXLOC( ABS(uu(:,:,:,Kmm)), mask = llmsk(:,:,:) ) 
     170            DO ji = 1, 2   ! local domain indices ==> global domain indices, excluding halos 
     171               iloc(1:2,ji) = (/ mig0(iloc(1,ji)), mjg0(iloc(2,ji)) /) 
     172            END DO 
     173            iareamin(:) = narea   ;   iareamax(:) = narea   ;   iareasum(:) = 1         ! this is local information 
     174         ENDIF 
     175         ! 
     176         WRITE(ctmp1,*) ' stp_ctl: |ssh| > 20 m  or  |U| > 10 m/s  or  S <= 0  or  S >= 100  or  NaN encounter in the tests' 
     177         CALL wrt_line( ctmp2, kt, '|e3t| min', -zmax(1), iloc(:,1), iareasum(1), iareamin(1), iareamax(1) ) 
     178         CALL wrt_line( ctmp3, kt, '|U|   max',  zmax(2), iloc(:,2), iareasum(2), iareamin(2), iareamax(2) ) 
     179         IF( Agrif_Root() ) THEN 
     180            WRITE(ctmp6,*) '      ===> output of last computed fields in output.abort* files' 
    135181         ELSE 
    136             ! find local min and max locations 
    137             ih(:)  = MAXLOC( ABS( ssh(:,:,Kmm)   )                              ) + (/ nimpp - 1, njmpp - 1    /) 
    138             iu(:)  = MAXLOC( ABS( uu  (:,:,:,Kmm) )                              ) + (/ nimpp - 1, njmpp - 1, 0 /) 
    139          ENDIF 
    140           
    141          WRITE(ctmp1,*) ' stp_ctl: (e3t0) ssh < 0 m  or  |U| > 10 m/s  or  NaN encounter in the tests' 
    142          WRITE(ctmp2,9100) kt,   zmax(1), ih(1) , ih(2) 
    143          WRITE(ctmp3,9200) kt,   zmax(2), iu(1) , iu(2) , iu(3) 
    144          WRITE(ctmp4,*) '      ===> output of last computed fields in output.abort.nc file' 
    145           
     182            WRITE(ctmp6,*) '      ===> output of last computed fields in '//TRIM(Agrif_CFixed())//'_output.abort* files' 
     183         ENDIF 
     184         ! 
    146185         CALL dia_wri_state( Kmm, 'output.abort' )     ! create an output.abort file 
    147           
    148          IF( .NOT. sn_cfctl%l_glochk ) THEN 
    149             WRITE(ctmp8,*) 'E R R O R message from sub-domain: ', narea 
    150             CALL ctl_stop( 'STOP', ctmp1, ' ', ctmp8, ' ', ctmp2, ctmp3, ctmp4 ) 
    151          ELSE 
    152             CALL ctl_stop( ctmp1, ' ', ctmp2, ctmp3, ctmp4 ) 
    153          ENDIF 
    154  
    155          kindic = -3 
    156          ! 
    157       ENDIF 
    158       ! 
    159 9100  FORMAT (' kt=',i8,'   |ssh| min: ',1pg11.4,', at  i j  : ',2i5) 
    160 9200  FORMAT (' kt=',i8,'   |U|   max: ',1pg11.4,', at  i j k: ',3i5) 
    161 9500  FORMAT(' it :', i8, '    |ssh|_max: ', D23.16, ' |U|_max: ', D23.16) 
     186         ! 
     187         IF( ll_colruns .or. jpnij == 1 ) THEN   ! all processes synchronized -> use lwp to print in opened ocean.output files 
     188            IF(lwp) THEN   ;   CALL ctl_stop( ctmp1, ' ', ctmp2, ctmp3, ' ', ctmp6 ) 
     189            ELSE           ;   nstop = MAX(1, nstop)   ! make sure nstop > 0 (automatically done when calling ctl_stop) 
     190            ENDIF 
     191         ELSE                                    ! only mpi subdomains with errors are here -> STOP now 
     192            CALL ctl_stop( 'STOP', ctmp1, ' ', ctmp2, ctmp3, ' ', ctmp6 ) 
     193         ENDIF 
     194         ! 
     195      ENDIF 
     196      ! 
     197      IF( nstop > 0 ) THEN                                                  ! an error was detected and we did not abort yet... 
     198         ngrdstop = Agrif_Fixed()                                           ! store which grid got this error 
     199         IF( .NOT. ll_colruns .AND. jpnij > 1 )   CALL ctl_stop( 'STOP' )   ! we must abort here to avoid MPI deadlock 
     200      ENDIF 
     201      ! 
     2029500  FORMAT(' it :', i8, '    |ssh|_max: ', D23.16, ' |U|_max: ', D23.16,' S_min: ', D23.16,' S_max: ', D23.16) 
    162203      ! 
    163204   END SUBROUTINE stp_ctl 
     205 
     206 
     207   SUBROUTINE wrt_line( cdline, kt, cdprefix, pval, kloc, ksum, kmin, kmax ) 
     208      !!---------------------------------------------------------------------- 
     209      !!                     ***  ROUTINE wrt_line  *** 
     210      !! 
     211      !! ** Purpose :   write information line 
     212      !! 
     213      !!---------------------------------------------------------------------- 
     214      CHARACTER(len=*),      INTENT(  out) ::   cdline 
     215      CHARACTER(len=*),      INTENT(in   ) ::   cdprefix 
     216      REAL(wp),              INTENT(in   ) ::   pval 
     217      INTEGER, DIMENSION(3), INTENT(in   ) ::   kloc 
     218      INTEGER,               INTENT(in   ) ::   kt, ksum, kmin, kmax 
     219      ! 
     220      CHARACTER(len=80) ::   clsuff 
     221      CHARACTER(len=9 ) ::   clkt, clsum, clmin, clmax 
     222      CHARACTER(len=9 ) ::   cli, clj, clk 
     223      CHARACTER(len=1 ) ::   clfmt 
     224      CHARACTER(len=4 ) ::   cl4   ! needed to be able to compile with Agrif, I don't know why 
     225      INTEGER           ::   ifmtk 
     226      !!---------------------------------------------------------------------- 
     227      WRITE(clkt , '(i9)') kt 
     228       
     229      WRITE(clfmt, '(i1)') INT(LOG10(REAL(jpnij  ,wp))) + 1     ! how many digits to we need to write ? (we decide max = 9) 
     230      !!! WRITE(clsum, '(i'//clfmt//')') ksum                   ! this is creating a compilation error with AGRIF 
     231      cl4 = '(i'//clfmt//')'   ;   WRITE(clsum, cl4) ksum 
     232      WRITE(clfmt, '(i1)') INT(LOG10(REAL(MAX(1,jpnij-1),wp))) + 1    ! how many digits to we need to write ? (we decide max = 9) 
     233      cl4 = '(i'//clfmt//')'   ;   WRITE(clmin, cl4) kmin-1 
     234                                   WRITE(clmax, cl4) kmax-1 
     235      ! 
     236      WRITE(clfmt, '(i1)') INT(LOG10(REAL(jpiglo,wp))) + 1      ! how many digits to we need to write jpiglo? (we decide max = 9) 
     237      cl4 = '(i'//clfmt//')'   ;   WRITE(cli, cl4) kloc(1)      ! this is ok with AGRIF 
     238      WRITE(clfmt, '(i1)') INT(LOG10(REAL(jpjglo,wp))) + 1      ! how many digits to we need to write jpjglo? (we decide max = 9) 
     239      cl4 = '(i'//clfmt//')'   ;   WRITE(clj, cl4) kloc(2)      ! this is ok with AGRIF 
     240      ! 
     241      IF( ksum == 1 ) THEN   ;   WRITE(clsuff,9100) TRIM(clmin) 
     242      ELSE                   ;   WRITE(clsuff,9200) TRIM(clsum), TRIM(clmin), TRIM(clmax) 
     243      ENDIF 
     244      IF(kloc(3) == 0) THEN 
     245         ifmtk = INT(LOG10(REAL(jpk,wp))) + 1                   ! how many digits to we need to write jpk? (we decide max = 9) 
     246         clk = REPEAT(' ', ifmtk)                               ! create the equivalent in blank string 
     247         WRITE(cdline,9300) TRIM(ADJUSTL(clkt)), TRIM(ADJUSTL(cdprefix)), pval, TRIM(cli), TRIM(clj), clk(1:ifmtk), TRIM(clsuff) 
     248      ELSE 
     249         WRITE(clfmt, '(i1)') INT(LOG10(REAL(jpk,wp))) + 1      ! how many digits to we need to write jpk? (we decide max = 9) 
     250         !!! WRITE(clk, '(i'//clfmt//')') kloc(3)               ! this is creating a compilation error with AGRIF 
     251         cl4 = '(i'//clfmt//')'   ;   WRITE(clk, cl4) kloc(3)   ! this is ok with AGRIF 
     252         WRITE(cdline,9400) TRIM(ADJUSTL(clkt)), TRIM(ADJUSTL(cdprefix)), pval, TRIM(cli), TRIM(clj),    TRIM(clk), TRIM(clsuff) 
     253      ENDIF 
     254      ! 
     2559100  FORMAT('MPI rank ', a) 
     2569200  FORMAT('found in ', a, ' MPI tasks, spread out among ranks ', a, ' to ', a) 
     2579300  FORMAT('kt ', a, ' ', a, ' ', 1pg11.4, ' at i j   ', a, ' ', a, ' ', a, ' ', a) 
     2589400  FORMAT('kt ', a, ' ', a, ' ', 1pg11.4, ' at i j k ', a, ' ', a, ' ', a, ' ', a) 
     259      ! 
     260   END SUBROUTINE wrt_line 
     261 
    164262 
    165263   !!====================================================================== 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/TOP/C14/trcatm_c14.F90

    r13295 r13571  
    120120            IF( ierr3 /= 0 )   CALL ctl_stop( 'STOP', 'trc_atm_c14_ini: unable to allocate fareaz' ) 
    121121      ! 
    122             DO_2D( 1, 1, 1, 1 ) 
     122            DO_2D( 1, 1, 1, 1 )                 ! from C14b package 
    123123              IF( gphit(ji,jj) >= yn40 ) THEN 
    124124                 fareaz(ji,jj,1) = 0. 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/TOP/CFC/trcsms_cfc.F90

    r13295 r13571  
    126126          
    127127         !                                                         !------------! 
    128          DO_2D( 1, 1, 1, 1 ) 
    129   
     128         DO_2D( 1, 1, 1, 1 )                                       !  i-j loop  ! 
     129            !                                                      !------------! 
    130130            ! space interpolation 
    131131            zpp_cfc  =       xphem(ji,jj)   * zpatm(1,jl)   & 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/TOP/PISCES/P2Z/p2zopt.F90

    r13295 r13571  
    9595      !                                          ! Photosynthetically Available Radiation (PAR) 
    9696      zcoef = 12 * redf / rcchl / rpig           ! -------------------------------------- 
    97       DO_3D( 1, 1, 1, 1, 2, jpk ) 
     97      DO_3D( 1, 1, 1, 1, 2, jpk )                     ! local par at w-levels 
    9898         zpig = LOG(  MAX( TINY(0.), tr(ji,jj,jk-1,jpphy,Kmm) ) * zcoef  ) 
    9999         zkr  = xkr0 + xkrp * EXP( xlr * zpig ) 
    … …  
    102102         zparg(ji,jj,jk) = zparg(ji,jj,jk-1) * EXP( -zkg * e3t(ji,jj,jk-1,Kmm) ) 
    103103      END_3D 
    104       DO_3D( 1, 1, 1, 1, 1, jpkm1 ) 
     104      DO_3D( 1, 1, 1, 1, 1, jpkm1 )                   ! mean par at t-levels 
    105105         zpig = LOG(  MAX( TINY(0.), tr(ji,jj,jk,jpphy,Kmm) ) * zcoef  ) 
    106106         zkr  = xkr0 + xkrp * EXP( xlr * zpig ) 
    … …  
    114114      !                                          ! -------------- 
    115115      neln(:,:) = 1                                   ! euphotic layer level 
    116       DO_3D( 1, 1, 1, 1, 1, jpkm1 ) 
     116      DO_3D( 1, 1, 1, 1, 1, jpkm1 )                   ! (i.e. 1rst T-level strictly below EL bottom) 
    117117        IF( etot(ji,jj,jk) >= zpar100(ji,jj) )   neln(ji,jj) = jk + 1  
    118118      END_3D 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/TOP/PISCES/P4Z/p4zfechem.F90

    r13295 r13571  
    118118         ! 
    119119         zfeequi = zFe3(ji,jj,jk) * 1E-9 
    120          zhplus  = max( rtrn, hi(ji,jj,jk) ) 
    121          fe3sol  = fesol(ji,jj,jk,1) * ( zhplus**3 + fesol(ji,jj,jk,2) * zhplus**2  & 
    122             &         + fesol(ji,jj,jk,3) * zhplus + fesol(ji,jj,jk,4)     & 
    123             &         + fesol(ji,jj,jk,5) / zhplus ) 
    124120         zfecoll = 0.5 * zFeL1(ji,jj,jk) * 1E-9 
    125121         ! precipitation of Fe3+, creation of nanoparticles 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/TOP/PISCES/P4Z/p4zlim.F90

    r13295 r13571  
    161161         zlim1    = xdiatno3(ji,jj,jk) + xdiatnh4(ji,jj,jk) 
    162162         zlim2    = tr(ji,jj,jk,jppo4,Kbb) / ( tr(ji,jj,jk,jppo4,Kbb) + zconc1dnh4  ) 
    163          zlim3    = tr(ji,jj,jk,jpsil,Kbb) / ( tr(ji,jj,jk,jpsil,Kbb) + xksi(ji,jj) ) 
     163         zlim3    = tr(ji,jj,jk,jpsil,Kbb) / ( tr(ji,jj,jk,jpsil,Kbb) + xksi(ji,jj) + rtrn ) 
    164164         zratio   = tr(ji,jj,jk,jpdfe,Kbb) * z1_trbdia 
    165165         zironmin = xcoef1 * tr(ji,jj,jk,jpdch,Kbb) * z1_trbdia + xcoef2 * zlim1 + xcoef3 * xdiatno3(ji,jj,jk) 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/TOP/PISCES/P4Z/p4zopt.F90

    r13295 r13571  
    3737   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   par_varsw      ! PAR fraction of shortwave 
    3838   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   ekb, ekg, ekr  ! wavelength (Red-Green-Blue) 
    39  
    40    INTEGER  ::   nksrp   ! levels below which the light cannot penetrate ( depth larger than 391 m) 
    41  
    42    REAL(wp), DIMENSION(3,61) ::   xkrgb   ! tabulated attenuation coefficients for RGB absorption 
    4339    
    4440   !! * Substitutions 
    … …  
    9490         irgb = NINT( 41 + 20.* LOG10( zchl ) + rtrn ) 
    9591         !                                                          
    96          ekb(ji,jj,jk) = xkrgb(1,irgb) * e3t(ji,jj,jk,Kmm) 
    97          ekg(ji,jj,jk) = xkrgb(2,irgb) * e3t(ji,jj,jk,Kmm) 
    98          ekr(ji,jj,jk) = xkrgb(3,irgb) * e3t(ji,jj,jk,Kmm) 
     92         ekb(ji,jj,jk) = rkrgb(1,irgb) * e3t(ji,jj,jk,Kmm) 
     93         ekg(ji,jj,jk) = rkrgb(2,irgb) * e3t(ji,jj,jk,Kmm) 
     94         ekr(ji,jj,jk) = rkrgb(3,irgb) * e3t(ji,jj,jk,Kmm) 
    9995      END_3D 
    10096      !                                        !* Photosynthetically Available Radiation (PAR) 
    … …  
    106102         CALL p4z_opt_par( kt, Kmm, zqsr_corr, ze1, ze2, ze3, pqsr100 = zqsr100 )  
    107103         ! 
    108          DO jk = 1, nksrp       
     104         DO jk = 1, nksr       
    109105            etot_ndcy(:,:,jk) =        ze1(:,:,jk) +        ze2(:,:,jk) +       ze3(:,:,jk) 
    110106            enano    (:,:,jk) =  1.85 * ze1(:,:,jk) + 0.69 * ze2(:,:,jk) + 0.46 * ze3(:,:,jk) 
    … …  
    112108         END DO 
    113109         IF( ln_p5z ) THEN 
    114             DO jk = 1, nksrp       
     110            DO jk = 1, nksr       
    115111              epico  (:,:,jk) =  1.94 * ze1(:,:,jk) + 0.66 * ze2(:,:,jk) + 0.4 * ze3(:,:,jk) 
    116112            END DO 
    … …  
    121117         CALL p4z_opt_par( kt, Kmm, zqsr_corr, ze1, ze2, ze3 )  
    122118         ! 
    123          DO jk = 1, nksrp       
     119         DO jk = 1, nksr       
    124120            etot(:,:,jk) =  ze1(:,:,jk) + ze2(:,:,jk) + ze3(:,:,jk) 
    125121         END DO 
    … …  
    131127         CALL p4z_opt_par( kt, Kmm, zqsr_corr, ze1, ze2, ze3, pqsr100 = zqsr100  )  
    132128         ! 
    133          DO jk = 1, nksrp       
     129         DO jk = 1, nksr       
    134130            etot (:,:,jk) =        ze1(:,:,jk) +        ze2(:,:,jk) +       ze3(:,:,jk) 
    135131            enano(:,:,jk) =  1.85 * ze1(:,:,jk) + 0.69 * ze2(:,:,jk) + 0.46 * ze3(:,:,jk) 
    … …  
    137133         END DO 
    138134         IF( ln_p5z ) THEN 
    139             DO jk = 1, nksrp       
     135            DO jk = 1, nksr       
    140136              epico(:,:,jk) =  1.94 * ze1(:,:,jk) + 0.66 * ze2(:,:,jk) + 0.4 * ze3(:,:,jk) 
    141137            END DO 
    … …  
    150146         ! 
    151147         etot3(:,:,1) =  qsr(:,:) * tmask(:,:,1) 
    152          DO jk = 2, nksrp + 1 
     148         DO jk = 2, nksr + 1 
    153149            etot3(:,:,jk) =  ( ze0(:,:,jk) + ze1(:,:,jk) + ze2(:,:,jk) + ze3(:,:,jk) ) * tmask(:,:,jk) 
    154150         END DO 
    … …  
    160156      heup_01(:,:) = gdepw(:,:,2,Kmm) 
    161157 
    162       DO_3D( 1, 1, 1, 1, 2, nksrp ) 
     158      DO_3D( 1, 1, 1, 1, 2, nksr ) 
    163159        IF( etot_ndcy(ji,jj,jk) * tmask(ji,jj,jk) >=  zqsr100(ji,jj) )  THEN 
    164160           neln(ji,jj) = jk+1                    ! Euphotic level : 1rst T-level strictly below Euphotic layer 
    … …  
    178174      zetmp2 (:,:)   = 0.e0 
    179175 
    180       DO_3D( 1, 1, 1, 1, 1, nksrp ) 
     176      DO_3D( 1, 1, 1, 1, 1, nksr ) 
    181177         IF( gdepw(ji,jj,jk+1,Kmm) <= hmld(ji,jj) ) THEN 
    182178            zetmp1 (ji,jj) = zetmp1 (ji,jj) + etot     (ji,jj,jk) * e3t(ji,jj,jk,Kmm) ! remineralisation 
    … …  
    189185      zpar(:,:,:) = etot_ndcy(:,:,:)  ! diagnostic : PAR with no diurnal cycle  
    190186      ! 
    191       DO_3D( 1, 1, 1, 1, 1, nksrp ) 
     187      DO_3D( 1, 1, 1, 1, 1, nksr ) 
    192188         IF( gdepw(ji,jj,jk+1,Kmm) <= hmld(ji,jj) ) THEN 
    193189            z1_dep = 1. / ( zdepmoy(ji,jj) + rtrn ) 
    … …  
    201197      zetmp4 (:,:)   = 0.e0 
    202198      ! 
    203       DO_3D( 1, 1, 1, 1, 1, nksrp ) 
     199      DO_3D( 1, 1, 1, 1, 1, nksr ) 
    204200         IF( gdepw(ji,jj,jk+1,Kmm) <= MIN(hmld(ji,jj), heup_01(ji,jj)) ) THEN 
    205201            zetmp3 (ji,jj) = zetmp3 (ji,jj) + enano    (ji,jj,jk) * e3t(ji,jj,jk,Kmm) ! production 
    … …  
    211207      ediatm(:,:,:) = ediat(:,:,:) 
    212208      ! 
    213       DO_3D( 1, 1, 1, 1, 1, nksrp ) 
     209      DO_3D( 1, 1, 1, 1, 1, nksr ) 
    214210         IF( gdepw(ji,jj,jk+1,Kmm) <= hmld(ji,jj) ) THEN 
    215211            z1_dep = 1. / ( zdepmoy(ji,jj) + rtrn ) 
    … …  
    221217      IF( ln_p5z ) THEN 
    222218         ALLOCATE( zetmp5(jpi,jpj) )  ;   zetmp5 (:,:) = 0.e0 
    223          DO_3D( 1, 1, 1, 1, 1, nksrp ) 
     219         DO_3D( 1, 1, 1, 1, 1, nksr ) 
    224220            IF( gdepw(ji,jj,jk+1,Kmm) <= MIN(hmld(ji,jj), heup_01(ji,jj)) ) THEN 
    225221               zetmp5(ji,jj)  = zetmp5 (ji,jj) + epico(ji,jj,jk) * e3t(ji,jj,jk,Kmm) ! production 
    … …  
    229225         epicom(:,:,:) = epico(:,:,:) 
    230226         ! 
    231          DO_3D( 1, 1, 1, 1, 1, nksrp ) 
     227         DO_3D( 1, 1, 1, 1, 1, nksr ) 
    232228            IF( gdepw(ji,jj,jk+1,Kmm) <= hmld(ji,jj) ) THEN 
    233229               z1_dep = 1. / ( zdepmoy(ji,jj) + rtrn ) 
    … …  
    283279         pe3(:,:,1) = zqsr(:,:) 
    284280         ! 
    285          DO jk = 2, nksrp + 1 
     281         DO jk = 2, nksr + 1 
    286282            DO jj = 1, jpj 
    287283               DO ji = 1, jpi 
    … …  
    302298        pe3(:,:,1) = zqsr(:,:) * EXP( -0.5 * ekr(:,:,1) ) 
    303299        ! 
    304         DO_3D( 1, 1, 1, 1, 2, nksrp ) 
     300        DO_3D( 1, 1, 1, 1, 2, nksr ) 
    305301           pe1(ji,jj,jk) = pe1(ji,jj,jk-1) * EXP( -0.5 * ( ekb(ji,jj,jk-1) + ekb(ji,jj,jk) ) ) 
    306302           pe2(ji,jj,jk) = pe2(ji,jj,jk-1) * EXP( -0.5 * ( ekg(ji,jj,jk-1) + ekg(ji,jj,jk) ) ) 
    … …  
    400396         ntimes_par = iom_getszuld( numpar )   ! get number of record in file 
    401397      ENDIF 
    402       ! 
    403       CALL trc_oce_rgb( xkrgb )                  ! tabulated attenuation coefficients 
    404       nksrp = trc_oce_ext_lev( r_si2, 0.33e2_wp )     ! max level of light extinction (Blue Chl=0.01) 
    405       ! 
    406       IF(lwp) WRITE(numout,*) '        level of light extinction = ', nksrp, ' ref depth = ', gdepw_1d(nksrp+1), ' m' 
    407398      ! 
    408399                         ekr      (:,:,:) = 0._wp 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/TOP/PISCES/P4Z/p4zsed.F90

    r13295 r13571  
    313313      ENDIF 
    314314      ! 
    315       IF(sn_cfctl%l_prttrc) THEN  ! print mean trends (USEd for debugging) 
     315      IF(sn_cfctl%l_prttrc) THEN  ! print mean trneds (USEd for debugging) 
    316316         WRITE(charout, fmt="('sed ')") 
    317317         CALL prt_ctl_info( charout, cdcomp = 'top' ) 
    … …  
    366366      lk_sed = ln_sediment .AND. ln_sed_2way  
    367367      ! 
     368      nitrpot(:,:,jpk) = 0._wp   ! define last level for iom_put 
     369      ! 
    368370   END SUBROUTINE p4z_sed_init 
    369371 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/TOP/PISCES/P4Z/p4zsms.F90

    r13295 r13571  
    6969      REAL(wp), ALLOCATABLE, DIMENSION(:,:    ) :: zw2d 
    7070      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:  ) :: zw3d 
    71       REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) ::   ztrdt   ! 4D workspace 
     71      REAL(wp), DIMENSION(jpi,jpj,jpk,jp_pisces) :: ztrbbio 
    7272 
    7373      !!--------------------------------------------------------------------- 
    … …  
    9393      rfact = rDt_trc 
    9494      ! 
    95       ! trends computation initialisation 
    96       IF( l_trdtrc )  THEN 
    97          ALLOCATE( ztrdt(jpi,jpj,jpk,jp_pisces) )  !* store now fields before applying the Asselin filter 
    98          ztrdt(:,:,:,:)  = tr(:,:,:,:,Kmm) 
    99       ENDIF 
    100       ! 
    101  
    10295      IF( ( ln_top_euler .AND. kt == nittrc000 )  .OR. ( .NOT.ln_top_euler .AND. kt <= nittrc000 + 1 ) ) THEN 
    10396         rfactr  = 1. / rfact 
    … …  
    117110         END DO 
    118111      ENDIF 
     112 
     113      DO jn = jp_pcs0, jp_pcs1              !   Store the tracer concentrations before entering PISCES 
     114         ztrbbio(:,:,:,jn) = tr(:,:,:,jn,Kbb) 
     115      END DO 
     116 
    119117      ! 
    120118      IF( ll_bc )    CALL p4z_bc( kt, Kbb, Kmm, Krhs )   ! external sources of nutrients  
    … …  
    198196         END DO 
    199197         ! 
    200          IF( ln_top_euler ) THEN 
    201             DO jn = jp_pcs0, jp_pcs1 
    202                tr(:,:,:,jn,Kmm) = tr(:,:,:,jn,Kbb) 
    203             END DO 
    204          ENDIF 
     198      END DO 
     199      ! 
     200#endif 
     201      ! 
     202      IF( ln_sediment ) THEN  
     203         ! 
     204         CALL sed_model( kt, Kbb, Kmm, Krhs )     !  Main program of Sediment model 
     205         ! 
     206      ENDIF 
     207      ! 
     208      DO jn = jp_pcs0, jp_pcs1 
     209         tr(:,:,:,jn,Krhs) = ( tr(:,:,:,jn,Kbb) - ztrbbio(:,:,:,jn) ) * rfactr 
     210         tr(:,:,:,jn,Kbb ) = ztrbbio(:,:,:,jn) 
     211         ztrbbio(:,:,:,jn) = 0._wp 
    205212      END DO 
    206213      ! 
    207214      IF( l_trdtrc ) THEN 
    208215         DO jn = jp_pcs0, jp_pcs1 
    209            ztrdt(:,:,:,jn) = ( tr(:,:,:,jn,Kbb) - ztrdt(:,:,:,jn) ) * rfactr  
    210216           CALL trd_trc( tr(:,:,:,jn,Krhs), jn, jptra_sms, kt, Kmm )   ! save trends 
    211217         END DO 
    212          DEALLOCATE( ztrdt )  
    213218      END IF 
    214 #endif 
    215       ! 
    216       IF( ln_sediment ) THEN  
    217          ! 
    218          CALL sed_model( kt, Kbb, Kmm, Krhs )     !  Main program of Sediment model 
    219          ! 
    220          IF( ln_top_euler ) THEN 
    221             DO jn = jp_pcs0, jp_pcs1 
    222                tr(:,:,:,jn,Kmm) = tr(:,:,:,jn,Kbb) 
    223             END DO 
    224          ENDIF 
    225          ! 
    226       ENDIF 
    227       ! 
     219      !   
    228220      IF( lrst_trc )  CALL p4z_rst( kt, Kbb, Kmm,  'WRITE' )           !* Write PISCES informations in restart file  
    229221      ! 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/TOP/PISCES/P4Z/p5zlim.F90

    r13295 r13571  
    306306         &          / (xqndmax(ji,jj,jk) - 2. * xqndmin(ji,jj,jk) ) )   & 
    307307         &          * xqndmax(ji,jj,jk) / (zration + rtrn) 
    308          zlim3    = tr(ji,jj,jk,jpsil,Kbb) / ( tr(ji,jj,jk,jpsil,Kbb) + xksi(ji,jj) ) 
     308         zlim3    = tr(ji,jj,jk,jpsil,Kbb) / ( tr(ji,jj,jk,jpsil,Kbb) + xksi(ji,jj) + rtrn ) 
    309309         zlim4    = MAX( 0., ( zratiof - zqfemd ) / qfdopt ) 
    310310         xlimdfe(ji,jj,jk) = MIN( 1., zlim4 ) 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/TOP/TRP/trcrad.F90

    r13295 r13571  
    168168              IF( l_trdtrc )   ztrtrd(:,:,:) = ptr(:,:,:,jn,itime)                       ! save input tr(:,:,:,:,Kbb) for trend computation            
    169169              ! 
    170               DO_3D( 1, 1, 1, 1, 1, jpkm1 ) 
     170              DO_3D( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpkm1 ) 
    171171                 IF( ztrneg(ji,jj,jn) /= 0. ) THEN                                 ! if negative values over the 3x3 box 
    172172                    ! 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/TOP/TRP/trdmxl_trc.F90

    r13295 r13571  
    148148         ! ... Weights for vertical averaging 
    149149         wkx_trc(:,:,:) = 0.e0 
    150          DO_3D( 1, 1, 1, 1, 1, jpktrd_trc ) 
     150         DO_3D( 1, 1, 1, 1, 1, jpktrd_trc )                       ! initialize wkx_trc with vertical scale factor in mixed-layer 
    151151            IF( jk - nmld_trc(ji,jj) < 0 )   wkx_trc(ji,jj,jk) = e3t(ji,jj,jk,Kmm) * tmask(ji,jj,jk) 
    152152         END_3D 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/TOP/oce_trc.F90

    r13286 r13571  
    8585   USE traqsr  , ONLY :   rn_abs     =>    rn_abs     !: fraction absorbed in the very near surface 
    8686   USE traqsr  , ONLY :   rn_si0     =>    rn_si0     !: very near surface depth of extinction 
     87   USE traqsr  , ONLY :   nksr       =>    nksr       !: levels below which the light cannot penetrate (depth larger than 391 m) 
     88   USE traqsr  , ONLY :   rkrgb      =>    rkrgb      !: tabulated attenuation coefficients for RGB absorption 
    8789   USE traqsr  , ONLY :   ln_qsr_bio =>    ln_qsr_bio !: flag to use or not the biological fluxes for light 
    8890   USE sbcrnf  , ONLY :   rnfmsk     =>    rnfmsk     !: mixed adv scheme in runoffs vicinity (hori.)  

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/TOP/trc.F90

    r12489 r13571  
    2121   INTEGER, PUBLIC ::   numonr     = -1   !: reference passive tracer namelist output output.namelist.top 
    2222   INTEGER, PUBLIC ::   numstr            !: tracer statistics 
    23    INTEGER, PUBLIC ::   numrtr            !: trc restart (read ) 
     23   INTEGER, PUBLIC ::   numrtr     = -1   !: trc restart (read ) 
    2424   INTEGER, PUBLIC ::   numrtw            !: trc restart ( write ) 
    2525   CHARACTER(:), ALLOCATABLE, PUBLIC ::   numnat_ref   !: character buffer for reference passive tracer namelist_top_ref 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/TOP/trcbdy.F90

    r13226 r13571  
    4949      INTEGER                           :: ib_bdy ,ir, jn ,igrd ! Loop indices 
    5050      REAL(wp), POINTER, DIMENSION(:,:) ::  ztrc 
    51       REAL(wp), POINTER                 ::  zfac 
    5251      LOGICAL                           :: llrim0               ! indicate if rim 0 is treated 
    5352      LOGICAL, DIMENSION(4)             :: llsend1, llrecv1     ! indicate how communications are to be carried out 
    … …  
    6160         IF( ir == 0 ) THEN   ;   llrim0 = .TRUE. 
    6261         ELSE                 ;   llrim0 = .FALSE. 
    63          END IF 
     62         ENDIF 
    6463         DO ib_bdy=1, nb_bdy 
     64            ! 
    6565            DO jn = 1, jptra 
    6666               ! 
    67                ztrc => trcdta_bdy(jn,ib_bdy)%trc  
    68                zfac => trcdta_bdy(jn,ib_bdy)%rn_fac 
     67               IF( ASSOCIATED(trcdta_bdy(jn,ib_bdy)%trc) .AND. trcdta_bdy(jn,ib_bdy)%cn_obc /= 'neumann' ) THEN 
     68                  IF( .NOT. ASSOCIATED(ztrc) )   ALLOCATE( ztrc(idx_bdy(ib_bdy)%nblen(igrd),jpk) ) 
     69                  ztrc(:,:) = trcdta_bdy(jn,ib_bdy)%trc(:,:) * trcdta_bdy(jn,ib_bdy)%rn_fac 
     70               ENDIF 
    6971               ! 
    70                SELECT CASE( TRIM(trcdta_bdy(jn,ib_bdy)%cn_obc) ) 
     72               SELECT CASE( trcdta_bdy(jn,ib_bdy)%cn_obc ) 
    7173               CASE('none'        )   ;   CYCLE 
    7274               CASE('frs'         )   ! treat the whole boundary at once 
    73                   IF( ir == 0 ) CALL bdy_frs( idx_bdy(ib_bdy),                tr(:,:,:,jn,Krhs), ztrc*zfac ) 
     75                  IF( ir == 0 )           CALL bdy_frs( idx_bdy(ib_bdy),                   tr(:,:,:,jn,Krhs), ztrc ) 
    7476               CASE('specified'   )   ! treat the whole rim      at once 
    75                   IF( ir == 0 ) CALL bdy_spe( idx_bdy(ib_bdy),                tr(:,:,:,jn,Krhs), ztrc*zfac ) 
    76                CASE('neumann'     )   ;   CALL bdy_nmn( idx_bdy(ib_bdy), igrd         , tr(:,:,:,jn,Krhs) )   ! tra masked 
    77                CASE('orlanski'    )   ;   CALL bdy_orl( idx_bdy(ib_bdy), tr(:,:,:,jn,Kbb), tr(:,:,:,jn,Krhs), ztrc*zfac, ll_npo=.false. ) 
    78                CASE('orlanski_npo')   ;   CALL bdy_orl( idx_bdy(ib_bdy), tr(:,:,:,jn,Kbb), tr(:,:,:,jn,Krhs), ztrc*zfac, ll_npo=.true. ) 
     77                  IF( ir == 0 )           CALL bdy_spe( idx_bdy(ib_bdy),                   tr(:,:,:,jn,Krhs), ztrc ) 
     78               CASE('neumann'     )   ;   CALL bdy_nmn( idx_bdy(ib_bdy), igrd            , tr(:,:,:,jn,Krhs),       llrim0 )   ! tra masked 
     79               CASE('orlanski'    )   ;   CALL bdy_orl( idx_bdy(ib_bdy), tr(:,:,:,jn,Kbb), tr(:,:,:,jn,Krhs), ztrc, llrim0,   & 
     80                  &                                     ll_npo=.FALSE. ) 
     81               CASE('orlanski_npo')   ;   CALL bdy_orl( idx_bdy(ib_bdy), tr(:,:,:,jn,Kbb), tr(:,:,:,jn,Krhs), ztrc, llrim0,   & 
     82                  &                                     ll_npo=.TRUE.  ) 
    7983               CASE DEFAULT           ;   CALL ctl_stop( 'trc_bdy : unrecognised option for open boundaries for passive tracers' ) 
    8084               END SELECT 
    8185               ! 
    8286            END DO 
     87            ! 
     88            IF( ASSOCIATED(ztrc) )   DEALLOCATE(ztrc) 
     89            ! 
    8390         END DO 
    8491         ! 
    8592         IF( nn_hls > 1 .AND. ir == 1 ) CYCLE   ! at least 2 halos will be corrected -> no need to correct rim 1 before rim 0 
    86          IF( nn_hls == 1 ) THEN   ;   llsend1(:) = .false.   ;   llrecv1(:) = .false.   ;   END IF 
     93         IF( nn_hls == 1 ) THEN   ;   llsend1(:) = .false.   ;   llrecv1(:) = .false.   ;   ENDIF 
    8794         DO ib_bdy=1, nb_bdy 
    88             SELECT CASE( TRIM(cn_tra(ib_bdy)) ) 
     95            SELECT CASE( cn_tra(ib_bdy) ) 
    8996            CASE('neumann') 
    9097               llsend1(:) = llsend1(:) .OR. lsend_bdyint(ib_bdy,1,:,ir)   ! possibly every direction, T points 
    … …  
    97104         IF( ANY(llsend1) .OR. ANY(llrecv1) ) THEN   ! if need to send/recv in at least one direction 
    98105            CALL lbc_lnk( 'trcbdy', tr(:,:,:,:,Krhs), 'T',  1.0_wp, kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) 
    99          END IF 
     106         ENDIF 
    100107         ! 
    101108      END DO   ! ir 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/TOP/trcdta.F90

    r13295 r13571  
    199199               WRITE(numout,*) 'trc_dta: interpolates passive tracer data onto the s- or mixed s-z-coordinate mesh' 
    200200            ENDIF 
    201             DO_2D( 1, 1, 1, 1 ) 
     201            DO_2D( 1, 1, 1, 1 )                 ! vertical interpolation of T & S 
    202202               DO jk = 1, jpk                        ! determines the intepolated T-S profiles at each (i,j) points 
    203203                  zl = gdept(ji,jj,jk,Kmm) 

  • NEMO/branches/2020/dev_r13296_HPC-07_mocavero_mpi3/src/TOP/trcrst.F90

    r13286 r13571  
    237237               ! calculate start time in hours and minutes 
    238238               zdayfrac=adatrj-INT(adatrj) 
    239                ksecs = NINT(zdayfrac*86400)            ! Nearest second to catch rounding errors in adatrj               
     239               ksecs = NINT(zdayfrac*86400)            ! Nearest second to catch rounding errors in adatrj 
    240240               ihour = INT(ksecs/3600) 
    241241               iminute = ksecs/60-ihour*60 
    … …  
    258258               adatrj = INT(adatrj)                    ! adatrj set to integer as nn_time0 updated             
    259259             ELSE 
     260               ndt05 = NINT( 0.5 * rn_Dt  )   !  --- WARNING --- not defined yet are we did not go through day_init 
    260261               ! parameters corresponding to nit000 - 1 (as we start the step 
    261262               ! loop with a call to day) 
    262                ndastp = ndate0 - 1       ! ndate0 read in the namelist in dom_nam 
     263               ndastp = ndate0        ! ndate0 read in the namelist in dom_nam 
    263264               nhour   =   nn_time0 / 100 
    264265               nminute = ( nn_time0 - nhour * 100 ) 
Note: See TracChangeset for help on using the changeset viewer.