SISVAT.f90

Go to the documentation of this file.

      subroutine sisvat_ini
 
!--------------------------------------------------------------------------+
!                                                                          |
!   MAR          SISVAT_ini                           Wed 26-Jun-2013  MAR |
!     SubRoutine SISVAT_ini generates non time dependant SISVAT parameters |
!                                                                          |
!     version 3.p.4.1 created by H. Gallee,           Tue  5-Feb-2013      |
!           Last Modification by H. Gallee,           Wed 26-Jun-2013      |
!                                                                          |
!--------------------------------------------------------------------------+
!                                                                          |
!     PARAMETERS:  kcolv: Total Number of columns =                        |
!     ^^^^^^^^^^        = Total Number of continental     grid boxes       |
!                       X       Number of Mosaic Cell per grid box         |
!                                                                          |
!     INPUT:   dt__SV   : Time  Step                                   [s] |
!     ^^^^^    dz_dSV   : Layer Thickness                              [m] |
!                                                                          |
!     OUTPUT:  RF__SV   : Root Fraction in Layer isl                   [-] |
!     ^^^^^^   rocsSV   : Soil Contrib. to (ro c)_s exclud.Water  [J/kg/K] |
!              etamSV   : Soil Minimum Humidity                    [m3/m3] |
!                        (based on a prescribed Soil Relative Humidity)    |
!              s1__SV   : Factor of eta**( b+2) in Hydraul.Diffusiv.       |
!              s2__SV   : Factor of eta**( b+2) in Hydraul.Conduct.        |
!              aKdtSV   : KHyd: Piecewise Linear Profile:  a * dt    [m]   |
!              bKdtSV   : KHyd: Piecewise Linear Profile:  b * dt    [m/s] |
!              dzsnSV(0): Soil first Layer Thickness                   [m] |
!              dzmiSV   : Distance between two contiguous levels       [m] |
!              dz78SV   : 7/8 (Layer Thickness)                        [m] |
!              dz34SV   : 3/4 (Layer Thickness)                        [m] |
!              dz_8SV   : 1/8 (Layer Thickness)                        [m] |
!              dzAvSV   : 1/8  dz_(i-1) + 3/4 dz_(i) + 1/8 dz_(i+1)    [m] |
!              dtz_SV   : dt/dz                                      [s/m] |
!              OcndSV   : Swab Ocean / Soil Ratio                      [-] |
!              Implic   : Implicit Parameter  (0.5:  Crank-Nicholson)      |
!              Explic   : Explicit Parameter = 1.0 - Implic                |
!                                                                          |
!                                                                          |
!     Preprocessing  Option: STANDARD Possibility                          |
!     ^^^^^^^^^^^^^^^^^^^^^  ^^^^^^^^^^^^^^^^^^^^                          |
!     #SH: Soil /Vegetation Model: Hapex-Sahel   Vegetation     DATA       |
!                                                                          |
!                                                                          |
!     Preprocessing  Option:                                               |
!     ^^^^^^^^^^^^^^^^^^^^^                                                |
!     #ER: Richards Equation is not smoothed                               |
!     #kd: Soil: De Ridder Discretization is forced                        |
!                                                                          |
!--------------------------------------------------------------------------+
 
 
! Global  Variables
! =================
 
      use mod_real
      use mod_phy____dat
      use mod_phy____grd
      use mod_sisvat_grd
      use mod_sisvat_ctr
 
 
 
! General Variables
! =================
 
      use mod_sisvat_dat
      use mod_sisvat_dzs
      use mod_sisvat_kkl
 
 
      IMPLICIT NONE
 
 
 
! Internal Variables
! ==================
 
      integer           ::  ivt   ,ist   ,ikl,ikv   ,isl   ,isn   ,ikh
      integer           ::  misl_2,nisl_2
      real(kind=real8)  ::  zDepth
      real(kind=real8)  ::  d__eta,eta__1,eta__2,Khyd_1,Khyd_2
      real(kind=real8)  ::  RHsMin=0.001                    ! Min.Soil Relative Humidity
      real(kind=real8)  ::  PsiMax                          ! Max.Soil Water    Potential
      real(kind=real8)  ::  a_Khyd,b_Khyd                   ! Piecewis.Water Conductivity
 
! OUTPUT/Verification: Soil Vertic.Discret.
! #kw real(kind=real8)  ::  Khyd_x,Khyd_y
 
 
 
! Non Time Dependant SISVAT parameters
! ====================================
 
! Decay of Angle(Wind,Sastrugi) Influence on z0 (Andreas, 1995, CCREL report 95-16)
! ---------------------------------------------
 
! #Za   Adz0dt = exp(-dt__SV/43200.)
 
 
! Soil Discretization
! -------------------
 
! Numerical Scheme Parameters
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^
        implic = 0.75                           ! 0.5  <==> Crank-Nicholson
        explic = 1.00 - implic                  !
 
! Soil/Snow Layers Indices
! ^^^^^^^^^^^^^^^^^^^^^^^^
      DO  isl=-nsoil,0
        islpsv(isl) =            isl+1
        islpsv(isl) = min(       islpsv(isl),0)
        islmsv(isl) =            isl-1
        islmsv(isl) = max(-nsoil,islmsv(isl))
      END DO
 
      DO  isn=1,nsnow
        isnpsv(isn) =           isn+1
        isnpsv(isn) = min(      isnpsv(isn),nsnow)
      END DO
 
! Soil      Layers Thicknesses: De Ridder discretization
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^  ^^^^^^^^^^^^^^^^^^^^^^^^
! #kd IF (nsoil.gt.4)                                             THEN
! #kd   DO isl=-5,-nsoil,-1
! #kd     dz_dSV(isl)=   1.
! #kd   END DO
! #kd END IF
 
! Soil      Layers Thicknesses: standard  discretization
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^  ^^^^^^^^^^^^^^^^^^^^^^^^
      IF (nsoil.ne.4)                                             THEN
        DO isl= 0,-nsoil,-1
          misl_2 =     -mod(isl,2)
          nisl_2 =         -isl/2
          dz_dsv(isl)=(((1-misl_2) * 0.001                              &
     &                  +  misl_2  * 0.003) * 10**(nisl_2)) * 4.
!         dz_dSV(0)  =         Hapex-Sahel Calibration:       4 mm
 
        END DO
! tun     dz_dSV(0)  =               0.001
! tun     dz_dSV(-1) = dz_dSV(-1)  - dz_dSV(0)          + 0.004
      END IF
 
        zz_dsv      = 0.
      DO  isl=-nsoil,0
        dzmisv(isl) = 0.500*(dz_dsv(isl)        +dz_dsv(islmsv(isl)))
        dziisv(isl) = 0.500* dz_dsv(isl)        /dzmisv(isl)
        dzi_sv(isl) = 0.500* dz_dsv(islmsv(isl))/dzmisv(isl)
        dtz_sv(isl) =        dt__sv             /dz_dsv(isl)
        dz78sv(isl) = 0.875* dz_dsv(isl)
        dz34sv(isl) = 0.750* dz_dsv(isl)
        dz_8sv(isl) = 0.125* dz_dsv(isl)
        dzavsv(isl) = 0.125* dz_dsv(islmsv(isl))                        &
     &              + 0.750* dz_dsv(isl)                                &
     &              + 0.125* dz_dsv(islpsv(isl))
 
! Richards Equation is not smoothed
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
! #ER   dz78SV(isl) =        dz_dSV(isl)
! #ER   dz34SV(isl) =        dz_dSV(isl)
! #ER   dz_8SV(isl) = 0.
! #ER   dzAvSV(isl) =        dz_dSV(isl)
 
        zz_dsv      = zz_dsv+dz_dsv(isl)
      END DO
 
      DO ikl=1,kcolp
      DO ikv=1,mwp
        dzsnsv(ikl,ikv,0) =      dz_dsv(0)
      END DO
      END DO
 
! Conversion to a 50 m Swab Ocean Discretization
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
        ocndsv = 0.
      DO isl=-nsoil,0
        ocndsv = ocndsv +dz_dsv(isl)
      END DO
        ocndsv = 50.    /ocndsv
 
 
! Secondary Vegetation Parameters
! -------------------------------
 
! Minimum Stomatal Resistance (Hapex Sahel Data)
! (Taylor et al. 1997, J.Hydrol 188-189, p.1047)
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
      DO ivg=1,3                       !
        stodsv(ivg) = 210.             ! Millet
      END DO                           !
        stodsv(  4) = 120.             ! Sparse Tiger Bush
      DO ivg=5,6                       !
        stodsv(ivg) =  80.             ! Dense  Tiger Bush
      END DO                           !
        stodsv(  7) =  80.             ! Low    Trees (Fallow)
        stodsv( 10) =  80.             !
 
! Minimum Stomatal Resistance (Tropical Forest)
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
        stodsv(  8) =  60.             ! Medium Trees
        stodsv( 11) =  60.             !
        stodsv(  9) =  40.             ! High   Trees
        stodsv( 12) =  40.             !
 
! Root Fraction
! ^^^^^^^^^^^^^
!    * GENERAL REFERENCE
!      Jackson et al., 1996: A global analysis of root distributions for
!      terrestrial biomes. In Oecologia, 108, 389-411.
 
!    * ROOT PROFILE
!      The cumulative root fraction Y is given by
!          Y = 1 - beta**d   with d    the depth (in cm),
!                                 beta a coefficient (vegetation dependent).
 
!    * BETA VALUES (for 11 world biomes)
!    1  boreal forest                0.943
!    2  crops                        0.961
!    3  desert                       0.975
!    4  sclerophyllous shrubs        0.964
!    5  temperate coniferous forest  0.976
!    6  temperate deciduous forest   0.966
!    7  temperate grassland          0.943
!    8  tropical deciduous forest    0.961
!    9  tropical evergreen forest    0.962
!    10 tropical grassland savanna   0.972
!    11 tundra                       0.914
 
!    * ADVISED BETA VALUES FOR MAR
!      (see 'block data SISVAT_dat', variable rbtdSV)
!
!      SVAT veg. type         default      West Africa
!      0  barren soil         0.000        0.000
!      1  crops low           0.961 (2)    0.961 (2)
!      2  crops medium        0.961 (2)    0.961 (2)
!      3  crops high          0.961 (2)    0.961 (2)
!      4  grass low           0.943 (7)    0.943 (7)
!      5  grass medium        0.943 (7)    0.964 (4)
!      6  grass high          0.943 (7)    0.972 (10)
!      7  broadleaf low       0.966 (6)    0.968 (4,10)
!      8  broadleaf medium    0.966 (6)    0.962 (8,9)
!      9  broadleaf high      0.966 (6)    0.962 (8,9)
!      10 needleleaf low      0.976 (5)    0.971 (5,6)
!      11 needleleaf medium   0.976 (5)    0.976 (5)
!      12 needleleaf high     0.976 (5)    0.976 (5)
 
!      Numbers between brackets refer to Jackson's biomes. For more details
!      about some choices, see the correspondance between the IGBP and SVAT
!      vegetation classes (i.e. in NESTOR).
 
!    * WARNING
!      Most of the roots are located in the first 2 m of soil. The root
!      fraction per layer depends on the definition of the soil layer
!      thickness. It will get wrong if a thick layer is defined around 2 m
!      deep.
 
      write(*,'(/a)') 'ROOT PROFILES (Jackson, 1996) :'
 
      DO ivt = 0, nvgt
        zdepth = 0.
        DO isl = 0, -nsoil, -1
          IF (ivt .ne. 0) THEN
            rf__sv(ivt,isl) =  rbtdsv(ivt)**zdepth *                    &
     &                         (1. - rbtdsv(ivt)**(dz_dsv(isl)*100) )
            zdepth = zdepth + dz_dsv(isl)*100  !in cm
          ELSE
            rf__sv(ivt,isl) = 0.
          END IF
        END DO
        write(*,'(a,i2,a,i3,a,99f10.5:)')                               &
     &       '  RF__SV(', ivt, ',',-nsoil, ':0) =', rf__sv(ivt,:)
      END DO
      write(6,6600)
 6600 format(                                                           &
     &  '  NOTE: If root fraction is not close to 0  around 2 m deep,', &
     &/,'        Then you should redefine the soil layer thicknesses.', &
     &/,'        See the code for more details.')
 
 
! Secondary Soil       Parameters
! -------------------------------
 
      DO  ist=0,nsot
         rocssv(ist)=(1.0-etadsv(ist))*1.2e+6  ! Soil Contrib. to (ro c)_s
         s1__sv(ist)=     bchdsv(ist)         &! Factor of (eta)**(b+2)
     &  *psidsv(ist)     *ks_dsv(ist)         &!    in DR97, Eqn.(3.36)
     & /(etadsv(ist)**(   bchdsv(ist)+3.))     !
         s2__sv(ist)=     ks_dsv(ist)         &! Factor of (eta)**(2b+3)
     & /(etadsv(ist)**(2.*bchdsv(ist)+3.))     !    in DR97, Eqn.(3.35)
 
! Soil Minimum Humidity (from a prescribed minimum relative Humidity)
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
         psimax = -(log(rhsmin))/7.2e-5        ! DR97, Eqn 3.15 Inversion
         etamsv(ist) =  etadsv(ist)           &!
     &         *(psimax/psidsv(ist))**(-min(10.,1./bchdsv(ist)))
      END DO
         etamsv(12)  =  0.
 
! Piecewise Hydraulic Conductivity Profiles
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
      DO   ist=0,nsot
 
! OUTPUT/Verification: Soil Vertic.Discret.
! #kw     write(6,6000)
 6000     format(' Type |    etaSat | No |    eta__1 |    eta__2 |',    &
     &           '    Khyd_1 |    Khyd_x |    Khyd_2 |    Khyd_y |',    &
     &         /,' -----+-----------+----+-----------+-----------+',    &
     &           '-----------+-----------+-----------+-----------+')
 
          d__eta          =  etadsv(ist)/nkhy
          eta__1          =  0.
          eta__2          =  d__eta
        DO ikh=0,nkhy
          khyd_1          =  s2__sv(ist)            &! DR97, Eqn.(3.35)
     &  *(eta__1      **(2. *bchdsv(ist)+3.))        !
          khyd_2          =  s2__sv(ist)            &!
     &  *(eta__2      **(2. *bchdsv(ist)+3.))        !
 
          a_khyd          = (khyd_2-khyd_1)/d__eta   !
          b_khyd          =  khyd_1-a_khyd *eta__1   !
 
          akdtsv(ist,ikh) =  a_khyd       * dt__sv   !
          bkdtsv(ist,ikh) =  b_khyd       * dt__sv   !
 
! OUTPUT/Verification: Soil Vertic.Discret.
! #kw     Khyd_x          =  a_Khyd*eta__1 +b_Khyd   !
! #kw     Khyd_y          =  a_Khyd*eta__2 +b_Khyd   !
! #kw     write(6,6001) ist,etadSV(ist),ikh,eta__1, &!
! #kw&          eta__2,Khyd_1,Khyd_x,Khyd_2,Khyd_y   !
 6001     format(i5,' |',e10.2,' |',i3,' |',        &!
     &                 6(e10.2,' |'))
 
          eta__1          = eta__1  + d__eta
          eta__2          = eta__2  + d__eta
        END DO
      END DO
 
 
      return
      end subroutine sisvat_ini
 
 
 
      subroutine sisvat(jjtime,kcolw)
 
!--------------------------------------------------------------------------+
!   MAR          SISVAT                               Sat 29-Jun-2013  MAR |
!     SubRoutine SISVAT contains the fortran 77 code of the                |
!                Soil/Ice Snow Vegetation Atmosphere Transfer Scheme       |
!                                                                          |
!     version 3.p.4.1 created by H. Gallee,           Thu 14-Feb-2013      |
!           Last Modification by H. Gallee,           Sat 29-Jun-2013      |
!                                                                          |
!--------------------------------------------------------------------------+
!     PARAMETERS:  kcolv: Total Number of columns =                        |
!     ^^^^^^^^^^        = Total Number of continental     grid boxes       |
!                       X       Number of Mosaic Cell per grid box         |
!                                                                          |
!     INPUT:   daHost   : Date Host Model                                  |
!     ^^^^^                                                                |
!                                                                          |
!     INPUT:   LSmask   : 1:          Land       MASK                      |
!     ^^^^^               0:          Sea        MASK                      |
!              ivgtSV   = 0,...,12:   Vegetation Type                      |
!              isotSV   = 0,...,12:   Soil       Type                      |
!                         0:          Water,          Liquid (Sea, Lake)   |
!                        12:          Water, Solid           (Ice)         |
!                                                                          |
!     INPUT:   coszSV   : Cosine of the Sun Zenithal Distance          [-] |
!     ^^^^^    sol_SV   : Surface Downward  Solar      Radiation    [W/m2] |
!              IRd_SV   : Surface Downward  Longwave   Radiation    [W/m2] |
!              drr_SV   : Rain  Intensity                        [kg/m2/s] |
!              dsn_SV   : Snow  Intensity                      [mm w.e./s] |
!              dsnbSV   : Snow  Intensity,  Drift Fraction             [-] |
!              dbs_SV   : Drift Amount                           [mm w.e.] |
!              za__SV   : Surface Boundary Layer (SBL) Height          [m] |
!              VV__SV   :(SBL Top)   Wind Velocity                   [m/s] |
!              TaT_SV   : SBL Top    Temperature                       [K] |
!              rhT_SV   : SBL Top    Air  Density                  [kg/m3] |
!              QaT_SV   : SBL Top    Specific  Humidity            [kg/kg] |
!              qsnoSV   : SBL Mean   Snow      Content             [kg/kg] |
!              LAI0SV   : Leaf Area  Index                             [-] |
!              glf0SV   : Green Leaf Fraction                          [-] |
!              alb0SV   : Soil Basic Albedo                            [-] |
!              dt__SV   : Time  Step                                   [s] |
!                                                                          |
!     INPUT /  isnoSV   = total Nb of Ice/Snow Layers                      |
!     OUTPUT:  ispiSV   = 0,...,nsno: Uppermost Superimposed Ice Layer     |
!     ^^^^^^   iiceSV   = total Nb of Ice      Layers                      |
!              istoSV   = 0,...,5 :   Snow     History (see istdSV data)   |
!                                                                          |
!     INPUT /  alb_SV   : Surface-Canopy Albedo                        [-] |
!     OUTPUT:  emi_SV   : Surface-Canopy Emissivity                    [-] |
!     ^^^^^^   IRs_SV   : Soil           IR Flux  (negative)        [W/m2] |
!              LMO_SV   : Monin-Obukhov               Scale            [m] |
!              us__SV   : Friction          Velocity                 [m/s] |
!              uts_SV   : Temperature       Turbulent Scale          [m/s] |
!              uqs_SV   : Specific Humidity Velocity                 [m/s] |
!              uss_SV   : Blowing Snow      Turbulent Scale          [m/s] |
!              usthSV   : Blowing Snow      Erosion   Threshold      [m/s] |
!              Z0m_SV   : Momentum     Roughness Length                [m] |
!              Z0mmSV   : Momentum     Roughness Length (time mean)    [m] |
!              Z0mnSV   : Momentum     Roughness Length (instantaneous)[m] |
!              Z0SaSV   : Sastrugi     Roughness Length                [m] |
!              Z0e_SV   : Erosion Snow Roughness Length                [m] |
!              Z0emSV   : Erosion Snow Roughness Length (time mean)    [m] |
!              Z0enSV   : Erosion Snow Roughness Length (instantaneous)[m] |
!              Z0roSV   : Subgrid Topo Roughness Length                [m] |
!              Z0h_SV   : Heat         Roughness Length                [m] |
!              snCaSV   : Canopy   Snow     Thickness            [mm w.e.] |
!              rrCaSV   : Canopy   Water    Content                [kg/m2] |
!              psivSV   : Leaf     Water    Potential                  [m] |
!              TvegSV   : Canopy   Temperature                         [K] |
!              TsisSV   : Soil/Ice Temperatures (layers -nsoil ,...,0)     |
!                       & Snow     Temperatures (layers  1,2,..,nsnow) [K] |
!              ro__SV   : Soil/Snow Volumic Mass                   [kg/m3] |
!              eta_SV   : Soil/Snow Water   Content                [m3/m3] |
!              G1snSV   : snow dendricity/sphericity                       |
!              G2snSV   : snow sphericity/grain size                       |
!              dzsnSV   : Snow Layer        Thickness                  [m] |
!              agsnSV   : Snow       Age                             [day] |
!              BufsSV   : Snow Buffer Layer              [kg/m2] .OR. [mm] |
!              BrosSV   : Snow Buffer Layer Density      [kg/m3]           |
!              BG1sSV   : Snow Buffer Layer Dendricity / Sphericity    [-] |
!              BG2sSV   : Snow Buffer Layer Sphericity / Size [-] [0.1 mm] |
!              rusnSV   : Surficial   Water              [kg/m2] .OR. [mm] |
!                                                                          |
!     OUTPUT:  no__SV   : OUTPUT file Unit Number                      [-] |
!     ^^^^^^   i___SV   : OUTPUT point   i Coordinate                  [-] |
!              j___SV   : OUTPUT point   j Coordinate                  [-] |
!              n___SV   : OUTPUT point   n Coordinate                  [-] |
!              lwriSV   : OUTPUT point vec Index                       [-] |
!                                                                          |
!     OUTPUT:  IRu_SV   : Upward     IR Flux (+, upw., effective)      [K] |
!     ^^^^^^   hSalSV   : Saltating Layer Height                       [m] |
!              qSalSV   : Saltating Snow  Concentration            [kg/kg] |
!              RnofSV   : RunOFF Intensity                       [kg/m2/s] |
!                                                                          |
!     Internal Variables:                                                  |
!     ^^^^^^^^^^^^^^^^^^                                                   |
!              NLaysv   = New            Snow Layer Switch             [-] |
!              albisv   : Snow/Ice/Water/Soil Integrated Albedo        [-] |
!              SoCasv   : Absorbed Solar Radiation by Canopy (Normaliz)[-] |
!              SoSosv   : Absorbed Solar Radiation by Surfac.(Normaliz)[-] |
!              tau_sv   : Fraction of Radiation transmitted by Canopy  [-] |
!              TBr_sv   : Brightness Temperature                       [K] |
!              IRupsv   : Upward     IR Flux (-, upw.)              [W/m2] |
!              IRv_sv   : Vegetation IR Flux                        [W/m2] |
!              rrMxsv   : Canopy Maximum Intercepted Rain          [kg/m2] |
!              Sigmsv   : Canopy Ventilation Factor                    [-] |
!              ram_sv   : Aerodynamic Resistance for Momentum        [s/m] |
!              rah_sv   : Aerodynamic Resistance for Heat            [s/m] |
!              HSv_sv   : Vegetation Sensible Heat Flux             [W/m2] |
!              HLv_sv   : Vegetation Latent   Heat Flux             [W/m2] |
!              Rootsv   : Root Water Pump                        [kg/m2/s] |
!              Evp_sv   : Evaporation                              [kg/m2] |
!              EvT_sv   : Evapotranspiration                       [kg/m2] |
!              HSs_sv   : Surface    Sensible Heat Flux + => absorb.[W/m2] |
!              HLs_sv   : Surface    Latent   Heat Flux + => absorb.[W/m2] |
!              Lx_H2O   : Latent Heat of Vaporization/Sublimation   [J/kg] |
!              Tsrfsv   : Surface    Temperature                       [K] |
!              LAI_sv   : Leaf Area  Index (snow included)             [-] |
!              LAIesv   : Leaf Area  Index (effective / transpiration) [-] |
!              glf_sv   : Green Leaf Fraction of NOT fallen Leaves     [-] |
!              sEX_sv   : Verticaly Integrated Extinction Coefficient  [-] |
!              LSdzsv   : Vertical   Discretization Factor             [-] |
!                       =    1. Soil                                       |
!                       = 1000. Ocean                                      |
!              z_snsv   : Snow Pack  Thickness                         [m] |
!              zzsnsv   : Snow Pack  Thickness                         [m] |
!              albssv   : Soil       Albedo                            [-] |
!              Evg_sv   : Soil+Vegetation Emissivity                   [-] |
!              Eso_sv   : Soil+Snow       Emissivity                   [-] |
!              psi_sv   : Soil       Water    Potential                [m] |
!              Khydsv   : Soil   Hydraulic    Conductivity           [m/s] |
!                                                                          |
!              ETVg_d   : VegetationEnergy Power         Forcing    [W/m2] |
!              ETSo_0   : Snow/Soil Energy Power, before Forcing    [W/m2] |
!              ETSo_1   : Snow/Soil Energy Power, after  Forcing    [W/m2] |
!              ETSo_d   : Snow/Soil Energy Power         Forcing    [W/m2] |
!              EqSn_0   : Snow      Energy, before Phase Change     [J/m2] |
!              EqSn_1   : Snow      Energy, after  Phase Change     [J/m2] |
!              EqSn_d   : Snow      Energy,       net    Forcing    [J/m2] |
!              Enrsvd   : SVAT      Energy Power         Forcing    [W/m2] |
!              Enrbal   : SVAT      Energy Balance                  [W/m2] |
!              Wats_0   : Soil Water,  before Forcing                 [mm] |
!              Wats_1   : Soil Water,  after  Forcing                 [mm] |
!              Wats_d   : Soil Water          Forcing                 [mm] |
!              SIWm_0   : Snow        initial Mass               [mm w.e.] |
!              SIWm_1   : Snow        final   Mass               [mm w.e.] |
!              SIWa_i   : Snow Atmos. initial Forcing            [mm w.e.] |
!              SIWa_f   : Snow Atmos. final   Forcing(noConsumed)[mm w.e.] |
!              SIWe_i   : SnowErosion initial Forcing            [mm w.e.] |
!              SIWe_f   : SnowErosion final   Forcing(noConsumed)[mm w.e.] |
!              SIsubl   : Snow sublimed/deposed  Mass            [mm w.e.] |
!              SImelt   : Snow Melted            Mass            [mm w.e.] |
!              SIrnof   : Surficial Water + Run OFF Change       [mm w.e.] |
!              SIvAcr   : Sea-Ice    vertical Acretion           [mm w.e.] |
!              Watsvd   : SVAT Water          Forcing                 [mm] |
!              Watbal   : SVAT Water  Balance                       [W/m2] |
!                                                                          |
!              dsn_Ca,snCa_n :     Snow Contribution to the Canopy[m w.e.] |
!              drr_Ca,rrCa_n,drip: Rain Contribution to the Canopy [kg/m2] |
!              vk2      : Square of Von Karman Constant                [-] |
!              sqrCm0   : Factor of   Neutral Drag Coeffic.Momentum  [s/m] |
!              sqrCh0   : Factor of   Neutral Drag Coeffic.Heat      [s/m] |
!              EmiVeg   : Vegetation    Emissivity                     [-] |
!              EmiSol   : Soil          Emissivity                     [-] |
!              EmiSno   : Snow          Emissivity                     [-] |
!              EmiWat   : Water         Emissivity                     [-] |
!              Z0mSea   :          Sea  Roughness Length               [m] |
!              Z0mLnd   :          Land Roughness Length               [m] |
!              sqrrZ0   : u*t/u*                                           |
!              f_eff    : Marticorena & B. 1995 JGR (20)                   |
!              A_Fact   : Fundamental * Roughness                          |
!              Z0mBSn   :         BSnow Roughness Length               [m] |
!              Z0mBS0   : Mimimum BSnow Roughness Length (blown* )     [m] |
!              Z0m_Sn   :          Snow Roughness Length (surface)     [m] |
!              Z0m_S0   : Mimimum  Snow Roughness Length               [m] |
!              Z0m_S1   : Maximum  Snow Roughness Length               [m] |
!              Z0_GIM   : Minimum GIMEX Roughness Length               [m] |
!              Z0_ICE   : Sea Ice ISW   Roughness Length               [m] |
!                                                                          |
!                                                                          |
!     Preprocessing  Option: STANDARD Possibility                          |
!     ^^^^^^^^^^^^^^^^^^^^^  ^^^^^^^^^^^^^^^^^^^^                          |
!     #AE: TURBULENCE: Aerosols Erosion / Turbulent Diffusion Coeff.       |
!     #BD: TraCer   Aeolian Erosion  Submodel           is turned ON       |
!     #BS: Explicit Cloud MICROPHYSICS: Blow. *(Snow)         Model)       |
!     #SN: SNOW Model                               may be turned ON       |
!     #NP: SNOW Model: Snow Properties may be those of Polar Snow          |
!     #ZG: SNOW Model: ETH-Camp & Greenland 3D simulations                 |
!     #MB: SNOW Model: Erosion Efficiency (Marticorena & Berga.1995)       |
!     #SI: SISVAT: Sea-Ice Fraction calculated from prescribed SST         |
!     #MT: SISVAT: Monin-Obukhov Theory is linearized (Garrat schem)       |
!     #SH: Soil /Vegetation Model: Hapex-Sahel   Vegetation     DATA       |
!     #ZO: SBL: Orography Roughness included from SL_z0 in MARdom          |
!     #ZW: SBL: Mom.: Roughn.Length= F(u*) Wang  MWR 129     ,  Sea        |
!     #ZT: SBL: Mom.: Roughn.Length= Typical value in polar models         |
!     #ZS: SBL: Mom.: Roughn.Length= F(u*) Andreas     (1995)  Snow        |
!     #Za: SBL: Mom.: Roughn.Length= F(u*) Andreas &al.(2004), Snow (modif.|
!     #ZA: SBL: Mom.: Roughn.Length= F(u*) Andreas &al.(2004), Snow (native|
!     #RS: SBL: Heat: Roughn.Length= F(u*,z0)  Andreas (1987)  Snow, Ice   |
!     #ZM: SBL: M/H   Roughn.Length: Box Moving Average (in Time)          |
!                                                                          |
!                                                                          |
!     Preprocessing  Option: STANDARD Col de Porte                         |
!     ^^^^^^^^^^^^^^^^^^^^^  ^^^^^^^^                                      |
!     #CP: Col de Porte  Turbulence        Parameterization                |
!                                                                          |
!                                                                          |
!     Preprocessing  Option:                                               |
!     ^^^^^^^^^^^^^^^^^^^^^                                                |
!     #Zw: SBL: Mom.: Roughn.Length= F(u*) Wang  MWR 129 bis ,  Sea        |
!     #ZN: SBL: Mom.: Roughn.Length= F(u*) Shao  & Lin (1999), Snow        |
!     #ZL: SBL: Z0mL  Roughn.Length= F(glf)                                |
!     #FL: SISVAT: LAI Assignation and Fallen Leaves Correction            |
!                                                                          |
!                                                                          |
!     Preprocessing  Option: SISVAT IO (not always a standard preprocess.) |
!     ^^^^^^^^^^^^^^^^^^^^^  ^^^^^^^^^                                     |
!     FILE                 |      CONTENT                                  |
!     ~~~~~~~~~~~~~~~~~~~~~+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
!   # SISVAT_iii_jjj_n     | #e0: OUTPUT on ASCII  File (SISVAT Variables) |
!   #                      |      Energy Budg. Verif.: Soil+(Sea-Ice)+Snow |
!   #                      |(#e0  MUST BE PREPROCESSED BEFORE #e1 & #e2 !) |
!   # SISVAT_iii_jjj_n     | #m0: OUTPUT/Verification: H2O    Conservation |
!                          |                                               |
!   # stdout               | #s0: OUTPUT of Snow Buffer Layer              |
!                          |      unit  6, SubRoutine  SISVAT     **ONLY** |
!   # stdout               | #s2: OUTPUT of SnowFall, Snow Buffer          |
!                          |      unit  6, SubRoutine  SISVAT_BSn, _qSn    |
!   # stdout               | #b0: OUTPUT of Snow Erosion Statistics        |
!                          |      unit  6, SubRoutine  SISVAT_BSn **ONLY** |
!   # stdout               | #sf: OUTPUT of SnowFall, Z0 and Drag Coeff.   |
!                          |      unit  6, SubRoutines PHY_SISVAT, SISVAT  |
!   # stdout               | #sz: OUTPUT of Roughness Length & Drag Coeff. |
!                          |      unit  6, SubRoutine  SISVAT     **ONLY** |
!                                                                          |
!     SUGGESTIONS of MODIFICATIONS: see lines beginning with "C +!!!"      |
!     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^                                         |
!--------------------------------------------------------------------------+
 
 
! Global  Variables
! =================
 
      use mod_real
      use mod_phy____dat
      use mod_phy____grd
      use mod_sisvat_grd
 
 
 
! General Variables
! =================
 
      use mod_sisvat_ctr
      use mod_sisvat_cdp
      use mod_sisvat_dat
      use mod_sisvat_dzs
      use mod_sisvat_kkl
      use mod_sisvat_log
      use mod_sisvat_loc
      use mod_sisvat_aux
! #BS use Mod_SISVAT_BSn
 
      use mod_sisvatlmmm
 
 
 
      IMPLICIT NONE
 
 
 
      integer           ::  jjtime
      integer           ::  kcolw
 
 
 
! Internal Variables
! ==================
 
! Non Local
! ---------
 
      real(kind=real8)                                 d_Bufs,Bufs_N   ! Buffer Snow Layer Increment
      real(kind=real8)                                 Buf_ro,Bros_N   ! Buffer Snow Layer Density
! #NP real(kind=real8)                                 BufPro          ! Buffer Snow Layer Density
      real(kind=real8)                                 Buf_G1,BG1__N   ! Buffer Snow Layer Dendr/Sphe[-]
      real(kind=real8)                                 Buf_G2,BG2__N   ! Buffer Snow Layer Spher/Size[-]
 
! Energy         Budget
! ~~~~~~~~~~~~~~~~~~~~~
! #e1 real(kind=real8),              dimension(kcolw)::ETSo_0          ! Soil/Snow Power, before Forcing
! #e1 real(kind=real8),              dimension(kcolw)::ETSo_1          ! Soil/Snow Power, after  Forcing
! #e1 real(kind=real8),              dimension(kcolw)::ETSo_d          ! Soil/Snow Power, Forcing
 
 
! Local
! -----
 
! #e0 character(len=16)                            ::  FilNam          !
! #e0 integer                                      ::  noUNIT          ! OUTPUT File  Unit Number
 
      integer                                      ::  ikl   ,ikv      !
      integer                                      ::  isn   ,isl      !
      integer                                      ::  ist   ,n        !
      integer                                      ::  ist__s,ist__w   ! Soil/Water Body Identifier
      integer                                      ::  growth          ! Seasonal               Mask
      integer                                      ::  LISmsk          ! Land+Ice / Open    Sea Mask
      integer                                      ::  LSnMsk          ! Snow-Ice / No Snow-Ice Mask
      integer                                      ::  IceMsk          !      Ice               Mask
      integer                                      ::  SnoMsk          ! Snow     / No Snow     Mask
 
      real(kind=real8)                             ::  drip            ! Rain Contribution to the Canopy
      real(kind=real8)                             ::  drr_Ca,rrCa_n   ! Rain Contribution to the Canopy
      real(kind=real8)                             ::  dsn_Ca,snCa_n   ! Snow Contribution to the Canopy
      real(kind=real8)                             ::  roSMin =  30.   ! Minimum Snow Density
      real(kind=real8)                             ::  roSn_1 = 109.   ! Fallen  Snow Density, Indep. Param. (PAHAUT)
      real(kind=real8)                             ::  roSn_2 =   6.   ! Fallen  Snow Density, Temper.Param. (PAHAUT)
      real(kind=real8)                             ::  roSn_3 =  26.   ! Fallen  Snow Density, Wind   Param. (PAHAUT)
      real(kind=real8)                             ::  Dendr1 =  17.12 ! Fallen  Snow Dendric. Wind 1/Param. (GIRAUD)
      real(kind=real8)                             ::  Dendr2 = 128.   ! Fallen  Snow Dendric. Wind 2/Param. (GIRAUD)
      real(kind=real8)                             ::  Dendr3 = -20.   ! Fallen  Snow Dendric. Indep. Param. (GIRAUD)
 
      real(kind=real8)                             ::  Spher1 =   7.87 ! Fallen  Snow Spheric.,Wind 1/Param.
      real(kind=real8)                             ::  Spher2 =  38.   ! Fallen  Snow Spheric.,Wind 2/Param.
      real(kind=real8)                             ::  Spher3 =  50.   ! Fallen  Snow Spheric.,Wind 3/Param.
      real(kind=real8)                             ::  Spher4 =  90.   ! Fallen  Snow Spheric.,Indep. Param. (GIRAUD)
      real(kind=real8)                             ::  Polair          ! Polar   Snow Switch
! #BS real(kind=real8)                             ::  PorSno          !
      real(kind=real8)                             ::  Salt_f,PorRef   !
 
! For Diffusion of Surficial Water in the Snow Pack
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
! #DW real(kind=real8)                             ::  PorVol,rWater   ! Pore Volume, retained Water
! #DW real(kind=real8)                             ::  rusNEW,rdzNEW,etaNEW
 
! #BS real(kind=real8)                             ::  ro_new          !
! #NP real(kind=real8)                             ::  TaPole = 263.15 ! Maximum     Polar Temperature
      real(kind=real8)                             ::  T__Min = 200.00 ! Minimum realistic Temperature
 
! DATA      Emissivities                                               ! Pielke, 1984, pp. 383,409
! ^^^^^^^^^^^^^^^^^^^^^^
      real(kind=real8)                             ::  EmiVeg =   0.98 ! Emissivity of Vegetation
      real(kind=real8)                             ::  EmiSol =   0.94 ! Emissivity of       Soil
      real(kind=real8)                             ::  EmiSno =   0.99 ! Emissivity of            Snow
      real(kind=real8)                             ::  EmiWat =   0.99 ! Emissivity of a Water Area
 
      real(kind=real8)                             ::  epsLMO = 1.e-18 ! minimum absolute value of LMo
      real(kind=real8)                             ::  vk2             ! Square of Von Karman Constant
      real(kind=real8)                             ::  u2star          !(u*)**2
! #ZL real(kind=real8)                             ::  fallen =   0.00 ! Fallen   Leaves         Switch
      real(kind=real8)                             ::  Z0mSea,Z0hSea   !          Sea  Roughness Length
      real(kind=real8)                             ::  Z0mLnd          !          Land Roughness Length
! #ZN real(kind=real8)                             ::  sqrrZ0          ! u*t/u*
! #MB real(kind=real8)                             ::  f_eff           ! Marticorena & B. 1995 JGR (20)
      real(kind=real8)                             ::  A_Fact          ! Fundamental * Roughness
 
      real(kind=real8)                             ::  Z0m_nu          ! Smooth R Snow Roughness Length
      real(kind=real8)                             ::  Z0mBSn          !         BSnow Roughness Length
      real(kind=real8)                             ::  Z0mBS0 = 0.5e-6 ! MINimum BSnow Roughness Length, Momentum
                                                                       ! Gallee et al. 2001 BLM 99 (19)
!     real(kind=real8)                             ::  Z0m_S0 = 0.00005! MINimum  Snow Roughness Length
!     real(kind=real8)                             ::  Z0m_S1 = 0.030  ! MAXimum  Snow Roughness Length, Sastrugis
! #ZS real(kind=real8)                             ::  Z0Sa_N          ! Regime   Snow Roughness Length
! #ZS real(kind=real8)                             ::  Z0SaSi          ! 1.IF Rgm Snow Roughness Length
! #ZG real(kind=real8)                             ::  Z0_GIM = 0.0013 ! Mimimum GIMEX Roughness Length  Ice Min Z0 = 0.0013 m (Broeke)
                                                                       !                                 Old Ice Z0 = 0.0500 m (Bruce)
                                                                       !                                              0.0500 m (Smeets)
                                                                       !                                              0.1200 m (Broeke)
      real(kind=real8)                             ::  Z0_ICE = 0.0010 ! Sea-Ice ISW   Roughness Length                        (Andreas)
      real(kind=real8)                             ::  Z0m_Sn          ! Snow  Surface Roughness Length
! #Za real(kind=real8)                             ::  Z0m_90          ! Snow  Surface Roughness Length
      real(kind=real8)                             ::  SnoWat          ! Snow Layer    Switch
! #RS real(kind=real8)                             ::  rstar,alors     !
! #RS real(kind=real8)                             ::  rstar0,rstar1   !
! #RS real(kind=real8)                             ::  rstar2          !
      real(kind=real8)                             ::  SameOK          ! 1. => Same Type of Grains
      real(kind=real8)                             ::  G1same          ! Averaged G1,  same Grains
      real(kind=real8)                             ::  G2same          ! Averaged G2,  same Grains
      real(kind=real8)                             ::  typ__1          ! 1. => Lay1 Type: Dendritic
      real(kind=real8)                             ::  zroNEW          ! dz X ro, if fresh Snow
      real(kind=real8)                             ::  G1_NEW          ! G1,      if fresh Snow
      real(kind=real8)                             ::  G2_NEW          ! G2,      if fresh Snow
      real(kind=real8)                             ::  zroOLD          ! dz X ro, if old   Snow
      real(kind=real8)                             ::  G1_OLD          ! G1,      if old   Snow
      real(kind=real8)                             ::  G2_OLD          ! G2,      if old   Snow
      real(kind=real8)                             ::  SizNEW          ! Size,    if fresh Snow
      real(kind=real8)                             ::  SphNEW          ! Spheric.,if fresh Snow
      real(kind=real8)                             ::  SizOLD          ! Size,    if old   Snow
      real(kind=real8)                             ::  SphOLD          ! Spheric.,if old   Snow
      real(kind=real8)                             ::  Siz_av          ! Averaged    Grain Size
      real(kind=real8)                             ::  Sph_av          ! Averaged    Grain Spher.
      real(kind=real8)                             ::  Den_av          ! Averaged    Grain Dendr.
      real(kind=real8)                             ::  DendOK          ! 1. => Average is  Dendr.
      real(kind=real8)                             ::  G1diff          ! Averaged G1, diff. Grains
      real(kind=real8)                             ::  G2diff          ! Averaged G2, diff. Grains
      real(kind=real8)                             ::  G1              ! Averaged G1
      real(kind=real8)                             ::  G2              ! Averaged G2
 
! Energy and Mass Budget
! ~~~~~~~~~~~~~~~~~~~~~~
! #e1 real(kind=real8)                             ::    EnsBal        ! Soil+Snow   , Power  Balance
! #e1 real(kind=real8)                             ::    EnvBal        !      Vegetat, Power  Balance
 
                                                                       ! H2O    Conservation
! #m0 real(kind=real8)                                   Watbal        ! Soil+Vegetat, Water  Balance
 
                                                                       ! * Mass Conservation
! #m1 real(kind=real8)                             ::    SnoBal        ! Snow Pack     Mass   Balance
 
 
 
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!                                                         !
! ALLOCATION                                              !
! ==========                                              !
 
      IF (it_run.EQ.1 .OR. flagdalloc)               THEN !
 
      allocate            ( tbr_sv(kcolp,mwp) )           ! Brightness Temperature
      allocate            ( irdwsv(kcolp,mwp) )           ! DOWNward   IR Flux
      allocate            ( irupsv(kcolp,mwp) )           ! UPward     IR Flux
      allocate            ( bdzssv(kcolp,mwp) )           ! Buffer Snow Layer Thickness
      allocate            ( z_snsv(kcolp,mwp) )           ! Snow-Ice, current Thickness
 
! Energy         Budget
! ~~~~~~~~~~~~~~~~~~~~~
! #e1 allocate            ( ETVg_d(kcolp,mwp) )           ! VegetationPower, Forcing
! #e1 allocate            ( EqSn_0(kcolp,mwp) )           ! Snow Energy, befor Phase Change
! #e1 allocate            ( EqSn_1(kcolp,mwp) )           ! Snow Energy, after Phase Change
! #e1 allocate            ( EqSn_d(kcolp,mwp) )           ! Energy in Excess
 
! OUTPUT/Verification: H2O    Conservation
! #m0 allocate            ( Wats_0(kcolp,mwp) )           ! Soil Water,  before Forcing
! #m0 allocate            ( Wats_1(kcolp,mwp) )           ! Soil Water,  after  Forcing
! #m0 allocate            ( Wats_d(kcolp,mwp) )           ! Soil Water,         Forcing
 
! OUTPUT/Verification: * Mass Conservation
! #m1 allocate            ( SIsubl(kcolp,mwp) )           ! Snow Sublimed/Deposed Mass
! #m1 allocate            ( SImelt(kcolp,mwp) )           ! Snow Melted           Mass
! #m1 allocate            ( SIrnof(kcolp,mwp) )           ! Local Surficial Water + Run OFF
 
! OUTPUT/Verification: SeaIce Conservation
! #m2 allocate            ( SIvAcr(kcolp,mwp) )           ! Sea-Ice      Vertical Acretion
 
! Energy and Mass Budget
! ~~~~~~~~~~~~~~~~~~~~~~
! #e1 allocate            ( Enrsvd(kcolp,mwp) )           ! Soil+Vegetat  Power  Forcing
 
                                                          ! H2O    Conservation
! #m0 allocate            ( Watsv0(kcolp,mwp) )           ! Soil+Vegetat, before Forcing
! #m0 allocate            ( Watsvd(kcolp,mwp) )           ! Soil+Vegetat  Water  Forcing
 
                                                          ! * Mass Conservation
! #m1 allocate            ( SIWm_0(kcolp,mwp) )           ! Snow Initial              Mass
! #m1 allocate            ( SIWm_1(kcolp,mwp) )           ! Snow Final                Mass
! #m1 allocate            ( SIWa_i(kcolp,mwp) )           ! Snow Initial       ATM Forcing
! #m1 allocate            ( SIWa_f(kcolp,mwp) )           ! Snow Final         ATM Forcing
! #m1 allocate            ( SIWe_i(kcolp,mwp) )           ! Snow Initial       BLS Forcing
! #m1 allocate            ( SIWe_f(kcolp,mwp) )           ! Snow Final         BLS Forcing
 
 
      allocate            ( icindx(kcolp,mwp) )           ! No   Ice               Mask
 
      allocate            ( fallok(kcolp,mwp) )           ! Snow Contribution to the Canopy
 
      END IF                                              !
!                                                         !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 
 
! Internal DATA
! =============
 
      vk2    =  vonkrm  *  vonkrm             ! Square of Von Karman Constant
! #FL fallen =             1.                 ! Fallen  Leaves         Switch
 
! #ZD Z0m_S0 =             0.00200            ! MINimum Snow Roughness Length
                                              ! MegaDunes    included
 
 
! BEGIN.main.
! ===========
 
      IF (.not.iniout)                                              THEN
               iniout = .true.
 
! Snow Pack Thickness
! -------------------
 
          DO ikl=1,kcolp
          DO ikv=1,mwp
            z_snsv(ikl,ikv)     = 0.0
          END DO
          END DO
        DO   isn=1,nsnow
          DO ikl=1,kcolp
          DO ikv=1,mwp
            z_snsv(ikl,ikv)     = z_snsv(ikl,ikv) + dzsnsv(ikl,ikv,isn)
            zzsnsv(ikl,ikv,isn) = z_snsv(ikl,ikv)
          END DO
          END DO
        END DO
 
 
! SISVAT Forcing VERIFICATION
! ---------------------------
 
        IF (irs_sv(1,1).gt.-eps6)                                       &
     &  write(6,600)
 600    format(/,'### SISVAT ERROR, Soil IR Upward  not defined ###',   &
     &         /,'###               Initialize and Store IRs_SV ###')
 
 
! OUTPUT
! ------
 
                    fillab              ='SISVAT'
                    seplab              ='_'
                    nwunit              = 51
      END IF
 
! #e0 DO ikl=1,kcolp
! #e0 DO ikv=1,mwp
! #e0   IF   (lwriSV(ikl,ikv).ne.0.AND.no__SV(lwriSV(ikl,ikv)).eq.0)THEN
! #e0                nwUNIT              = nwUNIT+1
! #e0                no__SV(lwriSV(ikl,ikv)) = nwUNIT
! #e0      write(FilNam,'(a6,a1,2(i3.3,a1),i1)')                        &
! #e0&           FilLab,SepLab,i___SV(lwriSV(ikl,ikv)),                 &
! #e0&                  SepLab,j___SV(lwriSV(ikl,ikv)),                 &
! #e0&                  SepLab,n___SV(lwriSV(ikl,ikv))
! #e0      open(unit=nwUNIT,status='unknown',file=FilNam)
! #e0      rewind    nwUNIT
! #e0   END IF
! #e0 END DO
! #e0 END DO
 
! #e0 DO ikl=1,kcolp
! #e0 DO ikv=1,mwp
! #e0   IF (lwriSV(ikl,ikv).ne.0)                                   THEN
! #e0           noUNIT=no__SV(lwriSV(ikl,ikv))
! #e0     write(noUNIT,5000) daHost,i___SV(lwriSV(ikl,ikv)),            &
! #e0&                              j___SV(lwriSV(ikl,ikv)),            &
! #e0&                              n___SV(lwriSV(ikl,ikv)),            &
! #e0&                                     Z0m_SV(ikl,ikv) ,            &
! #e0&                                     albisv(ikl,ikv)
 5000     format(                                                       &
     &       /,              a18,'|           Grid Point ',2i4,         &
     &                                           ' (',i2,')',           &
     &         '    | Z0m =',f12.6,' | Albedo = ',f6.3,' |',            &
     &       /,' -------+',7('---------+'),2('--------+'))
! #e0   END IF
! #e0 END DO
! #e0 END DO
 
 
! "Soil" Humidity of Water Bodies
! ===============================
 
      DO ikl=1,kcolp
      DO ikv=1,mwp
          ist    =      isotsv(ikl,ikv)                   ! Soil Type
          ist__s =  min(ist, 1)                           ! 1 => Soil
          ist__w =  1 - ist__s                            ! 1 => Water Body
        DO isl=-nsoil,0
          eta_sv(ikl,ikv,isl) = eta_sv(ikl,ikv,isl) * ist__s &! Soil
     &                    + etadsv(ist)     * ist__w      ! Water Body
        END DO
 
 
! Vertical Discretization Factor
! ==============================
 
          lsdzsv(ikl,ikv)     =                   ist__s &! Soil
     &                    + ocndsv          * ist__w      ! Water Body
      END DO
      END DO
 
 
! Vegetation Temperature Limits
! =============================
 
          DO ikl=1,kcolp
          DO ikv=1,mwp
            tvegsv(ikl,ikv) = max(tvegsv(ikl,ikv),t__min) ! T__Min = 200.K
 
 
! LAI Assignation and Fallen Leaves Correction (#FL)! Dead Leaves fall
! ==================================================! => LAI = Green Leaves only
                                                    ! => GLF = 1
 
            lai0sv(ikl,ikv) =     lai0sv(ikl,ikv)*min(1,ivgtsv(ikl,ikv)) ! NO LAI if
!                                                            ! no vegetation
            glf_sv(ikl,ikv) =     glf0sv(ikl,ikv)
! #FL       glf_sv(ikl,ikv) =     1.                         ! #FL
            lai_sv(ikl,ikv) =     lai0sv(ikl,ikv)        &   !
! #FL&               *        glf0SV(ikl,ikv)            &   ! #FL
     &               +        0.
          END DO
          END DO
 
 
! LAI in Presence of Snow
! =======================
 
!         ASSUMPTION: LAI decreases   when Snow Thickness increases,
!         ^^^^^^^^^^      becoming  0 when Snow Thickn. = Displac.Height
          DO ikl=1,kcolp
          DO ikv=1,mwp
            lai_sv(ikl,ikv) =     lai_sv(ikl,ikv)                       &
     &               * (1.0 - zzsnsv(       ikl,ikv, isnosv(ikl,ikv))   &
     &                      /(dh_dsv(ivgtsv(ikl,ikv))+eps6)      )
            lai_sv(ikl,ikv) = max(lai_sv(ikl,ikv),zer0)
            lai_sv(ikl,ikv) = min(lai_sv(ikl,ikv),ea_max)
          END DO
          END DO
 
 
! Interception of Rain by the Canopy
! ==================================
 
! OUTPUT/Verification: H2O    Conservation: Vegetation Forcing
! #m0     DO ikl=1,kcolp
! #m0     DO ikv=1,mwp
! #m0       Watsv0(ikl,ikv) =      rrCaSV(ikl,ikv)   ! Canopy Water Cont.
! #m0       Watsvd(ikl,ikv) =      drr_SV(ikl,ikv)   ! Precipitation
! #m0     END DO
! #m0     END DO
 
 
! New Canopy Water Content
! ------------------------
 
          DO ikl=1,kcolp
          DO ikv=1,mwp
            rrmxsv(ikl,ikv) = 0.2*max(     eps6,lai_sv(ikl,ikv)        )  ! Precip. Max. Intercept.
            sigmsv(ikl,ikv) = 1.0-exp(-min(half*lai_sv(ikl,ikv),ea_max))  ! Canopy Ventilation Coe.
!                                                                 ! (DR97, eqn 3.6)
            drr_ca      = drr_sv(ikl,ikv)  *sigmsv(ikl,ikv)      &! Intercepted Rain
     &                                 *dt__sv                    !
            rrca_n      = rrcasv(ikl,ikv)  +drr_ca                ! New Canopy Water Contnt
                                                                  ! (DR97, eqn 3.28)
            drip        = rrca_n       -rrmxsv(ikl,ikv)           ! Water  Drip
            drip        =      max(zer0,drip)                     !
            rrca_n      = rrca_n       -drip                      !
            IF (rrca_n.LT.1.e-30)       rrca_n = 0.               !
            drr_sv(ikl,ikv) = drr_sv(ikl,ikv) +(rrcasv(ikl,ikv)  &! Update Rain  Contribut.
     &                                 -rrca_n     )             &!
     &                                 /dt__sv                    !
            rrcasv(ikl,ikv) = rrca_n                              ! Upd.Canopy Water Contnt
 
 
! Interception of Snow by the Canopy
! ==================================
 
            dsn_ca      = dsn_sv(ikl,ikv)  *sigmsv(ikl,ikv) &! Intercepted Snow
     &                                 *dt__sv       !
            snca_n      = sncasv(ikl,ikv)  +dsn_ca   ! New Canopy Snow Thickn.
            drip        = snca_n       -rrmxsv(ikl,ikv)  !
            drip        =      max(zer0,drip)        !
            snca_n      = snca_n       -drip         !
            dsn_sv(ikl,ikv) = dsn_sv(ikl,ikv) +(sncasv(ikl,ikv) &! Update Snow  Contribut.
     &                                 -snca_n     )&!
     &                                 /dt__sv       !
            sncasv(ikl,ikv) = snca_n                 ! Upd.Canopy Snow Thickn.
          END DO
          END DO
 
 
! Snow Fall from the Canopy
! =========================
 
!         ASSUMPTION: snow fall from the canopy,
!         ^^^^^^^^^^  when the temperature of the vegetation is positive
!               (.OR. when snow over the canopy is saturated  with water)
 
          DO ikl=1,kcolp
          DO ikv=1,mwp
            fallok(ikl,ikv) =  max(zer0,sign(un_1,tvegsv(ikl,ikv)-tf_sno+eps6)) &
     &                  *  max(zer0,sign(un_1,sncasv(ikl,ikv)       -eps6))
            dsn_sv(ikl,ikv) =      dsn_sv(ikl,ikv)   +sncasv(ikl,ikv)*fallok(ikl,ikv)   &
     &                                       /dt__sv
            sncasv(ikl,ikv) =      sncasv(ikl,ikv) * (1.         -fallok(ikl,ikv))
 
 
! Blowing Particles Threshold Friction velocity
! =============================================
 
! #AE       usthSV(ikl,ikv) =                     1.0e+2
          END DO
          END DO
 
 
! Contribution of Snow to the Surface Snow Pack
! =============================================
 
      IF (snomod)                                                 THEN
 
 
! OUTPUT/Verification: * Mass Conservation
! #m1   DO ikl=1,kcolp
! #m1   DO ikv=1,mwp
! #m1     SIWa_i(ikl,ikv) =(drr_SV(ikl,ikv) + dsn_SV(ikl,ikv))   *dt__SV ![mm w.e.]
! #m1     SIWe_i(ikl,ikv) = dbs_SV(ikl,ikv)                          !
! #m1     SIWm_0(ikl,ikv) = BufsSV(ikl,ikv) + HFraSV(ikl,ikv)    *rhoIce !
! #m1   DO isn=1,nsnow                                               !
! #m1     SIWm_0(ikl,ikv) = SIWm_0(ikl,ikv) + dzsnSV(ikl,ikv,isn)*ro__SV(ikl,ikv,isn)!
! #m1   END DO                                                       !
! #m1   END DO
! #m1   END DO                                                       !
 
 
! Blowing Snow
! ------------
 
!                         **********
        IF (blomod)  call sisvat_bsn
!                         **********
 
!                         **********
! #ve                call SISVAT_wEq('_BSn  ',1)
!                         **********
 
 
! Sea Ice
! -------
 
!            **********
! #SI   call SISVAT_SIc(                                                &
! #m2&                  SIvAcr                                          &
! #SI&                 )
!            **********
 
!            **********
! #ve   call SISVAT_wEq('_SIc  ',0)
!            **********
 
 
! Buffer Layer
! ------------
 
          DO ikl=1,kcolp
          DO ikv=1,mwp
            bufssv(ikl,ikv) =      bufssv(ikl,ikv)      !     [mm w.e.]
            d_bufs      =  max(dsn_sv(ikl,ikv) *dt__sv,0.)  ! i.e., [kg/m2]
            dsn_sv(ikl,ikv) =      0.                   !
            bufs_n      =      bufssv(ikl,ikv) +d_bufs  !
 
! OUTPUT in SISVAT at specified i,j,k,n (see assignation in PHY_SISVAT)
! OUTPUT           for Buffer G1, G2 variables
! #s0       IF (ii__AP(ikl).EQ.iwr_SV .AND. jj__AP(ikl).EQ.jwr_SV .AND.&
! #s0&          ikv        .EQ.nwr_SV)                                 &
! #s0&      write(6,6601)      BufsSV(ikl,ikv) ,d_Bufs,Bufs_N
 6601       format(/,'Buffer *: ',3e15.6)
 
! Snow Density
! ^^^^^^^^^^^^
            polair      =      0.00                     !
! #NP       Polair      =  max(zer0,                   &!
! #NP&                         sign(un_1,TaPole        &!
! #NP&                                  -TaT_SV(ikl,ikv)))  !
            buf_ro      =  max( rosmin,                &! Fallen Snow Density
     &      rosn_1+rosn_2*     (tat_sv(ikl,ikv)-tf_sno)&! [kg/m3]
     &            +rosn_3*sqrt( vv10sv(ikl,ikv)))       ! Pahaut    (CEN)
! #NP       BufPro      =  max( rosMin,                &! Fallen Snow Density
! #NP&         104. *sqrt( max( VV10SV(ikl,ikv)-6.0,0.0)))  ! Kotlyakov (1961)
            bros_n      = (1. - polair) *   buf_ro     &! Temperate Snow
! #NP&                        + Polair  *   BufPro     &! Polar     Snow
     &                  +  0.                           !
 
! Instantaneous Density of deposited blown Snow (de Montmollin, 1978)
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! #BS       PorSno =      1.0d00     -  BSnoRo                          &
! #BS&                               /  rhoIce
! #BS       Salt_f =      usthSV(ikl,ikv)/  max(eps6,   us__SV(ikl,ikv))
! #BS       Salt_f =  min(Salt_f     ,  un_1)
! #BS       PorRef =      PorSno     /  max(eps6,1.-PorSno)             &
! #BS&               +log(Salt_f)
! #BS       Por_BS =      PorRef     /          (1.+PorRef)
! #BS       ro_new =      rhoIce     *          (1.-Por_BS)
! #BS       ro_new =  max(ro_new     ,  BSnoRo)
! #BS       Bros_N      = Bros_N     * (1.0-dsnbSV(ikl,ikv))            &
! #BS&                  + ro_new     *      dsnbSV(ikl,ikv)
 
! Instantaneous Density IF deposited blown Snow (Melted* from Canopy)
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
            bros_n      = bros_n     * (1.0-fallok(ikl,ikv))            &!
     &                  + 300.       *      fallok(ikl,ikv)              !
 
! Time averaged Density of deposited blown Snow
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
            brossv(ikl,ikv) =(bros_n     *      d_bufs                  &!
     &                   +brossv(ikl,ikv)*      bufssv(ikl,ikv))        &!
     &                   /         max(eps6,bufs_n)                      !
 
! OUTPUT in SISVAT at specified i,j,k,n (see assignation in PHY_SISVAT)
! OUTPUT           for Buffer G1, G2 variables
! #s0       IF (ii__AP(ikl).EQ.iwr_SV .AND. jj__AP(ikl).EQ.jwr_SV .AND. &
! #s0&          ikv        .EQ.nwr_SV)                                  &
! #s0&      write(6,6602) Buf_ro,Bros_N,BrosSV(ikl,ikv),dsnbSV(ikl,ikv)
 6602       format('rho    *: ',3e15.6,'    dsnbSV: ',e15.6)
 
!  S.Falling Snow Properties (computed as in SISVAT_zAg)
!    ^^^^^^^^^^^^^^^^^^^^^^^
            buf_g1      =  max(-g1_dsv,                                 &! Temperate Snow
     &               min(dendr1*vv__sv(ikl,ikv)-dendr2,                 &!     Dendricity
     &                   dendr3                   ))                     !
            buf_g2      =  min( spher4,                                 &! Temperate Snow
     &               max(spher1*vv__sv(ikl,ikv)+spher2,                 &!     Sphericity
     &                   spher3                   ))                     !
            buf_g1      = (1. - polair) *   buf_g1                      &! Temperate Snow
     &                        + polair  *   g1_dsv                       ! Polar     Snow
            buf_g2      = (1. - polair) *   buf_g2                      &! Temperate Snow
     &                        + polair  *   adsdsv                       ! Polar     Snow
                g1      =                   buf_g1                       ! NO  Blown Snow
                g2      =                   buf_g2                       ! NO  Blown Snow
 
! OUTPUT in SISVAT at specified i,j,k,n (see assignation in PHY_SISVAT)
! OUTPUT           for Buffer G1, G2 variables
! #s0       IF (ii__AP(ikl).EQ.iwr_SV .AND. jj__AP(ikl).EQ.jwr_SV .AND. &
! #s0&          ikv        .EQ.nwr_SV)                                  &
! #s0&      write(6,6603)       BG1sSV(ikl,ikv),BG2sSV(ikl,ikv)
 6603       format('G1,G2  *: ',3e15.6)
 
! S.1. Meme  Type  de Neige  / same Grain Type
!      ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
! #BS       SameOK  =  max(zer0,                                        &
! #BS&                     sign(un_1,    Buf_G1             *G1_dSV     &
! #BS&                                 - eps_21                    ))
! #BS       G1same  = ((1.0-dsnbSV(ikl,ikv))*Buf_G1+dsnbSV(ikl,ikv) *G1_dSV)
! #BS       G2same  = ((1.0-dsnbSV(ikl,ikv))*Buf_G2+dsnbSV(ikl,ikv) *ADSdSV)
!           Blowing Snow Properties:                         G1_dSV, ADSdSV
 
! S.2. Types differents / differents Types
!      ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
! #BS       typ__1  =  max(zer0,sign(un_1,eps6-Buf_G1))   ! =1.=> Dendritic
! #BS       zroNEW  =     typ__1  *(1.0-dsnbSV(ikl,ikv)) &! fract.Dendr.Lay.
! #BS&              + (1.-typ__1) *     dsnbSV(ikl,ikv)   !
! #BS       G1_NEW  =     typ__1  *Buf_G1                &! G1 of Dendr.Lay.
! #BS&              + (1.-typ__1) *G1_dSV                 !
! #BS       G2_NEW  =     typ__1  *Buf_G2                &! G2 of Dendr.Lay.
! #BS&              + (1.-typ__1) *ADSdSV                 !
! #BS       zroOLD  = (1.-typ__1) *(1.0-dsnbSV(ikl,ikv)) &! fract.Spher.Lay.
! #BS&              +     typ__1  *     dsnbSV(ikl,ikv)   !
! #BS       G1_OLD  = (1.-typ__1) *Buf_G1                &! G1 of Spher.Lay.
! #BS&              +     typ__1  *G1_dSV                 !
! #BS       G2_OLD  = (1.-typ__1) *Buf_G2                &! G2 of Spher.Lay.
! #BS&              +     typ__1  *ADSdSV                 !
! #BS       SizNEW  =    -G1_NEW  *DDcdSV/G1_dSV         &! Size  Dendr.Lay.
! #BS&               +(1.+G1_NEW         /G1_dSV)        &!
! #BS&                  *(G2_NEW  *DScdSV/G1_dSV         &!
! #BS&               +(1.-G2_NEW         /G1_dSV)*DFcdSV) !
! #BS       SphNEW  =     G2_NEW         /G1_dSV          ! Spher.Dendr.Lay.
! #BS       SizOLD  =     G2_OLD                          ! Size  Spher.Lay.
! #BS       SphOLD  =     G1_OLD         /G1_dSV          ! Spher.Spher.Lay.
! #BS       Siz_av =     (zroNEW*SizNEW+zroOLD*SizOLD)    ! Averaged Size
! #BS       Sph_av = min( zroNEW*SphNEW+zroOLD*SphOLD    &!
! #BS&                   ,  un_1)                         ! Averaged Sphericity
! #BS       Den_av = min((Siz_av -(    Sph_av *DScdSV    &!
! #BS&                            +(1.-Sph_av)*DFcdSV))  &!
! #BS&                 / (DDcdSV -(    Sph_av *DScdSV    &!
! #BS&                            +(1.-Sph_av)*DFcdSV))  &!
! #BS&                   ,  un_1)                         !
! #BS       DendOK  = max(zer0,                           !
! #BS&                    sign(un_1,     Sph_av *DScdSV  &! Small   Grains
! #BS&                              +(1.-Sph_av)*DFcdSV  &! Faceted Grains
! #BS&                              -    Siz_av        )) !
!           REMARQUE: le  type moyen (dendritique ou non) depend
!           ^^^^^^^^  de la  comparaison avec le diametre optique
!                     d'une neige recente de   dendricite nulle
!           REMARK:   the mean type  (dendritic   or not) depends
!           ^^^^^^    on the comparaison with the optical diameter
!                     of a recent snow    having zero dendricity
 
! #BS       G1diff  =(   -DendOK *Den_av                 &!
! #BS&               +(1.-DendOK)*Sph_av) *G1_dSV         !
! #BS       G2diff  =     DendOK *Sph_av  *G1_dSV        &!
! #BS&               +(1.-DendOK)*Siz_av                  !
! #BS       G1      =     SameOK *G1same                 &!
! #BS&               +(1.-SameOK)*G1diff                  !
! #BS       G2      =     SameOK *G2same                 &!
! #BS&               +(1.-SameOK)*G2diff                  !
 
            bg1__n      =((1. - fallok(ikl,ikv))*   g1   &!
     &                        + fallok(ikl,ikv) *   99.) &! Melted *  from Canopy
     &                  *       d_bufs/max(eps6,d_bufs)   !
            bg2__n      =((1. - fallok(ikl,ikv))*   g2   &!
     &                        + fallok(ikl,ikv) *   30.) &! Melted *  from Canopy
     &                  *       d_bufs/max(eps6,d_bufs)   !
 
!  S.Buffer  Snow Properties (computed as in SISVAT_zAg)
!    ^^^^^^^^^^^^^^^^^^^^^^^
            buf_g1      =       bg1__n                    ! Falling   Snow
            buf_g2      =       bg2__n                    ! Falling   Snow
 
! OUTPUT in SISVAT at specified i,j,k,n (see assignation in PHY_SISVAT)
! OUTPUT           for Buffer G1, G2 variables
! #s0       IF (ii__AP(ikl).EQ.iwr_SV .AND. jj__AP(ikl).EQ.jwr_SV .AND. &
! #s0&          ikv        .EQ.nwr_SV)                                  &
! #s0&      write(6,6604)      Buf_G1      ,Buf_G2         ,FallOK(ikl,ikv)  &
! #s0&                                                     ,TvegSV(ikl,ikv)
 6604       format('G1,G2 F*: ',3e15.6,'    T__Veg: ',e15.6)
 
! S.1. Meme  Type  de Neige  / same Grain Type
!      ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
            sameok  =  max(zer0,                                        &
     &                     sign(un_1,    buf_g1 *bg1ssv(ikl,ikv)        &
     &                                 - eps_21                    ))
            g1same  = (d_bufs*buf_g1+bufssv(ikl,ikv)*bg1ssv(ikl,ikv))   &
     &                     /max(eps6,bufs_n)
            g2same  = (d_bufs*buf_g2+bufssv(ikl,ikv)*bg2ssv(ikl,ikv))   &
     &                     /max(eps6,bufs_n)
 
! S.2. Types differents / differents Types
!      ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
            typ__1  =  max(zer0,sign(un_1,eps6-buf_g1))   ! =1.=> Dendritic
            zronew  =(    typ__1  *d_bufs                &! fract.Dendr.Lay.
     &              + (1.-typ__1) *bufssv(ikl,ikv))      &!
     &                   /max(eps6,bufs_n)                !
            g1_new  =     typ__1  *buf_g1                &! G1 of Dendr.Lay.
     &              + (1.-typ__1) *bg1ssv(ikl,ikv)        !
            g2_new  =     typ__1  *buf_g2                &! G2 of Dendr.Lay.
     &              + (1.-typ__1) *bg2ssv(ikl,ikv)        !
            zroold  =((1.-typ__1) *d_bufs                &! fract.Spher.Lay.
     &              +     typ__1  *bufssv(ikl,ikv))      &!
     &                   /max(eps6,bufs_n)                !
            g1_old  = (1.-typ__1) *buf_g1                &! G1 of Spher.Lay.
     &              +     typ__1  *bg1ssv(ikl,ikv)        !
            g2_old  = (1.-typ__1) *buf_g2                &! G2 of Spher.Lay.
     &              +     typ__1  *bg2ssv(ikl,ikv)        !
            siznew  =    -g1_new  *ddcdsv/g1_dsv         &! Size  Dendr.Lay.
     &               +(1.+g1_new         /g1_dsv)        &!
     &                  *(g2_new  *dscdsv/g1_dsv         &!
     &               +(1.-g2_new         /g1_dsv)*dfcdsv) !
            sphnew  =     g2_new         /g1_dsv          ! Spher.Dendr.Lay.
            sizold  =     g2_old                          ! Size  Spher.Lay.
            sphold  =     g1_old         /g1_dsv          ! Spher.Spher.Lay.
            siz_av  =   ( zronew  *siznew+zroold*sizold)  ! Averaged Size
            sph_av = min( zronew  *sphnew+zroold*sphold  &!
     &                  ,   un_1                       )  ! Averaged Sphericity
            den_av = min((siz_av  - (    sph_av *dscdsv  &!
     &                              +(1.-sph_av)*dfcdsv))&!
     &                 / (ddcdsv  - (    sph_av *dscdsv  &!
     &                              +(1.-sph_av)*dfcdsv))&!
     &                  ,   un_1                         )!
            dendok  = max(zer0,                          &!
     &                    sign(un_1,     sph_av *dscdsv  &! Small   Grains
     &                              +(1.-sph_av)*dfcdsv  &! Faceted Grains
     &                              -    siz_av        )) !
!           REMARQUE: le  type moyen (dendritique ou non) depend
!           ^^^^^^^^  de la  comparaison avec le diametre optique
!                     d'une neige recente de   dendricite nulle
!           REMARK:   the mean type  (dendritic   or not) depends
!           ^^^^^^    on the comparaison with the optical diameter
!                     of a recent snow    having zero dendricity
 
            g1diff  =(   -dendok *den_av                                &
     &               +(1.-dendok)*sph_av) *g1_dsv
            g2diff  =     dendok *sph_av  *g1_dsv                       &
     &               +(1.-dendok)*siz_av
            g1      =     sameok *g1same                                &
     &               +(1.-sameok)*g1diff
            g2      =     sameok *g2same                                &
     &               +(1.-sameok)*g2diff
 
            bg1ssv(ikl,ikv) =                       g1                  &!
     &                  *       bufs_n/max(eps6,bufs_n)                  !
            bg2ssv(ikl,ikv) =                       g2                  &!
     &                  *       bufs_n/max(eps6,bufs_n)                  !
 
! OUTPUT in SISVAT at specified i,j,k,n (see assignation in PHY_SISVAT)
! OUTPUT           for Buffer G1, G2 variables
! #s0       IF (ii__AP(ikl).EQ.iwr_SV .AND. jj__AP(ikl).EQ.jwr_SV .AND. &
! #s0&          ikv        .EQ.nwr_SV)                                  &
! #s0&      write(6,6605) Buf_G1     ,typ__1                            &
! #s0&                   ,DendOK     ,Den_av     ,Sph_av     ,Siz_av    &
! #s0&                   ,G1same     ,G1diff     ,G1
 6605       format('B1,Typ  : ',2e15.6,11x,'OK,Den,Sph,Siz: ',4e15.6    &
     &          ,/,'          ',30x   ,11x,'sam,dif,G1    : ',3e15.6)
 
! Update of Buffer Layer Content & Decision about creating a new snow layer
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
            bufssv(ikl,ikv) =       bufs_n              !     [mm w.e.]
            nlaysv(ikl,ikv) = min(un_1,                &!
     &                    max(zer0,                    &! Allows to create
     &                        sign(un_1,bufssv(ikl,ikv)&! a new snow Layer
     &                                 -smndsv     ))  &! if Buffer > SMndSV
     &                   *max(zer0,                    &! Except if * Erosion
     &                        sign(un_1,half           &! dominates
     &                                 -dsnbsv(ikl,ikv)))  &!
     &                   +max(zer0,                    &! Allows to create
     &                        sign(un_1,bufssv(ikl,ikv)&! a new snow Layer
     &                                 -smndsv*3.00)))  ! is Buffer > SMndSV*3
 
            bdzssv(ikl,ikv) = 1.e-3*bufssv(ikl,ikv)*rhowat &! [mm w.e.] -> [m w.e.]
     &                            /max(eps6,brossv(ikl,ikv))!& [m w.e.] -> [m]
 
! OUTPUT in SISVAT at specified i,j,k,n (see assignation in PHY_SISVAT)
! OUTPUT           for Buffer G1, G2 variables
! #s0       IF (ii__AP(ikl).EQ.iwr_SV .AND. jj__AP(ikl).EQ.jwr_SV .AND. &
! #s0&          ikv        .EQ.nwr_SV)                                  &
! #s0&      write(6,6606) BG1sSV(ikl,ikv),BG2sSV(ikl,ikv)               &
! #s0&                   ,NLaysv(ikl,ikv),BdzsSV(ikl,ikv)
 6606       format('G1,G2 N*: ',2e15.6,i15,e27.6)
 
          END DO
          END DO
 
 
! Snow Pack Discretization
! ========================
 
!            **********
        call sisvat_zsn
!            **********
 
!            **********
! #ve   call SISVAT_wEq('_zSn  ',0)
!            **********
 
! OUTPUT in SISVAT for ikl = 1 (preferably for Stand Alone Version)
! OUTPUT           for SnowFall and Snow Buffer
! #s2   IF          (isnoSV(1,1) .GT. 0)                                &
! #s2&  write(6,6004)isnoSV(1,1),  dsn_SV(1) *dt__SV + BufsSV(1),       &
! #s2&              (dzsnSV(1,isn)*ro__SV(1,isn),isn=1,isnoSV(1,1))
 6004   format(i3,'  dsn+Buf=',f6.2,6x,'z dz *ro =',10f6.2,             &
     &                                       (/,35x,10f6.2))
 
 
! Add a new Snow Layer
! ====================
 
          DO ikl=1,kcolp
          DO ikv=1,mwp
            isnosv(ikl,ikv)     = isnosv(ikl,ikv)              +nlaysv(ikl,ikv)
            isn                 = isnosv(ikl,ikv)
            dzsnsv(ikl,ikv,isn) = dzsnsv(ikl,ikv,isn) * float(1-nlaysv(ikl,ikv))   &
     &                          + bdzssv(ikl,ikv)     * float(  nlaysv(ikl,ikv))
            tsissv(ikl,ikv,isn) = tsissv(ikl,ikv,isn) * float(1-nlaysv(ikl,ikv))   &
     &                      + min(tat_sv(ikl,ikv),tf_sno)*float(nlaysv(ikl,ikv))
            ro__sv(ikl,ikv,isn) = ro__sv(ikl,ikv,isn) * float(1-nlaysv(ikl,ikv))   &
     &                          + brossv(ikl,ikv)     * float(  nlaysv(ikl,ikv))
            eta_sv(ikl,ikv,isn) = eta_sv(ikl,ikv,isn) * float(1-nlaysv(ikl,ikv))! + 0.
            agsnsv(ikl,ikv,isn) = agsnsv(ikl,ikv,isn) * float(1-nlaysv(ikl,ikv))! + 0.
            g1snsv(ikl,ikv,isn) = g1snsv(ikl,ikv,isn) * float(1-nlaysv(ikl,ikv))   &
     &                          + bg1ssv(ikl,ikv)     * float(  nlaysv(ikl,ikv))
            g2snsv(ikl,ikv,isn) = g2snsv(ikl,ikv,isn) * float(1-nlaysv(ikl,ikv))   &
     &                          + bg2ssv(ikl,ikv)     *    nlaysv(ikl,ikv)
            istosv(ikl,ikv,isn) = istosv(ikl,ikv,isn) * (1-nlaysv(ikl,ikv))        &
     &       + max(zer0,sign(un_1,tat_sv(ikl,ikv)                                  &
     &                           -tf_sno-eps_21)) *         istdsv(2)              &
     &                                            *         nlaysv(ikl,ikv)
            bufssv(ikl,ikv)     = bufssv(ikl,ikv) * float(1-nlaysv(ikl,ikv))
            nlaysv(ikl,ikv)     = 0
          END DO
          END DO
 
 
! Snow Pack Thickness
! -------------------
 
          DO ikl=1,kcolp
          DO ikv=1,mwp
            z_snsv(ikl,ikv)     = 0.0
          END DO
          END DO
        DO   isn=1,nsnow
          DO ikl=1,kcolp
          DO ikv=1,mwp
            z_snsv(ikl,ikv)     = z_snsv(ikl,ikv) + dzsnsv(ikl,ikv,isn)
            zzsnsv(ikl,ikv,isn) = z_snsv(ikl,ikv)
          END DO
          END DO
        END DO
 
 
! Diffusion of Surficial Water in the Snow Pack
! ---------------------------------------------
 
! #DW     DO isn=1,nsnow
! #DW     DO ikl=1,kcolp
! #DW     DO ikv=1,mwp
! #DW       PorVol      = 1.     - ro__SV(ikl,ikv,isn) /  rhoIce         !
! #DW       PorVol      =      max(PorVol            ,zer0  )            !
! #DW       rWater      = ws0dSV * PorVol     *rhoWat*dzsnSV(ikl,ikv,isn)   &
! #DW&                  * max(zer0,                                     &
! #DW&                   sign(un_1,rusnSV(ikl,ikv)/rhoWat-zzsnsv(ikl,ikv,isn)   &
! #DW&                                               +dzsnSV(ikl,ikv,isn)))
! #DW       rusNEW      =      max(rusnSV(ikl,ikv)-rWater,zer0  )
! #DW       rWater      =          rusnSV(ikl,ikv)-rusNEW
! #DW       rdzNEW          =      rWater                               &
! #DW&                           + ro__SV(ikl,ikv,isn) * dzsnSV(ikl,ikv,isn)
! #DW       etaNEW          =      rWater / max(eps6,rdzNEW)
! #DW       rusnSV(ikl,ikv) =          rusNEW
! #DW       ro__SV(ikl,ikv,isn) =      rdzNEW / max(eps6,dzsnSV(ikl,ikv,isn))
! #DW       eta_SV(ikl,ikv,isn) =      eta_SV(ikl,ikv,isn)  +etaNEW
! #DW     END DO
! #DW     END DO
! #DW     END DO
 
      END IF
 
! OUTPUT in SISVAT for ikl = 1 (preferably for Stand Alone Version)
! OUTPUT           for SnowFall and Snow Buffer
! #s2   IF          (isnoSV(1,1) .GT. 0)                                  &
! #s2&  write(6,6006)isnoSV(1,1),  dsn_SV(1) *dt__SV + BufsSV(1),       &
! #s2&              (dzsnSV(1,isn)*ro__SV(1,isn),isn=1,isnoSV(1,1))
 6006   format(i3,'  dsn+Buf=',f6.2,6x,'* dz *ro =',10f6.2,             &
     &                                       (/,35x,10f6.2))
 
 
! Blowing Dust
! ============
 
! #BD   IF (BloMod)                                                 THEN
 
!         ***************
! #BD     call SISVAT_BDu
!         ***************
 
! #BD   END IF
 
 
 
! Soil      Albedo: Soil Humidity Correction
! ==========================================
 
!         REFERENCE: McCumber and Pielke (1981), Pielke (1984)
!         ^^^^^^^^^
          DO ikl=1,kcolp
          DO ikv=1,mwp
            albssv(ikl,ikv) =                                           &
     &      alb0sv(ikl,ikv) *(1.0-min(half,eta_sv(       ikl,ikv,0)     &
     &                                /etadsv(isotsv(ikl,ikv))))
!         REMARK:    Albedo of Water Surfaces (isotSV=0):
!         ^^^^^^     alb0SV := 2  X  effective value, while
!                    eta_SV :=          etadSV
          END DO
          END DO
 
 
! Snow Pack Optical Properties
! ============================
 
      IF (snomod)                                                   THEN
 
!            ******
        call snoptp(                                                   &
! #AG&              jjtime                                             &
     &             )
!            ******
 
      ELSE
        DO ikl=1,kcolp
        DO ikv=1,mwp
          sex_sv(ikl,ikv,1) = 1.0
          sex_sv(ikl,ikv,0) = 0.0
          albisv(ikl,ikv)   = albssv(ikl,ikv)
        END DO
        END DO
      END IF
 
!            **********
! #ve   call SISVAT_wEq('SnOptP',0)
!            **********
 
 
! Solar Radiation Absorption and Effective Leaf Area Index
! ========================================================
 
!            ******
        call vgoptp
!            ******
 
 
! Surface-Canopy Emissivity
! =========================
 
        DO ikl=1,kcolp
        DO ikv=1,mwp
            lsnmsk         =     min( 1,isnosv(ikl,ikv))
            tau_sv(ikl,ikv)=     exp(  -lai_sv(ikl,ikv))                ! Veg Transmit.Frac.
            evg_sv(ikl,ikv)=  emiveg*(1-lsnmsk)+emisno*lsnmsk           ! Veg+Sno Emissivity
            eso_sv(ikl,ikv)=  emisol*(1-lsnmsk)+emisno*lsnmsk           ! Sol+Sno Emissivity
            emi_sv(ikl,ikv)=                                           &
     &   (((emisol*     tau_sv(ikl,ikv)                                &
     &     +emiveg*(1.0-tau_sv(ikl,ikv))) *lsmask(ikl,ikv))            &
     &    + emiwat                     *(1-lsmask(ikl,ikv)))*(1-lsnmsk)&
     &   +  emisno                                             *lsnmsk
        END DO
        END DO
 
 
! Soil/Vegetation Forcing/ Upward IR (INPUT, from previous time step)
! ===================================================================
 
        DO ikl=1,kcolp
        DO ikv=1,mwp
! #e1     Enrsvd(ikl,ikv) =    - IRs_SV(ikl,ikv)
          irupsv(ikl,ikv) =      irs_sv(ikl,ikv) *     tau_sv(ikl,ikv) ! Upward   IR
        END DO
        END DO
 
 
! Turbulence
! ==========
 
! Latent Heat of Vaporization/Sublimation
! ---------------------------------------
 
        DO ikl=1,kcolp
        DO ikv=1,mwp
          snowat      =                     min(isnosv(ikl,ikv),0)
          lx_h2o(ikl,ikv) =                                             &
     &    (1.-snowat) * lhvh2o                                          &
     &  +     snowat  *(lhsh2o * (1.-eta_sv(ikl,ikv,isnosv(ikl,ikv)))   &
     &                 +lhvh2o *     eta_sv(ikl,ikv,isnosv(ikl,ikv)) )
        END DO
        END DO
 
 
! Roughness Length for Momentum
! -----------------------------
 
! Land+Sea-Ice / Ice-free Sea Mask
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
        DO ikl=1,kcolp
        DO ikv=1,mwp
          icindx(ikl,ikv) = 0
        END DO
        END DO
        DO isn=1,nsnow
        DO ikl=1,kcolp
        DO ikv=1,mwp
          icindx(ikl,ikv) = max(icindx(ikl,ikv),                        &
     &                      isn*max(0,                                  &
     &                              sign(1,                             &
     &                                   int(ro__sv(ikl,ikv,isn)-900.))))
        END DO
        END DO
        END DO
 
        DO ikl=1,kcolp
        DO ikv=1,mwp
          lismsk    =     min(iicesv(ikl,ikv)  ,1     )
          lismsk    =     max(lsmask(ikl,ikv),lismsk)
          icemsk    =     max(0,sign(1       ,icindx(ikl,ikv)-1)  )
          snomsk    = max(min(isnosv(ikl,ikv)-iicesv(ikl,ikv),1),0)
 
! Sea  Roughness Length
! ^^^^^^^^^^^^^^^^^^^^^
          z0msea =       0.0002
          z0hsea =       0.000049
 
! #Zw     Z0mSea =       0.0185*us__SV(ikl,ikv)*us__SV(ikl,ikv)   ! Doyle MWR 130
! #Zw&                         *Grav_I                   &! p.3088 2e col
 
! #ZW     Z0mSea =       0.016 *us__SV(ikl,ikv)*us__SV(ikl,ikv)  &! Wang  MWR 129
! #ZW&                         *Grav_I                   &! p.1377 (21)
! #ZW&           +       0.11  *A_MolV                   &!
! #ZW&                         /  max(eps6 ,us__SV(ikl,ikv))  !
 
! #Zw     Z0mSea =       0.0185*us__SV(ikl,ikv)*us__SV(ikl,ikv)  &! Wang  MWR 129
! #Zw&                         *Grav_I                   &! p.1377 (21)
! #Zw&           +       0.135 *A_MolV                   &!   (adapted)
! #Zw&                         /  max(eps6 ,us__SV(ikl,ikv))  !
 
! #ZW     Z0hSea =   max(0.000049,                       &! Wang  MWR 129
! #ZW&                   0.20  *A_MolV                   &! p.1377 (22)
! #ZW&                         /  max(eps6 ,us__SV(ikl,ikv)))
 
! #ZW     Z0mSea =   max(Z0mSea,eps6)                     !
 
! Land Roughness Length, Snow Contribution excluded
! ^^^^^^^^^^^^^^^^^^^^^^ Ice  Contribution included
!                        ^^^^^^^^^^^^^^^^^^^^^^^^^^
! If vegetation Seasonal Cycle described by  LAI     :
          growth      =min(max(0,7-ivgtsv(ikl,ikv)),1)
          z0mlnd      =     z0mdsv(ivgtsv(ikl,ikv))*lai_sv(ikl,ikv)*growth  &
     &                                         /laidsv                  &
     &                +     z0mdsv(ivgtsv(ikl,ikv))*         (1-growth)
 
! If vegetation Seasonal Cycle described by  GLF only:
! #ZL     Z0mLnd      =                                                 &
! #ZL&             fallen * Z0mLnd                                      &
! #ZL&        +(1.-fallen)* Z0mdSV(ivgtSV(ikl,ikv))*glf_sv(ikl,ikv)*growth  &
! #ZL&                 +    Z0mdSV(ivgtSV(ikl,ikv))*         (1-growth)
 
! Land Roughness Length, Influence of the Masking by Snow
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
          z0mlnd      =max( z0mlnd   ,                                  &
     &                      z0mdsv(0)*(1-icemsk)                        &
     &                     +z0_ice   *   icemsk )
          z0mlnd      =     z0mlnd                                      &
     &                    -(zzsnsv(ikl,ikv,    isnosv(ikl,ikv))         &
     &                     -zzsnsv(ikl,ikv,max(icindx(ikl,ikv),0)))/7.
          z0mlnd      =max( z0mlnd    ,    5.e-5  )  ! Min set := Z0 on *
!         Roughness  disappears under Snow
!         Assumption Height/Roughness Length =  7 is used
 
! Z0 Smooth Regime over Snow (Andreas 1995, CRREL Report 95-16, p. 8)
! ^^^^^^^^^^^^^^^^^^^^^^^^^^
          z0m_nu =       5.e-5 ! z0s~(10-d)*exp(-vonKrm/sqrt(1.1e-03))
 
! Z0 Saltat.Regime over Snow (Gallee  et al., 2001, BLM 99 (19) p.11)
! ^^^^^^^^^^^^^^^^^^^^^^^^^^
          u2star =       us__sv(ikl,ikv) *us__sv(ikl,ikv)
          z0mbsn =       u2star      *0.536e-3   -  61.8e-6
          z0mbsn =   max(z0mbs0      ,z0mbsn)
 
! Z0 Smooth + Saltat. Regime
! ^^^^^^^^^^^^^^^^^^^^^^^^^^
          z0ensv(ikl,ikv) =  z0m_nu                                     &
     &                +  z0mbsn
 
! Rough   Snow Surface Roughness Length (Typical Value)
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
          z0m_sn =    0.250e-3 ! Andreas 1995, CRREL Report 95-16, fig.1&p.2
                               ! z0r~(10-d)*exp(-vonKrm/sqrt(1.5e-03))-5.e-5
          z0m_sn =    2.000e-3 ! Calibration    of MAR
! #ZT     Z0m_Sn =    1.000e-3 ! Exemple Tuning in RACMO
! #ZT     Z0m_Sn =    0.500e-3 ! Exemple Tuning in MAR
 
! Rough   Snow Surface Roughness Length (Variable Sastrugi Height)
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
          a_fact      =  1.0000        ! Andreas et al., 2004, p.4
                                       ! ams.confex.com/ams/pdfpapers/68601.pdf
 
!                                                                        ! 0050=.003/.6
! #ZS     Z0Sa_N =                   (us__SV(ikl,ikv) -0.2)*0.0050      &! 0053=TUNING
! #ZS&           * max(zer0,sign(un_1,Tf_Sno-eps9                       &!
! #ZS&                               -TsisSV(ikl,ikv , isnoSV(ikl,ikv))))
!!#ZS     Z0SaSi = max(zer0,sign(un_1,Z0Sa_N                  ))         ! 1 if erosion
! #ZS     Z0SaSi = max(zer0,sign(un_1,zer0  -eps9 -uss_SV(ikl,ikv)))     !
! #ZS     Z0Sa_N = max(zer0,          Z0Sa_N)
! #ZS     Z0SaSV(ikl,ikv) =                                             &!
! #ZS&             max(Z0SaSV(ikl,ikv)   ,Z0SaSV(ikl,ikv)               &!
! #ZS&               + Z0SaSi*(Z0Sa_N-Z0SaSV(ikl,ikv))*exp(-dt__SV/43200.)) &!
! #ZS&               -            min(dz0_SV(ikl,ikv) ,     Z0SaSV(ikl,ikv)) !
 
! #ZS     A_Fact      =               Z0SaSV(ikl,ikv) *  5.0/0.15        ! A=5 if h~10cm
!         CAUTION: The influence of the sastrugi direction is not yet included
 
! #ZS     Z0m_Sn =                    Z0SaSV(ikl,ikv)                   &!
! #ZS&                              - Z0m_nu                             !
 
! Z0                         (Shao & Lin, 1999, BLM 91 (46)  p.222)
! ^^^^^^^^^^^^^^^^^^^^^^^^^^
! Z0 Saltat.Regime over Snow (Shao & Lin, 1999, BLM 91 (46)  p.222)
! #ZN     sqrrZ0 =       usthSV(ikl,ikv)/max( us__SV(ikl,ikv),0.001)
! #ZN     sqrrZ0 =                   min( sqrrZ0     ,0.999)
! #ZN     Z0mBSn =       0.55 *0.55 *exp(-sqrrZ0     *sqrrZ0)           &!
! #ZN&                  *us__SV(ikl,ikv)*     us__SV(ikl,ikv)*Grav_I*0.5 !
 
! Z0 Smooth + Saltat. Regime (Shao & Lin, 1999, BLM 91 (46)  p.222)
! #ZN     Z0enSV(ikl,ikv) = (Z0m_nu     **    sqrrZ0 )                  &!
! #ZN&                * (Z0mBSn     **(1.-sqrrZ0))
! #ZN     Z0enSV(ikl,ikv) =  max(Z0enSV(ikl,ikv), Z0m_nu)
 
! Z0                         (Andreas etAl., 2004
! ^^^^^^^^^^^^^^^^^^^^^^^^^^  ams.confex.com/ams/pdfpapers/68601.pdf)
! Z0 Smooth Regime over Snow (Andreas etAl., 2004
! #Za     Z0m_nu = 0.135*A_MolV / max(us__SV(ikl,ikv) , eps6)
 
! Z0 Saltat.Regime over Snow (Andreas etAl., 2004
! #Za     Z0mBSn = 0.035*u2star      *Grav_I
 
! Z0 Smooth + Saltat. Regime (Andreas etAl., 2004
! #Za     Z0enSV(ikl,ikv) =  Z0m_nu                                     &!
! #Za&                +  Z0mBSn                                          !
 
! Z0 Rough  Regime over Snow (Andreas etAl., 2004
! (.NOT. used by Erosion)     ams.confex.com/ams/pdfpapers/68601.pdf)
! ^^^^^^^^^^^^^^^^^^^^^^^^^^
! #Za     Z0m_90 =(10.-0.025*VVs_SV(ikl,ikv)/5.)                        &!
! #Za&            *exp(-0.4/sqrt(.00275+.00001*max(0.,VVs_SV(ikl,ikv)-5.)))  !
! #Za     Z0m_Sn =           DDs_SV(ikl,ikv)* Z0m_90 / 45.              &!
! #Za&         - DDs_SV(ikl,ikv)*DDs_SV(ikl,ikv)* Z0m_90 /(90.*90.)      !
 
! #ZA     u2star =      (us__SV(ikl,ikv) -0.1800)     / 0.1
! #ZA     Z0m_Sn =A_Fact*Z0mBSn *exp(-u2star*u2star)
 
! Z0 Rough  Regime over Snow (Andreas etAl., 2004
! #Za     u2star =      (us__SV(ikl,ikv) -0.1800)     / 0.1
! #Za     Z0m_Sn =A_Fact*Z0mBSn *exp(-u2star*u2star)
 
! Z0 Smooth + Saltat. Regime + Rough  Regime over Snow (Andreas etAl., 2004)
! #Za     Z0enSV(ikl,ikv) =  Z0enSV(ikl,ikv)                            &!
! #Za&                +  Z0m_Sn                                         !
 
! Z0               over Snow (instantaneous or time average)
! ^^^^^^^^^^^^^^^^^^^^^^^^^^
          z0e_sv(ikl,ikv) =  z0ensv(ikl,ikv)
! #ZM     Z0e_SV(ikl,ikv) =  Z0emSV(ikl,ikv)
 
! Momentum  Roughness Length
! ^^^^^^^^^^^^^^^^^^^^^^^^^^                                 ! Contribution of
          z0mnsv(ikl,ikv) =  z0mlnd                         &! Vegetation Form
     &                + (z0m_sn                             &! Sastrugi   Form
     &                +  z0ensv(ikl,ikv))   *snomsk          ! Snow    Erosion
 
! Mom. Roughness Length, Discrimination among Ice/Land  and Ice-Free Ocean
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
          z0mnsv(ikl,ikv) =  z0mnsv(ikl,ikv)    *lismsk     &! Ice and  Land
     &                  +z0msea      *(1-lismsk)            &! Ice-Free Ocean
! #ZO&                  +Z0roSV(ikl,ikv)                    &! Subgrid  Topogr.
     &                  +0.
 
! GIS  Roughness Length
! ^^^^^^^^^^^^^^^^^^^^^
! #ZG     Z0mnSV(ikl,ikv) =                                            &!
! #ZG&      (1-LSmask(ikl,ikv)) *     Z0mnSV(ikl,ikv)                  &!
! #ZG&    +    LSmask(ikl,ikv)  * max(Z0mnSV(ikl,ikv),max(Z0_GIM,      &!
! #ZG&                                                    Z0_GIM+      &!
! #ZG&      (0.0032-Z0_GIM)*(ro__SV(ikl,ikv,isnoSV(ikl,ikv))-600.)     &!
! #ZG&                     /(920.00                 -600.)))            !
 
! Mom. Roughness Length, Instantaneous OR Box Moving Average in Time
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
          z0m_sv(ikl,ikv) =  z0mnsv(ikl,ikv)                   ! Z0mnSV  instant.
! #ZM     Z0m_SV(ikl,ikv) =  Z0mmSV(ikl,ikv)                   ! Z0mnSV  Average
 
! Corrected Threshold Friction Velocity before Erosion         ! Marticorena and
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^         ! Bergametti 1995
! #BS     Z0e_SV(ikl,ikv) =   min(Z0m_SV(ikl,ikv),Z0e_SV(ikl,ikv)) !
! #MB     f_eff=    log(0.35*(0.1        /Z0e_SV(ikl,ikv))**0.8)   ! JGR 100
! #MB     f_eff=1.-(log(      Z0m_SV(ikl,ikv)/Z0e_SV(ikl,ikv)      )) &! (20) p. 16420
! #MB&            /(max(      f_eff      ,eps6             ))  ! p.16426 2nd ?
! #MB     f_eff=    max(      f_eff      ,eps6              )  ! CONTROL
! #Mb     f_eff=2.0*max(      f_eff      ,eps6              )  ! TUNING
! #MB     f_eff=    min(      f_eff      ,un_1              )  !
! #MB     usthSV(ikl,ikv) =       usthSV(ikl,ikv)/f_eff        !
 
 
! Roughness Length for Scalars
! ----------------------------
 
          z0hnsv(ikl,ikv) =     z0mnsv(ikl,ikv)/  7.4
 
! Roughness Length for Scalars: Modification from Hapex-Sahel data
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
          z0hnsv(ikl,ikv) =     z0mnsv(ikl,ikv)/100.0
!                           Z0h = Z0m  /100.0   over the Sahel
!                                              (Taylor & Clark, QJRMS 127,p864)
 
! Roughness Length for Scalars: Modification for  Snow & Ice (Andrea, 1987)
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
! #RS     rstar       =     Z0mnSV(ikl,ikv) * us__SV(ikl,ikv) / A_MolV
! #RS     rstar       = max(eps6,min(rstar,R_1000))
! #RS     alors       =          log(rstar)
! #RS     rstar0      = 1.250e0 * max(zer0,sign(un_1,0.135e0 - rstar))   &
! #RS&                +(1.      - max(zer0,sign(un_1,0.135e0 - rstar)))  &
! #RS&                *(0.149e0 * max(zer0,sign(un_1,2.500e0 - rstar))   &
! #RS&                + 0.317e0                                          &
! #RS&                *(1.      - max(zer0,sign(un_1,2.500e0 - rstar))))
! #RS     rstar1      = 0.      * max(zer0,sign(un_1,0.135e0 - rstar))   &
! #RS&                +(1.      - max(zer0,sign(un_1,0.135e0 - rstar)))  &
! #RS&                *(-0.55e0 * max(zer0,sign(un_1,2.500e0 - rstar))   &
! #RS&                - 0.565                                            &
! #RS&                *(1.      - max(zer0,sign(un_1,2.500e0 - rstar))))
! #RS     rstar2      = 0.      * max(zer0,sign(un_1,0.135e0 - rstar))   &
! #RS&                +(1.      - max(zer0,sign(un_1,0.135e0 - rstar)))  &
! #RS&                *(0.      * max(zer0,sign(un_1,2.500e0 - rstar))   &
! #RS&                - 0.183                                            &
! #RS&                *(1.00    - max(zer0,sign(un_1,2.500e0 - rstar))))
! #RS     Z0hnSV(ikl,ikv) = max(zer0                                     &
! #RS&                , sign(un_1,zzsnsv(ikl,ikv,isnoSV(ikl,ikv))-eps6)) &
! #RS&                * exp(rstar0+rstar1*alors+rstar2*alors*alors)      &
! #RS&                * 0.001e0 + Z0hnSV(ikl,ikv) * ( 1. - max(zer0      &
! #RS&                , sign(un_1,zzsnsv(ikl,ikv,isnoSV(ikl,ikv))-eps6)))
 
          z0hnsv(ikl,ikv) =     z0hsea             *(1-lismsk)&! Ice-free Ocean
     &                +     z0hnsv(ikl,ikv)        *   lismsk  ! Ice and  Land
 
          z0h_sv(ikl,ikv) =     z0hnsv(ikl,ikv)
! #ZM     Z0h_SV(ikl,ikv) =     Z0hmSV(ikl,ikv)
 
 
! Contributions of the Roughness Lenghths to the neutral Drag Coefficient
! -----------------------------------------------------------------------
 
          IF (garrat)                                                   &
     &    z0m_sv(ikl,ikv) = max(2.0e-6     ,z0m_sv(ikl,ikv)) ! Min Z0_m (Garrat Scheme)
          z0m_sv(ikl,ikv) = min(z0m_sv(ikl,ikv),za__sv(ikl,ikv)*0.3333)
          sqrcm0(ikl,ikv) = log(za__sv(ikl,ikv)/z0m_sv(ikl,ikv))
! Martin control
!          PRINT*,'za__SV(:,:)=',za__SV(:,:)
!          PRINT*,'Z0h_SV=',Z0h_SV
! Martin control
          sqrch0(ikl,ikv) = log(za__sv(ikl,ikv)/z0h_sv(ikl,ikv))
 
! OUTPUT of SnowFall, Roughness Length and Drag Coefficients
! #sf     IF (ikl,ikv.EQ.1) write(6,6661) dsn_SV(ikl,ikv),us__SV(ikl,ikv),Z0SaSi&
! #sf&                        ,Z0Sa_N,Z0SaSV(ikl,ikv),Z0m_Sn,Z0m_SV(ikl,ikv)
 6661     format(20x,7f9.6)
 
! OUTPUT in SISVAT at specified i,j,k,n (see assignation in PHY_SISVAT)
! OUTPUT           of Roughness Length and Drag Coefficients
! #sz     IF (ii__AP(ikl).EQ.iwr_SV .AND. jj__AP(ikl).EQ. jwr_SV .AND.  &
! #sz&        ikv        .EQ.nwr_SV)                                    &
! #sz&    write(6,6600)  za__SV(ikl,ikv) , Z0m_SV(ikl,ikv)              &
! #sz&                  ,sqrCm0(ikl,ikv) , za__SV(ikl,ikv)/Z0m_SV(ikl,ikv)  &
! #sz&                  ,Z0SaSV(ikl,ikv) , Z0h_SV(ikl,ikv)              &
! #sz&                  ,sqrCh0(ikl,ikv) , za__SV(ikl,ikv)/Z0h_SV(ikl,ikv)
 6600     format(/,' ** SISVAT     *0  '                                &
     &            ,'  za__SV  = ',e12.4,'  Z0m_SV  = ',e12.4            &
     &            ,'  sqrCm0  = ',e12.4,'  Za/Z0m  = ',e12.4            &
     &          ,/,'                   '                                &
     &            ,'  Z0SaSV  = ',e12.4,'  Z0h_SV  = ',e12.4            &
     &            ,'  sqrCh0  = ',e12.4,'  Za/Z0h  = ',e12.4)
 
 
! Vertical Stability Correction
! -----------------------------
 
! Surface/Canopy Temperature
! ^^^^^^^^^^^^^^^^^^^^^^^^^^
          tsrfsv(ikl,ikv) = sigmsv(ikl,ikv) * tvegsv(ikl,ikv)           &
     &          + (1. - sigmsv(ikl,ikv))* tsissv(ikl,ikv,isnosv(ikl,ikv))
        END DO
        END DO
 
! Aerodynamic Resistance
! ^^^^^^^^^^^^^^^^^^^^^^
        IF            (snomod.AND.colprt)                           THEN
 
!                **********
            call colprt_sbl
!                **********
 
        ELSE
         IF           (garrat)                                      THEN
 
!                **********
            call sisvat_sbl
!                **********
 
         ELSE
 
!                **********
            call sisvatesbl
!                **********
 
         END IF
 
         DO ikl=1,kcolp
         DO ikv=1,mwp
           IF (lmo_sv(ikl,ikv) .GT. 0.) lmo_sv(ikl,ikv) = max( epslmo,lmo_sv(ikl,ikv))
           IF (lmo_sv(ikl,ikv) .LT. 0.) lmo_sv(ikl,ikv) = min(-epslmo,lmo_sv(ikl,ikv))
         END DO
         END DO
        END IF
 
 
! Canopy Energy Balance
! =====================
 
!            **********
        call sisvat_tvg(                                                &
! #e1&                  ETVg_d                                          &
     &                 )
!            **********
 
 
! Surface/Canopy Temperature
! ==========================
 
        DO ikl=1,kcolp
        DO ikv=1,mwp
          tsrfsv(ikl,ikv) = sigmsv(ikl,ikv) * tvegsv(ikl,ikv)           &
     &          + (1. - sigmsv(ikl,ikv))* tsissv(ikl,ikv,isnosv(ikl,ikv))
        END DO
        END DO
 
 
! Soil   Energy Balance
! =====================
 
 
!            **********
        call sisvat_tso(                                                &
! #e1&                  ETSo_0     ,ETSo_1     ,ETSo_d     ,kcolw       &
     &                 )
!            **********
 
!            **********
! #ve   call SISVAT_wEq('_TSo  ',0)
!            **********
 
 
 
 
! Canopy Water  Balance
! =====================
 
! Soil Water     Potential
! ------------------------
 
      DO   isl=-nsoil,0
        DO ikl=1,kcolp
        DO ikv=1,mwp
          ist             =     isotsv(ikl,ikv)    ! Soil Type
          psi_sv(ikl,ikv,isl) =     psidsv(ist)   &! DR97, Eqn.(3.34)
     &  *(etadsv(ist) /max(eps6,eta_sv(ikl,ikv,isl))) &!
     &  **bchdsv(ist)                              !
 
 
! Soil Hydraulic Conductivity
! ---------------------------
 
          khydsv(ikl,ikv,isl) =    s2__sv(ist)    &! DR97, Eqn.(3.35)
     &  *(eta_sv(ikl,ikv,isl)**(2.*bchdsv(ist)+3.))!
        END DO
        END DO
      END DO
 
!            **********
        call sisvat_qvg
!            **********
 
 
! OUTPUT/Verification: H2O    Conservation: Vegetation Forcing
! #m0   DO ikl=1,kcolp
! #m0   DO ikv=1,mwp
! #m0     Watsvd(ikl,ikv) =     (Watsvd(ikl,ikv)  &! Canopy Precip. IN
! #m0&                      -drr_SV(ikl,ikv)      &! Canopy Precip. OUT
! #m0&                      -Evp_sv(ikl,ikv))* dt__SV  ! Canopy Water Evap.
! #m0   END DO
! #m0   END DO
 
 
! Melting / Refreezing in the Snow Pack
! =====================================
 
      IF (snomod)                                                   THEN
 
!            **********
        call sisvat_qsn(                                                &
! #e1&                  EqSn_0,EqSn_1,EqSn_d                            &
! #m1&                 ,SIsubl,SImelt,SIrnof                            &
     &                 )
!            **********
 
!            **********
! #ve   call SISVAT_wEq('_qSn  ',0)
!            **********
 
! OUTPUT in SISVAT for ikl = 1 (preferably for Stand Alone Version)
! OUTPUT           for SnowFall and Snow Buffer
! #s2   IF          (isnoSV(1,1) .GT. 0)                                &
! #s2&  write(6,6007)isnoSV(1,1),  dsn_SV(1) *dt__SV + BufsSV(1,1),     &
! #s2&              (dzsnSV(1,isn)*ro__SV(1,isn),isn=1,isnoSV(1,1))
 6007   format(i3,'  dsn+Buf=',f6.2,6x,'q dz *ro =',10f6.2,             &
     &                                       (/,35x,10f6.2))
 
 
! Snow Pack Thickness
! -------------------
 
          DO ikl=1,kcolp
          DO ikv=1,mwp
            z_snsv(ikl,ikv)     = 0.0
          END DO
          END DO
        DO   isn=1,nsnow
          DO ikl=1,kcolp
          DO ikv=1,mwp
            z_snsv(ikl,ikv)     = z_snsv(ikl,ikv) + dzsnsv(ikl,ikv,isn)
            zzsnsv(ikl,ikv,isn) = z_snsv(ikl,ikv)
          END DO
          END DO
        END DO
 
 
! Energy in Excess is added to the first Soil Layer
! -------------------------------------------------
 
        DO ikl=1,kcolp
        DO ikv=1,mwp
            z_snsv(ikl,ikv)   = max(zer0,                               &
     &                          sign(un_1,eps6-z_snsv(ikl,ikv)))
            tsissv(ikl,ikv,0) = tsissv(ikl,ikv,0)    + eexcsv(ikl,ikv)  &
     &                                       /(rocssv(isotsv(ikl,ikv))  &
     &                                        +rcwdsv*eta_sv(ikl,ikv,0))
            eexcsv(ikl,ikv)   = 0.
        END DO
        END DO
 
 
! OUTPUT/Verification: * Mass Conservation: Mass (below the Canopy) and Forcing
! #m1   DO ikl=1,kcolp
! #m1   DO ikv=1,mwp
! #m1     SIWa_f(ikl,ikv) =(drr_SV(ikl,ikv) + dsn_SV(ikl,ikv))   *dt__SV ![mm w.e.]
! #m1     SIWe_f(ikl,ikv) = dbs_SV(ikl,ikv)                          !
! #m1     SIWm_1(ikl,ikv) = BufsSV(ikl,ikv) + HFraSV(ikl,ikv)    *rhoIce !
! #m1   DO isn=1,nsnow                                               !
! #m1     SIWm_1(ikl,ikv) = SIWm_1(ikl,ikv) + dzsnSV(ikl,ikv,isn)*ro__SV(ikl,ikv,isn)!
! #m1   END DO                                                       !
! #m1   END DO
! #m1   END DO                                                       !
 
      END IF
 
 
! Soil   Water  Balance
! =====================
 
!            **********
        call sisvat_qso(                                                &
! #m0&                 (Wats_0,Wats_1,Wats_d                            &
     &                 )
!            **********
 
 
! Surface/Canopy Fluxes
! =====================
 
        DO ikl=1,kcolp
        DO ikv=1,mwp
          irdwsv(ikl,ikv)=tau_sv(ikl,ikv) *ird_sv(ikl,ikv)*eso_sv(ikl,ikv)  &! Downward IR
     &          +(1.0-tau_sv(ikl,ikv))*ird_sv(ikl,ikv)*evg_sv(ikl,ikv)   !
          irupsv(ikl,ikv) =      irupsv(ikl,ikv)                &! Upward   IR
     &                + 0.5 *irv_sv(ikl,ikv) * (1.-tau_sv(ikl,ikv))  !
          iru_sv(ikl,ikv) =     -irupsv(ikl,ikv)                &! Upward   IR
     &                      +ird_sv(ikl,ikv)                    &! (effective)
     &                      -irdwsv(ikl,ikv)                     ! (positive)
          tbr_sv(ikl,ikv) =sqrt(sqrt(iru_sv(ikl,ikv)/stefbo))    ! Brightness
!                                                                ! Temperature
          uts_sv(ikl,ikv) =     (hsv_sv(ikl,ikv) +hss_sv(ikl,ikv))  &! u*T*
     &                     /(rht_sv(ikl,ikv) *cpdair)            !
          uqs_sv(ikl,ikv) =     (hlv_sv(ikl,ikv) +hls_sv(ikl,ikv))  &! u*q*
     &                     /(rht_sv(ikl,ikv) *lhvh2o)            !
 
! Surface/Canopy Temperature
! ^^^^^^^^^^^^^^^^^^^^^^^^^^
          tsrfsv(ikl,ikv) = sigmsv(ikl,ikv) * tvegsv(ikl,ikv)           &
     &          + (1. - sigmsv(ikl,ikv))* tsissv(ikl,ikv,isnosv(ikl,ikv))
        END DO
        END DO
 
 
! Snow Pack Properties (sphericity, dendricity, size)
! ===================================================
 
      IF (snomod)                                                   THEN
 
!            **********
        call sisvat_gsn
!            **********
 
!            **********
! #ve   call SISVAT_wEq('_GSn  ',0)
!            **********
 
 
! Surficial Water Freezing, including that of a Water Surface (isotSV=0)
! ======================================================================
 
 
      END IF
 
 
! OUTPUT
! ======
 
      IF (kcolv.LE.mwp)                                             THEN
          ikl=1
        write(4,4) day_tu,labmon(mon_tu),yeartu,hourtu,minutu          &
     &            ,(ivgtsv(ikl,ikv),dh_dsv(ivgtsv(ikl,ikv))            &
     &                           ,1.e3*z0m_sv(ikl,ikv),ikv,ikv=1,mwp)
 4      format(i3,a3,i5,i3,'h',i3,'   Vegetation: ',9(i6,2f8.3,i3))
      END IF
 
! #e0   DO ikl=1,kcolp
! #e0   DO ikv=1,mwp
! #e0   IF (lwriSV(ikl,ikv).ne.0)                                   THEN
! #e0           noUNIT =  no__SV(lwriSV(ikl,ikv))
! #e0     write(noUNIT,5001)                                            &
! #e0&       (SoSosv(ikl,ikv)+SoCasv(ikl,ikv))*sol_SV(ikl,ikv),         &
! #e0&        IRdwsv(ikl,ikv),IRu_SV(ikl,ikv),                          &
! #e0&        HSv_sv(ikl,ikv)+HSs_sv(ikl,ikv),                          &
! #e0&        HLv_sv(ikl,ikv)+HLs_sv(ikl,ikv), TaT_SV(ikl,ikv),         &
! #e0&        dsn_SV(ikl,ikv)*3.6e3,       drr_SV(ikl,ikv)*3.6e3,       &
! #e0&        SoSosv(ikl,ikv)             *sol_SV(ikl,ikv),             &
! #e0&                    IRv_sv(ikl,ikv) *0.5,                         &
! #e0&        HSv_sv(ikl,ikv),HLv_sv(ikl,ikv), TvegSV(ikl,ikv),         &
! #e0&                    SoCasv(ikl,ikv) *sol_SV(ikl,ikv),             &
! #e0&        HSs_sv(ikl,ikv),HLs_sv(ikl,ikv), TsisSV(ikl,ikv,isnoSV(ikl,ikv))
 5001     format(                                                       &
     &         '        |Net Solar| IR Down | IR Up   | HS/Dwn=+|',     &
     &          ' HL/Dwn=+| Temper. |         |  Snow  |  Rain  |',     &
     &       /,'        | [W/m2]  | [W/m2]  | [W/m2]  | [W/m2]  |',     &
     &          ' [W/m2]  | [K]     |         | [mm/h] | [mm/h] |',     &
     &       /,' -------+',7('---------+'),2('--------+'),              &
     &       /,' SISVAT |',f8.1,' |',f8.1,' |',f8.1,' |',f8.1,' |',     &
     &                     f8.1,' |A',f7.2,' |', 8x ,' |',2(f7.2,' |'), &
     &       /,' Canopy |',f8.1,' |', 8x ,' |',f8.1,' |',f8.1,' |',     &
     &                     f8.1,' |',f8.2,' |', 8x ,' |',2( 7x ,' |')   &
     &       /,' Soil   |',f8.1,' |', 8x ,' |', 8x ,' |',f8.1,' |',     &
     &                     f8.1,' |',f8.2,' |', 8x ,' |',2( 7x ,' |'))
 
 
! OUTPUT/Verification: Energy/Water Budget
! #e1     Enrsvd(ikl,ikv) = Enrsvd(ikl,ikv)                              &! Up Surf. IR
! #e1&                + IRs_SV(ikl,ikv)                                  &! Offset
! #e1&        + (      (SoSosv(ikl,ikv)                                  &! Net   Solar
! #e1&                 +SoCasv(ikl,ikv)) *sol_SV(ikl,ikv)                &!
! #e1&          +                     IRdwsv(ikl,ikv)                    &! Downward IR
! #e1&          +                     IRupsv(ikl,ikv)                    &! Upward   IR
! #e1&          +                     HSv_sv(ikl,ikv)+HSs_sv(ikl,ikv)    &! Sensible
! #e1&          +                     HLv_sv(ikl,ikv)+HLs_sv(ikl,ikv))    ! Latent
 
! #e1     write(noUNIT,5002)           Enrsvd(ikl,ikv),                  &
! #e1&                   ETSo_0(ikl,ikv),  ETSo_d(ikl,ikv),              &
! #e1&                   ETSo_0(ikl,ikv)+  ETSo_d(ikl,ikv), ETSo_1(ikl,ikv), &
! #e1&                   EqSn_0(ikl,ikv)                            /dt__SV, &
! #e1&                   EqSn_d(ikl,ikv)                            /dt__SV, &
! #e1&                  (EqSn_1(ikl,ikv)-  EqSn_0(ikl,ikv)- EqSn_d(ikl,ikv))/dt__SV, &
! #e1&                   EqSn_1(ikl,ikv)                            /dt__SV
 5002     format(                                                        &!
     &           ' -----------------+-------------------+',              &!
     &            '-----------------+-+-----------------+',              &!
     &          '-------------------+',                                  &!
     &         /,' SOIL/SNOW/VEGET. |                   |',              &!
     &            ' Power,  Forcing |                   |',              &! Enrsvd
     &          '                   |',                                  &!
! #el&         /,' -----------------+-------------------+',              &!
! #el&            '-----------------+-------------------+',              &!
! #el&          '-------------------+',                                  &!
     &         /,'                  |',   11x ,'        |',              &!
     &                f9.2,' [W/m2] |',   11x ,'        |',              &! Enrsvd
     &                11x ,'        |',                                  &!
     &         /,' -----------------+-------------------+',              &!
     &            '-----------------+-------------------+',              &!
     &          '-------------------+',                                  &!
     &         /,' SOIL/SNOW  (TSo) | Energy/dt, Time 0 |',              &!        ETSo_0
     &            ' Power,  Forcing |   Sum Tim.0+Forc. |',              &! ETSo_d/ETSo_0+d
     &          ' Energy/dt, Time 1 |',                                  &! ETSo_1
! #el&         /,' -----------------+-------------------+',              &!
! #el&            '-----------------+-------------------+',              &!
! #el&          '-------------------+',                                  &!
     &         /,'                  |',  f11.2,' [W/m2] |',              &!        ETSo_0
     &                f9.2,' [W/m2] |',  f11.2,' [W/m2] |',              &! ETSo_d/ETSo_0+d
     &               f11.2,' [W/m2] |',                                  &! ETSo_1
     &         /,' -----------------+-------------------+',              &!
     &            '-----------------+-------------------+',              &!
     &          '-------------------+',                                  &!
     &         /,'      SNOW  (qSn) | Energy/dt, Time 0 |',              &! EqSn_0/dt
     &            ' Power,  Excess  |   D(Tim.1-0-Forc.)|',              &! EqSn_d/dt, 1-0-d
     &          ' Energy/dt, Time 1 |',                                  &! EqSn_1/dt
! #el&         /,' -----------------+-------------------+',              &!
! #el&            '-----------------+-------------------+',              &!
! #el&          '-------------------+',                                  &!
     &         /,'                  |',  f12.2, '[W/m2] |',              &! EqSn_0/dt
     &                f9.2,' [W/m2] |',  f11.2,' [W/m2] |',              &! EqSn_d/dt, 1-0-d
     &               f12.2, '[W/m2] | ',                                 &! EqSn_1/dt
     &         /,' -----------------+-------------------+',              &!
     &            '-----------------+-------------------+',              &!
     &          '-------------------+')                                   !
 
! #e1             EnsBal = ETSo_1(ikl,ikv)-(ETSo_0(ikl,ikv)+Enrsvd(ikl,ikv))
! #e1             EnvBal = Enrsvd(ikl,ikv)- ETVg_d(ikl,ikv)
! #e1     IF (abs(EnsBal).gt.5.e-1                                       &
! #e2&    .OR.lwriSV(ikl,ikv).eq.    2                                   &
! #e1&                            )                                    THEN
! #e1       write(6,6001) daHost,i___SV(lwriSV(ikl,ikv)),                &
! #e1&                           j___SV(lwriSV(ikl,ikv)),                &
! #e1&                           n___SV(lwriSV(ikl,ikv)),                &
! #e1&                           ETSo_1(ikl,ikv),ETSo_0(ikl,ikv),ETSo_d(ikl,ikv),&
! #e1&                           ETSo_1(ikl,ikv)-ETSo_0(ikl,ikv)-ETSo_d(ikl,ikv),&
! #e1&                           Enrsvd(ikl,ikv),ETVg_d(ikl,ikv),ETSo_d(ikl,ikv),&
! #e1&                           Enrsvd(ikl,ikv)-ETVg_d(ikl,ikv)-ETSo_d(ikl,ikv)
 6001       format(a18,3i4,' (EB1'           ,f15.6,                     &
     &                ')  - [(EB0           ',f15.6,')',                 &
     &               /,55x,'+(ATM->Snow/Soil',f15.6,')] ',               &
     &                     '= EBAL'          ,f15.6,' [W/m2]',           &
     &               /,55x,' (ATM->SISVAT'   ,f18.6,                     &
     &               /,55x,'- Veg. ImBal.',   f18.6,')  ',               &
     &               /,55x,'- ATM->SnoSol',   f18.6,')  ',               &
     &                     '= ????'          ,f15.6,' [W/m2]')
! #e1           noEBal = noEBal + 1
! #e2           noEBal = noEBal - 1
! #e1       IF (noEBal.GE.       10) stop 'TOO MUCH ENERGY IMBALANCES'
! #e1     END IF
 
 
! OUTPUT/Verification: * Mass Conservation: Budget [mm w.e.]
! #m1     write(noUNIT,5010)                                             &
! #m1&             SIWm_0(ikl,ikv),  SIWa_i(ikl,ikv)-SIWa_f(ikl,ikv)     &
! #m1&            ,SIWm_0(ikl,ikv)+  SIWa_i(ikl,ikv)-SIWa_f(ikl,ikv)     &
! #m1&                          +SIWe_i(ikl,ikv)-SIWe_f(ikl,ikv)         &
! #m1&                          +SIsubl(ikl,ikv)                         &
! #m1&                          -SImelt(ikl,ikv)                         &
! #m1&                          -SIrnof(ikl,ikv)                         &
! #m2&                          +SIvAcr(ikl,ikv)                         &
! #m1&            ,SIWm_1(ikl,ikv),  SIWe_i(ikl,ikv)-SIWe_f(ikl,ikv)     &
! #m1&            ,              SIsubl(ikl,ikv)                         &
! #m1&            ,             -SImelt(ikl,ikv)                         &
! #m1&            ,             -SIrnof(ikl,ikv)                         &
! #m2&            ,              SIvAcr(ikl,ikv)
 5010     format(' SNOW             |   Snow,   Time 0  |',              &
     &            ' Snow,   Forcing |           Sum     |',              &
     &          '   Snow,   Time 1  |',                                  &
! #el&         /,' -----------------+-------------------+',              &
! #el&            '-----------------+-------------------+',              &
! #el&          '-------------------+',                                  &
     &         /,'                  |',    f13.3,' [mm] |',              &
     &           ' A',  f9.3,' [mm] |',    f13.3,' [mm] |',              &
     &                 f13.3,' [mm] |',                                  &
     &         /,'                  |',     13x ,'      |',              &
     &           ' E',  f9.3,' [mm] |',     13x ,'      |',              &
     &                  13x ,'      |',                                  &
     &         /,'                  |',     13x ,'      |',              &
     &           ' S',  f9.3,' [mm] |',     13x ,'      |',              &
     &                  13x ,'      |',                                  &
     &         /,'                  |',     13x ,'      |',              &
     &           '(M',  f9.3,' [mm])|  (included in A)  |',              &
     &                  13x ,'      |',                                  &
     &         /,'                  |',     13x ,'      |',              &
     &           ' R',  f9.3,' [mm] |',     13x ,'      |',              &
     &                  13x ,'      |',                                  &
! #m2&         /,'                  |',     13x ,'      |',              &
! #m2&           ' O',  f9.3,' [mm] |',     13x ,'      |',              &
! #m2&                  13x ,'      |',                                  &
     &         /,' -----------------+-------------------+',              &
     &            '-----------------+-------------------+',              &
     &          '-------------------+')
! #m1             SnoBal = SIWm_1(ikl,ikv)-(SIWm_0(ikl,ikv)              &
! #m1&                                 +SIWa_i(ikl,ikv)-SIWa_f(ikl,ikv)  &
! #m1&                                 +SIWe_i(ikl,ikv)-SIWe_f(ikl,ikv)) &
! #m1&                                 -SIsubl(ikl,ikv)                  &
! #m1&                                 +SIrnof(ikl,ikv)                  &
! #m2&                                 -SIvAcr(ikl,ikv)
! #m1     IF (abs(SnoBal).gt.eps6)                                  THEN
! #m1       write(6,6010) daHost,i___SV(lwriSV(ikl,ikv)),                &
! #m1&                           j___SV(lwriSV(ikl,ikv)),                &
! #m1&                           n___SV(lwriSV(ikl,ikv)),                &
! #m1&                           SIWm_1(ikl,ikv),SIWm_0(ikl,ikv),        &
! #m1&                           SIWa_i(ikl,ikv),SIWa_f(ikl,ikv),        &
! #m1&                           SIWe_i(ikl,ikv),SIWe_f(ikl,ikv),        &
! #m1&                           SIsubl(ikl,ikv),SImelt(ikl,ikv),        &
! #m2&                           SIrnof(ikl,ikv),SIvAcr(ikl,ikv),        &
! #m1&                           SnoBal
 6010       format(a18,3i4,' (MB1'        ,f12.6,                        &
     &                 ') - [(MB0        ',f12.6,        15x,')',        &
     &               /,51x,'+(ATM Forcing',f12.6,' - ',f12.6,')',        &
     &               /,51x,'+(BLS Forcing',f12.6,' - ',f12.6,')',        &
     &               /,51x,'-(Depo/Sublim',f12.6,        15x,')',        &
     &               /,51x,' !Melting    ',f12.6,'  included in A!',     &
     &               /,51x,'+(Run  OFF   ',f12.6,        15x,')',        &
! #m2&               /,51x,'-(Sea-Ice Acr',f12.6,        15x,')',        &
     &               /,29x,'= *BAL'       ,f12.6,      ' [mm w.e.]')
! #m1           noSBal = noSBal + 1
! #m1       IF (noSBal.GE.       10) stop 'TOO MUCH SNOW MASS IMBALANCE'
! #m1     END IF
 
 
! OUTPUT/Verification: H2O    Conservation: Water  Budget
! #m0     Watsv0(ikl,ikv) =  Watsv0(ikl,ikv)           &! Canopy Water Cont.
! #m0&                 + Wats_0(ikl,ikv)                ! Soil   Water Cont.
! #m0     Watsvd(ikl,ikv) =  Watsvd(ikl,ikv)           &! Canopy Forcing
! #m0&                 + Wats_d(ikl,ikv)                ! Soil   Forcing
 
! #m0     write(noUNIT,5003)                                             &
! #m0&                   Wats_0(ikl,ikv),  Wats_d(ikl,ikv),              &
! #m0&                   Wats_0(ikl,ikv)+  Wats_d(ikl,ikv),    Wats_1(ikl,ikv),  &
! #m0&                   Watsv0(ikl,ikv),  Watsvd(ikl,ikv),              &
! #m0&                   Watsv0(ikl,ikv)+  Watsvd(ikl,ikv),    Wats_1(ikl,ikv)   &
! #m0&                                                +rrCaSV(ikl,ikv)
 5003     format(' SOIL/SNOW  (qSo) |   Water,  Time 0  |',              &
     &            ' Water,  Forcing |           Sum     |',              &
     &          '   Water,  Time 1  |',                                  &
! #el&         /,' -----------------+-------------------+',              &
! #el&            '-----------------+-------------------+',              &
! #el&          '-------------------+',                                  &
     &         /,'                  |',    f13.3,' [mm] |',              &
     &                 f11.3,' [mm] |',    f13.3,' [mm] |',              &
     &                 f13.3,' [mm] |',                                  &
     &         /,' -----------------+-------------------+',              &
     &            '-----------------+-------------------+',              &
     &          '-------------------+',                                  &
     &         /,' SOIL/SNOW/VEGET. |   Water,  Time 0  |',              &
     &            ' Water,  Forcing |           Sum     |',              &
     &          '   Water,  Time 1  |',                                  &
! #el&         /,' -----------------+-------------------+',              &
! #el&            '-----------------+-------------------+',              &
! #el&          '-------------------+',                                  &
     &         /,'                  |',    f13.3,' [mm] |',              &
     &                 f11.3,' [mm] |',    f13.3,' [mm] |',              &
     &                 f13.3,' [mm] |',                                  &
     &         /,' -----------------+-------------------+',              &
     &            '-----------------+-------------------+',              &
     &          '-------------------+')
 
! #m0             WatBal = Wats_1(ikl,ikv)+rrCaSV(ikl,ikv)               &
! #m0&                   -(Watsv0(ikl,ikv)+Watsvd(ikl,ikv))
! #m0     IF (abs(WatBal).gt.eps6)                                  THEN
! #m0       write(6,6002) daHost,i___SV(lwriSV(ikl,ikv)),                &
! #m0&                           j___SV(lwriSV(ikl,ikv)),                &
! #m0&                           n___SV(lwriSV(ikl,ikv)),                &
! #m0&                           Wats_1(ikl,ikv),rrCaSV(ikl,ikv),        &
! #m0&                           Watsv0(ikl,ikv),Watsvd(ikl,ikv),WatBal, &
! #m0&                           Wats_1(ikl,ikv),                        &
! #m0&                           Wats_0(ikl,ikv),Wats_d(ikl,ikv),        &
! #m0&               Wats_1(ikl,ikv)-Wats_0(ikl,ikv)-Wats_d(ikl,ikv)
 6002       format(30x,' NEW Soil Water',3x,' Canopy   Water',3x,        &
     &                 ' OLD SVAT Water',4x,' FRC SVAT Water',           &
     &           /,a18,3i4,f15.6,' + ' ,f15.6,' - ' ,f15.6,              &
     &                           ' -  ',f15.6,'    ', 15x ,'    ',       &
     &      /,31x,'= ',f12.6,' [mm] (Water Balance)',                    &
     &           /,30x,' NEW Soil Water',3x,'               ',3x,        &
     &                 ' OLD Soil Water',4x,' FRC Soil Water',           &
     &           /,30x,f15.6,'   ' , 15x ,' - ' ,f15.6,                  &
     &                       ' -  ',f15.6,'    ', 15x ,'    ',           &
     &      /,31x,'= ',f12.6,' [mm] (3 terms SUM)')
! #m0           noWBal = noWBal + 1
! #m0       IF (noWBal.GE.       10) stop 'TOO MUCH WATER  IMBALANCES'
! #m0     END IF
 
 
! Water/Temperature Profiles
! --------------------------
 
! #e0       write(noUNIT,5004)
 5004       format(' -----+--------+--+-----+--------+----+---+',        &
     &  '--------+----+---+--------+------+-+--------+--------+',        &
     &           /,'    n |     z  |     dz |     ro |    eta |',        &
     &  '     T  |     G1 |     G2 | Extinc |        | HISTORY|',        &
     &           /,'      |    [m] |    [m] | [kg/m3]| [m3/m3]|',        &
     &  '    [K] |    [-] |    [-] |    [-] |        |   [-]  |',        &
     &           /,' -----+--------+--------+--------+--------+',        &
     &  '--------+--------+--------+--------+--------+--------+')
! #e0       write(noUNIT,5005) rusnSV(ikl,ikv),albisv(ikl,ikv)
 5005       format('      |        |        |        |W',f6.3,' |',      &
     &  '        |        |        |A',f6.3,' |        |        |')
! #e0       write(noUNIT,5015)                                           &
! #e0&                    (isn,zzsnsv(ikl,ikv,isn),dzsnSV(ikl,ikv,isn),  &
! #e0&                         ro__SV(ikl,ikv,isn),eta_SV(ikl,ikv,isn),  &
! #e0&                         TsisSV(ikl,ikv,isn),                      &
! #e0&                         G1snSV(ikl,ikv,isn),G2snSV(ikl,ikv,isn),  &
! #e0&                         sEX_sv(ikl,ikv,isn),istoSV(ikl,ikv,isn),  &
! #e0&                     isn=isnoSV(ikl,ikv),1,-1)
 5015       format((i5,' |',2(f7.3,' |'),               f7.1,' |',       &
     &           f7.3,' |' ,  f7.2,' |', 2(f7.1,' |'),  f7.3,' |',       &
     &            7x ,' |' ,  i5,'   |'                          ))
! #e0       write(noUNIT,5006)
 5006       format(' -----+--------+--------+--------+--------+',        &
     &  '--------+--------+--------+--------+--------+--------+')
! #e0       write(noUNIT,5007) TBr_sv(ikl,ikv),
! #e0&                         TvegSV(ikl,ikv),rrCaSV(ikl,ikv)*1.e3,
! #e0&                         EvT_sv(ikl,ikv)*86.4e3
 5007       format(' Brgh |',4(8x,'|'),  f7.2,' | [micm] |',4(8x,'|'),   &
     &           /,' VEGE |',4(8x,'|'),2(f7.2,' |'),        2(8x,'|'),   &
     &                                   f7.3,' |',           8x,'|' )
! #e0       write(noUNIT,5014)
 5014       format(' -----+--------+--------+--------+--------+',        &
     &  '--------+--------+--------+--------+--------+--------+',        &
     &           /,'    n |        |     dz |        |    eta |',        &
     &  '     T  |        |        |        | Root W.| W.Flow |',        &
     &           /,'      |        |    [m] |        | [m3/m3]|',        &
     &  '    [K] |        |        |        | [mm/d] | [mm/h] |',        &
     &           /,' -----+--------+--------+--------+--------+',        &
     &  '--------+--------+--------+--------+--------+--------+')
 
! #e0       write(noUNIT,5008)                                           &
! #e0&                    (isl,    LSdzsv(ikl,ikv)*dz_dSV(    isl),      &
! #e0&                                         eta_SV(ikl,ikv,isl),      &
! #e0&                                         TsisSV(ikl,ikv,isl),      &
! #e0&                                  86.4e3*Rootsv(ikl,ikv,isl),      &
! #e0&                                   3.6e3*Khydsv(ikl,ikv,isl),      &
! #e0&                     isl=0,-nsoil,-1)
 5008       format((i5,' |',   7x ,' |' ,  f7.3,' |' ,   7x ,' |',       &
     &           f7.3,' |' ,  f7.2,' |', 2( 7x ,' |'),   7x ,' |',       &
     &                                     f7.3,' |' ,  f7.2,' |'))
! #e0       write(noUNIT,5006)
! #e0       write(noUNIT,5009) RnofSV(ikl,ikv)* 3.6e3
 5009       format('      |',9(8x,'|'),f7.3,' |')
! #e0       write(noUNIT,5006)
! #e0   END IF
! #e0   END DO
! #e0   END DO
 
 
 
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!                                                         !
! DE-ALLOCATION                                           !
! =============                                           !
 
      IF (flagdalloc)                                THEN !
 
      deallocate          ( tbr_sv )                      ! Brightness Temperature
      deallocate          ( irdwsv )                      ! DOWNward   IR Flux
      deallocate          ( irupsv )                      ! UPward     IR Flux
      deallocate          ( bdzssv )                      ! Buffer Snow Layer Thickness
      deallocate          ( z_snsv )                      ! Snow-Ice, current Thickness
 
! Energy         Budget
! ~~~~~~~~~~~~~~~~~~~~~
! #e1 deallocate          ( ETVg_d )                      ! VegetationPower, Forcing
! #e1 deallocate          ( ETSo_1 )                      ! Soil/Snow Power, after  Forcing
! #e1 deallocate          ( EqSn_0 )                      ! Snow Energy, befor Phase Change
! #e1 deallocate          ( EqSn_1 )                      ! Snow Energy, after Phase Change
! #e1 deallocate          ( EqSn_d )                      ! Energy in Excess
 
! OUTPUT/Verification: H2O    Conservation
! #m0 deallocate          ( Wats_0 )                      ! Soil Water,  before Forcing
! #m0 deallocate          ( Wats_1 )                      ! Soil Water,  after  Forcing
! #m0 deallocate          ( Wats_d )                      ! Soil Water,         Forcing
 
! OUTPUT/Verification: * Mass Conservation
! #m1 deallocate          ( SIsubl )                      ! Snow Sublimed/Deposed Mass
! #m1 deallocate          ( SImelt )                      ! Snow Melted           Mass
! #m1 deallocate          ( SIrnof )                      ! Local Surficial Water + Run OFF
 
! OUTPUT/Verification: SeaIce Conservation
! #m2 deallocate          ( SIvAcr )                      ! Sea-Ice      Vertical Acretion
 
! Energy and Mass Budget
! ~~~~~~~~~~~~~~~~~~~~~~
! #e1 deallocate          ( Enrsvd )                      ! Soil+Vegetat  Power  Forcing
 
                                                          ! H2O    Conservation
! #m0 deallocate          ( Watsv0 )                      ! Soil+Vegetat, before Forcing
! #m0 deallocate          ( Watsvd )                      ! Soil+Vegetat  Water  Forcing
 
                                                          ! * Mass Conservation
! #m1 deallocate          ( SIWm_0       ,SIWm_1 )        ! Snow Initial/Final        Mass
! #m1 deallocate          ( SIWa_i       ,SIWa_f )        ! Snow Initial/Final ATM Forcing
! #m1 deallocate          ( SIWe_i       ,SIWe_f )        ! Snow Initial/Final BLS Forcing
 
 
      deallocate          ( icindx )                      ! No   Ice               Mask
 
      deallocate          ( fallok )                      ! Snow Contribution to the Canopy
 
      END IF                                              !
!                                                         !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 
! END  .main. (SISVAT)
 
 
      return
      end subroutine sisvat
 
 
 
      subroutine sisvat_bsn
 
!--------------------------------------------------------------------------+
!   MAR          SISVAT_BSn                           Wed 26-Jun-2013  MAR |
!     SubRoutine SISVAT_BSn treats Snow Erosion and Deposition             |
!                                                                          |
!     version 3.p.4.1 created by H. Gallee,           Thu 14-Feb-2013      |
!           Last Modification by H. Gallee,           Wed 26-Jun-2013      |
!                                                                          |
!--------------------------------------------------------------------------+
!                                                                          |
!     Preprocessing  Option: STANDARD Possibility                          |
!     ^^^^^^^^^^^^^^^^^^^^^  ^^^^^^^^^^^^^^^^^^^^                          |
!     #BS: Explicit Cloud MICROPHYSICS: Blow. *(Snow)         Model        |
!     #BM: Explicit Cloud MICROPHYSICS: de Montmollin Parameterizat.       |
!     #MA: SNOW Model: Increased polar B* Mobility (Mann et al.2000)       |
!                                                                          |
!                                                                          |
!     Preprocessing  Option:                                               |
!     ^^^^^^^^^^^^^^^^^^^^^                                                |
!     #BA: Budd et al.            1966, Ant.Res.Ser.9    u* BS Threshold   |
!     #BY: Budd et al. 1966, 2~m Averag Blow. *(Snow)    Properties        |
!     #AG: Snow Aging Col de Porte     (Brun et al.1991) discard BS at CdP |
!                                                                          |
!                                                                          |
!     Preprocessing  Option: SISVAT IO (not always a standard preprocess.) |
!     ^^^^^^^^^^^^^^^^^^^^^  ^^^^^^^^^                                     |
!     FILE                 |      CONTENT                                  |
!     ~~~~~~~~~~~~~~~~~~~~~+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
!   # stdout               | #s2: OUTPUT of SnowFall, Snow Buffer          |
!                          |      unit  6, SubRoutine  SISVAT_BSn, _qSn    |
!   # stdout               | #b0: OUTPUT of Snow Erosion Statistics        |
!                          |      unit  6, SubRoutine  SISVAT_BSn **ONLY** |
!--------------------------------------------------------------------------+
 
 
! Global  Variables
! =================
 
      use mod_real
      use mod_phy____dat
      use mod_phy____grd
      use mod_sisvat_grd
 
 
 
! General Variables
! =================
 
      use mod_sisvat_ctr
      use mod_sisvat_dat
      use mod_sisvat_kkl
      use mod_sisvat_loc
      use mod_sisvat_bsn
      use mod_sisvatlbsn
 
 
 
      IMPLICIT NONE
 
 
 
! Local Variables
! ===============
 
      integer                                        ::  ikl,ikv   ,isn   ,isnMAX      !
      integer                                        ::  Mobilm,Mobiln                 !
 
      real(kind=real8)                               ::  DendOK                        ! Dendricity Switch
      real(kind=real8)                               ::  SaltOK                        ! Saltation  Switch
      real(kind=real8)                               ::  MeltOK                        ! Saltation  Switch (Melting Snow)
      real(kind=real8)                               ::  SnowOK                        ! Pack Top   Switch
      real(kind=real8)                               ::  SaltM1,SaltM2,SaltMo          ! Saltation  Parameters
      real(kind=real8)                               ::  SaltMx = -5.83e-2             !
      real(kind=real8)                               ::  ShearX                        ! Arg. Max Shear Stress
      real(kind=real8)                               ::  SaltSU,Salt_U                 !
      real(kind=real8)                               ::  ArgFac,Fac_Mo                 !
      real(kind=real8)                               ::  FacRBS =  2.868               !
      real(kind=real8)                               ::  FacTBS =  0.085               !
      real(kind=real8)                               ::  ArguSi                        !
      real(kind=real8)                               ::  hdrift =  1.00e+1             ! Inverse erodibl.Snow Lay.Thickn.
      real(kind=real8)                               ::  h_mmWE =  0.01e00             ! Eroded Snow Layer Min Thickness
!     real(kind=real8)                               ::  tfv_vk =  5.10e-1             ! * Fall Veloc. / Von Karman Cst
                                                                                       ! tfv (Terminal Fall Veloc. =.216)
                                                                                       ! /vk (Von Karman Constant  =.4  )
                                                                                       ! (Wamser & Lykosov,   1995
                                                                                       !  Contr.Atm.Phys. 68, p.90)
      real(kind=real8)                               ::  dzweqo,dzweqn,bsno_x          !
      real(kind=real8)                               ::                hsno_x          !
      real(kind=real8)                               ::  ro_new                        !
! #BM real(kind=real8)                               ::  PorSno,PorRef                 !
! #BS real(kind=real8)                               ::  Salt_f                        !
      real(kind=real8)                               ::  MIN_Mo                        ! Minimum Mobility Fresh Fallen *
! #MA real(kind=real8)                               ::  AgBlow = 1.00                 ! Snow Mobility    Time  Scale
                                                                                       ! 1 Day (F.Domine, pers.communic.)
! #BS real(kind=real8)                               ::  snofOK                        ! Threshd Snow Fall
 
 
! OUTPUT in SISVAT at specified i,j,k,n (see assignation in PHY_SISVAT)
! OUTPUT           for Snow Erosion Variables
! #b0 real(kind=real8)                               ::  Sno0WE,Sno1WE                 ! Snow Mass before/after Erosion
! #b0 real(kind=real8)                               ::  SnodWE                        ! Snow Mass              Erosion
 
 
 
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!                                                         !
! ALLOCATION                                              !
! ==========                                              !
 
      IF (it_run.EQ.1 .OR. flagdalloc)               THEN !
 
      allocate            ( mobile(kcolp,mwp) )           !
      allocate            ( saltsi(kcolp,mwp,nsnow) )     ! Snow Drift Index
      allocate            ( sdrift(kcolp,mwp,nsnow) )     !
      allocate            ( xdrift(kcolp,mwp) )           !
      allocate            ( zdrift(kcolp,mwp) )           !
      allocate            ( tdepos(kcolp,mwp) )           !
      allocate            ( zdepos(kcolp,mwp,nsnow) )     !
      allocate            ( dbsaux(kcolp,mwp) )           ! Drift Amount   (Dummy Variable)
      allocate            ( isagr1(kcolp,mwp) )           ! 1st     Layer History
      allocate            ( isagr2(kcolp,mwp) )           ! 2nd     Layer History
 
      allocate            ( weagre(kcolp,mwp) )           ! Snow Water Equivalent Thickness
      allocate            ( agrege(kcolp,mwp) )           ! 1. when Agregation constrained
      allocate            ( dzagr1(kcolp,mwp) )           ! 1st     Layer Thickness
      allocate            ( dzagr2(kcolp,mwp) )           ! 2nd     Layer Thickness
      allocate            ( t_agr1(kcolp,mwp) )           ! 1st     Layer Temperature
      allocate            ( t_agr2(kcolp,mwp) )           ! 2nd     Layer Temperature
      allocate            ( roagr1(kcolp,mwp) )           ! 1st     Layer Density
      allocate            ( roagr2(kcolp,mwp) )           ! 2nd     Layer Density
      allocate            ( etagr1(kcolp,mwp) )           ! 1st     Layer Water Content
      allocate            ( etagr2(kcolp,mwp) )           ! 2nd     Layer Water Content
      allocate            ( g1agr1(kcolp,mwp) )           ! 1st     Layer Dendricity/Spher.
      allocate            ( g1agr2(kcolp,mwp) )           ! 2nd     Layer Dendricity/Spher.
      allocate            ( g2agr1(kcolp,mwp) )           ! 1st     Layer Sphericity/Size
      allocate            ( g2agr2(kcolp,mwp) )           ! 2nd     Layer Sphericity/Size
      allocate            ( agagr1(kcolp,mwp) )           ! 1st     Layer Age
      allocate            ( agagr2(kcolp,mwp) )           ! 2nd     Layer Age
 
      END IF                                              !
!                                                         !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 
 
! DATA
! ====
 
! Initialization
! ==============
 
      IF (.NOT.blowin)                                             THEN
               blowin = .true.
               facsbs =  1.             / facrbs
               facubs =  1.             / factbs
               por_bs =  1.             - bsnoro/      rhoice
               sheabs =                   por_bs/(1.00-por_bs)
!              SheaBS =  Arg(sqrt(shear = max shear stress in snow)):
!              shear  =  3.420d00 * exp(-(Por_BS      +Por_BS)          &
!    &                                  /(1.00        -Por_BS))
!              SheaBS :  see de Montmollin         (1978),
!                        These Univ. Sci. Medic. Grenoble, Fig. 1 p. 124
 
             DO ikl=1,kcolp             ! Parameterization of u*th
             DO ikv=1,mwp
               rcd10n      =  1./  26.5 ! was developed from observations made
             END DO
             END DO                     ! during assumed neutral conditions
 
               write(6,5000)  1./  rcd10n
 5000          format(/,' Blowing Snow Model  Initialization     ',     &
     &                /,' Vt / u*t =',f8.2,' (Neutral Assumption)',     &
     &                /,'           ', 8x ,' (Budd assumes  26.5)',/)
      END IF
 
 
! Snow Age (Influence on Snow Erosion Threshold)
! ==============================================
 
! #BS DO isn=1,nsnow
! #BS DO ikl=1,kcolp
! #BS DO ikv=1,mwp
! #BS   agsnSV(ikl,ikv,isn) = agsnSV(ikl,ikv,isn) + dt__SV/86400.
! #BS END DO
! #BS END DO
! #BS END DO
! #BS DO ikl=1,kcolp
! #BS DO ikv=1,mwp
! #BS   isn    = max(1 ,        isnoSV(ikl,ikv))
! #BS   snofOK = max(0.,sign(1.,dsn_SV(ikl,ikv)-eps6))  !  Threshold=1.e-6
! #BS   agsnSV(ikl,ikv,isn) =   (1.-snofOK) *agsnSV(ikl,ikv,isn)! ~0.1 mm w.e./day
! #BS END DO
! #BS END DO
      IF (.NOT.blomod)                                     GO TO 1000
! #AG STOP '?!&~@|@[#@#] --- INCONSISTANT SNOW AGE --- EMERGENCY STOP'
 1000 CONTINUE
 
 
! EROSION
! =======
 
      DO isn = 1,nsnow
      DO ikl = 1,kcolp
      DO ikv=1,mwp
 
! Below the high Snow Density Threshold  (ro__SV < BSnoRo)
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
        dendok   =  max(zer0,sign(un_1,eps6-g1snsv(ikl,ikv,isn)  ))  !
        saltok   =  min(1   , max(istdsv(2)-istosv(ikl,ikv,isn),0))  !
        meltok   =     (un_1                                    &!
     &             -max(zer0,sign(un_1,tf_sno-eps6              &!
     &                                     -tsissv(ikl,ikv,isn)  )))&! Melting Snow
     &           *  min(un_1,dendok                             &!
     &                  +(1.-dendok)                            &!
     &                      *sign(un_1,     g2snsv(ikl,ikv,isn)-1.0))! 1.0 for 1mm
        snowok   =  min(1   , max(isnosv(ikl,ikv)      +1 -isn ,0))  ! Snow Switch
 
        g1snsv(ikl,ikv,isn) =      snowok *    g1snsv(ikl,ikv,isn)  &
     &                  + (1.- snowok)*min(g1snsv(ikl,ikv,isn),g1_dsv)
        g2snsv(ikl,ikv,isn) =      snowok *    g2snsv(ikl,ikv,isn)  &
     &                  + (1.- snowok)*min(g2snsv(ikl,ikv,isn),g1_dsv)
 
        saltok   =  min(un_1 , saltok +    meltok)       * snowok
        saltm1   = -0.750e-2 * g1snsv(ikl,ikv,isn)              &
     &             -0.500e-2 * g2snsv(ikl,ikv,isn)+ 0.500e00
!       SaltM1   :  Guyomarc'h & Merindol, 1997, Ann. Glac.
!         CAUTION:  Guyomarc'h & Merindol Dendricity Sign is +
!         ^^^^^^^^                    MAR Dendricity Sign is -
        saltm2   = -0.833d-2 * g1snsv(ikl,ikv,isn)              &
     &             -0.583d-2 * g2snsv(ikl,ikv,isn)+ 0.833d00
        saltmo   = (dendok   * saltm1 + (1.-dendok) *     saltm2       )
 
! Increased Mobility of Deposed (blown) Snow (Mann et al., 2000, JGR 105,
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~  Fig.2 p.24496 & text below)
        min_mo   =  0.
! #MA   MIN_Mo   =  0.6 * exp(-agsnSV(ikl,ikv,isn)                  /AgBlow)
        saltmo   =                                    max(saltmo,min_mo)
 
        saltmo   =  saltok   * saltmo + (1.-saltok) * min(saltmo,saltmx)
!       SaltMo   =  SaltOK   * SaltMo - (1.-SaltOK) *     0.9500 ! Tuning
        saltmo   =         max(saltmo ,  eps6-un_1)
 
        saltsu   =     (1.00d0+saltmo)     *facsbs
 
! OUTPUT in SISVAT at specified i,j,k,n (see assignation in PHY_SISVAT)
! OUTPUT           for Snow Erosion Variables
! #b0   Salt_U   =        -log(SaltSU)     *FacUBS
! #b0   IF (ii__AP(ikl).EQ.iwr_SV.AND.jj__AP(ikl).EQ.jwr_SV        .AND. &
! #b0&      ikv        .EQ.nwr_SV.AND.isn        .EQ.isnoSV(ikl,ikv))    &
! #b0&    write(6,6010) isnoSV(ikl,ikv),G1snSV(ikl,ikv,isn)/G1_dSV       &
! #b0&                             ,G2snSV(ikl,ikv,isn)/G1_dSV           &
! #b0&                             ,ro__SV(ikl,ikv,isn),agsnSV(ikl,ikv,isn)  &
! #b0&                             ,SaltM1, SaltM2, SaltMo, Salt_U       &
! #b0&                             ,us__SV(ikl,ikv)   / rCd10n
 6010     format(/,'SISVAT_BSn',6x                                       &
     &           ,6x,i3,2x,'G1         =',f6.3,'   G2         =',f7.3    &
     &           ,      '   ro [kg/m3] =',f9.3,'   Age* [Day] =',f9.3    &
     &           ,   /,27x,'SaltM1     =',f6.3,'   SaltM2     =',f7.3    &
     &           ,      '   Mobility I.=',f9.3,'   Vt   [m/s] =',f9.3    &
     &           ,   /,27x,'            ', 6x ,'               ', 7x     &
     &           ,      '               ', 9x ,'   Vn10 [m/s] =',f9.3)
 
! Above the high Snow Density Threshold  (ro__SV > BSnoRo)
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
        por_bs      =  1.000       - ro__sv(ikl,ikv,isn)     /rhoice
        shearx      =                por_bs/max(eps6,un_1-por_bs)
!       ShearX ==> Arg(sqrt(shear)) with shear = max shear stress in snow:
!       shear       =  3.420d00 * exp(-(Por_BS      +Por_BS)             &
!    &                                /max(eps6,un_1-Por_BS))
!                      see de Montmollin         (1978),
!                      These Univ. Sci. Medic. Grenoble, Fig. 1 p. 124
 
! Influence of Density on Shear Stress if ro__SV > BSnoRo
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
        argfac      =  max(zer0  ,sheabs-shearx)     !
!       Fac_Mo      =  exp(       ArgFac       )     ! ** NOT ** tuned
        fac_mo   =     exp(       argfac       )     ! = 1 if ro__SV < BSnoRo
                                                     ! < 1 if ro__SV > BSnoRo
! Snow Drift Index
! ~~~~~~~~~~~~~~~~
        saltsu      =  max(eps6  ,    saltsu)
        saltsu      =  exp(fac_mo*log(saltsu))
        argusi      =     -factbs              *us__sv(ikl,ikv)/rcd10n
        saltsi(ikl,ikv,isn) = (saltsu-exp(argusi)) *facrbs
!       SaltSI          :  Generalization of the Snow Drift Index of
!                          Guyomarc'h & Merindol (1997, Ann.Glaciol.)
 
! Threshold Friction Velocity
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~
        snowok   =  1 -min(1,iabs(isn-isnosv(ikl,ikv)))
        salt_u   =               -log(saltsu)  *facubs
!       Salt_U   :  Guyomarc'h & Merindol, 1997, Ann. Glac.
 
        usthsv(ikl,ikv) =     snowok *   (salt_u   *rcd10n)              &
     &              + (1.-snowok)*    usthsv(ikl,ikv)
 
! Threshold Friction Velocity (Budd et al., 1966)
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~
! #BA   usthSV(ikl,ikv) =     SnowOK *   (Salt_U   /26.5)                &
! #BA&              + (1.-SnowOK)*    usthSV(ikl,ikv)
!       Us(U10)     :  Budd et al.            1966, Ant.Res.Ser.9
!                 (see Pomeroy & Gray 1995 NHRI Sci.Rep.7(30)p.62)
 
! OUTPUT in SISVAT at specified i,j,k,n (see assignation in PHY_SISVAT)
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! OUTPUT           for Snow Erosion Variables
! #b0   IF (ii__AP(ikl).EQ.iwr_SV.AND.jj__AP(ikl).EQ.jwr_SV        .AND. &
! #b0&      ikv        .EQ.nwr_SV.AND.isn        .EQ.isnoSV(ikl,ikv))    &
! #b0&    write(6,6011)     Fac_Mo,Por_BS,SaltSI(ikl,ikv,isn),usthSV(ikl,ikv)
 6011     format(      27x,'Fac_Mo     =',f6.3,'   Por_BS     =',f7.3    &
     &           ,      '   Drift    I.=',f9.3,'   ut*_0[m/s] =',f9.3)
      END DO
      END DO
      END DO
 
 
! Deepest Mobile Snow Layer
! -------------------------
 
      DO ikl = 1,kcolp
      DO ikv=1,mwp
        mobile(ikl,ikv) = nsnow+1
      END DO
      END DO
      DO isn =   nsnow,1,-1
      DO ikl = 1,kcolp
      DO ikv=1,mwp
        isnmax      =       max(   1,          isnosv(ikl,ikv)             )
        isnmax      =       min( isn,          isnmax                  )
        mobiln      = isn * max(zer0,sign(un_1,saltsi(ikl,ikv,isnmax)))
        mobilm      =   1 - min(1   ,          mobile(ikl,ikv) -1 -mobiln)
!       Mobilm      =   1   ONLY IF   Mobiln = Mobile(ikl) -1 (0 otherwise)
 
        mobile(ikl,ikv) =                 mobilm * mobiln               &
     &              +              (1-mobilm)* mobile(ikl,ikv)
      END DO
      END DO
      END DO
 
 
! Weighting the Amount of Snow to erode
! -------------------------------------
 
      DO ikl = 1,kcolp
      DO ikv=1,mwp
        zdrift(ikl,ikv) = 0.0
        xdrift(ikl,ikv) = 0.0
        dbsaux(ikl,ikv) = dbs_sv(ikl,ikv)
      END DO
      END DO
 
      DO isn = 1,nsnow
      DO ikl = 1,kcolp
      DO ikv=1,mwp
        zdrift(ikl,ikv)     =  zdrift(ikl,ikv)                          &
     &            + 0.50 * dzsnsv(ikl,ikv,isn) * (3.25  -saltsi(ikl,ikv,isn))
        sdrift(ikl,ikv,isn) =  saltsi(ikl,ikv,isn)                      &
     &          *exp(  max(ea_min, -zdrift(ikl,ikv)     *hdrift     ))  &
     &          *min(1,max(0     ,  isn +1          -mobile(ikl,ikv)))  &
     &          *min(1,max(0     ,  isnosv(ikl,ikv)     -isn +1     ))  &
!                Last 2 Lines force sdrift = 0 outside mobile Snow Layers
     &          *      max(zer0, sign(un_1,         -dbs_sv(ikl,ikv)))
!                Erosion is allowed only if available Blowing Snow
        xdrift(ikl,ikv)     =           sdrift(ikl,ikv,isn) +xdrift(ikl,ikv)
        zdrift(ikl,ikv)     =  zdrift(ikl,ikv)                          &
     &            + 0.50 * dzsnsv(ikl,ikv,isn) * (3.25  -saltsi(ikl,ikv,isn))
      END DO
      END DO
      END DO
 
! Normalization
! ~~~~~~~~~~~~~
      DO isn = 1,nsnow
      DO ikl = 1,kcolp
      DO ikv=1,mwp
        sdrift(ikl,ikv,isn) =  sdrift(ikl,ikv,isn) /max(eps6,xdrift(ikl,ikv))
      END DO
      END DO
      END DO
 
 
! Weighting the Amount of Snow to depose
! --------------------------------------
 
      DO ikl = 1,kcolp
      DO ikv=1,mwp
        zdrift(ikl,ikv) = 0.0
        tdepos(ikl,ikv) = 0.0
      END DO
      END DO
 
      DO isn = 1,nsnow
      DO ikl = 1,kcolp
      DO ikv=1,mwp
        zdepos(ikl,ikv,isn) =      exp(-zdrift(ikl,ikv)   )             &
     &          *min(1,max(0     ,  isn +1          -mobile(ikl,ikv)))  &
     &          *min(1,max(0     ,  isnosv(ikl,ikv    ) -isn +1     ))
!                Last 2 Lines force zdepos = 0 outside mobile Snow Layers
        tdepos(ikl,ikv) = tdepos(ikl,ikv) + zdepos(ikl,ikv,isn)
        zdrift(ikl,ikv) = zdrift(ikl,ikv) + dzsnsv(ikl,ikv,isn) *ro__sv(ikl,ikv,isn)&
     &                                              /rhowat
      END DO
      END DO
      END DO
 
! Normalization
! ~~~~~~~~~~~~~
      DO isn = 1,nsnow
      DO ikl = 1,kcolp
      DO ikv=1,mwp
        zdepos(ikl,ikv,isn) = zdepos(ikl,ikv,isn) / max(eps6,tdepos(ikl,ikv))
      END DO
      END DO
      END DO
 
! OUTPUT in SISVAT at specified i,j,k,n (see assignation in PHY_SISVAT)
! OUTPUT           for Snow Erosion Variables
! #b0 DO ikl = 1,kcolp
! #b0 DO ikv=1,mwp
! #b0   IF (ii__AP(ikl).EQ.iwr_SV.AND.jj__AP(ikl).EQ.jwr_SV .AND.      &
! #b0&      ikv        .EQ.nwr_SV                          )        THEN
! #b0     Sno0WE =   0.
! #b0   DO isn=1,nsnow
! #b0     Sno0WE =   Sno0WE                                            &
! #b0&           +   dzsnSV(ikl,ikv,isn) *ro__SV(ikl,ikv,isn)
! #b0   END DO
! #b0     write(6,6005)   Sno0WE                    ,dbs_SV(ikl,ikv)
 6005     format(                                                      &
     &      18x,'MB0',6x,'Sno1WE [mm]=',f9.3,19x,'0  dbs_SV [mm]=',f9.6)
! #b0     SnodWE =   dbs_SV(ikl,ikv)
! #b0   END IF
! #b0 END DO
! #b0 END DO
 
 
! Weighted  Erosion (Erosion amount is distributed       ! dbs_SV decreases
! -----------------  over the upper Snow Pack)           ! dzsnSV decreases
 
      DO isn = 1,nsnow
      DO ikl = 1,kcolp
      DO ikv=1,mwp
        snowok      = min(1,max(isnosv(ikl,ikv)+1-isn ,0))  ! Snow Switch
        dzweqo      = dzsnsv(ikl,ikv,isn) *ro__sv(ikl,ikv,isn)  ! [kg/m2, mm w.e.]
        bsno_x      = dbsaux(ikl,ikv)     *sdrift(ikl,ikv,isn)
        dzweqn      = dzweqo          +bsno_x
        dzweqn  = max(dzweqn,          h_mmwe *snowok)
        dbs_sv(ikl,ikv) = dbs_sv(ikl,ikv)    +(dzweqo -dzweqn)
        dzsnsv(ikl,ikv,isn) =              dzweqn                       &
     &                       /max(eps6,ro__sv(ikl,ikv,isn))
      END DO
      END DO
      END DO
 
! OUTPUT in SISVAT at specified i,j,k,n (see assignation in PHY_SISVAT)
! OUTPUT           for Snow Erosion Variables
! #b0 DO ikl = 1,kcolp
! #b0 DO ikv=1,mwp
! #b0   IF (ii__AP(ikl)    .EQ. 1 .AND.  jj__AP(ikl)     .EQ. 1)    THEN
! #b0     SnodWE =   SnodWE         -dbs_SV(ikl,ikv)
! #b0     Sno1WE =   0.
! #b0   DO isn=1,nsnow
! #b0     Sno1WE =   Sno1WE                                             &
! #b0&           +   dzsnSV(ikl,ikv,isn)*ro__SV(ikl,ikv,isn)
! #b0   END DO
! #b0     write(6,6006)Sno1WE      , dbs_SV(ikl,ikv)
 6006     format(                                                       &
     &      18x,'MB1',6x,'Sno1WE [mm]=',f9.3,19x,'1  dbs_SV [mm]=',f9.6)
! #b0     write(6,6007)Sno1WE    ,SnodWE   ,Sno0WE,                     &
! #b0&                (Sno1WE    -SnodWE   -Sno0WE)
 6007     format(                                                       &
     &      18x,'MB ',5x,'(After  [mm]=',f6.0, ')-(Erosion[mm]=', f7.3, &
     &                                         ')-(Before [mm]=', f9.3, &
     &                                         ')= Budget [mm]=', f9.6)
! #b0   END IF
! #b0 END DO
! #b0 END DO
 
 
! ACCUMULATION of BLOWN SNOW                             ! dsn_SV decreases
! --------------------------                             ! dzsnSV increases
 
        DO ikl = 1,kcolp
        DO ikv=1,mwp
          tdepos(ikl,ikv) = dsn_sv(ikl,ikv) * dsnbsv(ikl,ikv) * dt__sv
          weagre(ikl,ikv) = 0.
 
! OUTPUT in SISVAT at specified i,j,k,n (see assignation in PHY_SISVAT)
! OUTPUT           for Snow Erosion Variables
! #b0     IF (ii__AP(ikl).EQ.iwr_SV.AND.jj__AP(ikl).EQ.jwr_SV      .AND. &
! #b0&        ikv        .EQ.nwr_SV.AND.0          .LT.isnoSV(ikl,ikv))  &
! #b0&        write(6,6003) tdepos(ikl,ikv)  ,Mobile(ikl,ikv)
 6003         format(/,41x,'tdepos [-] =',f6.3,40x,'Mobil',i3            &
     &              ,/,27x,'Salt.Index    sdrift'                        &
     &              ,      '    zdepos  ro__snow  ro_bsnow  roN_snow'    &
     &              ,                '  dz__snow  dz_bsnow  dzN_snow'    &
     &              ,                '  d___snow'                        &
     &              ,/,27x,'             [kg/m3]   [kg/m3]   [kg/m3]'    &
     &              ,                '       [m]       [m]       [m]'    &
     &              ,                '   [kg/m2]')
        END DO
        END DO
 
      DO isn =     nsnow,1,-1
        DO ikl = 1,kcolp
        DO ikv=1,mwp
          weagre(ikl,ikv) = weagre(ikl,ikv) + ro__sv(ikl,ikv,isn)*dzsnsv(ikl,ikv,isn)
          isagr1(ikl,ikv) = istosv(ikl,ikv,isn)
          isagr2(ikl,ikv) = 0.
 
! Density of deposited blown Snow
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
          ro_new =                    bsnoro
 
! Density of deposited blown Snow (de Montmollin, 1978)
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! #BM     PorSno =      1.0d00     -  ro__SV(ikl,ikv,isn)               &
! #BM&                             /  rhoIce
! #BM     Salt_f =      usthSV(ikl,ikv)/  max(eps6,   us__SV(ikl,ikv))
! #BM     Salt_f =  min(Salt_f     ,  un_1)
! #BM     PorRef =      PorSno     /  max(eps6,1.-PorSno)               &
! #BM&             +log(Salt_f)
! #BM     Por_BS =      PorRef     / (1.0d00 + PorRef)
! #BM     ro_new =      rhoIce     * (1.0d00 - Por_BS)
! #BM     ro_new =  max(ro_new     ,  BSnoRo)
 
          roagr1(ikl,ikv) = ro__sv(ikl,ikv,isn)
          roagr2(ikl,ikv) = ro_new
          hsno_x      = tdepos(ikl,ikv)*  zdepos(ikl,ikv,isn)
 
          dzagr1(ikl,ikv) = dzsnsv(ikl,ikv,isn)
          dzagr2(ikl,ikv) = hsno_x     /  ro_new
!         Conversion    [kg/m2, i.e., mm w.e.] -----> [mSnow]
 
          dsn_sv(ikl,ikv) = dsn_sv(ikl,ikv)-  hsno_x / dt__sv
 
! Other Snow Properties
! ~~~~~~~~~~~~~~~~~~~~~
          t_agr1(ikl,ikv) =    tsissv(ikl,ikv,isn)
          t_agr2(ikl,ikv) =min(tf_sno,tat_sv(ikl,ikv))
          etagr1(ikl,ikv) =    eta_sv(ikl,ikv,isn)
          etagr2(ikl,ikv) =    0.0
          g1agr1(ikl,ikv) =    g1snsv(ikl,ikv,isn)
          g1agr2(ikl,ikv) =    g1_dsv
          g2agr1(ikl,ikv) =    g2snsv(ikl,ikv,isn)
          g2agr2(ikl,ikv) =    adsdsv
! #BY     G2agr2(ikl,ikv) =    0.87d0
!         Budd et al. 1966, 2~m Average /Table 5 p. 97
 
          agagr1(ikl,ikv) =    agsnsv(ikl,ikv,isn)
          agagr2(ikl,ikv) =    0.
          agrege(ikl,ikv) =    1.
        END DO
        END DO
 
! Agregation
! ~~~~~~~~~~
        DO ikl=1,kcolp
        DO ikv=1,mwp
 
!            **********
        call sisvat_zag                                                &
     &             (ikl,ikv,isagr1(ikl,ikv),isagr2(ikl,ikv),weagre(ikl,ikv)&
     &                 ,dzagr1(ikl,ikv),dzagr2(ikl,ikv),t_agr1(ikl,ikv),t_agr2(ikl,ikv)&
     &                 ,roagr1(ikl,ikv),roagr2(ikl,ikv),etagr1(ikl,ikv),etagr2(ikl,ikv)&
     &                 ,g1agr1(ikl,ikv),g1agr2(ikl,ikv),g2agr1(ikl,ikv),g2agr2(ikl,ikv)&
     &                 ,agagr1(ikl,ikv),agagr2(ikl,ikv),agrege(ikl,ikv)&
     &                 )
!            **********
 
        END DO
        END DO
 
 
        DO ikl = 1,kcolp
        DO ikv=1,mwp
 
! OUTPUT in SISVAT at specified i,j,k,n (see assignation in PHY_SISVAT)
! OUTPUT           for Snow Erosion Variables
! #b0     IF (ii__AP(ikl).EQ.iwr_SV.AND.jj__AP(ikl).EQ.jwr_SV      .AND. &
! #b0&        ikv        .EQ.nwr_SV.AND.isn        .LE.isnoSV(ikl,ikv))  &
! #b0&        write(6,6004)   isn          ,SaltSI(ikl,ikv,isn)          &
! #b0&                     ,sdrift(ikl,ikv,isn),zdepos(ikl,ikv,isn)      &
! #b0&                     ,ro__SV(ikl,ikv,isn),roagr2(ikl,ikv),roagr1(ikl,ikv)  &
! #b0&                     ,dzsnSV(ikl,ikv,isn),dzagr2(ikl,ikv),dzagr1(ikl,ikv)  &
! #b0&                     ,dsn_SV(ikl,ikv)
 6004         format((27x,i3,f7.2,2f10.6,3f10.3,4f10.6))
 
          istosv(ikl,ikv,isn) = isagr1(ikl,ikv)
          dzsnsv(ikl,ikv,isn) = dzagr1(ikl,ikv)
          tsissv(ikl,ikv,isn) = t_agr1(ikl,ikv)
          ro__sv(ikl,ikv,isn) = roagr1(ikl,ikv)
          eta_sv(ikl,ikv,isn) = etagr1(ikl,ikv)
          g1snsv(ikl,ikv,isn) = g1agr1(ikl,ikv)
          g2snsv(ikl,ikv,isn) = g2agr1(ikl,ikv)
          agsnsv(ikl,ikv,isn) = agagr1(ikl,ikv)
 
        END DO
        END DO
 
      END DO
 
! OUTPUT in SISVAT for ikl = 1 (preferably for Stand Alone Version)
! OUTPUT           for SnowFall and Snow Buffer
! #s2   IF          (isnoSV(1,1) .GT. 0)                               &
! #s2&  write(6,6008)isnoSV(1,1),  dsn_SV(1) *dt__SV + BufsSV(1,1),    &
! #s2&              (dzsnSV(1,isn)*ro__SV(1,isn),isn=1,isnoSV(1,1))
 6008   format(i3,'  dsn+Buf=',f6.2,6x,'A dz *ro =',10f6.2,            &
     &                                       (/,35x,10f6.2))
 
        DO ikl = 1,kcolp
        DO ikv=1,mwp
          hdrift      =  tdepos(ikl,ikv)/dt__sv
          esnbsv(ikl,ikv) = (dsnbsv(ikl,ikv)-1.00)*hdrift/max(dsn_sv(ikl,ikv),eps6) &
     &                  +dsnbsv(ikl,ikv)
          dsnbsv(ikl,ikv) =          min(un_1,   max(zer0,esnbsv(ikl,ikv) )   )
!         dsnbSV is now the Blown Snow fraction of precipitating snow
!                will be used for characterizing the Buffer Layer
!               (see update of  Bros_N, G1same, G2same, zroOLD, zroNEW)
        END DO
        END DO
 
 
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!                                                         !
! DE-ALLOCATION                                           !
! =============                                           !
 
      IF (flagdalloc)                                THEN !
 
      deallocate          ( saltsi )                      ! Snow Drift Index
      deallocate          ( sdrift )                      !
      deallocate          ( xdrift )                      !
      deallocate          ( zdrift )                      !
      deallocate          ( tdepos )                      !
      deallocate          ( zdepos )                      !
      deallocate          ( dbsaux )                      ! Drift Amount   (Dummy Variable)
      deallocate          ( isagr1 )                      ! 1st     Layer History
      deallocate          ( isagr2 )                      ! 2nd     Layer History
 
      deallocate          ( weagre )                      ! Snow Water Equivalent Thickness
      deallocate          ( agrege )                      ! 1. when Agregation constrained
      deallocate          ( dzagr1 )                      ! 1st     Layer Thickness
      deallocate          ( dzagr2 )                      ! 2nd     Layer Thickness
      deallocate          ( t_agr1 )                      ! 1st     Layer Temperature
      deallocate          ( t_agr2 )                      ! 2nd     Layer Temperature
      deallocate          ( roagr1 )                      ! 1st     Layer Density
      deallocate          ( roagr2 )                      ! 2nd     Layer Density
      deallocate          ( etagr1 )                      ! 1st     Layer Water Content
      deallocate          ( etagr2 )                      ! 2nd     Layer Water Content
      deallocate          ( g1agr1 )                      ! 1st     Layer Dendricity/Spher.
      deallocate          ( g1agr2 )                      ! 2nd     Layer Dendricity/Spher.
      deallocate          ( g2agr1 )                      ! 1st     Layer Sphericity/Size
      deallocate          ( g2agr2 )                      ! 2nd     Layer Sphericity/Size
      deallocate          ( agagr1 )                      ! 1st     Layer Age
      deallocate          ( agagr2 )                      ! 2nd     Layer Age
 
      END IF                                              !
!                                                         !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 
      return
      end subroutine sisvat_bsn
 
 
 
      subroutine sisvat_bdu
 
!--------------------------------------------------------------------------+
!   MAR          SISVAT_BDu                           Wed 26-Jun-2013  MAR |
!     SubRoutine SISVAT_BDu treats Dust Erosion                            |
!                                                                          |
!     version 3.p.4.1 created by H. Gallee,           Thu 14-Feb-2013      |
!           Last Modification by H. Gallee,           Wed 26-Jun-2013      |
!                                                                          |
!--------------------------------------------------------------------------+
!                                                                          |
!     OUTPUT:  usthSV   : Blowing Snow Erosion   Threshold           [m/s] |
!     ^^^^^^                                                               |
!                                                                          |
!     REFER. : Fecan, F., B. Marticorena and G. Bergametti, 1999   (Fal99) |
!     ^^^^^^^^ Ann. Geophysicae 17, 149--157                               |
!              u* threshold: adapted from Fig. 4 p. 153                    |
!              Clay Content:         from Tab. 2 p. 155                    |
!                                                                          |
!--------------------------------------------------------------------------+
 
 
 
! Global  Variables
! =================
 
      use mod_real
      use mod_phy____dat
      use mod_phy____grd
      use mod_sisvat_grd
 
 
 
! General Variables
! =================
 
      use mod_sisvat_dat
      use mod_sisvat_kkl
      use mod_sisvat_bdu
 
 
 
      IMPLICIT NONE
 
 
 
! Local   Variables
! =================
 
      integer           ::             ikl,ikv   ,  isot
 
      real(kind=real8)  ::             eta_Du,usthDu
 
 
! Initialisation
! ==============
 
      IF (.NOT.logust)                                              THEN
        DO isot=1,nsot
               etaust(isot) = 0.0014 * claypc(isot) * claypc(isot)      &! Fal99
     &                      + 0.17   * claypc(isot)                      ! Eqn.(14)
        END DO                                                           !  p. 154
               logust = .true.
      END IF
 
 
! Soil Erodibility
! ----------------
 
      DO ikl = 1,kcolp
      DO ikv = 1,mwp
        eta_du      =  max(     eta_sv(ikl,ikv,0),etaust(isotsv(ikl,ikv)))   ! Fal99
        eta_du      =  max(eps6,eta_sv(ikl,ikv,0)-eta_du             )   ! Eqn.(15)
        usthdu      = sqrt(un_1+1.21*exp(0.68*   log(eta_du)    ))      &! p.  155
     &              *                         ustdmn(isotsv(ikl,ikv))   &!
     &              *                         f__ust(ivgtsv(ikl,ikv))    !
        usthsv(ikl,ikv) =                                               &
     &                 usthsv(ikl,ikv)*(1-max(0,1-isnosv(ikl,ikv))) +   &
     &                 usthdu     *   max(0,1-isnosv(ikl,ikv))
      END DO
      END DO
 
 
      return
      end subroutine sisvat_bdu
 
 
 
      subroutine sisvat_sic(                                            &
! #m2&                      SIvAcr                                      &
     &                     )
 
!--------------------------------------------------------------------------+
!   MAR          SISVAT_SIc                           Wed 26-Jun-2013  MAR |
!     SubRoutine SISVAT_SIc treats Sea-Ice and Ocean Latent Heat Exchanges |
!                                                                          |
!     version 3.p.4.1 created by H. Gallee,           Thu 14-Feb-2013      |
!           Last Modification by H. Gallee,           Wed 26-Jun-2013      |
!                                                                          |
!--------------------------------------------------------------------------+
!                                                                          |
!     INPUT:   TaT_SV   : SBL Top    Temperature                       [K] |
!     ^^^^^    isnoSV   : total Nb of Ice/Snow Layers                  [-] |
!              LSmask   : Land-Sea   Mask                              [-] |
!              dsn_SV   : Snow  Intensity                      [mm w.e./s] |
!                                                                          |
!     INPUT /  TsisSV   : Snow/Ice/Soil-Water Temperature              [K] |
!     OUTPUT:  eta_SV   : Soil/Snow Water   Content                [m3/m3] |
!     ^^^^^^   dzsnSV   : Snow Layer        Thickness                  [m] |
!                                                                          |
!     OUTPUT:  HFraSV   : Frazil            Thickness                  [m] |
!     ^^^^^^                                                               |
!                                                                          |
!                                                                          |
!     Preprocessing  Option:                                               |
!     ^^^^^^^^^^^^^^^^^^^^^                                                |
!     #SJ: Sea-Ice Bottom   accretion  and  ocean cooling due to SnowFall  |
!                                                                          |
!--------------------------------------------------------------------------+
 
 
! Global  Variables
! =================
 
      use mod_real
      use mod_phy____dat
      use mod_phy____grd
      use mod_sisvat_grd
 
 
 
! General Variables
! =================
 
      use mod_sisvat_ctr
      use mod_sisvat_dat
      use mod_sisvat_kkl
      use mod_sisvat_sic
! #m2 use Mod_SISVATLSIc
 
 
 
      IMPLICIT NONE
 
 
 
! Local Variables
! ===============
 
      integer           ::            ikl   ,ikv   ,n
      real(kind=real8)  ::            OCN_OK
! #SJ real(kind=real8)  ::            SIceOK
! #SJ real(kind=real8)  ::            SIcFrz
! #SJ real(kind=real8)  ::            Twat_n
 
      real(kind=real8)  ::            SalIce = 10.                     ! Sea-Ice   Salinity
      real(kind=real8)  ::            SalWat = 35.                     ! Sea-Water Salinity
                                                                       !  Typical Salinities in Terra Nova Bay
                                                                       ! (Bromwich and Kurtz,   1984, JGR, p.3568;
                                                                       !  Cavalieri and Martin, 1985,      p. 248)
 
 
 
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!                                                                      !
! ALLOCATION                                                           !
! ==========                                                           !
 
! #m2 IF (it_RUN.EQ.1 .OR. FlagDALLOC)                            THEN !
 
! #m2 allocate                                       ( SIvAcr(kcolp,mwp) )
 
! #m2 END IF
!                                                                      !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 
 
! Initialisation
! ==============
 
      IF (.NOT.sicini)                                              THEN
               sicini =  .true.
               crodzw =  hc_wat*rhowat *          dz_dsv(0)     ! [J/m2/K]
               lro__i =  lhfh2o*rhoice *(1.-1.e-3*salice       &! [J/m3]
     &                 -(salice/salwat)*(1.-1.e-3*salwat) )     !
 
! OUTPUT/Verification: Energy/Water Budget
! #e1          Lro__I =  LhfH2O*rhoIce
 
      END IF
 
 
! Snow Fall cools Sea Water
! =========================
 
      DO ikl=1,kcolp
      DO ikv=1,mwp
        ocn_ok        =  (1   -lsmask(ikl,ikv) )                       &! Free Ocean
     &             *max(0,1   -isnosv(ikl,ikv)   )                      !
! #SJ   TsisSV(ikl,ikv,0) =        TsisSV(ikl,ikv,0)                   &! [K]
! #SJ& -OCN_OK*(Cn_dSV*(Tf_Sno-TaT_SV(ikl,ikv)   )                     &! [J/kg]
! #SJ&         +LhfH2O*(1.    -eta_SV(ikl,ikv,0)))                     &! [J/kg]
! #SJ&        * dsn_SV(ikl,ikv)   *dt__SV          / Crodzw             ! [kg/m2]
 
 
! Sea-Ice Formation
! =================
 
! #SJ   Twat_n      =      max(TsisSV(ikl,ikv,0  )  ,Tf_Sea)    ! [K]
! #SJ   SIcFrz      =  (Twat_n-TsisSV(ikl,ikv,0  ) )*Crodzw/Lro__I &! [m]
! #SJ&                              * 0.75
!  ***  Hibler (1984), Ocean Heat Flux: 25% of cooling (ANTARCTIC Ocean)
!      (Hansen and Takahashi Eds)
!       Geophys. Monogr. 29, M. Ewing Vol. 5, AGU, p. 241
 
 
! Frazil  Formation
! -----------------
 
! #SJ   HFraSV(ikl,ikv) =          SIcFrz           *OCN_OK
 
 
! Growth of the Sea-Ice First Ice Floe
! ------------------------------------
 
! #SJ   SIceOK        =  (1   -LSmask(ikl,ikvp,n)  )         &! Ice Cover.Ocean
! #SJ&             *min(  1   ,isnoSV(ikl,ikv)     )          !
! #SJ   dzsnSV(ikl,ikv,1) =        dzsnSV(ikl,ikv,1)         &! Vertical Acret.
! #SJ&                +        SIcFrz           *SIceOK       !
 
 
! OUTPUT/Verification: SeaIce Conservation: Diagnostic of Surface Mass Balance
! #m2   SIvAcr(ikl,ikv) = rhoIce*SIcFrz     *(OCN_OK+SIceOK)           &
! #m2&              - dt__SV*dsn_SV(ikl,ikv)* OCN_OK
 
 
! Water Fluxes Update
! -------------------
 
        rnofsv(ikl,ikv) =          rnofsv(ikl,ikv)                     &
     &              +          dsn_sv(ikl,ikv) *     ocn_ok
        dsn_sv(ikl,ikv) =          dsn_sv(ikl,ikv) * (1.-ocn_ok)
 
      END DO
      END DO
 
 
 
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!                                                                      !
! DE-ALLOCATION                                                        !
! =============                                                        !
 
! #m2 IF (FlagDALLOC)                                             THEN !
 
! #m2 deallocate                                     ( SIvAcr )
 
! #m2 END IF                                                           !
!                                                                      !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 
      return
      end subroutine sisvat_sic
 
 
 
      subroutine sisvat_zsn
 
!--------------------------------------------------------------------------+
!   MAR          SISVAT_zSn                           Wed 26-Jun-2013  MAR |
!     SubRoutine SISVAT_zSn manages the Snow Pack vertical Discretization  |
!                                                                          |
!     version 3.p.4.1 created by H. Gallee,           Mon  4-Feb-2013      |
!           Last Modification by H. Gallee,           Wed 26-Jun-2013      |
!                                                                          |
!--------------------------------------------------------------------------+
!                                                                          |
!     PARAMETERS:  kcolv: Total Number of columns =                        |
!     ^^^^^^^^^^        = Total Number of continental     grid boxes       |
!                       X       Number of Mosaic Cell per grid box         |
!                                                                          |
!     INPUT /  NLaysv   = New             Snow Layer  Switch               |
!     OUTPUT:  isnoSV   = total Nb of Ice/Snow Layers                      |
!     ^^^^^^   ispiSV   = 0,...,nsno: Uppermost Superimposed Ice Layer     |
!              iiceSV   = total Nb of Ice      Layers                      |
!              istoSV   = 0,...,5 :   Snow     History (see istdSV data)   |
!                                                                          |
!     INPUT /  TsisSV   : Soil/Ice Temperatures (layers -nsoil,-nsoil+1, 0)|
!     OUTPUT:           & Snow     Temperatures (layers  1,2,...,nsno) [K] |
!     ^^^^^^   ro__SV   : Soil/Snow Volumic Mass                   [kg/m3] |
!              eta_SV   : Soil/Snow Water   Content                [m3/m3] |
!              dzsnSV   : Snow Layer        Thickness                  [m] |
!              G1snSV   : Dendricity (<0) or Sphericity (>0) of Snow Layer |
!              G2snSV   : Sphericity (>0) or Size            of Snow Layer |
!              agsnSV   : Snow       Age                             [day] |
!                                                                          |
!     METHOD:  1) Agregate the thinest Snow Layer                          |
!     ^^^^^^      if a new Snow Layer has been precipitated   (NLaysv = 1) |
!              2) Divide   a too thick Snow Layer except                   |
!                 if the maximum Number of Layer is reached                |
!                 in this case forces                          NLay_s = 1  |
!              3) Agregate the thinest Snow Layer                          |
!                 in order to divide a too thick Snow Layer                |
!                 at next Time Step when                       NLay_s = 1  |
!                                                                          |
!                                                                          |
!     Preprocessing  Option: #SX: Search Ice/Snow Interface in Snow Model  |
!     ^^^^^^^^^^^^^^^^^^^^^                                                |
!                                                                          |
!     Preprocessing  Option: SISVAT IO (not always a standard preprocess.) |
!     ^^^^^^^^^^^^^^^^^^^^^  ^^^^^^^^^                                     |
!     FILE                 |      CONTENT                                  |
!     ~~~~~~~~~~~~~~~~~~~~~+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
!   # SISVAT_zSn.vz        | #vz: OUTPUT/Verification: Snow Layers Agrega. |
!                          |      unit 41, SubRoutine  SISVAT_zSn **ONLY** |
!   # SISVAT_GSn.vp        | #vp: OUTPUT/Verification: Snow   Properties   |
!                          |      unit 47, SubRoutines SISVAT_zSn, _GSn    |
!   # stdout               | #s1: OUTPUT of Snow Layers Agregation         |
!                          |      unit  6, SubRoutine  SISVAT_zSn, _zAg    |
!--------------------------------------------------------------------------+
 
 
! Global  Variables
! =================
 
      use mod_real
      use mod_phy____dat
      use mod_phy____grd
      use mod_sisvat_grd
 
 
 
! General Variables
! =================
 
      use mod_sisvat_dat
      use mod_sisvat_dzs
      use mod_sisvat_kkl
      use mod_sisvat_loc
      use mod_sisvat_zsn
      use mod_sisvatlzsn
 
 
 
      IMPLICIT NONE
 
 
 
! Internal Variables
! ==================
 
      integer                                      ::  ikl,ikv   ,isn   ,i !
 
      integer                                      ::  LstLay          ! 0 ====> isnoSV = 1
      integer                                      ::  isno_n          ! Snow Normal.Profile
      integer                                      ::  iice_n          ! Ice  Normal.Profile
      integer                                      ::  iiceOK          ! Ice         Switch
      integer                                      ::  icemix = 0      ! 0 ====> Agregated Snow+Ice=Snow
                                                                       ! 1                          Ice
      real(kind=real8)                             ::  staggr          !              stagger  Switch
 
      real(kind=real8)                             ::  OKthin          ! Swich ON  a  new thinest layer
      real(kind=real8)                             ::  dz_dif          ! difference from ideal discret.
      real(kind=real8)                             ::  thickL          ! Thick Layer          Indicator
! #SX real(kind=real8)                             ::  OK_ICE          ! Swich ON   uppermost Ice Layer
 
      real(kind=real8)                             ::  dzepsi = 0.0015 ! Min Single Snw Layer Thickness
      real(kind=real8)                             ::  dzxmin = 0.0020 ! Min Acceptable Layer Thickness
      real(kind=real8)                             ::  dz_min = 0.0050 ! Min Local      Layer Thickness
      real(kind=real8)                             ::  dz_max = 0.0300 ! Min Gener.     Layer Thickness
!     CAUTION:                           dz_max > dz_min*2 is required ! Otherwise re-agregation is
                                                                       ! activated  after splitting
 
 
 
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!                                                                      !
! ALLOCATION                                                           !
! ==========                                                           !
 
      IF (it_run.EQ.1 .OR. flagdalloc)                            THEN !
 
      allocate            ( nlay_s(kcolp,mwp) )                        ! Split Snow Layer         Switch
      allocate            ( isagr1(kcolp,mwp) )                        ! 1st     Layer History
      allocate            ( isagr2(kcolp,mwp) )                        ! 2nd     Layer History
      allocate            ( isn1(kcolp,mwp) )                        ! 1st layer to stagger
      allocate            ( weagre(kcolp,mwp) )                        ! Snow Water Equivalent Thickness
      allocate            ( dzthin(kcolp,mwp) )                        ! Thickness of the thinest layer
      allocate            ( agrege(kcolp,mwp) )                        ! 1. when Agregation constrained
      allocate            ( dzagr1(kcolp,mwp) )                        ! 1st     Layer Thickness
      allocate            ( dzagr2(kcolp,mwp) )                        ! 2nd     Layer Thickness
      allocate            ( t_agr1(kcolp,mwp) )                        ! 1st     Layer Temperature
      allocate            ( t_agr2(kcolp,mwp) )                        ! 2nd     Layer Temperature
      allocate            ( roagr1(kcolp,mwp) )                        ! 1st     Layer Density
      allocate            ( roagr2(kcolp,mwp) )                        ! 2nd     Layer Density
      allocate            ( etagr1(kcolp,mwp) )                        ! 1st     Layer Water Content
      allocate            ( etagr2(kcolp,mwp) )                        ! 2nd     Layer Water Content
      allocate            ( g1agr1(kcolp,mwp) )                        ! 1st     Layer Dendricity/Spher.
      allocate            ( g1agr2(kcolp,mwp) )                        ! 2nd     Layer Dendricity/Spher.
      allocate            ( g2agr1(kcolp,mwp) )                        ! 1st     Layer Sphericity/Size
      allocate            ( g2agr2(kcolp,mwp) )                        ! 2nd     Layer Sphericity/Size
      allocate            ( agagr1(kcolp,mwp) )                        ! 1st     Layer Age
      allocate            ( agagr2(kcolp,mwp) )                        ! 2nd     Layer Age
 
! #vz allocate            ( dz_ref(nsnow) )                            ! Snow Reference Discretization
! #vz allocate            ( dzwdif(nsnow) )                            !
 
      END IF                                                           !
!                                                                      !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 
 
! OUTPUT/Verification: Snow Layers Agregation
! #vz IF (.NOT.as_opn)                                              THEN
! #vz          as_opn=.true.
! #vz     open(unit=41,status='unknown',file='SISVAT_zSn.vz')
! #vz     rewind    41
! #vz END IF
 
! OUTPUT/Verification: Snow Layers Agregation: Properties
! #vp IF (.NOT.VP_opn)                                              THEN
! #vp          VP_opn=.true.
! #vp     open(unit=47,status='unknown',file='SISVAT_GSn.vp')
! #vp     rewind    47
! #vp END IF
 
 
! Constrains Agregation         of too thin  Layers
! =================================================
 
! Search the thinest  non-zero Layer
! ----------------------------------
 
        DO ikl=1,kcolp
        DO ikv=1,mwp
          dzthin(ikl,ikv) = 0.                          ! Arbitrary unrealistic
        END DO
        END DO                                          !       Layer Thickness
      DO   isn=1,nsnow
        DO ikl=1,kcolp
        DO ikv=1,mwp
          isno_n    =             isnosv(ikl,ikv)-isn+1 ! Snow Normal.Profile
          iice_n    =             iicesv(ikl,ikv)-isn   ! Ice  Normal.Profile
          iiceok    = min(1,max(0,iice_n         +1))   ! Ice         Switch
 
! OUTPUT/Verification: Snow Layers Agregation
! #vz     dz_ref(isn) =                                &!
! #vz&          dz_min *((1-iiceOK)*isno_n*isno_n      &! Theoretical Profile
! #vz&                 +    iiceOK *    2**iice_n)     &!
! #vz&               /max(1,isnoSV(ikl,ikv))            !
 
          dz_dif      = max(zer0,                      &! Actual      Profile
     &          dz_min                                 &!
     &                 *((1-iiceok)*isno_n*isno_n      &! Theoretical Profile
     &                 +    iiceok *2.   **iice_n)     &!
     &        - dzsnsv(ikl,ikv, isn)                    )   ! Actual      Profile
 
! OUTPUT/Verification: Snow Layers Agregation
! #vz     dzwdif(isn) =     dz_dif                      !
 
          okthin      = max(zer0,                      &!
     &                      sign(un_1,                 &!
     &                           dz_dif-dzthin(ikl,ikv)))  &! 1.=> New thinest Lay.
     &                * max(0,                         &! 1 => .le. isnoSV
     &                  min(1,                         &! 1 => isn is in the
     &                      isnosv(ikl,ikv)-isn +1 ))  &!          Snow Pack
     &                * min(un_1,                      &         !
!
!                       1st additional Condition to accept OKthin
     &                  max(zer0,                               &! combination
     &                      sign(un_1,g1snsv(ikl,ikv,      isn  )   &! G1 with same
     &                               *g1snsv(ikl,ikv,max(1,isn-1))))&!  sign => OK
!
!                       2nd additional Condition to accept OKthin
     &                + max(zer0,                               &! G1>0
     &                      sign(un_1,g1snsv(ikl,ikv,      isn   )))&!  =>OK
!
!                       3rd additional Condition to accept OKthin
     &                + max(zer0,                               &! dz too small
     &                      sign(un_1,dzxmin                    &!  =>OK
     &                               -dzsnsv(ikl,ikv,      isn   ))))!
 
          i_thin(ikl,ikv) =    (1. - okthin)  * i_thin(ikl,ikv)&! Update   thinest Lay.
     &                         + okthin   * isn         !                Index
          dzthin(ikl,ikv) =    (1. - okthin)  * dzthin(ikl,ikv)&!
     &                         + okthin   * dz_dif      !
        END DO
        END DO
      END DO
 
! OUTPUT/Verification: Snow Layers Agregation
! #vz     write(41,4150) daHost     ,n___SV(  lwriSV(1,1))             &
! #vz&                  ,i_thin(1,1),dzsnSV(1,i_thin(1,1))
 4150     format(/,'-',a18,i5,' ',70('-'),                             &
     &           /,' Thinest ',i3,':',f9.3)
 
      DO   isn=1,nsnow
        DO ikl=1,kcolp
        DO ikv=1,mwp
          okthin =      max(zer0,                       &!
     &                      sign(un_1,                  &!
     &                           dz_min                 &!
     &                          -dzsnsv(ikl,ikv,isn)))  &!
     &                * max(zer0,                       &! ON if dz > 0
     &                      sign(un_1,                  &!
     &                           dzsnsv(ikl,ikv,isn)-eps6)) &!
     &           *min(1,max(0,                          &! Multiple Snow    Lay.
     &                      min(1,                     &! Switch = 1
     &                           isnosv(ikl,ikv)        &!   if isno > iice + 1
     &                          -iicesv(ikl,ikv)-1))    &!
                                                         !
     &             +int(max(zer0,                       &!
     &                      sign(un_1,                  &!
     &                           dzepsi                 &! Minimum accepted for
     &                          -dzsnsv(ikl,ikv,isn)))) &! 1 Snow Layer over Ice
     &             *int(max(zer0,                       &! ON if dz > 0
     &                      sign(un_1,                  &!
     &                           dzsnsv(ikl,ikv,isn)-eps6)))&!
     &                 *(1 -min(abs(isnosv(ikl,ikv)    &! Switch = 1
     &                              -iicesv(ikl,ikv)-1),1)) &!   if isno = iice + 1
                                                         !
     &                 +max(0,                          &! Ice
     &                      min(1,                     &! Switch
     &                           iicesv(ikl,ikv)+1-isn)))   &!
     &             *min(un_1,                                    &!
     &                  max(zer0,                                &! combination
     &                      sign(un_1,g1snsv(ikl,ikv,      isn  )&! G1>0 + G1<0
     &                               *g1snsv(ikl,ikv,max(1,isn-1)))) &! NO
     &                + max(zer0,                                &!
     &                      sign(un_1,g1snsv(ikl,ikv,      isn   ))) &!
     &                + max(zer0,                                &!
     &                      sign(un_1,dzxmin                     &!
     &                               -dzsnsv(ikl,ikv,      isn   )))) !
          i_thin(ikl,ikv) =    (1. - okthin)  * i_thin(ikl,ikv) &! Update   thinest Lay.
     &                         + okthin   * isn          !                Index
        END DO
        END DO
      END DO
 
! OUTPUT/Verification: Snow Layers Agregation
! #vz     write(41,4151) i_thin(1,1),dzsnSV(1,i_thin(1,1))             &
! #vz&                  ,isnoSV(1,1),dzsnSV(1,isnoSV(1,1))
 4151     format(' Thinest ',i3,':',f9.3,'   Max   =',i3,f12.3)
 
! OUTPUT/Verification: Snow Layers Agregation: Properties
! #vp   write(47,470)(G1snSV(1,isn),isn=1,isnoSV(1,1))
 470    format('Before _zCr1: G1 = ',10f8.1,(/,19x,10f8.1))
! #vp   write(47,472)(G2snSV(1,isn),isn=1,isnoSV(1,1))
 472    format('              G2 = ',10f8.1,(/,19x,10f8.1))
 
 
! Index of the contiguous Layer to agregate
! -----------------------------------------
 
!          **********
      call sisvat_zcr
!          **********
 
 
! Assign the 2 Layers to agregate
! -------------------------------
 
        DO ikl=1,kcolp
        DO ikv=1,mwp
          isn         =    i_thin(ikl,ikv)
          isagr1(ikl,ikv) =    istosv(ikl,ikv,isn)
          isagr2(ikl,ikv) =    istosv(ikl,ikv,isn+lindsv(ikl,ikv))
          dzagr1(ikl,ikv) =    dzsnsv(ikl,ikv,isn)
          dzagr2(ikl,ikv) =    dzsnsv(ikl,ikv,isn+lindsv(ikl,ikv))
          t_agr1(ikl,ikv) =    tsissv(ikl,ikv,isn)
          t_agr2(ikl,ikv) =    tsissv(ikl,ikv,isn+lindsv(ikl,ikv))
          roagr1(ikl,ikv) =    ro__sv(ikl,ikv,isn)
          roagr2(ikl,ikv) =    ro__sv(ikl,ikv,isn+lindsv(ikl,ikv))
          etagr1(ikl,ikv) =    eta_sv(ikl,ikv,isn)
          etagr2(ikl,ikv) =    eta_sv(ikl,ikv,isn+lindsv(ikl,ikv))
          g1agr1(ikl,ikv) =    g1snsv(ikl,ikv,isn)
          g1agr2(ikl,ikv) =    g1snsv(ikl,ikv,isn+lindsv(ikl,ikv))
          g2agr1(ikl,ikv) =    g2snsv(ikl,ikv,isn)
          g2agr2(ikl,ikv) =    g2snsv(ikl,ikv,isn+lindsv(ikl,ikv))
          agagr1(ikl,ikv) =    agsnsv(ikl,ikv,isn)
          agagr2(ikl,ikv) =    agsnsv(ikl,ikv,isn+lindsv(ikl,ikv))
          lstlay      = min(1,max(  0,isnosv(ikl,ikv) -1))  ! 0  if single Layer
          isnosv(ikl,ikv) =               isnosv(ikl,ikv)  &! decrement   isnoSV
     &     -(1-lstlay)* max(zer0,                      &! if downmost  Layer
     &                      sign(un_1,eps_21           &! <  1.e-21 m
     &                               -dzsnsv(ikl,ikv,1)))   !
          isnosv(ikl,ikv) = max(   0,     isnosv(ikl,ikv)   )   !
          agrege(ikl,ikv) = max(zer0,                  &!
     &                      sign(un_1,dz_min           &! No Agregation
     &                               -dzagr1(ikl,ikv)  ))  &! if too thick Layer
     &                               *lstlay           &! if  a single Layer
     &                * min( max(0   ,isnosv(ikl,ikv)+1&! if Agregation
     &                               -i_thin(ikl,ikv)  &!    with    a Layer
     &                               -lindsv(ikl,ikv)  ),1) !    above the Pack
 
          weagre(ikl,ikv) = 0.
        END DO
        END DO
 
        DO isn=1,nsnow
        DO ikl=1,kcolp
        DO ikv=1,mwp
          weagre(ikl,ikv) = weagre(ikl,ikv) + ro__sv(ikl,ikv,isn)*dzsnsv(ikl,ikv,isn)  &
     &                                *min(1,max(0,i_thin(ikl,ikv)+1-isn))
        END DO
        END DO
        END DO
 
! OUTPUT/Verification: Snow Layers Agregation
! #vz write(41,410)
 410  format(/,' Agregation of too THIN Layers')
! #vz write(41,411) (100.*dz_ref(  isn),isn=1,nsnow)
! #vz write(41,412) (100.*dzwdif(  isn),isn=1,nsnow)
! #vz write(41,413) (100.*dzsnSV(1,isn),isn=1,nsnow)
! #vz write(41,414) (              isn ,isn=1,nsnow)
 411  format(' dz_ref [cm]:',10f8.2   ,/,('             ',10f8.2) )
 412  format(' dz_dif [cm]:',10f8.2   ,/,('             ',10f8.2) )
 413  format(' dzsnSV [cm]:',10f8.2   ,/,('             ',10f8.2) )
 414  format('             ',10(i5,3x),/,('             ',10(i5,3x)))
! #vz write(41,4111)      isnoSV(1    )
! #vz write(41,4112)      i_thin(1    )
! #vz write(41,4113)      LIndsv(1    )
! #vz write(41,4114)      Agrege(1    )
! #vz write(41,4115) 1.e2*dzagr1(1    )
! #vz write(41,4116) 1.e2*dzagr2(1    )
 4111 format(' isnoSV     :',  i8  )
 4112 format(' i_thin     :',  i8  )
 4113 format(' LIndsv     :',  i8  )
 4114 format(' Agrege     :',  f8.2)
 4115 format(' dzagr1     :',  f8.2)
 4116 format(' dzagr2     :',  f8.2)
 
! OUTPUT/Verification: Snow Layers Agregation: Properties
! #vp   write(47,471)(G1snSV(1,isn),isn=1,isnoSV(1,1))
 471    format('Before _zAg1: G1 = ',10f8.1,(/,19x,10f8.1))
! #vp   write(47,472)(G2snSV(1,isn),isn=1,isnoSV(1,1))
 
 
! Agregates
! ---------
 
        DO ikl=1,kcolp
        DO ikv=1,mwp
 
!            **********
        call sisvat_zag                                                &
     &             (ikl,ikv,isagr1(ikl,ikv),isagr2(ikl,ikv),weagre(ikl,ikv)&
     &                 ,dzagr1(ikl,ikv),dzagr2(ikl,ikv),t_agr1(ikl,ikv),t_agr2(ikl,ikv)&
     &                 ,roagr1(ikl,ikv),roagr2(ikl,ikv),etagr1(ikl,ikv),etagr2(ikl,ikv)&
     &                 ,g1agr1(ikl,ikv),g1agr2(ikl,ikv),g2agr1(ikl,ikv),g2agr2(ikl,ikv)&
     &                 ,agagr1(ikl,ikv),agagr2(ikl,ikv),agrege(ikl,ikv)&
     &                 )
!            **********
 
        END DO
        END DO
 
 
! Rearranges the Layers
! ---------------------
 
! New (agregated) Snow layer
! ^^^^^^^^^^^^^^^^^^^^^^^^^^
        DO ikl=1,kcolp
        DO ikv=1,mwp
          isn     =             i_thin(ikl,ikv)
          isn     = min(isn,isn+lindsv(ikl,ikv))
          isnosv(ikl,ikv) =         isnosv(ikl,ikv) -agrege(ikl,ikv)
          iicesv(ikl,ikv) =         iicesv(ikl,ikv)                    &
     &            -max(0,sign(1,iicesv(ikl,ikv) -isn +icemix))         &
     &                                      *agrege(ikl,ikv)           &
     &            *max(0,sign(1,iicesv(ikl,ikv) -1          ))
          istosv(ikl,ikv,isn) = (1.-agrege(ikl,ikv))*istosv(ikl,ikv,isn)   &
     &                      +   agrege(ikl,ikv) *isagr1(ikl,ikv)
          dzsnsv(ikl,ikv,isn) = (1.-agrege(ikl,ikv))*dzsnsv(ikl,ikv,isn)   &
     &                      +   agrege(ikl,ikv) *dzagr1(ikl,ikv)
          tsissv(ikl,ikv,isn) = (1.-agrege(ikl,ikv))*tsissv(ikl,ikv,isn)   &
     &                      +   agrege(ikl,ikv) *t_agr1(ikl,ikv)
          ro__sv(ikl,ikv,isn) = (1.-agrege(ikl,ikv))*ro__sv(ikl,ikv,isn)   &
     &                      +   agrege(ikl,ikv) *roagr1(ikl,ikv)
          eta_sv(ikl,ikv,isn) = (1.-agrege(ikl,ikv))*eta_sv(ikl,ikv,isn)   &
     &                      +   agrege(ikl,ikv) *etagr1(ikl,ikv)
          g1snsv(ikl,ikv,isn) = (1.-agrege(ikl,ikv))*g1snsv(ikl,ikv,isn)   &
     &                      +   agrege(ikl,ikv) *g1agr1(ikl,ikv)
          g2snsv(ikl,ikv,isn) = (1.-agrege(ikl,ikv))*g2snsv(ikl,ikv,isn)   &
     &                      +   agrege(ikl,ikv) *g2agr1(ikl,ikv)
          agsnsv(ikl,ikv,isn) = (1.-agrege(ikl,ikv))*agsnsv(ikl,ikv,isn)   &
     &                      +   agrege(ikl,ikv) *agagr1(ikl,ikv)
        END DO
        END DO
 
! Above
! ^^^^^
        DO ikl=1,kcolp
        DO ikv=1,mwp
          isn1(ikl,ikv)=max(i_thin(ikl,ikv),i_thin(ikl,ikv)+lindsv(ikl,ikv))
        END DO
        END DO
        DO i=  1,nsnow-1
        DO ikl=1,kcolp
        DO ikv=1,mwp
            staggr        =  min(1,max(0,i +1 -isn1(ikl,ikv)   ))
            istosv(ikl,ikv,i) = (1.-staggr     )*istosv(ikl,ikv,i  )   &
     &            + staggr*((1.-agrege(ikl,ikv))*istosv(ikl,ikv,i  )   &
     &                      +   agrege(ikl,ikv) *istosv(ikl,ikv,i+1))
            dzsnsv(ikl,ikv,i) = (1.-staggr     )*dzsnsv(ikl,ikv,i  )   &
     &            + staggr*((1.-agrege(ikl,ikv))*dzsnsv(ikl,ikv,i  )   &
     &                      +   agrege(ikl,ikv) *dzsnsv(ikl,ikv,i+1))
            tsissv(ikl,ikv,i) = (1.-staggr     )*tsissv(ikl,ikv,i  )   &
     &            + staggr*((1.-agrege(ikl,ikv))*tsissv(ikl,ikv,i  )   &
     &                      +   agrege(ikl,ikv) *tsissv(ikl,ikv,i+1))
            ro__sv(ikl,ikv,i) = (1.-staggr     )*ro__sv(ikl,ikv,i  )   &
     &            + staggr*((1.-agrege(ikl,ikv))*ro__sv(ikl,ikv,i  )   &
     &                      +   agrege(ikl,ikv) *ro__sv(ikl,ikv,i+1))
            eta_sv(ikl,ikv,i) = (1.-staggr     )*eta_sv(ikl,ikv,i  )   &
     &            + staggr*((1.-agrege(ikl,ikv))*eta_sv(ikl,ikv,i  )   &
     &                      +   agrege(ikl,ikv) *eta_sv(ikl,ikv,i+1))
            g1snsv(ikl,ikv,i) = (1.-staggr     )*g1snsv(ikl,ikv,i  )   &
     &            + staggr*((1.-agrege(ikl,ikv))*g1snsv(ikl,ikv,i  )   &
     &                      +   agrege(ikl,ikv) *g1snsv(ikl,ikv,i+1))
            g2snsv(ikl,ikv,i) = (1.-staggr     )*g2snsv(ikl,ikv,i  )   &
     &            + staggr*((1.-agrege(ikl,ikv))*g2snsv(ikl,ikv,i  )   &
     &                      +   agrege(ikl,ikv) *g2snsv(ikl,ikv,i+1))
            agsnsv(ikl,ikv,i) = (1.-staggr     )*agsnsv(ikl,ikv,i  )   &
     &            + staggr*((1.-agrege(ikl,ikv))*agsnsv(ikl,ikv,i  )   &
     &                      +   agrege(ikl,ikv) *agsnsv(ikl,ikv,i+1))
        END DO
        END DO
        END DO
 
        DO ikl=1,kcolp
        DO ikv=1,mwp
          isn             = min(isnosv(ikl,ikv) +1,nsnow)
          istosv(ikl,ikv,isn) = (1.-agrege(ikl,ikv))*istosv(ikl,ikv,isn)
          dzsnsv(ikl,ikv,isn) = (1.-agrege(ikl,ikv))*dzsnsv(ikl,ikv,isn)
          tsissv(ikl,ikv,isn) = (1.-agrege(ikl,ikv))*tsissv(ikl,ikv,isn)
          ro__sv(ikl,ikv,isn) = (1.-agrege(ikl,ikv))*ro__sv(ikl,ikv,isn)
          eta_sv(ikl,ikv,isn) = (1.-agrege(ikl,ikv))*eta_sv(ikl,ikv,isn)
          g1snsv(ikl,ikv,isn) = (1.-agrege(ikl,ikv))*g1snsv(ikl,ikv,isn)
          g2snsv(ikl,ikv,isn) = (1.-agrege(ikl,ikv))*g2snsv(ikl,ikv,isn)
          agsnsv(ikl,ikv,isn) = (1.-agrege(ikl,ikv))*agsnsv(ikl,ikv,isn)
        END DO
        END DO
 
! OUTPUT in SISVAT at specified i,j,k,n (see assignation in PHY_SISVAT)
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! #s1   IF (ii__AP(ikl).EQ.iwr_SV.AND.jj__AP(ikl).EQ.jwr_SV      .AND. &
! #s1&      ikv        .EQ.nwr_SV                          )     THEN
! #s1     write(6,5991) i_thin(ikl,ikv)
 5991     format(/,'First Agregation / Layer',i3,                      &
     &           /,'  i',11x,'T',9x,'rho',10x,'dz',11x,'H')
! #s1     write(6,5995) (isn,TsisSV(ikl,ikv,isn),ro__SV(ikl,ikv,isn)   &
! #s1&                      ,dzsnSV(ikl,ikv,isn),istoSV(ikl,ikv,isn),  &
! #s1&                   isn=isnoSV(ikl,ikv),1,-1)
 5995     format(i3,3f12.3,i12)
! #s1   END IF
 
 
! Constrains Splitting          of too thick Layers
! =================================================
 
 
! Search the thickest non-zero Layer
! ----------------------------------
 
        DO ikl=1,kcolp
        DO ikv=1,mwp
          dzthin(ikl,ikv) =   0.                        ! Arbitrary unrealistic
        END DO
        END DO                                          !       Layer Thickness
      DO   isn=1,nsnow
        DO ikl=1,kcolp
        DO ikv=1,mwp
          isno_n    =             isnosv(ikl,ikv)-isn+1 ! Snow Normal.Profile
          iice_n    =             iicesv(ikl,ikv)-isn   ! Ice  Normal.Profile
          iiceok    = min(1,max(0,iice_n         +1))   ! Ice         Switch
          dz_dif    =(      dzsnsv(ikl,ikv,isn)        &! Actual      Profile
     &        - dz_max *((1-iiceok)*isno_n*isno_n      &! Theoretical Profile
     &                 +    iiceok *2.   **iice_n)  )  &!
     &                 /max(dzsnsv(ikl,ikv,isn),eps6)   !
          okthin      = max(zer0,                      &!
     &                      sign(un_1,                 &!
     &                           dz_dif-dzthin(ikl,ikv)))  &! 1.=>New thickest Lay.
     &                * max(0,                         &! 1 =>.le. isnoSV
     &                  min(1,                         &!
     &                      isnosv(ikl,ikv)-isn +1 ))   !
          i_thin(ikl,ikv) =    (1. - okthin)  * i_thin(ikl,ikv)&!  Update thickest Lay.
     &                         + okthin   * isn         !                Index
          dzthin(ikl,ikv) =    (1. - okthin)  * dzthin(ikl,ikv)&!
     &                         + okthin   * dz_dif      !
        END DO
        END DO
      END DO
 
      DO   ikl=1,kcolp
      DO ikv=1,mwp
          thickl      = max(zer0,                      &! 1. => a too   thick
     &                      sign(un_1,dzthin(ikl,ikv)  &!         Layer exists
     &                               -eps6       ))    &!
     &        * max(0,1-max(0   ,     isnosv(ikl,ikv)  &! No spliting allowed
     &                               -nsnow+3    ))     ! if isno > nsnow - 3
          agrege(ikl,ikv) =               thickl       &! 1. => effective split
     &        * max(0,1-max(0   ,     nlaysv(ikl,ikv)  &!
     &                               +isnosv(ikl,ikv)  &!
     &                               -nsnow+1    ))     !
          nlay_s(ikl,ikv) =               thickl       &! Agregation
     &        * max(0,1-max(0   ,     nlaysv(ikl,ikv)  &! to allow  Splitting
     &                               +isnosv(ikl,ikv)  &!   at next Time Step
     &                               -nsnow      ))    &!
     &                               -agrege(ikl,ikv)   !
          nlay_s(ikl,ikv) = max(0   ,     nlay_s(ikl,ikv))  ! Agregation effective
      END DO
      END DO
 
! OUTPUT/Verification: Snow Layers Agregation
! #vz     write(41,4152) i_thin(1,1),dzthin(1,1),ThickL
 4152     format(/,' Thickest',i3,':',f9.3,'   Split =',f4.0)
 
 
! Rearranges the Layers
! ---------------------
 
      DO isn=nsnow,2,-1
      DO ikl=1,kcolp
      DO ikv=1,mwp
        IF (agrege(ikl,ikv).gt.0..AND.i_thin(ikl,ikv).lt.isnosv(ikl,ikv))   THEN
          staggr          =  min(1,max(0,isn-i_thin(ikl,ikv)    -1))   &
     &                    *  min(1,max(0,    isnosv(ikl,ikv)-isn+2))
          istosv(ikl,ikv,isn) =        staggr  * istosv(ikl,ikv ,isn-1)&
     &                    + (1. -  staggr) * istosv(ikl,ikv ,isn  )
          dzsnsv(ikl,ikv,isn) =        staggr  * dzsnsv(ikl,ikv ,isn-1)&
     &                    + (1. -  staggr) * dzsnsv(ikl,ikv ,isn  )
          tsissv(ikl,ikv,isn) =        staggr  * tsissv(ikl,ikv ,isn-1)&
     &                    + (1. -  staggr) * tsissv(ikl,ikv ,isn  )
          ro__sv(ikl,ikv,isn) =        staggr  * ro__sv(ikl,ikv ,isn-1)&
     &                    + (1. -  staggr) * ro__sv(ikl,ikv ,isn  )
          eta_sv(ikl,ikv,isn) =        staggr  * eta_sv(ikl,ikv ,isn-1)&
     &                    + (1. -  staggr) * eta_sv(ikl,ikv ,isn  )
          g1snsv(ikl,ikv,isn) =        staggr  * g1snsv(ikl,ikv ,isn-1)&
     &                    + (1. -  staggr) * g1snsv(ikl,ikv ,isn  )
          g2snsv(ikl,ikv,isn) =        staggr  * g2snsv(ikl,ikv ,isn-1)&
     &                    + (1. -  staggr) * g2snsv(ikl,ikv ,isn  )
          agsnsv(ikl,ikv,isn) =        staggr  * agsnsv(ikl,ikv ,isn-1)&
     &                    + (1. -  staggr) * agsnsv(ikl,ikv ,isn  )
        END IF
      END DO
      END DO
      END DO
 
      DO  ikl=1,kcolp
      DO ikv=1,mwp
          isn             =     i_thin(ikl,ikv)
          dzsnsv(ikl,ikv,isn) = 0.5*agrege(ikl,ikv) *dzsnsv(ikl,ikv,isn)   &
     &                    + (1.-agrege(ikl,ikv))*dzsnsv(ikl,ikv,isn)
 
          isn             = min(i_thin(ikl,ikv) +1,nsnow)
          istosv(ikl,ikv,isn) =     agrege(ikl,ikv) *istosv(ikl,ikv,isn-1) &
     &                    + (1.-agrege(ikl,ikv))*istosv(ikl,ikv,isn)
          dzsnsv(ikl,ikv,isn) =     agrege(ikl,ikv) *dzsnsv(ikl,ikv,isn-1) &
     &                    + (1.-agrege(ikl,ikv))*dzsnsv(ikl,ikv,isn)
          tsissv(ikl,ikv,isn) =     agrege(ikl,ikv) *tsissv(ikl,ikv,isn-1) &
     &                    + (1.-agrege(ikl,ikv))*tsissv(ikl,ikv,isn)
          ro__sv(ikl,ikv,isn) =     agrege(ikl,ikv) *ro__sv(ikl,ikv,isn-1) &
     &                    + (1.-agrege(ikl,ikv))*ro__sv(ikl,ikv,isn)
          eta_sv(ikl,ikv,isn) =     agrege(ikl,ikv) *eta_sv(ikl,ikv,isn-1) &
     &                    + (1.-agrege(ikl,ikv))*eta_sv(ikl,ikv,isn)
          g1snsv(ikl,ikv,isn) =     agrege(ikl,ikv) *g1snsv(ikl,ikv,isn-1) &
     &                    + (1.-agrege(ikl,ikv))*g1snsv(ikl,ikv,isn)
          g2snsv(ikl,ikv,isn) =     agrege(ikl,ikv) *g2snsv(ikl,ikv,isn-1) &
     &                    + (1.-agrege(ikl,ikv))*g2snsv(ikl,ikv,isn)
          agsnsv(ikl,ikv,isn) =     agrege(ikl,ikv) *agsnsv(ikl,ikv,isn-1) &
     &                    + (1.-agrege(ikl,ikv))*agsnsv(ikl,ikv,isn)
          isnosv(ikl,ikv)     =     agrege(ikl,ikv) +isnosv(ikl,ikv)
          iicesv(ikl,ikv)     =                  iicesv(ikl,ikv)       &
     &                    +     agrege(ikl,ikv) *max(0,sign(1,iicesv(ikl,ikv)  &
     &                                                   -isn +icemix))&
     &                                      *max(0,sign(1,iicesv(ikl,ikv)  &
     &                                                   -1          ))
      END DO
      END DO
 
 
! Constrains Agregation in case of too much  Layers
! =================================================
 
! Search the thinest   non-zero Layer
! -----------------------------------
 
! OUTPUT/Verification: Snow Thinest Layer
! #sd     write( 6,*)   ' '
! #sd     write( 6,*)   'Agregation 2'
! #sd     write( 6,6000) NLaysv(1)
 6000     format(i3,6x,                                                &
     &          'dzsnSV      dz_min      dz_dif      ',                &
     &          'OKthin      dzthin   i_thin')
 
        DO ikl=1,kcolp
        DO ikv=1,mwp
          dzthin(ikl,ikv) =   0.                        ! Arbitrary unrealistic
        END DO
        END DO                                          !       Layer Thickness
      DO   isn=1,nsnow
        DO ikl=1,kcolp
        DO ikv=1,mwp
          isno_n    =             isnosv(ikl,ikv)-isn+1 ! Snow Normal.Profile
          iice_n    =             iicesv(ikl,ikv)-isn   ! Ice  Normal.Profile
          iiceok    = min(1,max(0,iice_n         +1))   ! Ice         Switch
 
! OUTPUT/Verification: Snow Layers Agregation
! #vz     dz_ref(isn) =                                &!
! #vz&          dz_min *((1-iiceOK)*isno_n*isno_n      &! Theoretical Profile
! #vz&                 +    iiceOK *    2**iice_n)     &!
! #vz&               /max(1,isnoSV(ikl,ikv))            !
 
          dz_dif      =     dz_min                     &! Actual      Profile
     &                    - dzsnsv(ikl,ikv    ,isn)    &!
     &        /max(eps6,((1-iiceok)*isno_n*isno_n      &! Theoretical Profile
     &                 +    iiceok *2.   **iice_n))     !
 
! OUTPUT/Verification: Snow Layers Agregation
! #vz     dzwdif(isn) =     dz_dif                      !
 
          okthin      = max(zer0,                       &!
     &                      sign(un_1,                  &!
     &                           dz_dif  - dzthin(ikl,ikv)))&! 1.=> New thinest Lay.
     &                * max(0,                          &! 1 => .le. isnoSV
     &                  min(1,                          &!
     &                      isnosv(ikl,ikv)-isn +1 ))    !
          i_thin(ikl,ikv) =    (1. - okthin) * i_thin(ikl,ikv)  &! Update   thinest Lay.
     &                         + okthin  * isn           !                Index
          dzthin(ikl,ikv) =    (1. - okthin) * dzthin(ikl,ikv)  &!
     &                         + okthin  * dz_dif        !
 
! OUTPUT/Verification: Snow Thinest Layer
! #sd   IF(isn.LE.isnoSV(1,1).AND.ikl.EQ.1.AND.ikv.EQ.1)                     &
! #sd&    write( 6,6001) isn,dzsnSV(ikl,ikv,isn),dz_min*isno_n*isno_n,dz_dif &
! #sd&               ,OKthin,dzthin(ikl,ikv),    i_thin(ikl,ikv)
 6001     format(i3,5f12.6,i9)
 
        END DO
        END DO
      END DO
 
! OUTPUT/Verification: Snow Thinest Layer
! #sd     write( 6,*)   ' '
 
! OUTPUT/Verification: Snow Layers Agregation
! #vz     write(41,4153) i_thin(1,1),dzsnSV(1,i_thin(1,1))
 4153     format(/,' Thinest ',i3,':',f9.3)
! #vz     write(41,4151) i_thin(1,1),dzsnSV(1,i_thin(1,1))             &
! #vz&                  ,isnoSV(1,1),dzsnSV(1,isnoSV(1,1))
 
! OUTPUT/Verification: Snow Layers Agregation: Properties
! #vp   write(47,473)(G1snSV(1,isn),isn=1,isnoSV(1,1))
 473    format('Before _zCr2: G1 = ',10f8.1,(/,19x,10f8.1))
! #vp   write(47,472)(G2snSV(1,isn),isn=1,isnoSV(1,1))
 
 
! Index of the contiguous Layer to agregate
! -----------------------------------------
 
!          **********
      call sisvat_zcr
!          **********
 
 
! Assign the 2 Layers to agregate
! -------------------------------
 
        DO ikl=1,kcolp
        DO ikv=1,mwp
          isn         =    i_thin(ikl,ikv)
          isagr1(ikl,ikv) =    istosv(ikl,ikv,isn)
          isagr2(ikl,ikv) =    istosv(ikl,ikv,isn+lindsv(ikl,ikv))
          dzagr1(ikl,ikv) =    dzsnsv(ikl,ikv,isn)
          dzagr2(ikl,ikv) =    dzsnsv(ikl,ikv,isn+lindsv(ikl,ikv))
          t_agr1(ikl,ikv) =    tsissv(ikl,ikv,isn)
          t_agr2(ikl,ikv) =    tsissv(ikl,ikv,isn+lindsv(ikl,ikv))
          roagr1(ikl,ikv) =    ro__sv(ikl,ikv,isn)
          roagr2(ikl,ikv) =    ro__sv(ikl,ikv,isn+lindsv(ikl,ikv))
          etagr1(ikl,ikv) =    eta_sv(ikl,ikv,isn)
          etagr2(ikl,ikv) =    eta_sv(ikl,ikv,isn+lindsv(ikl,ikv))
          g1agr1(ikl,ikv) =    g1snsv(ikl,ikv,isn)
          g1agr2(ikl,ikv) =    g1snsv(ikl,ikv,isn+lindsv(ikl,ikv))
          g2agr1(ikl,ikv) =    g2snsv(ikl,ikv,isn)
          g2agr2(ikl,ikv) =    g2snsv(ikl,ikv,isn+lindsv(ikl,ikv))
          agagr1(ikl,ikv) =    agsnsv(ikl,ikv,isn)
          agagr2(ikl,ikv) =    agsnsv(ikl,ikv,isn+lindsv(ikl,ikv))
          lstlay      = min(1,max(  0,    isnosv(ikl,ikv)-1   ))
          agrege(ikl,ikv) = min(1,                                     &
     &                  max(0,                                         &
     &                      nlaysv(ikl,ikv)   +isnosv(ikl,ikv)-nsnow   &
     &                     +nlay_s(ikl,ikv)                    )       &
     &                                    *lstlay           )
          isnosv(ikl,ikv) =                    isnosv(ikl,ikv)         &
     &     -(1-lstlay)*max(zer0,                                       &
     &                     sign(un_1,      eps_21                      &
     &                                    -dzsnsv(ikl,ikv,1)   ))
          isnosv(ikl,ikv) =max(   0,           isnosv(ikl,ikv)      )
 
          weagre(ikl,ikv) = 0.
        END DO
        END DO
 
        DO isn=1,nsnow
        DO ikl=1,kcolp
        DO ikv=1,mwp
          weagre(ikl,ikv) = weagre(ikl,ikv) + ro__sv(ikl,ikv,isn)*dzsnsv(ikl,ikv,isn)  &
     &                                *min(1,max(0,i_thin(ikl,ikv)+1-isn))
        END DO
        END DO
        END DO
 
! OUTPUT/Verification: Snow Layers Agregation
! #vz write(41,4120)
 4120 format(' Agregation of too MUCH Layers')
! #vz write(41,411) (100.*dz_ref(  isn),isn=1,nsnow)
! #vz write(41,412) (100.*dzwdif(  isn),isn=1,nsnow)
! #vz write(41,413) (100.*dzsnSV(1,isn),isn=1,nsnow)
! #vz write(41,414) (              isn ,isn=1,nsnow)
! #vz write(41,4111)      isnoSV(1    )
! #vz write(41,4112)      i_thin(1    )
! #vz write(41,4113)      LIndsv(1    )
! #vz write(41,4114)      Agrege(1    )
 
! OUTPUT/Verification: Snow Layers Agregation: Properties
! #vp   write(47,474)(G1snSV(1,isn),isn=1,isnoSV(1,1))
 474    format('Before _zAg2: G1 = ',10f8.1,(/,19x,10f8.1))
! #vp   write(47,472)(G2snSV(1,isn),isn=1,isnoSV(1,1))
 
 
! Agregates
! ---------
 
        DO ikl=1,kcolp
        DO ikv=1,mwp
 
!            **********
        call sisvat_zag                                                &
     &             (ikl,ikv,isagr1(ikl,ikv),isagr2(ikl,ikv),weagre(ikl,ikv)&
     &                 ,dzagr1(ikl,ikv),dzagr2(ikl,ikv),t_agr1(ikl,ikv),t_agr2(ikl,ikv)&
     &                 ,roagr1(ikl,ikv),roagr2(ikl,ikv),etagr1(ikl,ikv),etagr2(ikl,ikv)&
     &                 ,g1agr1(ikl,ikv),g1agr2(ikl,ikv),g2agr1(ikl,ikv),g2agr2(ikl,ikv)&
     &                 ,agagr1(ikl,ikv),agagr2(ikl,ikv),agrege(ikl,ikv)&
     &                 )
!            **********
 
        END DO
        END DO
 
 
! Rearranges the Layers
! ---------------------
 
! New (agregated) Snow layer
! ^^^^^^^^^^^^^^^^^^^^^^^^^^
        DO ikl=1,kcolp
        DO ikv=1,mwp
          isn     =             i_thin(ikl,ikv)
          isn     = min(isn,isn+lindsv(ikl,ikv))
          isnosv(ikl,ikv) =         isnosv(ikl,ikv) -agrege(ikl,ikv)
          iicesv(ikl,ikv) =         iicesv(ikl,ikv)                    &
     &            -max(0,sign(1,iicesv(ikl,ikv) -isn +icemix))         &
     &                                      *agrege(ikl,ikv)           &
     &            *max(0,sign(1,iicesv(ikl,ikv) -1          ))
          istosv(ikl,ikv,isn) = (1.-agrege(ikl,ikv))*istosv(ikl,ikv,isn)   &
     &                      +   agrege(ikl,ikv) *isagr1(ikl,ikv)
          dzsnsv(ikl,ikv,isn) = (1.-agrege(ikl,ikv))*dzsnsv(ikl,ikv,isn)   &
     &                      +   agrege(ikl,ikv) *dzagr1(ikl,ikv)
          tsissv(ikl,ikv,isn) = (1.-agrege(ikl,ikv))*tsissv(ikl,ikv,isn)   &
     &                      +   agrege(ikl,ikv) *t_agr1(ikl,ikv)
          ro__sv(ikl,ikv,isn) = (1.-agrege(ikl,ikv))*ro__sv(ikl,ikv,isn)   &
     &                      +   agrege(ikl,ikv) *roagr1(ikl,ikv)
          eta_sv(ikl,ikv,isn) = (1.-agrege(ikl,ikv))*eta_sv(ikl,ikv,isn)   &
     &                      +   agrege(ikl,ikv) *etagr1(ikl,ikv)
          g1snsv(ikl,ikv,isn) = (1.-agrege(ikl,ikv))*g1snsv(ikl,ikv,isn)   &
     &                      +   agrege(ikl,ikv) *g1agr1(ikl,ikv)
          g2snsv(ikl,ikv,isn) = (1.-agrege(ikl,ikv))*g2snsv(ikl,ikv,isn)   &
     &                      +   agrege(ikl,ikv) *g2agr1(ikl,ikv)
          agsnsv(ikl,ikv,isn) = (1.-agrege(ikl,ikv))*agsnsv(ikl,ikv,isn)   &
     &                      +   agrege(ikl,ikv) *agagr1(ikl,ikv)
        END DO
        END DO
 
! Above
! ^^^^^
        DO ikl=1,kcolp
        DO ikv=1,mwp
          isn1(ikl,ikv)=max(i_thin(ikl,ikv),i_thin(ikl,ikv)+lindsv(ikl,ikv))
        END DO
        END DO
        DO i=  1,nsnow-1
        DO ikl=1,kcolp
        DO ikv=1,mwp
            staggr        =  min(1,max(0,i +1 -isn1(ikl,ikv)   ))
            istosv(ikl,ikv,i) = (1.-staggr     )*istosv(ikl,ikv,i  )   &
     &            + staggr*((1.-agrege(ikl,ikv))*istosv(ikl,ikv,i  )   &
     &                      +   agrege(ikl,ikv) *istosv(ikl,ikv,i+1))
            dzsnsv(ikl,ikv,i) = (1.-staggr     )*dzsnsv(ikl,ikv,i  )   &
     &            + staggr*((1.-agrege(ikl,ikv))*dzsnsv(ikl,ikv,i  )   &
     &                      +   agrege(ikl,ikv) *dzsnsv(ikl,ikv,i+1))
            tsissv(ikl,ikv,i) = (1.-staggr     )*tsissv(ikl,ikv,i  )   &
     &            + staggr*((1.-agrege(ikl,ikv))*tsissv(ikl,ikv,i  )   &
     &                      +   agrege(ikl,ikv) *tsissv(ikl,ikv,i+1))
            ro__sv(ikl,ikv,i) = (1.-staggr     )*ro__sv(ikl,ikv,i  )   &
     &            + staggr*((1.-agrege(ikl,ikv))*ro__sv(ikl,ikv,i  )   &
     &                      +   agrege(ikl,ikv) *ro__sv(ikl,ikv,i+1))
            eta_sv(ikl,ikv,i) = (1.-staggr     )*eta_sv(ikl,ikv,i  )   &
     &            + staggr*((1.-agrege(ikl,ikv))*eta_sv(ikl,ikv,i  )   &
     &                      +   agrege(ikl,ikv) *eta_sv(ikl,ikv,i+1))
            g1snsv(ikl,ikv,i) = (1.-staggr     )*g1snsv(ikl,ikv,i  )   &
     &            + staggr*((1.-agrege(ikl,ikv))*g1snsv(ikl,ikv,i  )   &
     &                      +   agrege(ikl,ikv) *g1snsv(ikl,ikv,i+1))
            g2snsv(ikl,ikv,i) = (1.-staggr     )*g2snsv(ikl,ikv,i  )   &
     &            + staggr*((1.-agrege(ikl,ikv))*g2snsv(ikl,ikv,i  )   &
     &                      +   agrege(ikl,ikv) *g2snsv(ikl,ikv,i+1))
            agsnsv(ikl,ikv,i) = (1.-staggr     )*agsnsv(ikl,ikv,i  )   &
     &            + staggr*((1.-agrege(ikl,ikv))*agsnsv(ikl,ikv,i  )   &
     &                      +   agrege(ikl,ikv) *agsnsv(ikl,ikv,i+1))
        END DO
        END DO
        END DO
 
        DO ikl=1,kcolp
        DO ikv=1,mwp
          isn             = min(isnosv(ikl,ikv) +1,nsnow)
          istosv(ikl,ikv,isn) = (1.-agrege(ikl,ikv))*istosv(ikl,ikv,isn)
          dzsnsv(ikl,ikv,isn) = (1.-agrege(ikl,ikv))*dzsnsv(ikl,ikv,isn)
          tsissv(ikl,ikv,isn) = (1.-agrege(ikl,ikv))*tsissv(ikl,ikv,isn)
          ro__sv(ikl,ikv,isn) = (1.-agrege(ikl,ikv))*ro__sv(ikl,ikv,isn)
          eta_sv(ikl,ikv,isn) = (1.-agrege(ikl,ikv))*eta_sv(ikl,ikv,isn)
          g1snsv(ikl,ikv,isn) = (1.-agrege(ikl,ikv))*g1snsv(ikl,ikv,isn)
          g2snsv(ikl,ikv,isn) = (1.-agrege(ikl,ikv))*g2snsv(ikl,ikv,isn)
          agsnsv(ikl,ikv,isn) = (1.-agrege(ikl,ikv))*agsnsv(ikl,ikv,isn)
        END DO
        END DO
 
! OUTPUT/Verification: Snow Layers Agregation: Properties
! #vp   write(47,475)(G1snSV(1,isn),isn=1,isnoSV(1,1))
 475    format('At End _zSn : G1 = ',10f8.1,(/,19x,10f8.1))
! #vp   write(47,472)(G2snSV(1,isn),isn=1,isnoSV(1,1))
 
 
! Search new Ice/Snow Interface
! =============================
 
! #SX   DO ikl=1,kcolp
! #SX   DO ikv=1,mwp
! #SX     iiceSV(ikl,ikv) =  0
! #SX   END DO
! #SX   END DO
 
! #SX   DO isn=1,nsnow
! #SX   DO ikl=1,kcolp
! #SX   DO ikv=1,mwp
! #SX     OK_ICE      = max(zer0,sign(un_1,ro__SV(ikl,ikv,isn)-850.))  &
! #SX&                * max(zer0,sign(un_1,dzsnSV(ikl,ikv,isn)-eps6))
! #SX     iiceSV(ikl,ikv) = (1.-OK_ICE)       *iiceSV(ikl,ikv)         &
! #SX&                +     OK_ICE        *isn
! #SX   END DO
! #SX   END DO
! #SX   END DO
 
 
 
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!                                                                      !
! DE-ALLOCATION                                                        !
! =============                                                        !
 
      IF (flagdalloc)                                             THEN !
 
      deallocate          ( nlay_s )                                   ! Split Snow Layer         Switch
      deallocate          ( isagr1 )                                   ! 1st     Layer History
      deallocate          ( isagr2 )                                   ! 2nd     Layer History
      deallocate          ( isn1   )                                   ! 1st layer to stagger
      deallocate          ( weagre )                                   ! Snow Water Equivalent Thickness
      deallocate          ( dzthin )                                   ! Thickness of the thinest layer
      deallocate          ( agrege )                                   ! 1. when Agregation constrained
      deallocate          ( dzagr1 )                                   ! 1st     Layer Thickness
      deallocate          ( dzagr2 )                                   ! 2nd     Layer Thickness
      deallocate          ( t_agr1 )                                   ! 1st     Layer Temperature
      deallocate          ( t_agr2 )                                   ! 2nd     Layer Temperature
      deallocate          ( roagr1 )                                   ! 1st     Layer Density
      deallocate          ( roagr2 )                                   ! 2nd     Layer Density
      deallocate          ( etagr1 )                                   ! 1st     Layer Water Content
      deallocate          ( etagr2 )                                   ! 2nd     Layer Water Content
      deallocate          ( g1agr1 )                                   ! 1st     Layer Dendricity/Spher.
      deallocate          ( g1agr2 )                                   ! 2nd     Layer Dendricity/Spher.
      deallocate          ( g2agr1 )                                   ! 1st     Layer Sphericity/Size
      deallocate          ( g2agr2 )                                   ! 2nd     Layer Sphericity/Size
      deallocate          ( agagr1 )                                   ! 1st     Layer Age
      deallocate          ( agagr2 )                                   ! 2nd     Layer Age
 
! #vz deallocate          ( dz_ref )                                   ! Snow Reference Discretization
! #vz deallocate          ( dzwdif )                                   !
 
      END IF                                                           !
!                                                                      !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 
      return
      end subroutine sisvat_zsn
 
 
 
      subroutine sisvat_zcr
 
!--------------------------------------------------------------------------+
!   MAR          SISVAT_zCr                           Wed 26-Jun-2013  MAR |
!     SubRoutine SISVAT_zCr determines criteria for Layers Agregation      |
!                                                                          |
!     version 3.p.4.1 created by H. Gallee,           Tue  5-Feb-2013      |
!           Last Modification by H. Gallee,           Wed 26-Jun-2013      |
!                                                                          |
!--------------------------------------------------------------------------+
!                                                                          |
!     PARAMETERS:  kcolv: Total Number of columns =                        |
!     ^^^^^^^^^^        = Total Number of continental     grid boxes       |
!                       X       Number of Mosaic Cell per grid box         |
!                                                                          |
!     INPUT /  isnoSV   = total Nb of Ice/Snow Layers                      |
!     OUTPUT:  iiceSV   = total Nb of Ice      Layers                      |
!     ^^^^^^   ispiSV   = 0,..,nsnow: Uppermost Superimposed Ice Layer     |
!              istoSV   = 0,..,5    : Snow     History (see istdSV data)   |
!                                                                          |
!     INPUT /  ro__SV   : Soil/Snow Volumic Mass                   [kg/m3] |
!     OUTPUT:           & Snow     Temperatures (layers  1,2,..,nsnow) [K] |
!     ^^^^^^   G1snSV   : Dendricity (<0) or Sphericity (>0) of Snow Layer |
!              G2snSV   : Sphericity (>0) or Size            of Snow Layer |
!              agsnSV   : Snow       Age                             [day] |
!                                                                          |
!     OUTPUT:  LIndsv   : Relative Index of a contiguous Layer to agregate |
!     ^^^^^^                                                               |
!--------------------------------------------------------------------------+
 
 
! Global  Variables
! =================
 
      use mod_real
      use mod_phy____dat
      use mod_phy____grd
      use mod_sisvat_grd
 
 
 
! General Variables
! =================
 
      use mod_sisvat_dat
      use mod_sisvat_dzs
      use mod_sisvat_kkl
      use mod_sisvat_loc
 
 
 
      IMPLICIT NONE
 
 
 
! Internal Variables
! ==================
 
      integer           ::  ikl,ikv   ,isn   ,is0   ,is1
      integer           ::  isno_1                        ! Switch:  ! Snow Layer over Ice
      real(kind=real8)  ::  Dtyp_0,Dtyp_1                 ! Snow Grains Difference Measure
      real(kind=real8)  ::  DenSph                        ! 1. when contiguous spheric
!                                                         !     and dendritic  Grains
      real(kind=real8)  ::  DendOK                        ! 1. when dendritic  Grains
      real(kind=real8)  ::  dTypMx = 200.0                ! Grain Type Differ.
      real(kind=real8)  ::  dTypSp =   0.5                ! Sphericity Weight
      real(kind=real8)  ::  dTypRo =   0.5                ! Density    Weight
      real(kind=real8)  ::  dTypDi =  10.0                ! Grain Diam.Weight
      real(kind=real8)  ::  dTypHi = 100.0                ! History    Weight
 
 
! Agregation Criteria
! ===================
 
      DO ikl=1,kcolp
      DO ikv=1,mwp
          i_thin(ikl,ikv) = min(i_thin(ikl,ikv),isnosv(ikl,ikv))
          isn         = max(1          ,i_thin(ikl,ikv))
 
 
! Comparison with the downward Layer
! ----------------------------------
 
          is0    = max(1,        i_thin(ikl,ikv)-1 )    ! Downward Layer Index
          densph = max(zer0,                           &! isn/is1
     &                 sign(un_1,                      &! Dendricity/Sphericity
     &                      eps6-g1snsv(ikl,ikv,isn)   &!            Switch
     &                          *g1snsv(ikl,ikv,is0)))  !
          dendok = max(zer0,                           &! Dendricity Switch
     &                 sign(un_1,                      &!
     &                      eps6-g1snsv(ikl,ikv,isn)))  !
 
          dtyp_0 =                                     &!
     &         densph *      dtypmx                    &!
     &    +(1.-densph)                                 &!
     &    *    dendok *((abs(g1snsv(ikl,ikv,isn)       &! Dendricity
     &                      -g1snsv(ikl,ikv,is0))      &!     Contribution
     &                  +abs(g2snsv(ikl,ikv,isn)       &! Sphericity
     &                      -g2snsv(ikl,ikv,is0))) *dtypsp &!     Contribution
     &                  +abs(ro__sv(ikl,ikv,isn)       &! Density
     &                      -ro__sv(ikl,ikv,is0))  *dtypro)&!     Contribution
     &    +(1.-densph)                                 &!
     &    *(1.-dendok)*((abs(g1snsv(ikl,ikv,isn)       &! Sphericity
     &                      -g1snsv(ikl,ikv,is0))      &!     Contribution
     &                  +abs(g2snsv(ikl,ikv,isn)       &! Size
     &                      -g2snsv(ikl,ikv,is0))) *dtypdi &!     Contribution
     &                  +abs(ro__sv(ikl,ikv,isn)       &! Density
     &                      -ro__sv(ikl,ikv,is0))  *dtypro) !     Contribution
          dtyp_0 =                                     &!
     &                   min(dtypmx,                   &!
     &                       dtyp_0                    &!
     &                  +abs(istosv(ikl,ikv,isn)       &! History
     &                      -istosv(ikl,ikv,is0))  *dtyphi)&!     Contribution
     &        +             (1 -abs(isn-is0))  * 1.e+6 &!"Same Layer"Score
     &        +  max(0,1-abs(iicesv(ikl,ikv)           &!"Ice /Snow
     &                                 -is0))  * 1.e+6  ! Interface" Score
 
 
! Comparison with the   upward Layer
! ----------------------------------
 
          is1    = min(          i_thin(ikl,ikv)+1,    &! Upward   Layer Index
     &                 max(1,    isnosv(ikl,ikv)  ))    !
          densph = max(zer0,                           &! isn/is1
     &                 sign(un_1,                      &! Dendricity/Sphericity
     &                      eps6-g1snsv(ikl,ikv,isn)   &!            Switch
     &                          *g1snsv(ikl,ikv,is1)))  !
          dendok = max(zer0,                           &! Dendricity Switch
     &                 sign(un_1,                      &!
     &                      eps6-g1snsv(ikl,ikv,isn)))  !
 
          dtyp_1 =                                     &!
     &         densph *      dtypmx                    &!
     &    +(1.-densph)                                 &!
     &    *    dendok *((abs(g1snsv(ikl,ikv,isn)       &! Dendricity
     &                      -g1snsv(ikl,ikv,is1))      &!     Contribution
     &                  +abs(g2snsv(ikl,ikv,isn)       &! Sphericity
     &                      -g2snsv(ikl,ikv,is1))) *dtypsp &!     Contribution
     &                  +abs(ro__sv(ikl,ikv,isn)       &! Density
     &                      -ro__sv(ikl,ikv,is1))  *dtypro)&!     Contribution
     &    +(1.-densph)                                 &!
     &    *(1.-dendok)*((abs(g1snsv(ikl,ikv,isn)       &! Sphericity
     &                      -g1snsv(ikl,ikv,is1))      &!     Contribution
     &                  +abs(g2snsv(ikl,ikv,isn)       &! Size
     &                      -g2snsv(ikl,ikv,is1))) *dtypdi &!     Contribution
     &                  +abs(ro__sv(ikl,ikv,isn)       &! Density
     &                      -ro__sv(ikl,ikv,is1))  *dtypro) !     Contribution
          dtyp_1 =                                     &!
     &                   min(dtypmx,                   &!
     &                       dtyp_1                    &!
     &                  +abs(istosv(ikl,ikv,isn)       &! History
     &                      -istosv(ikl,ikv,is1))  *dtyphi)&!     Contribution
     &        +             (1 -abs(isn-is1))  * 1.e+6 &!"Same Layer"Score
     &        +  max(0,1-abs(iicesv(ikl,ikv)           &!"Ice /Snow
     &                                 -isn))  * 1.e+6  ! Interface" Score
 
 
! Index of the Layer to agregate
! ==============================
 
          lindsv(ikl,ikv) = sign(un_1,dtyp_0           &!
     &                           -dtyp_1)               !
          isno_1      = (1 -min(abs(isnosv(ikl,ikv)   &! Switch = 1
     &                              -iicesv(ikl,ikv)-1),1))&!   if isno = iice +1
     &                * (1 -min(abs(isnosv(ikl,ikv)   &! Switch = 1
     &                              -i_thin(ikl,ikv)  ),1)) !   if isno = i_ithin
          lindsv(ikl,ikv) = (1 -isno_1) *lindsv(ikl,ikv)   &! Contiguous Layer is
     &                     -isno_1                      ! downward for top L.
          i_thin(ikl,ikv) =  max(1,   i_thin(ikl,ikv)   )   !
      END DO
      END DO
 
 
      return
      end subroutine sisvat_zcr
 
 
 
      subroutine sisvat_zag                                           &!
     &                 (ikl,ikv,isagra,isagrb,weagra                  &!
     &                     ,dzagra,dzagrb,t_agra,t_agrb               &!
     &                     ,roagra,roagrb,etagra,etagrb               &!
     &                     ,g1agra,g1agrb,g2agra,g2agrb               &!
     &                     ,agagra,agagrb,agreg1                      &!
     &                     )
 
!--------------------------------------------------------------------------+
!   MAR SURFACE                                       Wed 26-Jun-2013  MAR |
!     SubRoutine SISVAT_zAg aggregates two contiguous snow layers          |
!                                                                          |
!     version 3.p.4.1 created by H. Gallee,           Tue  5-Feb-2013      |
!           Last Modification by H. Gallee,           Wed 26-Jun-2013      |
!                                                                          |
!--------------------------------------------------------------------------+
!                                                                          |
!     PARAMETERS:  kcolv: Total Number of columns =                        |
!     ^^^^^^^^^^        = Total Number of continental     grid boxes       |
!                       X       Number of Mosaic Cell per grid box         |
!                                                                          |
!     INPUT:   isagrb   : 2nd     Layer History                            |
!     ^^^^^                                                                |
!                                                                          |
!     INPUT:   dzagrb   : 2nd     Layer Thickness                          |
!     ^^^^^    T_agrb   : 2nd     Layer Temperature                        |
!              roagrb   : 2nd     Layer Density                            |
!              etagrb   : 2nd     Layer Water Content                      |
!              G1agrb   : 2nd     Layer Dendricity/Spher.                  |
!              G2agrb   : 2nd     Layer Sphericity/Size                    |
!              agagrb   : 2nd     Age                                      |
!              Agreg1   : 1. when Agregation constrained                   |
!                                                                          |
!     INPUT /  isagra   : 1st     Layer History                            |
!     OUTPUT:                                                              |
!     ^^^^^^                                                               |
!                                                                          |
!     INPUT /  dzagra   : 1st     Layer Thickness                          |
!     OUTPUT:  T_agra   : 1st     Layer Temperature                        |
!     ^^^^^^   roagra   : 1st     Layer Density                            |
!              etagra   : 1st     Layer Water Content                      |
!              G1agra   : 1st     Layer Dendricity/Spher.                  |
!              G2agra   : 1st     Layer Sphericity/Size                    |
!              agagra   : 1st     Age                                      |
!                                                                          |
!                                                                          |
!     Preprocessing  Option: SISVAT IO (not always a standard preprocess.) |
!     ^^^^^^^^^^^^^^^^^^^^^  ^^^^^^^^^                                     |
!     FILE                 |      CONTENT                                  |
!     ~~~~~~~~~~~~~~~~~~~~~+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
!   # stdout               | #s1: OUTPUT of Snow Layers Agregation         |
!                          |      unit  6, SubRoutine  SISVAT_zSn, _zAg    |
!--------------------------------------------------------------------------+
 
 
! Global  Variables
! =================
 
      use mod_real
      use mod_phy____dat
 
 
 
! General Variables
! =================
 
      use mod_sisvat_dat
      use mod_sisvat_dzs
      use mod_sisvat_kkl
 
 
      IMPLICIT NONE
 
 
 
! Transferred Variables
! =====================
 
 
! INPUT
! -----
 
      integer           ::  ikl,ikv                       !    Column Index
 
      integer           ::  isagrb                        ! 2nd Layer History
      real(kind=real8)  ::  dzagrb                        ! 2nd Layer Thickness
      real(kind=real8)  ::  T_agrb                        ! 2nd Layer Temperature
      real(kind=real8)  ::  roagrb                        ! 2nd Layer Density
      real(kind=real8)  ::  etagrb                        ! 2nd Layer Water Content
      real(kind=real8)  ::  G1agrb                        ! 2nd Layer Dendricity/Spher.
      real(kind=real8)  ::  G2agrb                        ! 2nd Layer Sphericity/Size
      real(kind=real8)  ::  agagrb                        ! 2nd Layer Age
 
 
! INPUT/OUTPUT
! ------------
 
      integer           ::  isagra                        ! 1st Layer History
      real(kind=real8)  ::  WEagra                        ! 1st Layer Height    [mm w.e.]
      real(kind=real8)  ::  Agreg1                        ! 1. ===>   Agregates
      real(kind=real8)  ::  dzagra                        ! 1st Layer Thickness
      real(kind=real8)  ::  T_agra                        ! 1st Layer Temperature
      real(kind=real8)  ::  roagra                        ! 1st Layer Density
      real(kind=real8)  ::  etagra                        ! 1st Layer Water Content
      real(kind=real8)  ::  G1agra                        ! 1st Layer Dendricity/Spher.
      real(kind=real8)  ::  G2agra                        ! 1st Layer Sphericity/Size
      real(kind=real8)  ::  agagra                        ! 1st Layer Age
 
 
 
! Internal Variables
! ==================
 
      integer           ::  nh                            ! Averaged    Snow History
      integer           ::  nh__OK                        ! 1=>Conserve Snow History
      real(kind=real8)  ::  rh                            !
      real(kind=real8)  ::  dz                            ! Thickness
      real(kind=real8)  ::  dzro_1                        ! Thickness X Density, Lay.1
      real(kind=real8)  ::  dzro_2                        ! Thickness X Density, Lay.2
      real(kind=real8)  ::  dzro                          ! Thickness X Density, Aver.
      real(kind=real8)  ::  ro                            ! Averaged    Density
      real(kind=real8)  ::  wn                            ! Averaged    Water Content
      real(kind=real8)  ::  tn                            ! Averaged    Temperature
      real(kind=real8)  ::  ag                            ! Averaged    Snow Age
      real(kind=real8)  ::  SameOK                        ! 1. => Same Type of Grains
      real(kind=real8)  ::  G1same                        ! Averaged G1,  same Grains
      real(kind=real8)  ::  G2same                        ! Averaged G2,  same Grains
      real(kind=real8)  ::  typ__1                        ! 1. => Lay1 Type: Dendritic
      real(kind=real8)  ::  zroNEW                        ! dz X ro, if fresh Snow
      real(kind=real8)  ::  G1_NEW                        ! G1,      if fresh Snow
      real(kind=real8)  ::  G2_NEW                        ! G2,      if fresh Snow
      real(kind=real8)  ::  zroOLD                        ! dz X ro, if old   Snow
      real(kind=real8)  ::  G1_OLD                        ! G1,      if old   Snow
      real(kind=real8)  ::  G2_OLD                        ! G2,      if old   Snow
      real(kind=real8)  ::  SizNEW                        ! Size,    if fresh Snow
      real(kind=real8)  ::  SphNEW                        ! Spheric.,if fresh Snow
      real(kind=real8)  ::  SizOLD                        ! Size,    if old   Snow
      real(kind=real8)  ::  SphOLD                        ! Spheric.,if old   Snow
      real(kind=real8)  ::  Siz_av                        ! Averaged    Grain Size
      real(kind=real8)  ::  Sph_av                        ! Averaged    Grain Spher.
      real(kind=real8)  ::  Den_av                        ! Averaged    Grain Dendr.
      real(kind=real8)  ::  DendOK                        ! 1. => Average is  Dendr.
      real(kind=real8)  ::  G1diff                        ! Averaged G1, diff. Grains
      real(kind=real8)  ::  G2diff                        ! Averaged G2, diff. Grains
      real(kind=real8)  ::  G1                            ! Averaged G1
      real(kind=real8)  ::  G2                            ! Averaged G2
 
 
 
! Mean   Properties
! =================
 
!  1 Densite, Contenu en Eau, Temperature /
!    Density, Water Content,  Temperature
!    ------------------------------------
 
          dz      =  dzagra      + dzagrb
          dzro_1  =  roagra      * dzagra
          dzro_2  =  roagrb      * dzagrb
          dzro    =  dzro_1      + dzro_2
          ro      =  dzro                                              &
     &     /max(eps6,dz)
          wn      = (dzro_1*etagra      + dzro_2*etagrb     )          &
     &     /max(eps6,dzro)
          tn      = (dzro_1*t_agra      + dzro_2*t_agrb     )          &
     &     /max(eps6,dzro)
          ag      = (dzro_1*agagra      + dzro_2*agagrb     )          &
     &     /max(eps6,dzro)
 
          rh      =  max(zer0,sign(un_1,zwecsv(ikl,ikv)                &
     &                                         -0.5*weagra     ))
 
          nh__ok  =  rh
          nh      =                 max(isagra     ,isagrb     )       &
! #HB&            *  nh__OK                                            &
! #HB&          + (1-nh__OK)*       min(isagra     ,isagrb     )       &
     &          +  0.
 
! OUTPUT in SISVAT at specified i,j,k,n (see assignation in PHY_SISVAT)
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! #s1   IF (ii__AP(ikl).EQ.iwr_SV.AND.jj__AP(ikl).EQ.jwr_SV      .AND. &
! #s1&      ikv        .EQ.nwr_SV                          )       THEN
! #s1     write(6,5995) zWEcSV(ikl,ikv),WEagra                         &
! #s1&                 ,isagra     ,isagrb                             &
! #s1&                 ,nh__OK     ,nh
 5995     format(' WE2,WEa =',2f9.1,'  nha,b =',2i2,'  nh__OK,nh =',2i2)
! #s1   END IF
 
 
!  2 Nouveaux Types de Grains /  new Grain Types
!    -------------------------------------------
 
!  2.1. Meme  Type  de Neige  / same Grain Type
!       ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
          sameok  =  max(zer0,                                         &
     &                   sign(un_1, g1agra      *g1agrb       - eps_21))
          g1same  = (dzro_1*g1agra      + dzro_2*g1agrb     )          &
     &     /max(eps6,dzro)
          g2same  = (dzro_1*g2agra      + dzro_2*g2agrb     )          &
     &     /max(eps6,dzro)
 
!  2.2. Types differents / differents Types
!       ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
          typ__1  =  max(zer0,sign(un_1,eps6-g1agra     )) ! =1.=> Dendritic
          zronew  =     typ__1  *dzro_1                   &! ro of Dendr.Lay.
     &            + (1.-typ__1) *dzro_2                    !
          g1_new  =     typ__1  *g1agra                   &! G1 of Dendr.Lay.
     &            + (1.-typ__1) *g1agrb                    !
          g2_new  =     typ__1  *g2agra                   &! G2 of Dendr.Lay.
     &            + (1.-typ__1) *g2agrb                    !
          zroold  = (1.-typ__1) *dzro_1                   &! ro of Spher.Lay.
     &            +     typ__1  *dzro_2                    !
          g1_old  = (1.-typ__1) *g1agra                   &! G1 of Spher.Lay.
     &            +     typ__1  *g1agrb                    !
          g2_old  = (1.-typ__1) *g2agra                   &! G2 of Spher.Lay.
     &            +     typ__1  *g2agrb                    !
          siznew  =    -g1_new  *ddcdsv/g1_dsv            &! Size  Dendr.Lay.
     &             +(1.+g1_new         /g1_dsv)           &!
     &                *(g2_new  *dscdsv/g1_dsv            &!
     &             +(1.-g2_new         /g1_dsv)*dfcdsv)    !
          sphnew  =     g2_new         /g1_dsv             ! Spher.Dendr.Lay.
          sizold  =     g2_old                             ! Size  Spher.Lay.
          sphold  =     g1_old         /g1_dsv             ! Spher.Spher.Lay.
          siz_av  = (zronew*siznew+zroold*sizold)     &! Averaged Size
     &     /max(eps6,dzro)                             !
          sph_av  = (zronew*sphnew+zroold*sphold)     &! Averaged Sphericity
     &     /max(eps6,dzro)                             !
          den_av  = (siz_av -(    sph_av *dscdsv      &!
     &                       +(1.-sph_av)*dfcdsv))    &!
     &            / (ddcdsv -(    sph_av *dscdsv      &!
     &                       +(1.-sph_av)*dfcdsv))     !
          dendok  = max(zer0,                         &!
     &                  sign(un_1,     sph_av *dscdsv &! Small   Grains Contr.
     &                            +(1.-sph_av)*dfcdsv &! Faceted Grains Contr.
     &                            -    siz_av        ))!
!         REMARQUE: le  type moyen (dendritique ou non) depend
!         ^^^^^^^^  de la  comparaison avec le diametre optique
!                   d'une neige recente de   dendricite nulle
!         REMARK:   the mean type  (dendritic   or not) depends
!         ^^^^^^    on the comparaison with the optical diameter
!                   of a recent snow    having zero dendricity
 
          g1diff  =(   -dendok *den_av                                 &
     &             +(1.-dendok)*sph_av) *g1_dsv
          g2diff  =     dendok *sph_av  *g1_dsv                        &
     &             +(1.-dendok)*siz_av
          g1      =     sameok *g1same                                 &
     &             +(1.-sameok)*g1diff
          g2      =     sameok *g2same                                 &
     &             +(1.-sameok)*g2diff
 
 
! Assignation to new Properties
! =============================
 
          isagra        = agreg1      *nh +(1.-agreg1     ) *isagra
          dzagra        = agreg1      *dz +(1.-agreg1     ) *dzagra
          t_agra        = agreg1      *tn +(1.-agreg1     ) *t_agra
          roagra        = agreg1      *ro +(1.-agreg1     ) *roagra
          etagra        = agreg1      *wn +(1.-agreg1     ) *etagra
          g1agra        = agreg1      *g1 +(1.-agreg1     ) *g1agra
          g2agra        = agreg1      *g2 +(1.-agreg1     ) *g2agra
          agagra        = agreg1      *ag +(1.-agreg1     ) *agagra
 
 
      return
      end subroutine sisvat_zag
 
 
 
      subroutine snoptp(                                               &
! #AG&                  jjtime                                         &
     &                 )
 
!--------------------------------------------------------------------------+
!   MAR/SISVAT   SnOptP                               Wed 26-Jun-2013  MAR |
!     SubRoutine SnOptP computes the Snow Pack optical Properties          |
!                                                                          |
!     version 3.p.4.1 created by H. Gallee,           Tue  5-Feb-2013      |
!           Last Modification by H. Gallee,           Wed 26-Jun-2013      |
!                                                                          |
!--------------------------------------------------------------------------+
!                                                                          |
!     PARAMETERS:  kcolv: Total Number of columns =                        |
!     ^^^^^^^^^^        = Total Number of continental     Grid Boxes       |
!                       X       Number of Mosaic Cell per Grid Box         |
!                                                                          |
!     INPUT:   isnoSV   = total Nb of Ice/Snow Layers                      |
!     ^^^^^    ispiSV   = 0,...,nsno: Uppermost Superimposed Ice Layer     |
!                                                                          |
!              ivgtSV   = 0,...,12:   Vegetation Type                      |
!                         0:          Water, Solid or Liquid               |
!                                                                          |
!     INPUT:   G1snSV   : Dendricity (<0) or Sphericity (>0) of Snow Layer |
!     ^^^^^    G2snSV   : Sphericity (>0) or Size            of Snow Layer |
!              agsnSV   : Snow       Age                             [day] |
!              ro__SV   : Snow/Soil  Volumic Mass                  [kg/m3] |
!              eta_SV   : Water      Content                       [m3/m3] |
!              rusnSV   : Surficial  Water   Thickness   [kg/m2] .OR. [mm] |
!              SWS_SV   : Surficial  Water   Status                        |
!              dzsnSV   : Snow       Layer   Thickness                 [m] |
!                                                                          |
!              albssv   : Soil       Albedo                            [-] |
!              zzsnsv   : Snow       Pack    Thickness                 [m] |
!                                                                          |
!     OUTPUT:  albisv   : Snow/Ice/Water/Soil Integrated Albedo        [-] |
!     ^^^^^^   sEX_sv   : Verticaly Integrated Extinction Coefficient      |
!                                                                          |
!     Internal Variables:                                                  |
!     ^^^^^^^^^^^^^^^^^^                                                   |
!              SnOpSV   : Snow Grain optical Size                      [m] |
!              EX1_sv   : Integrated Snow Extinction (0.3--0.8micr.m)      |
!              EX2_sv   : Integrated Snow Extinction (0.8--1.5micr.m)      |
!              EX3_sv   : Integrated Snow Extinction (1.5--2.8micr.m)      |
!                                                                          |
!     METHODE:    Calcul de la taille optique des grains ? partir de       |
!     ^^^^^^^    -leur type decrit par les deux variables descriptives     |
!                      continues sur la plage -99/+99 passees en appel.    |
!                -la taille optique (1/10mm) des etoiles,                  |
!                                            des grains fins et            |
!                                            des jeunes faces planes       |
!                                                                          |
!     METHOD:     Computation of the optical diameter of the grains        |
!     ^^^^^^      described with the CROCUS formalism G1snSV / G2snSV      |
!                                                                          |
!     REFERENCE: Brun et al.      1989, J. Glaciol 35 pp. 333--342         |
!     ^^^^^^^^^  Brun et al.      1992, J. Glaciol 38 pp.  13-- 22         |
!                Eric Martin Sept.1996                                     |
!                                                                          |
!     CAUTION: Vegetation is not taken into account in albedo computations |
!     ^^^^^^^  Suggestion: 1) Reduce the displacement height  and/or LAI   |
!              (when snow)    for radiative transfert through vegetation   |
!                          2) Adapt leaf optical parameters                |
!                                                                          |
!                                                                          |
!     Preprocessing  Option: STANDARD Possibility                          |
!     ^^^^^^^^^^^^^^^^^^^^^  ^^^^^^^^^^^^^^^^^^^^                          |
!     #CZ: Albedo Correction (Zenith Angle) (Warren,      1982)            |
!     #cz: Albedo Correction (Zenith Angle) (Segal etAl., 1991) (obsolete) |
!                                                                          |
!                                                                          |
!     Preprocessing  Option: STANDARD Col de Porte                         |
!     ^^^^^^^^^^^^^^^^^^^^^  ^^^^^^^^                                      |
!     #cp: Col de Porte Integrated Snow/Ice Albedo                         |
!     #AG: Snow Aging Col de Porte     (Brun et al.1991)                   |
!                                                                          |
!                                                                          |
!     Preprocessing  Option: SISVAT IO (not always a standard preprocess.) |
!     ^^^^^^^^^^^^^^^^^^^^^  ^^^^^^^^^                                     |
!     FILE                 |      CONTENT                                  |
!     ~~~~~~~~~~~~~~~~~~~~~+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
!   # SnOptP____.va        | #va: OUTPUT/Verification: Albedo Parameteriz. |
!                          |      unit 46, SubRoutine  SnOptP     **ONLY** |
!--------------------------------------------------------------------------+
 
 
! Global  Variables
! =================
 
      use mod_real
      use mod_phy____dat
      use mod_phy____grd
      use mod_sisvat_grd
 
 
 
! General Variables
! =================
 
      use mod_sisvat_ctr
      use mod_sisvat_cdp
      use mod_sisvat_dat
      use mod_sisvat_kkl
      use mod_sisvat_loc
! #va use Mod_SISVAT_SnOptP
      use mod_sisvatlsno
 
 
 
      IMPLICIT NONE
 
 
 
! Internal Variables
! ==================
 
      real(kind=real8)                               ::  coalbm                ! weighted Coalbedo, mean
! #AG real(kind=real8)                               ::  agesno
 
! #AG integer                                        ::  jjtime                !
      integer                                        ::  isn   ,ikl,ikv        !
! #va integer                                        ::  isn1                  !
 
! For the computation of the solar irradiance extinction in snow
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      real(kind=real8)                               ::  sbeta1 = 0.0192
      real(kind=real8)                               ::  sbeta2 = 0.4000
      real(kind=real8)                               ::  sbeta3 = 0.1098
      real(kind=real8)                               ::  sbeta4 = 1.0000
      real(kind=real8)                               ::  sbeta5 = 2.00e1
 
! Snow Age Maximum (Taiga, e.g. Col de Porte)
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! #AG real(kind=real8)                               ::  AgeMax = 60.0         ! [day]
 
      real(kind=real8)                               ::  AlbMin =  0.94        !  Albedo Minimum / visible (0.3--0.8 micrometers)
      real(kind=real8)                               ::  AlbMax =  0.99        !  Albedo Maximum
      real(kind=real8)                               ::  HSnoSV =  0.01        !  Snow   Thickness over witch interpolate Albedo to Ice  Albedo
      real(kind=real8)                               ::  HIceSV =  0.10        !  Snow   Thickness over witch interpolate Albedo to Soil Albedo
 
      real(kind=real8)                               ::  doptmx =  2.3e-3      ! [m]     Maximum   optical Diameter    (pi * R**2)
 
      real(kind=real8)                               ::  SignG1,Sph_OK
      real(kind=real8)                               ::  dalbed                !
! #cz real(kind=real8)                               ::  dalbeS                !
! #CZ real(kind=real8)                               ::  dalbeW                !
 
! #CZ real(kind=real8)                               ::  bsegal =  4.00
! #CZ real(kind=real8)                               ::  czeMAX =  0.173648178 ! 80.deg (Segal et al., 1991 JAS)
! #CZ real(kind=real8)                               ::  CZ_eff
 
      real(kind=real8)                               ::  RoFrez,SignRo,SnowOK,OpSqrt
      real(kind=real8)                               ::  albSn1,a_SII1
      real(kind=real8)                               ::  albSn2,a_SII2
      real(kind=real8)                               ::  albSn3,a_SII3
      real(kind=real8)                               ::  albSno
! #va real(kind=real8)                               ::  albIce,albIc1,albIc2,albIc3
      real(kind=real8)                               ::  albSII,albWIc
      real(kind=real8)                               ::  doptic,Snow_H,SIce_H,SnownH,SIcenH
      real(kind=real8)                               ::  exarg1,exarg2,exarg3,sign_0,sExt_0
      real(kind=real8)                               ::  albedo_old
      real(kind=real8)                               ::  ro_ave,dz_ave
 
 
 
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!                                                                      !
! ALLOCATION                                                           !
! ==========                                                           !
 
      IF (it_run.EQ.1 .OR. flagdalloc)                            THEN !
 
      allocate            ( coalb1(kcolp,mwp) )                        ! weighted Coalbedo, Vis.
      allocate            ( coalb2(kcolp,mwp) )                        ! weighted Coalbedo, nIR 1
      allocate            ( coalb3(kcolp,mwp) )                        ! weighted Coalbedo, nIR 2
      allocate            ( sext_1(kcolp,mwp) )                        ! Extinction Coeff., Vis.
      allocate            ( sext_2(kcolp,mwp) )                        ! Extinction Coeff., nIR 1
      allocate            ( sext_3(kcolp,mwp) )                        ! Extinction Coeff., nIR 2
      allocate            ( snopsv(kcolp,mwp,nsnow) )                  ! Snow Grain optical Size
 
      allocate            ( alb1sv(kcolp,mwp) )                        !
      allocate            ( alb2sv(kcolp,mwp) )                        !
      allocate            ( alb3sv(kcolp,mwp) )                        !
 
      END IF
!                                                                      !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 
 
! Snow Grain optical Size
! =======================
 
      DO   isn=1,nsnow
        DO ikl=1,kcolp
        DO ikv=1,mwp
 
          g2snsv(ikl,ikv,isn) =  max(eps6,g2snsv(ikl,ikv,isn))
!         Avoid non physical Values
 
          signg1          = sign(un_1,g1snsv(ikl,ikv,isn))
          sph_ok          =  max(zer0,signg1)
 
          snopsv(ikl,ikv,isn) =   1.e-4 *                              &
!         SI:           (from 1/10 mm to m)
 
 
! Contribution of Non Dendritic Snow
! ----------------------------------
 
     &    (    sph_ok *(      g2snsv(ikl,ikv,isn)*g1snsv(ikl,ikv,isn)/g1_dsv   &
     &              +max(half*g2snsv(ikl,ikv,isn),dfcdsv)              &
     &                 *(1.00-g1snsv(ikl,ikv,isn)                /g1_dsv)) &
 
 
! Contribution of     Dendritic Snow
! ----------------------------------
 
     &    +(1.-sph_ok)*(     -g1snsv(ikl,ikv,isn)*ddcdsv         /g1_dsv   &
     &                 +(1.00+g1snsv(ikl,ikv,isn)                /g1_dsv)  &
     &                  *    (g2snsv(ikl,ikv,isn)*dscdsv         /g1_dsv   &
     &                 +(1.00-g2snsv(ikl,ikv,isn)                /g1_dsv)  &
     &                                       *dfcdsv                 )))
          snopsv(ikl,ikv,isn) =  max(zer0,snopsv(ikl,ikv,isn))
        END DO
        END DO
      END DO
 
 
! Snow/Ice Albedo
! ===============
 
! Snow Age (Influence on Albedo)
! ------------------------------
 
! #AG IF (iabs(mod(jjtime,86400)).lt.dt__SV)                        THEN
! #AG   DO isn=1,nsnow
! #AG   DO ikl=1,kcolp
! #AG   DO ikv=1,mwp
! #AG     agsnSV(ikl,ikv,isn) = agsnSV(ikl,ikv,isn) + 1.               &
! #AG&           + max(zer0,DH_dSV(ivgtSV(ikl,ikv))-DH_dSV(4)) ! High Vegetation
!                                                          ! Impurities
!                           CAUTION: crude parameterization
!                           ^^^^^^^
! #AG   END DO
! #AG   END DO
! #AG   END DO
! #AG END IF
 
 
! Uppermost effective Snow Layer
! ------------------------------
 
        DO ikl=1,kcolp
        DO ikv=1,mwp
 
           isn   =  max(1,isnosv(ikl,ikv))
 
          signro = sign(un_1, rocdsv - ro__sv(ikl,ikv,isn))
          snowok =  max(zer0,signro) ! Ice Density Threshold
 
          opsqrt = sqrt(snopsv(ikl,ikv,isn))
 
          albsn1 =  0.96-1.580*opsqrt
          albsn1 =  max(albsn1,albmin)
 
          albsn1 =  max(albsn1,zer0)
          albsn1 =  min(albsn1,un_1)
 
          albsn2 =  0.95-15.40*opsqrt
          albsn2 =  max(albsn2,zer0)
          albsn2 =  min(albsn2,un_1)
 
          doptic =  min(snopsv(ikl,ikv,isn),doptmx)
          albsn3 =  346.3*doptic -32.31*opsqrt +0.88
          albsn3 =  max(albsn3,zer0)
          albsn3 =  min(albsn3,un_1)
 
          albsno =  so1dsv*albsn1                                      &
     &           +  so2dsv*albsn2                                      &
     &           +  so3dsv*albsn3
 
          snowok =  snowok*max(zer0,sign(un_1,albsno-ai3dsv))
                 !  Minimum snow albedo is aI3dSV
 
          albsn1 =  snowok*albsn1+(1.0-snowok)*max(albsno,ai3dsv)
          albsn2 =  snowok*albsn2+(1.0-snowok)*max(albsno,ai3dsv)
          albsn3 =  snowok*albsn3+(1.0-snowok)*max(albsno,ai3dsv)
 
 
! Snow/Ice Pack Thickness
! -----------------------
 
          isn    =     max(min(isnosv(ikl,ikv) ,ispisv(ikl,ikv)),0)
          snow_h =  zzsnsv(ikl,ikv,isnosv(ikl,ikv))-zzsnsv(ikl,ikv,isn)
          sice_h =  zzsnsv(ikl,ikv,isnosv(ikl,ikv))
          snownh =  snow_h  /  hsnosv
          snownh =  min(un_1,  snownh)
          sicenh =  sice_h  / (hicesv                                  &
     &           +  max(zer0,z0mdsv(ivgtsv(ikl,ikv))                   &
     &           -           z0mdsv(4)         ))
          sicenh =  min(un_1,  sicenh)
 
!      The value of SnownH is set to 1 in case of ice lenses above
!      1m of dry snow (ro<700kg/m3) for using CROCUS albedo
 
          ro_ave =  0.
          dz_ave =  0.
          snowok =  1.
       DO isn    =  isnosv(ikl,ikv),1,-1
          ro_ave =  ro_ave + ro__sv(ikl,ikv,isn) * dzsnsv(ikl,ikv,isn) * snowok
          dz_ave =  dz_ave +                   dzsnsv(ikl,ikv,isn) * snowok
          snowok =  max(zer0,sign(un_1,1.-dz_ave))
       END DO
 
          ro_ave =  ro_ave / max(dz_ave,eps6)
          snowok =  max(zer0,sign(un_1,700.-ro_ave))
 
          snownh =  snowok + snownh * (1. - snowok)
 
 
! Integrated Snow/Ice Albedo: Case of Water on Bare Ice
! -----------------------------------------------------
 
          isn    =  max(min(isnosv(ikl,ikv) ,ispisv(ikl,ikv)),0)
 
          albwic =  ai1dsv-(ai1dsv-ai2dsv)                &!
     &           *  exp(-rusnsv(ikl,ikv)                  &!
     &           *  (1. -sws_sv(ikl,ikv)                  &! 0 <=> freezing
     &           *  (1  -min(1,iabs(isn-isnosv(ikl,ikv)))))   &! 1 <=> isn=isnoSV
     &                  /ru_dsv)                           !
 
          signro = sign(un_1,rhoice-1.-ro__sv(ikl,ikv,isn))! RoSN<920kg/m3
          snowok =  max(zer0,signro)
 
          albwic = (1. - snowok) * albwic + snowok        &!
     &           * (ai2dsv + (ai3dsv -ai2dsv)             &!
     &           * (ro__sv(ikl,ikv,isn)-rhoice)/(rocdsv-rhoice))
 
!    rocdSV < ro < rhoIce | aI2dSV< al >aI3dSV (fct of density))
!             ro > rhoIce | aI1dSV< al >aI2dSV (fct of superficial water content)s
 
 
! Integrated Snow/Ice      Albedo
! -------------------------------
 
          a_sii1      =     albwic      +(albsn1-albwic)     *snownh
          a_sii1      = min(a_sii1       ,albsn1)
 
          a_sii2      =     albwic      +(albsn2-albwic)     *snownh
          a_sii2      = min(a_sii2       ,albsn2)
 
          a_sii3      =     albwic      +(albsn3-albwic)     *snownh
          a_sii3      = min(a_sii3       ,albsn3)
 
! #AG     agesno =      min(agsnSV(ikl,ikv,isn)          ,AgeMax)
! #AG     a_SII1      =     a_SII1      -0.175*agesno/AgeMax
!                                        Impurities: Col de Porte Parameter.
 
 
!    Zenith Angle Correction (Segal et al.,         1991, JAS 48, p.1025)
!    ----------------------- (Wiscombe & Warren, dec1980, JAS   , p.2723)
!                            (Warren,               1982,  RG   , p.  81)
!                            --------------------------------------------
 
 
          dalbed = 0.0
! #CZ     CZ_eff = max(czemax                   ,coszSV(ikl,ikv))
! #cz     dalbeS =   ((bsegal+1.00)/(1.00+2.0*bsegal*CZ_eff)           &
! #cz&                -       1.00                          )*0.32     &
! #cz&              /  bsegal
! #cz     dalbeS = max(dalbeS,zer0)
! #cz     dalbed =     dalbeS      *       min(1,isnoSV(ikl,ikv))
 
! #CZ     dalbeW =(0.64 - CZ_eff  )*0.0625  ! Warren 1982, RevGeo, fig.12b
                                            ! 0.0625 = 5% * 1/0.8,   p.81
                                            ! 0.64   = cos(50)
! #CZ     dalbed =     dalbeW      *       min(1,isnoSV(ikl,ikv))
 
! Col de Porte Integrated Snow/Ice Albedo
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
          IF (colprt.AND.totsol.gt.0.)                              THEN
            albsii =  (((dr_1sn*a_sii1+dr_2sn*a_sii2+dr_3sn*a_sii3)    &
     &                  +dalbed                                    )   &
     &                  *dirsol                                        &
     &                 +(df_1sn*a_sii1+df_2sn*a_sii2+df_3sn*a_sii3)    &
     &                  *difsol*(1.   -cld_sv(ikl,ikv))                &
     &                 +(dfc1sn*a_sii1+dfc2sn*a_sii2+dfc3sn*a_sii3)    &
     &                  *difsol*       cld_sv(ikl,ikv)                  )  &
     &                 / totsol
 
! Elsewhere    Integrated Snow/Ice Albedo
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
          ELSE
            albsii =     so1dsv*a_sii1                                 &
     &                 + so2dsv*a_sii2                                 &
     &                 + so3dsv*a_sii3
          END IF
 
 
! Integrated Snow/Ice/Soil Albedo
! -------------------------------
 
            alb1sv(ikl,ikv) =     albssv(ikl,ikv) +(a_sii1-albssv(ikl,ikv))*sicenh
            alb1sv(ikl,ikv) = min(alb1sv(ikl,ikv)  ,a_sii1)
 
            alb2sv(ikl,ikv) =     albssv(ikl,ikv) +(a_sii2-albssv(ikl,ikv))*sicenh
            alb2sv(ikl,ikv) = min(alb2sv(ikl,ikv)  ,a_sii2)
 
            alb3sv(ikl,ikv) =     albssv(ikl,ikv) +(a_sii3-albssv(ikl,ikv))*sicenh
            alb3sv(ikl,ikv) = min(alb3sv(ikl,ikv)  ,a_sii3)
 
            albisv(ikl,ikv) =     albssv(ikl,ikv) +(albsii-albssv(ikl,ikv))*sicenh
            albisv(ikl,ikv) = min(albisv(ikl,ikv)  ,albsii)
 
 
! Integrated Snow/Ice/Soil Albedo: Clouds Correction! Greuell & all., 1994
! --------------------------------------------------! Glob.&t Planet.Change
                                                    ! (9):91-114
          IF (.NOT.colprt)                                          THEN
            alb1sv(ikl,ikv) = alb1sv(ikl,ikv) + 0.05 *(cld_sv(ikl,ikv)-0.5)*sicenh &
! #CZ&                  + dalbed      *    (1.-cld_SV(ikl,ikv))        &
     &                  + 0.
            alb2sv(ikl,ikv) = alb2sv(ikl,ikv) + 0.05 *(cld_sv(ikl,ikv)-0.5)*sicenh &
! #CZ&                  + dalbed      *    (1.-cld_SV(ikl,ikv))        &
     &                  + 0.
            alb3sv(ikl,ikv) = alb3sv(ikl,ikv) + 0.05 *(cld_sv(ikl,ikv)-0.5)*sicenh &
! #CZ&                  + dalbed      *    (1.-cld_SV(ikl,ikv))        &
     &                  + 0.
            albisv(ikl,ikv) = albisv(ikl,ikv) + 0.05 *(cld_sv(ikl,ikv)-0.5)*sicenh &
! #CZ&                  + dalbed      *    (1.-cld_SV(ikl,ikv))        &
     &                  + 0.
          END IF
 
 
! Integrated Snow/Ice/Soil Albedo: Minimum snow albedo = 40%
! ----------------------------------------------------------
 
            albedo_old  = albisv(ikl,ikv)
 
            albisv(ikl,ikv) = max(albisv(ikl,ikv),0.400    * sicenh    &
     &                  + albssv(ikl,ikv) *(1.0        - sicenh))
            alb1sv(ikl,ikv) = alb1sv(ikl,ikv) - 1.0/3.0                &! 33 %
     &                  * (albedo_old-albisv(ikl,ikv)) / so1dsv
            alb2sv(ikl,ikv) = alb2sv(ikl,ikv) - 1.0/3.0                &! 33 %
     &                  * (albedo_old-albisv(ikl,ikv)) / so2dsv
            alb3sv(ikl,ikv) = alb3sv(ikl,ikv) - 1.0/3.0                &! 33 %
     &                  * (albedo_old-albisv(ikl,ikv)) / so3dsv
 
 
! Integrated Snow/Ice/Soil Albedo: Maximum albedo = 99%
! -----------------------------------------------------
 
            albedo_old  = albisv(ikl,ikv)
            albisv(ikl,ikv) = min(albisv(ikl,ikv),0.99)
            alb1sv(ikl,ikv) = alb1sv(ikl,ikv) - 1.0/3.0                &! 33 %
     &                  * (albedo_old-albisv(ikl,ikv)) / so1dsv
            alb2sv(ikl,ikv) = alb2sv(ikl,ikv) - 1.0/3.0                &! 33 %
     &                  * (albedo_old-albisv(ikl,ikv)) / so2dsv
            alb3sv(ikl,ikv) = alb3sv(ikl,ikv) - 1.0/3.0                &! 33 %
     &                  * (albedo_old-albisv(ikl,ikv)) / so3dsv
 
            alb1sv(ikl,ikv) = min(max(zer0,alb1sv(ikl,ikv)),albmax)
            alb2sv(ikl,ikv) = min(max(zer0,alb2sv(ikl,ikv)),albmax)
            alb3sv(ikl,ikv) = min(max(zer0,alb3sv(ikl,ikv)),albmax)
 
        END DO
        END DO
 
 
! Extinction Coefficient: Exponential Factor
! ==========================================
 
        DO ikl=1,kcolp
        DO ikv=1,mwp
          sext_1(ikl,ikv)         = 1.
          sext_2(ikl,ikv)         = 1.
          sext_3(ikl,ikv)         = 1.
          sex_sv(ikl,ikv,nsnow+1) = 1.
 
          coalb1(ikl,ikv) = (1.          -alb1sv(ikl,ikv))*so1dsv
          coalb2(ikl,ikv) = (1.          -alb2sv(ikl,ikv))*so2dsv
          coalb3(ikl,ikv) = (1.          -alb3sv(ikl,ikv))*so3dsv
          coalbm      =  coalb1(ikl,ikv) +coalb2(ikl,ikv) +coalb3(ikl,ikv)
          coalb1(ikl,ikv) =  coalb1(ikl,ikv)              /coalbm
          coalb2(ikl,ikv) =  coalb2(ikl,ikv)              /coalbm
          coalb3(ikl,ikv) =  coalb3(ikl,ikv)              /coalbm
        END DO
        END DO
 
      DO   isn=  nsnow,1,-1
        DO ikl=1,kcolp
        DO ikv=1,mwp
 
          signro = sign(un_1, rocdsv - ro__sv(ikl,ikv,isn))
          snowok =  max(zer0,signro) ! Ice Density Threshold
 
          rofrez =  1.e-3      * ro__sv(ikl,ikv,isn) * (1.0-eta_sv(ikl,ikv,isn))
 
          opsqrt = sqrt(max(eps6,snopsv(ikl,ikv,isn)))
          exarg1 =      snowok  *1.e2 *max(sbeta1*rofrez/opsqrt,sbeta2)&
     &            +(1.0-snowok)           *sbeta5
          exarg2 =      snowok  *1.e2 *max(sbeta3*rofrez/opsqrt,sbeta4)&
     &            +(1.0-snowok)           *sbeta5
          exarg3 =      snowok  *1.e2     *sbeta5                      &
     &            +(1.0-snowok)           *sbeta5
 
! Col de Porte Snow Extinction Coefficient
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
          IF (colprt.AND.totsol.gt.0.)                              THEN
            exarg1 = exarg1*(dr_1sn*dirsol                             &
     &                      +df_1sn*difsol*(1.-cld_sv(ikl,ikv))        &
     &                      +dfc1sn*difsol*    cld_sv(ikl,ikv) )       &
     &                     /(dr_1sn*totsol)
            exarg2 = exarg2*(dr_2sn*dirsol                             &
     &                      +df_2sn*difsol*(1.-cld_sv(ikl,ikv))        &
     &                      +dfc2sn*difsol*    cld_sv(ikl,ikv) )       &
     &                     /(dr_2sn*totsol)
            exarg3 = exarg3*(dr_3sn*dirsol                             &
     &                      +df_3sn*difsol*(1.-cld_sv(ikl,ikv))        &
     &                      +dfc3sn*difsol*    cld_sv(ikl,ikv) )       &
     &                     /(dr_3sn*totsol)
          END IF
 
 
! Integrated Extinction of Solar Irradiance (Normalized Value)
! ============================================================
 
          sext_1(ikl,ikv) = sext_1(ikl,ikv)                            &
     &                          * exp(min(0.0,-exarg1 *dzsnsv(ikl,ikv,isn)))
          sign_0      =              sign(un_1,epsn   -sext_1(ikl,ikv))
          sext_0      =               max(zer0,sign_0)*sext_1(ikl,ikv)
          sext_1(ikl,ikv) = sext_1(ikl,ikv)                   -sext_0
 
          sext_2(ikl,ikv) = sext_2(ikl,ikv)                            &
     &                          * exp(min(0.0,-exarg2 *dzsnsv(ikl,ikv,isn)))
          sign_0      =              sign(un_1,epsn   -sext_2(ikl,ikv))
          sext_0      =               max(zer0,sign_0)*sext_2(ikl,ikv)
          sext_2(ikl,ikv) = sext_2(ikl,ikv)                   -sext_0
 
          sext_3(ikl,ikv) = sext_3(ikl,ikv)                            &
     &                          * exp(min(0.0,-exarg3 *dzsnsv(ikl,ikv,isn)))
          sign_0      =              sign(un_1,epsn   -sext_3(ikl,ikv))
          sext_0      =               max(zer0,sign_0)*sext_3(ikl,ikv)
          sext_3(ikl,ikv) = sext_3(ikl,ikv)                   -sext_0
 
          sex_sv(ikl,ikv,isn) = coalb1(ikl,ikv) * sext_1(ikl,ikv)      &
     &                    + coalb2(ikl,ikv) * sext_2(ikl,ikv)          &
     &                    + coalb3(ikl,ikv) * sext_3(ikl,ikv)
        END DO
        END DO
      END DO
 
      DO   isn=0,-nsoil,-1
        DO ikl=1,kcolp
        DO ikv=1,mwp
          sex_sv(ikl,ikv,isn) = 0.0
        END DO
        END DO
      END DO
 
 
! Albedo: IO
! ==========
 
! #va IF (.NOT.aw_opn)                                              THEN
! #va          aw_opn = .true.
! #va          open(unit=46,status='unknown',file='SnOptP____.va')
! #va          rewind(   46)
! #va END IF
 
! #va     ikl,ikv=1
! #va     write(46,460)daHost
! #va 460 format('---------------------------------+----+',            &
! #va&          '-------+-------+-------+-------+-------+-------+',    &
! #va&                                  '-------+-------+-------+',    &
! #va&         /,'Snow/Ice Pack ',a18,' |    |',                       &
! #va&          ' z [m] |0.3/0.8|0.8/1.5|1.5/2.8| Full  |Opt[mm]|',    &
! #va&                                  ' G1    | G2    | ro    |',    &
! #va&         /,'---------------------------------+----+',            &
! #va&          '-------+-------+-------+-------+-------+-------+',    &
! #va&                                  '-------+-------+-------+')
!         ______________________________________________________________
! #va     write(46,461)            SIce_H,                             &
! #va&                             alb1sv(ikl,ikv),alb2sv(ikl,ikv),alb3sv(ikl,ikv),&
! #va&                             albisv(ikl,ikv)
! #va 461 format('Integrated Snow/Ice/Soil  Albedo |',                 &
! #va&            3x,' |',  f6.3,' |' ,4(f6.3,' |'), 6x ,' |',         &
! #va&                                            3( 6x ,' |'))
!         ______________________________________________________________
! #va     write(46,462)ispiSV(ikl,ikv),a_SII1,a_SII2,a_SII3,albSII
! #va 462 format('Integrated Snow/Ice       Albedo |',                 &
! #va&            i3,' |',   6x ,' |' ,4(f6.3,' |'), 6x ,' |',         &
! #va&                                            3( 6x ,' |'))
!         ______________________________________________________________
! #va     write(46,463)            rusnSV(ikl,ikv),         albWIc,    &
! #va&                             SWS_SV(ikl,ikv)
! #va 463 format('Integrated Water/Bare Ice Albedo |',                 &
! #va&            3x,' |',  f6.3,'w|' ,3( 6x, ' |'),                   &
! #va&                                   f6.3,' |' ,f6.3,' |',         &
! #va&                                            3( 6x ,' |'))
!         ______________________________________________________________
! #va     write(46,465)isn1       ,zzsnsv(ikl,ikv,isn1),               &
! #va&                             albIc1,albIc2,albIc3,albIce,        &
! #va&                        1.e3*SnOpSV(ikl,ikv,max(1,isnoSV(ikl,ikv)-1)),   &
! #va&                             G1snSV(ikl,ikv,max(1,isnoSV(ikl,ikv)-1)),   &
! #va&                             G2snSV(ikl,ikv,max(1,isnoSV(ikl,ikv)-1)),   &
! #va&                             ro__SV(ikl,ikv,max(1,isnoSV(ikl,ikv)-1))&
! #va&                      *(1. - eta_SV(ikl,ikv,max(1,isnoSV(ikl,ikv)-1)))
! #va 465 format('Surficial       Ice Lense        |',                 &
! #va&            i3,' |', (f6.3,'i|'),4(f6.3,' |'),f6.3,' |',         &
! #va&                                            3(f6.1,' |'))
!         ______________________________________________________________
! #va     write(46,466)isnoSV(ikl,ikv),zzsnsv(ikl,ikv,isnoSV(ikl,ikv)),&
! #va&                             albSn1,albSn2,albSn3,albSno,        &
! #va&                        1.e3*SnOpSV(ikl,ikv,isnoSV(ikl,ikv)),    &
! #va&                             G1snSV(ikl,ikv,isnoSV(ikl,ikv)),    &
! #va&                             G2snSV(ikl,ikv,isnoSV(ikl,ikv)),    &
! #va&                             ro__SV(ikl,ikv,isnoSV(ikl,ikv))     &
! #va&                      *(1. - eta_SV(ikl,ikv,isnoSV(ikl,ikv)))
! #va 466 format('Uppermost  Effective Snow Layer  |',                 &
! #va&            i3,' |', (f6.3,'*|'),4(f6.3,' |'),f6.3,' |',         &
! #va&                                            3(f6.1,' |'))
 
 
 
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!                                                                      !
! DE-ALLOCATION                                                        !
! =============                                                        !
 
      IF (flagdalloc)                                             THEN !
 
      deallocate          ( coalb1 )                                   ! weighted Coalbedo, Vis.
      deallocate          ( coalb2 )                                   ! weighted Coalbedo, nIR 1
      deallocate          ( coalb3 )                                   ! weighted Coalbedo, nIR 2
      deallocate          ( sext_1 )                                   ! Extinction Coeff., Vis.
      deallocate          ( sext_2 )                                   ! Extinction Coeff., nIR 1
      deallocate          ( sext_3 )                                   ! Extinction Coeff., nIR 2
      deallocate          ( snopsv )                                   ! Snow Grain optical Size
 
      deallocate          ( alb1sv )                                   !
      deallocate          ( alb2sv )                                   !
      deallocate          ( alb3sv )                                   !
 
      END IF                                                           !
!                                                                      !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 
      return
      end subroutine snoptp
 
 
 
      subroutine vgoptp
 
!--------------------------------------------------------------------------+
!   MAR/SISVAT   VgOptP                               Wed 26-Jun-2013  MAR |
!     SubRoutine VgOptP computes the Canopy    optical Properties          |
!                                                                          |
!     version 3.p.4.1 created by H. Gallee,           Tue  5-Feb-2013      |
!           Last Modification by H. Gallee,           Wed 26-Jun-2013      |
!                                                                          |
!--------------------------------------------------------------------------+
!                                                                          |
!     PARAMETERS:  kcolv: Total Number of columns =                        |
!     ^^^^^^^^^^        = Total Number of continental     Grid Boxes       |
!                       X       Number of Mosaic Cell per Grid Box         |
!                                                                          |
!     INPUT:   ivgtSV   = 0,...,12:   Vegetation Type                      |
!     ^^^^^               0:          Water, Solid or Liquid               |
!                                                                          |
!     INPUT:   coszSV   : Cosine of the Sun Zenithal Distance          [-] |
!     ^^^^^    sol_SV   : Surface Downward  Solar   Radiation       [W/m2] |
!              snCaSV   : Canopy     Snow      Thickness         [mm w.e.] |
!                                                                          |
!              LAI_sv   : Leaf Area  Index      (snow included)        [-] |
!              glf_sv   : Green Leaf Fraction of NOT fallen Leaves     [-] |
!              albisv   : Snow/Ice/Water/Soil Integrated Albedo        [-] |
!                                                                          |
!     OUTPUT:  alb_SV   : Surface-Canopy Albedo                        [-] |
!     ^^^^^^   SoCasv   : Absorbed Solar Radiation by Canopy (Normaliz)[-] |
!              SoSosv   : Absorbed Solar Radiation by Surfac (Normaliz)[-] |
!              LAIesv   : Effective Leaf Area  Index for Transpiration [-] |
!                                                                          |
!     Internal Variables: Normalized Values:                               |
!     ^^^^^^^^^^^^^^^^^^                                                   |
!              u0_Vis   : Upward   Visible Radiation at Top Canopy     [-] |
!              absg_V   : Absorbed Visible Radiation by the Ground     [-] |
!              absv_V   : Absorbed Visible Radiation by the Canopy     [-] |
!              u0_nIR   : Upward   Near IR Radiation at Top Canopy     [-] |
!              absgnI   : Absorbed Near IR Radiation by the Ground     [-] |
!              absv_V   : Absorbed Near IR Radiation by the Canopy     [-] |
!                                                                          |
!     REFERENCE:   De Ridder, 1997, unpublished thesis, chapter 2 (DR97,2) |
!     ^^^^^^^^^                                                            |
!                                                                          |
!     ASSUMPTIONS: Leaf Inclination Index chi_l (eqn2.49 DR97) set to zero |
!     ^^^^^^^^^^^                         for all vegetation types         |
!                  Radiation Fluxes are normalized                         |
!                        with respect to incoming solar radiation (=I0+D0) |
!                                                                          |
!--------------------------------------------------------------------------+
 
 
! Global  Variables
! =================
 
      use mod_real
      use mod_phy____dat
      use mod_phy____grd
      use mod_sisvat_grd
 
 
 
! General Variables
! =================
 
      use mod_sisvat_trv
      use mod_sisvat_kkl
      use mod_sisvat_loc
 
 
 
! Internal Variables
! ==================
 
      use mod_sisvatlvgo
 
 
      IMPLICIT NONE
 
 
      integer             ::  ikl,ikv   ,kri
 
      real(kind=real8)    ::  exdRad,k_drad
      real(kind=real8)    ::  e_prad,e1pRad
      real(kind=real8)    ::  zv_fac,zv1fac,deadLF
      real(kind=real8)    ::  T_Rad0,A_Rad0
      real(kind=real8)    ::                r0_Rad,t0_Rad,nu_Rad
      real(kind=real8)    ::  Tr_Rad,Re_Rad,r__Rad,t__Rad,t1_Rad
      real(kind=real8)    ::  arggam, gamma
      real(kind=real8)    ::  gammaL
      real(kind=real8)    ::  denSig,Sig__c
      real(kind=real8)    ::  DDifH1,DDifC1
      real(kind=real8)    ::  DDifH2,DDifC2
      real(kind=real8)    ::  denS_s,denS_a,den_c1,DDif_L
      real(kind=real8)    ::  u0_Vis,absg_V,absv_V
      real(kind=real8)    ::  u0_nIR,absgnI,absvnI
      real(kind=real8)    ::  argexg,argexk
      real(kind=real8)    ::  residu,d_DDif,dDDifs,dDDifa
 
 
 
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!                                                                      !
! ALLOCATION                                                           !
! ==========                                                           !
 
      IF (it_run.EQ.1 .OR. flagdalloc)                            THEN !
 
      allocate              ( k___sv(kcolp,mwp) )
      allocate              ( a0__sv(kcolp,mwp) )
      allocate              ( gamasv(kcolp,mwp) )
      allocate              ( sigcsv(kcolp,mwp) )
      allocate              ( c1__sv(kcolp,mwp) )
      allocate              ( c2__sv(kcolp,mwp) )
      allocate              ( crilai(kcolp,mwp) )
 
      END IF                                                           !
!                                                                      !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 
 
! General Parameters, Solar Radiation Absorption
! ==============================================
 
      DO ikl=1,kcolp
      DO ikv=1,mwp
 
            k_drad = 0.5 /max(coszsv(ikl,ikv),eps6)           ! absorbed irradiance fraction
            e_prad = 2.5   *  coszsv(ikl,ikv)                 ! exponential argument,
                                                              ! V/nIR radiation partitioning,
                                                              ! DR97, 2, eqn (2.53) & (2.54)
            exdrad =    exp(-min(k_drad*lai_sv(ikl,ikv),ea_max))  ! exponential, Irradi. Absorpt.
            e1prad = 1.-exp(-    e_prad                    )  ! exponential, V/nIR Rad. Part.
 
            ivg    =                ivgtsv(ikl,ikv)           ! Vegetation Type
            zv_fac =    min( sncasv(ikl,ikv)/sncamx          &! Contribution of Snow to Leaf
     &                      ,  un_1)                          ! Reflectivity and Transmissiv.
            zv1fac = 1.     -       zv_fac                    !
            deadlf = 1.     -       glf_sv(ikl,ikv)           ! Dead Leaf Fraction
 
 
! Visible Part of the Solar Radiation Spectrum (V,   0.4--0.7mi.m)
! ================================================================
 
            a_rad0 =      0.25 + 0.697 * e1prad ! Absorbed    Vis. Radiation
            t_rad0 = 1. - a_rad0                ! Transmitted Vis  Radiation
 
! Reflectivity, Transmissivity
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^
            re_rad = glf_sv(ikl,ikv) *revisl(ivg)                      &
     &             + deadlf      *revisd(ivg)
            tr_rad = glf_sv(ikl,ikv) *trvisl(ivg)                      &
     &             + deadlf      *trvisd(ivg)
 
! Adaptation to Snow
! ^^^^^^^^^^^^^^^^^^
            re_rad = zv1fac      *re_rad      + zv_fac *reviss
            tr_rad = zv1fac      *tr_rad      + zv_fac *trviss
 
! Scattering /DR97, 2, eqn (2.26) and (2.27)           ! Diffuse  Radiation:
! ^^^^^^^^^^                                           ! ^^^^^^^^^^^^^^^^^^
            r__rad = (2. *re_rad +     tr_rad) / 3.    ! Upw.  Scatter.Fract.
            t__rad = (    re_rad + 2. *tr_rad) / 3.    ! Downw.Scatter.Fract.
 
            t1_rad =  1. -t__rad                       !
            arggam =      t1_rad*t1_rad-r__rad*r__rad  !
            arggam =  max(arggam,zer0)                 !
            gamma  = sqrt(arggam)                      ! eqn (2.39)
            gammal =  min( gamma*lai_sv(ikl,ikv),40.0) !
            ddifh1 =  exp( gammal           )          ! Downw.Diffus.Solut.1
            ddifh2 =  exp(-gammal           )          ! Downw.Diffus.Solut.2
!           REMARK:  These 2 contributions are zero in case of 0 Reflectivity
!           ^^^^^^
 
! Scattering /DR97, 2, eqn (2.19) and (2.20)           ! Direct   Radiation:
! ^^^^^^^^^^                                           ! ^^^^^^^^^^^^^^^^^^
            r0_rad = 0.5 *((re_rad+tr_rad) *k_drad    &! Upw.  Scatter.Fract.
     &                    +(re_rad-tr_rad) /    3.)    !
            t0_rad = 0.5 *((re_rad+tr_rad) *k_drad    &! Downw.Scatter.Fract.
     &                    -(re_rad-tr_rad) /    3.)    !
 
            nu_rad = t1_rad-r__rad*albisv(ikl,ikv)     ! nu coeff., eqn 2.43
            den_c1 =  gamma*(ddifh1+ddifh2)           &! eqn (2.43) Denomin.
     &              +nu_rad*(ddifh1-ddifh2)            !(Constant for DDifH1)
 
            densig =  gamma*gamma - k_drad*k_drad      ! eqn (2.40) Denomin.
            dens_s = sign(un_1,densig)                 !
            dens_a =  abs(     densig)                 !
            densig =  max(eps6,dens_a) * dens_s        !
            sig__c = (r__rad* r0_rad                  &! sigma_c, eqn (2.40)
     &               +t0_rad*(k_drad+t1_rad)) / densig !
 
            ddifc1 = ((gamma-nu_rad)*(t_rad0-sig__c*a_rad0)*ddifh2     &
     &             +((k_drad-nu_rad)* sig__c                           &
     &               +t0_rad+r__rad * albisv(ikl,ikv)) *a_rad0 *exdrad)&
     &           /max(den_c1,eps6)
            ddifc2 =  t_rad0        - ddifc1-sig__c*a_rad0
 
! Visible Diffuse Fluxes
! ^^^^^^^^^^^^^^^^^^^^^^
            ddif_l =  ddifc1*ddifh1 + ddifc2*ddifh2   &! DOWNward,
     &             +  sig__c*a_rad0 *exdrad            ! Canopy Basis
            u0_vis = ((gamma+t1_rad)*ddifc1           &! UPward
     &               -(gamma-t1_rad)*ddifc2           &! Canopy Top
     &             -((k_drad-t1_rad)*sig__c           &!
     &               +t0_rad               )*a_rad0)  &!
     &          / max(r__rad,eps6)                     !
            u0_vis = min(0.99,max(eps6,u0_vis))        ! ERROR
            absg_v = (1.-albisv(ikl,ikv))*(a_rad0*exdrad  &! Ground Absorption
     &                                +ddif_l       )  !
            absv_v = (1.-u0_vis     )- absg_v          ! Veget. Absorption
 
! Parameters for Computing Effective LAI for Transpiration
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
            gamasv(ikl,ikv) = gamma
            c1__sv(ikl,ikv) = ddifc1
            c2__sv(ikl,ikv) = ddifc2
            sigcsv(ikl,ikv) = sig__c
            k___sv(ikl,ikv) = k_drad
            a0__sv(ikl,ikv) = a_rad0
 
 
! Near-IR Part of the Solar Radiation Spectrum (nIR, 0.7--2.8mi.m)
! ================================================================
 
            a_rad0 =      0.80 + 0.185 * e1prad ! Absorbed    nIR. Radiation
            t_rad0 = 1. - a_rad0                ! Transmitted nIR  Radiation
 
! Reflectivity, Transmissivity
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^
            re_rad = glf_sv(ikl,ikv) *renirl(ivg)                      &
     &             + deadlf      *renird(ivg)
            tr_rad = glf_sv(ikl,ikv) *trnirl(ivg)                      &
     &             + deadlf      *trnird(ivg)
 
! Adaptation to Snow
! ^^^^^^^^^^^^^^^^^^
            re_rad = zv1fac      *re_rad      + zv_fac *renirs
            tr_rad = zv1fac      *tr_rad      + zv_fac *trnirs
 
! Scattering /DR97, 2, eqn (2.26) and (2.27)           ! Diffuse  Radiation:
! ^^^^^^^^^^                                           ! ^^^^^^^^^^^^^^^^^^
            r__rad = (2. *re_rad +     tr_rad) / 3.    ! Upw.  Scatter.Fract.
            t__rad = (    re_rad + 2. *tr_rad) / 3.    ! Downw.Scatter.Fract.
 
            t1_rad =  1. -t__rad                       !
            arggam =      t1_rad*t1_rad-r__rad*r__rad  !
            arggam =  max(arggam,zer0)                 !
            gamma  = sqrt(arggam)                      ! eqn (2.39)
            ddifh1 =  exp( gamma*lai_sv(ikl,ikv))      ! Downw.Diffus.Solut.1
            ddifh2 =  exp(-gamma*lai_sv(ikl,ikv))      ! Downw.Diffus.Solut.2
!           REMARK:  These 2 contributions are zero in case of 0 Reflectivity
!           ^^^^^^
 
! Scattering /DR97, 2, eqn (2.19) and (2.20)           ! Direct   Radiation:
! ^^^^^^^^^^                                           ! ^^^^^^^^^^^^^^^^^^
            r0_rad = 0.5 *((re_rad+tr_rad) *k_drad    &! Upw.  Scatter.Fract.
     &                    +(re_rad-tr_rad) /    3.)    !
            t0_rad = 0.5 *((re_rad+tr_rad) *k_drad    &! Downw.Scatter.Fract.
     &                    -(re_rad-tr_rad) /    3.)    !
 
            nu_rad = t1_rad-r__rad*albisv(ikl,ikv)     ! nu coeff., eqn 2.43
            den_c1 =  gamma*(ddifh1+ddifh2)           &! eqn (2.43) Denomin.
     &              +nu_rad*(ddifh1-ddifh2)            !(Constant for DDifH1)
 
            densig =  gamma*gamma - k_drad*k_drad      ! eqn (2.40) Denomin.
            dens_s = sign(un_1,densig)                 !
            dens_a =  abs(     densig)                 !
            densig =  max(eps6,dens_a) * dens_s        !
            sig__c = (r__rad* r0_rad                  &! sigma_c, eqn (2.40)
     &               +t0_rad*(k_drad+t1_rad)) / densig !
 
            ddifc1 = ((gamma-nu_rad)*(t_rad0-sig__c*a_rad0)*ddifh2     &
     &             +((k_drad-nu_rad)* sig__c                           &
     &               +t0_rad+r__rad * albisv(ikl,ikv)) *a_rad0 *exdrad)&
     &           /max(den_c1,eps6)
            ddifc2 =  t_rad0        - ddifc1-sig__c*a_rad0
 
! Near IR Diffuse Fluxes
! ^^^^^^^^^^^^^^^^^^^^^^
            ddif_l =  ddifc1*ddifh1 + ddifc2*ddifh2   &! DOWNward,
     &             +  sig__c*a_rad0 *exdrad            ! Canopy Basis
            u0_nir = ((gamma+t1_rad)*ddifc1           &! UPward
     &               -(gamma-t1_rad)*ddifc2           &! Canopy Top
     &             -((k_drad-t1_rad)*sig__c           &!
     &               +t0_rad               )*a_rad0)  &!
     &          / max(r__rad,eps6)                     !
            u0_nir = min(0.99,max(eps6,u0_nir))        ! ERROR
            absgni = (1.-albisv(ikl,ikv))*(a_rad0*exdrad  &! Ground Absorption
     &                                +ddif_l       )  !
            absvni = (1.-u0_nir     )- absgni          ! Veget. Absorption
 
 
! Surface-Canopy Albedo and Normalized Solar Radiation Absorption
! ===============================================================
 
            alb_sv(ikl,ikv) = (u0_vis+u0_nir)*0.5d0
            socasv(ikl,ikv) = (absv_v+absvni)*0.5d0
            sososv(ikl,ikv) = (absg_v+absgni)*0.5d0
 
      END DO
      END DO
 
 
! Effective LAI for Transpiration
! ===============================
 
        DO ikl=1,kcolp
        DO ikv=1,mwp
              crilai(ikl,ikv) = 2.              ! LAI for which D0_Vis > 20W/m2
                                                ! DR97, 2, eqn (2.57)
        END DO
        END DO
 
      DO   kri=1,10
        DO ikl=1,kcolp
        DO ikv=1,mwp
 
              argexg      =  min(crilai(ikl,ikv)*gamasv(ikl,ikv),     ea_max)
              argexk      =  min(crilai(ikl,ikv)*k___sv(ikl,ikv),     ea_max)
              residu      =      c1__sv(ikl,ikv)            *exp( argexg)  &
     &                          +c2__sv(ikl,ikv)            *exp(-argexg)  &
     &                          +a0__sv(ikl,ikv)*gamasv(ikl,ikv)*exp(-argexk)  &
     &                          -cristr /max(sol_sv(ikl,ikv),       eps6)
 
              d_ddif      =      c1__sv(ikl,ikv)*gamasv(ikl,ikv)*exp( argexg)  &
     &                          -c2__sv(ikl,ikv)*gamasv(ikl,ikv)*exp(-argexg)  &
     &                          -a0__sv(ikl,ikv)*k___sv(ikl,ikv)*exp(-argexk)
              dddifs      = sign(un_1,d_ddif)
              dddifa      =  abs(     d_ddif)
              d_ddif      =  max(eps6,dddifa) * dddifs
 
              crilai(ikl,ikv) =      crilai(ikl,ikv)-residu/d_ddif
              crilai(ikl,ikv) =  max(crilai(ikl,ikv),zer0       )
              crilai(ikl,ikv) =  min(crilai(ikl,ikv),lai_sv(ikl,ikv))
 
        END DO
        END DO
      END DO
 
        DO ikl=1,kcolp
        DO ikv=1,mwp
              laiesv(ikl,ikv) = crilai(ikl,ikv) +(exp(-min(k___sv(ikl,ikv)*crilai(ikl,ikv),ea_max)) &
     &                                   -exp(-min(k___sv(ikl,ikv)*lai_sv(ikl,ikv),ea_max)))&
     &                                  /          k___sv(ikl,ikv)
        END DO
        END DO
 
 
 
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!                                                                      !
! DE-ALLOCATION                                                        !
! =============                                                        !
 
      IF (flagdalloc)                                             THEN !
 
      deallocate            ( k___sv )
      deallocate            ( a0__sv )
      deallocate            ( gamasv )
      deallocate            ( sigcsv )
      deallocate            ( c1__sv )
      deallocate            ( c2__sv )
      deallocate            ( crilai )
 
      END IF                                                           !
!                                                                      !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 
      return
      end subroutine vgoptp
 
 
 
      subroutine colprt_sbl
 
!--------------------------------------------------------------------------+
!   MAR          ColPrt_SBL                           Wed 26-Jun-2013  MAR |
!     SubRoutine ColPrt_SBL generates Surface Boundary Layers Properties   |
!                                                                          |
!     version 3.p.4.1 created by H. Gallee,           Tue  5-Feb-2013      |
!           Last Modification by H. Gallee,           Wed 26-Jun-2013      |
!                                                                          |
!--------------------------------------------------------------------------+
!                                                                          |
!     PARAMETERS:  kcolv: Total Number of columns                          |
!     ^^^^^^^^^^        = Total Number of continental     grid boxes       |
!                       X       Number of Mosaic Cell per grid box         |
!                                                                          |
!     INPUT:   za__SV   : Surface Boundary Layer (SBL) Height          [m] |
!     ^^^^^    VV__SV   :(SBL Top)   Wind Velocity                   [m/s] |
!              TaT_SV   : SBL Top    Temperature                       [K] |
!              rhT_SV   : SBL Top  Air  Density                    [kg/m3] |
!              uqs_SV   : Specific  Humidity  Turbulent Flux         [m/s] |
!              Tsrfsv   : Surface    Temperature                       [K] |
!                                                                          |
!     INPUT /  LMO_SV   : Monin-Obukhov       Scale                    [m] |
!     OUTPUT:  us__SV   : Friction  Velocity                         [m/s] |
!     ^^^^^^   uts_SV   : Temperature         Turbulent Flux       [K.m/s] |
!                                                                          |
!     OUTPUT:  ram_sv   : Aerodynamic Resistance for Momentum        [s/m] |
!     ^^^^^^   rah_sv   : Aerodynamic Resistance for Heat            [s/m] |
!                                                                          |
!--------------------------------------------------------------------------+
 
 
! Global  Variables
! =================
 
      use mod_real
      use mod_phy____dat
      use mod_phy____grd
      use mod_sisvat_grd
 
 
 
! General Variables
! =================
 
      use mod_sisvat_dat
      use mod_sisvat_kkl
      use mod_sisvat_loc
 
 
 
      IMPLICIT NONE
 
 
 
! Internal Variables
! ==================
 
      integer           ::  ikl,ikv    ,ist    ,ist__s ,ist__w
      real(kind=real8)  ::  d_TaTs ,CD_m
      real(kind=real8)  ::  uustar ,thstar ,qqstar
      real(kind=real8)  ::  thstarv,thstars,thstara
      real(kind=real8)  ::  zeta   ,zeta_S ,zeta_A
      real(kind=real8)  ::  fCdCdP =  3.09                  ! Drag Coefficient Factor, Col de Porte
      real(kind=real8)  ::  Cd_min =  1.05                  ! Drag Coefficient Minimum Col de Porte
      real(kind=real8)  ::  cCdUns = -5.00                  ! Drag Coefficient Correction for Unstability
      real(kind=real8)  ::  RapCm0
 
 
! Aerodynamic Resistances
! =======================
 
      DO ikl=1,kcolp
      DO ikv=1,mwp
 
! Surface Type
! ~~~~~~~~~~~~
        ist    =      isotsv(ikl,ikv)                ! Soil Type
        ist__s =  min(ist, 1)                        ! 1 => Soil
        ist__w =  1 - ist__s                         ! 1 => Water Body
 
! Drag and Aerodynamic Resistance
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
        d_tats =      tat_sv(ikl,ikv)-tsrfsv(ikl,ikv)
        rapcm0 =  log(za__sv(ikl,ikv)/z0mdsv(4          )) &
     &         /  log(za__sv(ikl,ikv)/z0mdsv(ivgtsv(ikl,ikv)))
        rapcm0 =      rapcm0     *rapcm0             ! Neutral Drag Coefficient
                                                     ! Vegetation   Correction
        cd_m   =  max(cd_min*rapcm0,                &! Actual  Drag Coefficient
     &                fcdcdp*rapcm0*vv__sv(ikl,ikv)  )  &!         for  Momentum
     &          *(1.+max(min(d_tats,zer0),ccduns)   &! Unstability  Correction
     &                                   /ccduns )  &!
     &          * 1.5                                !
        ram_sv(ikl,ikv) = rht_sv(ikl,ikv) *cpdair/cd_m   !
        rah_sv(ikl,ikv) = ram_sv(ikl,ikv)            !
 
 
! Turbulent Scales
! ================
 
! Friction Velocity                   u*
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
        uustar      =      vv__sv(ikl,ikv) / ram_sv(ikl,ikv)
        us__sv(ikl,ikv) = sqrt(uustar)
 
! Real    Temperature Turbulent Scale theta*
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
        uts_sv(ikl,ikv) =    - d_tats      / rah_sv(ikl,ikv)
        thstar      =      uts_sv(ikl,ikv) / us__sv(ikl,ikv)
 
! Specific Humidity   Turbulent Scale qq*
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
        qqstar      =      uqs_sv(ikl,ikv) / us__sv(ikl,ikv)
 
! Virtual Temperature Turbulent Scale thetav*
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
        thstarv     = thstar      + tat_sv(ikl,ikv) *(0.608*qqstar)
        thstars     =     sign(un_1,thstarv)
        thstara     =      abs(     thstarv)
        thstarv     =      max(eps6,thstara)    *thstars
 
! Monin Obukhov Scale Height
! ~~~~~~~~~~~~~~~~~~~~~~~~~~
        lmo_sv(ikl,ikv) = tat_sv(ikl,ikv) * uustar                     &
     &              /(vonkrm      * grav_f     * thstarv)
        zeta        = za__sv(ikl,ikv) / lmo_sv(ikl,ikv)
        zeta_s      =          sign(un_1  ,zeta)
        zeta_a      =           abs(       zeta)
        zeta        = zeta_s  * max(eps6  ,zeta_a)
        lmo_sv(ikl,ikv) = za__sv(ikl,ikv) / zeta
 
      END DO
      END DO
 
 
      return
      end subroutine colprt_sbl
 
 
 
      subroutine sisvatesbl
 
!--------------------------------------------------------------------------+
!   MAR          SISVATeSBL                           Wed 26-Jun-2013  MAR |
!     SubRoutine SISVATeSBL generates Surface Boundary Layers Properties   |
!                                                                          |
!     version 3.p.4.1 created by H. Gallee,           Tue  5-Feb-2013      |
!           Last Modification by H. Gallee,           Wed 26-Jun-2013      |
!                                                                          |
!--------------------------------------------------------------------------+
!                                                                          |
!     PARAMETERS:  kcolv: Total Number of columns                          |
!     ^^^^^^^^^^        = Total Number of continental     grid boxes       |
!                       X       Number of Mosaic Cell per grid box         |
!                                                                          |
!     INPUT:   za__SV   : Surface Boundary Layer (SBL) Height          [m] |
!     ^^^^^    VV__SV   :(SBL Top)   Wind Velocity                   [m/s] |
!              TaT_SV   : SBL Top    Temperature                       [K] |
!              qsnoSV   : SBL Mean   Snow      Content             [kg/kg] |
!              uqs_SV   : Specific   Humidity  Turbulent Flux        [m/s] |
!              usthSV   : Blowing Snow Erosion   Threshold           [m/s] |
!              Z0m_SV   : Momentum     Roughness Length                [m] |
!              Z0h_SV   : Heat         Roughness Length                [m] |
!              Tsrfsv   : Surface    Temperature                       [K] |
!              sqrCm0   : Contribution of Z0m to Neutral Drag Coefficient  |
!              sqrCh0   : Contribution of Z0h to Neutral Drag Coefficient  |
!                                                                          |
!     INPUT /  LMO_SV   : Monin-Obukhov       Scale                    [m] |
!     OUTPUT:  us__SV   : Friction  Velocity                         [m/s] |
!     ^^^^^^   uts_SV   : Temperature         Turbulent Flux       [K.m/s] |
!              uss_SV   : Blowing Snow        Turbulent Flux         [m/s] |
!                                                                          |
!     OUTPUT:  hSalSV   : Saltating Layer Height                       [m] |
!     ^^^^^^   qSalSV   : Saltating Snow  Concentration            [kg/kg] |
!              ram_sv   : Aerodynamic Resistance for Momentum        [s/m] |
!              rah_sv   : Aerodynamic Resistance for Heat            [s/m] |
!                                                                          |
!                                                                          |
!     Preprocessing  Option: STANDARD                                      |
!     ^^^^^^^^^^^^^^^^^^^^^  ^^^^^^^^                                      |
!     #AE: TURBULENCE: Aerosols Erosion / Turbulent Diffusion Coeff.       |
!                                                                          |
!     #AW  TURBULENCE: Wind Time Mean (BOX Moving Average)                 |
!     #AH  TURBULENCE: Ta-T Time Mean (BOX Moving Average)                 |
!                                                                          |
!                                                                          |
!     Preprocessing  Option:                                               |
!     ^^^^^^^^^^^^^^^^^^^^^                                                |
!     #ZX  TURBULENCE: Strong Stability Limit (King    et al. 1996)        |
!     #zx  TURBULENCE: Strong Stability Limit (Mahalov et al. 2004)        |
!     #AX  TURBULENCE: recurrence                                          |
!                                                                          |
!                                                                          |
!     Preprocessing  Option: SISVAT IO (not always a standard preprocess.) |
!     ^^^^^^^^^^^^^^^^^^^^^  ^^^^^^^^^                                     |
!     FILE                 |      CONTENT                                  |
!     ~~~~~~~~~~~~~~~~~~~~~+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
!   # stdout               | #ss: OUTPUT of Blowing Snow Variables         |
!                          |      unit  6, SubRoutine  SISVATeSBL **ONLY** |
!--------------------------------------------------------------------------+
 
 
! Global  Variables
! =================
 
      use mod_real
      use mod_phy____dat
      use mod_phy____grd
      use mod_sisvat_grd
 
 
 
! General Variables
! =================
 
      use mod_sisvat_dat
      use mod_sisvat_kkl
      use mod_sisvat_loc
      use mod_sisvat_ctr
! #AW use Mod_SISVAT_xAW
! #AH use Mod_SISVAT_xAH
      use mod_sisvatlsbl
 
 
      IMPLICIT NONE
 
 
! Internal Variables
! ==================
 
! V,  dT(a-s)    Time Moving Averages
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      integer                                      ::  ikl,ikv   ,icount
! #AE integer                                      ::  nit    =   5    ! us(is0,uth) recursivity: Nb Iterations
! #AE integer                                      ::  iit
 
      real(kind=real8)                             ::  VVa_OK          ! effective SBL wind speed
      real(kind=real8)                             ::  Theta0 = 288.0  ! Potential Reference Temperature
 
!     real(kind=real8)                             ::  LMOsgn          ! Monin-Obukhov Scale Sign
!     real(kind=real8)                             ::  LMOabs          ! Monin-Obukhov Scale Abs.Value
 
      real(kind=real8)                             ::  uustar,thstar   !
      real(kind=real8)                             ::  qqstar,ssstar   !
      real(kind=real8)                             ::  thstarv,thstars !
      real(kind=real8)                             ::  thstara         !
      real(kind=real8)                             ::  zetam ,zetah    !
      real(kind=real8)                             ::  zeta0m,zeta0h   !
      real(kind=real8)                             ::  psim_s,xpsimi   !
      real(kind=real8)                             ::  psim_i,psim_z   !
! #AE real(kind=real8)                             ::  psis_s,psis_z   !
! #AE real(kind=real8)                             ::  psis_0          !
      real(kind=real8)                             ::  psih_s,xpsihi   !
      real(kind=real8)                             ::  psih_i,psih_z   !
      real(kind=real8)                             ::  psim_0,psih_0   !
      real(kind=real8)                             ::  dustar,u0star   !
 
      real(kind=real8)                             ::  sss__F,sss__N   !
      real(kind=real8)                             ::  usuth0          !
! #AE real(kind=real8)                             ::  dusuth,signus   !
! #AE real(kind=real8)                             ::  sss__K,sss__G   !
! #AE real(kind=real8)                             ::  us_127,us_227   !
! #AE real(kind=real8)                             ::  us_327,us_427   !
! #AE real(kind=real8)                             ::  us_527          !
 
      real(kind=real8)                             ::  stab_s          !
      real(kind=real8)                             ::  zetMAX =  1.e6  ! Strong Stability Limit
      real(kind=real8)                             ::  coef_m = 20.    ! Stabil.Funct.for Moment.: unstab.coef.
      real(kind=real8)                             ::  coef_h = 15.    ! Stabil.Funct.for Heat:    unstab.coef.
! #AE real(kind=real8)                             ::  SblPom =  1.27  ! Lower Boundary Height Parameter for Suspension
                                                                       ! Pommeroy, Gray and Landine 1993, J. Hydrology, 144(8) p.169
!     real(kind=real8)                             ::  fac_Ri          !
!     real(kind=real8)                             ::  Kz_vun          !
 
! OUTPUT of Snow Erosion Turbulence
! #b1 real(kind=real8)                             ::  W_pLMO          ! Pseudo Obukhov Length  (WRITE)
! #b1 real(kind=real8)                             ::  W_psim          ! Pseudo psim(z)         (WRITE)
 
! OUTPUT of Snow Erosion Turbulence (2)
! #b2 real(kind=real8)                             ::  W_NUs1          ! Contrib to U* numerat.1(WRITE)
! #b2 real(kind=real8)                             ::  W_NUs2          ! Contrib to U* numerat.2(WRITE)
! #b2 real(kind=real8)                             ::  W_NUs3          ! Contrib to U* numerat.3(WRITE)
! #b2 real(kind=real8)                             ::  W_DUs1          ! Contrib to U* denomin.1(WRITE)
! #b2 real(kind=real8)                             ::  W_DUs2          ! Contrib to U* denomin.2(WRITE)
 
 
 
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!                                                                      !
! ALLOCATION                                                           !
! ==========                                                           !
 
      IF (it_run.EQ.1 .OR. flagdalloc)                            THEN !
 
      allocate            ( vvasbl(kcolp,mwp) )                        ! effective SBL wind speed
      allocate            ( dta_ts(kcolp,mwp) )                        ! effective SBL Temperature diff.
      allocate            ( lmomom(kcolp,mwp) )                        ! Monin-Obukhov Scale Momentum
      allocate            ( cdm(kcolp,mwp)    )                        ! Drag Coefficient, Momentum
      allocate            ( cds(kcolp,mwp)    )                        ! Drag Coefficient, Blown **
      allocate            (rcds(kcolp,mwp)    )                        ! Drag Coefficient, Blown **
      allocate            ( cdh(kcolp,mwp)    )                        ! Drag Coefficient, Scalar
      allocate            ( richar(kcolp,mwp) )                        ! Richardson Number
 
      END IF                                                           !
!                                                                      !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 
 
! Internal DATA
! =============
 
! #zx                       zetMAX = 1.e0                 ! Strong Stability Limit
                                                          !(Mahalov et al. 2004, GRL  31 2004GL021055)
! #ZX                       zetMAX = 4.28                 ! Strong Stability Limit
                                                          !(King    et al. 1996, JGR 101(7) p.19121)
 
 
! Effective SBL variables
! =======================
 
      DO ikl=1,kcolp
      DO ikv=1,mwp
        vvasbl(ikl,ikv)   = vv__sv(ikl,ikv)
! #AW   VVaSBL(ikl,ikv)   = VVmmem(ikl,ikv)
        dta_ts(ikl,ikv)   = tat_sv(ikl,ikv)-tsrfsv(ikl,ikv)
! #AH   dTa_Ts(ikl,ikv)   = dTmmem(ikl,ikv)
      END DO
      END DO
 
 
! Convergence Criterion
! =====================
 
      icount = 0
 
! #AX 1        CONTINUE
      icount = icount + 1
      dustar = 0.
 
        DO ikl=1,kcolp
        DO ikv=1,mwp
 
          u0star      = us__sv(ikl,ikv)
 
 
! Turbulent Scales from previous Time Step
! ----------------------------------------
 
          u0star      =      max(eps6,u0star)      ! Friction Velocity     u*
          uustar      = u0star      * u0star       ! Friction Velocity^2  uu*
          thstar      = uts_sv(ikl,ikv) / u0star   ! Temperature       theta*
          qqstar      = uqs_sv(ikl,ikv) / u0star   ! Specific Humidity    qq*
          ssstar      = uss_sv(ikl,ikv) / u0star   ! Blown    Snow        ss*
 
 
! Monin-Obukhov Stability Parameter for Momentum
! ----------------------------------------------
 
! Pseudo Virtual Temperature Turbulent Scale thetav*
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
          thstarv     = thstar      + theta0      *(0.608*qqstar)      &
     &                             /(1.+0.608*qat_sv(ikl,ikv)-qsnosv(ikl,ikv))
          thstars     =     sign(un_1,thstarv)
          thstara     =      abs(     thstarv)
          thstarv     =      max(eps6,thstara)*thstars
 
! Pseudo Obukhov Length Scale        (Gall?e et al., 2001 BLM 99, (A2) p.17)
! Full   Obukhov Length Scale        (when Blowing * is ##NOT## switched ON)
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
          lmo_sv(ikl,ikv) = theta0      * max(eps6,uustar)             &
     &                /(vonkrm      * grav_f  *thstarv)
 
! OUTPUT of Snow Erosion Turbulence
! #b1     W_pLMO      = LMO_SV(ikl,ikv)
 
          zetah       = za__sv(ikl,ikv) / lmo_sv(ikl,ikv)
          zetam       =           min(zetmax,zetah)! Strong Stability Limit
                                                   !(Mahalov et al. 2004
                                                   ! GRL 31 2004GL021055)
          lmomom(ikl,ikv) = za__sv(ikl,ikv) /(max(eps6,abs(zetam))     &
     &                              *sign(un_1,    zetam ))
          zeta0m      = z0m_sv(ikl,ikv) / lmomom(ikl,ikv)
          zeta0h      = z0h_sv(ikl,ikv) / lmo_sv(ikl,ikv)
 
! Momentum Pseudo Stability Function (Gall?e et al. 2001, BLM 99, (11) p. 7)
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
          stab_s      =  max(zer0,sign(un_1,zetam))
 
          psim_s      =  -a_stab *zetam
          xpsimi      = sqrt(sqrt(un_1-coef_m*min(zer0,zetam)))
          psim_i      =   2. *log(half*(un_1+xpsimi))                  &
     &                       +log(half*(un_1+xpsimi*xpsimi))           &
     &                   -2.*atan(xpsimi)   +half*pinmbr
          psim_z      =    stab_s*psim_s+(1.-stab_s)*psim_i
 
! OUTPUT of Snow Erosion Turbulence
! #b1     W_psim      =           psim_z
 
          psim_s      =  -a_stab *zeta0m
          xpsimi      = sqrt(sqrt(un_1-coef_m*min(zer0,zeta0m)))
          psim_i      =   2. *log(half*(un_1+xpsimi))                  &
     &                       +log(half*(un_1+xpsimi*xpsimi))           &
     &                   -2.*atan(xpsimi)   +half*pinmbr
          psim_0      =    stab_s*psim_s+(1.-stab_s)*psim_i
 
! Virtual Temperature Turbulent Scale thetav*    (ss* impact included   )
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ needed for new ss*)
! #AE     thstarv     = thstar      + Theta0      *(0.608*qqstar       &
! #AE&                                                   -ssstar       &
! #AE&                                             )                   &
! #AE&                             /(1.+0.608*QaT_SV(ikl,ikv)-qsnoSV(ikl,ikv))
! #AE     thstars     =     sign(un_1,thstarv)
! #AE     thstara     =      abs(     thstarv)
! #AE     thstarv     =      max(eps6,thstara)    *thstars
 
! Full   Obukhov Length Scale        (Gall?e et al. 2001, BLM 99, (A1) p.16)
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! #AE     LMO_SV(ikl,ikv) = Theta0      * us__SV(ikl,ikv)* us__SV(ikl,ikv) &
! #AE&                /(vonKrm      * Grav_F     * thstarv)
 
! #AE     zetah       = za__SV(ikl,ikv) / LMO_SV(ikl,ikv)
! #AE     zetam       =           min(zetMAX,zetah)! Strong Stability Limit
                                                   !(Mahalov et al. 2004
                                                   ! GRL 31 2004GL021055)
! #AE     LMOmom(ikl,ikv) = za__SV(ikl,ikv) /(max(eps6,abs(zetam))     &
! #AE&                              *sign(un_1,    zetam ))
! #AE     zeta0m      = Z0m_SV(ikl,ikv) / LMOmom(ikl,ikv)
 
! Snow Erosion    Stability Function (Gall?e et al. 2001, BLM 99, (11) p. 7)
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! #AE     stab_s      =  max(zer0,sign(un_1,zetam))
 
! #AE     psis_s      =  -AsStab *zetam
! #AE     xpsimi      = sqrt(sqrt(un_1-coef_m*min(zer0,zetam)))
! #AE     psim_i      =   2. *log(half*(un_1+xpsimi))                  &
! #AE&                       +log(half*(un_1+xpsimi*xpsimi))           &
! #AE&                   -2.*atan(xpsimi)   +half*piNmbr
! #AE     psis_z      =    stab_s*psis_s+(1.-stab_s)*psim_i
 
! #AE     psis_s      =  -AsStab *zeta0m
! #AE     xpsimi      = sqrt(sqrt(un_1-coef_m*min(zer0,zeta0m)))
! #AE     psim_i      =   2. *log(half*(un_1+xpsimi))                  &
! #AE&                       +log(half*(un_1+xpsimi*xpsimi))           &
! #AE&                   -2.*atan(xpsimi)   +half*piNmbr
! #AE     psis_0      =    stab_s*psis_s+(1.-stab_s)*psim_i
 
! Square Roots of the Drag Coefficient for Snow Erosion Turbulent Flux
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! #AE     rCDmSV(ikl,ikv) = vonKrm/(sqrCm0(ikl,ikv)-psim_z+psim_0)
 
! OUTPUT in SISVAT at specified i,j,k,n (see assignation in PHY_SISVAT)
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! Martin control : on remplace les "! #ss" par rien au début de la ligne
          IF (ii__ap(ikl).EQ.iwr_sv.AND.jj__ap(ikl).EQ.jwr_sv   .AND.  &
     &        ikv        .EQ.nwr_sv                          )     &
     &    write(6,6600)  z0m_sv(ikl,ikv) , psim_z                      &
     &                  ,lmo_sv(ikl,ikv) , uustar                      &
     &                  ,sqrcm0(ikl,ikv) , psim_0                      &
     &                  ,lmomom(ikl,ikv) , thstarv
      6600      format(/,' ** SISVATeSBL *0  '                         &
     &            ,'  Z0m_SV  = ',e12.4,'  psim_z  = ',e12.4           &
     &            ,'  LMO_SV  = ',e12.4,'  uustar  = ',e12.4           &
     &          ,/,'                   '                               &
     &            ,'  sqrCm0  = ',e12.4,'  psim_0  = ',e12.4           &
     &            ,'  LMOmom  = ',e12.4,'  thstarv = ',e12.4)
! Martin control : on remplace les "! #ss" par rien au début de la ligne
 
 
! Momentum            Turbulent Scale  u*
! ---------------------------------------
 
! Momentum            Turbulent Scale  u*          in case of NO Blow. Snow
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
          vva_ok      =  max(0.000001,       vvasbl(ikl,ikv))
          sss__n      =  vonkrm      *       vva_ok
          sss__f      = (sqrcm0(ikl,ikv) - psim_z + psim_0)
          usuth0      =  sss__n /sss__f                ! u* if NO Blow. Snow
 
! Momentum            Turbulent Scale  u*          in case of    Blow. Snow
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! #AE     sss__G      =  0.27417     * Grav_F
 
! ______________               _____
! Newton-Raphson (! Iteration, BEGIN)
! ~~~~~~~~~~~~~~               ~~~~~
! #AE     DO iit=1,nit
! #AE     sss__K      =  Grav_F      * r_Stab * A_Stab *za__SV(ikl,ikv)&
! #AE&                                     *rCDmSV(ikl,ikv)*rCDmSV(ikl,ikv)&
! #AE&                           /(1.+0.608*QaT_SV(ikl,ikv)-qsnoSV(ikl,ikv))
! #AE     us_127      =  exp(    SblPom *log(us__SV(ikl,ikv)))
! #AE     us_227      =  us_127         *    us__SV(ikl,ikv)
! #AE     us_327      =  us_227         *    us__SV(ikl,ikv)
! #AE     us_427      =  us_327         *    us__SV(ikl,ikv)
! #AE     us_527      =  us_427         *    us__SV(ikl,ikv)
 
! #AE     us__SV(ikl,ikv) =  us__SV(ikl,ikv)                           &
! #AE&    - (  us_527     *sss__F     /sss__N                          &
! #AE&      -  us_427                                                  &
! #AE&      -  us_227     *qsnoSV(ikl,ikv)*sss__K                      &
! #AE&      + (us__SV(ikl,ikv)*us__SV(ikl,ikv)-usthSV(ikl,ikv)*usthSV(ikl,ikv))/sss__G)&
! #AE&     /(  us_427*5.27*sss__F     /sss__N                          &
! #AE&      -  us_327*4.27                                             &
! #AE&      -  us_127*2.27*qsnoSV(ikl,ikv)*sss__K                      &
! #AE&      +  us__SV(ikl,ikv)*2.0                                 /sss__G)
 
! #AE     us__SV(ikl,ikv)= min(us__SV(ikl,ikv),usuth0)
! #AE     us__SV(ikl,ikv)= max(us__SV(ikl,ikv),eps6  )
! #AE     rCDmSV(ikl,ikv)=     us__SV(ikl,ikv)/VVa_OK
! #Ae     sss__F     =     vonKrm     /rCDmSV(ikl,ikv)
! #AE     END DO
! ______________               ___
! Newton-Raphson (! Iteration, END  )
! ~~~~~~~~~~~~~~               ~~~
 
! #AE     us_127      =  exp(    SblPom *log(us__SV(ikl,ikv)))
! #AE     us_227      =  us_127         *    us__SV(ikl,ikv)
 
! Momentum            Turbulent Scale  u*: 0-Limit in case of no Blow. Snow
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! #AE     dusuth      =  us__SV(ikl,ikv) - usthSV(ikl,ikv)   ! u* - uth*
! #AE     signus      =  max(sign(un_1,dusuth),zer0)     ! 1 <=> u* - uth* > 0
          us__sv(ikl,ikv) =                             &!
! #AE&                   us__SV(ikl,ikv)  *signus  +    &! u* (_BS)
     &                   usuth0                         &! u* (nBS)
! #AE&                            *(1.-signus)          &!
     &                +  0.
 
 
! Blowing Snow        Turbulent Scale ss*
! ---------------------------------------
 
! Blowing Snow Surface Boundary Condition
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! #AE     hSalSV(ikl,ikv) = 8.436e-2  *exp(SblPom  *log(us__SV(ikl,ikv)))
! #AE     qSalSV(ikl,ikv) = (us__SV(ikl,ikv) * us__SV(ikl,ikv)         &
! #AE&                  -usthSV(ikl,ikv) * usthSV(ikl,ikv))*signus     &
! #AE&                / (sss__G      * us_227     )
 
! Blowing Snow Surface Boundary Condition (modification, .NOT. tested)
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! #ae     qSalSV(ikl,ikv) = (us__SV(ikl,ikv) * us__SV(ikl,ikv)         &
! #ae&                  -usthSV(ikl,ikv) * usthSV(ikl,ikv))            &
! #ae&                  *signus      * us__SV(ikl,ikv) *3.25           &
! #ae&                 /(hSalSV(ikl,ikv) * Grav_F           )
 
! #AE     ssstar      =  rCDmSV(ikl,ikv) *(qsnoSV(ikl,ikv) -qSalSV(ikl,ikv))   &
! #AE&                 * r_Stab
 
! #AE     uss_SV(ikl,ikv) =  min(zer0    , us__SV(ikl,ikv) *ssstar)
 
! OUTPUT in SISVAT at specified i,j,k,n (see assignation in PHY_SISVAT)
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! #ss     IF (ii__AP(ikl).EQ.iwr_SV.AND.jj__AP(ikl).EQ.jwr_SV   .AND.  &
! #ss&        ikv        .EQ.nwr_SV                          )  THEN
! #ss     write(6,6000)  daHost     ,     icount     ,                 &
! #ss&                   us__SV(ikl,ikv),1.e3*hSalSV(ikl,ikv),         &
! #ss&              1.e3*Z0m_SV(ikl,ikv),                              &
! #ss&              1.e3*qsnoSV(ikl,ikv),1.e3*qSalSV(ikl,ikv)          &
! #ss&                  ,usthSV(ikl,ikv),     us__SV(ikl,ikv)-usthSV(ikl,ikv), &
! #ss&              1.e3*ssstar     ,1.e3*us__SV(ikl,ikv)*ssstar
! #ss 6000 format(a18,i3,6x,'u*   [m/s] =',f6.3,'   hSalt[mm]='  ,e9.3,&
! #ss&                  '   Z0m   [mm] =',f9.3,'   q   [g/kg] =',f9.3, &
! #ss&               /,91x,                    '   qSa [g/kg] =',f9.3, &
! #ss&               /,27x, 'ut*[m/s]='  ,e9.3,'   u*-ut*   ='  ,e9.3, &
! #ss&                  '   s*  [g/kg] =',f9.3,'   us* [mm/s] =',f9.3)
! #ss     END IF
 
 
! Virtual Temperature Turbulent Scale thetav*    (ss* impact included)
! --------------------------------------------------------------------
 
! #AE     thstarv     = thstar      + Theta0      *(0.608*qqstar       &
! #AE&                                                   -ssstar       &
! #AE&                                             )                   &
! #AE&                             /(1.+0.608*QaT_SV(ikl,ikv)-qsnoSV(ikl,ikv))
! #AE     thstars     =     sign(un_1,thstarv)
! #AE     thstara     =      abs(     thstarv)
! #AE     thstarv     =      max(eps6,thstara)    *thstars
 
 
! Full   Obukhov Length Scale (Gall?e et al., 2001, BLM 99, (A1) p.16)
! --------------------------------------------------------------------
 
! #AE     LMO_SV(ikl,ikv) = Theta0      * us__SV(ikl,ikv)* us__SV(ikl,ikv) &
! #AE&                /(vonKrm      * Grav_F     * thstarv)
 
! #AE     zetah       = za__SV(ikl,ikv) / LMO_SV(ikl,ikv)
! #AE     zetam       =           min(zetMAX,zetah)! Strong Stability Limit
                                                   !(Mahalov et al. 2004
                                                   ! GRL 31 2004GL021055)
! #AE     LMOmom(ikl,ikv) = za__SV(ikl,ikv) /(max(eps6,abs(zetam))     &
! #AE&                              *sign(un_1,    zetam ))
! #AE     zeta0m      = Z0m_SV(ikl,ikv) / LMOmom(ikl,ikv)
! #AE     zeta0h      = Z0h_SV(ikl,ikv) / LMO_SV(ikl,ikv)
 
! OUTPUT in SISVAT at specified i,j,k,n (see assignation in PHY_SISVAT)
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! #ss     IF (ii__AP(ikl).EQ.iwr_SV.AND.jj__AP(ikl).EQ.jwr_SV   .AND.  &
! #ss&        ikv        .EQ.nwr_SV                          )  THEN
! #ss     write(6,6001)  LMO_SV(ikl,ikv)    ,    zetah
! #ss 6001      format(18x,9x,'LMO  [m]=',f9.1,'   zetah[-] =',f9.3)
! #ss     END IF
 
 
! Turbulent Scales
! ----------------
 
! Momentum Stability Function (Gall?e et al., 2001, BLM 99, (11) p. 7)
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
          stab_s      =  max(zer0,sign(un_1,zetam))
 
          psim_s      =  -a_stab *zetam
          xpsimi      = sqrt(sqrt(un_1-coef_m*min(zer0,zetam)))
          psim_i      =   2. *log(half*(un_1+xpsimi))                  &
     &                       +log(half*(un_1+xpsimi*xpsimi))           &
     &                   -2.*atan(xpsimi)   +half*pinmbr
          psim_z      =    stab_s*psim_s+(1.-stab_s)*psim_i
 
          psim_s      =  -a_stab *zeta0m
          xpsimi      = sqrt(sqrt(un_1-coef_m*min(zer0,zeta0m)))
          psim_i      =   2. *log(half*(un_1+xpsimi))                  &
     &                       +log(half*(un_1+xpsimi*xpsimi))           &
     &                   -2.*atan(xpsimi)   +half*pinmbr
          psim_0      =    stab_s*psim_s+(1.-stab_s)*psim_i
 
! Heat     Stability Function (Gallee et al., 2001, BLM 99, (11) p. 7)
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
          stab_s      =  max(zer0,sign(un_1,zetah))
 
          psih_s      =  -ahstab *zetah
          xpsihi      = sqrt(sqrt(un_1-coef_h*min(zer0,zetah)))
          psih_i      =   2. *log(half*(un_1+xpsihi))
          psih_z      =    stab_s*psih_s+(1.-stab_s)*psih_i
 
          psih_s      =  -ahstab *zeta0h
          xpsihi      = sqrt(sqrt(un_1-coef_h*min(zer0,zeta0h)))
          psih_i      =   2. *log(half*(un_1+xpsihi))
          psih_0      =    stab_s*psih_s+(1.-stab_s)*psih_i
 
! Square Roots of the Drag Coefficients
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
          rcdhsv(ikl,ikv) = vonkrm/(sqrch0(ikl,ikv)-psih_z+psih_0)
          rcdmsv(ikl,ikv) = vonkrm/(sqrcm0(ikl,ikv)-psim_z+psim_0)
 
! Drag Coefficients
! ~~~~~~~~~~~~~~~~~
          cdh(ikl,ikv)    = rcdmsv(ikl,ikv) * rcdhsv(ikl,ikv)
          cdm(ikl,ikv)    = rcdmsv(ikl,ikv) * rcdmsv(ikl,ikv)
 
! Real    Temperature Turbulent Scale theta*
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
          thstar      = rcdhsv(ikl,ikv) * dta_ts(ikl,ikv)
          uts_sv(ikl,ikv) = us__sv(ikl,ikv) * thstar
 
 
! Convergence Criterion
! =====================
 
          dustar      = max(dustar,abs(us__sv(ikl,ikv)-u0star))
 
! OUTPUT of Snow Erosion Turbulence
! #b1    IF (icount     .EQ.1  )                                    THEN
! #b1     write(6,6004)
! #b1 6004      format(122('-'))
! #b1    IF (mod(VVaSBL(ikl,ikv),4.).LT.0.1)                        THEN
! #b1     write(6,6003)
! #b1 6003      format('   V  Ta-Ts  Z0      It'                       &
! #b1&   ,' du*     u*    sss__F   CD       Qss       Qs*     '        &
! #b1&   ,' PseudOL Full-OL zetam   zetah   psim_z  psih_z')
! #b1     write(6,6004)
! #b1    END IF
! #b1    END IF
! #b1     write(6,6002) VVaSBL(ikl,ikv),dTa_Ts(ikl,ikv),Z0m_SV(ikl,ikv),icount &
! #b1&                 ,dustar     ,us__SV(ikl,ikv),sss__F             &
! #b1&                 ,   CDm(ikl,ikv),qSalSV(ikl,ikv),ssstar         &
! #b1&                 ,W_pLMO     ,LMO_SV(ikl,ikv)                    &
! #b1&                 ,zetam      ,zetah      ,W_psim     ,psih_z
! #b1 6002 format(2f6.1,f8.4,i3,f9.6,f6.3,f9.3,3f9.6,2f8.2,2f8.4,2f8.2)
 
! OUTPUT of Snow Erosion Turbulence (2): u*_AE
! #b2    IF (icount     .EQ.1  )                                    THEN
! #b2     write(6,6014)
! #b2 6014      format(100('-'))
! #b2    IF (mod(VVaSBL(ikl,ikv),4.).LT.0.1)                        THEN
! #b2     write(6,6013)
! #b2 6013     format('   V  Ta-Ts  Z0      It'                        &
! #b2&   ,' du*     u*    sss__F   W_NUs1   W_NUs2   W_NUs3      '     &
! #b2&   ,' W_DUs1     W_DUs2 ')
! #b2     write(6,6014)
! #b2    END IF
! #b2    END IF
! #b2     write(6,6012) VVaSBL(ikl,ikv),dTa_Ts(ikl,ikv),Z0m_SV(ikl,ikv),icount &
! #b2&                 ,dustar     ,us__SV(ikl,ikv),sss__F             &
! #b2&                 ,W_NUs1     ,W_NUs2     ,W_NUs3                 &
! #b2&                 ,W_DUs1     ,W_DUs2
! #b2 6012      format(2f6.1,f8.4,i3,f9.6,f6.3,f9.3,3f9.3,2f12.3)
 
        END DO
        END DO
 
! #AX IF (                     icount.lt. 3)                     GO TO 1
!     IF (dustar.gt.0.0001.AND.icount.lt. 6)                     GO TO 1
 
 
! Aerodynamic Resistances
! -----------------------
 
        DO ikl=1,kcolp
        DO ikv=1,mwp
          ram_sv(ikl,ikv) = 1./(cdm(ikl,ikv)*max(vvasbl(ikl,ikv),eps6))
          rah_sv(ikl,ikv) = 1./(cdh(ikl,ikv)*max(vvasbl(ikl,ikv),eps6))
        END DO
        END DO
 
 
 
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!                                                                      !
! DE-ALLOCATION                                                        !
! =============                                                        !
 
      IF (flagdalloc)                                             THEN !
 
      deallocate          ( vvasbl )                                   ! effective SBL wind speed
      deallocate          ( dta_ts )                                   ! effective SBL Temperature diff.
      deallocate          ( lmomom )                                   ! Monin-Obukhov Scale Momentum
      deallocate          ( cdm    )                                   ! Drag Coefficient, Momentum
      deallocate          ( cds    )                                   ! Drag Coefficient, Blown **
      deallocate          (rcds    )                                   ! Drag Coefficient, Blown **
      deallocate          ( cdh    )                                   ! Drag Coefficient, Scalar
      deallocate          ( richar )                                   ! Richardson Number
 
      END IF                                                           !
!                                                                      !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 
      return
      end subroutine sisvatesbl
 
 
 
      subroutine sisvat_sbl
 
!--------------------------------------------------------------------------+
!   MAR          SISVAT_SBL                           Wed 26-Jun-2013  MAR |
!     SubRoutine SISVAT_SBL generates Surface Boundary Layers Properties   |
!                                                                          |
!     version 3.p.4.1 created by H. Gallee,           Tue  5-Feb-2013      |
!           Last Modification by H. Gallee,           Wed 26-Jun-2013      |
!                                                                          |
!--------------------------------------------------------------------------+
!                                                                          |
!     PARAMETERS:  kcolv: Total Number of columns                          |
!     ^^^^^^^^^^        = Total Number of continental     grid boxes       |
!                       X       Number of Mosaic Cell per grid box         |
!                                                                          |
!     INPUT:   za__SV   : Surface Boundary Layer (SBL) Height          [m] |
!     ^^^^^    VV__SV   :(SBL Top)   Wind Velocity                   [m/s] |
!              TaT_SV   : SBL Top    Temperature                       [K] |
!              uqs_SV   : Specific   Humidity  Turbulent Flux        [m/s] |
!              Z0m_SV   : Momentum   Roughness Length                  [m] |
!              Z0h_SV   : Heat       Roughness Length                  [m] |
!              Tsrfsv   : Surface    Temperature                       [K] |
!              sqrCm0   : Contribution of Z0m to Neutral Drag Coefficient  |
!              sqrCh0   : Contribution of Z0h to Neutral Drag Coefficient  |
!                                                                          |
!     INPUT /  LMO_SV   : Monin-Obukhov       Scale                    [m] |
!     OUTPUT:  us__SV   : Friction  Velocity                         [m/s] |
!     ^^^^^^   uts_SV   : Temperature         Turbulent Flux       [K.m/s] |
!                                                                          |
!     OUTPUT:  Fh__sv   : Stability Function                           [-] |
!     ^^^^^^   dFh_sv   : Stability Function (Derivative)              [-] |
!              ram_sv   : Aerodynamic Resistance for Momentum        [s/m] |
!              rah_sv   : Aerodynamic Resistance for Heat            [s/m] |
!                                                                          |
!     WARNING: SISVAT_SBL blows up for too small z0m values & large z_SBL  |
!     ^^^^^^^                      (z0m = 1.8e-6 m for z_SBL = 20 m)       |
!                                                                          |
!                                                                          |
!                                                                          |
!     Preprocessing  Option: SISVAT IO (not always a standard preprocess.) |
!     ^^^^^^^^^^^^^^^^^^^^^  ^^^^^^^^^                                     |
!     FILE                 |      CONTENT                                  |
!     ~~~~~~~~~~~~~~~~~~~~~+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
!   # stdout               | #sb: OUTPUT/Verification: SISVAT_SBL          |
!                          |      unit  6, SubRoutine  SISVAT_SBL **ONLY** |
!--------------------------------------------------------------------------+
 
 
! Global  Variables
! =================
 
      use mod_real
      use mod_phy____dat
      use mod_phy____grd
      use mod_sisvat_grd
 
 
 
! General Variables
! =================
 
      use mod_sisvat_dat
      use mod_sisvat_kkl
      use mod_sisvat_loc
 
 
      IMPLICIT NONE
 
 
 
! Internal Variables
! ==================
 
      integer           ::  ikl,ikv    ,ist    ,ist__s ,ist__w
      real(kind=real8)  ::  CD_m_0 ,CD_h_0 ,ram0   ,rah0  ,rahMIN
      real(kind=real8)  ::  d_TaTs ,RiB__D ,RiBulk
      real(kind=real8)  ::  bmstab ,Am1_FU ,Am2_FU ,Fm_Uns
      real(kind=real8)  ::  bhstab ,Ah1_FU ,Ah2_FU ,Fh_Uns,dFh_Un
      real(kind=real8)  ::  Aux_FS ,FStabl ,dFSdRi ,Stabil,Fm_loc
      real(kind=real8)  ::  uustar ,thstar ,qqstar
      real(kind=real8)  ::  thstarv,thstars,thstara
      real(kind=real8)  ::  zeta   ,zeta_S ,zeta_A
 
      real(kind=real8)  ::  zetMAX = 4.28 ! Strong Stability Limit
!                                         !(King et al. 1996, JGR 101(7) p.19121)
 
 
! Aerodynamic Resistances
! =======================
 
      DO ikl=1,kcolp
      DO ikv=1,mwp
 
! Surface Type
! ~~~~~~~~~~~~
        ist    =      isotsv(ikl,ikv)                ! Soil Type
        ist__s =  min(ist, 1)                        ! 1 => Soil
        ist__w =  1 - ist__s                         ! 1 => Water Body
 
! Neutral Parameters
! ~~~~~~~~~~~~~~~~~~
        cd_m_0 =  0.16/    (sqrcm0(ikl,ikv)*sqrcm0(ikl,ikv)) ! Neutral Drag Coeff.Mom.
        cd_h_0 =  0.16/    (sqrcm0(ikl,ikv)*sqrch0(ikl,ikv)) ! Neutral Drag Coeff.Heat
        ram0   =  1.0 /    (cd_m_0     *vv__sv(ikl,ikv)) ! Neutral Aero Resis.Mom.
        rah0   =  1.0 /    (cd_h_0     *vv__sv(ikl,ikv)) ! Neutral Aero Resis.Heat
 
! Bulk Richardson Number
! ~~~~~~~~~~~~~~~~~~~~~~
        rib__d =          vv__sv(ikl,ikv) *vv__sv(ikl,ikv)             &
     &                   *tat_sv(ikl,ikv)
        d_tats =         (tat_sv(ikl,ikv)- tsrfsv(ikl,ikv))
        ribulk =  grav_f *za__sv(ikl,ikv)* d_tats                      &
     &          / rib__d
 
! OUTPUT/Verification: SISVAT_SBL
! #sb       IF (ii__AP(ikl).EQ.iwr_SV .AND. jj__AP(ikl).EQ.jwr_SV .AND.&
! #sb&          ikv        .GE.nwr_SV)                                 &
! #sb&      write(6,6600) Tsrfsv(ikl,ikv),TaT_SV(ikl,ikv),VV__SV(ikl,ikv)  &
! #sb&                  , d_TaTs     ,RiBulk
! #sb 6600  format(/,'Tem(s,a), Wind  , d_TaTs, RiBulk = ',5e15.6)
 
! Unstable Case
! ~~~~~~~~~~~~~
        bmstab =  ist__s * (13.7 -0.34 /sqrt(cd_m_0)) &! Momentum
     &          + ist__w *   4.9                       !
        bmstab =  10.    *  bmstab   * cd_m_0         &!
     &              *sqrt(za__sv(ikl,ikv)/ z0m_sv(ikl,ikv))!
        am1_fu =  bmstab *    sqrt(abs(ribulk))        !
        am2_fu =  am1_fu +1.0 +10.*abs(ribulk)         !
        fm_uns = (am1_fu +1.0)/        am2_fu          !
 
! OUTPUT/Verification: SISVAT_SBL
! #sb       IF (ii__AP(ikl).EQ.iwr_SV .AND. jj__AP(ikl).EQ.jwr_SV .AND.&
! #sb&          ikv        .GE.nwr_SV)                                 &
! #sb&      write(6,6601) CD_m_0     ,Z0m_SV(ikl,ikv),bmstab           &
! #sb&                  , ist__s     ,ist__w
! #sb 6601  format(/,'CD_m_0  , Z0m_SV, bmstab, ist/sw = ',3e15.6,2i15)
 
        bhstab =  ist__s * ( 6.3 -0.18 /sqrt(cd_h_0)) &! Heat
     &          + ist__w *   2.6                       !
        bhstab =  10.    *  bhstab   * cd_h_0         &!
     &              *sqrt(za__sv(ikl,ikv)/ z0h_sv(ikl,ikv))!
        ah1_fu =  bhstab *    sqrt(abs(ribulk))        !
        ah2_fu =  ah1_fu +1.0 +10.*abs(ribulk)         !
        fh_uns = (ah1_fu +1.0)/        ah2_fu          !
        dfh_un =((ah1_fu +2.0)/(ah2_fu*ah2_fu)) * 5.   !
 
! Stable   Case
! ~~~~~~~~~~~~~
        aux_fs =          1.0 + 5.*    ribulk
        fstabl =                aux_fs*aux_fs
        dfsdri =                aux_fs          *10.
 
! Effective Stability Functions and Derivatives
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
        stabil      =          sign(un_1,d_tats)
        fm_loc      =  fstabl * max(zer0,stabil)                       &
     &               - fm_uns * min(zer0,stabil)
        fh__sv(ikl,ikv) =  fstabl * max(zer0,stabil)                   &
     &               - fh_uns * min(zer0,stabil)
        dfh_sv(ikl,ikv) =  dfsdri * max(zer0,stabil)                   &
     &               - dfh_un * min(zer0,stabil)
 
! OUTPUT/Verification: SISVAT_SBL
! #sb       IF (ii__AP(ikl).EQ.iwr_SV .AND. jj__AP(ikl).EQ.jwr_SV .AND.&
! #sb&          ikv        .GE.nwr_SV)                                 &
! #sb&      write(6,6602) FStabl     ,Stabil                           &
! #sb&                   ,Fm_Uns     ,Fm_loc
! #sb 6602  format(/,'FStabl  , Stabil, Fm_Uns, Fm_loc = ',4e15.6)
 
! Aerodynamic Resistances
! ~~~~~~~~~~~~~~~~~~~~~~~
        ram_sv(ikl,ikv) =  ram0   *          fm_loc
        rah_sv(ikl,ikv) =  rah0   *          fh__sv(ikl,ikv)
        rahmin   = max(rah_sv(ikl,ikv),  abs(d_tats)*60./za__sv(ikl,ikv))
                                               ! 60 for 30dgC within 1/2 hour
        dfh_sv(ikl,ikv) =  rah0   *          dfh_sv(ikl,ikv)           &
     &              *  rahmin /          rah_sv(ikl,ikv)
        rah_sv(ikl,ikv) =  rahmin
 
 
! Square Root Contributions to the Drag Coefficients
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
        rcdmsv(ikl,ikv) =  sqrt(ram_sv(ikl,ikv) *vv__sv(ikl,ikv))
        rcdmsv(ikl,ikv) =  1.     / max(eps6,rcdmsv(ikl,ikv))
        rcdhsv(ikl,ikv) =       rah_sv(ikl,ikv) *vv__sv(ikl,ikv)       &
     &                                  *rcdmsv(ikl,ikv)
        rcdhsv(ikl,ikv) = (1.     / max(eps6,rcdhsv(ikl,ikv)))
 
! OUTPUT/Verification: SISVAT_SBL
! #sb       IF (ii__AP(ikl).EQ.iwr_SV .AND. jj__AP(ikl).EQ.jwr_SV .AND.&
! #sb&          ikv        .GE.nwr_SV)                                 &
! #sb&      write(6,6603) ram_sv(ikl,ikv),rah_sv(ikl,ikv)              &
! #sb&                   ,rCDmSV(ikl,ikv),rCDhSV(ikl,ikv)
! #sb 6603  format(/,'AeR(m,h), rCD(m,h)               = ',4e15.6)
 
 
! Turbulent Scales
! ================
 
! Friction Velocity                   u*
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
        uustar      =      vv__sv(ikl,ikv) / ram_sv(ikl,ikv)
        us__sv(ikl,ikv) = sqrt(uustar)
 
! Real    Temperature Turbulent Scale theta*
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
        uts_sv(ikl,ikv) =      d_tats      / rah_sv(ikl,ikv)
        thstar      =      uts_sv(ikl,ikv) / us__sv(ikl,ikv)
 
! Specific Humidity   Turbulent Scale qq*
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
        qqstar      =      uqs_sv(ikl,ikv) / us__sv(ikl,ikv)
 
! Virtual Temperature Turbulent Scale thetav*
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
        thstarv     = thstar      + tat_sv(ikl,ikv) *(0.608*qqstar     &
     &                                             )
        thstars     =     sign(un_1,thstarv)
        thstara     =      abs(     thstarv)
        thstarv     =      max(eps6,thstara)    *thstars
 
! Monin Obukhov Scale Height
! ~~~~~~~~~~~~~~~~~~~~~~~~~~
        lmo_sv(ikl,ikv) = tat_sv(ikl,ikv) * uustar                     &
     &              /(vonkrm      * grav_f     * thstarv)
        zeta        = za__sv(ikl,ikv) / lmo_sv(ikl,ikv)
        zeta        =           min(zetmax,zeta)  ! Strong Stability Limit
!                                                 ! King et al.   1996
!                                                 ! JGR 101(7) p.19121
        zeta_s      =          sign(un_1  ,zeta)
        zeta_a      =           abs(       zeta)
        zeta        = zeta_s  * max(eps6  ,zeta_a)
        lmo_sv(ikl,ikv) = za__sv(ikl,ikv) / zeta
 
! OUTPUT/Verification: SISVAT_SBL
! #sb       IF (ii__AP(ikl).EQ.iwr_SV .AND. jj__AP(ikl).EQ.jwr_SV .AND.&
! #sb&          ikv        .GE.nwr_SV)                                 &
! #sb&      write(6,6604) us__SV(ikl,ikv),uts_SV(ikl,ikv)              &
! #sb&                   ,LMO_SV(ikl,ikv),zeta
! #sb 6604  format(/,'***(m,h), LMO   , zeta           = ',4e15.6)
 
      END DO
      END DO
 
 
      return
      end subroutine sisvat_sbl
 
 
 
      subroutine sisvat_tvg(                                           &
! #e1&                     (ETVg_d                                     &
     &                     )
 
!--------------------------------------------------------------------------+
!   MAR          SISVAT_TVg                           Wed 26-Jun-2013  MAR |
!     SubRoutine SISVAT_TVg computes the Canopy Energy Balance             |
!                                                                          |
!     version 3.p.4.1 created by H. Gallee,           Tue  5-Feb-2013      |
!           Last Modification by H. Gallee,           Wed 26-Jun-2013      |
!                                                                          |
!--------------------------------------------------------------------------+
!                                                                          |
!     PARAMETERS:  kcolv: Total Number of columns =                        |
!     ^^^^^^^^^^        = Total Number of continental     grid boxes       |
!                       X       Number of Mosaic Cell per grid box         |
!                                                                          |
!     INPUT:   ivgtSV   = 0,...,12:   Vegetation Type                      |
!     ^^^^^               0:          Water, Solid or Liquid               |
!              isnoSV   = total Nb of Ice/Snow Layers                      |
!                                                                          |
!     INPUT:   sol_SV   : Downward Solar Radiation                  [W/m2] |
!     ^^^^^    IRd_SV   : Surface  Downward Longwave Radiation      [W/m2] |
!              TaT_SV   : SBL Top  Temperature                         [K] |
!              rhT_SV   : SBL Top  Air  Density                    [kg/m3] |
!              QaT_SV   : SBL Top  Specific  Humidity              [kg/kg] |
!              psivSV   : Leaf     Water     Potential                 [m] |
!              IRs_SV   : Soil     IR Flux  (previous time step)    [W/m2] |
!              dt__SV   : Time     Step                                [s] |
!                                                                          |
!              SoCasv   : Absorbed Solar Radiation by Canopy (Normaliz)[-] |
!              tau_sv   : Fraction of Radiation transmitted by Canopy  [-] |
!              Evg_sv   : Soil+Vegetation Emissivity                   [-] |
!              Eso_sv   : Soil+Snow       Emissivity                   [-] |
!              rah_sv   : Aerodynamic Resistance for Heat            [s/m] |
!              Sigmsv   : Canopy Ventilation Factor                    [-] |
!              LAI_sv   : Leaf Area  Index                             [-] |
!              LAIesv   : Leaf Area  Index (effective / transpiration) [-] |
!              glf_sv   : Green Leaf Fraction of NOT fallen Leaves     [-] |
!              rrMxsv   : Canopy Maximum Intercepted Rain          [kg/m2] |
!                                                                          |
!     INPUT /  TvegSV   : Canopy   Temperature                         [K] |
!     OUTPUT:  rrCaSV   : Canopy     Water     Content             [kg/m2] |
!     ^^^^^^                                                               |
!                                                                          |
!     OUTPUT:  IRv_sv   : Vegetation IR Flux                        [W/m2] |
!     ^^^^^^   HSv_sv   : Sensible Heat Flux                        [W/m2] |
!              HLv_sv   : Latent   Heat Flux                        [W/m2] |
!              Evp_sv   : Evaporation                              [kg/m2] |
!              EvT_sv   : Evapotranspiration                       [kg/m2] |
!              ETVg_d   : Vegetation  Energy Power Forcing          [W/m2] |
!                                                                          |
!     Internal Variables:                                                  |
!     ^^^^^^^^^^^^^^^^^^                                                   |
!                                                                          |
!     METHOD: The Newton-Raphson Scheme is preferable                      |
!     ^^^^^^  when computing over a long time step the heat content        |
!             of a medium having a very small or zero heat capacity.       |
!             This is to handle strong non linearities arising             |
!             in conjunction with rapid temperature variations.            |
!                                                                          |
!     REFERENCE: DR97: Koen de Ridder thesis, UCL, 1997                    |
!     ^^^^^^^^^                                                            |
!                                                                          |
!     Preprocessing  Option:                                               |
!     ^^^^^^^^^^^^^^^^^^^^^                                                |
!     #NN: Newton-Raphson Increment not added in last Iteration            |
!     #nc: OUTPUT Preparation for Stand Alone NetCDF File                  |
!                                                                          |
!--------------------------------------------------------------------------+
 
 
! Global  Variables
! =================
 
      use mod_real
      use mod_phy____dat
      use mod_phy____grd
      use mod_sisvat_grd
 
 
 
! General Variables
! =================
 
      use mod_sisvat_ctr
      use mod_sisvat_dat
      use mod_sisvat_kkl
      use mod_sisvat_loc
      use mod_sisvat_flx
 
 
 
! Internal Variables
! ==================
 
      use mod_sisvatltvg
 
 
      IMPLICIT NONE
 
 
! OUTPUT
! ------
 
 
      integer                                      ::  ikl,ikv         ! Grid Point Index
      integer                                      ::  nitmax =  5     ! Maximum  Iterations Number
      integer                                      ::  nit             !          Iterations Counter
      real(kind=real8)                             ::  d_Tveg          ! Canopy Temperat. Increment
      real(kind=real8)                             ::  dTvMAX =  5.    ! Canopy Temperat. Increment MAX
      real(kind=real8)                             ::  dHvdTv          ! Derivativ.of Canopy Energ.Budg.
      real(kind=real8)                             ::  Hv_Tv0          ! Imbalance of Canopy Energ.Budg.
      real(kind=real8)                             ::  Hv_MAX          ! MAX Imbal.of Canopy Energ.Budg.
      real(kind=real8)                             ::  Hv_MIN =  0.1   ! MIN Imbal.of Canopy Energ.Budg.
      real(kind=real8)                             ::  Hswich          ! Newton-Raphson         Switch
      real(kind=real8)                             ::  tau_Ca          ! Canopy IR Radiation Absorption
      real(kind=real8)                             ::  IR_net          ! InfraRed  NET(t)
      real(kind=real8)                             ::  EvFrac          ! Condensat./Transpirat. Switch
      real(kind=real8)                             ::  SnoMsk =  0.0   ! Canopy Snow            Switch
      real(kind=real8)                             ::  den_qs,arg_qs   !
!     real(kind=real8)                             ::  esat_i          ! Saturation Vapor Pressure       [hPa]
      real(kind=real8)                             ::  qsatvg          ! Canopy Saturat. Spec. Humidity
      real(kind=real8)                             ::  dqs_dT          ! d(qsatvg)/dTv
      real(kind=real8)                             ::  FacEvp,FacEvT   !
      real(kind=real8)                             ::  Fac_Ev          ! Evapo(transpi)ration Factor
      real(kind=real8)                             ::  F_Stom          ! Funct.  (Leaf Water Potential)
      real(kind=real8)                             ::  R0Stom          ! Minimum Stomatal Resistance
      real(kind=real8)                             ::  R_Stom          !         Stomatal Resistance
      real(kind=real8)                             ::  LAI_OK          ! 1. ==>  Leaves   exist
      real(kind=real8)                             ::  rrCaOK,snCaOK   !
      real(kind=real8)                             ::  dEvpOK          ! Positive Definiteness Correct.
 
 
 
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!                                                                      !
! ALLOCATION                                                           !
! ==========                                                           !
 
      IF (it_run.EQ.1 .OR. flagdalloc)                            THEN !
 
! #e1 allocate            ( ETVg_d(kcolp,mwp) )                        ! VegetationPower, Forcing
      allocate            ( tveg_0(kcolp,mwp) )                        ! Canopy Temperature, Previous t
      allocate            ( dirdtv(kcolp,mwp) )                        ! InfraRed  NET(t), Derivative(t)
      allocate            ( dhsdtv(kcolp,mwp) )                        ! Sensible Heat FL. Derivative(t)
      allocate            ( dhldtv(kcolp,mwp) )                        ! Latent   Heat FL. Derivative(t)
      allocate            ( devpdt(kcolp,mwp) )                        ! Evapo(transpi)ration Derivative
      allocate            ( devtdt(kcolp,mwp) )                        ! Evapo(transpi)ration Derivative
 
      END IF                                                           !
!                                                                      !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 
 
! Newton-Raphson Scheme
! =====================
 
      nit    = 0
  101 CONTINUE
      nit    = nit + 1
      hv_max = 0.
 
 
! Temperature of the Previous Time Step
! -------------------------------------
 
        DO ikl=1,kcolp
        DO ikv=1,mwp
          tveg_0(ikl,ikv) = tvegsv(ikl,ikv)
 
 
! IR    Radiation Absorption
! --------------------------
 
          tau_ca = 1.  - tau_sv(ikl,ikv)                    ! Canopy Absorption
          irv_sv(ikl,ikv) = -2.0   *evg_sv(ikl,ikv)  *stefbo   &!
     &                         *tvegsv(ikl,ikv)  *tvegsv(ikl,ikv)  &! Downward IR (OUT)
     &                         *tvegsv(ikl,ikv)  *tvegsv(ikl,ikv)   ! + Upward IR (OUT)
          dirdtv(ikl,ikv) =                                &!
     &     -evg_sv(ikl,ikv)*                               &!
     &                8.*stefbo*tvegsv(ikl,ikv)  *tvegsv(ikl,ikv)  &! Downward IR (OUT)
     &                         *tvegsv(ikl,ikv)             ! + Upward IR (OUT)
          ir_net =       tau_ca                            &!
     &    *(evg_sv(ikl,ikv)* ird_sv(ikl,ikv)               &! Downward IR (IN)
     &     -             irs_sv(ikl,ikv)                   &!   Upward IR (IN)
     &     +             irv_sv(ikl,ikv))                   !          IR (OUT)
 
 
! Sensible Heat Flux
! ------------------
 
          dhsdtv(ikl,ikv) = rht_sv(ikl,ikv)* sigmsv(ikl,ikv) *cpdair   &! Derivative, t(n)
     &                / rah_sv(ikl,ikv)                     !
          hsv_sv(ikl,ikv) = dhsdtv(ikl,ikv)                &! Value,      t(n)
     &                *(tat_sv(ikl,ikv)-tvegsv(ikl,ikv))    !
 
 
! Latent   Heat Flux
! ------------------
 
! Canopy Saturation Specific Humidity
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
!       IF      (DeRidder)                                THEN !
          den_qs      =         tvegsv(ikl,ikv)    - 35.8      !
          arg_qs      = 17.27 *(tvegsv(ikl,ikv)    -273.16)   &!
     &                                   / den_qs              !
          qsatvg      = .0038 *        exp(arg_qs)     *0.875  !  0.875 = Tuning Hapex-Sahel
          dqs_dt      = qsatvg     * 4099.2   /(den_qs *den_qs)!
!       ELSE IF (Dudhia_MAR)                              THEN !
!         esat_i      = 6.107                                 &!
!    &     *exp(ExpIsv*(un_1/WatIsv -un_1/TvegSV(ikl)    ))    !
!         qsatvg      = 0.622    *     esat_i                 &!
!    &      / (10.*pkPaSV(ikl) - 0.378*esat_i)                 !
!         dqs_dT      = qsatvg                                &!
!    &     *(1.0+0.6077*qsatvg     )                          &!
!    &     *    ExpIsv/(TvegSV(ikl)    *TvegSV(ikl)    )       !
!       END IF
 
! Canopy Stomatal Resistance
! ^^^^^^^^^^^^^^^^^^^^^^^^^^
          r0stom = min(         stodsv(ivgtsv(ikl,ikv))     &!
     &                /max(eps6,glf_sv(       ikl,ikv)),stxdsv)  ! Min Stomatal R.
          f_stom = pscdsv / max(pscdsv-psivsv(ikl,ikv) ,eps6)! F(Leaf Wat.Pot.)
                                                             ! DR97, eqn. 3.22
          r_stom =(r0stom / max(laiesv(ikl,ikv), r0stom/stxdsv))&! Can.Stomatal R.
     &           * f_stom                                    ! DR97, eqn. 3.21
 
! Evaporation / Evapotranspiration
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
          snomsk = max(zer0, sign(un_1,sncasv(ikl,ikv)-eps_21))  !
          evfrac = max(zer0, sign(un_1,qat_sv(ikl,ikv)-qsatvg))  ! Condensation/
          evfrac = evfrac                                   &! Transpiration
     &       + (1.-evfrac)*((1-snomsk)*         rrcasv(ikl,ikv) &!        Switch
     &                                         /rrmxsv(ikl,ikv) &!
     &                      +  snomsk *min(un_1,sncasv(ikl,ikv) &!
     &                                         /rrmxsv(ikl,ikv)))!
          fac_ev = rht_sv(ikl,ikv) *sigmsv(ikl,ikv)          ! Idem,  Factor
          facevp = fac_ev      *evfrac     / rah_sv(ikl,ikv) !
          evp_sv(ikl,ikv) = facevp*(qsatvg     - qat_sv(ikl,ikv))! Evaporation
          devpdt(ikl,ikv) = facevp* dqs_dt                   ! Evp Derivative
          facevt = fac_ev * (1.-evfrac)    /(rah_sv(ikl,ikv)&!
     &                              +r_stom *sigmsv(ikl,ikv))!
          evt_sv(ikl,ikv) = facevt*(qsatvg     - qat_sv(ikl,ikv))! EvapoTranspir.
          devtdt(ikl,ikv) = facevt* dqs_dt                   ! EvT Derivative
          hlv_sv(ikl,ikv) =-lhvh2o*(evp_sv(ikl,ikv)+ evt_sv(ikl,ikv))   &! Latent   Heat
     &                 -lhfh2o* evp_sv(ikl,ikv)* snomsk      !(Subli.Contrib.)
          dhldtv(ikl,ikv) = lhvh2o*(devpdt(ikl,ikv)+ devtdt(ikl,ikv))   &!
     &                 +lhfh2o* devpdt(ikl,ikv)* snomsk      !
 
 
! Imbalance  of the Canopy  Energy Budget
! ---------------------------------------
 
          lai_ok = max(zer0,                                &! NO Budget if
     &                 sign(un_1, lai_sv(ikl,ikv)-eps_21))   ! no Leaves
          hv_tv0 =    (  socasv(ikl,ikv)         *sol_sv(ikl,ikv)   &! Absorbed Solar
     &                 + ir_net                             &! NET      IR
     &                 + hsv_sv(ikl,ikv)                    &! Sensible Heat
     &                 + hlv_sv(ikl,ikv)                    &! Latent   Heat
     &                ) *lai_ok                              !
 
! OUTPUT/Verification: Energy/Water Budget
! #e1     ETVg_d(ikl,ikv) =  Hv_Tv0                          ! Veg.Energ.Bal.
 
          hswich      =          1.00
! #NN     Hswich      = max(zer0,                           &! Newton-Raphson
! #NN&                      sign(un_1,    abs(Hv_Tv0     )  &!         Switch
! #NN&                                       -Hv_MIN      )) !
 
 
! Derivative of the Canopy  Energy Budget
! ---------------------------------------
 
          dhvdtv    =   dirdtv(ikl,ikv) * max(eps_21,tau_ca)           &
     &                - dhsdtv(ikl,ikv)                                &
     &                - dhldtv(ikl,ikv)
 
 
! Update Canopy and Surface/Canopy Temperatures
! ---------------------------------------------
 
          d_tveg      = hv_tv0       / dhvdtv               !
          d_tveg      =      sign(un_1,d_tveg)             &! Increment
     &                       *min( abs(d_tveg)     ,dtvmax) ! Limitor
          tvegsv(ikl,ikv) = tvegsv(ikl,ikv)  - hswich      *d_tveg  ! Newton-Raphson
          hv_max      = max(hv_max,abs(hv_tv0     ))        !
 
 
! Update Vegetation Fluxes
! ------------------------
 
! #NN     IRv_sv(ikl,ikv) = IRv_sv(ikl,ikv)-dIRdTv(ikl,ikv)    *d_Tveg  ! Emitted  IR
! #NN     HSv_sv(ikl,ikv) = HSv_sv(ikl,ikv)+dHSdTv(ikl,ikv)    *d_Tveg  ! Sensible Heat
! #NN     Evp_sv(ikl,ikv) = Evp_sv(ikl,ikv)-dEvpdT(ikl,ikv)    *d_Tveg  ! Evapotranspir.
! #NN     EvT_sv(ikl,ikv) = EvT_sv(ikl,ikv)-dEvTdT(ikl,ikv)    *d_Tveg  ! Evapotranspir.
! #NN     HLv_sv(ikl,ikv) = HLv_sv(ikl,ikv)+dHLdTv(ikl,ikv)    *d_Tveg  ! Latent   Heat
 
          irv_sv(ikl,ikv) = irv_sv(ikl,ikv)                *lai_ok
          hsv_sv(ikl,ikv) = hsv_sv(ikl,ikv)                *lai_ok
          evp_sv(ikl,ikv) = evp_sv(ikl,ikv)                *lai_ok
          evt_sv(ikl,ikv) = evt_sv(ikl,ikv)                *lai_ok
          hlv_sv(ikl,ikv) = hlv_sv(ikl,ikv)                *lai_ok
        END DO
        END DO
 
! #AX IF (                     nit.lt.nitmax)    GO TO 101
      IF (hv_max.gt.hv_min.and.nit.lt.nitmax)    GO TO 101
 
        DO ikl=1,kcolp
        DO ikv=1,mwp
          irv_sv(ikl,ikv) = irv_sv(ikl,ikv)                &! Emitted  IR
     &   +dirdtv(ikl,ikv) *(tvegsv(ikl,ikv)-tveg_0(ikl,ikv))!
          hsv_sv(ikl,ikv) = hsv_sv(ikl,ikv)                &! Sensible Heat
     &   -dhsdtv(ikl,ikv) *(tvegsv(ikl,ikv)-tveg_0(ikl,ikv))!
          evp_sv(ikl,ikv) = evp_sv(ikl,ikv)                &! Evaporation
     &   +devpdt(ikl,ikv) *(tvegsv(ikl,ikv)-tveg_0(ikl,ikv))!
          evt_sv(ikl,ikv) = evt_sv(ikl,ikv)                &! Transpiration
     &   +devtdt(ikl,ikv) *(tvegsv(ikl,ikv)-tveg_0(ikl,ikv))!
          hlv_sv(ikl,ikv) = hlv_sv(ikl,ikv)                &! Latent   Heat
     &   -dhldtv(ikl,ikv) *(tvegsv(ikl,ikv)-tveg_0(ikl,ikv))!
 
! OUTPUT for Stand Alone NetCDF File
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
          hlv_kl(ikl,ikv) = hlv_sv(ikl,ikv)
 
 
! Update Canopy Water Content
! ---------------------------
 
          rrcasv(ikl,ikv) = rrcasv(ikl,ikv)-(1.-snomsk)*evp_sv(ikl,ikv)*dt__sv
          sncasv(ikl,ikv) = sncasv(ikl,ikv)-    snomsk *evp_sv(ikl,ikv)*dt__sv
 
! Correction for Positive Definiteness (see WKarea/EvpVeg/EvpVeg.f)
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
          rrcaok =  max(rrcasv(ikl,ikv), 0.)
          sncaok =  max(sncasv(ikl,ikv), 0.)
          devpok =     (rrcaok-rrcasv(ikl,ikv)                         &
     &                 +sncaok-sncasv(ikl,ikv))/dt__sv
 
          evp_sv(ikl,ikv) = evp_sv(ikl,ikv)       - devpok  ! Evaporation
          hlv_sv(ikl,ikv) = hlv_sv(ikl,ikv)                &! Latent   Heat
     &    +(1.-snomsk)* lhvh2o            * devpok         &!
     &    +    snomsk *(lhvh2o+lhfh2o)    * devpok          !
 
          rrcasv(ikl,ikv) = rrcaok
          sncasv(ikl,ikv) = sncaok
 
        END DO
        END DO
 
 
 
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!                                                                      !
! DE-ALLOCATION                                                        !
! =============                                                        !
 
      IF (flagdalloc)                                             THEN !
 
! #e1 deallocate          ( ETVg_d )                                   ! VegetationPower, Forcing
      deallocate          ( tveg_0 )                                   ! Canopy Temperature, Previous t
      deallocate          ( dirdtv )                                   ! InfraRed  NET(t), Derivative(t)
      deallocate          ( dhsdtv )                                   ! Sensible Heat FL. Derivative(t)
      deallocate          ( dhldtv )                                   ! Latent   Heat FL. Derivative(t)
      deallocate          ( devpdt )                                   ! Evapo(transpi)ration Derivative
      deallocate          ( devtdt )                                   ! Evapo(transpi)ration Derivative
 
      END IF                                                           !
!                                                                      !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 
      return
      end subroutine sisvat_tvg
 
 
 
      subroutine sisvat_tso(                                           &
! #e1&                     ,ETSo_0,ETSo_1,ETSo_d,kcolw                 &
     &                     )
 
!--------------------------------------------------------------------------+
!   MAR          SISVAT_TSo                           Wed 26-Jun-2013  MAR |
!     SubRoutine SISVAT_TSo computes the Soil/Snow Energy Balance          |
!                                                                          |
!     version 3.p.4.1 created by H. Gallee,           Tue  5-Feb-2013      |
!           Last Modification by H. Gallee,           Wed 26-Jun-2013      |
!                                                                          |
!--------------------------------------------------------------------------+
!                                                                          |
!     PARAMETERS:  kcolv: Total Number of columns =                        |
!     ^^^^^^^^^^        = Total Number of continental     grid boxes       |
!                       X       Number of Mosaic Cell per grid box         |
!                                                                          |
!     INPUT:   isotSV   = 0,...,11:   Soil       Type                      |
!     ^^^^^               0:          Water, Solid or Liquid               |
!              isnoSV   = total Nb of Ice/Snow Layers                      |
!              dQa_SV   = Limitation of  Water Vapor  Turbulent Flux       |
!                                                                          |
!     INPUT:   sol_SV   : Downward Solar Radiation                  [W/m2] |
!     ^^^^^    IRd_SV   : Surface Downward  Longwave   Radiation    [W/m2] |
!              za__SV   : SBL Top    Height                            [m] |
!              VV__SV   : SBL Top    Wind Speed                      [m/s] |
!              TaT_SV   : SBL Top    Temperature                       [K] |
!              ExnrSV   : Exner      Potential                         [-] |
!              rhT_SV   : SBL Top    Air  Density                  [kg/m3] |
!              QaT_SV   : SBL Top    Specific  Humidity            [kg/kg] |
!              LSdzsv   : Vertical   Discretization Factor             [-] |
!                       =    1. Soil                                       |
!                       = 1000. Ocean                                      |
!              dzsnSV   : Snow Layer Thickness                         [m] |
!              ro__SV   : Snow/Soil  Volumic Mass                  [kg/m3] |
!              eta_SV   : Soil Water Content                       [m3/m3] |
!              dt__SV   : Time Step                                    [s] |
!                                                                          |
!              SoSosv   : Absorbed Solar Radiation by Surfac.(Normaliz)[-] |
!              IRv_sv   : Vegetation  IR Radiation                  [W/m2] |
!              tau_sv   : Fraction of Radiation transmitted by Canopy  [-] |
!              Evg_sv   : Soil+Vegetation Emissivity                   [-] |
!              Eso_sv   : Soil+Snow       Emissivity                   [-] |
!              rah_sv   : Aerodynamic Resistance for Heat            [s/m] |
!              Lx_H2O   : Latent Heat of Vaporization/Sublimation   [J/kg] |
!              Sigmsv   : Canopy Ventilation Factor                    [-] |
!              sEX_sv   : Verticaly Integrated Extinction Coefficient  [-] |
!                                                                          |
!     INPUT /  TsisSV   : Soil/Ice Temperatures (layers -nsoil,-nsoil+1 ,0)|
!     OUTPUT:           & Snow     Temperatures (layers  1,2,...,nsno) [K] |
!     ^^^^^^                                                               |
!                                                                          |
!     OUTPUT:  IRs_SV   : Soil      IR Radiation                    [W/m2] |
!     ^^^^^^   HSs_sv   : Sensible  Heat Flux                       [W/m2] |
!              HLs_sv   : Latent    Heat Flux                       [W/m2] |
!              ETSo_0   : Snow/Soil Energy Power, before Forcing    [W/m2] |
!              ETSo_1   : Snow/Soil Energy Power, after  Forcing    [W/m2] |
!              ETSo_d   : Snow/Soil Energy Power         Forcing    [W/m2] |
!                                                                          |
!     METHOD: NO   Skin Surface Temperature                                |
!     ^^^^^^  Semi-Implicit Crank Nicholson Scheme                         |
!                                                                          |
!     REFERENCE: DR97: Koen de Ridder thesis, UCL, 1997                    |
!     ^^^^^^^^^                                                            |
!                                                                          |
!     Preprocessing  Option:                                               |
!     ^^^^^^^^^^^^^^^^^^^^^                                                |
!     #WL: TURBULENCE: u*q* limited to SBL Saturat.Specif.Humid.           |
!     #TR: TURBULENCE: Richardson Number:    T Derivative is used          |
!     #TL: TURBULENCE: Latent     Heat Flux: T Derivative is used          |
!     #nc: OUTPUT Preparation for Stand Alone NetCDF File                  |
!                                                                          |
!                                                                          |
!     Preprocessing  Option: SISVAT IO (not always a standard preprocess.) |
!     ^^^^^^^^^^^^^^^^^^^^^  ^^^^^^^^^                                     |
!     FILE                 |      CONTENT                                  |
!     ~~~~~~~~~~~~~~~~~~~~~+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
!   # SISVAT_iii_jjj_n     | #e1: OUTPUT/Verification: Energy Conservation |
!                          |                                               |
!--------------------------------------------------------------------------+
 
 
! Global  Variables
! =================
 
      use mod_real
      use mod_phy____dat
      use mod_phy____grd
      use mod_sisvat_grd
 
 
 
! General Variables
! =================
 
      use mod_sisvat_ctr
      use mod_sisvat_dat
      use mod_sisvat_dzs
      use mod_sisvat_kkl
      use mod_sisvat_loc
      use mod_sisvat_flx
 
 
 
! Internal Variables
! ==================
 
      use mod_sisvatltso
 
 
      IMPLICIT NONE
 
 
      real(kind=real8)                               ::  deltak
      real(kind=real8)                               ::  Exp_SA, Imp_SA
      real(kind=real8)                               ::  ExpTOP, ImpTOP
      real(kind=real8)                               ::  ExpHSL, ImpHSL
      real(kind=real8)                               ::  epsi15= 1.0e-15
      integer                                        ::  is1   , is2
 
 
! OUTPUT/Verification: Energy/Water Budget
! #e1 real(kind=real8),              dimension(kcolw)::  ETSo_0        ! Soil/Snow Power, before Forcing
! #e1 real(kind=real8),              dimension(kcolw)::  ETSo_1        ! Soil/Snow Power, after  Forcing
! #e1 real(kind=real8),              dimension(kcolw)::  ETSo_d        ! Soil/Snow Power, Forcing
 
      integer                                        ::  ikl,ikv   ,isl!
      integer                                        ::  jsl   ,isn    !
      integer                                        ::  isHigh        ! Order of the tridiagonal Matrix
      integer                                        ::  ist__s,ist__w,ist             ! Soil/Water  Body Identifier
      integer                                        ::  islsgn        ! Soil/Snow Surfac.Identifier
 
      real(kind=real8)                               ::  eps__3= 1.e-3 ! Arbitrary    Low Number
      real(kind=real8)                               ::  etaMid,psiMid ! Layer Interface's Humidity
      real(kind=real8)                               ::  mu_eta        !     Soil thermal Conductivity
      real(kind=real8)                               ::  mu_exp=-0.4343! arg Soil thermal Conductivity
      real(kind=real8)                               ::  mu_min= 0.172 ! Min Soil thermal Conductivity
      real(kind=real8)                               ::  mu_max= 2.000 ! Max Soil thermal Conductivity
      real(kind=real8)                               ::  mu_aux        !     Snow thermal Conductivity
      real(kind=real8)                               ::  dTSurf        ! Previous Surface Temperature
      real(kind=real8)                               ::  den_qs,arg_qs ! Soil   Saturat. Spec. Humidity
      real(kind=real8)                               ::  esat_i        ! Saturation Vapor Pressure       [hPa]
      real(kind=real8)                               ::  etaSol        ! Soil Surface          Humidity
      real(kind=real8)                               ::  d__eta        ! Soil Surface Humidity Increm.
      real(kind=real8)                               ::  Elem_A        !
      real(kind=real8)                               ::  ElemaA,ElemsA !   Diagonal Coefficients
      real(kind=real8)                               ::  Elem_C        !
      real(kind=real8)                               ::  ElemaC,ElemsC !   Diagonal Coefficients
      real(kind=real8)                               ::  Ts_Min = 175. ! Snow MIN Temperature
      real(kind=real8)                               ::  Ts_Max = 300. ! Snow MIN Temperature Acceptable
                                                                       ! both including Snow Melt Energy
 
! OUTPUT/Verification: Energy/Water Budget
! #e1 real(kind=real8)                               ::  Exist0        ! Existing Layer Switch
 
      integer,parameter                              ::  nt_srf=10     !
      integer                                        ::  it_srf,itEuBk ! HL: Surface Scheme
      real(kind=real8)                               ::  agpsrf,xgpsrf !
      real(kind=real8)                               ::  dt_srf,dt_ver !
 
 
 
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!                                                                      !
! ALLOCATION                                                           !
! ==========                                                           !
 
      IF (it_run.EQ.1 .OR. flagdalloc)                            THEN !
 
      allocate            ( tsisva(kcolp,mwp,-nsoil:nsnow+mzp) )       !
      allocate            ( fsisva(kcolp,mwp) )                        !
      allocate            ( dza__1(kcolp,mwp) )                        !
      allocate            ( mu_sno(kcolp,mwp) )                        !     Snow thermal Conductivity
      allocate            ( mu__dz(kcolp,mwp,-nsoil:nsnow+1)   )       ! mu_(eta,sno)   / dz
      allocate            ( dtc_sv(kcolp,mwp,-nsoil:nsnow)     )       ! dt      / C
      allocate            ( irs__d(kcolp,mwp) )                        ! UpwardIR Previous Iter.Contr.
      allocate            ( dirsdt(kcolp,mwp) )                        ! UpwardIR           T Derivat.
      allocate            ( f_hshl(kcolp,mwp) )                        ! Factor common to HS and HL
      allocate            ( dridts(kcolp,mwp) )                        ! d(Rib)/d(Ts)
      allocate            ( hs___d(kcolp,mwp) )                        ! Sensible Heat Flux Atm.Contr.
      allocate            ( f___hl(kcolp,mwp) )                        !
      allocate            ( hl___d(kcolp,mwp) )                        ! Latent   Heat Flux Atm.Contr.
      allocate            ( tsurf0(kcolp,mwp) )                        ! Previous Surface Temperature
      allocate            ( qsatsg(kcolp,mwp) )                        ! Soil   Saturat. Spec. Humidity
      allocate            ( dqs_dt(kcolp,mwp) )                        ! d(qsatsg)/dTv
      allocate            ( psi(   kcolp,mwp) )                        ! 1st Soil Layer Water Potential
      allocate            ( rhusol(kcolp,mwp) )                        ! Soil Surface Relative Humidity
      allocate            ( rhu_av(kcolp,mwp) )                        ! Soil Surface Relative Humidity
      allocate            ( diag_a(kcolp,mwp,-nsoil:nsnow+mzp) )       ! A Diagonal
      allocate            ( diag_b(kcolp,mwp,-nsoil:nsnow+mzp) )       ! B Diagonal
      allocate            ( diag_c(kcolp,mwp,-nsoil:nsnow+mzp) )       ! C Diagonal
      allocate            ( term_d(kcolp,mwp,-nsoil:nsnow+mzp) )       !   Independant Term
      allocate            ( aux__p(kcolp,mwp,-nsoil:nsnow+mzp) )       ! P Auxiliary Variable
      allocate            ( aux__q(kcolp,mwp,-nsoil:nsnow+mzp) )       ! Q Auxiliary Variable
      allocate            ( etabak(kcolp,mwp) )                        !
      allocate            ( etanew(kcolp,mwp) )                        !
      allocate            ( eteubk(kcolp,mwp) )                        !
      allocate            ( fac_dt(kcolp,mwp) )                        !
      allocate            ( faceta(kcolp,mwp) )                        !
      allocate            ( psiarg(kcolp,mwp) )                        !
      allocate            ( shusol(kcolp,mwp) )                        !
 
      END IF                                                           !
!                                                                      !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 
 
! Implicitness of the numerical Scheme at Surface - Atmosphere Interface
! ======================================================================
 
!        vvvvvvvv
      IF (svakzt)                                                  THEN
       IF(mzp.LT.2) svaubc = .true.
          exp_sa =  explic
          imp_sa =  implic
      ELSE
          exp_sa =  1.00
          imp_sa =  0.00
      END IF
          exphsl =  0.00
          imphsl =  1.00
 
 
 
 
! Heat Conduction Coefficient (zero in the Layers over the highest one)
! ===========================
!                               ---------------- isl    eta_SV, rho C (isl)
!
! Soil                          ++++++++++++++++        etaMid,    mu (isl)
! ----
!                               ---------------- isl-1  eta_SV, rho C (isl-1)
 
        DO ikl=1,kcolp
        DO ikv=1,mwp
!         __________
          isl=-nsoil
 
          mu__dz(ikl,ikv,isl) = 0.
 
          dtc_sv(ikl,ikv,isl) = dtz_sv(isl)              &! dt / (dz X rho C)
     &                   /((rocssv(isotsv(ikl,ikv))      &! [s / (m.J/m3/K)]
     &                     +rcwdsv*eta_sv(ikl,ikv,isl))  &!
     &                     *lsdzsv(ikl,ikv)            )  !
! #kv   END DO
! #kv   END DO
!         ______________
       DO isl=-nsoil+1,0
! #kv   DO ikl=1,kcolp
! #kv   DO ikv=1,mwp
          ist    =      isotsv(ikl,ikv)                   ! Soil Type
          ist__s =  min(ist, 1)                           ! 1 => Soil
          ist__w =  1 - ist__s                            ! 1 => Water Body
 
          etamid = 0.5*(dz_dsv(isl-1)*eta_sv(ikl,ikv,isl-1)  &! eta at layers
     &                 +dz_dsv(isl)  *eta_sv(ikl,ikv,isl)  ) &!     interface
     &                 /dzmisv(isl)                       ! LSdzsv implicit !
          etamid =  max(etamid,eps6)
          psimid =      psidsv(ist)                      &!
     &                *(etadsv(ist)/etamid)**bchdsv(ist)  !
          mu_eta =      3.82      *(psimid)**mu_exp       ! Soil Thermal
          mu_eta =  min(max(mu_eta, mu_min), mu_max)      ! Conductivity
                                                          ! DR97 eq.3.31
          mu_eta =  ist__s *mu_eta +ist__w * vk_dsv       ! Water Bodies
                                                          ! Correction
          mu__dz(ikl,ikv,isl) = mu_eta/(dzmisv(isl)      &!
     &                             *lsdzsv(ikl,ikv))      !
 
          dtc_sv(ikl,ikv,isl) = dtz_sv(isl)              &! dt / (dz X rho C)
     &                   /((rocssv(isotsv(ikl,ikv))      &!
     &                     +rcwdsv*eta_sv(ikl,ikv,isl))  &!
     &                     *lsdzsv(ikl,ikv)            )  !
! #kv   END DO
! #kv   END DO
       END DO
 
 
! Soil/Snow Interface
! -------------------
 
! Soil Contribution
! ^^^^^^^^^^^^^^^^^
!         _____
          isl=1
! #kv   DO ikl=1,kcolp
! #kv   DO ikv=1,mwp
          ist    =      isotsv(ikl,ikv)                   ! Soil Type
          ist__s =  min(ist, 1)                           ! 1 => Soil
          ist__w =  1 - ist__s                            ! 1 => Water Body
          psimid =      psidsv(ist)                       ! Snow => Saturation
          mu_eta =      3.82      *(psimid)**mu_exp       ! Soil Thermal
          mu_eta =  min(max(mu_eta, mu_min), mu_max)      ! Conductivity
                                                          ! DR97 eq.3.31
          mu_eta =  ist__s *mu_eta +ist__w * vk_dsv       ! Water Bodies
 
! Snow Contribution
! ^^^^^^^^^^^^^^^^^
          mu_sno(ikl,ikv) =  cdidsv                      &!
     &                 *(ro__sv(ikl,ikv,isl) /rhowat) ** 1.88 !
          mu_sno(ikl,ikv) =          max(eps6,mu_sno(ikl,ikv))!
!         mu_sno :  Snow Heat Conductivity Coefficient [Wm/K]
!                   (Yen 1981, CRREL Rep., 81-10)
 
! Combined Heat Conductivity
! ^^^^^^^^^^^^^^^^^^^^^^^^^^
          mu__dz(ikl,ikv,isl) = 2./(dzsnsv(ikl,ikv,isl  )&! Combined Heat
     &                         /mu_sno(ikl,ikv)          &! Conductivity
     &                         +lsdzsv(ikl,ikv)          &!
     &                         *dz_dsv(    isl-1)/mu_eta) ! Coefficient
 
! Inverted Heat Capacity
! ^^^^^^^^^^^^^^^^^^^^^^
          dtc_sv(ikl,ikv,isl) = dt__sv/max(eps6,         &! dt / (dz X rho C)
     &    dzsnsv(ikl,ikv,isl) * ro__sv(ikl,ikv,isl) *cn_dsv)  !
 
 
! Snow
! ----
 
!           _____________________
         DO isl=1,isnosv(ikl,ikv)
          ro__sv(ikl,ikv,isl) =                          &!
     &                   ro__sv(ikl,ikv ,isl)            &!
     &       * max(0,min(isnosv(ikl,ikv)-isl+1,1))        !
         END DO
 
!           _____________________
         DO isl=1,isnosv(ikl,ikv)
 
! Combined Heat Conductivity
! ^^^^^^^^^^^^^^^^^^^^^^^^^^
          mu_aux      =  cdidsv                          &!
     &                 *(ro__sv(ikl,ikv,isl) /rhowat) ** 1.88 !
          mu__dz(ikl,ikv,isl) =                          &!
     &      2.                        *mu_aux*mu_sno(ikl,ikv)&! Combined Heat
     &     /max(eps6,dzsnsv(ikl,ikv,isl  )*mu_sno(ikl,ikv)   &! Conductivity
     &              +dzsnsv(ikl,ikv,isl-1)*mu_aux     )   ! For upper Layer
          mu_sno(ikl,ikv)     =            mu_aux         !
 
! Inverted Heat Capacity
! ^^^^^^^^^^^^^^^^^^^^^^
          dtc_sv(ikl,ikv,isl) = dt__sv/max(eps__3,       &! dt / (dz X rho C)
     &    dzsnsv(ikl,ikv,isl) * ro__sv(ikl,ikv,isl) *cn_dsv)  !
         END DO
! #kv   END DO
! #kv   END DO
 
 
! Uppermost Effective Layer: NO conduction
! ----------------------------------------
 
! #kv   DO ikl=1,kcolp
! #kv   DO ikv=1,mwp
          mu__dz(ikl,ikv,isnosv(ikl,ikv)+1) = 0.0
 
 
 
! Soil - Ice - Snow - Vegetation - Atmosphere Variable
! ====================================================
 
          dza__1(ikl,ikv) =(zza_sv(ikl,ikv,min(mzp,2))   + zza_sv(ikl,ikv,1)) * 0.5
 
!              vvvvvvvv
!           IF (SVaKzT)                                             THEN
                fsisva(ikl,ikv) = p0_kap *   roa_sv(ikl,ikv,1) * dza__1(ikl,ikv)   &
     &                     *  dtc_sv(ikl,ikv,isnosv(  ikl,ikv))* cpdair /  dt__sv
!           END IF
 
! Soil/Snow Interior
! ^^^^^^^^^^^^^^^^^^
!           __________
         DO isl=-nsoil        ,isnosv(ikl,ikv)
          tsisva(ikl,ikv,isl) =        tsissv(ikl,ikv,isl)              &
     &                * p0_kap /   exnrsv(ikl,ikv)
         END DO
! #kv   END DO
! #kv   END DO
 
! Atmosphere
! ^^^^^^^^^^
!         vvvvvvvv
!      IF (SVaKzT)                                                  THEN
!         _________
       DO isl=1,mzp
! #kv   DO ikl=1,kcolp
! #kv   DO ikv=1,mwp
          isn=isnosv(ikl,ikv)+isl
          tsisva(ikl,ikv,isn) =   pktasv(ikl,ikv,isl) * fsisva(ikl,ikv)
! #kv   END DO
! #kv   END DO
       END DO
 
!      END IF
 
 
! OUTPUT/Verification: Energy/Water Budget: Energy Budget (IN)
! #e1  DO ikl=1,kcolp
! #e1  DO ikv=1,mwp
! #e1     ETSo_0(ikl,ikv) = 0.
! #e1  END DO
! #e1  END DO
! #e1  DO ikl=1,kcolp
! #e1  DO ikv=1,mwp
! #e1   DO isl= -nsoil,isnoSV(ikl,ikv)
! #e1     Exist0      = isl -           isnoSV(ikl,ikv)
! #e1     Exist0      = 1.  - max(zer0,min(un_1,Exist0))
! #e1     ETSo_0(ikl,ikv) = ETSo_0(ikl,ikv)                             &
! #e1&                +(TsisSV(ikl,ikv,isl)-Tf_Sno)*Exist0              &
! #e1&                                 /dtC_sv(ikl,ikv,isl)
! #e1   END DO
! #e1  END DO
! #e1  END DO
 
 
! Tridiagonal Elimination: Set Up
! ===============================
 
! #kv   DO ikl=1,kcolp
! #kv   DO ikv=1,mwp
!           _______________________________
         DO isl= -nsoil+1,isnosv(ikl,ikv)-1
          elem_a          =  dtc_sv(ikl,ikv,isl)         *mu__dz(ikl,ikv,isl)
          elem_c          =  dtc_sv(ikl,ikv,isl)         *mu__dz(ikl,ikv,isl+1)
          diag_a(ikl,ikv,isl) = -elem_a  *implic
          diag_c(ikl,ikv,isl) = -elem_c  *implic
          diag_b(ikl,ikv,isl) =  1.0d+0  -diag_a(ikl,ikv,isl)-diag_c(ikl,ikv,isl)
          term_d(ikl,ikv,isl) =  explic *(elem_a         *tsisva(ikl,ikv,isl-1)  &
     &                               +elem_c         *tsisva(ikl,ikv,isl+1)) &
     &             +(1.0d+0 -explic *(elem_a+elem_c))*tsisva(ikl,ikv,isl)&
     &  + dtc_sv(ikl,ikv,isl)           * sol_sv(ikl,ikv)    *sososv(ikl,ikv)&
     &                                              *(sex_sv(ikl,ikv,isl+1)  &
     &                                               -sex_sv(ikl,ikv,isl  )) &
     &   *p0_kap          /  exnrsv(ikl,ikv)
         END DO
 
! #kv   END DO
! #kv   END DO
 
! Soil  lowest Layer
! ^^^^^^^^^^^^^^^^^^
!          ___________
           isl= -nsoil
! #kv   DO ikl=1,kcolp
! #kv   DO ikv=1,mwp
          elem_a          =  0.
          elem_c          =  dtc_sv(ikl,ikv,isl)         *mu__dz(ikl,ikv,isl+1)
          diag_a(ikl,ikv,isl) =  0.
          diag_c(ikl,ikv,isl) = -elem_c  *implic
          diag_b(ikl,ikv,isl) =  1.0d+0  -diag_a(ikl,ikv,isl)-diag_c(ikl,ikv,isl)
          term_d(ikl,ikv,isl) =  explic * elem_c         *tsisva(ikl,ikv,isl+1)  &
     &             +(1.0d+0 -explic * elem_c)        *tsisva(ikl,ikv,isl)  ! & !
!    &  + dtC_sv(ikl,isl)           * sol_SV(ikl)    *SoSosv(ikl)        & ! .NOT. needed
!    &                                              *(sEX_sv(ikl,isl+1)  & ! since sEX_sv = 0.
!    &                                               -sEX_sv(ikl,isl  )) & !
!    &   *p0_kap          /  ExnrSV(ikl)
! #kv   END DO
! #kv   END DO
 
! Surface: UPwardIR Heat Flux
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^
! #kv   DO ikl=1,kcolp
! #kv   DO ikv=1,mwp
!         _________________________
          isl         = isnosv(ikl,ikv)
          dirsdt(ikl,ikv) = eso_sv(ikl,ikv)* stefbo          * 4. &! - d(IR)/d(T)
     &                             * tsissv(ikl,ikv,isl)      &!
     &                             * tsissv(ikl,ikv,isl)      &!
     &                             * tsissv(ikl,ikv,isl)       !
          irs__d(ikl,ikv) = dirsdt(ikl,ikv)* tsissv(ikl,ikv,isl) * 0.75!
 
! Surface: Richardson Number:   T Derivative
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
! #TR     dRidTs(ikl,ikv) =-Grav_F      *    za__SV(ikl,ikv)  &!
! #TR&                              *(1.-Sigmsv(ikl,ikv))     &!
! #TR&                /(TaT_SV(ikl,ikv) *    VV__SV(ikl,ikv)  &!
! #TR&                              *    VV__SV(ikl,ikv))      !
 
! Surface: Turbulent Heat Flux: Factors
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
          f_hshl(ikl,ikv) = rht_sv(ikl,ikv) *(1.-sigmsv(ikl,ikv)) &!#common factor
     &                              /    rah_sv(ikl,ikv)       ! to  HS, HL
          f___hl(ikl,ikv) = f_hshl(ikl,ikv) *    lx_h2o(ikl,ikv)
 
! Surface: Sensible  Heat Flux: T Derivative
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
          dsdtsv(ikl,ikv) = f_hshl(ikl,ikv) *    cpdair       &!#- d(HS)/d(T)
! #TR&         *(1.0  -(TsisSV(ikl,ikv,isl) -TaT_SV(ikl,ikv)) &!#Richardson
! #TR&         * dRidTs(ikl,ikv)*dFh_sv(ikl,ikv)/rah_sv(ikl,ikv)) &! Nb. Correct.
     &         + 0.
          hs___d(ikl,ikv) = dsdtsv(ikl,ikv) *    tat_sv(ikl,ikv)   !
 
! Surface: Latent    Heat Flux: Saturation Specific Humidity
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
!        IF      (DeRidder)                               THEN !
          den_qs      =         tsissv(ikl,ikv,isl)- 35.8      !
          arg_qs      = 17.27 *(tsissv(ikl,ikv,isl)-273.16)   &!
     &                                   / den_qs              !
          qsatsg(ikl,ikv) = .0038 *        exp(arg_qs)     *0.875  !  0.875 = Tuning Hapex-Sahel
          dqs_dt(ikl,ikv) = qsatsg(ikl,ikv)* 4099.2   /(den_qs *den_qs)!
!        ELSE IF (Dudhia_MAR)                             THEN !
!         esat_i      = 6.107                                 &!
!    &     *exp(ExpIsv*(un_1/WatIsv -un_1/TsisSV(ikl,isl)))    !
!         qsatsg(ikl) = 0.622    *     esat_i                 &!
!    &      / (10.*pkPaSV(ikl) - 0.378*esat_i)                 !
!         dqs_dT(ikl) = qsatsg(ikl)                           &!
!    &     *(1.0+0.6077*qsatsg(ikl))                          &!
!    &     *    ExpIsv/(TsisSV(ikl,isl)*TsisSV(ikl,isl))       !
!        END IF
 
          fac_dt(ikl,ikv) = f_hshl(ikl,ikv)/(rhowat   * dz_dsv(0)) !
! #kv   END DO
! #kv   END DO
 
! Surface: Latent    Heat Flux: Surface    Relative Humidity
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
              xgpsrf       =   1.05                            !
              agpsrf       = dt__sv*(   1.0-xgpsrf        )   &!
     &                             /(   1.0-xgpsrf**nt_srf)    !
              dt_srf       = agpsrf                            !
              dt_ver       = 0.                                !
! #kv       DO ikl=1,kcolp
! #kv       DO ikv=1,mwp
              isl          =          isnosv(ikl,ikv)          !
              etabak(ikl,ikv)  = max(eps6,eta_sv(ikl,ikv ,isl))!
              etanew(ikl,ikv)  =          etabak(ikl,ikv)      !
              eteubk(ikl,ikv)  =          etanew(ikl,ikv)      !
              rhu_av(ikl,ikv)  =     0.00                      !
              shumsv(ikl,ikv)  =     0.00                      !
! #kv       END DO
! #kv       END DO
!         _______________
       DO it_srf=1,nt_srf                                      !
              dt_ver       = dt_ver     +dt_srf                !
! #kv       DO ikl=1,kcolp
! #kv       DO ikv=1,mwp
              faceta(ikl,ikv)  = fac_dt(ikl,ikv)*dt_srf        !
! #WL         faceta(ikl,ikv)  = faceta(ikl,ikv)              &!
! #WL&                  /(1.+faceta(ikl,ikv)*dQa_SV(ikl,ikv))  !    Limitation
!             CAUTION:     Please VERIFY dQa_SV Set-Up         ! by Atm.Conten
!    &        *max(0,sign(1.,qsatsg(ikl)-QaT_SV(ikl))))        ! NO Limitation
! #kv       END DO
! #kv       END DO                                             ! of Downw.Flux
          DO iteubk=1,2                                        !
! #kv       DO ikl=1,kcolp
! #kv       DO ikv=1,mwp
              ist    = max(0,isotsv(ikl,ikv)-100*isnosv(ikl,ikv))  ! 0 if    H2O
                                                               !
              psi(ikl,ikv) =                                  &!
     &                psidsv(ist)                             &! DR97, Eqn 3.34
     &              *(etadsv(ist)                             &!
     &           /max(eteubk(ikl,ikv),eps6))                  &!
     &              **bchdsv(ist)                              !
              psiarg(ikl,ikv) = 7.2e-5*psi(ikl,ikv)            !
              rhusol(ikl,ikv) =   exp(-min(ea_max,psiarg(ikl,ikv)))!
              shusol(ikl,ikv) =     qsatsg(ikl,ikv)  *rhusol(ikl,ikv)  ! DR97, Eqn 3.15
              eteubk(ikl,ikv) =                               &!
     &       (etanew(ikl,ikv) + faceta(ikl,ikv)*(qat_sv(ikl,ikv)  &!
     &                                  -shusol(ikl,ikv)      &!
     &                    *(1.          -bchdsv(ist)          &!
     &                                  *psiarg(ikl,ikv))       ))&!
     &      /(1.          + faceta(ikl,ikv)* shusol(ikl,ikv)  &!
     &                                  *bchdsv(ist)          &!
     &                                  *psiarg(ikl,ikv)      &!
     &                                  /etanew(ikl,ikv))      !
              eteubk(ikl,ikv) = eteubk(ikl,ikv) -rootsv(ikl,ikv,0)&!
     &                    * dt_srf     /(rhowat*dz_dsv(0))     !
! #kv       END DO
! #kv       END DO
          END DO                                               !
! #kv       DO ikl=1,kcolp
! #kv       DO ikv=1,mwp
              rhu_av(ikl,ikv) =      rhu_av(ikl,ikv)+rhusol(ikl,ikv)*dt_srf!
              shumsv(ikl,ikv) =      shumsv(ikl,ikv)+shusol(ikl,ikv)*dt_srf!
              etanew(ikl,ikv) =  max(eteubk(ikl,ikv),eps6)     !
! #kv       END DO
! #kv       END DO
              dt_srf      =      xgpsrf                 *dt_srf!
       END DO                                                  !
 
 
! #kv   DO ikl=1,kcolp
! #kv   DO ikv=1,mwp
              rhu_av(ikl,ikv) =      rhu_av(ikl,ikv)            /dt_ver!
! tune        RHu_av(ikl) = 0.80*RHu_av(ikl)            /dt_ver!
 
! Surface  Type :  liquid or solid Water (i.e., H2O)  .OR.  SOIL
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
          isl        =  isnosv(ikl,ikv)                        !
          ist   = max(0,isotsv(ikl,ikv)-100*isnosv(ikl,ikv))   ! 0 if    H2O
          ist__s= min(1,ist)                                   ! 1 if no H2O
          ist__w=     1-ist__s                                 ! 1 if    H2O
 
! Surface  Specific  Humidity :
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
          shumsv(ikl,ikv)=  ist__s         *shumsv(ikl,ikv)  /dt_ver  &!      no H2O
     &                 +ist__w         *qsatsg(ikl,ikv)        !         H2O
 
! Surface: Latent    Heat Flux: Soil/Water Surface Contributions
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
          d__eta     =  eta_sv(ikl,ikv,isl)-etanew(ikl,ikv)    !
          hl___d(ikl,ikv)=( ist__s *rhowat *dz_dsv(0)         &! Soil Contrib.
     &                *(etanew(ikl,ikv)    -etabak(ikl,ikv)) / dt__sv &!
     &                 +ist__w         *f_hshl(ikl,ikv)       &! H2O  Contrib.
     &                *(qat_sv(ikl,ikv)    -qsatsg(ikl,ikv))         )&!
     &                * lx_h2o(ikl,ikv)                        ! common factor
 
! Surface: Latent    Heat Flux: T Derivative
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
          dldtsv(ikl,ikv) = 0.
! #TL     dLdTSV(ikl,ikv) = f___HL(ikl,ikv)   * dqs_dT(ikl,ikv)   &!
! #TL&                                * RHu_av(ikl,ikv)        ! - d(HL)/d(T)
 
! #TL     HL___D(ikl,ikv) = HL___D(ikl,ikv)                   &!
! #TL&                 +dLdTSV(ikl,ikv)   * TsisSV(ikl,ikv,isl)!
! #kv   END DO
! #kv   END DO
 
! Surface: Tridiagonal Matrix Set Up
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
! #kv   DO ikl=1,kcolp
! #kv   DO ikv=1,mwp
!         ______________________________
          isl             =  isnosv(ikl,ikv)
 
          tsurf0(ikl,ikv)     =  tsissv(ikl,ikv,isl)             ! Diagnostic
          elem_a          =  dtc_sv(ikl,ikv,isl)*mu__dz(ikl,ikv,isl) !
          elem_c          =  dsdtsv(ikl,ikv)                     ! HS/Surf.Contr.
          elemsc          =  elem_c        * dtc_sv(ikl,ikv,isl) !
          elemac          =  elem_c        *(dt__sv/cpdair)     &!
     &                     /(roa_sv(ikl,ikv,1  )*dza__1(ikl,ikv))!
          diag_a(ikl,ikv,isl) = -elem_a *implic                  !
          diag_c(ikl,ikv,isl) = -elemac *imp_sa                  !
          diag_b(ikl,ikv,isl) =  1.0d+0 -diag_a(ikl,ikv,isl)    &!
     &                     + elemsc *imphsl                     &!
     &  + dtc_sv(ikl,ikv,isl) * (dirsdt(ikl,ikv)                &! Upw. Sol IR
     &                      +dldtsv(ikl,ikv))                    ! HL/Surf.Contr.
          term_d(ikl,ikv,isl) =  explic *elem_a *tsisva(ikl,ikv,isl-1)  &!
     &             +(1.0d+0 -explic *elem_a                     &!
     &                      -exphsl *elemsc)*tsisva(ikl,ikv,isl)&!
     &                      +exp_sa *elemac *tsisva(ikl,ikv,isl+1)   !                !T
          term_d(ikl,ikv,isl) =  term_d(ikl,ikv,isl)            &!                !T
     &  + dtc_sv(ikl,ikv,isl) * (sol_sv(ikl,ikv)    *sososv(ikl,ikv)&! Absorbed
     &                                     *(sex_sv(ikl,ikv,isl+1)  &! Solar
     &                                      -sex_sv(ikl,ikv,isl  )) &!
     &        +      tau_sv(ikl,ikv)      *ird_sv(ikl,ikv) *eso_sv(ikl,ikv) &! Down Atm IR
     &         -(1.0-tau_sv(ikl,ikv)) *0.5*irv_sv(ikl,ikv)      &! Down Veg IR
     &                                +irs__d(ikl,ikv)          &! Upw. Sol IR
     &                                +hl___d(ikl,ikv)          &! HL/Atmo.Contr.
     &      ) *      p0_kap       /    exnrsv(ikl,ikv)           !
 
! SBL:        Tridiagonal Matrix Set Up
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
!            vvvvvvvv
          IF (svakzt)                                               THEN
             kz__sv(ikl,ikv,  1) = 0.
           IF(svaubc)                                               THEN
             kz__sv(ikl,ikv,mzp) = 0.
             exptop          = explic
             imptop          = implic
           ELSE
             exptop          = 1.0000
             imptop          = 0.0000
           END IF
 
             isl=1
             jsl=isnosv(ikl,ikv)
             isn=isnosv(ikl,ikv) +isl
             is1=   min(isl+1,mzp)
             is2=   min(isn+1,mzp+nsnow)
             elem_a          =  dsdtsv(ikl,ikv)                    &!
     &                         +dldtsv(ikl,ikv)                    &!
     &                         +0.0d+0
             elemaa          =  elem_a        *(dt__sv/cpdair)     &!
     &                        /(roa_sv(ikl,ikv,1  )*dza__1(ikl,ikv))!
             elemsa          =  elem_a        * dtc_sv(ikl,ikv,jsl)
             diag_a(ikl,ikv,isn) = -elemsa *imp_sa                  !
             deltak=                            dt__sv             &!
     &                        /(roa_sv(ikl,ikv,1  )*dza__1(ikl,ikv))!
             elem_c=deltak                                         &!
     &             *0.5*(roa_sv(ikl,ikv,is1  )+roa_sv(ikl,ikv,isl))&!
     &                 * kz__sv(ikl,ikv,is1  )                     &!
     &       /max(epsi15,zza_sv(ikl,ikv,is1  )-zza_sv(ikl,ikv,isl)) !
             diag_c(ikl,ikv,isn) = -elem_c *implic                  !
             diag_b(ikl,ikv,isn) =  1.0d+0 -diag_c(ikl,ikv,isn)    &!
     &                         +elemaa *implic                      !
             term_d(ikl,ikv,isn) =  elemsa *exp_sa *tsisva(ikl,ikv,isn-1)  &!
     &                +(1.0d+0 -elemaa *explic                     &!
     &                         -elem_c *explic)*tsisva(ikl,ikv,isn)&!
     &                         +elem_c *explic *tsisva(ikl,ikv,is2) !
 
! Atmosphere: Tridiagonal Matrix Set Up
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
          IF(mzp.GE.4)                                              THEN
             is1=2
             is2=mzp-2
!            ___________
          DO isl=is1,is2
             isn=isnosv(ikl,ikv)+isl                                !
             elem_a=elem_c                                          !
             deltak=0.5* dt__sv          /(roa_sv(ikl,ikv,isl)     &!
     &                 *(zza_sv(ikl,ikv,isl+1)-zza_sv(ikl,ikv,isl-1)))  !
             elem_c=deltak                                         &!
     &             *0.5*(roa_sv(ikl,ikv,isl+1)+roa_sv(ikl,ikv,isl))&!
     &                 * kz__sv(ikl,ikv,isl+1)                     &!
     &                 /(zza_sv(ikl,ikv,isl+1)-zza_sv(ikl,ikv,isl)) !
             diag_a(ikl,ikv,isn) = -implic *elem_a                  !
             diag_c(ikl,ikv,isn) = -implic *elem_c                  !
             diag_b(ikl,ikv,isn) =  1.0d+0 -diag_a(ikl,ikv,isn)    &!
     &                                 -diag_c(ikl,ikv,isn)         !
             term_d(ikl,ikv,isn) =  explic *elem_a *tsisva(ikl,ikv,isn-1)  &!
     &                +(1.0d+0 -explic *elem_a                     &!
     &                         -explic *elem_c)*tsisva(ikl,ikv,isn)&!
     &                         +explic *elem_c *tsisva(ikl,ikv,isn+1)   !
          END DO
 
          ENDIF
 
! Atmosphere: Tridiagonal Matrix Set Up
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
          IF(mzp .GE.2)                                             THEN
             is1=max(1,mzp-1)
!            _______
             isl=is1
             isn=isnosv(ikl,ikv)+isl                                !
             elem_a=elem_c                                          !
             deltak=0.5* dt__sv          /(roa_sv(ikl,ikv,isl)     &!
     &                 *(zza_sv(ikl,ikv,isl+1)-zza_sv(ikl,ikv,isl-1)))  !
             elem_c=deltak                                         &!
     &             *0.5*(roa_sv(ikl,ikv,isl+1)+roa_sv(ikl,ikv,isl))&!
     &                 * kz__sv(ikl,ikv,isl+1)                     &!
     &                 /(zza_sv(ikl,ikv,isl+1)-zza_sv(ikl,ikv,isl)) !
             diag_a(ikl,ikv,isn) = -implic *elem_a                  !
             diag_c(ikl,ikv,isn) = -imptop *elem_c                  !
             diag_b(ikl,ikv,isn) =  1.0d+0 -diag_a(ikl,ikv,isn)    &!
     &                         +implic *elem_c                      !
             term_d(ikl,ikv,isn) =  explic *elem_a *tsisva(ikl,ikv,isn-1)  &!
     &                +(1.0d+0 -explic *elem_a                     &!
     &                         -explic *elem_c)*tsisva(ikl,ikv,isn)&!
     &                         +exptop *elem_c *tsisva(ikl,ikv,isn+1)   !
          END IF
 
 
             ishigh          =  isnosv(ikl,ikv)+max(1,mzp-1)
          ELSE
             ishigh          =  isnosv(ikl,ikv)
          END IF
! #kv   END DO
! #kv   END DO
 
 
 
! Tridiagonal Elimination
! =======================
 
! Forward  Sweep
! ^^^^^^^^^^^^^^
! #kv   DO ikl=  1,kcolp
! #kv   DO ikv=1,mwp
          aux__p(ikl,ikv,-nsoil) = diag_b(ikl,ikv,-nsoil)
          aux__q(ikl,ikv,-nsoil) =-diag_c(ikl,ikv,-nsoil)/aux__p(ikl,ikv,-nsoil)
! #kv   END DO
! #kv   END DO
 
!         ___________________
       DO isl=-nsoil+1,ishigh
! #kv   DO ikl=      1,kcolp
! #kv   DO ikv=1,mwp
          aux__p(ikl,ikv,isl)   = diag_a(ikl,ikv,isl)  *aux__q(ikl,ikv,isl-1)  &
     &                       +diag_b(ikl,ikv,isl)
          aux__q(ikl,ikv,isl)   =-diag_c(ikl,ikv,isl)  /aux__p(ikl,ikv,isl)
! #kv   END DO
! #kv   END DO
       END DO
 
! #kv   DO ikl=      1,kcolp
! #kv   DO ikv=1,mwp
          tsisva(ikl,ikv,-nsoil) = term_d(ikl,ikv,-nsoil)/aux__p(ikl,ikv,-nsoil)
! #kv   END DO
! #kv   END DO
 
!         ___________________
       DO isl=-nsoil+1,ishigh
! #kv   DO ikl=      1,kcolp
! #kv   DO ikv=1,mwp
          tsisva(ikl,ikv,isl)   =(term_d(ikl,ikv,isl)                  &
     &                       -diag_a(ikl,ikv,isl)  *tsisva(ikl,ikv,isl-1)) &
     &                                         /aux__p(ikl,ikv,isl)
! #kv   END DO
! #kv   END DO
       END DO
 
! Backward Sweep
! ^^^^^^^^^^^^^^
!         ______________________
       DO isl=ishigh-1,-nsoil,-1
! #kv   DO ikl=1,kcolp
! #kv   DO ikv=1,mwp
          tsisva(ikl,ikv,isl)   = aux__q(ikl,ikv,isl)  *tsisva(ikl,ikv,isl+1)  &
     &                                         +tsisva(ikl,ikv,isl)
! #kv   END DO
! #kv   END DO
       END DO
 
! Go Back to Temperatures
! ^^^^^^^^^^^^^^^^^^^^^^^
! #kv  DO ikl=1,kcolp
! #kv  DO ikv=1,mwp
         DO isl=-nsoil   , isnosv(ikl,ikv)
          tsissv(ikl,ikv,isl) =    tsisva(ikl,ikv,isl)                 &
     &                /(p0_kap /   exnrsv(ikl,ikv))
         END DO
 
!         vvvvvvvv
       IF (svakzt)                                                  THEN
!         _________
       DO isl=1,mzp
          isn=isnosv(ikl,ikv)+isl
          pktasv(ikl,ikv,isl) =   tsisva(ikl,ikv,isn) / fsisva(ikl,ikv)
       END DO
 
       IF  (svaubc)                                                 THEN
          is1             =      max(  1,mzp-1)
          pktasv(ikl,ikv,mzp) =   pktasv(ikl,ikv,is1)
!      ELSE
!         pktaSV(ikl,mzp)  is implicitely .NOT. modified
       END IF
 
       END IF
 
! Temperature Limits (avoids problems in case of no Snow Layers)
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
!         _______________________________
          isl               = isnosv(ikl,ikv)
 
          dtsurf            = tsissv(ikl,ikv,isl) -        tsurf0(ikl,ikv)
          tsissv(ikl,ikv,isl)   = tsurf0(ikl,ikv) + sign(un_1,dtsurf)  &! 180.0 dgC/hr
     &              * min(abs(dtsurf),5.e-2*dt__sv)                 ! =0.05 dgC/s
! #kv  END DO
! #kv  END DO
 
!         ___________________
       DO isl=nsnow,1     ,-1
! #kv   DO ikl=     1,kcolp
! #kv   DO ikv=1,mwp
          tsissv(ikl,ikv,isl)   = max(ts_min,       tsissv(ikl,ikv,isl))
          tsissv(ikl,ikv,isl)   = min(ts_max,       tsissv(ikl,ikv,isl))
! #kv   END DO
! #kv   END DO
       END DO
 
 
! Update Surface    Fluxes
! ========================
 
! #kv   DO ikl=      1,kcolp
! #kv   DO ikv=1,mwp
!         _________________________
          isl         = isnosv(ikl,ikv)
 
          irs_sv(ikl,ikv) = irs__d(ikl,ikv)                   &!
     &                - dirsdt(ikl,ikv) * tsissv(ikl,ikv,isl)  !
          hss_sv(ikl,ikv) = hs___d(ikl,ikv)                   &! Sensible Heat
     &                - dsdtsv(ikl,ikv) * tsissv(ikl,ikv,isl)  ! Downward > 0
          hls_sv(ikl,ikv) = hl___d(ikl,ikv)                   &! Latent   Heat
     &                - dldtsv(ikl,ikv) * tsissv(ikl,ikv,isl)  ! Downward > 0
 
! OUTPUT for Stand Alone NetCDF File
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
          sosokl(ikl,ikv) = sol_sv(ikl,ikv) * sososv(ikl,ikv)  ! Absorbed Sol.
          irsokl(ikl,ikv) =               irs_sv(ikl,ikv)     &! Up Surf. IR
     &        +     tau_sv(ikl,ikv)      *ird_sv(ikl,ikv)*eso_sv(ikl,ikv) &! Down Atm IR
     &        -(1.0-tau_sv(ikl,ikv)) *0.5*irv_sv(ikl,ikv)      ! Down Veg IR
          hssokl(ikl,ikv) = hss_sv(ikl,ikv)                    ! HS
          hlsokl(ikl,ikv) = hls_sv(ikl,ikv)                    ! HL
          hls_kl(ikl,ikv) = hls_sv(ikl,ikv) / lhvh2o           ! mm w.e./sec
        END DO
        END DO
 
 
! OUTPUT/Verification: Energy/Water Budget: Energy Budget (OUT)
! #e1   DO ikl=1,kcolp
! #e1   DO ikv=1,mwp
! #e1     ETSo_d(ikl,ikv) =                                   &!
! #e1&         (     SoSosv(ikl,ikv)      *sol_SV(ikl,ikv)    &! Net   Solar
! #e1&         +                       IRs_SV(ikl,ikv)        &! Up Surf. IR
! #e1&         +     tau_sv(ikl,ikv)      *IRd_SV(ikl,ikv)*Eso_sv(ikl,ikv)&! Down Atm IR
! #e1&         -(1.0-tau_sv(ikl,ikv)) *0.5*IRv_sv(ikl,ikv)    &! Down Veg IR
! #e1&                                +HSs_sv(ikl,ikv)        &! Sensible
! #e1&                                +HLs_sv(ikl,ikv)            )! Latent
! #e1     ETSo_1(ikl,ikv) = 0.
! #e1   END DO
! #e1   END DO
!         _________________
! #e1  DO isl= -nsoil,nsnow
! #e1   DO ikl=1,kcolp
! #e1   DO ikv=1,mwp
! #e1     Exist0      = isl -           isnoSV(ikl,ikv)
! #e1     Exist0      = 1.  - max(zer0,min(un_1,Exist0))
! #e1     ETSo_1(ikl,ikv) = ETSo_1(ikl,ikv)                   &!
! #e1&                +(TsisSV(ikl,ikv,isl)-Tf_Sno)*Exist0    &!
! #e1&                                 /dtC_sv(ikl,ikv,isl)
! #e1   END DO
! #e1   END DO
! #e1  END DO
 
 
 
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!                                                                      !
! DE-ALLOCATION                                                        !
! =============                                                        !
 
      IF (flagdalloc)                                             THEN !
 
      deallocate          ( tsisva )                                   !
      deallocate          ( fsisva )                                   !
      deallocate          ( dza__1 )                                   !
      deallocate          ( mu_sno )                                   !     Snow thermal Conductivity
      deallocate          ( mu__dz )                                   ! mu_(eta,sno)   / dz
      deallocate          ( dtc_sv )                                   ! dt      / C
      deallocate          ( irs__d )                                   ! UpwardIR Previous Iter.Contr.
      deallocate          ( dirsdt )                                   ! UpwardIR           T Derivat.
      deallocate          ( f_hshl )                                   ! Factor common to HS and HL
      deallocate          ( dridts )                                   ! d(Rib)/d(Ts)
      deallocate          ( hs___d )                                   ! Sensible Heat Flux Atm.Contr.
      deallocate          ( f___hl )                                   !
      deallocate          ( hl___d )                                   ! Latent   Heat Flux Atm.Contr.
      deallocate          ( tsurf0 )                                   ! Previous Surface Temperature
      deallocate          ( qsatsg )                                   ! Soil   Saturat. Spec. Humidity
      deallocate          ( dqs_dt )                                   ! d(qsatsg)/dTv
      deallocate          ( psi    )                                   ! 1st Soil Layer Water Potential
      deallocate          ( rhusol )                                   ! Soil Surface Relative Humidity
      deallocate          ( rhu_av )                                   ! Soil Surface Relative Humidity
      deallocate          ( diag_a )                                   ! A Diagonal
      deallocate          ( diag_b )                                   ! B Diagonal
      deallocate          ( diag_c )                                   ! C Diagonal
      deallocate          ( term_d )                                   !   Independant Term
      deallocate          ( aux__p )                                   ! P Auxiliary Variable
      deallocate          ( aux__q )                                   ! Q Auxiliary Variable
      deallocate          ( etabak )                                   !
      deallocate          ( etanew )                                   !
      deallocate          ( eteubk )                                   !
      deallocate          ( fac_dt )                                   !
      deallocate          ( faceta )                                   !
      deallocate          ( psiarg )                                   !
      deallocate          ( shusol )                                   !
 
      END IF                                                           !
!                                                                      !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 
      return
      end subroutine sisvat_tso
 
 
 
      subroutine sisvat_qvg
 
!--------------------------------------------------------------------------+
!   MAR          SISVAT_qVg                           Wed 26-Jun-2013  MAR |
!     SubRoutine SISVAT_qVg computes the Canopy Water  Balance             |
!                                    including  Root   Extraction          |
!                                                                          |
!     version 3.p.4.1 created by H. Gallee,           Tue  5-Feb-2013      |
!           Last Modification by H. Gallee,           Wed 26-Jun-2013      |
!                                                                          |
!--------------------------------------------------------------------------+
!                                                                          |
!     PARAMETERS:  kcolv: Total Number of columns =                        |
!     ^^^^^^^^^^        = Total Number of continental     grid boxes       |
!                       X       Number of Mosaic Cell per grid box         |
!                                                                          |
!     INPUT:   ivgtSV   = 0,...,12:   Vegetation Type                      |
!     ^^^^^               0:          Water, Solid or Liquid               |
!                                                                          |
!     INPUT:   rhT_SV   : SBL Top    Air  Density                  [kg/m3] |
!     ^^^^^    QaT_SV   : SBL Top    Specific  Humidity            [kg/kg] |
!                                                                          |
!              TvegSV   : Canopy   Temperature                         [K] |
!              rrCaSV   : Canopy     Water     Content             [kg/m2] |
!              rrMxsv   : Canopy Maximum Intercepted Rain          [kg/m2] |
!              rah_sv   : Aerodynamic Resistance for Heat            [s/m] |
!              EvT_sv   : EvapoTranspiration                       [kg/m2] |
!              Sigmsv   : Canopy Ventilation Factor                    [-] |
!              glf_sv   : Green Leaf Fraction of NOT fallen Leaves     [-] |
!              LAIesv   : Leaf Area  Index (effective / transpiration) [-] |
!              psi_sv   : Soil       Water    Potential                [m] |
!              Khydsv   : Soil   Hydraulic    Conductivity           [m/s] |
!                                                                          |
!     INPUT /  psivSV   : Leaf       Water    Potential                [m] |
!     OUTPUT:                                                              |
!     ^^^^^^                                                               |
!                                                                          |
!     OUTPUT:  Rootsv   : Root Water Pump                        [kg/m2/s] |
!     ^^^^^^                                                               |
!                                                                          |
!     REMARK: Water Extraction by roots calibrated by Evapotranspiration   |
!     ^^^^^^  (computed in the Canopy Energy Balance)                      |
!                                                                          |
!     REFERENCE: DR97: Koen de Ridder thesis, UCL, 1997                    |
!     ^^^^^^^^^                                                            |
!                                                                          |
!     Preprocessing  Option:                                               |
!     ^^^^^^^^^^^^^^^^^^^^^                                                |
!     #RW: Root Water Flow slowed down by Soil Hydraulic Conductivity      |
!                                                                          |
!--------------------------------------------------------------------------+
 
 
! Global  Variables
! =================
 
      use mod_real
      use mod_phy____dat
      use mod_phy____grd
      use mod_sisvat_grd
 
 
 
! General Variables
! =================
 
      use mod_sisvat_dat
      use mod_sisvat_dzs
      use mod_sisvat_kkl
      use mod_sisvat_loc
 
 
 
! Internal Variables
! ==================
 
      use mod_sisvatlqvg
 
 
      IMPLICIT NONE
 
      integer                                      ::  ikl,ikv   ,isl  ! Grid Point, Layer Indices
      integer                                      ::  nitmax =  5     ! Maximum  Iterations Number
      integer                                      ::  nit             !          Iterations Counter
      real(kind=real8)                             ::  psidif          ! Soil-Canopy  Water Pot. Differ.
      real(kind=real8)                             ::  Root_W          ! Root   Water     Flow
      real(kind=real8)                             ::  RootOK          ! Roots take Water in Soil Layer
      real(kind=real8)                             ::  d_psiv          ! Canopy Water     Increment
      real(kind=real8)                             ::  dpvMAX = 20.    ! Canopy Water     Increment MAX
      real(kind=real8)                             ::  BWater          ! Imbalance of Canopy Water Budg.
      real(kind=real8)                             ::  BW_MAX          ! MAX Imbal.of Canopy Water Budg.
      real(kind=real8)                             ::  BW_MIN =  4.e-8 ! MIN Imbal.of Canopy Water Budg.
      real(kind=real8)                             ::  dBwdpv          ! Derivativ.of Canopy Water Budg.
      real(kind=real8)                             ::  Bswich          ! Newton-Raphson         Switch
      real(kind=real8)                             ::  EvFrac          ! Condensat./Transpiration Switch
      real(kind=real8)                             ::  den_qs,arg_qs   !
!     real(kind=real8)                             ::  esat_i          ! Saturation Vapor Pressure [hPa]
      real(kind=real8)                             ::  qsatvg          ! Canopy Saturat. Spec. Humidity
      real(kind=real8)                             ::  EvTran          ! EvapoTranspiration
      real(kind=real8)                             ::  dEdpsi          ! Evapotranspiration  Derivative
      real(kind=real8)                             ::  Fac_Ev,FacEvT   ! Evapotranspiration  Factors
      real(kind=real8)                             ::  denomE          ! Evapotranspiration  Denominator
      real(kind=real8)                             ::  F_Stom          ! Funct.  (Leaf Water Potential)
      real(kind=real8)                             ::  dFdpsi          ! Derivative  of F_Stom
      real(kind=real8)                             ::  denomF          ! Denominator of F_Stom
      real(kind=real8)                             ::  F___OK          ! (psi>psi_c) => F_Stom swich  ON
      real(kind=real8)                             ::  R0Stom          ! Minimum Stomatal Resistance
      real(kind=real8)                             ::  R_Stom          !         Stomatal Resistance
      real(kind=real8)                             ::  dRdpsi          ! Derivat.Stomatal Resistance
      real(kind=real8)                             ::  numerR          ! Numerat.Stomatal Resistance
 
 
 
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!                                                                      !
! ALLOCATION                                                           !
! ==========                                                           !
 
      IF (it_run.EQ.1 .OR. flagdalloc)                            THEN !
 
      allocate            ( plantw(kcolp,mwp) )                        ! Plant  Water
      allocate            ( dpdpsi(kcolp,mwp) )                        ! Plant  Water psi Derivative
      allocate            ( psiv_0(kcolp,mwp) )                        ! Canopy Temperature,  Previous t
 
      END IF                                                           !
!                                                                      !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 
 
! Newton-Raphson Scheme
! =====================
 
      nit    = 0
  101 CONTINUE
      nit    = nit + 1
      bw_max = 0.
 
 
! W.Potential of the Previous Time Step
! -------------------------------------
 
        DO ikl=1,kcolp
        DO ikv=1,mwp
          psiv_0(ikl,ikv) = psivsv(ikl,ikv)
 
 
! Extraction of Soil Water through the Plant Roots
! ------------------------------------------------
 
          plantw(ikl,ikv)     = 0.                          ! Plant Water
          dpdpsi(ikl,ikv)     = 0.                          ! Idem, Derivat.
        END DO
        END DO
      DO   isl= -nsoil,0
        DO ikl=1,kcolp
        DO ikv=1,mwp
          psidif = psivsv(ikl,ikv)-(dh_dsv(ivgtsv(ikl,ikv))&! Soil-Canopy Water
     &                         +psi_sv(       ikl,ikv ,isl))! Potential  Diff.
          root_w = rhowat     * rf__sv(ivgtsv(ikl,ikv),isl)&! If > 0, Contrib.
     &              /max(eps_21,pr_dsv(ivgtsv(ikl,ikv))    &!     to Root Water
! #RW&                         +Khydsv(ikl,ikv   ,isl )*1.e-4  &! (DR97, eqn.3.20)
     &                                                   )  !
!         Pas de prise en compte de la resistance sol/racine dans proto-svat
!         (DR97, eqn.3.20)
          rootok =      max(zer0, sign(un_1,psidif))
          rootsv(ikl,ikv,isl) = root_w*max(zer0,psidif)     ! Root  Water
          plantw(ikl,ikv)     = plantw(ikl,ikv) + rootsv(ikl,ikv ,isl)  ! Plant Water
          dpdpsi(ikl,ikv)     = dpdpsi(ikl,ikv) + rootok*root_w ! idem, Derivat.
        END DO
        END DO
      END DO
 
 
! Latent   Heat Flux
! ------------------
 
! Canopy Saturation Specific Humidity
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
        DO ikl=1,kcolp
        DO ikv=1,mwp
!       IF      (DeRidder)                                THEN !
          den_qs      =         tvegsv(ikl,ikv)    - 35.8      !
          arg_qs      = 17.27 *(tvegsv(ikl,ikv)    -273.16)   &!
     &                                   / den_qs              !
          qsatvg      = .0038 *        exp(arg_qs)     *0.875  !  0.875 = Tuning Hapex-Sahel
!         dqs_dT      = qsatvg     * 4099.2   /(den_qs *den_qs)!
!       ELSE IF (Dudhia_MAR)                              THEN !
!         esat_i      = 6.107                                 &!
!    &     *exp(ExpIsv*(un_1/WatIsv -un_1/TvegSV(ikl)    ))    !
!         qsatvg      = 0.622    *     esat_i                 &!
!    &      / (10.*pkPaSV(ikl) - 0.378*esat_i)                 !
!         dqs_dT      = qsatvg                                &!
!    &     *(1.0+0.6077*qsatvg     )                          &!
!    &     *    ExpIsv/(TvegSV(ikl)    *TvegSV(ikl)    )       !
!       END IF
 
 
! Canopy Stomatal Resistance
! ^^^^^^^^^^^^^^^^^^^^^^^^^^
          r0stom = min(         stodsv(ivgtsv(ikl,ikv))     &!
     &                /max(eps6,glf_sv(       ikl,ikv)),stxdsv)  ! Min Stomatal R.
          denomf =              pscdsv-psivsv(ikl,ikv)
          f___ok =     max(zer0,sign(un_1,denomf))
          denomf =     max(eps6,          denomf)            !
          f_stom =              pscdsv  / denomf             ! F(Leaf Wat.Pot.)
          dfdpsi =             -f_stom  / denomf             !
                                                             ! DR97, eqn. 3.22
          numerr = r0stom / max(laiesv(ikl,ikv), r0stom/stxdsv)  !
          r_stom = numerr *                  f_stom          ! Can.Stomatal R.
                                                             ! DR97, eqn. 3.21
          drdpsi = r_stom *                  dfdpsi          !
 
! Evaporation / Evapotranspiration
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
          evfrac = max(zer0, sign(un_1,qat_sv(ikl,ikv)-qsatvg))  ! Condensation/
          evfrac = evfrac                                   &! Transpiration
     &       + (1.-evfrac)     *rrcasv(ikl,ikv)/ rrmxsv(ikl,ikv) !        Switch
          fac_ev = rht_sv(ikl,ikv) *sigmsv(ikl,ikv)          ! idem,  Factor
          denome = rah_sv(ikl,ikv) +r_stom     * sigmsv(ikl,ikv)
          facevt = fac_ev * (1.-evfrac)    / denome          !
          evtran = facevt     *(qsatvg     - qat_sv(ikl,ikv))! EvapoTranspir.
          dedpsi =(evtran     / denome)    * drdpsi          ! EvT Derivative
 
 
! Imbalance  of the Canopy  Water  Budget
! ---------------------------------------
 
          bwater      =( plantw(ikl,ikv)                    &! Available  Water
     &                 - evtran     )*        f___ok         ! Transpired Water
 
          bswich      = max(zer0,                           &! Newton-Raphson
     &                      sign(un_1,    abs(bwater)       &!         Switch
     &                                       -bw_min))       !
 
 
! Derivative of the Canopy  Water  Budget
! ---------------------------------------
 
          dbwdpv      = dpdpsi(ikl,ikv)                     &!
     &                - dedpsi
          dbwdpv      = sign(  un_1,    dbwdpv)             &!
     &                *  max(eps_21,abs(dbwdpv))             !
 
 
! Update Canopy and Surface/Canopy Temperatures
! ---------------------------------------------
 
          d_psiv      = bwater       / dbwdpv                !
          d_psiv      =      sign(un_1,d_psiv)              &! Increment
     &                       *min( abs(d_psiv)     ,dpvmax)  ! Limitor
          psivsv(ikl,ikv) = psivsv(ikl,ikv)  - bswich      *d_psiv   ! Newton-Raphson
          bw_max      = max(bw_max,abs(bwater))
        END DO
        END DO
 
 
! Update Root Water Fluxes | := Evapotranspiration
! ------------------------------------------------
 
      DO   isl= -nsoil,0
        DO ikl=1,kcolp
        DO ikv=1,mwp
          rootsv(ikl,ikv,isl) = rootsv(ikl,ikv,isl)*evt_sv(ikl,ikv) &! Root  Water
     &                          /max(eps_21,plantw(ikl,ikv)) !
        END DO
        END DO
      END DO
 
      IF (bw_max.gt.bw_min.and.nit.lt.nitmax)    GO TO 101
 
 
 
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!                                                                      !
! DE-ALLOCATION                                                        !
! =============                                                        !
 
      IF (flagdalloc)                                             THEN !
 
      deallocate          ( plantw )                                   ! Plant  Water
      deallocate          ( dpdpsi )                                   ! Plant  Water psi Derivative
      deallocate          ( psiv_0 )                                   ! Canopy Temperature,  Previous t
 
      END IF                                                           !
!                                                                      !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 
      return
      end subroutine sisvat_qvg
 
 
 
      subroutine sisvat_qsn                                            &
     &                     (                                           &
! #e1&                      EqSn_0,EqSn_1,EqSn_d                       &
! #m1&                     ,SIsubl,SImelt,SIrnof                       &
     &                     )
 
!--------------------------------------------------------------------------+
!   MAR          SISVAT_qSn                           Wed 26-Jun-2013  MAR |
!     SubRoutine SISVAT_qSn updates  the Snow Water Content                |
!                                                                          |
!     version 3.p.4.1 created by H. Gallee,           Tue  5-Feb-2013      |
!           Last Modification by H. Gallee,           Wed 26-Jun-2013      |
!                                                                          |
!--------------------------------------------------------------------------+
!                                                                          |
!     PARAMETERS:  kcolv: Total Number of columns =                        |
!     ^^^^^^^^^^        = Total Number of continental     grid boxes       |
!                       X       Number of Mosaic Cell per grid box         |
!                                                                          |
!     INPUT:   isnoSV   = total Nb of Ice/Snow Layers                      |
!     ^^^^^                                                                |
!                                                                          |
!     INPUT:   TaT_SV   : SBL Top    Temperature                       [K] |
!     ^^^^^    dt__SV   : Time Step                                    [s] |
!                                                                          |
!     INPUT /  drr_SV   : Rain Intensity                         [kg/m2/s] |
!     OUTPUT:  dzsnSV   : Snow Layer Thickness                         [m] |
!     ^^^^^^   eta_SV   : Snow Water Content                       [m3/m3] |
!              ro__SV   : Snow/Soil  Volumic Mass                  [kg/m3] |
!              TsisSV   : Soil/Ice Temperatures (layers -nsoil,-nsoil+1, 0)|
!                       & Snow     Temperatures (layers  1,2,..,nsnow) [K] |
!                                                                          |
!     OUTPUT:  SWS_SV   : Surficial Water Status                           |
!     ^^^^^^                                                               |
!              EExcsv   : Snow Energy in Excess, initial Forcing    [J/m2] |
!              EqSn_d   : Snow Energy in Excess, remaining          [J/m2] |
!              EqSn_0   : Snow Energy, before Phase Change          [J/m2] |
!              EqSn_1   : Snow Energy, after  Phase Change          [J/m2] |
!              SIsubl   : Snow sublimed/deposed Mass             [mm w.e.] |
!              SImelt   : Snow Melted           Mass             [mm w.e.] |
!              SIrnof   : Surficial Water + Run OFF Change       [mm w.e.] |
!                                                                          |
!                                                                          |
!     Preprocessing  Option: STANDARD Possibility                          |
!     ^^^^^^^^^^^^^^^^^^^^^  ^^^^^^^^^^^^^^^^^^^^                          |
!     #IB: OUTPUT: Ice-Sheet Surface Mass Balance  (on NetCDF File )       |
!                                                                          |
!                                                                          |
!     Preprocessing  Option:           (PLEASE VERIFY before USE)          |
!     ^^^^^^^^^^^^^^^^^^^^^                                                |
!     #SU: SLUSH : Alternative Parameterization                            |
!                                                                          |
!                                                                          |
!     Preprocessing  Option: SISVAT IO (not always a standard preprocess.) |
!     ^^^^^^^^^^^^^^^^^^^^^  ^^^^^^^^^                                     |
!     FILE                 |      CONTENT                                  |
!     ~~~~~~~~~~~~~~~~~~~~~+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
!   # SISVAT_iii_jjj_n     | #e0: OUTPUT on ASCII  File (SISVAT Variables) |
!   #                      |(#e0  MUST BE PREPROCESSED BEFORE #e1 & #e2 !) |
!   # SISVAT_iii_jjj_n     | #e1: OUTPUT/Verification: Energy Conservation |
!   # SISVAT_iii_jjj_n     | #m1: OUTPUT/Verification: * Mass Conservation |
!                          |                                               |
!   # SISVAT_qSn.vm        | #e5: OUTPUT/Verification: Energy/Water Budget |
!                          |      unit 43, SubRoutine  SISVAT_qSn **ONLY** |
!   # SISVAT_qSn.vu        | #vu: OUTPUT/Verification: Slush  Parameteriz. |
!                          |      unit 44, SubRoutine  SISVAT_qSn **ONLY** |
!                          |                                               |
!   # stdout               | #s2: OUTPUT of SnowFall, Snow Buffer          |
!                          |      unit  6, SubRoutine  SISVAT_BSn, _qSn    |
!--------------------------------------------------------------------------+
 
 
! Global  Variables
! =================
 
      use mod_real
      use mod_phy____dat
      use mod_phy____grd
      use mod_sisvat_grd
 
 
 
! General Variables
! =================
 
      use mod_sisvat_ctr
      use mod_sisvat_dat
      use mod_sisvat_dzs
      use mod_sisvat_kkl
      use mod_sisvat_loc
      use mod_sisvat_qsn
 
 
 
! Internal Variables
! ==================
 
      use mod_sisvatlqsn
 
 
      IMPLICIT NONE
 
 
      integer                                      ::  ikl,ikv   ,isn  !
      integer                                      ::  nh              ! Non erodible Snow: up.lay.Index
      integer                                      ::  LayrOK          ! 1 (0)  if In(Above) Snow Pack
      integer                                      ::  k_face          ! 1 (0)  if Crystal(no) faceted
      integer                                      ::  LastOK          ! 1 ==>  1! Snow Layer
      integer                                      ::  NOLayr          ! 1     Layer  Update
! #SU integer                                      ::  kSlush          ! Slush Switch
      real(kind=real8)                             ::  dTSnow          ! Temperature                  [C]
      real(kind=real8)                             ::  OKmelt          ! 1 (0)  if        (no) Melting
      real(kind=real8)                             ::  EnMelt          ! Energy in excess, for Melting
      real(kind=real8)                             ::  SnHLat          ! Energy consumed   in  Melting
! #e4 real(kind=real8)                             ::  AdEnrg          ! Additional Energy from  Vapor
! #e3 real(kind=real8)                             ::  B_Enrg          ! Additional Energy from  Vapor
      real(kind=real8)                             ::  dzVap0,dzVap1   ! Vaporized Thickness          [m]
      real(kind=real8)                             ::  rosDry          ! Snow volumic Mass if no Water in
      real(kind=real8)                             ::  PorVol          ! Pore volume
      real(kind=real8)                             ::  PClose          ! Pore Hole Close OFF Switch
!     real(kind=real8)                             ::  SGDiam          !      Snow Grain Diameter
!     real(kind=real8)                             ::  SGDmax = 0.003  ! Max. Snow Grain Diameter     [m]
                                                                       ! (Rowe et al. 1995, JGR p.16268)
      real(kind=real8)                             ::  rWater          ! Retained Water           [kg/m2]
      real(kind=real8)                             ::  drrNEW          ! New available Water      [kg/m2]
      real(kind=real8)                             ::  rdzNEW          ! Snow          Mass       [kg/m2]
      real(kind=real8)                             ::  rdzsno          ! Snow          Mass       [kg/m2]
      real(kind=real8)                             ::  EnFrez          ! Energy Release    in  Freezing
      real(kind=real8)                             ::  WaFrez          ! Water  consumed   in  Melting
      real(kind=real8)                             ::  RapdOK          ! 1. ==> Snow melts rapidly
      real(kind=real8)                             ::  ThinOK          ! 1. ==> Snow Layer is thin
      real(kind=real8)                             ::  dzepsi = 0.0001 ! Minim. Snow Layer Thickness (!)
      real(kind=real8)                             ::  dz_Min = 1.e-3  ! Minim. Snow Layer Thickness
!                                                      dz_Min = 0.005  !
! ... Warning: Too high for Col de Porte: precludes 1st snow (layer) apparition
 
      real(kind=real8)                             ::  z_Melt          ! Last (thin) Layer Melting
      real(kind=real8)                             ::  rusnew          ! Surficial Water Thickness   [mm]
! #SU real(kind=real8)                             ::  zWater          ! Max Slush Water Thickness   [mm]
! #SU real(kind=real8)                             ::  zSlush          !     Slush Water Thickness   [mm]
! #SU real(kind=real8)                             ::  ro_new          ! New Snow/ice  Density    [kg/m3]
      real(kind=real8)                             ::  zc,zt           ! Non erod.Snow Thickness[mm w.e.]
 
 
! OUTPUT of SISVAT Trace Statistics (see assignation in PHY_SISVAT)
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      integer                                      ::  isnnew,isinew,isnUpD,isnitr
 
 
! #e5 real(kind=real8)                             ::  hourer          !
 
 
 
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!                                                                      !
! ALLOCATION                                                           !
! ==========                                                           !
 
      IF (it_run.EQ.1 .OR. flagdalloc)                            THEN !
 
! OUTPUT/Verification: Energy/Water Budget
! #e1 allocate            ( EqSn_d(kcolp,mwp) )                        ! Energy in Excess, initial
! #e1 allocate            ( EqSn_0(kcolp,mwp) )                        ! Snow Energy, befor Phase Change
! #e5 allocate            ( EqSn01(kcolp,mwp) )                        ! Snow Energy, after Phase Change
! #e5 allocate            ( EqSn02(kcolp,mwp) )                        ! Snow Energy, after Phase Change
                                                                       !              .AND. Last Melting
! #e1 allocate            ( EqSn_1(kcolp,mwp) )                        ! Snow Energy, after Phase Change
                                                                       !              .AND. Mass Redistr.
! OUTPUT/Verification: * Mass Conservation
! #m1 allocate            ( SIsubl(kcolp,mwp) )                        ! Snow Deposed Mass
! #m1 allocate            ( SImelt(kcolp,mwp) )                        ! Snow Melted  Mass
! #m1 allocate            ( SIrnof(kcolp,mwp) )                        ! Local Surficial Water + Run OFF
 
      allocate            ( nosnow(kcolp,mwp) )                        ! Nb of Layers Updater
      allocate            ( eexdum(kcolp,mwp) )                        ! Energy in Excess when no Snow
      allocate            ( dzmelt(kcolp,mwp) )                        ! Melted    Thickness          [m]
 
! OUTPUT/Verification: Energy/Water Budget
! #e5 allocate            ( WqSn_0(kcolp,mwp) )                        ! Snow Water+Forcing  Initial
! #e5 allocate            ( WqSn_1(kcolp,mwp) )                        ! Snow Water+Forcing, Final
 
      END IF                                                           !
!                                                                      !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 
 
! OUTPUT/Verification: Energy/Water Budget: Energy Budget (IN)
! #e1   DO ikl=1,kcolp
! #e1   DO ikv=1,mwp
! #e1     EqSn_0(ikl,ikv) = 0.
! #e1   END DO
! #e1   END DO
! #e1 DO   isn=nsnow,1,-1
! #e1   DO ikl=1,kcolp
! #e1   DO ikv=1,mwp
! #e1     EqSn_0(ikl,ikv) = EqSn_0(ikl,ikv) + ro__SV(ikl,ikv,isn) *dzsnSV(ikl,ikv,isn) &
! #e1&                *(Cn_dSV      *(TsisSV(ikl,ikv,isn) -Tf_Sno         )&
! #e1&                 -LhfH2O      *(1.              -eta_SV(ikl,ikv,isn)))
! #e1   END DO
! #e1   END DO
! #e1 END DO
 
 
! OUTPUT/Verification: Energy/Water Budget: Water  Budget (IN)
! #e5   DO ikl=1,kcolp
! #e5   DO ikv=1,mwp
! #e5     WqSn_0(ikl,ikv) = drr_SV(ikl,ikv) * dt__SV                   &
! #e5&                 +rusnSV(ikl,ikv)
! #e5   END DO
! #e5   END DO
! #e5 DO   isn=nsnow,1,-1
! #e5   DO ikl=1,kcolp
! #e5   DO ikv=1,mwp
! #e5     WqSn_0(ikl,ikv) = WqSn_0(ikl,ikv) + ro__SV(ikl,ikv,isn) *dzsnSV(ikl,ikv,isn)
! #e5   END DO
! #e5   END DO
! #e5 END DO
 
 
! OUTPUT/Verification: * Mass Conservation
! #m1   DO ikl=1,kcolp
! #m1   DO ikv=1,mwp
! #m1     SImelt(ikl,ikv) = 0.
! #m1     SIrnof(ikl,ikv) = rusnSV(ikl,ikv) + RnofSV(ikl,ikv) * dt__SV
! #m1   END DO
! #m1   END DO
 
 
! Initialization
! ==============
 
      DO ikl=1,kcolp
      DO ikv=1,mwp
        nosnow(ikl,ikv)   = 0               ! Nb of Layers Updater
        ispisv(ikl,ikv)   = 0               ! Pore Hole Close OFF Index
                                            ! (assumed to be the Top of
                                            !  the surimposed Ice Layer)
! #IB   dwemSV(ikl,ikv)   = 0.
! #IB   dwerSV(ikl,ikv)   = 0.
      END DO
      END DO
 
 
! Melting/Freezing Energy
! =======================
 
!  REMARK: Snow liquid Water Temperature assumed = Tf_Sno
!  ^^^^^^
        DO ikl=1,kcolp
        DO ikv=1,mwp
          eexdum(ikl,ikv) = drr_sv(ikl,ikv)     * hc_wat *(tat_sv(ikl,ikv)-tf_sno) &
     &                                  * dt__sv
          eexcsv(ikl,ikv) = eexdum(ikl,ikv)     *    min(1,isnosv(ikl,ikv)) ! Snow exists
          eexdum(ikl,ikv) = eexdum(ikl,ikv)     -          eexcsv(ikl,ikv)  !
 
! OUTPUT/Verification: Energy/Water Budget
! #e1     EqSn_d(ikl,ikv) = EExcsv(ikl,ikv)                     !
 
        END DO
        END DO
 
 
! Surficial Water Status
! ----------------------
 
        DO ikl=1,kcolp
        DO ikv=1,mwp
          sws_sv(ikl,ikv) = max(zer0,sign(un_1,tf_sno                  &
     &                                    -tsissv(ikl,ikv,isnosv(ikl,ikv))))
        END DO
        END DO
 
      DO   isn=nsnow,1,-1
        DO ikl=1,kcolp
        DO ikv=1,mwp
 
! Energy, store Previous Content
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
          dtsnow      = tsissv(ikl,ikv,isn) -          tf_sno
          eexcsv(ikl,ikv) = eexcsv(ikl,ikv)                            &
     &                + ro__sv(ikl,ikv,isn) * cn_dsv * dtsnow          &
     &                                           * dzsnsv(ikl,ikv,isn)
          tsissv(ikl,ikv,isn) =                        tf_sno
 
! Water,  store Previous Content
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
          drr_sv(ikl,ikv) = drr_sv(ikl,ikv)                            &
     &                + ro__sv(ikl,ikv,isn)          * eta_sv(ikl,ikv,isn) &
     &                                           * dzsnsv(ikl,ikv,isn) &
     &                / dt__sv
          ro__sv(ikl,ikv,isn) =                                        &
     &                  ro__sv(ikl,ikv,isn) *(1.     - eta_sv(ikl,ikv,isn))
          eta_sv(ikl,ikv,isn) =  0.
 
 
! Melting  if EExcsv > 0
! ======================
 
          enmelt      =    max(zer0,          eexcsv(ikl,ikv) )
 
! Energy Consumption
! ^^^^^^^^^^^^^^^^^^
          snhlat      = ro__sv(ikl,ikv,isn) * lhfh2o          !
          dzmelt(ikl,ikv) = enmelt      / max(snhlat,    eps6 )   !
          nosnow(ikl,ikv) = nosnow(ikl,ikv)                  &!
     &   +int(max(zer0  ,sign(un_1,dzmelt(ikl,ikv)           &!
     &                            -dzsnsv(ikl,ikv ,isn))))   &! 1 if full Melt
     &       *min(1     , max(0 ,1+isnosv(ikl,ikv)-isn))      ! 1 in the  Pack
          dzmelt(ikl,ikv) =                                  &!
     &              min(dzsnsv(ikl,ikv, isn),dzmelt(ikl,ikv)) !
          dzsnsv(ikl,ikv,isn) =                              &!
     &                  dzsnsv(ikl,ikv,isn) -dzmelt(ikl,ikv)  !
          eexcsv(ikl,ikv) = eexcsv(ikl,ikv)     -dzmelt(ikl,ikv)*snhlat   !
! #IB     dwemSV(ikl,ikv) = dwemSV(ikl,ikv)     -dzMelt(ikl,ikv)*ro__SV(ikl,ikv,isn)
 
! Water  Production
! ^^^^^^^^^^^^^^^^^
          drr_sv(ikl,ikv) = drr_sv(ikl,ikv)                            &
     &                + ro__sv(ikl,ikv,isn) * dzmelt(ikl,ikv)/dt__sv
 
! OUTPUT/Verification: * Mass Conservation
! #m1     SImelt(ikl,ikv) = SImelt(ikl,ikv)                            &
! #m1&                + ro__SV(ikl,ikv,isn) * dzMelt(ikl,ikv)
 
          okmelt      =max(zer0,sign(un_1,drr_sv(ikl,ikv)-eps6))
 
! Snow History
! ^^^^^^^^^^^^
          k_face          =       min(    istosv(ikl,ikv,isn),istdsv(1)) &! = 1  if
     &                           *max(0,2-istosv(ikl,ikv,isn)          )  ! faceted
          istosv(ikl,ikv,isn) =                                      &!
     &     int(1.-okmelt) *               istosv(ikl,ikv,isn)        &!
     &    +int(okmelt) *((1-k_face) *  istdsv(2)                  &!
     &                     +   k_face  *  istdsv(3)      )            !
 
 
! Freezing if EExcsv < 0
! ======================
 
          rdzsno      =          ro__sv(ikl,ikv,isn) * dzsnsv(ikl,ikv ,isn)
          layrok      = min(   1, max(0          , isnosv(ikl,ikv)-isn+1))
          enfrez      = min(zer0,                  eexcsv(ikl,ikv))
          wafrez      =   -(     enfrez          * layrok / lhfh2o)
          drrnew      = max(zer0,drr_sv(ikl,ikv)     - wafrez / dt__sv)
          wafrez      =    (     drr_sv(ikl,ikv)     - drrnew)* dt__sv
          drr_sv(ikl,ikv) =          drrnew
          eexcsv(ikl,ikv) =          eexcsv(ikl,ikv)     + wafrez * lhfh2o
          enfrez      = min(zer0,eexcsv(ikl,ikv))    * layrok
          rdznew      = wafrez + rdzsno
          ro__sv(ikl,ikv,isn) =      rdznew /max(eps6, dzsnsv(ikl,ikv,isn))
          tsissv(ikl,ikv,isn) =      tf_sno                            &
     &                + enfrez /(cn_dsv *max(eps6, rdznew)        )
          eexcsv(ikl,ikv) =          eexcsv(ikl,ikv)     - enfrez
! #IB     dwerSV(ikl,ikv) = WaFrez                                     &
! #IB&                + dwerSV(ikl,ikv)
 
 
! Snow Water Content
! ==================
 
! Pore   Volume [-]
! ^^^^^^^^^^^^^^^^^
          rosdry      =(1.     - eta_sv(ikl,ikv,isn))* ro__sv(ikl,ikv,isn) !
          porvol      = 1.     - rosdry          / rhoice          !
          porvol      =      max(porvol          , zer0  )         !
 
! Water  Retention
! ^^^^^^^^^^^^^^^^
          rwater      = ws0dsv * porvol * rhowat * dzsnsv(ikl,ikv,isn)
          drrnew      = max(zer0,drr_sv(ikl,ikv)     - rwater /dt__sv)
          rwater      =    (     drr_sv(ikl,ikv)     - drrnew)*dt__sv
          drr_sv(ikl,ikv)     =      drrnew
          rdznew          =      rwater                                &
     &                         + rosdry          * dzsnsv(ikl,ikv,isn)
          eta_sv(ikl,ikv,isn) =      rwater / max(eps6,rdznew)
          ro__sv(ikl,ikv,isn) =      rdznew / max(eps6,dzsnsv(ikl,ikv,isn))
 
! Pore Hole Close OFF
! ^^^^^^^^^^^^^^^^^^^
          pclose = max(zer0,                                           &
     &                 sign(un_1,ro__sv(ikl,ikv,isn)                   &
     &                          -rocdsv         ))
          ispisv(ikl,ikv) =          ispisv(ikl,ikv)  * int(1.-pclose) &
     &                +      max(ispisv(ikl,ikv),isn) *int(pclose)
          pclose = max(0   ,                                           &! Water under SuPer.Ice
     &                 min(1   ,ispisv(ikl,ikv)                       &! contributes to
     &                          -isn            ))                      ! Surficial   Water
          rusnsv(ikl,ikv) =          rusnsv(ikl,ikv)                   &
     &                +          drr_sv(ikl,ikv) *dt__sv * pclose
          drr_sv(ikl,ikv) =          drr_sv(ikl,ikv)      *(1.-pclose)
 
        END DO
        END DO
      END DO
 
 
! Remove Zero-Thickness Layers
! ============================
 
 1000 CONTINUE
           isnitr =          0
      DO   ikl=1,kcolp
      DO ikv=1,mwp
           isnupd =          0
           isinew =          0
        DO isn=1,nsnow-1
           isnnew =                                                    &
     &          int(un_1-max(zer0  ,sign(un_1,dzsnsv(ikl,ikv,isn)-dzepsi)))&
     &             *     max(0     , min(1   ,isnosv(ikl,ikv) +1 -isn ))
           isnupd =      max(isnupd,          isnnew)
           isnitr =      max(isnitr,          isnnew)
           isinew =      isn*isnupd *max(0, 1-isinew)                  &! LowerMost  0-Layer
     &                                       +isinew                    ! Index
           dzsnsv(ikl,ikv,isn) =                  dzsnsv(ikl,ikv,isn+isnnew)
           ro__sv(ikl,ikv,isn) =                  ro__sv(ikl,ikv,isn+isnnew)
           tsissv(ikl,ikv,isn) =                  tsissv(ikl,ikv,isn+isnnew)
           eta_sv(ikl,ikv,isn) =                  eta_sv(ikl,ikv,isn+isnnew)
           g1snsv(ikl,ikv,isn) =                  g1snsv(ikl,ikv,isn+isnnew)
           g2snsv(ikl,ikv,isn) =                  g2snsv(ikl,ikv,isn+isnnew)
           dzsnsv(ikl,ikv,isn+isnnew) =(1-isnnew)*dzsnsv(ikl,ikv,isn+isnnew)
           ro__sv(ikl,ikv,isn+isnnew) =(1-isnnew)*ro__sv(ikl,ikv,isn+isnnew)
           eta_sv(ikl,ikv,isn+isnnew) =(1-isnnew)*eta_sv(ikl,ikv,isn+isnnew)
           g1snsv(ikl,ikv,isn+isnnew) =(1-isnnew)*g1snsv(ikl,ikv,isn+isnnew)
           g2snsv(ikl,ikv,isn+isnnew) =(1-isnnew)*g2snsv(ikl,ikv,isn+isnnew)
        END DO
           isnosv(ikl,ikv)   =   isnosv(ikl,ikv)-isnupd                 ! Nb of Snow   Layer
           ispisv(ikl,ikv)   =   ispisv(ikl,ikv)                       &! Nb of SuperI Layer
     &    -isnupd *max(0,min(ispisv(ikl,ikv)-isinew,1))                 ! Update  if I=0
 
      END DO
      END DO
      IF  (isnitr.GT.0)                                       GO TO 1000
 
 
! New upper Limit of the non erodible Snow (istoSV .GT. 1)
! ========================================
 
      DO   ikl=1,kcolp
      DO ikv=1,mwp
           nh =     0
        DO isn=  nsnow,1,-1
           nh =    nh + isn* min(istosv(ikl,ikv,isn)-1,1)*max(0,1-nh)
        END DO
           zc =     0.
           zt =     0.
        DO isn=1,nsnow
           zc =    zc +          dzsnsv(ikl,ikv,isn) *ro__sv(ikl,ikv,isn)  &
     &                     * max(0,min(1,nh+1-isn))
           zt =    zt +          dzsnsv(ikl,ikv,isn) *ro__sv(ikl,ikv,isn)
        END DO
           zwe_sv(ikl,ikv) =                 zt
           zwecsv(ikl,ikv) = min(zwecsv(ikl,ikv),zt)
           zwecsv(ikl,ikv) = max(zwecsv(ikl,ikv),zc)
      END DO
      END DO
 
 
! OUTPUT/Verification: Energy/Water Budget: Energy Budget (OUT)
! #e5   DO ikl=1,kcolp
! #e5   DO ikv=1,mwp
! #e5     EqSn01(ikl,ikv) =-EqSn_0(ikl,ikv)                            &
! #e5&                 -EExcsv(ikl,ikv)
! #e5   END DO
! #e5   END DO
! #e5 DO   isn=nsnow,1,-1
! #e5   DO ikl=1,kcolp
! #e5   DO ikv=1,mwp
! #e5     EqSn01(ikl,ikv) = EqSn01(ikl,ikv) + ro__SV(ikl,ikv,isn) *dzsnSV(ikl,ikv,isn) &
! #e5&                *(Cn_dSV      *(TsisSV(ikl,ikv,isn) -Tf_Sno         )&
! #e5&                 -LhfH2O      *(1.              -eta_SV(ikl,ikv,isn)))
! #e5   END DO
! #e5   END DO
! #e5 END DO
 
 
! "Negative Heat" from supercooled rain
!  ------------------------------------
 
      DO ikl=1,kcolp
      DO ikv=1,mwp
          eexcsv(ikl,ikv) = eexcsv(ikl,ikv) + eexdum(ikl,ikv)
 
 
! Surficial Water Run OFF
! -----------------------
 
          rusnew      = rusnsv(ikl,ikv) * swf_sv(ikl,ikv)
          rnofsv(ikl,ikv) = rnofsv(ikl,ikv)                            &
     &                +(rusnsv(ikl,ikv) - rusnew     ) / dt__sv
          rusnsv(ikl,ikv) = rusnew
      END DO
      END DO
 
 
! Percolation down the Continental Ice Pack
! -----------------------------------------
 
        DO ikl=1,kcolp
        DO ikv=1,mwp
          drr_sv(ikl,ikv) = drr_sv(ikl,ikv) + rusnsv(ikl,ikv)          &
     &                     * (1-min(1,ispisv(ikl,ikv)))/ dt__sv
          rusnsv(ikl,ikv) = rusnsv(ikl,ikv)                            &
     &                     *    min(1,ispisv(ikl,ikv))
        END DO
        END DO
 
 
! Slush Formation (CAUTION: ADD RunOff Possibility before Activation)
! ---------------  ^^^^^^^  ^^^
 
! OUTPUT/Verification: Slush  Parameterization
! #vu IF (.NOT.su_opn)                                              THEN
! #vu          su_opn=.true.
! #vu     open(unit=44,status='unknown',file='SISVAT_qSn.vu')
! #vu     rewind    44
! #vu END IF
! #vu     write(44,440) daHost
! #vu 440 format('iSupI    i       dz       ro      eta',              &
! #vu&            '   PorVol   zSlush     ro_n    eta_n',2x,a18)
 
! #SU DO   isn=1,nsnow
! #SU   DO ikl=1,kcolp
! #SU   DO ikv=1,mwp
! #SU     kSlush = min(1,max(0,isn+1-ispiSV(ikl,ikv)))    ! Slush Switch
 
! Available Additional Pore   Volume [-]
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
! #SU     PorVol = 1. - ro__SV(ikl,ikv,isn)                &! [--]
! #SU&           *(1. - eta_SV(ikl,ikv,isn))/ rhoIce       &!
! #SU&           -      eta_SV(ikl,ikv,isn)                &!
! #SU&                 *ro__SV(ikl,ikv,isn) / rhoWat        !
! #SU     PorVol =  max(PorVol          , zer0  )           !
! #SU     zWater =      dzsnSV(ikl,ikv,isn) * PorVol * 1000.   &! [mm] OR [kg/m2]
! #SU&           * (1. -SWS_SV(ikl,ikv)                    &! 0 <=> freezing
! #SU&                *(1 -min(1,iabs(isn-isnoSV(ikl,ikv)))))   ! 1 <=> isn=isnoSV
! #SU     zSlush =  min(rusnSV(ikl,ikv)     , zWater)       ! [mm] OR [kg/m2]
! #SU     rusnSV(ikl,ikv) = rusnSV(ikl,ikv)     - zSlush    ! [mm] OR [kg/m2]
! #SU     ro_new      =(dzsnSV(ikl,ikv,isn) * ro__SV(ikl,ikv,isn)  &!
! #SU&                 +zSlush                           ) &!
! #SU&            / max(dzsnSV(ikl,ikv,isn) , eps6           )  !
 
! OUTPUT/Verification: Slush  Parameterization
! #vu     rusnew          = eta_SV(ikl,ikv,isn)             !
 
! #SU     eta_SV(ikl,ikv,isn) =(ro_new - ro__SV(ikl,ikv,isn)   &!
! #SU&                    *(1.     - eta_SV(ikl,ikv,isn))) &!
! #SU&               / max (ro_new , eps6            )      !
 
! OUTPUT/Verification: Slush  Parameterization
! #vu     IF    (isn.le.isnoSV(ikl,ikv))                   &!
! #vu&    write(44,441) ispiSV(ikl,ikv),isn,dzsnSV(ikl,ikv,isn)&!
! #vu&                 ,ro__SV(ikl,ikv,isn),rusnew         &!
! #vu&                 ,PorVol         ,zSlush             &!
! #vu&                 ,ro_new         ,eta_SV(ikl,ikv,isn) !
! #vu 441 format(2i5,f9.3,f9.1,f9.6,f9.3,f9.6,f9.1,f9.6)    !
 
! #SU     ro__SV(ikl,ikv,isn) =      ro_new                 !
! #SU   END DO
! #SU   END DO
! #SU END DO
 
 
! Impact of the Sublimation/Deposition on the Surface Mass Balance
! ================================================================
 
      DO ikl=1,kcolp
      DO ikv=1,mwp
          isn                     = isnosv(ikl,ikv)
          dzvap0                  =                       dt__sv       &
     &  * hls_sv(ikl,ikv)             * min(isn             , 1   )    &
     &  /(lx_h2o(ikl,ikv)             * max(ro__sv(ikl,ikv,isn) , eps6))
          nolayr=int(min(zer0,sign(un_1,dzsnsv(ikl,ikv,isn) + dzvap0)))
          dzvap1=    min(zer0,          dzsnsv(ikl,ikv,isn) + dzvap0)
 
 
! Additional Energy (CAUTION: Verification is not performed)
! -----------------
 
! OUTPUT/Verification: Energy Consrv. (HLS)
! #e4     AdEnrg = dzVap0 * ro__SV(ikl,ikv,isnoSV(ikl,ikv))            &! Water   Vapor
! #e4&            *hC_Wat *(TsisSV(ikl,ikv,isnoSV(ikl,ikv)) -Tf_Sno)    ! Sensible Heat
 
! OUTPUT/Verification: Energy Consrv. (HL)
! #e3     B_Enrg =(Cn_dSV      *(TsisSV(ikl,ikv,isn) -Tf_Sno         ) &
! #e3&            -LhfH2O      *(1.              -eta_SV(ikl,ikv,isn)))&
! #e3&           /(1.          + dzVap0 /max(eps6,dzsnSV(ikl,ikv,isn)))
! #e3     eta_SV(ikl,ikv,isn) =                                        &
! #e3&           max(zer0,un_1 +(B_Enrg                                &
! #e3&                         -(TsisSV(ikl,ikv,isn) -Tf_Sno)*Cn_dSV)  &
! #e3&                          /LhfH2O                          )
! #e3     TsisSV(ikl,ikv,isn) =    ( B_Enrg                            &
! #e3&                         +(1.              -eta_SV(ikl,ikv,isn)) &
! #e3&                          *LhfH2O                          )     &
! #e3&                         / Cn_dSV                                &
! #e3&                         + Tf_Sno
 
! OUTPUT/Verification: Energy Conservation
! #e1     STOP "PLEASE add Energy (#e3) from deposition/sublimation"
 
 
! Update of the upper Snow layer Thickness
! ----------------------------------------
 
          dzsnsv(ikl,ikv,isn) =                                        &
     &           max(zer0,  dzsnsv(ikl,ikv,isnosv(ikl,ikv)) + dzvap0)
          isnosv(ikl,ikv)     = isnosv(ikl,ikv)             + nolayr
          isn             = isnosv(ikl,ikv)
          dzsnsv(ikl,ikv,isn) = dzsnsv(ikl,ikv,isn) + dzvap1
! #IB     dwesSV(ikl,ikv)     = ro__SV(ikl,ikv,isn) * dzVap0
      END DO
      END DO
 
 
! OUTPUT/Verification: Energy/Water Budget: Energy Budget (OUT)
! #e5   DO ikl=1,kcolp
! #e5   DO ikv=1,mwp
! #e5     EqSn02(ikl,ikv) =-EqSn_0(ikl,ikv)                            &
! #e5&                 -EExcsv(ikl,ikv)
! #e5   END DO
! #e5   END DO
! #e5 DO   isn=nsnow,1,-1
! #e5   DO ikl=1,kcolp
! #e5   DO ikv=1,mwp
! #e5     EqSn02(ikl,ikv) = EqSn01(ikl,ikv) + ro__SV(ikl,ikv,isn) *dzsnSV(ikl,ikv,isn) &
! #e5&                *(Cn_dSV      *(TsisSV(ikl,ikv,isn) -Tf_Sno         )&
! #e5&                 -LhfH2O      *(1.              -eta_SV(ikl,ikv,isn)))
! #e5   END DO
! #e5   END DO
! #e5 END DO
 
 
! OUTPUT/Verification: * Mass Conservation
! #m1   DO ikl=1,kcolp
! #m1   DO ikv=1,mwp
! #m1     SIsubl(ikl,ikv) = dt__SV*HLs_sv(ikl,ikv)*min(isnoSV(ikl,ikv),1)  &
! #m1&                        /Lx_H2O(ikl,ikv)
! #m1     SIrnof(ikl,ikv) = rusnSV(ikl,ikv) + RnofSV(ikl,ikv) * dt__SV &
! #m1&                - SIrnof(ikl,ikv)
! #m1   END DO
! #m1   END DO
 
 
! Anticipated Disappearance of a rapidly Melting too thin Last Snow Layer
! =======================================================================
 
      DO ikl=1,kcolp
      DO ikv=1,mwp
        lastok = min(1   , max(0   ,iicesv(ikl,ikv)-isnosv(ikl,ikv)+2) &
     &                    *min(1   ,isnosv(ikl,ikv)-iicesv(ikl,ikv))   &
     &                    +min(1   ,isnosv(ikl,ikv))              )
        rapdok = max(zer0,sign(un_1,dzmelt(ikl,ikv)-eps6         ))
        thinok = max(zer0,sign(un_1,dz_min     -dzsnsv(ikl,ikv,1)))
        z_melt = lastok     *rapdok*thinok
        nosnow(ikl,ikv)   = nosnow(ikl,ikv)+int(z_melt)
        z_melt        =                 z_melt *dzsnsv(ikl,ikv,1)
        dzsnsv(ikl,ikv,1) = dzsnsv(ikl,ikv,1) - z_melt
        eexcsv(ikl,ikv)   = eexcsv(ikl,ikv)   - z_melt *ro__sv(ikl,ikv,1)  &
     &                                *(1.     -eta_sv(ikl,ikv,1))*lhfh2o
 
! Water  Production
! ^^^^^^^^^^^^^^^^^
        drr_sv(ikl,ikv)   = drr_sv(ikl,ikv)                            &
     &                + ro__sv(ikl,ikv,1) * z_melt /dt__sv
      END DO
      END DO
 
 
! Update Nb of Layers
! ===================
 
! OUTPUT in SISVAT for ikl = 1 (preferably for Stand Alone Version)
! OUTPUT           for SnowFall and Snow Buffer
! #s2   IF          (isnoSV(1,1) .GT. 0)                               &
! #s2&  write(6,6005)noSnow(1,1)
! #s2   6005   format(i3,' (noSnow) ')
 
      DO ikl=1,kcolp
      DO ikv=1,mwp
        isnosv(ikl,ikv)   = isnosv(ikl,ikv)                            &
     &         * min(1,iabs(isnosv(ikl,ikv)-nosnow(ikl,ikv)))
      END DO
      END DO
 
 
! OUTPUT/Verification: Energy Conservation: Energy Budget (OUT)
! #e1   DO ikl=1,kcolp
! #e1   DO ikv=1,mwp
! #e1     EqSn_1(ikl,ikv) = 0.
! #e1   END DO
! #e1   END DO
! #e1 DO   isn=nsnow,1,-1
! #e1   DO ikl=1,kcolp
! #e1   DO ikv=1,mwp
! #e1     EqSn_1(ikl,ikv) = EqSn_1(ikl,ikv) + ro__SV(ikl,ikv,isn) *dzsnSV(ikl,ikv,isn) &
! #e1&                *(Cn_dSV      *(TsisSV(ikl,ikv,isn) -Tf_Sno         )&
! #e1&                 -LhfH2O      *(1.              -eta_SV(ikl,ikv,isn)))
! #e1   END DO
! #e1   END DO
! #e1 END DO
 
 
! OUTPUT/Verification: Energy/Water Budget: Water  Budget (OUT)
! #e5   DO ikl=1,kcolp
! #e5   DO ikv=1,mwp
! #e5     WqSn_0(ikl,ikv) = WqSn_0(ikl,ikv)                            &
! #e5&                + HLs_sv(ikl,ikv)    * dt__SV                    &
! #e5&             *min(isnoSV(ikl,ikv),1) / Lx_H2O(ikl,ikv)
! #e5     WqSn_1(ikl,ikv) = drr_SV(ikl,ikv)    * dt__SV                &
! #e5&                + rusnSV(ikl,ikv)                                &
! #e5&                + RnofSV(ikl,ikv)    * dt__SV
! #e5   END DO
! #e5   END DO
! #e5 DO   isn=nsnow,1,-1
! #e5   DO ikl=1,kcolp
! #e5   DO ikv=1,mwp
! #e5     WqSn_1(ikl,ikv) = WqSn_1(ikl,ikv)                            &
! #e5&                + ro__SV(ikl,ikv,isn)* dzsnSV(ikl,ikv,isn)
! #e5   END DO
! #e5   END DO
! #e5 END DO
 
 
! OUTPUT/Verification: Energy/Water Budget
! #e5 IF (.NOT.emopen)                                              THEN
! #e5          emopen = .true.
! #e5          open(unit=43,status='unknown',file='SISVAT_qSn.vm')
! #e5          rewind 43
! #e5   write(43,43)
! #e5 43 format('SubRoutine SISVAT_qSn: Local Energy and Water Budgets',&
! #e5&       /,'=====================================================')
! #e5 END IF
! #e5 DO ikl=1,kcolp
! #e5 DO ikv=1,mwp
! #e5 IF (EqSn01(ikl,ikv).gt.1.e-3) write(43,431) dahost,EqSn01(ikl,ikv)
! #e5 431  format(' WARNING (1) in _qSn,',         a18,                &
! #e5&       ': Energy Unbalance in Phase Change = ',e15.6)
! #e5 END DO
! #e5 END DO
! #e5 DO ikl=1,kcolp
! #e5 DO ikv=1,mwp
! #e5 IF (EqSn02(ikl,ikv).gt.1.e-3) write(43,432) dahost,EqSn01(ikl,ikv)
! #e5 432  format(' WARNING (2) in _qSn,',         a18,                &
! #e5&       ': Energy Unbalance in Phase Change = ',e15.6)
! #e5 END DO
! #e5 END DO
! #e5         timeer=timeer + dt__SV
! #e5         hourer=3600.0
! #e5 IF (mod(no_err,11).eq.0)                                      THEN
! #e5         no_err=       1
! #e5   write(43,435)timeer/hourer
! #e5 435    format(11('-'),'----------+-',3('-'),'----------+-',      &
! #e5&          3('-'),'----------+-',3('-'),'----------+-',           &
! #e5&                 '----------------+----------------+',           &
! #e5&       /,f8.2,3x,'EqSn_0(1) | ',3x,'EqSn_d(1) | ',               &
! #e5&              3x,'EqSn_1(1) | ',3x,'EExcsv(1) | ',               &
! #e5&                 'E_0+E_d-E_1-EE  |   Water Budget |',           &
! #e5&       /,11('-'),'----------+-',3('-'),'----------+-',           &
! #e5&          3('-'),'----------+-',3('-'),'----------+-',           &
! #e5&                 '----------------+----------------+')
! #e5 END IF
! #e5 IF (abs(EqSn_0(1)+EqSn_d(1)-EqSn_1(1)-EExcsv(1)).gt.eps6.OR.     &
! #e5&    abs(WqSn_1(1)-WqSn_0(1))                    .gt.eps6    ) THEN
! #e5         no_err=no_err+1
! #e5   write(43,436)   EqSn_0(1),EqSn_d(1)                            &
! #e5&                 ,EqSn_1(1),EExcsv(1)                            &
! #e5&                 ,EqSn_0(1)+EqSn_d(1)-EqSn_1(1)-EExcsv(1)        &
! #e5&                 ,WqSn_1(1)-WqSn_0(1)
! #e5 436    format(8x,f12.0,' + ',f12.0,' - ',f12.0,' - ',f12.3,' = ' &
! #e5&             ,f12.3,'    | ',f15.9)
! #e5 END IF
 
! OUTPUT/Verification: Energy Conservation
! #e1   DO ikl=1,kcolp
! #e1   DO ikv=1,mwp
! #e1     EqSn_d(ikl,ikv) = EqSn_d(ikl,ikv) - EExcsv(ikl,ikv)
! #e1   END DO
! #e1   END DO
 
 
 
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!                                                                      !
! DE-ALLOCATION                                                        !
! =============                                                        !
 
      IF (flagdalloc)                                             THEN !
 
! OUTPUT/Verification: Energy/Water Budget
! #e1 deallocate          ( EqSn_d )                                   ! Energy in Excess, initial
! #e1 deallocate          ( EqSn_0 )                                   ! Snow Energy, befor Phase Change
! #e5 deallocate          ( EqSn01 )                                   ! Snow Energy, after Phase Change
! #e5 deallocate          ( EqSn02 )                                   ! Snow Energy, after Phase Change
                                                                       !              .AND. Last Melting
! #e1 deallocate          ( EqSn_1 )                                   ! Snow Energy, after Phase Change
                                                                       !              .AND. Mass Redistr.
! OUTPUT/Verification: * Mass Conservation
! #m1 deallocate          ( SIsubl )                                   ! Snow Deposed Mass
! #m1 deallocate          ( SImelt )                                   ! Snow Melted  Mass
! #m1 deallocate          ( SIrnof )                                   ! Local Surficial Water + Run OFF
 
      deallocate          ( nosnow )                                   ! Nb of Layers Updater
      deallocate          ( eexdum )                                   ! Energy in Excess when no Snow
      deallocate          ( dzmelt )                                   ! Melted    Thickness          [m]
 
! OUTPUT/Verification: Energy/Water Budget
! #e5 deallocate          ( WqSn_0 )                                   ! Snow Water+Forcing  Initial
! #e5 deallocate          ( WqSn_1 )                                   ! Snow Water+Forcing, Final
 
      END IF                                                           !
!                                                                      !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 
      return
      end subroutine sisvat_qsn
 
 
 
      subroutine sisvat_gsn
 
!--------------------------------------------------------------------------+
!   MAR          SISVAT_GSn                           Wed 26-Jun-2013  MAR |
!     SubRoutine SISVAT_GSn simulates SNOW Metamorphism                    |
!                                                                          |
!     version 3.p.4.1 created by H. Gallee,           Tue  5-Feb-2013      |
!           Last Modification by H. Gallee,           Wed 26-Jun-2013      |
!                                                                          |
!--------------------------------------------------------------------------+
!                                                                          |
!     PARAMETERS:  kcolv: Total Number of columns =                        |
!     ^^^^^^^^^^        = Total Number of continental     grid boxes       |
!                       X       Number of Mosaic Cell per grid box         |
!                                                                          |
!     INPUT /  isnoSV   = total Nb of Ice/Snow Layers                      |
!     OUTPUT:  iiceSV   = total Nb of Ice      Layers                      |
!     ^^^^^^   istoSV   = 0,...,5 :   Snow     History (see istdSV data)   |
!                                                                          |
!     INPUT:   TsisSV   : Soil/Ice Temperatures (layers -nsoil,-nsoil+1, 0)|
!     ^^^^^             & Snow     Temperatures (layers  1,2,...,nsno) [K] |
!              ro__SV   : Soil/Snow Volumic Mass                   [kg/m3] |
!              eta_SV   : Soil/Snow Water   Content                [m3/m3] |
!              slorSV   : Surface Slope                           [radian] |
!              dzsnSV   : Snow Layer        Thickness                  [m] |
!              dt__SV   : Time  Step                                   [s] |
!                                                                          |
!     INPUT /  G1snSV   : Dendricity (<0) or Sphericity (>0) of Snow Layer |
!     OUTPUT:  G2snSV   : Sphericity (>0) or Size            of Snow Layer |
!     ^^^^^^                                                               |
!                                                                          |
!     Formalisme adopte pour la Representation des Grains:                 |
!     Formalism         for the Representation of  Grains:                 |
!     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^                 |
!                                                                          |
!               1       - -1                 Neige Fraiche                 |
!              / \      |                    -------------                 |
!             /   \     |  Dendricite        decrite  par Dendricite       |
!            /     \    |  Dendricity                  et Sphericite       |
!           /       \   |                                                  |
!          2---------3  -  0                 described by Dendricity       |
!                                                     and Sphericity       |
!          |---------|                                                     |
!          0         1                                                     |
!          Sphericite                                                      |
!          Sphericity                                                      |
!                                                                          |
!          4---------5  -                                                  |
!          |         |  |                                                  |
!          |         |  |  Diametre (1/10eme de mm) (ou Taille)            |
!          |         |  |  Diameter (1/10th  of mm) (or Size  )            |
!          |         |  |                                                  |
!          |         |  |                    Neige non dendritique         |
!          6---------7  -                    ---------------------         |
!                                            decrite  par Sphericite       |
!                                                      et     Taille       |
!                                            described by Sphericity       |
!                                                     and       Size       |
!                                                                          |
!     Les Variables du Modele:                                             |
!     Model         Variables:                                             |
!     ^^^^^^^^^^^^^^^^^^^^^^^^                                             |
!       Cas Dendritique               Cas non Dendritique                  |
!                                                                          |
!       G1snSV        : Dendricite    G1snSV        : Sphericite           |
!       G2snSV        : Sphericite    G2snSV        : Taille (1/10e mm)    |
!                                                     Size                 |
!                                                                          |
!     Cas Dendritique/ Dendritic Case                                      |
!     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^                                      |
!     Dendricite(Dendricity) G1snSV                                        |
!              varie     de -G1_dSV (-99 par defaut / etoile)          a 0 |
!              division par -G1_dSV pour obtenir des valeurs entre 1  et 0 |
!              varies  from -G1_dSV (default -99    / fresh snow)     to 0 |
!              division  by -G1_dSV to obtain values       between 1 and 0 |
!                                                                          |
!     Sphericite(Sphericity) G2snSV                                        |
!              varie     de  0         (cas completement anguleux)         |
!                         a  G1_dSV (99 par defaut, cas spherique)         |
!              division par  G1_dSV pour obtenir des valeurs entre 0  et 1 |
!              varies  from  0      (full faceted)               to G1_dSV |
!                                                                          |
!     Cas non Dendritique / non Dendritic Case                             |
!     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^                             |
!     Sphericite(Sphericity) G1snSV                                        |
!              varie     de  0         (cas completement anguleux)         |
!                         a  G1_dSV (99 par defaut, cas spherique)         |
!              division par  G1_dSV pour obtenir des valeurs entre 0  et 1 |
!              varies  from  0      (full faceted)               to G1_dSV |
!                                                                          |
!     Taille    (Size)       G2snSV                                        |
!              superieure a  ADSdSV (.4 mm) et ne fait que croitre         |
!              greater than  ADSdSV (.4 mm) always increases               |
!                                                                          |
!     Exemples: Points caracteristiques des Figures ci-dessus              |
!     ^^^^^^^^^                                                            |
!                                                                          |
!                 G1snSV    G2snSV     dendricite  sphericite  taille      |
!                                      dendricity  sphericity  size        |
!     ------------------------------------------------------------------   |
!                                                              [1/10 mm]   |
!       1        -G1_dSV    sph3SN          1           0.5                |
!       2           0         0             0           0                  |
!       3           0       G1_dSV          0           1                  |
!       4           0       ADSdSV                      0       4.         |
!       5         G1_dSV    ADSdSV-vsphe1               1       3.         |
!       6           0         --                        0       --         |
!       7         G1_dSV      --                        1       --         |
!                                                                          |
!     par defaut: G1_dSV=99.                                               |
!                           sph3SN=50.                                     |
!                           ADSdSV= 4.                                     |
!                                  vsphe1=1.                               |
!                                                                          |
!     Methode:                                                             |
!     ^^^^^^^^                                                             |
!     1. Evolution Types de Grains selon Lois de Brun et al. (1992):       |
!        Grain metamorphism according to         Brun et al. (1992):       |
!        Plusieurs Cas sont a distiguer  /  the different Cases are:       |
!         1.1 Metamorphose Neige humide  /  wet Snow                       |
!         1.2 Metamorphose Neige seche   /  dry Snow                       |
!           1.2.1 Gradient faible        /  low      Temperature Gradient  |
!           1.2.2 Gradient moyen         /  moderate Temperature Gradient  |
!           1.2.3 Gradient fort          /  high     Temperature Gradient  |
!        Dans chaque Cas on separe Neige Dendritique et non Dendritique    |
!                             le Passage Dendritique -> non Dendritique    |
!                             se fait lorsque  G1snSV devient > 0          |
!        the Case of Dentritic or non Dendritic Snow is treated separately |
!        the Limit   Dentritic -> non Dendritic is reached when G1snSV > 0 |
!                                                                          |
!     2. Tassement: Loi de Viscosite adaptee selon le Type de Grains       |
!        Snow Settling:    Viscosity depends on the   Grain Type           |
!                                                                          |
!     3. Update Variables historiques (cas non dendritique seulement)      |
!        nhSNow defaut                                                     |
!                  0    Cas normal                                         |
!        istdSV(1) 1    Grains anguleux / faceted cristal                  |
!        istdSV(2) 2    Grains ayant ete en presence d eau liquide         |
!                       mais n'ayant pas eu de caractere anguleux    /     |
!                       liquid water and no faceted cristals before        |
!        istdSV(3) 3    Grains ayant ete en presence d eau liquide         |
!                       ayant eu auparavant un caractere anguleux    /     |
!                       liquid water and    faceted cristals before        |
!                                                                          |
!     REFER. : Brun et al.      1989, J. Glaciol 35 pp. 333--342           |
!     ^^^^^^^^ Brun et al.      1992, J. Glaciol 38 pp.  13-- 22           |
!              (CROCUS Model, adapted to MAR at CEN by H.Gallee)           |
!                                                                          |
!     REFER. : Marbouty, D.     1980, J. Glaciol 26 pp. xxx--xxx           |
!     ^^^^^^^^ (CROCUS Model, adapted to MAR at CEN by H.Gallee)           |
!              (for angular shapes)                                        |
!                                                                          |
!                                                                          |
!     Preprocessing  Option: SISVAT IO (not always a standard preprocess.) |
!     ^^^^^^^^^^^^^^^^^^^^^  ^^^^^^^^^                                     |
!     FILE                 |      CONTENT                                  |
!     ~~~~~~~~~~~~~~~~~~~~~+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
!   # SISVAT_GSn.vp        | #vp: OUTPUT/Verification: Snow   Properties   |
!                          |      unit 47, SubRoutines SISVAT_zSn, _GSn    |
!   # stdout               | #vs: OUTPUT/Verification: Snow   Properties   |
!                          |      unit  6, SubRoutine  SISVAT_GSn          |
!                                                                          |
!--------------------------------------------------------------------------+
 
 
! Global  Variables
! =================
 
      use mod_real
      use mod_phy____dat
      use mod_phy____grd
      use mod_sisvat_grd
 
 
 
! General Variables
! =================
 
      use mod_sisvat_ctr
      use mod_sisvat_dat
      use mod_sisvat_dzs
      use mod_sisvat_kkl
      use mod_sisvat_gsn
 
 
 
! Local  Variables
! ================
 
      use mod_sisvatlgsn
 
 
      IMPLICIT NONE
 
 
! OUTPUT
! ------
 
! #vp integer           ::  k
 
      logical           ::  vector = .true.                            ! Vectorization  Switch
      integer           ::  ikl,ikv                                    !
      integer           ::  isn   ,isnp                                !
      integer           ::  istoOK                                     !
      real(kind=real8)  ::  G1_bak,G2_bak                              ! Old Values of G1, G2
      real(kind=real8)  ::  dTsndz                                     ! Temperature Gradient
      real(kind=real8)  ::  sWater                                     !        Water Content       [%]
      real(kind=real8)  ::  exp1Wa                                     !
      real(kind=real8)  ::  dDENDR                                     ! Dendricity Increment
      real(kind=real8)  ::  DENDRn                                     ! Normalized Dendricity
      real(kind=real8)  ::  SPHERn                                     ! Normalized Sphericity
      real(kind=real8)  ::  Wet_OK                                     ! Wet Metamorphism Switch
      real(kind=real8)  ::  OK__DE                                     !
      real(kind=real8)  ::  OK__wd                                     ! New G*, from wet Dendritic
      real(kind=real8)  ::  G1__wd                                     ! New G1, from wet Dendritic
      real(kind=real8)  ::  G2__wd                                     ! New G2, from wet Dendritic
      real(kind=real8)  ::  OKlowT                                     !
      real(kind=real8)  ::  facVap                                     !
      real(kind=real8)  ::  OK_ldd                                     !
      real(kind=real8)  ::  G1_ldd                                     !
      real(kind=real8)  ::  G2_ldd                                     !
      real(kind=real8)  ::  DiamGx                                     !
      real(kind=real8)  ::  DiamOK                                     !
      real(kind=real8)  ::  No_Big                                     !
      real(kind=real8)  ::  dSPHER                                     !
      real(kind=real8)  ::  SPHER0                                     !
      real(kind=real8)  ::  SPHbig                                     !
      real(kind=real8)  ::  G1_lds                                     !
      real(kind=real8)  ::  OK_mdT                                     !
      real(kind=real8)  ::  OKmidT                                     !
      real(kind=real8)  ::  OKhigT                                     !
      real(kind=real8)  ::  OK_mdd                                     !
      real(kind=real8)  ::  G1_mdd                                     !
      real(kind=real8)  ::  G2_mdd                                     !
      real(kind=real8)  ::  G1_mds                                     !
      real(kind=real8)  ::  OK_hdd                                     !
      real(kind=real8)  ::  G1_hdd                                     !
      real(kind=real8)  ::  G2_hdd                                     !
      real(kind=real8)  ::  OK_hds                                     !
      real(kind=real8)  ::  G1_hds                                     !
      real(kind=real8)  ::  T1__OK,T2__OK                              !
      real(kind=real8)  ::  T3_xOK,T3__OK,T3_nOK                       !
      real(kind=real8)  ::  ro1_OK,ro2_OK                              !
      real(kind=real8)  ::  dT1_OK,dT2_OK,dT3xOK,dT3_OK                !
      real(kind=real8)  ::  dT4xOK,dT4_OK,dT4nOK,AngSno                !
      real(kind=real8)  ::  G2_hds,SphrOK,HISupd                       !
      real(kind=real8)  ::  H1a_OK,H1b_OK,H1__OK                       !
      real(kind=real8)  ::  H23aOK,H23bOK,H23_OK                       !
      real(kind=real8)  ::  H2__OK,H3__OK                              !
      real(kind=real8)  ::  H45_OK,H4__OK,H5__OK                       !
      real(kind=real8)  ::  ViscSn,OK_Liq,OK_Ang,OKxLiq                !
      real(kind=real8)  ::  dSnMas,dzsnew,rosnew,rosmax                !
 
      real(kind=real8)  ::  epsi5  = 1.0e-5                            ! Alpha ev67 single precision            
      real(kind=real8)  ::  epsi15 = 1.0e-15                           ! Minimal 'dry' Sphericity
!     real(kind=real8)  ::  vdiam1 = 4.0                               ! Small Grains Min.Diam.[.0001m]
      real(kind=real8)  ::  vdiam2 = 0.5                               ! Spher.Variat.Max Diam.    [mm]
      real(kind=real8)  ::  vdiam3 = 3.0                               ! Min.Diam.|Limit Spher.    [mm]
      real(kind=real8)  ::  vdiam4 = 2.0                               ! Min.Diam.|Viscosity Change
      real(kind=real8)  ::  vsphe1 = 1.0                               ! Max Sphericity
      real(kind=real8)  ::  vsphe2 = 1.0e9                             ! Low T Metamorphism  Coeff.
      real(kind=real8)  ::  vsphe3 = 0.5                               ! Max.Sphericity (history=1)
      real(kind=real8)  ::  vsphe4 = 0.1                               ! Min.Sphericity=>history=1
 
! DATA (Coefficient Fonction fort Gradient Marbouty)
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      real(kind=real8)  ::  vtang1 = 40.0                              ! Temperature Contribution v
      real(kind=real8)  ::  vtang2 =  6.0                              !
      real(kind=real8)  ::  vtang3 = 22.0                              !
      real(kind=real8)  ::  vtang4 =  0.7                              !
      real(kind=real8)  ::  vtang5 =  0.3                              !
      real(kind=real8)  ::  vtang6 =  6.0                              !
      real(kind=real8)  ::  vtang7 =  1.0                              !
      real(kind=real8)  ::  vtang8 =  0.8                              !
      real(kind=real8)  ::  vtang9 = 16.0                              !
      real(kind=real8)  ::  vtanga =  0.2                              !
      real(kind=real8)  ::  vtangb =  0.2                              !
      real(kind=real8)  ::  vtangc = 18.0                              ! Temperature Contribution ^
 
      real(kind=real8)  ::  vrang1 =  0.40                             ! Density     Contribution v
      real(kind=real8)  ::  vrang2 =  0.15                             ! Density     Contribution ^
 
      real(kind=real8)  ::  vgang1 =  0.70                             ! Grad(T)     Contribution v
      real(kind=real8)  ::  vgang2 =  0.25                             !
      real(kind=real8)  ::  vgang3 =  0.40                             !
      real(kind=real8)  ::  vgang4 =  0.50                             !
      real(kind=real8)  ::  vgang5 =  0.10                             !
      real(kind=real8)  ::  vgang6 =  0.15                             !
      real(kind=real8)  ::  vgang7 =  0.10                             !
      real(kind=real8)  ::  vgang8 =  0.55                             !
      real(kind=real8)  ::  vgang9 =  0.65                             !
      real(kind=real8)  ::  vganga =  0.20                             !
      real(kind=real8)  ::  vgangb =  0.85                             !
      real(kind=real8)  ::  vgangc =  0.15                             ! Grad(T)     Contribution ^
 
      real(kind=real8)  ::  vgran6 = 51.                               ! Max.Sphericity for Settling
      real(kind=real8)  ::  vtelv1 =  5.e-1                            ! Threshold | history = 2, 3
      real(kind=real8)  ::   vvap1 = -6.e3                             ! Vapor Pressure Coefficient
      real(kind=real8)  ::   vvap2 =  0.4                              ! Vapor Pressure Exponent
      real(kind=real8)  ::  vgrat1 =  0.05                             ! Boundary weak/mid   grad(T)
      real(kind=real8)  ::  vgrat2 =  0.15                             ! Boundary mid/strong grad(T)
      real(kind=real8)  ::     vfi =  0.09                             ! PHI,         strong grad(T)
 
      real(kind=real8)  ::  vvisc1 =   0.70                            ! Viscosity Coefficients
      real(kind=real8)  ::  vvisc2 =   1.11e5                          !
      real(kind=real8)  ::  vvisc3 =  23.00                            !
      real(kind=real8)  ::  vvisc4 =   0.10                            ! Viscosity Coefficients
      real(kind=real8)  ::  vvisc5 =   1.00                            ! Viscosity Coefficients, wet Snow
      real(kind=real8)  ::  vvisc6 =   2.00                            ! Viscosity Coefficients, wet Snow
      real(kind=real8)  ::  vvisc7 =  10.00                            ! Viscosity Coefficients, wet Snow
      real(kind=real8)  ::  rovisc =   0.25                            ! Wet Snow Density  Influence
      real(kind=real8)  ::    vdz3 =   0.30                            ! Maximum Layer Densification
 
      real(kind=real8)  ::  OK__ws                                     ! New G2
      real(kind=real8)  ::  G1__ws                                     ! New G1, from wet Spheric
      real(kind=real8)  ::  G2__ws                                     ! New G2, from wet Spheric
      real(kind=real8)  ::  husi_0 =  20.                              ! Constant for New G2:   10  * 2
      real(kind=real8)  ::  husi_1 =   0.23873                         ! Constant for New G2: (3/4) /pi
      real(kind=real8)  ::  husi_2 =   4.18880                         ! Constant for New G2: (4/3) *pi
      real(kind=real8)  ::  husi_3 =   0.33333                         ! Constant for New G2:  1/3
      real(kind=real8)  ::  vtail1 =   1.28e-08                        ! Constant for New G2:  Wet Metamorphism
      real(kind=real8)  ::  vtail2 =   4.22e-10                        ! Constant for New G2: (NON Dendritic / Spheric)
      real(kind=real8)  ::  frac_j                                     ! Time Step            [Day]
 
      real(kind=real8)  ::   vdent1 =  2.e8                            ! Wet Snow Metamorphism
      integer           ::  nvdent1 =  3                               ! (Coefficients for
      integer           ::  nvdent2 = 16                               !           Dendricity)
 
 
 
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!                                                                      !
! ALLOCATION                                                           !
! ==========                                                           !
 
      IF (it_run.EQ.1 .OR. flagdalloc)                            THEN !
 
      allocate            ( ro_dry(kcolp,mwp,nsnow) )                  ! Dry Density            [g/cm3]
      allocate            ( etasno(kcolp,mwp,nsnow) )                  ! Liquid Water Content   [g/cm2]
      allocate            ( snmass(kcolp,mwp)       )                  ! Snow   Mass            [kg/m2]
 
      END IF                                                           !
!                                                                      !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 
 
!  1. Metamorphoses dans les Strates
!     Metamorphism
!     ==============================
 
      frac_j = dt__sv / 86400.                        ! Time Step [Day]
 
 
!  1.1 Initialisation: teneur en eau liquide et gradient de temperature
!  ------------------  liquid water content and temperature gradient
 
      DO   isn=1,nsnow
        DO ikl=1,kcolp
        DO ikv=1,mwp
          ro_dry(ikl,ikv,isn) = 1.e-3 *ro__sv(ikl,ikv,isn)   &! Dry Density
     &                    *(1.    -eta_sv(ikl,ikv,isn))   !         [g/cm3]
          etasno(ikl,ikv,isn) = 1.e-1 *dzsnsv(ikl,ikv,isn)   &! Liquid Water
     &                    *        ro__sv(ikl,ikv,isn)   &! Content [g/cm2]
     &                    *        eta_sv(ikl,ikv,isn)!
        END DO
        END DO
      END DO
 
      DO   isn=1,nsnow
        DO ikl=1,kcolp
        DO ikv=1,mwp
 
          isnp   = min(isn+1,isnosv(ikl,ikv))
 
          dtsndz = abs( (tsissv(ikl,ikv,isnp)-tsissv(ikl,ikv,isn-1)) *2.e-2&
     &            /max(((dzsnsv(ikl,ikv,isnp)+dzsnsv(ikl,ikv,isn)  )   &
     &                 *(           isnp -           isn)              &
     &                 +(dzsnsv(ikl,ikv,isn )+dzsnsv(ikl,ikv,isn-1))),eps6))
!         Factor 1.d-2 for Conversion K/m --> K/cm
 
 
!  1.2 Metamorphose humide
!      Wet Snow Metamorphism
!      ---------------------
 
          wet_ok = max(zer0,sign(un_1,eta_sv(ikl,ikv,isn)-eps6))
 
 
!      Vitesse de diminution de la dendricite
!      Rate of the dendricity decrease
!      ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
          swater=1.d-1*ro__sv(ikl,ikv,isn)*eta_sv(ikl,ikv,isn)         &
     &       /max(eps6,ro_dry(ikl,ikv,isn))
! .    sWater:Water Content [%]
!             1.d-1= 1.d2(1->%) * 1.d-3(ro__SV*eta_SV:kg/m3->g/cm3)
 
          exp1wa=   swater**nvdent1
          ddendr=max(exp1wa/nvdent2,vdent1*exp(vvap1/tf_sno))
 
!  1.2.1 Cas dendritique/dendritic Case
!        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
          ok__wd=max(zer0,                           &!
     &               sign(un_1,-g1snsv(ikl,ikv,isn)  &!
     &                         -eps6           ))     !
 
          dendrn=-g1snsv(ikl,ikv,isn)/g1_dsv  ! Normalized Dendricity (+)
          sphern= g2snsv(ikl,ikv,isn)/g1_dsv  ! Normalized Sphericity
          dendrn= dendrn -ddendr *frac_j  ! New        Dendricity (+)
          sphern= sphern +ddendr *frac_j  ! New        Sphericity
 
          ok__de=max(zer0,                           &! IF 1.,
     &               sign(un_1, dendrn               &! NO change
     &                         -eps6           ))     ! Dendr. -> Spheric
 
          g1__wd=ok__de *    (      -dendrn*g1_dsv)  &! Dendritic
     &      +(1.-ok__de)* min(g1_dsv,sphern*g1_dsv)   ! Dendr. -> Spheric
          g2__wd=ok__de * min(g1_dsv,sphern*g1_dsv)  &! Spheric
     &      +(1.-ok__de)*(adsdsv-min(sphern,vsphe1))  ! Spher. -> Size
 
!  1.2.2 Cas non dendritique non completement spherique
!        Evolution de la Sphericite seulement.
!        Non dendritic and not completely spheric Case
!        Evolution of    Sphericity only (not size)
!        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
          ok__ws=max(zer0,                           &!
     &               sign(un_1, g1_dsv               &!
     &                         -epsi5                &!
     &                         -g1snsv(ikl,ikv,isn))) !
 
          sphern= g1snsv(ikl,ikv,isn)/g1_dsv
          sphern= sphern +ddendr *frac_j
          g1__ws=         min(g1_dsv,sphern*g1_dsv)
 
!  1.2.3 Cas non dendritique et spherique / non dendritic and spheric
!        Evolution de la Taille seulement / Evolution of Size only
!        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
          g2__ws =  husi_0                                             &
     &           *( husi_1                                             &
     &            *(husi_2 *( g2snsv(ikl,ikv,isn)/husi_0)**3           &
     &                      +(vtail1 +vtail2 *exp1wa    )*dt__sv))     &
     &           ** husi_3
 
 
!  1.3 Metamorposes seches / Dry Metamorphism
!      --------------------------------------
 
 
!  1.3.1 Calcul Metamorphose faible/low Gradient (0.00-0.05 deg/cm)
!        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
          oklowt=max(zer0,                           &!
     &               sign(un_1, vgrat1               &!
     &                         -dtsndz         ))     !
 
          facvap=exp(vvap1/tsissv(ikl,ikv,isn))
 
!  1.3.1.1 Cas dendritique / dendritic Case
 
          ok_ldd=max(zer0,                           &!
     &               sign(un_1,-g1snsv(ikl,ikv,isn)  &!
     &                         -eps6           ))     !
 
          dendrn=-g1snsv(ikl,ikv,isn)     /g1_dsv
          sphern= g2snsv(ikl,ikv,isn)     /g1_dsv
          dendrn= dendrn-vdent1*facvap*frac_j
          sphern= sphern+vsphe2*facvap*frac_j
 
          ok__de=max(zer0,                           &! IF 1.,
     &               sign(un_1, dendrn               &! NO change
     &                         -eps6           ))     ! Dendr. -> Spheric
 
          g1_ldd= ok__de *    (      -dendrn*g1_dsv) &! Dendritic
     &       +(1.-ok__de)* min(g1_dsv,sphern*g1_dsv)  ! Dendr. -> Spheric
          g2_ldd= ok__de * min(g1_dsv,sphern*g1_dsv) &! Spheric
     &       +(1.-ok__de)*(adsdsv-min(sphern,vsphe1)) ! Spher. -> Size
 
!  1.3.1.2 Cas non dendritique / non dendritic Case
 
          sphern=g1snsv(ikl,ikv,isn)/g1_dsv
          diamgx=g2snsv(ikl,ikv,isn)*0.1
 
          istook=min( abs(istosv(ikl,ikv,isn)-       &!
     &                    istdsv(1)      ),1)         ! zero if istoSV = 1
          diamok=max(zer0,  sign(un_1,vdiam2-diamgx))
          no_big=    istook+diamok
          no_big=min(no_big,un_1)
 
          dspher=           vsphe2*facvap*frac_j      !
          spher0=    sphern+dspher                    ! small grains
          sphbig=    sphern+dspher                   &! big   grains
     &        *exp(min(zer0,vdiam3-g2snsv(ikl,ikv,isn)))  ! (history = 2 or 3)
          sphbig=       min(vsphe3,sphbig)            ! limited sphericity
          sphern= no_big *  spher0                   &!
     &      + (1.-no_big)*  sphbig                    !
 
! HG v Precudes underflow
          sphern=       max(epsi15,sphern)            !
! HG ^ Precudes underflow
 
          g1_lds=       min(g1_dsv,sphern*g1_dsv)     !
 
!  1.3.2 Calcul Metamorphose Gradient Moyen/Moderate (0.05-0.15)
!        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
          ok_mdt=max(zer0,                           &!
     &               sign(un_1, vgrat2               &!
     &                         -dtsndz))              !
          okmidt=               ok_mdt  *(1.-oklowt)  !
          okhigt=          (1. -ok_mdt) *(1.-oklowt)  !
 
          facvap=vdent1*exp(vvap1/tsissv(ikl,ikv,isn))   &!
     &                 *   (1.e2 *dtsndz)**vvap2      !
 
!  1.3.2.1 cas dendritique / dendritic case.
 
          ok_mdd=max(zer0,                           &!
     &               sign(un_1,-g1snsv(ikl,ikv,isn)  &!
     &                         -eps6           ))     !
 
          dendrn=-g1snsv(ikl,ikv,isn)/g1_dsv
          sphern= g2snsv(ikl,ikv,isn)/g1_dsv
          dendrn= dendrn - facvap*frac_j
          sphern= sphern - facvap*frac_j
 
          ok__de=max(zer0,                           &! IF 1.,
     &               sign(un_1, dendrn               &! NO change
     &                         -eps6           ))     ! Dendr. -> Spheric
 
          g1_mdd= ok__de *    (      -dendrn*g1_dsv) &! Dendritic
     &       +(1.-ok__de)* max(zer0  ,sphern*g1_dsv)  ! Dendr. -> Spheric
          g2_mdd= ok__de * max(zer0  ,sphern*g1_dsv) &! Spheric
     &       +(1.-ok__de)*(adsdsv-max(sphern,zer0  )) ! Spher. -> Size
 
!  1.3.2.2 Cas non dendritique / non dendritic Case
 
          sphern=g1snsv(ikl,ikv,isn)/g1_dsv
          sphern=         sphern-facvap*frac_j
          g1_mds=max(zer0,sphern*g1_dsv)
 
!  1.3.3 Calcul Metamorphose fort / high Gradient
!  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
          facvap=vdent1*exp(vvap1/tsissv(ikl,ikv,isn))   &!
     &                 *   (1.e2 *dtsndz)**vvap2      !
 
!  1.3.3.1 Cas dendritique / dendritic Case
 
          ok_hdd=max(zer0,                           &!
     &               sign(un_1,-g1snsv(ikl,ikv,isn)  &!
     &                         -eps6           ))     !
 
          dendrn=-g1snsv(ikl,ikv,isn)/g1_dsv          !
          sphern= g2snsv(ikl,ikv,isn)/g1_dsv          !
          dendrn= dendrn - facvap*frac_j              !
          sphern= sphern - facvap*frac_j              ! Non dendritic
                                                      ! and angular
          ok__de=max(zer0,                           &! IF 1.,
     &               sign(un_1, dendrn               &! NO change
     &                         -eps6  ))              ! Dendr. -> Spheric
 
          g1_hdd= ok__de *    (      -dendrn*g1_dsv) &! Dendritic
     &       +(1.-ok__de)* max(zer0  ,sphern*g1_dsv)  ! Dendr. -> Spheric
          g2_hdd= ok__de * max(zer0  ,sphern*g1_dsv) &! Spheric
     &       +(1.-ok__de)*(adsdsv-max(sphern,zer0  )) ! Spher. -> Size
 
!  1.3.3.2 Cas non dendritique non completement anguleux.
!          non dendritic and spericity gt. 0
 
          ok_hds=max(zer0,                           &!
     &               sign(un_1, g1snsv(ikl,ikv,isn)  &!
     &                         -eps6           ))     !
 
          sphern= g1snsv(ikl,ikv,isn)/g1_dsv
          sphern= sphern - facvap*frac_j
          g1_hds= max(zer0,sphern*g1_dsv)
 
!  1.3.3.3 Cas non dendritique et anguleux
!          dendritic and spericity = 0.
 
          t1__ok = max(zer0,sign(un_1,tsissv(ikl,ikv,isn)-tf_sno+vtang1))
          t2__ok = max(zer0,sign(un_1,tsissv(ikl,ikv,isn)-tf_sno+vtang2))
          t3_xok = max(zer0,sign(un_1,tsissv(ikl,ikv,isn)-tf_sno+vtang3))
          t3__ok =                    t3_xok  * (1. - t2__ok)
          t3_nok =              (1. - t3_xok) * (1. - t2__ok)
          ro1_ok = max(zer0,sign(un_1,vrang1-ro_dry(ikl,ikv,isn)))
          ro2_ok = max(zer0,sign(un_1,ro_dry(ikl,ikv,isn)-vrang2))
          dt1_ok = max(zer0,sign(un_1,vgang1-dtsndz         ))
          dt2_ok = max(zer0,sign(un_1,vgang2-dtsndz         ))
          dt3xok = max(zer0,sign(un_1,vgang3-dtsndz         ))
          dt3_ok =                    dt3xok  * (1. - dt2_ok)
          dt4xok = max(zer0,sign(un_1,vgang4-dtsndz         ))
          dt4_ok =                    dt4xok  * (1. - dt3_ok)          &
     &                                        * (1. - dt2_ok)
          dt4nok =              (1. - dt4xok) * (1. - dt3_ok)          &
     &                                        * (1. - dt2_ok)
 
!  Influence de la Temperature /Temperature Influence
!  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
          angsno =                                                     &
     &      t1__ok                                                     & ! 11
     &    *(t2__ok*(vtang4+vtang5*(tf_sno       -tsissv(ikl,ikv,isn))  & ! 12
     &                    /vtang6)                                     & !
     &     +t3__ok*(vtang7-vtang8*(tf_sno-vtang2-tsissv(ikl,ikv,isn))  & ! 13
     &                    /vtang9)                                     & !
     &     +t3_nok*(vtanga-vtangb*(tf_sno-vtang3-tsissv(ikl,ikv,isn))  & ! 14
     &                    /vtangc))                                    & !
 
!  Influence de la Masse Volumique /Density Influence
!  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
     &    * ro1_ok                                                     & !
     &        *(   ro2_ok*(1. - (ro_dry(ikl,ikv,isn)-vrang2)           & !
     &                                  /(vrang1-vrang2))              & !
     &         +1.-ro2_ok                                )             & !
 
!  Influence du Gradient de Temperature /Temperature Gradient Influence
!  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
     &        *(   dt1_ok*(dt2_ok*vgang5*(dtsndz-vgang6)               & ! 15
     &                                  /(vgang2-vgang6)               & !
     &                    +dt3_ok*vgang7                               & ! 16
     &                    +dt4_ok*vgang9                               & ! 17
     &                    +dt4nok*vgangb                )              & ! 18
     &         +1.-dt1_ok                                )             & !
     &    + ro1_ok                                                     & !
     &        *    dt1_ok*(dt3_ok*vgang8*(dtsndz-vgang2)               & !
     &                                  /(vgang3-vgang2)               & !
     &                    +dt4_ok*vganga*(dtsndz-vgang3)               & !
     &                                  /(vgang4-vgang3)               & !
     &                    +dt4nok*vgangc*(dtsndz-vgang4)               & !
     &                                  /(vgang1-vgang4))                !
 
          g2_hds = g2snsv(ikl,ikv,isn) + 1.d2 *angsno*vfi     *frac_j
 
 
! New Properties
! --------------
 
          g1_bak          = g1snsv(ikl,ikv,isn)
          g2_bak          = g2snsv(ikl,ikv,isn)
 
          g1snsv(ikl,ikv,isn) = wet_ok * (    ok__wd             *g1__wd   & !  1
     &                               +(1.-ok__wd)*    ok__ws *g1__ws   & !  2
     &                               +(1.-ok__wd)*(1.-ok__ws)*g1_bak)  & !  3
     &               +(1. - wet_ok)                                    & !
     &                *(    oklowt  *(    ok_ldd             *g1_ldd   & !  4
     &                               +(1.-ok_ldd)            *g1_lds)  & !  5
     &                    + okmidt  *(    ok_mdd             *g1_mdd   & !  6
     &                               +(1.-ok_mdd)            *g1_mds)  & !  7
     &                    + okhigt  *(    ok_hdd             *g1_hdd   & !  8
     &                               +(1.-ok_hdd)*    ok_hds *g1_hds   & !  9
     &                               +(1.-ok_hdd)*(1.-ok_hds)*g1_bak))   ! 10
 
! XF
          IF (g1snsv(ikl,ikv,isn).GE.0.0.AND.g1snsv(ikl,ikv,isn)<0.1)  & !
! HG -------------------------^^^^^^
     &        g2_hds = g2snsv(ikl,ikv,isn) + 1.d1 *angsno*vfi    *frac_j !
!             Previens chute exageree de l'albedo lorsque G1~0.
! XF
 
          g2snsv(ikl,ikv,isn) = wet_ok * (    ok__wd             *g2__wd   & !  1
     &                               +(1.-ok__wd)*    ok__ws *g2_bak   & !  2
     &                               +(1.-ok__wd)*(1.-ok__ws)*g2__ws)  & !  3
     &               +(1. - wet_ok)                                    & !
     &                *(    oklowt  *(    ok_ldd             *g2_ldd   & !  4
     &                               +(1.-ok_ldd)            *g2_bak)  & !  5
     &                    + okmidt  *(    ok_mdd             *g2_mdd   & !  6
     &                               +(1.-ok_mdd)            *g2_bak)  & !  7
     &                    + okhigt  *(    ok_hdd             *g2_hdd   & !  8
     &                               +(1.-ok_hdd)*    ok_hds *g2_bak   & !  9
     &                               +(1.-ok_hdd)*(1.-ok_hds)*g2_hds))   ! 10
 
! OUTPUT/Verification: Snow Layers Agregation: Properties
! #vp     G_curr( 1) =     Wet_OK             *    OK__wd
! #vp     G_curr( 2) =     Wet_OK             *(1.-OK__wd)*    OK__ws
! #vp     G_curr( 3) =     Wet_OK             *(1.-OK__wd)*(1.-OK__ws)
! #vp     G_curr( 4) = (1.-Wet_OK)*    OKlowT *    OK_ldd
! #vp     G_curr( 5) = (1.-Wet_OK)*    OKlowT *(1.-OK_ldd)
! #vp     G_curr( 6) = (1.-Wet_OK)*    OKmidT *    OK_mdd
! #vp     G_curr( 7) = (1.-Wet_OK)*    OKmidT *(1.-OK_mdd)
! #vp     G_curr( 8) = (1.-Wet_OK)*    OKhigT *    OK_hdd
! #vp     G_curr( 9) = (1.-Wet_OK)*    OKhigT *(1.-OK_hdd)*    OK_hds
! #vp     G_curr(10) = (1.-Wet_OK)*    OKhigT *(1.-OK_hdd)*(1.-OK_hds)
! #vp     G_curr(11) =     T1__OK                         * G_curr(10)
! #vp     G_curr(12) =     T2__OK                         * G_curr(10)
! #vp     G_curr(13) =     T3__OK                         * G_curr(10)
! #vp     G_curr(14) =     T3_nOK                         * G_curr(10)
! #vp     G_curr(15) =     ro1_OK*     dT1_OK *    dT2_OK * G_curr(10)
! #vp     G_curr(16) =     ro1_OK*     dT1_OK *    dT3_OK * G_curr(10)
! #vp     G_curr(17) =     ro1_OK*     dT1_OK *    dT4_OK * G_curr(10)
! #vp     G_curr(18) =     ro1_OK*     dT1_OK *    dT4nOK * G_curr(10)
 
! #vp     Gcases( 1) = max(Gcases( 1),G_curr( 1))
! #vp     Gcases( 2) = max(Gcases( 2),G_curr( 2))
! #vp     Gcases( 3) = max(Gcases( 3),G_curr( 3))
! #vp     Gcases( 4) = max(Gcases( 4),G_curr( 4))
! #vp     Gcases( 5) = max(Gcases( 5),G_curr( 5))
! #vp     Gcases( 6) = max(Gcases( 6),G_curr( 6))
! #vp     Gcases( 7) = max(Gcases( 7),G_curr( 7))
! #vp     Gcases( 8) = max(Gcases( 8),G_curr( 8))
! #vp     Gcases( 9) = max(Gcases( 9),G_curr( 9))
! #vp     Gcases(10) = max(Gcases(10),G_curr(10))
! #vp     Gcases(11) = max(Gcases(11),G_curr(11))
! #vp     Gcases(12) = max(Gcases(12),G_curr(12))
! #vp     Gcases(13) = max(Gcases(13),G_curr(13))
! #vp     Gcases(14) = max(Gcases(14),G_curr(14))
! #vp     Gcases(15) = max(Gcases(15),G_curr(15))
! #vp     Gcases(16) = max(Gcases(16),G_curr(16))
! #vp     Gcases(17) = max(Gcases(17),G_curr(17))
! #vp     Gcases(18) = max(Gcases(18),G_curr(18))
 
! #vp     IF          (isn    .le.     isnoSV(ikl,ikv))                &
! #vp&    write(47,471)isn            ,isnoSV(ikl,ikv)                    ,&
! #vp&                 TsisSV(ikl,ikv,isn),ro__SV(ikl,ikv,isn),eta_SV(ikl,ikv,isn),&
! #vp&                 G1_bak         ,G2_bak         ,istoSV(ikl,ikv,isn),&
! #vp&                 dTsndz,                                         &
! #vp&                (       k ,k=1,18),                              &
! #vp&                (G_curr(k),k=1,18),                              &
! #vp&                (Gcases(k),k=1,18),                              &
! #vp&                 Wet_OK,OK__wd,G1__wd,G2__wd,                    &
! #vp&                     1.-OK__wd,OK__ws,G1__ws,1.-OK__ws,G2__ws,   &
! #vp&              1.-Wet_OK,OKlowT,OK_ldd,G1_ldd,          G2_ldd,   &
! #vp&                            1.-OK_ldd,G1_lds,                    &
! #vp&                        OKmidT,OK_mdd,G1_mdd,          G1_mdd,   &
! #vp&                            1.-OK_mdd,G1_mds,                    &
! #vp&                        OKhigT,OK_hdd,G1_hdd,          G2_hdd,   &
! #vp&                            1.-OK_hdd,OK_hds,          G1_hds,   &
! #vp&                                             1.-OK_hds,G2_hds,   &
! #vp&                 G1snSV(ikl,ikv,isn),                            &
! #vp&                 G2snSV(ikl,ikv,isn)
! #vp 471 format(                                                      &
! #vp&         /,' isn     =  ',i4,6x,'(MAX.:',i4,')',                 &
! #vp&         /,' T       =  ',f8.3,                                  &
! #vp&         /,' ro      =  ',f8.3,                                  &
! #vp&         /,' eta     =  ',f8.3,                                  &
! #vp&         /,' G1      =  ',f8.3,                                  &
! #vp&         /,' G2      =  ',f8.3,                                  &
! #vp&         /,' Histor. =  ',i4  ,                                  &
! #vp&         /,' Grad(T) =  ',f8.3,'                   ' ,18i3  ,    &
! #vp&/,         '                       Current    Case: ',18f3.0,    &
! #vp&/,         '                       Cases performed: ',18f3.0,    &
! #vp&/,' ------------------------------------------------------------',&
! #vp&             '-----------+------------------+------------------+',&
! #vp&/,' Status                                                      ',&
! #vp&             '           | G1               | G2               |',&
! #vp&/,' ------------------------------------------------------------',&
! #vp&             '-----------+------------------+------------------+',&
! #vp&/,'    Wet_OK: ',f8.3,'                  OK__wd: ',f8.3,'       ',&
! #vp&             '           | G1__wd: ',f8.3,' | G2__wd: ',f8.5,' |',&
! #vp&/,'                                   1.-OK__wd: ',f8.3,' OK__ws',&
! #vp&             ': ',f8.3,' | G1__ws: ',f8.3,' |                  |',&
! #vp&/,'                                                    1.-OK__ws',&
! #vp&             ': ',f8.3,' |                  | G2__ws: ',f8.5,' |',&
! #vp&/,' 1.-Wet_OK: ',f8.3,' OKlowT: ',f8.3,' OK_ldd: ',f8.3,'       ',&
! #vp&             '           | G1_ldd: ',f8.3,' | G2_ldd: ',f8.5,' |',&
! #vp&/,'                                   1.-OK_ldd: ',f8.3,'       ',&
! #vp&             '           | G1_lds: ',f8.3,' |                  |',&
! #vp&/,'                     OKmidT: ',f8.3,' OK_mdd: ',f8.3,'       ',&
! #vp&             '           | G1_mdd: ',f8.3,' | G2_mdd: ',f8.5,' |',&
! #vp&/,'                                   1.-OK_mdd: ',f8.3,'       ',&
! #vp&             '           | G1_mds: ',f8.3,' |                  |',&
! #vp&/,'                     OKhigT: ',f8.3,' OK_hdd: ',f8.3,'       ',&
! #vp&             '           | G1_hdd: ',f8.3,' | G2_hdd: ',f8.5,' |',&
! #vp&/,'                                   1.-OK_hdd: ',f8.3,' OK_hds',&
! #vp&             ': ',f8.3,' | G1_hds: ',f8.3,' |                  |',&
! #vp&/,'                                                    1.-OK_hds',&
! #vp&             ': ',f8.3,' |                  | G2_hds: ',f8.5,' |',&
! #vp&/,' ------------------------------------------------------------',&
! #vp&             '-----------+------------------+------------------+',&
! #vp&/,'                                                             ',&
! #vp&             '           |         ',f8.3,' |         ',f8.5,' |',&
! #vp&/,' ------------------------------------------------------------',&
! #vp&             '-----------+------------------+------------------+')
        END DO
        END DO
      END DO
 
 
!  2. Mise a Jour Variables Historiques (Cas non dendritique)
!     Update of the historical Variables
!     =======================================================
 
      IF (vector)                                                   THEN
        DO isn=1,nsnow
        DO ikl=1,kcolp
        DO ikv=1,mwp
 
          sphrok = max(zer0,sign(un_1,       g1snsv(ikl,ikv,isn)))
          h1a_ok = max(zer0,sign(un_1,vsphe4-g1snsv(ikl,ikv,isn)))
          h1b_ok =     1   - min(1   ,       istosv(ikl,ikv,isn))
          h1__ok =                    h1a_ok*h1b_ok
          h23aok = max(zer0,sign(un_1,vsphe4-g1_dsv                    &
     &                                      +g1snsv(ikl,ikv,isn)))
          h23bok = max(zer0,sign(un_1,etasno(ikl,ikv,isn)              &
     &                      /max(eps6,dzsnsv(ikl,ikv,isn))             &
     &                                      -vtelv1         ))
          h23_ok =                    h23aok*h23bok
          h2__ok =     1   - min(1   ,       istosv(ikl,ikv,isn))
          h3__ok =     1   - min(1   ,   abs(istosv(ikl,ikv,isn)-istdsv(1)))
          h45_ok = max(zer0,sign(un_1,tf_sno-tsissv(ikl,ikv,isn)+eps6))
          h4__ok =     1   - min(1   ,   abs(istosv(ikl,ikv,isn)-istdsv(2)))
          h5__ok =     1   - min(1   ,   abs(istosv(ikl,ikv,isn)-istdsv(3)))
 
          hisupd          =                                            &
     &    sphrok*(h1__ok                             *istdsv(1)        &
     &       +(1.-h1__ok)*    h23_ok         *(h2__ok*istdsv(2)        &
     &                                        +h3__ok*istdsv(3))       &
     &       +(1.-h1__ok)*(1.-h23_ok) *h45_ok*(h4__ok*istdsv(4)        &
     &                                        +h5__ok*istdsv(5)))
          istosv(ikl,ikv,isn)=int(hisupd) +                            &
     &        int(1.-min(un_1,hisupd))               *istosv(ikl,ikv,isn)
        END DO
        END DO
        END DO
      ELSE
 
 
!  2. Mise a Jour Variables Historiques (Cas non dendritique)
!     Update of the historical Variables
!     =======================================================
 
        DO ikl=1,kcolp
        DO ikv=1,mwp
        DO isn=iicesv(ikl,ikv),isnosv(ikl,ikv)
          IF  (g1snsv(ikl,ikv,isn).ge.0.)                           THEN
            IF(g1snsv(ikl,ikv,isn).lt.vsphe4.and.istosv(ikl,ikv,isn).eq.0)  THEN
                   istosv(ikl,ikv,isn)=istdsv(1)
            ELSEIF(g1_dsv-g1snsv(ikl,ikv,isn)         .lt.vsphe4.and.  &
     &             etasno(ikl,ikv,isn)/dzsnsv(ikl,ikv,isn).gt.vtelv1)   THEN
              IF  (istosv(ikl,ikv,isn).eq.0)                           &
     &             istosv(ikl,ikv,isn)=   istdsv(2)
              IF  (istosv(ikl,ikv,isn).eq.istdsv(1))                   &
     &             istosv(ikl,ikv,isn)=   istdsv(3)
            ELSEIF(tsissv(ikl,ikv,isn).lt.tf_sno)                   THEN
              IF  (istosv(ikl,ikv,isn).eq.istdsv(2))                   &
     &             istosv(ikl,ikv,isn)=   istdsv(4)
              IF  (istosv(ikl,ikv,isn).eq.istdsv(3))                   &
     &             istosv(ikl,ikv,isn)=   istdsv(5)
            END IF
          END IF
        END DO
        END DO
        END DO
      END IF
 
 
!  3. Tassement mecanique /mechanical Settlement
!     ==========================================
 
        DO ikl=1,kcolp
        DO ikv=1,mwp
          snmass(ikl,ikv) = 0.
        END DO
        END DO
      DO isn=nsnow,1,-1
        DO ikl=1,kcolp
        DO ikv=1,mwp
          dsnmas     = 100.*dzsnsv(ikl,ikv,isn)*ro_dry(ikl,ikv,isn)
          snmass(ikl,ikv)=      snmass(ikl,ikv)+0.5*dsnmas
          viscsn     =      vvisc1         *vvisc2                     &
     &               *exp(vvisc3           *ro_dry(ikl,ikv,isn)        &
     &                   +vvisc4*abs(tf_sno-tsissv(ikl,ikv,isn)))      &
     &                                     *ro_dry(ikl,ikv,isn)/rovisc
 
!  Changement de Viscosite si Teneur en Eau liquide
!  Change of the Viscosity if liquid Water Content
!  ------------------------------------------------
 
          ok_liq     =    max(zer0,sign(un_1,etasno(ikl,ikv,isn)-eps6))
          ok_ang     =    max(zer0,sign(un_1,vgran6-g1snsv(ikl,ikv,isn)))  &
     &                *(1-min(1   , abs(istosv(ikl,ikv,isn)-istdsv(1))))
 
! OUTPUT/Verification: Snow   Properties
! #vs     IF (G1snSV(ikl,ikv,isn).gt.0..AND.G1snSV(ikl,ikv,isn).lt.vsphe4  &
! #vs&                             .AND.istoSV(ikl,ikv,isn).eq.     0) &
! #vs&    THEN
! #vs       write(6,*) ikl,ikv,isn,' G1,G2,hist,OK_Ang  ',             &
! #vs&          G1snSV(ikl,ikv,isn), G2snSV(ikl,ikv,isn),istoSV(ikl,ikv,isn),OK_Ang
! #vs       stop "Grains anguleux mal d?finis"
! #vs     END IF
 
          okxliq     =    max(zer0,sign(un_1,vtelv1-etasno(ikl,ikv,isn)&
     &                                    /max(eps6,dzsnsv(ikl,ikv,isn)))) &
     &               *    max(0   ,sign(1   ,istosv(ikl,ikv,isn)       &
     &                                      -istdsv(1)      ))
          viscsn     =                                                 &
     &    viscsn*(    ok_liq/(vvisc5+vvisc6*etasno(ikl,ikv,isn)        &
     &                            /max(eps6,dzsnsv(ikl,ikv,isn)))      &
     &           +(1.-ok_liq)                               )          &
     &          *(    ok_ang*exp(min(adsdsv,g2snsv(ikl,ikv,isn)-vdiam4))   &
     &           +(1.-ok_ang)                                       )  &
     &          *(    okxliq*        vvisc7                            &
     &           +(1.-okxliq)              )
 
 
!  Calcul nouvelle Epaisseur / new Thickness
!  -----------------------------------------
 
          dzsnew         =                                             &
     &    dzsnsv(ikl,ikv,isn)                                          &
     &     *max(vdz3,                                                  &
     &         (un_1-dt__sv*max(snmass(ikl,ikv)*cos(slorsv(ikl,ikv)),un_1) &
     &                     /max(viscsn                      ,eps6)))
          rosnew         = ro__sv(ikl,ikv,isn) *dzsnsv(ikl,ikv,isn)    &
     &                            /max(eps6,dzsnew)
          rosmax         = 1.d0   /( (1.d0 -eta_sv(ikl,ikv,isn)) /rhoice   &
     &                               +      eta_sv(ikl,ikv,isn)  /rhowat)
          rosnew         =                        min(rosnew ,rosmax)
          dzsnsv(ikl,ikv,isn)= dzsnsv(ikl,ikv,isn) *ro__sv(ikl,ikv,isn)&
     &                            /max(eps6,rosnew)
          ro__sv(ikl,ikv,isn)= rosnew
          ro_dry(ikl,ikv,isn)= ro__sv(ikl,ikv,isn)*(1.-eta_sv(ikl,ikv,isn))*1.e-3
!         ro_dry: Dry Density (g/cm3)
 
          snmass(ikl,ikv)    = snmass(ikl,ikv)+dsnmas*0.5
        END DO
        END DO
      END DO
 
 
! OUTPUT/Verification: Snow   Properties
! #vs DO ikl = 1,kcolp
! #vs DO ikv=1,mwp
! #vs DO isn = 1,isnoSV(ikl,ikv)
! #vs   IF (G1snSV(ikl,ikv,isn).gt.0. .AND. G2snSV(ikl,ikv,isn).gt.D__MAX) THEN
! #vs     write(6,6600) G1snSV(ikl,ikv,isn),G2snSV(ikl,ikv,isn),ikl,ikv,isn
! #vs6600 format(/,'WARNING in _GSn: G1,G2 =',2f9.3,'  (ikl,ikv,isn) =',2i4)
! #vs     D__MAX =                      G2snSV(ikl,ikv,isn)
! #vs   END IF
! #vs   IF (                            G2snSV(ikl,ikv,isn).lt.0.    ) THEN
! #vs     write(6,6601) G1snSV(ikl,ikv,isn),G2snSV(ikl,ikv,isn),ikl,ikv,isn
! #vs6601 format(/,'ERROR 1 in _GSn: G1,G2 =',2f9.3,'  (ikl,ikv,isn) =',2i4)
! #vs     STOP
! #vs   END IF
! #vs   IF (G1snSV(ikl,ikv,isn).gt.G1_dSV+eps6                       ) THEN
! #vs     write(6,6602) G1snSV(ikl,ikv,isn),G2snSV(ikl,ikv,isn),ikl,ikv,isn
! #vs6602 format(/,'ERROR 2 in _GSn: G1,G2 =',2f9.3,'  (ikl,ikv,isn) =',2i4)
! #vs     STOP
! #vs   END IF
! #vs   IF (G1snSV(ikl,ikv,isn).lt.0.                           .AND.  &
! #vs&      G2snSV(ikl,ikv,isn).gt.G1_dSV+eps6                       ) THEN
! #vs     write(6,6603) G1snSV(ikl,ikv,isn),G2snSV(ikl,ikv,isn),ikl,ikv,isn
! #vs6603 format(/,'ERROR 3 in _GSn: G1,G2 =',2f9.3,'  (ikl,ikv,isn) =',2i4)
! #vs     STOP
! #vs   END IF
! #vs END DO
! #vs END DO
! #vs END DO
 
 
 
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!                                                                      !
! DE-ALLOCATION                                                        !
! =============                                                        !
 
      IF (flagdalloc)                                             THEN !
 
      deallocate          ( ro_dry )                                   ! Dry Density            [g/cm3]
      deallocate          ( etasno )                                   ! Liquid Water Content   [g/cm2]
      deallocate          ( snmass )                                   ! Snow   Mass            [kg/m2]
 
      END IF                                                           !
!                                                                      !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 
      return
      end subroutine sisvat_gsn
 
 
 
      subroutine sisvat_qso(                                           &
! #m0&                      Wats_0,Wats_1,Wats_d                       &
     &                     )
 
!--------------------------------------------------------------------------+
!   MAR          SISVAT_qSo                           Wed 26-Jun-2013  MAR |
!     SubRoutine SISVAT_qSo computes the Soil      Water  Balance          |
!                                                                          |
!     version 3.p.4.1 created by H. Gallee,           Tue  5-Feb-2013      |
!           Last Modification by H. Gallee,           Wed 26-Jun-2013      |
!                                                                          |
!--------------------------------------------------------------------------+
!                                                                          |
!     PARAMETERS:  kcolv: Total Number of columns =                        |
!     ^^^^^^^^^^        = Total Number of continental     grid boxes       |
!                       X       Number of Mosaic Cell per grid box         |
!                                                                          |
!     INPUT:   isnoSV   = total Nb of Ice/Snow Layers                      |
!     ^^^^^    isotSV   = 0,...,11:   Soil       Type                      |
!                         0:          Water, Solid or Liquid               |
!                                                                          |
!     INPUT:   rhT_SV   : SBL Top    Air  Density                  [kg/m3] |
!     ^^^^^    drr_SV   : Rain   Intensity                       [kg/m2/s] |
!              LSdzsv   : Vertical   Discretization Factor             [-] |
!                       =    1. Soil                                       |
!                       = 1000. Ocean                                      |
!              dt__SV   : Time   Step                                  [s] |
!                                                                          |
!              Lx_H2O   : Latent Heat of Vaporization/Sublimation   [J/kg] |
!              HLs_sv   : Latent Heat  Flux                         [W/m2] |
!              Rootsv   : Root   Water Pump                      [kg/m2/s] |
!                                                                          |
!     INPUT /  eta_SV   : Water      Content                       [m3/m3] |
!     OUTPUT:  Khydsv   : Soil   Hydraulic    Conductivity           [m/s] |
!     ^^^^^^                                                               |
!                                                                          |
!     OUTPUT:  RnofSV   : RunOFF Intensity                       [kg/m2/s] |
!     ^^^^^^   Wats_0   : Soil Water,  before Forcing                 [mm] |
!              Wats_1   : Soil Water,  after  Forcing                 [mm] |
!              Wats_d   : Soil Water          Forcing                 [mm] |
!                                                                          |
!     Internal Variables:                                                  |
!     ^^^^^^^^^^^^^^^^^^                                                   |
!              z_Bump   : (Partly)Bumpy Layers Height                  [m] |
!              z0Bump   :         Bumpy Layers Height                  [m] |
!              dzBump   :  Lowest Bumpy Layer:                         [m] |
!              etBump   :         Bumps Layer Averaged Humidity    [m3/m3] |
!              etaMid   : Layer Interface's Humidity               [m3/m3] |
!              eta__f   : Layer             Humidity  (Water Front)[m3/m3] |
!              Dhyd_f   : Soil  Hydraulic Diffusivity (Water Front) [m2/s] |
!              Dhydif   : Soil  Hydraulic Diffusivity               [m2/s] |
!              WgFlow   : Water         gravitational     Flux   [kg/m2/s] |
!              Wg_MAX   : Water MAXIMUM gravitational     Flux   [kg/m2/s] |
!              SatRat   : Water         Saturation        Flux   [kg/m2/s] |
!              WExces   : Water         Saturation Excess Flux   [kg/m2/s] |
!              Dhydtz   : Dhydif * dt / dz                             [m] |
!              FreeDr   : Free Drainage Fraction                       [-] |
!              Elem_A   : A Diagonal Coefficient                           |
!              Elem_C   : C Diagonal Coefficient                           |
!              Diag_A   : A Diagonal                                       |
!              Diag_B   : B Diagonal                                       |
!              Diag_C   : C Diagonal                                       |
!              Term_D   :   Independant Term                               |
!              Aux__P   : P Auxiliary Variable                             |
!              Aux__Q   : Q Auxiliary Variable                             |
!                                                                          |
!     TUNING PARAMETER:                                                    |
!     ^^^^^^^^^^^^^^^^                                                     |
!              z0soil   : Soil Surface averaged Bumps Height           [m] |
!                                                                          |
!     METHOD: NO   Skin Surface Humidity                                   |
!     ^^^^^^  Semi-Implicit Crank Nicholson Scheme                         |
!             (Partial) free Drainage, Water Bodies excepted (Lakes, Sea)  |
!                                                                          |
!                                                                          |
!     Preprocessing  Option:                                               |
!     ^^^^^^^^^^^^^^^^^^^^^                                                |
!     #GF: Saturation Front                                                |
!     #GH: Saturation Front allows Horton Runoff                           |
!     #GA: Soil Humidity Geometric Average                                 |
!     #TB: Parameterization of Terrain Bumps                               |
!                                                                          |
!                                                                          |
!     Preprocessing  Option: SISVAT IO (not always a standard preprocess.) |
!     ^^^^^^^^^^^^^^^^^^^^^  ^^^^^^^^^                                     |
!     FILE                 |      CONTENT                                  |
!     ~~~~~~~~~~~~~~~~~~~~~+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
!   # SISVAT_iii_jjj_n     | #m0: OUTPUT/Verification: H2O    Conservation |
!   # SISVAT_iii_jjj_n     | #m1: OUTPUT/Verification: * Mass Conservation |
!   # stdout               | #mw: OUTPUT/Verification: H2O    Conservation |
!                          |      unit  6, SubRoutine  SISVAT_qSo **ONLY** |
!   # SISVAT_qSo.vw        | #vw: OUTPUT/Verif+Detail: H2O    Conservation |
!                          |      unit 42, SubRoutine  SISVAT_qSo **ONLY** |
!   # stdout               | #vg: OUTPUT/Verification: Gravitational Front |
!                          |      unit  6, SubRoutine  SISVAT_qSo **ONLY** |
!                                                                          |
!     REMARQUE: Inclure possibilite de creer mare sur bedrock impermeable  |
!     ^^^^^^^^                                                             |
!--------------------------------------------------------------------------+
 
 
! Global  Variables
! =================
 
      use mod_real
      use mod_phy____dat
      use mod_phy____grd
      use mod_sisvat_grd
 
 
 
! General Variables
! =================
 
      use mod_sisvat_ctr
      use mod_sisvat_dat
      use mod_sisvat_dzs
      use mod_sisvat_kkl
      use mod_sisvat_loc
 
 
 
! Internal Variables
! ==================
 
      use mod_sisvatlqso
 
 
      IMPLICIT NONE
 
 
      integer                                        ::  isl           !
      integer                                        ::  ist   ,ikl,ikv!
      integer                                        ::  ikm   ,ikp    !
      integer                                        ::  ik0           !
      integer                                        ::  ist__s,ist__w ! Soil/Water Body Identifier
 
 
! #TB real(kind=real8)                               ::  z0soil = 0.02 ! Soil Surface Bumps Height  [m]
! #TB real(kind=real8)                               ::  z_Bump        !(Partly)Bumpy Layers Height [m]
! #TB real(kind=real8)                               ::  z0Bump        !        Bumpy Layers Height [m]
! #TB real(kind=real8)                               ::  dzBump        ! Lowest Bumpy Layer:
 
      real(kind=real8)                               ::  etaMid        ! Layer Interface's Humidity
      real(kind=real8)                               ::  Dhydif        ! Hydraulic Diffusivity   [m2/s]
! #GH real(kind=real8)                               ::  eta__f        ! Water Front Soil Water Content
      real(kind=real8)                               ::  Khyd_f        ! Water Front Hydraulic Conduct.
      real(kind=real8)                               ::  Khydav        ! Hydraulic Conductivity   [m/s]
! #GF real(kind=real8)                               ::  WgFlow        ! Water gravitat. Flux [kg/m2/s]
      real(kind=real8)                               ::  Wg_MAX        ! Water MAX.grav. Flux [kg/m2/s]
      real(kind=real8)                               ::  SatRat        ! Saturation      Flux [kg/m2/s]
! #GF real(kind=real8)                               ::  WExces        ! Saturat. Excess Flux [kg/m2/s]
      real(kind=real8)                               ::  Elem_A        !   Diagonal Coefficients
      real(kind=real8)                               ::  Elem_B        !   Diagonal Coefficients
      real(kind=real8)                               ::  Elem_C        !   Diagonal Coefficients
      real(kind=real8)                               ::  FreeDr        ! Free Drainage Fraction (actual)
!     real(kind=real8)                               ::  FreeD0 = 1.00 ! Free Drainage Fraction (1=Full)
 
! OUTPUT
! ------
 
! OUTPUT/Verification: H2O    Conservation
! #mw real(kind=real8)                               ::  hourwr
 
 
 
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!                                                                      !
! ALLOCATION                                                           !
! ==========                                                           !
 
      IF (it_run.EQ.1 .OR. flagdalloc)                            THEN !
 
! OUTPUT/Verification: H2O    Conservation
! #m0 allocate            ( Wats_0(kcolp,mwp) )                        ! Soil Water,  before forcing
! #m0 allocate            ( Wats_1(kcolp,mwp) )                        ! Soil Water,  after  forcing
! #m0 allocate            ( Wats_d(kcolp,mwp) )                        ! Soil Water          forcing
 
! #TB allocate            ( etBump(kcolp,mwp) )                        ! Bumps Layer Averaged Humidity
 
      allocate            ( sornof(kcolp,mwp) )                        ! Soil     Run    OFF
      allocate            ( dhydtz(kcolp,mwp,-nsoil:0) )               ! Dhydif * dt / dz           [m]
      allocate            ( diag_a(kcolp,mwp,-nsoil:0) )               ! A Diagonal
      allocate            ( diag_b(kcolp,mwp,-nsoil:0) )               ! B Diagonal
      allocate            ( diag_c(kcolp,mwp,-nsoil:0) )               ! C Diagonal
      allocate            ( term_d(kcolp,mwp,-nsoil:0) )               !   Independant Term
      allocate            ( aux__p(kcolp,mwp,-nsoil:0) )               ! P Auxiliary Variable
      allocate            ( aux__q(kcolp,mwp,-nsoil:0) )               ! Q Auxiliary Variable
      allocate            ( etaaux(kcolp,mwp,-nsoil:-nsoil+1) )        ! Soil Water Content     [m3/m3]
 
      END IF                                                           !
!                                                                      !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 
 
! OUTPUT/Verification: H2O    Conservation: Water  Budget (IN)
! #m0   DO ikl=1,kcolp
! #m0   DO ikv=1,mwp
! #m0     Wats_0(ikl,ikv) = 0.                ! OLD RunOFF Contrib.
! #m0     Wats_d(ikl,ikv) = drr_SV(ikl,ikv)   ! Water Surface Forc.
! #m0   END DO
! #m0   END DO
 
! #m0      isl= -nsoil
! #m0   DO ikl=1,kcolp
! #m0   DO ikv=1,mwp
! #m0     Wats_0(ikl,ikv) = Wats_0(ikl,ikv)                            &
! #m0&      + rhoWat *( eta_SV(ikl,ikv,isl)   *dz78SV(isl)             &
! #m0&                + eta_SV(ikl,ikv,isl+1) *dz_8SV(isl) ) * LSdzsv(ikl,ikv)
! #m0   END DO
! #m0   END DO
 
! #m0 DO   isl= -nsoil+1,-1
! #m0   DO ikl=1,kcolp
! #m0   DO ikv=1,mwp
! #m0     Wats_0(ikl,ikv) = Wats_0(ikl,ikv)                            &
! #m0&      + rhoWat *( eta_SV(ikl,ikv,isl)   *dz34SV(isl)             &
! #m0&                +(eta_SV(ikl,ikv,isl-1)                          &
! #m0&                 +eta_SV(ikl,ikv,isl+1))*dz_8SV(isl) ) * LSdzsv(ikl,ikv)
! #m0   END DO
! #m0   END DO
! #m0 END DO
 
! #m0      isl=  0
! #m0   DO ikl=1,kcolp
! #m0   DO ikv=1,mwp
! #m0     Wats_0(ikl,ikv) = Wats_0(ikl,ikv)                            &
! #m0&      + rhoWat *( eta_SV(ikl,ikv,isl)   *dz78SV(isl)             &
! #m0&                + eta_SV(ikl,ikv,isl-1) *dz_8SV(isl) ) * LSdzsv(ikl,ikv)
! #m0   END DO
! #m0   END DO
 
 
! Gravitational Flow
! ==================
 
! .    METHOD: Surface Water Flux saturates successively the soil layers
!      ^^^^^^  from up to below, but is limited by infiltration capacity.
!              Hydraulic Conductivity again contributes after this step,
!              not redundantly because of a constant (saturated) profile.
 
! Flux  Limitor
! ^^^^^^^^^^^^^
           isl=0
        DO ikl=1,kcolp
        DO ikv=1,mwp
          ist    = isotsv(ikl,ikv)                 ! Soil Type
          ist__s = min(ist, 1)                     ! 1 => Soil
          ist__w = 1 - ist__s                      ! 1 => Water Body
          dhydif = s1__sv(ist)                    &!
     &               *max(eps6,eta_sv(ikl,ikv,isl))   &! Hydraulic Diffusivity
     &                      **(bchdsv(ist)+2.)     ! DR97, Eqn.(3.36)
          dhydif = ist__s    * dhydif             &!
     &           + ist__w    * vk_dsv              ! Water Bodies
 
          khydav = ist__s    * ks_dsv(ist)        &! DR97  Assumption
     &           + ist__w    * vk_dsv              ! Water Bodies
 
          wg_max = rhowat     *dhydif             &! MAXimum  Infiltration
     &           *(etadsv(ist)-eta_sv(ikl,ikv,isl))   &!          Rate
     &           /(dzavsv(isl)*lsdzsv(ikl,ikv)    )   &!
     &          +  rhowat     *khydav              !
 
! Surface Horton RunOFF
! ^^^^^^^^^^^^^^^^^^^^^
          sornof(ikl,ikv) =                       &!
     &                max(zer0,drr_sv(ikl,ikv)-wg_max) !
          drr_sv(ikl,ikv) =        drr_sv(ikl,ikv)-sornof(ikl,ikv)
        END DO
        END DO
 
! #GF DO   isl=0,-nsoil,-1
! #GF   DO ikl=1,kcolp
! #GF   DO ikv=1,mwp
! #GF     ist    = isotSV(ikl,ikv)                 ! Soil Type
! #GF     ist__s = min(ist, 1)                     ! 1 => Soil
! #GF     ist__w = 1 - ist__s                      ! 1 => Water Body
 
! Water Diffusion
! ^^^^^^^^^^^^^^^
! #GF     Dhydif = s1__SV(ist)                    &!
! #GF&               *max(eps6,eta_SV(ikl,ikv,isl))   &! Hydraulic Diffusivity
! #GF&                      **(bCHdSV(ist)+2.)     ! DR97, Eqn.(3.36)
! #GF     Dhydif = ist__s    * Dhydif             &!
! #GF&           + ist__w    * vK_dSV              ! Water Bodies
 
! Water Conduction (without Horton Runoff)
! ^^^^^^^^^^^^^^^^
! #GF     Khyd_f =             Ks_dSV(ist)
!         Uses saturated K ==> Horton Runoff ~0    !
 
! Water Conduction (with    Horton Runoff)
! ^^^^^^^^^^^^^^^^
! #GH     ik0    = nkhy   *int(eta_SV(ikl,ikv,isl)&!
! #GH&                        /etadSV(ist))        !
! #GH     eta__f         =            1.          &!
! #GH&   -aKdtSV(ist,ik0)/(2. *dzAvSV(isl)        &!
! #GH&                        *LSdzsv(ikl,ikv))    !
! #GH     eta__f         = max(eps_21,eta__f)
! #GH     eta__f         = min(etadSV(ist),       &!
! #GH&                         eta_SV(ikl,ikv,isl) +  &!
! #GH&   (aKdtSV(ist,ik0)     *eta_SV(ikl,ikv,isl)&!
! #GH&   +bKdtSV(ist,ik0))   /(dzAvSV(isl)        &!
! #GH&                        *LSdzsv(ikl,ikv))   &!
! #GH&                       / eta__f          )
 
! #GH     eta__f         = .5*(eta_SV(ikl,ikv,isl)&!
! #GH&                        +eta__f)             !
!         eta__f         =     eta_SV(ikl,isl)     ! Another Possibility
 
! #GH     ik0    = nkhy       *eta__f             &!
! #GH&                        /etadSV(ist)         !
! #GH     Khyd_f =                                &!
! #GH&   (aKdtSV(ist,ik0)     *eta__f             &!
! #GH&   +bKdtSV(ist,ik0))    /dt__SV              !
 
! #GF     Khydav = ist__s    * Khyd_f             &! DR97  Assumption
! #GF&           + ist__w    * vK_dSV              ! Water Bodies
 
! Gravitational Flow
! ^^^^^^^^^^^^^^^^^^
! #GF     Wg_MAX =                                &! MAXimum  Infiltration
! #GF&             rhoWat     *Dhydif             &!          Rate
! #GF&           *(etadSV(ist)-eta_SV(ikl,ikv,isl))   &!
! #GF&           /(dzAvSV(isl)*LSdzsv(ikl,ikv)    )   &!
! #GF&          +  rhoWat     *Khydav              !
 
! OUTPUT/Verification: Gravitational Front
! #vg     write(6,6001) isl,drr_SV(ikl,ikv)*3.6e3,Wg_MAX     *3.6e3
! #vg6001 format(i3,'  vRain ,Wg_MAX ',2e12.3,' mm/hr')
 
! #GF     WgFlow =  min(Wg_MAX,drr_SV(ikl,ikv))    ! Infiltration Rate
! #GF     WExces =  max(zer0  ,drr_SV(ikl,ikv)-WgFlow) ! Water Excess => RunOff
 
! OUTPUT/Verification: Gravitational Front
! #vg     write(6,6002)     WgFlow     *3.6e3,WExces     *3.6e3
! #vg6002 format(3x,'  WgFlow,WExces ',2e12.3,' mm/hr')
 
! #GF     SoRnOF(ikl,ikv) =        SoRnOF(ikl,ikv)+WExces  !
! #GF     drr_SV(ikl,ikv) =        WgFlow          !
 
! OUTPUT/Verification: Gravitational Front
! #vg     write(6,6003)     SoRnOF(ikl,ikv)*3.6e3,drr_SV(ikl,ikv)*3.6e3
! #vg6003 format(3x,'  SoRnOF,drr_SV ',2e12.3,' mm/hr')
 
! #GF     SatRat =(etadSV(ist)-eta_SV(ikl,ikv,isl))   &! Saturation   Rate
! #GF&            *rhoWat     *dzAvSV(isl)        &!
! #GF&                        *LSdzsv(ikl,ikv)/dt__SV  !
! #GF     SatRat =  min(SatRat,drr_SV(ikl,ikv))    !
! #GF     drr_SV(ikl,ikv) =        drr_SV(ikl,ikv)-SatRat  ! Water Flux for Below
 
! OUTPUT/Verification: Gravitational Front
! #vg     write(6,6004)     SatRat     *3.6e3,drr_SV(ikl,ikv)*3.6e3
! #vg6004 format(3x,'  SatRat,drr_SV ',2e12.3,' mm/hr')
! #vg     write(6,6005)     eta_SV(ikl,ikv,isl)*1.e3
 
! #GF     eta_SV(ikl,ikv,isl) =    eta_SV(ikl,ikv,isl)&! Saturation
! #GF&                        +SatRat*dt__SV      &!
! #GF&                       /(rhoWat*dzAvSV(isl) &!
! #GF&                               *LSdzsv(ikl,ikv)) !
 
! OUTPUT/Verification: Gravitational Front
! #vg     write(6,6005)     eta_SV(ikl,ikv,isl)*1.e3
! #vg6005 format(3x,'  eta_SV,       ',e12.3,' g/kg')
! #GF   END DO
! #GF   END DO
! #GF END DO
! #GF   DO ikl=1,kcolp
! #GF   DO ikv=1,mwp
! #GF     SoRnOF(ikl,ikv)     =    SoRnOF(ikl,ikv)&! RunOFF Intensity
! #GF&                    +    drr_SV(ikl,ikv)     ! [kg/m2/s]
!         Inclure la possibilite de creer une mare sur un bedrock impermeable
! #GF     drr_SV(ikl,ikv) = 0.
! #GF   END DO
! #GF   END DO
 
 
! Temperature Correction due to a changed Soil Energy Content
! ===========================================================
 
! REMARQUE: Mettre en oeuvre le couplage humidite-energie
! ^^^^^^^^
 
 
! Full Resolution of the Richard's Equation
! =========================================
 
!         METHOD: Water content evolution results from water fluxes
!         ^^^^^^  at the layer boundaries
!                 Conductivity is approximated by a piecewise linear profile.
!                 Semi-Implicit Crank-Nicholson scheme is used.
!                (Bruen, 1997, Sensitivity of hydrological processes
!                              at the land-atmosphere interface.
!                              Proc. Royal Irish Academy,  IGBP symposium
!                              on global change and the Irish Environment.
!                              Publ.: Maynooth)
 
!                        - - - - - - - -   isl+1/2   - -  ^
!                                                         |
!     eta_SV(isl)        ---------------   isl     -----  +--dz_dSV(isl)  ^
!                                                         |               |
!     Dhydtz(isl) etaMid - - - - - - - -   isl-1/2   - -  v  dzmiSV(isl)--+
!                                                                         |
!     eta_SV(isl-1)      ---------------   isl-1   -----                  v
 
! Transfert       Coefficients
! ----------------------------
 
      DO   isl=-nsoil+1,0
        DO ikl=1,kcolp
        DO ikv=1,mwp
          ist    =      isotsv(ikl,ikv)                   ! Soil Type
          ist__s =      min(ist, 1)                       ! 1 => Soil
          ist__w =      1 - ist__s                        ! 1 => Water Body
          etamid =     (dz_dsv(isl)  *eta_sv(ikl,ikv,isl-1)  &! eta at layers
     &                 +dz_dsv(isl-1)*eta_sv(ikl,ikv,isl)  ) &!     interface
     &           /(2.0* dzmisv(isl))                      ! LSdzsv implicit !
! #GA     etaMid = sqrt(dz_dSV(isl)  *eta_SV(ikl,ikv,isl-1)  &! Idem, geometric
! #GA&                 *dz_dSV(isl-1)*eta_SV(ikl,ikv,isl)  ) &!       average
! #GA&           /(2.0* dzmiSV(isl))                      ! (Vauclin&al.1979)
          dhydif          =    s1__sv(ist)               &! Hydraul.Diffusi.
     &  *(etamid         **(   bchdsv(ist)+2.))           ! DR97, Eqn.(3.36)
          dhydtz(ikl,ikv,isl) =    dhydif*dt__sv         &!
     &                              /(dzmisv(isl)        &!
     &                               *lsdzsv(ikl,ikv))    !
          dhydtz(ikl,ikv,isl) =    dhydtz(ikl,ikv,isl) * ist__s  &! Soil
     &        +0.5*dzmisv(isl)*lsdzsv(ikl,ikv)     * ist__w   ! Water bodies
 
        END DO
        END DO
      END DO
           isl=-nsoil
        DO ikl=1,kcolp
        DO ikv=1,mwp
          dhydtz(ikl,ikv,isl) =    0.0                    !
        END DO
        END DO
 
 
! Tridiagonal Elimination: Set Up
! -------------------------------
 
! Soil/Snow Interior
! ^^^^^^^^^^^^^^^^^^
      DO   isl=-nsoil,-nsoil+1
        DO ikl=1,kcolp
        DO ikv=1,mwp
          etaaux(ikl,ikv,isl) =  eta_sv(ikl,ikv,isl)
        END DO
        END DO
      END DO
 
      DO   isl=-nsoil+1,-1
        DO ikl=1,kcolp
        DO ikv=1,mwp
          ist      =         isotsv(ikl,ikv)
          ikm      =nkhy*int(eta_sv(ikl,ikv,isl-1) / etadsv(ist))
          ik0      =nkhy*int(eta_sv(ikl,ikv,isl)   / etadsv(ist))
          ikp      =nkhy*int(eta_sv(ikl,ikv,isl+1) / etadsv(ist))
          elem_a   =         dhydtz(ikl,ikv,isl)                       &
     &                    -  akdtsv(ist,ikm)* dziisv(isl)  *lsdzsv(ikl,ikv)
          elem_b   =      - (dhydtz(ikl,ikv,isl)                       &
     &                      +dhydtz(ikl,ikv,isl+1)                     &
     &                      -akdtsv(ist,ik0)*(dziisv(isl+1)            &
     &                                       -dzi_sv(isl) )*lsdzsv(ikl,ikv))
          elem_c   =         dhydtz(ikl,ikv,isl+1)                     &
     &                    +  akdtsv(ist,ikp)* dzi_sv(isl+1)*lsdzsv(ikl,ikv)
          diag_a(ikl,ikv,isl) =  dz_8sv(isl)        *lsdzsv(ikl,ikv)   &
     &                      -implic            * elem_a
          diag_b(ikl,ikv,isl) =  dz34sv(isl)        *lsdzsv(ikl,ikv)   &
     &                      -implic            * elem_b
          diag_c(ikl,ikv,isl) =  dz_8sv(isl)        *lsdzsv(ikl,ikv)   &
     &                      -implic            * elem_c
 
          term_d(ikl,ikv,isl) = (dz_8sv(isl) *lsdzsv(ikl,ikv)          &
     &                      +explic      *elem_a     )*eta_sv(ikl,ikv,isl-1)&
     &                    + (dz34sv(isl) *lsdzsv(ikl,ikv)              &
     &                      +explic      *elem_b     )*eta_sv(ikl,ikv,isl) &
     &                    + (dz_8sv(isl) *lsdzsv(ikl,ikv)              &
     &                      +explic      *elem_c     )*eta_sv(ikl,ikv,isl+1)&
     &                    + (bkdtsv(ist,ikp)* dzi_sv(isl+1)            &
     &                      +bkdtsv(ist,ik0)*(dziisv(isl+1)            &
     &                                       -dzi_sv(isl)  )           &
     &                      -bkdtsv(ist,ikm)* dziisv(isl)   )          &
     &                                      * lsdzsv(ikl,ikv)          &
     &                    -  dt__sv         * rootsv(ikl,ikv,isl)/rhowat
        END DO
        END DO
      END DO
 
           isl=-nsoil
        DO ikl=1,kcolp
        DO ikv=1,mwp
          ist      =         isotsv(ikl,ikv)
          freedr   =         iwafsv(ikl,ikv)       *  min(ist,1)
!         FreeDr   =         FreeD0            *  min(ist,1) ! Free Drainage
          ik0      =nkhy*int(eta_sv(ikl,ikv,isl  ) / etadsv(ist))
          ikp      =nkhy*int(eta_sv(ikl,ikv,isl+1) / etadsv(ist))
          elem_a   =         0.
          elem_b   =      - (dhydtz(ikl,ikv,isl+1)                     &
     &                      -akdtsv(ist,ik0)*(dziisv(isl+1)*lsdzsv(ikl,ikv)&
     &                                       -freedr                  ))
          elem_c   =         dhydtz(ikl,ikv,isl+1)                     &
     &                    +  akdtsv(ist,ikp)* dzi_sv(isl+1)*lsdzsv(ikl,ikv)
          diag_a(ikl,ikv,isl) =  0.
          diag_b(ikl,ikv,isl) =  dz78sv(isl) *lsdzsv(ikl,ikv)          &
     &                      -implic      *elem_b
          diag_c(ikl,ikv,isl) =  dz_8sv(isl) *lsdzsv(ikl,ikv)          &
     &                      -implic      *elem_c
 
          term_d(ikl,ikv,isl) = (dz78sv(isl) *lsdzsv(ikl,ikv)          &
     &                      +explic      *elem_b     )*eta_sv(ikl,ikv,isl) &
     &                    + (dz_8sv(isl) *lsdzsv(ikl,ikv)              &
     &                      +explic      *elem_c     )*eta_sv(ikl,ikv,isl+1)&
     &                    + (bkdtsv(ist,ikp)* dzi_sv(isl+1)*lsdzsv(ikl,ikv)&
     &                      +bkdtsv(ist,ik0)*(dziisv(isl+1)*lsdzsv(ikl,ikv)&
     &                                       -freedr                  ))&
     &                    -  dt__sv         * rootsv(ikl,ikv,isl)/rhowat
        END DO
        END DO
 
           isl=0
        DO ikl=1,kcolp
        DO ikv=1,mwp
          ist      =         isotsv(ikl,ikv)
          ikm      =nkhy*int(eta_sv(ikl,ikv,isl-1) / etadsv(ist))
          ik0      =nkhy*int(eta_sv(ikl,ikv,isl)   / etadsv(ist))
          elem_a   =         dhydtz(ikl,ikv,isl)                       &
     &                    -  akdtsv(ist,ikm)* dziisv(isl)*lsdzsv(ikl,ikv)
          elem_b   =      - (dhydtz(ikl,ikv,isl)                       &
     &                      +akdtsv(ist,ik0)* dzi_sv(isl)*lsdzsv(ikl,ikv))
          elem_c   =         0.
          diag_a(ikl,ikv,isl) =  dz_8sv(isl) *lsdzsv(ikl,ikv)          &
     &                    -  implic      *elem_a
          diag_b(ikl,ikv,isl) =  dz78sv(isl) *lsdzsv(ikl,ikv)          &
     &                    -  implic      *elem_b
          diag_c(ikl,ikv,isl) =  0.
 
          term_d(ikl,ikv,isl) = (dz_8sv(isl) *lsdzsv(ikl,ikv)          &
     &                      +explic      *elem_a     )*eta_sv(ikl,ikv,isl-1)&
     &                    + (dz78sv(isl) *lsdzsv(ikl,ikv)              &
     &                      +explic      *elem_b     )*eta_sv(ikl,ikv,isl) &
     &                    - (bkdtsv(ist,ik0)* dzi_sv(isl)              &
     &                      +bkdtsv(ist,ikm)* dziisv(isl))*lsdzsv(ikl,ikv) &
     &            + dt__sv *(hls_sv(ikl,ikv)    *     (1-min(1,isnosv(ikl,ikv)))&
     &                                                   / lx_h2o(ikl,ikv) &
     &                      +drr_sv(ikl,ikv)                           &
     &                      -rootsv(ikl,ikv,isl)             )/rhowat
        END DO
        END DO
 
 
! Tridiagonal Elimination
! =======================
 
! Forward  Sweep
! ^^^^^^^^^^^^^^
        DO ikl=  1,kcolp
        DO ikv=1,mwp
          aux__p(ikl,ikv,-nsoil) = diag_b(ikl,ikv,-nsoil)
          aux__q(ikl,ikv,-nsoil) =-diag_c(ikl,ikv,-nsoil)/aux__p(ikl,ikv,-nsoil)
        END DO
        END DO
 
      DO   isl=-nsoil+1,0
        DO ikl=      1,kcolp
        DO ikv=1,mwp
          aux__p(ikl,ikv,isl)   = diag_a(ikl,ikv,isl)  *aux__q(ikl,ikv,isl-1)  &
     &                       +diag_b(ikl,ikv,isl)
          aux__q(ikl,ikv,isl)   =-diag_c(ikl,ikv,isl)  /aux__p(ikl,ikv,isl)
        END DO
        END DO
      END DO
 
        DO ikl=      1,kcolp
        DO ikv=1,mwp
          eta_sv(ikl,ikv,-nsoil) = term_d(ikl,ikv,-nsoil)/aux__p(ikl,ikv,-nsoil)
        END DO
        END DO
 
      DO   isl=-nsoil+1,0
        DO ikl=      1,kcolp
        DO ikv=1,mwp
          eta_sv(ikl,ikv,isl)   =(term_d(ikl,ikv,isl)                  &
     &                       -diag_a(ikl,ikv,isl)  *eta_sv(ikl,ikv,isl-1)) &
     &                                         /aux__p(ikl,ikv,isl)
        END DO
        END DO
      END DO
 
! Backward Sweep
! ^^^^^^^^^^^^^^
      DO   isl=-1,-nsoil,-1
        DO ikl= 1,kcolp
        DO ikv=1,mwp
          eta_sv(ikl,ikv,isl)   = aux__q(ikl,ikv,isl)  *eta_sv(ikl,ikv,isl+1)  &
     &                                         +eta_sv(ikl,ikv,isl)
        END DO
        END DO
      END DO
 
 
! Horton RunOFF Intensity
! =======================
 
      DO   isl=0,-nsoil,-1
        DO ikl=1,kcolp
        DO ikv=1,mwp
          ist    =   isotsv(ikl,ikv)               ! Soil Type
          satrat =  (eta_sv(ikl,ikv,isl)-etadsv(ist)) &! OverSaturation Rate
     &              *rhowat         *dzavsv(isl)  &!
     &                              *lsdzsv(ikl,ikv)  &!
     &                              /dt__sv        !
          sornof(ikl,ikv)     =          sornof(ikl,ikv)  &!
     &                    + max(zer0,satrat)       !
          eta_sv(ikl,ikv,isl) = max(eps6          &!
     &                         ,eta_sv(ikl,ikv,isl))   !
          eta_sv(ikl,ikv,isl) = min(eta_sv(ikl,ikv,isl)   &!
     &                         ,etadsv(ist)    )   !
        END DO
        END DO
      END DO
 
! OUTPUT/Verification: Soil Vertic.Discret.
! #kw     write(6,6010)
! #kw6010 format(/,1x)
      DO   isl= 0,-nsoil,-1
        DO ikl= 1,kcolp
        DO ikv=1,mwp
          ist      =          isotsv(ikl,ikv)
          ikp      = nkhy*int(eta_sv(ikl,ikv,isl)  /etadsv(ist))
          khydsv(ikl,ikv,isl)   =(akdtsv(ist,ikp)  *eta_sv(ikl,ikv,isl)&
     &                           +bkdtsv(ist,ikp)) *2.0/dt__sv
! OUTPUT/Verification: Soil Vertic.Discret.
! #kw     write(6,6011) ikl,ikv,isl,eta_SV(ikl,ikv,isl)*1.e3,          &
! #kw&                  ikp,    aKdtSV(ist,ikp),bKdtSV(ist,ikp),       &
! #kw&                          Khydsv(ikl,ikv,isl)
! #kw6011 format(2i3,f8.1,i3,3e12.3)
 
        END DO
        END DO
      END DO
 
 
! Additional RunOFF Intensity
! ===========================
 
        DO ikl=1,kcolp
        DO ikv=1,mwp
          ist      =          isotsv(ikl,ikv)
          ik0      = nkhy*int(etaaux(ikl,ikv,-nsoil  ) /etadsv(ist))
          freedr   =          iwafsv(ikl,ikv)       *  min(ist,1)
!         FreeDr   =          FreeD0            *  min(ist,1) ! Free Drainage
          sornof(ikl,ikv) =  sornof(ikl,ikv)                           &
     &                + (akdtsv(ist,ik0)*(etaaux(ikl,ikv,-nsoil)*explic &
     &                                   +eta_sv(ikl,ikv,-nsoil)*implic)&
     &                 + bkdtsv(ist,ik0)                           )   &
     &                 * freedr          *rhowat           /dt__sv
 
! Full Run OFF: Update
! ~~~~~~~~~~~~~~~~~~~~
          rnofsv(ikl,ikv) = rnofsv(ikl,ikv)     + sornof(ikl,ikv)
        END DO
        END DO
 
 
! Temperature Correction due to a changed Soil Energy Content
! ===========================================================
 
! REMARQUE: Mettre en oeuvre le couplage humidite-energie
! ^^^^^^^^
 
 
! Bumps/Asperites Treatment
! =========================
 
! Average over Bump Depth (z0soil)
! --------------------------------
 
! #TB       z_Bump      = 0.
! #TB     DO ikl=1,kcolp
! #TB     DO ikv=1,mwp
! #TB       etBump(ikl,ikv) = 0.
! #TB     END DO
! #TB     END DO
 
! #TB DO     isl=0,-nsoil,-1
! #TB       z0Bump      = z_Bump
! #TB       z_Bump      = z_Bump      +  dzAvSV(isl)
! #TB   IF (z_Bump.lt.z0soil)                                       THEN
! #TB     DO ikl=1,kcolp
! #TB     DO ikv=1,mwp
! #TB       etBump(ikl,ikv) = etBump(ikl,ikv) +  dzAvSV(isl)   *eta_SV(ikl,ikv,isl)
! #TB     END DO
! #TB     END DO
! #TB   END IF
! #TB   IF (z_Bump.gt.z0soil.AND.z0Bump.lt.z0soil)                  THEN
! #TB     DO ikl=1,kcolp
! #TB     DO ikv=1,mwp
! #TB       etBump(ikl,ikv) = etBump(ikl,ikv) + (z0soil-z0Bump)*eta_SV(ikl,ikv,isl)
! #TB       etBump(ikl,ikv) = etBump(ikl,ikv) /  z0soil
! #TB     END DO
! #TB     END DO
! #TB   END IF
! #TB END DO
 
 
! Correction
! ----------
 
! #TB       z_Bump      = 0.
! #TB DO     isl=0,-nsoil,-1
! #TB       z0Bump =  z_Bump
! #TB       z_Bump =  z_Bump +dzAvSV(isl)
! #TB   IF (z_Bump.lt.z0soil)                                       THEN
! #TB     DO ikl=1,kcolp
! #TB     DO ikv=1,mwp
! #TB       eta_SV(ikl,ikv,isl) = etBump(ikl,ikv)
! #TB     END DO
! #TB     END DO
! #TB   END IF
! #TB   IF (z_Bump.gt.z0soil.AND.z0Bump.lt.z0soil)                  THEN
! #TB       dzBump          =    z_Bump -  z0soil
! #TB     DO ikl=1,kcolp
! #TB     DO ikv=1,mwp
! #TB       eta_SV(ikl,ikv,isl) =(etBump(ikl,ikv)    *(dzAvSV(isl)-dzBump) &
! #TB&                      + eta_SV(ikl,ikv,isl)*             dzBump) &
! #TB&                      /                  dzAvSV(isl)
! #TB     END DO
! #TB     END DO
! #TB   END IF
! #TB END DO
 
 
! Positive Definite
! =================
 
! #TB DO   isl= 0,-nsoil,-1
! #TB   DO ikl= 1,kcolp
! #TB   DO ikv=1,mwp
! #TB     eta_SV(ikl,ikv,isl)   =          max(eps6,eta_SV(ikl,ikv,isl))
! #TB   END DO
! #TB   END DO
! #TB END DO
 
 
! OUTPUT/Verification: H2O    Conservation: Water  Budget (OUT)
! #m0   DO ikl=1,kcolp
! #m0   DO ikv=1,mwp
! #m0     Wats_d(ikl,ikv) = Wats_d(ikl,ikv)           &!
! #m0&                + drr_SV(ikl,ikv)     *0.00     &! Precipitation is
!                                        \______________ already included
! #m0&                + HLs_sv(ikl,ikv)               &!
! #m0&          *(1-min(isnoSV(ikl,ikv),1)) /Lx_H2O(ikl,ikv)  &! Evaporation
! #m0&                - SoRnOF(ikl,ikv)                ! Soil RunOFF Contrib.
! #m0     Wats_1(ikl,ikv) = 0.                         !
 
! OUTPUT/Verification: H2O    Conservation
! #mw     Evapor(ikl,ikv) = HLs_sv(ikl,ikv)     *dt__SV   &!
! #mw&          *(1-min(isnoSV(ikl,ikv),1)) /Lx_H2O(ikl,ikv)   !
 
! #m0   END DO
! #m0   END DO
 
! #m0 DO   isl= -nsoil,0
! #m0   DO ikl=1,kcolp
! #m0   DO ikv=1,mwp
! #m0     Wats_d(ikl,ikv) = Wats_d(ikl,ikv)           &!
! #m0&                - Rootsv(ikl,ikv,isl)            ! Root Extract.
! #m0   END DO
! #m0   END DO
! #m0 END DO
! #m0   DO ikl=1,kcolp
! #m0   DO ikv=1,mwp
! #m0     Wats_d(ikl,ikv) = Wats_d(ikl,ikv)     *dt__SV!
! #m0   END DO
! #m0   END DO
 
! #m0      isl= -nsoil
! #m0   DO ikl=1,kcolp
! #m0   DO ikv=1,mwp
! #m0     Wats_1(ikl,ikv) = Wats_1(ikl,ikv)                            &
! #m0&      + rhoWat *( eta_SV(ikl,ikv,isl)   *dz78SV(isl)             &
! #m0&                + eta_SV(ikl,ikv,isl+1) *dz_8SV(isl) ) *LSdzsv(ikl,ikv)
! #m0   END DO
! #m0   END DO
 
! #m0 DO   isl= -nsoil+1,-1
! #m0   DO ikl=1,kcolp
! #m0   DO ikv=1,mwp
! #m0     Wats_1(ikl,ikv) = Wats_1(ikl,ikv)                            &
! #m0&      + rhoWat *( eta_SV(ikl,ikv,isl)   *dz34SV(isl)             &
! #m0&                +(eta_SV(ikl,ikv,isl-1)                          &
! #m0&                 +eta_SV(ikl,ikv,isl+1))*dz_8SV(isl) ) *LSdzsv(ikl,ikv)
! #m0   END DO
! #m0   END DO
! #m0 END DO
 
! #m0      isl=  0
! #m0   DO ikl=1,kcolp
! #m0   DO ikv=1,mwp
! #m0     Wats_1(ikl,ikv) = Wats_1(ikl,ikv)                            &
! #m0&      + rhoWat *( eta_SV(ikl,ikv,isl)   *dz78SV(isl)             &
! #m0&                + eta_SV(ikl,ikv,isl-1) *dz_8SV(isl) ) *LSdzsv(ikl,ikv)
! #m0   END DO
! #m0   END DO
 
 
! OUTPUT/Verification: H2O    Conservation
! #mw IF (.NOT.mwopen)                                              THEN
! #mw          mwopen = .true.
! #mw          open(unit=42,status='unknown',file='SISVAT_qSo.vw')
! #mw          rewind 42
! #mw   write(42,42)
! #mw42 format('SubRoutine SISVAT_qSo: Local Water Budget',            &
! #mw&       /,'=========================================')
! #mw END IF
! #mw         timewr=timewr + dt__SV
! #mw         hourwr=3600.0
! #mw IF (mod(timewr,hourwr).lt.eps6)                                  &
! #mw&  write(42,420)timewr/hourwr
! #mw420 format(11('-'),'----------+--------------+-',                 &
! #mw&          3('-'),'----------+--------------+-',                  &
! #mw&                 '----------------+----------------+',           &
! #mw&       /,f8.2,3x,'Wats_0(1) |    Wats_d(1) | ',                  &
! #mw&              3x,'Wats_1(1) | W_0+W_d-W_1  | ',                  &
! #mw&                 '   Soil Run OFF |   Soil Evapor. |',           &
! #mw&       /,11('-'),'----------+--------------+-',                  &
! #mw&          3('-'),'----------+--------------+-',                  &
! #mw&                 '----------------+----------------+')
! #mw   write(42,421)   Wats_0(1),Wats_d(1)                            &
! #mw&                 ,Wats_1(1)                                      &
! #mw&                 ,Wats_0(1)+Wats_d(1)-Wats_1(1)                  &
! #mw&                 ,SoRnOF(1),Evapor(1)
! #mw421 format(8x,f12.6,' + ',f12.6,' - ',f12.6,' = ',f12.6,' | ',f12.6,&
! #mw&      '      ',f15.6)
 
 
 
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!                                                                      !
! DE-ALLOCATION                                                        !
! =============                                                        !
 
      IF (flagdalloc)                                             THEN !
 
! OUTPUT/Verification: H2O    Conservation
! #m0 deallocate          ( Wats_0 )                                   ! Soil Water,  before forcing
! #m0 deallocate          ( Wats_1 )                                   ! Soil Water,  after  forcing
! #m0 deallocate          ( Wats_d )                                   ! Soil Water          forcing
 
! #TB deallocate          ( etBump )                                   ! Bumps Layer Averaged Humidity
 
      deallocate          ( sornof )                                   ! Soil     Run    OFF
      deallocate          ( dhydtz )                                   ! Dhydif * dt / dz           [m]
      deallocate          ( diag_a )                                   ! A Diagonal
      deallocate          ( diag_b )                                   ! B Diagonal
      deallocate          ( diag_c )                                   ! C Diagonal
      deallocate          ( term_d )                                   !   Independant Term
      deallocate          ( aux__p )                                   ! P Auxiliary Variable
      deallocate          ( aux__q )                                   ! Q Auxiliary Variable
      deallocate          ( etaaux )                                   ! Soil Water Content     [m3/m3]
 
      END IF                                                           !
!                                                                      !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 
      return
      end subroutine sisvat_qso
 
 
 
      subroutine sisvat_weq( labWEq ,istart)
 
!--------------------------------------------------------------------------+
!   MAR          SISVAT_wEq                           Wed 26-Jun-2013  MAR |
!     SubRoutine SISVAT_wEq computes the Snow/Ice  Water  Equivalent       |
!                                                                          |
!     version 3.p.4.1 created by H. Gallee,           Tue  5-Feb-2013      |
!           Last Modification by H. Gallee,           Wed 26-Jun-2013      |
!                                                                          |
!                                                                          |
!     Preprocessing  Option: SISVAT IO (not always a standard preprocess.) |
!     ^^^^^^^^^^^^^^^^^^^^^  ^^^^^^^^^                                     |
!     FILE                 |      CONTENT                                  |
!     ~~~~~~~~~~~~~~~~~~~~~+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
!   # SISVAT_wEq.ve        | #ve: OUTPUT/Verification: Snow/Ice Water Eqv. |
!                          |      unit 45, SubRoutine  SISVAT_wEq **ONLY** |
!--------------------------------------------------------------------------+
 
 
! General Variables
! =================
 
      use mod_real
      use mod_sisvat_ctr
      use mod_sisvat_grd
      use mod_sisvat_kkl
      use mod_sisvat_weq
 
 
      IMPLICIT NONE
 
 
! Global Variables
! ================
 
      character(len=6)  ::  labWEq
      integer           ::  istart
 
 
! Local  Variables
! ================
 
      integer           ::  ikl,ikv   ,isn
      real(kind=real8)  ::  SnoWEQ,IceWEQ
 
 
! Switch Initialization
! =====================
 
      IF (.NOT.logweq)                                              THEN
               logweq = .true.
               open(unit=45,status='unknown',file='SISVAT_wEq.ve')
               rewind    45
      END IF
 
 
! Snow Water Equivalent
! =====================
 
           ikl   = 1
           ikv   = 1
      IF          (isnosv(ikl,ikv).gt.iicesv(ikl,ikv))              THEN
 
          snoweq = 0.
        DO isn   = iicesv(ikl,ikv)+1 ,isnosv(ikl,ikv)
          snoweq = snoweq           + ro__sv(ikl,ikv,isn) * dzsnsv(ikl,ikv,isn)
        END DO
 
      END IF
 
 
! Ice  Water Equivalent
! =====================
 
      IF          (iicesv(ikl,ikv).gt.0)                            THEN
 
          iceweq = 0.
        DO isn   = 1      , iicesv(ikl,ikv)
          iceweq = iceweq + ro__sv(ikl,ikv,isn) * dzsnsv(ikl,ikv,isn)
        END DO
 
      END IF
 
 
! OUTPUT
! ======
 
      IF (istart.eq.1)                                              THEN
        write(45,45)dahost,i___sv(lwrisv(1,1)),j___sv(lwrisv(1,1))     &
     &                    ,n___sv(lwrisv(1,1))
 45     format(a18,10('-'),'Pt.',3i4,60('-'))
      END IF
 
      write(45,450) labweq,iceweq,iicesv(ikl,ikv),snoweq               &
     &                    ,iceweq+snoweq,isnosv(ikl,ikv)               &
     &                                  ,drr_sv(ikl,ikv)*dt__sv        &
     &                                  ,dsn_sv(ikl,ikv)*dt__sv        &
     &                                  ,bufssv(ikl,ikv)
 450  format(a6,3x,'  I+S =',f11.4,'(',i2,') +',f11.4,' =',            &
     &                       f11.4,'(',i2,')',                         &
     &             '  drr =', f7.4,                                    &
     &             '  dsn =', f7.4,                                    &
     &             '  Buf =', f7.4)
 
 
      return
      end subroutine sisvat_weq